Return to floating_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.

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;