03-14-2023, 04:25 AM
(This post was last modified: 03-14-2023, 04:29 AM by 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.
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