VolksForth/8080/AmstradCPC/GRAFDEMO.SCR

\ Grafik Demo                                         UH 03Dec86Dieses File enthaelt im Wesentlichen die Definitionen           der Grafikdemo vom C64 und vom Atari.                                                                                           Start mit INCLUDE GRAFDEMO.SCR                                                                                                  An diesem Beispiel zeigt sich, dass sich mit volksFORTH relativ leicht Programme von einem auf den anderen Rechner uebertragen  lassen, auch wenn die Basis (hier das Grafik-Paket) unterschied-lich ist.                                                       Natuerlich muss auf spezielle Eigenschaften des LINE-A-Grafic   Pakets des Atari verzichtet werden.                             (z.B. gestrichelte Linien zeichen)                              Ist die Basis dagegen gleich, wie z.B der Kern aller volksFORTH Systeme, ist eine Uebernahme von Programmen gar kein Problem    mehr.                                                           \ Demo Loadscreen                                        05Sep86                                                                \needs Graphics     include grafik.scr                          Onlyforth   Graphics also definitions                           \needs exorwrite    include atari.scr \ Atari Grafic-Name Layer \needs 2over        include double.scr                           1 $0A +thru                                                                                                                    \ clear                                                                                                                         moire                                                           \ muster                                                        kaleidos                                                        boxes                                                           \ poly                                                          lines                                                           \ tri.up tri.dn                                          25feb86                                                                | : yscale   [ decimal ] 400 640 */  [ hex ] ;                                                                                  : tri.dn  ( dim --  )                                            >r   cur.x @  cur.y @                                           2dup  r@ yscale  - swap r@ - swap   2swap 2over set             2dup  r@ yscale  - swap r@ + swap  draw                         2dup  r> yscale  +  draw  2swap  draw  set ;                                                                                   : tri.up  ( dim -- )                                             >r   cur.x @   cur.y @                                          2dup  r@  yscale -  2swap  2over  set                           2dup  r@  yscale +  swap  r@ +  swap  draw                      2dup  r@  yscale +  swap  r> -  swap  draw                      2swap  draw  set ;                                             \ diamond                                             UH 05Sep86                                                                : diamond   ( size -- )                                          >r  cur.x @   cur.y @                                           2dup  swap  r@ -  swap   2swap 2over     set                    2dup  r@ yscale -  draw                                         2dup  swap r@ + swap  draw                                      2dup  r> yscale + draw                                          2swap draw   set ;                                                                                                             | : big.diamond                                                    exorwrite  &319 0  &639 &200  &319 &399  0 &200  4  polygon ;                                                                                                                                                                                                                                                                \ some usefull definitions                               05Sep86                                                                | : center    &320 &200 set ;                                   \ | : wrap      #esc con! Ascii v con! ;     wrap               | : logo      &117 0 DO  ." volksFORTH 83    "  LOOP ;          | : wait      BEGIN  pause key?  UNTIL  &25 0 at                              getkey #cr = abort" stopped" ;                    | : titel                                                        &21 &24 at ."  ***  v o l k s F O R T H  *** "                  &22 &31 at        ."  Line-A Graphic " ;                                                                                                                                                                                                                                                                                                                                                                                                                       \ patterns example                                       04Sep86\\                                                              : muster                                                         page   overwrite    1 pat.mask !                                $10 0 DO  patterns I 2* + @  pattern !                                    $10 I $10 * + dup  $80 $80  rectangle  LOOP           6 pat.mask !                                                    $10 0 DO  patterns I 2* + @  pattern !                              $110 I $10 * dup >r + $110 r> - $80 $80  rectangle  LOOP    1 pat.mask ! wait  ;                                                                                                                                                                                                                                                                                                                                                                                                                                           \ kaleidoskop                                         UH 05Sep86                                                                | : kaleid    exorwrite   home center                           \             patterns &30 + @  pattern !                                     2 0 DO                                                          $40 1 DO  $140 0 DO  I diamond  J 2* +LOOP 2 +LOOP              LOOP ;                                                                                                            : kaleidos    page  big.diamond  kaleid wait ;                  : kaleid1     page  logo  kaleid wait ;                                                                                         : diamonds    $10 0 DO  \ patterns I 2* + @  pattern !                                  page big.diamond  wait  LOOP ;                                                                                                                                                                                                          \ polygon example                                        05Sep86                                                                | : (poly   ( x y -- )                                           2dup  >r &100 +  r> &10 +                                       2dup  >r  &10 +  r> &90 +                                       2dup  >r  &30 -  r> &20 +                                       2dup  >r  &50 -  r> &35 -                                       2dup  >r  &30 -  r> &85 -  6  polygon ;                        \\                                                              : poly   page invtrans                                           &10 0  DO  patterns I 5 + 2* + @  pattern !                                I I * &5 * I &30 * (poly  LOOP                       &10 0  DO  patterns I 5 + 2* + @  pattern !                           &510 I I * &5 * -  I &30 * (poly  LOOP                    wait  ;                                                                                                                        \ moire                                                  27feb86                                                                : moire    page  curoff  exorwrite                                 &640 0 DO  I  &399  &639 I - 0  line   3 +loop                  &399 0 DO  &639  &398 I -  0 I  line   2 +loop                titel  wait   ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                \ boxes                                                  05Sep86                                                                : boxes   page                                                   &162 0 DO      I           I      set  I I box                            &639 I 2* -      I      set  I I box                                 I      &399 I 2* - set  I I box                            &639 I 2* - &399 I 2* - set  I I box  2 +LOOP         wait  ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        \ linien                                                 27feb86                                                                | : (lines ( abstand -- )   exorwrite                             &640 0 DO                                                                &640 0 DO  I &399  J 0  line   dup +LOOP               dup +LOOP drop ;                                                                                                              : lines  page home  curoff                                       &45 (lines &90 (lines                                           BEGIN &45 (lines key $FF and $0D = UNTIL                        &25 0 at ;                                                                                                                                                                                                                                                                                                                                                                                     \ moire punkte muster                                    05Sep86                                                                : kreis.moire    page                                            &320 0 DO                                                       &199 0 DO  I dup *  J dup *  +  &300 /  1 and                       IF  &320 J +  &200 I +  1  put.pixel                                &320 J -  &200 I +  1  put.pixel                                &320 J -  &200 I -  1  put.pixel                                &320 J +  &200 I -  1  put.pixel                            THEN  2 +LOOP  LOOP                                         wait   ;