Amazing Rat (QB64)

[bplus]

It backtracks allot but it always finds the cheese:

Code Select Expand


_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 = 64
CONST H = 48
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


It leaves a trail of... screen shot 1 BTW the ... are alpha colored so areas of path where it back tracked are darker. I've seen videos on YouTube where AI's compete to run a given maze 3x's and are expected to improve each run for fastest time. (The mice are robots in a real room sized maze, it is like a gladiator's arena.)

Also it grows fat!... screen shot 2 after a couple of cheese feasts.