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