Tetris, but with hexagons

Game development specific discussions.
badidea
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Tetris, but with hexagons

Postby badidea » Jun 06, 2021 12:20

Still work in progress, but the basic piece control is implemented.
On GitHub: https://github.com/verybadidea/hexgrid (test_game_hexatris.bas) <-- For this latest version
Or the copy-and-paste conveniently concatenated version:

Code: Select all

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

#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)
   Return Type(-a.y, -a.z, -a.x)
End Function

Function hex_rotate_right(a As hex_cube) As hex_cube
   'return type(-a.y, -a.z, -a.x)
   Return Type(-a.z, -a.x, -a.y)
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

Const HEX_AX_RI_DN = 0
Const HEX_AX_RI_UP = 1
Const HEX_AX_UP = 2
Const HEX_AX_LE_UP = 3
Const HEX_AX_LE_DN = 4
Const HEX_AX_DN = 5

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))
   Return Type(ha.q, -(ha.q + ha.r), ha.r)
End Function

'------------------------------- axial rotation --------------------------------

Sub hex_axial_rotate_right(ByRef ha As hex_axial)
   ha = hex_cube_to_axial(hex_rotate_right(hex_axial_to_cube(ha)))
End Sub

Sub hex_axial_rotate_left(ByRef ha As hex_axial)
   ha = hex_cube_to_axial(hex_rotate_left(hex_axial_to_cube(ha)))
End Sub

'--------------------------------- 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 'distance from origin to a corner
   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
   size.x *= 0.85
   size.y *= 0.85
   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

'a bit complex way to make an array of 6 points
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 (clockwise)
      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

Sub draw_triangle_filled(pt1 As pt_dbl, pt2 As pt_dbl, pt3 As pt_dbl, c As ULong)
   Dim As Integer x, y, xmid
   Dim As Double x1, x2
   Dim As Double dx12, dx13, dx23
   'order top to bottom
   If (pt1.y > pt2.y) Then Swap pt1, pt2
   If (pt1.y > pt3.y) Then Swap pt1, pt3
   If (pt2.y > pt3.y) Then Swap pt2, pt3
   'calculate line slopes
   dx12 = (pt2.x - pt1.x) / (pt2.y - pt1.y)
   dx13 = (pt3.x - pt1.x) / (pt3.y - pt1.y)
   dx23 = (pt3.x - pt2.x) / (pt3.y - pt2.y)
   'Upper half triangle
   x1 = pt1.x
   x2 = pt1.x
   For y = pt1.y To pt2.y - 1
      Line (x1, y)-(x2, y), c
      x1 += dx12
      x2 += dx13
   Next
   'lower half triangle
   x1 = pt2.x' + dx23 / 2
   For y = pt2.y To pt3.y
      Line (x1, y)-(x2, y), c
      x1 += dx23
      x2 += dx13
   Next
   'make edges nice (optional)
   'line (pt1.x, pt1.y)-(pt2.x, pt2.y), c
   'line (pt2.x, pt2.y)-(pt3.x, pt3.y), c
   'line (pt3.x, pt3.y)-(pt1.x, pt1.y), c
End Sub

Sub hex_draw_filled(layout As hex_layout, h As hex_axial, c_fill As ULong)
   Dim As pt_dbl center = hex_to_pixel(layout, h)
   'create + fill array with 6 conners positions
   Dim As pt_dbl corner(0 To 5)
   For i As Integer = 0 To 5 'loop 6 corners (clockwise)
      Dim As pt_dbl offset = hex_corner_offset(layout, i)
      corner(i) = Type(center.x + offset.x, center.y + offset.y)
   Next
   Select Case layout.orientation.start_angle
   Case 0.0 'flat top
      Line(corner(4).x, corner(4).y)-(corner(1).x, corner(1).y), c_fill, bf
      draw_triangle_filled(corner(0), corner(1), corner(5), c_fill)
      draw_triangle_filled(corner(2), corner(3), corner(4), c_fill)
   Case 0.5 'pointy top
      Line(corner(3).x, corner(3).y)-(corner(0).x, corner(0).y), c_fill, bf
      draw_triangle_filled(corner(0), corner(1), corner(2), c_fill)
      draw_triangle_filled(corner(3), corner(4), corner(5), c_fill)
   End Select
End Sub

Sub hex_draw_filled_border(layout As hex_layout, h As hex_axial, c_fill As ULong, c_border As ULong)
   Dim As pt_dbl center = hex_to_pixel(layout, h)
   'create + fill array with 6 conners positions
   Dim As pt_dbl corner(0 To 5)
   For i As Integer = 0 To 5 'loop 6 corners (clockwise)
      Dim As pt_dbl offset = hex_corner_offset(layout, i)
      corner(i) = Type(center.x + offset.x, center.y + offset.y)
   Next
   Select Case layout.orientation.start_angle
   Case 0.0 'flat top
      Line(corner(4).x, corner(4).y)-(corner(1).x, corner(1).y), c_fill, bf
      draw_triangle_filled(corner(0), corner(1), corner(5), c_fill)
      draw_triangle_filled(corner(2), corner(3), corner(4), c_fill)
   Case 0.5 'pointy top
      Line(corner(3).x, corner(3).y)-(corner(0).x, corner(0).y), c_fill, bf
      draw_triangle_filled(corner(0), corner(1), corner(2), c_fill)
      draw_triangle_filled(corner(3), corner(4), corner(5), c_fill)
   End Select
   hex_draw_outline(layout, h, c_border)
End Sub

#Define hex_draw_o   hex_draw_outline
#Define hex_draw_f   hex_draw_filled
#Define hex_draw_fb   hex_draw_filled_border

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

#Define rnd_int_rng(a, b) Int(Rnd * (((b) - (a)) + 1)) + (a)

Const As String KEY_UP = Chr(255, 72)
Const As String KEY_DN = Chr(255, 80)
Const As String KEY_LE = Chr(255, 75)
Const As String KEY_RI = Chr(255, 77)
Const As String KEY_ESC = Chr(27)
Const As String KEY_SPC = Chr(32)

#Include "fbgfx.bi"
Const SW = 400, SH = 600
ScreenRes SW, SH, 32
Width SW \ 8, SH \ 16

Dim As hex_layout layout1 = _
   Type(layout_flat, Type<pt_dbl>(17, 16.2), Type<pt_dbl>(SW \ 2, SH \ 2))

Const brd_rh = 10 'board height radius
Const brd_rw = 7 'board width radius
Const brd_psr = -9 'piece start row
Dim As ULong board(-brd_rh To +brd_rh, -brd_rh To +brd_rh)

Const piece_size = 4
Type piece_type
   Dim As hex_axial abs_pos
   Dim As hex_axial tile_pos(piece_size - 1) '0 to 3
   'dim as hex_axial tile_rot 'tile to rotate around --> NOT NEEDED?
   Dim As ULong c_fill
End Type

Const num_pieces = 9
Dim As piece_type piece(num_pieces-1) = {_ '(q, r)
   Type((0, 0), {(0, -1), (0, 0), (0, 1), (0, 2)},   &hff007070),_
   Type((0, 0), {(0, -1), (0, 0), (0, 1), (1, 1)},   &hff700070),_
   Type((0, 0), {(0, -1), (0, 0), (0, 1), (-1, 0)},  &hff707000),_
   Type((0, 0), {(0, -1), (0, 0), (0, 1), (1, -1)},  &hff700000),_
   Type((0, 0), {(0, -1), (0, 0), (0, 1), (-1, 2)},  &hff007000),_
   Type((0, 0), {(0, -1), (1, -1), (1, 0), (0, 1)},  &hff400070),_
   Type((0, 0), {(0, -1), (1, -1), (1, 0), (0, 1)},  &hff704000),_
   Type((0, 0), {(0, -1), (0, 0), (1, 0), (1, 1)},   &hff004070),_
   Type((0, 0), {(0, -1), (0, 0), (-1, 1), (-1, 2)}, &hff507000)}

Function get_tile_pos(piece As piece_type, tile_idx As Integer) As hex_axial
   Return hex_axial_add(piece.abs_pos, piece.tile_pos(tile_idx))
End Function

'valid board tile index?
Function valid_tile_pos(ha As hex_axial) As boolean
   Dim As hex_cube hc = hex_axial_to_cube(ha)
   Return (Abs(hc.x) <= brd_rw) And (Abs(hc.y) <= brd_rh) And (Abs(hc.z) <= brd_rh)
End Function

'all tiles valid board index & not occupied?
Function free_piece_pos(piece As piece_type, board() As ULong) As boolean
   For iTile As Integer = 0 To piece_size - 1
      Dim As hex_axial ha = get_tile_pos(piece, iTile)
      If Not valid_tile_pos(ha) Then Return false
      If board(ha.q, ha.r) <> 0 Then Return false
   Next
   Return true
End Function

'function is correct for all cases!
Function pos_off_screen(layout As hex_layout, ha As hex_axial) As boolean
   Dim As pt_dbl pt = hex_to_pixel(layout, ha)
   If pt.x + layout.size.x < 0 Then Return true 'left of screen
   If pt.x - layout.size.x > SW Then Return true 'right of screen
   If pt.y + layout.size.y < 0 Then Return true 'above screen
   If pt.y - layout.size.y > SH Then Return true 'below screen
   Return false
End Function

Sub draw_board(board() As ULong, layout As hex_layout)
   Dim As hex_axial ha
   For q As Integer = -(brd_rh-2) To +(brd_rh-2)
      ha.q = q
      For r As Integer = -(brd_rh+5) To +(brd_rh+5)
         ha.r = r
         If pos_off_screen(layout, ha) = false Then
            If valid_tile_pos(ha) Then
               If board(q, r) <> 0 Then
                  'piece tile, with bright edge
                  hex_draw_fb(layout, ha, board(q, r), board(q, r) ShL 1)
               Else
                  'no piece tile on board
                  hex_draw_o(layout, ha, &hff404040)
               End If
            Else
               'outside board
               hex_draw_fb(layout, ha, &hff505050, &hff909090)
            End If
         End If
      Next
   Next
End Sub

Sub draw_piece(piece As piece_type, layout As hex_layout)
   For iTile As Integer = 0 To piece_size - 1
      Dim As ULong c_fill = piece.c_fill
      Dim As ULong c_border = &hff000000 Or (c_fill ShL 1) 'double intensity
      'dim as hex_axial ha = hex_axial_add(current_piece.tile_pos(iTile), current_piece.abs_pos)
      Dim As hex_axial ha = get_tile_pos(piece, iTile)
      hex_draw_filled_border(layout, ha, c_fill, c_border)
   Next
End Sub

Sub rotate_piece(ByRef piece As piece_type, direction As Integer)
   Dim pRotFunc As Sub (ByRef ha As hex_axial) 'subroutine pointer
   pRotFunc = IIf(direction > 0, @hex_axial_rotate_right, @hex_axial_rotate_left)
   For iTile As Integer = 0 To piece_size - 1
      pRotFunc(piece.tile_pos(iTile))
   Next
End Sub

Sub move_piece(ByRef piece As piece_type, direction As Integer)
   piece.abs_pos = hex_axial_neighbor(piece.abs_pos, direction)
End Sub

'choose random piece and position at top of board
Function new_piece(piece() As piece_type) As piece_type
   Dim As piece_type ret_piece = piece(Int(Rnd() * num_pieces))
   ret_piece.abs_pos.r = brd_psr
   Return ret_piece
End Function

Const As Double start_interval = 1.0 '1 tiles per second
Const As Double drop_interval = 0.05 '20 tiles per second

Dim As piece_type current_piece
Dim As Double t = Timer, t_step = start_interval, t_next = t + t_step
Dim As Integer enable_control = true
Dim As Integer quit = 0, request_new = true

Randomize Timer
While quit = 0
   If request_new = true Then
      current_piece = new_piece(piece())
      request_new = false
   End If

   ScreenLock
   Line(0, 0)-(SW-1, SH-1), 0, bf 'clear screen
   draw_board(board(), layout1)
   If free_piece_pos(current_piece, board()) Then
      draw_piece(current_piece, layout1)
   End If
   Draw String (5, 0), "keys: up, down, left, right, space, escape"
   ScreenUnLock

   Dim As String key = InKey
   If enable_control = true Then
      Select Case key
      Case KEY_ESC
         quit = 1
      Case KEY_LE
         move_piece(current_piece, HEX_AX_LE_DN)
         If Not free_piece_pos(current_piece, board()) Then
            move_piece(current_piece, HEX_AX_RI_UP) 'undo move
         End If
      Case KEY_RI
         move_piece(current_piece, HEX_AX_RI_DN)
         If Not free_piece_pos(current_piece, board()) Then
            move_piece(current_piece, HEX_AX_LE_UP) 'undo move
         End If
      Case KEY_UP
         rotate_piece(current_piece, +1)
         If Not free_piece_pos(current_piece, board()) Then
            rotate_piece(current_piece, -1) 'undo move
         End If
      Case KEY_DN
         rotate_piece(current_piece, -1)
         If Not free_piece_pos(current_piece, board()) Then
            rotate_piece(current_piece, +1) 'undo move
         End If
      Case KEY_SPC
         enable_control = false
         current_piece.abs_pos.r += 1
         t_step = drop_interval
         t_next = t + t_step
      End Select
   End If
   If t > t_next Then
      current_piece.abs_pos.r += 1
      t_next = t + t_step
      If Not free_piece_pos(current_piece, board()) Then
         current_piece.abs_pos.r -= 1
         'copy to board
         For iTile As Integer = 0 To piece_size - 1
            Dim As hex_axial ha = get_tile_pos(current_piece, iTile)
            If valid_tile_pos(ha) Then 'redundant check
               board(ha.q, ha.r) = current_piece.c_fill
            End If
         Next
         request_new = true
         enable_control = true
         t_step = start_interval
         t_next = t + t_step
      End If
   End If
   Sleep 1
   t = Timer
Wend
Locate 13, 13: Print "End, press any key to exit"

GetKey()

'steps:
'implement 'wall-kick'
'points / scoring: make lines, shift/drop board
'check cannot place piece on start pos: game over
'check line drop down/left and/or down right
'drop position preview (option)

'~ 'show all pieces
'~ for iPiece as integer = 0 to num_pieces-1
   '~ current_piece = piece(iPiece)
   '~ rotate_piece(current_piece, 1)
   '~ current_piece.abs_pos.r = iPiece * 2 - 9
   '~ current_piece.abs_pos.q = ((iPiece+1) mod 2) * 6 - 3
   '~ draw_piece(current_piece, layout1)
'~ next
'~ getkey()
'~ end
Last edited by badidea on Jun 21, 2021 23:22, edited 2 times in total.
counting_pine
Site Admin
Posts: 6295
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: Tetris, but with hexagons

Postby counting_pine » Jun 06, 2021 15:39

Looks nice!
It might be slightly neater if you use slightly irregular hexagons and 2:1 gradients on the lines.
I think I hit one instance where I managed to overlap existing tiles with a new piece. I'm not sure exactly how, but it probably had something to do with rotation, and it might have been near an edge..
badidea
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

Postby badidea » Jun 06, 2021 22:19

counting_pine wrote:It might be slightly neater if you use slightly irregular hexagons and 2:1 gradients on the lines.

Yes, it is not really 'pixel perfect':
Image
I'll try to improve it, but the underlying hexagon math is with floating points (based on https://www.redblobgames.com/grids/hexagons/) which may complicate 'pixel perfection'.

counting_pine wrote:I think I hit one instance where I managed to overlap existing tiles with a new piece. I'm not sure exactly how, but it probably had something to do with rotation, and it might have been near an edge..

That would be a bug. I have not been able to reproduce that yet. But more functionality to be implemented, so more testing needed anyway...
badidea
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

Postby badidea » Jun 19, 2021 0:51

I am a bit stuck on the progress of this game as I have not decided yet what should happen when a line is made.
In normal (squares) tetris, all blocks move down. That is not always possible in this version as can be seen in these two screenshots:
Image Image
a) I could change the shape of the board to prevent the whole issue, but I like this layout.
b) I could just not lower the tiles if one is 'blocking' and leave the line open.
c) I could change the tetris physics and let isolated parts drop individually, but I want too stick to the original as much as is possible.
And I probable have to move tiles down diagonal (left-down or right-down) else crossing lines is a problem (2nd image).
So probably (b) with the diagonal movement, but i'll give it another thought...
xlucas
Posts: 314
Joined: May 09, 2014 21:19
Location: Argentina

Re: Tetris, but with hexagons

Postby xlucas » Jun 21, 2021 22:44

Hey! This looks super neat! I love this idea!

In my opinion, you shouldn't allow for moving up-left or up-right, since this would make it possible to keep a piece floating indefinitely, but if you can find a very imaginative way of allowing it without this happening, it could be interesting.

In my mind, before trying it, I felt it was going to be uncomfortable and difficult to get the pieces in place, but once I was playing it, all felt really smooth and natural, so I think you're doing it very well.

Regarding filling lines, my idea would be that you don't delete "horizontal rows", but diagonal lines, when filled, and that you can fill either up-left to down-right or down-left to up-right and any of the two happening would result in the whole diagonal line to be deleted. Then, all pieces above that line would fall one place down (not diagonally). It looks like that should be possible always. Or is there something I haven't seen?
counting_pine
Site Admin
Posts: 6295
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: Tetris, but with hexagons

Postby counting_pine » Jun 22, 2021 13:57

Looking good.
I think that it's possible to complete a left and right diagonal line at the same time, thus removing a 'V' shape. I think the only logical response in that case is to shift everything above downward.
EDIT: never mind, I thought you were thinking of doing diagonal shifts, which wouldn't be possible in this case, but on a more careful reading it doesn't sound like you're thinking that.
dodicat
Posts: 6993
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Tetris, but with hexagons

Postby dodicat » Jun 23, 2021 23:20

Squeeze through method.

Code: Select all


Type pt
      As Single x,y
End Type

Type hexagon
      As pt h(1 To 6)
      As Long idx,idy
      As pt ctr
      As boolean active
      As boolean move
      Dim As Long k
End Type

Function rotate2d(pivot As pt,p As pt,a As Single,scale As Single=1) As pt
      Var rotx=scale*(Cos(a*.0174533)*(p.x-pivot.x)-Sin(a*.0174533)*(p.y-pivot.y))+pivot.x
      Var roty=scale*(Sin(a*.0174533)*(p.x-pivot.x)+Cos(a*.0174533)*(p.y-pivot.y))+pivot.y
      Return Type(rotx,roty)
End Function

Function rothex(p As hexagon,angle As Single) As hexagon
      Dim As hexagon z=p
      For n As Long=1 To 6
            Var r= rotate2d(p.ctr,p.h(n),angle)
            z.h(n)=r
      Next n
      Return z
End Function

Function dist(p1 As hexagon,p2 As hexagon) As Single
      If p1.ctr.x=p2.ctr.x Then Return 5000
      Return Sqr((p1.ctr.x-p2.ctr.x)^2 + (p1.ctr.y-p2.ctr.y)^2)
End Function

Function inpolygon(p1() As Pt,Byval p2 As Pt) As Long
      #define Winder(L1,L2,p) -Sgn((L1.x-L2.x)*(p.y-L2.y)-(p.x-L2.x)*(L1.y-L2.y))
      Dim As Long index,nextindex,k=Ubound(p1)+1,wn
      For n As Long=1 To Ubound(p1)
            index=n Mod k:nextindex=(n+1) Mod k
            If nextindex=0 Then nextindex=1
            If p1(index).y<=p2.y Then
                  If p1(nextindex).y>p2.y Andalso  Winder(p1(index),p1(nextindex),p2)>0 Then wn+=1
            Else
                  If p1(nextindex).y<=p2.y Andalso Winder(p1(index),p1(nextindex),p2)<0 Then wn-=1
            End If
      Next n
      Return wn
End Function

Function drawhexagon(p As hexagon, col As Ulong,flag As Long) As pt
      If p.active=false Then Exit Function
      Dim k As Long=7
      Dim As Long index,nextindex
      Dim As Single cx,cy
      For n As Long=1 To 6
            index=n Mod k:nextindex=(n+1) Mod k
            If nextindex=0 Then nextindex=1
            Line (p.h(index).x,p.h(index).y)-(p.h(nextindex).x,p.h(nextindex).y),col
            cx+=p.h(n).x:cy+=p.h(n).y
      Next
      cx/=6:cy/=6
      If flag Then Paint(cx,cy),col,col
      Return Type(cx,cy)
End Function

Sub shrink(p As hexagon,f As Single)
      Dim As pt c
      For n As Long=1 To 6
            c.x+=p.h(n).x
            c.y+=p.h(n).y
      Next n
      c.x/=6
      c.y/=6
      p.ctr=c
      For n As Long=1 To 6
            p.h(n).x= c.x-(c.x-p.h(n).x)*f
            p.h(n).y= c.y-(c.y-p.h(n).y)*f
      Next n
End Sub

Sub tessellate(pts() As hexagon,r As Single,f As Single=1)
      Dim As Integer xres,yres
      Screeninfo xres,yres
      #macro _hex(p,r)
      Scope
            Dim As Long ctr
            For z As Single=0 To 360 Step 360/6
                  Var x=p.x+r*Cos(z*.0174533)
                  Var y=p.y+r*Sin(z*.0174533)
                  ctr+=1   
                  If ctr>6 Then Exit For
                  pts(ctr2).h(ctr)=Type(x,y)
            Next z
           
      End Scope
      #endmacro
      Dim As pt hp
      Dim As Single x,y,z
      Dim As Long k=1,ctr2,ctrx,ctry
      For x =r To xres-r Step r+r/2
            Var h=.86603*r/2
            z=h*k
            ctrx+=1
            ctry=0
            For y =z+r+r\2 To yres-r Step Sqr(3)*r
                  ctry+=1
                  hp=Type<pt>(x,y)
                  ctr2+=1
                  Redim Preserve pts(1 To ctr2)
                  pts(ctr2).idx=ctrx-1
                  pts(ctr2).idy=ctry-1 
                  _hex(hp,r)
                  shrink(pts(ctr2),f)
            Next y
            k=-k
      Next x
End Sub

Sub arraydelete(a() As hexagon,index As Long)
      If index>=Lbound(a) And index<=Ubound(a) Then
            For x As Integer=index To Ubound(a)-1
                  a(x)=a(x+1)
            Next x
            Redim Preserve a(Lbound(a) To Ubound(a)-1)
      End If
End Sub

'==============================================='
Screen 20
Dim As hexagon p(Any)
Dim As Long mx,my,btn,flag
tessellate(p(),30,.83)'starters
Dim As hexagon A0(Lbound(p) To Ubound(p))
Dim As hexagon A30(Lbound(p) To Ubound(p))
Dim As hexagon w(Lbound(p) To Ubound(p))

For n As Long=Lbound(p) To Ubound(p) 'select a few to suit
      If p(n).idy=0 And p(n).idx Mod 2=1 And p(n).idx Mod 3=1 Then p(n).active=true
      If p(n).ctr.y>200 And p(n).ctr.y<650 And p(n).idx Mod 2=0 Then  p(n).active=true':rothex(p(n),30)
      p(n).k=1
Next

Dim As Long n
Do
      n+=1
      If p(n).active=0 Then arraydelete(p(),n):n-=1 'clean out uneedded hexagons
Loop Until n=Ubound(p)

For n As Long=Lbound(p) To Ubound(p)'create flip arrays
      A0(n)=p(n)
      w(n)=p(n)
      A30(n)=rothex(p(n),30)
Next

Dim As Single d,start
Do
      Getmouse mx,my,,btn
      Screenlock
      Cls
      if start=0 then
            locate 2,15
            print "click these off to start"
            end if
     
      Randomize 1
      For n As Long=Lbound(p) To Ubound(p)
            drawhexagon(w(n),1+Rnd*8,1)
            drawhexagon(w(n),15,0)
            If inpolygon(p(n).h(),Type(mx,my)) And btn=1 And p(n).ctr.y<100 Then
                  start=1
                  drawhexagon(w(n),4,1):Draw String(0,0),Str(p(n).idx)+","+Str(p(n).idy)
                  p(n).move=true
                  A0(n).move=true
                  A30(n).move=true
                  w(n).move=true
            End If
      Next n
     
      For n As Long=Lbound(p) To Ubound(p)
            If p(n).move Then
                  A0(n).ctr.y+=1*A0(n).k
                  A30(n).ctr.y+=1*A30(n).k
                  w(n).ctr.y+=1*w(n).k
                  If w(n).ctr.y>(768-20) Or w(n).ctr.y<20 Then
                        A0(n).k=-A0(n).k
                        A30(n).k=-A30(n).k
                        w(n).k=-w(n).k
                  End If
                  For m As Long=1 To 6
                        A0(n).h(m).y+=1*A0(n).k
                        A30(n).h(m).y+=1*A30(n).k
                        w(n).h(m).y+=1*w(n).k
                  Next m
            End If
      Next n
     
      For n As Long=Lbound(p) To Ubound(p)-1
            For m As Long=n+1 To Ubound(p)
                  d=5000
                  If w(n).move Or w(m).move Then
                        d=dist(w(n),w(m))
                        If d<55  Then
                              w(n)=A30(n)
                              w(m)=A30(m)
                        End If
                        If d>65 And d<66  Then
                              w(m)=A0(m)
                              w(n)=A0(n)
                        End If
                  End If     
            Next m
      Next n
     
      Screenunlock
      Sleep 1
      flag=btn
Loop Until Inkey=Chr(27)

Sleep

 
Dr_D
Posts: 2431
Joined: May 27, 2005 4:59
Contact:

Re: Tetris, but with hexagons

Postby Dr_D » Jul 05, 2021 18:04

This is really cool, but I must say it's very hard. I was unable to complete a single line.
Very cool though... I think I just need more practice! lol
dafhi
Posts: 1389
Joined: Jun 04, 2005 9:51

Re: Tetris, but with hexagons

Postby dafhi » Jul 08, 2021 7:14

how did i not try this until now? i love it! yes it is hard
badidea
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

Postby badidea » Jul 08, 2021 21:37

I should continue with this, but I keep getting distracted by other stuff.
Due to the weird coordinate system, seemingly simple things (like looping a row) are not that simple.
badidea
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

Postby badidea » Jul 12, 2021 0:34

The full line removal (with drop of all blocks if possible) is now implemented. GitHub link first post.

They say that people who play a lot of Tetris, start dreaming of Tetris blocks. Also know as the Tetris effect.
'Tetris nightmare' seems like good name for this version. Unfortunately someone already made a 'Tetris nightmare', but that version is in flash and flash is dead now, so that doesn't count.

Return to “Game Dev”

Who is online

Users browsing this forum: No registered users and 2 guests