A mazing rat
#1
A lab rat in pursuit of cheese:
Code:
_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

W and H control number of cells in maze (width and height). See what happens when rat gets a couple hits of cheese.


B += x
Reply
#2
Why is there only one piece of cheeze?

Erik.
dndbbs project:

Links to my MUD: (strictly 16-bit); AKA XP:

Dndbbs executables
http://www.filegate.net/pdn/pdnbasic/dnd50a1e.zip

Dndbbs source
http://www.filegate.net/pdn/pdnbasic/dnd50a1s.zip

Dndbbs upgrade
http://www.filegate.net/pdn/pdnbasic/dnd50a1u.zip

DNDDOOR - https://bit.ly/EriksDNDDoor DUNGEON - https://bit.ly/EriksDungeon
Interpreter - https://bit.ly/EriksSICK Hex Editor - https://bit.ly/EriksHexEditor Utilities - https://bit.ly/EriksUtils
QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: - https://bit.ly/OldQB64
Reply
#3
Why do you feel there should be more?

Besides when it eats one, a new one appears and look how fat it's getting!
B += x
Reply
#4
Create multiple rat cheezes or you will become ratshit!!

(do it now)

Erik.
dndbbs project:

Links to my MUD: (strictly 16-bit); AKA XP:

Dndbbs executables
http://www.filegate.net/pdn/pdnbasic/dnd50a1e.zip

Dndbbs source
http://www.filegate.net/pdn/pdnbasic/dnd50a1s.zip

Dndbbs upgrade
http://www.filegate.net/pdn/pdnbasic/dnd50a1u.zip

DNDDOOR - https://bit.ly/EriksDNDDoor DUNGEON - https://bit.ly/EriksDungeon
Interpreter - https://bit.ly/EriksSICK Hex Editor - https://bit.ly/EriksHexEditor Utilities - https://bit.ly/EriksUtils
QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: - https://bit.ly/OldQB64
Reply
#5
(06-22-2018, 04:45 PM)eoredson Wrote: Create multiple rat cheezes or you will become ratshit!!

(do it now)

Erik.

Sounds rather harsh and threatening, yikes!

Maybe too many bugs, well this avatar is not getting seen at NET, so...



Multiple rat cheeses by way of Google:
https://www.google.com/search?q=multiple...45&bih=671

B += x
Reply
#6
Nice lab rat image: here's another:


Attached Files Thumbnail(s)

Image(s)

dndbbs project:

Links to my MUD: (strictly 16-bit); AKA XP:

Dndbbs executables
http://www.filegate.net/pdn/pdnbasic/dnd50a1e.zip

Dndbbs source
http://www.filegate.net/pdn/pdnbasic/dnd50a1s.zip

Dndbbs upgrade
http://www.filegate.net/pdn/pdnbasic/dnd50a1u.zip

DNDDOOR - https://bit.ly/EriksDNDDoor DUNGEON - https://bit.ly/EriksDungeon
Interpreter - https://bit.ly/EriksSICK Hex Editor - https://bit.ly/EriksHexEditor Utilities - https://bit.ly/EriksUtils
QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: - https://bit.ly/OldQB64
Reply
#7
Images of dissected rats:


Attached Files Image(s)

dndbbs project:

Links to my MUD: (strictly 16-bit); AKA XP:

Dndbbs executables
http://www.filegate.net/pdn/pdnbasic/dnd50a1e.zip

Dndbbs source
http://www.filegate.net/pdn/pdnbasic/dnd50a1s.zip

Dndbbs upgrade
http://www.filegate.net/pdn/pdnbasic/dnd50a1u.zip

DNDDOOR - https://bit.ly/EriksDNDDoor DUNGEON - https://bit.ly/EriksDungeon
Interpreter - https://bit.ly/EriksSICK Hex Editor - https://bit.ly/EriksHexEditor Utilities - https://bit.ly/EriksUtils
QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: - https://bit.ly/OldQB64
Reply
#8
I am remembering rat finks! I remember one birthday being loaded up with camping gear (my parents fantasy of getting rid of me for summer) and all I cared about was a stupid little rat fink toy.

Erik, I think you would like my eRATication game.
B += x
Reply