Posts: 3,982
Threads: 178
Joined: Apr 2022
Reputation:
220
Code: (Select All) _Title "Amazing rat B+ trans 2018-06-15"
'from SmallBASIC to QB64 version 2017 1106/82 (the day before they switched to version 1.2)
'2018-06-15 added more fun!
'rat runs whole maze.bas for SmallBASIC 0.12.6 [B+MGA] 2016-06-30
' mod of Chris maze gererator post
' Backtracking maze generator
' https://en.wikipedia.org/wiki/Maze_generation_algorithm
'
' - Starting from a random cell,
' - Selects a random neighbouring cell that has not been visited.
' - Remove the wall between the two cells and marks the new cell as visited,
' and adds it to the stack to facilitate backtracking.
' - Continues with a cell that has no unvisited neighbours being considered a dead-end.
' When at a dead-end it backtracks through the path until it reaches a cell with an
' unvisited neighbour, continuing the path generation by visiting this new,
' unvisited cell (creating a new junction).
' This process continues until every cell has been visited, backtracking all the
' way back to the beginning cell. We can be sure every cell is visited.
'
' model consts
Const xmax = 1200
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
Const W = 48
Const H = 28
Const margin = 25
Const border = margin / 2
Type cell
x As Integer
y As Integer
End Type
Dim Shared cellW
cellW = (xmax - margin) / W
Dim Shared cellH
cellH = (ymax - margin) / H
Dim Shared h_walls(W, H)
Dim Shared v_walls(W, H)
Dim Shared pi
pi = _Pi
' What's a maze without a little white mouse
Randomize Timer
init_walls
generate_maze
rX = 0: rY = 0: rd = 180
Dim trail As cell
ti = 0
cheese = 0
chx = Int(Rnd * (W - 1)) + 1
chy = Int(Rnd * (H - 1)) + 1
While 1
'maze board
Color _RGB32(155, 75, 32)
recf 0, 0, xmax, ymax
show_maze
'add to trail
ti = ti + 1
ReDim _Preserve trail(ti) As cell
trail(ti).x = border + (rX + .5) * cellW
trail(ti).y = border + (rY + .5) * cellH
'bread crumbs or whatever...
Color _RGBA(8, 4, 2, 40)
For i = 1 To ti
fcirc trail(i).x, trail(i).y, 2
Next
'draw cheese
Color _RGB32(200, 180, 0)
fcirc border + (chx + .5) * cellW, border + (chy + .5) * cellH, .25 * cellH
'draw mouse
drawRat border + rX * cellW, border + rY * cellH, cellW, cellH, rd, cheese
'mouse find the cheese?
If rX = chx And rY = chy Then
cheese = cheese + 1
chx = Int(Rnd * (W - 1)) + 1
chy = Int(Rnd * (H - 1)) + 1
ti = 0
ReDim trail(ti) As cell
_Delay 1
End If
_Display
_Delay .2
'setup next move
Select Case rd
Case 0
If h_walls(rX, rY + 1) = 0 Then
rY = rY + 1: rd = 90
ElseIf v_walls(rX + 1, rY) = 0 Then
rX = rX + 1
ElseIf h_walls(rX, rY) = 0 Then
rY = rY - 1: rd = 270
Else
rX = rX - 1: rd = 180
End If
Case 90
If v_walls(rX, rY) = 0 Then
rX = rX - 1: rd = 180
ElseIf h_walls(rX, rY + 1) = 0 Then
rY = rY + 1
ElseIf v_walls(rX + 1, rY) = 0 Then
rX = rX + 1: rd = 0
Else
rY = rY - 1: rd = 270
End If
Case 180
If h_walls(rX, rY) = 0 Then
rY = rY - 1: rd = 270
ElseIf v_walls(rX, rY) = 0 Then
rX = rX - 1
ElseIf h_walls(rX, rY + 1) = 0 Then
rY = rY + 1: rd = 90
Else
rX = rX + 1: rd = 0
End If
Case 270
If v_walls(rX + 1, rY) = 0 Then
rX = rX + 1: rd = 0
ElseIf h_walls(rX, rY) = 0 Then
rY = rY - 1
ElseIf v_walls(rX, rY) = 0 Then
rX = rX - 1: rd = 180
Else
rY = rY + 1: rd = 90
End If
End Select
Wend
Sub init_walls ()
For x = 0 To W
For y = 0 To H
v_walls(x, y) = 1
h_walls(x, y) = 1
Next
Next
End Sub
Sub show_maze ()
Color _RGB32(180, 90, 45)
'cls
py = border
For y = 0 To H
px = border
For x = 0 To W
If x < W And h_walls(x, y) = 1 Then
recf px, py, px + cellW, py + 2
End If
If y < H And v_walls(x, y) = 1 Then
recf px, py, px + 2, py + cellH
End If
px = px + cellW
Next
py = py + cellH
Next
End Sub
Sub rand_cell (rWx, rHy)
rWx = Int(Rnd * 1000) Mod W
rHy = Int(Rnd * 1000) Mod H
End Sub
Sub get_unvisited (visited(), current As cell, unvisited() As cell, uvi)
'local n
ReDim unvisited(0) As cell
x = current.x
y = current.y
uvi = 0
If x > 0 Then
If visited(x - 1, y) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x - 1
unvisited(uvi).y = y
End If
End If
If x < W - 1 Then
If visited(x + 1, y) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x + 1
unvisited(uvi).y = y
End If
End If
If y > 0 Then
If visited(x, y - 1) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x
unvisited(uvi).y = y - 1
End If
End If
If y < H - 1 Then
If visited(x, y + 1) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x
unvisited(uvi).y = y + 1
End If
End If
End Sub
Sub generate_maze ()
'local curr_cell, next_cell, num_visited, num_cells, visited, stack, cells
'local x, y
Dim visited(W, H)
ReDim stack(0) As cell
Dim curr_cell As cell
Dim next_cell As cell
rand_cell cur_cell.x, cur_cell.y
visited(curr_cell.x, curr_cell.y) = 1
num_visited = 1
num_cells = W * H
si = 0
While num_visited < num_cells
ReDim cells(0) As cell
cnt = 0
get_unvisited visited(), curr_cell, cells(), cnt
If cnt > 0 Then
' choose randomly one of the current cell's unvisited neighbours
rc = Int(Rnd * 100) Mod cnt + 1
next_cell.x = cells(rc).x
next_cell.y = cells(rc).y
' push the current cell to the stack
si = si + 1
ReDim _Preserve stack(si) As cell
stack(si).x = curr_cell.x
stack(si).y = curr_cell.y
' remove the wall between the current cell and the chosen cell
If next_cell.x = curr_cell.x Then
x = next_cell.x
y = max(next_cell.y, curr_cell.y)
h_walls(x, y) = 0
Else
x = max(next_cell.x, curr_cell.x)
y = next_cell.y
v_walls(x, y) = 0
End If
' make the chosen cell the current cell and mark it as visited
curr_cell.x = next_cell.x
curr_cell.y = next_cell.y
visited(curr_cell.x, curr_cell.y) = 1
num_visited = num_visited + 1
ElseIf si > 0 Then
' pop a cell from the stack and make it the current cell
curr_cell.x = stack(si).x
curr_cell.y = stack(si).y
si = si - 1
ReDim _Preserve stack(si) As cell
Else
Exit While
End If
Wend
End Sub
Sub drawRat (leftX, topY, cwidth, cheight, heading, cheese)
Color _RGB32(225, 225, 225)
'local bcX, bcY, bR, neckX, neckY
bcX = leftX + .5 * cwidth
bcY = topY + .5 * cheight
bR = .5 * .5 * min(cwidth, cheight)
'local noseX :
noseX = bcX + 2 * bR * Cos(rad(heading))
'local noseY :
noseY = bcY + 2 * bR * Sin(rad(heading))
neckX = bcX + .75 * bR * Cos(rad(heading))
neckY = bcY + .75 * bR * Sin(rad(heading))
'local tailX :
tailX = bcX + 2 * bR * Cos(rad(heading + 180))
'local tailY :
tailY = bcY + 2 * bR * Sin(rad(heading + 180))
'local earLX :
earLX = bcX + bR * Cos(rad(heading - 30))
'local earLY :
earLY = bcY + bR * Sin(rad(heading - 30))
'local earRX :
earRX = bcX + bR * Cos(rad(heading + 30))
'local earRY :
earRY = bcY + bR * Sin(rad(heading + 30))
fcirc bcX, bcY, .65 * bR + 2 * cheese
fcirc neckX, neckY, bR * .3
ftri noseX, noseY, earLX, earLY, earRX, earRY, _RGB32(225, 225, 225)
fcirc earLX, earLY, bR * .3
fcirc earRX, earRY, bR * .3
wX = .7 * bR * Cos(rad(heading - 90 - 20))
wY = .7 * bR * Sin(rad(heading - 90 - 20))
ln noseX + wX, noseY + wY, noseX - wX, noseY - wY
wX = .7 * bR * Cos(rad(heading - 90 + 20))
wY = .7 * bR * Sin(rad(heading - 90 + 20))
ln noseX + wX, noseY + wY, noseX - wX, noseY - wY
ln bcX, bcY, tailX, tailY
End Sub
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
' found at QB64.net: http://www.qb64.net/forum/index.php?topic=14425.0
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest 0
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Sub ln (x1, y1, x2, y2)
Line (x1, y1)-(x2, y2)
End Sub
Sub rec (x1, y1, x2, y2)
Line (x1, y1)-(x2, y2), , B
End Sub
Sub recf (x1, y1, x2, y2)
Line (x1, y1)-(x2, y2), , BF
End Sub
Function max (a, b)
If a > b Then max = a Else max = b
End Function
Function min (a, b)
If a > b Then min = b Else min = a
End Function
Function rad (a)
rad = a * pi / 180
End Function
when this rat finally finds the cheese it grows bigger and heads out again for another bite
b = b + ...
Posts: 3,982
Threads: 178
Joined: Apr 2022
Reputation:
220
Escape from Monster Maze
Code: (Select All) Option _Explicit
_Title "Escape from Monster Maze 3" 'B+ 2019-09-04
' 2019-08-31 attempt a better, smoother mouser
' 2019-09-03 Maze geneartion, nice mouse and arrow key action,
' momentum removed, just cant turn corners that fast.
' 2019-09-03 Troubles
' I either have to loose arrow keys or deactivate mouse or something
' so arrow key presses are defeated by mouse presence. :-P
' and still not 100% happy with mouse action. ;(
' I kicked out walls randomly several for each new monster but not effective for creating
' alternate paths when dang monsters are ganging up at upper left corner, yikes! no escape!!!
' to fix that
' 1. lay out another generated maze over top of current that will create meaningfull alternate route
' 2. relocate monsters when my guy gets back to start!
' Ok I fixed it so if you start using arrow keys the mouse is disabled for 3 seconds from last arrow press
' using Luke's time stamp. This way the mouse position wont counteract arrow key presses.
' HEY I think XOR smoothed out the mouse action a tiny bit!!! and so did opening up angles
' directions from mouse to full 90 degrees around 0, 90, 180, 270.
'2019-09-04 could have monsters follow one direction until blocked flip a coin and go on
' really want mouse smoother
' Oh dang did not have wallThk update! fixed
' OK my guy can cut corners now!!!
'2019-09-05 Escape From Monster Maze 3:
' I have another idea that will greatly simplify the mouse corner moves
' AND display step by step, no diagonal skips so all moves remain rectilinear.
' This version removes more walls because monsters can block only way through
' and goal tend either top left or bottom right critical cells.
'
'2 subs for my toolbox yCP - printing center alignment at pixel y row
' cSleep - wait for keypress or Mouse Click
Declare Library 'give Lukes' timesstamp function a test drive!
Function time& (ByVal null&)
End Declare
Const xmax = 700, ymax = 700 'screen
Const W = 15, H = 15, border = 50, wallThk = 2 'maze cells wide and high
Const mazeClr = &HFFFF8800
Const mDelay = 6 'slow monsters down so I can speed up limit for loops for mouse moving player
Type cell
x As Integer
y As Integer
End Type
Type monsterType
x As Integer
y As Integer
dir As Integer
delay As Integer
face As Integer
End Type
Dim Shared cellW As Single, cellH As Single, h_walls(W, H) As Integer, v_walls(W, H) As Integer
cellW = (xmax - 2 * border) / W
cellH = (ymax - 2 * border) / H
Dim Shared stopTime&, nMonsters As Integer
ReDim Shared m(1 To 1) As monsterType
' Locals for Main module code
Dim px As Integer, py As Integer, mx As Integer, my As Integer, dx As Integer, dy As Integer
Dim adx As Integer, ady As Integer
Dim k$, d, start, i, j, test As cell, tmp As Long
Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
nMonsters = 3
Do
init_walls
generate_maze
'open gate a bottom right corner to esacpe
h_walls(W - 1, H) = 0
nMonsters = nMonsters + 1
ReDim m(1 To nMonsters) As monsterType
For i = 1 To nMonsters
newMonster (i)
For j = 1 To 2 'for every monster make 4 escape hatches
test.x = Int(Rnd * (W - 2)) + 1: test.y = Int(Rnd * (H - 2)) + 1
While h_walls(test.x, test.y) = 0
test.x = Int(Rnd * (W - 2)) + 1: test.y = Int(Rnd * (H - 2)) + 1
Wend
h_walls(test.x, test.y) = 0
test.x = Int(Rnd * (W - 2)) + 1: test.y = Int(Rnd * (H - 2)) + 1
While v_walls(test.x, test.y) = 0
test.x = Int(Rnd * (W - 2)) + 1: test.y = Int(Rnd * (H - 2)) + 1
Wend
v_walls(test.x, test.y) = 0
Next
Next
px = 0: py = 0: start = Timer
While 1
Cls
show_maze
For i = 1 To nMonsters
If m(i).delay Mod 4 = 0 Then m(i).face = 1 - m(i).face 'toggle face
If m(i).face = 1 Then
monster1 (m(i).x + .5) * cellW + border, (m(i).y + .5) * cellH + border
Else
monster2 (m(i).x + .5) * cellW + border, (m(i).y + .5) * cellH + border
End If
m(i).delay = m(i).delay - 1
If m(i).delay = 0 Then
m(i).delay = mDelay
If moveOK(m(i).x, m(i).y, m(i).dir) And Rnd < .5 Then 'most of time monsters on momentum
move m(i).x, m(i).y, m(i).dir
Else
d = Int(Rnd * 4) + 1
While moveOK(m(i).x, m(i).y, d) = 0
d = Int(Rnd * 4) + 1
Wend
move m(i).x, m(i).y, d
m(i).dir = d
End If 'move OK
If m(i).x = px And m(i).y = py Then
makeFace (px + .5) * cellW + border, (py + .5) * cellH + border, 1
_Display
_Delay 1
px = 0: py = 0
End If 'intersect my guy
If (m(i).x = W - 1 And m(i).y = H - 1) Or (m(i).x = 0 And m(i).y = 0) Then newMonster i
End If 'monster delay
'FOR j = 1 TO nMonsters
' IF j <> i AND m(j).x = m(i).x AND m(j).y = m(i).y THEN newMonster i
'NEXT
Next
If mouseOK(0) = -1 Then 'might not need this?
While _MouseInput: Wend
mx = Int((_MouseX - border) / cellW) 'convert to maze cell
my = Int((_MouseY - border) / cellH)
dx = mx - px: dy = my - py ' dist in cells of mouse to player
If dx < 0 Then dx = -1: If dy < 0 Then dy = -1 ' one step at a time
If dx > 0 Then dx = 1: If dy > 0 Then dy = 1
adx = Abs(dx): ady = Abs(dy) ' which is bigger difference = priority move
If dx = -1 Then
If dy = -1 Then
If adx > ady Then
If moveOK(px, py, 4) Then move px, py, 4
Else
If moveOK(px, py, 1) Then move px, py, 1
End If
ElseIf dy = 0 Then
If moveOK(px, py, 4) Then move px, py, 4
ElseIf dy = 1 Then
If adx > ady Then
If moveOK(px, py, 4) Then move px, py, 4
Else
If moveOK(px, py, 2) Then move px, py, 2
End If
End If
ElseIf dx = 0 Then
If dy = -1 Then
If moveOK(px, py, 1) Then move px, py, 1
ElseIf dy = 1 Then
If moveOK(px, py, 2) Then move px, py, 2
End If
ElseIf dx = 1 Then
If dy = -1 Then
If adx > ady Then
If moveOK(px, py, 3) Then move px, py, 3
Else
If moveOK(px, py, 1) Then move px, py, 1
End If
ElseIf dy = 0 Then
If moveOK(px, py, 3) Then move px, py, 3
ElseIf dy = 1 Then
If adx > ady Then
If moveOK(px, py, 3) Then move px, py, 3
Else
If moveOK(px, py, 2) Then move px, py, 2
End If
End If
End If
End If
k$ = InKey$ 'key press takes precedence over mouse
If Len(k$) = 2 Then
Select Case Asc(k$, 2) 'turn off mouse control for 3 secs after arrow press
Case 72: tmp = mouseOK(1): If moveOK(px, py, 1) Then move px, py, 1 'up
Case 80: tmp = mouseOK(1): If moveOK(px, py, 2) Then move px, py, 2 'down
Case 77: tmp = mouseOK(1): If moveOK(px, py, 3) Then move px, py, 3 'right
Case 75: tmp = mouseOK(1): If moveOK(px, py, 4) Then move px, py, 4 'left
End Select
End If
makeFace (px + .5) * cellW + border, (py + .5) * cellH + border, 0
yCP 20, Str$(nMonsters) + " Monsters " + Str$((Timer - start) \ 1) + " Secs"
_Display
_Limit 30
If px = W - 1 And py = H Then Exit While
Wend
yCP ymax - 20, "You escaped in" + Str$((Timer - start) \ 1) + " secs, click to continue..."
_Display
cSleep
Loop
Sub move (x As Integer, y As Integer, direction As Integer)
Select Case direction
Case 1: y = y - 1
Case 2: y = y + 1
Case 3: x = x + 1
Case 4: x = x - 1
End Select
End Sub
Function moveOK% (curX As Integer, curY As Integer, direction As Integer)
' is the way blocked or even inside maze, assuming move is not OK
' _____ ________
' |x, y |x+1, y the walls of the cell x, y are at right and above,
' ________ x+1 has the next wall and y+1 is the next horizontal separator
' |x, y+1
Select Case direction
Case 1 'up
If curY - 1 >= 0 Then
If h_walls(curX, curY) = 0 Then moveOK = -1
End If
Case 2 'down
If curY + 1 <= H Then ' OR (curX = W - 1 AND curY = H - 1) THEN 'let through gate bottom right corner
If h_walls(curX, curY + 1) = 0 Then moveOK = -1
End If
Case 3 'right
If curX + 1 <= W - 1 Then
If v_walls(curX + 1, curY) = 0 Then moveOK = -1
End If
Case 4 'left
If curX - 1 >= 0 Then
If v_walls(curX, curY) = 0 Then moveOK = -1
End If
End Select
End Function
Function mouseOK% (mode%) '1 set, 0 checks if time is up yes -1, no 0
If mode% > 0 Then 'set
stopTime& = timestamp& + 3 '3 secs before mouse access
Else
If timestamp& - stopTime& > 0 Then mouseOK% = -1 Else mouseOK% = 0
End If
End Function
Function timestamp& 'try Luke's Timestamp for checking times
timestamp& = time&(0)
End Function
Sub makeFace (x, y, white)
If white Then fcirc x, y, cellW / 3, &HFF994422 Else fcirc x, y, cellW / 3, &HFF88AAFF
fcirc x - 3 * cellW / 24, y, cellW / 14, &HFFFFFFFF
fcirc x + 3 * cellW / 24, y, cellW / 14, &HFFFFFFFF
fcirc x - 3 * cellW / 24, y + 1, cellW / 28, &HFF000000
fcirc x + 3 * cellW / 24, y + 1, cellW / 28, &HFF000000
Line (x - cellW / 12, y + cellW / 6)-Step(cellW / 6, 2), &HFFFF4444, BF
End Sub
Sub newMonster (i As Integer)
Dim x As Integer, y As Integer, j As Integer
restart:
x = Rnd * 7 * W / 8 + W / 8 - 1: y = Rnd * 7 * H / 8 + H / 8 - 1
For j = 1 To nMonsters
If j <> i And m(j).x = x And m(j).y = y Then GoTo restart
Next
m(i).x = x: m(i).y = y
m(i).dir = Int(Rnd * 4) + 1
m(i).delay = Int(Rnd * 8) + 1
m(i).face = Int(Rnd * 2)
End Sub
Sub monster1 (x, y)
fcirc x, y, cellW / 2.5, &HFF990000
Line (x - cellW / 6, y - 2)-Step(cellW / 18, 1), &HFF000000, BF
Line (x + cellW / 12, y - 2)-Step(cellW / 18, 1), &HFF000000, BF
Line (x - cellW / 12, y + cellW / 6)-Step(cellW / 6, 2), &HFF000000, BF
End Sub
Sub monster2 (x, y)
fcirc x, y, cellW / 2.5, &HFF990000
Line (x - cellW / 6, y - 6)-Step(cellW / 18, 1), &HFF000000, BF
Line (x + cellW / 12, y - 6)-Step(cellW / 18, 1), &HFF000000, BF
fcirc x, y + cellW / 6, cellW / 6, &HFF000000
End Sub
Sub cSleep 'wait for keypress or mouseclick
Dim wayt
wayt = 1
While wayt
While _MouseInput: Wend
If _MouseButton(1) Then wayt = 0
If Len(InKey$) Then wayt = 0
Wend
End Sub
Sub yCP (y, s$) 'for xmax pixel wide graphics screen
_PrintString ((_Width - Len(s$) * 8) / 2, y), s$
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
' From SmallBASIC code written by Chris WS developer
' Backtracking maze generator by chrisws 2016-06-30 now found at
' https://github.com/smallbasic/smallbasic.github.io/blob/5601c8bc1d794c5b143d863555bb7c15a5966a3c/samples/node/1623.bas
'
' Chris notes:
' https://en.wikipedia.org/wiki/Maze_generation_algorithm
' - Starting from a random cell,
' - Selects a random neighbouring cell that has not been visited.
' - Remove the wall between the two cells and marks the new cell as visited,
' and adds it to the stack to facilitate backtracking.
' - Continues with a cell that has no unvisited neighbours being considered a dead-end.
' When at a dead-end it backtracks through the path until it reaches a cell with an
' unvisited neighbour, continuing the path generation by visiting this new,
' unvisited cell (creating a new junction).
' This process continues until every cell has been visited, backtracking all the
' way back to the beginning cell. We can be sure every cell is visited.
Sub init_walls ()
Dim x As Integer, y As Integer
For x = 0 To W
For y = 0 To H
v_walls(x, y) = 1
h_walls(x, y) = 1
Next
Next
End Sub
Sub show_maze ()
Dim py As Single, px As Single, y As Integer, x As Integer
py = border
For y = 0 To H
px = border
For x = 0 To W
If x < W And h_walls(x, y) = 1 Then
Line (px, py)-Step(cellW + wallThk, wallThk), mazeClr, BF
End If
If y < H And v_walls(x, y) = 1 Then
Line (px, py)-Step(wallThk, cellH + wallThk), mazeClr, BF
End If
px = px + cellW
Next
py = py + cellH
Next
End Sub
Sub rand_cell (rWx, rHy)
rWx = Int(Rnd * 1000) Mod W: rHy = Int(Rnd * 1000) Mod H
End Sub
Sub get_unvisited (visited() As Integer, current As cell, unvisited() As cell, uvi As Integer)
ReDim unvisited(0) As cell
Dim x As Integer, y As Integer
x = current.x: y = current.y: uvi = 0
If x > 0 Then
If visited(x - 1, y) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x - 1: unvisited(uvi).y = y
End If
End If
If x < W - 1 Then
If visited(x + 1, y) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x + 1: unvisited(uvi).y = y
End If
End If
If y > 0 Then
If visited(x, y - 1) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x: unvisited(uvi).y = y - 1
End If
End If
If y < H - 1 Then
If visited(x, y + 1) = 0 Then
uvi = uvi + 1
ReDim _Preserve unvisited(uvi) As cell
unvisited(uvi).x = x: unvisited(uvi).y = y + 1
End If
End If
End Sub
Sub generate_maze ()
Dim visited(W, H) As Integer
Dim num_visited As Integer, num_cells As Integer, si As Integer
Dim cnt As Integer, rc As Integer, x As Integer, y As Integer
ReDim stack(0) As cell
Dim curr_cell As cell, next_cell As cell, cur_cell As cell
rand_cell cur_cell.x, cur_cell.y
visited(curr_cell.x, curr_cell.y) = 1
num_visited = 1: num_cells = W * H: si = 0
While num_visited < num_cells
ReDim cells(0) As cell
cnt = 0
get_unvisited visited(), curr_cell, cells(), cnt
If cnt > 0 Then
' choose randomly one of the current cell's unvisited neighbours
rc = Int(Rnd * 100) Mod cnt + 1
next_cell.x = cells(rc).x: next_cell.y = cells(rc).y
' push the current cell to the stack
si = si + 1
ReDim _Preserve stack(si) As cell
stack(si).x = curr_cell.x: stack(si).y = curr_cell.y
' remove the wall between the current cell and the chosen cell
If next_cell.x = curr_cell.x Then
x = next_cell.x: y = max(next_cell.y, curr_cell.y)
h_walls(x, y) = 0
Else
x = max(next_cell.x, curr_cell.x): y = next_cell.y
v_walls(x, y) = 0
End If
' make the chosen cell the current cell and mark it as visited
curr_cell.x = next_cell.x: curr_cell.y = next_cell.y
visited(curr_cell.x, curr_cell.y) = 1
num_visited = num_visited + 1
ElseIf si > 0 Then
' pop a cell from the stack and make it the current cell
curr_cell.x = stack(si).x: curr_cell.y = stack(si).y
si = si - 1
ReDim _Preserve stack(si) As cell
Else
Exit While
End If
Wend
End Sub
Function max (a, b)
If a > b Then max = a Else max = b
End Function
b = b + ...
Posts: 733
Threads: 103
Joined: Apr 2022
Reputation:
14
(06-18-2024, 12:50 AM)bplus Wrote: Escape from Monster Maze
These are great starters for games and for learning how these kinds of programs work - thanks!
There's a rat program from the 60s I've been looking for, the "amazing rat" might be it.
I'll have to find the article on it and let you know what it was.
Thanks again - will play with this more soon.
|
