Annotation of OpenXM_contrib/PHC/Ada/Root_Counts/Symmetry/symmetric_set_structure.adb, Revision 1.1.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