+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: TheBOB (https://staging.qb64phoenix.com/forumdisplay.php?fid=27)
+---- Thread: SCRAMBLE - A Tile Game Based on the Popular Keychain Puzzle. (/showthread.php?tid=188)
SCRAMBLE - A Tile Game Based on the Popular Keychain Puzzle. - Pete - 04-25-2022
SCRAMBLE.BAS by Bob Seguin
![[Image: Screenshot-589.png]](https://i.ibb.co/DVcxr3Q/Screenshot-589.png)
Code: (Select All)
'--------------------------------------------
' S C R A M B L E . B A S
' based on a popular keychain puzzle
' Freeware 2001 by Bob Seguin
'--------------------------------------------
_TITLE "SCRAMBLE.BAS by Bob Seguin"
DEFINT A-Z
DIM SHARED TileBOX(1 TO 5000)
DIM SHARED Puzzle(1 TO 6, 1 TO 7)
DIM SHARED Numbers(1 TO 20)
DIM SHARED RowCOL(1 TO 4, 1 TO 5)
DIM SHARED Ticks, Elapsed$
DIM SHARED GameOVER, TimesUP, GameSTARTED, NewGAME
SCREEN 12
DrawSCREEN
GOSUB SetPALETTE
'Initialize game arrays
FOR n = 1 TO 20
Numbers(n) = n
NEXT n
FOR Row = 2 TO 6
FOR Col = 2 TO 5
SetNUM = SetNUM + 1
Puzzle(Col, Row) = SetNUM
NEXT Col
NEXT Row
RANDOMIZE TIMER
ON TIMER(1) GOSUB Clock
SetTILES 0
NewGAME = 1
'Game menu
DO
_LIMIT 30
MouseSTATUS LB, RB, MouseX, MouseY
k$ = UCASE$(INKEY$)
IF k$ = CHR$(27) THEN SYSTEM
IF k$ = "B" THEN '<--------"BOSS" key
FOR Colr = 0 TO 15
OUT &H3C8, Colr
OUT &H3C9, 0
OUT &H3C9, 0
OUT &H3C9, 0
NEXT Colr
DO
k$ = INKEY$
LOOP UNTIL k$ <> ""
IF k$ = CHR$(27) THEN SYSTEM
Colr = 0
GOSUB SetPALETTE
END IF
IF k$ = "P" THEN '<-------------Pause
StoppedTIME! = TIMER
a$ = INPUT$(1)
StartTIME! = TIMER - StoppedTIME! + StartTIME!
END IF
SELECT CASE MouseX
CASE 262 TO 381
IF Item THEN Menu 1
PlayGAME
CASE 545 TO 565
Menu 0
CASE ELSE
IF Item THEN Menu 1
END SELECT
IF GameOVER OR TimesUP THEN GOSUB CloseUP
WAIT &H3DA, 8
WAIT &H3DA, 8, 8
ClearMOUSE
LOOP
SYSTEM
'------ SUBROUTINE SECTION ---------
CloseUP:
TIMER OFF
TIMERon = 0
IF TimesUP THEN
COLOR 13
LOCATE 20, 58: PRINT "Sorry, time's up!"
PLAY "MBMST200L16O6gec<gc<gec<gec<gec<gec"
LOCATE 18, 70: PRINT Elapsed$
ELSE
COLOR 10
LOCATE 20, 59: PRINT "Congratulations!"
PLAY "MBMST120O1L16ceg>ceg>ceg>L32cgcgcgcg"
LOCATE 18, 70: PRINT Elapsed$
END IF
Ticks = 0: GameSTARTED = 0: GameOVER = 0: TimesUP = 0
RETURN
SetPALETTE:
PALETTE
OUT &H3C8, 2
OUT &H3C9, 58
OUT &H3C9, 58
OUT &H3C9, 58
OUT &H3C8, 4
OUT &H3C9, 63
OUT &H3C9, 0
OUT &H3C9, 0
OUT &H3C8, 5
OUT &H3C9, 20
OUT &H3C9, 20
OUT &H3C9, 48
OUT &H3C8, 6
OUT &H3C9, 5
OUT &H3C9, 17
OUT &H3C9, 58
OUT &H3C8, 11
OUT &H3C9, 40
OUT &H3C9, 34
OUT &H3C9, 63
OUT &H3C8, 12
OUT &H3C9, 58
OUT &H3C9, 57
OUT &H3C9, 60
RETURN
Clock:
Ticks = Ticks + 1
IF Ticks > 599 THEN
TimesUP = 1
Ticks = 600
END IF
Minute$ = LTRIM$(STR$(Ticks \ 60 MOD 60))
IF VAL(Minute$) < 10 THEN Minute$ = "0" + Minute$
Second$ = LTRIM$(STR$(Ticks MOD 60))
IF VAL(Second$) < 10 THEN Second$ = "0" + Second$
Elapsed$ = Minute$ + ":" + Second$
COLOR 11: LOCATE 18, 70: PRINT Elapsed$
RETURN
SUB ClearMOUSE
SHARED LB, RB
WHILE LB OR RB
MouseSTATUS LB, RB, MouseX, MouseY
WEND
END SUB
SUB DrawSCREEN
x = 40: y = 100
COLOR 7
LOCATE 9, 12: PRINT "1 2 3 4"
LOCATE 11, 12: PRINT "5 6 7 8"
LOCATE 13, 12: PRINT "9 1O 11 12"
LOCATE 15, 11: PRINT "13 14 15 16"
LOCATE 17, 11: PRINT "17 18 19"
GET (86, 130)-(166, 187), TileBOX()
LINE (86, 130)-(166, 187), 0, BF
PUT (82, 130), TileBOX(), PSET
GET (86, 190)-(100, 210), TileBOX()
PUT (83, 190), TileBOX(), PSET
FOR x = 76 TO 148 STEP 24
FOR y = 120 TO 248 STEP 32
LINE (x, y)-(x + 24, y + 32), 8, B
NEXT y
NEXT x
LOCATE 20, 9: PRINT "The object of the"
LOCATE 21, 9: PRINT "game is to arrange"
LOCATE 22, 9: PRINT "the tiles as shown"
LOCATE 23, 9: PRINT "above."
LOCATE 25, 9: PRINT "Use the blank square to move"
LOCATE 26, 9: PRINT "tiles around. To move a tile to"
LOCATE 27, 9: PRINT "an adjacent blank, simply click it."
LOCATE 23, 58: PRINT "TIMER begins with";
LOCATE 24, 60: PRINT "the first click";
LOCATE 26, 58: PRINT "MAXIMUM GAME TIME";
LOCATE 27, 54: PRINT "ALLOWED IS 10 MINUTES";
DIM NumBOX(1 TO 1000)
LINE (0, 1)-(2, 18), 15, BF
GET (0, 1)-(2, 18), NumBOX()
LINE (0, 1)-(2, 18), 0, BF
FOR x = 3 TO 83 STEP 10
FOR y = 1 TO 16 STEP 7
LINE (x, y)-(x + 8, y + 3), 15, BF
LINE (x, 1)-(x + 2, 18), 15, BF
LINE (x + 6, 1)-(x + 8, 18), 15, BF
NEXT y
NEXT x
LINE (3, 5)-(5, 7), 0, BF
LINE (9, 12)-(11, 14), 0, BF
LINE (13, 5)-(15, 7), 0, BF
LINE (13, 12)-(15, 14), 0, BF
LINE (26, 1)-(28, 7), 0, BF
LINE (23, 12)-(28, 18), 0, BF
LINE (39, 5)-(41, 7), 0, BF
LINE (33, 12)-(35, 14), 0, BF
LINE (49, 5)-(51, 7), 0, BF
LINE (53, 5)-(58, 18), 0, BF
LINE (53, 8)-(61, 18), 0, BF
LINE (58, 8)-(60, 8), 15, BF
LINE (57, 9)-(59, 10), 15, BF
LINE (56, 11)-(58, 18), 15, BF
LINE (73, 12)-(75, 14), 0, BF
LINE (86, 6)-(88, 14), 0, BF
Index = 101
FOR x = 3 TO 83 STEP 10
GET (x, 1)-(x + 8, 18), NumBOX(Index)
Index = Index + 100
NEXT x
x = 0
LINE (0, 0)-(120, 20), 0, BF
'Draw and GET tiles
Index = 1
Index2 = 1
FOR Reps = 1 TO 20
LINE (20, 0)-(49, 29), 12, BF
LINE (20, 0)-(49, 29), 0, B
LINE (21, 1)-(48, 28), 15, B
LINE (48, 1)-(48, 28), 7
LINE (21, 28)-(48, 28), 7
PSET (20, 0), 1
PSET (49, 0), 1
PSET (20, 29), 1
PSET (49, 29), 1
IF Reps < 10 THEN
IF Index = 1 THEN
PUT (3, 0), NumBOX(Index)
ELSE
PUT (0, 0), NumBOX(Index)
END IF
ELSE
IF Reps = 11 THEN
PUT (3, 0), NumBOX()
PUT (10, 0), NumBOX()
ELSE
PUT (1, 0), NumBOX()
PUT (6, 0), NumBOX(Index)
END IF
END IF
Index = Index + 100
IF Index = 1001 THEN
Index = 1
Repeat = 1
END IF
PlusX = 30
IF Reps > 9 THEN PlusX = 27
IF Reps = 20 THEN PlusX = 28
FOR x = 0 TO 16
FOR y = 0 TO 18
IF y > 6 THEN Colr = 5 ELSE Colr = 1
IF POINT(x, y) <> 0 THEN PSET (x + PlusX, y + 6), Colr
NEXT y
NEXT x
LINE (0, 0)-(14, 20), 0, BF
IF Reps = 20 THEN LINE (20, 0)-(50, 30), 1, BF
GET (20, 0)-(49, 29), TileBOX(Index2)
Index2 = Index2 + 250
NEXT Reps
LINE (0, 0)-(50, 30), 0, BF
'Borders and Title
COLOR 7
LOCATE 1, 1
PRINT "SCRAMBLE"
FOR x = 0 TO 64
FOR y = 0 TO 16
IF y > 6 THEN Colr = 7 ELSE Colr = 2
IF POINT(x, y) <> 0 THEN
LINE (x * 2 + 258, y * 2 + 20)-(x * 2 + 259, y * 2 + 21), Colr, B
END IF
NEXT y
NEXT x
LOCATE 1, 1
PRINT SPACE$(8)
COLOR 8
LOCATE 4, 24
PRINT "Based on a popular keychain puzzle"
LINE (5, 5)-(634, 474), 8, B
LINE (10, 10)-(629, 469), 8, B
'Draw playing frame
LINE (253, 121)-(390, 289), 1, BF
LINE (256, 124)-(387, 285), 9, BF
LINE (256, 124)-(387, 285), 14, B
LINE (260, 128)-(383, 281), 6, BF
LINE (261, 129)-(382, 280), 1, BF
LINE (247, 115)-(396, 295), 13, B
LINE (242, 110)-(401, 300), 7, B
LINE (237, 105)-(406, 305), 8, B
COLOR 7
LOCATE 8, 60: PRINT "MENU"
LOCATE 18, 56: PRINT "ELAPSED TIME:"
COLOR 8
LOCATE 9, 60: PRINT "New Game"
LOCATE 10, 60: PRINT "EXIT"
LINE (545, 130)-(565, 139), 7, BF
LINE (545, 146)-(565, 155), 7, BF
LINE (465, 126)-(570, 160), 8, B
END SUB
DEFSNG A-Z
SUB Interval (Length!)
OldTimer# = TIMER
DO: LOOP UNTIL TIMER > OldTimer# + Length!
WAIT &H3DA, 8
END SUB
DEFINT A-Z
SUB Menu (OnOFF)
SHARED LB, RB, MouseX, MouseY
SHARED Item
IF OnOFF THEN
LOCATE 9, 60: PRINT "New Game"
LOCATE 10, 60: PRINT "EXIT"
LINE (545, 130)-(565, 139), 7, BF
LINE (545, 146)-(565, 155), 7, BF
Item = 0
EXIT SUB
END IF
SELECT CASE MouseY
CASE 129 TO 142
LINE (545, 146)-(565, 155), 7, BF
COLOR 8: LOCATE 10, 60: PRINT "EXIT"
IF Item <> 1 THEN
LINE (545, 130)-(565, 139), 15, BF
COLOR 7: LOCATE 9, 60: PRINT "New Game"
TIMER OFF
Ticks = 0: GameSTARTED = 0: GameOVER = 0: TimesUP = 0
Item = 1
END IF
IF LB THEN
PLAY "MBT120O6L64a"
LINE (545, 130)-(565, 139), 7, BF
COLOR 8: LOCATE 9, 60: PRINT "New Game"
SetTILES 1
NewGAME = 1
IF GameSTARTED THEN GameSTARTED = 0
Item = 0
END IF
CASE 143 TO 156
LINE (545, 130)-(565, 139), 7, BF
COLOR 8: LOCATE 9, 60: PRINT "New Game"
IF Item <> 2 THEN
LINE (545, 146)-(565, 155), 15, BF
COLOR 7: LOCATE 10, 60: PRINT "EXIT"
Item = 2
END IF
IF LB THEN
PLAY "MBT120O6L64a"
LINE (545, 146)-(565, 155), 7, BF
COLOR 8: LOCATE 10, 60: PRINT "EXIT"
SYSTEM
END IF
CASE ELSE
IF Item THEN
COLOR 8
LOCATE 9, 60: PRINT "New Game"
LOCATE 10, 60: PRINT "EXIT"
LINE (545, 130)-(565, 139), 7, BF
LINE (545, 146)-(565, 155), 7, BF
Item = 0
END IF
END SELECT
END SUB
SUB MouseSTATUS (LB, RB, MouseX, MouseY)
WHILE _MOUSEINPUT: WEND
LB = _MOUSEBUTTON(1)
RB = _MOUSEBUTTON(2)
MouseX = _MOUSEX
MouseY = _MOUSEY
END SUB
SUB PlayGAME
SHARED LB, RB, MouseX, MouseY, TIMERon
SELECT CASE MouseX
CASE 262 TO 291
SELECT CASE MouseY
CASE 130 TO 159
Col = 2: Row = 2
GOSUB MoveIT
CASE 160 TO 189
Col = 2: Row = 3
GOSUB MoveIT
CASE 190 TO 219
Col = 2: Row = 4
GOSUB MoveIT
CASE 220 TO 249
Col = 2: Row = 5
GOSUB MoveIT
CASE 250 TO 279
Col = 2: Row = 6
GOSUB MoveIT
END SELECT
CASE 292 TO 321
SELECT CASE MouseY
CASE 130 TO 159
Col = 3: Row = 2
GOSUB MoveIT
CASE 160 TO 189
Col = 3: Row = 3
GOSUB MoveIT
CASE 190 TO 219
Col = 3: Row = 4
GOSUB MoveIT
CASE 220 TO 249
Col = 3: Row = 5
GOSUB MoveIT
CASE 250 TO 279
Col = 3: Row = 6
GOSUB MoveIT
END SELECT
CASE 322 TO 351
SELECT CASE MouseY
CASE 130 TO 159
Col = 4: Row = 2
GOSUB MoveIT
CASE 160 TO 189
Col = 4: Row = 3
GOSUB MoveIT
CASE 190 TO 219
Col = 4: Row = 4
GOSUB MoveIT
CASE 220 TO 249
Col = 4: Row = 5
GOSUB MoveIT
CASE 250 TO 279
Col = 4: Row = 6
GOSUB MoveIT
END SELECT
CASE 352 TO 381
SELECT CASE MouseY
CASE 130 TO 159
Col = 5: Row = 2
GOSUB MoveIT
CASE 160 TO 189
Col = 5: Row = 3
GOSUB MoveIT
CASE 190 TO 219
Col = 5: Row = 4
GOSUB MoveIT
CASE 220 TO 249
Col = 5: Row = 5
GOSUB MoveIT
CASE 250 TO 279
Col = 5: Row = 6
GOSUB MoveIT
END SELECT
END SELECT
EXIT SUB
MoveIT:
IF LB THEN
IF GameSTARTED = 0 AND NewGAME THEN
GameSTARTED = 1
NewGAME = 0
TIMER ON
TIMERon = 1
END IF
IF GameSTARTED THEN
TileX = (Col - 2) * 30 + 262
TileY = (Row - 2) * 30 + 130
IF Puzzle(Col, Row - 1) = 20 THEN
PUT (TileX, TileY), TileBOX(4751), PSET
PUT (TileX, TileY - 30), TileBOX((Puzzle(Col, Row) - 1) * 250 + 1), PSET
Puzzle(Col, Row - 1) = Puzzle(Col, Row)
Puzzle(Col, Row) = 20
SOUND 12000, 1
END IF
IF Puzzle(Col, Row + 1) = 20 THEN
PUT (TileX, TileY), TileBOX(4751), PSET
PUT (TileX, TileY + 30), TileBOX((Puzzle(Col, Row) - 1) * 250 + 1), PSET
Puzzle(Col, Row + 1) = Puzzle(Col, Row)
Puzzle(Col, Row) = 20
SOUND 12000, 1
END IF
IF Puzzle(Col - 1, Row) = 20 THEN
PUT (TileX, TileY), TileBOX(4751), PSET
PUT (TileX - 30, TileY), TileBOX((Puzzle(Col, Row) - 1) * 250 + 1), PSET
Puzzle(Col - 1, Row) = Puzzle(Col, Row)
Puzzle(Col, Row) = 20
SOUND 12000, 1
END IF
IF Puzzle(Col + 1, Row) = 20 THEN
PUT (TileX, TileY), TileBOX(4751), PSET
PUT (TileX + 30, TileY), TileBOX((Puzzle(Col, Row) - 1) * 250 + 1), PSET
Puzzle(Col + 1, Row) = Puzzle(Col, Row)
Puzzle(Col, Row) = 20
SOUND 12000, 1
END IF
TileNUM = 0
FOR CheckROW = 2 TO 6
FOR CheckCOL = 2 TO 5
TileNUM = TileNUM + 1
IF Puzzle(CheckCOL, CheckROW) <> TileNUM THEN RETURN
NEXT CheckCOL
NEXT CheckROW
GameOVER = 1
END IF
END IF
RETURN
END SUB
SUB SetTILES (Wipe)
LOCATE 18, 70: PRINT SPACE$(5)
LOCATE 20, 58: PRINT SPACE$(18)
COLOR 11: LOCATE 18, 70: PRINT "00:00"
IF Wipe THEN
'Initialize tile checking array
FOR R = 1 TO 5
FOR C = 1 TO 4
RowCOL(C, R) = 1
NEXT C
NEXT R
DO
DO
Row = INT(RND * 5) + 1
Col = INT(RND * 4) + 1
LOOP WHILE RowCOL(Col, Row) = 0
RowCOL(Col, Row) = 0
PUT ((Col - 1) * 30 + 262, (Row - 1) * 30 + 130), TileBOX(4751), PSET
PLAY "MFT200L64O6B"
'Check for all tiles erased
FOR R = 1 TO 5
FOR C = 1 TO 4
IF RowCOL(C, R) = 0 THEN Count = Count + 1
NEXT C
NEXT R
IF Count = 20 THEN EXIT DO ELSE Count = 0
SOUND 24000, 1
LOOP
END IF
'Scramble tiles using physical model
'Test for blank square
FOR Col = 2 TO 5
FOR Row = 2 TO 6
IF Puzzle(Col, Row) = 20 THEN
BlankCOL = Col
BlankROW = Row
END IF
NEXT Row
NEXT Col
FOR Reps = 1 TO 1000
DO
IncCOL = 0: IncROW = 0
RandINC = INT(RND * 4) + 1
SELECT CASE RandINC
CASE 1: IncCOL = 1
CASE 2: IncCOL = -1
CASE 3: IncROW = 1
CASE 4: IncROW = -1
END SELECT
LOOP UNTIL Puzzle(BlankCOL + IncCOL, BlankROW + IncROW) <> 0
SWAP Puzzle(BlankCOL, BlankROW), Puzzle(BlankCOL + IncCOL, BlankROW + IncROW)
BlankCOL = BlankCOL + IncCOL: BlankROW = BlankROW + IncROW
NEXT Reps
Row = 1: Col = 1
FOR y = 130 TO 250 STEP 30
Row = Row + 1
FOR x = 262 TO 352 STEP 30
Col = Col + 1
IF Puzzle(Col, Row) <> 20 THEN
PUT (x, y), TileBOX((Puzzle(Col, Row) - 1) * 250 + 1), PSET
Interval .05
SOUND 24000, 1
END IF
NEXT x
Col = 1
NEXT y
END SUB