File:  [gforth] / gforth / arch / misc / sokoban.fs
Revision 1.7: download - view: text, annotated - select for diffs
Mon Dec 31 15:25:18 2012 UTC (9 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright year

    1: \ sokoban - a maze game in FORTH
    2: 
    3: \ Copyright (C) 1995,1997,1998,2000,2003,2004,2007,2012 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: >TARGET
   66: 
   67: : new-maze ( n -- addr ) \ add a new level
   68:     X here mazes rot 1 ?DO X @ LOOP X !
   69:     0 X , 0 X , X here >maze X ! 0 X , ;
   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:     >maze X @ 1 X cells - dup X @ rot + swap X ! 
   75:     bounds ?DO  I c@ X c,  LOOP
   76:     /maze swap - 0 ?DO  bl X c,  LOOP
   77:     >maze X @ X here over X cell+ - swap X ! ;
   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>