Stroq - A game in Forth#
About Stroq:#
Stroq is a simple but addictive puzzle game. I found the game for Linux and MacOS X on the Internet (Stroq Homepage
) and decided to do a conversation for the Atari 8Bit Computer in Forth. Winfried Piegsda did the graphical design, sound and artwork, I did the coding in Forth (X-Forth for Atari). The Game programmed in little less than 4 weeks to be submitted to the annual ABBUC Software Contest where it scored the 5th place.
Screenshots#
Atari 8bit Version#
License:#
This game is licensed under the GNU Public License, Version 2 or higher.
Source:#
Atari XL/XE Computer (6502 X-Forth / FIG-Forth)#
I didn't look at the C-Sources, we only "stole" the puzzle level from the No InterWiki reference defined in properties for Wiki called "original game at sourceforge>http"!. Because the game was programmed under time pressure, the code is not "optimal".
( Stroq )
CR ." Loading Stroq" CR
HEX
: AT-X ( xp -- ) 55 ! ;
: AT-Y ( yp -- ) 54 C! ;
: AT ( xp yp -- ) AT-Y AT-X ;
: AT-X? ( -- xp ) 55 @ ;
58 CONSTANT SAVMSC ( Pointer to Displaybuffer )
14 CONSTANT MAXX
14 CONSTANT MAXY
0 VARIABLE pf MAXX MAXY * ALLOT
pf CELL+ pf !
pf VARIABLE pfp
." Playfield is at $" pfp @ U. CR
0 VARIABLE curx
0 VARIABLE cury
0 VARIABLE lastx
0 VARIABLE lasty
0 VARIABLE lastblox
0 VARIABLE STROQPTR
7000 CONSTANT STROQMEM
0 VARIABLE LevelWidth
0 VARIABLE LevelHeight
0 VARIABLE BloxUsed
0 VARIABLE PuzzleNumber
0 VARIABLE XOffset
0 VARIABLE YOffset
: WAITKEY KEY DROP ;
: [PF"]
R COUNT DUP 1+ R> + >R
pfp @ SWAP CMOVE
LevelWidth @ pfp +!
;
: BEGINLEVEL
pf @ pfp !
0 STROQPTR !
0 lastx ! 0 curx !
0 lasty ! 0 cury !
0 lastblox ! ;
: PF"
22 STATE @ IF COMPILE [PF"] WORD
C@ 1+ ALLOT ELSE WORD DUP C@ 1+
PAD SWAP CMOVE PAD COUNT THEN ; IMMEDIATE
: CLS 7D EMIT ;
: CONVERTLEVEL
pfp @ DUP
LevelWidth @ LevelHeight @ * + SWAP DO
I C@
DUP 58 = IF 41 I C! THEN
DUP 20 = IF 01 I C! THEN
4F = IF 81 I C! THEN
LOOP ;
: ENDLEVEL
10 LevelHeight @ - 2 / 28 * YOffset !
28 LevelWidth @ 2 * - 2 / XOffset !
LevelWidth @ 2 MOD 0=
IF -1 XOffset +! THEN
LevelHeight @ 2 MOD 0=
IF -28 YOffset +! THEN
pf @ pfp ! CONVERTLEVEL ;
: PRINTBLOX ( x y n -- )
ROT 2 * SAVMSC @ + XOffset @ +
ROT 50 * YOffset @ + + 28 -
SWAP 2 * 40 +
OVER OVER SWAP C!
1+ SWAP 1+ OVER OVER C!
27 + SWAP 3F + SWAP OVER OVER C!
1+ SWAP 1+ SWAP C! ;
: PRINTBLOX2 ( x y )
OVER OVER LevelWidth @ * + pfp @ +
C@ DUP 80 AND IF 0F AND 70 + PRINTBLOX ELSE
DUP 40 AND IF 0F AND PRINTBLOX ELSE
DUP F0 AND 0= IF 0F AND 30 + PRINTBLOX ELSE
DROP THEN THEN THEN ;
: PRINTLEVEL
LevelHeight @ 0 DO
LevelWidth @ 0 DO
I J PRINTBLOX2
LOOP
LOOP ;
: AND! ( n addr -- )
DUP C@ F0 AND ROT OR SWAP C! ;
: PUTBLOX ( x y n -- )
ROT pfp @ + ROT LevelWidth @ * +
AND! ;
: INLINE? ( -- f )
curx @ lastx @ - ABS 1 =
cury @ lasty @ - ABS 1 = + 1 = ;
: CLEARHEADER BC40 28 ERASE ;
: FLIPBLOX ( x y )
LevelWidth @ * + pfp @ + DUP
C@ DUP 40 AND 0= IF
80 XOR SWAP C!
ELSE
DROP DROP
THEN ;
: GETBLOX ( x y -- n )
LevelWidth @ * + pfp @ + C@ 0F AND ;
: GETCOLOR ( x y -- )
LevelWidth @ * + pfp @ + C@ 80 AND ;
: EMPTY? ( -- f )
curx @ cury @ GETBLOX 1 = ;
: PUTLBLOX ( n -- )
lastx @ lasty @ ROT PUTBLOX ;
: PUTCBLOX ( n -- )
curx @ cury @ ROT PUTBLOX ;
: SUCCESS ( -- )
lastx @ lasty @ PRINTBLOX2
curx @ cury @ PRINTBLOX2
curx @ lastx !
cury @ lasty !
2 STROQPTR +! 1 BloxUsed +!
curx @ STROQMEM STROQPTR @ + C!
cury @ STROQMEM STROQPTR @ + 1+ C! ;
: STROQADDR STROQMEM STROQPTR @ + ;
: STROQX STROQADDR C@ ;
: STROQY STROQADDR 1+ C@ ;
: REWIND
BEGIN
STROQX STROQY 1 PUTBLOX
STROQX STROQY PRINTBLOX2
STROQX curx @ =
STROQY cury @ =
AND 0=
WHILE
-2 STROQPTR +!
-1 BloxUsed +!
REPEAT
-2 STROQPTR +! -1 BloxUsed +!
STROQX lastx !
STROQY lasty !
STROQPTR @ 0 > IF
STROQX curx @ = IF
STROQY cury @ < IF
3 PUTCBLOX 3 lastblox !
ELSE
5 PUTCBLOX 5 lastblox !
THEN
THEN
STROQY cury @ = IF
STROQX curx @ > IF
4 PUTCBLOX 4 lastblox !
ELSE
6 PUTCBLOX 6 lastblox !
THEN
THEN
ELSE
2 PUTCBLOX 2 lastblox !
THEN SUCCESS
-2 STROQPTR +!
;
: SOLVE
CLEARHEADER A 0 AT
STROQPTR @ IF
STROQPTR @ 0 DO
STROQX STROQY FLIPBLOX
STROQX STROQY PRINTBLOX2
-2 STROQPTR +!
2 +LOOP
0 LevelHeight @ 1 - 1 DO
0 LevelWidth @ 1 - 1 DO
I J GETCOLOR
IF 2 OR ELSE 1 OR THEN
LOOP
3 = IF 1 OR THEN
LOOP
IF
." Puzzle Not Solved! " 0
ELSE
." Puzzle Solved! " 1
THEN
ELSE
." No Stroke! " 0
THEN WAITKEY
;
: SETSTROQ ( -- )
INLINE? EMPTY? AND IF
curx @ lastx @ = IF
cury @ lasty @ - 1 = IF
( one down )
lastblox @
DUP 2 = IF 5 PUTLBLOX THEN
DUP 3 = IF 8 PUTLBLOX THEN
DUP 4 = IF C PUTLBLOX THEN
6 = IF A PUTLBLOX THEN
3 PUTCBLOX 3 lastblox !
ELSE
( one up )
lastblox @
DUP 2 = IF 3 PUTLBLOX THEN
DUP 4 = IF B PUTLBLOX THEN
DUP 5 = IF 8 PUTLBLOX THEN
6 = IF 9 PUTLBLOX THEN
5 PUTCBLOX 5 lastblox !
THEN
ELSE
curx @ lastx @ - 1 = IF
( one right )
lastblox @
DUP 2 = IF 4 PUTLBLOX THEN
DUP 3 = IF B PUTLBLOX THEN
DUP 5 = IF C PUTLBLOX THEN
6 = IF 7 PUTLBLOX THEN
6 PUTCBLOX 6 lastblox !
ELSE
( one left )
lastblox @
DUP 2 = IF 6 PUTLBLOX THEN
DUP 3 = IF 9 PUTLBLOX THEN
DUP 4 = IF 7 PUTLBLOX THEN
5 = IF A PUTLBLOX THEN
4 PUTCBLOX 4 lastblox !
THEN
THEN SUCCESS
ELSE
EMPTY? 0= IF
REWIND SUCCESS
ELSE
CLEARHEADER
E 0 AT ." Illegal Move!"
WAITKEY CLEARHEADER
THEN
THEN
;
: SETBLOX ( -- )
lastblox @
IF
SETSTROQ
ELSE
curx @ cury @ 2 PUTBLOX
2 lastblox ! SUCCESS
THEN ;
: CUROFF FF 2F0 C! ;
: CURON 00 2F0 C! ;
: HEADER ( Print header )
DECIMAL CUROFF
1 0 AT BloxUsed @ S>D
<# # # # #> TYPE SPACE ." Blox used"
16 0 AT ." Puzzle Number "
PuzzleNumber @ S>D
<# # # # #> TYPE
HEX ;
00 VARIABLE FOOTERMEM 28 ALLOT
." Footermem is at " FOOTERMEM . CR
( Displaylistgeraffel )
230 CONSTANT SDLSTL
200 CONSTANT VSDLST
D40E CONSTANT NMIEN
00 VARIABLE DLSAVE
D40B CONSTANT VCOUNT
: SAVEDL SDLSTL @ DLSAVE ! ;
: RESTOREDL DLSAVE @ SDLSTL ! ;
: SETDL ( addr -- )
BEGIN
VCOUNT C@ 10 <
UNTIL
SDLSTL ! C0 NMIEN C! ;
0 VARIABLE DLGAME -2 ALLOT
70 C, 60 C,
80 C, ( DLI1 )
00 C,
00 C,
42 C, BC40 ,
80 C, ( DLI2 )
00 C,
40 C,
0404 , 0404 , 0404 , 0404 ,
0404 , 0404 , 0404 , 0404 ,
0404 , 0404 , 0404 ,
10 C,
80 C, ( DLI3 )
10 C,
42 C, FOOTERMEM ,
80 C, ( DLI4 )
00 C,
41 C, DLGAME ,
: SETDLGAME
DLGAME SETDL ;
0 VARIABLE DLHELP -2 ALLOT
70 C, 60 C,
80 C, ( DLI1 )
00 C,
42 C, BC40 ,
80 C, ( DLI2 )
00 C,
00 C,
40 C,
40 C,
0202 , 0202 , 0202 , 0202 ,
0202 , 0202 , 0202 , 0202 ,
0202 , 0202 , 0202 ,
A0 C, ( DLI3 )
00 C, 00 C,
42 C, FOOTERMEM ,
80 C, ( DLI4 ) 00 C,
41 C, DLHELP ,
: SETDLHELP
DLHELP SETDL ;
0 VARIABLE DLTITLE -2 ALLOT
70 C, 40 C,
80 C, 00 , 42 C, BC40 ,
80 C, 00 C, 00 C, 30 C,
( 1) 4F C, 8010 , 0F C,
0F0F , 0F0F , 0F0F
( 2) 0F0F , 0F0F , 0F0F , 0F0F ,
( 3) 0F0F , 0F0F , 0F0F , 0F0F ,
( 4) 0F0F , 0F0F , 0F0F , 0F0F ,
( 5) 0F0F , 0F0F , 0F0F , 0F0F ,
( 6) 0F0F , 0F0F , 0F0F , 0F0F ,
( 7) 0F0F , 0F0F , 0F0F , 0F0F ,
( 8) 0F0F , 0F0F , 0F0F , 0F0F ,
( 9) 0F0F , 0F0F , 0F0F , 0F0F ,
( 10) 0F0F , 0F0F , 0F0F , 0F0F ,
( 11) 0F0F , 0F0F , 0F0F , 0F0F ,
( 12) 0F0F , 0F0F , 0F0F , 0F0F ,
( 13) 0F0F , 0F0F , 0F0F , 0F0F ,
4F C, 9000 , 0F C,
( 14) 0F0F , 0F0F , 0F0F ,
( 15) 0F0F , 0F0F , 0F0F , 0F0F ,
( 16) 0F0F , 0F0F , 0F0F , 0F0F ,
( 17) 0F0F , 0F0F , 0F0F , 0F0F ,
( 18) 0F0F , 0F0F , 0F0F , 0F0F ,
( 19) 0F0F , 0F0F , 0F0F , 0F0F ,
( 20) 0F0F , 0F0F , 0F0F , 0F0F ,
( 21) 0F0F , 0F0F , 0F0F , 0F0F ,
( 22) 0F0F , 0F0F , 0F0F , 0F0F ,
( 23) 0F0F , 0F0F , 0F0F ,
A0 C, 00 C, 00 C,
42 C, FOOTERMEM ,
80 C, 00 C, 41 C, DLTITLE ,
: SETDLTITLE
DLTITLE SETDL ;
( Displaylist Interrupt )
D40A CONSTANT WSYNC
D016 CONSTANT COLPF0
D017 CONSTANT COLPF1
D018 CONSTANT COLPF2
D019 CONSTANT COLPF3
D01A CONSTANT COLBK
D409 CONSTANT CHBASE
02F4 CONSTANT CHBAS
80 4 - VARIABLE FONT
0E VARIABLE WHITE
00 VARIABLE BLACK
06 VARIABLE GREY
B6 VARIABLE GREEN
84 VARIABLE BLUE
32 VARIABLE T-RED
B2 VARIABLE T-GREEN
82 VARIABLE T-BLUE
( Poor Mens Assembler )
48 CONSTANT PHA
68 CONSTANT PLA
40 CONSTANT RTI
8D CONSTANT STA
AD CONSTANT LDA
A9 CONSTANT LDA#
60 CONSTANT RTS
20 CONSTANT JSR
4C CONSTANT JMP
00 VARIABLE WHITEBAR -2 ALLOT
LDA C, WHITE ,
STA C, WSYNC ,
STA C, COLBK ,
LDA C, BLACK ,
STA C, WSYNC ,
STA C, COLBK ,
RTS C,
00 VARIABLE DLI1 -2 ALLOT
PHA C,
JSR C, WHITEBAR ,
STA C, COLPF2 ,
LDA C, WHITE ,
STA C, COLPF1 ,
LDA# C, HERE DLI1 100 / C,
STA C, VSDLST 1+ ,
LDA# C, HERE DLI1 100 MOD C,
STA C, VSDLST ,
PLA C,
RTI ,
." DLI1 is at " DLI1 . CR
00 VARIABLE DLI2 -2 ALLOT
( Patch DLI1 )
DLI2 100 MOD SWAP C!
DLI2 100 / SWAP C!
PHA C,
JSR C, WHITEBAR ,
LDA C, GREY ,
STA C, COLPF0 ,
LDA C, WHITE ,
STA C, COLPF1 ,
LDA C, BLUE ,
STA C, COLPF2 ,
LDA C, GREEN ,
STA C, COLPF3 ,
LDA C, FONT ,
STA C, CHBASE ,
LDA# C, HERE DLI2 100 / C,
STA C, VSDLST 1+ ,
LDA# C, HERE DLI2 100 MOD C,
STA C, VSDLST ,
PLA C,
RTI C,
." DLI2 is at " DLI2 . CR
00 VARIABLE DLI3 -2 ALLOT
( Patch DLI2 )
DLI3 100 MOD SWAP C!
DLI3 100 / SWAP C!
PHA C,
JSR C, WHITEBAR ,
STA C, COLPF2 ,
LDA C, WHITE ,
STA C, COLPF1 ,
LDA C, CHBAS ,
STA C, CHBASE ,
LDA# C, HERE DLI3 100 / C,
STA C, VSDLST 1+ ,
LDA# C, HERE DLI3 100 MOD C,
STA C, VSDLST ,
PLA C,
RTI C,
." DLI3 is at " DLI3 . CR
00 VARIABLE DLI4 -2 ALLOT
( Patch DLI3 )
DLI4 100 MOD SWAP C!
DLI4 100 / SWAP C!
PHA C,
JSR C, WHITEBAR ,
LDA# C, DLI1 100 / C,
STA C, VSDLST 1+ ,
LDA# C, DLI1 100 MOD C,
STA C, VSDLST ,
PLA C,
RTI C,
." DLI4 is at " DLI4 . CR
E462 CONSTANT XITVBV
E45F CONSTANT SYSVBV
0224 CONSTANT VVBLKD
0222 CONSTANT VVBLKI
00 VARIABLE VBI -2 ALLOT
PHA C,
LDA# C, DLI1 100 / C,
STA C, VSDLST 1+ ,
LDA# C, DLI1 100 MOD C,
STA C, VSDLST ,
PLA C,
JMP C, SYSVBV ,
." VBI is at " VBI . CR
( Musik )
A001 CONSTANT MSTART
A008 CONSTANT MSTOP
A011 CONSTANT MINIT
A017 CONSTANT MPLAY
00 VARIABLE MUSIC
: SETMUSIC
MSTART @ 9F20 = IF
MINIT CALL
MSTART CALL
1 MUSIC !
THEN ;
: STOPMUSIC
MSTART @ 9F20 = IF
MSTOP CALL
0 MUSIC !
THEN ;
: STARTMUSIC
MSTART @ 9F20 = IF
MSTART CALL
1 MUSIC !
THEN ;
: SETVBI
NMIEN C@
0 NMIEN C!
VBI VVBLKI !
NMIEN C! ;
: SETDLI ( addr - )
( STOPMUSIC SETVBI ) VSDLST !
( STARTMUSIC ) ;
: RESETDLI 60 NMIEN C! C0CE SETDLI ;
( Player Missile Grafics )
022F CONSTANT SDMCTL
026F CONSTANT GPRIOR
D000 CONSTANT HPOS0
D01D CONSTANT GRACTL
D407 CONSTANT PMBASE
D01C CONSTANT VDELAY
02C0 CONSTANT PCOLR0
: INITPM
SDMCTL C@ 8 + SDMCTL C! ( Enable PM DMA )
2 GRACTL C! ( Enable PM )
1 GPRIOR C!
80 6 - PMBASE C! ;
( Player )
0 VARIABLE CROSS -2 ALLOT
2 BASE !
00000000 C,
11101110 C,
10000010 C,
10000010 C,
00000000 C,
10000010 C,
10000010 C,
11101110 C,
00000000 C,
HEX
: PMPOS ( x y -- )
7A00 FF 00 FILL
YOffset @ 40 / +
8 * 7A0B +
LevelHeight @ 8 = IF 4 + THEN ( Hack! )
CROSS SWAP 9 CMOVE
XOffset @ 2 / +
8 * 34 + HPOS0 C!
10 VDELAY C! ;
( Strings )
: ["] ( -- addr len )
R COUNT DUP 1+ R> + >R ;
: " ( -- addr len )
22 STATE @ IF
COMPILE ["] WORD C@ 1+ ALLOT
ELSE
WORD DUP C@ 1+ PAD
SWAP CMOVE PAD COUNT
THEN ; IMMEDIATE
( Level )
: LEVEL1
7 LevelWidth ! 7 LevelHeight !
0 BloxUsed ! 1 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXX"
PF" XOO OOX"
PF" XO O OX"
PF" X O O X"
PF" XO O OX"
PF" XOO OOX"
PF" XXXXXXX"
ENDLEVEL
;
: LEVEL2
A LevelWidth ! A LevelHeight !
0 BloxUsed ! 2 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" XO O OO OX"
PF" XO O OO OX"
PF" XOOO OX"
PF" XOOO OO OX"
PF" XO O OO OX"
PF" XO O OO X"
PF" X OO OX"
PF" X OO OX"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVEL3
8 LevelWidth ! A LevelHeight !
0 BloxUsed ! 3 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXX"
PF" XO OOO X"
PF" X OOO X"
PF" XOO O X"
PF" X O OO X"
PF" X O OO X"
PF" XOO OOX"
PF" XOOO O X"
PF" X O OOX"
PF" XXXXXXXX"
ENDLEVEL ;
: LEVEL4
A LevelWidth ! A LevelHeight !
0 BloxUsed ! 4 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" X OOX"
PF" X OOOOX"
PF" X OOOOOOX"
PF" XOOOOOOO X"
PF" X OOX"
PF" X OOO X"
PF" X OOO X"
PF" XOOO X"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVEL5
A LevelWidth ! A LevelHeight !
0 BloxUsed ! 5 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" XOOOO X"
PF" XOOO X"
PF" XOO OX"
PF" XOOOO OX"
PF" XOOO OX"
PF" XOO OOOX"
PF" XO OOOOOX"
PF" X OOOOOOX"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVEL6
A LevelWidth ! A LevelHeight !
0 BloxUsed ! 6 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" X OO X"
PF" X OO X"
PF" X OO X"
PF" X OOO X"
PF" X OOO X"
PF" X OOOO X"
PF" XOOOO OOX"
PF" XOOO OOX"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVEL7
A LevelWidth ! A LevelHeight !
0 BloxUsed ! 7 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" XOOOOOOO X"
PF" XOOO OX"
PF" XOOO OOX"
PF" XOO OOOOOX"
PF" XO OOOOX"
PF" XO OOOOX"
PF" XOO OOOOOX"
PF" XOO OOOOOX"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVEL8
A LevelWidth ! 6 LevelHeight !
0 BloxUsed ! 8 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" XO O O OOX"
PF" XO OOO O X"
PF" XOO OO X"
PF" XOOO OOO X"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVEL9
A LevelWidth ! A LevelHeight !
0 BloxUsed ! 9 PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" XOO O OO X"
PF" XOOO O X"
PF" XOOOOO OOX"
PF" XO OX"
PF" XOO OOOX"
PF" X O X"
PF" XOOOOO OOX"
PF" X OOX"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVELA
A LevelWidth ! 8 LevelHeight !
0 BloxUsed ! A PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" X OOOOOO X"
PF" X O OOX"
PF" X OOOO O X"
PF" X O O O X"
PF" X O OOOOX"
PF" X OOOOO X"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVELB
9 LevelWidth ! A LevelHeight !
0 BloxUsed ! B PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXX"
PF" XOO OOX"
PF" XOO OOX"
PF" XOOO OOOX"
PF" XOOO OOOX"
PF" XOO O OOX"
PF" XOO OOX"
PF" XOO OOX"
PF" XOO OOX"
PF" XXXXXXXXX"
ENDLEVEL ;
: LEVELC
9 LevelWidth ! 8 LevelHeight !
0 BloxUsed ! C PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXX"
PF" X OO OO X"
PF" XO OX"
PF" X O O X"
PF" X O O X"
PF" XO O OX"
PF" X O O X"
PF" XXXXXXXXX"
ENDLEVEL ;
: LEVELD
A LevelWidth ! A LevelHeight !
0 BloxUsed ! D PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" XOO OOX"
PF" XO OOOX"
PF" X OOOOX"
PF" X OOOX"
PF" X O OO X"
PF" X OOO OX"
PF" XOOOOO X"
PF" XOOOOOO X"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVELE
A LevelWidth ! A LevelHeight !
0 BloxUsed ! E PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" XO OOOO OX"
PF" X O OO O X"
PF" XO O O OX"
PF" X OOOOOO X"
PF" X OOOO X"
PF" X OOOOOO X"
PF" XO OO OX"
PF" XOOO OOOX"
PF" XXXXXXXXXX"
ENDLEVEL ;
: LEVELF
A LevelWidth ! 7 LevelHeight !
0 BloxUsed ! F PuzzleNumber !
BEGINLEVEL
PF" XXXXXXXXXX"
PF" X OOOOOX"
PF" XOO O O X"
PF" X OOO X"
PF" X OO O OOX"
PF" XOOO O X"
PF" XXXXXXXXXX"
ENDLEVEL ;
00 VARIABLE LEVELMEM 60 ALLOT
." LevelMem is at " LEVELMEM . CR
LEVELMEM 60 ERASE
00 VARIABLE MAXLEVEL
: LOADLEVEL
." Load Level Savefile..." CR
" D:STROQ.SAV" R/O OPEN-FILE DUP
IF ." Open Savefile Error:" . CR WAITKEY ELSE
DROP DUP LEVELMEM 60 ROT READ-FILE DUP
IF DROP DROP ELSE
DROP DROP CLOSE-FILE DROP ." ok" CR THEN THEN ;
: SAVELEVEL
." Store Level Savefile..." CR
" D:STROQ.SAV" W/O OPEN-FILE DUP
IF ." Open Savefile Error:" . CR ELSE
DROP DUP LEVELMEM 60 ROT WRITE-FILE DUP
IF ." Save Savefile Error:" . CR ELSE
DROP CLOSE-FILE DROP ." ok" CR THEN THEN ;
: LEVELADDR LEVELMEM @ 4 * LEVELMEM + ;
: >LEVEL ( xt -- )
1 LEVELMEM +! LEVELADDR ! ;
: GETLEVELXT ( -- xt )
LEVELADDR @ CFA ;
: NEXTLEVEL
1 LEVELMEM +!
MAXLEVEL @ LEVELMEM @ < IF
1 LEVELMEM !
THEN
GETLEVELXT EXECUTE ;
' LEVEL1 >LEVEL
' LEVEL2 >LEVEL
' LEVEL3 >LEVEL
' LEVEL4 >LEVEL
' LEVEL5 >LEVEL
' LEVEL6 >LEVEL
' LEVEL7 >LEVEL
' LEVEL8 >LEVEL
' LEVEL9 >LEVEL
' LEVELA >LEVEL
' LEVELB >LEVEL
' LEVELC >LEVEL
' LEVELD >LEVEL
' LEVELE >LEVEL
' LEVELF >LEVEL
LEVELMEM @ MAXLEVEL !
: SAVESCORE
BloxUsed @ LEVELADDR 2+ ! ;
( Footer )
: CLEARFOOTER
FOOTERMEM 28 ERASE ;
: >FOOTER
BC40 FOOTERMEM 28 CMOVE ;
: FOOTER
CLEARFOOTER
0 0 AT ." Main Menu:Solve Puzzle:Reset Puzzle:Help"
>FOOTER ;
: TFOOTER
CLEARFOOTER
0 0 AT ." Start Game : Select Puzzle : Quit : Help"
>FOOTER ;
00 VARIABLE I1
00 VARIABLE I2
: FINV
I2 @ I1 @ DO
FOOTERMEM I + DUP C@ 80 XOR SWAP C!
LOOP ;
00 VARIABLE TSEL
: TMENU
BEGIN
TSEL @
DUP 0= IF 00 I1 ! 0B I2 ! THEN
DUP 1 = IF 0C I1 ! 1B I2 ! THEN
DUP 2 = IF 1C I1 ! 22 I2 ! THEN
3 = IF 23 I1 ! 28 I2 ! THEN
FINV KEY FINV
DUP 2B = IF TSEL @ IF -1 TSEL +! THEN THEN
DUP 2A = IF TSEL @ 3 < IF 1 TSEL +! THEN THEN
9B = UNTIL ;
00 VARIABLE GSEL
: GMENU
BEGIN
GSEL @
DUP 0= IF 00 I1 ! 09 I2 ! THEN
DUP 1 = IF 0A I1 ! 16 I2 ! THEN
DUP 2 = IF 17 I1 ! 23 I2 ! THEN
3 = IF 24 I1 ! 28 I2 ! THEN
FINV KEY FINV
DUP 2B = IF GSEL @ IF -1 GSEL +! THEN THEN
DUP 2A = IF GSEL @ 3 < IF 1 GSEL +! THEN THEN
9B = UNTIL ;
( Picture )
8010 CONSTANT PICBASE
: LOADPIC
" D:STROQ.PIC" R/O OPEN-FILE DUP
IF ." Pic Open Error " . CR BYE ELSE
DROP DUP PICBASE 1C20 ROT READ-FILE DUP
IF ." Pic Load Error " . . CR BYE ELSE
DROP DROP CLOSE-FILE DROP THEN THEN ;
( Font )
8000 400 - CONSTANT FONTBASE
0 VARIABLE SAVEFONT
: LOADFONT
" D:STROQ.FNT" R/O OPEN-FILE DUP
IF ." Font Open Error " . CR BYE ELSE
DROP DUP FONTBASE 400 ROT READ-FILE DUP
IF ." Font Load Error " . . CR BYE ELSE
DROP DROP CLOSE-FILE DROP THEN THEN ;
: SETFONT
CHBAS C@ SAVEFONT C!
FONTBASE 100 / CHBAS C! ;
: RESETFONT
SAVEFONT C@ CHBAS C! ;
: CROSSPOS
curx @ cury @ PMPOS ;
: CURUP
cury @ IF -1 cury +! THEN ;
: CURDOWN
cury @ LevelHeight @ 1 - < IF 1 cury +! THEN ;
: CURLEFT
curx @ IF -1 curx +! THEN ;
: CURRIGHT
curx @ LevelWidth @ 1 - < IF 1 curx +! THEN ;
00 VARIABLE Pulse -2 ALLOT
00 C, 00 C, 00 C, 00 C,
02 C, 02 C, 02 C, 02 C,
04 C, 04 C, 04 C,
06 C, 06 C,
08 C,
0A C,
0C C,
0A C,
08 C,
06 C, 06 C,
04 C, 04 C, 04 C,
02 C, 02 C, 02 C, 02 C,
00 C, 00 C, 00 C, 00 C, 00 C,
00 VARIABLE PulseP
00 VARIABLE Count
: WAIT 0 14 C! BEGIN 14 C@ UNTIL ;
: NOCLICK FF 2DB C! ;
: RESET
GETLEVELXT EXECUTE 0 STROQPTR !
CLS PRINTLEVEL HEADER ;
: DOS
0 HPOS0 C! CLS RESTOREDL CURON STOPMUSIC
SAVELEVEL BYE ;
: SETGAME
80 4 - FONT C! 82 BLUE !
DLI1 SETDLI SETDLGAME
FOOTER CLS HEADER PRINTLEVEL ;
: SETTITLE
0 BLUE !
TFOOTER CLS HEADER
SETDLTITLE DLI1 SETDLI ;
: HELP
RESETDLI CLS 0 HPOS0 C!
CHBAS C@ FONT C! B2 BLUE !
SETDLHELP DLI1 SETDLI
0 0 AT ." Stroq Help "
0 2 AT ." Atari Version
0 3 AT ." (C) 2005 Carsten Strotmann &"
0 4 AT ." Winfried Piegsda"
0 6 AT ." Stroq is OpenSource Software"
0 7 AT ." and Licensed under the GPL"
0 8 AT ." Version 2 or higher"
0 A AT ." How to play:"
0 B AT ." ------------"
0 D AT ." The goal of the game is simple, draw"
0 E AT ." a single continuous line, the stroke"
0 F AT ." from one square to another."
0 10 AT ." When you run the puzzle (Solve Puzzle)"
0 11 AT ." green and blue squares along the line"
0 12 AT ." will flop over (blue becoming green,"
0 13 AT ." green becoming blue). The Puzzle is"
0 14 AT ." solved when all tiles on the row are"
0 15 AT ." the same color."
WAITKEY CLS
RESETDLI
;
: MOVECURSOR
3 GSEL !
BEGIN
?TERMINAL
IF KEY
DUP 1C = IF CURUP THEN
DUP 2D = IF CURUP THEN
DUP 1D = IF CURDOWN THEN
DUP 3D = IF CURDOWN THEN
DUP 1E = IF CURLEFT THEN
DUP 2B = IF CURLEFT THEN
DUP 1F = IF CURRIGHT THEN
DUP 2A = IF CURRIGHT THEN
DUP 9B = IF SETBLOX HEADER THEN
DUP 20 = IF SETBLOX HEADER THEN
DUP 08 = IF HELP SETGAME THEN
DUP 11 = IF DOS THEN
DUP 12 = IF RESET THEN
DUP 13 = IF SOLVE
IF SAVESCORE NEXTLEVEL
THEN
RESET THEN
DUP 1B = IF GMENU
GSEL @
DUP 1 = IF SOLVE IF
SAVESCORE NEXTLEVEL THEN
RESET THEN
DUP 2 = IF RESET THEN
3 = IF HELP SETGAME THEN
THEN
DUP 0D = IF MUSIC @ IF STOPMUSIC
ELSE STARTMUSIC
THEN
THEN
DROP ( 0 0 AT ." SP=" SP@ . )
CROSSPOS
ELSE
WAIT 1 Count +! Count @ 40 AND 0=
IF
PulseP @ 1+ 2F AND PulseP !
Pulse PulseP @ + @ PCOLR0 C!
THEN
THEN
GSEL @ 0 = UNTIL 0 HPOS0 C!
RESETDLI ;
: SELECTPUZZLE
RESETDLI CLS 0 HPOS0 C!
CHBAS C@ FONT C! 32 BLUE !
SETDLHELP DLI1 SETDLI
C 0 AT ." Select Puzzle "
DECIMAL
BEGIN
2 5 AT ." Level:" LEVELMEM @
S>D <# # # # #> TYPE SPACE
2 7 AT
LEVELADDR 2 + @
DUP IF ." Solved with "
S>D <# # # # #> TYPE SPACE
." Blox used."
ELSE
DROP
." Not solved. "
THEN
KEY
DUP 2B = IF LEVELMEM @ 1 >
IF -1 LEVELMEM +!
THEN
THEN
DUP 2A = IF MAXLEVEL @
LEVELMEM @ > IF
1 LEVELMEM +!
THEN
THEN
9B = UNTIL HEX
GETLEVELXT EXECUTE
CLS RESETDLI ;
: TITLE
SETTITLE
TMENU
84 BLUE ! RESETDLI ;
: STROQ
CLS SAVEDL
0 2C6 C! NOCLICK
." Starting Stroq..." CR
( ." Load Font..." CR )
( LOADFONT )
( ." Load Picture..." CR )
( LOADPIC )
LOADLEVEL
0 LEVELMEM !
NEXTLEVEL
INITPM SETMUSIC
BEGIN
TITLE
TSEL @
DUP 0= IF
SETGAME
CROSSPOS MOVECURSOR
THEN
DUP 1 = IF SELECTPUZZLE THEN
DUP 2 = IF DOS THEN
3 = IF HELP THEN
AGAIN
;
." Ready." CR
Downloads#
The Atari Stroq Programm has some quirks when running in an Emulator (such as No InterWiki reference defined in properties for Wiki called "Atari800>http"!). It runs fine on the real hardware.