(*
 * LANGUAGE    : ANS Forth with extensions
 * PROJECT     : Forth Environments
 * DESCRIPTION : Sierpinski line after Lindenmayer
 * CATEGORY    : Fractals
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : December 16, 2003, Marcel Hendrix 
 *)



 	NEEDS -miscutil
	NEEDS -graphics

	REVISION -sierlind "ÄÄÄ Sierpinski line     Version 1.00 ÄÄÄ"

	PRIVATES

DOC
(*
 Draw a Sierpinski-like line fractal as a Lindenmayer system. 
*)
ENDDOC

CREATE x  PRIVATE  #2048 CELLS DUP ALLOT	x SWAP ERASE  
CREATE y  PRIVATE  #2048 CELLS DUP ALLOT	y SWAP ERASE  

Green VALUE color

  5   VALUE GMAX  PRIVATE
  0   VALUE NR	  PRIVATE

: contract ( p -- )
		LOCAL ix
	   	2  y ix   1+  CELL[] !  
		0  y ix   2+  CELL[] !	
		1  y ix   3 + CELL[] !  
		0  y ix   4 + CELL[] !
		3  y ix   5 + CELL[] !  
		0  y ix   6 + CELL[] !	
		1  y ix   7 + CELL[] !  
		0  y ix   8 + CELL[] !
		3  y ix   9 + CELL[] !  
		0  y ix #10 + CELL[] !	
		1  y ix #11 + CELL[] !  
		0  y ix #12 + CELL[] !
		2  y ix #13 + CELL[] ! ;P
      
: (INIT)	1 TO NR
		0 LOCAL p
		1 x CELL+ !
		GMAX 1+ 1 DO	CLEAR p
			 	NR 1+ 
				   1 DO  CASE  x I CELL[] @ 
					   0 OF  0  y p 1+  CELL[] !  
					   	 0  y p 2+  CELL[] !   2 +TO p	ENDOF
					   1 OF  p  contract  #13 +TO p 	ENDOF 
					   2 OF  1 +TO p  2 y p CELL[] !	ENDOF
					   3 OF  1 +TO p  3 y p CELL[] !  	ENDOF
					 ENDCASE	
				   LOOP 
				p TO nr   y x  nr 1+ CELLS MOVE
		        LOOP ;P

: SIERLIND ( n -- ) 
		5 UMIN TO GMAX ( system order )
		0e 0e FLOCALS| hh ff |
		(INIT)
		TEXTMODE? IF GRAPHICS ENDIF  GCLEAR
		 0 0 Xmax Ymax -2e -1e  2e 2e SET-GWINDOW
		 2e  GMAX NEGATE S>F  F** TO hh
		 0e TO ff  
		 0e TO PenX 0e TO PenY
		 NR 1+ 
		    1  DO  CASE x I CELL[] @
			   0 OF  ff FCOS hh F*  PenX F+
			         ff FSIN hh F*  PenY F+ 
				 color DRAW-SCALED-LINE ENDOF
			   2 OF  PI*2  3e F/ +TO ff  	ENDOF
			   3 OF  PI*2 -3e F/ +TO ff  	ENDOF
			  ENDCASE 	
		    LOOP
		TEXT ;

:ABOUT		CR ." Try: <+n> SIERLIND -- n is the system order (n<6)" ;


		.ABOUT -sierlind CR
		DEPRIVE

				(* End of Source *)