Tetris, but with hexagons

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

Tetris, but with hexagons

Post by badidea »

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

Re: Tetris, but with hexagons

Post by counting_pine »

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

Re: Tetris, but with hexagons

Post by badidea »

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

Re: Tetris, but with hexagons

Post by badidea »

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

Re: Tetris, but with hexagons

Post by xlucas »

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

Re: Tetris, but with hexagons

Post by counting_pine »

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

Re: Tetris, but with hexagons

Post by dodicat »

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: 2451
Joined: May 27, 2005 4:59
Contact:

Re: Tetris, but with hexagons

Post by Dr_D »

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

Re: Tetris, but with hexagons

Post by dafhi »

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

Re: Tetris, but with hexagons

Post by badidea »

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

Re: Tetris, but with hexagons

Post by badidea »

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.
IVAN0
Posts: 2
Joined: Nov 18, 2014 23:09

Re: Tetris, but with hexagons

Post by IVAN0 »

I like Tetris zelimir ikovic
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

Post by badidea »

IVAN0 wrote:I like Tetris zelimir ikovic
This hexagon version did not work out as I had hoped. Making lines is weird / difficult.
Regular tetris & special version at post #5 here: https://freebasic.net/forum/viewtopic.php?f=15&t=26306 (I hope it still works)
And another special version here: https://freebasic.net/forum/viewtopic.php?f=15&t=26893
And if you are getting tetris nightmares, here is a puzzle game with tiles made of 5 squares: https://freebasic.net/forum/viewtopic.p ... 0&p=134932 (from 2010, so some tweaking needed for the current compiler)
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Tetris, but with hexagons

Post by BasicCoder2 »

After looking at your first posts I actually tried to code my own version but couldn't sustain enough interest to debug and complete the project. I used bitmap images rather than compute the hexagons.
(have to convert this image to .bmp format)
Image

Image

Code: Select all

'  paver numbers
'            07
'
'
'12          01           08
'
'      06          02
'
'            00
'
'      05          03
'
'11          04           09
'
'
'            10   

screenres 606,606,32
'color rgb(0,0,0),rgb(255,25,255):cls

dim shared as any ptr hexImage,hexImage2
hexImage = imagecreate(29,29)
bload "hex.bmp",hexImage


type PAVER_GROUP
    as integer x        'center of pg GROUP
    as integer y
    as integer xd(0 to 12)   'up to twelve paver's displacement values
    as integer yd(0 to 12)
    as integer s(0 to 12)   'draw paver or not
    as ulong   c
end type

dim shared as PAVER_GROUP pg

pg.x = 300
pg.y = 57

for i as integer = 0 to 12
    read pg.xd(i)
    read pg.yd(i)
next i
pg.c = rgb(int(rnd(1)*256),int(rnd(1)*256),int(rnd(1)*256))

for i as integer = 0 to 12
    read pg.s(i)
next i

    

dim shared as integer xshift

function testHit() as boolean
    return TRUE
end function


sub drawDisplay()
    screenlock
    cls
    'draw background
    for y as integer = 1 to 580 step 14
        if xShift = 0 then xShift = 23 else xShift = 0
        for x as integer = 1 to 580 step 46
            put (x+xShift,y),hexImage,trans
        next x
    next y

    for i as integer = 0 to 12
        if pg.s(i)=1 then
          '  put    (pg.x+pg.xd(i),   pg.y+pg.yd(i)   ),hexImage,trans
            circle (pg.x+pg.xd(i)+14,pg.y+pg.yd(i)+14),11,pg.c,,,,f
           ' paint  (pg.x+pg.xd(i)+14,pg.y+pg.yd(i)+14),pg.c
        end if
    next i
    
    locate 1,1
    print "                     "
    print " SPACE KEY TO ROTATE "
    print " a = down left       "
    print " d = down right      "
    print " s = down            "
    print " x = exit program    "
    print "                     "
    screenunlock
end sub

drawDisplay()

dim as string key
dim as integer saveState
dim as ulong   colors

do
    key = inkey
    if key = "s" then
        if pg.y < 530 then
            pg.y = pg.y + 28  'move down
        end if
    end if
    if key = "a" then
        if pg.y < 530 and pg.x > 40 then
            pg.y = pg.y + 14  'move down to left
            pg.x = pg.x - 23
        end if
    end if
    if key = "d" then
        if pg.y < 530 and pg.x < 550 then
            pg.y = pg.y + 14  'move down to right
            pg.x = pg.x + 23
        end if
    end if
    
    if key = " " then  'rotate

        saveState = pg.s(1)
        pg.s(1)=pg.s(2)
        pg.s(2)=pg.s(3)
        pg.s(3)=pg.s(4)
        pg.s(4)=pg.s(5)
        pg.s(5)=pg.s(6)
        pg.s(6)=saveState

        
        saveState = pg.s(7)
        pg.s(7)=pg.s(8)
        pg.s(8)=pg.s(9)
        pg.s(9)=pg.s(10)
        pg.s(10)=pg.s(11)
        pg.s(11)=pg.s(12)
        pg.s(12)=saveState
        
        
    end if
    
    drawDisplay()
    sleep 2
    
loop until key = "x"

data 0,0, 0,-28, 23,-14, 23,14, 0,28, -23,14, -23,-14
data 0,-56, 46,-28, 46,+28, 0,56, -46,28, -46,-28
'    00  01  02  03  04  05  06  07  08  09  10  11  12
data 1,  1,  0,  0,  1,  0,  0,  1,  0,  0,  1,  0,  0
Some online examples:
https://www.youtube.com/watch?v=kHy0gCemyck
https://www.youtube.com/watch?v=5rykNQO9FfA
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Tetris, but with hexagons

Post by badidea »

Nice find, this "beetris" version is like mine. They solved the 'line removal issue' by allowing the left and right side to slide down independent. Feels a bit like cheating, but works better then what I have. Maybe I will update mine to that as well... (but I also have a new game planned).

BTW, hexagons are the best: https://www.youtube.com/watch?v=thOifuHs6eY
Post Reply