(*
 * LANGUAGE    : ANS Forth with extensions
 * PROJECT     : Forth Environments
 * DESCRIPTION : Draw "Levy's line" using conditional backtracking
 * CATEGORY    : Iterative system with 2 contractors
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : December 10, 2003, Marcel Hendrix 
 *)



 	NEEDS -miscutil
	NEEDS -graphics

	REVISION -levy3 "ÄÄÄ Tree-like fractals  Version 1.01 ÄÄÄ"

	PRIVATES

DOC
(*
 Build Levy's fractal, using conditional backtracking.
*)
ENDDOC

0.005e FCONSTANT eps PRIVATE
  #28   CONSTANT p   PRIVATE

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

   0.5e FCONSTANT a1  PRIVATE	
   0.5e FCONSTANT b1  PRIVATE	
 3e 1/F FCONSTANT a2  PRIVATE	
-3e 1/F FCONSTANT b2  PRIVATE	

 a1 FSQR b1 FSQR F+ FSQRT FCONSTANT f1 PRIVATE 
 a2 FSQR b2 FSQR F+ FSQRT FCONSTANT f2 PRIVATE 

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]

: LR-contraction ( F: x y -- x1 y1 x2 y2 )
		FLOCALS| y x |
		a1 x F*  b1 y F* F-  a1 F1- F+ ( x1)
		b1 x F*  a1 y F* F+  b1     F+ ( y1) 
		F2DUP FPLOT 
		a2 x F*  b2 y F* F-  F1+ a2 F- ( x2)
		b2 x F*  a2 y F* F+  b2     F- ( y2) 
		F2DUP FPLOT ;P

: LEVY ( -- )   0 0 LOCALS| m g |
		1e FLOCAL ff
		TEXTMODE? IF GRAPHICS ENDIF  GCLEAR
		 0 0 Xmax Ymax -2.4e -1.2e  2.4e 2.4e SET-GWINDOW
		 RESET-MDOTS  
		 0e 1e F2DUP FPLOT  
		  BEGIN ( F: x y -- )
		       g p <  ff eps F> 
		       AND   IF  LR-contraction ( F: x y -- x1 y1 x2 y2 )
				 1 +TO m 1 +TO g  ( stack second point )
				 y m FLOAT[] F!    x m FLOAT[] F!  
				 ff f2 F*  f m FLOAT[] F!  g  z m CELL[] !  
				 ff f1 F* TO ff   ( continue with first point )
		  	   ELSE  F2DROP           ( pop stack )
				 x m FLOAT[] F@  y m FLOAT[] F@  
				 f m FLOAT[] F@ TO ff   z m CELL[] @ TO g   
				 1 -TO m
			  ENDIF
		    m 0< 
		  UNTIL 
		 F2DROP
		 FLUSH-MDOTS
		TEXT ;

:ABOUT	CR ." Try: LEVY " ;


		.ABOUT -levy3 CR
		DEPRIVE

				(* End of Source *)