\ sokoban - a maze game in FORTH
\ Copyright (C) 1995,1997,1998,2000,2003,2004,2007,2012 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
\ SOKOBAN
\ Sokoban is a visual game of pushing. You (Soko) are represented by the
\ at-sign "@" You may move freely through the maze on unoccupied spaces.
\ The dollar-signs "$" are the rocks you have to push. You can only push
\ one rock at a time, and cannot push a rock through a wall "#" or over
\ another rock. The object is to push the rocks to their goals which are
\ indicated by the periods ".". There are 50 levels, the first of which
\ is shown below.
\ program is ANS FORTH with environmental dependency of case-insensitiv
\ source. Tested with gforth, bigFORTH and pfe
\ bell (7) is replaced with "Wuff!" ;-)
\ (this is a german joke)
\ I don't like the keyboard interpreting CASE-statement either, but
\ was to lazy to use a table.
\ I could have used blocks as level tables, but as I don't have a good
\ block editor for gforth now, I let it be.
Create pn-tab ," 000102030405060708091011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980"
: pn ( n -- ) 2* pn-tab 1+ + 2 type ;
: ;pn [char] ; emit pn ;
: ESC[ &27 emit [char] [ emit ;
: at-xy 1+ swap 1+ swap ESC[ pn ;pn [char] H emit ;
: page ESC[ ." 2J" 0 0 at-xy ;
40 Constant /maze \ maximal maze line
Create maze 1 cells allot /maze 25 * allot \ current maze
Variable mazes 0 mazes ! \ root pointer
Variable soko 0 soko ! \ player position
Variable >maze 0 >maze ! \ current compiled maze
\ score information
Variable rocks 0 rocks ! \ number of rocks left
Variable level# 0 level# ! \ Current level
Variable moves 0 moves ! \ number of moves
Variable score 0 score ! \ total number of scores
UNLOCK
>TARGET
: new-maze ( n -- addr ) \ add a new level
X here mazes rot 1 ?DO X @ LOOP X !
0 X , 0 X , X here >maze X ! 0 X , ;
: count-$ ( addr u -- n ) 0 rot rot
over + swap ?DO I c@ [char] $ = - LOOP ;
: m: ( "string" -- ) \ add a level line (top first!)
-1 parse tuck 2dup count-$
>maze X @ 1 X cells - dup X @ rot + swap X !
bounds ?DO I c@ X c, LOOP
/maze swap - 0 ?DO bl X c, LOOP
>maze X @ X here over X cell+ - swap X ! ;
LOCK
: maze-field ( -- addr n )
maze dup cell+ swap @ chars ;
: .score ( -- )
." Level: " level# @ 2 .r ." Score: " score @ 4 .r
." Moves: " moves @ 6 .r ." Rocks: " rocks @ 2 .r ;
: .maze ( -- ) \ display maze
0 0 at-xy .score
cr maze-field over + swap
DO I /maze type cr /maze chars +LOOP ;
: find-soko ( -- n )
maze-field 0
DO dup I chars + c@ [char] @ =
IF drop I UNLOOP EXIT THEN
LOOP true abort" No player in field!" ;
: level ( n -- flag ) \ finds level n
dup level# !
mazes swap 0
?DO @ dup 0= IF drop false UNLOOP EXIT THEN LOOP
cell+ dup @ rocks !
cell+ dup @ cell+ maze swap chars move
find-soko soko ! true ;
\ now the playing rules as replacement strings
: 'soko ( -- addr ) \ gives player's address
maze cell+ soko @ chars + ;
: apply-rule? ( addr u offset -- flag )
'soko 2swap
\ offset soko-addr addr u
0 DO
over c@ over c@ <>
IF drop 2drop false UNLOOP EXIT THEN
>r over chars + r> char+
LOOP 2drop drop true ;
: apply-rule! ( addr u offset -- )
'soko
2swap
\ offset soko-addr addr u
0 DO
count rot tuck c! rot tuck chars + rot
LOOP 2drop drop ;
: play-rule ( addr1 u1 addr2 u2 offset -- flag )
>r 2swap r@ apply-rule?
IF r> apply-rule! true ELSE r> drop 2drop false THEN ;
\ player may move up, down, left and right
: (move) ( offset -- )
>r 1 moves +!
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 IF r> soko +! EXIT THEN
S" @*." S" &*" r@ play-rule IF r> soko +! EXIT THEN
S" @* " S" &$" r@ play-rule
IF r> soko +! 1 rocks +! -1 score +! EXIT THEN
S" @$." S" @*" r@ play-rule
IF r> soko +! -1 rocks +! 1 score +! EXIT THEN
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 IF r> soko +! EXIT THEN
S" &." S" .&" r@ play-rule IF r> soko +! EXIT THEN
S" &* " S" .&$" r@ play-rule
IF r> soko +! 1 rocks +! -1 score +! EXIT THEN
-1 moves +! r> drop ;
: soko-right 1 (move) ;
: soko-left -1 (move) ;
: soko-down /maze (move) ;
: soko-up /maze negate (move) ;
: print-help
." Move soko '@' with h, j, k or l key (like vi)" cr
." or with vt100 cursor keys." cr ;
Variable redraw
: play-loop ( -- ) redraw on
BEGIN
rocks @ 0=
IF
level# @ 1+ level 0= IF EXIT THEN
redraw on
THEN
key? 0= redraw @ and IF .maze redraw off THEN
key
CASE
[char] ? OF print-help false ENDOF
[char] h OF soko-left redraw on false ENDOF
[char] j OF soko-down redraw on false ENDOF
[char] k OF soko-up redraw on false ENDOF
[char] l OF soko-right redraw on false ENDOF
\ vt100 cursor keys should work too
27 OF key [char] [ <> ENDOF
[char] D OF soko-left redraw on false ENDOF
[char] B OF soko-down redraw on false ENDOF
[char] A OF soko-up redraw on false ENDOF
[char] C OF soko-right redraw on false ENDOF
[char] q OF true ENDOF
false swap ENDCASE
UNTIL ;
\ start game with "sokoban"
: sokoban ( -- )
page 1 level IF play-loop ." Game finished!" THEN ;
001 new-maze
m: #####
m: # #
m: #$ #
m: ### $##
m: # $ $ #
m: ### # ## # ######
m: # # ## ##### ..#
m: # $ $ ..#
m: ##### ### #@## ..#
m: # #########
m: #######
002 new-maze
m: ############
m: #.. # ###
m: #.. # $ $ #
m: #.. #$#### #
m: #.. @ ## #
m: #.. # # $ ##
m: ###### ##$ $ #
m: # $ $ $ $ #
m: # # #
m: ############
003 new-maze
m: ########
m: # @#
m: # $#$ ##
m: # $ $#
m: ##$ $ #
m: ######### $ # ###
m: #.... ## $ $ #
m: ##... $ $ #
m: #.... ##########
m: ########
004 new-maze
m: ########
m: # ....#
m: ############ ....#
m: # # $ $ ....#
m: # $$$#$ $ # ....#
m: # $ $ # ....#
m: # $$ #$ $ $########
m: # $ # #
m: ## #########
m: # # ##
m: # $ ##
m: # $$#$$ @#
m: # # ##
m: ###########
005 new-maze
m: #####
m: # #####
m: # #$## #
m: # $ #
m: ######### ### #
m: #.... ## $ $###
m: #.... $ $$ ##
m: #.... ##$ $ @#
m: ######### $ ##
m: # $ $ #
m: ### ## #
m: # #
m: ######
006 new-maze
m: ###### ###
m: #.. # ##@##
m: #.. ### #
m: #.. $$ #
m: #.. # # $ #
m: #..### # $ #
m: #### $ #$ #
m: # $# $ #
m: # $ $ #
m: # ## #
m: #########
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>