Conway's Game of Life in FORTH (essentially same with one in rosesttacode)

life-rosetta.fth

\ -*- Mode: Forth -*-

\ Conway's Game of Life
\   originally from http://rosettacode.org/wiki/Conway's_Game_of_Life#Forth
\   see also http://en.wikipedia.org/wiki/Conway's_Game_of_Life

\ -------------------------------------------------------------------

\ The fast wrapping requires dimensions that are powers of 2.
\ (for playing just size, you may set terminal size to 64x17)
64 constant _width_
16 constant _height_

: nrows _width_ * 2* ;
1        nrows constant _row_
_height_ nrows constant _size_

create world _size_ allot
world         value old
old _width_ + value new
: clear-world world _size_ erase ;
: flip-world  new old to new to old ;
: foreach-row ( xt -- )  _size_ 0 do i over execute _row_ +loop drop ;

: row+  _row_ + ;
: row-  _row_ - ;
: col+  1+ ;
: col-  1- dup _width_ and + ;  \ avoid borrow into row
: wrap ( i -- i   ) [ _size_ _width_ - 1- ] literal and ;
: wow@ ( i -- 0/1 ) wrap old + c@ ;
: wow! ( 0/1 i -- ) wrap old + c! ;
: ow@  ( i -- 0/1 ) old + c@ ;
: nw!  ( 0/1 i -- ) new + c! ;

: sum-neighbors ( i -- i n )
  dup  col- row- wow@     over      row- wow@  +  over col+ row- wow@  +
  over col-      wow@  +                          over col+      wow@  +
  over col- row+ wow@  +  over      row+ wow@  +  over col+ row+ wow@  + ;

variable *gen*                  \ generation
: clear  clear-world  0 *gen*  ! ;
: age    flip-world   1 *gen* +! ;

\ the core Game of Life rules: just 3=>born, 2or3=>still alive, else=>die
: gencell ( i -- )  sum-neighbors over ow@ or 3 = 1 and swap nw! ;
: genrow  ( i -- )  _width_ over + swap do i gencell loop ;
: gen     (   -- )  ['] genrow foreach-row age ;

: emit-pos    ( 0/1-- )  if [char] * else bl then emit ;
: showrow     ( i  -- )  cr  old + _width_ over + swap do i c@ emit-pos loop ;
: show        (    -- )  ['] showrow foreach-row  cr ." Generation " *gen* @ . ;

: home 0 0 at-xy ;
: life ( -- ) begin gen home show key? until ;

\ -------------------------------------------------------------------
\ patterns
\

char | constant '|'
: pat' ( i addr len -- )
  rot dup 2swap  over + swap do
    i c@ '|' = if drop row+ dup else
    i c@ bl  = 1+ over wow! col+ then
  loop 2drop ;
: pat ( i c-addr -- ) count pat' ;

\ sample usage: "pentomino test-pat"
\ (also you may try "' pentomino test-pat" for random image)
: ini' ( qp x y -- ) _width_ * + swap clear pat page home show ;
: ini  ( qp     -- ) _width_ 2/ _height_ 2 - ini' ;
: nex  ( -- ) gen home show ;
: test-pat' ( qp -- )
    begin
        key case
            [char] x of     1 endof
            [char] n of nex 0 endof
            ( do nothing )  0
        endcase
    until ;
: test-pat ini test-pat' ;

\ still lifes
: block_     c" **|**" ;
: beehive    c"  **|*  *| **" ;
: loaf       c"  **|*  *| * *|  *" ;
: boat       c" **|* *| *" ;

\ oscillators
: blinker    c" ***" ;                    \ period  2
: toad       c" ***| ***" ;               \ period  2
: beacon     c" **|**|  **|  **" ;        \ period  2
: clock      c"  *|  **|**|  *" ;         \ period  2
: pulsar     c" *****|*   *" ;            \ period  3 after prelude
: decathlon  c" **********" ;             \ period 15 after prelude
: pulsar3    c"  " ;                      \ not yet implemented

\ spaceships
: glider     c"  *|  *|***" ;
: lwss       c"  ****|*   *|    *|*  *" ; \ light weight space ship
: ship       c"  ****|*   *|    *|   *" ; \ another lwss

\ breeder (if wide screen)
: 1d-breeder c" ******** *****   ***      ******* *****" ;
: test-1db   1d-breeder _width_ 2/ 2/ _height_ 2 - ini' test-pat' ;

\ long life
: pentomino  c" **| **| *" ;           \ finally still
: pi_        c" **| **|**" ;           \ finally oscillator
: diehard    c"       *|**| *   ***" ; \ die off after 130-gen
: acorn      c"  *|   *|**  ***" ;     \ spawn 13 gliders in 5206-gen (if wide)

\ -------------------------------------------------------------------
\ some usage demos
\

(
clear 0 glider show
  *
   *
 ***
Generation 0  ok

gen show
 * *
  **
  *
Generation 1  ok

clear 500 pulsar show
life
)

\ eof