2048 Puzzle

[bplus]

For the record even if Steve objects to one line (it's his fault I am doing better anyway!) :

2048 - 55 LOC

Code: (Select All)

DefLng A-Z: Randomize Timer: ReDim Shared B(15) ' 2048 - 55 LOC

Screen _NewImage(405, 405, 32): _ScreenMove 450, 180

_PrintMode _KeepBackground: _Font _LoadFont("arial.ttf", 28)

Color , &HFFBB0033: AddNewCell: AddNewCell

DoLoop: Cls: _Title "2048 - b+ 55 LOC " + "Score: " + Str$(Score)

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

For y = 0 To 3: For x = 0 To 3

        If B(y * 4 + x) = 0 Then 10

        If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then 10

        If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then 10

Next: Next: Beep: Sleep: End

10 ReDim t(15): jm = 0 ' Update Board by arrow keys

Select Case _KeyHit

    Case 27, 32: System

    Case 19200: jm = 4: ks = 0: ke = 3: kstep = 1: km = 1

    Case 19712: jm = 4: ks = 3: ke = 0: kstep = -1: km = 1

    Case 18432: jm = 1: ks = 0: ke = 3: kstep = 1: km = 4

    Case 20480: jm = 1: ks = 3: ke = 0: kstep = -1: km = 4

End Select: If jm = 0 Then GoTo DoLoop

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: 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 < .8 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4

    End If

End Sub



' =============================================================================



' Instructions briefly:

' Use arrow keys to move all numbers on board toward that side, like numbers

' will combine and double. Score is shown in title bar. ESC quits.

' Objective is to get a tile to 2048 but can go further.



'==============================================================================



' Guide for multiple statements on one line by way of colon = Double Parking:



' + Premise: Avoid horizontal scrolling if at all possible!

'   Use code _line extensions if you must. I think it worth the effort to avoid

'   those as well.  ( Now all lines < 80 chars !)



' + For sure, multiple assignments can go on one line best if all are related.



' + For sure, multiple short Sub calls specially if all are related.



' + Remember Next x, y and for keypress either _Keyhit or Input$(1)



' + Option _Explicit used until code is where I want then removed.

Longest line is 79 chars and look! it still works: