Return to pieri_root_counts.adb CVS log

Up to [local] / OpenXM_contrib / PHC / Ada / Schubert

Import the second public release of PHCpack.

OKed by Jan Verschelde.

with unchecked_deallocation;
with integer_io;                         use integer_io;
with Brackets;                           use Brackets;
with Brackets_io;                        use Brackets_io;
with Pieri_Trees_io;                     use Pieri_Trees_io;

package body Pieri_Root_Counts is

  procedure free is new unchecked_deallocation(Nodal_Pair,Link_to_Nodal_Pair);

  type Boolean_Array is array ( integer range <> ) of boolean;

  function Create ( n,d : natural; t1,t2 : Pieri_Tree )
                  return List_of_Paired_Nodes is

    res,res_last : List_of_Paired_Nodes;
    h1 : constant natural := Height(t1);
    h2 : constant natural := Height(t2);
    b1,b2 : Bracket(1..d);
    firstlnd : Link_to_Pieri_Node;
    cnt : natural := 0;

    procedure Check_Pair ( lnd : in Link_to_Pieri_Node;
                           continue : out boolean ) is
    begin
      b2 := lnd.node;
      if Pieri_Condition(n,b1,b2)
       then declare
              lpnd : Paired_Nodes;
            begin
              lpnd.left := firstlnd;
              lpnd.right := lnd;
              Append(res,res_last,lpnd);
            end ;
      end if;
      continue := true;
    end Check_Pair;
    procedure Check_Pairs is new Enumerate_Nodes(Check_Pair);

    procedure Count_First ( lnd : in Link_to_Pieri_Node;
                            continue : out boolean ) is
    begin
      b1 := lnd.node;
      firstlnd := lnd;
      Check_Pairs(t2,h2);
      continue := true;
    end Count_First;
    procedure First_Leaves is new Enumerate_Nodes(Count_First);

  begin
    First_Leaves(t1,h1);
    return res;
  end Create;

  function Create ( pnd : Paired_Nodes ) return Paired_Chain is

    res : Paired_Chain(1..Height(pnd));
    ind : natural := res'last;

  begin
    res(ind) := pnd;
    while not At_First_Branch_Point(res(ind)) loop         -- fill in
      ind := ind - 1;
      res(ind) := Ancestor(res(ind+1));
    end loop;
    if ind = 1
     then return res;
     else for i in 1..res'last-ind+1 loop                  -- shift down
            res(i) := res(i+ind-1);
          end loop;
          return res(1..res'last-ind+1);
    end if;
  end Create;

  procedure Connect ( ancnp,np : in out Link_to_Nodal_Pair ) is

  -- DESCRIPTION :
  --   Connects the ancestor paired nodes with the paired nodes np.

    ancpnd : Paired_Nodes := Ancestor(np.pnd);
    j1 : constant natural := Jump(ancpnd.left.node,np.pnd.left.node);
    j2 : constant natural := Jump(ancpnd.right.node,np.pnd.right.node);

  begin
    ancnp.pnd := ancpnd;
    ancnp.children(j1,j2) := np;
    np.ancestor := ancnp;
  end Connect;

  procedure Initial_Branch ( root,np : in out Link_to_Nodal_Pair ) is

  -- DESCRIPTION :
  --   Constructs the initial branch in the tree of paired nodes.

  begin
    if At_First_Branch_Point(np.pnd)
     then root := np;
     else declare
            acc : Link_to_Nodal_Pair := new Nodal_Pair(np.d);
          begin
            acc.sols := 1;
            Connect(acc,np);
            Initial_Branch(root,acc);
          end;
    end if;
  end Initial_Branch;

  procedure Merge ( root : in Nodal_Pair;
                    current : in out Link_to_Nodal_Pair; k : in natural;
                    chain : in Paired_Chain ) is

  -- DESCRIPTION :
  --   Merges the chain with the root of the tree, at level k.

    j1,j2 : natural;

  begin
    j1 := Jump(chain(k).left.node,chain(k+1).left.node);
    j2 := Jump(chain(k).right.node,chain(k+1).right.node); 
    if current.children(j1,j2) = null
     then declare
            newnp : Link_to_Nodal_Pair := new Nodal_Pair(current.d);
          begin
            newnp.pnd := chain(k+1);
            if Is_In(root,newnp.pnd)
             then newnp.sols := 0;
             else newnp.sols := 1;
            end if;
            current.children(j1,j2) := newnp;
            newnp.ancestor := current;
          end;
     else if current.children(j1,j2).sols > 0
           then current.children(j1,j2).sols
                  := current.children(j1,j2).sols + 1;
          end if;
    end if;
    if k+1 < chain'last
     then Merge(root,current.children(j1,j2),k+1,chain);
    end if;
  end Merge;

  function Create ( d : natural; lp : List_of_Paired_Nodes )
                  return Nodal_Pair is

    root : Nodal_Pair(d);
    lroot : Link_to_Nodal_Pair := new Nodal_Pair'(root);
    first : Link_to_Nodal_Pair := new Nodal_Pair(d);
    tmp : List_of_Paired_Nodes := Tail_Of(lp);

  begin
    first.pnd := Head_Of(lp);
    first.sols := 1;
    lroot.sols := 1;
    Initial_Branch(lroot,first);
    while not Is_Null(tmp) loop
      declare
        pnd : Paired_Nodes := Head_Of(tmp);
        chn : constant Paired_Chain := Create(pnd);
      begin
        lroot.sols := lroot.sols + 1;
        Merge(lroot.all,lroot,1,chn);
      end;
      tmp := Tail_Of(tmp);
    end loop;
    return lroot.all;
  end Create;

-- SELECTORS :

  function Height ( pnd : Paired_Nodes ) return natural is
  begin
    if pnd.left.h >= pnd.right.h
     then return pnd.left.h;
     else return pnd.right.h;
    end if;
  end Height;

  function Equal ( pnd1,pnd2 : Paired_Nodes ) return boolean is
  begin
    return (Is_Equal(pnd1.left.node,pnd2.left.node)
        and Is_Equal(pnd1.right.node,pnd2.right.node));
  end Equal;

  function At_First_Branch_Point ( pnd : Paired_Nodes ) return boolean is
  begin
    if pnd.left.h /= pnd.right.h
     then return false;
     elsif ((pnd.left.c > 1) or (pnd.right.c > 1))
         then return false;
	     else return (((pnd.left.i = 0) and (pnd.left.c = 1))
                or else ((pnd.right.i = 0) and (pnd.right.c = 1)));
    end if;
  end At_First_Branch_Point;

  function At_Leaves ( pnd : Paired_Nodes ) return boolean is
  begin
    return (Is_Leaf(pnd.left.all) and Is_Leaf(pnd.right.all));
  end At_Leaves;

  function Ancestor ( pnd : Paired_Nodes ) return Paired_Nodes is

    res : Paired_Nodes;

  begin
    if pnd.left.h = pnd.right.h
     then res.left := pnd.left.ancestor;
          res.right := pnd.right.ancestor;
     elsif pnd.left.h > pnd.right.h
         then res.left := pnd.left.ancestor;
              res.right := pnd.right;
         else res.left := pnd.left;
              res.right := pnd.right.ancestor;
    end if;
    return res;
  end Ancestor;

  function First_Branch_Point ( pnd : Paired_Nodes ) return Paired_Nodes is
  begin
    if At_First_Branch_Point(pnd)
     then return pnd;
     else return First_Branch_Point(Ancestor(pnd));
    end if;
  end First_Branch_Point;

  function Height ( np : Nodal_Pair ) return natural is
  begin
    if np.pnd.left.h >= np.pnd.right.h
     then return np.pnd.left.h;
     else return np.pnd.right.h;
    end if;
  end Height;

  function Is_In ( root : Nodal_Pair; pnd : Paired_Nodes ) return boolean is
  begin
    if Equal(root.pnd,pnd)
     then return true;
     else for j1 in root.children'range(1) loop
            for j2 in root.children'range(2) loop
              if root.children(j1,j2) /= null
               then if Is_In(root.children(j1,j2).all,pnd)
                     then return true;
                    end if;
              end if;
            end loop;
          end loop;
    end if;
    return false;
  end Is_In;

  function Number_of_Paths ( root : Nodal_Pair ) return natural is

    res : natural := root.sols;

  begin
    for j1 in root.children'range(1) loop
      for j2 in root.children'range(2) loop
        if root.children(j1,j2) /= null
         then if not At_Leaves(root.children(j1,j2).pnd)
               then res := res + Number_of_Paths(root.children(j1,j2).all);
              end if;
        end if;
      end loop;
    end loop;
    return res;
  end Number_of_Paths;

-- FORMATTED OUTPUT :

  procedure Write ( file : in file_type; chn : in Paired_Chain ) is
  begin
    for i in chn'first..(chn'last-1) loop
      put(file,"("); put(file,chn(i).left.node);
      put(file,","); put(file,chn(i).right.node); put(file,") < ");
    end loop;
    put(file,"("); put(file,chn(chn'last).left.node);
    put(file,","); put(file,chn(chn'last).right.node); put_line(file,")");
  end Write;

  function Last_Child ( np : Nodal_Pair; i,j : natural ) return boolean is

  -- DESCRIPTION :
  --   Returns true if the (i,j)th child is the last child of the node.

  begin
    for j1 in j+1..np.children'last(2) loop
      if np.children(i,j1) /= null
       then return false;
      end if;
    end loop;
    for i1 in i+1..np.children'last(1) loop
      for j1 in np.children'range(2) loop
        if np.children(i1,j1) /= null
         then return false;
        end if;
      end loop;
    end loop;
    return true;
  end Last_Child;

  procedure Write_Labels ( file : in file_type; np : in Nodal_Pair;
                           j1,j2,h : in natural; last : in Boolean_Array ) is

  -- DESCRIPTION :
  --   Writes the contents of the nodal pair with the jumps, taking into
  --   account which children appeared last.
  --   The current node is at height h in the nodal pair tree.

    first : Paired_Nodes := First_Branch_Point(np.pnd);

  begin
    if h /= 0
     then put(file,"   ");
    end if;
    for i in 1..h-1 loop
      if last(i)
       then put(file,"     ");
       else put(file,"|    ");       
      end if;
    end loop;
    if h /= 0
     then put(file,"!-+(");
          put(file,j1,1); put(file,","); put(file,j2,1);
          put(file,")");
    end if;
    put(file,"("); put(file,np.pnd.left.node);
    put(file,","); put(file,np.pnd.right.node);
    put(file,") ");
    put(file,np.sols,1);
    new_line(file);
  end Write_Labels;

  procedure Write_Nodes ( file : in file_type; np : in Nodal_Pair;
                          j1,j2,h : in natural; last : in out Boolean_Array ) is

  -- DESCRIPTION :
  --   Writes the contents of the nodal pair, followed by the children.

  begin
    Write_Labels(file,np,j1,j2,h,last);
    for jj1 in np.children'range(1) loop
      for jj2 in np.children'range(2) loop
        if np.children(jj1,jj2) /= null
         then last(h+1) := Last_Child(np,jj1,jj2);
              Write_Nodes(file,np.children(jj1,jj2).all,jj1,jj2,h+1,last);
        end if;
      end loop;
    end loop;
  end Write_Nodes;

  procedure Write ( file : in file_type; root : in Nodal_Pair ) is

    last : Boolean_Array(1..Height(root)+1);

  begin
    Write_Nodes(file,root,1,1,0,last);
  end Write;

end Pieri_Root_Counts;