Vorlesung: Aufbau von 3D CAD Systemen (WS 1998/99)

 Datenstruktur für einen Brep Facetten Modellierer
nach Mäntylä: An Introduction to Solid Modeling

nach Pascal übertragen von R.Schwaibold

(******************************************************************)
 (*
    Deklaration der Halbkanten-Datenstruktur,
    Deklaration der Konstanten und
    Deklaration globaler Variablen
 *)
(******************************************************************)
unit gwb;
(*****************************************)
  (****** DEFINITIONSTEIL ********)
(*****************************************)
Interface
type
(**** Deklaration einfacher Typen *****)
 rtp = double;                                        { Koordinatentyp }
 vector = array[0..3] of rtp;                       { homogene 3D-Koordinaten}
 {vector2d = array[0..2] of rtp; }                    { erweiterte 2D-Koordinaten }
 matrix = array[0..3] of vector;                    { Proj.matrix }
 parameters=(solid,face,loop,halfedge,edge,vertex); { Variantenbezechner von
                                                      tnode s.u.}
 id        = Integer;                   { Bezeichnertyp der Recordinstanzen}

(****  Deklaration der Zeigertypen *****)
 pbrface     = ^tbrface;
 pbrsolid    = ^tbrsolid;
 ploop     = ^tloop;
 pedge     = ^tedge;
 phalfedge = ^thalfedge;
 pbrvertex   = ^tbrvertex;
 pnode     = ^tnode;
(***** Deklaration der Recordtypen *********)

tbox = record                        { boundarybox im 3-D und 2-D}
        min:vector;                  { 3D-Minimum (x,y,z) }
        max:vector;                  { 3D-Maximum (x,y,z) }
        {min2d:vector2d;  }            { 2D-Minimum (x,y) }
        {max2d:vector2d;  }            { 2D-Maximum (x,y) }
      end;
tbrsolid = record                      { K”rper }
          color:integer;             { Farbe des K”rpers }
          bbox : tbox;               { boundarybox eines K”rpers }
          solidno : id;              { bezeichner des K”rpers }
          sfaces  : pbrface;           { Zeiger auf Fl„chenliste }
          sedges  : pedge;           { Zeiger auf Kantenliste }
          sverts  : pbrvertex;         { Zeiger auf Knotenliste }
          nexts   : pbrsolid;          { Zeiger auf Nachfolger }
          prevs   : pbrsolid;          { Zeiger auf Vorg„nger }
         end;
 

tbrface = record                      { Fl„che }
        color:integer;              { Fl„chenfarbe }
        BS:boolean;                 { Markierung von Vorder-
                                      und Rckseiten (BackSide) }
        bbox:tbox;                  { boundary-box des K”rpers }
        mark:boolean;               { Markierung von sich selbstberhrenden
                                      Berandungen einer Fl„che }
        dist:rtp;                   { definiert Abstand zum Augpunkt
                                      Siehe Diplarbeit Kap.8 }
        faceno : id;                { Fl„chenbezeichner }
        fsolid : pbrsolid;            { Zeiger auf Vorg„nger }
        flout  : ploop;             { Zeiger auf „uáere Fl„chenberandung, gespeichert in floops }
        floops : ploop;             { Berandungsliste }
        feq : vector;               { Fl„chennormale }
        nextf : pbrface;              { Zeiger auf Nachfolger }
        prevf : pbrface;              { Zeiger auf Vorg„nger }
       end;
tloop  = record                     { Schleife }
         ledge : phalfedge;         { Zeiger auf erste Halbkante
                                      des Halbkantenrings }
         lface : pbrface;             { Zeiger auf adj. Fl„che }
         nextl : ploop;             { Zeiger auf Nachfolger }
         prevl : ploop;             { Zeiger auf Vorg„nger }
        end;
tedge = record
         mark:boolean;              { markiert Flatterkanten }
         bbox :tbox;                { bbox einer Kante }
         ne:integer;                { Verweis auf Nullkante, falls
                                      Halbkanteninstanz Nullkante ist. }
         he1    : phalfedge;        { Zeiger auf erste Halbkante }
         he2    : phalfedge;        { Zeiger auf zweite Halbkante }
         nexte  : pedge;            { Zeiger auf Nachfolger }
         preve  : pedge;            { Zeiger auf Vorg„nger }
       end;
thalfedge = record                    { Halbkante }
               konv   : boolean;      { Marke zur Unterscheidung von konvexen
                                        und konkaven Startknoten der Halbkante }
               neighb : phalfedge;    { zeigt auf den Nachbarn der Halbkante }
               mark   : boolean;      { Markierung eines Nullkantenclusters }
               edg    : pedge;        { Zeiger auf adj. Kante }
               vtx    : pbrvertex;      { Zeiger auf Startknoten der Halbkante }
               wloop  : ploop;        { Zeiger auf adj. Schleife }
               nxt    : phalfedge;    { Zeiger auf Nachfolger }
               prv    : phalfedge;    { Zeiger auf Vorg„nger }
             end;
tbrvertex = record
           mark:boolean;             { Zum Erzeugen eines linearen Modells,
                                       siehe Prozedrur cleanup}
           vertexno : id;            { Knotenbezeichner }
           vedge    : phalfedge;     { Zeiger Halbakante, die den Knoten als
                                       Startknoten besitzt }
           vcoord   : vector;        { 3D-Koordinaten }
           {vcoord2d :vector2d;}       { 2D-Koordinaten, werden in vecop.pas
                                       von project berechnet}
           nextv    : pbrvertex;       { Zeiger auf Nachfolger }
           prevv    : pbrvertex;       { Zeiger auf Vorg„nger }
          end;
tnode = record                       { Varianter Record zur Speicherung
                                       aller Knotentypen }
         case parameters of
          solid:(s:tbrsolid);
          face:(f:tbrface);
          loop:(l:tloop);
          halfedge:(h:thalfedge);
          vertex:(v:tbrvertex);
          edge:(e:tedge);
         end;
(**** Konstanten ****)
const
 { Byteanzahlen der Varianten von tnode }
 nodesize: array[parameters] of integer=(sizeof(tbrsolid),sizeof(tbrface),
                                         sizeof(tloop),sizeof(thalfedge),
                                         sizeof(tedge),sizeof(tbrvertex));
 PI : rtp = 3.141592653589793;
 UNION= 0;
 INTERSECT= 1;
 DIFFERENCE= 2;
 inn =-1;
 outer = 1;
 above =  1;
 iston    =  0;
 below = -1;

(**
    Anforderung und Freigabe von Speicher          +
    Verwaltung der Knoten-, Halbkanten-,
    Kanten-, Berandungs-,Fl„chen- und K”rperlisten +
    Kopieren und L”schen von Instanzen aller elementarer Datenstrukturen
**)
unit alloc;
interface
uses gwb;
(************************************************************)
          (**** DEFINITIONSTEIL ****)
(************************************************************)
type
 orientations = (PLUS,MINUS);   { Orientierung der Halbkanten einer Kante }
function  newnode(what:parameters; wherep:pointer):pnode;
function  copynode(what:parameters;n:pnode):pnode;
procedure del(what:parameters; which, where:pnode);
function  mygetmem(what:parameters): pnode;
function  addhe(e:pedge;v:pvertex; where:phalfedge;sign:orientations):phalfedge;
function  delhe( he:phalfedge):phalfedge;
procedure addlist(what:parameters; which,where:pnode);
procedure dellist(what : parameters;  which, where:pnode);
function  copy_halfedge(h:phalfedge):phalfedge;
function  copy_vertex(v:pvertex):pvertex;
(************************************************************)
          (**** IMPLEMENTATIONSTEIL ****)
(************************************************************)
implementation
uses helpfunc,vecop,memory,geom;
function mygetmem(what:parameters): pnode;
{ Liefert Zeiger auf ein Element der GrӇe
  nodesize[what] x bytes}
var
 i:integer;
 node:pnode;
begin
 getmem(node,nodesize[what]);
 mygetmem:=node;
end;
function newnode(what:parameters; wherep:pointer): pnode;
{ Liefert Zeiger auf ein Element der GrӇe
  nodesize[what] x bytes und h„ngt Element
  je nach Auspr„gung von what in die richtige
  Liste hinter wherep}
var
 i:integer;
 node:pnode;
 where: pnode absolute wherep;
begin
 if MaxAvail < nodesize[what] then
 begin
  mouttext('Not enough memory');
  newnode:=nil;
  exit;
 end;
 getmem(node,nodesize[what]);
 newnode:=node;
 case what of
  solid:begin
         addlist(solid,node,nil);            { neuen K”rper an den Anfang der
                                              K”rperliste einornden }
         node^.s.sfaces:=nil;               { init. des hierarchischen...}
         node^.s.sedges:=nil;
         node^.s.sverts:=nil;               { ... und linearen Modells des
                                              neuen K”rpers }
        end;
  face:begin
        addlist(face,node,where);           { neue fl„che in die Fl„chenliste
                                              des K”rpers where einfgen }
        node^.f.floops:=nil;                { Berandungliste der
                                              Fl„che ist leer}
        node^.f.flout:=nil;
       end;
  loop:addlist(loop,node,where);            { neue Berandung in die Berandungsliste
                                              der Fl„che where einfgen }
  edge:addlist(edge,node,where);            { neue Kante in die Kantenliste
                                              des K”rpers where einfgen }

  vertex:begin
          addlist(vertex,node,where);        { neuen Knoten in die Knotenliste
                                              des K”rpers einfgen }
          node^.v.vedge:=nil;
          node^.v.mark:=false;
         end;
  end;
end;

function addhe(e:pedge;v:pvertex; where:phalfedge;sign:orientations):phalfedge;
{ neue Halbkante vor where in den Halbkantenring einfgen }
var he:phalfedge;
 pn:pointer;
begin
   if where^.edg=nil then
    he:=where
   else
   begin
    he:=phalfedge(newnode(halfedge,nil));
    where^.prv^.nxt:=he;
    he^.prv:=where^.prv;
    where^.prv:=he;
    he^.nxt:=where;
   end;
   he^.edg:=e;
   he^.vtx:=v;
   he^.wloop:=where^.wloop;
   if sign=plus then
    e^.he1:=he
   else e^.he2:=he;
    addhe:=he;
end;

procedure    dellist(what : parameters; which, where:pnode);
{ l”scht das Listenelement which aus der Liste where. which und what sind
  vom typ what }
begin
    case what of
     SOLID: begin
            if(which^.s.prevs<>nil) then
              which^.s.prevs^.nexts := which^.s.nexts;
            if(which^.s.nexts<>nil)then
                which^.s.nexts^.prevs := which^.s.prevs;
            if(psolid(which) = firsts)then
                firsts := firsts^.nexts
           end;

     FACE:  begin
            if(which^.f.prevf<>nil)then
                which^.f.prevf^.nextf := which^.f.nextf;
            if(which^.f.nextf<>nil)then
                which^.f.nextf^.prevf := which^.f.prevf;
            if(pface(which) = where^.s.sfaces)then
                where^.s.sfaces := which^.f.nextf;
           end;
     LOOP:  begin
            if(which^.l.prevl<>nil) then
                which^.l.prevl^.nextl := which^.l.nextl;
            if(which^.l.nextl<>nil)then
                which^.l.nextl^.prevl := which^.l.prevl;
            if(ploop(which) = where^.f.floops)then
                where^.f.floops := which^.l.nextl;
            end;
     EDGE:  begin
            if(which^.e.preve<>nil)then
                which^.e.preve^.nexte := which^.e.nexte;
            if(which^.e.nexte<>nil)then
                which^.e.nexte^.preve := which^.e.preve;
            if(pedge(which) = where^.s.sedges)then
                where^.s.sedges := which^.e.nexte;
            end;
    VERTEX: begin
            if(which^.v.prevv<>nil)then
                which^.v.prevv^.nextv := which^.v.nextv;
            if(which^.v.nextv<>nil)then
                which^.v.nextv^.prevv := which^.v.prevv;
            if(pvertex(which) = where^.s.sverts)then
                where^.s.sverts := which^.v.nextv;
            end;
  end;
end;
(********************)
  (* del *)
(********************)
procedure    del(what:parameters;  which, where:pnode);
{ l”scht which aus  der  Liste where und gibt Speicherplatz frei. what spezifiziert
  typ von which und what }
var e1 :pedge;
begin
    case what of
    SOLID:
          begin
           dellist(SOLID,which,where);
          end;
    FACE: dellist(FACE, which, where);
    LOOP: dellist(LOOP, which, where);
    EDGE: dellist(EDGE, which, where);
    VERTEX: dellist(VERTEX, which, where);
    end;
(*wo*)
     freemem(pnode(which),nodesize[what]);
end;
function  delhe( he:phalfedge):phalfedge;
{ l”scht Halbkante he }
var pn:pnode;
begin
        if(he^.edg = NIL)then
        begin
                pn:=nil;
                del(HALFEDGE, pnode(he),pn);
                delhe:=nil;
                exit;
        end
        else if(he^.nxt = he)then
        begin
                he^.edg := NIL;
                delhe:=he;
                exit;
        end
        else
         begin
          he^.prv^.nxt := he^.nxt;
          he^.nxt^.prv := he^.prv;
          delhe:=he^.prv;
          del(HALFEDGE, pnode(he), NIL);
         end;
end;
procedure addlist(what:parameters; which,where:pnode);
{ fg which in die Liste where ein. Beide sind vom Typ what }
begin
    case what of
    solid:begin            (* set which at the beginning of the list firsts*)
      which^.s.nexts:=firsts;
      which^.s.prevs:=nil;
      if firsts<>nil then
       firsts^.prevs:=psolid(which);
      firsts:=psolid(which);
     end;
    face:begin             (* mount which in the facelist of the solid where *)
      which^.f.nextf:=where^.s.sfaces;
      which^.f.prevf:=nil;
      if where^.s.sfaces<>nil then
       where^.s.sfaces^.prevf:=pface(which);
      where^.s.sfaces:=pface(which);
      which^.f.fsolid:=psolid(where);
     end;
    loop:begin
      which^.l.nextl:=where^.f.floops;
      which^.l.prevl:=nil;
      if where^.f.floops<>nil then
        where^.f.floops^.prevl:=ploop(which);
      where^.f.floops:=ploop(which);
      which^.l.lface:=pface(where);
     end;
    edge:
     begin
      which^.e.nexte:=where^.s.sedges;
      which^.e.preve:=nil;
      if where^.s.sedges<>nil then
       where^.s.sedges^.preve:=pedge(which);
      where^.s.sedges:=pedge(which);
     end;
    vertex:begin
      which^.v.nextv:=where^.s.sverts;
      which^.v.prevv:=nil;
      if where^.s.sverts<>nil then
       where^.s.sverts^.prevv:=pvertex(which);
      where^.s.sverts:=pvertex(which);
     end;

    end;
end;
function copy_vertex(v:pvertex):pvertex;
{kopiert Knoten v}
var
 node:pnode;
 nv:pvertex;
begin
 getmem(node,nodesize[vertex]);
 nv:=pvertex(node);
 nv^.vcoord[0]:=v^.vcoord[0];
 nv^.vcoord[1]:=v^.vcoord[1];
 nv^.vcoord[2]:=v^.vcoord[2];
 nv^.vcoord[3]:=v^.vcoord[3];
 project(nv);
 nv^.vertexno:=-3;
 copy_vertex:=nv;
end;
function copy_halfedge(h:phalfedge):phalfedge;
{kopiert Halbkante h}
var
 node:pnode;
 nh:phalfedge;
begin
 getmem(node,nodesize[halfedge]);
 copy_halfedge:=phalfedge(node);
end;

function copy_sol(s:psolid):psolid;
{kopiert K”rper s}
var
 node:pnode;
 ns:psolid;
begin
 getmem(node,nodesize[solid]);
 ns:=psolid(node);
 ns^.solidno:=s^.solidno;
 copy_sol:= ns;
end;
function copynode(what:parameters;n:pnode):pnode;
{liefert Kopie einer Variante what von tnode}
var
 node:pnode;
begin
 getmem(node,nodesize[what]);
 copynode:=node;
 if node=nil then
 begin
  mouttext('kein Speicher!');
  exit;
 end;
 case what of
  solid: begin
          psolid(node)^.solidno:= psolid(n)^.solidno;
         end;
  face:  begin
          pface(node)^.faceno:=pface(n)^.faceno;
         end;
  loop:  begin
         end;
  edge:  begin
         end;
  vertex:begin
          pvertex(node)^.vertexno:=pvertex(n)^.vertexno;
          pvertex(node)^.vcoord[0]:=pvertex(n)^.vcoord[0];
          pvertex(node)^.vcoord[1]:=pvertex(n)^.vcoord[1];
          pvertex(node)^.vcoord[2]:=pvertex(n)^.vcoord[2];
          pvertex(node)^.vcoord[3]:=pvertex(n)^.vcoord[3];

          pvertex(node)^.vcoord2d[0]:=pvertex(n)^.vcoord2d[0];
          pvertex(node)^.vcoord2d[1]:=pvertex(n)^.vcoord2d[1];
          pvertex(node)^.vcoord2d[2]:=pvertex(n)^.vcoord2d[2];
         end;
  end;
end;
end.

{ Implementierung der Euler-Operatoren:Siehe mäntylae }
unit euler;
(************************************************************)
          (**** DEFINITIONSTEIL ****)
(************************************************************)
interface
uses gwb;

function  lmef(he1,he2:phalfedge;f:id):pface;
procedure lkef(h1, h2: phalfedge);
function  lmev(he1,he2:phalfedge;v:id;x,y,z:rtp):pedge;
procedure lkev(he1, he2:phalfedge);
procedure lmekr(he1, he2:phalfedge);
procedure lkemr( h1, h2:phalfedge);
function  lmfkrh(l:ploop; fn:id):pface;
procedure lkfmrh(f1, f2:pface);
procedure laringmv(f1, f2:pface);

function  mev(s,f1,f2,v1,v2,v3,v4:id;x,y,z:rtp):integer;
function  smev(s,f1,v1,v4:id;x,y,z:rtp):integer;
function  mef(s :psolid; vert1, vert2, fac1, fac2 : id) : integer;
function  smef(s,f1,v1,v3,f2:id):integer;
function  mvfs(s,f,v:id;x,y,z:rtp):psolid;

(************************************************************)
          (**** IMPLEMENTATIONSTEIL ****)
(************************************************************)
implementation
uses alloc,helpfunc,vecop,crt,graph,geom,vis,boolconn;
const
 ERROR      : Integer =  -1;
 SUCCESS    : Integer =  -2;
 

function mvfs(s,f,v:id;x,y,z:rtp):psolid;
{ initialer Euler-Operator }
var
 newsolid:psolid;
 newface:pface;
 newvertex:pvertex;
 newhe:phalfedge;
 newloop:ploop;
begin
 newsolid:=psolid(newnode(solid,nil));
 newface:=pface(newnode(face,newsolid));
 newloop:=ploop(newnode(loop,newface));
 newvertex:=pvertex(newnode(vertex,newsolid));
 newhe:=phalfedge(newnode(halfedge,nil));

 newsolid^.solidno:=s;
 newface^.faceno:=f;
 newface^.flout:=newloop;
 newloop^.ledge:=newhe;
 newhe^.wloop:=newloop;
 newhe^.nxt:=newhe;
 newhe^.prv:=newhe;
 newhe^.vtx:=newvertex;
 newhe^.edg:=nil;
 newvertex^.vertexno:=v;
 newvertex^.vcoord[0]:=x;
 newvertex^.vcoord[1]:=y;
 newvertex^.vcoord[2]:=z;
 newvertex^.vcoord[3]:=1.0;
 project(newvertex);
 mvfs:=newsolid;
end;
 

procedure lkfmrh(f1, f2:pface);
var
    l,l1,l2,nextl :ploop;
begin
    l1:=f2^.floops;
    while(l1 <>nil)do
     begin
        nextl:=l1^.nextl;
        dellist(LOOP, pnode(l1), pnode(f2));
        addlist(LOOP, pnode(l1), pnode(f1));
        l1:=nextl;
     end;
    del(FACE, pnode(f2), pnode(f2^.fsolid));
end;
function lmfkrh(l:ploop; fn:id):pface;
var
    nf:pnode;
begin
    nf := newnode(FACE, l^.lface^.fsolid);
    nf^.f.faceno := fn;
    nf^.f.flout := l;
    dellist(LOOP, pnode(l), pnode(l^.lface));
    addlist(LOOP, pnode(l), pnode(nf));
    lmfkrh:=@(nf^.f);
end;

function mev(s,f1,f2,v1,v2,v3,v4:id;x,y,z:rtp):integer;
{ Einfügen eines Knotens und einer Kante }
var oldsolid:psolid;
 oldface1,oldface2:pface;
 he1,he2:phalfedge;
begin
  mev:=error;
  oldsolid := getsol(s);
  if oldsolid=nil then
  begin
   writeln('mev: solid ',s,' not found');
   exit;
  end;
  oldface1:=fface(oldsolid,f1);
  if oldface1=nil then
  begin
   writeln('mev: face ',f1,' not found in solid ',s);
   exit;
  end;
  oldface2:=fface(oldsolid,f2);
  if oldface2=nil then
  begin
   writeln('mev: face ',f2,' not found in solid ',s);
   exit;
  end;
  he1:=fhe(oldface1,v1,v2);
  if he1=nil then
  begin
   writeln('mev: edge ',v1,'<>',v2,' not found in face ',f1);
   exit;
  end;
  he2:=fhe(oldface2,v1,v3);
  if he2=nil then
  begin
   writeln('mev: edge ',v1,'<>',v3,' not found in face ',f2);
   exit;
  end;
  lmev(he1,he2,v4,x,y,z);
  mev:=success;
end;

function smev(s,f1,v1,v4:id;x,y,z:rtp):integer;
var v2:id;
 oldsolid:psolid;
 oldface:pface;
 he1:phalfedge;
begin
  smev:=error;
  oldsolid:=getsol(s);
  if oldsolid=nil then
  begin
   writeln('smev: solid ',s,' not found');
   exit;
  end;
  oldface:=fface(oldsolid,f1);
  if oldface=nil then
  begin
   writeln('smev: face ',f1,' not found in solid ',s);
   exit;
  end;
  he1:=fhe1(oldface,v1);  (* get halfedge beginning with v1*)
  if he1=nil then begin
   writeln('Smev: vertex ',v1,' not found in face ',f1);
   exit;
  end;
  v2:=he1^.prv^.vtx^.vertexno;
  smev:=mev(s,f1,f1,v1,v2,v2,v4,x,y,z);
end;

function lmev(he1,he2:phalfedge;v:id;x,y,z:rtp):pedge;
var
 he:phalfedge;
 newvertex:pvertex;
 newedge:pedge;
begin
    newedge:=pedge(newnode(edge,he1^.wloop^.lface^.fsolid));
    newvertex:=pvertex(newnode(vertex,he1^.wloop^.lface^.fsolid));
    newvertex^.vcoord[0]:=x;
    newvertex^.vcoord[1]:=y;
    newvertex^.vcoord[2]:=z;
    newvertex^.vcoord[3]:=1.0;
    project(newvertex);
    newvertex^.vertexno:=v;
    he:=he1;
    while he<>he2 do
    begin
      he^.vtx:=newvertex;
      he:=mate(he)^.nxt;
      if he=he1 then
      begin
       mouttext('lmev:he=he1,weiter mit return');
       drawhe1(he1);
       highlight(he1^.wloop^.lface,lightblue);
       highlight(he2^.wloop^.lface,lightred);
       he:=he1;
       while he<>he2 do
       begin
         drawhe1(he);
         highlight(he1^.wloop^.lface,lightblue);
         he:=mate(he)^.nxt;
       end;
      end;
    end;
    addhe(newedge, he2^.vtx,he1,MINUS);
    addhe(newedge,newvertex,he2,PLUS);
    newvertex^.vedge := he2^.prv;
    he2^.vtx^.vedge := he2;
    lmev:=newedge;
end;

function lmef(he1,he2:phalfedge;f:id):pface;
var
 newface,oldface:pface;
 newloop:ploop;
 newedge:pedge;
 he,nhe1,nhe2,temp:phalfedge;
begin
    oldface:=he1^.wloop^.lface;
    newface:=pface(newnode(face,he1^.wloop^.lface^.fsolid));
    newloop:=ploop(newnode(loop,newface));
    newedge:=pedge(newnode(edge,he1^.wloop^.lface^.fsolid));
    newface^.faceno:=f;
    newface^.flout:=newloop;
    he:=he1;
    while he<>he2 do begin
     he^.wloop:=newloop;        (*hier bekommt he1 seine neue Fläche*)
     he:=he^.nxt;
    end;
    nhe1:=addhe(newedge,he2^.vtx,he1,minus);
    nhe2:=addhe(newedge,he1^.vtx,he2,plus);
    nhe1^.prv^.nxt:=nhe2;
    nhe2^.prv^.nxt:=nhe1;
    temp:=nhe1^.prv;
    nhe1^.prv:=nhe2^.prv;
    nhe2^.prv:=temp;
    newloop^.ledge:=nhe1;
    he2^.wloop^.ledge:=nhe2;
    lmef:=newface;
    newface^.mark:= oldface^.mark;
end;

function mef(s :psolid; vert1, vert2, fac1, fac2 : id) : integer;
var
    oldface, newface : pface;
    he1,he2 : phalfedge;
begin
    oldface := fface(s, fac1);
    if oldface = nil then
    begin
         writeln('mef: face ', fac1 ,'not found');
         mef := error;
    end;
    (* get vert1 *)
    he1 := fhe1(oldface, vert1);
    if(he1 = nil)then
    begin
        writeln('mef: vertex', vert1, 'not found');
        mef := error;
    end;

    (* get the next occurance of vert2 *)
    he2 := he1;
    if(he2^.vtx^.vertexno <> vert2)then
     repeat
        he2 := he2^.nxt;
        if(he2 = he1)then
         begin
          writeln('mef: vertex ',vert2,'not found');
          mef := ERROR;
         end;
     until(he2^.vtx^.vertexno = vert2);

    newface := lmef(he1, he2, fac2);

    mef := SUCCESS;
end;
 

function smef(s,f1,v1,v3,f2:id):integer;
var
 oldsolid:psolid;
 oldface,newface:pface;
 he1,he3,test:phalfedge;
begin
  smef:=error;
  oldsolid:=getsol(s);
  if oldsolid=nil then begin
   writeln('smev: solid ',s,' not found');exit;
  end;
  oldface:=fface(oldsolid,f1);
  if oldface=nil then begin
   writeln('smev: face ',f1,' not found in solid ',s);exit;
  end;
  he1:=fhe1(oldface,v1);
  if he1=nil then begin
   writeln('mev: vertex ',v1,' not found in face ',f1);exit;
  end;
  he3:=fhe1(oldface,v3);
  if he3=nil then begin
   writeln('mev: vertex ',v3,' not found in face ',f1);exit;
  end;
  newface:=lmef(he1,he3,f1);
  newface^.faceno:=f2;
  smef:=success;
end;
procedure    laringmv(f1, f2:pface);
{ innere Berandungen von f1 die innerhalb
  von f2 liegen werden f2 zugeordnet. Diese Untersuchung
  ist nach Erzeugung einer neuen Fläche mit mef nötig}
var
  tmp:vector;
  drop,int:integer;
  ring,l:ploop;
  test:tvertex;
  v1,v2:pvertex;
  run,start:phalfedge;
  label nextloop;
begin
    drop := dropvector(f1^.feq);
    l := f1^.floops;
    while(l<>nil)do
     begin
        ring:=l;
        if(ring  <> f1^.flout)then
        begin
            l:=l^.nextl;
            v1:=ring^.ledge^.vtx;
            v2:=ring^.ledge^.nxt^.vtx;
            test.vcoord[0]:=(v1^.vcoord[0]+v2^.vcoord[0])/2.0;
            test.vcoord[1]:=(v1^.vcoord[1]+v2^.vcoord[1])/2.0;
            test.vcoord[2]:=(v1^.vcoord[2]+v2^.vcoord[2])/2.0;
            test.vcoord[3]:=1;
            project(@test);
            int := contfv2(f2, @test, drop);
            if(int=1)then
            begin
            { innere Berandung von f1 liegt in f2=>Berandung f2 zuordnen }
                dellist(LOOP, pnode(ring), pnode(f1));
                addlist(LOOP, pnode(ring), pnode(f2));
            end else if (int>1) and not(strutedgeinn(ring^.ledge)) then
            begin
             { Testpunkt liegt auf der Berandung von f2 => betrachte restliche
               Kanten der Berandung }
             start:=ring^.ledge;
             run:=start^.nxt;
             repeat              { Durchlaufe Halbkantenliste der Berandung }
              v1:=run^.vtx;
              v2:=run^.nxt^.vtx;
              test.vcoord[0]:=(v1^.vcoord[0]+v2^.vcoord[0])/2.0;
              test.vcoord[1]:=(v1^.vcoord[1]+v2^.vcoord[1])/2.0;
              test.vcoord[2]:=(v1^.vcoord[2]+v2^.vcoord[2])/2.0;
              test.vcoord[3]:=1;
              project(@test);
              int := contfv2(f2, @test, drop);
              if(int>1)then
              begin
               { Testpunkt liegt wieder auf Berandung }
               run:=run^.nxt;
              end else if int=1 then    { sonst Behandlung wie oben }
              begin
                dellist(LOOP, pnode(ring), pnode(f1));
                addlist(LOOP, pnode(ring), pnode(f2));
                goto nextloop;      { nächste Schleife }
              end else if int=0 then
              begin
               run:=start;
              end;
             until run = start;
             drop:=dropvector(f1^.feq);
             if (run=start) and
                (ring <> ring^.lface^.flout) and
                (contlv(ring^.lface^.flout,ring^.ledge^.vtx,drop)=0) then
              { ring ist deckungsgleich zu einer Berandung von f2 und
                ring liegt nicht in der äußeren Berandung von f1 }
              lmfkrh(ring,-1);   { => innere Berandung ist Berandung einer
                                      neuen Fläche }
             end;
nextloop:
        end else
        l := l^.nextl;
     end;
end;

procedure lkef(h1, h2: phalfedge);
{ löscht Kante und Fläche adjazent zur Halbkante h2 }
var
    f1,f2,killface:pface;
    l,l1,l2,l3,l4,killoop: ploop;
    he :phalfedge;
    edgep,killedge:pedge;
    ap,s:psolid;
    ring:ploop;
    checkl:boolean;
begin
    if (not((h1^.edg=h2^.edg)and(h1^.wloop^.lface<>h2^.wloop^.lface)))then
    begin
        exit;
    end;
    if (not((h1^.vtx=h2^.nxt^.vtx)or not(h2^.vtx=h1^.nxt^.vtx)))then
    begin
        mouttext('bug in lkef');
        drawhe1(h1);
        drawhe1(h2);
    end;
    killedge:=h2^.edg;
    s := h1^.wloop^.lface^.fsolid;
    l1 := h1^.wloop;
    f1 := l1^.lface;
    l2 := h2^.wloop;
    f2 := l2^.lface;

    l3:=f2^.floops;
    while(l3 <> nil)do
     begin
        ring:=l3;
        l3:=l3^.nextl;
        dellist(LOOP, pnode(ring), pnode(f2));
        addlist(LOOP, pnode(ring), pnode(f1));
     end;

    he := l2^.ledge;
    repeat
        he^.wloop := l1;
        he := he^.nxt;
    until(he = l2^.ledge);

    h1^.prv^.nxt := h2;
    h2^.prv^.nxt := h1;
    he := h2^.prv;
    h2^.prv := h1^.prv;
    h1^.prv := he;
    h2:=delhe(h2);
    h1:=delhe(h1);
    h1^.wloop^.ledge:=h1;
    h2^.wloop^.ledge:=h2;
    h2^.nxt^.vtx^.vedge:=h2^.nxt;
    if h2^.nxt^.vtx^.vedge^.edg=nil then
     h2^.nxt^.vtx^.vedge:=nil;

    h1^.nxt^.vtx^.vedge:=h1^.nxt;
    if h1^.nxt^.vtx^.vedge^.edg=nil then
     h1^.nxt^.vtx^.vedge:=nil;

    if(h1^.nxt^.vtx^.vedge=nil)or
      (h2^.nxt^.vtx^.vedge=nil) then
      mouttext('lkef:nil');

    del(FACE, pnode(f2), pnode(f1^.fsolid));
    del(LOOP, pnode(l2), pnode(f1));
    del(EDGE, pnode(killedge), pnode(f1^.fsolid));
end;

procedure     lmekr(he1, he2:phalfedge);
{ erzeugt Kante löscht ring }
var
    n_ed:pedge;
    n_he1,n_he2:phalfedge;
    f:pface;
    l1,l2:ploop;
begin
    l1 := he1^.wloop;
    l2 := he2^.wloop;      {l2 wird gelöscht}
    f := l1^.lface;

    n_he1 := l2^.ledge;
    (*alle halbkanten vonm ring adj. zu h2 werden in
    die schleife von h1 eingefügt*)
    repeat
        n_he1^.wloop := l1;
        n_he1 :=n_he1^.nxt;
    until(n_he1 = l2^.ledge);

    n_ed := pedge(newnode(EDGE, f^.fsolid));
    (*neue halbkante an das End von he1 und he2 hängen*)
    n_he1 := addhe(n_ed, he1^.vtx, he1, Plus);
    n_he2 := addhe(n_ed, he2^.vtx, he2, minus);
    n_he1^.nxt := he2;
    n_he2^.nxt := he1;
    he2^.prv := n_he1;
    he1^.prv := n_he2;

    if(f^.flout = l2) then
     f^.flout := l1;
    del(LOOP, pnode(l2), pnode(l2^.lface));
end;
procedure  lkemr(h1, h2:phalfedge);
{ löscht Kante erzeugt ring }
var
    h3,h4:phalfedge;
    ol:ploop;
    killedge:pedge;
    nl:pnode;
    killsolid:psolid;
begin
    ol := h1^.wloop;
    nl := newnode(LOOP, ol^.lface);
    killedge := h1^.edg;
    killsolid:= ol^.lface^.fsolid;
    h3 := h1^.nxt;
    h1^.nxt := h2^.nxt;
    h2^.nxt^.prv := h1;
    h2^.nxt := h3;
    h3^.prv := h2;

    h4 := h2;
    repeat
        h4^.wloop := @nl^.l;
        h4 := h4^.nxt;
    until (h4 = h2);
    h1:= delhe(h1);
    ol^.ledge :=h1;
    h3:=ol^.ledge;
    h2:= delhe(h2);
    nl^.l.ledge:=h2;
    h4:=nl^.l.ledge;
    if h3^.edg<>nil then
    begin
      h3^.vtx^.vedge := h3;
    end else
      h3^.vtx^.vedge:= NIL;
    if h4^.edg<>nil then begin
      h4^.vtx^.vedge:=h4;
    end else
      h4^.vtx^.vedge:=nil;
    if h3^.nxt^.edg<>nil then begin
      h3^.nxt^.vtx^.vedge := h3^.nxt;
    end else
      h3^.nxt^.vtx^.vedge:= NIL;
    if h4^.nxt^.edg<>nil then begin
      h4^.nxt^.vtx^.vedge:=h4^.nxt;
    end else
      h4^.nxt^.vtx^.vedge:=nil;
    del(EDGE, pnode(killedge), pnode(killsolid));
end;
procedure  lkev2(he1, he2:phalfedge);
{ löscht Kante und Knoten, wobei he1^.vtx=he2^.vtx }
var
 e1,edgep:pedge;
 newvertex,vtxp,v1,v2:pvertex;
 z:integer;
 he,he1p,hedgep:phalfedge;
 facep:pface;
 solidp:psolid;
begin
    v1:=he1^.vtx;
    v2:=he2^.vtx;
    hedgep:=he1;
    facep:=he1^.wloop^.lface;
    solidp:=he1^.wloop^.lface^.fsolid;
    edgep:=he1^.edg;
    vtxp:=he1^.vtx;
    he := he2^.nxt;
    while((he <> he1)) do
    begin
        he^.vtx := he2^.vtx;
        he := mate(he)^.nxt;
    end;
    newvertex:=pvertex(newnode(vertex,he1^.wloop^.lface^.fsolid));
    newvertex^.vcoord[0]:=he2^.vtx^.vcoord[0];
    newvertex^.vcoord[1]:=he2^.vtx^.vcoord[1];
    newvertex^.vcoord[2]:=he2^.vtx^.vcoord[2];
    newvertex^.vcoord[3]:=1.0;
    project(newvertex);
    newvertex^.vertexno:=-1;
    he:=he2;
    while he<>he1 do
    begin
     he^.vtx:=newvertex;
     he:=mate(he)^.nxt;
    end;
    he1:= delhe(he1);
    if(he1^.nxt=he2) then
    begin
     he2^.vtx^.vedge:=he1^.nxt^.nxt;
    end else
     he2^.vtx^.vedge:=he1^.nxt;
    if he1=he2 then
    begin
     he1:=he1^.prv;
    end;
    he2:= delhe(he2);

    he1^.wloop^.ledge:=he1;
    he2^.wloop^.ledge:=he2;

    if(he2^.nxt^.vtx^.vedge^.edg=nil)then
     he2^.nxt^.vtx^.vedge := phalfedge(nil);
    del(EDGE, pnode(edgep), pnode(solidp));
end;
procedure  lkev(he1, he2:phalfedge);
{ löscht Kante und Knoten }
var
 e1,edgep:pedge;
 vtxp,v1,v2:pvertex;
 z:integer;
 he,he1p,hedgep:phalfedge;
 facep:pface;
 solidp:psolid;
begin
    v1:=he1^.vtx;
    v2:=he2^.vtx;
    if v1=v2 then
    begin
     lkev2(he1,he2);
     exit;
    end;
    hedgep:=he1;
    facep:=he1^.wloop^.lface;
    solidp:=he1^.wloop^.lface^.fsolid;
    edgep:=he1^.edg;
    vtxp:=he1^.vtx;
    he := he2^.nxt;
    while((he <> he1)) do
    begin
        he^.vtx := he2^.vtx;

        he := mate(he)^.nxt;
    end;
    he1:= delhe(he1);
    if(he1^.nxt=he2) then
    begin
     he2^.vtx^.vedge:=he1^.nxt^.nxt;
    end else
     he2^.vtx^.vedge:=he1^.nxt;
    if he1=he2 then
    begin
     he1:=he1^.prv;
    end;
    he2:= delhe(he2);

    he1^.wloop^.ledge:=he1;
    he2^.wloop^.ledge:=he2;

    if(he2^.nxt^.vtx^.vedge^.edg=nil)then
     he2^.nxt^.vtx^.vedge := phalfedge(nil);
    del(EDGE, pnode(edgep), pnode(solidp));
    del(vertex, pnode(vtxp), pnode(solidp));
end;
end.