Hexagonal Grid

General FreeBASIC programming questions.
badidea
Posts: 2328
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Hexagonal Grid

Postby badidea » May 05, 2021 22:01

RockTheSchock wrote:I started to port most of the code to freebasic from this site:
https://www.redblobgames.com/grids/hexagons/

Maybe i find it again and post it here

While you search, I started my own port. Still work in progress, but some things are working.

Demo: Hex index at mouse position

Code: Select all

'https://www.redblobgames.com/grids/hexagons
'https://www.redblobgames.com/grids/hexagons/implementation.html

'-------------------------------------------------------------------------------

#Define sqrt Sqr
#Define max(a, b) (IIf((a) > (b), (a), (b)))
#Define min(a, b) (IIf((a) < (b), (a), (b)))
#Define limit(v, v_min, v_max) (min(max((v), (v_min)), (v_max)))
#Define lerp(a, b, t) ((a) + ((b) - (a)) * t) 'linearly interpolation
#Define M_PI (Atn(1) * 4)

'---------------------------- hex cube coordinates -----------------------------

Type hex_cube
   Dim As Integer x 'pointing right/up
   Dim As Integer y 'pointing left/up
   Dim As Integer z 'pointing down
   Declare Operator Cast () As String
End Type

Operator hex_cube.cast() As String
   Return "(x: " & x & ", y: " & y & ", z: " & z & ")"
End Operator

Function hex_equal(a As hex_cube, b As hex_cube) As boolean
   If a.x <> b.x Then Return false
   If a.y <> b.y Then Return false
   If a.z <> b.z Then Return false
   Return true
End Function

Function hex_add(a As hex_cube, b As hex_cube) As hex_cube
   Return Type(a.x + b.x, a.y + b.y, a.z + b.z)
End Function

Function hex_substract(a As hex_cube, b As hex_cube) As hex_cube
   Return Type(a.x - b.x, a.y - b.y, a.z - b.z)
End Function

Dim Shared As Const hex_cube hex_cube_direction(0 To 5) = {_
   Type(+1, -1, 0), Type(+1, 0, -1), Type(0, +1, -1), _
   Type(-1, +1, 0), Type(-1, 0, +1), Type(0, -1, +1) }

Function hex_neighbor(hc As hex_cube, direction As Integer) As hex_cube
   Return hex_add(hc, Cast(hex_cube, hex_cube_direction(direction)))
End Function

Dim Shared As Const hex_cube hex_cube_diagonal(0 To 5) = {_
   Type(+2, -1, -1), Type(+1, +1, -2), Type(-1, +2, -1), _
   Type(-2, +1, +1), Type(-1, -1, +2), Type(+1, -2, +1) }

Function hex_neighbor_diagonal(hc As hex_cube, direction As Integer) As hex_cube
   Return hex_add(hc, Cast(hex_cube, hex_cube_diagonal(direction)))
End Function

Function hex_distance(a As hex_cube, b As hex_cube) As Integer
   Return (Abs(a.x - b.x) + Abs(a.y - b.y) + Abs(a.z - b.z)) \ 2
End Function
'Note: cube_distance also possible with max(dx, dy, dx)

'60° rotation
Function hex_rotate_left(a As hex_cube) As hex_cube
    Return Type(-a.z, -a.x, -a.y)
End Function

Function hex_rotate_right(a As hex_cube) As hex_cube
    Return Type(-a.y, -a.z, -a.x)
End Function

'For 60° rotation around other hex: translate, rotate, translate back: TODO
'Use add and substract for translation

'Reflection
Function hex_reflect_x(h As hex_cube) As hex_cube
   Return Type(h.x, h.z, h.y)
End Function

Function hex_reflect_y(h As hex_cube) As hex_cube
   Return Type(h.z, h.y, h.y)
End Function

Function hex_reflect_z(h As hex_cube) As hex_cube
   Return Type(h.x, h.y, h.z)
End Function

'===============================================================================

'--------------------------- hex axial coordinates -----------------------------

Type hex_axial
   Dim As Integer q 'pointing right/up
   Dim As Integer r 'pointing down
   Declare Operator Cast () As String
End Type

Operator hex_axial.cast() As String
   Return "(q: " & q & ", r: " & r & ")"
End Operator

Function hex_axial_add(a As hex_axial, b As hex_axial) As hex_axial
   Return Type(a.q + b.q, a.r + b.r)
End Function

Function hex_axial_substract(a As hex_axial, b As hex_axial) As hex_axial
   Return Type(a.q - b.q, a.r - b.r)
End Function

Dim Shared As Const hex_axial hex_axial_direction(0 To 5) = {_
   Type(+1, 0), Type(+1, -1), Type(0, -1), _
   Type(-1, 0), Type(-1, +1), Type(0, +1) }

Function hex_axial_neighbor(ha As hex_axial, direction As Integer) As hex_axial
   Return hex_axial_add(ha, Cast(hex_axial, hex_axial_direction(direction)))
End Function

Function hex_axial_distance(a As hex_axial, b As hex_axial) As Integer
    Return (Abs(a.q - b.q) + Abs(a.q + a.r - b.q - b.r) + Abs(a.r - b.r)) \ 2
End Function
'Note: Or convert to hex_cube first

'------------------------- a simple hex <vextor> class -------------------------

Type hex_list
   Private:
   Dim As hex_cube h(Any)
   Public:
   Declare Function Push(h As hex_cube) As Integer
   Declare Function Pop() As hex_cube
   Declare Sub del_()
   Declare Function size() As Integer
   Declare Function last_index() As Integer
End Type

'add to end of list
Function hex_list.push(h_ As hex_cube) As Integer
   Dim As Integer ub = UBound(h) + 1
   ReDim Preserve h(ub)
   h(ub) = h_
   Return ub
End Function

'remove from end of list
Function hex_list.pop() As hex_cube
   Dim As hex_cube h_
   Dim As Integer ub = UBound(h)
   If ub >= 0 Then
      h_ = h(ub)
      If ub = 0 Then
         Erase h
      Else
         ReDim Preserve h(ub - 1)
      End If
   End If
   Return h_
End Function

Sub hex_list.del_()
   Erase(h)
End Sub

Function hex_list.size() As Integer
   Return UBound(h) + 1
End Function

Function hex_list.last_index() As Integer
   Return UBound(h)
End Function

'------------------------ a simple point <vextor> class ------------------------

Type pt_dbl
   Dim As Double x, y
End Type

Type pt_list
   Private:
   Dim As pt_dbl pt(Any)
   Public:
   Declare Function Push(pt_ As pt_dbl) As Integer
   Declare Function Pop() As pt_dbl
   Declare Sub del_()
   Declare Function size() As Integer
   Declare Function last_index() As Integer
End Type

'add to end of list
Function pt_list.push(pt_ As pt_dbl) As Integer
   Dim As Integer ub = UBound(pt) + 1
   ReDim Preserve pt(ub)
   pt(ub) = pt_
   Return ub
End Function

'remove from end of list
Function pt_list.pop() As pt_dbl
   Dim As pt_dbl pt_
   Dim As Integer ub = UBound(pt)
   If ub >= 0 Then
      pt_ = pt(ub)
      If ub = 0 Then
         Erase pt
      Else
         ReDim Preserve pt(ub - 1)
      End If
   End If
   Return pt_
End Function

Sub pt_list.del_()
   Erase(pt)
End Sub

Function pt_list.size() As Integer
   Return UBound(pt) + 1
End Function

Function pt_list.last_index() As Integer
   Return UBound(pt)
End Function

'---------------------------- offset coordinates -------------------------------

Type hex_offset
   Dim As Integer row_, col_
End Type

'odd-r: for pointy tops, shoves odd row_s by +½ col_umn
Function hex_cube_to_oddr(hc As hex_cube) As hex_offset
   Return Type(hc.x + (hc.z - (hc.z And 1)) \ 2, hc.z)
End Function

Function hex_oddr_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_ - (ho.row_ - (ho.row_ And 1)) \ 2
   Dim As Integer z = ho.row_
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'even-r: for pointy tops, shoves even row_s by +½ col_umn
Function hex_cube_to_evenr(hc As hex_cube) As hex_offset
   Return Type(hc.x + (hc.z + (hc.z And 1)) \ 2, hc.z)
End Function

Function hex_evenr_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_ - (ho.row_ + (ho.row_ And 1)) \ 2
   Dim As Integer z = ho.row_
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'odd-q: for flat tops, shoves odd col_umns by +½ row_
Function hex_cube_to_oddq(hc As hex_cube) As hex_offset
   Return Type(hc.x, hc.z + (hc.x - (hc.x And 1)) \ 2)
End Function

Function hex_oddq_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_
   Dim As Integer z = ho.row_ - (ho.col_ - (ho.col_ And 1)) \ 2
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'even-q: shoves even col_umns by +½ row_
Function hex_cube_to_evenq(hc As hex_cube) As hex_offset
   Return Type(hc.x, hc.z + (hc.x + (hc.x And 1)) \ 2)
End Function

Function hex_evenq_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_
   Dim As Integer z = ho.row_ - (ho.col_ + (ho.col_ And 1)) \ 2
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'--------------------------- coordinate conversion -----------------------------

Function hex_cube_to_axial(hc As hex_cube) As hex_axial
   Return Type(hc.x, hc.z) 'ignore y
End Function

Function hex_axial_to_cube(ha As hex_axial) As hex_cube
   Return Type(ha.q, ha.r, -(ha.q + ha.r))
End Function

'--------------------------------- hex layout ----------------------------------

Type hex_orientation
   Dim As Const Double f0, f1, f2, f3
   Dim As Const Double b0, b1, b2, b3
   Dim As Const Double start_angle 'in multiples of 60°
End Type

Dim Shared As Const hex_orientation layout_pointy = Type( _
   sqrt(3),   sqrt(3)/2, 0, 3/2, _
   sqrt(3)/3, -1/3,      0, 2/3, _
   0.5)

Dim Shared As Const hex_orientation layout_flat = Type( _
   3/2, 0, sqrt(3)/2, sqrt(3), _
   2/3, 0, -1/3,      sqrt(3)/3, _
   0.0)

Type hex_layout
   Dim As Const hex_orientation orientation
   Dim As Const pt_dbl size
   Dim As Const pt_dbl origin
End Type

'Hex to Pixel
Function hex_to_pixel(layout As hex_layout, h As hex_axial) As pt_dbl
   Dim ByRef As Const hex_orientation M = layout.orientation
   Dim As Double x = (M.f0 * h.q + M.f1 * h.r) * layout.size.x
   Dim As Double y = (M.f2 * h.q + M.f3 * h.r) * layout.size.y
   Return Type(x + layout.origin.x, y + layout.origin.y)
End Function

Type hex_cube_frac
    Dim As Double x, y, z
End Type

'hex cube rounding
Function hex_round(h As hex_cube_frac) As hex_cube
   Dim As Integer x = CInt(h.x) 'is this right?
   Dim As Integer y = CInt(h.y)
   Dim As Integer z = CInt(h.z)
   Dim As Double x_diff = Abs(x - h.x) 'q
   Dim As Double y_diff = Abs(y - h.y) 'r
   Dim As Double z_diff = Abs(z - h.z) 's
   If (x_diff > y_diff) And (x_diff > z_diff) Then
      x = -(y + z)
   ElseIf (y_diff > z_diff) Then
      y = -(x + z)
   Else
      z = -(x + y)
   End If
   Return Type(x, y, z)
End Function

'Pixel to Hex (integer cube coordinates)
Function pixel_to_hex_int(layout As hex_layout, p As pt_dbl) As hex_cube
   Dim ByRef As Const hex_orientation M = layout.orientation
   Dim As pt_dbl pt = Type(_
      (p.x - layout.origin.x) / layout.size.x, _
      (p.y - layout.origin.y) / layout.size.y)
   Dim As Double q = M.b0 * pt.x + M.b1 * pt.y
   Dim As Double r = M.b2 * pt.x + M.b3 * pt.y
   Return hex_round(Type(q, -(q + r), r)) 'x,y,z
End Function

Function hex_lerp(a As hex_cube, b As hex_cube, t As Double) As hex_cube_frac
   Return Type(lerp(a.x, b.x, t), lerp(a.y, b.y, t), lerp(a.z, b.z, t))
End Function

'return list of hex (with cube coordinates)
Function hex_line_list(a As hex_cube, b As hex_cube) As hex_list
   Dim As Integer N = hex_distance(a, b)
   Dim As hex_list hexes
   Dim As Double dist_step = 1.0 / max(N, 1)
   For i As Integer = 0 To N
      hexes.push(hex_round(hex_lerp(a, b, dist_step * i)))
   Next
   Return hexes
End Function

'relative corner position from hexagon center
'note: for speed, the corner positions can be precalculated (after setting size)
Function hex_corner_offset(layout As hex_layout, corner As Integer) As pt_dbl
   Dim As pt_dbl size = layout.size
   Dim As Double angle = 2.0 * M_PI * (layout.orientation.start_angle + corner) / 6
   Return Type(size.x * Cos(angle), size.y * Sin(angle))
End Function

Function hex_corner_list(layout As hex_layout, h As hex_axial) As pt_list
   Dim As pt_list corners
   Dim As pt_dbl center = hex_to_pixel(layout, h)
   For i As Integer = 0 To 5 'loop 6 corners
      Dim As pt_dbl offset = hex_corner_offset(layout, i)
      corners.push(Type(center.x + offset.x, center.y + offset.y))
   Next
   Return corners
End Function

Sub hex_draw_outline(layout As hex_layout, h As hex_axial, c As ULong)
   Dim As pt_list corners = hex_corner_list(layout, h)
   Dim As pt_dbl first = corners.pop() 'save for last loop
   Dim As pt_dbl b = first
   For i As Integer = 0 To 5
      Dim As pt_dbl a = b
      b = IIf(i = 5, first, corners.pop())
      Line(a.x, a.y)-(b.x, b.y), c
   Next
End Sub

'-------------------------------------------------------------------------------

#Include "fbgfx.bi"
Const SW = 800, SH = 600
ScreenRes SW, SH, 32
Width SW \ 8, SH \ 16
Dim As hex_layout layout = _
   Type(layout_flat, Type<pt_dbl>(30, 30), Type<pt_dbl>(SW \ 2, SH \ 2))
Dim As hex_axial ha = Type(0, 0)
Dim As UByte rd, gn, bl
Dim As Integer mx, my
Dim As hex_cube hc
Dim As Integer map_radius = 5

While Not MultiKey(FB.SC_ESCAPE)
   ScreenLock
   Line(0, 0)-(SW-1, SH-1), 0, bf
   'draw grid
   For q As Integer = -map_radius To +map_radius
      ha.q = q
      For r As Integer = -map_radius To +map_radius
         ha.r = r
         hc = hex_axial_to_cube(ha)
         rd = limit(r * 25 + 127, 0, 255)
         gn = limit(q * 25 + 127, 0, 255)
         bl = 127
         If Abs(hc.x) <= map_radius And Abs(hc.y) <= map_radius And Abs(hc.z) <= map_radius Then
            hex_draw_outline(layout, ha, RGB(rd, gn, bl))
         End If
      Next
   Next
   'highlight tile at cursor
   If GetMouse(mx, my) = 0 Then
      hc = pixel_to_hex_int(layout, Type(mx, my))
      If Abs(hc.x) <= map_radius And Abs(hc.y) <= map_radius And Abs(hc.z) <= map_radius Then
         ha = hex_cube_to_axial(hc)
         hex_draw_outline(layout, ha, RGB(255, 255, 255))
         Draw String(10, 10), "hex cube coordinates: " & hc
         Draw String(10, 30), "hex axial coordinates: " & ha
      End If
   End If
   
   ScreenUnLock
   Sleep 1
Wend

GetKey()

Demo: Lines on a hex grid

Code: Select all

'https://www.redblobgames.com/grids/hexagons
'https://www.redblobgames.com/grids/hexagons/implementation.html

'-------------------------------------------------------------------------------

#Define sqrt Sqr
#Define max(a, b) (IIf((a) > (b), (a), (b)))
#Define min(a, b) (IIf((a) < (b), (a), (b)))
#Define limit(v, v_min, v_max) (min(max((v), (v_min)), (v_max)))
#Define lerp(a, b, t) ((a) + ((b) - (a)) * t) 'linearly interpolation
#Define M_PI (Atn(1) * 4)

'---------------------------- hex cube coordinates -----------------------------

Type hex_cube
   Dim As Integer x 'pointing right/up
   Dim As Integer y 'pointing left/up
   Dim As Integer z 'pointing down
   Declare Operator Cast () As String
End Type

Operator hex_cube.cast() As String
   Return "(x: " & x & ", y: " & y & ", z: " & z & ")"
End Operator

Function hex_equal(a As hex_cube, b As hex_cube) As boolean
   If a.x <> b.x Then Return false
   If a.y <> b.y Then Return false
   If a.z <> b.z Then Return false
   Return true
End Function

Function hex_add(a As hex_cube, b As hex_cube) As hex_cube
   Return Type(a.x + b.x, a.y + b.y, a.z + b.z)
End Function

Function hex_substract(a As hex_cube, b As hex_cube) As hex_cube
   Return Type(a.x - b.x, a.y - b.y, a.z - b.z)
End Function

Dim Shared As Const hex_cube hex_cube_direction(0 To 5) = {_
   Type(+1, -1, 0), Type(+1, 0, -1), Type(0, +1, -1), _
   Type(-1, +1, 0), Type(-1, 0, +1), Type(0, -1, +1) }

Function hex_neighbor(hc As hex_cube, direction As Integer) As hex_cube
   Return hex_add(hc, Cast(hex_cube, hex_cube_direction(direction)))
End Function

Dim Shared As Const hex_cube hex_cube_diagonal(0 To 5) = {_
   Type(+2, -1, -1), Type(+1, +1, -2), Type(-1, +2, -1), _
   Type(-2, +1, +1), Type(-1, -1, +2), Type(+1, -2, +1) }

Function hex_neighbor_diagonal(hc As hex_cube, direction As Integer) As hex_cube
   Return hex_add(hc, Cast(hex_cube, hex_cube_diagonal(direction)))
End Function

Function hex_distance(a As hex_cube, b As hex_cube) As Integer
   Return (Abs(a.x - b.x) + Abs(a.y - b.y) + Abs(a.z - b.z)) \ 2
End Function
'Note: cube_distance also possible with max(dx, dy, dx)

'60° rotation
Function hex_rotate_left(a As hex_cube) As hex_cube
    Return Type(-a.z, -a.x, -a.y)
End Function

Function hex_rotate_right(a As hex_cube) As hex_cube
    Return Type(-a.y, -a.z, -a.x)
End Function

'For 60° rotation around other hex: translate, rotate, translate back: TODO
'Use add and substract for translation

'Reflection
Function hex_reflect_x(h As hex_cube) As hex_cube
   Return Type(h.x, h.z, h.y)
End Function

Function hex_reflect_y(h As hex_cube) As hex_cube
   Return Type(h.z, h.y, h.y)
End Function

Function hex_reflect_z(h As hex_cube) As hex_cube
   Return Type(h.x, h.y, h.z)
End Function

'--------------------------- hex axial coordinates -----------------------------

Type hex_axial
   Dim As Integer q 'pointing right/up
   Dim As Integer r 'pointing down
   Declare Operator Cast () As String
End Type

Operator hex_axial.cast() As String
   Return "(q: " & q & ", r: " & r & ")"
End Operator

Function hex_axial_add(a As hex_axial, b As hex_axial) As hex_axial
   Return Type(a.q + b.q, a.r + b.r)
End Function

Function hex_axial_substract(a As hex_axial, b As hex_axial) As hex_axial
   Return Type(a.q - b.q, a.r - b.r)
End Function

Dim Shared As Const hex_axial hex_axial_direction(0 To 5) = {_
   Type(+1, 0), Type(+1, -1), Type(0, -1), _
   Type(-1, 0), Type(-1, +1), Type(0, +1) }

Function hex_axial_neighbor(ha As hex_axial, direction As Integer) As hex_axial
   Return hex_axial_add(ha, Cast(hex_axial, hex_axial_direction(direction)))
End Function

Function hex_axial_distance(a As hex_axial, b As hex_axial) As Integer
    Return (Abs(a.q - b.q) + Abs(a.q + a.r - b.q - b.r) + Abs(a.r - b.r)) \ 2
End Function
'Note: Or convert to hex_cube first

'------------------------- a simple hex <vextor> class -------------------------

Type hex_list
   Private:
   Dim As hex_cube h(Any)
   Public:
   Declare Function Push(h As hex_cube) As Integer
   Declare Function Pop() As hex_cube
   Declare Sub del_()
   Declare Function size() As Integer
   Declare Function last_index() As Integer
End Type

'add to end of list
Function hex_list.push(h_ As hex_cube) As Integer
   Dim As Integer ub = UBound(h) + 1
   ReDim Preserve h(ub)
   h(ub) = h_
   Return ub
End Function

'remove from end of list
Function hex_list.pop() As hex_cube
   Dim As hex_cube h_
   Dim As Integer ub = UBound(h)
   If ub >= 0 Then
      h_ = h(ub)
      If ub = 0 Then
         Erase h
      Else
         ReDim Preserve h(ub - 1)
      End If
   End If
   Return h_
End Function

Sub hex_list.del_()
   Erase(h)
End Sub

Function hex_list.size() As Integer
   Return UBound(h) + 1
End Function

Function hex_list.last_index() As Integer
   Return UBound(h)
End Function

'------------------------ a simple point <vextor> class ------------------------

Type pt_dbl
   Dim As Double x, y
End Type

Type pt_list
   Private:
   Dim As pt_dbl pt(Any)
   Public:
   Declare Function Push(pt_ As pt_dbl) As Integer
   Declare Function Pop() As pt_dbl
   Declare Sub del_()
   Declare Function size() As Integer
   Declare Function last_index() As Integer
End Type

'add to end of list
Function pt_list.push(pt_ As pt_dbl) As Integer
   Dim As Integer ub = UBound(pt) + 1
   ReDim Preserve pt(ub)
   pt(ub) = pt_
   Return ub
End Function

'remove from end of list
Function pt_list.pop() As pt_dbl
   Dim As pt_dbl pt_
   Dim As Integer ub = UBound(pt)
   If ub >= 0 Then
      pt_ = pt(ub)
      If ub = 0 Then
         Erase pt
      Else
         ReDim Preserve pt(ub - 1)
      End If
   End If
   Return pt_
End Function

Sub pt_list.del_()
   Erase(pt)
End Sub

Function pt_list.size() As Integer
   Return UBound(pt) + 1
End Function

Function pt_list.last_index() As Integer
   Return UBound(pt)
End Function

'---------------------------- offset coordinates -------------------------------

Type hex_offset
   Dim As Integer row_, col_
End Type

'odd-r: for pointy tops, shoves odd row_s by +½ col_umn
Function hex_cube_to_oddr(hc As hex_cube) As hex_offset
   Return Type(hc.x + (hc.z - (hc.z And 1)) \ 2, hc.z)
End Function

Function hex_oddr_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_ - (ho.row_ - (ho.row_ And 1)) \ 2
   Dim As Integer z = ho.row_
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'even-r: for pointy tops, shoves even row_s by +½ col_umn
Function hex_cube_to_evenr(hc As hex_cube) As hex_offset
   Return Type(hc.x + (hc.z + (hc.z And 1)) \ 2, hc.z)
End Function

Function hex_evenr_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_ - (ho.row_ + (ho.row_ And 1)) \ 2
   Dim As Integer z = ho.row_
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'odd-q: for flat tops, shoves odd col_umns by +½ row_
Function hex_cube_to_oddq(hc As hex_cube) As hex_offset
   Return Type(hc.x, hc.z + (hc.x - (hc.x And 1)) \ 2)
End Function

Function hex_oddq_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_
   Dim As Integer z = ho.row_ - (ho.col_ - (ho.col_ And 1)) \ 2
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'even-q: shoves even col_umns by +½ row_
Function hex_cube_to_evenq(hc As hex_cube) As hex_offset
   Return Type(hc.x, hc.z + (hc.x + (hc.x And 1)) \ 2)
End Function

Function hex_evenq_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_
   Dim As Integer z = ho.row_ - (ho.col_ + (ho.col_ And 1)) \ 2
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'--------------------------- coordinate conversion -----------------------------

Function hex_cube_to_axial(hc As hex_cube) As hex_axial
   Return Type(hc.x, hc.z) 'ignore y
End Function

Function hex_axial_to_cube(ha As hex_axial) As hex_cube
   Return Type(ha.q, ha.r, -(ha.q + ha.r))
End Function

'--------------------------------- hex layout ----------------------------------

Type hex_orientation
   Dim As Const Double f0, f1, f2, f3
   Dim As Const Double b0, b1, b2, b3
   Dim As Const Double start_angle 'in multiples of 60°
End Type

Dim Shared As Const hex_orientation layout_pointy = Type( _
   sqrt(3),   sqrt(3)/2, 0, 3/2, _
   sqrt(3)/3, -1/3,      0, 2/3, _
   0.5)

Dim Shared As Const hex_orientation layout_flat = Type( _
   3/2, 0, sqrt(3)/2, sqrt(3), _
   2/3, 0, -1/3,      sqrt(3)/3, _
   0.0)

Type hex_layout
   Dim As Const hex_orientation orientation
   Dim As Const pt_dbl size
   Dim As Const pt_dbl origin
End Type

'Hex to Pixel
Function hex_to_pixel(layout As hex_layout, h As hex_axial) As pt_dbl
   Dim ByRef As Const hex_orientation M = layout.orientation
   Dim As Double x = (M.f0 * h.q + M.f1 * h.r) * layout.size.x
   Dim As Double y = (M.f2 * h.q + M.f3 * h.r) * layout.size.y
   Return Type(x + layout.origin.x, y + layout.origin.y)
End Function

Type hex_cube_frac
    Dim As Double x, y, z
End Type

'hex cube rounding
Function hex_round(h As hex_cube_frac) As hex_cube
   Dim As Integer x = CInt(h.x) 'is this right?
   Dim As Integer y = CInt(h.y)
   Dim As Integer z = CInt(h.z)
   Dim As Double x_diff = Abs(x - h.x) 'q
   Dim As Double y_diff = Abs(y - h.y) 'r
   Dim As Double z_diff = Abs(z - h.z) 's
   If (x_diff > y_diff) And (x_diff > z_diff) Then
      x = -(y + z)
   ElseIf (y_diff > z_diff) Then
      y = -(x + z)
   Else
      z = -(x + y)
   End If
   Return Type(x, y, z)
End Function

'Pixel to Hex (integer cube coordinates)
Function pixel_to_hex_int(layout As hex_layout, p As pt_dbl) As hex_cube
   Dim ByRef As Const hex_orientation M = layout.orientation
   Dim As pt_dbl pt = Type(_
      (p.x - layout.origin.x) / layout.size.x, _
      (p.y - layout.origin.y) / layout.size.y)
   Dim As Double q = M.b0 * pt.x + M.b1 * pt.y
   Dim As Double r = M.b2 * pt.x + M.b3 * pt.y
   Return hex_round(Type(q, -(q + r), r)) 'x,y,z
End Function

Function hex_lerp(a As hex_cube, b As hex_cube, t As Double) As hex_cube_frac
   Return Type(lerp(a.x, b.x, t), lerp(a.y, b.y, t), lerp(a.z, b.z, t))
End Function

'return list of hex (with cube coordinates)
Function hex_line_list(a As hex_cube, b As hex_cube) As hex_list
   Dim As Integer N = hex_distance(a, b)
   Dim As hex_list hexes
   Dim As Double dist_step = 1.0 / max(N, 1)
   For i As Integer = 0 To N
      hexes.push(hex_round(hex_lerp(a, b, dist_step * i)))
   Next
   Return hexes
End Function

'relative corner position from hexagon center
'note: for speed, the corner positions can be precalculated (after setting size)
Function hex_corner_offset(layout As hex_layout, corner As Integer) As pt_dbl
   Dim As pt_dbl size = layout.size
   Dim As Double angle = 2.0 * M_PI * (layout.orientation.start_angle + corner) / 6
   Return Type(size.x * Cos(angle), size.y * Sin(angle))
End Function

Function hex_corner_list(layout As hex_layout, h As hex_axial) As pt_list
   Dim As pt_list corners
   Dim As pt_dbl center = hex_to_pixel(layout, h)
   For i As Integer = 0 To 5 'loop 6 corners
      Dim As pt_dbl offset = hex_corner_offset(layout, i)
      corners.push(Type(center.x + offset.x, center.y + offset.y))
   Next
   Return corners
End Function

Sub hex_draw_outline(layout As hex_layout, h As hex_axial, c As ULong)
   Dim As pt_list corners = hex_corner_list(layout, h)
   Dim As pt_dbl first = corners.pop() 'save for last loop
   Dim As pt_dbl b = first
   For i As Integer = 0 To 5
      Dim As pt_dbl a = b
      b = IIf(i = 5, first, corners.pop())
      Line(a.x, a.y)-(b.x, b.y), c
   Next
End Sub

'-------------------------------------------------------------------------------

#Define rnd_range(a, b) (Rnd * (b - a) + a)
#Define rnd_color() (&hff000000 Or Int(Rnd * &h00ffffff))

#Include "fbgfx.bi"
Const SW = 800, SH = 600
ScreenRes SW, SH, 32
Width SW \ 8, SH \ 16
Dim As hex_layout layout = _
   Type(layout_pointy, Type<pt_dbl>(8, 8), Type<pt_dbl>(SW * 0.6, SH * 0.5))
Dim As hex_axial ha = Type(0, 0)
Dim As hex_cube hc
Dim As Integer map_radius = 20
Dim As hex_axial h0 = Type(0, 0), h1, h2
Dim As hex_list hl

'draw grid
For q As Integer = -map_radius To +map_radius
   ha.q = q
   For r As Integer = -map_radius To +map_radius
      ha.r = r
      hc = hex_axial_to_cube(ha)
      If Abs(hc.x) <= map_radius And Abs(hc.y) <= map_radius And Abs(hc.z) <= map_radius Then
         hex_draw_outline(layout, ha, &hff606060) 'drak grey
      End If
   Next
Next

While Not MultiKey(FB.SC_ESCAPE)
   ScreenLock
   'clear left part of screen
   Line(0, 0)-(SW * 0.2, SH - 1), 0, bf
   'Create a random start- and endpoint, that are within the map
   Do
      h1.r = CInt(rnd_range(-map_radius, +map_radius))
      h1.q = CInt(rnd_range(-map_radius, +map_radius))
   Loop While hex_axial_distance(h1, h0) > map_radius
   Do
      h2.r = CInt(rnd_range(-map_radius, +map_radius))
      h2.q = CInt(rnd_range(-map_radius, +map_radius))
   Loop While hex_axial_distance(h2, h0) > map_radius
   hl = hex_line_list(hex_axial_to_cube(h1), hex_axial_to_cube(h2))
   Dim As ULong colour = rnd_color()
   For i As Integer = 0 To hl.last_index()
      hc = hl.pop()
      ha = hex_cube_to_axial(hc)
      'hex_draw_outline(layout, ha, &hfff0f060) 'yellow
      hex_draw_outline(layout, ha, colour)
      Draw String (10, 10 + i * 16), Str(i) & ". " & ha
   Next
   ScreenUnLock
   Sleep 500
Wend

GetKey()
badidea
Posts: 2328
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Hexagonal Grid

Postby badidea » May 09, 2021 22:25

Demo: Refection over the 3 axis x, y and z.
(it looks quite confusing, like bees swarming over the cells when you move the mouse)

Code: Select all

'https://www.redblobgames.com/grids/hexagons
'https://www.redblobgames.com/grids/hexagons/implementation.html

'-------------------------------------------------------------------------------

#Define sqrt Sqr
#Define max(a, b) (IIf((a) > (b), (a), (b)))
#Define min(a, b) (IIf((a) < (b), (a), (b)))
#Define limit(v, v_min, v_max) (min(max((v), (v_min)), (v_max)))
#Define lerp(a, b, t) ((a) + ((b) - (a)) * t) 'linearly interpolation
#Define M_PI (Atn(1) * 4)

'---------------------------- hex cube coordinates -----------------------------

Type hex_cube
   Dim As Integer x 'pointing right/up
   Dim As Integer y 'pointing left/up
   Dim As Integer z 'pointing down
   Declare Operator Cast () As String
End Type

Operator hex_cube.cast() As String
   Return "(x: " & x & ", y: " & y & ", z: " & z & ")"
End Operator

Function hex_equal(a As hex_cube, b As hex_cube) As boolean
   If a.x <> b.x Then Return false
   If a.y <> b.y Then Return false
   If a.z <> b.z Then Return false
   Return true
End Function

Function hex_add(a As hex_cube, b As hex_cube) As hex_cube
   Return Type(a.x + b.x, a.y + b.y, a.z + b.z)
End Function

Function hex_substract(a As hex_cube, b As hex_cube) As hex_cube
   Return Type(a.x - b.x, a.y - b.y, a.z - b.z)
End Function

Dim Shared As Const hex_cube hex_cube_direction(0 To 5) = {_
   Type(+1, -1, 0), Type(+1, 0, -1), Type(0, +1, -1), _
   Type(-1, +1, 0), Type(-1, 0, +1), Type(0, -1, +1) }

Function hex_neighbor(hc As hex_cube, direction As Integer) As hex_cube
   Return hex_add(hc, Cast(hex_cube, hex_cube_direction(direction)))
End Function

Dim Shared As Const hex_cube hex_cube_diagonal(0 To 5) = {_
   Type(+2, -1, -1), Type(+1, +1, -2), Type(-1, +2, -1), _
   Type(-2, +1, +1), Type(-1, -1, +2), Type(+1, -2, +1) }

Function hex_neighbor_diagonal(hc As hex_cube, direction As Integer) As hex_cube
   Return hex_add(hc, Cast(hex_cube, hex_cube_diagonal(direction)))
End Function

Function hex_distance(a As hex_cube, b As hex_cube) As Integer
   Return (Abs(a.x - b.x) + Abs(a.y - b.y) + Abs(a.z - b.z)) \ 2
End Function
'Note: cube_distance also possible with max(dx, dy, dx)

'60° rotation
Function hex_rotate_left(a As hex_cube) As hex_cube
    Return Type(-a.z, -a.x, -a.y)
End Function

Function hex_rotate_right(a As hex_cube) As hex_cube
    Return Type(-a.y, -a.z, -a.x)
End Function

'For 60° rotation around other hex: translate, rotate, translate back: TODO
'Use add and substract for translation

'Reflection
Function hex_reflect_x(h As hex_cube) As hex_cube
   Return Type(h.x, h.z, h.y)
End Function

Function hex_reflect_y(h As hex_cube) As hex_cube
   Return Type(h.z, h.y, h.x)
End Function

Function hex_reflect_z(h As hex_cube) As hex_cube
   Return Type(h.y, h.x, h.z)
End Function

'--------------------------- hex axial coordinates -----------------------------

Type hex_axial
   Dim As Integer q 'pointing right/up
   Dim As Integer r 'pointing down
   Declare Operator Cast () As String
End Type

Operator hex_axial.cast() As String
   Return "(q: " & q & ", r: " & r & ")"
End Operator

Function hex_axial_add(a As hex_axial, b As hex_axial) As hex_axial
   Return Type(a.q + b.q, a.r + b.r)
End Function

Function hex_axial_substract(a As hex_axial, b As hex_axial) As hex_axial
   Return Type(a.q - b.q, a.r - b.r)
End Function

Dim Shared As Const hex_axial hex_axial_direction(0 To 5) = {_
   Type(+1, 0), Type(+1, -1), Type(0, -1), _
   Type(-1, 0), Type(-1, +1), Type(0, +1) }

Function hex_axial_neighbor(ha As hex_axial, direction As Integer) As hex_axial
   Return hex_axial_add(ha, Cast(hex_axial, hex_axial_direction(direction)))
End Function

Function hex_axial_distance(a As hex_axial, b As hex_axial) As Integer
    Return (Abs(a.q - b.q) + Abs(a.q + a.r - b.q - b.r) + Abs(a.r - b.r)) \ 2
End Function
'Note: Or convert to hex_cube first

'------------------------- a simple hex <vextor> class -------------------------

Type hex_list
   Private:
   Dim As hex_cube h(Any)
   Public:
   Declare Function Push(h As hex_cube) As Integer
   Declare Function Pop() As hex_cube
   Declare Sub del_()
   Declare Function size() As Integer
   Declare Function last_index() As Integer
End Type

'add to end of list
Function hex_list.push(h_ As hex_cube) As Integer
   Dim As Integer ub = UBound(h) + 1
   ReDim Preserve h(ub)
   h(ub) = h_
   Return ub
End Function

'remove from end of list
Function hex_list.pop() As hex_cube
   Dim As hex_cube h_
   Dim As Integer ub = UBound(h)
   If ub >= 0 Then
      h_ = h(ub)
      If ub = 0 Then
         Erase h
      Else
         ReDim Preserve h(ub - 1)
      End If
   End If
   Return h_
End Function

Sub hex_list.del_()
   Erase(h)
End Sub

Function hex_list.size() As Integer
   Return UBound(h) + 1
End Function

Function hex_list.last_index() As Integer
   Return UBound(h)
End Function

'------------------------ a simple point <vextor> class ------------------------

Type pt_dbl
   Dim As Double x, y
End Type

Type pt_list
   Private:
   Dim As pt_dbl pt(Any)
   Public:
   Declare Function Push(pt_ As pt_dbl) As Integer
   Declare Function Pop() As pt_dbl
   Declare Sub del_()
   Declare Function size() As Integer
   Declare Function last_index() As Integer
End Type

'add to end of list
Function pt_list.push(pt_ As pt_dbl) As Integer
   Dim As Integer ub = UBound(pt) + 1
   ReDim Preserve pt(ub)
   pt(ub) = pt_
   Return ub
End Function

'remove from end of list
Function pt_list.pop() As pt_dbl
   Dim As pt_dbl pt_
   Dim As Integer ub = UBound(pt)
   If ub >= 0 Then
      pt_ = pt(ub)
      If ub = 0 Then
         Erase pt
      Else
         ReDim Preserve pt(ub - 1)
      End If
   End If
   Return pt_
End Function

Sub pt_list.del_()
   Erase(pt)
End Sub

Function pt_list.size() As Integer
   Return UBound(pt) + 1
End Function

Function pt_list.last_index() As Integer
   Return UBound(pt)
End Function

'---------------------------- offset coordinates -------------------------------

Type hex_offset
   Dim As Integer row_, col_
End Type

'odd-r: for pointy tops, shoves odd row_s by +½ col_umn
Function hex_cube_to_oddr(hc As hex_cube) As hex_offset
   Return Type(hc.x + (hc.z - (hc.z And 1)) \ 2, hc.z)
End Function

Function hex_oddr_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_ - (ho.row_ - (ho.row_ And 1)) \ 2
   Dim As Integer z = ho.row_
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'even-r: for pointy tops, shoves even row_s by +½ col_umn
Function hex_cube_to_evenr(hc As hex_cube) As hex_offset
   Return Type(hc.x + (hc.z + (hc.z And 1)) \ 2, hc.z)
End Function

Function hex_evenr_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_ - (ho.row_ + (ho.row_ And 1)) \ 2
   Dim As Integer z = ho.row_
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'odd-q: for flat tops, shoves odd col_umns by +½ row_
Function hex_cube_to_oddq(hc As hex_cube) As hex_offset
   Return Type(hc.x, hc.z + (hc.x - (hc.x And 1)) \ 2)
End Function

Function hex_oddq_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_
   Dim As Integer z = ho.row_ - (ho.col_ - (ho.col_ And 1)) \ 2
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'even-q: shoves even col_umns by +½ row_
Function hex_cube_to_evenq(hc As hex_cube) As hex_offset
   Return Type(hc.x, hc.z + (hc.x + (hc.x And 1)) \ 2)
End Function

Function hex_evenq_to_cube(ho As hex_offset) As hex_cube
   Dim As Integer x = ho.col_
   Dim As Integer z = ho.row_ - (ho.col_ + (ho.col_ And 1)) \ 2
   Dim As Integer y = -(x + z)
   Return Type(x, y, z)
End Function

'--------------------------- coordinate conversion -----------------------------

Function hex_cube_to_axial(hc As hex_cube) As hex_axial
   Return Type(hc.x, hc.z) 'ignore y
End Function

Function hex_axial_to_cube(ha As hex_axial) As hex_cube
   Return Type(ha.q, ha.r, -(ha.q + ha.r))
End Function

'--------------------------------- hex layout ----------------------------------

Type hex_orientation
   Dim As Const Double f0, f1, f2, f3
   Dim As Const Double b0, b1, b2, b3
   Dim As Const Double start_angle 'in multiples of 60°
End Type

Dim Shared As Const hex_orientation layout_pointy = Type( _
   sqrt(3),   sqrt(3)/2, 0, 3/2, _
   sqrt(3)/3, -1/3,      0, 2/3, _
   0.5)

Dim Shared As Const hex_orientation layout_flat = Type( _
   3/2, 0, sqrt(3)/2, sqrt(3), _
   2/3, 0, -1/3,      sqrt(3)/3, _
   0.0)

Type hex_layout
   Dim As Const hex_orientation orientation
   Dim As Const pt_dbl size
   Dim As Const pt_dbl origin
End Type

'Hex to Pixel
Function hex_to_pixel(layout As hex_layout, h As hex_axial) As pt_dbl
   Dim ByRef As Const hex_orientation M = layout.orientation
   Dim As Double x = (M.f0 * h.q + M.f1 * h.r) * layout.size.x
   Dim As Double y = (M.f2 * h.q + M.f3 * h.r) * layout.size.y
   Return Type(x + layout.origin.x, y + layout.origin.y)
End Function

Type hex_cube_frac
    Dim As Double x, y, z
End Type

'hex cube rounding
Function hex_round(h As hex_cube_frac) As hex_cube
   Dim As Integer x = CInt(h.x) 'is this right?
   Dim As Integer y = CInt(h.y)
   Dim As Integer z = CInt(h.z)
   Dim As Double x_diff = Abs(x - h.x) 'q
   Dim As Double y_diff = Abs(y - h.y) 'r
   Dim As Double z_diff = Abs(z - h.z) 's
   If (x_diff > y_diff) And (x_diff > z_diff) Then
      x = -(y + z)
   ElseIf (y_diff > z_diff) Then
      y = -(x + z)
   Else
      z = -(x + y)
   End If
   Return Type(x, y, z)
End Function

'Pixel to Hex (integer cube coordinates)
Function pixel_to_hex_int(layout As hex_layout, p As pt_dbl) As hex_cube
   Dim ByRef As Const hex_orientation M = layout.orientation
   Dim As pt_dbl pt = Type(_
      (p.x - layout.origin.x) / layout.size.x, _
      (p.y - layout.origin.y) / layout.size.y)
   Dim As Double q = M.b0 * pt.x + M.b1 * pt.y
   Dim As Double r = M.b2 * pt.x + M.b3 * pt.y
   Return hex_round(Type(q, -(q + r), r)) 'x,y,z
End Function

Function hex_lerp(a As hex_cube, b As hex_cube, t As Double) As hex_cube_frac
   Return Type(lerp(a.x, b.x, t), lerp(a.y, b.y, t), lerp(a.z, b.z, t))
End Function

'return list of hex (with cube coordinates)
Function hex_line_list(a As hex_cube, b As hex_cube) As hex_list
   Dim As Integer N = hex_distance(a, b)
   Dim As hex_list hexes
   Dim As Double dist_step = 1.0 / max(N, 1)
   For i As Integer = 0 To N
      hexes.push(hex_round(hex_lerp(a, b, dist_step * i)))
   Next
   Return hexes
End Function

'relative corner position from hexagon center
'note: for speed, the corner positions can be precalculated (after setting size)
Function hex_corner_offset(layout As hex_layout, corner As Integer) As pt_dbl
   Dim As pt_dbl size = layout.size
   Dim As Double angle = 2.0 * M_PI * (layout.orientation.start_angle + corner) / 6
   Return Type(size.x * Cos(angle), size.y * Sin(angle))
End Function

Function hex_corner_list(layout As hex_layout, h As hex_axial) As pt_list
   Dim As pt_list corners
   Dim As pt_dbl center = hex_to_pixel(layout, h)
   For i As Integer = 0 To 5 'loop 6 corners
      Dim As pt_dbl offset = hex_corner_offset(layout, i)
      corners.push(Type(center.x + offset.x, center.y + offset.y))
   Next
   Return corners
End Function

Sub hex_draw_outline(layout As hex_layout, h As hex_axial, c As ULong)
   Dim As pt_list corners = hex_corner_list(layout, h)
   Dim As pt_dbl first = corners.pop() 'save for last loop
   Dim As pt_dbl b = first
   For i As Integer = 0 To 5
      Dim As pt_dbl a = b
      b = IIf(i = 5, first, corners.pop())
      Line(a.x, a.y)-(b.x, b.y), c
   Next
End Sub

'-------------------------------------------------------------------------------

#Include "fbgfx.bi"
Const SW = 800, SH = 600
ScreenRes SW, SH, 32
Width SW \ 8, SH \ 16
Dim As hex_layout layout = _
   Type(layout_pointy, Type<pt_dbl>(15, 15), Type<pt_dbl>(SW \ 2, SH \ 2))
Dim As hex_axial ha = Type(0, 0)
Dim As Integer mx, my
Dim As hex_cube hc
Dim As Integer map_radius = 12

While Not MultiKey(FB.SC_ESCAPE)
   ScreenLock
   Line(0, 0)-(SW-1, SH-1), 0, bf
   'draw grid
   For q As Integer = -map_radius To +map_radius
      ha.q = q
      For r As Integer = -map_radius To +map_radius
         ha.r = r
         hc = hex_axial_to_cube(ha)
         If Abs(hc.x) <= map_radius And Abs(hc.y) <= map_radius And Abs(hc.z) <= map_radius Then
            hex_draw_outline(layout, ha, &hff606060) 'dark grey
         End If
      Next
   Next
   'highlight tile at cursor
   If GetMouse(mx, my) = 0 Then
      hc = pixel_to_hex_int(layout, Type(mx, my))
      If Abs(hc.x) <= map_radius And Abs(hc.y) <= map_radius And Abs(hc.z) <= map_radius Then
         ha = hex_cube_to_axial(hc)
         hex_draw_outline(layout, ha, RGB(255, 255, 255))
         ha = hex_cube_to_axial(hex_reflect_x(hc))
         hex_draw_outline(layout, ha, RGB(255, 255, 0))
         ha = hex_cube_to_axial(hex_reflect_y(hc))
         hex_draw_outline(layout, ha, RGB(255, 0, 255))
         ha = hex_cube_to_axial(hex_reflect_z(hc))
         hex_draw_outline(layout, ha, RGB(0, 255, 255))
      Else
         Draw String(10, 10), "Mouse move inside grid"
      End If
   Else
      Draw String(10, 10), "Mouse move inside window"
   End If
   
   ScreenUnLock
   Sleep 1
Wend

GetKey()

The functions reflectY() and reflectZ() seem incorrect on the 'redblobgames' website.

I'll convert this into a github repository. Easier to maintain then forum posts.

Edit: https://github.com/verybadidea/hexgrid

Return to “General”

Who is online

Users browsing this forum: No registered users and 11 guests