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;
   fT: array[fElements]of ^TriangleName;
   tC: array[fElements]of ^Point;
   fL: array[fElements]of LineName;
   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)<Radius then vDif(speed,Mv,speed);
      Gravity(speed,aC,0);
      for i:=1 to 3 do Speed[i]:=Speed[i]*miu;
      MoveV(speed);
end;

// ~ MoveV ~ //
Procedure TFig3D.MoveV;
begin
  for i:=1 to 3 do aC[i]:=round(aC[i]+v[i]);
end;
// ~ MoveRel ~ //
Procedure TFig3D.MoveRel;
begin
 fC^[1]:=fC^[1]+(x);
 fC^[2]:=fC^[2]+(y);
 fC^[3]:=fC^[3]+(z);
end;


// ~ Calc_rP ~ //
Procedure TFig3D.Calc_rP;
Begin
 if nPoint>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;
//  nLine := 0;
//  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(i<nPoint)do inc(i);
 if i<nPoint then result:=i else begin
  new(fP[nPoint]);fP[nPoint]^:=p1;new(rP[nPoint]);result:=nPoint;inc(nPoint);
 end;
end;

// ~ AddL ~ //
Function TFig3D.AddL;
begin
//   new(fL[nLine]);
  fL[nLine][1]:=n1;
  fL[nLine][2]:=n2;
  result:=nLine;
  inc(nLine);
end;
// ~ AddFig ~ //
Function TFig3D.AddFig;
begin
 new(figs[nFig]);
 if F<>nil 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 Break;
    inc(nLine);
//     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 nLine>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;
    i,j,k: integer;
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.