home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / tshade / tshade.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1994-06-04  |  11.9 KB  |  427 lines
  1. (*
  2.   ──────────────────────
  3.   Quick Shade  unit v1.0
  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.  
  23. {$F-}
  24. {$N+}
  25. {$E+}
  26. {$D-}
  27. {$L-}
  28. {$Y-}
  29.  
  30.  
  31. UNIT Tshade;
  32. INTERFACE
  33.  
  34.  
  35. {$define pointperface=3}
  36. USES drawpoly,crt,tools;
  37.  
  38. TYPE points=RECORD
  39.        x,y,z:real;
  40.        END;
  41.      patchs=RECORD
  42.        s1,s2,s3:WORD;
  43.        col:BYTE;
  44.        END;
  45.  
  46.  
  47. CONST MaxP=1500;                 (*Max points in world*)
  48.  
  49.  
  50. VAR pnt:ARRAY[1..MaxP] OF points;
  51.     pat:ARRAY[1..MaxP] OF patchs;
  52.     dwg:ARRAY[1..MaxP] OF pt;
  53.     zbuffering:ARRAY[1..MaxP] OF real;
  54.     sort:ARRAY[1..MaxP] OF WORD;
  55.  
  56.     pacount:WORD;                (*Patch in drawing*)
  57.     pocount:WORD;                (*Points in drawing*)
  58.     midx,midy:INTEGER;           (*Screen Center coord. = Drawing center*)
  59.  
  60.     Light1,Light2:INTEGER;       (*2 points for light direction*)
  61.     LightPat:INTEGER;            (*1 patch for light drawing*)
  62.     LightRadius:real;            (*Length for Light drawing*)
  63.  
  64.     LightColor:BYTE;             (*What's color*)
  65.     LightFactor:real;            (*Light Factory*)
  66.     LightAmbient:BYTE;           (*Light Ambient*)
  67.  
  68.     FrontClip:real;              (*Minimal value for front clipping*)
  69.  
  70. PROCEDURE InitShade;             (*Sort All Points on Z axis*)
  71. PROCEDURE AddLight;              (*Show LightPosition*)
  72. PROCEDURE redraw;                (*Redraw Picture, use double buffering*)
  73. PROCEDURE Clear;                 (*Clean drawing*)
  74. FUNCTION  AddPoint(x,y,z:real):INTEGER;       (*Add a point in drawing*)
  75. PROCEDURE AddPatch(s1,s2,s3:INTEGER;co:BYTE); (*Add a patch on 3 points*)
  76. PROCEDURE move_center(orgx,orgy,orgz:real);   (*Move Drawing*)
  77. PROCEDURE gravity(VAR xx,yy,zz:real);         (*Calc gravity center*)
  78. PROCEDURE calc(ax,ay,az,dist:real);           (*Rotate drawing on AX&AY angle, AZ=focus DIST=distance*)
  79. PROCEDURE xshade(sun_a,sun_b,sun_c:real);     (*Quick Shading on XYZ axis*)
  80. PROCEDURE shadepalette(faca,facb,facc:real;baseR,BaseG,BaseB:BYTE);
  81.                                               (*Smooth palette, Factor for R,G,B, Base for R,G,B*)
  82. PROCEDURE LoadMesh(nom:STRING;scalex,scaley,scalez:real;col:BYTE);
  83.                                               (*Import Ascii meshes from 3D Studio or ...*)
  84. PROCEDURE Pop;PROCEDURE push;                 (*Used into LoadMesh*)
  85.  
  86. IMPLEMENTATION
  87.  
  88.  
  89. (*########################################################################*)
  90.  
  91. PROCEDURE gravity(VAR xx,yy,zz:real);
  92. VAR q:INTEGER;
  93. BEGIN
  94. xx:=0;yy:=0;zz:=0;
  95. FOR q:=1 TO pocount DO BEGIN xx:=xx+pnt[q].x;yy:=yy+pnt[q].y;zz:=zz+pnt[q].z;END;
  96. xx:=xx/pocount;yy:=yy/pocount;zz:=zz/pocount;
  97. END;
  98.  
  99. (*########################################################################*)
  100.  
  101. FUNCTION ztest(r:real):real; (*If R=0 then return=0.0001*)
  102. BEGIN
  103. IF r=0  THEN ztest:=0.0001 ELSE ztest:=r;
  104. END;
  105.  
  106. (*########################################################################*)
  107.  
  108. PROCEDURE InitShade;
  109. VAR q,w:INTEGER;
  110.     dummy:INTEGER;
  111.     dummy2:BYTE;
  112.     PROCEDURE Swap(n1,n2:BYTE);
  113.     BEGIN
  114.     IF n1>n2 THEN BEGIN Dummy2:=n1;n1:=n2;n2:=dummy2;END;
  115.      IF (n1=1) AND (n2=2) THEN BEGIN dummy:=pat[q].s1;pat[q].s1:=pat[q].s2;pat[q].s2:=dummy;EXIT;END;
  116.      IF (n1=1) AND (n2=3) THEN BEGIN dummy:=pat[q].s1;pat[q].s1:=pat[q].s3;pat[q].s3:=dummy;EXIT;END;
  117.      IF (n1=2) AND (n2=3) THEN BEGIN dummy:=pat[q].s2;pat[q].s2:=pat[q].s3;pat[q].s3:=dummy;EXIT;END;
  118.     END;
  119. BEGIN
  120.   FOR q:=1 TO pacount DO
  121.      BEGIN
  122.       IF pnt[pat[q].s1].z<pnt[pat[q].s2].z THEN Swap(1,2);
  123.       IF pnt[pat[q].s1].z<pnt[pat[q].s3].z THEN Swap(1,3);
  124.       IF pnt[pat[q].s2].z<pnt[pat[q].s3].z THEN Swap(2,3);
  125.      END;
  126. END;
  127.  
  128. (*########################################################################*)
  129.  
  130. PROCEDURE AddLight;
  131. BEGIN
  132. Light1:=addpoint(0,0,0);
  133. Light2:=addpoint(0,0,0);
  134. Addpatch(light1,light2,light2,LightColor);
  135. LightPat:=pacount;
  136. END;
  137.  
  138. (*########################################################################*)
  139.  
  140. PROCEDURE redraw;
  141. VAR q2,q1:INTEGER;
  142.     fa:ARRAY[1..3] OF pt;
  143. BEGIN
  144. vscls;
  145. FOR q2:=1 TO Pacount DO WITH dwg[q1] DO BEGIN
  146.           q1:=sort[q2];
  147.           fa[1]:=dwg[pat[q1].s1];
  148.           fa[2]:=dwg[pat[q1].s2];
  149.           fa[3]:=dwg[pat[q1].s3];
  150.           tri(fa,pat[q1].col);
  151.           END;
  152. vsshow;
  153. END;
  154.  
  155. (*########################################################################*)
  156.  
  157.  
  158. PROCEDURE move_center(orgx,orgy,orgz:real);
  159. VAR q:INTEGER;
  160. BEGIN
  161. FOR q:=1 TO pocount DO pnt[q].x:=pnt[q].x-orgx;
  162. FOR q:=1 TO pocount DO pnt[q].y:=pnt[q].y-orgy;
  163. FOR q:=1 TO pocount DO pnt[q].z:=pnt[q].z-orgz;
  164. END;
  165.  
  166. (*########################################################################*)
  167.  
  168. PROCEDURE SetRGBPalette(co,r,g,b:BYTE);
  169. BEGIN
  170. Port[$3C8] := Co;
  171. Port[$3C9] := R;
  172. Port[$3C9] := G;
  173. Port[$3C9] := B;
  174. END;
  175.  
  176. (*########################################################################*)
  177.  
  178. PROCEDURE shadepalette(faca,facb,facc:real;baseR,BaseG,BaseB:BYTE);
  179. VAR q:INTEGER;
  180. BEGIN
  181. IF faca=0 THEN faca:=0.00001;
  182. IF facb=0 THEN facb:=0.00001;
  183. IF facc=0 THEN facc:=0.00001;
  184. faca:=faca/100*(63-baseR)/255;
  185. facb:=facb/100*(63-baseG)/255;
  186. facc:=facc/100*(63-baseB)/255;
  187. FOR q:=1 TO 255 DO setrgbpalette(q,BaseR+Trunc(q*faca),BaseG+Trunc(q*facb),BaseB+Trunc(q*facc));
  188. END;
  189.  
  190. (*########################################################################*)
  191.  
  192. PROCEDURE xshade(sun_a,sun_b,sun_c:real);
  193. VAR e,q,w:INTEGER;
  194.     ang1,ang2:real;
  195.     xu,yu,zu,xv,yv,zv,xn,y0n,zn,v1,v2,v3,v4,v5,xw,yw,zw:real;
  196. BEGIN
  197. sun_a:=sun_a/57.29;
  198. sun_b:=sun_b/57.29;
  199. sun_c:=sun_c/57.29;
  200.  
  201. FOR q:=1 TO pacount DO WITH pat[q] DO BEGIN
  202.  
  203.     xu := pnt[s2].x -pnt[s1].x ;yu := pnt[s2].y -pnt[s1].y ;zu := pnt[s2].z -pnt[s1].z ; (* vector 1 a 2 *)
  204.     xv := pnt[s3].x -pnt[s1].x ;yv := pnt[s3].y -pnt[s1].y ;zv := pnt[s3].z -pnt[s1].z ; (* vector 1 a 3 *)
  205.  
  206.     xn := (yu *zv )-(zu *yv );
  207.     y0n := (zu *xv )-(xu *zv );
  208.     zn := (xu *yv )-(yu *xv );                                   (* Vecteur perpendiculaire a la surface*)
  209.  
  210.     y0n := y0n *(-1);
  211.     zn := zn *(-1);
  212.  
  213.     v1 := (xn *xn )+(y0n *y0n )+(zn *zn );
  214.     v2 := Sqrt (v1 );                                            (* magnitude*)
  215.     IF v2=0 THEN v2:=0.00001;
  216.     v3 := v2;
  217.     xw := v3 *xn ;yw := v3 *y0n ;zw := v3 *zn ;
  218.     v4 := (xw *sun_a )+(yw *sun_b )+(zw *sun_c );                (* illumination facteur 0 to 1 *)
  219.     v4 := v4/LightFactor+LightAmbient;                           (* facteur d'illumination*)
  220.     IF v4>255 THEN v4:=255;
  221.     IF v4<LightAmbient THEN v4:=lightAmbient;
  222.     col:=Trunc(v4);
  223.     END;
  224. IF light1<>-1 THEN
  225.    BEGIN (*If ADDLIGHT was used*)
  226.    pnt[light1].x:=ztest(Sin(-sun_A)*LightRadius);
  227.    pnt[light1].y:=ztest(Sin(-sun_B)*LightRadius);
  228.    pnt[light1].z:=ztest(Sin(-sun_C)*LightRadius);
  229.    pnt[light2].x:=ztest(Sin(-sun_A)*LightRadius/2);
  230.    pnt[light2].y:=ztest(Sin(-sun_B)*LightRadius/2);
  231.    pnt[light2].z:=ztest(Sin(-sun_C)*LightRadius/2);
  232.    pat[LightPat].col:=LightColor;
  233.    END;
  234.  
  235. END;
  236.  
  237. (*########################################################################*)
  238.  
  239. PROCEDURE calc(ax,ay,az,dist:real);
  240. VAR q,w:INTEGER;
  241.     aux1,aux2,aux3,aux4,aux5,aux6,aux7,aux8:real;
  242.     x_obs,y_obs,z_obs:real;
  243.     sum:ARRAY[1..MaxP] OF real;
  244.     sum_old:real;
  245.     e:WORD;
  246. PROCEDURE init_projection(the,phi:real);
  247. VAR th,ph:real;
  248. BEGIN
  249. th:=the*0.017454;ph:=phi*0.017454;
  250. aux1:=Sin(th);aux2:=Sin(ph);aux3:=Cos(th);aux4:=Cos(ph);
  251. aux5:=aux3*aux2;aux6:=aux1*aux2;aux7:=aux3*aux4;aux8:=aux1*aux4;
  252. END;
  253.  
  254. PROCEDURE QuickSort;
  255. VAR Lo,Hi:INTEGER;
  256.     i, j : INTEGER;
  257.     x,y:real;
  258.     v:INTEGER;
  259.  PROCEDURE qSort(l, r: INTEGER);
  260.  BEGIN
  261.    i := l; j := r; x := sum[(l+r) DIV 2];
  262.    REPEAT
  263.      WHILE sum[i] < x DO i := i + 1;
  264.      WHILE x < sum[j] DO j := j - 1;
  265.      IF i <= j THEN
  266.      BEGIN
  267.        y := sum[i]; sum[i]:= sum[j]; sum[j]:=y;
  268.        v := sort[i];sort[i]:=sort[j];sort[j]:=v;
  269.        i := i + 1; j := j - 1;
  270.      END;
  271.    UNTIL i > j;
  272.    IF l < j THEN qSort(l, j);
  273.    IF i < r THEN qSort(i, r);
  274.  END;
  275.  
  276.  BEGIN {QuickSort};
  277.    Lo:=1;Hi:=Pacount;
  278.    qSort(Lo,Hi);
  279.  END;
  280.  
  281. BEGIN
  282. init_projection(ax,ay);
  283. FOR q:=1 TO pocount DO BEGIN
  284.     x_obs:=-pnt[q].x*aux1+pnt[q].y*aux3;
  285.     y_obs:=-pnt[q].x*aux5-pnt[q].y*aux6+pnt[q].z*aux4;
  286.     z_obs:=-pnt[q].x*aux7-pnt[q].y*aux8-pnt[q].z*aux2+az;
  287.  
  288.     dwg[q].x:=midx+Trunc(dist*x_obs/(z_obs));
  289.     dwg[q].y:=midy+Trunc(dist*y_obs/(z_obs));
  290.     zbuffering[q]:=(z_obs-az) /10;
  291.     END;
  292. FOR q:=1 TO pacount DO WITH pat[q] DO
  293.     sum[q]:=(zbuffering[s1]+zbuffering[s2]+zbuffering[s3]); (*must be more accurate*)
  294. FOR q:=1 TO pacount DO sort[q]:=q;
  295. quicksort;
  296. END;
  297.  
  298. (*########################################################################*)
  299.  
  300. PROCEDURE Clear;
  301. BEGIN
  302. pocount:=0;
  303. pacount:=0;
  304. END;
  305.  
  306. (*########################################################################*)
  307.  
  308. FUNCTION  AddPoint(x,y,z:real):INTEGER;
  309. BEGIN
  310. IF pocount>=MaxP THEN EXIT;
  311. INC(pocount);
  312. IF x=0 THEN x:=0.0001;
  313. IF y=0 THEN y:=0.0001;
  314. IF z=0 THEN z:=0.0001;
  315. Pnt[pocount].x:=x;
  316. Pnt[pocount].y:=y;
  317. Pnt[pocount].z:=z;
  318. Addpoint:=pocount;
  319. END;
  320.  
  321. (*########################################################################*)
  322.  
  323. VAR old:INTEGER;
  324. PROCEDURE AddPatch(s1,s2,s3:INTEGER;co:BYTE);
  325. BEGIN
  326. IF pacount>=MaxP THEN EXIT;
  327. INC(pacount);
  328. Pat[pacount].s1:=s1+old;
  329. Pat[pacount].s2:=s2+old;
  330. Pat[pacount].s3:=s3+old;
  331. Pat[pacount].col:=co;
  332. END;
  333.  
  334. (*########################################################################*)
  335.  
  336. PROCEDURE Push;
  337. BEGIN
  338. old:=Pocount;
  339. END;
  340. PROCEDURE Pop;
  341. BEGIN
  342. old:=0;
  343. END;
  344.  
  345. (*########################################################################*)
  346. (*With LOADMESH, you will load an ASCII mesh file, ge. 3d Studio,...*)
  347. PROCEDURE LoadMesh(nom:STRING;scalex,scaley,scalez:real;col:BYTE);
  348. VAR f:TEXT;
  349.     x,y,z:real;
  350.     p1,p2,p3,p4:INTEGER;
  351.     a,s,lin:STRING;
  352.     q:INTEGER;
  353.     FUNCTION  GetWord(VAR st:STRING):STRING;
  354.     VAR q,w:INTEGER;
  355.         a:STRING;
  356.     BEGIN
  357.     IF Length(st)<2 THEN BEGIN GetWord:='';EXIT;END;
  358.     IF st[1]=' ' THEN
  359.        BEGIN
  360.        REPEAT
  361.        Delete(st,1,1);
  362.        UNTIL (st[1]<>' ') OR (Length(st)<1);
  363.        END;
  364.     a:='';
  365.     REPEAT
  366.      a:=a+st[1];
  367.      Delete(st,1,1);
  368.     UNTIL (st[1]=' ') OR (Length(st)<1);
  369.     GetWord:=a;
  370.     END;
  371.  
  372. BEGIN
  373. push;
  374. Assign(f,nom);
  375. {$i-}
  376. Reset(f);
  377.  
  378. REPEAT
  379. ReadLn(f,lin);lin:=toupper(lin);a:=lin;
  380. s:=getword(a);
  381. IF s='NAMED' THEN push;
  382. IF s='VERTEX' THEN
  383.               IF Copy(getword(a),1,4)<>'LIST' THEN
  384.               BEGIN
  385.               getword(a);
  386.               Val(getword(a),x,q);
  387.               getword(a);
  388.               Val(getword(a),y,q);
  389.               getword(a);
  390.               Val(getword(a),z,q);
  391.               addpoint(x*scalex,y*scaley,z*scalez);
  392.               END;
  393. IF s='FACE'   THEN
  394.               IF Copy(getword(a),1,4)<>'LIST' THEN
  395.               BEGIN
  396.               s:=getword(a);
  397.               p1:=1+ival(Copy(s+' ',3,Length(s)-2));
  398.               s:=getword(a);
  399.               p2:=1+ival(Copy(s+' ',3,Length(s)-2));
  400.               s:=getword(a);
  401.               p3:=1+ival(Copy(s+' ',3,Length(s)-2));
  402.               Addpatch(p1,p2,p3,col);
  403.               END;
  404. (*writeln(pocount:4,pacount:4,lin);*)
  405. pop;
  406. UNTIL Eof(f);
  407. Close(f);
  408. END;
  409.  
  410. (*########################################################################*)
  411. (*########################################################################*)
  412. (*########################################################################*)
  413.  
  414. BEGIN
  415. midx:=Round(160);
  416. midy:=Round(100);
  417. FrontClip:=-100;
  418. Pocount:=0;Pacount:=0;push;
  419. LightFactor:=10;
  420. Light1:=-1;
  421. LightColor:=255;Lightpat:=-1;
  422. LightAmbient:=1;
  423. LightRadius:=50;
  424. END.
  425.  
  426.  
  427.