Hex_Maze

[James D Jarvis]

This is Hex_Maze version 0B. It generates a crude labyrinth using hexes as cells as opposed to a standard orthogonal square grid.
There are a couple subs in it that don't get used in this run but would prove useful in using the hex-grid in a program.


 

Code: (Select All)

'hex_maze
'by James D. Jarvis   Mar. 14,2023
' geneate a haex "maze" in a hex grid as opposed to a more standard orthogonal square grid
'generates a new hexmaze on a keypress press q to exit
Screen _NewImage(1100, 600, 32)
_FullScreen _SquarePixels , _Smooth
Randomize Timer
Dim Shared hexradius
Dim Shared hexborder As _Unsigned Long
hexborder = _RGB32(100, 100, 100)
hexradius = 8 'can be any value but draws cleaner if radius is evenly divisible by 4
maxx = 80: maxy = 40 'maxx is the maxximum number  of columns    and maxy is the maximum height of a column
Dim Shared map(maxx, maxy)
Dim Shared hgrid(0 To maxx + 1, 0 To maxy + 1, 6)
Do
    Cls
    For y = 1 To maxy
        For x = 1 To maxx
            map(x, y) = 1
        Next x
    Next y

    sx = Int(maxx / 5 + Rnd * maxx / 2)
    sy = Int(maxy / 5 + Rnd * maxy / 2)
    'map(sx, sy) = 0
    lastgo = Int(1 + Rnd * 6)
    c = 0
    clim = 600 + Int((1 + Rnd * 4) * (Rnd * (maxx + maxy))) 'determine how many hex cells will be dug for this hex maze   haven't found an ideal ratio yet
    hrun = 7
    lasthrun = Int(1 + Rnd * 3)
    Do
        'generate hex maze with a drunken wanderer method. Not a true maze but it will work for a shoot-n-scoot or a roguelike
        dgo = Int(1 + Rnd * 8) 'generate direction to send the tunnel
        hrun = Int(1 + Rnd * (2 + Sqr(maxy))) 'generate a length  for the tunnel being dug
        If hrun > Sqr(maxy) Then hrun = lasthrun
        If sx = 2 And dgo = 5 Then dgo = 3
        If sx = 2 And dgo = 6 Then dgo = 2
        If dgo > 6 Then dgo = lastgo
        For hgo = 1 To hrun
            Select Case dgo
                Case 1
                    If sy - 1 > 1 Then
                        sy = sy - 1
                    End If
                Case 2
                    If sx + 1 < maxx Then
                        If sx Mod 2 Then
                            If sy - 1 > 1 Then
                                sx = sx + 1
                                sy = sy - 1
                            End If
                        Else
                            sx = sx + 1
                        End If
                    End If
                Case 3
                    If sx + 1 < maxx Then
                        If sx Mod 2 Then
                            sx = sx + 1
                        Else
                            If sy + 1 < (maxy - 1) Then
                                sx = sx + 1
                                sy = sy + 1
                            End If
                        End If
                    End If
                Case 4
                    If sy + 1 < maxy Then
                        sy = sy + 1
                    End If
                Case 5
                    If sx - 1 > 1 Then
                        If sx Mod 2 Then
                            If sy - 1 > 1 Then
                                sx = sx - 1
                                sy = sy - 1
                            End If
                        Else
                            sx = sx - 1
                        End If
                    End If
                Case 6
                    If sx - 1 > 1 Then
                        If sx Mod 2 Then
                            sx = sx - 1
                        Else
                            If sy + 1 < (maxy - 1) Then
                                sx = sx - 1
                                sy = sy + 1
                            End If
                        End If
                    End If
            End Select
            If map(sx, sy) = 1 Then 'only dig out and count the hex-cell if it is filled
                map(sx, sy) = 0
                c = c + 1
            End If
            lastgo = dgo
            lasthrun = hrun
        Next hgo
    Loop Until c >= clim
    'draw the hex grid
    For y = 1 To maxy
        For x = 1 To maxx
            If map(x, y) = 1 Then
                hexat x, y
                hexpaint x, y, _RGB32(200, 200, 200)
            End If
        Next x
    Next y
    _Display
    Do
        _KeyClear
        _Limit 60
        kk$ = InKey$
    Loop Until kk$ <> ""
Loop Until kk$ = "q"

Sub hexpaint (x, y, hklr As _Unsigned Long)
    'paint an arbitrary hex
    'hexradius and hexborder defined as shared variables in main program
    hr = hexradius
    If x Mod 2 Then
        Paint ((x * 2) * hr * .75, y * (hr * 1.75)), hklr, hexborder
    Else
        Paint ((x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875)), hklr, hexborder
    End If
End Sub

Sub hexput (sp&, x, y, sscale, hf)
    'drop a sprite/image inside a hex , hf is hexfacing given in degrees
    'sp& would be an image handle to a sprite created elsewere in program
    hr = hexradius
    If x Mod 2 Then
        RotoZoom23d (x * 2) * hr * .75, y * (hr * 1.75), sp&, sscale, sscale, hf
    Else
        RotoZoom23d (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), sp&, sscale, sscale, hf
    End If
End Sub

Sub hexat (xx, yy)
    'draw an arbitrary hex, hexradius and hexborder are shared variables created in main porgram
    hr = hexradius
    y = yy
    x = xx
    If x Mod 2 Then
        rotpoly (x * 2) * hr * .75, y * (hr * 1.75), hr, 60, 30, hexborder
    Else
        rotpoly (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), hr, 60, 30, hexborder
    End If
End Sub

Sub hexgrid (xx, yy)
    'draw a whole empty hexgrid
    hr = hexradius
    For y = 1 To yy
        For x = 1 To xx
            If x Mod 2 Then
                rotpoly (x * 2) * hr * .75, y * (hr * 1.75), hr, 60, 30, hexborder
            Else
                rotpoly (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), hr, 60, 30, hexborder
            End If
        Next x
    Next y
End Sub

Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
    'draw an equilateral polygon (if shapedeg divides evenly into 360) centered on cx and cy
    x = rr * Sin(0.01745329 * turn)
    y = rr * Cos(0.01745329 * turn)
    Line (cx + x, cy + y)-(cx + x, cy + y), klr
    For deg = turn To turn + 360 Step shapedeg
        x2 = rr * Sin(0.01745329 * deg)
        y2 = rr * Cos(0.01745329 * deg)
        Line -(cx + x2, cy + y2), klr
    Next
End Sub

'used in hexput to drop a sprite in a hex
Sub RotoZoom23d (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single)
    Dim px(3) As Single: Dim py(3) As Single
    Wi& = _Width(Image&): Hi& = _Height(Image&)
    W& = Wi& / 2 * xScale
    H& = Hi& / 2 * yScale
    px(0) = -W&: py(0) = -H&: px(1) = -W&: py(1) = H&
    px(2) = W&: py(2) = H&: px(3) = W&: py(3) = -H&
    sinr! = Sin(-0.01745329 * Rotation): cosr! = Cos(-0.01745329 * Rotation)
    For i& = 0 To 3
        x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
        px(i&) = x2&: py(i&) = y2&
    Next
    _MapTriangle (0, 0)-(0, Hi& - 1)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle (0, 0)-(Wi& - 1, 0)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub