home *** CD-ROM | disk | FTP | other *** search
- \\ *** Graphic - Demonstrationen *** 26may86we Dieses File enthält einige Graphic-Demos, die von den Line-A Routinen Gebrauch machen. Hier bietet sich auch dem Anfänger ein weites Feld für eigene Versuche. Mit CHECKING ON kann man die gröbsten Fehler abfan- gen, alledings auf Kosten der Geschwindigkeit. \ Demo Loadscreen 21sep86we \needs Graphics include line_a.scr Onlyforth Graphics also definitions 1 &11 +thru moire kaleidos lines boxes rechtecke rechtecke1 \ patterns 18sep86we 1 ?head ! : !pattern ( d -- ) Create , , ; $C000.C000 !pattern p1 $CCCC.3333 !pattern p2 $C0C0.3030 !pattern p3 $0303.0C0C !pattern p4 $C003.300C !pattern p5 $C3C3.3C3C !pattern p6 $FFFF.8001 !pattern p7 $40A0.8040 !pattern p8 $4444.0000 !pattern p9 $FFFF.2222 !pattern p10 $4444.8282 !pattern p11 $8080.8888 !pattern p12 $0000.1010 !pattern p13 $0101.8080 !pattern p14 $7777.8888 !pattern p15 $7E7E.8181 !pattern p16 $E640.FFFF !pattern p17 $3838.C6C6 !pattern p18 0 ?head ! \ patterns 21may86we Create patterns p1 , p2 , p3 , p4 , p5 , p6 , p7 , p8 , p9 , p10 , p11 , p12 , p13 , p14 , p15 , p16 , p17 , p18 , \ diamonds 20sep86we | : yscale &400 &640 */ ; : 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 2 wr_mode ! &319 0 &639 &200 &319 &399 0 &200 4 polygon ; \ some usefull definitions 20sep86we : overwrite 0 wr_mode ! ; : exorwrite 2 wr_mode ! ; | : home get_res scr_res ! 0 0 set ; | : center &320 &200 set ; | : wait BEGIN pause key? UNTIL &25 0 at getkey $FF and #esc = abort" stopped" ; | : logo &117 0 DO ." volksFORTH 83 " LOOP ; | : titel &21 &24 at ." *** v o l k s F O R T H *** " &22 &31 at ." Line-A Graphic " ; \ patterns example 18sep86we : 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 20sep86we | : kaleid exorwrite home center patterns &30 + @ pattern ! 2 0 DO $40 1 DO $140 0 DO I diamond J +LOOP LOOP LOOP ; : kaleidos page big_diamond kaleid wait ; : kaleid1 page logo kaleid wait ; : diamonds 1 pat_mask ! $10 0 DO patterns I 2* + @ pattern ! page big_diamond wait LOOP ; \ polygon example 18sep86we | : (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 &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 : moire page curoff exorwrite titel &400 1 DO &640 0 DO I &399 &639 I - 0 line J +LOOP &400 0 DO &639 &398 I - 0 I line J +LOOP LOOP 1 &399 DO &640 0 DO I &399 &639 I - 0 line J +LOOP &400 0 DO &639 &398 I - 0 I line J +LOOP -1 +LOOP wait ; \ boxes 17sep86we : boxes exorwrite page &162 0 DO I I set I dup box &639 I 2* - I set I dup box I &399 I 2* - set I dup box &639 I 2* - &399 I 2* - set I dup box 2 +LOOP wait ; | Code a>r 4 SP D) D0 move D0 SP ) sub 6 SP D) D0 move D0 2 SP D) sub Next end-code : abox ( x1 y1 x2 y2 -- ) a>r 2swap set box ; \ Rechtecke 17sep86we : rechtecke exorwrite page 0 BEGIN stop? not WHILE 8 + dup >r r@ &640 mod r@ &400 mod &639 r@ - &640 mod &399 r> - &400 mod abox REPEAT drop ; : rechtecke1 page exorwrite fullpattern pattern ! BEGIN stop? not WHILE &99 3 DO &300 0 DO I dup dup J + dup a>r rectangle J +LOOP LOOP 3 &98 DO &300 0 DO I dup dup J + dup a>r rectangle J +LOOP -1 +LOOP REPEAT ; \ linien punkte 18sep86we | : (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 stop? UNTIL &25 0 at ; : 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 ; \ Sprites 20sep86we \needs q : q ; forget q : q ; : Sprite: Create 5 0 DO 4 I - roll , LOOP $10 0 DO $FFFF , $0F I - roll , LOOP ; Create spritebuf &74 allot --> %0000000000000000 \ 20sep86we%0111111111111100 %0100000000000000 %0100000000000000 %0100000000000000 %0100000000000000 %0100000000000000 %0111111111110000 %0100000000000000 %0100000000000000 %0100000000000000 %0100000000000000 %0100000000000000 %0100000000000000 %0100000000000000 %0000000000000000 0 0 1 0 1 Sprite: test
