File: [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Stalift / floating_lifting_utilities.adb (download)
Revision 1.1.1.1 (vendor branch), Sun Oct 29 17:45:29 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.
|
package body Floating_Lifting_Utilities is
function Adaptive_Lifting ( l : Array_of_Lists ) return Vector is
res : Vector(l'range);
fac : constant double_float := 3.0; -- multiplication factor
max : constant double_float := 23.0; -- upper bound for lifting
begin
for i in l'range loop
res(i) := fac*double_float(Length_Of(l(i)));
if res(i) > max
then res(i) := max;
end if;
end loop;
return res;
end Adaptive_Lifting;
procedure Search_Lifting ( l : in List; pt : in Vector;
found : out boolean; lif : out double_float ) is
tmp : List := l;
lpt : Link_to_Vector;
begin
found := false;
while not Is_Null(tmp) loop
lpt := Head_Of(tmp);
if Equal(lpt(pt'range),pt)
then found := true;
lif := lpt(lpt'last);
exit;
else tmp := Tail_Of(tmp);
end if;
end loop;
end Search_Lifting;
function Search_and_Lift ( l : List; pt : Vector ) return Vector is
tmp : List := l;
lpt : Link_to_Vector;
begin
while not Is_Null(tmp) loop
lpt := Head_Of(tmp);
if Equal(lpt(pt'range),pt)
then return lpt.all;
else tmp := Tail_Of(tmp);
end if;
end loop;
return pt;
end Search_and_Lift;
function Search_and_Lift ( mic : Mixed_Cell; k : natural; pt : Vector )
return Vector is
begin
return Search_and_Lift(mic.pts(k),pt);
end Search_and_Lift;
function Occured_Lifting ( mixsub : Mixed_Subdivision; k : natural;
pt : Vector ) return Vector is
tmp : Mixed_Subdivision := mixsub;
begin
while not Is_Null(tmp) loop
declare
lpt : constant Vector := Search_and_Lift(Head_Of(tmp),k,pt);
begin
if lpt'last > pt'last
then return lpt;
else tmp := Tail_Of(tmp);
end if;
end;
end loop;
return pt;
end Occured_Lifting;
function Occured_Lifting
( n : natural; mix : Standard_Integer_Vectors.Vector;
points : Array_of_Lists; mixsub : Mixed_Subdivision )
return Array_of_Lists is
res,res_last : Array_of_Lists(mix'range);
cnt : natural := 1;
tmp : List;
begin
for k in mix'range loop
res_last(k) := res(k);
tmp := points(cnt);
while not Is_Null(tmp) loop
declare
pt : Link_to_Vector := Head_Of(tmp);
lpt : constant Vector := Occured_Lifting(mixsub,k,pt.all);
begin
if lpt'last > pt'last
then Append(res(k),res_last(k),lpt);
end if;
end;
tmp := Tail_Of(tmp);
end loop;
cnt := cnt + mix(k);
end loop;
return res;
end Occured_Lifting;
function Induced_Lifting ( mixsub : Mixed_Subdivision; k : natural;
pt : Vector ) return Vector is
tmp : Mixed_Subdivision := mixsub;
res : Vector(pt'first..pt'last+1);
begin
while not Is_Null(tmp) loop
declare
mic : Mixed_Cell := Head_Of(tmp);
lpt : constant Vector := Search_and_Lift(mic,k,pt);
begin
if lpt'length = pt'length+1
then return lpt;
else tmp := Tail_Of(tmp);
end if;
end;
end loop;
res(pt'range) := pt;
res(res'last) := 1.0;
res(res'last) := Conservative_Lifting(mixsub,k,res);
return res;
end Induced_Lifting;
function Induced_Lifting
( n : natural; mix : Standard_Integer_Vectors.Vector;
points : Array_of_Lists; mixsub : Mixed_Subdivision )
return Array_of_Lists is
res,res_last : Array_of_Lists(mix'range);
cnt : natural := 1;
tmp : List;
begin
for k in mix'range loop
res_last(k) := res(k);
tmp := points(cnt);
while not Is_Null(tmp) loop
declare
pt : Link_to_Vector := Head_Of(tmp);
lpt : constant Vector := Induced_Lifting(mixsub,k,pt.all);
begin
Append(res(k),res_last(k),lpt);
end;
tmp := Tail_Of(tmp);
end loop;
cnt := cnt + mix(k);
end loop;
return res;
end Induced_Lifting;
function Conservative_Lifting
( mic : Mixed_Cell; k : natural; point : Vector )
return double_float is
sp : double_float := mic.nor*Head_Of(mic.pts(k));
spp : double_float:= mic.nor.all*point;
res : double_float;
begin
if sp < spp
then return point(point'last);
else if mic.nor(mic.nor'last) = 0.0
then res := point(point'last);
else spp := spp - point(point'last)*mic.nor(mic.nor'last);
res := (sp - spp)/mic.nor(mic.nor'last) + 1.0;
end if;
return res;
end if;
end Conservative_Lifting;
function Conservative_Lifting ( mixsub : Mixed_Subdivision; k : natural;
point : Vector ) return double_float is
tmp : Mixed_Subdivision := mixsub;
pt : Vector(point'range) := point;
res : double_float;
begin
while not Is_Null(tmp) loop
pt(pt'last) := Conservative_Lifting(Head_Of(tmp),k,pt);
tmp := Tail_Of(tmp);
end loop;
res := pt(pt'last);
Clear(pt);
return res;
end Conservative_Lifting;
end Floating_Lifting_Utilities;