Here's the classic 15 puzzle game in QB64. Use arrows to move numbers to the empty place. Put numbers in order 1 to 15 to solve puzzle. Uses the handy Text SUB by @bplus for the big numbers.
- Dav
- Dav
Code: (Select All)
'============
'15puzzle.bas
'============
'The classic 15 puzzle game in QB64.
'By Dav, OCT/2024
'Use arrows to move numbers to the empty place.
'Put numbers in order 1 to 15 to solve puzzle.
'Text SUB made by bplus (thanks bplus!)
Randomize Timer
dh = Int(_DesktopHeight * .75) 'scale board to 75% of users desktop height
Screen _NewImage(dh, dh, 32)
Dim board(4, 4) '4x4 board
'=== init board
Dim num(15) '15 random numbers
For n = 0 To 14
num(n) = n + 1
Next: num(15) = 0 'this one is empty
For b = 1 To 500 'shuffle
Swap num(Int(Rnd * 15)), num(15)
Next
b = 0 'assign on the board
For row = 0 To 4 - 1
For col = 0 To 4 - 1
board(row, col) = num(b)
If board(row, col) = 0 Then
emptyrow = row: emptycol = col
End If
b = b + 1
Next
Next
GoSub DrawBoard
'=== main loop
Do
'=== get user input
Do
key$ = InKey$: _Limit 30
Loop Until key$ <> ""
Select Case key$
Case Chr$(0) + Chr$(72) 'up
If emptyrow < 4 - 1 Then
board(emptyrow, emptycol) = board(emptyrow + 1, emptycol)
board(emptyrow + 1, emptycol) = 0
emptyrow = emptyrow + 1
End If
Case Chr$(0) + Chr$(80) 'down
If emptyrow > 0 Then
board(emptyrow, emptycol) = board(emptyrow - 1, emptycol)
board(emptyrow - 1, emptycol) = 0
emptyrow = emptyrow - 1
End If
Case Chr$(0) + Chr$(75) 'left
If emptycol < 4 - 1 Then
board(emptyrow, emptycol) = board(emptyrow, emptycol + 1)
board(emptyrow, emptycol + 1) = 0
emptycol = emptycol + 1
End If
Case Chr$(0) + Chr$(77) 'right
If emptycol > 0 Then
board(emptyrow, emptycol) = board(emptyrow, emptycol - 1)
board(emptyrow, emptycol - 1) = 0
emptycol = emptycol - 1
End If
Case Chr$(27) 'quit
End
End Select
GoSub DrawBoard
'== check if puzzle solved
solved = 1: tally = 1
For row = 0 To 4 - 1
For col = 0 To 4 - 1
If board(row, col) <> 0 Then
If board(row, col) <> tally Then solved = 0
tally = tally + 1
End If
Next
Next
If solved = 1 Then Exit Do
Loop
GoSub DrawBoard
Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, 150), BF
Text _Width / 4 + 2, _Height / 3 + 2, _Width / 8, _RGB(0, 0, 0), "SOLVED!!"
Text _Width / 4, _Height / 3, _Width / 8, _RGB(255, 255, 0), "SOLVED!!"
_Display
End
'========
DrawBoard:
'========
size = _Width / 4
For row = 0 To 4 - 1
For col = 0 To 4 - 1
x1 = (col * size): x2 = x1 + size
y1 = (row * size): y2 = y1 + size
If board(row, col) = 0 Then
Line (x1, y1)-(x2, y2), _RGB(0, 0, 0), BF
Else
Line (x1, y1)-(x2, y2), _RGB(200, 0, 0), BF
Line (x1, y1)-(x2, y2), _RGB(0, 0, 0), B
p$ = _Trim$(Str$(board(row, col)))
If Len(p$) = 1 Then x1 = x1 + (size / 4)
Text x1 + 2, y1 + 2, size, _RGB(0, 0, 0), p$
Text x1, y1, size, _RGB(255, 255, 255), p$
End If
Next
Next
_Display
Return
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&
End Sub