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>
![[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