2048 Puzzle

[bplus]

154 LOC

110 LOC

Code: (Select All)

DefLng A-Z
_Title "2048 - bplus mod Dav 2nd 2024-10-17" ' bplus 2024-10-17
'from Dav's 2048.BAS v1.01 Puzzle, OCT/2024  New for v1.01: Screen autoscales
ReDim Shared As Long Board(3, 3), Score, F
Randomize Timer
Screen _NewImage(400, 400, 32)
_ScreenMove 450, 180
_PrintMode _KeepBackground
F = _LoadFont("arial.ttf", 28): _Font F
GetNewNumber: GetNewNumber
Do
    DrawBoard
    If RemaingMove = 0 Then
        Line (75, 100)-(325, 300), _RGBA(0, 0, 0, 40), BF
        Line (75, 100)-(325, 300), _RGBA(255, 255, 255, 150), B
        s$ = "No More Moves!": _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 166), s$
        s$ = "Score:" + Str$(Score): _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 266), s$
        _Display: Beep: _Delay 3: Exit Do
    End If
    Do: key$ = InKey$: _Limit 30: Loop Until key$ <> ""
    If key$ = Chr$(0) + "K" Then LRArrow 1 'left arrow
    If key$ = Chr$(0) + "M" Then LRArrow 2 'right arrow
    If key$ = Chr$(0) + "H" Then UDArrow 1 'up arrow
    If key$ = Chr$(0) + "P" Then UDArrow 2 'down arrow
    '_KeyClear
    GetNewNumber
Loop Until key$ = Chr$(27)
Sleep
Sub GetNewNumber
    ReDim temp(15) '=== get a list of places to make a number
    c = 0
    For y = 0 To 3: For x = 0 To 3
            If Board(x, y) = 0 Then temp(c) = x + y * 4: c = c + 1
    Next: Next
    If c > 0 Then '=== choose one place to make a number
        i = Int(Rnd * c)
        y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
        If Rnd < .8 Then Board(x1, y1) = 2 Else Board(x1, y1) = 4
        DrawBoard
    End If
End Sub
Sub DrawBoard
    Cls , _RGB(187, 173, 160)
    Color _RGB(255, 255, 255)
    For x = 0 To 3: For y = 0 To 3 'do regular board next
            If Board(x, y) Then power = Log(Board(x, y)) / Log(2) Else power = 0
            bg& = _RGB32(255 - 17 * power)
            Line (x * 100 + 3, y * 100 + 3)-((x * 100) + 100 - 3, (y * 100) + 100 - 3), bg&, BF
            Line (x * 100 + 3, y * 100 + 3)-((x * 100) + 100 - 3, (y * 100) + 100 - 3), &HFFFFFFFF, B
            If Board(x, y) > 0 Then
                num$ = _Trim$(Str$(Board(x, y)))
                offx = (100 - _PrintWidth(num$)) / 2: offy = (100 - _FontHeight(F)) / 2
                Color &HFF000000
                _PrintString (x * 100 + offx + 2, y * 100 + offy + 2), num$
                Color &HFFFFFFFF
                _PrintString (x * 100 + offx, y * 100 + offy), num$
            End If
    Next: Next
    _Title "2048 - " + "Score: " + Str$(Score)
    _Display
End Sub
Sub LRArrow (direction&)
    If direction& = 1 Then pstart = 0: pstepper = 1: xs = 0: xe = 3 ' left
    If direction& = 2 Then pstart = 3: pstepper = -1: xs = 3: xe = 0 ' right
    For y = 0 To 3
        ReDim row(3)
        p = pstart
        For x = xs To xe Step pstepper
            If Board(x, y) <> 0 Then
                If row(p) = Board(x, y) Then
                    row(p) = row(p) + Board(x, y): Score = Score + row(p): p = p + pstepper
                ElseIf row(p) = 0 Then
                    row(p) = Board(x, y)
                Else
                    p = p + pstepper: If p >= 0 And p < 4 Then row(p) = Board(x, y)
                End If
            End If
        Next
        For x = xs To xe Step pstepper: Board(x, y) = row(x): Next
    Next
End Sub
Sub UDArrow (direction&)
    If direction& = 1 Then pstart = 0: pstepper = 1: ys = 0: ye = 3 ' up
    If direction& = 2 Then pstart = 3: pstepper = -1: ys = 3: ye = 0 ' down
    For x = 0 To 3
        ReDim col(3)
        p = pstart
        For y = ys To ye Step pstepper
            If Board(x, y) <> 0 Then
                If col(p) = Board(x, y) Then
                    col(p) = col(p) + Board(x, y): Score = Score + col(p): p = p + pstepper
                ElseIf col(p) = 0 Then
                    col(p) = Board(x, y)
                Else
                    p = p + pstepper: If p >= 0 And p < 4 Then col(p) = Board(x, y)
                End If
            End If
        Next
        For y = ys To ye Step pstepper: Board(x, y) = col(y): Next
    Next
End Sub
Function RemaingMove
    For x = 0 To 3
        For y = 0 To 3
            If Board(x, y) = 0 Then RemaingMove = 1
            If y < 3 Then If Board(x, y) = Board(x, y + 1) Then RemaingMove = 1
            If x < 3 Then If Board(x, y) = Board(x + 1, y) Then RemaingMove = 1
        Next
    Next
End Function

' =============================================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board to a side, like numbers will combine and double
' Score is shown in title bar. ESC quits. Objective is to get a tile at 2048 but can go further.

'==============================================================================================
' Tracking bplus mods
' 2024-10-17 Dav's original 468 tons of blank lines for easy reading removed plus all that redundant
' Flash code and stuff, reduced to last paragraph of screening the Board. Added Option _Explicit and
' Dim lines for all variables not Dim'd for Option _Explicit. Now 356 LOC!

' Next dump rounded box and TEXT subs and replace with font and Line BF
' removed ss for screen shrinkage factor just used a 400 x 400 screen
' RBox replaced with standard Line
' OK now 257 lines about even with Steves
' OK 237 with combined DoRight DoLeft
' OK 215 line combined DoUp and DoDown
' OK 192 lines with reduction in picking a new place for next number
' OK 186 lines with reduction of RemainingMove
' OK 182 more edits of comments
' OK 174 no blank lines!
' Man I am looking at all those lines for color in DrawBoard.
' OK 158 lines.
' OK 154 4 lines off RemainingMove does it still work?
' OK 148 some more lines in UDArrow and LRArrow
' OK 142 double parking where it makes sense
' OK 138 subst IF Then for Select Case
' OK 131 sub DEFLNG A-Z for Option _Explicit remov DIM's
' OK the Double Parking is getting more serious
' OK 110 enough!

And Best score:
   

I started playing stupid when I saw 1024, half way point.