Free BASIC 2048.bas

#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