+- 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)
2048 Puzzle - Dav - 10-17-2024
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 SubRE: 2048 Puzzle - FellippeHeitor - 10-17-2024
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)
RE: 2048 Puzzle - Dav - 10-17-2024
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
RE: 2048 Puzzle - FellippeHeitor - 10-17-2024
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!
RE: 2048 Puzzle - bplus - 10-17-2024
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 SubOh I luv large font too
RE: 2048 Puzzle - Dav - 10-17-2024
@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 SubRE: 2048 Puzzle - bplus - 10-17-2024
@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.
RE: 2048 Puzzle - Dav - 10-17-2024
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
RE: 2048 Puzzle - bplus - 10-17-2024
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?
RE: 2048 Puzzle - SMcNeill - 10-17-2024
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"