\ for Jacques Barzun on his 88th birthday 30NOV95 \ revised 28MAY96 : RULES 0 21 AT-XY ." Sokoban is a game of pushing. You are Soko " ." (@). Your aim is to push" CR ." rocks ($) to their goals (.). You can push " ." only one rock at a time," CR ." and you can neither step nor push through a " ." wall (#). Best wishes!" ; \ miscellaneous tools : CHAR- ( a - a') 1 CHARS - ; : CHAR/ ( n - n') 1 CHARS / ; : DOWNOVER ( n1 n2 n3 - n1 n2 n1 n3) >R OVER R> ; : OFF ( a) 0 SWAP ! ; : INCR ( a) 1 SWAP +! ; : DECR ( a) -1 SWAP +! ; : @! ( n1 a - n2) DUP @ >R ! R> ; : FOR ( a u - a' a) OVER + SWAP ; : BETWEEN ( n1 n2 n3 - f) 1+ WITHIN ; : c>C ( c - c') DUP [CHAR] a [CHAR] z BETWEEN BL AND XOR ; : BIGKEY ( - c) KEY c>C ; : BEEP 7 EMIT ; \ implementation dependent? : CSEARCH ( c a u - u'|0) 0 ?DO 2DUP C@ = IF 2DROP I 1+ UNLOOP EXIT THEN CHAR+ LOOP 2DROP FALSE ; \ get-number from Woehr, Forth: The New Model, p. 153 : GET-NUMBER ( - d f) 0. PAD 84 BLANK PAD 84 ACCEPT PAD SWAP -TRAILING >NUMBER NIP 0= ; : #INPUT ( - #) GET-NUMBER DROP D>S ; \ game pieces and variables CHAR @ CONSTANT SOKO \ our hero BL CONSTANT VACANT CHAR $ CONSTANT ROCK CHAR * CONSTANT GEM CHAR . CONSTANT GOAL CHAR # CONSTANT WALL VARIABLE where's-soko \ Soko's position in the maze VARIABLE rocks VARIABLE gems VARIABLE steps VARIABLE pushes VARIABLE no-nos \ maze ground 20 CONSTANT #ROWS 20 CONSTANT #COLS #ROWS #COLS * CONSTANT MAP MAP CHARS CONSTANT TERRITORY #COLS CHARS CONSTANT WIDTH CREATE MAZE TERRITORY ALLOT : CLEAR-MAZE MAZE MAP BLANK ; : MAZE-XY ( a - col row) MAZE - CHAR/ #COLS /MOD ; : AT-MAZE ( a) MAZE-XY AT-XY ; \ sokoban.dat contains 85 mazes, \ each delimited by a line that begins with ( CHAR ( CONSTANT DELIMITER 0 VALUE MAZEFILE VARIABLE maze# : OPEN-MAZES S" sokoban.dat" R/O OPEN-FILE ABORT" OPEN-MAZES problem" TO MAZEFILE ; : CLOSE-MAZES MAZEFILE CLOSE-FILE ABORT" CLOSE-MAZES problem" ; : >BOF ( fileid) 0. ROT REPOSITION-FILE ABORT" >BOF problem" ; : MAZE-LINE ( - a u) PAD DUP [ #COLS 2 + ] LITERAL MAZEFILE READ-LINE ABORT" MAZE-LINE problem" DROP ; : CHOOSE ( - n) 0 BEGIN DROP PAGE ." Maze Number (1 to 85):" #INPUT DUP 1 85 BETWEEN UNTIL DUP maze# ! ; \ use = -1 AND + if true-flag <> -1 : SEEK ( n) MAZEFILE >BOF BEGIN DUP WHILE MAZE-LINE DROP C@ DELIMITER = + REPEAT DROP ; : GET CLEAR-MAZE MAZE BEGIN MAZE-LINE OVER C@ DELIMITER <> WHILE DOWNOVER CMOVE WIDTH + REPEAT 2DROP DROP ; : .ROW ( a) #COLS -TRAILING TYPE CR ; : SHOW PAGE MAZE TERRITORY FOR DO I .ROW WIDTH +LOOP ; \ store VACANT in Soko's spot, \ and store Soko's spot in where's-soko : !SOKO ( a) VACANT OVER C! where's-soko ! ; : TALLY rocks OFF gems OFF MAZE MAP 0 DO COUNT DUP ROCK = IF DROP rocks INCR ELSE DUP GEM = IF DROP gems INCR ELSE SOKO = IF DUP CHAR- !SOKO THEN THEN THEN LOOP DROP ; : AMAZE CHOOSE SEEK GET SHOW TALLY ; : SCOREBOARD steps OFF pushes OFF no-nos OFF 40 0 AT-XY ." MAZE: " maze# ? 40 2 AT-XY ." GEMS:" 40 4 AT-XY ." ROCKS:" 40 6 AT-XY ." STEPS:" 40 8 AT-XY ." PUSHES:" 40 10 AT-XY ." NO-NOS:" 40 13 AT-XY ." E/I/8" 40 14 AT-XY ." S/J/4 < > F/L/6 Q quits" 40 15 AT-XY ." C/</2" ; : .SCORE 48 2 AT-XY gems ? 48 4 AT-XY rocks ? 48 6 AT-XY steps ? 48 8 AT-XY pushes ? 48 10 AT-XY no-nos ? ; : .SOKO where's-soko @ MAZE-XY 2DUP AT-XY SOKO EMIT AT-XY ; : STATUS .SCORE .SOKO ; \ In the following stack comments, \ a1 is where Soko wants to go to \ a2 is where a rock or gem in a1 would be pushed to \ moves \ when moving Soko, redisplay old spot, \ and store Soko's new spot : MOVE-SOKO ( a1) where's-soko @! DUP AT-MAZE C@ EMIT ; \ move without pushing : STEP ( a1 a2) DROP MOVE-SOKO steps INCR ; \ when pushing a rock or gem, \ put rock/gem in a2; restore vacant/goal to a1, \ and move soko to a1 : PUT ( rock|gem a2) 2DUP C! AT-MAZE EMIT ; : PUSH ( a2 rock|gem) SWAP PUT pushes INCR ; : UNDER-SOKO ( a1 vacant|goal) OVER C! MOVE-SOKO ; : PUSH-ROCK ( a1 a2) ROCK PUSH VACANT UNDER-SOKO ; : PUSH-GEM ( a1 a2) GEM PUSH GOAL UNDER-SOKO ; \ a rock pushed to a goal becomes a gem : +GEM ( a1 a2) GEM PUSH VACANT UNDER-SOKO gems INCR rocks DECR ; \ a gem pushed to a spot that's vacant becomes a rock : -GEM ( a1 a2) ROCK PUSH GOAL UNDER-SOKO gems DECR rocks INCR ; \ illegal move : NO-NO ( a1 a2) 2DROP BEEP no-nos INCR ; \ moves are e/w/s/n 1 CHARS CONSTANT EAST -1 CHARS CONSTANT WEST WIDTH CONSTANT SOUTH WIDTH NEGATE CONSTANT NORTH \ compute next spot and the spot beyond \ don't care if a2 is outside of maze, \ since a1 must then be a wall : WARD ( e|w|s|n - a1 a2) DUP where's-soko @ + DUP ROT + ; \ what Soko might see up ahead CREATE LOOKS 5 C, VACANT C, GOAL C, ROCK C, GEM C, WALL C, \ 0 max keeps out-of-maze a2 within the jump table : SIGHT ( a - n|0) C@ LOOKS COUNT CSEARCH 1- 0 MAX ; : PROSPECT ( a1 a2 - n1 n2) >R SIGHT R> SIGHT ; \ 2jump adapted from Dwight Elvey's 2array, \ comp.lang.forth, 25JUL95 : CELL* ( n1 n2...nn n - n1cells n2cells...nncells) DUP 0 ?DO DUP ROLL CELLS SWAP LOOP DROP ; : INDEX ( u a n - a') 0 DO DUP , OVER + LOOP NIP ; : JUMP ( n a - a') SWAP CELLS + ; : 2JUMP CREATE ( #x's #y's - u) TUCK \ need index entry for each y 2 CELL* \ #x's and #y's * CELL HERE + \ 1st index entry ROT INDEX \ make index HERE - \ space to allot DOES> ( x y - a) JUMP @ JUMP ; \ is from Brodie \ Thinking FORTH, reprint edition, p. 223 : IS ' , ; : ARE ( n) 0 DO IS LOOP ; 5 5 2JUMP OUTCOME DROP \ n1 vacant goal rock gem wall \ n2 5 ARE STEP STEP PUSH-ROCK -GEM NO-NO \ vacant 5 ARE STEP STEP +GEM PUSH-GEM NO-NO \ goal 5 ARE STEP STEP NO-NO NO-NO NO-NO \ rock 5 ARE STEP STEP NO-NO NO-NO NO-NO \ gem 5 ARE STEP STEP NO-NO NO-NO NO-NO \ wall : HO! ( a1 a2) 2DUP PROSPECT OUTCOME @ EXECUTE STATUS ; \ keys for lefties, righties, and numerists \ ignore invalid keys : UP ( c - u|0) S" EI8" CSEARCH ; : LEFT ( c - u|0) S" SJ4" CSEARCH ; : RIGHT ( c - u|0) S" FL6" CSEARCH ; : DOWN ( c - u|0) S" C,<2" CSEARCH ; : Q= ( c - f) [CHAR] Q = ; \ sokoban : PLAY AMAZE RULES SCOREBOARD STATUS BEGIN BIGKEY DUP UP IF NORTH WARD HO! ELSE DUP DOWN IF SOUTH WARD HO! ELSE DUP RIGHT IF EAST WARD HO! ELSE DUP LEFT IF WEST WARD HO! THEN THEN THEN THEN Q= rocks @ 0= OR UNTIL ; : DONE ( - f) 40 17 AT-XY ." PLAY AGAIN (y/n)?" BIGKEY [CHAR] Y <> ; : SOKOBAN OPEN-MAZES BEGIN PLAY DONE UNTIL CLOSE-MAZES ; SOKOBAN
Leo Wong hello@albany.net