May 31, 2020, 05:17:42 PM

Author Topic: Escape from Monster Maze #3 (QB64)  (Read 539 times)

Offline bplus

  • Full Member
  • ***
  • Posts: 134
Escape from Monster Maze #3 (QB64)
« on: November 14, 2019, 03:41:34 PM »
Without comments < 400 loc, I'd say (but I have to add code for drawing a filled circle!) :
Code: [Select]
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

'2019-09-06 3A remove newMonster call when they bump

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
        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

Screenshot from normal Escape MM #3 and another of a novelty version:

Offline Qube

  • Administrator
  • Hero Member
  • *****
  • Posts: 2373
Re: Escape from Monster Maze #3 (QB64)
« Reply #1 on: November 14, 2019, 11:35:15 PM »
He he, that's pretty cool and in Quick BASIC too ;D
Until the next time...

Offline bplus

  • Full Member
  • ***
  • Posts: 134
Re: Escape from Monster Maze #3 (QB64)
« Reply #2 on: November 15, 2019, 03:32:00 AM »
Hey thanks Qube, yeah what do ya' know QB, but QB64 is not like from '84 although the IDE may look ancient and the file menu is ancient but... I don't know... guess I am spoiled by that syntax checking and automatic formatting, though I miss GW Basic's "OK" after each enter key press, so reassuring... :)

Hey check this out: https://www.syntaxbomb.com/index.php/topic,6516.0.html

Offline Steve Elliott

  • Hero Member
  • *****
  • Posts: 2454
Re: Escape from Monster Maze #3 (QB64)
« Reply #3 on: November 15, 2019, 04:53:49 AM »
Nice.  And any maze related code is cool around these parts at the moment.   :D
Windows 10, 64-bit, 16Gb RAM, CPU Intel i5, 3.2 GHz, Nvidia GeForce GTX 1050 (2Gb).
MacOS Catalina, 64-bit, 8Gb RAM, CPU Intel i5, 2.3 Ghz, Intel Iris Plus Graphics 640 1536 MB.
Linux Mint 19.3, 64-bit, 16Gb RAM, CPU Intel i5, 3.2 GHz, Nvidia GeForce GTX 1050 (2Gb).
Raspberry pi 3 and 4.

Offline bplus

  • Full Member
  • ***
  • Posts: 134
Re: Escape from Monster Maze #3 (QB64)
« Reply #4 on: November 15, 2019, 03:18:48 PM »
Nice.  And any maze related code is cool around these parts at the moment.   :D

Hmm... I have a mouse with a tiny little savant AI that always finds the cheese in a maze such as the above...
Maybe I can find it if it hasn't escaped Windows OS yet :D

Trapped here: https://www.syntaxbomb.com/index.php/topic,6519.0.html

 

SimplePortal 2.3.6 © 2008-2014, SimplePortal