While you search, I started my own port. Still work in progress, but some things are working.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
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()
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()