Return to bracket_monomials.adb CVS log

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

Import the second public release of PHCpack.

OKed by Jan Verschelde.

package body Bracket_Monomials is

-- INTERNAL SORTING ROUTINE TO MAINTAIN ORDER :

  procedure Swap_Heads ( bm1,bm2 : in out Bracket_Monomial;
                         lb1,lb2 : in out Link_to_Bracket ) is

    b1 : Bracket(lb1'range) := lb1.all;
    b2 : Bracket(lb2'range) := lb2.all;

  begin
    Clear(lb2); lb2 := new Bracket'(b1);
    Clear(lb1); lb1 := new Bracket'(b2);
    Set_Head(bm1,lb1);
    Set_Head(bm2,lb2);
  end Swap_Heads;

  procedure Sort ( bm : in out Bracket_Monomial ) is

    tmp1 : Bracket_Monomial := bm;

  begin
    while not Is_Null(tmp1) loop
      declare
        lb1 : Link_to_Bracket := Head_Of(tmp1);
        min : Link_to_Bracket := lb1;
        mintmp : Bracket_Monomial := tmp1;
        tmp2 : Bracket_Monomial := Tail_Of(tmp1);
      begin
        while not Is_Null(tmp2) loop
          if Head_Of(tmp2).all < min.all
           then min := Head_Of(tmp2);
                mintmp := tmp2;
          end if;
          tmp2 := Tail_Of(tmp2);
        end loop;
        if not Is_Equal(lb1.all,min.all)
         then Swap_Heads(tmp1,mintmp,lb1,min);
        end if;
      end;
      tmp1 := Tail_Of(tmp1);
    end loop;
  end Sort;

-- CONSTRUCTORS :

  function Create ( b : Bracket ) return Bracket_Monomial is

    bm : Bracket_Monomial;
    lb : Link_to_Bracket := new Bracket'(b);

  begin
    Construct(lb,bm);
    return bm;
  end Create;

  procedure Multiply ( bm : in out Bracket_Monomial; b : in Bracket ) is
  begin
    if Is_Null(bm)
     then bm := Create(b);
     else declare
            lb : Link_to_Bracket := new Bracket'(b);
          begin
            Construct(lb,bm);
            Sort(bm);
          end;
    end if;
  end Multiply;

  procedure Copy ( bm1 : in Bracket_Monomial;
                   bm2 : in out Bracket_Monomial ) is

    tmp : Bracket_Monomial := bm1;

  begin
    Clear(bm2);
    while not Is_Null(tmp) loop
      declare
        b : constant Bracket := Head_Of(tmp).all;
      begin
        Multiply(bm2,b);
      end;
      tmp := Tail_Of(tmp);
    end loop;
  end Copy;

-- OPERATIONS :

  function "*" ( b1,b2 : Bracket ) return Bracket_Monomial is

    bm : Bracket_Monomial := Create(b1);

  begin
    Multiply(bm,b2);
    return bm;
  end "*";

  function "*" ( bm : Bracket_Monomial; b : Bracket )
               return Bracket_Monomial is

    res : Bracket_Monomial;

  begin
    Copy(bm,res);
    Multiply(res,b);
    return res;
  end "*";

  function "*" ( b : Bracket; bm : Bracket_Monomial )
               return Bracket_Monomial is

    res : Bracket_Monomial;

  begin
    Copy(bm,res);
    Multiply(res,b);
    return res;
  end "*";

  function "*" ( bm1,bm2 : Bracket_Monomial ) return Bracket_Monomial is

    res : Bracket_Monomial;

  begin
    Copy(bm1,res);
    Multiply(res,bm2);
    return res;
  end "*";

  procedure Multiply ( bm1 : in out Bracket_Monomial;
                       bm2 : in Bracket_Monomial ) is

    tmp : Bracket_Monomial := bm2;

  begin
    while not Is_Null(tmp) loop
      declare
        b : constant Bracket := Head_Of(tmp).all;
      begin
        Multiply(bm1,b);
      end;
      tmp := Tail_Of(tmp);
    end loop;
  end Multiply;

  function Is_Equal ( bm1,bm2 : Bracket_Monomial ) return boolean is

    tmp1 : Bracket_Monomial := bm1;
    tmp2 : Bracket_Monomial := bm2;

  begin
    if Length_Of(tmp1) /= Length_Of(tmp2)
     then return false;
     else while not Is_Null(tmp1) loop
            if not Is_Equal(Head_Of(tmp1).all,Head_Of(tmp2).all)
             then return false;
             else tmp1 := Tail_Of(tmp1);
                  tmp2 := Tail_Of(tmp2);
            end if;
          end loop;
          return true;
    end if;
  end Is_Equal;

  function "<" ( bm1,bm2 : Bracket_Monomial ) return boolean is

    tmp1 : Bracket_Monomial := bm1;
    tmp2 : Bracket_Monomial := bm2;
    lb1,lb2 : Link_to_Bracket;

  begin
    while not Is_Null(tmp1) and not Is_Null(tmp2) loop
      lb1 := Head_Of(tmp1); lb2 := Head_Of(tmp2);
      if lb1.all < lb2.all
       then return true;
       elsif lb1.all > lb2.all
           then return false;
           else tmp1 := Tail_Of(tmp1); tmp2 := Tail_Of(tmp2);
      end if;
    end loop;
    if Is_Null(tmp1) and not Is_Null(tmp2)
     then return true;
     else return false;
    end if;
  end "<";

  function ">" ( bm1,bm2 : Bracket_Monomial ) return boolean is

    tmp1 : Bracket_Monomial := bm1;
    tmp2 : Bracket_Monomial := bm2;
    lb1,lb2 : Link_to_Bracket;

  begin
    while not Is_Null(tmp1) and not Is_Null(tmp2) loop
      lb1 := Head_Of(tmp1); lb2 := Head_Of(tmp2);
      if lb1.all > lb2.all
       then return true;
       elsif lb1.all < lb2.all
           then return false;
           else tmp1 := Tail_Of(tmp1); tmp2 := Tail_Of(tmp2);
      end if;
    end loop;
    if Is_Null(tmp2) and not Is_Null(tmp1)
     then return true;
     else return false;
    end if;
  end ">";

  function Divisible ( bm : Bracket_Monomial; b : Bracket ) return boolean is

    tmp : Bracket_Monomial := bm;

  begin
    while not Is_Null(tmp) loop
      if Is_Equal(Head_Of(tmp).all,b)
       then return true;
       else tmp := Tail_Of(tmp);
      end if;
    end loop;
    return false;
  end Divisible;

-- ITERATORS OVER THE BRACKETS :

  function Number_of_Brackets ( bm : Bracket_Monomial ) return natural is
  begin
    return Length_Of(bm);
  end Number_of_Brackets;

  procedure Enumerate_Brackets ( bm : in Bracket_Monomial ) is

    tmp : Bracket_Monomial := bm;
    continue : boolean := true;

  begin
    while not Is_Null(tmp) loop
      Process(Head_Of(tmp).all,continue);
      exit when not continue;
      tmp := Tail_Of(tmp);
    end loop;
  end Enumerate_Brackets;

-- DESTRUCTOR :

  procedure Clear ( bm : in out Bracket_Monomial ) is

    tmp : Bracket_Monomial := bm;
    lb : Link_to_Bracket;

  begin
    while not Is_Null(tmp) loop
      lb := Head_Of(tmp);
      Clear(lb);
      tmp := Tail_Of(tmp);
    end loop;
    Lists_of_Brackets.Clear(Lists_of_Brackets.List(bm));
  end Clear;

end Bracket_Monomials;