+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://staging.qb64phoenix.com/forumdisplay.php?fid=9)
+---- Thread: Wandering In The Cave (/showthread.php?tid=922)
Pages:
1
2
RE: Wandering In The Cave - Pete - 09-27-2022
Well we won't dwell on it.. Oh wait, that's exactly what cave dwellers do!
Pete
- Seems we're in the middle of another massive PUNdemic.
RE: Wandering In The Cave - James D Jarvis - 09-29-2022
Added Mushroom harvesting and eating to the game. They can be a boon to keep your health up but don't always agree with your stomach and the spores can be dangerous.
Code: (Select All)
'wandering in the cave
'By James D. Jarvis sept 26,2022
_Title "Wandering In The Cave v0.5d"
'use the number keys of W,S,A,D to find the exit
'press 5 or . to rest briefly
'
' this is a work in progress and may generate an impossible starting position
'
_Define K As _UNSIGNED LONG
Dim Shared kk, kblack, kfloor, krock, kwater, kslime, klava, krubble, kcrystal, kexit, kfungus
Dim Shared cave(24, 6), caverunlimit, lightradius
Dim Shared phealth, pstamina, pwounds, ptemp, ppx, ppy, lastx, lasty, rubblefreq, crystalfreq, fungusfreq, pshrooms
Dim Shared cmap As _Unsigned Long
Dim Shared ms As _Unsigned Long
cmap = _NewImage(800, 800, 32)
ms = _NewImage(800, 500, 32)
Screen ms
Print "Wandering In The Cave v0.5d"
Print "By James D. Jarvis"
Print
Print "You must escape the cave."
Print
Print "Navigate with the numberpad or WASD"
Print "H harvest mushrooms and E to eat mushrooms"
Print
Print "press any key to start and get a preview of the cave map"
Print "press spacebar after that to start your wandering."
any$ = Input$(1)
Screen cmap
_FullScreen _SquarePixels
_ControlChr Off
Const csx = 1, csy = 2, ctx = 3, cty = 4, cmx = 5, cmy = 6
kfloor = _RGB32(200, 180, 160): kwater = _RGB32(10, 30, 240)
krock = _RGB32(40, 30, 20): kslime = _RGB32(20, 240, 100): klava = _RGB32(200, 5, 5)
krubble = _RGB32(80, 80, 80): kcrystal = _RGB32(250, 250, 0): kexit = _RGB32(255, 0, 255)
kfungus = _RGB32(200, 50, 150)
Randomize Timer
check$ = "off"
caverunlimit = 500
Do
_Limit 10
restartcaves:
rubblefreq = Int(3 + Rnd * 100)
crystalfreq = Int(1 + Rnd * 200)
fungusfreq = Int(3 + Rnd * 100)
Line (0, 0)-(_Width, _Height), krock, BF
cave(1, csx) = Int(100 + Rnd * 600)
cave(1, csy) = Int(100 + Rnd * 600)
Do
cave(1, ctx) = Int(100 + Rnd * 600)
cave(1, cty) = Int(100 + Rnd * 600)
dx = Abs(cave(1, csx) - cave(1, ctx))
dy = Abs(cave(1, csy) - cave(1, cty))
dl = Sqr(dx * dx + dy * dy)
Loop Until dy > 20 And dx > 20
cave(1, cmx) = Int((cave(1, csx) + cave(1, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
cave(1, cmy) = Int((cave(1, csy) + cave(1, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
For c = 2 To 24
Select Case Int(1 + Rnd * 8)
Case 1, 2, 3
cave(c, csx) = cave(c - 1, csx)
cave(c, csy) = cave(c - 1, csy)
Case 4, 5
cave(c, csx) = cave(c - 1, cmx)
cave(c, csy) = cave(c - 1, cmy)
Case 6, 7, 8
cave(c, csx) = cave(c - 1, ctx)
cave(c, csy) = cave(c - 1, cty)
End Select
cpl = 0
Do
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
cave(c, ctx) = Int(100 + Rnd * 600)
cave(c, cty) = Int(100 + Rnd * 600)
Case 4, 5, 6
If cave(c, csx) <= 400 Then
cave(c, ctx) = cave(c, csx) + Int(50 + Rnd * 200)
Else
cave(c, ctx) = cave(c, csx) - Int(50 + Rnd * 200)
End If
If cave(c, csy) <= 400 Then
cave(c, cty) = cave(c, csy) + Int(50 + Rnd * 200)
Else
cave(c, cty) = cave(c, csy) - Int(50 + Rnd * 200)
End If
End Select
dx = Abs(cave(c, csx) - cave(c, ctx))
dy = Abs(cave(c, csy) - cave(c, cty))
dl = Sqr(dx * dx + dy * dy)
cpl = cpl + 1
If cave(c, ctx) < 50 Then GoTo restartcaves
If cpl > caverunlimit Then GoTo restartcaves
Loop Until dy > 20 And dx > 20
cave(c, cmx) = Int((cave(c, csx) + cave(c, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
cave(c, cmy) = Int((cave(c, csy) + cave(c, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
' Print cave(c, csx), cave(c, csy), cave(c, ctx), cave(c, cty), dl
Next c
For c = 1 To 24
r = (1 + (1 + Rnd * 6) + (1 + Rnd * 6)) / 2
xx = cave(c, csx)
yy = cave(c, csy)
xtrend = 0: ytrend = 0
If xx < cave(c, cmx) Then xtrend = 3
If xx > cave(c, cmx) Then xtrend = -3
If yy < cave(c, cmy) Then ytrend = 3
If yy > cave(c, cmy) Then ytrend = -3
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(cave(c, cmx) - nx)
dy = Abs(cave(c, cmy) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < (r * 10) Then
nx = cave(c, cmx)
ny = ny + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
If dy < (r * 10) Then
ny = cave(c, cmy)
nx = nx + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
bumpyline xx, yy, nx, ny, r, kfloor
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartcaves
If cave(c, cmx) < 50 Then GoTo restartcaves
Loop Until xx = cave(c, cmx) And yy = cave(c, cmy)
Next
For c = 1 To 24
xx = cave(c, cmx)
yy = cave(c, cmy)
xtrend = 0: ytrend = 0
If xx < cave(c, ctx) Then xtrend = 2
If xx > cave(c, ctx) Then xtrend = -2
If yy < cave(c, cty) Then ytrend = 2
If yy > cave(c, cty) Then ytrend = -2
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(cave(c, ctx) - nx)
dy = Abs(cave(c, cty) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < r * 7 Then
nx = cave(c, ctx)
ny = ny + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
If dy < r * 7 Then
ny = cave(c, cty)
nx = nx + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
bumpyline xx, yy, nx, ny, r, kfloor
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartcaves
If cave(c, ctx) < 50 Then GoTo restartcaves
Loop Until xx = cave(c, ctx) And yy = cave(c, cty)
Next
For c = 1 To 24
If Rnd * 6 < 3.5 Then
reps = Int(2 + Rnd * 3)
For e = 1 To reps
If Rnd * 10 < 8.5 Then bumpypoly cave(c, csx), cave(c, csy), Int(5 + Int(Rnd * (5 * e))), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
If Rnd * 10 < 8.5 Then bumpypoly cave(c, ctx), cave(c, cty), Int(5 + Int(Rnd * (5 * e))), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
Next
End If
Next c
'streams
ns = Int(1 + Rnd * 12)
If ns < 9 Then addstreams ns, kwater
'lava flows
nf = Int(1 + Rnd * 12)
If nf < 5 Then addstreams nf, klava
'slime flows
nf = Int(1 + Rnd * 30)
If nf < 9 Then addstreams nf, kslime
'add rubble and more
For yy = 1 To 799
For xx = 1 To 799
If Int(1 + Rnd * 10) < 4 Then
For gx = -1 To 1
For gy = -1 To 1
If Point(xx, yy) = kfloor And Point(xx + gx, yy + gy) = krock Then PSet (xx, yy), krubble
If Point(xx, yy) = klava And Point(xx + gx, yy + gy) = krock Then
Select Case Int(1 + Rnd * 100)
Case 1
PSet (xx + gx, yy + gy), kcrystal
Case 2, 3, 4, 5, 6, 7, 8, 9, 10
PSet (xx + gx, yy + gy), krubble
Case 11, 12, 13
PSet (xx + gx, yy + gy), kfloor
End Select
End If
If Point(xx, yy) = klava And Point(xx + gx, yy + gy) = kwater Then
Select Case Int(1 + Rnd * 300)
Case 1
PSet (xx + gx, yy + gy), kcrystal
Case 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25
PSet (xx + gx, yy + gy), krubble
Case 26, 27, 28, 29, 30, 31, 32, 33
PSet (xx + gx, yy + gy), kfloor
End Select
End If
Next
Next
End If
If Int(1 + Rnd * 1000) < rubblefreq Then
If Point(xx, yy) = kfloor Then
PSet (xx, yy), krubble
For gx = -1 To 1
For gy = -1 To 1
If Int(1 + Rnd * 10) < 3 Then
If Point(xx + gx, yy + gy) = kfloor Then PSet (xx + gx, yy + gy), krubble
End If
Next
Next
End If
End If
If Int(1 + Rnd * 5000) < crystalfreq Then
If Point(xx, yy) = kfloor Then
PSet (xx, yy), kcrystal
For gx = -1 To 1
For gy = -1 To 1
If Int(1 + Rnd * 100) < 3 Then
If Point(xx + gx, yy + gy) = kfloor Then PSet (xx + gx, yy + gy), kcrystal
End If
Next
Next
End If
End If
If Int(1 + Rnd * 1000) < fungusfreq Then
If Point(xx, yy) = kfloor Then
PSet (xx, yy), kfungus
For gx = -1 To 1
For gy = -1 To 1
If Int(1 + Rnd * 20) < 3 Then
If Point(xx + gx, yy + gy) = kfloor Then PSet (xx + gx, yy + gy), kfungus
End If
Next
Next
End If
End If
Next
Next
For puddles = 1 To 20
pl = Int(1 + Rnd * 6)
cc = Int(1 + Rnd * 24)
Select Case pl
Case 1
addwater cave(cc, csx), cave(cc, csy), 2
Case 2
addwater cave(cc, cmx), cave(cc, cmy), 1
Case 3
addwater cave(cc, ctx), cave(cc, cty), 2
Case 4, 5, 6
addwater 0, 0, 3
End Select
Next
For slimedrops = 1 To 16
pl = Int(1 + Rnd * 7)
cc = Int(1 + Rnd * 24)
Select Case pl
Case 1
addslime cave(cc, csx), cave(cc, csy), 1
Case 2
addslime cave(cc, cmx), cave(cc, cmy), 1
Case 3
addslime cave(cc, ctx), cave(cc, cty), 1
Case 4, 5, 6, 7
addslime 0, 0, 1.5
End Select
Next
For lavapools = 1 To 12
pl = Int(1 + Rnd * 8)
cc = Int(3 + Rnd * 22)
Select Case pl
Case 1, 2, 3
addlava cave(cc, csx), cave(cc, csy), 3
Case 4
addlava cave(cc, cmx), cave(cc, cmy), 1
Case 5, 6, 7
addlava cave(cc, ctx), cave(cc, cty), 2
Case 8
addlava 0, 0, 2
End Select
Next
If check$ = "on" Then
For c = 1 To 24
Line (cave(c, csx), cave(c, csy))-(cave(c, cmx), cave(c, cmy)), _RGB32(250, 250, 250)
Line (cave(c, cmx), cave(c, cmy))-(cave(c, ctx), cave(c, cty)), _RGB32(250, 250, 250)
_PrintString (cave(c, cmx), cave(c, cmy)), _Trim$(Str$(c))
Next c
End If
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
' Cls n
Loop Until kk$ = " "
'Do
ecave = Int(6 + Rnd * 16)
exitX = cave(ecave, ctx)
exitY = cave(ecave, cty)
'Loop Until Point(exitX, exitY) <> krock
PSet (exitX, exitY), kexit
kk$ = ""
'turn based cave exploration
Screen ms
Cls
_Source cmap
_Dest ms
ppx = cave(1, csx): ppy = cave(1, csy)
start_x = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
lightradius = 9: pstamina = 100: phealth = 100: pwounds = 0: ptemp = 98: pmushrooms = 0
pshrooms = 0
turn = 0
_PrintMode _KeepBackground
View Print 25 To 30
Do
'draw location
rsqrd = lightradius * lightradius
y = -lightradius
While y <= lightradius
x = Int(Sqr(rsqrd - y * y))
For x2 = ppx - x To ppx + x
vx = x2 - ppx + 12
kk = Point(x2, ppy + y)
Line (vx * 8, (y + 12) * 16)-(vx * 8 + 7, (y + 12) * 16 + 15), kk, BF
If kk = kfungus Then
Color _RGB32(250, 100, 200)
_PrintString (vx * 8, (y + 12) * 16), Chr$(234)
Color _RGB32(255, 255, 255)
End If
If kk = kcrystal Then _PrintString (vx * 8, (y + 12) * 16), Chr$(127)
If kk = krubble Then
Color _RGB32(150, 150, 150)
_PrintString (vx * 8, (y + 12) * 16), Chr$(177)
Color _RGB32(255, 255, 255)
End If
If kk = kslime Then
Color _RGB32(250, 250, 150)
sb = Int(Rnd * 4)
If sb = 1 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(247)
If sb = 2 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(126)
Color _RGB32(255, 255, 255)
End If
If kk = klava Then
Color _RGB32(250, 250, 150)
lb = Int(Rnd * 7)
If lb = 1 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(249)
If lb = 2 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(9)
If lb = 3 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(176)
If lb = 4 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(248)
If lb = 5 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(46)
Color _RGB32(255, 255, 255)
End If
If kk = kwater Then
Color _RGB32(40, 120, 250)
wb = Int(Rnd * 6)
If wb = 1 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(45)
If wb = 2 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(61)
If wb = 3 Then _PrintString (vx * 8, (y + 12) * 16), Chr$(240)
Color _RGB32(255, 255, 255)
End If
Next
y = y + 1
Wend
Line (598, 18)-(795, 144), krock, BF
_PrintString ((12) * 8, (12) * 16), "@"
o$ = "Stamina " + Str$(pstamina)
_PrintString (600, 20), o$
o$ = "Health " + Str$(phealth)
_PrintString (600, 40), o$
o$ = "Wounds " + Str$(pwounds)
_PrintString (600, 60), o$
o$ = "Temperature " + Str$(ptemp)
_PrintString (600, 80), o$
o$ = "Mushrooms " + Str$(pshrooms)
_PrintString (600, 100), o$
edd = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
o$ = "Distance to Exit " + Str$(edd)
_PrintString (600, 120), o$
Print "Turn", turn
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
turn = turn + 1
lastx = ppx
lasty = ppy
Select Case kk$
Case "e", "E"
eatshrooms
Case "h", "H"
pshrooms = pshrooms + harvestfungus
Case "w", "8"
If pstamina > 0 And Point(ppx, ppy - 1) <> krock Then ppy = ppy - 1
Case "s", "2"
If pstamina > 0 And Point(ppx, ppy + 1) <> krock Then ppy = ppy + 1
Case "a", "4"
If pstamina > 0 And Point(ppx - 1, ppy) <> krock Then ppx = ppx - 1
Case "d", "6"
If pstamina > 0 And Point(ppx + 1, ppy) <> krock Then ppx = ppx + 1
Case "7"
If pstamina > 0 And Point(ppx - 1, ppy - 1) <> krock Then
ppy = ppy - 1
ppx = ppx - 1
End If
Case "9"
If pstamina > 0 And Point(ppx + 1, ppy - 1) <> krock Then
ppy = ppy - 1
ppx = ppx + 1
End If
Case "1"
If pstamina > 0 And Point(ppx - 1, ppy + 1) <> krock Then
ppy = ppy + 1
ppx = ppx - 1
End If
Case "3"
If pstamina > 0 And Point(ppx + 1, ppy + 1) <> krock Then
ppy = ppy + 1
ppx = ppx + 1
End If
Case "5", "."
If Int(1 + Rnd * 50) < phealth And pstamina < 100 Then pstamina = pstamina + 1 + Int(Rnd * (phealth / 25))
End Select
If Point(ppx, ppy) = krubble Then pwounds = pwounds + checkrubble(ppx, ppy)
If Point(ppx, ppy) = kcrystal Then pwounds = pwounds + checkcrystal(ppx, ppy)
If Int(1 + Rnd * 80 + pwounds) > phealth Then pstamina = pstamina - 1
If Point(ppx, ppy) = kslime Then
Print "The slime is nauseating...";
If Int(Rnd * 120) > phealth Then phealth = phealth - Int(Rnd * 4)
If Int(Rnd * 120) > phealth Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
Print " it's making you itch."
Case 4, 5, 6
Print " it's feel's like it is burning you."
wounds = wounds + Abs(Int(Rnd * 2 - Rnd * 2))
End Select
End If
End If
If Point(ppx, ppy) = kwater Then ptemp = ptemp - Int(Abs(Rnd * 2 - Rnd * 2))
If Point(ppx, ppy) = klava Then
ptemp = ptemp + 100
dmg = 10 + Int(Rnd * 20)
pwounds = pwounds + dmg
Print "YOU ARE STANDING IN LAVA !!!"
Print "....suffering "; dmg; " points of damage !"
End If
If ptemp < 0 Then
Print "You are dangerously COLD .... brrrrr"
pstamina = pstamina - Int(Rnd * 2)
If Int(1 + Rnd * (50 + Abs(ptemp))) > pstamina Then
pwounds = pwounds + Int(1 + Rnd * 2)
phealth = phealth - Int(Rnd * 2)
End If
End If
tcheck = ptemp + Rnd * 10
If tcheck > 108 Then
pstamina = pstamina - 1
Print "You are dangerously warm!"
If Int(1 + Rnd * ptemp) > pstamina Then
pwounds = pwounds + 1
phealth = phealth - Int(Rnd * 2)
End If
End If
If Point(ppx, ppy) = kfloor Then
If ptemp < 98 Then ptemp = ptemp + 1
If ptemp > 98 Then ptemp = Int((ptemp + 98) / 2)
End If
If pstamina < 20 Then
Print "You are ";
If pstamina < 1 Then
Print "exhausted."
Else
Print "fatigued."
End If
End If
If wounds > phealth Then
Print "You are in intense pain !"
pstamina = pstamina = Int(Rnd * 2)
End If
If Point(ppx, ppy) = kexit Then
Print
Print "YOU HAVE FOUND THE EXIT"
Print
Print "it took you "; turn; " turns after starting "; start_x; " spaces away from the exit."
Print
kk$ = Chr$(27)
End If
If phealth < 1 Or pwounds > 99 Then
Print "YOU HAVE PERISHED DUE TO YOUR POOR CONDITION."
Print
Print "(press any key to continue)"
any$ = Input$(1)
kk$ = Chr$(27)
End If
Loop Until kk$ = Chr$(27)
Print "GAME OVER"
Print "play again?"
Print "Y or N?"
Do
ask$ = Input$(1)
ask$ = UCase$(ask$)
Loop Until ask$ = "Y" Or ask$ = "N"
If ask$ = "Y" Then
Screen cmap
GoTo restartcaves
End If
System
Function checkrubble (xx, yy)
stumblecheck = Int(1 + Rnd * 120)
dmg = 0
If stumblecheck > health Then
Print "whooops.... you stumbled on the rubble...";
Select Case Int(1 + Rnd * 20)
Case 1
If Point(ppx - 1, ppy - 1) <> krock Then
ppx = ppx - 1
ppy = ppy - 1
End If
Case 2
If Point(ppx, ppy - 1) <> krock Then
ppy = ppy - 1
End If
Case 3
If Point(ppx + 1, ppy + 1) <> krock Then
ppx = ppx + 1
ppy = ppy + 1
End If
Case 4
If Point(ppx - 1, ppy) <> krock Then
ppx = ppx - 1
End If
Case 6
If Point(ppx + 1, ppy) <> krock Then
ppx = ppx + 1
End If
Case 7
If Point(ppx - 1, ppy + 1) <> krock Then
ppx = ppx - 1
ppy = ppy + 1
End If
Case 8
If Point(ppx, ppy + 1) <> krock Then
ppy = ppy + 1
End If
Case 9
If Point(ppx + 1, ppy + 1) <> krock Then
ppy = ppy + 1
ppx = ppx + 1
End If
Case 10, 11, 12, 13, 14
Print " knocking the wind out of you... ";
pstamina = Int(pstamina / 4)
Case 15, 16, 17, 18, 19, 20
ppx = lastx
ppy = lasty
Print "you tumble back...";
End Select
dmg = Abs(Int((Rnd * 3) - (Rnd * 3)))
If dmg > 0 Then
Print "you suffer "; dmg; " points of damage!"
Else
Print "."
End If
End If
checkrubble = dmg
End Function
Function checkcrystal (xx, yy)
climbcheck = Int(1 + Rnd * 100)
If climbcheck > phealth Then
Print "You just can't gain any purchase to climb the crystal."
Else
stumblecheck = Int(1 + Rnd * 120)
dmg = 0
If stumblecheck > health Then
Print ".... you fell from the crytsal...";
Select Case Int(1 + Rnd * 9)
Case 1
If Point(ppx - 1, ppy - 1) <> krock Then
ppx = ppx - 1
ppy = ppy - 1
End If
Case 2
If Point(ppx, ppy - 1) <> krock Then
ppy = ppy - 1
End If
Case 3
If Point(ppx + 1, ppy + 1) <> krock Then
ppx = ppx + 1
ppy = ppy + 1
End If
Case 4
If Point(ppx - 1, ppy) <> krock Then
ppx = ppx - 1
End If
Case 5
ppx = lastx
ppy = lasty
Case 6
If Point(ppx + 1, ppy) <> krock Then
ppx = ppx + 1
End If
Case 7
If Point(ppx - 1, ppy + 1) <> krock Then
ppx = ppx - 1
ppy = ppy + 1
End If
Case 8
If Point(ppx, ppy + 1) <> krock Then
ppy = ppy + 1
End If
Case 9
If Point(ppx + 1, ppy + 1) <> krock Then
ppy = ppy + 1
ppx = ppx + 1
End If
End Select
dmg = Abs(Int((Rnd * 4) - (Rnd * 4)))
If dmg > 0 Then
Print "you suffer "; dmg; " points of damage!"
Else
Print "."
End If
End If
End If
checkcrystal = dmg
End Function
Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)
rsqrd = r * r
y = -r
While y <= r
x = Sqr(rsqrd - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF
y = y + 1
Wend
End Sub
Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
Line (cx + x, cy + y)-(cx + x, cy + y), klr
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
Line -(cx + x2, cy + y2), klr
Next
End Sub
Sub bumpypoly (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
'Line (cx + x, cy + y)-(cx + x, cy + y), klr
lx = cx + x: ly = cy + y
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
tv = (Rnd * 6 + Rnd * 6 + 3) / 10
bumpyline lx, ly, cx + x2, cy + y2, thk * tv, klr
lx = cx + x2: ly = cy + y2
Next
End Sub
Sub addwater (pcx, pcy, scale)
If pcx = 0 Then
pcx = Int(100 + Rnd * 600)
pcy = Int(100 + Rnd * 600)
End If
prr = Int(6 + Rnd * (12 * scale))
preps = (3 + Int(Rnd * prr))
For r = 1 To preps
pcx = pcx + Int(Rnd * 4) - Int(Rnd * 4)
pcy = pcy + Int(Rnd * 4) - Int(Rnd * 4)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcx - x To pcx + x
kk = Point(x2, pcy + y)
If kk = kfloor Then
PSet (x2, pcy + y), kwater
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addslime (pcx, pcy, scale)
If pcx = 0 Then
pcx = Int(100 + Rnd * 600)
pcy = Int(100 + Rnd * 600)
End If
prr = Int(6 + Rnd * (12 * scale))
preps = (3 + Int(Rnd * prr))
For r = 1 To preps
pcx = pcx + Int(Rnd * 4) - Int(Rnd * 4)
pcy = pcy + Int(Rnd * 4) - Int(Rnd * 4)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcx - x To pcx + x
kk = Point(x2, pcy + y)
If kk = kfloor Then
PSet (x2, pcy + y), kslime
End If
Next
y = y + 1
Wend
prr = Int(2 + Rnd * (12 * scale))
Next
End Sub
Sub addlava (pcx, pcy, scale)
If pcx = 0 Then
pcx = Int(100 + Rnd * 600)
pcy = Int(100 + Rnd * 600)
End If
prr = Int(6 + Rnd * (12 * scale))
preps = (2 + Int(Rnd * (prr / 2)))
For r = 1 To preps
pcx = pcx + Int(Rnd * 4) - Int(Rnd * 4)
pcy = pcy + Int(Rnd * 4) - Int(Rnd * 4)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcx - x To pcx + x
kk = Point(x2, pcy + y)
If kk = kfloor Then
PSet (x2, pcy + y), klava
End If
If kk = kslime Then
PSet (x2, pcy + y), klava
End If
If kk = kwater Then
Select Case Int(1 + Rnd * 51)
Case 1 To 5
PSet (x2, pcy + y), klava
Case 6 To 20
PSet (x2, pcy + y), krock
Case 21 To 40
PSet (x2, pcy + y), kfloor
Case 41 To 50
PSet (x2, pcy + y), krubble
Case 51
PSet (x2, pcy + y), kcrystal
End Select
End If
If kk = kfungus Then
PSet (x2, pcy + y), klava
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub fatpoly (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
'Line (cx + x, cy + y)-(cx + x, cy + y), klr
lx = cx + x: ly = cy + y
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
fatline lx, ly, cx + x2, cy + y2, thk, klr
lx = cx + x2: ly = cy + y2
Next
End Sub
Sub bumpyline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
bumpylineLow x1, y1, x0, y0, r, klr
Else
bumpylineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
bumpylineHigh x1, y1, x0, y0, r, klr
Else
bumpylineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
lineLow x1, y1, x0, y0, r, klr
Else
lineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
lineHigh x1, y1, x0, y0, r, klr
Else
lineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
circleBF x, y, r, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
circleBF x, y, r, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
Sub bumpylineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
tv = (Rnd * 6 + Rnd * 6 + 3) / 10
circleBF x + Rnd * r - Rnd * r, y + Rnd * r - Rnd * 4, r * tv, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub bumpylineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
tv = (Rnd * 12 + Rnd * 6 + 3) / 10
circleBF x + Rnd * r - Rnd * r, y + Rnd * r - Rnd * 4, r * tv, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
Sub addstreams (numstreams, kklr)
Dim stream(numstreams, 6)
restartstreams:
stream(1, csx) = Int(100 + Rnd * 600)
stream(1, csy) = Int(100 + Rnd * 600)
Do
stream(1, ctx) = Int(100 + Rnd * 600)
stream(1, cty) = Int(100 + Rnd * 600)
dx = Abs(stream(1, csx) - stream(1, ctx))
dy = Abs(stream(1, csy) - stream(1, cty))
dl = Sqr(dx * dx + dy * dy)
Loop Until dy > 20 And dx > 20
stream(1, cmx) = Int((stream(1, csx) + stream(1, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(1, cmy) = Int((stream(1, csy) + stream(1, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
For c = 2 To numstreams
Select Case Int(1 + Rnd * 8)
Case 1, 2, 3
stream(c, csx) = stream(c - 1, csx)
stream(c, csy) = stream(c - 1, csy)
Case 4, 5
stream(c, csx) = stream(c - 1, cmx)
stream(c, csy) = stream(c - 1, cmy)
Case 6, 7, 8
stream(c, csx) = stream(c - 1, ctx)
stream(c, csy) = stream(c - 1, cty)
End Select
cpl = 0
Do
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
stream(c, ctx) = Int(100 + Rnd * 600)
stream(c, cty) = Int(100 + Rnd * 600)
Case 4, 5, 6
If stream(c, csx) <= 400 Then
stream(c, ctx) = stream(c, csx) + Int(50 + Rnd * 200)
Else
stream(c, ctx) = stream(c, csx) - Int(50 + Rnd * 200)
End If
If stream(c, csy) <= 400 Then
stream(c, cty) = stream(c, csy) + Int(50 + Rnd * 200)
Else
stream(c, cty) = stream(c, csy) - Int(50 + Rnd * 200)
End If
End Select
dx = Abs(stream(c, csx) - stream(c, ctx))
dy = Abs(stream(c, csy) - stream(c, cty))
dl = Sqr(dx * dx + dy * dy)
cpl = cpl + 1
If stream(c, ctx) < 50 Then GoTo restartstreams
If cpl > caverunlimit Then GoTo restartstreams
Loop Until dy > 20 And dx > 20
stream(c, cmx) = Int((stream(c, csx) + stream(c, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(c, cmy) = Int((stream(c, csy) + stream(c, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
' Print cave(c, csx), cave(c, csy), cave(c, ctx), cave(c, cty), dl
Next c
For c = 1 To numstreams
r = (3 + (1 + Rnd * 6) + (1 + Rnd * 6)) / 4
xx = stream(c, csx)
yy = stream(c, csy)
If Point(xx, yy) = krock Then
bumpypoly xx, yy, Int(r / 2 + Int(Rnd * (r * 3))), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
End If
xtrend = 0: ytrend = 0
If xx < stream(c, cmx) Then xtrend = 3
If xx > stream(c, cmx) Then xtrend = -3
If yy < stream(c, cmy) Then ytrend = 3
If yy > stream(c, cmy) Then ytrend = -3
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(stream(c, cmx) - nx)
dy = Abs(stream(c, cmy) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < (r * 10) Then
nx = stream(c, cmx)
ny = ny + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
If dy < (r * 10) Then
ny = stream(c, cmy)
nx = nx + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
bumpyline xx, yy, nx, ny, r, kklr
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartstreams
If stream(c, cmx) < 50 Then GoTo restartstreams
Loop Until xx = stream(c, cmx) And yy = stream(c, cmy)
Next
If Point(nx, ny) = krock Then
bumpypoly nx, ny, Int(r / 2 + Int(Rnd * r)), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
End If
For c = 1 To numstreams
xx = stream(c, cmx)
yy = stream(c, cmy)
xtrend = 0: ytrend = 0
If xx < stream(c, ctx) Then xtrend = 2
If xx > stream(c, ctx) Then xtrend = -2
If yy < stream(c, cty) Then ytrend = 2
If yy > stream(c, cty) Then ytrend = -2
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(stream(c, ctx) - nx)
dy = Abs(stream(c, cty) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < r * 7 Then
nx = stream(c, ctx)
ny = ny + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
If dy < r * 7 Then
ny = stream(c, cty)
nx = nx + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
bumpyline xx, yy, nx, ny, r, kklr
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartstreams
If stream(c, ctx) < 50 Then GoTo restartstreams
Loop Until xx = stream(c, ctx) And yy = stream(c, cty)
If Point(nx, ny) = krock Then
bumpypoly nx, ny, Int(r / 2 + Int(Rnd * r)), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
End If
Next
End Sub
Sub addlavaflows (numstreams)
Dim stream(numstreams, 6)
restartflows:
stream(1, csx) = Int(100 + Rnd * 600)
stream(1, csy) = Int(100 + Rnd * 600)
Do
stream(1, ctx) = Int(100 + Rnd * 600)
stream(1, cty) = Int(100 + Rnd * 600)
dx = Abs(stream(1, csx) - stream(1, ctx))
dy = Abs(stream(1, csy) - stream(1, cty))
dl = Sqr(dx * dx + dy * dy)
Loop Until dy > 20 And dx > 20
stream(1, cmx) = Int((stream(1, csx) + stream(1, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(1, cmy) = Int((stream(1, csy) + stream(1, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
For c = 2 To numstreams
Select Case Int(1 + Rnd * 8)
Case 1, 2, 3
stream(c, csx) = stream(c - 1, csx)
stream(c, csy) = stream(c - 1, csy)
Case 4, 5
stream(c, csx) = stream(c - 1, cmx)
stream(c, csy) = stream(c - 1, cmy)
Case 6, 7, 8
stream(c, csx) = stream(c - 1, ctx)
stream(c, csy) = stream(c - 1, cty)
End Select
cpl = 0
Do
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
stream(c, ctx) = Int(100 + Rnd * 600)
stream(c, cty) = Int(100 + Rnd * 600)
Case 4, 5, 6
If stream(c, csx) <= 400 Then
stream(c, ctx) = stream(c, csx) + Int(50 + Rnd * 200)
Else
stream(c, ctx) = stream(c, csx) - Int(50 + Rnd * 200)
End If
If stream(c, csy) <= 400 Then
stream(c, cty) = stream(c, csy) + Int(50 + Rnd * 200)
Else
stream(c, cty) = stream(c, csy) - Int(50 + Rnd * 200)
End If
End Select
dx = Abs(stream(c, csx) - stream(c, ctx))
dy = Abs(stream(c, csy) - stream(c, cty))
dl = Sqr(dx * dx + dy * dy)
cpl = cpl + 1
If stream(c, ctx) < 50 Then GoTo restartflows
If cpl > caverunlimit Then GoTo restartflows
Loop Until dy > 20 And dx > 20
stream(c, cmx) = Int((stream(c, csx) + stream(c, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(c, cmy) = Int((stream(c, csy) + stream(c, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
' Print cave(c, csx), cave(c, csy), cave(c, ctx), cave(c, cty), dl
Next c
For c = 1 To numstreams
r = (3 + (1 + Rnd * 6) + (1 + Rnd * 6)) / 4
xx = stream(c, csx)
yy = stream(c, csy)
xtrend = 0: ytrend = 0
If xx < stream(c, cmx) Then xtrend = 3
If xx > stream(c, cmx) Then xtrend = -3
If yy < stream(c, cmy) Then ytrend = 3
If yy > stream(c, cmy) Then ytrend = -3
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(stream(c, cmx) - nx)
dy = Abs(stream(c, cmy) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < (r * 10) Then
nx = stream(c, cmx)
ny = ny + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
If dy < (r * 10) Then
ny = stream(c, cmy)
nx = nx + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
bumpyline xx, yy, nx, ny, r, klava
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartflows
If stream(c, cmx) < 50 Then GoTo restartflows
Loop Until xx = stream(c, cmx) And yy = stream(c, cmy)
Next
For c = 1 To numstreams
xx = stream(c, cmx)
yy = stream(c, cmy)
xtrend = 0: ytrend = 0
If xx < stream(c, ctx) Then xtrend = 2
If xx > stream(c, ctx) Then xtrend = -2
If yy < stream(c, cty) Then ytrend = 2
If yy > stream(c, cty) Then ytrend = -2
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(stream(c, ctx) - nx)
dy = Abs(stream(c, cty) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < r * 7 Then
nx = stream(c, ctx)
ny = ny + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
If dy < r * 7 Then
ny = stream(c, cty)
nx = nx + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
bumpyline xx, yy, nx, ny, r, klava
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartflows
If stream(c, ctx) < 50 Then GoTo restartflows
Loop Until xx = stream(c, ctx) And yy = stream(c, cty)
Next
End Sub
Function harvestfungus
If Point(ppx, ppy) = kfungus And pstamina > 0 Then
nf = Int(Rnd * 3)
Print "You root among the fungus and harvest "; nf; " decent mushrooms";
_Dest cmap
PSet (ppx, ppy), kfloor
_Dest ms
pstamina = pstamina - Int(Rnd * 3)
If Int(1 + Rnd * 100) > phealth Then
Print " getting a face full of toxic spores."
phealth = phealth - Int(Rnd * 4)
Else
Print "."
End If
harvestfungus = nf
Else
Print "No mushrooms to pick here."
End If
End Function
Sub eatshrooms
If pshrooms < 1 Then Print "You don't have any mushrooms."
If pshrooms > 0 Then
pshrooms = pshrooms - 1
eat = Int(1 + Rnd * 100)
If eat > phealth Then
Select Case eat
Case 1 To 50
Print "Oh.... that was horrible, it makes you terribly ill."
phealth = Int(phealth * .7)
pstamina = Int(pstamina / 2)
pwounds = pwounds + Int(1 + Rnd * 3)
Case 51 To 75
Print "Oh...That was awful, it tasted like dirt."
pstamina = Int(pstamina * .9)
phealth = Int(phealth * .9)
Case 76 To 100
Print "That didn't go down right."
pstamina = Int(pstamina * .9)
End Select
Else
Select Case eat
Case 1 To 25
Print "You've eaten worse."
phealth = phealth + Int(Rnd * 2)
pstamina = pstamina + 2
Case 26 To 75
Print "That tasted great!"
pwounds = pwounds - Int(Rnd * 2)
phealth = phealth + Int(1 + Rnd * 6)
pstamina = pstamina + 3
Case 76 To 100
pwounds = pwounds - Int(Rnd * 3)
Print "Munch, munch... well that hit the spot."
pstamina = pstamina + 4
End Select
End If
If pstamina < 1 Then pstamina = 0
If phealth < 1 Then phealth = 0
If phealth > 100 Then phealth = 100
If pwounds < 1 Then pwounds = 0
If pstamina > 100 Then pstamina = pstamina - 1
End If
End SubRE: Wandering In The Cave - Pete - 09-29-2022
Mushrooms remind me of politicians. They keep you in the dark and keep feeding you ____.
Where's Steve? At least he could plant me some corn.
Pete
RE: Wandering In The Cave - justsomeguy - 10-30-2022
Great work on you rouge-like! I played with it longer than I expected. Do you have any future plans for it? Combat? Treasure?
RE: Wandering In The Cave - James D Jarvis - 10-30-2022
(10-30-2022, 04:25 AM)justsomeguy Wrote: Great work on you rouge-like! I played with it longer than I expected. Do you have any future plans for it? Combat? Treasure?
I do have some future plans. I have 2 other related programs I've been testing different feature sets with. Mostly playing about with map generation, I posted deathmazedungeon here, I have another one that does an overland ruined city as well but not too thrilled with that and haven't posted it yet. The ascii microgrouge "Mazerogue" I posted a few days ago and am fiddling with right now came out of developing a more maze-like method for dungeon labyrinths that I plan on bringing into this model. Eventually there will be treasures/equipment, monsters, combat, alchemy, and magic spells that are built off of this general engine. I'm focusing more on environments to stumble about it and interact with so I am exploring how to make them interesting and coherent to some degree.
EDIT: I posted ruingen.bas in the deathmaze thread. It's an expansion of this orignal program and uses a sprite set for graphics. The subroutine that holds and loads the sprite set is also in that thread.
https://staging.qb64phoenix.com/showthread.php?tid=934&pid=8775#pid8775