## Hexagonal Grid

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

### Re: Hexagonal Grid

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 StringEnd TypeOperator hex_cube.cast() As String   Return "(x: " & x & ", y: " & y & ", z: " & z & ")"End OperatorFunction 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 trueEnd FunctionFunction 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 FunctionFunction 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 FunctionDim 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 FunctionDim 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 FunctionFunction 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)) \ 2End Function'Note: cube_distance also possible with max(dx, dy, dx)'60° rotationFunction hex_rotate_left(a As hex_cube) As hex_cube    Return Type(-a.z, -a.x, -a.y)End FunctionFunction 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'ReflectionFunction hex_reflect_x(h As hex_cube) As hex_cube   Return Type(h.x, h.z, h.y)End FunctionFunction hex_reflect_y(h As hex_cube) As hex_cube   Return Type(h.z, h.y, h.y)End FunctionFunction 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 StringEnd TypeOperator hex_axial.cast() As String   Return "(q: " & q & ", r: " & r & ")"End OperatorFunction 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 FunctionFunction 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 FunctionDim 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 FunctionFunction 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)) \ 2End 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 IntegerEnd Type'add to end of listFunction hex_list.push(h_ As hex_cube) As Integer   Dim As Integer ub = UBound(h) + 1   ReDim Preserve h(ub)   h(ub) = h_   Return ubEnd Function'remove from end of listFunction 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 FunctionSub hex_list.del_()   Erase(h)End SubFunction hex_list.size() As Integer   Return UBound(h) + 1End FunctionFunction hex_list.last_index() As Integer   Return UBound(h)End Function'------------------------ a simple point <vextor> class ------------------------Type pt_dbl   Dim As Double x, yEnd TypeType 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 IntegerEnd Type'add to end of listFunction pt_list.push(pt_ As pt_dbl) As Integer   Dim As Integer ub = UBound(pt) + 1   ReDim Preserve pt(ub)   pt(ub) = pt_   Return ubEnd Function'remove from end of listFunction 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 FunctionSub pt_list.del_()   Erase(pt)End SubFunction pt_list.size() As Integer   Return UBound(pt) + 1End FunctionFunction 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_umnFunction 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 FunctionFunction 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_umnFunction 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 FunctionFunction 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 FunctionFunction 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 FunctionFunction 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 yEnd FunctionFunction 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 TypeDim 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 originEnd Type'Hex to PixelFunction 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 FunctionType hex_cube_frac    Dim As Double x, y, zEnd Type'hex cube roundingFunction 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,zEnd FunctionFunction 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 hexesEnd 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 FunctionFunction 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 cornersEnd FunctionSub 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   NextEnd Sub'-------------------------------------------------------------------------------#Include "fbgfx.bi"Const SW = 800, SH = 600ScreenRes SW, SH, 32Width SW \ 8, SH \ 16Dim 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, blDim As Integer mx, myDim As hex_cube hcDim As Integer map_radius = 5While 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 1WendGetKey()`

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 StringEnd TypeOperator hex_cube.cast() As String   Return "(x: " & x & ", y: " & y & ", z: " & z & ")"End OperatorFunction 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 trueEnd FunctionFunction 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 FunctionFunction 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 FunctionDim 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 FunctionDim 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 FunctionFunction 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)) \ 2End Function'Note: cube_distance also possible with max(dx, dy, dx)'60° rotationFunction hex_rotate_left(a As hex_cube) As hex_cube    Return Type(-a.z, -a.x, -a.y)End FunctionFunction 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'ReflectionFunction hex_reflect_x(h As hex_cube) As hex_cube   Return Type(h.x, h.z, h.y)End FunctionFunction hex_reflect_y(h As hex_cube) As hex_cube   Return Type(h.z, h.y, h.y)End FunctionFunction 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 StringEnd TypeOperator hex_axial.cast() As String   Return "(q: " & q & ", r: " & r & ")"End OperatorFunction 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 FunctionFunction 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 FunctionDim 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 FunctionFunction 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)) \ 2End 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 IntegerEnd Type'add to end of listFunction hex_list.push(h_ As hex_cube) As Integer   Dim As Integer ub = UBound(h) + 1   ReDim Preserve h(ub)   h(ub) = h_   Return ubEnd Function'remove from end of listFunction 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 FunctionSub hex_list.del_()   Erase(h)End SubFunction hex_list.size() As Integer   Return UBound(h) + 1End FunctionFunction hex_list.last_index() As Integer   Return UBound(h)End Function'------------------------ a simple point <vextor> class ------------------------Type pt_dbl   Dim As Double x, yEnd TypeType 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 IntegerEnd Type'add to end of listFunction pt_list.push(pt_ As pt_dbl) As Integer   Dim As Integer ub = UBound(pt) + 1   ReDim Preserve pt(ub)   pt(ub) = pt_   Return ubEnd Function'remove from end of listFunction 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 FunctionSub pt_list.del_()   Erase(pt)End SubFunction pt_list.size() As Integer   Return UBound(pt) + 1End FunctionFunction 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_umnFunction 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 FunctionFunction 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_umnFunction 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 FunctionFunction 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 FunctionFunction 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 FunctionFunction 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 yEnd FunctionFunction 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 TypeDim 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 originEnd Type'Hex to PixelFunction 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 FunctionType hex_cube_frac    Dim As Double x, y, zEnd Type'hex cube roundingFunction 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,zEnd FunctionFunction 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 hexesEnd 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 FunctionFunction 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 cornersEnd FunctionSub 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   NextEnd 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 = 600ScreenRes SW, SH, 32Width SW \ 8, SH \ 16Dim 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 hcDim As Integer map_radius = 20Dim As hex_axial h0 = Type(0, 0), h1, h2Dim As hex_list hl'draw gridFor 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   NextNextWhile 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 500WendGetKey()`
Posts: 2333
Joined: May 24, 2007 22:10
Location: The Netherlands

### Re: Hexagonal Grid

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 StringEnd TypeOperator hex_cube.cast() As String   Return "(x: " & x & ", y: " & y & ", z: " & z & ")"End OperatorFunction 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 trueEnd FunctionFunction 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 FunctionFunction 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 FunctionDim 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 FunctionDim 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 FunctionFunction 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)) \ 2End Function'Note: cube_distance also possible with max(dx, dy, dx)'60° rotationFunction hex_rotate_left(a As hex_cube) As hex_cube    Return Type(-a.z, -a.x, -a.y)End FunctionFunction 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'ReflectionFunction hex_reflect_x(h As hex_cube) As hex_cube   Return Type(h.x, h.z, h.y)End FunctionFunction hex_reflect_y(h As hex_cube) As hex_cube   Return Type(h.z, h.y, h.x)End FunctionFunction 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 StringEnd TypeOperator hex_axial.cast() As String   Return "(q: " & q & ", r: " & r & ")"End OperatorFunction 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 FunctionFunction 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 FunctionDim 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 FunctionFunction 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)) \ 2End 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 IntegerEnd Type'add to end of listFunction hex_list.push(h_ As hex_cube) As Integer   Dim As Integer ub = UBound(h) + 1   ReDim Preserve h(ub)   h(ub) = h_   Return ubEnd Function'remove from end of listFunction 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 FunctionSub hex_list.del_()   Erase(h)End SubFunction hex_list.size() As Integer   Return UBound(h) + 1End FunctionFunction hex_list.last_index() As Integer   Return UBound(h)End Function'------------------------ a simple point <vextor> class ------------------------Type pt_dbl   Dim As Double x, yEnd TypeType 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 IntegerEnd Type'add to end of listFunction pt_list.push(pt_ As pt_dbl) As Integer   Dim As Integer ub = UBound(pt) + 1   ReDim Preserve pt(ub)   pt(ub) = pt_   Return ubEnd Function'remove from end of listFunction 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 FunctionSub pt_list.del_()   Erase(pt)End SubFunction pt_list.size() As Integer   Return UBound(pt) + 1End FunctionFunction 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_umnFunction 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 FunctionFunction 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_umnFunction 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 FunctionFunction 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 FunctionFunction 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 FunctionFunction 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 yEnd FunctionFunction 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 TypeDim 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 originEnd Type'Hex to PixelFunction 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 FunctionType hex_cube_frac    Dim As Double x, y, zEnd Type'hex cube roundingFunction 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,zEnd FunctionFunction 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 hexesEnd 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 FunctionFunction 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 cornersEnd FunctionSub 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   NextEnd Sub'-------------------------------------------------------------------------------#Include "fbgfx.bi"Const SW = 800, SH = 600ScreenRes SW, SH, 32Width SW \ 8, SH \ 16Dim 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, myDim As hex_cube hcDim As Integer map_radius = 12While 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 1WendGetKey()`

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.