Tetris, but with hexagons

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

Tetris, but with hexagons

Still work in progress, but the basic piece control is implemented.
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 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)   Return Type(-a.y, -a.z, -a.x)End FunctionFunction 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'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 FunctionConst HEX_AX_RI_DN = 0Const HEX_AX_RI_UP = 1Const HEX_AX_UP = 2Const HEX_AX_LE_UP = 3Const HEX_AX_LE_DN = 4Const HEX_AX_DN = 5Dim 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))   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 SubSub 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 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 'distance from origin to a corner   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   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 pointsFunction 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 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 SubSub 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), cEnd 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 SelectEnd SubSub 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 = 600ScreenRes SW, SH, 32Width SW \ 8, SH \ 16Dim 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 radiusConst brd_rw = 7 'board width radiusConst brd_psr = -9 'piece start rowDim As ULong board(-brd_rh To +brd_rh, -brd_rh To +brd_rh)Const piece_size = 4Type 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_fillEnd TypeConst num_pieces = 9Dim 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 trueEnd 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 falseEnd FunctionSub 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   NextEnd SubSub 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)   NextEnd SubSub 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))   NextEnd SubSub 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 boardFunction 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_pieceEnd FunctionConst As Double start_interval = 1.0 '1 tiles per secondConst As Double drop_interval = 0.05 '20 tiles per secondDim As piece_type current_pieceDim As Double t = Timer, t_step = start_interval, t_next = t + t_stepDim As Integer enable_control = trueDim As Integer quit = 0, request_new = trueRandomize TimerWhile 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 = TimerWendLocate 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
Posts: 6296
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: Tetris, but with hexagons

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..
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

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':

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...
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

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:

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: 317
Joined: May 09, 2014 21:19
Location: Argentina

Re: Tetris, but with hexagons

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
Posts: 6296
Joined: Jul 05, 2005 17:32
Location: Manchester, Lancs

Re: Tetris, but with hexagons

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: 7005
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Tetris, but with hexagons

Squeeze through method.

Code: Select all

`Type pt       As Single x,yEnd TypeType hexagon      As pt h(1 To 6)      As Long idx,idy       As pt ctr      As boolean active      As boolean move      Dim As Long kEnd TypeFunction 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 FunctionFunction 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 zEnd FunctionFunction 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 FunctionFunction 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 wnEnd FunctionFunction 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 FunctionSub 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 nEnd SubSub 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 xEnd SubSub 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 IfEnd Sub'==============================================='Screen 20Dim As hexagon p(Any)Dim As Long mx,my,btn,flagtessellate(p(),30,.83)'startersDim 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=1NextDim As Long nDo      n+=1      If p(n).active=0 Then arraydelete(p(),n):n-=1 'clean out uneedded hexagonsLoop 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)NextDim As Single d,startDo      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=btnLoop Until Inkey=Chr(27)Sleep `
Dr_D
Posts: 2431
Joined: May 27, 2005 4:59
Contact:

Re: Tetris, but with hexagons

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: 1400
Joined: Jun 04, 2005 9:51

Re: Tetris, but with hexagons

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

Re: Tetris, but with hexagons

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.
Posts: 2340
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

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.