Subversion Repositories forth-cpu

; ==== Sokoban: Instructions ===================================

To run, load the next blocks 9 blocks, which contain the code

for the Sokoban game. The object of the game is to maneuver the

boulders (*) onto the pads (.) with the player character (@/~),

until all the bolders are on the pads. Sokoban levels are

stored one per block. To play:

  $2A sokoban

Would load a game stored in block '$2A' and begin playing.

The WASD keys move the player around, 'h' is for help, and

'q' quits.

\ ==== Sokoban 1/9 =============================================

\ only forth definitions hex

\ variable sokoban-wordlist sokoban-wordlist +order definitions

blk @ 1- constant help-block

char X constant wall

char * constant boulder

char . constant off

char & constant on

char @ constant player

char ~ constant player+ ( player + off pad )

$10    constant l/b     ( lines   per block )

$40    constant c/b     ( columns per block )

     7 constant bell    ( bell character )

variable position  ( current player position )

variable moves     ( moves made by player )

create rule 3 c, 0 c, 0 c, 0 c,

\ ==== Sokoban 2/9 =============================================

: n1+ swap 1+ swap ; ( n n -- n n )

: match              ( a a -- f )

  n1+ ( replace with umin of both counts? )

  count

  for aft

    count rot count rot <> if 2drop rdrop 0 exit then

  then next 2drop -1 ;

: beep bell emit ; ( -- )

: ?apply           ( a a a -- a, R: ? -- ?| )

  >r over swap match if drop r> rdrop exit then rdrop ;

\ ==== Sokoban 3/9 =============================================

: apply ( a -- a )

 $" @ "  $"  @"  ?apply

 $" @."  $"  ~"  ?apply

 $" @* " $"  @*" ?apply

 $" @*." $"  @&" ?apply

 $" @&." $"  ~&" ?apply

 $" @& " $"  ~*" ?apply

 $" ~ "  $" .@"  ?apply

 $" ~."  $" .~"  ?apply

 $" ~* " $" .@*" ?apply

 $" ~*." $" .@&" ?apply

 $" ~&." $" .~&" ?apply

 $" ~& " $" .~*" ?apply beep ;

\ ==== Sokoban 4/9 =============================================

: pack ( c0...cn b n -- )

  2dup swap c! for aft 1+ tuck c! then next drop ;

: locate ( b u c -- u f )

  >r

  begin

    ?dup

  while

    1- 2dup + c@ r@ = if nip rdrop -1 exit then

  repeat

  rdrop

  drop

  0 0 ;

\ ==== Sokoban 5/9 =============================================

: 2* 1 lshift ; ( u -- )

: relative swap c/b * + + ( $3FF and ) ; ( +x +y pos -- pos )

: +position position @ relative ; ( +x +y -- pos )

: double 2* swap 2* swap ;  ( u u -- u u )

: arena blk @ block b/buf ; ( -- b u )

: >arena arena drop + ;     ( pos -- a )

: fetch                     ( +x +y -- a a a )

  2dup   +position >arena >r

  double +position >arena r> swap

  position @ >arena -rot ;

: rule@ fetch c@ rot c@ rot c@ rot ; ( +x +y -- c c c )

: 3reverse -rot swap ;               ( 1 2 3 -- 3 2 1 )

: rule! rule@ 3reverse rule 3 pack ; ( +x +y -- )

: think 2dup rule! rule apply >r fetch r> ; ( +x +y --a a a a )

: count! count rot c! ;              ( a a -- )

\ ==== Sokoban 6/9 =============================================

\ 'act' could be made to be more elegant, but it works, it

\ handles rules of length 2 and length 3

: act ( a a a a -- )

  count swap >r 2 =

  if

     drop swap r> count! count!

  else

     3reverse r> count! count! count!

  then drop ;

: #boulders ( -- n )

   0 arena

   for aft

     dup c@ boulder = if n1+ then

     1+

   then next drop ;

\ ==== Sokoban 7/9 =============================================

: .boulders  ." BOULDERS: " #boulders u. cr ; ( -- )

: .moves    ." MOVES: " moves    @ u. cr ; ( -- )

: .help     ." WASD - MOVEMENT" cr ." H    - HELP" cr ; ( -- )

: .maze blk @ list ;                  ( -- )

: show ( page cr ) .maze .boulders .moves .help ; ( -- )

: solved? #boulders 0= ;               ( -- )

: finished? solved? if 1 throw then ; ( -- )

: instructions blk @ help-block list block drop key drop ;

: where >r arena r> locate ;          ( c -- u f )

: player? player where 0= if drop player+ where else -1 then ;

: player! player? 0= throw position ! ; ( -- )

: start player! 0 moves ! ;           ( -- )

: .winner show cr ." SOLVED!" cr ;    ( -- )

: .quit cr ." Quitter!" cr ;          ( -- )

: finish 1 = if .winner exit then .quit ; ( n -- )

\ ==== Sokoban 8/9 =============================================

: rules think act player! ;           ( +x +y -- )

: +move 1 moves +! ;                  ( -- )

: ?ignore over <> if rdrop then ;     ( c1 c2 --, R: x -- | x )

: left  [char] a ?ignore -1  0 rules +move ; ( c -- c )

: right [char] d ?ignore  1  0 rules +move ; ( c -- c )

: up    [char] w ?ignore  0 -1 rules +move ; ( c -- c )

: down  [char] s ?ignore  0  1 rules +move ; ( c -- c )

: help  [char] h ?ignore instructions ; ( c -- c )

: end   [char] q ?ignore 2 throw ; ( c -- | c, R ? -- | ? )

: default drop ;  ( c -- )

: command up down left right help end default finished? ;

: maze! block drop ; ( k -- )

: input key ;        ( -- c )

\ ==== Sokoban 9/9 =============================================

\ sokoban-wordlist -order definitions

\ sokoban-wordlist +order

: sokoban ( k -- )

  maze! start

  begin

    show input ' command catch ?dup

  until finish ;

; ==== Sokoban Map 1 ===========================================

                    XXXXX

                    X   X

                    X*  X

                  XXX  *XXX

                  X  *  * X

                XXX X XXX X     XXXXXX

                X   X XXX XXXXXXX  ..X

                X *  *             ..X

                XXXXX XXXX X@XXXX  ..X

                    X      XXX  XXXXXX

                    XXXXXXXX

; ==== Sokoban Map 2 ===========================================

               XXXXXXXXXXXX

               X..  X     XXX

               X..  X *  *  X

               X..  X*XXXX  X

               X..    @ XX  X

               X..  X X  * XX

               XXXXXX XX* * X

                 X *  * * * X

                 X    X     X

                 XXXXXXXXXXXX

; ==== Sokoban Map 3 ===========================================

                       XXXXXXXX

                       X     @X

                       X *X* XX

                       X *  *X

                       XX* * X

               XXXXXXXXX * X XXX

               X....  XX *  *  X

               XX...    *  *   X

               X....  XXXXXXXXXX

               XXXXXXXX

; ==== Sokoban Map 4 ===========================================

                             XXXXXXXX

                             X  ....X

                  XXXXXXXXXXXX  ....X

                  X    X  * *   ....X

                  X ***X*  * X  ....X

                  X  *     * X  ....X

                  X ** X* * *XXXXXXXX

               XXXX  * X     X

               X   X XXXXXXXXX

               X    *  XX

               X **X** @X

               X   X   XX

               XXXXXXXXX

\ ==== Game of Life: 1/4 =======================================

\ This is a Game Of Life implementation, originally from

\ . It has been adapted so

\ instead of blocks it uses 1KiB buffers at arbitrary memory

\ locations.

   $40 constant c/b

   $10 constant l/b

c/b 1- constant c/b>

l/b 1- constant l/b>

    bl constant off

char * constant on

variable state1

variable state2

variable statep

\ ==== Game of Life: 2/4 =======================================

: wrapy dup 0< if drop l/b> then dup l/b> > if drop 0 then ;

: wrapx dup 0< if drop c/b> then dup c/b> > if drop 0 then ;

: wrap  wrapy swap wrapx swap ;

: row c/b * + ; ( a u -- a )

: deceased? wrap row state2 @ ( block ) + c@ on <> ;

: living?  deceased? 0= ;

: (-1,-1) 2dup 1- swap 1- swap living? 1 and ;

: (0,-1)  >r 2dup 1- living? 1 and r> + ;

: (1,-1)  >r 2dup 1- swap 1+ swap living? 1 and r> + ;

: (-1,0)  >r 2dup swap 1- swap living? 1 and r> + ;

: (1,0)   >r 2dup swap 1+ swap living? 1 and r> + ;

: (-1,1)  >r 2dup 1+ swap 1- swap living? 1 and r> + ;

: (0,1)   >r 2dup 1+ living? 1 and r> + ;

: (1,1)   >r 1+ swap 1+ swap living? 1 and r> + ;

: mates (-1,-1) (0,-1) (1,-1) (-1,0) (1,0) (-1,1) (0,1) (1,1) ;

\ ==== Game of Life: 3/4 =======================================

: born?  mates 3 = ;

: survives?  2dup living? -rot mates 2 = and ;

: lives?  2dup born? -rot survives? or ;        ( u u -- )

: newstate  state1 @ ( block update ) statep ! ; ( -- )

: state!  statep @ c! 1 statep +! ;             ( c -- )

: alive  on state! ;                            ( -- )

: dead  off state! ;                            ( -- )

: cell?  2dup swap lives? if alive else dead then ; ( u u -- )

: rows   0 begin dup c/b < while cell? 1+ repeat drop ;

: iterate-block 0 begin dup l/b < while rows 1+ repeat drop ;

: generation  state2 @ state1 @ state2 ! state1 ! ;

: iterate  newstate iterate-block generation ; ( -- )

: done?  key [char] q = ;                      ( -- f )

: prompt  cr ." q to quit" cr ;                ( -- )

: .line l/b> swap - row c/b type cr ;          ( b u -- )

\ ==== Game of Life: 4/4 =======================================

: view state2 @ l/b> for dup r@ .line next drop prompt ;

\ : view (  page ) state2 @ list prompt ;      ( -- )

: game  begin page view iterate done? until ;  ( -- )

: life state2 ! state1 ! game ;                ( a a -- )

cr .( Usage: $3000 $32 block life ) cr

; ==== Game of Life: Glider ====================================

              ***

              *

               *

'2@' retrieves two consecutive cells from an address 'a'. The

word forms a pair with '2!', which stores two cells at two

consecutive addresses.

Usage:

'aligned' takes an address 'b', that is potentially unaligned

and returns an aligned address by rounding up to the nearest

cell boundary. This word is like 'align' but it works on any

pointer instead of the dictionary pointer only. As this is

a 16-bit Forth system this rounds up to the nearest 16-bit cell

boundary, or to next multiple of two (bytes).

Usage:

'ansi' is used to help construct ANSI escape code sequences,

most sequences consist of a CSI escape code, a number in base

10, and a single character to indicate the command. The

character and the number change, and are given as arguments

to the word 'ansi'. Most terminal emulators can deal with these

sequences, and the hardware VT100 clone that controls the VGA

display can deal with most of the more important codes.

Usage:

'at-xy' emits the ANSI escape sequence which will place the

cursor at column 'x' and row 'y'. This should work with the

built in VT100 terminal emulator, and with any decent terminal

emulator used to talk to the device over UART. 'at-xy' can be

used to draw primitive graphics along with other escape codes.

Counting starts from one, not zero.

Usage:

Usage:

  blk @ block b/buf blank ( blank most recently loaded block )

'begin' is used to start three looping mechanisms,

* 'begin...again'          ( infinite loop )

* 'begin...until'          ( loop until non-zero )

* 'begin...while...repeat' ( loop until zero )

Which are best explained in the entries for 'again', 'until'

and 'while'/'repeat' respectively. 'begin' is an immediate

word that should only be used within a word definition, and

should be used in conjunction with a valid looping mechanism

word set.

Usage:

'blk' is a variable which contains the value of the last block

to be loaded. This value is updated by 'block' on a successful

operation, and is set to an invalid block number on a block

error, or when 'flush' is called.

; ==== block  ( k -- a : perform block operation ) =============

'block' is a complex word that abstracts away all the details

of mass storage, whilst at the same time being easy to use, it

forms the basis on which Forth Blocks are used to organize

code and data. 'block'  takes a block number and if it is

valid attempts to find a free buffer in which to load the

block into, it then returns a pointer to that buffer. If no

free buffers are available it saves a dirty buffer to disk

then deallocates it, or it overwrites a clean buffer (as it

can always be loaded from disk if needed again).

Usage: