| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Oh yeah I'm enjoying QB64 |
|
Posted by: James D Jarvis - 05-13-2022, 05:15 PM - Forum: General Discussion
- Replies (2)
|
 |
I've been tinkering with QB64 like mad in recent weeks and I'm just happy it exists and has a community of users supporting it.
The ease at which it puts the modern machine on call for me is very appreciated.
I've programmed in c/c++ but never really had fun with it. Years back when I programmed much more I'd often prototype or bash out a routine in basic before making it work with C/C++ and assembler. Once upon a time I even had a major graphics board manufacturer trying to recruit me into an in-house demo squad writing graphical demos to show off their goods but I wimped out and went on to become a concept artist for an R&D firm where most of my programming skills were used to write filters and getting adobe products to import some obscure data format (contractors would try and trick my employers with proprietary formats to lock them in if we wanted to keep using the data but if I could confirm all the work they did was for hire I was into data in a couple days). I'm amazed at how rusty some of my skills have gotten but I'm also amazed at how powerful the machines have gotten and how easy to is to make use of that with QB64. A lot of the work of programming in QB4.5 and PowerBasic in the old days was getting around the system and hardware bottlenecks and some are still there but I can mostly just ignore them these days and that just increase the fun.
I sometimes worry the ease of access to very powerful features is teaching me to be lazy but that passes when I can knock off a little program without having to learn a framework or an API and how a particular implementation of the programming language does or doesn't deal with said features inside a RAD suite.
Looked at some old coding tricks and I realized...wow 80-90% of this was to get around the segment limits and the memory model. Actually being able to casually knock out a program that uses dozens if not hundreds of megs of ram is a pleasure. (I still get nervous about garbage collection.)
It's fun. Thanks folks.
|
|
|
| dottext ,scale and display text chars |
|
Posted by: James D Jarvis - 05-13-2022, 02:30 PM - Forum: Utilities
- Replies (3)
|
|
3 simple subs and a sample program for an alternate way to scale and display text. It's expandable if you want to use fancier fonts. (there's also a color reference builder but that's just so to make rgb32 colors a little easier to use.)
Code: (Select All) 'dottext
'draw scalable standard text using locate coordinates
Dim Shared ms&, chardot&
Dim Shared klr(0 To 255) As _Unsigned Long
ms& = _NewImage(800, 520, 32)
Screen ms&
_PrintMode _KeepBackground
'!!!! If you want to use another font put apporptiate code here
fw = _FontWidth 'manuually set this if changing code to use a hand drawn font image instead ofusing default
chardot& = _NewImage(fw * 255, 50, 32) 'create an image buffer to place and hold the font
'Screen chardot& uncomment to look at it if you would like to
_Dest chardot&
Cls
_ControlChr Off
buildrefcolors
Color klr(15)
For x = 0 To 255
Print Chr$(x); 'print that font into place
Next x
dottext 2, 1, "Dotext, 2 routines to draw scaleable text dot by dot", klr(3), 1, 1
Screen ms&
_Dest ms&
dottext 3, 3, "Sample Text, standard size.", klr(15), 1, 1
dottext 4, 4, "Sample Text, double height.", klr(8), 1, 2
dottext 6, 6, "Sample Text, double height and width.", klr(12), 2, 2
backdottext 8, 8, "Sample Text, double size and a background.", Chr$(219), klr(11), klr(8), 2, 1
dottext 10, 10, "Sample Text, x1.4 width x2.2 height.", klr(13), 1.4, 2.2
Locate 13, 1: Print "Plain text."
dottext 13, 13, "Sample Text,triple sized!", klr(14), 3, 3
dottext 16, 3, "Randomly sized height, width and color.", klr(Int(Rnd * 15) + 1), Rnd * 3 + .5, Rnd * 3 + .5
dottext 19, 1, "Enter your name.", klr(15), 2, 1
Locate 21, 1: Input n$
n$ = "ByE " + n$ + " !"
px = 1
For c = 1 To Len(n$)
'breaking down and printing the text message letter by letter
A$ = Mid$(n$, c, 1)
ww = Int(Rnd * 6) + 1
hh = Int(Rnd * 6) + 1
scalechar 22, px, Asc(A$), _RGB32(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255)), ww, hh
px = px + ww
Next c
Sub scalechar (c, r, char, cc As _Unsigned Long, tw, th)
'the raw sub to scan the font image and draw each dot in the font
Dim kc As _Unsigned Long
ww = _FontWidth 'this needs to be changed if yuo choose to load a font as a whole image instead
hh = _FontHeight 'this needs to be changed if yuo choose to load a font as a whole image instead
tr = (r - 1) * ww
tc = (c - 1) * hh
_Source chardot&
_Dest ms&
tx = char * 8
ty = 0
For px = 0 To (ww - 1)
For py = 0 To (hh - 1)
kc = Point(tx + px, ty + py)
If kc <> klr(0) Then
'PSet (xx + px, yy + py), cc
' Line (xx + px * mag - (mag - 1), yy + py * mag - (mag - 1))-(xx + px * mag, yy + py * mag), cc, BF
Line (tr + px * tw, tc + py * th)-(tr + (px + 1) * tw - 1, tc + (py + 1) * th - 1), cc, BF
End If
Next py
Next px
End Sub
Sub dottext (c, r, text$, cc As _Unsigned Long, tw, th)
'take text strign and pass it through scalechar to get print it
Dim kc As _Unsigned Long
tr = r
tc = c
For k = 1 To Len(text$)
ch = Asc(Mid$(text$, k, 1))
scalechar tc, tr, ch, cc, tw, th
tr = tr + tw
Next k
End Sub
Sub backdottext (c, r, text$, bkg$, cc As _Unsigned Long, bgc As _Unsigned Long, tw, th)
'as dotext but wiht a background character and background color defiend in same command
Dim kc As _Unsigned Long
tr = r
tc = c
bc = Asc(bkg$)
For k = 1 To Len(text$)
ch = Asc(Mid$(text$, k, 1))
scalechar tc, tr, bc, bgc, tw, th
scalechar tc, tr, ch, cc, tw, th
tr = tr + tw
Next k
End Sub
Sub buildrefcolors
'color reference table for using rgb32 colors quickly
For c = 0 To 255
klr(c) = _RGB32(c, c, c) 'all grey for now
Next c
_Source chardot&
klr(0) = Point(1, 1) '<- the pixel at this location in chardot defines black , this would matter if you loaded a an image
'very slightly cooled EGA palette
klr(1) = _RGB32(0, 0, 170) 'ega_blue
klr(2) = _RGB32(0, 170, 0) 'ega_green
klr(3) = _RGB32(0, 170, 170) 'ega_cyan
klr(4) = _RGB(170, 0, 0) 'ega_red
klr(5) = _RGB32(170, 0, 170) 'ega_magenta
klr(6) = _RGB32(170, 85, 0) 'ega_brown
klr(7) = _RGB32(170, 170, 170) 'ega_litgray
klr(8) = _RGB32(85, 85, 85) 'ega_gray
klr(9) = _RGB32(85, 85, 250) 'ega_ltblue
klr(10) = _RGB32(85, 250, 85) 'ega_ltgreen
klr(11) = _RGB32(85, 250, 250) 'ega_ltcyan
klr(12) = _RGB32(250, 85, 85) 'ega_ltred
klr(13) = _RGB32(250, 85, 250) 'ega_ltmagenta
klr(14) = _RGB32(250, 250, 85) 'ega_yellow
klr(15) = _RGB32(250, 250, 250) 'ega_white
End Sub
|
|
|
|
| planetdoodle2 |
|
Posted by: James D Jarvis - 05-12-2022, 12:00 AM - Forum: Programs
- Replies (1)
|
|
This is an earlier version of my alien skies program posted elsewhere here in this forum. I whipped this up a few months back when first using QB64 again. This is nowhere near as fancy as alien skies or as complicated in code. It's also just in 256 colors but it works well enough for what it does so I'm sharing it.
Code: (Select All) 'planetdoodle2
' By James D. Jarvis
' a 256 color planet picture generator
' type quit to leave program, press enter to go on
Screen _NewImage(800, 500, 256)
Cls
redstart = 17
redstop = 32
orangestart = 33
orangestop = 48
yellowstart = 49
yellowstop = 64
greenstart = 65
greenstop = 80
bluestart = 81
bluestop = 96
purplestart = 97
purplestop = 112
greystart = 113
greystop = 128
brownstart = 129
brownstop = 144
pinkstart = 145
pinkstop = 160
whitestart = 161
whitestop = 176
cyanstart = 177
cyanstop = 192
neonstart = 193
neonstop = 208
mix1start = 209
mix1stop = 224
mix2start = 225
mix2stop = 240
Randomize Timer
For x = 0 To 15
_PaletteColor redstart + x, _RGB32(x * 16, 0, 0)
_PaletteColor bluestart + x, _RGB32(0, 0, x * 16)
_PaletteColor greenstart + x, _RGB32(0, x * 16, 0)
_PaletteColor yellowstart + x, _RGB32(x * 16, x * 16, 0)
_PaletteColor purplestart + x, _RGB32(x * 16, 0, x * 16)
_PaletteColor orangestart + x, _RGB32(x * 16, x * 12, 0)
_PaletteColor greystart + x, _RGB32(x * 16, x * 16, x * 16)
_PaletteColor brownstart + x, _RGB32(x * 8 + 37, x * 2 + 18, x * 3 + 17)
_PaletteColor pinkstart + x, _RGB32(x * 4 + 191, x * 12, (x * 15))
_PaletteColor whitestart + x, _RGB32(x * 2 + 223, x * 2 + 224, x * 2 + 225)
_PaletteColor cyanstart + x, _RGB32(0, x * 8 + 127, x * 8 + 127)
_PaletteColor neonstart + x, _RGB32(x * x, x * x, x * 2)
_PaletteColor mix1start + x, _RGB32(x * x, x * x, x * x)
_PaletteColor mix2start + x, _RGB32(255 - (x * x), x * x, x * x)
Next x
Cls
'shadded balls
planets:
'sky
stars = Int(Rnd * 3000)
horizon = 200 + Int(Rnd * 200)
hstart = 1
hstop = horizon
hkolor = Int(Rnd * 14)
hkolor = hkolor * 16 + 17
change = 0
For h = 0 To horizon
Line (0, h)-(799, h), hkolor + change
If Int(Rnd * 3) = 1 Then change = change + 1
If change > 15 Then change = 15
Next h
For s = 1 To stars
x = Int(Rnd * 800)
y = Int(Rnd * horizon)
sr = Int(Rnd * 10) + 1
sr = Int(Sqr(sr))
sr = sr / 3
kk = whitestart + Int(Rnd * 16)
Circle (x, y), sr, kk
Paint (x, y), kk, kk
Next s
For balls = 1 To 5
x = Int(Rnd * 700) + 100
y = Int(Rnd * horizon) + 50
ox = x
oy = y
rr = Int(Rnd * 60) + 20
kk = Int(Rnd * 14)
kk = kk * 16 + 17 + Int(Rnd * 4)
Circle (x, y), rr, kk
Paint (x, y), kk, kk
ck = kk
For inner = 1 To 4
oldr = rr
rr = Int(rr * .87)
nc = Int((oldr - rr) / 2)
x = x + nc
y = y - nc
kk = kk + inf(Rnd * 2) + 1
Circle (x, y), rr, kk
Paint (x, y), kk, kk
Next inner
craters = Int(Rnd * 10) - 6
If craters < 0 Then craters = 0
If craters > 0 Then
For cc = 1 To craters
cr = oldr * .75
xv = Int((Rnd * cr) + 3) - Int(Rnd * (cr + 3))
yv = Int((Rnd * cr) + 3) - Int(Rnd * (cr + 3))
Circle (ox + xv, oy + yv), cr - 2, ck + 2
Paint (ox + xv, oy + yv), ck + 1, ck + 2
Next cc
End If
Next balls
pointy = Int(Rnd * 30) + 1
pkolor = Int(Rnd * 14)
pkolor = pkolor * 16 + 17 + Int(Rnd * 3)
change = 0
For h = horizon To 499
Line (0, h)-(799, h), pkolor + chnage
For qq = 1 To 8
mcheck = Int(Rnd * 20)
If mcheck = 1 Then GoTo drawmountain
dirt:
Next qq
If Int(Rnd * 4) = 1 Then
change = change + 1
If change > 15 Then change = 15
End If
Next h
Input a$
If a$ = "quit" Then GoTo done
GoTo planets
drawmountain:
mhigh = h - (Int(Rnd * 120) + 20)
mwide = Int(Rnd * 3) + 2
mwide = mwide * Sqr(Rnd * mwide / 3)
'mlow = horizon + Int(Rnd * mhigh) + 40
mkolor = pkolor + Int(Rnd * 8)
mx = Int(Rnd * 800) + 1
mx1 = mx - (mwide / 2)
mx2 = mx + (mwide / 2)
rcheck = 0
rlimit = Int(Rnd * 30) + 1
For my = mhigh To h
Line (mx1, my)-(mx2, my), mkolor
xv1 = Int(Rnd * 5)
xv2 = Int(Rnd * 5)
Line (mx1 + xv1, my)-(mx2 - xv2, my), mkolor + 1
Line (mx - (xv1 + mwide / 3), my)-(mx2 - xv2, my), mkolor + 3
rcheck = rcheck + 1
If rcheck > rlimit Then
Line (mx - (xv1 + mwide / 3), my)-(mx - (mwide / 2), my), mkolor + 3
End If
mwide = mwide + xv1 + wv2
mx1 = mx1 - (Int(Rnd * pointy) + (Rnd * mwide) / 2)
mx2 = mx2 + (Int(Rnd * pointy) + (Rnd * mwide) / 2)
' mwide = mx2 - mx1
Next my
GoTo dirt
done:
'end program
Cls
Clear
End
|
|
|
|
| keyhit functions |
|
Posted by: James D Jarvis - 05-11-2022, 03:01 PM - Forum: Programs
- Replies (2)
|
|
Just some functions and subs I worked up exploring how to use the _keyhit command. All pretty simple but as I've been an inkey$ user for year it's new to me. There's a super simple parser for using a comma separated list of options as input selection. The program is dull, the routines much more useful.
Code: (Select All) 'keyhit functions
'by James D. Jarvis
'just playing about with the _keyhit command and sharing
'I found waiting for a key release got results I like more than a keypress
'also has simple parser to break a comma separated list into an entry list for selection
'$dynamic
Dim Shared tlist$(0)
Print "Waiting for any key to be pressed and released"
Do
_Limit 1000
kyp = waitup
Loop Until kyp <> 0
kyp = 0
Color 15
Print "Get key pressed (press ESC to move on)"
Do
_Limit 1000
kyp = getkey
If Abs(kyp) > 0 And Abs(kyp) < 256 Then Print Chr$(Abs(kyp))
Loop Until kyp = 27
kyp = 0
Color 15
Print "Waiting for Q to be pressed and released"
Do
_Limit 1000
kyp = waitfor("Q")
Loop Until kyp <> 0
kyp = 0
Color 15
Print "Gonna keep counting until esc key is pressed and released"
x = 0
Do
_Limit 20
x = x + 1
Print x;
kyp = getkeyrelease
Loop Until kyp = -27
Print "Return the character pressed"
Do
k$ = anykey$
Loop Until k$ <> ""
Print k$
Print "Press X,Y or Z (upper or lower case)"
kk$ = pickkey$("XYZxyz")
Print "you picked "; kk$
Print "Press any key"
Do
_Limit 1000
kyp = waitup
Loop Until kyp <> 0
Cls
Print "TAB to selection and press Enter to select"
nlist$ = "1,2,3,4,5,6,7,8,9,10"
build_tablist nlist$
tp1$ = tablistpick$(2, 2)
Locate 1, 15
Print "You selected #"; tp1$
'Cls
Locate 1, 1
Print "TAB to selection and press Enter to select"
nlist$ = "a,bb,ccc,dddd,eee,ff,g"
build_tablist nlist$
tp2$ = tablistpick$(12, 2)
Print "Selected "; tp2$
nlist$ = "I,II,III,IV,V"
build_tablist nlist$
tp3$ = tablistpick$(25, 2)
Print "Selected "; tp3$
Sub build_tablist (text$)
baselist$ = text$ + ","
For cc = 1 To Len(baselist$)
If Mid$(baselist$, cc, 1) = "," Then
ccount = ccount + 1
End If
Next cc
Dim comma(ccount)
ReDim tlist$(ccount)
cid = 0
For cc = 1 To Len(baselist$)
If Mid$(baselist$, cc, 1) = "," Then
cid = cid + 1
comma(cid) = cc
End If
Next cc
comma(0) = 0
For c = 1 To ccount
' Print Mid$(baselist$, comma(c - 1) + 1, comma(c) - comma(c - 1) - 1)
tlist$(c) = Mid$(baselist$, comma(c - 1) + 1, comma(c) - comma(c - 1) - 1)
Next c
End Sub
Function getkey
x = _KeyHit
getkey = x
End Function
Function getkeyrelease
x = _KeyHit
If x > 0 Then x = 0 'returns 0 unless a key was released
getkeyrelease = x
End Function
Function anykey$
x = _KeyHit
If x < 0 Then x = -x
If x > 256 Then x = x \ 256
If x > 0 Then
anykey$ = Chr$(x)
Else
anykey$ = ""
End If
End Function
Function pickkey$ (list$)
pickflag = 0
Do
x = _KeyHit
x = -x
If x > 0 And x < 256 Then
A$ = Chr$(x)
If InStr(list$, A$) Then pickflag = 1
pickkey$ = A$
End If
Loop Until pickflag = 1
End Function
Function waitfor (kk$)
Do
x = _KeyHit
x1 = x
If Abs(x) > 256 Then
x1 = x1 \ 256
End If
Loop Until x < 0 And Abs(x1) = Asc(kk$)
waitfor = x
End Function
Function waitup
Do
x = _KeyHit
Loop Until x < 0
waitup = x
End Function
Function tablistpick$ (xx, yy)
choicelimit = UBound(tlist$)
choice = 0
For y = 1 To choicelimit
Locate yy + y, xx + 1
Print tlist$(y)
Next y
Do
_Limit 30
kk = getkeyrelease
kk = -kk
If kk = 9 Or kk = 20480 Then
newchoice = choice + 1
Else
newchoice = choice
End If
If kk = 18432 Then newchoice = choice - 1
If newchoice < 1 Then newchoice = choicelimit
If newchoice > choicelimit Then newchoice = 1
If kk <> 0 And newchoice <> choice Then
choice = newchoice
For y = 1 To choicelimit
Locate yy + y, xx
Print " "; tlist$(y); " "
Next y
Locate yy + choice, xx
Print "["; tlist$(choice); "]"
kk = 0
End If
Loop Until kk = 13
Locate yy + y + 11, xx + 1
tablistpick$ = tlist$(choice)
End Function
|
|
|
|
| Drop Down Menu |
|
Posted by: Dimster - 05-11-2022, 02:35 PM - Forum: Help Me!
- Replies (5)
|
|
Anyone have Drop Down Menu routine with both mouse and arrow key options? I had one back in QBasic days working with arrow keys but seems I lost it when I changed to a new computer. I know I should be devoting the time to do this myself but honestly, it would be crap. If you do, maybe drop it in the Utilities section?
|
|
|
|
|
