Posts: 2,696
Threads: 327
Joined: Apr 2022
Reputation:
217
(10-22-2024, 04:37 PM)bplus Wrote: That is one line of code for which I'd gladly exchange the 3 easier to understand lines from which it came.
I wouldn't take it even if I was at 66 lines and was trying to get to 64.
But now you're changing the rules of the exercise. Which do you want -- Readable Code, or least Lines Of Code? Those two things are usually mutually exclusive. Same for efficiency -- do you want the most efficient program, or the shortest program? Smallest executable? Least memory usage? Fastest processing?
Usually, people would focus on "I want readable code that works", without much concern over the other things. But once you zoom in on "I want the least amount of lines of code for this program, as possible, so that it still works," you change the style completely.
If we're going for readability, then I'd go for the following for those lines:
Code: (Select All) If y < 3 _ANDALSO B(y * 4 + x) = B((y + 1) * 4 + x) Then 10 ' == a move left goto 10 ==
If x < 3 _ANDALSO B(y * 4 + x) = B(y * 4 + (x + 1)) Then 10
IF THEN IF just doesn't seem like that readable or efficient of a set of code to me. A single line IF THEN seems better, and there's no one who should ever obect to it and say something like, "It's just cramming multiple IF statements on one line to reduce line count!"
It's a valid code restructure which reduces lines of code. We go from what is basically multiple line statements packed together:
If y < 3 Then
If B(y * 4 + x) = B((y + 1) * 4 + x) Then
Goto 10 ' == a move left goto 10 ==
End If
End If
To a single line statement:
If y < 3 _ANDALSO B(y * 4 + x) = B((y + 1) * 4 + x) Then
Goto 10 ' == a move left goto 10 ==
End If
But, for pure reduction of lines of code?
One single line, which combines all that logic together, such as what I posted above, is what you want.
It honestly just sounds like the goalpost has shifted and the game has changed in the middle of playing it. No longer is it an exercise to reduce the code down to the smallest number of lines of code. It's now about having it look pretty, fit on a screen of no more than 100 characters in width, making it readable, and then reducing the line count down until it's a cutely acceptable number like 64. 
Posts: 2,696
Threads: 327
Joined: Apr 2022
Reputation:
217
Cleaned up the code from #9 that you'd posted earlier. ( https://qb64phoenix.com/forum/showthread...&pid=29236 )
Have it down to about 100 lines of code and most all are single lines of code. It's not down to 64 LOC, but without going out of my way to compress it further, I think this is about as small as I can make it, unless someone has some nice ninja magic to drop 30 lines out of it.
Code: (Select All)
Dim Shared Grid(0 To 5, 0 To 5) As Integer
Const Left = 19200, Right = 19712, Down = 20480, Up = 18432, ESC = 32, LCtrl = 100306, RCtrl = 100305
Screen _NewImage(480, 480, 32): _ScreenMove _Middle
_Title "Double Up": Randomize Timer
_Font _LoadFont("C:\Windows\Fonts\courbd.ttf", 32, "MONOSPACE")
MakeNewGame
Do
Cls
_Limit 30
ShowGrid
If CheckInput Then GetNextNumber
_Display
Loop
Function CheckInput
Select Case _KeyHit
Case ESC: System
Case 83, 115: If _KeyDown(LCtrl) Or _KeyDown(RCtrl) Then MakeNewGame
Case Left: MoveLeftRight 1: CheckInput = -1 'we hit a valid move key. Even if we don't move, get a new number
Case Up: MoveUpDown 1: CheckInput = -1
Case Down: MoveUpDown -1: CheckInput = -1
Case Right: MoveLeftRight -1: CheckInput = -1
End Select
End Function
Sub MoveUpDown (direction As Integer)
start = 1: finish = 4: If direction < 0 Then Swap start, finish
Do
moved = 0
For y = start To finish Step direction: For x = 1 To 4
If Grid(x, y) = 0 Then 'every point above this moves down
For j = y To finish Step direction
Grid(x, j) = Grid(x, j + direction)
If Grid(x, j) <> 0 Then moved = -1
Next
End If
Next x, y
If moved Then y = y + direction 'recheck the same column
Loop Until Not moved
For y = start To finish Step direction: For x = 1 To 4
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y + direction) Then 'add them together and every point above this moves
Grid(x, y) = Grid(x, y) * 2
For j = y + direction To finish Step direction
Grid(x, j) = Grid(x, j + direction)
Next
End If
Next x, y
End Sub
Sub MoveLeftRight (direction)
start = 1: finish = 4: If direction < 0 Then Swap start, finish
Do
moved = 0
For x = start To finish Step direction
For y = 1 To 4
If Grid(x, y) = 0 Then 'every point right of this moves left
For j = x To finish Step direction
Grid(j, y) = Grid(j + direction, y)
If Grid(j, y) <> 0 Then moved = -1
Next
End If
Next y, x
If moved Then x = x + direction 'recheck the same row
Loop Until Not moved
For x = start To finish Step direction
For y = 1 To 4
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x + direction, y) Then 'add them together and every point right of this moves left
Grid(x, y) = Grid(x, y) * 2
For j = x + direction To finish Step direction
Grid(j, y) = Grid(j + direction, y)
Next
End If
Next y, x
End Sub
Sub ShowGrid
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) * 120, (y - 1) * 120, 120, 120, t$, -1, 0, 0, -1, 0, 0
Next y, x
End Sub
Sub MakeNewGame
For x = 1 To 4: For y = 1 To 4: Grid(x, y) = 0: Next y, x
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 y, x
If valid Then Do: x = _Ceil(Rnd * 4): y = _Ceil(Rnd * 4): Loop Until Grid(x, y) = 0: Grid(x, y) = 2
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)
Line (x1 + 1, y1 + 1)-(x1 + x2 - 1, y1 + y2 - 1), BoxHighLight, B
Line (x1 + 2, t1 + 2)-(x1 + x2 - 2, y1 + y2 - 2), BoxHighLight, B
_PrintString (x1 + (x2 - _PrintWidth(Caption)) \ 2, y1 + (y2 - _FontHeight) \ 2), Caption$
End Sub
Posts: 3,972
Threads: 177
Joined: Apr 2022
Reputation:
219
10-23-2024, 10:32 AM
(This post was last modified: 10-23-2024, 03:18 PM by bplus.)
Oh sweet! _Font _LoadFont("theFile.ttf...) ' skip the font handle middleman variable
Ninja magic here, the two routines MoveUpDown and MoveLeftRight combined, not 30 lines but not nothing either:
Here is relaxed version with most comments removed except crucial ones and spaces thrown in for breathing room PLUS all lines are under 80 characters:
Code: (Select All)
_Title "2048 - Relaxed a little " ' bplus 2024-10-22 fit 80 chars
DefLng A-Z: Randomize Timer
ReDim Shared B(15) ' Game Board 4x4 indexes go left to right and then down
Screen _NewImage(400, 400, 32): _ScreenMove 450, 180
_PrintMode _KeepBackground: F = _LoadFont("arial.ttf", 28): _Font F
OY = (100 - _FontHeight(F)) / 2 ' Y offset in tile
W~& = &HFFFFFFFF ' White Color
AddNewCell: AddNewCell
Do
5 Cls , _RGB(100, 100, 250): Color _RGB(255, 255, 255)
For y = 0 To 3: For x = 0 To 3
If B(x + 4 * y) Then p2 = Log(B(x + 4 * y)) / Log(2) Else p2 = 0
bg& = _RGB32(255 - 17 * p2)
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), W~&, B
If B(x + 4 * y) > 0 Then
n$ = _Trim$(Str$(B(x + 4 * y)))
OX = (100 - _PrintWidth(n$)) / 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 x, y
_Title "2048 - " + "Score: " + Str$(Score): _Display
' Remaining Move ?
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then 10
If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then 10
If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then 10
Next x, y
' No, Game Over
Line (75, 100)-(325, 300), _RGBA(0, 0, 0, 40), BF
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
10 ReDim t(15): jm = 0 ' Update Board by arrow keys
Select Case _KeyHit
Case 19200: jm = 4: ks = 0: ke = 3: kstep = 1: km = 1
Case 19712: jm = 4: ks = 3: ke = 0: kstep = -1: km = 1
Case 18432: jm = 1: ks = 0: ke = 3: kstep = 1: km = 4
Case 20480: jm = 1: ks = 3: ke = 0: kstep = -1: km = 4
End Select
If jm = 0 Then 5
For j = 0 To 3
If jm = 4 Then ' outer loop y's = row ends
p = j * jm + ks ' start pointer at arrow side left or right
Else ' outer loop x's
If kstep = 1 Then p = j Else p = 12 + j ' pointer at column ends
End If
For k = ks To ke Step kstep
If B(j * jm + k * km) <> 0 Then
If t(p) = B(j * jm + k * km) Then
t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p)
p = p + kstep * km
ElseIf t(p) = 0 Then
t(p) = B(j * jm + k * km)
Else
p = p + kstep * km: t(p) = B(j * jm + k * km)
End If
End If
Next
Next
For j = 0 To 15: B(j) = t(j): Next: AddNewCell: _Limit 30
Loop Until _KeyDown(27)
Sub AddNewCell
Dim temp(15), x, y, c, i, x1, y1
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
Next x, y
If c > 0 Then
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .8 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4
End If
End Sub
' =============================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board toward that side, like numbers
' will combine and double. Score is shown in title bar. ESC quits.
' Objective is to get a tile to 2048 but can go further.
'==============================================================================
' Guide for multiple statements on one line by way of colon = Double Parking:
' + Premise: Avoid horizontal scrolling if at all possible!
' Use code _line extensions if you must. I think it worth the effort to avoid
' those as well. ( Now all lines < 80 chars !)
' + For sure, multiple assignments can go on one line best if all are related.
' + For sure, multiple short Sub calls specially if all are related.
' + Remember Next x, y and for keypress either _Keyhit or Input$(1)
' + Option _Explicit used until code is where I want then removed.
EDIT: WTH? this didn't work when I checked it. Fixed now.
b = b + ...
Posts: 3,972
Threads: 177
Joined: Apr 2022
Reputation:
219
10-23-2024, 12:40 PM
(This post was last modified: 10-23-2024, 01:02 PM by bplus.)
Well I cleaned up Steve's code a little further, removed Typo in MakeBox and MakeNewGame option/routine altogether, then I had room to throw long comments under the THEN's so now all lines are < 80 chars PLUS I added 4's missing in GetNewNumber routine. So now we make < 100 easy with no horizontal scrolling even on 80 width screen. Plus a tiny little bit of color in the tiles.
Code: (Select All)
Dim Shared Grid(0 To 5, 0 To 5) As Integer
Const Left = 19200, Right = 19712, Down = 20480, Up = 18432, ESC = 32
Screen _NewImage(480, 480, 32): _ScreenMove _Middle
_Title "Double Up by Steve mod b+": Randomize Timer
_Font _LoadFont("C:\Windows\Fonts\courbd.ttf", 32, "MONOSPACE")
GetNextNumber: GetNextNumber
Do
ShowGrid
If CheckInput Then GetNextNumber
_Display: _Limit 30: Cls
Loop
Function CheckInput
Select Case _KeyHit
Case ESC: System
Case Left: MoveLeftRight 1: CheckInput = -1 'we hit a valid move key.
Case Up: MoveUpDown 1: CheckInput = -1 ' Even if we don't move,
Case Down: MoveUpDown -1: CheckInput = -1 ' get a new number.
Case Right: MoveLeftRight -1: CheckInput = -1
End Select
End Function
Sub MoveUpDown (direction As Integer)
start = 1: finish = 4: If direction < 0 Then Swap start, finish
Do
moved = 0
For y = start To finish Step direction: For x = 1 To 4
If Grid(x, y) = 0 Then 'every point above this moves down
For j = y To finish Step direction
Grid(x, j) = Grid(x, j + direction)
If Grid(x, j) <> 0 Then moved = -1
Next
End If
Next x, y
If moved Then y = y + direction 'recheck the same column
Loop Until Not moved
For y = start To finish Step direction: For x = 1 To 4
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y + direction) Then
'add them together and every point above this moves
Grid(x, y) = Grid(x, y) * 2
For j = y + direction To finish Step direction
Grid(x, j) = Grid(x, j + direction)
Next
End If
Next x, y
End Sub
Sub MoveLeftRight (direction)
start = 1: finish = 4: If direction < 0 Then Swap start, finish
Do
moved = 0
For x = start To finish Step direction
For y = 1 To 4
If Grid(x, y) = 0 Then 'every point right of this moves left
For j = x To finish Step direction
Grid(j, y) = Grid(j + direction, y)
If Grid(j, y) <> 0 Then moved = -1
Next
End If
Next y, x
If moved Then x = x + direction 'recheck the same row
Loop Until Not moved
For x = start To finish Step direction
For y = 1 To 4
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x + direction, y) Then
'add them together and every point right of this moves left
Grid(x, y) = Grid(x, y) * 2
For j = x + direction To finish Step direction
Grid(j, y) = Grid(j + direction, y)
Next
End If
Next y, x
End Sub
Sub ShowGrid
For x = 1 To 4: For y = 1 To 4
t$ = LTrim$(Str$(Grid(x, y))): If t$ = "0" Then t$ = ""
MakeBox (x - 1) * 120, (y - 1) * 120, 120, 120, t$
Next y, x
End Sub
Sub GetNextNumber
For x = 1 To 4: For y = 1 To 4
If Grid(x, y) = 0 Then valid = -1
Next y, x
If valid Then
Do: x = _Ceil(Rnd * 4): y = _Ceil(Rnd * 4): Loop Until Grid(x, y) = 0
If Rnd < .8 Then Grid(x, y) = 2 Else Grid(x, y) = 4 ' < missed 4
End If
End Sub
Sub MakeBox (x1%, y1%, x2%, y2%, Caption$)
Line (x1% + 3, y1% + 3)-(x1% + x2% - 3, y1% + y2% - 3), &HFF008888, B
Line (x1% + 5, y1% + 5)-(x1% + x2% - 5, y1% + y2% - 5), &HFF00FFFF, B
x = x1% + (x2% - _PrintWidth(Caption$)) \ 2
_PrintString (x, y1% + (y2% - _FontHeight) \ 2), Caption$
End Sub
b = b + ...
Posts: 2,696
Threads: 327
Joined: Apr 2022
Reputation:
217
There -- I stripped off the 30 lines that I mentioned earlier.
Code: (Select All)
Dim Shared Grid(0 To 5, 0 To 5) As Integer
Screen _NewImage(480, 480, 32): _ScreenMove _Middle
_Title "Double Up by Steve": Randomize Timer: Color , 0
_Font _LoadFont("courbd.ttf", 32, "MONOSPACE")
GetNextNumber: GetNextNumber
Do
For x = 1 To 4: For y = 1 To 4
t$ = LTrim$(Str$(Grid(x, y))): If t$ = "0" Then t$ = ""
x1% = (x - 1) * 120: y1% = (y - 1) * 120
Line (x1% + 3, y1% + 3)-Step(117, 117), &HFF008888, BF
Line (x1% + 5, y1% + 5)-Step(115, 115), &HFF00FFFF, B
_PrintString (x1% + 60 - _PrintWidth(t$) \ 2, y1% + 44), t$
Next y, x
Select Case _KeyHit
Case 32: System
Case 19200: MoveLeftRight 1: GetNextNumber 'we hit a valid move key.
Case 18432: MoveUpDown 1: GetNextNumber ' Even if we don't move,
Case 20480: MoveUpDown -1: GetNextNumber ' get a new number.
Case 19712: MoveLeftRight -1: GetNextNumber
End Select
_Display: _Limit 30
Loop
Sub MoveUpDown (d As Integer)
s = 1: f = 4: If d < 0 Then Swap s, f
Do
moved = 0
For y = s To f Step d: For x = 1 To 4
If Grid(x, y) = 0 Then 'every point above this moves down
For j = y To f Step d
Grid(x, j) = Grid(x, j + d): moved = (Grid(x, j) <> 0)
Next
End If
Next x, y
If moved Then y = y + d 'recheck the same column
Loop Until Not moved
For y = s To f Step d: For x = 1 To 4
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y + d) Then
Grid(x, y) = Grid(x, y) * 2
For j = y + d To f Step d: Grid(x, j) = Grid(x, j + d): Next
End If
Next x, y
End Sub
Sub MoveLeftRight (d)
s = 1: f = 4: If d < 0 Then Swap s, f
Do
moved = 0
For x = s To f Step d: For y = 1 To 4
If Grid(x, y) = 0 Then 'every point right of this moves left
For j = x To f Step d
Grid(j, y) = Grid(j + d, y): moved = (Grid(j, y) <> 0)
Next
End If
Next y, x
If moved Then x = x + d 'recheck the same row
Loop Until Not moved
For x = s To f Step d: For y = 1 To 4
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x + d, y) Then
Grid(x, y) = Grid(x, y) * 2
For j = x + d To f Step d: Grid(j, y) = Grid(j + d, y): Next
End If
Next y, x
End Sub
Sub GetNextNumber
For x = 1 To 4: For y = 1 To 4: valid = (Grid(x, y) = 0): Next y, x
If valid Then
Do: x = _Ceil(Rnd * 4): y = _Ceil(Rnd * 4): Loop Until Grid(x, y) = 0
If Rnd < .8 Then Grid(x, y) = 2 Else Grid(x, y) = 4 ' < missed 4
End If
End Sub
And, every line is still less than 80 characters in width.
Posts: 3,972
Threads: 177
Joined: Apr 2022
Reputation:
219
10-23-2024, 05:00 PM
(This post was last modified: 10-23-2024, 05:11 PM by bplus.)
2048 - 60 LOC
Code: (Select All)
DefLng A-Z: Randomize Timer: ReDim Shared B(15) ' 2048 - 60 LOC
Screen _NewImage(405, 405, 32): _ScreenMove 450, 180
_PrintMode _KeepBackground: _Font _LoadFont("arial.ttf", 28)
Color , &HFFBB0033: AddNewCell: AddNewCell
DoLoop: Cls: _Title "2048 - b+ 60 LOC " + "Score: " + Str$(Score)
For x = 0 To 3: For y = 0 To 3
If B(x + 4 * y) Then pwr = Log(B(x + 4 * y)) / Log(2) Else pwr = 0
bg& = _RGB32(255 - 17 * pwr): bg2& = _RGB32(128 - 12 * pwr)
Line (x * 100 + 4, y * 100 + 4)-Step(100 - 4, 100 - 4), bg&, BF
Line (x * 100 + 5, y * 100 + 5)-Step(100 - 6, 100 - 6), bg2&, B
If B(x + 4 * y) > 0 Then
n$ = _Trim$(Str$(B(x + 4 * y))): u = x * 100: v = y * 100
ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight) / 2
Color &HFF000000: _PrintString (u + ox + 2, v + oy + 2), n$
Color &HFFFFFFFF: _PrintString (u + ox, v + oy), n$
End If
Next: Next: _Display: _Limit 30
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then 10
If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then 10
If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then 10
Next: Next: Beep: Sleep: End
10 ReDim t(15): jm = 0 ' Update Board by arrow keys
Select Case _KeyHit
Case 27, 32: System
Case 19200: jm = 4: ks = 0: ke = 3: kstep = 1: km = 1
Case 19712: jm = 4: ks = 3: ke = 0: kstep = -1: km = 1
Case 18432: jm = 1: ks = 0: ke = 3: kstep = 1: km = 4
Case 20480: jm = 1: ks = 3: ke = 0: kstep = -1: km = 4
End Select: If jm = 0 Then GoTo DoLoop
For j = 0 To 3
If jm = 4 Then
p = j * jm + ks
Else
If kstep = 1 Then p = j Else p = 12 + j
End If
For k = ks To ke Step kstep
If B(j * jm + k * km) <> 0 Then
If t(p) = B(j * jm + k * km) Then
t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p)
p = p + kstep * km
ElseIf t(p) = 0 Then '
t(p) = B(j * jm + k * km)
Else
p = p + kstep * km: t(p) = B(j * jm + k * km)
End If
End If
Next k, j
For j = 0 To 15: B(j) = t(j): Next: AddNewCell: GoTo DoLoop
Sub AddNewCell ' == Insert new cell onto board in random unused blank ==
Dim temp(15), x, y, c, i, x1, y1
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
Next x, y
If c > 0 Then
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .8 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4
End If
End Sub
' =============================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board toward that side, like numbers
' will combine and double. Score is shown in title bar. ESC quits.
' Objective is to get a tile to 2048 but can go further.
'==============================================================================
' Guide for multiple statements on one line by way of colon = Double Parking:
' + Premise: Avoid horizontal scrolling if at all possible!
' Use code _line extensions if you must. I think it worth the effort to avoid
' those as well. ( Now all lines < 80 chars !)
' + For sure, multiple assignments can go on one line best if all are related.
' + For sure, multiple short Sub calls specially if all are related.
' + Remember Next x, y and for keypress either _Keyhit or Input$(1)
' + Option _Explicit used until code is where I want then removed.
Longest line of code is 74 chars 
and a line to spare!
b = b + ...
Posts: 3,972
Threads: 177
Joined: Apr 2022
Reputation:
219
10-24-2024, 06:42 PM
(This post was last modified: 10-24-2024, 06:48 PM by bplus.)
For the record even if Steve objects to one line (it's his fault I am doing better anyway!) :
2048 - 55 LOC
Code: (Select All)
DefLng A-Z: Randomize Timer: ReDim Shared B(15) ' 2048 - 55 LOC
Screen _NewImage(405, 405, 32): _ScreenMove 450, 180
_PrintMode _KeepBackground: _Font _LoadFont("arial.ttf", 28)
Color , &HFFBB0033: AddNewCell: AddNewCell
DoLoop: Cls: _Title "2048 - b+ 55 LOC " + "Score: " + Str$(Score)
For x = 0 To 3: For y = 0 To 3
If B(x + 4 * y) Then pwr = Log(B(x + 4 * y)) / Log(2) Else pwr = 0
bg& = _RGB32(255 - 17 * pwr): bg2& = _RGB32(128 - 12 * pwr)
Line (x * 100 + 4, y * 100 + 4)-Step(100 - 4, 100 - 4), bg&, BF
Line (x * 100 + 5, y * 100 + 5)-Step(100 - 6, 100 - 6), bg2&, B
If B(x + 4 * y) > 0 Then
n$ = _Trim$(Str$(B(x + 4 * y))): u = x * 100: v = y * 100
ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight) / 2
Color &HFF000000: _PrintString (u + ox + 2, v + oy + 2), n$
Color &HFFFFFFFF: _PrintString (u + ox, v + oy), n$
End If
Next: Next: _Display: _Limit 30
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then 10
If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then 10
If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then 10
Next: Next: Beep: Sleep: End
10 ReDim t(15): jm = 0 ' Update Board by arrow keys
Select Case _KeyHit
Case 27, 32: System
Case 19200: jm = 4: ks = 0: ke = 3: kstep = 1: km = 1
Case 19712: jm = 4: ks = 3: ke = 0: kstep = -1: km = 1
Case 18432: jm = 1: ks = 0: ke = 3: kstep = 1: km = 4
Case 20480: jm = 1: ks = 3: ke = 0: kstep = -1: km = 4
End Select: If jm = 0 Then GoTo DoLoop
For j = 0 To 3
If jm = 4 Then p = j * jm + ks Else If kstep = 1 Then p = j Else p = 12 + j
For k = ks To ke Step kstep
If B(j * jm + k * km) <> 0 Then
If t(p) = B(j * jm + k * km) Then
t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p)
p = p + kstep * km
ElseIf t(p) = 0 Then '
t(p) = B(j * jm + k * km)
Else
p = p + kstep * km: t(p) = B(j * jm + k * km)
End If
End If
Next k, j
For j = 0 To 15: B(j) = t(j): Next: AddNewCell: GoTo DoLoop
Sub AddNewCell ' == Insert new cell onto board in random unused blank ==
Dim temp(15), x, y, c, i, x1, y1
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
Next x, y
If c > 0 Then
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .8 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4
End If
End Sub
' =============================================================================
' Instructions briefly:
' Use arrow keys to move all numbers on board toward that side, like numbers
' will combine and double. Score is shown in title bar. ESC quits.
' Objective is to get a tile to 2048 but can go further.
'==============================================================================
' Guide for multiple statements on one line by way of colon = Double Parking:
' + Premise: Avoid horizontal scrolling if at all possible!
' Use code _line extensions if you must. I think it worth the effort to avoid
' those as well. ( Now all lines < 80 chars !)
' + For sure, multiple assignments can go on one line best if all are related.
' + For sure, multiple short Sub calls specially if all are related.
' + Remember Next x, y and for keypress either _Keyhit or Input$(1)
' + Option _Explicit used until code is where I want then removed.
Longest line is 79 chars and look! it still works:
b = b + ...
Posts: 730
Threads: 120
Joined: Apr 2022
Reputation:
106
Man, that's really a small version of 2048 now., bplus.
I still haven't reached 2048 yet, stuck at 1024.
- Dav
Posts: 3,972
Threads: 177
Joined: Apr 2022
Reputation:
219
Yeah it takes a long time to build up to even 1024.
@Dav did you know it was supposed to be only 10% 4's not 20%? I rechecked rules last night when I ported code to JB (not nearly as few LOC) and compared to a previous post there back in 2022. I think that would slow down the clogging by 4's mixed with 2's. Still gonna take a long time to get to 2048.
b = b + ...
Posts: 730
Threads: 120
Joined: Apr 2022
Reputation:
106
Interesting, nope I didn’t know that. Is JB =JustBasic?
|
