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



 	NEEDS -miscutil
	NEEDS -graphics

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

	PRIVATES

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

 #15   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  

 0.5e FCONSTANT aa  PRIVATE	
 0.5e FCONSTANT bb  PRIVATE	
 0.5e FCONSTANT cc  PRIVATE	
-0.5e FCONSTANT dd  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]

-- FPLOT dominates, so extreme optimization has no use:
-- FORTH> cr timer-reset levy .elapsed ( 3DROP instead of SET-MDOT, p=15)
-- 0.137 seconds elapsed. ok
-- FORTH> cr timer-reset levy .elapsed ( SET-MDOT instead of DROP, window hidden, p=15)
-- 0.518 seconds elapsed. ok
-- FORTH> cr timer-reset levy .elapsed ( SET-MDOT instead of DROP, small/large window, p=15)
-- 0.826 seconds elapsed. ok
: LR-contraction ( F: x y -- x1 y1 x2 y2 )
		FLOCALS| yy xx |
		aa xx F*  bb yy F* F-  aa F1- F+ ( x1)
		bb xx F*  aa yy F* F+  bb     F+ ( y1) 
		F2DUP FPLOT 
		cc xx F*  dd yy F* F-  F1+ cc F- ( x2)
		dd xx F*  cc yy F* F+  dd     F- ( y2) 
		F2DUP FPLOT ;P

: LEVY ( -- )   0 0 LOCALS| m g |
		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 1- < IF  1 +TO m 1 +TO g  
		    		 LR-contraction ( F: x y -- x1 y1 x2 y2 )
				 y m FLOAT[] F!  x m FLOAT[] F!  g  z m CELL[] !  
		  	   ELSE  1 +TO g  
			   	 LR-contraction F4DROP
				 x m FLOAT[] F@  y m FLOAT[] F@  1 -TO m
				 LR-contraction F4DROP
				 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: LEVY " ;


		.ABOUT -levy2 CR
		DEPRIVE

				(* End of Source *)