home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / TUT1-9.ZIP / TUTPROG6.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-10-01  |  7.7 KB  |  242 lines
  1. {$X+}
  2. USES crt;
  3.  
  4. CONST VGA = $a000;
  5.  
  6. TYPE tbl = Array [1..8000] of real;
  7.              { This will be the shape of the 'table' where we look up
  8.                values, which is faster then calculating them }
  9.  
  10. VAR loop1:integer;
  11.     Pall : Array [1..20,1..3] of byte;
  12.       { This is our temporary pallette. We ony use colors 1 to 20, so we
  13.         only have variables for those ones. }
  14.  
  15. {──────────────────────────────────────────────────────────────────────────}
  16. Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
  17. BEGIN
  18.   asm
  19.      mov        ax,0013h
  20.      int        10h
  21.   end;
  22. END;
  23.  
  24.  
  25. {──────────────────────────────────────────────────────────────────────────}
  26. Procedure SetText;  { This procedure returns you to text mode.  }
  27. BEGIN
  28.   asm
  29.      mov        ax,0003h
  30.      int        10h
  31.   end;
  32. END;
  33.  
  34. {──────────────────────────────────────────────────────────────────────────}
  35. Procedure Cls (Col : Byte);
  36.    { This clears the screen to the specified color }
  37. BEGIN
  38.   Fillchar (Mem [VGA:0],64000,col);
  39. END;
  40.  
  41.  
  42. {──────────────────────────────────────────────────────────────────────────}
  43. Procedure Putpixel (X,Y : Integer; Col : Byte);
  44.   { This puts a pixel on the screen by writing directly to memory. }
  45. BEGIN
  46.   Mem [VGA:X+(Y*320)]:=Col;
  47. END;
  48.  
  49.  
  50. {──────────────────────────────────────────────────────────────────────────}
  51. procedure WaitRetrace; assembler;
  52.   {  This waits for a vertical retrace to reduce snow on the screen }
  53. label
  54.   l1, l2;
  55. asm
  56.     mov dx,3DAh
  57. l1:
  58.     in al,dx
  59.     and al,08h
  60.     jnz l1
  61. l2:
  62.     in al,dx
  63.     and al,08h
  64.     jz  l2
  65. end;
  66.  
  67.  
  68. {──────────────────────────────────────────────────────────────────────────}
  69. Procedure Pal(ColorNo : Byte; R,G,B : Byte);
  70.   { This sets the Red, Green and Blue values of a certain color }
  71. Begin
  72.    Port[$3c8] := ColorNo;
  73.    Port[$3c9] := R;
  74.    Port[$3c9] := G;
  75.    Port[$3c9] := B;
  76. End;
  77.  
  78.  
  79. {──────────────────────────────────────────────────────────────────────────}
  80. Function rad (theta : real) : real;
  81.   {  This calculates the degrees of an angle }
  82. BEGIN
  83.   rad := theta * pi / 180
  84. END;
  85.  
  86.  
  87.  
  88. {──────────────────────────────────────────────────────────────────────────}
  89. Procedure NormCirc;
  90.   { This generates a spireal without using a lookup table }
  91. VAR deg,radius:real;
  92.     x,y:integer;
  93.  
  94. BEGIN
  95.   gotoxy (1,1);
  96.   Writeln ('Without pregenerated arrays.');
  97.   for loop1:=60 downto 43 do BEGIN
  98.     deg:=0;
  99.     radius:=loop1;
  100.     repeat
  101.       X:=round(radius*COS (rad (deg)));
  102.       Y:=round(radius*sin (rad (deg)));
  103.       putpixel (x+160,y+100,61-loop1);
  104.       deg:=deg+0.4;           { Increase the degree so the circle is round }
  105.       radius:=radius-0.02;    { Decrease the radius for a spiral effect }
  106.     until radius<0; {  Continue till at the centre (the radius is zero) }
  107.   END;
  108. END;
  109.  
  110.  
  111. {──────────────────────────────────────────────────────────────────────────}
  112. Procedure LookupCirc;
  113.   {  This draws a spiral using a lookup table }
  114. VAR radius:real;
  115.     x,y,pos:integer;
  116.     costbl : ^tbl;
  117.     sintbl : ^tbl;
  118.  
  119.     Procedure Setupvars;
  120.       {  This is a nested procedure (a procedure in a procedure), and may
  121.          therefore only be used from within the main part of this procedure.
  122.          This section gets the memory for the table, then generates the
  123.          table. }
  124.     VAR deg:real;
  125.     BEGIN
  126.       getmem (costbl,sizeof(costbl^));
  127.       getmem (sintbl,sizeof(sintbl^));
  128.       deg:=0;
  129.       for loop1:=1 to 8000 do BEGIN         { There are 360 degrees in a    }
  130.         deg:=deg+0.4;                       { circle. If you increase the   }
  131.         costbl^[loop1]:=cos (rad(deg));     { degrees by 0.4, the number of }
  132.         sintbl^[loop1]:=sin (rad(deg));     { needed parts of the table is  }
  133.       END;                                  { 360/0.4=8000                  }
  134.     END;
  135.     { NB : For greater accuracy I increase the degrees by 0.4, because if I
  136.            increase them by one, holes are left in the final product as a
  137.            result of the rounding error margin. This means the pregen array
  138.            is bigger, takes up more memory and is slower to calculate, but
  139.            the finished product looks better.}
  140.  
  141. BEGIN
  142.   cls (0);
  143.   gotoxy (1,1);
  144.   Writeln ('Generating variables....');
  145.   setupvars;
  146.   gotoxy (1,1);
  147.   Writeln ('With pregenerated arrays.');
  148.   for loop1:=60 downto 43 do BEGIN
  149.     pos:=1;
  150.     radius:=loop1;
  151.     repeat
  152.       X:=round (radius*costbl^[pos]);   { Note how I am not recalculating sin}
  153.       Y:=round (radius*sintbl^[pos]);   { and cos for each point.            }
  154.       putpixel (x+160,y+100,61-loop1);
  155.       radius:=radius-0.02;
  156.       inc (pos);
  157.       if pos>8000 then pos:=1;    { I only made a table from 1 to 8000, so it}
  158.                                   { must never exceed that, or the program   }
  159.                                   { will probably crash.                     }
  160.     until radius<0;
  161.   END;
  162.   freemem (costbl,sizeof(costbl^));   { Freeing the memory taken up by the   }
  163.   freemem (sintbl,sizeof(sintbl^));   { tables. This is very important.      }
  164. END;
  165.  
  166.  
  167. {──────────────────────────────────────────────────────────────────────────}
  168. Procedure PalPlay;
  169.   { This procedure mucks about with our "virtual pallette", then shoves it
  170.     to screen. }
  171. Var Tmp : Array[1..3] of Byte;
  172.   { This is used as a "temporary color" in our pallette }
  173.     loop1 : Integer;
  174. BEGIN
  175.    Move(Pall[1],Tmp,3);
  176.      { This copies color 1 from our virtual pallette to the Tmp variable }
  177.    Move(Pall[2],Pall[1],18*3);
  178.      { This moves the entire virtual pallette down one color }
  179.    Move(Tmp,Pall[18],3);
  180.      { This copies the Tmp variable to no. 18 of the virtual pallette }
  181.    WaitRetrace;
  182.    For loop1:=1 to 18 do
  183.      pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
  184. END;
  185.  
  186.  
  187. BEGIN
  188.   ClrScr;
  189.   writeln ('Hi there! This program will demonstrate the usefullness of ');
  190.   writeln ('pregenerated arrays, also known as lookup tables. The program');
  191.   writeln ('will first draw a spiral without using a lookup table, rotate');
  192.   writeln ('the pallette until a key is pressed, the calculate the lookup');
  193.   writeln ('table, then draw the same spiral using the lookup table.');
  194.   writeln;
  195.   writeln ('This is merely one example for the wide range of uses of a ');
  196.   writeln ('lookup table.');
  197.   writeln;
  198.   writeln;
  199.   Write ('  Hit any key to contine ...');
  200.   Readkey;
  201.   setmcga;
  202.   directvideo:=FALSE;  { This handy trick allows you to use GOTOXY and }
  203.                        { Writeln in GFX mode. Hit CTRL-F1 on it for more }
  204.                        { info/help }
  205.   For Loop1 := 1 to 18 do BEGIN
  206.     Pall[Loop1,1] := (Loop1*3)+9;
  207.     Pall[Loop1,2] := 0;
  208.     Pall[Loop1,3] := 0;
  209.   END;
  210.        { This sets colors 1 to 18 to values between 12 to 63. }
  211.  
  212.    WaitRetrace;
  213.    For loop1:=1 to 18 do
  214.      pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
  215.         { This sets the true pallette to variable Pall }
  216.  
  217.   normcirc;         { This draws a spiral without lookups }
  218.   Repeat
  219.     PalPlay;
  220.   Until keypressed;
  221.   readkey;
  222.   lookupcirc;       { This draws a spiral with lookups }
  223.   Repeat
  224.     PalPlay;
  225.   Until keypressed;
  226.   Readkey;
  227.  
  228.   SetText;
  229.   Writeln ('All done. This concludes the sixth sample program in the ASPHYXIA');
  230.   Writeln ('Training series. You may reach DENTHOR under the name of GRANT');
  231.   Writeln ('SMITH on the MailBox BBS, or leave a message to ASPHYXIA on the');
  232.   Writeln ('ASPHYXIA BBS. I am also an avid Connectix BBS user.');
  233.   Writeln ('Get the numbers from Roblist, or write to :');
  234.   Writeln ('             Grant Smith');
  235.   Writeln ('             P.O. Box 270');
  236.   Writeln ('             Kloof');
  237.   Writeln ('             3640');
  238.   Writeln ('I hope to hear from you soon!');
  239.   Writeln; Writeln;
  240.   Write   ('Hit any key to exit ...');
  241.   Readkey;
  242. END.