10-17-2024, 01:01 PM
@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
@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 Sub