unit Fig3D; interface uses graph, D3, crt, dos, Strings; const mElements=$FF; // maximum elements mFigs=$FF; // maximum figures DefColor=$ff8f0f; // default color type fElements =0..mElements; Figures =0..mFigs; Colors =0..$FFFFFF; // 24 bits color LineName=array[1..2]of fElements; // a line is defined via 2 points TriangleName=array[1..3]of fElements; IDDist=record d:real; //Distanta n:word; //Nr. de ordine t:byte; //Tipul fig:1-Triunghi; 2-Figura end; TFig=^TFig3D; TFig3D=object Constructor Init; Destructor Done; Procedure Drow(Orig:point); Procedure LDrow(n:fElements); // LineDrow Procedure LDrow_rP(p1,p2:word); // LineDrow relative points Procedure TDrow(n:fElements); // TriangleDrow Function AddP(p1:point):fElements; // AddPoint to figure Function AddL(n1,n2:fElements):fElements; // AddLine to figure Function AddFig(F:TFig):Figures; // AddFigure to figure Function GetPN:fElements; // GetPointsNumber Function GetLN:fElements; Function GetFN:Figures; Function GetTN:fElements; Function GetON:fElements; Procedure SetClr(c:Colors); // SetColor Procedure MoveV(v:vector); // Move by given vector Procedure MoveRel(x,y,z:longint); // Move relatively Procedure AddIndex(n:word;t:byte); // Add to index (for consecutive drow) Procedure OrdIndex; // Order figures in index by distance from O Procedure Calc_rP; // Calculate relative points Procedure CalcDynam; Procedure ReadFile(fn:string); Procedure ReadF(var F:text); Procedure WriteFile(fn:string); Procedure WriteF(var F:text); Procedure Optimize; Public Name: string[16]; Clr: ^Colors; Index: array[word]of ^IDDist; nIndex: Word; {Fizics} speed: Vector; // Speed m: Word; // Mass {Geometry} Radius: Word; aC: Point; //Absolut Center rP: array[fElements]of ^Point; //Relative Points Rate: integer; Figs: array[Figures]of TFig; nPoint, nLine, nTriangle: fElements; nFig: Figures; fC:^Point; // Figures' center fP: array[fElements]of ^sPoint; fL: array[fElements]of ^LineName; fT: array[fElements]of ^TriangleName; tC: array[fElements]of ^Point; tPerpV: array[fElements]of ^Vector; tClr: array[fElements]of ^Colors; Procedure tInit; oFL: ^text; end; var i,j,k:longint; tmpP:point; tmpV:vector; Fig:TFig3D; Function Exist(fn:string):boolean; Function DistP(p1,p2:point):real; Function ClrIntens(v:vector;p,Lght:point):real; implementation uses Grph3D; // ~ CalcDynam ~ // Procedure TFig3D.CalcDynam; var i:fElements; begin i:=0; while not(Figs[i]=nil) do begin Figs[i]^.CalcDynam; inc(i); end; // pDif(o,aC,TP); if pModul(TP)0 then for i:=0 to nPoint-1 do begin pSum(aC,fP[i]^,tmpP); rP[i]^[1]:=PCrd(tmpP,1); if rP[i]^[1]>-deeph then begin rP[i]^[3]:=PCrd(tmpP,3); rP[i]^[2]:=PCrd(tmpP,2); end; end; End; // ~ LDrow_rP ~ // Procedure TFig3D.LDrow_rP(p1,p2:word); var r1,r2:real; begin if(rP[p1]^[1]>0)and(rP[p2]^[1]>0)then begin r1:=DphP(rP[p1]^[1]);r2:=DphP(rP[p2]^[1]); line(ex+round(rP[p1]^[3]*r1),ey-round(rP[p1]^[2]*r1), ex+round(rP[p2]^[3]*r2),ey-round(rP[p2]^[2]*r2)); end end; // ~ TDrow ~ // Procedure TFig3D.TDrow(n:fElements); var r1,r2,r3,intense:real; cl:Colors; c1,c2,c3:byte; Begin if tClr[n]=nil then if Clr=nil then cl:=DefColor else cl:=Clr^ else cl:=tClr[n]^; outtextxy(mx-100,2,tex(cl)); c1:=cl mod $100; c2:=cl div $100; c2:=cl div $10000; intense:=ClrIntens(tPerpV[n]^,tC[n]^,Lght); cl:=round(c1*intense)+round(c2*intense)*$100+round(c3*intense)*$10000; outtextxy(mx-100,30,tex(round(intense*10000))); SetFillColor(cl); if(rP[fT[n]^[1]]^[1]>0)and(rP[fT[n]^[2]]^[1]>0)and(rP[fT[n]^[3]]^[1]>0)then begin r1:=DphP(rP[fT[n]^[1]]^[1]); r2:=DphP(rP[fT[n]^[2]]^[1]); r3:=DphP(rP[fT[n]^[3]]^[1]); FillTriangle(ex+round(rP[fT[n]^[1]]^[3]*r1),ey-round(rP[fT[n]^[1]]^[2]*r1), ex+round(rP[fT[n]^[2]]^[3]*r2),ey-round(rP[fT[n]^[2]]^[2]*r2), ex+round(rP[fT[n]^[3]]^[3]*r3),ey-round(rP[fT[n]^[3]]^[2]*r3)); end End; // ~ Drow ~ // Procedure TFig3D.Drow(Orig:point); var i:word; b:byte; pct:Point;nID:IDDist; Procedure CompOrdF(n:Figures); begin if(n>0)and(Index[n]^.d>Index[n-1]^.d)then begin nID:=Index[n]^;Index[n]^:=Index[n-1]^;Index[n-1]^:=nID; CompOrdF(n-1); end; end; Begin {Gasirea punctelor in Sp relativ din cel absolut} Calc_rP; {Desenarea liniilor, folosind punctele din sp rel} setColor(Clr^); if nLine>0 then for i:=0 to nLine-1 do LDrow(i); pDif(Orig,o,tmpP); GetVec(tmpP,tmpV); for j:=0 to nFig-1 do with Index[j]^,Figs[j]^ do begin n:=j;t:=2; if(fC^[1]=0)and(fC^[2]=0)and(fC^[3]=0)then d:=0 else d:=vpProd(tmpV,fC^)/pModul(fC^); CompOrdF(j); end; for j:=0 to nTriangle-1 do with Index[j]^ do begin n:=j;t:=1; if(tC[j]^[1]=0)and(tC[j]^[2]=0)and(tC[j]^[3]=0)then d:=0 else d:=vpProd(tmpV,tC[j]^)/pModul(tC[j]^); CompOrdF(j); end; for j:=0 to nIndex-1 do case Index[j]^.t of 1:tDrow(Index[j]^.n); 2:Figs[Index[j]^.n]^.Drow(fC^); end; End; // ~ LDrow ~ // Procedure TFig3D.LDrow(n:fElements);begin LDrow_rP(fL[n]^[1],fL[n]^[2]);end; // ~ AddIndex ~ // ?????????????????????????? Procedure TFig3D.AddIndex; Begin New(Index[nIndex]); Index[nIndex]^.n:=n; Index[nIndex]^.t:=t; Inc(nIndex); End; // ~ OrdIndex ~ // Procedure TFig3D.OrdIndex; Begin End; // ~ tInit ~ // Procedure TFig3D.tInit; begin if GetTN>0 then for i:=0 to nTriangle-1 do begin new(tC[i]);new(tPerpV[i]); for j:=1 to 3 do tC[i]^[j]:=(fP[fT[i]^[1]]^[j]+fP[fT[i]^[2]]^[j]+fP[fT[i]^[3]]^[j])div 3; vGetPerp(fP[fT[i]^[1]]^,fP[fT[i]^[2]]^,fP[fT[i]^[3]]^,tPerpV[i]^); VecUnit(tPerpV[i]^,tPerpV[i]^); AddIndex(I,1); end; end; // ~ Init ~ // Constructor TFig3D.Init; begin GetPN; Radius:=1000; for i:=0 to nPoint-1 do begin new(rP[i]); end; GetLN; If fC<>nil then pSum(aC,fC^,aC);// else begin new(fC); fC^:=zero; end; tInit; nFig:=0; while not(Figs[nFig]=nil) do begin Figs[nFig]^.aC:=aC; Figs[nFig]^.Init; inc(nFig); end; for i:=0 to nFig-1 do AddIndex(I,2); end; // ~ ~ // Function DistP;begin Result:=((sqr(p2[1]-p1[1])+sqr(p2[2]-p1[2])+sqr(p2[3]-p1[3])));end; Function Exist;var sr:TSearchRec;begin FindFirst(fn,$3f,sr);if doserror=0 then Exist:=true else exist:=false;end; Function ClrIntens(v:vector;p,Lght:point):real; var l:point;dst:real; begin PDif(p,Lght,l); dst:=pModul(l); ClrIntens:=abs(vpProd(v,l)*sqr(10000)/(sqr(dst)*dst)); end; // ~ AddP ~ // Function TFig3D.AddP; var i:fElements; begin i:=0; while((p1[1]<>fP[i]^[1])or(p1[2]<>fP[i]^[2])or(p1[3]<>fP[i]^[3]))and(inil then figs[nFig]:=F; Result:=nFig; inc(nFig); end; {// --- Dealing with files... --- } // ~ ReadFile ~ // Procedure TFig3D.ReadFile; begin if Exist(fn)then begin if not(Figs[0]=nil)then Done; new(Ofl); assign(OFL^,fn); reset(OFL^); ReadF(oFL^); close(OFL^); dispose(Ofl); end; end; // ~ ReadF ~ // Procedure TFig3D.ReadF; var c:char; ln:string; np:longint; begin if Clr=nil then begin new(Clr); Clr^:=DefColor; end; fC^:=zero; WriteLN(#10,' ~Begin~'); while not eof(F) do begin ln:=''; repeat Read(F,c); if not(ord(c)in[32,10,13,61])then begin ln:=ln+upcase(c);end; until(c='=')or(eof(F)); {}if ln='RATE'then begin readLn(F,rate)end {}else if ln='NAME' then begin readLn(F,Name);writeln('Name=',name)end {}else if ln='COLOR' then begin SetClr(0);readLn(F,Clr^);writeln('Color=',Clr^)end {}else if ln='XYZ'then begin new(Fc);readLn(F,fC^[1],fC^[2],fC^[3]);writeln('XYZ=',fC^[1],' ',fC^[2],' ',fC^[3])end {}else if ln='POINTS'then begin readLn(F,np);writeln('nPoints=',nP); for i:=0 to np-1 do begin if eof(F)then exit; new(fP[i]); ReadLn(F,fP[i]^[1],fP[i]^[2],fP[i]^[3]); if rate<>0 then for j:=1 to 3 do fP[i]^[j]:=fP[i]^[j]*rate; end; end {}else if ln='LINES'then begin readLn(F,np);writeln('nLines=',nP); for i:=0 to np-1 do begin if eof(F)then exit; new(fL[i]); readLn(F,fL[i]^[1],fL[i]^[2]); { dec(fL[i]^[1]); dec(fL[i]^[2]);} end; end {}else if ln='FIGURE' then begin readLn(F,ln); if UpperCase(ln)='[END]'then begin Writeln(' ~End~'); exit;end; new(figs[GetFN]);inc(nFig); If UpperCase(ln)='[BEGIN]'then figs[nFig-1]^.ReadF(F) else figs[nFig-1]^.ReadFile(ln); end {}else readLn(F); end; Writeln(' ~End~',#10); Init; Optimize; end; // ~ WriteFile ~ // Procedure TFig3D.WriteFile; begin if fn='' then fn:=name+'.3Df'; new(oFL); assign(oFL^,fn); rewrite(oFL^); WriteF(oFL^); Close(oFL^); Dispose(oFL); end; // ~ WriteF ~ // Procedure TFig3D.WriteF; var fg:Figures; begin Writeln(f,#13#10,'Figure=[Begin]'); if name<>''then WriteLn(f,'NAME=',name); if Clr<>nil then WriteLn(f,'COLOR=',Clr^); if (fC^[1]or fC^[2]or fC^[3])<>0 then WriteLn(f,'XYZ=',FC^[1],' ',FC^[2],' ',FC^[3]); if GetPN>0 then begin WriteLn(f,'POINTS=',nPoint);for i:=0 to nPoint-1 do WriteLn(f,fP[i]^[1],#32,fP[i]^[2],#32,fP[i]^[3]);end; if GetLN>0 then begin WriteLn(f,'LINES=',nLine);for i:=0 to nLine-1 do WriteLn(f,fL[i]^[1],' ',fL[i]^[2]);end; if GetFN>0 then begin for fg:=0 to nFig-1 do Figs[fg]^.WriteF(f);end; Writeln(f,'Figure=[End]'); end; // ~ Optimize ~ // Procedure TFig3D.Optimize; var n:longint;eq:boolean; begin for i:=nPoint-1 downto 1 do for j:=i-1 downto 0 do begin eq:=false;k:=1; while(k<4)and(fP[i]^[k]=fP[j]^[k])do inc(k); if k=4 then begin dec(nPoint); fP[i]^:=fP[nPoint]^; dispose(fP[nPoint]); for k:=0 to nLine-1 do begin n:=fL[k]^[1]; if n=i then n:=j else if n=nPoint then n:=i; fL[k]^[1]:=n; n:=fL[k]^[2]; if n=i then n:=j else if n=nPoint then n:=i; fL[k]^[2]:=n; end; end; end; for i:=nLine-1 downto 1 do for j:=i-1 downto 0 do if(fL[i]^[1]=fL[j]^[1])and(fL[i]^[2]=fL[j]^[2])then begin dec(nLine); fL[i]^:=fL[nLine]^; dispose(fL[nLine]); end; end; // ~ Get*N ~ // Function TFig3D.GetPN;begin nPoint:=0; while not(fP[nPoint]=nil)do inc(nPoint);result:=nPoint;end; Function TFig3D.GetLN;begin nLine:=0; while not(fl[nLine]=nil)do inc(nLine);result:=nLine;end; Function TFig3D.GetTN;begin nTriangle:=0; while not(fT[nTriangle]=nil)do inc(nTriangle);result:=nTriangle;end; Function TFig3D.GetFN;begin nFig:=0; while not(Figs[nFig]=nil)do inc(nFig);result:=nFig;end; Function TFig3D.GetON;begin nIndex:=0; while not(Index[nIndex]=nil)do inc(nIndex);result:=nIndex;end; // ~ SetClr ~ // Procedure TFig3D.SetClr(c:Colors);begin if Clr=nil then new(Clr);Clr^:=c;end; // ~ Done ~ // Destructor TFig3D.Done; var i:Figures; begin if GetFN>0 then for i:=nFig-1 downto 0 do begin Figs[i]^.Done; dispose(Figs[i]); end; i:=0; while(fL[i]<>nil)do begin dispose(fL[i]);inc(i);end; i:=0; while(fP[i]<>nil)do begin dispose(fP[i]);inc(i);end; i:=0; while(rP[i]<>nil)do begin dispose(rP[i]);inc(i);end; end; Procedure SPLine(p1,p2:point); var r1,r2:real;c1,c2:longint; begin c1:=PCrd(p1,1); if(c1>0)then begin c2:=PCrd(p2,1);if(c2>0)then begin r1:=DphP(c1);r2:=DphP(c2); line(ex+round(pCrd(p1,3)*r1),ey-round(PCrd(p1,2)*r1), ex+round(PCrd(p2,3)*r2),ey-round(PCrd(p2,2)*r2)); end end end; End.