+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://qb64phoenix.com/forum/forumdisplay.php?fid=9)
+---- Thread: Wandering In The Cave (/showthread.php?tid=922)
Pages:
1
2
Wandering In The Cave - James D Jarvis - 09-26-2022
Wandering In The Cave
A simple cave escape game. Navigate to the exit to escape and win. Watch out for lava, exposure, and toxic slime.
EDIT added functionality to game, see latest post.
Code: (Select All)
'wandering in the cave
'By James D. Jarvis sept 26,2022
_Title "Wandering In The Cave v0.4"
'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
Dim Shared cave(24, 6), caverunlimit, lightradius
Dim Shared phealth, pstamina, pwounds, ptemp, ppx, ppy, lastx, lasty
Dim cmap As _Unsigned Long
Dim ms As _Unsigned Long
cmap = _NewImage(800, 800, 32)
ms = _NewImage(800, 500, 32)
Screen ms
Print "Wandering In The Cave v0.4"
Print "By James D. Jarvis"
Print
Print "You must escape the cave."
Print
Print "Navigate with the numberpad or WASD"
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
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)
Randomize Timer
check$ = "off"
caverunlimit = 500
Do
_Limit 10
restartcaves:
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
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) < 6 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
PSet (xx, yy), krubble
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
Loop Until kk$ = " "
'Do
ecave = Int(6 + Rnd * 16)
exitX = cave(ecave, ctx)
exitY = cave(excave, 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)
lightradius = 9: pstamina = 100: phealth = 100: pwounds = 0: ptemp = 98
_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
Next
y = y + 1
Wend
Line (598, 18)-(795, 124), 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$
edd = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
o$ = "Distance to Exit " + Str$(edd)
_PrintString (600, 100), o$
Print "Turn", turn
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
turn = turn + 1
lastx = ppx
lasty = ppy
Select Case kk$
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 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 "; turns; " 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
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(Rnd * 10)
Case 1
PSet (x2, pcy + y), klava
Case 2, 3
PSet (x2, pcy + y), krock
Case 4, 5, 6, 7
PSet (x2, pcy + y), kfloor
Case 8, 9, 10
PSet (x2, pcy + y), krubble
End Select
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 SubRE: Wandering In The Cave - Pete - 09-26-2022
Thanks, I cave it a try. Please send search party.
Pete
RE: Wandering In The Cave - James D Jarvis - 09-26-2022
I usually die pretty quickly.
RE: Wandering In The Cave - James D Jarvis - 09-26-2022
version 0.5
added a little more terrain variation and gave it a tiny bit more visual pop. Added fungus and crystals.... crystals are just dangerous obstacles for now and the fungus is just eye candy but that shall change as features are added.
Code: (Select All)
'wandering in the cave
'By James D. Jarvis sept 26,2022
_Title "Wandering In The Cave v0.5"
'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
Dim cmap As _Unsigned Long
Dim ms As _Unsigned Long
cmap = _NewImage(800, 800, 32)
ms = _NewImage(800, 500, 32)
Screen ms
Print "Wandering In The Cave v0.5"
Print "By James D. Jarvis"
Print
Print "You must escape the cave."
Print
Print "Navigate with the numberpad or WASD"
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(excave, 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)
lightradius = 9: pstamina = 100: phealth = 100: pwounds = 0: ptemp = 98
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
Next
y = y + 1
Wend
Line (598, 18)-(795, 124), 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$
edd = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
o$ = "Distance to Exit " + Str$(edd)
_PrintString (600, 100), o$
Print "Turn", turn
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
turn = turn + 1
lastx = ppx
lasty = ppy
Select Case kk$
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 "; turns; " 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 climbe 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 SubRE: Wandering In The Cave - Pete - 09-26-2022
I lava good text game. Running low on rations. How's that search party coming along?
Pete
RE: Wandering In The Cave - James D Jarvis - 09-27-2022
version 0.5c
fixed a couple of bugs and prettied things up a little more.
Code: (Select All)
'wandering in the cave
'By James D. Jarvis sept 26,2022
_Title "Wandering In The Cave v0.5c"
'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
Dim cmap As _Unsigned Long
Dim ms As _Unsigned Long
cmap = _NewImage(800, 800, 32)
ms = _NewImage(800, 500, 32)
Screen ms
Print "Wandering In The Cave v0.5c"
Print "By James D. Jarvis"
Print
Print "You must escape the cave."
Print
Print "Navigate with the numberpad or WASD"
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
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, 124), 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$
edd = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
o$ = "Distance to Exit " + Str$(edd)
_PrintString (600, 100), o$
Print "Turn", turn
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
turn = turn + 1
lastx = ppx
lasty = ppy
Select Case kk$
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 SubRE: Wandering In The Cave - bplus - 09-27-2022
@Pete you are here only 304 to exit
Don't worry, Trump is raising money now...
RE: Wandering In The Cave - James D Jarvis - 09-27-2022
I've gotten out once without starting with the exit within the light radius. I've managed to die from hypothermia in the water a couple of times and I know how it's coded, the death spiral is brutal once it get's rolling.
RE: Wandering In The Cave - Pete - 09-27-2022
Good news and bad news. Good news is I found some vendors in the cave to buy food. Bad news, the prices are through the cave roof!
Bidenflation: The rising cost of voting stupidly!
Pete
RE: Wandering In The Cave - James D Jarvis - 09-27-2022
The prices the official vendors have are rock bottom but they aren't open right now, it really gravels me when people take advantage of others.