(* * LANGUAGE : ANS Forth with extensions * PROJECT : Forth Environments * DESCRIPTION : 3D bare Pythagoras tree * CATEGORY : Fractals * AUTHOR : Marcel Hendrix * LAST CHANGE : Wednesday, December 17, 2003 8:03 PM, Marcel Hendrix *) NEEDS -miscutil NEEDS -graphics REVISION -pyt3dbt "ÄÄÄ Pythagoras 3D tree Version 1.00 ÄÄÄ" PRIVATES DOC (* Draw a 3D bare fixed order Pythagoras tree, using backtracking. *) ENDDOC #11 =: p PRIVATE CREATE xa PRIVATE p 1+ FLOATS DUP ALLOT xa SWAP ERASE CREATE ya PRIVATE p 1+ FLOATS DUP ALLOT ya SWAP ERASE CREATE za PRIVATE p 1+ FLOATS DUP ALLOT za SWAP ERASE CREATE xb PRIVATE p 1+ FLOATS DUP ALLOT xb SWAP ERASE CREATE yb PRIVATE p 1+ FLOATS DUP ALLOT yb SWAP ERASE CREATE zb PRIVATE p 1+ FLOATS DUP ALLOT zb SWAP ERASE CREATE sa PRIVATE p 1+ CELLS DUP ALLOT sa SWAP ERASE CREATE colortable PRIVATE Brown , LightRed , Red , Yellow , LightGreen , Green , : NSTDCOLOR ( ix -- color ) 6 MOD colortable []CELL @ ;P 20e FRAD FCONSTANT H1 PRIVATE -- prescribed angles -60e FRAD FCONSTANT H2 PRIVATE 0.85e FCONSTANT R1 PRIVATE -- prescribed reductions 0.70e FCONSTANT R2 PRIVATE H1 FCOS R1 F* FCONSTANT a1 PRIVATE H1 FSIN R1 F* FCONSTANT b1 PRIVATE H2 FCOS R2 F* FCONSTANT a2 PRIVATE H2 FSIN R2 F* FCONSTANT b2 PRIVATE 0e FVALUE cs PRIVATE -- viewing angle 0e FVALUE ss PRIVATE : PROJECTION-ANGLE ( F: -- ) FRAD FSINCOS TO cs TO ss ; 45e PROJECTION-ANGLE ( 45 degrees is nice ) 0e FVALUE xx PRIVATE 0e FVALUE yy PRIVATE 0e FVALUE zz PRIVATE 0e FVALUE x1 PRIVATE 0e FVALUE y1 PRIVATE 0e FVALUE z1 PRIVATE 0e FVALUE x2 PRIVATE 0e FVALUE y2 PRIVATE 0e FVALUE z2 PRIVATE 0e FVALUE =xa PRIVATE 0e FVALUE =ya PRIVATE 0e FVALUE =za PRIVATE 0e FVALUE =xb PRIVATE 0e FVALUE =yb PRIVATE 0e FVALUE =zb PRIVATE 0 VALUE g PRIVATE 0 VALUE m PRIVATE : popstack xa m FLOAT[] F@ TO =xa ya m FLOAT[] F@ TO =ya za m FLOAT[] F@ TO =za xb m FLOAT[] F@ TO =xb yb m FLOAT[] F@ TO =yb zb m FLOAT[] F@ TO =zb sa m CELL[] @ TO g ;P : pushstack xx TO =xa yy TO =ya zz TO =za x1 TO =xb y1 TO =yb z1 TO =zb xx xa m FLOAT[] F! yy ya m FLOAT[] F! zz za m FLOAT[] F! x2 xb m FLOAT[] F! y2 yb m FLOAT[] F! z2 zb m FLOAT[] F! g sa m CELL[] ! ;P : proc1 =xb =xa F- =yb =ya F- =zb =za F- FLOCALS| w v u | w FSQR u FSQR v FSQR F+ F/ F1+ FSQRT FLOCAL t =xb TO xx =yb TO yy =zb TO zz =xb u a1 F* F+ b1 v F* t F* F- TO x1 =yb u b1 F* t F* F+ a1 v F* F+ TO y1 =zb w a1 F* F+ TO z1 =xb u a2 F* F+ b2 v F* t F* F- TO x2 =yb u b2 F* t F* F+ a2 v F* F+ TO y2 =zb w a2 F* F+ TO z2 ;P : proc2 g DUP NSTDCOLOR LOCAL color p SWAP - SETPENWIDTH y1 TO PenX z1 cs F* ss x1 F* F+ TO PenY =yb =zb cs F* ss =xb F* F+ color DRAW-SCALED-LINE y2 z2 cs F* ss x2 F* F+ color DRAW-SCALED-LINE ;P :INLINE work proc1 proc2 ; : PYT3DBT TEXTMODE? IF GRAPHICS ENDIF GCLEAR 0 0 Xmax Ymax -4e -2e 4e 4e SET-GWINDOW 0.01e TO =xa 0e TO =ya -1e TO =za 0e TO =xb 0e TO =yb 0e TO =zb =ya TO PenX =za cs F* =xa ss F* F+ TO PenY =xb =zb cs F* =yb ss F* F+ p SETPENWIDTH 0 NSTDCOLOR DRAW-SCALED-LINE CLEAR g CLEAR m BEGIN g p 1- < IF 1 +TO g 1 +TO m work pushstack ELSE 1 +TO g work popstack 1 -TO m work popstack 1 -TO m ENDIF m 0< UNTIL 1 SETPENWIDTH TEXT ; : TREES #90 #10 DO I S>F PROJECTION-ANGLE PYT3DBT EKEY? ?LEAVE 5 +LOOP #10 #90 DO I S>F PROJECTION-ANGLE PYT3DBT EKEY? ?LEAVE -5 +LOOP ; :ABOUT CR ." Try: PYT3DBT" ; .ABOUT -pyt3dbt CR DEPRIVE (* End of Source *)