Author Topic: Amazing Rat (Read 7166 times)

bplus · « **on:** June 15, 2018, 04:52:00 pm »

Here is some RI (Rodent Intelligence):

Code: QB64: [Select]

_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 with out 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 [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]:    http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/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
 

Ashish · « **Reply #1 on:** June 16, 2018, 03:50:34 am »

Hi bplus! Which pathfinding algorithm does the program uses? I see some here - https://en.wikipedia.org/wiki/Pathfinding

johnno56 · « **Reply #2 on:** June 16, 2018, 07:57:27 am »

Very cool. Could be used as a type of screensaver... Almost hypnotic... Almost felt like cheering for the mouse... until I remembered that mice are rodents... I watched until the mouse had navigated about half of the maze and figured it would probably die of starvation before it found the cheese... Mesmerizing entertainment... One odd side effect... After terminating the program I developed a hankering for Swiss cheese....

bplus · « **Reply #3 on:** June 16, 2018, 10:15:10 am »

Quote from: Ashish on June 16, 2018, 03:50:34 am

Hi bplus! Which pathfinding algorithm does the program uses? I see some here - https://en.wikipedia.org/wiki/Pathfinding

I used the Greek method of removing oneself from a maze, it is completely brainless in that it requires 0 memory (well you do have to remember the trick), study the pattern of turns in the main routine.

The maze itself is guaranteed to be accessible to any cell. So the cheese can be put anywhere and the mouse will get to it, eventually... but you have to wait longer than Johnno. ;-))

bplus · « **Reply #4 on:** June 16, 2018, 10:17:29 am »

Quote from: johnno56 on June 16, 2018, 07:57:27 am

Very cool. Could be used as a type of screensaver... Almost hypnotic... Almost felt like cheering for the mouse... until I remembered that mice are rodents... I watched until the mouse had navigated about half of the maze and figured it would probably die of starvation before it found the cheese... Mesmerizing entertainment... One odd side effect... After terminating the program I developed a hankering for Swiss cheese....

Dang Johnno, you missed the best part. What happens when the mouse does get the cheese and again and again... :P

Oh hey! Johnno if you drank too much coffee and can't wait so long, set W and H to less cells. That's how I tested the code.

BTW, if you don't like rats, have I got an app for you!

bplus · « **Reply #5 on:** June 16, 2018, 11:59:40 am »

Here is 12x 7 with a couple of cheese hits:

Ashish · « **Reply #6 on:** June 16, 2018, 12:25:25 pm »

Quote from: bplus on June 16, 2018, 10:15:10 am

Quote from: Ashish on June 16, 2018, 03:50:34 am
Hi bplus! Which pathfinding algorithm does the program uses? I see some here - https://en.wikipedia.org/wiki/Pathfinding
I used the Greek method of removing oneself from a maze, it is completely brainless in that it requires 0 memory (well you do have to remember the trick), study the pattern of turns in the main routine.

If that is completely brainless then how this is rodent intelligence ❓❓

bplus · « **Reply #7 on:** June 16, 2018, 12:44:05 pm »

How is AI intelligent? That is truly brainless.

_vince · « **Reply #8 on:** June 16, 2018, 01:05:59 pm »

Nice one, bplus, i like the dots. Needs a scary serpent in there as well.

bplus · « **Reply #9 on:** June 16, 2018, 01:06:47 pm »

I was thinking Pac Rat!

TempodiBasic · « **Reply #10 on:** June 16, 2018, 03:19:47 pm »

Hi Bplus
Yes Pac Rat... but for its mode to eat cheese I should say Pac Boa Rat :-)
Fine the algorithm of binary choose preferring for first the right side.

bplus · « **Reply #11 on:** June 16, 2018, 08:23:40 pm »

Oh hey! How about a version of the snake game with a moving target!

Append: No? a snake can't back up, it would have to be played above the mouse tunnels. Still a moving target would be a twist.

Petr · « **Reply #12 on:** June 17, 2018, 05:08:48 am »

I like it, Bplus :-D

News:

Author Topic: Amazing Rat (Read 7166 times)

bplus

Amazing Rat

Ashish

Re: Amazing Rat

johnno56

Re: Amazing Rat

bplus

Re: Amazing Rat

bplus

Re: Amazing Rat

bplus

Re: Amazing Rat

Ashish

Re: Amazing Rat

bplus

Re: Amazing Rat

_vince

Re: Amazing Rat

bplus

Re: Amazing Rat

TempodiBasic

Re: Amazing Rat

bplus

Re: Amazing Rat

Petr

Re: Amazing Rat