home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format 91 / af091a.adf / af91a3.lzx / prgs / Gfx / tri.b < prev   
Encoding:
Text File  |  1996-09-15  |  4.7 KB  |  184 lines
  1. ' HiSoft BASIC demo based on Dreier on the German Extras disk
  2. ' used with permission
  3.  
  4. ' you can load this into AmigaBASIC to see the difference
  5. ' (assumes 80-column text mode)
  6.  
  7. '" dreierneu
  8. '" Demo schnelles Flächenfüllen
  9. '" P. Kittel, CBM Ffm, 4.4.87, 18.6.88
  10.  
  11. '..modified for ACE v1.02 by David J Benn, 13.3.1993
  12. '..modified for ACE v2.03 by David J Benn, 10.3.1994
  13.  
  14. 'CLEAR,4000
  15. 'CLEAR,7500
  16.  
  17. sc&=PEEKL(WINDOW(7) + 46) '" Screen-Struktur
  18. Hoehe=PEEKW(sc&+14)       '" Screen-Höhe
  19. IF Hoehe=256 THEN
  20.   ym=250:y1=140:y0=58:ye=119:zl=29 ':PRINT "PAL-Screen"
  21.           ELSE
  22.   ym=200:y1=105:y0=45:ye= 93:zl=20 ':PRINT "NTSC-Screen"
  23. END IF
  24.  
  25. window 1,"ACE BASIC Demo",(0,0)-(640,200)
  26. PRINT
  27. PRINT "This program illustrates several things:":?
  28. PRINT "1. How fast the Amiga is at colour graphics"
  29. PRINT "2. How fast ACE BASIC for the Amiga is"
  30. PRINT "3. How compatible ACE BASIC is with AmigaBASIC,"
  31. PRINT "   the language supplied with every Amiga."
  32. PRINT
  33. PRINT "If you load the file HBDemo.bas into AmigaBASIC you"
  34. PRINT "will be able to see the difference yourself."
  35. PRINT
  36. 'PRINT "HiSoft BASIC for the Amiga is available from your dealer"
  37. 'PRINT "or, in case of difficulty, from:"
  38. 'PRINT "HiSoft, The Old School, Greenfield, Bedford, MK45 5DE, UK"
  39. 'PRINT "                                      Phone (0525) 718181"
  40. PRINT:PRINT
  41. PRINT "Press any key to begin...";
  42.  
  43. t=TIMER+20
  44. WHILE (INKEY$="") AND (TIMER<t)
  45. WEND
  46.  
  47. window close 1
  48.  
  49. 'fz=0        '1 is prettier but too slow under AmigaBASIC
  50. fz=1
  51.  
  52. SCREEN 1,570,ym,4,2
  53. {IF SYSTAB THEN
  54.     t$=" Compiled with HiSoft BASIC"
  55.     REM $event off
  56.     REM $option a-,e-,x-,b-,o-,n-
  57. ELSE
  58.     t$=" Running under AmigaBASIC"
  59. END IF}
  60.  
  61. t$="Compiled with ACE BASIC"
  62.  
  63. WINDOW 2,t$+" (ESC to exit)",(0,0)-(510,ym),0,1
  64. x1=250
  65. x2=290:y2=y1
  66. z1=0  :z2=0
  67. co=2
  68.  
  69. const nn=15
  70. const nn1=16
  71.  
  72. DIM pr(nn),pg(nn),pb(nn),pra(nn1),pga(nn1),pba(nn1)
  73. FOR i=2 TO nn:PALETTE i,0,0,0:NEXT
  74. fr=0:fg=0:fb=0:pf=0:ff=4000:fs=0:c7=7/15:c6=15*16:c2=15*256
  75. cc=0:cf=1:co2=0
  76. PALETTE 0,.5,.5,.5
  77. COLOR 1
  78. LOCATE 1,2:PRINT "Fast";:     LOCATE 1,50:PRINT "Solid fills";
  79. LOCATE 2,2:PRINT "Graphics" ;:LOCATE 2,50:PRINT "using blitter";
  80. {IF SYSTAB THEN
  81.     LOCATE zl-1,50:PRINT "All with";
  82.         LOCATE zl  ,50:PRINT "HiSoft BASIC!";
  83. END IF}
  84.  
  85. LOCATE zl-1,50:PRINT "All with";
  86. LOCATE zl  ,50:PRINT "ACE BASIC!";
  87.  
  88. IF fz THEN
  89.   LOCATE zl/2-1,25:PRINT "Bitte etwas Geduld...";
  90.   END IF
  91. COLOR 2
  92. LOCATE zl-1,2:PRINT "4096";
  93. LOCATE zl  ,2:PRINT "Colours";
  94.  
  95. '" Die Art der Farbweiterschaltung wird
  96. '" durch die Variablen fs und ff in
  97. '" späteren Zeilen bestimmt.
  98. '" Hier ist viel Raum für eigene
  99. '" Experimente.
  100.  
  101. ex$=CHR$(27)
  102.  
  103. WHILE INKEY$<>ex$
  104.  
  105.   x3=x2 :y3=y2
  106.   z1=z1+.01         :IF z1>6.28 THEN z1=0
  107.   z2=z2+.03*SIN(z1) :IF z2>6.28 THEN z2=0
  108.   z3=z3+z1*SIN(z2)/4:IF z3>6.28 THEN z3=0
  109.  
  110.   x2=INT(120*(1+SIN(z2))*COS(z3)+x1)
  111.   y2=INT( y0*(1+SIN(z2))*SIN(z3)+ye)
  112.   AREA (x1,y1):AREA (x2,y2):AREA (x3,y3)
  113.  
  114.   IF fz=0 THEN
  115.     pra(co)=pr(co):pga(co)=pg(co):pba(co)=pb(co)
  116.     PALETTE co,pr(co),pg(co),pb(co)
  117.     END IF
  118.  
  119.   '" Farbweiterschaltung
  120.   co=co+1:IF co>nn THEN
  121.     co=2
  122.     co2=co2+1
  123.     IF co2>1 OR fz=0 THEN
  124.       co2=0
  125.       fs=fs+.1:IF fs>7 THEN fs=fs-7
  126.       ff=ff+273.16*(1+COS(fs)*1.02):IF ff>4095 THEN ff=ff-4095
  127.       fi=INT(ff)
  128.       ar=fr:ag=fg:ab=fb
  129.       fr=(fi AND 15)/15
  130.       fg=(fi AND 15*16 )/c6
  131.       fb=(fi AND 15*256)/c2  
  132.       pr(15)=fr:pg(15)=fg:pb(15)=fb ' neue Farbe
  133.       cc=cc+1:IF cc>20 THEN cc=0:cf=-cf
  134.       IF cf*(fr+ar)>cf THEN
  135.         fr2=2-fr:m=(fr2-ar)/14:a=ar-m
  136.         FOR i=2 TO 14:pr(i)=a+i*m:IF pr(i)>1 THEN pr(i)=2-pr(i)
  137.           NEXT
  138.               ELSE
  139.         fr2=-fr:m=(fr2-ar)/14:a=ar-m
  140.         FOR i=2 TO 14:pr(i)=a+i*m:IF pr(i)<0 THEN pr(i)=-pr(i)
  141.           NEXT
  142.         END IF
  143.       IF cf*(fg+ag)>cf THEN
  144.         fg2=2-fg:m=(fg2-ag)/14:a=ag-m
  145.         FOR i=2 TO 14:pg(i)=a+i*m:IF pg(i)>1 THEN pg(i)=2-pg(i)
  146.           NEXT
  147.               ELSE
  148.         fg2=-fg:m=(fg2-ag)/14:a=ag-m
  149.         FOR i=2 TO 14:pg(i)=a+i*m:IF pg(i)<0 THEN pg(i)=-pg(i)
  150.           NEXT
  151.         END IF
  152.       IF cf*(fb+ab)>cf THEN
  153.         fb2=2-fb:m=(fb2-ab)/14:a=ab-m
  154.         FOR i=2 TO 14:pb(i)=a+i*m:IF pb(i)>1 THEN pb(i)=2-pb(i)
  155.           NEXT
  156.               ELSE
  157.         fb2=-fb:m=(fb2-ab)/14:a=ab-m
  158.         FOR i=2 TO 14:pb(i)=a+i*m:IF pb(i)<0 THEN pb(i)=-pb(i)
  159.           NEXT
  160.         END IF
  161.       END IF
  162.     END IF
  163.  
  164.   IF fz THEN
  165.     '" Palette zyklisch umbelegen  
  166.      FOR i=nn+1 TO 3 STEP -1
  167.        pra(i)=pra(i-1): pga(i)=pga(i-1): pba(i)=pba(i-1)
  168.        NEXT
  169.      pra(2)=pra(nn+1): pga(2)=pga(nn+1): pba(2)=pba(nn+1)
  170.      cd=2*co-2: IF cd>nn THEN cd=cd-nn+1
  171.      pra(cd)=pr(co):   pga(cd)=pg(co):   pba(cd)=pb(co)
  172.      FOR i=2 TO nn:PALETTE i,pra(i),pga(i),pba(i):NEXT
  173.      END IF
  174.  
  175.   COLOR co
  176.   AREAFILL
  177.   WEND
  178.  
  179. '" Am Schluß sauber aufräumen
  180. WINDOW CLOSE 2
  181. SCREEN CLOSE 1
  182. 'IF SYSTAB THEN SYSTEM
  183. END
  184.