version 1.1, 1995/10/26 22:48:42
|
version 1.9, 2007/12/31 19:02:24
|
Line 1
|
Line 1
|
\ sokoban - a maze game in FORTH |
\ sokoban - a maze game in FORTH |
|
|
|
\ Copyright (C) 1995,1997,1998,2003,2007 Free Software Foundation, Inc. |
|
|
|
\ This file is part of Gforth. |
|
|
|
\ Gforth is free software; you can redistribute it and/or |
|
\ modify it under the terms of the GNU General Public License |
|
\ as published by the Free Software Foundation, either version 3 |
|
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ GNU General Public License for more details. |
|
|
|
\ You should have received a copy of the GNU General Public License |
|
\ along with this program. If not, see http://www.gnu.org/licenses/. |
|
|
\ Contest from Rick VanNorman in comp.lang.forth |
\ Contest from Rick VanNorman in comp.lang.forth |
|
|
\ SOKOBAN |
\ SOKOBAN |
Line 13
|
Line 30
|
\ is shown below. |
\ is shown below. |
|
|
\ program is ANS FORTH with environmental dependency of case-insensitiv |
\ program is ANS FORTH with environmental dependency of case-insensitiv |
\ source. Tested with gforth and bigFORTH |
\ source. Tested with gforth, bigFORTH and pfe |
|
|
\ really uses "dump" terminal: No PAGE, no AT-XY to speed things up |
\ bell (7) is replaced with "Wuff!" ;-) |
\ Even bell (7) is replaced with "Wuff!" ;-) |
|
\ (this is a german joke) |
\ (this is a german joke) |
\ I don't like the keyboard interpreting CASE-statement either, but |
\ I don't like the keyboard interpreting CASE-statement either, but |
\ was to lazy to use a table. |
\ was to lazy to use a table. |
Line 29 Create maze 1 cells allot /maze 25 * al
|
Line 45 Create maze 1 cells allot /maze 25 * al
|
Variable mazes 0 mazes ! \ root pointer |
Variable mazes 0 mazes ! \ root pointer |
Variable soko 0 soko ! \ player position |
Variable soko 0 soko ! \ player position |
Variable >maze 0 >maze ! \ current compiled maze |
Variable >maze 0 >maze ! \ current compiled maze |
>maze off |
|
|
|
\ score information |
\ score information |
|
|
Line 42 Variable score 0 score ! \ total nu
|
Line 57 Variable score 0 score ! \ total nu
|
here mazes rot 1 ?DO @ LOOP ! |
here mazes rot 1 ?DO @ LOOP ! |
0 , 0 , here >maze ! 0 , ; |
0 , 0 , here >maze ! 0 , ; |
: count-$ ( addr u -- n ) 0 rot rot |
: count-$ ( addr u -- n ) 0 rot rot |
bounds ?DO I c@ [char] $ = - LOOP ; |
over + swap ?DO I c@ [char] $ = - LOOP ; |
: m: ( "string" -- ) \ add a level line (top first!) |
: m: ( "string" -- ) \ add a level line (top first!) |
-1 parse tuck 2dup count-$ >maze @ 1 cells - +! |
-1 parse tuck 2dup count-$ >maze @ 1 cells - +! |
here swap move dup allot |
here swap move dup allot |
Line 58 Variable score 0 score ! \ total nu
|
Line 73 Variable score 0 score ! \ total nu
|
|
|
: .maze ( -- ) \ display maze |
: .maze ( -- ) \ display maze |
0 0 at-xy .score |
0 0 at-xy .score |
cr maze-field bounds |
cr maze-field over + swap |
DO I /maze type cr /maze chars +LOOP ; |
DO I /maze type cr /maze chars +LOOP ; |
|
|
: find-soko ( -- n ) |
: find-soko ( -- n ) |
Line 99 Variable score 0 score ! \ total nu
|
Line 114 Variable score 0 score ! \ total nu
|
|
|
: play-rule ( addr1 u1 addr2 u2 offset -- flag ) |
: play-rule ( addr1 u1 addr2 u2 offset -- flag ) |
>r 2swap r@ apply-rule? |
>r 2swap r@ apply-rule? |
IF r> apply-rule! true ELSE rdrop 2drop false THEN ; |
IF r> apply-rule! true ELSE r> drop 2drop false THEN ; |
|
|
\ player may move up, down, left and right |
\ player may move up, down, left and right |
|
|
Line 120 Variable score 0 score ! \ total nu
|
Line 135 Variable score 0 score ! \ total nu
|
S" &." S" .&" r@ play-rule IF r> soko +! EXIT THEN |
S" &." S" .&" r@ play-rule IF r> soko +! EXIT THEN |
S" &* " S" .&$" r@ play-rule |
S" &* " S" .&$" r@ play-rule |
IF r> soko +! 1 rocks +! -1 score +! EXIT THEN |
IF r> soko +! 1 rocks +! -1 score +! EXIT THEN |
-1 moves +! rdrop ; |
S" &$." S" .@*" r@ play-rule |
|
IF r> soko +! -1 rocks +! 1 score +! EXIT THEN |
|
-1 moves +! r> drop ; |
|
|
1 move: soko-right |
1 move: soko-right |
-1 move: soko-left |
-1 move: soko-left |
Line 155 Variable score 0 score ! \ total nu
|
Line 172 Variable score 0 score ! \ total nu
|
[char] C OF soko-right false ENDOF |
[char] C OF soko-right false ENDOF |
|
|
[char] q OF true ENDOF |
[char] q OF true ENDOF |
ENDCASE |
false swap ENDCASE |
UNTIL ; |
UNTIL ; |
|
|
\ start game with "sokoban" |
\ start game with "sokoban" |
|
|
: sokoban ( -- ) |
: sokoban ( -- ) |
1 level IF play-loop ." Game finished!" THEN ; |
page 1 level IF play-loop ." Game finished!" THEN ; |
|
|
001 new-maze |
001 new-maze |
m: ##### |
m: ##### |