1: \ sokoban - a maze game in FORTH
2:
3: \ Contest from Rick VanNorman in comp.lang.forth
4:
5: \ SOKOBAN
6:
7: \ Sokoban is a visual game of pushing. You (Soko) are represented by the
8: \ at-sign "@" You may move freely through the maze on unoccupied spaces.
9: \ The dollar-signs "$" are the rocks you have to push. You can only push
10: \ one rock at a time, and cannot push a rock through a wall "#" or over
11: \ another rock. The object is to push the rocks to their goals which are
12: \ indicated by the periods ".". There are 50 levels, the first of which
13: \ is shown below.
14:
15: \ program is ANS FORTH with environmental dependency of case-insensitiv
16: \ source. Tested with gforth, bigFORTH and pfe
17:
18: \ bell (7) is replaced with "Wuff!" ;-)
19: \ (this is a german joke)
20: \ I don't like the keyboard interpreting CASE-statement either, but
21: \ was to lazy to use a table.
22: \ I could have used blocks as level tables, but as I don't have a good
23: \ block editor for gforth now, I let it be.
24:
25: Create pn-tab ," 000102030405060708091011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980"
26:
27: : pn ( n -- ) 2* pn-tab 1+ + 2 type ;
28: : ;pn [char] ; emit pn ;
29: : ESC[ &27 emit [char] [ emit ;
30: : at-xy 1+ swap 1+ swap ESC[ pn ;pn [char] H emit ;
31: : page ESC[ ." 2J" 0 0 at-xy ;
32:
33: 40 Constant /maze \ maximal maze line
34:
35: Create maze 1 cells allot /maze 25 * allot \ current maze
36: Variable mazes 0 mazes ! \ root pointer
37: Variable soko 0 soko ! \ player position
38: Variable >maze 0 >maze ! \ current compiled maze
39:
40: \ score information
41:
42: Variable rocks 0 rocks ! \ number of rocks left
43: Variable level# 0 level# ! \ Current level
44: Variable moves 0 moves ! \ number of moves
45: Variable score 0 score ! \ total number of scores
46:
47: UNLOCK
48: >MINIMAL
49:
50: : new-maze ( n -- addr ) \ add a new level
51: T here mazes rot 1 H ?DO T @ H LOOP T !
52: 0 , 0 , here >maze ! 0 , H ;
53: : count-$ ( addr u -- n ) 0 rot rot
54: over + swap ?DO I c@ [char] $ = - LOOP ;
55: : m: ( "string" -- ) \ add a level line (top first!)
56: -1 parse tuck 2dup count-$
57: T >maze @ 1 cells - dup @ rot + swap ! H
58: bounds ?DO I c@ T c, H LOOP
59: /maze swap - 0 ?DO bl T c, H LOOP
60: T >maze @ here over cell+ - swap ! H ;
61:
62: LOCK
63:
64: : maze-field ( -- addr n )
65: maze dup cell+ swap @ chars ;
66:
67: : .score ( -- )
68: ." Level: " level# @ 2 .r ." Score: " score @ 4 .r
69: ." Moves: " moves @ 6 .r ." Rocks: " rocks @ 2 .r ;
70:
71: : .maze ( -- ) \ display maze
72: 0 0 at-xy .score
73: cr maze-field over + swap
74: DO I /maze type cr /maze chars +LOOP ;
75:
76: : find-soko ( -- n )
77: maze-field 0
78: DO dup I chars + c@ [char] @ =
79: IF drop I UNLOOP EXIT THEN
80: LOOP true abort" No player in field!" ;
81:
82: : level ( n -- flag ) \ finds level n
83: dup level# !
84: mazes swap 0
85: ?DO @ dup 0= IF drop false UNLOOP EXIT THEN LOOP
86: cell+ dup @ rocks !
87: cell+ dup @ cell+ maze swap chars move
88: find-soko soko ! true ;
89:
90: \ now the playing rules as replacement strings
91:
92: : 'soko ( -- addr ) \ gives player's address
93: maze cell+ soko @ chars + ;
94:
95: : apply-rule? ( addr u offset -- flag )
96: 'soko 2swap
97: \ offset soko-addr addr u
98: 0 DO
99: over c@ over c@ <>
100: IF drop 2drop false UNLOOP EXIT THEN
101: >r over chars + r> char+
102: LOOP 2drop drop true ;
103:
104: : apply-rule! ( addr u offset -- )
105: 'soko
106: 2swap
107: \ offset soko-addr addr u
108: 0 DO
109: count rot tuck c! rot tuck chars + rot
110: LOOP 2drop drop ;
111:
112: : play-rule ( addr1 u1 addr2 u2 offset -- flag )
113: >r 2swap r@ apply-rule?
114: IF r> apply-rule! true ELSE r> drop 2drop false THEN ;
115:
116: \ player may move up, down, left and right
117:
118: : (move) ( offset -- )
119: >r 1 moves +!
120: S" @ " S" @" r@ play-rule IF r> soko +! EXIT THEN
121: S" @." S" &" r@ play-rule IF r> soko +! EXIT THEN
122: S" @$ " S" @$" r@ play-rule IF r> soko +! EXIT THEN
123: S" @*." S" &*" r@ play-rule IF r> soko +! EXIT THEN
124: S" @* " S" &$" r@ play-rule
125: IF r> soko +! 1 rocks +! -1 score +! EXIT THEN
126: S" @$." S" @*" r@ play-rule
127: IF r> soko +! -1 rocks +! 1 score +! EXIT THEN
128: S" &*." S" .&*" r@ play-rule IF r> soko +! EXIT THEN
129: S" &$ " S" .@$" r@ play-rule IF r> soko +! EXIT THEN
130: S" & " S" .@" r@ play-rule IF r> soko +! EXIT THEN
131: S" &." S" .&" r@ play-rule IF r> soko +! EXIT THEN
132: S" &* " S" .&$" r@ play-rule
133: IF r> soko +! 1 rocks +! -1 score +! EXIT THEN
134: -1 moves +! r> drop ;
135:
136: : soko-right 1 (move) ;
137: : soko-left -1 (move) ;
138: : soko-down /maze (move) ;
139: : soko-up /maze negate (move) ;
140:
141: : print-help
142: ." Move soko '@' with h, j, k or l key (like vi)" cr
143: ." or with vt100 cursor keys." cr ;
144:
145: Variable redraw
146:
147: : play-loop ( -- ) redraw on
148: BEGIN
149: rocks @ 0=
150: IF
151: level# @ 1+ level 0= IF EXIT THEN
152: redraw on
153: THEN
154: key? 0= redraw @ and IF .maze redraw off THEN
155: key
156: CASE
157: [char] ? OF print-help false ENDOF
158:
159: [char] h OF soko-left redraw on false ENDOF
160: [char] j OF soko-down redraw on false ENDOF
161: [char] k OF soko-up redraw on false ENDOF
162: [char] l OF soko-right redraw on false ENDOF
163:
164: \ vt100 cursor keys should work too
165: 27 OF key [char] [ <> ENDOF
166: [char] D OF soko-left redraw on false ENDOF
167: [char] B OF soko-down redraw on false ENDOF
168: [char] A OF soko-up redraw on false ENDOF
169: [char] C OF soko-right redraw on false ENDOF
170:
171: [char] q OF true ENDOF
172: false swap ENDCASE
173: UNTIL ;
174:
175: \ start game with "sokoban"
176:
177: : sokoban ( -- )
178: page 1 level IF play-loop ." Game finished!" THEN ;
179:
180: 001 new-maze
181: m: #####
182: m: # #
183: m: #$ #
184: m: ### $##
185: m: # $ $ #
186: m: ### # ## # ######
187: m: # # ## ##### ..#
188: m: # $ $ ..#
189: m: ##### ### #@## ..#
190: m: # #########
191: m: #######
192: 002 new-maze
193: m: ############
194: m: #.. # ###
195: m: #.. # $ $ #
196: m: #.. #$#### #
197: m: #.. @ ## #
198: m: #.. # # $ ##
199: m: ###### ##$ $ #
200: m: # $ $ $ $ #
201: m: # # #
202: m: ############
203: 003 new-maze
204: m: ########
205: m: # @#
206: m: # $#$ ##
207: m: # $ $#
208: m: ##$ $ #
209: m: ######### $ # ###
210: m: #.... ## $ $ #
211: m: ##... $ $ #
212: m: #.... ##########
213: m: ########
214: 004 new-maze
215: m: ########
216: m: # ....#
217: m: ############ ....#
218: m: # # $ $ ....#
219: m: # $$$#$ $ # ....#
220: m: # $ $ # ....#
221: m: # $$ #$ $ $########
222: m: # $ # #
223: m: ## #########
224: m: # # ##
225: m: # $ ##
226: m: # $$#$$ @#
227: m: # # ##
228: m: ###########
229: 005 new-maze
230: m: #####
231: m: # #####
232: m: # #$## #
233: m: # $ #
234: m: ######### ### #
235: m: #.... ## $ $###
236: m: #.... $ $$ ##
237: m: #.... ##$ $ @#
238: m: ######### $ ##
239: m: # $ $ #
240: m: ### ## #
241: m: # #
242: m: ######
243: 006 new-maze
244: m: ###### ###
245: m: #.. # ##@##
246: m: #.. ### #
247: m: #.. $$ #
248: m: #.. # # $ #
249: m: #..### # $ #
250: m: #### $ #$ #
251: m: # $# $ #
252: m: # $ $ #
253: m: # ## #
254: m: #########
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sokoban.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / arch / misc