2048 Puzzle

[bplus]

A faster Autoplay almost burnt out my CPU before I put _Limit 4000 in it!

Code: (Select All)

' 2048 - Autoplay 3 Best score faster!  b+ 2024-10-27 10544 high
DefLng A-Z: Randomize Timer: ReDim Shared B(15), Score, High
Screen _NewImage(405, 405, 32): _ScreenMove 450, 180
_PrintMode _KeepBackground: _Font _LoadFont("arial.ttf", 28)
Color , &HFFBB0033
restart: AddNewCell: AddNewCell
DoLoop: Cls: _Title "High Score:" + Str$(High) + "  Score:" + Str$(Score)
If High = 0 Then DisplayBoard
eF = 0: xF = 0: yF = 0
For y = 0 To 3: For x = 0 To 3
        If B(y * 4 + x) = 0 Then eF = eF + 1
        If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then yF = yF + 1
        If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then xF = xF + 1
Next: Next
If (eF = 0 And xF = 0) And yF = 0 Then ' no moves left
    If Score > High Then High = Score: DisplayBoard
    Score = 0: ReDim B(15): GoTo restart
End If
ReDim t(15): jm = 0 ' Update Board by arrow keys
If xF > yF Then
    If Rnd < .85 Then d = 1 Else d = 2
Else
    d = 4
End If
Select Case d
    Case 1: jm = 4: ks = 0: ke = 3: kstep = 1: km = 1 ' left
    Case 2: jm = 4: ks = 3: ke = 0: kstep = -1: km = 1 'right
    Case 3: jm = 1: ks = 0: ke = 3: kstep = 1: km = 4 ' up
    Case 4: jm = 1: ks = 3: ke = 0: kstep = -1: km = 4 ' down
End Select
For j = 0 To 3
    If jm = 4 Then p = j * jm + ks Else If kstep = 1 Then p = j Else p = 12 + j
    For k = ks To ke Step kstep
        If B(j * jm + k * km) <> 0 Then
            If t(p) = B(j * jm + k * km) Then
                t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p)
                p = p + kstep * km
            ElseIf t(p) = 0 Then '
                t(p) = B(j * jm + k * km)
            Else
                p = p + kstep * km: t(p) = B(j * jm + k * km)
            End If
        End If
Next k, j
For j = 0 To 15: B(j) = t(j): Next: AddNewCell: _Limit 4000: GoTo DoLoop
Sub AddNewCell '  == Insert new cell onto board in random unused blank ==
    Dim temp(15), x, y, c, i, x1, y1
    For y = 0 To 3: For x = 0 To 3
            If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
    Next x, y
    If c > 0 Then
        i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
        If Rnd < .9 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4
    End If
End Sub
Sub DisplayBoard
    For x = 0 To 3: For y = 0 To 3
            If B(x + 4 * y) Then pwr = Log(B(x + 4 * y)) / Log(2) Else pwr = 0
            bg& = _RGB32(255 - 17 * pwr): bg2& = _RGB32(128 - 12 * pwr)
            Line (x * 100 + 4, y * 100 + 4)-Step(100 - 4, 100 - 4), bg&, BF
            Line (x * 100 + 5, y * 100 + 5)-Step(100 - 6, 100 - 6), bg2&, B
            If B(x + 4 * y) > 0 Then
                n$ = _Trim$(Str$(B(x + 4 * y))): u = x * 100: v = y * 100
                ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight) / 2
                Color &HFF000000: _PrintString (u + ox + 2, v + oy + 2), n$
                Color &HFFFFFFFF: _PrintString (u + ox, v + oy), n$
            End If
    Next: Next: _Display: _Limit 30
End Sub

   
This is starting to get close to my highest!