(*
 * LANGUAGE    : ANS Forth with extensions
 * PROJECT     : Forth Environments
 * DESCRIPTION : Draw Sierpinski Sieve using backtracking
 * CATEGORY    : Iterative system with 3 contractors
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : December 10, 2003, Marcel Hendrix 
 *)



 	NEEDS -miscutil
	NEEDS -graphics

	REVISION -sierps "ÄÄÄ Triangular fractals Version 1.01 ÄÄÄ"

	PRIVATES

DOC
(*
 Build Sierpinski Sieve, using backtracking.
*)
ENDDOC

8 CONSTANT p  PRIVATE

CREATE x  PRIVATE  p 2* FLOATS DUP ALLOT   x SWAP ERASE  
CREATE y  PRIVATE  p 2* FLOATS DUP ALLOT   y SWAP ERASE  
CREATE z  PRIVATE  p 2* CELLS  DUP ALLOT   z SWAP ERASE  

        0.5e FCONSTANT aa  PRIVATE	
3e FSQRT F2/ FCONSTANT bb  PRIVATE	-- transformation coefficients
        0.5e FCONSTANT cc  PRIVATE	-- contraction factor

White VALUE color
2 VALUE dotsize

0 [IF]  :INLINE FPLOT ( F: x y -- ) SCALE dotsize color CIRCLE ; ( nice with p=8 or so)
[ELSE]  :INLINE FPLOT ( F: x y -- ) SCALE color SET-MDOT ; ( MDOT is about twice faster than DOT )
[THEN]

: contractions ( F: x y -- x1 y1 x2 y2 x3 y3 )
		FLOCALS| y x |
		cc x F*  cc F- F1+ 	  ( x1)
		cc y F* 	   	  ( y1) \ contract wrt (1,0) 
		F2DUP FPLOT 
		cc x F*  cc F1- aa F*  F+ ( x2)
		cc y F*  cc F1- bb F*  F- ( y2) \ contract wrt (-A,B) 
		F2DUP FPLOT 
		cc x F*  cc F1- aa F*  F+ ( x3)
		cc y F*  cc F1- bb F*  F+ ( y3) \ contract wrt (-A,-B) 
		F2DUP FPLOT ;P

: -contractions ( F: x y -- )
		FLOCALS| y x |
		cc x F*  cc F- F1+ 	  ( x1)
		cc y F* 	   	  ( y1) \ contract wrt (1,0) 
		FPLOT 
		cc x F*  cc F1- aa F*  F+ ( x2)
		cc y F*  cc F1- bb F*  F- ( y2) \ contract wrt (-A,B) 
		FPLOT 
		cc x F*  cc F1- aa F*  F+ ( x3)
		cc y F*  cc F1- bb F*  F+ ( y3) \ contract wrt (-A,-B) 
		FPLOT ;P

: SIERPS ( -- )	0 0 LOCALS| m g |
		0.04e FLOCAL rr
		TEXTMODE? IF GRAPHICS ENDIF  GCLEAR
		 0 0 Xmax Ymax -1.4e -1.2e  1.8e 1.2e SET-GWINDOW
		 RESET-MDOTS  
		 0e 0e F2DUP FPLOT  
		  BEGIN ( F: x y -- )
		       g p 1- < 
		             IF  1 +TO g
			     	 contractions ( F: x y -- x1 y1 x2 y2 x3 y3 )
				 y m 2+ FLOAT[] F!    x m 2+ FLOAT[] F!  g  z m 2+ CELL[] !  
				 y m 1+ FLOAT[] F!    x m 1+ FLOAT[] F!  g  z m 1+ CELL[] !  
				 2 +TO m
		  	   ELSE  1 +TO g
			     	 -contractions	x m FLOAT[] F@  y m FLOAT[] F@  		   1 -TO m
			     	 -contractions	x m FLOAT[] F@  y m FLOAT[] F@ 			   1 -TO m
			     	 -contractions  x m FLOAT[] F@  y m FLOAT[] F@  z m CELL[] @ TO g  1 -TO m
			  ENDIF
		    m 0< 
		  UNTIL 
		 F2DROP
		 FLUSH-MDOTS
		TEXT ;

:ABOUT		CR ." Try: SIERPS " ;

		.ABOUT -sierps CR
		DEPRIVE

				(* End of Source *)