home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / TUT1-9.ZIP / TUTPROG3.PAS < prev    next >
Pascal/Delphi Source File  |  1993-07-27  |  8KB  |  269 lines
  1. {$X+}
  2. USES crt;
  3.  
  4. CONST VGA = $a000;
  5.  
  6. VAR loop1:integer;
  7.     Pall : Array [1..199,1..3] of byte;
  8.       { This is our temporary pallette. We ony use colors 1 to 199, so we
  9.         only have variables for those ones. }
  10.  
  11. {──────────────────────────────────────────────────────────────────────────}
  12. Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
  13. BEGIN
  14.   asm
  15.      mov        ax,0013h
  16.      int        10h
  17.   end;
  18. END;
  19.  
  20.  
  21. {──────────────────────────────────────────────────────────────────────────}
  22. Procedure SetText;  { This procedure returns you to text mode.  }
  23. BEGIN
  24.   asm
  25.      mov        ax,0003h
  26.      int        10h
  27.   end;
  28. END;
  29.  
  30.  
  31. {──────────────────────────────────────────────────────────────────────────}
  32. Procedure Putpixel (X,Y : Integer; Col : Byte);
  33.   { This puts a pixel on the screen by writing directly to memory. }
  34. BEGIN
  35.   Mem [VGA:X+(Y*320)]:=Col;
  36. END;
  37.  
  38.  
  39. {──────────────────────────────────────────────────────────────────────────}
  40. procedure WaitRetrace; assembler;
  41. label
  42.   l1, l2;
  43. asm
  44.     mov dx,3DAh
  45. l1:
  46.     in al,dx
  47.     and al,08h
  48.     jnz l1
  49. l2:
  50.     in al,dx
  51.     and al,08h
  52.     jz  l2
  53. end;
  54.  
  55.  
  56. {──────────────────────────────────────────────────────────────────────────}
  57. Procedure Pal(ColorNo : Byte; R,G,B : Byte);
  58.   { This sets the Red, Green and Blue values of a certain color }
  59. Begin
  60.    Port[$3c8] := ColorNo;
  61.    Port[$3c9] := R;
  62.    Port[$3c9] := G;
  63.    Port[$3c9] := B;
  64. End;
  65.  
  66.  
  67. {──────────────────────────────────────────────────────────────────────────}
  68. Procedure Circle (X,Y,rad:integer;Col:Byte);
  69.   { This draws a circle with centre X,Y, with Rad as it's radius }
  70. VAR deg:real;
  71. BEGIN
  72.   deg:=0;
  73.   repeat
  74.     X:=round(rad*COS (deg));
  75.     Y:=round(rad*sin (deg));
  76.     putpixel (x+160,y+100,col);
  77.     deg:=deg+0.005;
  78.   until (deg>6.4);
  79. END;
  80.  
  81.  
  82. {──────────────────────────────────────────────────────────────────────────}
  83. Procedure Line2 (x1,y1,x2,y2:integer;col:byte);
  84.   { This draws a line from x1,y1 to x2,y2 using the first method }
  85. VAR x,y,xlength,ylength,dx,dy:integer;
  86.     xslope,yslope:real;
  87. BEGIN
  88.   xlength:=abs (x1-x2);
  89.   if (x1-x2)<0 then dx:=-1;
  90.   if (x1-x2)=0 then dx:=0;
  91.   if (x1-x2)>0 then dx:=+1;
  92.   ylength:=abs (y1-y2);
  93.   if (y1-y2)<0 then dy:=-1;
  94.   if (y1-y2)=0 then dy:=0;
  95.   if (y1-y2)>0 then dy:=+1;
  96.   if (dy=0) then BEGIN
  97.     if dx<0 then for x:=x1 to x2 do
  98.       putpixel (x,y1,col);
  99.     if dx>0 then for x:=x2 to x1 do
  100.       putpixel (x,y1,col);
  101.     exit;
  102.   END;
  103.   if (dx=0) then BEGIN
  104.     if dy<0 then for y:=y1 to y2 do
  105.       putpixel (x1,y,col);
  106.     if dy>0 then for y:=y2 to y1 do
  107.       putpixel (x1,y,col);
  108.     exit;
  109.   END;
  110.   xslope:=xlength/ylength;
  111.   yslope:=ylength/xlength;
  112.   if (yslope/xslope<1) and (yslope/xslope>-1) then BEGIN
  113.     if dx<0 then for x:=x1 to x2 do BEGIN
  114.                    y:= round (yslope*x);
  115.                    putpixel (x,y,col);
  116.                  END;
  117.     if dx>0 then for x:=x2 to x1 do BEGIN
  118.                    y:= round (yslope*x);
  119.                    putpixel (x,y,col);
  120.                  END;
  121.   END
  122.   ELSE
  123.   BEGIN
  124.     if dy<0 then for y:=y1 to y2 do BEGIN
  125.                    x:= round (xslope*y);
  126.                    putpixel (x,y,col);
  127.                  END;
  128.     if dy>0 then for y:=y2 to y1 do BEGIN
  129.                    x:= round (xslope*y);
  130.                    putpixel (x,y,col);
  131.                  END;
  132.   END;
  133. END;
  134.  
  135.  
  136. {──────────────────────────────────────────────────────────────────────────}
  137. procedure line(a,b,c,d,col:integer);
  138.   { This draws a line from x1,y1 to x2,y2 using the first method }
  139.  
  140.     function sgn(a:real):integer;
  141.     begin
  142.          if a>0 then sgn:=+1;
  143.          if a<0 then sgn:=-1;
  144.          if a=0 then sgn:=0;
  145.     end;
  146.  
  147. var u,s,v,d1x,d1y,d2x,d2y,m,n:real;
  148.     i:integer;
  149. begin
  150.      u:= c - a;
  151.      v:= d - b;
  152.      d1x:= SGN(u);
  153.      d1y:= SGN(v);
  154.      d2x:= SGN(u);
  155.      d2y:= 0;
  156.      m:= ABS(u);
  157.      n := ABS(v);
  158.      IF NOT (M>N) then
  159.      BEGIN
  160.           d2x := 0 ;
  161.           d2y := SGN(v);
  162.           m := ABS(v);
  163.           n := ABS(u);
  164.      END;
  165.      s := INT(m / 2);
  166.      FOR i := 0 TO round(m) DO
  167.      BEGIN
  168.           putpixel(a,b,col);
  169.           s := s + n;
  170.           IF not (s<m) THEN
  171.           BEGIN
  172.                s := s - m;
  173.                a:= a +round(d1x);
  174.                b := b + round(d1y);
  175.           END
  176.           ELSE
  177.           BEGIN
  178.                a := a + round(d2x);
  179.                b := b + round(d2y);
  180.           END;
  181.      end;
  182. END;
  183.  
  184.  
  185. {──────────────────────────────────────────────────────────────────────────}
  186. Procedure PalPlay;
  187.   { This procedure mucks about with our "virtual pallette", then shoves it
  188.     to screen. }
  189. Var Tmp : Array[1..3] of Byte;
  190.   { This is used as a "temporary color" in our pallette }
  191.     loop1 : Integer;
  192. BEGIN
  193.    Move(Pall[199],Tmp,3);
  194.      { This copies color 199 from our virtual pallette to the Tmp variable }
  195.    Move(Pall[1],Pall[2],198*3);
  196.      { This moves the entire virtual pallette up one color }
  197.    Move(Tmp,Pall[1],3);
  198.      { This copies the Tmp variable to the bottom of the virtual pallette }
  199.    WaitRetrace;
  200.    For loop1:=1 to 199 do
  201.      pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
  202. END;
  203.  
  204.  
  205. BEGIN
  206.   ClrScr;
  207.   Writeln ('This sample program will test out our line and circle algorithms.');
  208.   Writeln ('In the first part, many circles will be draw creating (hopefully)');
  209.   Writeln ('a "tunnel" effect. I will the rotate the pallete to make it look');
  210.   Writeln ('nice. I will then draw some lines and rotate the pallette on them');
  211.   Writeln ('too. Note : I am using the slower (first) line algorithm (in');
  212.   Writeln ('procedure line2). Change it to Procedure Line and it will be using');
  213.   Writeln ('the second line routine. NB : For descriptions on how pallette works');
  214.   Writeln ('have a look at part two of this series; I won''t re-explain it here.');
  215.   Writeln;
  216.   Writeln ('Remember to send me any work you have done, I am most eager to help.');
  217.   Writeln; Writeln;
  218.   Writeln ('Hit any key to continue ...');
  219.   Readkey;
  220.   setmcga;
  221.  
  222.   For Loop1 := 1 to 199 do BEGIN
  223.     Pall[Loop1,1] := Loop1 mod 30+33;
  224.     Pall[Loop1,2] := 0;
  225.     Pall[Loop1,3] := 0;
  226.   END;
  227.        { This sets colors 1 to 199 to values between 33 to 63. The MOD
  228.          function gives you the remainder of a division, ie. 105 mod 10 = 5 }
  229.  
  230.    WaitRetrace;
  231.    For loop1:=1 to 199 do
  232.      pal (loop1,pall[loop1,1],pall[loop1,2],pall[loop1,3]);
  233.         { This sets the true pallette to variable Pall }
  234.  
  235.   for loop1:=1 to 90 do
  236.     circle (160,100,loop1,loop1);
  237.        { This draws 90 circles all with centres at 160,100; with increasing
  238.          radii and colors. }
  239.  
  240.   Repeat
  241.     PalPlay;
  242.   Until keypressed;
  243.   Readkey;
  244.  
  245.   for loop1:=1 to 199 do
  246.     line2 (0,1,319,loop1,loop1);   { *** Replace Line2 with Line to use the
  247.                                          second line algorithm *** }
  248.        { This draws 199 lines, all starting at 0,1 }
  249.  
  250.   Repeat
  251.     PalPlay;
  252.   Until keypressed;
  253.  
  254.   readkey;
  255.   SetText;
  256.   Writeln ('All done. Okay, so maybe it wasn''t a tunnel effect, but you get the');
  257.   Writeln ('general idea ;-) This concludes the third sample program in the ASPHYXIA');
  258.   Writeln ('Training series. You may reach DENTHOR under the name of GRANT SMITH');
  259.   Writeln ('on the MailBox BBS, or leave a message to ASPHYXIA on the ASPHYXIA BBS.');
  260.   Writeln ('Get the numbers from Roblist, or write to :');
  261.   Writeln ('             Grant Smith');
  262.   Writeln ('             P.O. Box 270');
  263.   Writeln ('             Kloof');
  264.   Writeln ('             3640');
  265.   Writeln ('I hope to hear from you soon!');
  266.   Writeln; Writeln;
  267.   Write   ('Hit any key to exit ...');
  268.   Readkey;
  269. END.