Return to dynamic_lifting_functions.adb CVS log

Up to [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Dynlift

Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Dynlift/dynamic_lifting_functions.adb, Revision 1.1

1.1     ! maekawa     1: package body Dynamic_Lifting_Functions is
        !             2:
        !             3:   function Lift_to_Place ( s : Simplex; x : Vector ) return integer is
        !             4:
        !             5:     nor : constant Vector := Normal(s);
        !             6:     ips : integer := nor*Vertex(s,1);
        !             7:     ipx : integer := nor*x;
        !             8:
        !             9:   begin
        !            10:     if ips < ipx
        !            11:      then return x(x'last);
        !            12:      else ipx := ipx - x(x'last)*nor(nor'last);
        !            13:           return ((ips - ipx)/nor(nor'last) + 1);
        !            14:     end if;
        !            15:   end Lift_to_Place;
        !            16:
        !            17:   function Lift_to_Place ( t : Triangulation; x : Vector ) return integer is
        !            18:
        !            19:     tmp : Triangulation := t;
        !            20:     wrk : Vector(x'range) := x;
        !            21:
        !            22:   begin
        !            23:     while not Is_Null(tmp) loop
        !            24:       wrk(wrk'last) := Lift_to_Place(Head_Of(tmp),wrk);
        !            25:       tmp := Tail_Of(tmp);
        !            26:     end loop;
        !            27:     return wrk(wrk'last);
        !            28:   end Lift_to_Place;
        !            29:
        !            30:   function Lift_to_Pull ( s : Simplex; x : Vector ) return integer is
        !            31:
        !            32:     nor : constant Vector := Normal(s);
        !            33:     ips : integer := nor*Vertex(s,1);
        !            34:     ipx : integer := nor*x;
        !            35:
        !            36:   begin
        !            37:     if ipx < ips
        !            38:      then return x(x'last);
        !            39:      else ipx := ipx - x(x'last)*nor(nor'last);
        !            40:           return ((ips - ipx)/nor(nor'last) - 1);
        !            41:     end if;
        !            42:   end Lift_to_Pull;
        !            43:
        !            44:   function Lift_to_Pull ( t : Triangulation; x : Vector ) return integer is
        !            45:
        !            46:     tmp : Triangulation := t;
        !            47:     wrk : Vector(x'range) := x;
        !            48:
        !            49:   begin
        !            50:     while not Is_Null(tmp) loop
        !            51:       wrk(wrk'last) := Lift_to_Pull(Head_Of(tmp),wrk);
        !            52:       tmp := Tail_Of(tmp);
        !            53:     end loop;
        !            54:     return wrk(wrk'last);
        !            55:   end Lift_to_Pull;
        !            56:
        !            57:   function Degenerate ( t : Triangulation; x : Vector ) return boolean is
        !            58:
        !            59:     tmp : Triangulation := t;
        !            60:     s : Simplex;
        !            61:
        !            62:   begin
        !            63:     while not Is_Null(tmp) loop
        !            64:       s := Head_Of(tmp);
        !            65:       declare
        !            66:         nor : constant Vector := Normal(s);
        !            67:         apt : constant Vector := Vertex(s,1);
        !            68:         ipx : constant integer := x*nor;
        !            69:       begin
        !            70:         if apt*nor = ipx
        !            71:          then return true;
        !            72:         end if;
        !            73:       end;
        !            74:       tmp := Tail_Of(tmp);
        !            75:     end loop;
        !            76:     return false;
        !            77:   end Degenerate;
        !            78:
        !            79:   function Lift_to_Pull ( t1,t2 : Triangulation; x : Vector ) return integer is
        !            80:
        !            81:     wrk : Vector(x'range) := x;
        !            82:
        !            83:   begin
        !            84:     wrk(wrk'last) := Lift_to_Pull(t1,x);
        !            85:     while Degenerate(t2,wrk) loop   -- pull the lifting further down
        !            86:       wrk(wrk'last) := wrk(wrk'last) - 1;
        !            87:     end loop;
        !            88:     return wrk(wrk'last);
        !            89:   end Lift_to_Pull;
        !            90:
        !            91: end Dynamic_Lifting_Functions;