![]() ![]() | ![]() |
File: [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Dynlift / dynamic_lifting_functions.adb (download)
Revision 1.1.1.1 (vendor branch), Sun Oct 29 17:45:28 2000 UTC (23 years, 10 months ago) by maekawa
Import the second public release of PHCpack. OKed by Jan Verschelde. |
package body Dynamic_Lifting_Functions is function Lift_to_Place ( s : Simplex; x : Vector ) return integer is nor : constant Vector := Normal(s); ips : integer := nor*Vertex(s,1); ipx : integer := nor*x; begin if ips < ipx then return x(x'last); else ipx := ipx - x(x'last)*nor(nor'last); return ((ips - ipx)/nor(nor'last) + 1); end if; end Lift_to_Place; function Lift_to_Place ( t : Triangulation; x : Vector ) return integer is tmp : Triangulation := t; wrk : Vector(x'range) := x; begin while not Is_Null(tmp) loop wrk(wrk'last) := Lift_to_Place(Head_Of(tmp),wrk); tmp := Tail_Of(tmp); end loop; return wrk(wrk'last); end Lift_to_Place; function Lift_to_Pull ( s : Simplex; x : Vector ) return integer is nor : constant Vector := Normal(s); ips : integer := nor*Vertex(s,1); ipx : integer := nor*x; begin if ipx < ips then return x(x'last); else ipx := ipx - x(x'last)*nor(nor'last); return ((ips - ipx)/nor(nor'last) - 1); end if; end Lift_to_Pull; function Lift_to_Pull ( t : Triangulation; x : Vector ) return integer is tmp : Triangulation := t; wrk : Vector(x'range) := x; begin while not Is_Null(tmp) loop wrk(wrk'last) := Lift_to_Pull(Head_Of(tmp),wrk); tmp := Tail_Of(tmp); end loop; return wrk(wrk'last); end Lift_to_Pull; function Degenerate ( t : Triangulation; x : Vector ) return boolean is tmp : Triangulation := t; s : Simplex; begin while not Is_Null(tmp) loop s := Head_Of(tmp); declare nor : constant Vector := Normal(s); apt : constant Vector := Vertex(s,1); ipx : constant integer := x*nor; begin if apt*nor = ipx then return true; end if; end; tmp := Tail_Of(tmp); end loop; return false; end Degenerate; function Lift_to_Pull ( t1,t2 : Triangulation; x : Vector ) return integer is wrk : Vector(x'range) := x; begin wrk(wrk'last) := Lift_to_Pull(t1,x); while Degenerate(t2,wrk) loop -- pull the lifting further down wrk(wrk'last) := wrk(wrk'last) - 1; end loop; return wrk(wrk'last); end Lift_to_Pull; end Dynamic_Lifting_Functions;