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