3d stéréoscopique. faites de la 3d à partir de deux photos.

Soyez le premier à donner votre avis sur cette source.
Vue 9 060 fois - Téléchargée 1 015 fois
Télécharger le projet
Commenter
Description

Ce programme est basé sur l'utilisation de photos pour réaliser simplement des modéles 3D.
A partir de deux photos décalés d'un objet vous réalisez grâce au programme un modèle 3D de votre objet en quelques clics de souris.
Ainsi vous pouvez modéliser par exemple votre visage( à condition de posséder un appareil photo numérique).
Attention pour que le code source fonctionne et pour le modifier, vous devez installer le composant M3D que j'ai deja installé sur le site.
Le zip fournit contient l'ensemble des fichiers delphi du projet mais aussi l'executable au cas ou vous ne posséderiez pas le composant.
N'hésitez pas à me poser des questions si vous trouvez que mon code n'est pas clair et signalez moi les bugs.
Source / Exemple :

unit surfcplx;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ExtDlgs, ComCtrls, M3D;

type                                          
  Tligne2=record                           //alg 1
    num:word;etat:byte;
  end;
                   
  Ttriligne=array[1..800,1..800] of Tligne2;   //alg 1

  Tpoly=record
   x1,y1,z1,x2,y2,z2,x3,y3,z3:extended;     //etape 2
   p1,p2,p3:word;
  end;
                                                
  Ttrait=record
    x1,y1,x2,y2,coef:extended;
  end;

  Tligne=record                    //alg 2
   p1,p2:word;
   poly1,poly2:word;
  end;

  Tmligne=array[1..1000] of tligne;     //etape2

  Tintersec=record                                       
    dist:extended;
    etat:byte;
  end;

  Ttampligne=array[1..800] of word;      //alg 1

  Tmultiligne=array[1..800,1..800] of Tintersec;    //alg 1+2
  Tpoint = record
    x,y,z:extended;
  end;

  Tpol = record
   x1,y1,z1,x2,y2,z2,x3,y3,z3:extended;
   xt1,yt1,xt2,yt2,xt3,yt3:word;
  end;

  TForm1 = class(TForm)
    M3D1: TM3D;
    Image2: TImage;
    Image1: TImage;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Button3: TButton;
    Button4: TButton;
    Timer1: TTimer;
    OpenPictureDialog1: TOpenPictureDialog;
    Button5: TButton;
    Button6: TButton;
    Edit4: TEdit;
    Edit5: TEdit;
    Label4: TLabel;
    Label5: TLabel;
    Button12: TButton;
    Button13: TButton;
    Button14: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    TrackBar1: TTrackBar;
    TrackBar2: TTrackBar;
    TrackBar3: TTrackBar;
    Image3: TImage;
    Label6: TLabel;
    Image4: TImage;
    Image5: TImage;
    Image6: TImage;
    Image7: TImage;
    Button7: TButton;
    SavePictureDialog1: TSavePictureDialog;
    procedure etape1;
    procedure devinepolygones;
    function  coupe(p1,p2,p3,p4:word):boolean;
    function  coupe2(p1,p2,p3:word;x4u,y4u:extended):boolean;
    function  coupe3(p1,p2,tn:word):boolean;
    function  defsens(x1u,y1u,x2u,y2u,x3u,y3u:extended):shortint;
    function  detangle(x1,y1,x2,y2,x3,y3:extended):extended;
    function  dehors(x1,y1:extended):boolean;
    procedure sauvesurface(fichier:string);
    procedure chargesurface(fichier:string);
    procedure appercu;
    procedure fragmente(dist:extended);

    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image2MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image2MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image2MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button4Click(Sender: TObject);
    procedure timer(Sender: TObject);
    procedure M3D1Mousemove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    //procedure Button7Click(Sender: TObject);
    procedure Button9Click(Sender: TObject);
    procedure Button10Click(Sender: TObject);
    procedure Button11Click(Sender: TObject);
    procedure Button12Click(Sender: TObject);
    procedure Button13Click(Sender: TObject);
    procedure Button14Click(Sender: TObject);
    procedure Button15Click(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
    procedure TrackBar2Change(Sender: TObject);
    procedure TrackBar3Change(Sender: TObject);
    procedure Image3MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image7MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image6MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image4MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image5MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image3MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button7pClick(Sender: TObject);
    procedure Button7Click(Sender: TObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;

var
  Form1: TForm1;
   mat3d,mat3d2:array[1..1000] of Tpoint;
  contour:array[1..200] of Tpoint;
  nc,np,nf:word;
  trctr:boolean;
  matligne:^Tmultiligne;
  lfin:^Tmligne;
  matpoly:array[1..1000] of Tpoly ;
  cli,ctr,cpo:dword;
  mligne:^Ttriligne;
  tampligne:^Ttampligne;
  multrait:array[1..1500] of Ttrait;
  ntrait,v1,v2,pcour:word;
  masq,appuie,dehor,bloque:boolean;
  btm1,btm2:tbitmap;
  l,dE,z0,vr:extended;
  decx,decy:word;
  rendu,im1,im2:string;
  m1,m2:array[1..100] of byte;
  matsav:array[1..1000] of tpol;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var n:word;
begin
 image1.canvas.Pen.color:=clgreen;
 image1.canvas.moveTo(round(mat3d[1].x),round(mat3d[1].y));
 for n:=2 to nc-1 do begin
  image1.canvas.lineTo(round(mat3d[n].x),round(mat3d[n].y));
 end;
 image1.canvas.lineTo(round(mat3d[1].x),round(mat3d[1].y));
 if trctr then begin
  edit1.text:=inttostr(nf);
  edit3.text:=inttostr(ntrait);
 // v1:=np+nc-2;v2:=ntrait;
 end;
 trctr:=False;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 etape1;
 devinepolygones;
 l:=(trackbar1.Position);
 z0:=(trackbar2.Position);
 appercu;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
m3d1.creer;
m3d1.Moteur.coulfond:=$5fff;
trctr:=True;nc:=1;np:=1;
new(matligne);new(lfin);cli:=0;ctr:=0;cpo:=1;
new(mligne);new(tampligne);
btm1:=tbitmap.create;
btm2:=tbitmap.create;
//btm1.LoadFromFile('c:\windows\Britney 06.BMP');
m3d1.camera.champ:=200;
m3d1.camera.decz:=40;
m3d1.Moteur.coulfond:=$1234;
m3d1.ChargeReflexions(1,'C:\Windows\Bureau\camille\rech\surfaces complexes\fichiers 3D\light.lum');
//m3d1.ChargeReflexions(1,'C:\Windows\Bureau\camille\rech\surfaces complexes\fichiers 3D\diffus.lum');
rendu:='texnormal';
l:=20;
dE:=15;
z0:=5;
vr:=1;
decx:=0;
decy:=0;
 with m3d1.camera do begin   
  posx:=0;
  posy:=0;
  posz:=0;
  perspective:=400;
 end;

 m3d1.assignbitmap(2,320,240,image3.picture.bitmap);

 btm1.LoadFromFile('C:\Windows\exemple1\Ressources\masque1.bmp');
 m3d1.chargetexture(0,'C:\Windows\exemple1\Ressources\masque1.bmp');
 im1:='C:\Windows\exemple1\Ressources\masque1.bmp';
                                                                     //charge l'exemple
 btm2.LoadFromFile('C:\Windows\exemple1\Ressources\masque2.bmp');
 im2:='C:\Windows\exemple1\Ressources\masque2.bmp';

 chargesurface('C:\Windows\exemple1\Ressources\masque.sur');

 etape1;
 devinepolygones;      //relie les points en polygones
 l:=(trackbar1.Position);
 z0:=(trackbar2.Position);
 appercu;             //calcul le rendu
 dehor:=True;
 bloque:=False;

 //image3.canvas.Font
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
image1.canvas.Brush.color:=clwhite;
btm1.canvas.rectangle(0,0,512,512);
btm2.canvas.rectangle(0,0,512,512);
m3d1.objet.taille:=0;
nc:=1;np:=1;cli:=0;ctr:=0;
trctr:=true;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
//m3d1.dpoint(1,x,300-y,0);
//m3d1.rafraichis(1);
//image1.Canvas.Draw(0,0,btm1);
image1.canvas.Pixels[x,y]:=1;
//image1.canvas.pen.color:=clred;
//image1.Canvas.Ellipse(x-2,y-2,x+2,y+2);
if trctr then begin
 mat3d[nc].x:=x+decx;
 mat3d[nc].y:=y+decy;
 //mat3d[nc].z:=l*dE/(z0);

 mat3d2[nc].x:=x+decx;
 mat3d2[nc].y:=y+decy;
 inc(nc);masq:=True;
end;

if trctr=False then begin
 if dehors(x+decx,y+decy)=false then begin
  mat3d[np+nc-1].x:=x+decx;
  mat3d[np+nc-1].y:=y+decy;
 // mat3d[np+nc-1].z:=l*dE/(z0);

  mat3d2[np+nc-1].x:=x+decx;
  mat3d2[np+nc-1].y:=y+decy;
  inc(np);masq:=False;
 end
 else begin
  showmessage('Point en dehors du contour');
 end;

 end;
end;

procedure TForm1.Image7MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var n:dword;
begin
if (decx>4) then decx:=decx-4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;
 image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;
end;

procedure TForm1.Image6MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var n:dword;
begin
decx:=decx+4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;
 image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;

end;

procedure TForm1.Image4MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var n:dword;
begin
decy:=decy+4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
//image1.Canvas.Draw(decx,decy,btm1);
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;

image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;

end;

procedure TForm1.Image5MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var n:dword;
begin
if (decy>4) then decy:=decy-4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
//image1.Canvas.Draw(decx,decy,btm1);
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;
 image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;

end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
  var n:dword;
begin
//image1.Canvas.Draw(decx,decy,btm1);
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
// image1.canvas.Pixels[round(mat3d[n].x),round(mat3d[n].y)]:=1;
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y)-2-decy,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;
end;

procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
 var n:dword;
begin
 image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));

 image2.canvas.pen.color:=clred;
 image2.canvas.brush.color:=clwhite;
 for n:=1 to nc+np-2 do begin
  if n<>pcour then begin
   //image2.canvas.Pixels[round(mat3d2[n].x),round(mat3d2[n].y)]:=1;
   image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y)-2-decy,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
  end;
 end;

  image2.canvas.pen.color:=clblue;
   image1.canvas.pen.color:=clblue;
 if (appuie) and (pcour<>0) then begin
  image2.Canvas.Ellipse(x-2,y-2,x+2,y+2);
  image1.Canvas.Ellipse(round(mat3d[pcour].x)-2-decx,round(mat3d[pcour].y)-2-decy,round(mat3d[pcour].x)+2-decx,round(mat3d[pcour].y)+2-decy);
 end;

end;

procedure TForm1.Image2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var n:dword;
begin
 appuie:=True;
 pcour:=0;
 for n:=1 to (np+nc-2) do begin
   if (abs(mat3d2[n].x-(x+decx))<=4) and (abs(mat3d2[n].y-(y+decy))<=4) then pcour:=n;
 end;
end;
                    
procedure TForm1.Image2MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
 var x1,y1:extended;
begin                             
 appuie:=false;
 x1:=mat3d[pcour].x;y1:=mat3d[pcour].y;
 mat3d2[pcour].x:=x+decx;mat3d2[pcour].y:=y+decy;
 image2.canvas.pen.color:=clred;
 image2.Canvas.Ellipse(x-2,y-2,x+2,y+2);

 //mat3d[pcour].z:=l*dE/(z0+x1-(x+decx));
 pcour:=0;
end;

procedure TForm1.Button4Click(Sender: TObject);
var n:dword;
begin
for n:=1 to cpo do begin
  m3d1.structure[n].polarite:=-1*m3d1.structure[n].polarite;
end;

with m3d1 do begin
  moteur.coulfond:=$1234;
  rend(rendu,1);
  moteur.coulfond:=$ffff;
  camera.zoom:=8;
  rend('coloré',2);
  rafraichis(1);
  rafraichis(2);
 end;
{with m3d1 do begin
 with objet do begin
  taille:=cpo;
  nom:='suface1';
 end;
 //chargetexture(0,'c:\windows\Britney 06.bmp');
// chargetexture(1,'c:\windows\Britney 06.bmp');         
 //chargetexture(0,'c:\windows\Britney 06.bmp');
 for n:=1 to cpo do begin
   structure^[n].xt1:=round(matpoly[n].x1);structure^[n].xt2:=round(matpoly[n].x2);structure^[n].xt3:=round(matpoly[n].x3);
   structure^[n].yt1:=round(matpoly[n].y1);structure^[n].yt2:=round(matpoly[n].y2);structure^[n].yt3:=round(matpoly[n].y3);

   structure^[n].y1:=matpoly[n].x1/20;structure^[n].y2:=matpoly[n].x2/20;structure^[n].y3:=matpoly[n].x3/20;
   structure^[n].x1:=matpoly[n].y1/20;structure^[n].x2:=matpoly[n].y2/20;structure^[n].x3:=matpoly[n].y3/20;
   structure^[n].z1:=matpoly[n].z1/20;structure^[n].z2:=matpoly[n].z2/20;structure^[n].z3:=matpoly[n].z3/20;
   structure^[n].texture:=1;
  //polarite:=1;

 end;
 rend('texnormal',1);
 rafraichis(1);
end;  }

end;

procedure TForm1.timer(Sender: TObject);
begin
 with m3d1 do begin
 if (dehor=False) then  begin
  moteur.coulfond:=$1234;
  //moteur.raftamp:=True;
  rend(rendu,1);
  {moteur.raftamp:=False;
  rend('fildefer',1);   }
  //camera.decy:=camera.decy+9;
  moteur.coulfond:=$ffff;
  camera.zoom:=8;
 // rend('pcav',2);
 // moteur.raftamp:=True;
  rend('coloré',2);
 // camera.decy:=camera.decy-9;
  //Moteur.grandecran:=True;
  rafraichis(1);
  //Moteur.grandecran:=False;
  rafraichis(2);
  form1.caption:='M3D:'+floattostr(m3d1.IPS)+' IPS.';
  end;
 end;

end;

procedure TForm1.M3D1Mousemove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if bloque=False then begin
  m3d1.alpha:=x/40;
  m3d1.tetha:=y/40;
 end;
 dehor:=False;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 with m3d1 do begin
   {if key=105  then  deplacey(vr);
   if key=99   then  deplacey(-vr);

   if key=102  then  deplacex(vr);
   if key=100  then  deplacex(-vr);

   if key=104  then  deplacez(vr);
   if key=101  then  deplacez(-vr);  }

   if key=221  then  deplacey(vr);
   if key=192  then  deplacey(-vr);

   if key=77  then  deplacex(vr);
   if key=75  then  deplacex(-vr);

   if key=79  then  deplacez(vr);
   if key=76  then  deplacez(-vr);

   if key=83 then begin
    if bloque then bloque:=False
    else bloque:=True;
   end;

   with camera do begin
    if key=105  then  decx:=decx-vr;
    if key=99   then  decx:=decx+vr;

    if key=102  then  decy:=decy-vr;   //x et y
    if key=100  then  decy:=decy+vr;

    if key=104  then  perspective:=round(perspective*1.1);    //z
    if key=101  then  perspective:=round(perspective/1.1);
   end;
 end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
{ m3d1.alpha:=x/50;
 m3d1.tetha:=y/50;   }
 dehor:=True;
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
 if openpicturedialog1.execute then begin
   btm1.LoadFromFile(openpicturedialog1.FileName);
   m3d1.chargetexture(0,openpicturedialog1.FileName);
   im1:=openpicturedialog1.FileName;
 end;
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
 if openpicturedialog1.execute then begin
   btm2.LoadFromFile(openpicturedialog1.FileName);
   im2:=openpicturedialog1.FileName;
 end;
end;

procedure TForm1.Button8Click(Sender: TObject);
var n:dword;
begin
if (decy>4) then decy:=decy-4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
//image1.Canvas.Draw(decx,decy,btm1);
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;
 image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;
end;

{procedure TForm1.Button7Click(Sender: TObject);
var n:dword;
begin
decy:=decy+4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
//image1.Canvas.Draw(decx,decy,btm1);
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;

image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;
end; }

procedure TForm1.Button9Click(Sender: TObject);
var n:dword;
begin
if (decx>4) then decx:=decx-4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;
 image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;
end;

procedure TForm1.Button10Click(Sender: TObject);
var n:dword;
begin
decx:=decx+4;
image1.canvas.CopyRect(rect(0,0,500,400),btm1.Canvas,rect(decx,decy,decx+500,decy+400));
image1.canvas.pen.color:=clred;
image1.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image1.Canvas.Ellipse(round(mat3d[n].x)-2-decx,round(mat3d[n].y-decy)-2,round(mat3d[n].x)+2-decx,round(mat3d[n].y)+2-decy);
end;
 image2.canvas.CopyRect(rect(0,0,500,400),btm2.Canvas,rect(decx,decy,decx+500,decy+400));
image2.canvas.pen.color:=clred;
image2.canvas.brush.color:=clwhite;
for n:=1 to nc+np-2 do begin
 image2.Canvas.Ellipse(round(mat3d2[n].x)-2-decx,round(mat3d2[n].y-decy)-2,round(mat3d2[n].x)+2-decx,round(mat3d2[n].y)+2-decy);
end;
end;

procedure TForm1.Button12Click(Sender: TObject);
var lo:word;
var typ:string;
begin
if savedialog1.Execute then begin
 {m3d1.SauveTextures(1,savedialog1.filename);
 m3d1.SauveStructure(savedialog1.filename);
 m3d1.SauveObjet(savedialog1.filename);
 lo:=length(savedialog1.filename);
 typ:=Copy(savedialog1.filename,lo-3, 4); }
// typ:=savedialog1.filterindex;
 if savedialog1.filterindex=1 then sauvesurface(savedialog1.filename);
 if savedialog1.filterindex=2 then begin
  m3d1.SauveTextures(1,savedialog1.filename);
  m3d1.SauveStructure(savedialog1.filename);
  m3d1.SauveObjet(savedialog1.filename);
 end;
end;
end;

procedure TForm1.Button13Click(Sender: TObject);
var lo:word;
var typ:string;
begin
if opendialog1.Execute then begin
 lo:=length(opendialog1.filename);
 typ:=Copy(opendialog1.filename,lo-3, 4);
 if typ='.O3D' then m3d1.ChargeObjet(opendialog1.filename); //chargement d'un objet 3D (géré par M3D)
 if typ='.sur' then chargesurface(opendialog1.filename);    //chargement d'une surface (interne)
 //chargesurface(opendialog1.filename);
end;
end;

procedure TForm1.Button14Click(Sender: TObject);
label l1;
begin
 if rendu='fildefer' then begin
  rendu:='texnormal';goto l1;
 end;
 if rendu='texnormal' then begin
  rendu:='texombré';goto l1;
 end;
 if rendu='texombré' then begin
  rendu:='ombré';goto l1;
 end;
 if rendu='ombré' then begin
  rendu:='pcav';goto l1;
 end;
 if rendu='pcav' then begin
   rendu:='coloré';goto l1;
 end;
 if rendu='coloré' then begin
   rendu:='fildefer';goto l1;
 end;

 l1:

 with m3d1 do begin
  moteur.coulfond:=$1234;
  rend(rendu,1);
  moteur.coulfond:=$ffff;
  camera.zoom:=8;
  rend('coloré',2);
  rafraichis(1);
  rafraichis(2);
 end;
end;

procedure Tform1.sauvesurface(fichier:string);
var
fi:file;
t1,t2,n:word;
begin
 t1:=length(im1);t2:=length(im2);

 for n:=1 to t1 do begin
  m1[n]:=ord(im1[n]);
 end;

 for n:=1 to t2 do begin
  m2[n]:=ord(im2[n]);
 end;

 AssignFile(fi,fichier+'.sur');
 Rewrite(fi, 1);

 Blockwrite(fi,t1,2);
 Blockwrite(fi,t2,2);
 Blockwrite(fi,m1,t1);
 Blockwrite(fi,m2,t2);
 Blockwrite(fi,nc,2);
 Blockwrite(fi,np,2);
 Blockwrite(fi,mat3d,(np+nc-2)*30);
 Blockwrite(fi,mat3d2,(np+nc-2)*30);
 CloseFile(Fi);

end;

procedure Tform1.chargesurface(fichier:string);
var
fi:file;
t1,t2,n:word;
begin
  AssignFile(Fi,fichier);
  Reset(Fi,1);

  Blockread(fi,t1,2);
  Blockread(fi,t2,2);
  Blockread(fi,m1,t1);
  Blockread(fi,m2,t2);

  Blockread(fi,nc,2);
  Blockread(fi,np,2);
  Blockread(fi,mat3d,(np+nc-2)*30);
  Blockread(fi,mat3d2,(np+nc-2)*30);
  CloseFile(Fi);
  im1:='';im2:='';

  for n:=1 to t1 do begin
   im1:=im1+chr(m1[n]);
  end;

  for n:=1 to t2 do begin
   im2:=im2+chr(m2[n]);
  end;

  btm1.LoadFromFile(im1);
  m3d1.chargetexture(0,im1);
  btm2.LoadFromFile(im2);
  trctr:=false;
end;

procedure TForm1.Button15Click(Sender: TObject);
begin
 if savedialog1.Execute then begin
  m3d1.SauveTextures(1,savedialog1.filename);
  m3d1.SauveStructure(savedialog1.filename);
  m3d1.SauveObjet(savedialog1.filename);
 end;
end;

procedure TForm1.appercu;
var
n,q1,q2,q3:dword;
mx,my,mz:extended;

begin
with m3d1 do begin
 //m3d1.Moteur.raftamp:=false;
 for n:=1 to cpo do begin
  //mat3d[n].z:=l*dE/(z0+mat3d[n].x-mat3d2[n].x);
   q1:=matpoly[n].p1;q2:=matpoly[n].p2;q3:=matpoly[n].p3;
   structure^[n].z1:=l*dE/((z0+mat3d[q1].x-mat3d2[q1].x+1E-5)*20);       //recalcul des profondeurs
   structure^[n].z2:=l*dE/((z0+mat3d[q2].x-mat3d2[q2].x+1E-5)*20);
   structure^[n].z3:=l*dE/((z0+mat3d[q3].x-mat3d2[q3].x+1E-5)*20);
  end;

 with objet do begin
  taille:=cpo;
  nom:='suface1';
 end;
 //chargetexture(0,'c:\windows\Britney 06.bmp');
// chargetexture(1,'c:\windows\Britney 06.bmp');
 //chargetexture(0,'c:\windows\Britney 06.bmp');
{ for n:=1 to 100 do begin
 m3d1.voirtexture(1);
 end;}
 for n:=1 to cpo do begin
   structure^[n].xt1:=round(matpoly[n].x1);structure^[n].xt2:=round(matpoly[n].x2);structure^[n].xt3:=round(matpoly[n].x3);
   structure^[n].yt1:=round(matpoly[n].y1);structure^[n].yt2:=round(matpoly[n].y2);structure^[n].yt3:=round(matpoly[n].y3);

   structure^[n].y1:=-matpoly[n].x1/20;structure^[n].y2:=-matpoly[n].x2/20;structure^[n].y3:=-matpoly[n].x3/20;
   structure^[n].x1:=matpoly[n].y1/20;structure^[n].x2:=matpoly[n].y2/20;structure^[n].x3:=matpoly[n].y3/20;
   //structure^[n].z1:=matpoly[n].z1/20;structure^[n].z2:=matpoly[n].z2/20;structure^[n].z3:=matpoly[n].z3/20;
   structure^[n].texture:=0;structure^[n].couleur:=random($ffff);
   with structure^[n] do begin
    polarite:=-defsens(x1,y1,x2,y2,x3,y3);
   end;     
  //polarite:=1;
 end;
 mx:=0;my:=0;mz:=0;

 for n:=1 to cpo do begin
  with structure^[n] do begin
   mx:=mx+x1+x2+x3;
   my:=my+y1+y2+y3;
   mz:=mz+z1+z2+z3;
  end;
 end;

 mx:=mx/(3*cpo);
 my:=my/(3*cpo);
 mz:=mz/(3*cpo);
{ with camera do begin
  {posx:=mx;
  posy:=my;
  posz:=mz;
 end;}

 for n:=1 to cpo do begin
  with structure^[n] do begin
   x1:=x1-mx;x2:=x2-mx;x3:=x3-mx;           //recentrage de l'objet en son centre de gravite
   y1:=y1-my;y2:=y2-my;y3:=y3-my;
   z1:=z1-mz;z2:=z2-mz;z3:=z3-mz;
  end;
 end;

 for n:=1 to cpo do begin
  matsav[n].x1:=structure^[n].x1;matsav[n].x2:=structure^[n].x2;matsav[n].x3:=structure^[n].x3;
  matsav[n].y1:=structure^[n].y1;matsav[n].y2:=structure^[n].y2;matsav[n].y3:=structure^[n].y3;
  matsav[n].z1:=structure^[n].z1;matsav[n].z2:=structure^[n].z2;matsav[n].z3:=structure^[n].z3;        //sauvegarde de la structure
  matsav[n].xt1:=structure^[n].xt1;matsav[n].xt2:=structure^[n].xt2;matsav[n].xt3:=structure^[n].xt3;
  matsav[n].yt1:=structure^[n].yt1;matsav[n].yt2:=structure^[n].yt2;matsav[n].yt3:=structure^[n].xt3;
 end;

 { rend(rendu,1);
  rafraichis(1); }
 end;
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin

 l:=(trackbar1.Position);
 z0:=(trackbar2.Position);

 edit4.text:=floattostr(l);
 edit5.text:=floattostr(z0);

 appercu;
 with m3d1 do begin
  moteur.coulfond:=$1234;
  rend(rendu,1);
  moteur.coulfond:=$ffff;
  camera.zoom:=8;
  rend('coloré',2);
  rafraichis(1);
  rafraichis(2);
 end;
end;

procedure TForm1.TrackBar2Change(Sender: TObject);
begin
 l:=(trackbar1.Position);
 z0:=(trackbar2.Position);

 edit4.text:=floattostr(l);
 edit5.text:=floattostr(z0);
 appercu;

  with m3d1 do begin
   moteur.coulfond:=$1234;
   rend(rendu,1);
   moteur.coulfond:=$ffff;
   camera.zoom:=8;
   rend('coloré',2);
   rafraichis(1);
   rafraichis(2);
 end;
end;

procedure TForm1.fragmente(dist:extended);
var n:dword;
var x1,x2,x3,y1,y2,y3,z1,z2,z3,mx,my,mz,a,b:extended;
begin
with m3d1 do begin
 for n:=1 to cpo do begin
   x1:=matsav[n].x1;x2:=matsav[n].x2;x3:=matsav[n].x3;
   y1:=matsav[n].y1;y2:=matsav[n].y2;y3:=matsav[n].y3;
   z1:=matsav[n].z1;z2:=matsav[n].z2;z3:=matsav[n].z3;
   mx:=(x1+x2+x3)/3;my:=(y1+y2+y3)/3;mz:=(z1+z2+z3)/3;
   structure^[n].x1:=mx*dist+x1;structure^[n].x2:=mx*dist+x2;structure^[n].x3:=mx*dist+x3;
   structure^[n].y1:=my*dist+y1;structure^[n].y2:=my*dist+y2;structure^[n].y3:=my*dist+y3;
   structure^[n].z1:=mz*dist+z1;structure^[n].z2:=mz*dist+z2;structure^[n].z3:=mz*dist+z3;
 end;
end;
end;

procedure TForm1.Button11Click(Sender: TObject);
var n,p1,p2,p3:dword;
begin
 fragmente(1.3);
 m3d1.rend(rendu,1);
 m3d1.rafraichis(1);
end;

procedure TForm1.TrackBar3Change(Sender: TObject);
begin
 fragmente((TrackBar3.position-400)/100);
  with m3d1 do begin
  moteur.coulfond:=$1234;
  rend(rendu,1);
  moteur.coulfond:=$ffff;
  camera.zoom:=8;
  rend('coloré',2);
  rafraichis(1);
  rafraichis(2);
 end;
 {m3d1.rend(rendu,1);
 m3d1.rafraichis(1);  }
end;

                                         
procedure TForm1.Image3MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if bloque=False then begin
  m3d1.alpha:=x/40;
  m3d1.tetha:=y/40;
 end;
 dehor:=False;
end;

procedure TForm1.Button7Click(Sender: TObject);
var svimg:Tbitmap;
begin

 svimg:=tbitmap.Create;
 svimg.width:=506;                               
 svimg.height:=352;
 if SavePictureDialog1.Execute then begin
   SavePictureDialog1.title:='Sauvegarder le rendu';
   svimg.Canvas.copyrect(rect(0,0,506,352),m3d1.canvas,rect(0,0,506,352));
   svimg.savetofile(SavePictureDialog1.filename+'.bmp');
 end;
 svimg.Destroy;
end;
                                                   

procedure TForm1.Image3MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
  var p:word;
begin
 p:=m3d1.numpoly(2,x,y);
 m3d1.structure[p].couleur:=$ffff-m3d1.structure[p].couleur;  //couleur invérsé du polygone sélectionné

end;

/////////////////////////////////////////////Partie désitinée à relier les points en une surface uniforme faite de triangle//////////////////////////////////////

procedure TForm1.etape1;
var m,n,p,q:dword;
var d,dmin,da,al,ai,xm,ym:extended;
var npol,mpol,tpol,tlim:word;
var g:boolean;
var sens,sensi:shortint;
label l1,l2,l3;
begin
 cli:=0;ctr:=0;ntrait:=0;
  nf:=np+nc-2;

 m3d1.canvas.pen.width:=1;m3d1.canvas.Pen.color:=clblack;
for p:=1 to nf do begin
 for n:=1 to nf do begin
   d:=sqrt(sqr(mat3d[n].x-mat3d[p].x)+sqr(mat3d[n].y-mat3d[p].y));      //calcul de toutes les distances du contour
   Matligne^[n,p].dist:=d;Matligne^[p,n].dist:=d;

    Matligne^[n,p].etat:=0;Matligne^[p,n].etat:=0;

   if (n=p)  then begin
     Matligne^[p,n].etat:=2;Matligne^[n,p].etat:=2;
   end;

  end;
 end;

 Matligne^[1,2].etat:=1;Matligne^[2,1].etat:=1;
 for n:=2 to nc-1 do begin

  Matligne^[n-1,n].etat:=1;Matligne^[n,n-1].etat:=1;
  lfin[n-1].p1:=n-1;lfin[n-1].p2:=n;
 end;

 Matligne^[nc-1,1].etat:=1;Matligne^[1,nc-1].etat:=1;
 lfin[nc-1].p1:=nc-1;lfin[nc-1].p2:=1;
 ctr:=nc-1;
 ntrait:=nc-1;

 for n:=1 to ntrait-1 do begin
  multrait[n].x1:=mat3d[n].x;multrait[n].y1:=mat3d[n].y;
  multrait[n].x2:=mat3d[n+1].x;multrait[n].y2:=mat3d[n+1].y;
  if (multrait[n].x1-multrait[n].x2)<>0 then multrait[n].coef:=(multrait[n].y1-multrait[n].y2)/(multrait[n].x1-multrait[n].x2)
  else multrait[n].coef:=314159265;
 end;

 multrait[ntrait].x1:=mat3d[ntrait].x;multrait[ntrait].y1:=mat3d[ntrait].y;
 multrait[ntrait].x2:=mat3d[1].x;multrait[ntrait].y2:=mat3d[1].y;
 if (multrait[ntrait].x1-multrait[ntrait].x2)<>0 then multrait[ntrait].coef:=(multrait[ntrait].y1-multrait[ntrait].y2)/(multrait[ntrait].x1-multrait[ntrait].x2)
 else multrait[ntrait].coef:=314159265;

  al:=0;

 ai:=detangle(mat3d[1].x,mat3d[1].y,mat3d[2].x,mat3d[2].y,mat3d[nc-1].x,mat3d[nc-1].y);

 for n:=2 to nc-2 do begin
  da:=detangle(mat3d[1].x,mat3d[1].y,mat3d[n].x,mat3d[n].y,mat3d[n+1].x,mat3d[n+1].y);
  al:=al+da;
 end;

if al<0 then sens:=1;
if al>0 then sens:=-1;
edit2.text:=floattostr(abs(al-ai))+' '+inttostr(sens);

p:=3;                       //a partir du point p
for p:=1 to nc-1 do begin
for n:=1 to nc-1 do begin //1  //chercher les segments [pn] qui sortent du contour
 al:=0;
 if Matligne^[p,n].etat=0 then begin//2
  for m:=1 to nc-2 do begin//3  //et qui ne coupent pas les segments [mm+1]
   if coupe(p,n,m,m+1) then begin //4
     Matligne^[p,n].etat:=2;Matligne^[n,p].etat:=2;
     goto l2;
   end;  //4
                                                                //on verifie qu'elle ne coupe aucune droite du contour
  end;  //3
  if coupe(p,n,1,nc-1) then begin //4
    Matligne^[p,n].etat:=2;Matligne^[n,p].etat:=2;
    goto l2;
   end;

   xm:=(mat3d[p].x+mat3d[n].x)/2;
   ym:=(mat3d[p].y+mat3d[n].y)/2;

   //ai:=detangle(mat3d[1].x,mat3d[1].y,mat3d[2].x,mat3d[2].y,mat3d[nc-1].x,mat3d[nc-1].y);

   for q:=1 to nc-2 do begin
     da:=detangle(xm,ym,mat3d[q].x,mat3d[q].y,mat3d[q+1].x,mat3d[q+1].y);
     al:=al+da;
   end;

    da:=detangle(xm,ym,mat3d[nc-1].x,mat3d[nc-1].y,mat3d[1].x,mat3d[1].y);
    al:=al+da;
   //sensi:=defsens(mat3d[p].x,mat3d[p].y,mat3d[round((p+n)/2)].x,mat3d[round((p+n)/2)].y,xm,ym)           //puis on verifie qu'elle ne sort pas du cadre

   if abs(al)<1 then begin
    Matligne^[p,n].etat:=2;Matligne^[n,p].etat:=2;
   end;
  l2:                                                  
 end;  //2
end;  //1
end;

for p:=1 to nc-1 do begin
  tampligne^[p]:=65535;
  for n:=1 to nc-1 do begin
    tampligne^[n]:=round(matligne^[p,n].dist*10);
  end;

  for n:=1 to nc-1 do begin
     mpol:=65534;
     for q:=1 to nc-1 do begin
      tpol:=tampligne^[q];                           //tri de matligne dans mligne
      if (tpol<mpol) then begin
       mpol:=tpol;
       npol:=q;
      end;
     end;
     tampligne^[npol]:=65535;
     mligne^[p,n-1].num:=npol;
     mligne^[p,n-1].etat:=matligne^[p,npol].etat;
  end;

 end;

for n:=1 to nc-2 do begin
 for m:=1 to nc-2 do begin            //relie  l'ensemble des points a son n-ieme plus proche
 p:=mligne^[m,n].num;

    if Matligne^[m,p].etat=0 then begin

    for q:=1 to ntrait do begin         // q=point le n-ieme plus proche de m
     if {coupe2(m,p,q)} coupe3(m,p,q) then begin  // on verifie que [pm] ne coupe pas la q-ieme ligne deja existante
      //mligne^[m,n].etat:=2;
       Matligne^[m,p].etat:=2;Matligne^[p,m].etat:=2;

     // g:=coupe3(m,p,q);

      goto l1;
     end;
   end;
    //mligne^[m,n].etat:=1;
    Matligne^[m,p].etat:=1;Matligne^[p,m].etat:=1;
    inc(ntrait);
    with multrait[ntrait] do begin
     x1:=mat3d[m].x;y1:=mat3d[m].y;
     x2:=mat3d[p].x;y2:=mat3d[p].y;
     if (x1-x2)<>0 then coef:=(y1-y2)/(x1-x2)
     else coef:=314159265;
    end;

    l1:

  end;
 end;
// if ntrait>tlim then break;
end;
 edit1.text:=inttostr(nf);
 edit3.text:=inttostr(ntrait);

//if masq=False then begin
 //m3d1.canvas.rectangle(0,0,640,480);
 m3d1.canvas.Pen.color:=clblue;
  tlim:=(np-1)*3+ntrait;

for p:=1 to nf do begin
 for n:=1 to nf do begin
   if (Matligne^[n,p].etat=1)  then begin
    Matligne^[n,p].etat:=0;Matligne^[p,n].etat:=0;
   end;
  end;
 end;

 Matligne^[1,2].etat:=1;Matligne^[2,1].etat:=1;

 for n:=2 to nc-1 do begin
  Matligne^[n-1,n].etat:=1;Matligne^[n,n-1].etat:=1;
 end;
 Matligne^[nc-1,1].etat:=1;Matligne^[1,nc-1].etat:=1;
 ntrait:=nc-1;

 for n:=1 to ntrait-1 do begin
  multrait[n].x1:=mat3d[n].x;multrait[n].y1:=mat3d[n].y;
  multrait[n].x2:=mat3d[n+1].x;multrait[n].y2:=mat3d[n+1].y;
  if (multrait[n].x1-multrait[n].x2)<>0 then multrait[n].coef:=(multrait[n].y1-multrait[n].y2)/(multrait[n].x1-multrait[n].x2)
  else multrait[n].coef:=314159265;
 end;

 multrait[ntrait].x1:=mat3d[ntrait].x;multrait[ntrait].y1:=mat3d[ntrait].y;
 multrait[ntrait].x2:=mat3d[1].x;multrait[ntrait].y2:=mat3d[1].y;
 if (multrait[ntrait].x1-multrait[ntrait].x2)<>0 then multrait[ntrait].coef:=(multrait[ntrait].y1-multrait[ntrait].y2)/(multrait[ntrait].x1-multrait[ntrait].x2)
 else multrait[ntrait].coef:=314159265;

{ tlim:=(nf-v1)*3+v2;
 v1:=np+nc-2;v2:=ntrait;   }
 //tlim:=10000;

 p:=3;
 for p:=1 to nf do begin
  tampligne^[p]:=65535;
  for n:=1 to nf do begin
    tampligne^[n]:=round(matligne^[p,n].dist*10);
  end;

  for n:=1 to nf do begin
     mpol:=65534;
     for q:=1 to nf do begin
      tpol:=tampligne^[q];                           //tri de matligne dans mligne
      if (tpol<mpol) then begin
       mpol:=tpol;
       npol:=q;
      end;
     end;
     tampligne^[npol]:=65535;
     mligne^[p,n-1].num:=npol;
     mligne^[p,n-1].etat:=matligne^[p,npol].etat;
  end;

 end;

ntrait:=nc-1;

n:=5;
for n:=1 to nf-1 do begin
 for m:=1 to nf-1 do begin            //relie  l'ensemble des points a son n-ieme plus proche
 p:=mligne^[m,n].num;

    if Matligne^[m,p].etat=0 then begin

    for q:=1 to ntrait do begin         // q=point le n-ieme plus proche de m
     if {coupe2(m,p,q)} coupe3(m,p,q) then begin  // on verifie que [pm] ne coupe pas la q-ieme ligne deja existante
      //mligne^[m,n].etat:=2;
       Matligne^[m,p].etat:=2;Matligne^[p,m].etat:=2;

     // g:=coupe3(m,p,q);

      goto l3;
     end;
   end;
    //mligne^[m,n].etat:=1;
    Matligne^[m,p].etat:=1;Matligne^[p,m].etat:=1;
    inc(ntrait);inc(ctr);lfin[ctr].p1:=m;lfin[ctr].p2:=p;
    with multrait[ntrait] do begin
     x1:=mat3d[m].x;y1:=mat3d[m].y;
     x2:=mat3d[p].x;y2:=mat3d[p].y;
     if (x1-x2)<>0 then coef:=(y1-y2)/(x1-x2)
     else coef:=314159265;
    end;

    if (ntrait>tlim)  then break;
    l3:

  end;
   if (ntrait>tlim)  then break;
 end;
// if ntrait>tlim then break;
end;
 edit1.text:=inttostr(nf);
 edit3.text:=inttostr(ntrait);

end;

procedure TForm1.devinepolygones;
var n,p,m,q,r,c1,c2,c3,pols,o:dword;
var xm,ym:extended;
label l4;
label l5;
begin
 cpo:=1;

 for n:=1 to ctr do begin
   lfin[n].poly1:=0;lfin[n].poly2:=0;
   matpoly[n].x1:=10000;matpoly[n].x2:=11000;matpoly[n].x3:=12000;
 end;

for p:=1 to ctr do begin        //en partant de la droite lfin[p]
 pols:=lfin[p].poly1;
 //p:=3;
 c1:=lfin[p].p1;
 c2:=lfin[p].p2;
 for n:=1 to ctr do begin    //b1          //on cherche 2 droites lfin[n] et lfin[m] pour que l'ensemble forme un triangle

  if (lfin[n].p1=c1) or (lfin[n].p2=c1)  then begin   //b2
   if (lfin[n].p1=c1) then c3:=lfin[n].p2;
   if (lfin[n].p2=c1) then c3:=lfin[n].p1;
   for m:=1 to ctr do begin      //b3

    if (((lfin[m].p1=c3) and (lfin[m].p2=c2)) or ((lfin[m].p1=c2) and (lfin[m].p2=c3))) then begin   //b4
     for q:=1 to cpo do begin
       if (mat3d[c1].x=matpoly[q].x1) and (mat3d[c2].x=matpoly[q].x2) and (mat3d[c3].x=matpoly[q].x3) then goto l4;
       if (mat3d[c1].x=matpoly[q].x2) and (mat3d[c2].x=matpoly[q].x3) and (mat3d[c3].x=matpoly[q].x1) then goto l4;
       if (mat3d[c1].x=matpoly[q].x3) and (mat3d[c2].x=matpoly[q].x2) and (mat3d[c3].x=matpoly[q].x1) then goto l4;   //on verifie que ce triangle n'existe pas deja sous d'autres formes
       if (mat3d[c1].x=matpoly[q].x1) and (mat3d[c2].x=matpoly[q].x3) and (mat3d[c3].x=matpoly[q].x2) then goto l4;
       if (mat3d[c1].x=matpoly[q].x2) and (mat3d[c2].x=matpoly[q].x1) and (mat3d[c3].x=matpoly[q].x3) then goto l4;
       if (mat3d[c1].x=matpoly[q].x3) and (mat3d[c2].x=matpoly[q].x1) and (mat3d[c3].x=matpoly[q].x2) then goto l4;
     end;
     { 1 2 3
       2 3 1
       3 2 1
       1 3 2
       2 1 3
       3 1 2     }
     xm:=(mat3d[c1].x+mat3d[c2].x)/2;
     ym:=(mat3d[c1].y+mat3d[c2].y)/2;
     for q:=1 to ctr do begin
      if ((lfin[q].p2<>c3) and  (lfin[q].p1<>c3)) and ((lfin[q].p1<>c2) or (lfin[q].p2<>c1))  and ((lfin[q].p1<>c1) or (lfin[q].p2<>c2))   then begin
        if coupe2(lfin[q].p1,lfin[q].p2,c3,xm,ym) then goto l4;
      end;
     end;

     matpoly[cpo].x1:=mat3d[c1].x;matpoly[cpo].y1:=mat3d[c1].y;//matpoly[cpo].z1:=mat3d[c1].z;
     matpoly[cpo].x2:=mat3d[c2].x;matpoly[cpo].y2:=mat3d[c2].y;//matpoly[cpo].z2:=mat3d[c2].z;
     matpoly[cpo].x3:=mat3d[c3].x;matpoly[cpo].y3:=mat3d[c3].y;//matpoly[cpo].z3:=mat3d[c3].z;
     matpoly[cpo].p1:=c1;matpoly[cpo].p2:=c2;matpoly[cpo].p3:=c3;
    // image1.canvas.Pen.color:=clblack;
     //image1.canvas.Brush.color:=random($ffffff);
     //image1.canvas.Polygon([point(round(matpoly[cpo].x1),round(matpoly[cpo].y1)),point(round(matpoly[cpo].x2),round(matpoly[cpo].y2)),point(round(matpoly[cpo].x3),round(matpoly[cpo].y3))]);
     inc(cpo);
     goto l5;
     l4:
      {matpoly[cpo].x1:=mat3d[c1].x;matpoly[cpo].y1:=mat3d[c1].y;matpoly[cpo].z1:=mat3d[c1].z;
      matpoly[cpo].x2:=mat3d[c2].x;matpoly[cpo].y2:=mat3d[c2].y;matpoly[cpo].z2:=mat3d[c2].z;
      matpoly[cpo].x3:=mat3d[c3].x;matpoly[cpo].y3:=mat3d[c3].y;matpoly[cpo].z3:=mat3d[c3].z;  }

     l5:
    end;     //f4
   end;     //f3

  end;  //f2

 end;  //f1
end;
dec(cpo);
edit2.text:=inttostr(cpo);
end;

function  TForm1.coupe3(p1,p2,tn:word):boolean;
var n,pn:word;
var d1,d2,b1,b2,xi,x1,y1,x2,y2,x3,x4,y3,y4:extended;
var entre1,entre2:boolean;
begin
 inc(cli);pn:=tn;
 x1:=mat3d[p1].x;y1:=mat3d[p1].y;
 x2:=mat3d[p2].x;y2:=mat3d[p2].y;
 x3:=multrait[pn].x1;y3:=multrait[pn].y1;
 x4:=multrait[pn].x2;y4:=multrait[pn].y2;
 coupe3:=false;entre1:=false;entre2:=false;
 if  (x1=x2) or  (x3=x4) then begin
  d1:=(x1-x2)/(y1-y2+1E-8);
  d2:=(x3-x4)/(y3-y4+3E-8);
  b1:=x1-d1*y1;
  b2:=x3-d2*y3;
  xi:=(b2-b1)/(d1-d2+2E-8);
  if (y3<xi) and (y4>xi) then entre1:=True;
  if (y3>xi) and (y4<xi) then entre1:=True;

  if ((x3=x1) and (y3=y1)) or ((x3=x2) and (y3=y2)) or ((x4=x1) and (y4=y1)) or ((x4=x2) and (y4=y2)) then entre1:=false;

  if (y1<xi) and (y2>xi) then entre2:=True;
  if (y1>xi) and (y2<xi) then entre2:=True;

 end
 else  begin

 d1:=(y1-y2)/(x1-x2);
 //d2:=(y3-y4)/(x3-x4);
 d2:=multrait[pn].coef;
 b1:=y1-d1*x1;
 b2:=y3-d2*x3;
 xi:=(b2-b1)/(d1-d2+1E-8);
 if (x3<xi) and (x4>xi) then entre1:=True;
 if (x3>xi) and (x4<xi) then entre1:=True;
 if ((x3=x1) and (y3=y1)) or ((x3=x2) and (y3=y2)) or ((x4=x1) and (y4=y1)) or ((x4=x2) and (y4=y2)) then entre1:=false;

 if (x1<xi) and (x2>xi) then entre2:=True;
 if (x1>xi) and (x2<xi) then entre2:=True;
 end;
 if (entre1=true) and (entre2=true) then coupe3:=true;

end;

function  TForm1.coupe2(p1,p2,p3:word;x4u,y4u:extended):boolean;
var n:word;
var d1,d2,b1,b2,xi,x1,y1,x2,y2,x3,x4,y3,y4:extended;
var entre1,entre2:boolean;
begin
 inc(cli);
 x1:=mat3d[p1].x;y1:=mat3d[p1].y;
 x2:=mat3d[p2].x;y2:=mat3d[p2].y;
 x3:=mat3d[p3].x;y3:=mat3d[p3].y;
 coupe2:=false;entre1:=false;entre2:=false;
 if  (x1=x2) or  (x3=x4u) then begin
  d1:=(x1-x2)/(y1-y2+1E-8);
  d2:=(x3-x4u)/(y3-y4u+3E-8);
  b1:=x1-d1*y1;
  b2:=x3-d2*y3;
  xi:=(b2-b1)/(d1-d2+2E-8);
  if (y3<xi) and (y4u>xi) then entre1:=True;
  if (y3>xi) and (y4u<xi) then entre1:=True;

 // if ((x3=x1) and (y3=y1)) or ((x3=x2) and (y3=y2)) or ((x4u=x1) and (y4u=y1)) or ((x4u=x2) and (y4u=y2)) then entre1:=false;

  if (y1<xi) and (y2>xi) then entre2:=True;
  if (y1>xi) and (y2<xi) then entre2:=True;

 end
 else  begin

 d1:=(y1-y2)/(x1-x2);
 d2:=(y3-y4u)/(x3-x4u);
 b1:=y1-d1*x1;
 b2:=y3-d2*x3;
 xi:=(b2-b1)/(d1-d2+1E-8);
 if (x3<xi) and (x4u>xi) then entre1:=True;
 if (x3>xi) and (x4u<xi) then entre1:=True;
 //if ((x3=x1) and (y3=y1)) or ((x3=x2) and (y3=y2)) or ((x4u=x1) and (y4u=y1)) or ((x4u=x2) and (y4u=y2)) then entre1:=false;

 if (x1<xi) and (x2>xi) then entre2:=True;
 if (x1>xi) and (x2<xi) then entre2:=True;
 end;
 if (entre1=true) and (entre2=true) then coupe2:=true;
 {
 d1*x1+b1=y1
 b1=y1-d1*x1

 d1*xi+b1=d2*xi+b2
 (d1-d2)*xi=(b2-b1)
 xi=(b2-b1)/(d1-d2) }
end;

function TForm1.coupe(p1,p2,p3,p4:word):boolean;
var n:word;
var d1,d2,b1,b2,xi,x1,y1,x2,y2,x3,x4,y3,y4:extended;
var entre1,entre2:boolean;
begin
 inc(cli);
 x1:=mat3d[p1].x;y1:=mat3d[p1].y;
 x2:=mat3d[p2].x;y2:=mat3d[p2].y;
 x3:=mat3d[p3].x;y3:=mat3d[p3].y;
 x4:=mat3d[p4].x;y4:=mat3d[p4].y;
 coupe:=false;entre1:=false;entre2:=false;
 if  (x1=x2) or  (x3=x4) then begin
  d1:=(x1-x2)/(y1-y2+1E-8);
  d2:=(x3-x4)/(y3-y4+3E-8);
  b1:=x1-d1*y1;
  b2:=x3-d2*y3;
  xi:=(b2-b1)/(d1-d2+2E-8);
  if (y3<xi) and (y4>xi) then entre1:=True;
  if (y3>xi) and (y4<xi) then entre1:=True;

  if ((x3=x1) and (y3=y1)) or ((x3=x2) and (y3=y2)) or ((x4=x1) and (y4=y1)) or ((x4=x2) and (y4=y2)) then entre1:=false;

  if (y1<xi) and (y2>xi) then entre2:=True;
  if (y1>xi) and (y2<xi) then entre2:=True;

 end
 else  begin

 d1:=(y1-y2)/(x1-x2);
 d2:=(y3-y4)/(x3-x4);
 b1:=y1-d1*x1;
 b2:=y3-d2*x3;
 xi:=(b2-b1)/(d1-d2+1E-8);
 if (x3<xi) and (x4>xi) then entre1:=True;
 if (x3>xi) and (x4<xi) then entre1:=True;
 if ((x3=x1) and (y3=y1)) or ((x3=x2) and (y3=y2)) or ((x4=x1) and (y4=y1)) or ((x4=x2) and (y4=y2)) then entre1:=false;

 if (x1<xi) and (x2>xi) then entre2:=True;
 if (x1>xi) and (x2<xi) then entre2:=True;
 end;
 if (entre1=true) and (entre2=true) then coupe:=true;
 {
 d1*x1+b1=y1
 b1=y1-d1*x1

 d1*xi+b1=d2*xi+b2
 (d1-d2)*xi=(b2-b1)
 xi=(b2-b1)/(d1-d2) }
end;

function tform1.defsens(x1u,y1u,x2u,y2u,x3u,y3u:extended):shortint;
var au,bu,yu:extended;
var se,ses:integer;
var sor,sens:boolean;
begin
ses:=1;
if ses<>0 then begin
if (y1u>y2u) and (y1u>y3u) then begin
    if ((x2u-x1u)*(x3u-x1u)<0) then begin
     if (x2u<x3u) then se:=1;
     if (x3u<=x2u) then se:=-1;
    end;

    if (x2u<x1u) and (x3u<x1u) then begin
     au:=(y1u-y2u)/(x1u-x2u);
     bu:=y2u-au*x2u;
     yu:=au*x3u+bu;
     if (y3u<yu) then se:=1;
     if (y3u>yu) then se:=-1;
     if y3u=yu then se:=0;
    end;

    if (x2u>x1u) and (x3u>x1u) then begin
     au:=(y1u-y2u)/(x1u-x2u);
     bu:=y2u-au*x2u;
     yu:=au*x3u+bu;
     if (y3u<yu) then se:=-1;
     if (y3u>yu) then se:=1;
     if y3u=yu then se:=0;
    end;

    if (x1u=x2u) then begin
       if (x3u<x2u) then se:=-1;
       if (x3u>x2u) then se:=1;
       se:=0;
    end;
end;

if (y1u<y2u) and (y2u>y3u) then begin
    if ((x1u-x2u)*(x3u-x2u)<0)  then begin
     if (x3u<x1u) then se:=1;
     if (x1u<=x3u) then se:=-1;
    end;

    if (x1u<x2u) and (x3u<x2u) then begin
     au:=(y2u-y3u)/(x2u-x3u);
     bu:=y3u-au*x3u;
     yu:=au*x1u+bu;
     if (y1u<yu) then se:=1;
     if (y1u>yu) then se:=-1;
     if y1u=yu then se:=0;
    end;

    if (x1u>x2u) and (x3u>x2u) then begin
     au:=(y2u-y3u)/(x2u-x3u);
     bu:=y3u-au*x3u;
     yu:=au*x1u+bu;
     if (y1u<yu) then se:=-1;
     if (y1u>yu) then se:=1;
     if y1u=yu then se:=0;
    end;

    if (x2u=x3u) then begin
     if (x1u<x2u) then se:=-1;
     if (x1u>x2u) then se:=1;
     se:=0;
    end;

end;

if (y3u>y1u) and (y3u>y2u) then begin
    if ((x1u-x3u)*(x2u-x3u)<0)  then begin
     if (x1u<x2u) then se:=1;
     if (x2u<=x1u) then se:=-1;
    end;

    if (x1u<x3u) and (x2u<x3u) then begin
     au:=(y3u-y1u)/(x3u-x1u);
     bu:=y1u-au*x1u;
     yu:=au*x2u+bu;
     if (y2u<yu) then se:=1;
     if (y2u>yu) then se:=-1;
     if y2u=yu then se:=0;
    end;

    if (x1u>x3u) and (x2u>x3u) then begin
     au:=(y3u-y1u)/(x3u-x1u);
     bu:=y1u-au*x1u;
     yu:=au*x2u+bu;
     if (y2u<yu) then se:=-1;
     if (y2u>yu) then se:=1;
     if y2u=yu then se:=0;
    end;

    if (x3u=x1u) then begin
       if (x2u<x1u) then se:=-1;
       if (x2u>x1u) then se:=1;
       se:=0;
    end;

end;

if (y1u=y2u) or (y1u=y3u) or (y2u=y3u) then se:=0;
if (x1u=x2u) or (x1u=x3u) or (x2u=x3u) then se:=0;

if (se*ses=-1) then sens:=false;
if (se*ses=1) or (ses=0) then begin
 sens:=true;
// inc(polyd);
end;
end;
if sens then defsens:=1
else defsens:=-1;

if se=0 then defsens:=0;

end;

function  TForm1.detangle(x1,y1,x2,y2,x3,y3:extended):extended;
var a,b,a2,b2,xi,yi,l1,l2,angle,x1p,y1p,x2p,y2p,x3p,y3p:extended;
var si:shortint;
begin
x1p:=x1+1E-3;y1p:=y1+1E-3;
x2p:=x2+2E-3;y2p:=y2+2E-3;
x3p:=x3+3E-3;y3p:=y3+3E-3;
 if (x3p-x1p)<>0 then begin
  if (y3p-y1p)<>0 then begin
   a:=(y3p-y1p)/(x3p-x1p);
   b:=y1p-a*x1p;                //y1=a*x1+b
   a2:=-1/a;
   b2:=y2p-a2*x2p;              //y2=a*x1+b
   xi:=(b2-b)/(a-a2);         //a*x+b=a2*x+b2
   yi:=a*xi+b;
   l1:=sqrt(sqr(yi-y2p)+sqr(xi-x2p));
   l2:=sqrt(sqr(yi-y1p)+sqr(xi-x1p));
   angle:=Arctan(l1/l2);
   if (y3p-y1p)*(yi-y1p)<0 then angle :=pi-angle;
   si:=defsens(x1p,y1p,x2p,y2p,x3p,y3p);
   detangle:=si*angle*180/pi;
  end

  else begin
   l1:=abs(y3p-y2p);
   l2:=abs(x2p-x1p);
   angle:=Arctan(l1/l2);
   if (x3p-x1p)*(xi-x1p)<0 then angle :=pi-angle;
   si:=defsens(x1p,y1p,x2p,y2p,x3p,y3p);
   detangle:=si*angle*180/pi;
  end;
end
else begin
  l1:=abs(x2p-x1p);
  l2:=abs(y2p-y1p);
  angle:=Arctan(l1/l2);
  if (y3p-y1p)*(yi-y1p)<0 then angle :=pi-angle;
  si:=defsens(x1p,y1p,x2p,y2p,x3p,y3p);
  detangle:=si*angle*180/pi;
end;
end;

function  TForm1.dehors(x1,y1:extended):boolean;
var q:dword;
var al,da:extended;
begin
 dehors:=False;
 al:=0;
 for q:=1 to nc-2 do begin
   da:=detangle(x1,y1,mat3d[q].x,mat3d[q].y,mat3d[q+1].x,mat3d[q+1].y);
   al:=al+da;
  end;

  da:=detangle(x1,y1,mat3d[nc-1].x,mat3d[nc-1].y,mat3d[1].x,mat3d[1].y);
  al:=al+da;
  if abs(al)<1 then dehors:=True;
end;

procedure TForm1.Button7pClick(Sender: TObject);
var n:dword;
begin
 for n:=1 to 1000000 do begin
  image1.Picture.Bitmap.Canvas.Pixels[2,2]:=53;
 end;
end;

end.
Conclusion :

La partie 3D est géré par mon moteur 3D (M3D) normalement disponible sur ce site.
Important:Pour faire fonctionner l'exemple dézippez le fichier dans c:\windows et suivez les indications (décompréssez les jpegs).
Télécharger le projet
Codes Sources

A voir également

3d stéréoscopique. faites de la 3d à partir de deux photos.
Projet reconstruction 3d à partir une seule image - Codes sources - C / C++ / C++.NET (Application)
Visual Basic / VB.NET : Jeux 3d iso ver 1.2 - CodeS SourceS - Guide
Visual Basic / VB.NET : Loi de pythagore, prog qui calcule une mesure manquante a partir des 2 autre - Guide
C / C++ / C++.NET : "trouver l'équation d'une droite à partir de deux points&quo - Guide
C / C++ / C++.NET : Métaoutilex - 2e partie (les 2 srces sont nécessaires) - CodeS So - Guide
Ajouter un commentaire
Commentaire

S'inscrire maintenant
Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.
3d stéréoscopique. faites de la 3d à partir de deux photos.

Description

Source / Exemple :

Conclusion :

Codes Sources

A voir également

Commentaire

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (cs_cam91)

Jonglage en notation siteswap

Synchronisez vos sous-titres

Jeu: randonné virtuelle en montagne.

Modeleur 3d: fabriquez des objets 3d simplements à partir de primitives (cube,cylindre...), appliquez leurs ensuite des text

Quelques routines graphiques performantes (négatif d'une image,balance rvb,noir et blanc)

Source / Exemple :

Conclusion :

A voir également

Vous n'êtes pas encore membre ? inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Du même auteur (cs_cam91)

Jonglage en notation siteswap

Synchronisez vos sous-titres

Jeu: randonné virtuelle en montagne.

Modeleur 3d: fabriquez des objets 3d simplements à partir de primitives (cube,cylindre...), appliquez leurs ensuite des text

Quelques routines graphiques performantes (négatif d'une image,balance rvb,noir et blanc)

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
