Tweet
Code:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Game15 v2, a simple "15 tiles" brick game, written in PB/DLL 6.0
' January 2000 by Borje Hagsten. Released as Public Domain.
' Updated June 2003 with better mix code - now shuffles bricks instead,
' plus added keyboard handling - can be played using the arrow keys.
' Free to enhance, learn from, or simply to enjoy and play.
'
' The "rules" are simple. Click on the tiles next to the open
' space in order to move them and try to line them up, 1 to 15.
' A beep and red caption on a brick indicates a correct position.
' It's not as easy as it may look like from the beginning and some
' people may even become addicted to playing it. A complete 32-bit
' game for Windows with a file size of just 20 KB - PB rules!
'
' - Some ideas, in case you want to do something more of it:
' Use a split bitmap instead of numbers on the labels
' Create and add resource file with version info and program icon
' Create routines to save and show results (maybe even store/recall a running game?)
' Add a "About" dialog, menu, sound support, help and some game info
' Set a price and sell a million copies (but please remember me, if you succeed.. <IMG SRC="http://www.powerbasic.com/support/forums/smile.gif" ALT="smile">
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#COMPILE EXE
#INCLUDE "WIN32API.INC"
%ID_MIX = 11
%ID_LABEL1 = 20
%ID_LABEL2 = 21
%ID_LABEL3 = 22
%ID_TIMER = 40
TYPE bx
x AS LONG ' x pos
y AS LONG ' y pos
z AS LONG ' reference number
p AS LONG ' actual position
c AS LONG ' color value
END TYPE
GLOBAL hDlg AS LONG
GLOBAL gTime AS LONG
GLOBAL brc AS LONG
GLOBAL n AS LONG
GLOBAL EmptyPos AS LONG
GLOBAL hTimer AS LONG
GLOBAL bPos() AS bx
DECLARE CALLBACK FUNCTION DlgCallback()
DECLARE FUNCTION CheckDone AS LONG
DECLARE FUNCTION EndProcedure AS LONG
DECLARE SUB NewGame
DECLARE SUB ReMix
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' PBMAIN, where all controls and the dialog is created
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION PBMAIN
LOCAL x AS LONG, y AS LONG, z AS LONG, w AS LONG, h AS LONG, b AS LONG
LOCAL a AS LONG
brc = 4 'number of columns/rows - use at least 3, classic is 4 (15-tile game)
' Note: The brc value is all you have to change. The dialog and all
' controls will resize themselves accordingly. Try with 5 or 6 to
' create a game with 25 or 36 bricks, but do have in mind that the
' time it takes to solve the puzzle relates to this number.. :-)
w = 26 'width
h = 24 'height
a = 10 'distance from dialog edge
n = brc^2 - 1 'number of bricks (tiles, whatever..)
b = brc - 1 'zero based number of columns and rows
EmptyPos = n 'initial empty space, down in the corner
REDIM bPos (n) 'array for storing brick info
DIALOG NEW 0, FORMAT$(n) & " tiles",,, brc * w + 22, brc * h + 90, _
%WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU, 0 TO hDlg
CONTROL ADD LABEL, hDlg, %ID_LABEL2, "", 9, 9, _
brc * w + 2, brc * h + 2, %SS_SUNKEN OR %WS_TABSTOP
CONTROL ADD LABEL, hDlg, %ID_LABEL1, "", a, brc * h + 18, _
brc * w + 2, 12, %SS_CENTER OR %SS_SUNKEN
CONTROL ADD LABEL, hDlg, %ID_LABEL3, "", a, brc * h + 30, _
brc * w + 2, 12, %SS_CENTER OR %SS_SUNKEN
CONTROL ADD BUTTON, hDlg, %ID_MIX, "&New game", a, brc * h + 50, brc * w + 2, 14
CONTROL ADD BUTTON, hDlg, %IDCANCEL, "E&xit", a, brc * h + 68, brc * w + 2, 14
'A zero based index would be better here, but some low values are already
'used by the DDT dialog (like IDCANCEL, etc), so we better use another
'approach and increase it to a "100 based" line of controls instead
z = 100
FOR y = 0 TO b
FOR x = 0 TO b
bPos(z - 100).x = a + x * w
bPos(z - 100).y = a + y * h
CONTROL ADD LABEL, hDlg, z, FORMAT$(z - 99), a + x * w, a + y * h, w, h, _
%SS_NOTIFY OR %SS_CENTER, %WS_EX_DLGMODALFRAME
INCR z
IF z > 99 + n THEN EXIT FOR
NEXT
NEXT
bPos(n).x = a + b * w 'x and y for the inital empty space
bPos(n).y = a + b * h
DIALOG SHOW MODELESS hDlg, CALL DlgCallback
'DDT dialog, so use own message loop to trap WM_KEYDOWN..
LOCAL msg AS TAGMSG
WHILE GetMessage(Msg, %NULL, 0, 0)
IF IsDialogMessage(hDlg, Msg) THEN
SELECT CASE msg.message
CASE %WM_CREATE
CASE %WM_CHAR : MessageBeep &HFFFFFFFF
CASE %WM_KEYDOWN
IF GetDlgCtrlID(msg.hWnd) <> %ID_LABEL2 THEN EXIT SELECT
SELECT CASE msg.wParam
CASE %VK_LEFT
IF (EmptyPos + 1) MOD brc <> 0 THEN
FOR x = 0 TO n - 1
IF bPos(bPos(x).p).z = EmptyPos + 1 THEN
x = 100 + bPos(x).p
SendMessage hDlg, %WM_COMMAND, MAKLNG(x, %BN_CLICKED), GetDlgItem(hDlg, x)
EXIT FOR
END IF
NEXT
END IF
CASE %VK_RIGHT
IF EmptyPos MOD brc <> 0 THEN
FOR x = 0 TO n - 1
IF bPos(bPos(x).p).z = EmptyPos - 1 THEN
x = 100 + bPos(x).p
SendMessage hDlg, %WM_COMMAND, MAKLNG(x, %BN_CLICKED), GetDlgItem(hDlg, x)
EXIT FOR
END IF
NEXT
END IF
CASE %VK_UP
IF EmptyPos + brc <= n THEN
FOR x = 0 TO n - 1
IF bPos(bPos(x).p).z = EmptyPos + brc THEN
x = 100 + bPos(x).p
SendMessage hDlg, %WM_COMMAND, MAKLNG(x, %BN_CLICKED), GetDlgItem(hDlg, x)
EXIT FOR
END IF
NEXT
END IF
CASE %VK_DOWN
IF EmptyPos - brc >= 0 THEN
FOR x = 0 TO n - 1
IF bPos(bPos(x).p).z = EmptyPos - brc THEN
x = 100 + bPos(x).p
SendMessage hDlg, %WM_COMMAND, MAKLNG(x, %BN_CLICKED), GetDlgItem(hDlg, x)
EXIT FOR
END IF
NEXT
END IF
END SELECT
END SELECT
Else
TranslateMessage Msg
DispatchMessage Msg
End If
Wend
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' One dialog Callback function takes care of almost everything
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
CALLBACK FUNCTION DlgCallback()
LOCAL rStr AS STRING
STATIC hBrushDialog AS LONG
SELECT CASE CBMSG
CASE %WM_INITDIALOG
hBrushDialog = CreateSolidBrush(RGB(255,223,161)) 'dialog color
CALL ReMix 'mix and set up new game
CheckDone
CASE %WM_DESTROY 'at exit
IF hTimer THEN KillTimer hDlg, hTimer 'Kill the timer
DeleteObject hBrushDialog 'Delete the brush
PostQuitMessage 0
CASE %WM_COMMAND
SELECT CASE CBCTL
CASE %ID_MIX 'Start a new game..
rStr = "Break current game and start a new?"
IF hTimer = 0 OR MessageBox(hDlg, BYVAL STRPTR(rStr), _
FORMAT$(n) & " Tiles" & CHR$(0), _
%MB_YESNO OR %MB_ICONQUESTION) = %IDYES THEN
CALL NewGame
END IF
CASE %IDCANCEL
IF hTimer = 0 OR EndProcedure THEN DIALOG END CBHNDL 'exit program
CASE 100 TO 100 + n 'The bricks - label controls
LOCAL bc AS LONG, tmp AS LONG : bc = CBCTL - 100
'check to see if the brick has an empty space next to it
IF (bPos(bc).z + 1 = EmptyPos AND (bPos(bc).z + 1) MOD brc <> 0) OR _
(bPos(bc).z - 1 = EmptyPos AND (EmptyPos + 1) MOD brc <> 0) OR _
bPos(bc).z + brc = EmptyPos OR bPos(bc).z - brc = EmptyPos THEN
IF hTimer = 0 THEN
hTimer = SetTimer(hDlg, %ID_TIMER, 1000, BYVAL %NULL) '1000 mSec = 1 sec
END IF
'okay, so move the Brick into the empty space
CONTROL SET LOC hDlg, CBCTL, bPos(EmptyPos).x, bPos(EmptyPos).y
IF EmptyPos = bc THEN 'Was it a "good" position?
bPos(bc).c = %RED : BEEP 'Could play something else here too..
ELSE
bPos(bc).c = %BLACK
END IF
tmp = EmptyPos 'store new empty space
EmptyPos = bPos(bc).z
bPos(bc).z = tmp
bPos(bc).p = bc
'following triggers %WM_CTLCOLORSTATIC (redraws brick)
InvalidateRect CBLPARAM, BYVAL %NULL, 0 : UpdateWindow CBLPARAM
bc = CheckDone
IF bc >= n THEN 'All is done, build and show a message
rStr = "Done in "
rStr = rStr & FORMAT$(gTime \ 60, "0") & " min. " _
& FORMAT$(gTime MOD 60, "0") & " sec."
rStr = rStr & CHR$(10, 10)
rStr = rStr & "Play again?" & CHR$(0)
IF MessageBox(hDlg, BYVAL STRPTR(rStr), FORMAT$(n) & " Tiles" & CHR$(0), _
%MB_YESNO OR %MB_ICONWARNING) = %IDYES THEN
CALL NewGame
ELSE
DIALOG END CBHNDL 'exit game
END IF
END IF
END IF
END SELECT
CASE %WM_CTLCOLORSTATIC 'color tiles and set their textcolor
IF GetDlgCtrlID(CBLPARAM) > 99 THEN
SetTextColor CBWPARAM, bPos(GetDlgCtrlID(CBLPARAM) - 100).c
FUNCTION = GetSysColorBrush(%COLOR_INFOBK)
END IF
CASE %WM_CTLCOLORDLG : FUNCTION = hBrushDialog 'paint the dialog's background
CASE %WM_SYSCOMMAND
IF CBWPARAM = %SC_CLOSE THEN
IF EndProcedure = 0 THEN
FUNCTION = 1: EXIT FUNCTION
END IF
END IF
CASE %WM_TIMER
INCR gTime
CONTROL SET TEXT hDlg, %ID_LABEL3, _
FORMAT$(gTime \ 60, "0") & " min. " & _
FORMAT$(gTime MOD 60, "0") & " sec."
END SELECT
END FUNCTION
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' NewGame generates a new game.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUB NewGame 'We get smother action with redraw turned off
IF hTimer THEN KillTimer hDlg, hTimer 'Kill eventual timer
hTimer = 0
CALL SendMessage(hDlg, %WM_SETREDRAW, %FALSE, 0)
CALL ReMix 'Set new random order
CALL SendMessage(hDlg, %WM_SETREDRAW, %TRUE, 0)
InvalidateRect hDlg, BYVAL %NULL, 0 : UpdateWindow hDlg
CALL CheckDone
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' ReMix generates random numbers and moves the bricks to their new positions.
' This is only (?) sure way to mix the bricks - mimics real life mix by moving
' bricks around randomly, using real empty space as target space. Cannot simply
' use a bunch of random numbers, since some combinations are impossible to solve..
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB ReMix
LOCAL aa AS LONG, bb AS LONG, tmp AS LONG, ePos AS LONG
FOR aa = 0 TO n - 1 ' Make sure all numbers are unique
bPos(aa).z = aa
bPos(aa).c = %BLACK
NEXT
ePos = n
RANDOMIZE ' Seed the random number generator
FOR aa = 1 TO n * 100 'experiment if you like - think this is enough to mix them properly..
DO
bb = RND(1, n) - 1 ' Generate number, then see if it can be moved
IF (bPos(bb).z + 1 = ePos AND (bPos(bb).z + 1) MOD brc <> 0) OR _ 'test right of pos 1-3
(bPos(bb).z - 1 = ePos AND (ePos + 1) MOD brc <> 0) OR _ 'test left of position 2-4
bPos(bb).z + brc = ePos OR bPos(bb).z - brc = ePos THEN 'test above/under
tmp = bPos(bb).z
bPos(bb).z = ePos
ePos = tmp
EXIT DO
END IF
LOOP
IF aa > n * 50 AND ePos = n THEN EXIT FOR 'enough many draws and empty pos in down/right corner - use it!
NEXT
EmptyPos = ePos
FOR aa = 0 TO n - 1 ' Re-position the bricks
IF aa = bPos(aa).z THEN bPos(aa).c = %RED
CONTROL SET LOC hDlg, 100 + aa, bPos(bPos(aa).z).x, bPos(bPos(aa).z).y
bPos(aa).p = aa
NEXT aa
gTime = 0 ' Reset the timing of the game
CONTROL SET TEXT hDlg, %ID_LABEL3, "0 min. 0 sec."
SetFocus hDlg
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' CheckDone loops through all bricks to see which ones are
' placed correctly and then shows the result in %ID_LABEL1
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION CheckDone AS LONG
LOCAL aa AS LONG, isDone AS LONG
FOR aa = 0 TO n - 1
IF aa = bPos(aa).z THEN
bPos(aa).c = %RED 'in correct place, use red text color
INCR isDone 'count correct ones
ELSE
bPos(aa).c = %BLACK 'not in correct place, use black text
END IF
NEXT aa
IF isDone = 1 THEN
CONTROL SET TEXT hDlg, %ID_LABEL1, FORMAT$(isDone) & " tile done"
ELSE
CONTROL SET TEXT hDlg, %ID_LABEL1, FORMAT$(isDone) & " tiles done"
END IF
FUNCTION = isDone 'return number of tiles in correct place
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' message before end..
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION EndProcedure AS LONG
IF MessageBox(hDlg, "Exit game?", FORMAT$(n) & " Tiles" & CHR$(0), _
%MB_YESNO OR %MB_ICONQUESTION) = %IDYES THEN
FUNCTION = 1 : EXIT FUNCTION
END IF
END FUNCTION
[This message has been edited by Borje Hagsten (edited June 08, 2003).]
Comment