| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
Trojan infection !
Forum: Help Me!
Last Post: PhilOfPerth
2 hours ago
» Replies: 4
» Views: 81
|
Qix line monster
Forum: Programs
Last Post: Abazek
3 hours ago
» Replies: 0
» Views: 14
|
Tenary operator in QB64 w...
Forum: Utilities
Last Post: eoredson
5 hours ago
» Replies: 8
» Views: 302
|
_IIF limits two question...
Forum: General Discussion
Last Post: NakedApe
10 hours ago
» Replies: 10
» Views: 426
|
Curious if I am thinking ...
Forum: Help Me!
Last Post: bplus
10 hours ago
» Replies: 28
» Views: 398
|
Aloha from Maui guys.
Forum: General Discussion
Last Post: SMcNeill
Yesterday, 10:38 PM
» Replies: 17
» Views: 491
|
Glow Bug
Forum: Programs
Last Post: SierraKen
Yesterday, 06:33 PM
» Replies: 7
» Views: 129
|
ADPCM compression
Forum: Petr
Last Post: Petr
Yesterday, 03:13 PM
» Replies: 0
» Views: 41
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
Yesterday, 02:47 PM
» Replies: 15
» Views: 243
|
BAM Sample Programs
Forum: QBJS, BAM, and Other BASICs
Last Post: CharlieJV
Yesterday, 02:50 AM
» Replies: 36
» Views: 2,003
|
|
|
| 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?
|
|
|
|
| Adding without adding |
|
Posted by: SMcNeill - 05-11-2022, 10:11 AM - Forum: Programs
- No Replies
|
 |
So, how do you add two numbers, without adding them?
Code: (Select All) Print Add(200, 22, Overflow~%%);: If Overflow~%% Then Print "Overflow!" Else Print
Print Add(245, 22, Overflow~%%);: If Overflow~%% Then Print "Overflow!" Else Print
Function Add (A As _Unsigned _Byte, B As _Unsigned _Byte, Overflow As _Unsigned _Byte)
Dim As _Unsigned _Byte CarryFlag
Overflow = 0
While B <> 0
CarryFlag = A And B
Overflow = Overflow Or _SHR(CarryFlag, 7)
A = A Xor B
B = _SHL(CarryFlag, 1)
Wend
Add = A
End Function
You XOR, Bit shift, and AND them into submission! 
|
|
|
|
| First Computer Programming Book You Bought |
|
Posted by: TarotRedhand - 05-11-2022, 10:09 AM - Forum: General Discussion
- Replies (12)
|
 |
I still have "Illustrating BASIC" (6th reprint 1981) by Donald Alcock. Published by the Cambridge University Press and first released in 1977. It covers Dartmouth BASIC and I bought before I had any computer.
So over to you. What was your first computer programming (there are other types of programming) book that you actually bought?
TR
|
|
|
|
|
