Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Symmetry/symmetric_set_structure.adb, Revision 1.1
1.1 ! maekawa 1: with unchecked_deallocation;
! 2: with text_io,integer_io; use text_io,integer_io;
! 3: with Generic_Lists;
! 4: with Standard_Natural_Vectors; use Standard_Natural_Vectors;
! 5: with Standard_Natural_Vectors_io; use Standard_Natural_Vectors_io;
! 6: with Set_Structure; use Set_Structure;
! 7: with Permutations,Permute_Operations; use Permutations,Permute_Operations;
! 8: with Templates; use Templates;
! 9:
! 10: package body Symmetric_Set_Structure is
! 11:
! 12: -- DATASTRUCTURES :
! 13:
! 14: type set is array (natural range <>) of boolean;
! 15: type boolean_array is array (natural range <>) of boolean;
! 16: type link_to_boolean_array is access boolean_array;
! 17: procedure free is new unchecked_deallocation(boolean_array,
! 18: link_to_boolean_array);
! 19: type boolean_matrix is array (natural range <>) of link_to_boolean_array;
! 20: type link_to_boolean_matrix is access boolean_matrix;
! 21: procedure free is new unchecked_deallocation(boolean_matrix,
! 22: link_to_boolean_matrix);
! 23: type set_coord is record
! 24: k,l : natural;
! 25: end record;
! 26: type Dependency_Structure is array (natural range <>) of set_coord;
! 27: type Link_to_Dependency_Structure is access Dependency_Structure;
! 28: procedure free is new unchecked_deallocation(Dependency_Structure,
! 29: Link_to_Dependency_Structure);
! 30:
! 31: package Lists_of_Dependency_Structures
! 32: is new Generic_Lists (Link_to_Dependency_Structure);
! 33: type Covering is new Lists_of_Dependency_Structures.List;
! 34:
! 35: -- INTERNAL DATA :
! 36:
! 37: cov : Covering; -- covering of the set structure
! 38: lbm : link_to_boolean_matrix;
! 39: -- auxiliary data structure for bookeeping during the construction
! 40: -- of the covering,
! 41: -- to remember which sets have already been treated.
! 42:
! 43: -- AUXILIARY ROUTINES FOR CONSTRUCTING THE COVERING :
! 44:
! 45: function Give_Set ( n,i,j : natural ) return set is
! 46:
! 47: -- DESCRIPTION :
! 48: -- Returns the (i,j)-th set out of the set structure.
! 49:
! 50: s : set(1..n);
! 51:
! 52: begin
! 53: for k in 1..n loop
! 54: s(k) := Is_In(i,j,k);
! 55: end loop;
! 56: return s;
! 57: end Give_Set;
! 58:
! 59: function Equal ( s1,s2 : set ) return boolean is
! 60:
! 61: -- DESCRIPTION :
! 62: -- Returns true if both sets are equal.
! 63:
! 64: begin
! 65: for i in s1'range loop
! 66: if s1(i) /= s2(i)
! 67: then return false;
! 68: end if;
! 69: end loop;
! 70: return true;
! 71: end Equal;
! 72:
! 73: function Find ( i,n : natural; s : set ) return natural is
! 74:
! 75: -- DESCRIPTION :
! 76: -- Returns the first occurence of the set s in the i-th row
! 77: -- of the set structure;
! 78: -- returns zero if the set does not occur in the i-th row.
! 79:
! 80: begin
! 81: for j in 1..Number_Of_Sets(i) loop
! 82: if not lbm(i)(j) and then Equal(s,Give_Set(n,i,j))
! 83: then return j;
! 84: end if;
! 85: end loop;
! 86: return 0;
! 87: end Find;
! 88:
! 89: function Apply ( p : Permutation; s : set ) return set is
! 90:
! 91: -- DESCRIPTION :
! 92: -- Returns the result after application of p on the set s.
! 93:
! 94: r : set(s'range);
! 95: begin
! 96: for i in p'range loop
! 97: r(i) := s(p(i));
! 98: end loop;
! 99: return r;
! 100: end Apply;
! 101:
! 102: procedure Init_Covering ( n : in natural ) is
! 103:
! 104: -- DESCRIPTION :
! 105: -- Initialization of lbm.
! 106:
! 107: begin
! 108: lbm := new boolean_matrix(1..n);
! 109: for i in 1..n loop
! 110: lbm(i) := new boolean_array'(1..Number_of_Sets(i) => false);
! 111: end loop;
! 112: end Init_Covering;
! 113:
! 114: procedure Update ( dps : Dependency_Structure ) is
! 115:
! 116: -- DESCRIPTION :
! 117: -- All pairs in dps are marked in lbm.
! 118:
! 119: begin
! 120: for i in dps'range loop
! 121: lbm(dps(i).k)(dps(i).l) := true;
! 122: end loop;
! 123: end Update;
! 124:
! 125: procedure Search ( n : in natural; i,j : out natural;
! 126: empty : out boolean ) is
! 127:
! 128: -- DESCRIPTION :
! 129: -- Searches in lbm the first (i,j)-th free set;
! 130: -- returns empty if all sets have already been used.
! 131:
! 132: begin
! 133: for k in 1..n loop
! 134: for l in lbm(k)'range loop
! 135: if not lbm(k)(l)
! 136: then i := k; j := l; empty := false;
! 137: return;
! 138: end if;
! 139: end loop;
! 140: end loop;
! 141: empty := true;
! 142: end Search;
! 143:
! 144: -- CONSTRUCTOR FOR DEPENDENCY STRUCTURE AND COVERING :
! 145:
! 146: procedure Construct_Dependency_Structure
! 147: ( n,m : in natural; v,w : in List_Of_Permutations;
! 148: i,j : in natural; dps : in out Dependency_Structure;
! 149: fail : out boolean ) is
! 150:
! 151: -- DESCRIPTION :
! 152: -- A dependency structure will be constructed.
! 153:
! 154: -- ON ENTRY :
! 155: -- n the dimension;
! 156: -- m number of elements in dps,v and w;
! 157: -- v,w matrix representations;
! 158: -- i,j coordinates of a set in the dependency structure.
! 159:
! 160: -- ON RETURN :
! 161: -- dps the dependency structure;
! 162: -- fail is true if the set structure is not symmetric.
! 163:
! 164: s : set(1..n) := Give_Set(n,i,j);
! 165: lv,lw : List_Of_Permutations;
! 166: pv,pw : Permutation(1..n);
! 167: ps : set(1..n);
! 168: res : natural;
! 169:
! 170: begin
! 171: lv := v; lw := w;
! 172: for x in 1..m loop
! 173: pw := Permutation(Head_Of(lw).all);
! 174: dps(x).k := pw(i);
! 175: pv := Permutation(Head_Of(lv).all);
! 176: ps := Apply(pv,s);
! 177: res := Find(dps(x).k,n,ps);
! 178: exit when (res = 0);
! 179: dps(x).l := res;
! 180: lv := Tail_Of(lv);
! 181: lw := Tail_Of(lw);
! 182: end loop;
! 183: fail := (res = 0);
! 184: end Construct_Dependency_Structure;
! 185:
! 186: procedure Construct_Covering
! 187: ( n,m : in natural; v,w : in List_Of_Permutations;
! 188: fail : out boolean ) is
! 189:
! 190: -- DESCRIPTION :
! 191: -- A covering of the set structure will be constructed.
! 192:
! 193: -- EFFECT :
! 194: -- Initially, all entries in lbm are false;
! 195: -- at the end, all entries in lbm are true (if not fail).
! 196:
! 197: dps : Dependency_Structure(1..m);
! 198: ldps : Link_to_Dependency_Structure;
! 199: empty,fl : boolean;
! 200: i,j : natural;
! 201:
! 202: begin
! 203: Init_Covering(n);
! 204: Search(n,i,j,empty);
! 205: while not empty loop
! 206: Construct_Dependency_Structure(n,m,v,w,i,j,dps,fl);
! 207: exit when fl;
! 208: Update(dps);
! 209: ldps := new Dependency_Structure(1..m);
! 210: ldps.all := dps;
! 211: Construct(ldps,cov);
! 212: Search(n,i,j,empty);
! 213: end loop;
! 214: fail := fl;
! 215: end Construct_Covering;
! 216:
! 217: -- OUTPUT PROCEDURES FOR COVERING :
! 218:
! 219: procedure Write_Set ( n,i,j : natural ) is
! 220:
! 221: -- DESCRIPTION :
! 222: -- Writes the (i,j)-th set on the standard output.
! 223:
! 224: begin
! 225: put('{');
! 226: for k in 1..n loop
! 227: if Is_In(i,j,k)
! 228: then put(' '); put('x'); put(k,1);
! 229: end if;
! 230: end loop;
! 231: put(" }");
! 232: end Write_Set;
! 233:
! 234: procedure Write_Coord ( k,l : in natural ) is
! 235: begin
! 236: put('['); put(k,1); put(' '); put(l,1); put(']');
! 237: end Write_Coord;
! 238:
! 239: procedure Write_Covering is
! 240: tmp : Covering := cov;
! 241: ldps : Link_to_Dependency_Structure;
! 242: begin
! 243: put_line("The covering :");
! 244: while not Is_Null(tmp) loop
! 245: ldps := Head_Of(tmp);
! 246: declare
! 247: nb : natural := 0;
! 248: begin
! 249: for i in ldps'range loop
! 250: Write_Coord(ldps(i).k,ldps(i).l);
! 251: nb := nb+1;
! 252: if nb > 7
! 253: then new_line;
! 254: nb := 0;
! 255: end if;
! 256: end loop;
! 257: new_line;
! 258: end;
! 259: tmp := Tail_Of(tmp);
! 260: end loop;
! 261: end Write_Covering;
! 262:
! 263: procedure Write_Coord ( file : in file_type; k,l : in natural ) is
! 264: begin
! 265: put(file,'['); put(file,k,1); put(file,' '); put(file,l,1); put(file,']');
! 266: end Write_Coord;
! 267:
! 268: procedure Write_Covering ( file : in file_type ) is
! 269: tmp : Covering := cov;
! 270: ldps : Link_to_Dependency_Structure;
! 271: begin
! 272: put_line(file,"The covering :");
! 273: while not Is_Null(tmp) loop
! 274: ldps := Head_Of(tmp);
! 275: declare
! 276: nb : natural := 0;
! 277: begin
! 278: for i in ldps'range loop
! 279: Write_Coord(file,ldps(i).k,ldps(i).l);
! 280: nb := nb+1;
! 281: if nb > 7
! 282: then new_line(file);
! 283: nb := 0;
! 284: end if;
! 285: end loop;
! 286: new_line(file);
! 287: end;
! 288: tmp := Tail_Of(tmp);
! 289: end loop;
! 290: end Write_Covering;
! 291:
! 292: -- CONSTRUCTION OF TEMPLATES :
! 293:
! 294: procedure Init_Template ( n : in natural ) is
! 295:
! 296: -- DESCRIPTION :
! 297: -- Initialization of the template.
! 298:
! 299: h : Standard_Natural_Vectors.Vector(0..n) := (0..n => 0);
! 300:
! 301: begin
! 302: Templates.Create(n);
! 303: for i in 1..n loop
! 304: for j in 1..Number_Of_Sets(i) loop
! 305: Templates.Add_Hyperplane(i,h);
! 306: end loop;
! 307: end loop;
! 308: end Init_Template;
! 309:
! 310: procedure First_Equivariant_Template
! 311: ( n : in natural; cnt : in out natural ) is
! 312:
! 313: -- DESCRIPTION :
! 314: -- Constructs the first equation of the template, for an equivariant
! 315: -- linear product system system
! 316:
! 317: -- ON ENTRY :
! 318: -- n the dimension;
! 319: -- cnt counts the number of free coefficients.
! 320:
! 321: h : Standard_Natural_Vectors.Vector(0..n);
! 322:
! 323: begin
! 324: for j in 1..Templates.Number_of_Hyperplanes(1) loop
! 325: Templates.Get_Hyperplane(1,j,h);
! 326: cnt := cnt + 1; h(0) := cnt;
! 327: for k in 1..n loop
! 328: if Set_Structure.Is_In(1,j,k)
! 329: then if cnt = h(0)
! 330: then cnt := cnt + 1;
! 331: end if;
! 332: h(k) := cnt;
! 333: end if;
! 334: end loop;
! 335: Templates.Change_Hyperplane(1,j,h);
! 336: end loop;
! 337: end First_Equivariant_Template;
! 338:
! 339: function Action ( i,n : natural ; g : List_of_Permutations )
! 340: return Permutation is
! 341:
! 342: -- DESCRIPTION :
! 343: -- Returns the group action from the list g that permutes the first
! 344: -- array of sets into the ith one.
! 345:
! 346: p : Permutation(1..n);
! 347: first,second : Standard_Natural_Vectors.Vector(1..n);
! 348: tmp : List_of_Permutations := g;
! 349:
! 350: begin
! 351: for k in 1..n loop
! 352: if Set_Structure.Is_In(1,1,k)
! 353: then first(k) := 1;
! 354: else first(k) := 0;
! 355: end if;
! 356: if Set_Structure.Is_In(i,1,k)
! 357: then second(k) := 1;
! 358: else second(k) := 0;
! 359: end if;
! 360: end loop;
! 361: while not Is_Null(tmp) loop
! 362: p := Permutation(Head_Of(tmp).all);
! 363: if second = p*first
! 364: then return p;
! 365: end if;
! 366: tmp := Tail_Of(tmp);
! 367: end loop;
! 368: p := (p'range => 0);
! 369: return p;
! 370: end Action;
! 371:
! 372: procedure Propagate_Equivariant_Template
! 373: ( n : in natural; g : in List_of_Permutations;
! 374: fail : out boolean ) is
! 375:
! 376: -- DESCRIPTION :
! 377: -- Given a template whose first equation is already constructed,
! 378: -- the rest of the template will be constructed, with the aid of the
! 379: -- list of generating permutations.
! 380:
! 381: h : Standard_Natural_Vectors.Vector(0..n);
! 382: p : Permutation(1..n);
! 383:
! 384: begin
! 385: for i in 2..n loop
! 386: p := Action(i,n,g);
! 387: if p = (p'range => 0)
! 388: then fail := true; return;
! 389: end if;
! 390: for j in 1..Templates.Number_of_Hyperplanes(i) loop
! 391: Templates.Get_Hyperplane(1,j,h);
! 392: h(1..n) := p*h(1..n);
! 393: Templates.Change_Hyperplane(i,j,h);
! 394: end loop;
! 395: end loop;
! 396: fail := false;
! 397: end Propagate_Equivariant_Template;
! 398:
! 399: procedure Construct_Part_of_Template
! 400: ( n,m : in natural; v : in List_Of_Permutations;
! 401: dps : in Dependency_Structure; invpv1 : in Permutation;
! 402: cnt : in out natural ) is
! 403:
! 404: -- DESCRIPTION :
! 405: -- This procedure constructs the coefficients of the hyperplanes
! 406: -- associated with the sets in the dependency structure dps.
! 407: -- cnt counts the number of free coefficients.
! 408:
! 409: lv : List_Of_Permutations;
! 410: pv : Permutation(1..n);
! 411: h : Standard_Natural_Vectors.Vector(0..n);
! 412: indi : natural;
! 413:
! 414: begin
! 415: -- GENERATE CONSTANT COEFFICIENT :
! 416: cnt := cnt+1;
! 417: for j in 1..m loop
! 418: Templates.Get_Hyperplane(dps(j).k,dps(j).l,h);
! 419: h(0) := cnt;
! 420: Templates.Change_Hyperplane(dps(j).k,dps(j).l,h);
! 421: end loop;
! 422: -- GENERATE THE OTHER COEFFICIENTS :
! 423: for i in 1..n loop
! 424: -- GENERATE :
! 425: if Is_In(dps(1).k,dps(1).l,i)
! 426: then Templates.Get_Hyperplane(dps(1).k,dps(1).l,h);
! 427: if h(i) = 0
! 428: then cnt := cnt + 1;
! 429: -- PROPAGATE :
! 430: --put("PROPAGATING "); put(i,1);
! 431: --put_line("-th coefficient :");
! 432: lv := v;
! 433: for j in 1..m loop
! 434: pv := Permutation(Head_Of(lv).all);
! 435: indi := 0;
! 436: for l in 1..n loop
! 437: if pv(l) = invpv1(i)
! 438: then indi := l;
! 439: exit;
! 440: end if;
! 441: end loop;
! 442: --Write_Coord(dps(j).k,dps(j).l); put(" : ");
! 443: --Write_Set(n,dps(j).k,dps(j).l);
! 444: --put(" indi : "); put(indi,1); new_line;
! 445: Templates.Get_Hyperplane(dps(j).k,dps(j).l,h);
! 446: h(indi) := cnt;
! 447: Templates.Change_Hyperplane(dps(j).k,dps(j).l,h);
! 448: lv := Tail_Of(lv);
! 449: end loop;
! 450: --put_line("RANDOM PRODUCT SYSTEM AFTER PROPAGATION :");
! 451: --Write_RPS(n,2,4,3);
! 452: --for l in 1..75 loop put("+"); end loop; new_line;
! 453: end if;
! 454: end if;
! 455: end loop;
! 456: end Construct_Part_of_Template;
! 457:
! 458: procedure Construct_Template
! 459: ( n,m : in natural; v : in List_Of_Permutations;
! 460: nbfree : out natural ) is
! 461:
! 462: -- DESCRIPTION :
! 463: -- Given a covering of the set structure,
! 464: -- the data of the package Random_Product_System will be filled.
! 465:
! 466: -- ON ENTRY :
! 467: -- n the dimension of the vectors
! 468: -- m the number of entries in v
! 469: -- v matrix representations of the group
! 470:
! 471: -- ON RETURN :
! 472: -- nbfree the number of free coefficients
! 473:
! 474: tmp : Covering := cov;
! 475: ldps : Link_to_Dependency_Structure;
! 476: invpv1 : Permutation(1..n);
! 477: cnt : natural;
! 478:
! 479: begin
! 480: Init_Template(n);
! 481: cnt := 0;
! 482: -- CONSTRUCT THE BASE SET OF dps :
! 483: invpv1 := inv(Permutation(Head_Of(v).all));
! 484: -- then for each pv in v: permutation of the base set
! 485: -- is defined as pv*invpv1.
! 486: --put("invpv1 : "); Put(invpv1); new_line;
! 487: while not Is_Null(tmp) loop
! 488: ldps := Head_Of(tmp);
! 489: Construct_Part_of_Template(n,m,v,ldps.all,invpv1,cnt);
! 490: tmp := Tail_Of(tmp);
! 491: end loop;
! 492: nbfree := cnt;
! 493: end Construct_Template;
! 494:
! 495: procedure Construct_Equivariant_Template
! 496: ( n : in natural; g : in List_of_Permutations;
! 497: cntfree : in out natural; fail : out boolean ) is
! 498:
! 499: -- DESCRIPTION :
! 500: -- Constructs a template for an equivariant system. The list g contains
! 501: -- the generating elements of the group. The variable cntfree counts the
! 502: -- number of free coefficients.
! 503:
! 504: begin
! 505: Init_Template(n);
! 506: First_Equivariant_Template(n,cntfree);
! 507: Propagate_Equivariant_Template(n,g,fail);
! 508: end Construct_Equivariant_Template;
! 509:
! 510: procedure Write_Templates ( n : in natural ) is
! 511: begin
! 512: Write_Templates(Standard_Output,n);
! 513: end Write_Templates;
! 514:
! 515: procedure Write_Templates ( file : in file_type; n : in natural ) is
! 516:
! 517: h : Standard_Natural_Vectors.Vector(0..n);
! 518:
! 519: begin
! 520: put_line(file,"The templates :");
! 521: for i in 1..n loop
! 522: for j in 1..Number_of_Hyperplanes(i) loop
! 523: put(file,"("); put(file,i,1); put(file,","); put(file,j,1);
! 524: put(file,") : "); Get_Hyperplane(i,j,h); put(file,h); new_line(file);
! 525: end loop;
! 526: end loop;
! 527: end Write_Templates;
! 528:
! 529: -- CONSTRUCTION OF START SYSTEMS :
! 530:
! 531: procedure Equivariant_Start_System
! 532: ( n : in natural; g : in List_of_Permutations;
! 533: fail : out boolean ) is
! 534:
! 535: nbfree : natural := 0;
! 536: fl : boolean := false;
! 537:
! 538: begin
! 539: Construct_Equivariant_Template(n,g,nbfree,fl);
! 540: if not fl
! 541: then Templates.Polynomial_System(n,nbfree);
! 542: end if;
! 543: fail := fl;
! 544: end Equivariant_Start_System;
! 545:
! 546: procedure Symmetric_Start_System
! 547: ( n,bb : in natural; lp : in List;
! 548: v,w : in List_Of_Permutations;
! 549: notsymmetric,degenerate : out boolean ) is
! 550:
! 551: m : natural := Number(v);
! 552: fl : boolean;
! 553: nbfree : natural;
! 554:
! 555: begin
! 556: Construct_Covering(n,m,v,w,fl);
! 557: -- Write_Covering;
! 558: for i in lbm'range loop
! 559: free(lbm(i));
! 560: end loop;
! 561: free(lbm);
! 562: if fl
! 563: then notsymmetric := true;
! 564: -- put_line("The set structure is not (G,V,W)-symmetric.");
! 565: else notsymmetric := false;
! 566: -- put_line("The set structure is (G,V,W)-symmetric.");
! 567: -- Templates.Create(n);
! 568: Construct_Template(n,m,v,nbfree);
! 569: -- Write_Templates(n);
! 570: -- vb := Templates.Verify(n,lp);
! 571: -- put("The bound of Templates.Verify : "); put(vb,1); new_line;
! 572: -- if bb /= vb
! 573: -- then degenerate := true;
! 574: -- put_line("The set structure is degenerate.");
! 575: -- else
! 576: degenerate := false;
! 577: -- put_line("The set structure is not degenerate.");
! 578: Templates.Polynomial_System(n,nbfree);
! 579: -- end if;
! 580: end if;
! 581: end Symmetric_Start_System;
! 582:
! 583: -- DESTRUCTOR :
! 584:
! 585: procedure Clear is
! 586:
! 587: use Lists_of_Dependency_Structures;
! 588: tmp : Covering := cov;
! 589: elem : Link_to_Dependency_Structure;
! 590:
! 591: begin
! 592: while not Is_Null(tmp) loop
! 593: elem := Head_Of(tmp);
! 594: free(elem);
! 595: tmp := Tail_Of(tmp);
! 596: end loop;
! 597: Clear(cov);
! 598: Templates.Clear;
! 599: end Clear;
! 600:
! 601: end Symmetric_Set_Structure;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to symmetric_set_structure.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Root_Counts / Symmetry