As you will see, the goal is not to make lines, but same color shapes >= 4 blocks. Floating 'leftovers' will drop afterwards.
Github link: https://github.com/verybadidea/tetrisame
Single file version:
Code: Select all
'* Initial date = 2023-08-17
'* Fbc = 1.09.0, 32/64-bit, linux-x86
'* Indent = tab
'This variation of tetris is a programming excercise, if you like playing teris,
'consider buying as officially licenced teris game from the original creator:
'Алексе́й Леони́дович Па́житнов: https://en.wikipedia.org/wiki/Alexey_Pajitnov
'Note: I made this program as one file to make it easier to post on the forum.
' The code can be easily converted to seperate .bas and .bi files, the
' comments show where to split the files. Declarations and constants to
' .bi files, the rest in the .bas files.
'Controls: Up, Down, Left, Rigt, Space, Escape
'Score: ????
Const As Integer SCREEN_W = 800
Const As Integer SCREEN_H = SCREEN_W
Width SCREEN_W \ 8, SCREEN_H \ 16
Const As ULong C_BLACK = &h00000000
Const As ULong C_DARK_GRAY = &h00404040
Const As ULong C_GRAY = &h00808080
Const As ULong C_LIGHT_GRAY = &h00C0C0C0
Const As ULong C_WHITE = &h00F0F0F0
Const As ULong C_RED = &h00F04040
Const As ULong C_DARK_RED = &h00A02020
Const As ULong C_YELLOW = &h00F0F000
'clockwise like in pieces class
Const As Integer DIR_DN = 0
Const As Integer DIR_LE = 1
Const As Integer DIR_UP = 2
Const As Integer DIR_RI = 3
Sub panic(text As String)
ScreenUnLock()
Print "Panic: " & text
GetKey()
End -1
End Sub
Sub imageKill(p_img As Any Ptr)
ImageDestroy(p_img)
p_img = 0
End Sub
Function inRange(value As Integer, min As Integer, max As Integer) As Integer
If value >= min And value <= max Then
Return true
Else
Return false
End If
End Function
'~ type int2d
'~ dim as integer x, y
'~ end type
'~ operator + (v1 as int2d, v2 as int2d) as int2d
'~ return type(v1.x + v2.x, v1.y + v2.y)
'~ end operator
Const As UShort KEY_UP = &h48FF
Const As UShort KEY_RI = &h4DFF
Const As UShort KEY_DN = &h50FF
Const As UShort KEY_LE = &h4BFF
Const As UShort KEY_W = &h77
Const As UShort KEY_A = &h61
Const As UShort KEY_S = &h73
Const As UShort KEY_D = &h64
'const as ushort KEY_P = &h50
Const As UShort KEY_P = &h70
Const As UShort KEY_ENTER = &h0D
Const As UShort KEY_ESC = &h1B
Const As UShort KEY_TAB = &h09
Const As UShort KEY_BACK = &h08
Const As UShort KEY_SPACE = &h20
Function waitKeyCode() As UShort
Return GetKey() 'getkey is weird
End Function
Function pollKeyCode() As UShort
Dim As String key = InKey()
If (key = "") Then Return 0
If (key[0] = 255) Then
Return *Cast(UShort Ptr, StrPtr(key))
'return (key[1] shl 8) or key[0]
Else
Return key[0]
End If
End Function
'===============================================================================
Type sgl2d_fwd As sgl2d
Type int2d_fwd As int2d
Type int2d
Dim As Integer x, y
'declare constructor
'declare constructor(x as integer, y as integer)
Declare Operator Cast () As String
'~ declare operator cast () byref as sgl2d_fwd
'~ declare operator let (v as sgl2d_fwd)
End Type
'~ constructor int2d
'~ end constructor
'~ constructor int2d(x as integer, y as integer)
'~ this.x = x : this.y = y
'~ end constructor
Type sgl2d
Dim As Single x, y
Declare Operator Cast () As String
'~ declare operator cast () byref as int2d_fwd
'~ declare operator let (v as int2d_fwd)
End Type
'-------------------------------------------------------------------------------
Operator int2d.cast () As String
Return "(" & Str(x) & "," & Str(y) & ")"
End Operator
'~ operator int2d.cast () byref as sgl2d
'~ static as sgl2d temp
'~ temp.x = x
'~ temp.y = y
'~ return temp
'~ end operator
'~ operator int2d.let (v as sgl2d)
'~ x = cint(v.x)
'~ y = cint(v.y)
'~ end operator
Operator = (a As int2d, b As int2d) As boolean
If a.x <> b.x Then Return false
If a.y <> b.y Then Return false
Return true
End Operator
Operator + (v1 As int2d, v2 As int2d) As int2d
Return Type(v1.x + v2.x, v1.y + v2.y)
End Operator
'-------------------------------------------------------------------------------
Operator sgl2d.cast () As String
Return "(" & Str(x) & "," & Str(y) & ")"
End Operator
'~ operator sgl2d.cast () byref as int2d
'~ static as int2d temp
'~ temp.x = cint(x)
'~ temp.y = cint(y)
'~ return temp
'~ end operator
'~ operator sgl2d.let (v as int2d)
'~ x = v.x
'~ y = v.y
'~ end operator
Operator + (v1 As sgl2d, v2 As sgl2d) As sgl2d
Return Type(v1.x + v2.x, v1.y + v2.y)
End Operator
Operator * (v As sgl2d, mul As Single) As sgl2d
Return Type(v.x * mul, v.y * mul)
End Operator
Function distSql(p1 As sgl2d, p2 As sgl2d) As Single
Dim As Single dx = p1.x - p2.x
Dim As Single dy = p1.y - p2.y
Return Sqr(dx * dx + dy * dy)
End Function
'-------------------------------------------------------------------------------
Function toInt2d(v As sgl2d) As int2d
Return Type(Int(v.x), Int(v.y))
End Function
Function toCint2d(v As sgl2d) As int2d
Return Type(CInt(v.x), CInt(v.y))
End Function
Function toSgl2d(v As int2d) As sgl2d
Return Type(v.x, v.y)
End Function
'===============================================================================
Type timer_type
Private:
Dim As Double tEnd
Dim As Double tStart
Dim As Double tSpan
Dim As Integer active
Public:
Declare Sub start(duration As Double)
Declare Function inactive() As boolean
Declare Function ended() As boolean
Declare Sub restart()
Declare Sub pause()
Declare Sub unpause()
End Type
Sub timer_type.start(duration As Double)
tStart = Timer()
tSpan = duration
tEnd = tStart + tSpan
active = 1
End Sub
'does NOT update the timer status
Function timer_type.inactive() As boolean
If active = 0 Then Return true
End Function
Function timer_type.ended() As boolean
If active = 0 Then Return false
If Timer() >= tEnd Then
active = 0
Return true
Else
Return false
End If
End Function
'continue timer, add same delay to original tStart
Sub timer_type.restart()
tStart = tEnd
tEnd = tStart + tSpan
active = 1
End Sub
Sub timer_type.pause()
active = 0
End Sub
Sub timer_type.unpause()
tStart = Timer()
tEnd = tStart + tSpan
active = 1
End Sub
'===============================================================================
'contains all piece tiles in all rotations + unrotated base_piece tiles
Const As Integer N_SHAPES = 7
Const As Integer N_COLORS = 4 'N_SHAPES
Const As Integer N_TILES = 4
Const As Integer T_I = 0
Const As Integer T_J = 1
Const As Integer T_L = 2
Const As Integer T_O = 3
Const As Integer T_S = 4
Const As Integer T_T = 5
Const As Integer T_Z = 6
Dim Shared As Const ULong colors(N_SHAPES-1) = {_ 'req: N_SHAPES >= N_COLORS
&h00F0F0,_ 'lightblue
&h0000F0,_ 'blue
&hF0A000,_ 'orange
&hF0F000,_ 'yellow
&h00F000,_ 'green
&HA000F0,_ 'purple
&hF00000} 'red
Type all_pieces
Dim As int2d baseTilePos(N_SHAPES-1, N_TILES-1) = _
{_
{( 0, 1), ( 1, 1), ( 2, 1), ( 3, 1)}, _ 'I
{( 0, 0), ( 0, 1), ( 1, 1), ( 2, 1)}, _ 'J
{( 2, 0), ( 0, 1), ( 1, 1), ( 2, 1)}, _ 'L
{( 0, 0), ( 0, 1), ( 1, 0), ( 1, 1)}, _ 'O
{( 1, 0), ( 2, 0), ( 0, 1), ( 1, 1)}, _ 'S
{( 1, 0), ( 0, 1), ( 1, 1), ( 2, 1)}, _ 'T
{( 0, 0), ( 1, 0), ( 1, 1), ( 2, 1)} _ 'Z
}
Dim As int2d offsetPos(N_SHAPES-1) = _
{( 0, 0), ( 0, 0), ( 0, 0), ( 1, 0), ( 0, 0), ( 0, 0), ( 0, 0)}
Dim As Integer areaSize(N_SHAPES-1) = _
{4, 3, 3, 2, 3, 3, 3}
End Type
'-------------------------------------------------------------------------------
'~ const as integer PIECE_O = 0
'~ const as integer PIECE_I = 1
'~ const as integer PIECE_S = 2
'~ const as integer PIECE_Z = 3
'~ const as integer PIECE_L = 4
'~ const as integer PIECE_J = 5
'~ const as integer PIECE_T = 6
'~ dim shared as const ulong pieceColor(NUM_PIECES-1) = {&h00FFFF00, &h0000FFFF, _
'~ &h0000FF00, &h00FF0000, &h00FFAA00, &h000000FF, &h009900FF}
'~ dim shared as const ulong pieceColor(NUM_PIECES-1) = {_
'~ &h00F0F0,_ 'lightblue
'~ &h0000F0,_ 'blue
'~ &hF0A100,_ 'orange
'~ &hF0F000,_ 'yellow
'~ &h00E000,_ 'green
'~ &H922B8C,_ 'purple
'~ &hF00000} 'red
'~ 'Official colors:
'~ ' Yellow O
'~ ' Cyan I
'~ ' Green S
'~ ' Red Z
'~ ' Orange L
'~ ' Blue J
'~ ' Purple T
'~ type pieces_type
'~ private:
'~ dim as int2d baseTilePos(NUM_PIECES-1, NUM_SQUARES-1) = _
'~ {_
'~ {(-1, 0), ( 0, 0), (-1, +1), ( 0, +1)}, _ 'O
'~ {(-2, 0), (-1, 0), ( 0, 0), (+1, 0)}, _ 'I
'~ {( 0, 0), (+1, 0), (-1, +1), ( 0, +1)}, _ 'S
'~ {(-1, 0), ( 0, 0), ( 0, +1), (+1, +1)}, _ 'Z
'~ {(-1, 0), ( 0, 0), (+1, 0), (-1, +1)}, _ 'L
'~ {(-1, 0), ( 0, 0), (+1, 0), (+1, +1)}, _ 'J
'~ {(-1, 0), ( 0, 0), (+1, 0), ( 0, +1)} _ 'T
'~ }
'~ dim as int2d tilePos(NUM_PIECES-1, NUM_ORIENT-1, NUM_SQUARES-1)
'~ dim as integer orientation(NUM_PIECES-1) = {1, 2, 2, 2, 4, 4, 4}
'~ public:
'~ 'functions/subs
'~ declare function rotatedSquare(orientation as integer, p as int2d) as int2d
'~ declare sub init()
'~ declare function getSquarePos(iPiece as integer, iOrient as integer, _
'~ iSquare as integer) as int2d
'~ end type
'~ 'get grid position of 1 square for a specified rotation
'~ function pieces_type.rotatedSquare(orientation as integer, p as int2d) as int2d
'~ select case orientation
'~ case 0: return type(+p.x, +p.y)
'~ case 1: return type(-p.y, +p.x)
'~ case 2: return type(-p.x, -p.y)
'~ case 3: return type(+p.y, -p.x)
'~ end select
'~ end function
'~ 'Fill pieces array for all possibly orientations use base_pieces data
'~ 'Can be converted to constructor
'~ sub pieces_type.init()
'~ dim as integer iOrient, iPiece, iSquare, iOrientMod
'~ for iPiece = 0 to NUM_PIECES-1
'~ for iOrient = 0 to NUM_ORIENT-1
'~ for iSquare = 0 to NUM_SQUARES-1
'~ iOrientMod = iOrient mod orientation(iPiece)
'~ tilePos(iPiece, iOrient, iSquare) = _
'~ rotatedSquare(iOrientMod, baseTilePos(iPiece, iSquare))
'~ next
'~ next
'~ next
'~ end sub
'~ function pieces_type.getSquarePos(iPiece as integer, iOrient as integer, _
'~ iSquare as integer) as int2d
'~ return tilePos(iPiece, iOrient, iSquare)
'~ end function
'===============================================================================
Type piece_type
Public:
Dim As Integer alive
Dim As int2d position
Dim As ULong tileColor(0 To 3)
Dim As int2d tilePos(0 To 3) 'relative to piecePos
Dim As int2d offsetPos
Dim As Integer areaSize
Public:
Declare Sub init(shape As Integer, allPieces As all_pieces)
Declare Sub rotRight()
Declare Sub rotLeft()
Declare Function getTilePos(tileNum As Integer) As int2d
Declare Sub disable()
End Type
Sub piece_type.init(shape As Integer, allPieces As all_pieces)
alive = true
If shape = -1 Then shape = Int(Rnd * N_SHAPES) 'choose a random one
For iTile As Integer = 0 To 3
tileColor(iTile) = colors(Int(Rnd * N_COLORS))
tilePos(iTile) = allPieces.baseTilePos(shape, iTile)
Next
offsetPos = allPieces.offsetPos(shape)
areaSize = allPieces.areaSize(shape)
position.x = 3 + offsetPos.x 'for placement on a 10 wide board, left alignment
position.y = -1 + offsetPos.y 'TO BE DEFINED !!!
End Sub
Sub piece_type.rotRight()
Dim As piece_type clone
clone = This
Dim As Integer tileBound = areaSize - 1
For i As Integer = 0 To 3
tilePos(i).x = tileBound - clone.tilePos(i).y
tilePos(i).y = clone.tilePos(i).x
tileColor(i) = clone.tileColor(i)
Next
End Sub
Sub piece_type.rotLeft()
Dim As piece_type clone
clone = This
Dim As Integer tileBound = areaSize - 1
For i As Integer = 0 To 3
tilePos(i).x = clone.tilePos(i).y
tilePos(i).y = tileBound - clone.tilePos(i).x
tileColor(i) = clone.tileColor(i)
Next
End Sub
Function piece_type.getTilePos(tileNum As Integer) As int2d
Return position + tilePos(tileNum)
End Function
Sub piece_type.disable()
alive = false
End Sub
'-------------------------------------------------------------------------------
'~ 'Does not contain the tile positions itself
'~ const as integer NUM_SQUARES = 4
'~ const as integer NUM_ORIENT = 4
'~ const as integer NUM_PIECES = 7
'~ const as integer NUM_COLORS = NUM_PIECES
'~ type piece_type
'~ dim as int2d p 'grid postion index (central piece position)
'~ dim as integer id, rot
'~ public:
'~ dim as integer colorIdx(NUM_SQUARES-1) 'color index
'~ declare sub init(gridPos as int2d, iPiece as integer, iOrient as integer, iColor as integer)
'~ declare sub disable()
'~ end type
'~ sub piece_type.init(gridPos as int2d, iPiece as integer, iOrient as integer, iColor as integer)
'~ p.x = gridPos.x
'~ p.y = gridPos.y
'~ id = iif(iPiece = -1, int(rnd * NUM_PIECES), iPiece)
'~ rot = iif(iOrient = -1, int(rnd * NUM_ORIENT), iOrient)
'~ for i as integer = 0 to NUM_SQUARES-1
'~ colorIdx(i) = iif(iColor = -1, int(rnd * NUM_COLORS), iColor)
'~ next
'~ end sub
'~ sub piece_type.disable
'~ id = -1
'~ end sub
'===============================================================================
Const As Long BLOCK_INVALID = -1
Const As Long BLOCK_FREE = 0
'const as long BLOCK_FIXED = 1
Const As Long BLOCK_PIECE = 2
Const As Long BLOCK_MARKED = 3
'const as long BLOCK_RES = 32
Const As Short BLOCK_FAIL = 64
Const As Short BLOCK_CHECK = 128
Const MAX_TETRO = 20 'used in tetro search
#Define TILE_T Long
#Define TILE_C ULong
Type tile_type
Dim As TILE_T tType ', colorIdx
Dim As TILE_C tColor
End Type
Operator =(ByRef a As tile_type, ByRef b As tile_type) As Integer
Return ((a.tType = b.tType) And (a.tColor = b.tColor))
End Operator
Type board_type
Private:
Const As Integer GRID_YSZ = 20
Const As Integer GRID_XSZ = 10
Const As Integer GRID_SIZE = SCREEN_H \ GRID_YSZ 'size of squares
Const As Integer GRID_XOFFS = (SCREEN_W - GRID_XSZ * GRID_SIZE) \ 2 'offset on screen
Const As Integer GRID_YOFFS = (SCREEN_H - GRID_YSZ * GRID_SIZE) \ 2 'offset on screen
'variables:
Dim As tile_type tile(GRID_XSZ-1, -2 To GRID_YSZ-1) 'block type & color index
Public:
Declare Sub init()
Declare Sub drawBoard()
Declare Sub drawTile(x As Integer, y As Integer, tile As tile_type)
Declare Sub drawTilePos(pos_ As int2d, tile As tile_type)
Declare Function onBoard(x As Integer, y As Integer) As Integer
Declare Function getWidth() As Integer
Declare Function getHeight() As Integer
Declare Function getSize() As int2d
Declare Function getInfo(id As Integer) As Integer
Declare Sub setTile(x As Integer, y As Integer, tile As tile_type)
Declare Sub setTileType(x As Integer, y As Integer, tt As TILE_T)
'~ declare sub setTileC(x as integer, y as integer, c as ulong)
Declare Sub setTilePos(pos_ As int2d, tile As tile_type)
Declare Function getTile(x As Integer, y As Integer) As tile_type
Declare Function getTileType(x As Integer, y As Integer) As TILE_T
'declare function checkHorzLine(yiCheck as integer) as integer
'declare sub markHorzLine(yiMark as integer)
'declare sub moveHorzLines(yiRemove as integer)
'declare function checkLines() as integer
'declare function removeLines() as integer
Declare Sub replaceType(fromType As Integer, toType As Integer)
Declare Function checkTetro() As Integer
Declare Sub removeTetro()
Declare Function floodFill(x As Integer, y As Integer, c As ULong) As Integer
End Type
'Can be converted to constructor
Sub board_type.init()
For yi As Integer = -2 To GRID_YSZ-1
For xi As Integer = 0 To GRID_XSZ-1
tile(xi, yi) = Type(BLOCK_FREE, -1) '&hffffffff
Next
Next
End Sub
Sub board_type.drawBoard()
For xi As Integer = 0 To GRID_XSZ-1
For yi As Integer = 0 To GRID_YSZ-1
Dim As tile_type tile = getTile(xi, yi)
'dim as ulong c = &hF0F0F0
'~ select case tile.tType
'~ case BLOCK_PIECE, BLOCK_MARKED
'~ c = pieceColor(tile.colorIdx)
'~ end select
'drawSquare(xi, yi, tile.tType, c)
drawTile(xi, yi, tile)
Next
Next
End Sub
'Position (x,y) = grid position
Sub board_type.drawTile(x As Integer, y As Integer, tile As tile_type)
If inRange(x, 0, GRID_XSZ-1) And inRange(y, 0, GRID_YSZ-1) Then
Dim As Integer xScrn = GRID_XOFFS + x * GRID_SIZE
Dim As Integer yScrn = GRID_YOFFS + y * GRID_SIZE
'get color
Dim As ULong c = &hF0F0F0
Select Case tile.tType
Case BLOCK_PIECE, BLOCK_MARKED
'c = colors(tile.colorIdx)
c = tile.tColor
End Select
'draw gray border always
Line(xScrn, yScrn)-step(GRID_SIZE-1, GRID_SIZE-1), C_DARK_GRAY, b
Select Case tile.tType
Case BLOCK_PIECE
Line(xScrn + 1, yScrn + 1)-step(GRID_SIZE-3, GRID_SIZE-3), c, bf
Case BLOCK_MARKED
Line(xScrn + 1, yScrn + 1)-step(GRID_SIZE-3, GRID_SIZE-3), c, b
Line(xScrn + 2, yScrn + 2)-step(GRID_SIZE-5, GRID_SIZE-5), c, b
Line(xScrn + 3, yScrn + 3)-step(GRID_SIZE-7, GRID_SIZE-7), c, b
'~ case BLOCK_RES
'~ line(xScrn + 3, yScrn + 3)-step(GRID_SIZE-7, GRID_SIZE-7), c, bf
Case Else
'not good, unknown block type
End Select
Else
'not good, outside grid
'panic("drawSquare"), don't panic, just skip, can be 2 lines above
End If
End Sub
Sub board_type.drawTilePos(pos_ As int2d, tile As tile_type)
drawTile(pos_.x, pos_.y, tile)
End Sub
Function board_type.onBoard(x As Integer, y As Integer) As Integer
If Not inRange(x, 0, GRID_XSZ-1) Then Return false
If Not inRange(y, -2, GRID_YSZ-1) Then Return false
Return true
End Function
Function board_type.getWidth() As Integer
Return GRID_XSZ
End Function
Function board_type.getHeight() As Integer
Return GRID_YSZ
End Function
Function board_type.getSize() As int2d
Return Type(GRID_XSZ, GRID_YSZ)
End Function
Function board_type.getInfo(id As Integer) As Integer
Select Case id
Case 0: Return GRID_SIZE
Case 1: Return GRID_XOFFS 'left
Case 2: Return GRID_YOFFS 'top
Case 3: Return GRID_XOFFS + GRID_XSZ * GRID_SIZE 'right
Case 4: Return GRID_YOFFS + GRID_YSZ * GRID_SIZE 'bottom
Case Else 'panic("board_type.getBoardEdge")
End Select
End Function
Sub board_type.setTile(x As Integer, y As Integer, tile_ As tile_type)
If onBoard(x, y) Then tile(x, y) = tile_
End Sub
Sub board_type.setTileType(x As Integer, y As Integer, bt As Long)
If onBoard(x, y) Then tile(x, y).tType = bt
End Sub
'~ sub board_type.setTileColor(x as integer, y as integer, c as ulong)
'~ if onBoard(x, y) then tile(x, y).tColor = c
'~ end sub
Sub board_type.setTilePos(pos_ As int2d, tile As tile_type)
setTile(pos_.x, pos_.y, tile)
End Sub
Function board_type.getTile(x As Integer, y As Integer) As tile_type
If Not onBoard(x, y) Then
'panic("getTileType")
Return Type(BLOCK_INVALID, -1)
Else
Return tile(x, y)
End If
End Function
Function board_type.getTileType(x As Integer, y As Integer) As TILE_T
If Not onBoard(x, y) Then
'panic("getTileType")
Return BLOCK_INVALID
Else
Return tile(x, y).tType
End If
End Function
'~ function board_type.checkHorzLine(yiCheck as integer) as integer
'~ dim as integer xi
'~ for xi = 0 to GRID_XSZ-1
'~ if getTile(xi, yiCheck).tType = BLOCK_FREE then return false
'~ next
'~ return true 'complete line
'~ end function
'~ 'move all lines 1 down from yiRemove and above
'~ sub board_type.moveHorzLines(yiRemove as integer)
'~ dim as integer xi, yi
'~ for yi = yiRemove to 1 step -1
'~ for xi = 0 to GRID_XSZ-1
'~ if not onBoard(xi, yi) then panic("moveHorzLines")
'~ setTile(xi, yi, getTile(xi, yi - 1))
'~ next
'~ next
'~ end sub
'~ sub board_type.markHorzLine(yiMark as integer)
'~ dim as integer xi
'~ for xi = 0 to GRID_XSZ-1
'~ if not onBoard(xi, yiMark) then panic("markHorzLine")
'~ 'setTile(xi, yiMark, type(BLOCK_MARKED, -1))
'~ tile(xi, yiMark).tType = BLOCK_MARKED
'~ next
'~ end sub
'~ 'find and mark complete lines
'~ function board_type.checkLines() as integer
'~ dim as integer yi, xi
'~ dim as integer numLines = 0
'~ 'from bottom to top
'~ for yi = GRID_YSZ-1 to -2 step -1
'~ if checkHorzLine(yi) then
'~ numLines += 1
'~ markHorzLine(yi)
'~ end if
'~ next
'~ return numLines
'~ end function
'~ 'check and move lines, return number of lines removed
'~ function board_type.removeLines() as integer
'~ dim as integer xi, yi
'~ dim as integer numLines = 0
'~ 'loop bottom to top
'~ for yi = GRID_YSZ-1 to -2 step -1
'~ 'check complete horizontal line
'~ if checkHorzLine(yi) then
'~ moveHorzLines(yi)
'~ numLines += 1
'~ yi += 1 'recheck this line
'~ end if
'~ next
'~ return numLines
'~ end function
Sub board_type.replaceType(fromType As Integer, toType As Integer)
For yi As Integer = GRID_YSZ-1 To -2 Step -1
For xi As Integer = 0 To GRID_XSZ-1
If tile(xi, yi).tType = fromType Then
tile(xi, yi).tType = toType
End If
Next
Next
End Sub
'find and mark neighbouring blocks sections
Function board_type.checkTetro() As Integer
Dim As int2d tetroPos(0 To MAX_TETRO-1)
Dim As Integer xi, yi, numTiles, numTetro = 0
Dim As ULong c
'loop bottom to top, find and count tetrominoes+ (4-tile piece or larger)
For yi = GRID_YSZ-1 To -2 Step -1
For xi = 0 To GRID_XSZ-1
If tile(xi, yi).tType = BLOCK_PIECE Then
c = tile(xi, yi).tColor
numTiles = floodFill(xi, yi, c)
If numTiles >= 4 Then
tetroPos(numTetro) = Type(xi, yi)
numTetro += 1
End If
End If
Next
Next
'clear all again, tetro positions were saved
replaceType(BLOCK_MARKED, BLOCK_PIECE)
'run the recursive thing again on listed positions
For iTetro As Integer = 0 To numTetro-1
xi = tetroPos(iTetro).x
yi = tetroPos(iTetro).y
If tile(xi, yi).tType = BLOCK_PIECE Then
c = tile(xi, yi).tColor
numTiles = floodFill(xi, yi, c)
End If
Next
'if no tetrominoes+ found, clear marks
'if numTetro = 0 then clearMarked()
Return numTetro
End Function
Sub board_type.removeTetro()
'replaceType(BLOCK_MARKED, BLOCK_FREE)
For yi As Integer = GRID_YSZ-1 To -2 Step -1
For xi As Integer = 0 To GRID_XSZ-1
If tile(xi, yi).tType = BLOCK_MARKED Then
tile(xi, yi) = Type(BLOCK_FREE, -1) '&hffffffff
End If
Next
Next
End Sub
Function board_type.floodFill(x As Integer, y As Integer, c As ULong) As Integer
Dim As Integer count
Dim As tile_type matchTile = Type(BLOCK_PIECE, c)
'mark this tile, prevent resursive loop
tile(x, y).tType = BLOCK_MARKED
'check neighbour tiles
If onBoard(x + 1, y) AndAlso tile(x + 1, y) = matchTile Then count += floodFill(x + 1, y, c)
If onBoard(x - 1, y) AndAlso tile(x - 1, y) = matchTile Then count += floodFill(x - 1, y, c)
If onBoard(x, y + 1) AndAlso tile(x, y + 1) = matchTile Then count += floodFill(x, y + 1, c)
If onBoard(x, y - 1) AndAlso tile(x, y - 1) = matchTile Then count += floodFill(x, y - 1, c)
Return count + 1 'should return at least 1 if nothing else is found
End Function
'~ 'Drop all pieces not touching? Only floating parts? most natural!
'~ 'Make block lists & mark --> use additional map or reset afterwards?
'~ 'wait for all block lists to finish dropping? Easier with current dynamic list
'~ 'then check for complete lines
'~ function game_type.stirBlocks() as integer
'~ 'create lists of blocks, loop all blocks
'~ dim as integer bcNum, canMove, tType, count = 0
'~ dim as int2d blockPos
'~ for yi as integer = 0 to board.Y_DIM-1
'~ for xi as integer = 0 to board.X_DIM-1
'~ if board.getType(type(xi, yi)) = BLOCK_PIECE then
'~ bcNum = bl.alloc() 'start a block list
'~ with bl.bc(bcNum)
'~ .speed = type(0, V_STIR_BLOCK)
'~ .relPosCurrent = type(0, 0)
'~ .absPosSource = type(xi, yi)
'~ .relPosTarget = type(0, 1)
'~ .addBlock(type(0, 0), board.getBlock(type(xi, yi))) 'first one at rel. pos 0,0
'~ end with
'~ checkBlocks(xi, yi, bcNum) 'resurve block search
'~ 'check if dropable (all piece of section nothing below?)
'~ canMove = 1
'~ for iBlock as integer = 0 to bl.bc(bcNum).getSize() - 1
'~ blockPos = toCint2d(bl.bc(bcNum).getAbsPosBlocks(iBlock))
'~ tType = board.getType(type(blockPos.x, blockPos.y + 1))
'~ if not(tType = BLOCK_FREE or tType = BLOCK_CHECK) then
'~ canMove = 0
'~ exit for
'~ end if
'~ next
'~ if canMove = 1 then
'~ 'remove from board + reserve position
'~ for iBlock as integer = 0 to bl.bc(bcNum).getSize() - 1
'~ blockPos = toCint2d(bl.bc(bcNum).getAbsPosBlocks(iBlock))
'~ board.setType(blockPos, BLOCK_FREE)
'~ board.setType(type(blockPos.x, blockPos.y + 1), BLOCK_RES)
'~ next
'~ count += 1
'~ else
'~ bl.bc(bcNum).cleanUp() 'remove from list
'~ end if
'~ end if
'~ next
'~ next
'marked --> piece
'~ for yi as integer = 0 to board.Y_DIM-1
'~ for xi as integer = 0 to board.X_DIM-1
'~ if board.getType(type(xi, yi)) = BLOCK_CHECK then
'~ board.setType(type(xi, yi), BLOCK_PIECE)
'~ end if
'~ next
'~ next
'~ 'note: count can also be obtained form list length
'~ return count
'~ end function
'===============================================================================
#Include Once "file.bi"
Union rgba_union
value As ULong
Type
b As UByte
g As UByte
r As UByte
a As UByte
End Type
End Union
Function createPixel(r As UByte, g As UByte, b As UByte) As rgba_union
Dim As rgba_union pixel
pixel.r = r
pixel.g = g
pixel.b = b
Return pixel
End Function
Type bitmap_header Field = 1
bfType As UShort
bfsize As ULong
bfReserved1 As UShort
bfReserved2 As UShort
bfOffBits As ULong
biSize As ULong
biWidth As ULong
biHeight As ULong
biPlanes As UShort
biBitCount As UShort
biCompression As ULong
biSizeImage As ULong
biXPelsPerMeter As ULong
biYPelsPerMeter As ULong
biClrUsed As ULong
biClrImportant As ULong
End Type
Type image_type
Dim As Any Ptr pFbImg
Dim As int2d size, half
Declare Sub create(sizeInit As int2d, colorInit As ULong)
Declare Function createFromBmp(fileName As String) As Integer
Declare Sub destroy()
Declare Destructor()
End Type
Sub image_type.create(sizeInit As int2d, colorInit As ULong)
pFbImg = ImageCreate(sizeInit.x, sizeInit.y, colorInit)
size = sizeInit
half.x = size.x \ 2
half.y = size.y \ 2
'center = 0
'method = 0
End Sub
Function image_type.createFromBmp(fileName As String) As Integer
Dim As bitmap_header bmp_header
Dim As int2d bmpSize
If FileExists(filename) Then
Open fileName For Binary As #1
Get #1, , bmp_header
Close #1
bmpSize.x = bmp_header.biWidth
bmpSize.y = bmp_header.biHeight
create(bmpSize, &hff000000)
BLoad fileName, pFbImg
Print "Bitmap loaded: " & filename
Else
Print "File not found: " & filename
Sleep 1000
Return -1
End If
Return 0
End Function
Sub image_type.destroy()
If (pFbImg <> 0) Then
ImageDestroy(pFbImg)
pFbImg = 0
End If
End Sub
Destructor image_type()
destroy()
End Destructor
'===============================================================================
Type area_type
Dim As Integer x1, y1
Dim As Integer x2, y2
End Type
Function imageGrayInt(pFbImg As Any Ptr, area As area_type, intOffs As Integer) As Integer
Dim As Integer w, h, bypp, pitch
Dim As Integer xi, yi, intensity
Dim As Any Ptr pPixels
Dim As rgba_union Ptr pRow
If ImageInfo(pFbImg, w, h, bypp, pitch, pPixels) <> 0 Then Return -1
If bypp <> 4 Then Return -2 'only 32-bit images
If pPixels = 0 Then Return -3
If area.x1 < 0 Or area.x1 >= w Then Return -4
If area.y1 < 0 Or area.y1 >= h Then Return -5
If area.x2 < 0 Or area.x2 >= w Then Return -6
If area.y2 < 0 Or area.y2 >= h Then Return -7
For yi = area.y1 To area.y2
pRow = pPixels + yi * pitch
For xi = area.x1 To area.x2
intensity = CInt(0.3 * pRow[xi].r + 0.5 * pRow[xi].g + 0.2 * pRow[xi].b) + intOffs
If intensity < 0 Then intensity = 0
If intensity > 255 Then intensity = 255
pRow[xi].r = intensity
pRow[xi].g = intensity
pRow[xi].b = intensity
Next
Next
Return 0
End Function
'===============================================================================
Type bd_type 'block descriptor
Dim As int2d relPos
Dim As tile_type block
End Type
'-------------------------------------------------------------------------------
Type bc_type 'block collection class
Public:
Dim As boolean inUse
Dim As int2d relPos 'relative to absPosSource
Dim As bd_type bd(Any) 'positions relative to relPosCurrent
Dim As int2d absPosSource 'initial position ??????????????????????????????????
Public:
Declare Function getSize() As Integer
'declare sub setSpeed(speed as sgl2d)
Declare Sub cleanUp()
Declare Sub addBlock(blockPos As int2d, block As tile_type)
Declare Function getAbsPosBlocks(blockNum As Integer) As int2d
Declare Function getBlock(blockNum As Integer) As tile_type
'declare function update() as integer
'declare sub copyToBoard(relPos as int2d, blockType as TILE_T, board as board_type)
Declare Sub copyToBoard(relPos As int2d, board As board_type)
Declare Function possible(checkPos As int2d, board As board_type) As boolean
'declare sub extendTarget()
End Type
Function bc_type.getSize() As Integer
Return UBound(bd) + 1
End Function
Sub bc_type.cleanUp()
inUse = false
Erase bd
relPos = Type(0, 0)
absPosSource = Type(0, 0)
End Sub
Sub bc_type.addBlock(blockPos As int2d, block As tile_type)
Dim As Integer ub = UBound(bd)
ReDim Preserve bd(ub + 1)
bd(ub + 1).relPos = blockPos
bd(ub + 1).block = block
End Sub
Function bc_type.getAbsPosBlocks(blockNum As Integer) As int2d
Dim As int2d blockPos
If blockNum >= 0 And blockNum <= UBound(bd) Then
blockPos = relPos + absPosSource + bd(blockNum).relPos
End If
Return blockPos
End Function
Function bc_type.getBlock(blockNum As Integer) As tile_type
If blockNum >= 0 And blockNum <= UBound(bd) Then
Return bd(blockNum).block
End If
Return Type(BLOCK_INVALID, -1)
End Function
'updates position of block collection
'return 1 on target position reached <-- IS REMOVED NOW
'~ function bc_type.update() as integer
'~ if inUse = true then
'~ relPosCurrent.y += 1
'~ return 1
'~ end if
'~ return 0
'~ end function
'IS NIET GOED, moet ook tColor kopieren! ???
Sub bc_type.copyToBoard(relPos As int2d, board As board_type)
Dim As int2d blockPos
For iBlock As Integer = 0 To UBound(bd)
blockPos = relPos + absPosSource + bd(iBlock).relPos
board.setTile(blockPos.x, blockPos.y, bd(iBlock).block)
Next
End Sub
'~ sub bc_type.copyToBoard(relPos as int2d, blockType as TILE_T, board as board_type)
'~ dim as int2d blockPos
'~ for iBlock as integer = 0 to ubound(bd)
'~ 'blockPos = relPos + toSgl2d(absPosSource + bd(iBlock).relPos)
'~ blockPos = relPos + absPosSource + bd(iBlock).relPos
'~ if blockType = BLOCK_FREE or blockType = BLOCK_RES then
'~ 'board.setType(toCint2d(blockPos), blockType)
'~ board.setTileType(blockPos.x, blockPos.y, blockType)
'~ elseif blockType = BLOCK_PIECE then
'~ 'board.setBlock(toCint2d(blockPos), bd(iBlock).block)
'~ board.setTile(blockPos.x, blockPos.y, bd(iBlock).block)
'~ end if
'~ next
'~ end sub
Function bc_type.possible(checkPos As int2d, board As board_type) As boolean
Dim As int2d blockPos
Dim As TILE_T blockType
For iBlock As Integer = 0 To UBound(bd)
blockPos = checkPos + absPosSource + bd(iBlock).relPos
blockType = board.getTileType(blockPos.x, blockPos.y)
If blockType <> BLOCK_FREE Then Return false
Next
Return true
End Function
'~ sub bc_type.extendTarget()
'~ if inUse = true then
'~ relPosTarget.y += 1
'~ end if
'~ end sub
'===============================================================================
Type bcl_type 'block (collection) list class
Public:
Dim As bc_type bc(Any)
Public:
Declare Function getSize() As Integer
Declare Function getUsed() As Integer
Declare Function alloc() As Integer
Declare Function free() As Integer
'declare function free(index as integer) as integer
Declare Sub show()
Declare Function update(board As board_type) As Integer
'~ declare sub changeDrop(vSpeed as single)
Declare Sub drawBlocks(board As board_type)
End Type
Function bcl_type.getSize() As Integer
Return UBound(bc) + 1
End Function
Function bcl_type.getUsed() As Integer
Dim As Integer count = 0
For i As Integer = 0 To UBound(bc)
If bc(i).inUse = true Then count += 1
Next
Return count
End Function
Function bcl_type.alloc() As Integer
Dim As Integer index = -1
Dim As Integer ub = UBound(bc)
For i As Integer = 0 To ub
If bc(i).inUse = false Then
index = i
Exit For
End If
Next
If index < 0 Then
ReDim Preserve bc(ub + 1)
index = ub + 1
End If
bc(index).inUse = true
Return index
End Function
Function bcl_type.free() As Integer
For i As Integer = 0 To UBound(bc)
bc(i).cleanUp()
Next
Return 0
End Function
Sub bcl_type.show()
For i As Integer = 0 To UBound(bc)
Print "list index: " & Str(i)
'bc(i).show()
Print
Next
End Sub
'update position of block sections
'copy to board if next position not possible
Function bcl_type.update(board As board_type) As Integer
Dim As Integer blUpdate = 0
For iBc As Integer = 0 To getSize()-1
'update position
With bc(iBc)
If .inUse Then
.relPos.y += 1 'move down
'check further drop possible
If .possible(.relPos + Type(0, 1), board) Then
'nothing, chack next update again
Else
.copyToBoard(.relPos, board)
.cleanUp() 'remove from list
blUpdate = 1
End If
End If
End With
Next
Return blUpdate
End Function
'draw all alive block collections on board
Sub bcl_type.drawBlocks(board As board_type)
For iBc As Integer = 0 To getSize()-1
If bc(iBc).inUse = true Then
For iBlock As Integer = 0 To bc(iBc).getSize() - 1
Dim As int2d blockPos = bc(iBc).getAbsPosBlocks(iBlock)
Dim As tile_type tile = bc(iBc).getBlock(iBlock)
board.drawTilePos(blockPos, tile)
Next
End If
Next
End Sub
'~ function bcl_type.update(board as board_type) as integer
'~ dim as integer blUpdate = 0
'~ for iBc as integer = 0 to getSize()-1
'~ 'update position
'~ with bc(iBc)
'~ 'check if target reached --> Now, move 1 step!!!
'~ if .update() = 1 then '<-- always true now? -------- MOVE CURRENT 1 DOWN -----------
'~ 'clear reservation
'~ '.copyToBoard(.relPosCurrent, BLOCK_FREE, board) RESERVERING 1 tE lAAG wordt VREWIJDERD?
'~ 'set next target
'~ .extendTarget()
'~ 'check next pos. possible
'~ if .possible(.relPosTarget, board) then
'~ 'set new reservation
'~ .copyToBoard(.relPosTarget, BLOCK_RES, board)
'~ else
'~ .copyToBoard(.relPosCurrent, BLOCK_PIECE, board)
'~ .cleanUp() 'remove from list
'~ blUpdate = 1
'~ end if
'~ end if
'~ end with
'~ next
'~ return blUpdate
'~ end function
'~ sub bcl_type.changeDrop(vSpeed as single)
'~ for iBc as integer = 0 to getSize()-1
'~ with bc(iBc)
'~ if .inUse = true then
'~ 'check, only block collections dropping down
'~ if .speed.x = 0 and .speed.y > 0 then
'~ .speed.y = vSpeed
'~ end if
'~ end if
'~ end with
'~ next
'~ end sub
'===============================================================================
'message centered on screen
Sub showMsg(msgStr As String, c1 As ULong, c2 As ULong)
Dim As Integer widthPx = Len(msgStr) * 8
Dim As Integer x = (SCREEN_W - widthPx) \ 2
Dim As Integer y = (SCREEN_H - 16) \ 2
Line(x-8,y-8)-step(widthPx + 16 - 1, 16 + 8 - 1), c2, bf
Line(x-8,y-8)-step(widthPx + 16 - 1, 16 + 8 - 1), c1, b
Draw String (x,y), msgStr, c1
End Sub
Enum playStateEnum
psNewPiece
psActivePlay
psWaitDrop
psCheckBoard
psWaitClearLine
psFloatDrop
psPaused
psEnd 'not used
End Enum
Dim Shared As String playStateStr(0 To psEnd)
playStateStr(0) = "psNewPiece"
playStateStr(1) = "psActivePlay"
playStateStr(2) = "psWaitDrop"
playStateStr(3) = "psCheckBoard"
playStateStr(4) = "psWaitClearLine"
playStateStr(5) = "psFloatDrop"
playStateStr(6) = "psPaused"
playStateStr(7) = "psEnd"
Type game_type
Private:
Dim As all_pieces allPieces
Dim As piece_type piece
Dim As image_type bgImg
Dim As playStateEnum playState
Dim As piece_type activePiece, nextPiece
Dim As bcl_type bcl 'block collection list
'public: 'TEMPORARY until gameloop in here game.bi
Dim As board_type board
Public:
Declare Sub init()
Declare Function loop_() As Integer
Declare Sub drawScene()
Declare Sub clearScreen()
Declare Sub showAllPieces()
Declare Sub gameOver()
Declare Function piecePossible(piece As piece_type) As Integer
Declare Sub wallKick(piece As piece_type)
Declare Sub copyToBoard(piece As piece_type)
Declare Sub drawPiece(piece As piece_type)
Declare Sub showPiece(piece As piece_type, xOffs As Integer, yOffs As Integer, tileSize As Integer)
Declare Function CheckFloat() As Integer
Declare Function checkNeighbours(x As Integer, y As Integer, bcNum As Integer) As Integer
End Type
Sub game_type.init()
'pieces.init()
board.init()
'bgImg.createFromBmp("res/Basil-cathedral-morning_800.bmp")
bgImg.createFromBmp("res/radioactive_800.bmp")
imageGrayInt(bgImg.pFbImg, Type(000, 0, 199, (bgImg.size.y-1)), +20)
imageGrayInt(bgImg.pFbImg, Type((bgImg.size.x-1)-199, 0, (bgImg.size.x-1)-000, (bgImg.size.y-1)), +20)
imageGrayInt(bgImg.pFbImg, Type(200, 0, (bgImg.size.x-1)-200, (bgImg.size.y-1)), -50)
End Sub
Function game_type.loop_() As Integer
Dim As Integer quit = 0
Dim As UShort keyCode
Dim As timer_type gravTmr, clearTmr
Dim As piece_type movedPiece
Dim As all_pieces allPieces
'dim as integer dropActive
'dim as integer requestNewPiece = true
Dim As Integer score, lineCount, tetroCount, floatCount
playState = psNewPiece
nextPiece.init(-1, allPieces)
Do
keyCode = pollKeyCode()
If playState = psNewPiece Then
'if requestNewPiece then
'~ 'requestNewPiece = false
'~ 'activePiece.init(type(game.board.getWidth()\2, 0), -1, 0, -1)
'activePiece.init(-1, allPieces)
activePiece = nextPiece
nextPiece.init(-1, allPieces)
If Not piecePossible(activePiece) Then quit = 1
gravTmr.start(0.500)
'end if
playState = psActivePlay
End If
movedPiece = activePiece 'copy piece for location / orientation
If playState = psPaused Then
Select Case keyCode
Case KEY_P
gravTmr.unpause()
playState = psActivePlay
keyCode = 0 'hack, prevent repause in section below
Case KEY_ESC
quit = 1
Case Else
'...
End Select
End If
If playState = psActivePlay Then
Select Case keyCode
Case KEY_LE
movedPiece.position.x -= 1
Case KEY_RI
movedPiece.position.x += 1
Case KEY_UP
'movedPiece.rot = (movedPiece.rot + 1) mod NUM_ORIENT
movedPiece.rotRight()
wallKick(movedPiece)
Case KEY_DN
'movedPiece.rot = (movedPiece.rot + 3) mod NUM_ORIENT
movedPiece.rotLeft()
wallKick(movedPiece)
Case KEY_SPACE
playState = psWaitDrop 'disable user piece control
gravTmr.start(0.025) 'drop faster
Case KEY_P
gravTmr.pause()
playState = psPaused
Case KEY_ESC
quit = 1
Case Else
'...
End Select
'check move possible
If piecePossible(movedPiece) Then
activePiece = movedPiece 'update position
Else
movedPiece = activePiece 'reset moved piece, for next step
End If
End If
If playState = psActivePlay Or playState = psWaitDrop Then
'piece drop by timer
If gravTmr.ended() Then
movedPiece.position.y += 1
'check drop possible
If piecePossible(movedPiece) Then 'continue drop
gravTmr.restart()
activePiece = movedPiece
Else
copyToBoard(activePiece)
activePiece.disable()
playState = psCheckBoard
'dropActive = false
End If
End If
End If
If playState = psCheckBoard Then
'piece has been dropped onto something
tetroCount = board.checkTetro() 'and mark for visualisation
If tetroCount > 0 Then
clearTmr.start(0.500) 'remove section after this time
playState = psWaitClearLine
Else
playState = psNewPiece
End If
End If
If playState = psWaitClearLine Then
If clearTmr.ended() Then
score += tetroCount
board.removeTetro() 'marked -> free
'
floatCount = checkFloat() 'find + remove + reserve + build list
If floatCount > 0 Then
clearTmr.start(0.250)
playState = psFloatDrop
Else
playState = psNewPiece
End If
End If
End If
If playState = psFloatDrop Then
If clearTmr.ended() Then
bcl.update(board) 'move down and/or copy bl to board
floatCount = bcl.getUsed()
If floatCount > 0 Then
clearTmr.start(0.250) 'stay in this play state
Else
'playState = psNewPiece
'No recheck tetro !!!!!!
playState = psCheckBoard
End If
End If
End If
ScreenLock
clearScreen()
drawScene()
Locate 2, 2: Print "Score:"; score;
Locate 4, 2: Print "State:"; playState; " " ;playStateStr(playState)
Locate 6, 2: Print "Time: "; Time;
Locate 8, 2: Print "floatCount:"; floatCount;
ScreenUnLock
Sleep 1,1
Loop Until quit = 1
Return quit
End Function
Sub game_type.drawScene()
Put (0, 0), bgImg.pFbImg, PSet
board.drawBoard()
bcl.drawBlocks(board)
showPiece(nextPiece, board.getInfo(3) + 50, 50, 32)
If activePiece.alive Then drawPiece(activePiece)
If playState = psPaused Then showMsg("PAUSED", C_WHITE, C_DARK_RED)
End Sub
Sub game_type.clearScreen()
Line(0, 0) - (SCREEN_W-1, SCREEN_H-1), C_BLACK, bf
End Sub
'draw all tretris pieces (for debugging only)
'~ sub game_type.showAllPieces()
'~ dim as integer iPiece, iOrient
'~ dim as piece_type piece
'~ for iPiece = 0 to NUM_PIECES-1
'~ for iOrient = 0 to NUM_ORIENT-1
'~ piece.init(type<int2d>(5 + iPiece * 5, 5 + iOrient * 5), iPiece, iOrient)
'~ piece.id = iPiece
'~ piece.rot = iOrient
'~ drawPiece(piece)
'~ next
'~ next
'~ end sub
'Game over animation, fill board to to bottom
Sub game_type.gameOver()
Dim As int2d boardSize = board.getSize()
Dim As tile_type tile
For yi As Integer = boardSize.y-1 To 0 Step -1
For xi As Integer = 0 To boardSize.x-1
tile = board.getTile(xi, yi)
tile.tType = BLOCK_MARKED
board.setTile(xi, yi, tile)
Next
ScreenLock
clearScreen()
drawScene()
ScreenUnLock
Sleep 25, 1
Next
End Sub
'check if piece is possible on board
Function game_type.piecePossible(piece As piece_type) As Integer
For iTile As Integer = 0 To 3
Dim As Integer xi = piece.position.x + piece.tilePos(iTile).x
Dim As Integer yi = piece.position.y + piece.tilePos(iTile).y
If board.onBoard(xi, yi) = false Then Return false
If board.getTileType(xi, yi) <> BLOCK_FREE Then Return false
Next
Return true
End Function
'test and shift piece (max 1 block/tile), after turn
Sub game_type.wallKick(piece As piece_type)
Dim As Integer bw = board.getWidth()
For iTest As Integer = 0 To 1 'run twice for long piece
'check left/right (can't be both)
For iTile As Integer = 0 To 3
Dim As Integer xi = piece.position.x + piece.tilePos(iTile).x
If xi < 0 Then
piece.position.x += 1 'move piece right
Exit For
End If
If xi >= bw Then
piece.position.x -= 1 'move piece left
Exit For
End If
Next
Next
End Sub
'copy piece to board
Sub game_type.copyToBoard(piece As piece_type)
For iTile As Integer = 0 To N_TILES-1
Dim As int2d absTilePos = piece.getTilePos(iTile)
Dim As ULong c = piece.tileColor(iTile)
board.setTilePos(absTilePos, Type(BLOCK_PIECE, c))
Next
End Sub
'draw teris 1 piece, multiple squares, on board
Sub game_type.drawPiece(piece As piece_type)
For iTile As Integer = 0 To N_TILES-1
Dim As int2d absTilePos = piece.getTilePos(iTile)
Dim As ULong c = piece.tileColor(iTile)
board.drawTilePos(absTilePos, Type(BLOCK_PIECE, c))
Next
End Sub
'display anyway, at specified location and tile size
Sub game_type.showPiece(piece As piece_type, xScrn As Integer, yScrn As Integer, tileSize As Integer)
For iTile As Integer = 0 To N_TILES-1
Dim As int2d tilePos = piece.tilePos(iTile)
Dim As ULong c = piece.tileColor(iTile)
Dim As Integer x = xScrn + (tilePos.x + piece.offsetPos.x) * tileSize
Dim As Integer y = yScrn + (tilePos.y + piece.offsetPos.y) * tileSize
Line(x, y)-step(tileSize - 2, tileSize - 2), c, bf
Next
End Sub
'Drop all pieces not touching? Only floating parts? most natural!
'Make block lists & mark --> use additional map or reset afterwards?
'wait for all block lists to finish dropping? Easier with current dynamic list
'then check for complete lines
'find + remove + reserve + build list
Function game_type.checkFloat() As Integer
'create lists of blocks, loop all blocks
Dim As Integer bcNum, floating, blockType, count = 0
Dim As int2d blockPos
For yi As Integer = 0 To board.getHeight() - 1
For xi As Integer = 0 To board.getWidth() - 1
If board.getTileType(xi, yi) = BLOCK_PIECE Then
bcNum = bcl.alloc() 'start a block list
With bcl.bc(bcNum)
'.speed = type(0, V_STIR_BLOCK)
.relPos = Type(0, 0)
.absPosSource = Type(xi, yi)
'.relPosTarget = type(0, 1)
.addBlock(Type(0, 0), board.getTile(xi, yi)) 'first one at rel. pos 0,0
End With
'start resurve block search, add more neighbour blocks to list
checkNeighbours(xi, yi, bcNum)
'check if dropable (all piece of section with nothing below)
floating = 1
For iBlock As Integer = 0 To bcl.bc(bcNum).getSize() - 1
blockPos = bcl.bc(bcNum).getAbsPosBlocks(iBlock)
blockType = board.getTileType(blockPos.x, blockPos.y + 1)
If Not(blockType = BLOCK_FREE Or blockType = BLOCK_CHECK) Then
floating = 0
Exit For
End If
Next
'if floation section then remove from board & reserve position
If floating = 1 Then
For iBlock As Integer = 0 To bcl.bc(bcNum).getSize() - 1
blockPos = bcl.bc(bcNum).getAbsPosBlocks(iBlock)
'board.setTileType(blockPos.x, blockPos.y, BLOCK_FREE)
board.setTile(blockPos.x, blockPos.y, Type(BLOCK_FREE, -1)) '&hffffffff = clear
'board.setTileType(blockPos.x, blockPos.y + 1, BLOCK_RES) Waarom ???????????????
Next
count += 1
Else
bcl.bc(bcNum).cleanUp() 'remove from list (no floating)
End If
End If
Next
Next
'restore all marked blocks to normal
For yi As Integer = 0 To board.getHeight() - 1
For xi As Integer = 0 To board.getWidth() - 1
If board.getTileType(xi, yi) = BLOCK_CHECK Then
board.setTileType(xi, yi, BLOCK_PIECE)
End If
Next
Next
'note: count can also be obtained from list length
Return count
End Function
'resurve block search + mark, no check
Function game_type.checkNeighbours(x As Integer, y As Integer, bcNum As Integer) As Integer
With bcl.bc(bcNum)
If .getSize() > 0 Then 'skip first block here
.addBlock(Type(x - .absPosSource.x, y - .absPosSource.y), board.getTile(x, y)) 'relative to source
End If
End With
board.setTileType(x, y, BLOCK_CHECK)
If board.getTileType(x - 1, y) = BLOCK_PIECE Then checkNeighbours(x - 1, y, bcNum)
If board.getTileType(x + 1, y) = BLOCK_PIECE Then checkNeighbours(x + 1, y, bcNum)
If board.getTileType(x, y - 1) = BLOCK_PIECE Then checkNeighbours(x, y - 1, bcNum)
If board.getTileType(x, y + 1) = BLOCK_PIECE Then checkNeighbours(x, y + 1, bcNum)
Return 0
End Function
'===============================================================================
'******************************* main.bas **************************************
Dim As game_type game
ScreenRes SCREEN_W, SCREEN_H, 32
Randomize(Timer())
'randomize (88)
game.init()
game.loop_()
game.gameOver()
'game.drawScene()
'game.showAllPieces() '<-- This is broken, pieces too large
'sleep 1000,1
Locate 4, 2: Print "Game ended, press any key."
waitKeyCode()