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



        NEEDS -miscutil
	NEEDS -graphics

        REVISION -pick3 "ÄÄÄ Growth Model 2.1    Version 1.01 ÄÄÄ"

	PRIVATES


DOC
(*
 A Cellular Automaton based on an idea by Clifford A. Pickover.
 Even/Odd growth, takes a different rule every other iteration.
*)
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

CREATE _tab	0 , 4 , 12 , 2 , 10 , 14 , 5 , 13 ,	PRIVATE

: ctable	7 AND _tab []CELL @  STDCOLOR ; PRIVATE


-- The result of the rule is stored in Yy. 

DEFER APPLY	PRIVATE

: RULE1		2DUP Xx LOCALS| addr jj ii |		\ <i> <j> --- <>
		ii 0>  jj 0>  AND 
		   IF   addr 1+ C@       addr 1- C@ +
			addr nrows + C@  addr nrows - C@ + +
			ii jj Yy   C! EXIT 
		ENDIF
		ii 0=  jj 0>  AND 
		   IF	1 jj    Xx  C@ 2*  
			0 jj 1+ Xx  C@ +  
			0 jj 1- Xx  C@ + 
			ii jj Yy   C! EXIT 
		ENDIF
		ii 0>  jj 0=  AND
		   IF	ii 1    Xx  C@ 2*  
			ii 1+ 0 Xx  C@ +  
			ii 1- 0 Xx  C@ + 
			ii jj Yy   C! EXIT 
		ENDIF ; PRIVATE

: RULE2		2DUP Xx LOCALS| addr jj ii |	\ <i> <j> --- <>
		ii 0>  jj 0>  AND 
		   IF   addr 1+ C@           addr 1- C@ +
			addr nrows + C@      addr nrows - C@ + +
			addr 1+ nrows + C@   addr 1+ nrows - C@ + +
			addr 1- nrows + C@   addr 1- nrows - C@ + +
			ii jj Yy   C!  EXIT
		ENDIF
		ii 0=  jj 0>  AND 
		   IF	1 jj    Xx  C@ 2*  
			1 jj 1+ Xx  C@ 2* + 
			1 jj 1- Xx  C@ 2* + 
			0 jj 1+ Xx  C@    +  
			0 jj 1- Xx  C@    + 
			ii jj Yy   C!  EXIT
		ENDIF
		ii 0>  jj 0=  AND
		   IF	ii 1    Xx  C@ 2*  
			ii 1+ 1 Xx  C@ 2* +
			ii 1- 1 Xx  C@ 2* +
			ii 1+ 0 Xx  C@    +  
			ii 1- 0 Xx  C@    + 
			ii jj Yy   C!  EXIT
		ENDIF ; PRIVATE

: COLORIZE	LOCALS| jj ii |			\ <i> <j> --- <>
		ii jj Yy C@ ctable >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 AND IF ['] RULE1 
		       ELSE ['] RULE2 
		      ENDIF IS APPLY
		kk 1+ 0 ?DO 			\ Calculate, use Yy as scratch
			   kk 1+ 0 ?DO
					J I Xx C@ IF J I Xx C@  J I Yy C!
					 	ELSE J I APPLY
					       ENDIF
				  LOOP
		       LOOP	
		kk 1+ 0 ?DO			\ copy back Yy to Xx
			   kk 1+ 0 ?DO  
					kk 1 AND IF J I COLORIZE ENDIF
					J I Yy  C@ 1 = 1 AND 
					J I Xx  C!
				  LOOP
		       LOOP ; 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! ;	' SYMMETRIC IS INIT-PICTURE

: 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
		       LOOP 
		TEXT ;

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


                .ABOUT -pick3 CR
		DEPRIVE  XOR!

                              (* End of Source *)