2048 Puzzle

[Dav]

Classic 2048 game.  Use arrows to move numbers.  Goal is to combine same numbers until a 2048 number is made.

Still working on this, but it's fully playable already. Lots of code bloat.  I need to rethink how I'm handling/drawing the board.  I didn't want to post this version now, but my wrist is starting to bother me a little from too much coding and piano gigs lately, so I'm going to rest from coding for a while and post this as is.  Will pick it up a later time.

- Dav

Code: (Select All)

'========

'2048.BAS

'========

'Classic 2048 puzzle for QB64.

'by Dav, OCT/2024



'Use arrow keys to move numbers on board.

'Score is shown in title bar.

'ESC quits



Screen _NewImage(800, 800, 32)



ReDim Shared board(3, 3), flash(3, 3), score



GetNewNumber

GetNewNumber



Do

    DrawBoard



    If MovesLeft = 0 Then

        Rbox 150, 150, 650, 450, 30, _RGBA(0, 0, 0, 150), 1

        Rbox 150, 150, 650, 450, 30, _RGBA(255, 255, 255, 255), 0

        Text 200 + 2, 200 + 2, 60, _RGB(0, 0, 0), "NO MORE MOVES!"

        Text 200, 200, 60, _RGB(255, 255, 255), "NO MORE MOVES!"

        Text 200 + 2, 300 + 2, 60, _RGB(0, 0, 0), "SCORE:" + _Trim$(Str$(score))

        Text 200, 300, 60, _RGB(255, 255, 255), "SCORE:" + _Trim$(Str$(score))

        _Display: Beep: _Delay 3: Exit Do

    End If



    Do

        key$ = InKey$

        _Limit 30

    Loop Until key$ <> ""



    Select Case key$

        Case Chr$(0) + "K": DoLeft 'left arrow

        Case Chr$(0) + "M": DoRight 'right arrow

        Case Chr$(0) + "H": DoUp 'up arrow

        Case Chr$(0) + "P": DoDown 'down arrow

    End Select

    _KeyClear



    GetNewNumber



Loop Until key$ = Chr$(27)

Sleep

End



Sub GetNewNumber



    '=== get a list of places to make a number

    ReDim temp(15)

    c = 0

    For x = 0 To 3

        For y = 0 To 3

            If board(x, y) = 0 Then

                temp(c) = x * 4 + y

                c = c + 1

            End If

        Next

    Next

    '=== choose one place to make a number

    If c > 0 Then

        i = Int(Rnd * c)

        If Rnd < .8 Then

            DrawBoard

            x1 = Int(temp(i) / 4): y1 = temp(i) Mod 4

            For s = 100 To 0 Step -20

                Rbox (x1 * 200) + s, (y1 * 200) + s, ((x1 * 200) + 200) - s, ((y1 * 200) + 200) - s, 30, _RGB(239, 229, 218), 1

                _Display

                _Delay .025

            Next

            board(x1, y1) = 2

        Else

            DrawBoard

            x1 = Int(temp(i) / 4): y1 = temp(i) Mod 4

            For s = 100 To 0 Step -20

                Rbox (x1 * 200) + s, (y1 * 200) + s, ((x1 * 200) + 200) - s, ((y1 * 200) + 200) - s, 30, _RGB(239, 229, 218), 1

                _Display

                _Delay .025

            Next

            board(x1, y1) = 4

        End If

    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

            Select Case board(x, y)

                Case 2: bg& = _RGB(239, 229, 218)

                Case 4: bg& = _RGB(236, 224, 198)

                Case 8: bg& = _RGB(241, 177, 121)

                Case 16: bg& = _RGB(236, 141, 84)

                Case 32: bg& = _RGB(247, 124, 95)

                Case 64: bg& = _RGB(233, 89, 55)

                Case 128: bg& = _RGB(242, 217, 107)

                Case 256: bg& = _RGB(238, 205, 96)

                Case 512: bg& = _RGB(238, 205, 96)

                Case 1024: bg& = _RGB(238, 205, 96)

                Case 2048: bg& = _RGB(238, 205, 96)

                Case 4096: bg& = _RGB(121, 184, 226)

                Case 8192: bg& = _RGB(121, 184, 226)

                Case 16384: bg& = _RGB(121, 184, 226)

                Case 32768: bg& = _RGB(60, 64, 64)

                Case Else: bg& = _RGB(204, 192, 180)

            End Select



            If flash(x, y) <> 0 Then

                'skip for now

            Else

                Rbox x * 200 + 5, y * 200 + 5, (x * 200) + 200 - 5, (y * 200) + 200 - 5, 30, bg&, 1

                Rbox x * 200 + 5, y * 200 + 5, (x * 200) + 200 - 5, (y * 200) + 200 - 5, 30, _RGB(255, 255, 255), 0

                If board(x, y) > 0 Then

                    num$ = _Trim$(Str$(board(x, y)))

                    If Val(num$) < 8 Then fg& = _RGB(128, 128, 128) Else fg& = _RGB(255, 255, 255)

                    size = 200 / 2: ts = size: tx = size / 2 + (size / 4): ty = size / 2

                    Select Case Len(num$)

                        Case 2: tx = size / 2: ty = size / 2

                        Case 3: ts = 200 / 2.5: tx = size / 2.5: ty = size / 1.75

                        Case 4: ts = 200 / 3: tx = size / 3: ty = size / 1.50

                        Case 5: ts = 200 / 3.5: tx = size / 3.5: ty = size / 1.36

                    End Select

                    Text x * 200 + tx + 2, y * 200 + ty + 2, ts, _RGB(0, 0, 0), num$

                    Text x * 200 + tx, y * 200 + ty, ts, fg&, num$

                End If

            End If



        Next

    Next





    'do flash board

    For s = 100 To 0 Step -20

        For x = 0 To 3

            For y = 0 To 3

                If flash(x, y) <> 0 Then

                    Select Case flash(x, y)

                        Case 2: bg& = _RGB(239, 229, 218)

                        Case 4: bg& = _RGB(236, 224, 198)

                        Case 8: bg& = _RGB(241, 177, 121)

                        Case 16: bg& = _RGB(236, 141, 84)

                        Case 32: bg& = _RGB(247, 124, 95)

                        Case 64: bg& = _RGB(233, 89, 55)

                        Case 128: bg& = _RGB(242, 217, 107)

                        Case 256: bg& = _RGB(238, 205, 96)

                        Case 512: bg& = _RGB(238, 205, 96)

                        Case 1024: bg& = _RGB(238, 205, 96)

                        Case 2048: bg& = _RGB(238, 205, 96)

                        Case 4096: bg& = _RGB(121, 184, 226)

                        Case 8192: bg& = _RGB(121, 184, 226)

                        Case 16384: bg& = _RGB(121, 184, 226)

                        Case 32768: bg& = _RGB(60, 64, 64)

                        Case Else: bg& = _RGB(204, 192, 180)

                    End Select

                    Rbox (x * 200) + s, (y * 200) + s, ((x * 200) + 200) - s, ((y * 200) + 200) - s, 30, bg&, 1

                End If

            Next

        Next



        _Display

        _Delay .025



    Next



    'do regular board next

    For x = 0 To 3

        For y = 0 To 3

            Select Case board(x, y)

                Case 2: bg& = _RGB(239, 229, 218)

                Case 4: bg& = _RGB(236, 224, 198)

                Case 8: bg& = _RGB(241, 177, 121)

                Case 16: bg& = _RGB(236, 141, 84)

                Case 32: bg& = _RGB(247, 124, 95)

                Case 64: bg& = _RGB(233, 89, 55)

                Case 128: bg& = _RGB(242, 217, 107)

                Case 256: bg& = _RGB(238, 205, 96)

                Case 512: bg& = _RGB(238, 205, 96)

                Case 1024: bg& = _RGB(238, 205, 96)

                Case 2048: bg& = _RGB(238, 205, 96)

                Case 4096: bg& = _RGB(121, 184, 226)

                Case 8192: bg& = _RGB(121, 184, 226)

                Case 16384: bg& = _RGB(121, 184, 226)

                Case 32768: bg& = _RGB(60, 64, 64)

                Case Else: bg& = _RGB(204, 192, 180)

            End Select

            Rbox x * 200 + 5, y * 200 + 5, (x * 200) + 200 - 5, (y * 200) + 200 - 5, 30, bg&, 1

            Rbox x * 200 + 5, y * 200 + 5, (x * 200) + 200 - 5, (y * 200) + 200 - 5, 30, _RGB(255, 255, 255), 0

            If board(x, y) > 0 Then

                num$ = _Trim$(Str$(board(x, y)))

                If Val(num$) < 8 Then fg& = _RGB(128, 128, 128) Else fg& = _RGB(255, 255, 255)

                size = 200 / 2: ts = size: tx = size / 2 + (size / 4): ty = size / 2

                Select Case Len(num$)

                    Case 2: tx = size / 2: ty = size / 2

                    Case 3: ts = 200 / 2.5: tx = size / 2.5: ty = size / 1.75

                    Case 4: ts = 200 / 3: tx = size / 3: ty = size / 1.50

                    Case 5: ts = 200 / 3.5: tx = size / 3.5: ty = size / 1.36

                End Select

                Text x * 200 + tx + 2, y * 200 + ty + 2, ts, _RGB(0, 0, 0), num$

                Text x * 200 + tx, y * 200 + ty, ts, fg&, num$

            End If

        Next

    Next



    ReDim flash(3, 3)





    _Title "2048 - " + "Score: " + Str$(score)

    _Display



End Sub



Sub DoLeft



    ReDim flash(3, 3)



    For y = 0 To 3

        ReDim row(3)

        p = 0

        For x = 0 To 3

            If board(x, y) <> 0 Then

                If row(p) = board(x, y) Then

                    row(p) = row(p) + board(x, y)

                    score = score + row(p)

                    flash(p, y) = row(p) '+ board(x, y)

                    p = p + 1

                ElseIf row(p) = 0 Then

                    row(p) = board(x, y)

                Else

                    p = p + 1

                    If p < 4 Then row(p) = board(x, y)

                End If

            End If

        Next



        For x = 0 To 3

            board(x, y) = row(x)

        Next



    Next



End Sub



Sub DoRight

    ReDim flash(3, 3)



    For y = 0 To 3

        ReDim row(3)

        p = 3

        For x = 3 To 0 Step -1

            If board(x, y) <> 0 Then

                If row(p) = board(x, y) Then

                    row(p) = row(p) + board(x, y)

                    score = score + row(p)

                    flash(p, y) = row(p)

                    p = p - 1

                ElseIf row(p) = 0 Then

                    row(p) = board(x, y)

                Else

                    p = p - 1

                    If p >= 0 Then

                        row(p) = board(x, y)

                    End If

                End If

            End If

        Next



        For x = 0 To 3

            board(x, y) = row(x)

        Next

    Next



End Sub



Sub DoUp



    ReDim flash(3, 3)



    For x = 0 To 3

        ReDim col(3)

        p = 0

        For y = 0 To 3

            If board(x, y) <> 0 Then

                If col(p) = board(x, y) Then

                    col(p) = col(p) + board(x, y)

                    score = score + col(p)

                    flash(x, p) = col(p)

                    p = p + 1

                ElseIf col(p) = 0 Then

                    col(p) = board(x, y)

                Else

                    p = p + 1

                    If p < 4 Then col(p) = board(x, y)

                End If

            End If

        Next



        For y = 0 To 3

            board(x, y) = col(y)

        Next

    Next



End Sub



Sub DoDown



    ReDim flash(3, 3)



    For x = 0 To 3

        ReDim col(3)

        p = 3

        For y = 3 To 0 Step -1

            If board(x, y) <> 0 Then

                If col(p) = board(x, y) Then

                    col(p) = col(p) + board(x, y)

                    score = score + col(p)

                    flash(x, p) = col(p)

                    p = p - 1

                ElseIf col(p) = 0 Then

                    col(p) = board(x, y)

                Else

                    p = p - 1

                    If p >= 0 Then col(p) = board(x, y)

                End If

            End If

        Next



        For y = 3 To 0 Step -1

            board(x, y) = col(y)

        Next

    Next



End Sub



Function MovesLeft

    MovesLeft = 0

    For x = 0 To 3

        For y = 0 To 3

            If board(x, y) = 0 Then

                MovesLeft = 1

            End If

            If y < 3 Then

                If board(x, y) = board(x, y + 1) Then

                    MovesLeft = 1

                End If

            End If

            If x < 3 Then

                If board(x, y) = board(x + 1, y) Then

                    MovesLeft = 1

                End If

            End If

        Next

    Next

End Function



Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)

    'Text SUB by bplus.

    Dim fg As _Unsigned Long, cur&, I&, multi, xlen

    fg = _DefaultColor

    cur& = _Dest

    I& = _NewImage(8 * Len(txt$), 16, 32)

    _Dest I&

    Color K, _RGBA32(0, 0, 0, 0)

    _PrintString (0, 0), txt$

    multi = textHeight / 16

    xlen = Len(txt$) * 8 * multi

    _PutImage (x, y)-Step(xlen, textHeight), I&, cur&

    Color fg

    _FreeImage I&

    _Dest cur&

End Sub





Sub Rbox (x1, y1, x2, y2, r, clr~&, fill)

    'x1/y1, y2/y2 = placement of box

    'r = radius of rounded corner

    'clr~& = color of box

    'fill =  1 for filled, 0 for just an edge



    ReDim filled(_Width + x2, _Height + y2) As Integer



    If fill = 1 Then

        Line (x1 + r + 1, y1)-(x2 - r - 1, y1 + r), clr~&, BF 'top

        Line (x1 + r + 1, y2 - r)-(x2 - r - 1, y2), clr~&, BF 'bottom

        Line (x1, y1 + r + 1)-(x1 + r, y2 - r - 1), clr~&, BF 'left

        Line (x2 - r, y1 + r + 1)-(x2, y2 - r - 1), clr~&, BF 'right

        Line (x1 + r + 1, y1 + r + 1)-(x2 - r - 1, y2 - r - 1), clr~&, BF 'middle

    Else

        Line (x1 + r, y1)-(x2 - r, y1), clr~& 'top

        Line (x1 + r, y2)-(x2 - r, y2), clr~& 'bottom

        Line (x1, y1 + r)-(x1, y2 - r), clr~& 'left

        Line (x2, y1 + r)-(x2, y2 - r), clr~& 'right

    End If



    'top left corner

    For angle = 180 To 270

        If fill = 1 Then

            For radius = 0 To r

                x3 = (x1 + r) + radius * Cos(_D2R(angle))

                y3 = (y1 + r) + radius * Sin(_D2R(angle))

                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

            Next

        Else

            x3 = (x1 + r) + r * Cos(_D2R(angle))

            y3 = (y1 + r) + r * Sin(_D2R(angle))

            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

        End If

    Next



    'top right corner

    For angle = 270 To 360

        If fill = 1 Then

            For radius = 0 To r

                x3 = (x2 - r) + radius * Cos(_D2R(angle))

                y3 = (y1 + r) + radius * Sin(_D2R(angle))

                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

            Next

        Else

            x3 = (x2 - r) + r * Cos(_D2R(angle))

            y3 = (y1 + r) + r * Sin(_D2R(angle))

            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

        End If

    Next



    'bottom left corner

    For angle = 90 To 180

        If fill = 1 Then

            For radius = 0 To r

                x3 = (x1 + r) + radius * Cos(_D2R(angle))

                y3 = (y2 - r) + radius * Sin(_D2R(angle))

                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

            Next

        Else

            x3 = (x1 + r) + r * Cos(_D2R(angle))

            y3 = (y2 - r) + r * Sin(_D2R(angle))

            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

        End If

    Next



    'bottom right corner

    For angle = 0 To 90

        If fill = 1 Then

            For radius = 0 To r

                x3 = (x2 - r) + radius * Cos(_D2R(angle))

                y3 = (y2 - r) + radius * Sin(_D2R(angle))

                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

            Next

        Else

            x3 = (x2 - r) + r * Cos(_D2R(angle))

            y3 = (y2 - r) + r * Sin(_D2R(angle))

            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1

        End If

    Next



End Sub

[FellippeHeitor]

I did one in screen 0 back in the day, I can share it if you wanna see the logic I used (although I do trust you more with that kinda thing)

[Dav]

Id love to see it, @FellippeHeitor!  Actually i studied a text mode one, which didnt work at all, but i got some good idea for row/col merging from it. I tried to copy the one i play on my ipad.

- Dav

[FellippeHeitor]

I found the version I rewrote when I discovered QB64 (this is from 2015), and by then I had ported it to graphics mode, but the logic is still the same from the original QB45 text version, I believe. If I fetch that one I'll let you know. Now let me compile your code...

---

Love the large font and how you've been faithful to the original game's palette. So much done in 459 lines of code, man!

[bplus]

Nice! I finally looked up the rules for playing. Missed the part that the arrow shifts all numbers in that direction doubling like numbers and creating a space.

For a cuter size game board that fits laptop:

Code: (Select All)

'========
'2048.BAS
'========
'Classic 2048 puzzle for QB64.
'by Dav, OCT/2024

'Use arrow keys to move numbers on board.
'Score is shown in title bar.
'ESC quits

Screen _NewImage(600, 600, 32)
_ScreenMove 350, 60
ReDim Shared board(3, 3), flash(3, 3), score

GetNewNumber
GetNewNumber

Do
    DrawBoard

    If MovesLeft = 0 Then
        Rbox 150, 150, 650, 450, 30, _RGBA(0, 0, 0, 150), 1
        Rbox 150, 150, 650, 450, 30, _RGBA(255, 255, 255, 255), 0
        Text 200 + 2, 200 + 2, 60, _RGB(0, 0, 0), "NO MORE MOVES!"
        Text 200, 200, 60, _RGB(255, 255, 255), "NO MORE MOVES!"
        Text 200 + 2, 300 + 2, 60, _RGB(0, 0, 0), "SCORE:" + _Trim$(Str$(score))
        Text 200, 300, 60, _RGB(255, 255, 255), "SCORE:" + _Trim$(Str$(score))
        _Display: Beep: _Delay 3: Exit Do
    End If

    Do
        key$ = InKey$
        _Limit 30
    Loop Until key$ <> ""

    Select Case key$
        Case Chr$(0) + "K": DoLeft 'left arrow
        Case Chr$(0) + "M": DoRight 'right arrow
        Case Chr$(0) + "H": DoUp 'up arrow
        Case Chr$(0) + "P": DoDown 'down arrow
    End Select
    _KeyClear

    GetNewNumber

Loop Until key$ = Chr$(27)
Sleep
End

Sub GetNewNumber

    '=== get a list of places to make a number
    ReDim temp(15)
    c = 0
    For x = 0 To 3
        For y = 0 To 3
            If board(x, y) = 0 Then
                temp(c) = x * 4 + y
                c = c + 1
            End If
        Next
    Next
    '=== choose one place to make a number
    If c > 0 Then
        i = Int(Rnd * c)
        If Rnd < .8 Then
            DrawBoard
            x1 = Int(temp(i) / 4): y1 = temp(i) Mod 4
            For s = 100 To 0 Step -20
                Rbox (x1 * 150) + s, (y1 * 150) + s, ((x1 * 150) + 150) - s, ((y1 * 150) + 150) - s, 30, _RGB(239, 229, 218), 1
                _Display
                _Delay .025
            Next
            board(x1, y1) = 2
        Else
            DrawBoard
            x1 = Int(temp(i) / 4): y1 = temp(i) Mod 4
            For s = 100 To 0 Step -20
                Rbox (x1 * 150) + s, (y1 * 150) + s, ((x1 * 150) + 150) - s, ((y1 * 150) + 150) - s, 30, _RGB(239, 229, 218), 1
                _Display
                _Delay .025
            Next
            board(x1, y1) = 4
        End If
    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
            Select Case board(x, y)
                Case 2: bg& = _RGB(239, 229, 218)
                Case 4: bg& = _RGB(236, 224, 198)
                Case 8: bg& = _RGB(241, 177, 121)
                Case 16: bg& = _RGB(236, 141, 84)
                Case 32: bg& = _RGB(247, 124, 95)
                Case 64: bg& = _RGB(233, 89, 55)
                Case 128: bg& = _RGB(242, 217, 107)
                Case 256: bg& = _RGB(238, 205, 96)
                Case 512: bg& = _RGB(238, 205, 96)
                Case 1024: bg& = _RGB(238, 205, 96)
                Case 2048: bg& = _RGB(238, 205, 96)
                Case 4096: bg& = _RGB(121, 184, 226)
                Case 8192: bg& = _RGB(121, 184, 226)
                Case 16384: bg& = _RGB(121, 184, 226)
                Case 32768: bg& = _RGB(60, 64, 64)
                Case Else: bg& = _RGB(204, 192, 180)
            End Select

            If flash(x, y) <> 0 Then
                'skip for now
            Else
                Rbox x * 150 + 5, y * 150 + 5, (x * 150) + 150 - 5, (y * 150) + 150 - 5, 30, bg&, 1
                Rbox x * 150 + 5, y * 150 + 5, (x * 150) + 150 - 5, (y * 150) + 150 - 5, 30, _RGB(255, 255, 255), 0
                If board(x, y) > 0 Then
                    num$ = _Trim$(Str$(board(x, y)))
                    If Val(num$) < 8 Then fg& = _RGB(128, 128, 128) Else fg& = _RGB(255, 255, 255)
                    size = 150 / 2: ts = size: tx = size / 2 + (size / 4): ty = size / 2
                    Select Case Len(num$)
                        Case 2: tx = size / 2: ty = size / 2
                        Case 3: ts = 150 / 2.5: tx = size / 2.5: ty = size / 1.75
                        Case 4: ts = 150 / 3: tx = size / 3: ty = size / 1.50
                        Case 5: ts = 150 / 3.5: tx = size / 3.5: ty = size / 1.36
                    End Select
                    Text x * 150 + tx + 2, y * 150 + ty + 2, ts, _RGB(0, 0, 0), num$
                    Text x * 150 + tx, y * 150 + ty, ts, fg&, num$
                End If
            End If

        Next
    Next


    'do flash board
    For s = 100 To 0 Step -20
        For x = 0 To 3
            For y = 0 To 3
                If flash(x, y) <> 0 Then
                    Select Case flash(x, y)
                        Case 2: bg& = _RGB(239, 229, 218)
                        Case 4: bg& = _RGB(236, 224, 198)
                        Case 8: bg& = _RGB(241, 177, 121)
                        Case 16: bg& = _RGB(236, 141, 84)
                        Case 32: bg& = _RGB(247, 124, 95)
                        Case 64: bg& = _RGB(233, 89, 55)
                        Case 128: bg& = _RGB(242, 217, 107)
                        Case 256: bg& = _RGB(238, 205, 96)
                        Case 512: bg& = _RGB(238, 205, 96)
                        Case 1024: bg& = _RGB(238, 205, 96)
                        Case 2048: bg& = _RGB(238, 205, 96)
                        Case 4096: bg& = _RGB(121, 184, 226)
                        Case 8192: bg& = _RGB(121, 184, 226)
                        Case 16384: bg& = _RGB(121, 184, 226)
                        Case 32768: bg& = _RGB(60, 64, 64)
                        Case Else: bg& = _RGB(204, 192, 180)
                    End Select
                    Rbox (x * 150) + s, (y * 150) + s, ((x * 150) + 150) - s, ((y * 150) + 150) - s, 30, bg&, 1
                End If
            Next
        Next

        _Display
        _Delay .025

    Next

    'do regular board next
    For x = 0 To 3
        For y = 0 To 3
            Select Case board(x, y)
                Case 2: bg& = _RGB(239, 229, 218)
                Case 4: bg& = _RGB(236, 224, 198)
                Case 8: bg& = _RGB(241, 177, 121)
                Case 16: bg& = _RGB(236, 141, 84)
                Case 32: bg& = _RGB(247, 124, 95)
                Case 64: bg& = _RGB(233, 89, 55)
                Case 128: bg& = _RGB(242, 217, 107)
                Case 256: bg& = _RGB(238, 205, 96)
                Case 512: bg& = _RGB(238, 205, 96)
                Case 1024: bg& = _RGB(238, 205, 96)
                Case 2048: bg& = _RGB(238, 205, 96)
                Case 4096: bg& = _RGB(121, 184, 226)
                Case 8192: bg& = _RGB(121, 184, 226)
                Case 16384: bg& = _RGB(121, 184, 226)
                Case 32768: bg& = _RGB(60, 64, 64)
                Case Else: bg& = _RGB(204, 192, 180)
            End Select
            Rbox x * 150 + 5, y * 150 + 5, (x * 150) + 150 - 5, (y * 150) + 150 - 5, 30, bg&, 1
            Rbox x * 150 + 5, y * 150 + 5, (x * 150) + 150 - 5, (y * 150) + 150 - 5, 30, _RGB(255, 255, 255), 0
            If board(x, y) > 0 Then
                num$ = _Trim$(Str$(board(x, y)))
                If Val(num$) < 8 Then fg& = _RGB(128, 128, 128) Else fg& = _RGB(255, 255, 255)
                size = 150 / 2: ts = size: tx = size / 2 + (size / 4): ty = size / 2
                Select Case Len(num$)
                    Case 2: tx = size / 2: ty = size / 2
                    Case 3: ts = 150 / 2.5: tx = size / 2.5: ty = size / 1.75
                    Case 4: ts = 150 / 3: tx = size / 3: ty = size / 1.50
                    Case 5: ts = 150 / 3.5: tx = size / 3.5: ty = size / 1.36
                End Select
                Text x * 150 + tx + 2, y * 150 + ty + 2, ts, _RGB(0, 0, 0), num$
                Text x * 150 + tx, y * 150 + ty, ts, fg&, num$
            End If
        Next
    Next

    ReDim flash(3, 3)


    _Title "2048 - " + "Score: " + Str$(score)
    _Display

End Sub

Sub DoLeft

    ReDim flash(3, 3)

    For y = 0 To 3
        ReDim row(3)
        p = 0
        For x = 0 To 3
            If board(x, y) <> 0 Then
                If row(p) = board(x, y) Then
                    row(p) = row(p) + board(x, y)
                    score = score + row(p)
                    flash(p, y) = row(p) '+ board(x, y)
                    p = p + 1
                ElseIf row(p) = 0 Then
                    row(p) = board(x, y)
                Else
                    p = p + 1
                    If p < 4 Then row(p) = board(x, y)
                End If
            End If
        Next

        For x = 0 To 3
            board(x, y) = row(x)
        Next

    Next

End Sub

Sub DoRight
    ReDim flash(3, 3)

    For y = 0 To 3
        ReDim row(3)
        p = 3
        For x = 3 To 0 Step -1
            If board(x, y) <> 0 Then
                If row(p) = board(x, y) Then
                    row(p) = row(p) + board(x, y)
                    score = score + row(p)
                    flash(p, y) = row(p)
                    p = p - 1
                ElseIf row(p) = 0 Then
                    row(p) = board(x, y)
                Else
                    p = p - 1
                    If p >= 0 Then
                        row(p) = board(x, y)
                    End If
                End If
            End If
        Next

        For x = 0 To 3
            board(x, y) = row(x)
        Next
    Next

End Sub

Sub DoUp

    ReDim flash(3, 3)

    For x = 0 To 3
        ReDim col(3)
        p = 0
        For y = 0 To 3
            If board(x, y) <> 0 Then
                If col(p) = board(x, y) Then
                    col(p) = col(p) + board(x, y)
                    score = score + col(p)
                    flash(x, p) = col(p)
                    p = p + 1
                ElseIf col(p) = 0 Then
                    col(p) = board(x, y)
                Else
                    p = p + 1
                    If p < 4 Then col(p) = board(x, y)
                End If
            End If
        Next

        For y = 0 To 3
            board(x, y) = col(y)
        Next
    Next

End Sub

Sub DoDown

    ReDim flash(3, 3)

    For x = 0 To 3
        ReDim col(3)
        p = 3
        For y = 3 To 0 Step -1
            If board(x, y) <> 0 Then
                If col(p) = board(x, y) Then
                    col(p) = col(p) + board(x, y)
                    score = score + col(p)
                    flash(x, p) = col(p)
                    p = p - 1
                ElseIf col(p) = 0 Then
                    col(p) = board(x, y)
                Else
                    p = p - 1
                    If p >= 0 Then col(p) = board(x, y)
                End If
            End If
        Next

        For y = 3 To 0 Step -1
            board(x, y) = col(y)
        Next
    Next

End Sub

Function MovesLeft
    MovesLeft = 0
    For x = 0 To 3
        For y = 0 To 3
            If board(x, y) = 0 Then
                MovesLeft = 1
            End If
            If y < 3 Then
                If board(x, y) = board(x, y + 1) Then
                    MovesLeft = 1
                End If
            End If
            If x < 3 Then
                If board(x, y) = board(x + 1, y) Then
                    MovesLeft = 1
                End If
            End If
        Next
    Next
End Function

Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
    'Text SUB by bplus.
    Dim fg As _Unsigned Long, cur&, I&, multi, xlen
    fg = _DefaultColor
    cur& = _Dest
    I& = _NewImage(8 * Len(txt$), 16, 32)
    _Dest I&
    Color K, _RGBA32(0, 0, 0, 0)
    _PrintString (0, 0), txt$
    multi = textHeight / 16
    xlen = Len(txt$) * 8 * multi
    _PutImage (x, y)-Step(xlen, textHeight), I&, cur&
    Color fg
    _FreeImage I&
    _Dest cur&
End Sub


Sub Rbox (x1, y1, x2, y2, r, clr~&, fill)
    'x1/y1, y2/y2 = placement of box
    'r = radius of rounded corner
    'clr~& = color of box
    'fill =  1 for filled, 0 for just an edge

    ReDim filled(_Width + x2, _Height + y2) As Integer

    If fill = 1 Then
        Line (x1 + r + 1, y1)-(x2 - r - 1, y1 + r), clr~&, BF 'top
        Line (x1 + r + 1, y2 - r)-(x2 - r - 1, y2), clr~&, BF 'bottom
        Line (x1, y1 + r + 1)-(x1 + r, y2 - r - 1), clr~&, BF 'left
        Line (x2 - r, y1 + r + 1)-(x2, y2 - r - 1), clr~&, BF 'right
        Line (x1 + r + 1, y1 + r + 1)-(x2 - r - 1, y2 - r - 1), clr~&, BF 'middle
    Else
        Line (x1 + r, y1)-(x2 - r, y1), clr~& 'top
        Line (x1 + r, y2)-(x2 - r, y2), clr~& 'bottom
        Line (x1, y1 + r)-(x1, y2 - r), clr~& 'left
        Line (x2, y1 + r)-(x2, y2 - r), clr~& 'right
    End If

    'top left corner
    For angle = 180 To 270
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x1 + r) + radius * Cos(_D2R(angle))
                y3 = (y1 + r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x1 + r) + r * Cos(_D2R(angle))
            y3 = (y1 + r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

    'top right corner
    For angle = 270 To 360
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x2 - r) + radius * Cos(_D2R(angle))
                y3 = (y1 + r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x2 - r) + r * Cos(_D2R(angle))
            y3 = (y1 + r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

    'bottom left corner
    For angle = 90 To 180
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x1 + r) + radius * Cos(_D2R(angle))
                y3 = (y2 - r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x1 + r) + r * Cos(_D2R(angle))
            y3 = (y2 - r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

    'bottom right corner
    For angle = 0 To 90
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x2 - r) + radius * Cos(_D2R(angle))
                y3 = (y2 - r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x2 - r) + r * Cos(_D2R(angle))
            y3 = (y2 - r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

End Sub

Oh I luv large font too

[Dav]

@FellippeHeitor: Nice version!  Plays smooth.  I like how the blocks slide into place. That's what mine is missing.

@bplus: Cool. I went ahead and made a scaled version of it, so it will resize perfectly on any desktop to 70% of desktopheight.  What I did was half all the drawing values and applied a scaling factor to them.

- Dav

Code: (Select All)

'========
'2048.BAS v1.01
'========
'Classic 2048 puzzle for QB64.
'by Dav, OCT/2024

'New for v1.01:  Screen now autoscales to user desktop.

'Use arrow keys to move numbers on board.
'Score is shown in title bar.
'ESC quits

'Credits: Uses Text SUB by bplus for the big numbers.

Randomize Timer

Dim Shared ss: ss = (_DesktopHeight / 400) * .70 'screen scale factor (70% of desktop height)

Screen _NewImage(400 * ss, 400 * ss, 32)

ReDim Shared board(3, 3), flash(3, 3), score

GetNewNumber
GetNewNumber

Do
    DrawBoard

    If MovesLeft = 0 Then
        Rbox 75 * ss, 75 * ss, 325 * ss, 225 * ss, 15 * ss, _RGBA(0, 0, 0, 150), 1
        Rbox 75 * ss, 75 * ss, 325 * ss, 225 * ss, 15 * ss, _RGBA(255, 255, 255, 255), 0
        Text (100 * ss) + (2 * ss), (100 * ss) + (2 * ss), 30 * ss, _RGB(0, 0, 0), "NO MORE MOVES!"
        Text 100 * ss, 100 * ss, 30 * ss, _RGB(255, 255, 255), "NO MORE MOVES!"
        Text (100 * ss) + (2 * ss), (150 * ss) + (2 * ss), 30 * ss, _RGB(0, 0, 0), "SCORE:" + _Trim$(Str$(score))
        Text 100 * ss, 150 * ss, 30 * ss, _RGB(255, 255, 255), "SCORE:" + _Trim$(Str$(score))
        _Display: Beep: _Delay 3: Exit Do
    End If

    Do
        key$ = InKey$
        _Limit 30
    Loop Until key$ <> ""

    Select Case key$
        Case Chr$(0) + "K": DoLeft 'left arrow
        Case Chr$(0) + "M": DoRight 'right arrow
        Case Chr$(0) + "H": DoUp 'up arrow
        Case Chr$(0) + "P": DoDown 'down arrow
    End Select
    _KeyClear

    GetNewNumber

Loop Until key$ = Chr$(27)
Sleep
End

Sub GetNewNumber

    '=== get a list of places to make a number
    ReDim temp(15)
    c = 0
    For x = 0 To 3
        For y = 0 To 3
            If board(x, y) = 0 Then
                temp(c) = x * 4 + y
                c = c + 1
            End If
        Next
    Next
    '=== choose one place to make a number
    If c > 0 Then
        i = Int(Rnd * c)
        If Rnd < .8 Then
            DrawBoard
            x1 = Int(temp(i) / 4): y1 = temp(i) Mod 4
            For s = 50 * ss To 0 Step -(10 * ss)
                Rbox (x1 * (100 * ss)) + s, (y1 * (100 * ss)) + s, ((x1 * (100 * ss)) + (100 * ss)) - s, ((y1 * (100 * ss)) + (100 * ss)) - s, 15 * ss, _RGB(239, 229, 218), 1
                _Display
                _Delay .025
            Next
            board(x1, y1) = 2
        Else
            DrawBoard
            x1 = Int(temp(i) / 4): y1 = temp(i) Mod 4
            For s = 50 * ss To 0 Step -(10 * ss)
                Rbox (x1 * (100 * ss)) + s, (y1 * (100 * ss)) + s, ((x1 * (100 * ss)) + (100 * ss)) - s, ((y1 * (100 * ss)) + (100 * ss)) - s, 15 * ss, _RGB(239, 229, 218), 1
                _Display
                _Delay .025
            Next
            board(x1, y1) = 4
        End If
    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
            Select Case board(x, y)
                Case 2: bg& = _RGB(239, 229, 218)
                Case 4: bg& = _RGB(236, 224, 198)
                Case 8: bg& = _RGB(241, 177, 121)
                Case 16: bg& = _RGB(236, 141, 84)
                Case 32: bg& = _RGB(247, 124, 95)
                Case 64: bg& = _RGB(233, 89, 55)
                Case 128: bg& = _RGB(242, 217, 107)
                Case 256: bg& = _RGB(238, 205, 96)
                Case 512: bg& = _RGB(238, 205, 96)
                Case 1024: bg& = _RGB(238, 205, 96)
                Case 2048: bg& = _RGB(238, 205, 96)
                Case 4096: bg& = _RGB(121, 184, 226)
                Case 8192: bg& = _RGB(121, 184, 226)
                Case 16384: bg& = _RGB(121, 184, 226)
                Case 32768: bg& = _RGB(60, 64, 64)
                Case Else: bg& = _RGB(204, 192, 180)
            End Select

            If flash(x, y) <> 0 Then
                'skip for now
            Else
                Rbox x * (100 * ss) + (3 * ss), y * (100 * ss) + (3 * ss), (x * (100 * ss)) + (100 * ss) - (3 * ss), (y * (100 * ss)) + (100 * ss) - (3 * ss), 15 * ss, bg&, 1
                Rbox x * (100 * ss) + (3 * ss), y * (100 * ss) + (3 * ss), (x * (100 * ss)) + (100 * ss) - (3 * ss), (y * (100 * ss)) + (100 * ss) - (3 * ss), 15 * ss, _RGB(255, 255, 255), 0
                If board(x, y) > 0 Then
                    num$ = _Trim$(Str$(board(x, y)))
                    If Val(num$) < 8 Then fg& = _RGB(128, 128, 128) Else fg& = _RGB(255, 255, 255)
                    size = (100 * ss) / 2: ts = size: tx = size / 2 + (size / 4): ty = size / 2
                    Select Case Len(num$)
                        Case 2: tx = size / 2: ty = size / 2
                        Case 3: ts = (100 * ss) / 2.5: tx = size / 2.5: ty = size / 1.75
                        Case 4: ts = (100 * ss) / 3: tx = size / 3: ty = size / 1.50
                        Case 5: ts = (100 * ss) / 3.5: tx = size / 3.5: ty = size / 1.36
                    End Select
                    Text x * (100 * ss) + tx + (2 * ss), y * (100 * ss) + ty + (2 * ss), ts, _RGB(0, 0, 0), num$
                    Text x * (100 * ss) + tx, y * (100 * ss) + ty, ts, fg&, num$
                End If
            End If


        Next
    Next


    'do flash board
    For s = 50 To 0 Step -10
        For x = 0 To 3
            For y = 0 To 3
                If flash(x, y) <> 0 Then
                    Select Case flash(x, y)
                        Case 2: bg& = _RGB(239, 229, 218)
                        Case 4: bg& = _RGB(236, 224, 198)
                        Case 8: bg& = _RGB(241, 177, 121)
                        Case 16: bg& = _RGB(236, 141, 84)
                        Case 32: bg& = _RGB(247, 124, 95)
                        Case 64: bg& = _RGB(233, 89, 55)
                        Case 128: bg& = _RGB(242, 217, 107)
                        Case 256: bg& = _RGB(238, 205, 96)
                        Case 512: bg& = _RGB(238, 205, 96)
                        Case 1024: bg& = _RGB(238, 205, 96)
                        Case 2048: bg& = _RGB(238, 205, 96)
                        Case 4096: bg& = _RGB(121, 184, 226)
                        Case 8192: bg& = _RGB(121, 184, 226)
                        Case 16384: bg& = _RGB(121, 184, 226)
                        Case 32768: bg& = _RGB(60, 64, 64)
                        Case Else: bg& = _RGB(204, 192, 180)
                    End Select
                    Rbox (x * (100 * ss)) + s, (y * (100 * ss)) + s, ((x * (100 * ss)) + (100 * ss)) - s, ((y * (100 * ss)) + (100 * ss)) - s, 15 * ss, bg&, 1
                End If
            Next
        Next

        _Display
        _Delay .025

    Next

    'do regular board next
    For x = 0 To 3
        For y = 0 To 3
            Select Case board(x, y)
                Case 2: bg& = _RGB(239, 229, 218)
                Case 4: bg& = _RGB(236, 224, 198)
                Case 8: bg& = _RGB(241, 177, 121)
                Case 16: bg& = _RGB(236, 141, 84)
                Case 32: bg& = _RGB(247, 124, 95)
                Case 64: bg& = _RGB(233, 89, 55)
                Case 128: bg& = _RGB(242, 217, 107)
                Case 256: bg& = _RGB(238, 205, 96)
                Case 512: bg& = _RGB(238, 205, 96)
                Case 1024: bg& = _RGB(238, 205, 96)
                Case 2048: bg& = _RGB(238, 205, 96)
                Case 4096: bg& = _RGB(121, 184, 226)
                Case 8192: bg& = _RGB(121, 184, 226)
                Case 16384: bg& = _RGB(121, 184, 226)
                Case 32768: bg& = _RGB(60, 64, 64)
                Case Else: bg& = _RGB(204, 192, 180)
            End Select
            Rbox x * (100 * ss) + (3 * ss), y * (100 * ss) + (3 * ss), (x * (100 * ss)) + (100 * ss) - (3 * ss), (y * (100 * ss)) + (100 * ss) - (3 * ss), 15 * ss, bg&, 1
            Rbox x * (100 * ss) + (3 * ss), y * (100 * ss) + (3 * ss), (x * (100 * ss)) + (100 * ss) - (3 * ss), (y * (100 * ss)) + (100 * ss) - (3 * ss), 15 * ss, _RGB(255, 255, 255), 0
            If board(x, y) > 0 Then
                num$ = _Trim$(Str$(board(x, y)))
                If Val(num$) < 8 Then fg& = _RGB(128, 128, 128) Else fg& = _RGB(255, 255, 255)
                size = (100 * ss) / 2: ts = size: tx = size / 2 + (size / 4): ty = size / 2
                Select Case Len(num$)
                    Case 2: tx = size / 2: ty = size / 2
                    Case 3: ts = (100 * ss) / 2.5: tx = size / 2.5: ty = size / 1.75
                    Case 4: ts = (100 * ss) / 3: tx = size / 3: ty = size / 1.50
                    Case 5: ts = (100 * ss) / 3.5: tx = size / 3.5: ty = size / 1.36
                End Select
                Text x * (100 * ss) + tx + (2 * ss), y * (100 * ss) + ty + (2 * ss), ts, _RGB(0, 0, 0), num$
                Text x * (100 * ss) + tx, y * (100 * ss) + ty, ts, fg&, num$
            End If
        Next
    Next

    ReDim flash(3, 3)


    _Title "2048 - " + "Score: " + Str$(score)
    _Display

End Sub

Sub DoLeft

    ReDim flash(3, 3)

    For y = 0 To 3
        ReDim row(3)
        p = 0
        For x = 0 To 3
            If board(x, y) <> 0 Then
                If row(p) = board(x, y) Then
                    row(p) = row(p) + board(x, y)
                    score = score + row(p)
                    flash(p, y) = row(p) '+ board(x, y)
                    p = p + 1
                ElseIf row(p) = 0 Then
                    row(p) = board(x, y)
                Else
                    p = p + 1
                    If p < 4 Then row(p) = board(x, y)
                End If
            End If
        Next

        For x = 0 To 3
            board(x, y) = row(x)
        Next

    Next

End Sub

Sub DoRight
    ReDim flash(3, 3)

    For y = 0 To 3
        ReDim row(3)
        p = 3
        For x = 3 To 0 Step -1
            If board(x, y) <> 0 Then
                If row(p) = board(x, y) Then
                    row(p) = row(p) + board(x, y)
                    score = score + row(p)
                    flash(p, y) = row(p)
                    p = p - 1
                ElseIf row(p) = 0 Then
                    row(p) = board(x, y)
                Else
                    p = p - 1
                    If p >= 0 Then
                        row(p) = board(x, y)
                    End If
                End If
            End If
        Next

        For x = 0 To 3
            board(x, y) = row(x)
        Next
    Next

End Sub

Sub DoUp

    ReDim flash(3, 3)

    For x = 0 To 3
        ReDim col(3)
        p = 0
        For y = 0 To 3
            If board(x, y) <> 0 Then
                If col(p) = board(x, y) Then
                    col(p) = col(p) + board(x, y)
                    score = score + col(p)
                    flash(x, p) = col(p)
                    p = p + 1
                ElseIf col(p) = 0 Then
                    col(p) = board(x, y)
                Else
                    p = p + 1
                    If p < 4 Then col(p) = board(x, y)
                End If
            End If
        Next

        For y = 0 To 3
            board(x, y) = col(y)
        Next
    Next

End Sub

Sub DoDown

    ReDim flash(3, 3)

    For x = 0 To 3
        ReDim col(3)
        p = 3
        For y = 3 To 0 Step -1
            If board(x, y) <> 0 Then
                If col(p) = board(x, y) Then
                    col(p) = col(p) + board(x, y)
                    score = score + col(p)
                    flash(x, p) = col(p)
                    p = p - 1
                ElseIf col(p) = 0 Then
                    col(p) = board(x, y)
                Else
                    p = p - 1
                    If p >= 0 Then col(p) = board(x, y)
                End If
            End If
        Next

        For y = 3 To 0 Step -1
            board(x, y) = col(y)
        Next
    Next

End Sub

Function MovesLeft
    MovesLeft = 0
    For x = 0 To 3
        For y = 0 To 3
            If board(x, y) = 0 Then
                MovesLeft = 1
            End If
            If y < 3 Then
                If board(x, y) = board(x, y + 1) Then
                    MovesLeft = 1
                End If
            End If
            If x < 3 Then
                If board(x, y) = board(x + 1, y) Then
                    MovesLeft = 1
                End If
            End If
        Next
    Next
End Function

Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
    'Text SUB by bplus.
    Dim fg As _Unsigned Long, cur&, I&, multi, xlen
    fg = _DefaultColor
    cur& = _Dest
    I& = _NewImage(8 * Len(txt$), 16, 32)
    _Dest I&
    Color K, _RGBA32(0, 0, 0, 0)
    _PrintString (0, 0), txt$
    multi = textHeight / 16
    xlen = Len(txt$) * 8 * multi
    _PutImage (x, y)-Step(xlen, textHeight), I&, cur&
    Color fg
    _FreeImage I&
    _Dest cur&
End Sub


Sub Rbox (x1, y1, x2, y2, r, clr~&, fill)
    'x1/y1, y2/y2 = placement of box
    'r = radius of rounded corner
    'clr~& = color of box
    'fill =  1 for filled, 0 for just an edge

    ReDim filled(_Width + x2, _Height + y2) As Integer

    If fill = 1 Then
        Line (x1 + r + 1, y1)-(x2 - r - 1, y1 + r), clr~&, BF 'top
        Line (x1 + r + 1, y2 - r)-(x2 - r - 1, y2), clr~&, BF 'bottom
        Line (x1, y1 + r + 1)-(x1 + r, y2 - r - 1), clr~&, BF 'left
        Line (x2 - r, y1 + r + 1)-(x2, y2 - r - 1), clr~&, BF 'right
        Line (x1 + r + 1, y1 + r + 1)-(x2 - r - 1, y2 - r - 1), clr~&, BF 'middle
    Else
        Line (x1 + r, y1)-(x2 - r, y1), clr~& 'top
        Line (x1 + r, y2)-(x2 - r, y2), clr~& 'bottom
        Line (x1, y1 + r)-(x1, y2 - r), clr~& 'left
        Line (x2, y1 + r)-(x2, y2 - r), clr~& 'right
    End If

    'top left corner
    For angle = 180 To 270
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x1 + r) + radius * Cos(_D2R(angle))
                y3 = (y1 + r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x1 + r) + r * Cos(_D2R(angle))
            y3 = (y1 + r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

    'top right corner
    For angle = 270 To 360
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x2 - r) + radius * Cos(_D2R(angle))
                y3 = (y1 + r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x2 - r) + r * Cos(_D2R(angle))
            y3 = (y1 + r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

    'bottom left corner
    For angle = 90 To 180
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x1 + r) + radius * Cos(_D2R(angle))
                y3 = (y2 - r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x1 + r) + r * Cos(_D2R(angle))
            y3 = (y2 - r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

    'bottom right corner
    For angle = 0 To 90
        If fill = 1 Then
            For radius = 0 To r
                x3 = (x2 - r) + radius * Cos(_D2R(angle))
                y3 = (y2 - r) + radius * Sin(_D2R(angle))
                If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
            Next
        Else
            x3 = (x2 - r) + r * Cos(_D2R(angle))
            y3 = (y2 - r) + r * Sin(_D2R(angle))
            If filled(x3, y3) = 0 Then PSet (x3, y3), clr~&: filled(x3, y3) = 1
        End If
    Next

End Sub

[bplus]

@FellippeHeitor nice directions / Help screen.

@Dav your update works for me.

You guys have inspired me to take a shot at this, maybe I can build my skills while building a less LOC game.

[Dav]

Neat, can’t wait to see your version. I think if I redo this I would make the number blocks images instead, that way I could slide, and pop/animate them good with rotozoom.

- Dav

[bplus]

I just found one by @SMcNeill, that one is pretty low on LOC.

I searched Games for it, no show, so with all your permissions (I hope) I will include here:
I knocked out allot of extra empty lines and moved the book he wrote on MoveBox MakeBox to underneath to get an LOC of around 257, not bad, sorta what I was shooting for!

SMcNeill 2048 Game

Code: (Select All)

_Define A-Z As _INTEGER64
Dim Shared Grid(0 To 5, 0 To 5) As Integer
Const Left = 19200
Const Right = 19712
Const Down = 20480
Const Up = 18432
Const ESC = 32
Const LCtrl = 100306
Const RCtrl = 100305

Init
MakeNewGame
Do
    _Limit 30
    ShowGrid
    CheckInput flag
    If flag Then GetNextNumber
    _Display
Loop

Sub CheckInput (flag)
    flag = 0
    k = _KeyHit
    Select Case k
        Case ESC: System
        Case 83, 115 'S
            If _KeyDown(LCtrl) Or _KeyDown(RCtrl) Then MakeNewGame
        Case Left
            MoveLeft
            flag = -1 'we hit a valid move key.  Even if we don't move, get a new number
        Case Up
            MoveUp
            flag = -1
        Case Down
            MoveDown
            flag = -1
        Case Right
            MoveRight
            flag = -1
    End Select
End Sub

Sub MoveDown
    'first move everything left to cover the blank spaces
    Do
        moved = 0
        For y = 4 To 1 Step -1
            For x = 1 To 4
                If Grid(x, y) = 0 Then 'every point above this moves down
                    For j = y To 1 Step -1
                        Grid(x, j) = Grid(x, j - 1)
                        If Grid(x, j) <> 0 Then moved = -1
                    Next
                End If
            Next
        Next
        If moved Then y = y + 1 'recheck the same column
    Loop Until Not moved
    For y = 4 To 1 Step -1
        For x = 1 To 4
            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y - 1) Then 'add them together and every point above this moves
                Grid(x, y) = Grid(x, y) * 2
                For j = y - 1 To 1
                    Grid(x, j) = Grid(x, j - 1)
                Next
            End If
        Next
    Next
End Sub

Sub MoveLeft
    'first move everything to cover the blank spaces
    Do
        moved = 0
        For x = 1 To 4
            For y = 1 To 4
                If Grid(x, y) = 0 Then 'every point right of this moves left
                    For j = x To 4
                        Grid(j, y) = Grid(j + 1, y)
                        If Grid(j, y) <> 0 Then moved = -1
                    Next
                End If
            Next
        Next
        If moved Then x = x - 1 'recheck the same row
    Loop Until Not moved
    For x = 1 To 4
        For y = 1 To 4
            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x + 1, y) Then 'add them together and every point right of this moves left
                Grid(x, y) = Grid(x, y) * 2
                For j = x + 1 To 4
                    Grid(j, y) = Grid(j + 1, y)
                Next
            End If
        Next
    Next
End Sub

Sub MoveUp
    'first move everything to cover the blank spaces
    Do
        moved = 0
        For y = 1 To 4
            For x = 1 To 4
                If Grid(x, y) = 0 Then 'every point below of this moves up
                    For j = y To 4
                        Grid(x, j) = Grid(x, j + 1)
                        If Grid(x, j) <> 0 Then moved = -1
                    Next
                End If
            Next
        Next
        If moved Then y = y - 1 'recheck the same column
    Loop Until Not moved
    For y = 1 To 4
        For x = 1 To 4
            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y + 1) Then 'add them together and every point below this moves
                Grid(x, y) = Grid(x, y) * 2
                For j = y + 1 To 4
                    Grid(x, j) = Grid(x, j + 1)
                Next
                Grid(x, 4) = 0
            End If
        Next
    Next
End Sub

Sub MoveRight
    'first move everything to cover the blank spaces
    Do
        moved = 0
        For x = 4 To 1 Step -1
            For y = 1 To 4
                If Grid(x, y) = 0 Then 'every point right of this moves left
                    For j = x To 1 Step -1
                        Grid(j, y) = Grid(j - 1, y)
                        If Grid(j, y) <> 0 Then moved = -1
                    Next
                End If
            Next
        Next
        If moved Then x = x - 1 'recheck the same row
    Loop Until Not moved

    For x = 4 To 1 Step -1
        For y = 1 To 4
            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x - 1, y) Then 'add them together and every point right of this moves left
                Grid(x, y) = Grid(x, y) * 2
                For j = x - 1 To 1 Step -1
                    Grid(j, y) = Grid(j - 1, y)
                Next
            End If
        Next
    Next
End Sub

Sub ShowGrid
    'SUB MakeBox (Mode AS INTEGER, x1 AS INTEGER, y1 AS INTEGER, x2 AS INTEGER, y2 AS INTEGER,
    'Caption AS STRING, FontColor AS _UNSIGNED LONG, FontBackground AS _UNSIGNED LONG,
    'BoxColor AS _UNSIGNED LONG, BoxHighLight AS _UNSIGNED LONG, XOffset AS INTEGER, YOffset AS INTEGER)
    w = 120
    h = 120
    For x = 1 To 4
        For y = 1 To 4
            t$ = LTrim$(Str$(Grid(x, y)))
            If t$ = "0" Then t$ = ""
            MakeBox 4, (x - 1) * w, (y - 1) * h, w, h, t$, -1, 0, 0, -1, 0, 0
        Next
    Next
End Sub

Sub Init
    ws = _NewImage(480, 480, 32)
    Screen ws
    _Delay 1
    _Title "Double Up"
    _ScreenMove _Middle
    Randomize Timer
    f& = _LoadFont("C:\Windows\Fonts\courbd.ttf", 32, "MONOSPACE")
    _Font f&

End Sub

Sub MakeNewGame
    For x = 1 To 4
        For y = 1 To 4
            Grid(x, y) = 0
        Next
    Next
    GetNextNumber
    GetNextNumber
End Sub

Sub GetNextNumber
    For x = 1 To 4
        For y = 1 To 4
            If Grid(x, y) = 0 Then valid = -1
        Next
    Next
    If valid Then 'If all the grids are full, we can't add any more numbers
        'This doesn't mean the game is over, as the player may be able to
        Do
            x = _Ceil(Rnd * 4)
            y = _Ceil(Rnd * 4)
        Loop Until Grid(x, y) = 0
        Grid(x, y) = 2
    End If
End Sub

Sub MakeBox (Mode As Integer, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, Caption As String, FontColor As _Unsigned Long, FontBackground As _Unsigned Long, BoxColor As _Unsigned Long, BoxHighLight As _Unsigned Long, XOffset As Integer, YOffset As Integer)
    Dim BoxBlack As _Unsigned Long

    dc& = _DefaultColor: bg& = _BackgroundColor
    If Black <> 0 Then
        'We have black either as a CONST or a SHARED color
        BoxBlack = Black
    Else
        'We need to define what Black is for our box.
        BoxBlack = _RGB32(0, 0, 0)
    End If

    If _FontWidth <> 0 Then cw = _FontWidth * Len(Caption) Else cw = _PrintWidth(Caption)
    ch = _FontHeight

    tx1 = x1: tx2 = x2: ty1 = y1: ty2 = y2
    Select Case Mode
        Case 0
            'We use the X2, Y2 coordinates provided as absolute coordinates
        Case 1
            tx2 = tx1 + cw + 8
            ty2 = ty1 + ch + 8
            XOffset = 5: YOffset = 5
        Case 2
            tx2 = tx1 + x2
            ty2 = ty1 + y2
        Case 3
            XOffset = (tx2 - tx1 - cw) \ 2
            YOffset = (ty2 - ty1 - ch) \ 2
        Case 4
            tx2 = tx1 + x2
            ty2 = ty1 + y2
            XOffset = (tx2 - tx1) \ 2 - cw \ 2
            YOffset = (ty2 - ty1 - ch) \ 2
    End Select
    Line (tx1, ty1)-(tx2, ty2), BoxBlack, BF
    Line (tx1 + 1, ty1 + 1)-(tx2 - 1, ty2 - 1), BoxHighLight, B
    Line (tx1 + 2, ty1 + 2)-(tx2 - 2, ty2 - 2), BoxHighLight, B
    Line (tx1 + 3, ty1 + 3)-(tx2 - 3, ty2 - 3), BoxBlack, B
    Line (tx1, ty1)-(tx1 + 3, ty1 + 3), BoxBlack
    Line (tx2, ty1)-(tx2 - 3, ty1 + 3), BoxBlack
    Line (tx1, ty2)-(tx1 + 3, ty2 - 3), BoxBlack
    Line (tx2, ty2)-(tx2 - 3, ty2 - 3), BoxBlack
    Line (tx1 + 3, y1 + 3)-(tx2 - 3, ty2 - 3), BoxColor, BF
    Color FontColor, FontBackground
    _PrintString (tx1 + XOffset, ty1 + YOffset), Caption$
    Color dc&, bg&
End Sub

' ========================================= MakeBox Comments
'This is an upgrade version of my original Button routine.
'It's more versitile (but complex) than the original.
'Mode 0 (or any unsupported number) will tell the box to size itself from X1,Y1 to X2,Y2
'Mode 1 will tell the box to autosize itself according to whatever text is placed within it.
'Mode 2 will tell the box to use X2 and Y2 as relative coordinates and not absolute coordinates.
'Mode 3 will tell the box to autocenter text with X2, Y2 being absolute coordinates.
'Mode 4 will tell the box to autocenter text with X2, Y2 being relative coordinates.
'Mode otherwise is unused, but available for expanded functionality.
'X1 carries the X location of where we want to place our box on the screen.
'Y2 carries the Y location of where we want to place our box on the screen.
'X2 is the X boundry of our box on the screen, depending on our mode.
'Y2 is the Y boundry of our box on the screen, depending on our mode.

'Caption is the text that we want our box to contain.

'FontColor is our font color for our caption
'FontBackground is the font background color for our caption
'NOTE: IF FONTCOLOR OR FONTBACKGROUND IS SET TO ZERO, THEY WILL **NOT** AFFECT THE COLOR BEHIND THEM.
'This can be used to mimic the function of _KEEPBACKGROUND, _FILLBACKGROUND, or _ONLYBACKGROUND

'BoxColor is our box color
'BoxHighlight is our box highligh colors
'NOTE: SAME WITH BOXCOLOR AND BOXHIGHLIGHT.  IF SET TO ZERO, THEY WILL HAVE **NO** COLOR AT ALL TO THEM, AND WILL NOT AFFECT THE BACKGROUND OF ANYTHING BEHIND THEM.

'XOffset is used to offset our text # pixels from the X1 top.
'YOffset is used to offset our text # pixels from the Y1 top.
'These can be used to place our text wherever we want on our box.
'But remember, if Mode = 3 or 4, the box will autocenter the text and ignore these parameters completely.

OH! He called it Double Up no wonder I couldn't find it.

Update 3: Might as well get The Master of cutting BS LOC involved I know he can do better on this one because I think I can

Update: Still can't find it in Games. I don't remember where/when I got it. Less than a year ago, my memory is guessing?

Update 2: @Dav I got yours down to 358 (minus 110 lines) by removing blank lines, but I added Option _Explicit and DIM all not Dim'd yet. Plus I dumped that flash redundant stuff, I don't miss it, I just used last paragraph of screen drawing of Board. I suppose you were going for a visual effect?

[SMcNeill]

I also have this one -- Double Up, Any Size!

Code: (Select All)

_Define A-Z As _INTEGER64

Dim Shared GameSize

$Resize:On

_Resize , _Smooth

Do

    Input "How large a grid would you like to try your skill against?"; Gridsize

    If Gridsize < 4 Or Gridsize > 10 Then Print "Grid must between 4 an 10 tiles."

Loop Until Gridsize > 3 And Gridsize < 11

GameSize = Gridsize





Dim Shared Grid(0 To GameSize + 1, 0 To GameSize + 1) As Integer

Const Left = 19200

Const Right = 19712

Const Down = 20480

Const Up = 18432

Const ESC = 27

Const LCtrl = 100306

Const RCtrl = 100305



'The highscore IRC client shared variables

Dim Shared Client As Long, Server As String, Channel As String

Dim Shared Speaker As String

Dim Shared LastSpeaker As String, nick$

Dim Shared respond







Init

MakeNewGame

Do

    _Limit 30

    ShowGrid

    CheckInput flag

    If flag Then GetNextNumber

    _Display

Loop











Sub CheckInput (flag)

    flag = 0

    k = _KeyHit

    Select Case k

        Case ESC: System

        Case 83, 115 'S

            If _KeyDown(LCtrl) Or _KeyDown(RCtrl) Then

                GetHighScores

                MakeNewGame

            End If

        Case Left

            MoveLeft

            flag = -1 'we hit a valid move key.  Even if we don't move, get a new number

        Case Up

            MoveUp

            flag = -1

        Case Down

            MoveDown

            flag = -1

        Case Right

            MoveRight

            flag = -1

    End Select

End Sub



Sub GetHighScores

    _AutoDisplay

    DC = _DefaultColor: BG = _BackgroundColor

    Cls

    f& = _Font

    _Font 16

    Do: i$ = InKey$: k = _KeyHit: Loop Until k = 0 And i$ = "" 'clear the keyboard buffer

    Input "Please Enter your name =>"; player$



    player$ = LTrim$(UCase$(player$))





    Cls

    For x = 1 To GameSize

        For y = 1 To GameSize

            If Grid(x, y) > score Then score = Grid(x, y)

        Next

    Next

    Print "Checking online for the high player list.  This might take a moment."



    result$ = HighScore$("Double Up" + Str$(GameSize), player$, score)

    Print "Finished Checking"

    If Left$(result$, 5) = "ERROR" Then Print result$: Close: GoTo finishup

    _AutoDisplay

    'COLOR DC, BG

    Open "temp.txt" For Output As #1: Close #1 'make a blank file to start with

    Open "temp.txt" For Binary As #1

    Put #1, , result$

    Close

    Open "temp.txt" For Input As #1

    c = 0

    Cls

    Print "DOUBLE UP HIGH SCORES!"



    Do

        c = c + 1

        Input #1, p$

        p$ = UCase$(LTrim$(RTrim$(p$)))

        If p$ = "SKB64 DONE" Then Exit Do

        Input #1, s

        Print Str$(c), p$, s

    Loop

    Close #1



    finishup:

    Do: i$ = InKey$: k = _KeyHit: Loop Until k = 0 And i$ = "" 'clear the keyboard buffer



    Print "Press <ANY KEY> to continue"

    Do

        _Limit 30

        k = _KeyHit

    Loop Until k <> 0

    Cls

    _Font f&

    _Display

    Close Client

End Sub





Sub MoveDown

    'first move everything left to cover the blank spaces

    Do

        moved = 0

        For y = GameSize To 1 Step -1

            For x = 1 To GameSize

                If Grid(x, y) = 0 Then 'every point above this moves down

                    For j = y To 1 Step -1

                        Grid(x, j) = Grid(x, j - 1)

                        If Grid(x, j) <> 0 Then moved = -1

                    Next

                End If

            Next

        Next

        If moved Then y = y + 1 'recheck the same column

    Loop Until Not moved

    For y = GameSize To 1 Step -1

        For x = 1 To GameSize

            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y - 1) Then 'add them together and every point above this moves

                Grid(x, y) = Grid(x, y) * 2

                For j = y - 1 To 1

                    Grid(x, j) = Grid(x, j - 1)

                Next

            End If

        Next

    Next

End Sub







Sub MoveLeft

    'first move everything to cover the blank spaces

    Do

        moved = 0

        For x = 1 To GameSize

            For y = 1 To GameSize

                If Grid(x, y) = 0 Then 'every point right of this moves left

                    For j = x To GameSize

                        Grid(j, y) = Grid(j + 1, y)

                        If Grid(j, y) <> 0 Then moved = -1

                    Next

                End If

            Next

        Next

        If moved Then x = x - 1 'recheck the same row

    Loop Until Not moved

    For x = 1 To GameSize

        For y = 1 To GameSize

            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x + 1, y) Then 'add them together and every point right of this moves left

                Grid(x, y) = Grid(x, y) * 2

                For j = x + 1 To GameSize

                    Grid(j, y) = Grid(j + 1, y)

                Next

            End If

        Next

    Next

End Sub



Sub MoveUp

    'first move everything to cover the blank spaces

    Do

        moved = 0

        For y = 1 To GameSize

            For x = 1 To GameSize

                If Grid(x, y) = 0 Then 'every point below of this moves up

                    For j = y To GameSize

                        Grid(x, j) = Grid(x, j + 1)

                        If Grid(x, j) <> 0 Then moved = -1

                    Next

                End If

            Next

        Next

        If moved Then y = y - 1 'recheck the same column

    Loop Until Not moved

    For y = 1 To GameSize

        For x = 1 To GameSize

            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y + 1) Then 'add them together and every point below this moves

                Grid(x, y) = Grid(x, y) * 2

                For j = y + 1 To GameSize

                    Grid(x, j) = Grid(x, j + 1)

                Next

                Grid(x, GameSize) = 0

            End If

        Next

    Next

End Sub





Sub MoveRight

    'first move everything to cover the blank spaces

    Do

        moved = 0

        For x = GameSize To 1 Step -1

            For y = 1 To GameSize

                If Grid(x, y) = 0 Then 'every point right of this moves left

                    For j = x To 1 Step -1

                        Grid(j, y) = Grid(j - 1, y)

                        If Grid(j, y) <> 0 Then moved = -1

                    Next

                End If

            Next

        Next

        If moved Then x = x - 1 'recheck the same row

    Loop Until Not moved



    For x = GameSize To 1 Step -1

        For y = 1 To GameSize

            If Grid(x, y) <> 0 And Grid(x, y) = Grid(x - 1, y) Then 'add them together and every point right of this moves left

                Grid(x, y) = Grid(x, y) * 2

                For j = x - 1 To 1 Step -1

                    Grid(j, y) = Grid(j - 1, y)

                Next

            End If

        Next

    Next

End Sub







Sub ShowGrid

    'SUB MakeBox (Mode AS INTEGER, x1 AS INTEGER, y1 AS INTEGER, x2 AS INTEGER, y2 AS INTEGER,

    'Caption AS STRING, FontColor AS _UNSIGNED LONG, FontBackground AS _UNSIGNED LONG,

    'BoxColor AS _UNSIGNED LONG, BoxHighLight AS _UNSIGNED LONG, XOffset AS INTEGER, YOffset AS INTEGER)

    w = _Width / GameSize

    h = _Height / GameSize

    For x = 1 To GameSize

        For y = 1 To GameSize

            t$ = LTrim$(Str$(Grid(x, y)))

            If t$ = "0" Then t$ = ""

            MakeBox GameSize, (x - 1) * w, (y - 1) * h, w, h, t$, -1, 0, 0, -1, 0, 0

        Next

    Next

End Sub







Sub Init

    ws = _NewImage(640, 640, 32)

    Screen ws

    _Delay 1

    _Title "Anysize Double Up"

    _ScreenMove _Middle

    Randomize Timer

    f& = _LoadFont("C:\Windows\Fonts\courbd.ttf", 48 * 4 \ GameSize, "MONOSPACE")

    _Font f&



End Sub



Sub MakeNewGame

    For x = 1 To GameSize

        For y = 1 To GameSize

            Grid(x, y) = 0

        Next

    Next

    GetNextNumber

    GetNextNumber

End Sub



Sub GetNextNumber

    For x = 1 To GameSize

        For y = 1 To GameSize

            If Grid(x, y) = 0 Then valid = -1

        Next

    Next

    If valid Then 'If all the grids are full, we can't add any more numbers

        'This doesn't mean the game is over, as the player may be able to

        Do

            x = _Ceil(Rnd * GameSize)

            y = _Ceil(Rnd * GameSize)

        Loop Until Grid(x, y) = 0

        Grid(x, y) = 2

    End If

End Sub



Sub MakeBox (Mode As Integer, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, Caption As String, FontColor As _Unsigned Long, FontBackground As _Unsigned Long, BoxColor As _Unsigned Long, BoxHighLight As _Unsigned Long, XOffset As Integer, YOffset As Integer)



    'This is an upgrade version of my original Button routine.

    'It's more versitile (but complex) than the original.

    'Mode 0 (or any unsupported number) will tell the box to size itself from X1,Y1 to X2,Y2

    'Mode 1 will tell the box to autosize itself according to whatever text is placed within it.

    'Mode 2 will tell the box to use X2 and Y2 as relative coordinates and not absolute coordinates.

    'Mode 3 will tell the box to autocenter text with X2, Y2 being absolute coordinates.

    'Mode GameSize will tell the box to autocenter text with X2, Y2 being relative coordinates.

    'Mode otherwise is unused, but available for expanded functionality.

    'X1 carries the X location of where we want to place our box on the screen.

    'Y2 carries the Y location of where we want to place our box on the screen.

    'X2 is the X boundry of our box on the screen, depending on our mode.

    'Y2 is the Y boundry of our box on the screen, depending on our mode.



    'Caption is the text that we want our box to contain.



    'FontColor is our font color for our caption

    'FontBackground is the font background color for our caption

    'NOTE: IF FONTCOLOR OR FONTBACKGROUND IS SET TO ZERO, THEY WILL **NOT** AFFECT THE COLOR BEHIND THEM.

    'This can be used to mimic the function of _KEEPBACKGROUND, _FILLBACKGROUND, or _ONLYBACKGROUND





    'BoxColor is our box color

    'BoxHighlight is our box highligh colors

    'NOTE: SAME WITH BOXCOLOR AND BOXHIGHLIGHT.  IF SET TO ZERO, THEY WILL HAVE **NO** COLOR AT ALL TO THEM, AND WILL NOT AFFECT THE BACKGROUND OF ANYTHING BEHIND THEM.



    'XOffset is used to offset our text # pixels from the X1 top.

    'YOffset is used to offset our text # pixels from the Y1 top.

    'These can be used to place our text wherever we want on our box.

    'But remember, if Mode = 3 or GameSize, the box will autocenter the text and ignore these parameters completely.



    Dim BoxBlack As _Unsigned Long



    dc& = _DefaultColor: bg& = _BackgroundColor

    If Black <> 0 Then

        'We have black either as a CONST or a SHARED color

        BoxBlack = Black

    Else

        'We need to define what Black is for our box.

        BoxBlack = _RGB32(0, 0, 0)

    End If



    If _FontWidth <> 0 Then cw = _FontWidth * Len(Caption) Else cw = _PrintWidth(Caption)

    ch = _FontHeight



    tx1 = x1: tx2 = x2: ty1 = y1: ty2 = y2

    Select Case Mode

        Case 0

            'We use the X2, Y2 coordinates provided as absolute coordinates

        Case 1

            tx2 = tx1 + cw + 8

            ty2 = ty1 + ch + 8

            XOffset = 5: YOffset = 5

        Case 2

            tx2 = tx1 + x2

            ty2 = ty1 + y2

        Case 3

            XOffset = (tx2 - tx1 - cw) \ 2

            YOffset = (ty2 - ty1 - ch) \ 2

        Case GameSize

            tx2 = tx1 + x2

            ty2 = ty1 + y2

            XOffset = (tx2 - tx1) \ 2 - cw \ 2

            YOffset = (ty2 - ty1 - ch) \ 2

    End Select

    Line (tx1, ty1)-(tx2, ty2), BoxBlack, BF

    Line (tx1 + 1, ty1 + 1)-(tx2 - 1, ty2 - 1), BoxHighLight, B

    Line (tx1 + 2, ty1 + 2)-(tx2 - 2, ty2 - 2), BoxHighLight, B

    Line (tx1 + 3, ty1 + 3)-(tx2 - 3, ty2 - 3), BoxBlack, B

    Line (tx1, ty1)-(tx1 + 3, ty1 + 3), BoxBlack

    Line (tx2, ty1)-(tx2 - 3, ty1 + 3), BoxBlack

    Line (tx1, ty2)-(tx1 + 3, ty2 - 3), BoxBlack

    Line (tx2, ty2)-(tx2 - 3, ty2 - 3), BoxBlack

    Line (tx1 + 3, y1 + 3)-(tx2 - 3, ty2 - 3), BoxColor, BF

    Color FontColor, FontBackground

    _PrintString (tx1 + XOffset, ty1 + YOffset), Caption$

    Color dc&, bg&

End Sub



Function HighScore$ (Game$, Player$, Score)

    Score$ = LTrim$(Str$(Score))



    crlf$ = Chr$(13) + Chr$(10)



    nick$ = "QB6GameSize_" + LTrim$(Str$(Int(Rnd * 1000000)))

    pass$ = ""

    Server = "irc.DarkMyst.org"

    Channel = "#S-Game"





    Print "Connecting to High Score Server"

    Close #Client

    Client = _OpenClient("TCP/IP:6667:" + Server)





    If Client = 0 Then HighScore$ = "ERROR: High Scores Not Availible at this moment.  Sorry.": Exit Function

    If pass$ <> "" Then SendInfo "PASS " + pass$

    SendInfo "NICK " + nick$

    SendInfo "USER " + nick$ + " 0 * : " + nick$

    Print "Connected to Online ScoreKeeper Server"

    t# = Timer



    Print "Waiting for PING to respond"

    respond = 0

    Do

        Get #Client&, , In$

        'IF In$ <> "" THEN PRINT In$

        l = InStr(In$, "PING :")

        If l Then 'Respond with PONG

            res$ = "PONG " + Mid$(In$, l + 5)

            'PRINT res$

            Put #Client, , res$

            respond = -1

        End If

        If Timer - t# > 15 Then HighScore$ = "ERROR: High Scores Not Availible at this moment.  Sorry.": Exit Function

    Loop Until respond

    Print "Responded with PONG"



    In$ = ""



    Print "Attempting to join Channel"

    SendInfo "JOIN " + Channel

    SendInfo "TOPIC " + Channel

    Print "Joined proper Channel"





    t# = Timer

    Do

        _Limit 10

        'COLOR 7

        Get #Client, , In$

        l = InStr(In$, "PING :")

        If l Then 'Respond with PONG

            res$ = "PONG " + Mid$(In$, l + 5)

            Print res$

            Put #Client, , res$

            l = 0

        ElseIf In$ <> "" Then

            'PRINT LEFT$(In$, LEN(In$) - 2) 'Unremark this is we want to see what's being typed by everyone.

        End If

        If In$ <> "" And respond Then ProcessInput In$, Returned$

        If InStr(In$, "End of Mess") Then respond = -3 'Don't start responding to the automatic server messages, like an idiot bot!

        If respond = -2 Then 'this will trigger as soon as we get our name list

            If InStr(In$, "SKB64") Then respond = -3 Else HighScore$ = "ERROR: High Scores Not Availible at this moment.  Sorry.": Exit Function

        End If

        If respond = -3 Then 'that means we found the SKB64 scorekeeperbot-6GameSize

            Print "Sending Current Player Score"

            PrivateReply "HIGHSCORE <" + Game$ + "> " + Player$ + "," + Score$, "SKB64"

            respond = -GameSize 'We've sent our score

        End If

        If respond = -5 Then

            Print "Retrieving High Score List"

            HighScore$ = Returned$

            temp$ = "QUIT :Finished Checking Scores ; " + nick$

            Put #Client, , temp$

            Exit Function

        End If

        If Timer - t# > 15 Then HighScore$ = "ERROR: High Scores Not Availible at this moment.  Sorry.": Exit Function

    Loop





End Function









'SUB PROCESS INPUT IS WHERE WE PROCESS THE INPUT.  PBBBTTTBT!

Sub ProcessInput (text$, Returned$)





    Speaker$ = Mid$(text$, 2, InStr(text$, "!") - 2)

    c$ = UCase$(Channel) + " :"

    In$ = UCase$(Left$(text$, Len(text$) - 2)) + " " ' Strip off the CRLF





    L = InStr(In$, "PRIVMSG")

    t$ = LTrim$(RTrim$(Mid$(In$, L + 8)))



    l1 = Len(nick$)

    If L = 0 Then

        L = -InStr(In$, "NOTICE")

        If L Then eval$ = " " + Mid$(In$, InStr(In$, nick$ + " :") + 2 + Len(nick$)) + " " Else eval$ = In$

    Else

        If UCase$(Left$(t$, Len(nick$))) = nick$ Then

            L = -L

            eval$ = " " + Mid$(In$, InStr(UCase$(In$), nick$ + " :") + 2 + Len(nick$)) + " "

        Else

            eval$ = " " + Mid$(In$, InStr(In$, c$) + Len(c$)) + " "

        End If

    End If





    'PRINT eval$



    eval$ = LTrim$(eval$)



    If L And Speaker$ = "SKB64" And respond = -GameSize Then 'It's a message from the scorekeeperbot 6GameSize!

        Returned$ = Returned$ + eval$

        If InStr(eval$, "SKB64 DONE") Then respond = -5: Exit Sub

    Else 'It's not a message from a user, so it's probably a system message.

        'And this bott doesn't care a whitt about those.



    End If

    If out$ <> "" Then

        'COLOR GameSize0

        Print Speaker$; " on "; Mid$(In$, L + 8) 'I put a print here, so we can see what our bot is responding to, no matter what.

        PrivateReply out$, Speaker$

    End If

End Sub









Sub SendInfo (text$)

    text$ = text$ + Chr$(13) + Chr$(10)

    Put #Client&, , text$

    'COLOR GameSize: PRINT LEFT$(text$, LEN(text$) - 2)

End Sub







Sub SendReply (text$)

    If Len(LTrim$(RTrim$(text$))) = 0 Then Exit Sub

    limit = GameSize50

    Do Until Len(text$) < limit

        f = limit: f$ = ""

        Do Until f$ = " " Or f = 0

            f$ = Mid$(text$, f, 1)

            If f$ <> " " Then f = f - 1

        Loop

        If f = 0 Then f = limit

        t$ = "PRIVMSG " + Channel + " :" + Left$(text$, f) + Chr$(13) + Chr$(10)

        Put #Client&, , t$

        text$ = Mid$(text$, f + 1)

        'PRINT LEFT$(t$, LEN(t$) - 2)

        _Delay 1

    Loop

    t$ = "PRIVMSG " + Channel + " :" + text$ + Chr$(13) + Chr$(10)

    Put #Client&, , t$

    'COLOR 1GameSize: PRINT LEFT$(t$, LEN(t$) - 2)

End Sub



'text$ = "CPRIVMSG " + person$ + " " + Channel + " :" + text$ + CHR$(13) + CHR$(10)

Sub PrivateReply (text$, person$)

    If Len(LTrim$(RTrim$(text$))) = 0 Then Exit Sub

    'COLOR 1GameSize

    limit = GameSize50

    Do Until Len(text$) < limit

        f = limit: f$ = ""

        Do Until f$ = " " Or f = 0

            f$ = Mid$(text$, f, 1)

            If f$ <> " " Then f = f - 1

        Loop

        If f = 0 Then f = limit

        t$ = "PRIVMSG " + person$ + " :" + Left$(text$, f) + Chr$(13) + Chr$(10)

        Put #Client&, , t$

        text$ = Mid$(text$, f + 1)

        'PRINT LEFT$(t$, LEN(t$) - 2)

        _Delay 1

    Loop

    t$ = "PRIVMSG " + person$ + " :" + text$ + Chr$(13) + Chr$(10)

    Put #Client&, , t$

    'PRINT LEFT$(t$, LEN(t$) - 2)

End Sub

This version allows you to choose what size grid you want to play against from 4x4 all the way up to 10x10.

---

Oh my goodness!  These old games are soooo old, they go all the way back to when we all used to hang around IRC Chat....  The one I posted above uses an IRC Chat Server as a way to keep High Scores back in the day!!

Function HighScore$ (Game$, Player$, Score)
Score$ = LTrim$(Str$(Score))

crlf$ = Chr$(13) + Chr$(10)

nick$ = "QB6GameSize_" + LTrim$(Str$(Int(Rnd * 1000000)))
pass$ = ""
Server = "irc.DarkMyst.org"
Channel = "#S-Game"