+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Games (https://qb64phoenix.com/forum/forumdisplay.php?fid=57)
+---- Thread: 2048 Puzzle (/showthread.php?tid=3128)
RE: 2048 Puzzle - bplus - 10-17-2024
There he is!
@SMcNeill do remember where/when the one I posted of your came from?
It seems recent to my memory, oh let me check copy date in Windows...
Update: Oct 8, 2022 another October
RE: 2048 Puzzle - SMcNeill - 10-17-2024
I would guess it came from the original forums that Galleon had up about 10 years ago, or more. Those were back in the days when we were playing around with chat bots and such in IRC, and that's what this used to store and retrieve the highscores for people. It's oooooold. Good thing I'm not!
RE: 2048 Puzzle - Dav - 10-17-2024
bplus@: yeah, I was going to use the flash stuff for a special effect, but never really got there. For now it just marks cells that doubled so they can all grow in at the same time. Not really that important.
Hey I didn’t remember Steve made one too. Looks solid.
- Dav
RE: 2048 Puzzle - bplus - 10-18-2024
154 LOC
110 LOC
Code: (Select All)
DefLng A-Z
_Title "2048 - bplus mod Dav 2nd 2024-10-17" ' bplus 2024-10-17
'from Dav's 2048.BAS v1.01 Puzzle, OCT/2024 New for v1.01: Screen autoscales
ReDim Shared As Long Board(3, 3), Score, F
Randomize Timer
Screen _NewImage(400, 400, 32)
_ScreenMove 450, 180
_PrintMode _KeepBackground
F = _LoadFont("arial.ttf", 28): _Font F
GetNewNumber: GetNewNumber
Do
DrawBoard
If RemaingMove = 0 Then
Line (75, 100)-(325, 300), _RGBA(0, 0, 0, 40), BF
Line (75, 100)-(325, 300), _RGBA(255, 255, 255, 150), B
s$ = "No More Moves!": _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 166), s$
s$ = "Score:" + Str$(Score): _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 266), s$
_Display: Beep: _Delay 3: Exit Do
End If
Do: key$ = InKey$: _Limit 30: Loop Until key$ <> ""
If key$ = Chr$(0) + "K" Then LRArrow 1 'left arrow
If key$ = Chr$(0) + "M" Then LRArrow 2 'right arrow
If key$ = Chr$(0) + "H" Then UDArrow 1 'up arrow
If key$ = Chr$(0) + "P" Then UDArrow 2 'down arrow
'_KeyClear
GetNewNumber
Loop Until key$ = Chr$(27)
Sleep
Sub GetNewNumber
ReDim temp(15) '=== get a list of places to make a number
c = 0
For y = 0 To 3: For x = 0 To 3
If Board(x, y) = 0 Then temp(c) = x + y * 4: c = c + 1
Next: Next
If c > 0 Then '=== choose one place to make a number
i = Int(Rnd * c)
y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .8 Then Board(x1, y1) = 2 Else Board(x1, y1) = 4
DrawBoard
End If
End Sub
Sub DrawBoard
Cls , _RGB(187, 173, 160)
Color _RGB(255, 255, 255)
For x = 0 To 3: For y = 0 To 3 'do regular board next
If Board(x, y) Then power = Log(Board(x, y)) / Log(2) Else power = 0
bg& = _RGB32(255 - 17 * power)
Line (x * 100 + 3, y * 100 + 3)-((x * 100) + 100 - 3, (y * 100) + 100 - 3), bg&, BF
Line (x * 100 + 3, y * 100 + 3)-((x * 100) + 100 - 3, (y * 100) + 100 - 3), &HFFFFFFFF, B
If Board(x, y) > 0 Then
num$ = _Trim$(Str$(Board(x, y)))
offx = (100 - _PrintWidth(num$)) / 2: offy = (100 - _FontHeight(F)) / 2
Color &HFF000000
_PrintString (x * 100 + offx + 2, y * 100 + offy + 2), num$
Color &HFFFFFFFF
_PrintString (x * 100 + offx, y * 100 + offy), num$
End If
Next: Next
_Title "2048 - " + "Score: " + Str$(Score)
_Display
End Sub
Sub LRArrow (direction&)
If direction& = 1 Then pstart = 0: pstepper = 1: xs = 0: xe = 3 ' left
If direction& = 2 Then pstart = 3: pstepper = -1: xs = 3: xe = 0 ' right
For y = 0 To 3
ReDim row(3)
p = pstart
For x = xs To xe Step pstepper
If Board(x, y) <> 0 Then
If row(p) = Board(x, y) Then
row(p) = row(p) + Board(x, y): Score = Score + row(p): p = p + pstepper
ElseIf row(p) = 0 Then
row(p) = Board(x, y)
Else
p = p + pstepper: If p >= 0 And p < 4 Then row(p) = Board(x, y)
End If
End If
Next
For x = xs To xe Step pstepper: Board(x, y) = row(x): Next
Next
End Sub
Sub UDArrow (direction&)
If direction& = 1 Then pstart = 0: pstepper = 1: ys = 0: ye = 3 ' up
If direction& = 2 Then pstart = 3: pstepper = -1: ys = 3: ye = 0 ' down
For x = 0 To 3
ReDim col(3)
p = pstart
For y = ys To ye Step pstepper
If Board(x, y) <> 0 Then
If col(p) = Board(x, y) Then
col(p) = col(p) + Board(x, y): Score = Score + col(p): p = p + pstepper
ElseIf col(p) = 0 Then
col(p) = Board(x, y)
Else
p = p + pstepper: If p >= 0 And p < 4 Then col(p) = Board(x, y)
End If
End If
Next
For y = ys To ye Step pstepper: Board(x, y) = col(y): Next
Next
End Sub
Function RemaingMove
For x = 0 To 3
For y = 0 To 3
If Board(x, y) = 0 Then RemaingMove = 1
If y < 3 Then If Board(x, y) = Board(x, y + 1) Then RemaingMove = 1
If x < 3 Then If Board(x, y) = Board(x + 1, y) Then RemaingMove = 1
Next
Next
End Function
' =============================================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board to a side, like numbers will combine and double
' Score is shown in title bar. ESC quits. Objective is to get a tile at 2048 but can go further.
'==============================================================================================
' Tracking bplus mods
' 2024-10-17 Dav's original 468 tons of blank lines for easy reading removed plus all that redundant
' Flash code and stuff, reduced to last paragraph of screening the Board. Added Option _Explicit and
' Dim lines for all variables not Dim'd for Option _Explicit. Now 356 LOC!
' Next dump rounded box and TEXT subs and replace with font and Line BF
' removed ss for screen shrinkage factor just used a 400 x 400 screen
' RBox replaced with standard Line
' OK now 257 lines about even with Steves
' OK 237 with combined DoRight DoLeft
' OK 215 line combined DoUp and DoDown
' OK 192 lines with reduction in picking a new place for next number
' OK 186 lines with reduction of RemainingMove
' OK 182 more edits of comments
' OK 174 no blank lines!
' Man I am looking at all those lines for color in DrawBoard.
' OK 158 lines.
' OK 154 4 lines off RemainingMove does it still work?
' OK 148 some more lines in UDArrow and LRArrow
' OK 142 double parking where it makes sense
' OK 138 subst IF Then for Select Case
' OK 131 sub DEFLNG A-Z for Option _Explicit remov DIM's
' OK the Double Parking is getting more serious
' OK 110 enough!And Best score:
I started playing stupid when I saw 1024, half way point.
RE: 2048 Puzzle - Dav - 10-18-2024
Woah - great job, bplus! That's tight.
I haven't reached 2048 yet with mine.
- Dav
RE: 2048 Puzzle - bplus - 10-18-2024
Finally < 100 at 97 LOC added rules for Parking
Code: (Select All)
_Title "2048 - bplus mod Dav 2nd 2024-10-17" ' bplus 2024-10-17
'from Dav's 2048.BAS v1.01 Puzzle, OCT/2024 New for v1.01: Screen autoscales
DefLng A-Z: Randomize Timer
ReDim Shared Board(3, 3), Score, F
Screen _NewImage(400, 400, 32): _ScreenMove 450, 180
_PrintMode _KeepBackground: F = _LoadFont("arial.ttf", 28): _Font F
GetNewNumber: GetNewNumber
Do
DrawBoard
If RemaingMove = 0 Then
Line (75, 100)-(325, 300), _RGBA(0, 0, 0, 40), BF
Line (75, 100)-(325, 300), _RGBA(255, 255, 255, 150), B
s$ = "No More Moves!": _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 166), s$
s$ = "Score:" + Str$(Score): _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 266), s$
_Display: Beep: _Delay 3: Exit Do
End If
Do: key$ = InKey$: _Limit 30: Loop Until key$ <> ""
If key$ = Chr$(0) + "K" Then LRArrow 1 'left arrow
If key$ = Chr$(0) + "M" Then LRArrow 2 'right arrow
If key$ = Chr$(0) + "H" Then UDArrow 1 'up arrow
If key$ = Chr$(0) + "P" Then UDArrow 2 'down arrow
GetNewNumber
Loop Until key$ = Chr$(27)
Sleep
Sub GetNewNumber
ReDim temp(15) '=== get a list of places to make a number
For y = 0 To 3: For x = 0 To 3
If Board(x, y) = 0 Then temp(c) = x + y * 4: c = c + 1
Next: Next
If c > 0 Then '=== choose one place to make a number
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .8 Then Board(x1, y1) = 2 Else Board(x1, y1) = 4
DrawBoard
End If
End Sub
Sub DrawBoard
Cls , _RGB(100, 100, 250): Color _RGB(255, 255, 255)
For x = 0 To 3: For y = 0 To 3 'do regular board next
If Board(x, y) Then power = Log(Board(x, y)) / Log(2) Else power = 0
bg& = _RGB32(255 - 17 * power)
Line (x * 100 + 3, y * 100 + 3)-((x * 100) + 100 - 3, (y * 100) + 100 - 3), bg&, BF
Line (x * 100 + 3, y * 100 + 3)-((x * 100) + 100 - 3, (y * 100) + 100 - 3), &HFFFFFFFF, B
If Board(x, y) > 0 Then
n$ = _Trim$(Str$(Board(x, y))): ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight(F)) / 2
Color &HFF000000: _PrintString (x * 100 + ox + 2, y * 100 + oy + 2), n$
Color &HFFFFFFFF: _PrintString (x * 100 + ox, y * 100 + oy), n$
End If
Next: Next
_Title "2048 - " + "Score: " + Str$(Score): _Display
End Sub
Sub LRArrow (direction&)
If direction& = 1 Then pstart = 0: pstepper = 1: xs = 0: xe = 3 ' left
If direction& = 2 Then pstart = 3: pstepper = -1: xs = 3: xe = 0 ' right
For y = 0 To 3
ReDim row(3)
p = pstart
For x = xs To xe Step pstepper
If Board(x, y) <> 0 Then
If row(p) = Board(x, y) Then
row(p) = row(p) + Board(x, y): Score = Score + row(p): p = p + pstepper
ElseIf row(p) = 0 Then
row(p) = Board(x, y)
Else
p = p + pstepper: If p >= 0 And p < 4 Then row(p) = Board(x, y)
End If
End If
Next
For x = xs To xe Step pstepper: Board(x, y) = row(x): Next
Next
End Sub
Sub UDArrow (direction&)
If direction& = 1 Then pstart = 0: pstepper = 1: ys = 0: ye = 3 ' up
If direction& = 2 Then pstart = 3: pstepper = -1: ys = 3: ye = 0 ' down
For x = 0 To 3
ReDim col(3)
p = pstart
For y = ys To ye Step pstepper
If Board(x, y) <> 0 Then
If col(p) = Board(x, y) Then
col(p) = col(p) + Board(x, y): Score = Score + col(p): p = p + pstepper
ElseIf col(p) = 0 Then
col(p) = Board(x, y)
Else
p = p + pstepper: If p >= 0 And p < 4 Then col(p) = Board(x, y)
End If
End If
Next
For y = ys To ye Step pstepper: Board(x, y) = col(y): Next
Next
End Sub
Function RemaingMove
For x = 0 To 3: For y = 0 To 3
If Board(x, y) = 0 Then RemaingMove = 1
If y < 3 Then If Board(x, y) = Board(x, y + 1) Then RemaingMove = 1
If x < 3 Then If Board(x, y) = Board(x + 1, y) Then RemaingMove = 1
Next: Next
End Function
' =============================================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board to a side, like numbers will combine and double
' Score is shown in title bar. ESC quits. Objective is to get a tile at 2048 but can go further.
'==============================================================================================
' Tracking bplus mods
' 2024-10-17 Dav's original 468 tons of blank lines for easy reading removed plus all that redundant
' Flash code and stuff, reduced to last paragraph of screening the Board. Added Option _Explicit and
' Dim lines for all variables not Dim'd for Option _Explicit. Now 356 LOC!
' Next dump rounded box and TEXT subs and replace with font and Line BF
' removed ss for screen shrinkage factor just used a 400 x 400 screen
' RBox replaced with standard Line
' OK now 257 lines about even with Steves
' OK 237 with combined DoRight DoLeft
' OK 215 line combined DoUp and DoDown
' OK 192 lines with reduction in picking a new place for next number
' OK 186 lines with reduction of RemainingMove
' OK 182 more edits of comments
' OK 174 no blank lines!
' Man I am looking at all those lines for color in DrawBoard.
' OK 158 lines.
' OK 154 4 lines off RemainingMove does it still work?
' OK 148 some more lines in UDArrow and LRArrow
' OK 142 double parking where it makes sense
' OK 138 subst IF Then for Select Case
' OK 131 sub DEFLNG A-Z for Option _Explicit remov DIM's
' OK the Double Parking is getting more serious
' OK 110 enough! 10/17/2024
' OK last night right after I posted 110, I immediately saw 2 obvious lines to take out
' WTH! in for a penny in for a 100, more judicious double/triple parking
' Rules for double/triple/more statements on one line by way of colon:
' For sure multiple assignments can go on one line specially if all are related.
' Doubling up on For loops for 2D array For y = 0 to ny : For x = 0 to nx ... Next: Next
' Line 3 saved on Option _Explicit and combined with Random, I don't recommend starting
' without Option _Explicit because it comes in handy when name changes come. It should be
' a last step in reducing LOC.
' Avoid _code line extensions if at all possible, all lines < 100 chars nice too.
' OK 97 LOC < 100 10/18/2024New High Score with new look at Blue and Grey Theme:
RE: 2048 Puzzle - bplus - 10-18-2024
This might be final version of my 2048 game. I changed some more lines and commented everything!
@Dav when I was doing comments where you were using row and row() I want to use col and col() and vice versa.
Please check comments for the code that handles the Arrow keypresses and see if it makes sense the way I have used row and col.
Code: (Select All)
_Title "2048 - bplus mod Dav 2nd 2024-10-17" ' bplus 2024-10-17 instructions and code updates below
DefLng A-Z: Randomize Timer ' == Basic Setup: Default Type and Random starts ==
ReDim Shared Board(3, 3), Score, F ' == Globals Game Board, Score, Font ==
Screen _NewImage(400, 400, 32): _ScreenMove 450, 180 ' == Screen Stuff ==
_PrintMode _KeepBackground: F = _LoadFont("arial.ttf", 28): _Font F ' == Print stuff ==
AddNewCell: AddNewCell ' = Add 2 random cells to Board for starters ==
Do
DrawBoard
If RemaingMove = 0 Then ' == Game is over if Board is filled AND 0 combines possible. ==
Line (75, 100)-(325, 300), _RGBA(0, 0, 0, 40), BF ' == Game Over message box with accent ==
Line (75, 100)-(325, 300), _RGBA(255, 255, 255, 150), B
s$ = "No More Moves!": _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 166), s$
s$ = "Score:" + Str$(Score): _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 266), s$
_Display: Beep: Exit Do ' == Sleep after Do loop holds screen in final state. ==
End If
Do: key$ = InKey$: _Limit 30: Loop Until key$ <> "" ' == wait for arrow keypress then handle it
If key$ = Chr$(0) + "K" Then LRArrow 1 ' Left arrow
If key$ = Chr$(0) + "M" Then LRArrow 2 ' Right arrow
If key$ = Chr$(0) + "H" Then UDArrow 1 ' Up arrow
If key$ = Chr$(0) + "P" Then UDArrow 2 ' Down arrow
AddNewCell
Loop Until key$ = Chr$(27) ' == Escape quits before running out of moves ==
Sleep ' == Hold screen at final state until user presses a key ==
Sub AddNewCell ' == Insert new cell onto board in random unused blank ==
ReDim temp(15) ' == Get a list of places to make a number ==
For y = 0 To 3: For x = 0 To 3
If Board(x, y) = 0 Then temp(c) = x + y * 4: c = c + 1
Next: Next
If c > 0 Then ' == choose one place to make a number, convert index to row =y1, col =x1 ==
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .8 Then Board(x1, y1) = 2 Else Board(x1, y1) = 4 ' way more 2's, 80% than 4's, 20%
End If
End Sub
Sub DrawBoard ' == Update the Board State on screen ==
Cls , _RGB(100, 100, 250): Color _RGB(255, 255, 255)
For x = 0 To 3: For y = 0 To 3 ' == draw board, find power of 2 that each Board(x,y) is ==
If Board(x, y) Then power = Log(Board(x, y)) / Log(2) Else power = 0
bg& = _RGB32(255 - 17 * power) ' =set to shade of grey, the higher the value the darker
Line (x * 100 + 3, y * 100 + 3)-Step(100 - 3, 100 - 3), bg&, BF
Line (x * 100 + 3, y * 100 + 3)-Step(100 - 3, 0 - 3), &HFFFFFFFF, B
If Board(x, y) > 0 Then ' == label cells that aren't blank ==
n$ = _Trim$(Str$(Board(x, y))) ' == find offsets for centering in cell ==
ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight(F)) / 2
Color &HFF000000: _PrintString (x * 100 + ox + 2, y * 100 + oy + 2), n$
Color &HFFFFFFFF: _PrintString (x * 100 + ox, y * 100 + oy), n$
End If
Next: Next
_Title "2048 - " + "Score: " + Str$(Score): _Display
End Sub
Sub LRArrow (direction&) ' == Update Board according to Left or Right arrow press ==
If direction& = 1 Then pstart = 0: pstepper = 1: xs = 0: xe = 3 ' == Left Arrow ==
If direction& = 2 Then pstart = 3: pstepper = -1: xs = 3: xe = 0 ' == Right Arrow ==
For y = 0 To 3 ' == outer loop down Board array ==
ReDim col(3): p = pstart ' == setup ==
For x = xs To xe Step pstepper ' == inner loop across ==
If Board(x, y) <> 0 Then ' == if value then update column x ==
If col(p) = Board(x, y) Then ' == have matching values score! and combine ==
col(p) = col(p) + Board(x, y): Score = Score + col(p): p = p + pstepper
ElseIf col(p) = 0 Then ' == move col value if blanks between ==
col(p) = Board(x, y)
Else ' == col(p) had a value skip to next slot and update ==
p = p + pstepper: If p >= 0 And p < 4 Then col(p) = Board(x, y)
End If
End If
Next
For x = xs To xe Step pstepper: Board(x, y) = col(x): Next ' = update with combined or moved
Next
End Sub
Sub UDArrow (direction&) ' == Update Board according to Up or Down arrow press ==
If direction& = 1 Then pstart = 0: pstepper = 1: ys = 0: ye = 3 ' == Up Arrow ==
If direction& = 2 Then pstart = 3: pstepper = -1: ys = 3: ye = 0 ' == Down Arrow ==
For x = 0 To 3 ' == outer loop across Board array ==
ReDim row(3): p = pstart ' == setup ==
For y = ys To ye Step pstepper ' == inner loop up/down Board array ==
If Board(x, y) <> 0 Then ' == if value then update row y ==
If row(p) = Board(x, y) Then ' == have matching values score! and combine ==
row(p) = row(p) + Board(x, y): Score = Score + row(p): p = p + pstepper
ElseIf row(p) = 0 Then ' == move row value if blanks between ==
row(p) = Board(x, y)
Else ' == rowl(p) had a value skip to next slot and update ==
p = p + pstepper: If p >= 0 And p < 4 Then row(p) = Board(x, y)
End If
End If
Next
For y = ys To ye Step pstepper: Board(x, y) = row(y): Next
Next
End Sub
Function RemaingMove ' == Can player still make a move? ==
For x = 0 To 3: For y = 0 To 3 ' == Look for empty space or combine move ==
If Board(x, y) = 0 Then RemaingMove = 1 ' == yes a move is left ==
If y < 3 Then If Board(x, y) = Board(x, y + 1) Then RemaingMove = 1 ' yes move left ==
If x < 3 Then If Board(x, y) = Board(x + 1, y) Then RemaingMove = 1 ' yes move left ==
Next: Next
End Function
' =============================================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board to a side, like numbers will combine and double
' Score is shown in title bar. ESC quits. Objective is to get a tile at 2048 but can go further.
'==============================================================================================
' Tracking bplus mods
' From Dav's 2048.BAS v1.01 Puzzle, OCT/2024 New for v1.01: Screen autoscales
' 2024-10-17 Dav's original 468 tons of blank lines for easy reading removed plus all that redundant
' Flash code and stuff, reduced to last paragraph of screening the Board. Added Option _Explicit and
' Dim lines for all variables not Dim'd for Option _Explicit. Now 356 LOC!
' Next dump rounded box and TEXT subs and replace with font and Line BF
' removed ss for screen shrinkage factor just used a 400 x 400 screen
' RBox replaced with standard Line
' OK now 257 lines about even with Steves
' OK 237 with combined DoRight DoLeft
' OK 215 line combined DoUp and DoDown
' OK 192 lines with reduction in picking a new place for next number
' OK 186 lines with reduction of RemainingMove
' OK 182 more edits of comments
' OK 174 no blank lines!
' Man I am looking at all those lines for color in DrawBoard.
' OK 158 lines.
' OK 154 4 lines off RemainingMove does it still work?
' OK 148 some more lines in UDArrow and LRArrow
' OK 142 double parking where it makes sense
' OK 138 subst IF Then for Select Case
' OK 131 sub DEFLNG A-Z for Option _Explicit remov DIM's
' OK the Double Parking is getting more serious
' OK 110 enough! 10/17/2024
' OK last night right after I posted 110, I immediately saw 2 obvious lines to take out
' WTH! in for a penny in for a 100, more judicious double/triple parking
' Rules for double/triple/more statements on one line by way of colon, I call Double Parking:
' + Premise: Avoid _code line extensions if at all possible, all lines < 100 chars nice too.
' + For sure, multiple assignments can go on one line specially if all are related.
' - When it comes to documenting varaibles DO NOT Double Park, following Terry's descriptive method.
' + For sure, multiple short Sub calls specially if all are related.
' + Doubling up on For loops specially for 2D array For y = 0 to ny : For x = 0 to nx ... Next: Next
' + Line 3 saved on Option _Explicit and combined with Random. I don't recommend starting
' without Option _Explicit because it comes in handy when name changes come ie to shorten
' names so everything fits in 100 chars across line. It should be a last step in reducing LOC.
' OK 97 LOC < 100 10/18/2024 am post
' OK 95 cut 2 but had to add one because line was too long for mult-assignments
' When adding comments I had to change Dav' temp Row() and Col() words. He or I had/have them
' reversed.
' 2024-10-19 94 LOC DrawBoard NOT needed in AddCellEDIT: ' 2024-10-19 94 LOC DrawBoard NOT needed in AddCell
RE: 2048 Puzzle - Dav - 10-20-2024
Hi bplus, looks fine to me. You sure did an expert job shrinking it down!
- Dan
RE: 2048 Puzzle - bplus - 10-20-2024
Thanks for checking @Dav
And the shrinkage continues!
I switched to a 1D array Board and then was able to combine all the arrow key handling in one Sub.
So now down to 75 LOC
Code: (Select All)
_Title "2048 - 1D Board" ' bplus 2024-10-20 == instructions and code updates below ==
DefLng A-Z: Randomize Timer ' == Basic Setup: Default Type and Random starts ==
ReDim Shared B(15), Score, F ' == Globals Game Board, Score, Font ==
Screen _NewImage(400, 400, 32): _ScreenMove 450, 180 ' == Screen Stuff ==
_PrintMode _KeepBackground: F = _LoadFont("arial.ttf", 28): _Font F ' == Print stuff ==
AddNewCell: AddNewCell ' = Add 2 random cells to Board for starters ==
Do
DrawBoard
If RemaingMove = 0 Then ' == Game is over if Board is filled AND 0 combines possible. ==
Line (75, 100)-(325, 300), _RGBA(0, 0, 0, 40), BF ' == Game Over message box with accent ==
Line (75, 100)-(325, 300), _RGBA(255, 255, 255, 150), B
s$ = "No More Moves!": _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 166), s$
s$ = "Score:" + Str$(Score): _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 266), s$
_Display: Beep: Exit Do ' == Sleep after Do loop holds screen in final state. ==
End If
Do: key$ = InKey$: _Limit 30: Loop Until key$ <> "" ' == wait for arrow keypress then handle it
Arrow key$: AddNewCell
Loop Until key$ = Chr$(27) ' == Escape quits before running out of moves ==
Sleep ' == Hold screen at final state until user presses a key ==
Sub Arrow (k$) ' == Handle the arrow keys to update game play ==
Dim j, jm, k, ks, ke, kstep, km, p, t(15)
If k$ = Chr$(0) + "K" Then jm = 4: ks = 0: ke = 3: kstep = 1: km = 1 ' == Left arrow ==
If k$ = Chr$(0) + "M" Then jm = 4: ks = 3: ke = 0: kstep = -1: km = 1 ' == Right arrow ==
If k$ = Chr$(0) + "H" Then jm = 1: ks = 0: ke = 3: kstep = 1: km = 4 ' == Up arrow ==
If k$ = Chr$(0) + "P" Then jm = 1: ks = 3: ke = 0: kstep = -1: km = 4 ' == Down arrow ==
If jm = 0 Then Exit Sub
For j = 0 To 3 ' == outer loop is always same numbers but could be for x or y ==
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 ' == inner loop, main processing ==
If B(j * jm + k * km) <> 0 Then ' only handle cells with a value
If t(p) = B(j * jm + k * km) Then ' == ah a matching tile! combine & update score =
t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p): p = p + kstep * km
ElseIf t(p) = 0 Then ' == move board value into next open slot ==
t(p) = B(j * jm + k * km)
Else ' == move board value into next open slot ==
p = p + kstep * km: t(p) = B(j * jm + k * km)
End If
End If
Next
Next
For j = 0 To 15: B(j) = t(j): Next ' == Copy t() into B() array ==
End Sub
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 ' == save index of empty cells for random pick ==
If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
Next: Next
If c > 0 Then ' == choose one place to make a number, convert index to row =y1, col =x1 ==
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4 ' == pick and convert index ==
If Rnd < .8 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4 ' = more 2's, 80% than 4's, 20%
End If
End Sub
Sub DrawBoard ' == Update the Board State on screen ==
Cls , _RGB(100, 100, 250): Color _RGB(255, 255, 255)
For x = 0 To 3: For y = 0 To 3 ' == draw board, find power of 2 that each Board(x,y) is ==
If B(x + 4 * y) Then power = Log(B(x + 4 * y)) / Log(2) Else power = 0
bg& = _RGB32(255 - 17 * power) ' =set to shade of grey, the higher the value the darker
Line (x * 100 + 3, y * 100 + 3)-Step(100 - 3, 100 - 3), bg&, BF
Line (x * 100 + 3, y * 100 + 3)-Step(100 - 3, 0 - 3), &HFFFFFFFF, B
If B(x + 4 * y) > 0 Then ' == label cells that aren't blank ==
n$ = _Trim$(Str$(B(x + 4 * y))) ' == find offsets for centering in cell ==
ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight(F)) / 2
Color &HFF000000: _PrintString (x * 100 + ox + 2, y * 100 + oy + 2), n$
Color &HFFFFFFFF: _PrintString (x * 100 + ox, y * 100 + oy), n$
End If
Next: Next
_Title "2048 - " + "Score: " + Str$(Score): _Display
End Sub
Function RemaingMove ' == Can player still make a move? ==
For y = 0 To 3: For x = 0 To 3 ' == Look for empty space or combine move ==
If B(y * 4 + x) = 0 Then RemaingMove = 1 ' == yes a move is left ==
If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then RemaingMove = 1 ' move left ==
If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then RemaingMove = 1 ' move left ==
Next: Next
End Function
' =============================================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board to a side, like numbers will combine and double
' Score is shown in title bar. ESC quits. Objective is to get a tile at 2048 but can go further.
'==============================================================================================
' Tracking bplus mods
' From Dav's 2048.BAS v1.01 Puzzle, OCT/2024 New for v1.01: Screen autoscales
' 2024-10-17 Dav's original 468 tons of blank lines for easy reading removed plus all that redundant
' Flash code and stuff, reduced to last paragraph of screening the Board. Added Option _Explicit and
' Dim lines for all variables not Dim'd for Option _Explicit. Now 356 LOC!
' Next dump rounded box and TEXT subs and replace with font and Line BF
' removed ss for screen shrinkage factor just used a 400 x 400 screen
' RBox replaced with standard Line
' OK now 257 lines about even with Steves
' OK 237 with combined DoRight DoLeft
' OK 215 line combined DoUp and DoDown
' OK 192 lines with reduction in picking a new place for next number
' OK 186 lines with reduction of RemainingMove
' OK 182 more edits of comments
' OK 174 no blank lines!
' Man I am looking at all those lines for color in DrawBoard.
' OK 158 lines.
' OK 154 4 lines off RemainingMove does it still work?
' OK 148 some more lines in UDArrow and LRArrow
' OK 142 double parking where it makes sense
' OK 138 subst IF Then for Select Case
' OK 131 sub DEFLNG A-Z for Option _Explicit remov DIM's
' OK the Double Parking is getting more serious
' OK 110 enough! 10/17/2024
' OK last night right after I posted 110, I immediately saw 2 obvious lines to take out
' WTH! in for a penny in for a 100, more judicious double/triple parking
' Rules for double/triple/more statements on one line by way of colon, I call Double Parking:
' + Premise: Avoid _code line extensions if at all possible, all lines < 100 chars nice too.
' + For sure, multiple assignments can go on one line specially if all are related.
' - When it comes to documenting varaibles DO NOT Double Park, following Terry's descriptive method.
' + For sure, multiple short Sub calls specially if all are related.
' + Doubling up on For loops specially for 2D array For y = 0 to ny : For x = 0 to nx ... Next: Next
' + Line 3 saved on Option _Explicit and combined with Random. I don't recommend starting
' without Option _Explicit because it comes in handy when name changes come ie to shorten
' names so everything fits in 100 chars across line. It should be a last step in reducing LOC.
' OK 97 LOC < 100 10/18/2024 am post
' OK 95 cut 2 but had to add one because line was too long for mult-assignments
' When adding comments I had to change Dav' temp Row() and Col() words. He or I had/have them
' reversed.
' 2024-10-19 94 LOC DrawBoard NOT needed in AddCell and main both I chose in Main only.
' ============================================================================
' 2024-10-20 2048 - 1D Board combine all arrow handling subs into one, save LOC!
' OK 75 LOCRE: 2048 Puzzle - bplus - 10-21-2024
2048 - 64 LOC, how appropriate!
Code: (Select All)
_Title "2048 - 64 LOC" ' bplus 2024-10-21 == instructions and code updates below ==
DefLng A-Z: Randomize Timer ' == Basic Setup: Default Type and Random starts ==
ReDim Shared B(15), Score, F ' == Globals Game Board, Score, Font ==
Screen _NewImage(400, 400, 32): _ScreenMove 450, 180 ' == Screen Stuff ==
_PrintMode _KeepBackground: F = _LoadFont("arial.ttf", 28): _Font F ' == Print stuff ==
AddNewCell: AddNewCell ' = Add 2 random cells to Board for starters ==
Do
5 Cls , _RGB(100, 100, 250): Color _RGB(255, 255, 255) ' == DrawBoard ==
For x = 0 To 3: For y = 0 To 3 ' == find power of 2 that each Board(x,y) is for bg& in tiles ==
If B(x + 4 * y) Then power = Log(B(x + 4 * y)) / Log(2) Else power = 0
bg& = _RGB32(255 - 17 * power) ' == set shade grey, the higher the value the darker ==
Line (x * 100 + 3, y * 100 + 3)-Step(100 - 3, 100 - 3), bg&, BF ' == draw tile ==
Line (x * 100 + 3, y * 100 + 3)-Step(100 - 3, 0 - 3), &HFFFFFFFF, B ' == accent tile ==
If B(x + 4 * y) > 0 Then ' == label cells that aren't blank ==
n$ = _Trim$(Str$(B(x + 4 * y))) ' == find offsets for centering in cell ==
ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight(F)) / 2
Color &HFF000000: _PrintString (x * 100 + ox + 2, y * 100 + oy + 2), n$ ' shade ==
Color &HFFFFFFFF: _PrintString (x * 100 + ox, y * 100 + oy), n$ ' =& print value ==
End If
Next: Next
_Title "2048 - " + "Score: " + Str$(Score): _Display ' == let player know the score ==
For y = 0 To 3: For x = 0 To 3 ' == Look for empty space or combine move ==
If B(y * 4 + x) = 0 Then 10 ' == yes a move is left, skip to 10 ==
If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then 10 ' == a move left goto 10 ==
If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then 10 ' == a move left goto 10 ==
Next: Next
Line (75, 100)-(325, 300), _RGBA(0, 0, 0, 40), BF ' = OH NO! Game Over message box break the ==
s$ = "No More Moves!": _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 166), s$ ' == bad ==
s$ = "Score:" + Str$(Score): _PrintString (75 + (250 - _PrintWidth(s$)) / 2, 266), s$ ' news ==
_Display: Beep: Exit Do ' == Sleep after Do loop holds screen in final state. ==
10 Do: k$ = InKey$: _Limit 30: Loop Until k$ <> "" ' == wait for key ==
ReDim t(15): jm = 0 ' == start temp board array t() and make sure only arrow keys processed ==
If k$ = Chr$(0) + "K" Then jm = 4: ks = 0: ke = 3: kstep = 1: km = 1 ' == Left arrow ==
If k$ = Chr$(0) + "M" Then jm = 4: ks = 3: ke = 0: kstep = -1: km = 1 ' == Right arrow ==
If k$ = Chr$(0) + "H" Then jm = 1: ks = 0: ke = 3: kstep = 1: km = 4 ' == Up arrow ==
If k$ = Chr$(0) + "P" Then jm = 1: ks = 3: ke = 0: kstep = -1: km = 4 ' == Down arrow ==
If jm = 0 Then 5 ' == back to the drawing board ! ==
For j = 0 To 3 ' == outer loop is always same numbers but could be for x or y ==
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 ' == inner loop, main processing ==
If B(j * jm + k * km) <> 0 Then ' only handle cells with a value
If t(p) = B(j * jm + k * km) Then ' == ah a matching tile! combine & update score =
t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p): p = p + kstep * km
ElseIf t(p) = 0 Then ' == move board value into next open slot ==
t(p) = B(j * jm + k * km)
Else ' == move board value into next open slot ==
p = p + kstep * km: t(p) = B(j * jm + k * km) ' == and update next p slot ==
End If
End If
Next
Next
For j = 0 To 15: B(j) = t(j): Next: AddNewCell ' == Copy t() into B() array & Add cell ==
Loop Until _KeyDown(27) ' == Escape quits before running out of moves ==
Sleep ' == Hold screen at final state until user presses a key ==
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 ' == save index of empty cells for random pick ==
If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
Next: Next
If c > 0 Then ' == choose one place to make a number, convert index to row =y1, col =x1 ==
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4 ' == pick and convert index ==
If Rnd < .8 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4 ' = more 2's, 80% than 4's, 20%
End If
End Sub
' =============================================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board to a side, like numbers will combine and double
' Score is shown in title bar. ESC quits. Objective is to get a tile at 2048 but can go further.
'==============================================================================================
' Tracking bplus mods
' From Dav's 2048.BAS v1.01 Puzzle, OCT/2024 New for v1.01: Screen autoscales
' 2024-10-17 Dav's original 468 tons of blank lines for easy reading removed plus all that redundant
' Flash code and stuff, reduced to last paragraph of screening the Board. Added Option _Explicit and
' Dim lines for all variables not Dim'd for Option _Explicit. Now 356 LOC!
' Next dump rounded box and TEXT subs and replace with font and Line BF
' removed ss for screen shrinkage factor just used a 400 x 400 screen
' RBox replaced with standard Line
' OK now 257 lines about even with Steves
' OK 237 with combined DoRight DoLeft
' OK 215 line combined DoUp and DoDown
' OK 192 lines with reduction in picking a new place for next number
' OK 186 lines with reduction of RemainingMove
' OK 182 more edits of comments
' OK 174 no blank lines!
' Man I am looking at all those lines for color in DrawBoard.
' OK 158 lines.
' OK 154 4 lines off RemainingMove does it still work?
' OK 148 some more lines in UDArrow and LRArrow
' OK 142 double parking where it makes sense
' OK 138 subst IF Then for Select Case
' OK 131 sub DEFLNG A-Z for Option _Explicit remov DIM's
' OK the Double Parking is getting more serious
' OK 110 enough! 10/17/2024
' OK last night right after I posted 110, I immediately saw 2 obvious lines to take out
' WTH! in for a penny in for a 100, more judicious double/triple parking
' Rules for double/triple/more statements on one line by way of colon, I call Double Parking:
' + Premise: Avoid _code line extensions if at all possible, all lines < 100 chars nice too.
' + For sure, multiple assignments can go on one line specially if all are related.
' - When it comes to documenting varaibles DO NOT Double Park, following Terry's descriptive method.
' + For sure, multiple short Sub calls specially if all are related.
' + Doubling up on For loops specially for 2D array For y = 0 to ny : For x = 0 to nx ... Next: Next
' + Line 3 saved on Option _Explicit and combined with Random. I don't recommend starting
' without Option _Explicit because it comes in handy when name changes come ie to shorten
' names so everything fits in 100 chars across line. It should be a last step in reducing LOC.
' OK 97 LOC < 100 10/18/2024 am post
' OK 95 cut 2 but had to add one because line was too long for mult-assignments
' When adding comments I had to change Dav' temp Row() and Col() words. He or I had/have them
' reversed.
' 2024-10-19 94 LOC DrawBoard NOT needed in AddCell and main both I chose in main only.
' ============================================================================
' 2024-10-20 2048 - 1D Board combine all arrow handling subs into one, save LOC!
' OK 75 LOC
' 2024-10-21 2048 - 64 LOC
' subs and a function reinserted back into Main