VolksForth/8080/AmstradCPC/TURTDEMO.SCR

\ Turtle-Demo                                         UH 03Dec86                                                                Dieses File enthaelt einige Demonstrationen der Turtle-Grafik.                                                                  Starten mit:  INCLUDE TURTDEMO.SCR                                                                                              Einige Definitionen sind im Original in LOGO geschrieben,       ihre Uebertragung konnte quasi 1 zu 1 geschehen.                (Umsetzung von Prefix- in Postfix-Notation)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     \ Turtle-Demo                                         UH 10Oct86                                                                \needs Graphics  include grafik.scr   include turtle.scr                                                                        1 4 +thru                                                                                                                       : weiter   key drop ;                                                                                                           rosette         weiter                                                                                                          dreiecke        weiter                                                                                                          siedlung        weiter                                                                                                          $40 6 hilbert   weiter                                                                                                          \ n-eck                                               UH 10Oct86                                                                : eck ( seitenlaenge n -- )                                        &360 over /  swap                                               0 DO  over fd dup lt  LOOP 2drop ;                                                                                                                                                           : quadrat  4 eck ;                                                                                                              : rosette   page home  &36 0 DO &700 quadrat  &10 lt LOOP ;                                                                                                                                                                                                                                                                                                                                                                                                     \ Rekursives Drei-eck-muster                          UH 10Oct86                                                                                                                                : muster ( groesse -- ) recursive                                   dup &220 < IF pd 3 eck pu exit THEN                             2/  dup muster dup fd  dup muster  &120 lt dup fd &120 rt           dup muster  &120 rt  fd &120 lt ;                                                                                                                                                       : dreiecke ( -- )                                                  page &300 0 setxy  &60 seth  pu   &3500 muster pd   ;                                                                                                                                                                                                                                                                                                                                        \ Nikolaushaus                                        UH 10Oct86| : diagonale ( len -- )   &7071 &10000 */ fd ;                 | : dies ( len -- len )  dup fd ;                               | : ist  ( len -- len )  &45 rt  dup  diagonale ;               | : das  ( len -- len )  &90 rt  dup  diagonale ;               | : haus ( len -- len ) &135 rt  dup  fd ;                      | : vom  ( len -- len ) &135 lt  dup  2*  diagonale ;           | ' haus Alias ni                                               | : ko   ( len -- len ) &135 rt  dup 2* diagonale ;             | ' haus alias laus                                                                                                             : nikolaushaus    &500                                              dies ist das haus vom ni ko laus    drop ;                                                                                  : siedlung  page 0 &170 setxy                                      &10 0 DO &90 seth nikolaushaus pu  0 seth &60 fd pd LOOP ;   \ Hilbert-Kurve  Byte 9/86 S 14                          10Oct86| Defer curvleft                                                : curvright ( size order -- )   recursive                          dup 0= IF 2drop exit THEN  1-                                   &90 left  2dup curvleft   over forward                          &90 right 2dup curvright  over forward  2dup curvright          &90 right over forward   curvleft  &90 left ;                                                                                : curvleft [ last @ name> is curvleft ]  ( size order -- )         dup 0= IF 2drop exit THEN  1-                                   &90 right  2dup curvright  over forward                         &90 left   2dup curvleft   over forward  2dup curvleft          &90 left   over forward   curvright &90 right ;                                                                              : hilbert ( size order -- )                                           page   0 0 setxy   0 setheading pendown curvright ;