DUzun's Web
Programare, proiecte personale, divertisment

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.

​

​