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 Rckseiten (BackSide) }
bbox:tbox;
{ boundary-box des K”rpers }
mark:boolean;
{ Markierung von sich selbstberhrenden
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 einfgen }
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 einfgen }
edge:addlist(edge,node,where);
{ neue Kante in die Kantenliste
des K”rpers where einfgen }
vertex:begin
addlist(vertex,node,where);
{ neuen Knoten in die Knotenliste
des K”rpers einfgen }
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 einfgen }
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);
{ fg 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.