Return to unfolding_subdivisions.adb CVS log

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

Import the second public release of PHCpack.

OKed by Jan Verschelde.

with Integer_Support_Functions;          use Integer_Support_Functions;
with Flatten_Mixed_Subdivisions;         use Flatten_Mixed_Subdivisions;

package body Unfolding_Subdivisions is

  function Different_Normals ( mixsub : Mixed_Subdivision ) return List is
  
    tmp : Mixed_Subdivision := mixsub;
    res,res_last : List;

  begin
    while not Is_Null(tmp) loop
      Append_Diff(res,res_last,Head_Of(tmp).nor.all);
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Different_Normals;

  function Extract ( normal : Vector; mixsub : Mixed_Subdivision )
                   return Mixed_Subdivision is

    tmp : Mixed_Subdivision := mixsub;
    res,res_last : Mixed_Subdivision;

  begin
    while not Is_Null(tmp) loop
      declare
        mic : Mixed_Cell := Head_Of(tmp);
      begin
        if mic.nor.all = normal
         then Append(res,res_last,mic);
        end if;
      end;
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Extract;

  function Merge_Same_Normal ( mixsub : Mixed_Subdivision )
                             return Mixed_Cell is

  -- DESCRIPTION :
  --   All cells with the same inner normal will be put in one cell,
  --   that will be contained in the mixed subdivision on return.

  -- REQUIRED :
  --   not Is_Null(mixsub) and all mixed cells have the same inner normal.

    tmp : Mixed_Subdivision;
    resmic,mic : Mixed_Cell;

  begin
    mic := Head_Of(mixsub);
    resmic.nor := new Standard_Integer_Vectors.Vector'(mic.nor.all);
    resmic.pts := new Array_of_Lists'(mic.pts.all);
    tmp := Tail_Of(mixsub);
    while not Is_Null(tmp) loop
      mic := Head_Of(tmp);
      declare
        last : List;
      begin
        for k in mic.pts'range loop
          last := resmic.pts(k);
          while not Is_Null(Tail_Of(last)) loop
            last := Tail_Of(last);
          end loop;
          Deep_Concat_Diff(resmic.pts(k),last,mic.pts(k));
        end loop;
      end;
      tmp := Tail_Of(tmp);
    end loop;
    return resmic;
  end Merge_Same_Normal;

  function Merge_Same_Normal ( mixsub : Mixed_Subdivision )
                             return Mixed_Subdivision is

  -- REQUIRED :
  --   not Is_Null(mixsub) and all mixed cells have the same inner normal.

    resmic : Mixed_Cell := Merge_Same_Normal(mixsub);
    ressub : Mixed_Subdivision;

  begin
    Construct(resmic,ressub);
    return ressub;
  end Merge_Same_Normal;

  function Merge ( mixsub : Mixed_Subdivision ) return Mixed_Subdivision is

  -- NOTE :
  --   Cells with an unique normal are simply taken over in the result,
  --   cells with the same normal are merged, hereby the refinement of these
  --   cells is destroyed.  Though, one could do better...

  begin
    if Is_Null(mixsub)
     then return mixsub;
     else
       declare
         tmp : Mixed_Subdivision := mixsub;
         res,res_last : Mixed_Subdivision;
         mic : Mixed_Cell;
       begin
         while not Is_Null(tmp) loop
           mic := Head_Of(tmp);
           if not Is_In(res,mic.nor.all)
            then
              if not Is_In(Tail_Of(tmp),mic.nor.all)
               then Append(res,res_last,mic);
               else declare
                      tmpmic : Mixed_Subdivision := Extract(mic.nor.all,tmp);
                      bigmic : Mixed_Cell := Merge_Same_Normal(tmpmic);
                    begin
                      Append(res,res_last,bigmic);
                    end;
              end if;
           end if;
           tmp := Tail_Of(tmp);
         end loop;
         return res;
       end;
    end if;
  end Merge;

  function Relift ( l : List; point : Vector ) return List is

    tmp,res : List;
    pt : Link_to_Vector;

  begin
    Copy(l,res);
    tmp := res;
    while not Is_Null(tmp) loop
      pt := Head_Of(tmp);
      if pt.all = point
       then pt(pt'last) := 1;
       else pt(pt'last) := 0;
      end if;
      Set_Head(tmp,pt);
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Relift;

  function Relift ( pts : Array_of_Lists; point : Vector )
                  return Array_of_Lists is

    res : Array_of_Lists(pts'range);

  begin
    for i in pts'range loop
      res(i) := Relift(pts(i),point);
    end loop;
    return res;
  end Relift;

  function Relift ( mic : Mixed_Cell; point : Vector ) return Mixed_Cell is

    res : Mixed_Cell;

  begin
    res.pts := new Array_of_Lists'(Relift(mic.pts.all,point));
    res.nor := new Standard_Integer_Vectors.Vector'(point'range => 0);
    Compute_Inner_Normal(res);
    return res;
  end Relift;

  function Relift ( mixsub : Mixed_Subdivision; point : Vector )
                  return Mixed_Subdivision is

    tmp,res,res_last : Mixed_Subdivision;

  begin
    tmp := mixsub;
    while not Is_Null(tmp) loop
      Append(res,res_last,Relift(Head_Of(tmp),point));
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Relift;

  function Is_In_Point ( pt : Link_to_Vector; l : List ) return boolean is

  -- DESCRIPTION :
  --   Returns true if the first n coordinates of pt belong to l.

    tmp : List := l;
    lpt : Link_to_Vector;

  begin
    while not Is_Null(tmp) loop
      lpt := Head_Of(tmp);
      if lpt(lpt'first..lpt'last-1) = pt(pt'first..pt'last-1)
       then return true;
       else tmp := Tail_Of(tmp);
      end if;
    end loop;
    return false;
  end Is_In_Point;

  function Different_Points ( l1,l2 : List ) return natural is

  -- DESCRIPTION :
  --   Return the number of different points of the list l2 w.r.t. l1.

    res : natural := 0;
    tmp : List := l2;

  begin
    while not Is_Null(tmp) loop
      if not Is_In_Point(Head_Of(tmp),l1)
       then res := res + 1;
      end if;
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Different_Points;

  function Different_Points ( l1,l2 : List ) return List is

  -- DESCRIPTION :
  --   Return the list of different points of the list l2 w.r.t. l1.

    res,res_last : List;
    tmp : List := l2;

  begin
    while not Is_Null(tmp) loop
      if not Is_In_Point(Head_Of(tmp),l1)
       then Append(res,res_last,Head_Of(tmp).all);
      end if;
      tmp := Tail_Of(tmp);
    end loop;
    return res;
  end Different_Points;

  function Different_Points ( pts : Array_of_Lists; mic : Mixed_Cell )
                            return natural is

  -- DESCRIPTION :
  --   Return the number of different points of the cell mic w.r.t. pts.

    res : natural := 0;

  begin
    for i in pts'range loop
      res := res + Different_Points(pts(i),mic.pts(i));
    end loop;
    return res;
  end Different_Points;

  function Different_Points ( pts : Array_of_Lists; mic : Mixed_Cell )
                            return Array_of_Lists is

  -- DESCRIPTION :
  --   Return the different points of the cell mic w.r.t. pts.

    res : Array_of_Lists(pts'range);

  begin
    for i in pts'range loop
      res(i) := Different_Points(pts(i),mic.pts(i));
    end loop;
    return res;
  end Different_Points;

  procedure Add ( l : in out List; pts : in List ) is

  -- DESCRIPTION :
  --   Adds the points in pts to l.

    tmp : List := pts;
    pt : Link_to_Vector;

  begin
    while not Is_Null(tmp) loop
      pt := Head_Of(tmp);
      declare
        npt : Link_to_Vector := new Vector'(pt.all);
      begin
        Construct(npt,l);
      end;
      tmp := Tail_Of(tmp);
    end loop;
  end Add;

  procedure Add ( l : in out Array_of_Lists; pts : in Array_of_Lists ) is

  -- DESCRIPTION :
  --   Adds the points in pts to l.

  begin
    for i in l'range loop
      Add(l(i),pts(i));
    end loop;
  end Add;

  procedure Put_Next_to_Front ( mixsub : in out Mixed_Subdivision;
                                pts : in Array_of_Lists ) is
 
  -- DESCRIPTION :
  --   Selects the next mixed cell to be processed, and puts in front
  --   of the list of cells mixsub.

    mic1 : Mixed_Cell := Head_Of(mixsub);
    min1 : natural := Different_Points(pts,mic1);
    tmp : Mixed_Subdivision := Tail_Of(mixsub);
    min : natural;
    mic : Mixed_Cell;

  begin
    while not Is_Null(tmp) loop
      mic := Head_Of(tmp);
      min := Different_Points(pts,mic);
      if min < min1
       then min1 := min;
            Set_Head(mixsub,mic);
            Set_Head(tmp,mic1);
      end if;
      tmp := Tail_Of(tmp);
    end loop;
  end Put_Next_to_Front;

  procedure Relift ( l : in out List; ref : in List ) is

  -- DESCRIPTION :
  --   Gives all points in l, which belong to ref, lifting value 1.

    tmp : List := l;
    pt : Link_to_Vector;

  begin
    while not Is_Null(tmp) loop
      pt := Head_Of(tmp);
      if Is_In(ref,pt)
       then pt(pt'last) := 1;
       else pt(pt'last) := 0;
      end if;
      Set_Head(tmp,pt);
      tmp := Tail_Of(tmp);
    end loop;
  end Relift;

  procedure Relift ( l : in out List ) is

  -- DESCRIPTION :
  --   Gives all points lifting value 1.

    tmp : List := l;
    pt : Link_to_Vector;

  begin
    while not Is_Null(tmp) loop
      pt := Head_Of(tmp);
      pt(pt'last) := 1;
      Set_Head(tmp,pt);
      tmp := Tail_Of(tmp);
    end loop;
  end Relift;

  procedure Relift ( l : in out Array_of_Lists; ref : in Array_of_Lists ) is

  -- DESCRIPTION :
  --   Gives all points in l, which belong to ref, lifting value 1.

  begin
    for i in l'range loop
      Relift(l(i),ref(i));
    end loop;
  end Relift;

  procedure Relift ( l : in out Array_of_Lists ) is

  -- DESCRIPTION :
  --   Gives all points lifting value 1.

  begin
    for i in l'range loop
      Relift(l(i));
    end loop;
  end Relift;

  procedure Relift ( mic : in out Mixed_Cell; pts : in out Array_of_Lists ) is

  -- DESCRIPTION :
  --   Gives the points in mic, which belong to pts lifting 1,
  --   and computes the new inner normal.

  begin
    Relift(mic.pts.all,pts);
    Relift(pts);
  end Relift;

  procedure Orientate_Inner_Normal 
                ( mic : in out Mixed_Cell; pts : in Array_of_Lists ) is

  -- DESCRIPTION :
  --   Orientates the normal of mic w.r.t. the points in pts.

    done : boolean := false;

  begin
    for i in pts'range loop
      if Minimal_Support(mic.pts(i),mic.nor.all) 
          > Minimal_Support(pts(i),mic.nor.all)
       then Min(mic.nor);
            done := true;
      end if;
      exit when done;
    end loop;
  end Orientate_Inner_Normal;

  procedure Unfolding ( mixsub : in out Mixed_Subdivision ) is

    tmp : Mixed_Subdivision;

  begin
    if not Is_Null(mixsub)
     then
       declare
         mic : Mixed_Cell := Head_Of(mixsub);
         pts : Array_of_Lists(mic.pts'range);
       begin
         Flatten(mic);
         Copy(mic.pts.all,pts);
         Process(mic,pts);
         tmp := Tail_Of(mixsub);
         while not Is_Null(tmp) loop
           Put_Next_to_Front(tmp,pts);
           mic := Head_Of(tmp);
           declare
             newpts : Array_of_Lists(pts'range);
           begin
             newpts := Different_Points(pts,mic);
             Relift(mic,newpts);
             Compute_Inner_Normal(mic);
            -- Orientate_Inner_Normal(mic,pts);
             Process(mic,newpts);
             Add(pts,newpts);
             Deep_Clear(newpts);
           end;
           tmp := Tail_Of(tmp);
         end loop;
       end;
    end if;
  end Unfolding;
  
end Unfolding_Subdivisions;