Return to integer_lifting_utilities.adb CVS log

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

Import the second public release of PHCpack.

OKed by Jan Verschelde.

with Integer_Vectors_Utilities;          use Integer_Vectors_Utilities;
-- with Power_Lists;                 use Power_Lists;

package body Integer_Lifting_Utilities is

  function Adaptive_Lifting ( l : Array_of_Lists ) return Vector is

    res : Vector(l'range);
    fac : constant natural := 3;     -- multiplication factor
    max : constant natural := 23;    -- upper bound for lifting

  begin
    for i in l'range loop
      res(i) := fac*Length_Of(l(i));
      if res(i) > max
       then res(i) := max;
      end if;
    end loop;
    return res;
  end Adaptive_Lifting;

--  function Select_Subsystem ( p : Laur_Sys; mix : Vector; mic : Mixed_Cell )
--                            return Laur_Sys is
--
--    res : Laur_Sys(p'range);
--    cnt : natural := 0;
--
--  begin
--    for k in mix'range loop
--      for l in 1..mix(k) loop
--        cnt := cnt + 1;
--        res(cnt) := Select_Terms(p(cnt),mic.pts(k));
--      end loop;
--    end loop;
--    return res;
--  end Select_Subsystem;

  function Perform_Lifting ( n : natural; l : List; p : Poly ) return Poly is

    res : Poly := Null_Poly;
    tmp : List := l;

  begin
    while not Is_Null(tmp) loop
      declare
        d : Link_to_Vector := Head_Of(tmp);
        dr : Link_to_Vector := Reduce(d,n+1);
        t : Term;
      begin
        t.cf := Coeff(p,Degrees(dr));
        t.dg := Degrees(d);
        Add(res,t);
        Clear(dr);
      end;
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Perform_Lifting;

  function Perform_Lifting
              ( n : natural; mix : Vector; lifted : Array_of_Lists;
                p : Laur_Sys ) return Laur_Sys is

    res : Laur_Sys(p'range);
    cnt : natural := 1;

  begin
    for k in mix'range loop
      for l in 1..mix(k) loop
        res(cnt) := Perform_Lifting(n,lifted(k),p(cnt));
        cnt := cnt+1;
      end loop;
    end loop;
    return res;
  end Perform_Lifting;

  function Copy_Lifting ( lifted : List; pt : Link_to_Vector )
                        return Link_to_Vector is

  -- DESCRIPTION :
  --   Searches the correspoinding point in the list lifted and returns
  --   the lifted point.  If the corresponding point has not been found,
  --   then the original point pt will be returned.

    tmp : List := lifted;
    lpt,res : Link_to_Vector;

  begin
    while not Is_Null(tmp) loop
      lpt := Head_Of(tmp);
      if Equal(lpt(pt'range),pt.all)
       then res := new Standard_Integer_Vectors.Vector'(lpt.all);
            return res;
       else tmp := Tail_Of(tmp);
      end if;
    end loop;
    return pt;
  end Copy_Lifting;

  function Copy_Lifting ( lifted,pts : List ) return List is

  -- DESCRIPTION :
  --   Copies the lifting on the points lifted to the points in pts,
  --   i.e., each point in pts will get the same lifting as the corresponding
  --   lifted point in the list lifted.

    res : List;
    tmp : List := pts;

  begin
    while not Is_Null(tmp) loop
      Construct(Copy_Lifting(lifted,Head_Of(tmp)),res);
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Copy_Lifting;

  procedure Search_Lifting ( l : in List; pt : in Vector;
                             found : out boolean; lif : out integer ) 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 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;
    res(res'last) := Conservative_Lifting(mixsub,k,res);
    return res;
  end Induced_Lifting;

  function Induced_Lifting
               ( n : natural; mix : 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;

  procedure Constant_Lifting
                ( l : in List; liftval : in natural;
                  lifted,lifted_last : in out List ) is

    tmp : List := l;
    pt : Link_to_Vector;
 
  begin
    while not Is_Null(tmp) loop
      pt := Head_Of(tmp);
      declare
        lpt : Link_to_Vector := new Vector(pt'first..pt'last+1);
      begin
        lpt(pt'range) := pt.all;
        lpt(lpt'last) := liftval;
        Append(lifted,lifted_last,lpt);
      end;
      tmp := Tail_Of(tmp);
    end loop;
  end Constant_Lifting;

  procedure Constant_Lifting
               ( al : in Array_of_Lists; liftval : in natural;
                 lifted,lifted_last : in out Array_of_Lists ) is
  begin
    for i in al'range loop
      Constant_Lifting(al(i),liftval,lifted(i),lifted_last(i));
    end loop;
  end Constant_Lifting;

  function Conservative_Lifting
               ( mic : Mixed_Cell; k : natural; point : Vector )
               return integer is

    sp : integer := mic.nor*Head_Of(mic.pts(k));
    spp : integer := mic.nor.all*point;
    res : integer;

  begin
    if sp < spp
     then return point(point'last);
     else if mic.nor(mic.nor'last) = 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;
          end if;
          return res;
    end if;
  end Conservative_Lifting;

  function Conservative_Lifting ( mixsub : Mixed_Subdivision; k : natural;
                                  point : Vector ) return integer is

    tmp : Mixed_Subdivision := mixsub;
    pt : Vector(point'range) := point;
    res : integer;

  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;

  function Lower_Lifting ( mic : Mixed_Cell; k : natural; point : Vector )
                         return integer is
  begin
    if Is_In(mic.pts(k),point)
     then return 0;
     else declare
            pt : Vector(point'range) := point;
          begin
            pt(pt'last) := 0;
            return Conservative_Lifting(mic,k,pt);
          end;
    end if;
  end Lower_Lifting;

  function Lower_Lifting ( mixsub : Mixed_Subdivision; k : natural;
                           point : Vector ) return integer is

    lif : integer := point(point'last);
    tmp : Mixed_Subdivision := mixsub;
    max : integer := 0;

  begin
    while not Is_Null(tmp) loop
      lif := Lower_Lifting(Head_Of(tmp),k,point);
      if lif > max
       then max := lif;
      end if;
      exit when max = point(point'last);
      tmp := Tail_Of(tmp);
    end loop;
    return max;
  end Lower_Lifting;

end Integer_Lifting_Utilities;