(*
 * LANGUAGE    : ANS Forth with extensions
 * PROJECT     : Forth Environments
 * DESCRIPTION : Fractal profile
 * CATEGORY    : Fractals
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : Thursday, December 18, 2003 10:32 PM, Marcel Hendrix 
 *)



 	NEEDS -miscutil
	NEEDS -graphics

	REVISION -fracprof "ÄÄÄ Fractal profile     Version 1.00 ÄÄÄ"

	PRIVATES

DOC
(*
 Draw a fractal profile line ("Height profile, land -- sea"). 
*)
ENDDOC

  9 =: p  PRIVATE
CREATE ff PRIVATE  p 2^x 1+ FLOATS DUP ALLOT	ff SWAP ERASE  

: ranproc ( F: s del -- r )
		0e FLOCAL r1
		BEGIN
		  2 FCHOOSE F1- TO r1
		  2 FCHOOSE F1- FSQR  r1 FSQR F+ 
		  FDUP 1e F>
		WHILE  
		  FDROP
		REPEAT ( F: -- r3 )
		FDUP FLN FSWAP F/ F2* FNEGATE FSQRT r1 F* 
		( F: s del r3 -- )  F* F+ ;P

: FRACPROF 	0.15e 0.15e 0.5e FLOCALS| h del sigma |
		p 2- 2^x  p 1- 2^x  p 2^x LOCALS| N a b |
		TEXTMODE? IF GRAPHICS ENDIF  GCLEAR
		0 0 Xmax Ymax 0e -1e  N S>F 1e SET-GWINDOW
		 0.4e ff  0 	   FLOAT[] F!  
		-0.4e ff  p 1- 2^x FLOAT[] F!
		 0.2e ff  p    2^x FLOAT[] F!
		p 1+ 1 DO h FNEGATE F2^X del F* TO del
			  N b - 1+ b DO 
			  		I b + ff []FLOAT F@
					I b - ff []FLOAT F@ F+ F2/ 
					del ( F: s del -- ) ranproc  ff I FLOAT[] F!
			  	a +LOOP
			  a 2/ TO a  b 2/ TO b
			  a 0= ?LEAVE
		     LOOP
		Xmax N /MOD SWAP IF 1+ ENDIF SETPENWIDTH
		N 1+ 0 DO  I S>F TO PenX   CLEAR PenY 	\ beginpoint
			   ff I FLOAT[] F@ ( y)		\ endpoint
			   FDUP F0> IF  Green  ELSE  Blue  ENDIF
			   PenX FSWAP DRAW-SCALED-LINE
		     LOOP
		1 SETPENWIDTH
		TEXT ;

:ABOUT		CR ." Try: FRACPROF" ;

		.ABOUT -fracprof CR
		DEPRIVE

				(* End of Source *)