File: [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Dynlift / unfolding_subdivisions.adb (download)
Revision 1.1.1.1 (vendor branch), Sun Oct 29 17:45:28 2000 UTC (23 years, 10 months ago) by maekawa
Branch: PHC, MAIN
CVS Tags: v2, maekawa-ipv6, RELEASE_1_2_3, RELEASE_1_2_2_KNOPPIX_b, RELEASE_1_2_2_KNOPPIX, RELEASE_1_2_2, RELEASE_1_2_1, HEAD Changes since 1.1: +0 -0
lines
Import the second public release of PHCpack.
OKed by Jan Verschelde.
|
with Integer_Support_Functions; use Integer_Support_Functions;
with Flatten_Mixed_Subdivisions; use Flatten_Mixed_Subdivisions;
package body Unfolding_Subdivisions is
function Different_Normals ( mixsub : Mixed_Subdivision ) return List is
tmp : Mixed_Subdivision := mixsub;
res,res_last : List;
begin
while not Is_Null(tmp) loop
Append_Diff(res,res_last,Head_Of(tmp).nor.all);
tmp := Tail_Of(tmp);
end loop;
return res;
end Different_Normals;
function Extract ( normal : Vector; mixsub : Mixed_Subdivision )
return Mixed_Subdivision is
tmp : Mixed_Subdivision := mixsub;
res,res_last : Mixed_Subdivision;
begin
while not Is_Null(tmp) loop
declare
mic : Mixed_Cell := Head_Of(tmp);
begin
if mic.nor.all = normal
then Append(res,res_last,mic);
end if;
end;
tmp := Tail_Of(tmp);
end loop;
return res;
end Extract;
function Merge_Same_Normal ( mixsub : Mixed_Subdivision )
return Mixed_Cell is
-- DESCRIPTION :
-- All cells with the same inner normal will be put in one cell,
-- that will be contained in the mixed subdivision on return.
-- REQUIRED :
-- not Is_Null(mixsub) and all mixed cells have the same inner normal.
tmp : Mixed_Subdivision;
resmic,mic : Mixed_Cell;
begin
mic := Head_Of(mixsub);
resmic.nor := new Standard_Integer_Vectors.Vector'(mic.nor.all);
resmic.pts := new Array_of_Lists'(mic.pts.all);
tmp := Tail_Of(mixsub);
while not Is_Null(tmp) loop
mic := Head_Of(tmp);
declare
last : List;
begin
for k in mic.pts'range loop
last := resmic.pts(k);
while not Is_Null(Tail_Of(last)) loop
last := Tail_Of(last);
end loop;
Deep_Concat_Diff(resmic.pts(k),last,mic.pts(k));
end loop;
end;
tmp := Tail_Of(tmp);
end loop;
return resmic;
end Merge_Same_Normal;
function Merge_Same_Normal ( mixsub : Mixed_Subdivision )
return Mixed_Subdivision is
-- REQUIRED :
-- not Is_Null(mixsub) and all mixed cells have the same inner normal.
resmic : Mixed_Cell := Merge_Same_Normal(mixsub);
ressub : Mixed_Subdivision;
begin
Construct(resmic,ressub);
return ressub;
end Merge_Same_Normal;
function Merge ( mixsub : Mixed_Subdivision ) return Mixed_Subdivision is
-- NOTE :
-- Cells with an unique normal are simply taken over in the result,
-- cells with the same normal are merged, hereby the refinement of these
-- cells is destroyed. Though, one could do better...
begin
if Is_Null(mixsub)
then return mixsub;
else
declare
tmp : Mixed_Subdivision := mixsub;
res,res_last : Mixed_Subdivision;
mic : Mixed_Cell;
begin
while not Is_Null(tmp) loop
mic := Head_Of(tmp);
if not Is_In(res,mic.nor.all)
then
if not Is_In(Tail_Of(tmp),mic.nor.all)
then Append(res,res_last,mic);
else declare
tmpmic : Mixed_Subdivision := Extract(mic.nor.all,tmp);
bigmic : Mixed_Cell := Merge_Same_Normal(tmpmic);
begin
Append(res,res_last,bigmic);
end;
end if;
end if;
tmp := Tail_Of(tmp);
end loop;
return res;
end;
end if;
end Merge;
function Relift ( l : List; point : Vector ) return List is
tmp,res : List;
pt : Link_to_Vector;
begin
Copy(l,res);
tmp := res;
while not Is_Null(tmp) loop
pt := Head_Of(tmp);
if pt.all = point
then pt(pt'last) := 1;
else pt(pt'last) := 0;
end if;
Set_Head(tmp,pt);
tmp := Tail_Of(tmp);
end loop;
return res;
end Relift;
function Relift ( pts : Array_of_Lists; point : Vector )
return Array_of_Lists is
res : Array_of_Lists(pts'range);
begin
for i in pts'range loop
res(i) := Relift(pts(i),point);
end loop;
return res;
end Relift;
function Relift ( mic : Mixed_Cell; point : Vector ) return Mixed_Cell is
res : Mixed_Cell;
begin
res.pts := new Array_of_Lists'(Relift(mic.pts.all,point));
res.nor := new Standard_Integer_Vectors.Vector'(point'range => 0);
Compute_Inner_Normal(res);
return res;
end Relift;
function Relift ( mixsub : Mixed_Subdivision; point : Vector )
return Mixed_Subdivision is
tmp,res,res_last : Mixed_Subdivision;
begin
tmp := mixsub;
while not Is_Null(tmp) loop
Append(res,res_last,Relift(Head_Of(tmp),point));
tmp := Tail_Of(tmp);
end loop;
return res;
end Relift;
function Is_In_Point ( pt : Link_to_Vector; l : List ) return boolean is
-- DESCRIPTION :
-- Returns true if the first n coordinates of pt belong to l.
tmp : List := l;
lpt : Link_to_Vector;
begin
while not Is_Null(tmp) loop
lpt := Head_Of(tmp);
if lpt(lpt'first..lpt'last-1) = pt(pt'first..pt'last-1)
then return true;
else tmp := Tail_Of(tmp);
end if;
end loop;
return false;
end Is_In_Point;
function Different_Points ( l1,l2 : List ) return natural is
-- DESCRIPTION :
-- Return the number of different points of the list l2 w.r.t. l1.
res : natural := 0;
tmp : List := l2;
begin
while not Is_Null(tmp) loop
if not Is_In_Point(Head_Of(tmp),l1)
then res := res + 1;
end if;
tmp := Tail_Of(tmp);
end loop;
return res;
end Different_Points;
function Different_Points ( l1,l2 : List ) return List is
-- DESCRIPTION :
-- Return the list of different points of the list l2 w.r.t. l1.
res,res_last : List;
tmp : List := l2;
begin
while not Is_Null(tmp) loop
if not Is_In_Point(Head_Of(tmp),l1)
then Append(res,res_last,Head_Of(tmp).all);
end if;
tmp := Tail_Of(tmp);
end loop;
return res;
end Different_Points;
function Different_Points ( pts : Array_of_Lists; mic : Mixed_Cell )
return natural is
-- DESCRIPTION :
-- Return the number of different points of the cell mic w.r.t. pts.
res : natural := 0;
begin
for i in pts'range loop
res := res + Different_Points(pts(i),mic.pts(i));
end loop;
return res;
end Different_Points;
function Different_Points ( pts : Array_of_Lists; mic : Mixed_Cell )
return Array_of_Lists is
-- DESCRIPTION :
-- Return the different points of the cell mic w.r.t. pts.
res : Array_of_Lists(pts'range);
begin
for i in pts'range loop
res(i) := Different_Points(pts(i),mic.pts(i));
end loop;
return res;
end Different_Points;
procedure Add ( l : in out List; pts : in List ) is
-- DESCRIPTION :
-- Adds the points in pts to l.
tmp : List := pts;
pt : Link_to_Vector;
begin
while not Is_Null(tmp) loop
pt := Head_Of(tmp);
declare
npt : Link_to_Vector := new Vector'(pt.all);
begin
Construct(npt,l);
end;
tmp := Tail_Of(tmp);
end loop;
end Add;
procedure Add ( l : in out Array_of_Lists; pts : in Array_of_Lists ) is
-- DESCRIPTION :
-- Adds the points in pts to l.
begin
for i in l'range loop
Add(l(i),pts(i));
end loop;
end Add;
procedure Put_Next_to_Front ( mixsub : in out Mixed_Subdivision;
pts : in Array_of_Lists ) is
-- DESCRIPTION :
-- Selects the next mixed cell to be processed, and puts in front
-- of the list of cells mixsub.
mic1 : Mixed_Cell := Head_Of(mixsub);
min1 : natural := Different_Points(pts,mic1);
tmp : Mixed_Subdivision := Tail_Of(mixsub);
min : natural;
mic : Mixed_Cell;
begin
while not Is_Null(tmp) loop
mic := Head_Of(tmp);
min := Different_Points(pts,mic);
if min < min1
then min1 := min;
Set_Head(mixsub,mic);
Set_Head(tmp,mic1);
end if;
tmp := Tail_Of(tmp);
end loop;
end Put_Next_to_Front;
procedure Relift ( l : in out List; ref : in List ) is
-- DESCRIPTION :
-- Gives all points in l, which belong to ref, lifting value 1.
tmp : List := l;
pt : Link_to_Vector;
begin
while not Is_Null(tmp) loop
pt := Head_Of(tmp);
if Is_In(ref,pt)
then pt(pt'last) := 1;
else pt(pt'last) := 0;
end if;
Set_Head(tmp,pt);
tmp := Tail_Of(tmp);
end loop;
end Relift;
procedure Relift ( l : in out List ) is
-- DESCRIPTION :
-- Gives all points lifting value 1.
tmp : List := l;
pt : Link_to_Vector;
begin
while not Is_Null(tmp) loop
pt := Head_Of(tmp);
pt(pt'last) := 1;
Set_Head(tmp,pt);
tmp := Tail_Of(tmp);
end loop;
end Relift;
procedure Relift ( l : in out Array_of_Lists; ref : in Array_of_Lists ) is
-- DESCRIPTION :
-- Gives all points in l, which belong to ref, lifting value 1.
begin
for i in l'range loop
Relift(l(i),ref(i));
end loop;
end Relift;
procedure Relift ( l : in out Array_of_Lists ) is
-- DESCRIPTION :
-- Gives all points lifting value 1.
begin
for i in l'range loop
Relift(l(i));
end loop;
end Relift;
procedure Relift ( mic : in out Mixed_Cell; pts : in out Array_of_Lists ) is
-- DESCRIPTION :
-- Gives the points in mic, which belong to pts lifting 1,
-- and computes the new inner normal.
begin
Relift(mic.pts.all,pts);
Relift(pts);
end Relift;
procedure Orientate_Inner_Normal
( mic : in out Mixed_Cell; pts : in Array_of_Lists ) is
-- DESCRIPTION :
-- Orientates the normal of mic w.r.t. the points in pts.
done : boolean := false;
begin
for i in pts'range loop
if Minimal_Support(mic.pts(i),mic.nor.all)
> Minimal_Support(pts(i),mic.nor.all)
then Min(mic.nor);
done := true;
end if;
exit when done;
end loop;
end Orientate_Inner_Normal;
procedure Unfolding ( mixsub : in out Mixed_Subdivision ) is
tmp : Mixed_Subdivision;
begin
if not Is_Null(mixsub)
then
declare
mic : Mixed_Cell := Head_Of(mixsub);
pts : Array_of_Lists(mic.pts'range);
begin
Flatten(mic);
Copy(mic.pts.all,pts);
Process(mic,pts);
tmp := Tail_Of(mixsub);
while not Is_Null(tmp) loop
Put_Next_to_Front(tmp,pts);
mic := Head_Of(tmp);
declare
newpts : Array_of_Lists(pts'range);
begin
newpts := Different_Points(pts,mic);
Relift(mic,newpts);
Compute_Inner_Normal(mic);
-- Orientate_Inner_Normal(mic,pts);
Process(mic,newpts);
Add(pts,newpts);
Deep_Clear(newpts);
end;
tmp := Tail_Of(tmp);
end loop;
end;
end if;
end Unfolding;
end Unfolding_Subdivisions;