Amazing Rat

[bplus]

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