Annotation of OpenXM_contrib/PHC/Ada/Schubert/bracket_monomials.adb, Revision 1.1
1.1 ! maekawa 1: package body Bracket_Monomials is
! 2:
! 3: -- INTERNAL SORTING ROUTINE TO MAINTAIN ORDER :
! 4:
! 5: procedure Swap_Heads ( bm1,bm2 : in out Bracket_Monomial;
! 6: lb1,lb2 : in out Link_to_Bracket ) is
! 7:
! 8: b1 : Bracket(lb1'range) := lb1.all;
! 9: b2 : Bracket(lb2'range) := lb2.all;
! 10:
! 11: begin
! 12: Clear(lb2); lb2 := new Bracket'(b1);
! 13: Clear(lb1); lb1 := new Bracket'(b2);
! 14: Set_Head(bm1,lb1);
! 15: Set_Head(bm2,lb2);
! 16: end Swap_Heads;
! 17:
! 18: procedure Sort ( bm : in out Bracket_Monomial ) is
! 19:
! 20: tmp1 : Bracket_Monomial := bm;
! 21:
! 22: begin
! 23: while not Is_Null(tmp1) loop
! 24: declare
! 25: lb1 : Link_to_Bracket := Head_Of(tmp1);
! 26: min : Link_to_Bracket := lb1;
! 27: mintmp : Bracket_Monomial := tmp1;
! 28: tmp2 : Bracket_Monomial := Tail_Of(tmp1);
! 29: begin
! 30: while not Is_Null(tmp2) loop
! 31: if Head_Of(tmp2).all < min.all
! 32: then min := Head_Of(tmp2);
! 33: mintmp := tmp2;
! 34: end if;
! 35: tmp2 := Tail_Of(tmp2);
! 36: end loop;
! 37: if not Is_Equal(lb1.all,min.all)
! 38: then Swap_Heads(tmp1,mintmp,lb1,min);
! 39: end if;
! 40: end;
! 41: tmp1 := Tail_Of(tmp1);
! 42: end loop;
! 43: end Sort;
! 44:
! 45: -- CONSTRUCTORS :
! 46:
! 47: function Create ( b : Bracket ) return Bracket_Monomial is
! 48:
! 49: bm : Bracket_Monomial;
! 50: lb : Link_to_Bracket := new Bracket'(b);
! 51:
! 52: begin
! 53: Construct(lb,bm);
! 54: return bm;
! 55: end Create;
! 56:
! 57: procedure Multiply ( bm : in out Bracket_Monomial; b : in Bracket ) is
! 58: begin
! 59: if Is_Null(bm)
! 60: then bm := Create(b);
! 61: else declare
! 62: lb : Link_to_Bracket := new Bracket'(b);
! 63: begin
! 64: Construct(lb,bm);
! 65: Sort(bm);
! 66: end;
! 67: end if;
! 68: end Multiply;
! 69:
! 70: procedure Copy ( bm1 : in Bracket_Monomial;
! 71: bm2 : in out Bracket_Monomial ) is
! 72:
! 73: tmp : Bracket_Monomial := bm1;
! 74:
! 75: begin
! 76: Clear(bm2);
! 77: while not Is_Null(tmp) loop
! 78: declare
! 79: b : constant Bracket := Head_Of(tmp).all;
! 80: begin
! 81: Multiply(bm2,b);
! 82: end;
! 83: tmp := Tail_Of(tmp);
! 84: end loop;
! 85: end Copy;
! 86:
! 87: -- OPERATIONS :
! 88:
! 89: function "*" ( b1,b2 : Bracket ) return Bracket_Monomial is
! 90:
! 91: bm : Bracket_Monomial := Create(b1);
! 92:
! 93: begin
! 94: Multiply(bm,b2);
! 95: return bm;
! 96: end "*";
! 97:
! 98: function "*" ( bm : Bracket_Monomial; b : Bracket )
! 99: return Bracket_Monomial is
! 100:
! 101: res : Bracket_Monomial;
! 102:
! 103: begin
! 104: Copy(bm,res);
! 105: Multiply(res,b);
! 106: return res;
! 107: end "*";
! 108:
! 109: function "*" ( b : Bracket; bm : Bracket_Monomial )
! 110: return Bracket_Monomial is
! 111:
! 112: res : Bracket_Monomial;
! 113:
! 114: begin
! 115: Copy(bm,res);
! 116: Multiply(res,b);
! 117: return res;
! 118: end "*";
! 119:
! 120: function "*" ( bm1,bm2 : Bracket_Monomial ) return Bracket_Monomial is
! 121:
! 122: res : Bracket_Monomial;
! 123:
! 124: begin
! 125: Copy(bm1,res);
! 126: Multiply(res,bm2);
! 127: return res;
! 128: end "*";
! 129:
! 130: procedure Multiply ( bm1 : in out Bracket_Monomial;
! 131: bm2 : in Bracket_Monomial ) is
! 132:
! 133: tmp : Bracket_Monomial := bm2;
! 134:
! 135: begin
! 136: while not Is_Null(tmp) loop
! 137: declare
! 138: b : constant Bracket := Head_Of(tmp).all;
! 139: begin
! 140: Multiply(bm1,b);
! 141: end;
! 142: tmp := Tail_Of(tmp);
! 143: end loop;
! 144: end Multiply;
! 145:
! 146: function Is_Equal ( bm1,bm2 : Bracket_Monomial ) return boolean is
! 147:
! 148: tmp1 : Bracket_Monomial := bm1;
! 149: tmp2 : Bracket_Monomial := bm2;
! 150:
! 151: begin
! 152: if Length_Of(tmp1) /= Length_Of(tmp2)
! 153: then return false;
! 154: else while not Is_Null(tmp1) loop
! 155: if not Is_Equal(Head_Of(tmp1).all,Head_Of(tmp2).all)
! 156: then return false;
! 157: else tmp1 := Tail_Of(tmp1);
! 158: tmp2 := Tail_Of(tmp2);
! 159: end if;
! 160: end loop;
! 161: return true;
! 162: end if;
! 163: end Is_Equal;
! 164:
! 165: function "<" ( bm1,bm2 : Bracket_Monomial ) return boolean is
! 166:
! 167: tmp1 : Bracket_Monomial := bm1;
! 168: tmp2 : Bracket_Monomial := bm2;
! 169: lb1,lb2 : Link_to_Bracket;
! 170:
! 171: begin
! 172: while not Is_Null(tmp1) and not Is_Null(tmp2) loop
! 173: lb1 := Head_Of(tmp1); lb2 := Head_Of(tmp2);
! 174: if lb1.all < lb2.all
! 175: then return true;
! 176: elsif lb1.all > lb2.all
! 177: then return false;
! 178: else tmp1 := Tail_Of(tmp1); tmp2 := Tail_Of(tmp2);
! 179: end if;
! 180: end loop;
! 181: if Is_Null(tmp1) and not Is_Null(tmp2)
! 182: then return true;
! 183: else return false;
! 184: end if;
! 185: end "<";
! 186:
! 187: function ">" ( bm1,bm2 : Bracket_Monomial ) return boolean is
! 188:
! 189: tmp1 : Bracket_Monomial := bm1;
! 190: tmp2 : Bracket_Monomial := bm2;
! 191: lb1,lb2 : Link_to_Bracket;
! 192:
! 193: begin
! 194: while not Is_Null(tmp1) and not Is_Null(tmp2) loop
! 195: lb1 := Head_Of(tmp1); lb2 := Head_Of(tmp2);
! 196: if lb1.all > lb2.all
! 197: then return true;
! 198: elsif lb1.all < lb2.all
! 199: then return false;
! 200: else tmp1 := Tail_Of(tmp1); tmp2 := Tail_Of(tmp2);
! 201: end if;
! 202: end loop;
! 203: if Is_Null(tmp2) and not Is_Null(tmp1)
! 204: then return true;
! 205: else return false;
! 206: end if;
! 207: end ">";
! 208:
! 209: function Divisible ( bm : Bracket_Monomial; b : Bracket ) return boolean is
! 210:
! 211: tmp : Bracket_Monomial := bm;
! 212:
! 213: begin
! 214: while not Is_Null(tmp) loop
! 215: if Is_Equal(Head_Of(tmp).all,b)
! 216: then return true;
! 217: else tmp := Tail_Of(tmp);
! 218: end if;
! 219: end loop;
! 220: return false;
! 221: end Divisible;
! 222:
! 223: -- ITERATORS OVER THE BRACKETS :
! 224:
! 225: function Number_of_Brackets ( bm : Bracket_Monomial ) return natural is
! 226: begin
! 227: return Length_Of(bm);
! 228: end Number_of_Brackets;
! 229:
! 230: procedure Enumerate_Brackets ( bm : in Bracket_Monomial ) is
! 231:
! 232: tmp : Bracket_Monomial := bm;
! 233: continue : boolean := true;
! 234:
! 235: begin
! 236: while not Is_Null(tmp) loop
! 237: Process(Head_Of(tmp).all,continue);
! 238: exit when not continue;
! 239: tmp := Tail_Of(tmp);
! 240: end loop;
! 241: end Enumerate_Brackets;
! 242:
! 243: -- DESTRUCTOR :
! 244:
! 245: procedure Clear ( bm : in out Bracket_Monomial ) is
! 246:
! 247: tmp : Bracket_Monomial := bm;
! 248: lb : Link_to_Bracket;
! 249:
! 250: begin
! 251: while not Is_Null(tmp) loop
! 252: lb := Head_Of(tmp);
! 253: Clear(lb);
! 254: tmp := Tail_Of(tmp);
! 255: end loop;
! 256: Lists_of_Brackets.Clear(Lists_of_Brackets.List(bm));
! 257: end Clear;
! 258:
! 259: end Bracket_Monomials;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to bracket_monomials.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Schubert