Annotation of gforth/arch/misc/sokoban.fs, revision 1.1

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>