(*
 * LANGUAGE    : ANS Forth
 * PROJECT     : Forth Environments
 * DESCRIPTION : Growth Model by Clifford A. Pickover
 * CATEGORY    : Graphic example
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : April 4, 1994, Marcel Hendrix 
 * LAST CHANGE : Tuesday, December 30, 2003 10:08 PM, Marcel Hendrix 
 *)



        NEEDS -miscutil
	NEEDS -graphics

        REVISION -pick1 "ÄÄÄ Growth Model 1.0    Version 1.01 ÄÄÄ"

	PRIVATES


DOC
(*
 A Cellular Automaton based on an idea by Clifford A. Pickover.
*)
ENDDOC


  0 VALUE nrows PRIVATE
  0 VALUE Xm	PRIVATE
  0 VALUE Ym	PRIVATE
  0 VALUE pcol	PRIVATE

: SQMATRIX	CREATE	0 , 			\ <> --- <>
		FORGET>	@ FREE ?ALLOCATE
		DOES>	@ SWAP nrows * + + ;P	\ <x> <y> --- <addr>

SQMATRIX Xx  
SQMATRIX Yy

-- The result of the rule, if one and only one neighbour lives -> become alive,
-- is stored in Yy. 

: APPLY-RULE	0 LOCALS| tt jj ii |		\ <i> <j> --- <>
		ii 0>  jj 0>  AND 
		   IF   ii 1+ jj Xx  C@  ii 1- jj Xx  C@ +
			ii jj 1+ Xx  C@  ii jj 1- Xx  C@ + + TO tt
		ENDIF
		ii 0=  jj 0>  AND 
		   IF	1 jj    Xx  C@ 2*  
			0 jj 1+ Xx  C@ +  
			0 jj 1- Xx  C@ + TO tt
		ENDIF
		ii 0>  jj 0=  AND
		   IF	ii 1    Xx  C@ 2*  
			ii 1+ 0 Xx  C@ +  
			ii 1- 0 Xx  C@ + TO tt
		ENDIF 
		tt 1 = 1 AND  ii jj Yy   C! ; PRIVATE

: COLORIZE	LOCALS| jj ii |			\ <i> <j> --- <>
		pcol 1 OR STDCOLOR >S
		Xm ii +  Ym jj -  S  SET-DOT
		Xm ii -  Ym jj -  S  SET-DOT
		Xm ii +  Ym jj +  S  SET-DOT
		Xm ii -  Ym jj +  S> SET-DOT ; PRIVATE

: INNERLOOP	LOCAL kk			\ <k> --- <>
		kk 1+ 0 ?DO 			\ Calculate, use Yy as scratch
			   kk I - 1+ 0 ?DO
					   J I Xx C@ IF J I COLORIZE
					 	   ELSE J I APPLY-RULE
						  ENDIF
				      LOOP
		       LOOP	
		kk 1+ 0 ?DO			\ copy back Yy to Xx
			   kk I - 1+ 0 ?DO  
					    J I Yy  C@ 1 = 1 AND 
					    J I Xx  C!
				      LOOP
		       LOOP ; PRIVATE

: NEW-COLOR	pcol 1+ #15 AND TO pcol ; PRIVATE

DEFER INIT-PICTURE

: SYMMETRIC	Xmax Ymax MIN 2/ TO nrows
		nrows DUP * ALLOCATE ?ALLOCATE ['] Xx >BODY !
		nrows DUP * ALLOCATE ?ALLOCATE ['] Yy >BODY !
		0 0 Xx  nrows nrows * ERASE
		1  0 0 Xx  C! ;	

: WILD		Xmax Ymax MIN 2/ TO nrows
		nrows DUP * ALLOCATE ?ALLOCATE ['] Xx >BODY !
		nrows DUP * ALLOCATE ?ALLOCATE ['] Yy >BODY !
		0 0 Xx  nrows nrows * ERASE
		2 0 DO 2 0 DO 
			     RANDOM 1 AND  J I Xx C! 
			 LOOP 
		  LOOP ; 

: COMPUTE	TEXTMODE? IF GRAPHICS ENDIF
		Xmax 2/ TO Xm  
		Ymax 2/ TO Ym
		#16 CHOOSE TO pcol
		GCLEAR INIT-PICTURE
		nrows 1 ?DO  I INNERLOOP 
			     EKEY? ?LEAVE
			     NEW-COLOR  
		       LOOP 
		TEXT ;

:ABOUT		CR ." Type COMPUTE for Pickover's Cellular Automaton #1." 
		CR ." OR! gives a special effect, default is XOR!" ;


                .ABOUT -pick1 CR
		DEPRIVE  XOR!
		' SYMMETRIC IS INIT-PICTURE

                              (* End of Source *)