Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
2048 Puzzle
#9
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 Wink I know he can do better on this one because I think I can Big Grin

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?
b = b + ...
Reply


Messages In This Thread
2048 Puzzle - by Dav - 10-17-2024, 02:19 AM
RE: 2048 Puzzle - by FellippeHeitor - 10-17-2024, 02:42 AM
RE: 2048 Puzzle - by Dav - 10-17-2024, 02:48 AM
RE: 2048 Puzzle - by FellippeHeitor - 10-17-2024, 03:17 AM
RE: 2048 Puzzle - by bplus - 10-17-2024, 09:16 AM
RE: 2048 Puzzle - by Dav - 10-17-2024, 01:01 PM
RE: 2048 Puzzle - by bplus - 10-17-2024, 03:36 PM
RE: 2048 Puzzle - by Dav - 10-17-2024, 04:19 PM
RE: 2048 Puzzle - by bplus - 10-17-2024, 04:26 PM
RE: 2048 Puzzle - by SMcNeill - 10-17-2024, 05:05 PM
RE: 2048 Puzzle - by bplus - 10-17-2024, 05:15 PM
RE: 2048 Puzzle - by SMcNeill - 10-17-2024, 05:28 PM
RE: 2048 Puzzle - by Dav - 10-17-2024, 10:46 PM
RE: 2048 Puzzle - by bplus - 10-18-2024, 12:48 AM
RE: 2048 Puzzle - by Dav - 10-18-2024, 11:49 AM
RE: 2048 Puzzle - by bplus - 10-18-2024, 01:51 PM
RE: 2048 Puzzle - by bplus - 10-18-2024, 09:59 PM
RE: 2048 Puzzle - by Dav - 10-20-2024, 10:44 PM
RE: 2048 Puzzle - by bplus - 10-20-2024, 11:32 PM
RE: 2048 Puzzle - by bplus - 10-21-2024, 09:18 AM
RE: 2048 Puzzle - by SMcNeill - 10-21-2024, 10:19 AM
RE: 2048 Puzzle - by bplus - 10-22-2024, 11:37 AM
RE: 2048 Puzzle - by SMcNeill - 10-22-2024, 02:27 PM
RE: 2048 Puzzle - by SMcNeill - 10-22-2024, 02:39 PM
RE: 2048 Puzzle - by bplus - 10-22-2024, 03:26 PM
RE: 2048 Puzzle - by SMcNeill - 10-22-2024, 03:49 PM
RE: 2048 Puzzle - by SMcNeill - 10-22-2024, 03:36 PM
RE: 2048 Puzzle - by bplus - 10-22-2024, 03:38 PM
RE: 2048 Puzzle - by bplus - 10-22-2024, 04:37 PM
RE: 2048 Puzzle - by SMcNeill - 10-22-2024, 08:18 PM
RE: 2048 Puzzle - by bplus - 10-22-2024, 04:47 PM
RE: 2048 Puzzle - by SMcNeill - 10-23-2024, 03:44 AM
RE: 2048 Puzzle - by bplus - 10-23-2024, 10:32 AM
RE: 2048 Puzzle - by bplus - 10-23-2024, 12:40 PM
RE: 2048 Puzzle - by SMcNeill - 10-23-2024, 01:51 PM
RE: 2048 Puzzle - by bplus - 10-23-2024, 05:00 PM
RE: 2048 Puzzle - by bplus - 10-24-2024, 06:42 PM
RE: 2048 Puzzle - by Dav - 10-25-2024, 07:32 PM
RE: 2048 Puzzle - by bplus - 10-26-2024, 12:34 PM
RE: 2048 Puzzle - by Dav - 10-26-2024, 01:21 PM
RE: 2048 Puzzle - by bplus - 10-26-2024, 01:33 PM
RE: 2048 Puzzle - by bplus - 10-27-2024, 01:39 AM
RE: 2048 Puzzle - by bplus - 10-27-2024, 10:08 AM



Users browsing this thread: 14 Guest(s)