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