( midpoint.4th ) ( 3dfrac.4th by Mark A. Washburn 2004 ) ( 3dfrac.c 3.0 by Aaron Contorer 1987-1989 ) ( The code presented here is placed in the public domain. ) ( Mark A. Washburn {mawcowboy@netscape.net} 8th of February 2004 ) ( maw Feb 10, 2004 ) ( modified for v.43 release, maw Mar 3, 2004 ) BASE @ DECIMAL ( need graphics words from system ) : grEnable ( f -- ) 30 (SYS) ; : grSize? ( -- width height ) 31 (SYS) ; : drawLine ( x1 y1 x2 y2 -- ) 32 (SYS) ; ( need some double words ) : 2CONSTANT ( d 'name' -- ) CREATE , , DOES> 2@ ; : 2VARIABLE ( 'name' -- ) CREATE 2 CELLS ALLOT ; ( : 2OVER >R >R 2DUP R> R> 2SWAP ; ) ( start of 3DFRAC.4TH defines ) ( Graphic design ) 6 CONSTANT MAXDEEP 256 CONSTANT PARTS 0 CONSTANT XA 256 CONSTANT XB 0 CONSTANT YA 256 CONSTANT YB 0 CONSTANT ZA 38 CONSTANT YADD 384 CONSTANT YSIZE ( Color contants ) \ WATERCOLOR is LIGHTBLUE BLUE 2CONSTANT WATERCOLOR \ LANDCOLOR is GREEN GREEN 2CONSTANT LANDCOLOR ( Fractal function variables ) \ STEEP is number from 0 to 9 used \ in generating a ratio between .51 and .96 VARIABLE STEEP VARIABLE SEALEVEL ( start of RAN4.SEQ ) ( This is an ANS Standard Program implementing the function RAN4 as ) ( described in the second edition of "Numerical Recipes in C" by ) ( Press Teukolsky Vetterling and Flannery {ISBN 0-521-43108-5} ) ( Forth Scientific Library Algorithm #24 ) ( ran4.seq 1.1 12:10:28 1/9/95 GC ) ( The code presented here is placed in the public domain. ) ( Gordon Charlton {gordon@charlton.demon.co.uk} 10th September 1994 ) ( maw Feb 8, 2004 modified for myForth ) BASE @ HEX : DINVERT ( d--d) SWAP INVERT SWAP INVERT ; : DXOR ( d d--d) ROT XOR >R XOR R> ; : FuncG ( d dc1 dc2--d) >R >R DXOR 2DUP UM* 2SWAP DUP UM* DINVERT ROT DUP UM* D+ SWAP R> R> DXOR D+ ; ( : PseudoDes ( d d--d d) ( 32 bit version) ( 2SWAP 2OVER 383B E34C 6887 BAA9 B5F8 3D02 3B58 4B0F FuncG DXOR ) ( 2SWAP 2OVER 4033 39F7 D32C 1E17 BF1A 9226 F0C3 E874 FuncG DXOR ) ( 2SWAP 2OVER 3DA7 60B4 DC3C 03BC CD47 1D38 C5A6 6955 FuncG DXOR ) ( 2SWAP 2OVER 215B 65E9 D1B2 0F33 B432 F358 CA46 55A7 FuncG DXOR ; ) : PseudoDes ( d d--d d) ( 16 bit version) 2SWAP 2OVER 6887 BAA9 3B58 4B0F FuncG DXOR 2SWAP 2OVER D32C 1E17 F0C3 E874 FuncG DXOR 2SWAP 2OVER DC3C 03BC C5A6 6955 FuncG DXOR 2SWAP 2OVER D1B2 0F33 CA46 55A7 FuncG DXOR ; ( : PseudoDes ( d d--d d) ( 32 bit version) ( 2SWAP 2OVER BAA96887E34C383B. 4B0F3B583D02B5F8. FuncG DXOR ) ( 2SWAP 2OVER 1E17D32C39F74033. E874F0C39226BF1A. FuncG DXOR ) ( 2SWAP 2OVER 03BCDC3C60B43DA7. 6955C5A61D38CD47. FuncG DXOR ) ( 2SWAP 2OVER 0F33D1B265E9215B. 55A7CA46F358B432. FuncG DXOR ; ) ( : PseudoDes ( d d--d d) ( 16 bit version) ( 2SWAP 2OVER BAA96887. 4BOF3B58. FuncG DXOR ) ( 2SWAP 2OVER 1E17D32C. E874F0C3. FuncG DXOR ) ( 2SWAP 2OVER 03BCDC3C. 6955C5A6. FuncG DXOR ) ( 2SWAP 2OVER 0F33D1B2. 55A7CA46. FuncG DXOR ; ) 2VARIABLE Counter 2VARIABLE Sequence# : START-SEQUENCE ( dcounter dseq#) Sequence# 2! Counter 2! ; : RAN4 ( --d) Sequence# 2@ Counter 2@ PseudoDes 2SWAP 2DROP Counter 2@ 1 D+ Counter 2! ; BASE ! ( start of 3DFRAC.4TH code ) : XLATE ( x y z -- OVER + YADD + ROT ROT 2/ + 384 swap - SWAP ; : ADDLINE GREEN FG! XLATE >R >R XLATE R> R> drawLine ; : ADDSEALEVEL \ CR ." z0 y0 x0" . . . ; BLUE FG! OVER + YADD + ROT ROT 2/ + 384 SWAP - \ test2 SWAP \ 2 42 2DUP drawLine ; : FRAME1 ( -- ) HERE , ; : &NEWZ HERE 1 CELLS - ; : &XMID HERE 2 CELLS - ; : &YMID HERE 3 CELLS - ; : &Z01 HERE 4 CELLS - ; : &Z12 HERE 5 CELLS - ; : &Z23 HERE 6 CELLS - ; : &Z30 HERE 7 CELLS - ; : &DEEP HERE 8 CELLS - ; : &X0 HERE 9 CELLS - ; : &Y0 HERE 10 CELLS - ; : &X2 HERE 11 CELLS - ; : &Y2 HERE 12 CELLS - ; : &Z0 HERE 13 CELLS - ; : &Z1 HERE 14 CELLS - ; : &Z2 HERE 15 CELLS - ; : &Z3 HERE 16 CELLS - ; : &FRAME1 HERE 17 CELLS - ; : NEWZ &NEWZ @ ; : XMID &XMID @ ; : YMID &YMID @ ; : Z01 &Z01 @ ; : Z12 &Z12 @ ; : Z23 &Z23 @ ; : Z30 &Z30 @ ; : DEEP &DEEP @ ; : X0 &X0 @ ; : Y0 &Y0 @ ; : X2 &X2 @ ; : Y2 &Y2 @ ; : Z0 &Z0 @ ; : Z1 &Z1 @ ; : Z2 &Z2 @ ; : Z3 &Z3 @ ; : _FRAME1 &FRAME1 @ ; : UNFRAME1 ( -- ) _FRAME1 HERE - ALLOT ; : FRAC ( depth x0 y0 x2 y2 z0 z1 z2 z3 -- ) \ create free memory variables frame FRAME1 \ z3 z2 z1 z0 , , , , \ y2 x2 y0 x0 , , , , \ depth , \ z30 z23 z12 z01 0 , 0 , 0 , 0 , \ ymid xmid newz 0 , 0 , 0 , \ average previous quad heights Z0 Z1 + Z2 + Z3 + 4 / ( average -- ) \ calculate random offset to average using slope \ STEEP is number from 0 to 9 used \ in generating a ratio between .51 and .96 RAN4 Y2 Y0 - MOD STEEP @ 102 + 200 */MOD SWAP DROP \ 50% chane of up or down ( added to average) RAN4 0 < IF + ELSE - THEN \ store NEWZ value &NEWZ ! X0 X2 + 2/ &XMID ! Y0 Y2 + 2/ &YMID ! Z1 Z2 + 2/ &Z12 ! Z3 Z0 + 2/ &Z30 ! Z0 Z1 + 2/ &Z01 ! Z2 Z3 + 2/ &Z23 ! \ DEBUG \ CR ." stack " .s \ CR ." XMID YMID Z12 Z30 Z01 Z23 " CR \ XMID . YMID . Z12 . Z30 . Z01 . Z23 . \ key drop -1 &DEEP +! DEEP 0 < INVERT IF \ >= DEEP X0 Y0 XMID YMID Z0 Z01 NEWZ Z30 RECURSE DEEP XMID Y0 X2 YMID Z01 Z1 Z12 NEWZ RECURSE DEEP X0 YMID XMID Y2 Z30 NEWZ Z23 Z3 RECURSE DEEP XMID YMID X2 Y2 NEWZ Z12 Z2 Z23 RECURSE ELSE NEWZ SEALEVEL @ < IF \ <= \ above sea level XMID YMID NEWZ X2 YMID Z12 ADDLINE XMID YMID NEWZ X0 YMID Z30 ADDLINE ELSE \ below "sea level" XMID YMID SEALEVEL @ ADDSEALEVEL THEN THEN UNFRAME1 ; : ZZA RAN4 YB 15 / MOD ; : MIDPOINT \ initialize RAN4 \ 1 1 1 1 START-SEQUENCE \ ?MS returns double double in myForth 16-bit ?MS START-SEQUENCE \ number between 0 and 9 RAN4 ABS 10 MOD STEEP ! \ set SEALEVEL RAN4 ABS 17 MOD 8 - SEALEVEL ! \ enable graphics mode TRUE grEnable \ clear screen PAGE FG@ \ save foregound color BEGIN PAGE MAXDEEP XA YA XB YB ZZA ZZA ZZA ZZA FRAC GREEN FG! 1 20 AT-XY ." Press the [Esc] key to quit or any other key to continue." KEY 27 = UNTIL FG! \ restore foreground color FALSE grEnable CR ." 3DFRAC done." ; BASE !