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



 	NEEDS -miscutil
	NEEDS -graphics

	REVISION -bush "ÄÄÄ Bush or tree        Version 1.00 ÄÄÄ"

	PRIVATES

DOC
(*
 Draw a synthetic bush or tree-like line fractal as a Lindenmayer system. 
*)
ENDDOC

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

#64 =: lstack PRIVATE

CREATE uu PRIVATE  #64 FLOATS DUP ALLOT	uu SWAP ERASE  
CREATE vv PRIVATE  #64 FLOATS DUP ALLOT	vv SWAP ERASE  
CREATE ww PRIVATE  #64 FLOATS DUP ALLOT	ww SWAP ERASE  

Green VALUE leavecolor
Brown VALUE stemcolor
  5   VALUE leavesize

  5   VALUE GMAX  PRIVATE
  0   VALUE NR	  PRIVATE

PI 5e F/ FCONSTANT PI/5 PRIVATE

: contract ( p -- )
		LOCAL ix
	   	0  y ix   1+  CELL[] !  
		1  y ix   2+  CELL[] !	
		0  y ix   3 + CELL[] !  
		3  y ix   4 + CELL[] !
		0  y ix   5 + CELL[] !  
		2  y ix   6 + CELL[] !	
		0  y ix   7 + CELL[] !  
		3  y ix   8 + CELL[] !
		0  y ix   9 + CELL[] ! ;P
      
: (INIT)	1 TO NR
		0 LOCAL p
		0 x CELL+ !
		GMAX 1+ 1 DO	CLEAR p
			 	NR 1+ 
				   1 DO  x I CELL[] @ 
				   	 DUP IF 1 +TO p  y p CELL[] ! 
					   ELSE DROP  p contract   9 +TO p
					  ENDIF
				   LOOP 
				p TO nr   y x  nr 1+ CELLS MOVE
		        LOOP ;P

: BUSHLIND ( n -- ) 
		5 UMIN TO GMAX ( system order )
		0e 0e FLOCALS| hh ff |
		0 LOCAL m
		(INIT)
		TEXTMODE? IF GRAPHICS ENDIF  GCLEAR
		 0 0 Xmax Ymax -4e -1e  4e 8e SET-GWINDOW
		 2e  GMAX NEGATE S>F  F** TO hh
		 0 TO m   PI/2 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+ 
				 stemcolor DRAW-SCALED-LINE	ENDOF
			   1 OF  1 +TO m  ( push to stack )
			   	 PenX uu m FLOAT[] F!  
				 PenY vv m FLOAT[] F!  
				 ff   ww m FLOAT[] F!
			   	 PI/5 +TO ff	  		ENDOF
			   2 OF  1 +TO m  ( push to stack )
			   	 PenX uu m FLOAT[] F!  
				 PenY vv m FLOAT[] F!  
				 ff   ww m FLOAT[] F!
			   	 PI/5 -TO ff	  		ENDOF
			   3 OF  PenX PenY SCALE leavesize 
			   	 leavecolor CIRCLE 
				 ( pop stack )
			   	 uu m FLOAT[] F@ TO PenX  
				 vv m FLOAT[] F@ TO PenY 
				 ww m FLOAT[] F@ TO ff 	
				 1 -TO m  			ENDOF
			  ENDCASE
			  m lstack > ABORT" m too large; array out of bounds"
		    LOOP
		TEXT ;

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


		.ABOUT -bush CR
		DEPRIVE

				(* End of Source *)