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



        NEEDS -miscutil
	NEEDS -graphics

        REVISION -pick2 "ÄÄÄ Growth Model 2.0    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 * + + ;	\ <x> <y> --- <addr>

SQMATRIX Xx  
SQMATRIX Yy

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

DEFER APPLY	PRIVATE

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

: RULE2		2DUP Xx >S LOCALS| jj ii |	\ <i> <j> --- <>
		ii 0>  jj 0>  AND 
		   IF   S 1+ C@           S  1- C@ +
			S nrows + C@      S  nrows - C@ + +
			S 1+ nrows + C@   S  1+ nrows - C@ + +
			S 1- nrows + C@   S> 1- nrows - C@ + +
			1 = 1 AND  ii jj Yy   C!  EXIT
		ENDIF  -S
		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@    + 
			1 = 1 AND  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@    + 
			1 = 1 AND  ii jj Yy   C!  EXIT
		ENDIF ; 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> --- <>

		( alternatives, not so interesting)
\		kk 1 AND 			
\		2 CHOOSE 1 =
\		kk CHOOSE kk 4 / >

		kk CHOOSE kk 8 / >
			 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 COLORIZE
					 	ELSE J I APPLY
					       ENDIF
				  LOOP
		       LOOP	
		kk 1+ 0 ?DO			\ copy back Yy to Xx
			   kk 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! ;	' 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
			     NEW-COLOR  
		       LOOP 
		TEXT ;

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


                .ABOUT -pick2 CR

		DEPRIVE  XOR!

                              (* End of Source *)