2048: Difference between revisions
2048 in FreeBASIC
m (correct the header from "APPLESOFT" to "Applesoft BASIC") |
(2048 in FreeBASIC) |
||
Line 7,768:
Move 2, score 6. Moves RULD ... Your move:
</pre>
=={{header|FreeBASIC}}==
Based On MichD's original code (https://github.com/michd/2048-qbasic)
<lang freebasic>#define EXTCHAR Chr(255)
'--- Declaration of global variables ---
Dim Shared As Integer gGridSize = 4 'grid size (4 -> 4x4)
Dim Shared As Integer gGrid(gGridSize, gGridSize)
Dim Shared As Integer gScore
Dim Shared As Integer curX, curY
Dim Shared As Integer hasMoved, wasMerge
' Don't touch these numbers, seriously
Dim Shared As Integer gOriginX, gOriginY
gOriginX = 75 'pixel X of top left of grid
gOriginY = 12 'pixel Y of top right of grida
Dim Shared As Integer gTextOriginX, gTextOriginY, gSquareSide
gTextOriginX = 11
gTextOriginY = 3
gSquareSide = 38 'width/height of block in pixels
'set up all the things!
Dim Shared As Integer gDebug = 0
'--- SUBroutines and FUNCtions ---
Sub addblock
Dim As Integer emptyCells(gGridSize * gGridSize, 2)
Dim As Integer emptyCellCount = 0
Dim As Integer x, y, index, num
For x = 0 To gGridSize - 1
For y = 0 To gGridSize - 1
If gGrid(x, y) = 0 Then
emptyCells(emptyCellCount, 0) = x
emptyCells(emptyCellCount, 1) = y
emptyCellCount += 1
End If
Next y
Next x
If emptyCellCount > 0 Then
index = Int(Rnd * emptyCellCount)
num = Cint(Rnd + 1) * 2
gGrid(emptyCells(index, 0), emptyCells(index, 1)) = num
End If
End Sub
Function pad(num As Integer) As String
Dim As String strNum = Ltrim(Str(num))
Select Case Len(strNum)
Case 1: Return " " + strNum + " "
Case 2: Return " " + strNum + " "
Case 3: Return " " + strNum
Case 4: Return strNum
End Select
End Function
Sub drawNumber(num As Integer, xPos As Integer, yPos As Integer)
Dim As Integer c, x, y
Select Case num
Case 0: c = 16
Case 2: c = 2
Case 4: c = 3
Case 8: c = 4
Case 16: c = 5
Case 32: c = 6
Case 64: c = 7
Case 128: c = 8
Case 256: c = 9
Case 512: c = 10
Case 1024: c = 11
Case 2048: c = 12
Case 4096: c = 13
Case 8192: c = 13
Case Else: c = 13
End Select
x = xPos *(gSquareSide + 2) + gOriginX + 1
y = yPos *(gSquareSide + 2) + gOriginY + 1
Line(x + 1, y + 1)-(x + gSquareSide - 1, y + gSquareSide - 1), c, BF
If num > 0 Then
Locate gTextOriginY + 1 +(yPos * 5), gTextOriginX +(xPos * 5) : Print " "
Locate gTextOriginY + 2 +(yPos * 5), gTextOriginX +(xPos * 5) : Print pad(num)
Locate gTextOriginY + 3 +(yPos * 5), gTextOriginX +(xPos * 5)
End If
End Sub
Function getAdjacentCell(x As Integer, y As Integer, d As String) As Integer
If (d = "l" And x = 0) Or (d = "r" And x = gGridSize - 1) Or (d = "u" And y = 0) Or (d = "d" And y = gGridSize - 1) Then
getAdjacentCell = -1
Else
Select Case d
Case "l": getAdjacentCell = gGrid(x - 1, y)
Case "r": getAdjacentCell = gGrid(x + 1, y)
Case "u": getAdjacentCell = gGrid(x, y - 1)
Case "d": getAdjacentCell = gGrid(x, y + 1)
End Select
End If
End Function
'Draws the outside grid(doesn't render tiles)
Sub initGraphicGrid
Dim As Integer x, y, gridSide =(gSquareSide + 2) * gGridSize
Line(gOriginX, gOriginY)-(gOriginX + gridSide, gOriginY + gridSide), 14, BF 'outer square, 3 thick
Line(gOriginX, gOriginY)-(gOriginX + gridSide, gOriginY + gridSide), 1, B 'outer square, 3 thick
Line(gOriginX - 1, gOriginY - 1)-(gOriginX + gridSide + 1, gOriginY + gridSide + 1), 1, B
Line(gOriginX - 2, gOriginY - 2)-(gOriginX + gridSide + 2, gOriginY + gridSide + 2), 1, B
For x = gOriginX + gSquareSide + 2 To gOriginX +(gSquareSide + 2) * gGridSize Step gSquareSide + 2 ' horizontal lines
Line(x, gOriginY)-(x, gOriginY + gridSide), 1
Next x
For y = gOriginY + gSquareSide + 2 To gOriginY +(gSquareSide + 2) * gGridSize Step gSquareSide + 2 ' vertical lines
Line(gOriginX, y)-(gOriginX + gridSide, y), 1
Next y
End Sub
'Init the(data) grid with 0s
Sub initGrid
Dim As Integer x, y
For x = 0 To 3
For y = 0 To 3
gGrid(x, y) = 0
Next y
Next x
addblock
addblock
End Sub
Sub moveBlock(sourceX As Integer, sourceY As Integer, targetX As Integer, targetY As Integer, merge As Integer)
If sourceX < 0 Or sourceX >= gGridSize Or sourceY < 0 Or sourceY >= gGridSize And gDebug = 1 Then
Locate 0, 0 : Print "moveBlock: source coords out of bounds"
End If
If targetX < 0 Or targetX >= gGridSize Or targetY < 0 Or targetY >= gGridSize And gDebug = 1 Then
Locate 0, 0 : Print "moveBlock: source coords out of bounds"
End If
Dim As Integer sourceSquareValue = gGrid(sourceX, sourceY)
Dim As Integer targetSquareValue = gGrid(targetX, targetY)
If merge = 1 Then
If sourceSquareValue = targetSquareValue Then
gGrid(sourceX, sourceY) = 0
gGrid(targetX, targetY) = targetSquareValue * 2
gScore += targetSquareValue * 2 ' Points!
Elseif gDebug = 1 Then
Locate 0, 0 : Print "moveBlock: Attempted to merge unequal sqs"
End If
Else
If targetSquareValue = 0 Then
gGrid(sourceX, sourceY) = 0
gGrid(targetX, targetY) = sourceSquareValue
Elseif gDebug = 1 Then
Locate 0, 0 : Print "moveBlock: Attempted to move to non-empty block"
End If
End If
End Sub
Function pColor(r As Integer, g As Integer, b As Integer) As Integer
Return (r + g * 256 + b * 65536)
End Function
Sub moveToObstacle(x As Integer, y As Integer, direcc As String)
curX = x : curY = y
Do While getAdjacentCell(curX, curY, direcc) = 0
Select Case direcc
Case "l": curX -= 1
Case "r": curX += 1
Case "u": curY -= 1
Case "d": curY += 1
End Select
Loop
End Sub
Sub processBlock(x As Integer, y As Integer, direcc As String)
Dim As Integer merge = 0, mergeDirX, mergeDirY
If gGrid(x, y) <> 0 Then ' have block
moveToObstacle(x, y, direcc) ' figure out where it can be moved to
If getAdjacentCell(curX, curY, direcc) = gGrid(x, y) And wasMerge = 0 Then ' obstacle can be merged with
merge = 1
wasMerge = 1
Else
wasMerge = 0
End If
If curX <> x Or curY <> y Or merge = 1 Then
mergeDirX = 0
mergeDirY = 0
If merge = 1 Then
Select Case direcc
Case "l": mergeDirX = -1
Case "r": mergeDirX = 1
Case "u": mergeDirY = -1
Case "d": mergeDirY = 1
End Select
End If
moveBlock(x, y, curX + mergeDirX, curY + mergeDirY, merge) ' move to before obstacle or merge
hasMoved = 1
End If
End If
End Sub
Sub renderGrid
Dim As Integer x, y
For x = 0 To gGridSize - 1
For y = 0 To gGridSize - 1
drawNumber(gGrid(x, y), x, y)
Next y
Next x
End Sub
Sub updateScore
Locate 1, 10 : Print Using "Score: #####"; gScore
End Sub
Sub processMove(direcc As String) '' direcc can be 'l', 'r', 'u', or 'd'
Dim As Integer x, y
hasMoved = 0
If direcc = "l" Then
For y = 0 To gGridSize - 1
wasMerge = 0
For x = 0 To gGridSize - 1
processBlock(x,y,direcc)
Next x
Next y
Elseif direcc = "r" Then
For y = 0 To gGridSize - 1
wasMerge = 0
For x = gGridSize - 1 To 0 Step -1
processBlock(x,y,direcc)
Next x
Next y
Elseif direcc = "u" Then
For x = 0 To gGridSize - 1
wasMerge = 0
For y = 0 To gGridSize - 1
processBlock(x,y,direcc)
Next y
Next x
Elseif direcc = "d" Then
For x = 0 To gGridSize - 1
wasMerge = 0
For y = gGridSize - 1 To 0 Step -1
processBlock(x,y,direcc)
Next y
Next x
End If
If hasMoved = 1 Then addblock
renderGrid
updateScore
End Sub
'--- Main Program ---
Screen 8
Windowtitle "2048"
Palette 1, pColor(35, 33, 31)
Palette 2, pColor(46, 46, 51)
Palette 3, pColor(59, 56, 50)
Palette 4, pColor(61, 44, 30)
Palette 5, pColor(61, 37, 25)
Palette 6, pColor(62, 31, 24)
Palette 7, pColor(62, 24, 15)
Palette 8, pColor(59, 52, 29)
Palette 9, pColor(59, 51, 24)
Palette 10, pColor(59, 50, 20)
Palette 11, pColor(59, 49, 16)
Palette 12, pColor(59, 49, 12)
Palette 13, pColor(15, 15, 13)
Palette 14, pColor(23, 22, 20)
Randomize Timer
Cls
Do
initGrid
initGraphicGrid
renderGrid
updateScore
gScore = 0
Locate 23, 10 : Print "Move with arrow keys."
Locate 24, 12 : Print "(R)estart, (Q)uit"
Dim As String k
Do
Do
k = Inkey
Loop Until k <> ""
Select Case k
Case EXTCHAR + Chr(72) 'up
processMove("u")
Case EXTCHAR + Chr(80) 'down
processMove("d")
Case EXTCHAR + Chr(77) 'right
processMove("r")
Case EXTCHAR + Chr(75) 'left
processMove("l")
Case "q", "Q", Chr(27) 'escape
End
Case "r", "R"
Exit Do
End Select
Loop
Loop</lang>
=={{header|Go}}==
| |||