home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / tshade / drawpoly.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-06-04  |  4.0 KB  |  179 lines
  1. (*
  2.   ──────────────────────
  3.   Fill Poly    unit v1.1
  4.   ──────────────────────
  5.   (c)1994   Rsc Research
  6.  
  7.   Write me at:     or on Compuserve
  8.   ────────────     ────────────────
  9.   Cédric Rime           100340,2736
  10.   Dixence 21
  11.   1950 Sion
  12.   Switzerland
  13.  
  14.  
  15.   This program is entered as Shareware.
  16.   If you find it useful, a small donation would be appreciated.(then i can take some English lessons!!!)
  17.  
  18.   Feel free to incorporate the code into your own programs.
  19.  
  20. *)
  21.  
  22. {$F-}{$N+}{$E+}{$D-}{$L-}{$Y-}
  23. UNIT DrawPoly;
  24. INTERFACE
  25.  
  26. USES crt;
  27.  
  28. TYPE PT=RECORD x,y:LongInt;END;         (*Point Type X,Y*)
  29.      tTRI =ARRAY[1..3] OF pt;
  30.  
  31.  
  32. TYPE Pvs=^tvs;
  33.      tVS=ARRAY[0..199,0..319] OF BYTE;  (*Virtual Display*)
  34. VAR  VS:Pvs;
  35. CONST SIF=64;                           (*Don't change!!!*)
  36.  
  37.  
  38. PROCEDURE Point(x,y:INTEGER;co:BYTE);   (*Draw a point*)
  39. PROCEDURE Quad(p:ARRAY OF pt;co:BYTE);  (*Draw 4 sides polygon*)
  40. PROCEDURE Tri(P:ARRAY OF pt;co:BYTE);   (*Draw 3 sides    "*)
  41.  
  42. PROCEDURE vscls;                        (*Clear display*)
  43. PROCEDURE vsShow;                       (*Show  display*)
  44. PROCEDURE vsInit;                       (*Init Display*)
  45. PROCEDURE vsDone;                       (*Restore Display*)
  46. PROCEDURE SetRGB(co,r,g,b:BYTE);
  47.  
  48. IMPLEMENTATION
  49.  
  50.  
  51. PROCEDURE SetRGB(co,r,g,b:BYTE);
  52. BEGIN
  53. Port[$3C8] := Co;
  54. Port[$3C9] := R;
  55. Port[$3C9] := G;
  56. Port[$3C9] := B;
  57. END;
  58.  
  59. PROCEDURE vsInit;
  60. VAR q:BYTE;
  61. BEGIN
  62. GetMem(vs,SizeOf(tvs)+1024);
  63. IF vs=NIL THEN BEGIN WriteLn;WriteLn('Not enough memory');HALT;END;
  64. asm
  65. mov ax,$0013
  66. Int $10
  67. END;
  68. FOR q:=1 TO 255 DO setrgb(q,q SHR 2,0,q DIV 10);
  69. END;
  70.  
  71. PROCEDURE vsDone;
  72. BEGIN
  73. TextMode(lastmode);
  74. FreeMem(vs,SizeOf(tvs)+1024);
  75. END;
  76.  
  77.  
  78. PROCEDURE vscls;
  79. BEGIN
  80. FillChar(vs^[0,0],SizeOf(Tvs),0);
  81. END;
  82.  
  83. PROCEDURE vsShow;
  84. BEGIN
  85. Move(vs^[0,0],mem[segA000:0],SizeOf(tvs));
  86. END;
  87.  
  88. PROCEDURE Point(x,y:INTEGER;co:BYTE);
  89. BEGIN
  90. IF (x<=319) AND (x>=0) AND (y<=199) AND (y>=0) THEN
  91.    vs^[y,x]:=co;
  92. END;
  93.  
  94.  
  95. PROCEDURE Tri(P:ARRAY OF pt;co:BYTE);
  96. VAR q,w:INTEGER;
  97.     S:pt;
  98.     f12,f13,f23:LongInt;
  99.     s1,s2:LongInt;
  100.  
  101. PROCEDURE Hline(s1,s2:LongInt;y:INTEGER;co:BYTE);
  102. VAR x1,x2:INTEGER;
  103.     q:INTEGER;
  104. BEGIN
  105. x1:=s1 DIV SIF;
  106. x2:=s2 DIV SIF;
  107. IF x1>x2 THEN BEGIN q:=x1;x1:=x2;x2:=q;END;
  108. IF x1<0 THEN x1:=0;
  109. IF x2<0 THEN EXIT;
  110. IF x1>319 THEN EXIT;
  111. IF x2>319 THEN x2:=319;
  112. IF y<0 THEN EXIT;
  113. IF y>199 THEN EXIT;
  114. FOR q:=x1 TO x2 DO IF vs^[y,q]=0 THEN vs^[y,q]:=co;
  115. END;
  116.  
  117. BEGIN
  118. IF p[0].y>p[2].y THEN BEGIN s:=p[0];p[0]:=p[2];p[2]:=s;END;
  119. IF p[0].y>p[1].y THEN BEGIN s:=p[0];p[0]:=p[1];p[1]:=s;END;
  120. IF p[1].y>p[2].y THEN BEGIN s:=p[1];p[1]:=p[2];p[2]:=s;END;
  121.  
  122. q:=(p[0].y-p[1].y);
  123. IF q<>0 THEN f12:=LongInt((p[0].x-p[1].x) * SIF) DIV q ELSE f12:=0;
  124. q:=(p[0].y-p[2].y);
  125. IF q<>0 THEN f13:=LongInt((p[0].x-p[2].x) * SIF) DIV q ELSE f13:=0;
  126. q:=(p[1].y-p[2].y);
  127. IF q<>0 THEN f23:=LongInt((p[1].x-p[2].x) * SIF) DIV q ELSE f23:=0;
  128.  
  129. (*
  130. gotoxy(p[0].x div 8,p[0].y div 8);write('1');
  131. gotoxy(p[1].x div 8,p[1].y div 8);write('2');
  132. gotoxy(p[2].x div 8,p[2].y div 8);write('3');
  133. *)
  134.  
  135.  
  136. s1:=p[0].x*SIF;s2:=s1;
  137. FOR q:=p[0].y TO p[1].y DO
  138.  BEGIN
  139.   Hline(s1,s2,q,co);
  140.   s1:=s1+f12;
  141.   s2:=s2+f13;
  142.  END;
  143. s1:=p[2].x*SIF;s2:=s1;
  144. FOR q:=p[2].y DOWNTO p[1].y DO
  145.  BEGIN
  146.   Hline(s1,s2,q,co);
  147.   s1:=s1-f23;
  148.   s2:=s2-f13;
  149.  END;
  150. END;
  151.  
  152.  
  153. (*#############################################################
  154. ###############################################################
  155. ###############################################################
  156. #############################################################*)
  157.  
  158.  
  159. PROCEDURE Quad(p:ARRAY OF pt;co:BYTE);
  160. VAR t1,t2:ARRAY[1..3] OF pt;
  161. BEGIN
  162. t1[1]:=p[0];
  163. t1[2]:=p[1];
  164. t1[3]:=p[2];
  165. t2[1]:=p[0];
  166. t2[2]:=p[2];
  167. t2[3]:=p[3];
  168. tri(t1,co);
  169. tri(t2,co);
  170. END;
  171.  
  172. (*#############################################################
  173. ###############################################################
  174. ###############################################################
  175. #############################################################*)
  176.  
  177. BEGIN
  178. END.
  179.