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

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;