1 /* SYMMETRICA perm.c */
2 #include "def.h"
3 #include "macro.h"
4
5 static struct permutation * callocpermutation();
6 /* static INT free_permutation(); */
7 static INT co_div_040989();
8 static INT co040989();
9 static INT mem_counter_perm;
10 static OP old_kranz_tafel; /* speichert letzte kranztafel */
11 static INT co_120194();
12 static INT co_120194_1();
13 static INT co_co();
14 static INT co_co_2();
15 #define CPT(typ,text,a) CTO(PERMUTATION,text,a);if (S_P_K(a) != typ) \
16 fprintf(stderr,\
17 "wrong typ of permutation in %s\n typ should be %ld and it was %ld\n "\
18 ,text,typ,S_O_K(a));
19 #define CPTT(typ,typ2,text,a) CTO(PERMUTATION,text,a);if \
20 ((S_P_K(a) != typ)&&(S_P_K(a) != typ2)) \
21 fprintf(stderr,\
22 "wrong typ of permutation in %s\n typ should be %ld or %ld and it was %ld\n "\
23 ,text,typ,typ2,S_O_K(a));
24
25
26 #ifdef PERMTRUE
unrank_permutation(a,b)27 INT unrank_permutation(a,b) OP a,b;
28 /* AK 140597 */
29 /* AK 151104 V3.0 */
30 {
31 INT erg = OK;
32 CTTO(INTEGER, LONGINT, "unrank_permutation(1)",a);
33 {
34 OP c,d;
35 /* get the degree */
36 CALLOCOBJECT2(c,d);
37 M_I_I((INT)1, d);
38 again:
39 erg += fakul(d,c);
40 if (lt(c,a) ) { INC(c); goto again; }
41 DEC(c);
42 erg += unrank_degree_permutation(a,c,b);
43 FREEALL2(c,d);
44 }
45 ENDR("unrank_permutation");
46 }
47
unrank_degree_permutation(a,c,b)48 INT unrank_degree_permutation(a,c,b) OP a,c,b;
49 /* AK 200597 */
50 /* AK 151104 V3.0 */
51 {
52 INT erg = OK;
53 CTTO(INTEGER,LONGINT,"unrank_degree_permutation(1)",a);
54 CTO(INTEGER,"unrank_degree_permutation(2)",c);
55 {
56 INT i;
57 OP d,e,f,g;
58 CALLOCOBJECT4(d,e,f,g);
59
60 erg += m_l_v(c,d);
61 COPY(c,e);
62 COPY(a,g);
63 for (i=0;i<S_V_LI(d);i++)
64 {
65 DEC(e);
66 erg += fakul(e,f);
67 erg += quores(g,f,S_V_I(d,i),g);
68 }
69 FREEALL3(e,f,g);
70 erg += lehmercode(d,b);
71 FREEALL(d);
72 }
73 ENDR("unrank_degree_permutation");
74 }
75
rank_permutation(a,b)76 INT rank_permutation(a,b) OP a,b;
77 /* AK 160295 */
78 /* a and b may be equal */
79 /* result is integer >= 0 */
80 /* AK 151104 V3.0 */
81
82 {
83 INT erg = OK;
84 CTO(PERMUTATION,"rank_permutation",a);
85 CPT(VECTOR,"rank_permutation",a);
86 {
87 OP f,c,d;
88 INT i,j;
89 CALLOCOBJECT3(c,d,f);
90 erg += lehmercode(a,f);
91 erg += m_i_i(0L,b);
92 for (i=0,j=S_P_LI(a);i<S_P_LI(a);j--,i++)
93 {
94 erg += m_i_i(j-1,d);
95 erg += fakul(d,c);
96 MULT_APPLY(S_V_I(f,i),c);
97 ADD_APPLY(c,b);
98 }
99 erg += t_longint_int(b,b);
100 FREEALL3(c,d,f);
101 }
102 ENDR("rank_permutation");
103 }
104
perm_anfang()105 INT perm_anfang()
106 /* AK 100893 */
107 /* AK 110804 V3.0 */
108 {
109 INT erg = OK;
110 {
111 old_kranz_tafel=CALLOCOBJECT();
112 mem_counter_perm=0L;
113 }
114 ENDR("perm_anfang");
115 }
116
117 static OP next_perm_v = NULL;
118 static OP zykeltyp_perm_v = NULL;
perm_ende()119 INT perm_ende()
120 /* AK 100893 */
121 {
122 INT erg = OK;
123 erg += freeall(old_kranz_tafel);
124 if (mem_counter_perm != 0L)
125 {
126 fprintf(stderr, "mem_counter_perm = %" PRIINT "\n" ,mem_counter_perm);
127 erg += error("permutation memory not freed");
128 }
129 if (next_perm_v != NULL)
130 {
131 erg += freeall(next_perm_v);
132 next_perm_v = NULL;
133 }
134 if (zykeltyp_perm_v != NULL)
135 {
136 erg += freeall(zykeltyp_perm_v);
137 zykeltyp_perm_v = NULL;
138 }
139 return erg;
140 }
141
even_permutation(a)142 INT even_permutation(a) OP a;
143 /* AK 010692 */
144 {
145 INT erg;
146 OP c;
147 c = callocobject();
148 numberof_inversionen(a,c);
149 erg = even(c);
150 freeall(c);
151 return erg;
152 }
153 #endif /* PERMTRUE */
154
permutationp(a)155 INT permutationp(a) OP a;
156 /* AK 150891 V1.3 */
157 {
158 if (S_O_K(a) != PERMUTATION) return FALSE;
159 else return TRUE;
160 }
161
162 #ifdef PERMTRUE
163 #ifdef MATRIXTRUE
164
diagramm_permutation(perm,mat)165 INT diagramm_permutation(perm,mat) OP perm,mat;
166 /* 0 at the position i,perm[i] */
167 /* else empty object */
168 /* AK 010988 */ /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
169 /* AK 060704 V3.0 */
170 {
171 INT erg = OK;
172 CPT(VECTOR,"diagramm_permutation(1)",perm);
173 CE2(perm,mat,diagramm_permutation);
174
175 {
176 INT i,j;
177 OP l,h;
178
179 l=CALLOCOBJECT();
180 h=CALLOCOBJECT();
181
182 COPY_INTEGER(S_P_L(perm),h);
183 COPY_INTEGER(S_P_L(perm),l);
184 erg += b_lh_m(l,h,mat);
185
186 /* but the 0 at the right position */
187 for (i=0L, j= S_P_LI(perm)-1;i<S_P_LI(perm);i++,j--)
188 M_I_I(0,S_M_IJ(mat,j,S_P_II(perm,i)-1));
189
190 }
191 CTO(MATRIX,"diagramm_permutation(2e)",mat);
192 ENDR("diagramm_permutation");
193 }
194 #endif /* MATRIXTRUE */
195
196 #ifdef TABLEAUXTRUE
red_dia_perm(p,e)197 INT red_dia_perm(p,e) OP p,e;
198 /* ein allgemeines tableau zu der perm */
199 /* AK 010988 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
200 {
201 INT i,j,k,m;
202
203 diagramm_permutation(p,e);
204 for (j=0L;j<S_M_LI(e); j++)
205 {
206 k=j+1;
207 for (i=S_M_HI(e)-1;i>=0 ; i--)
208 {
209 if (EMPTYP(S_M_IJ(e,i,j)))
210 {
211 M_I_I(k,S_M_IJ(e,i,j)) ;
212 k++;
213 }
214 else if (S_M_IJI(e,i,j) == -1L) freeself(S_M_IJ(e,i,j));
215 else if (S_M_IJI(e,i,j) == 0L)
216 {
217 freeself(S_M_IJ(e,i,j));
218 for (m=j+1; m<S_M_LI(e);m++)
219 M_I_I(-1L,S_M_IJ(e,i,m));
220 for (m=i-1; m>=0 ; m--)
221 if (not EMPTYP(S_M_IJ(e,m,j)))
222 if (S_M_IJI(e,m,j) == -1L)
223 freeself(S_M_IJ(e,m,j));
224 break;
225 }
226 else return error("red_dia_perm:wrong content");
227 }
228 }
229 return(OK);
230 }
231
232
233
first_tab_perm(a,c)234 INT first_tab_perm(a,c) OP a,c;
235 /* AK 010988 */ /* das erste tableau */ /* AK 151289 V1.1 */
236 /* AK 150891 V1.3 */
237 {
238 OP b;
239 INT erg = OK;
240 CTO(PERMUTATION,"first_tab_perm(1)",a);
241 b = callocobject();
242 erg += red_dia_perm(a,b);
243 erg += fill_left_down_matrix(b);
244 erg += m_matrix_tableaux(b,c);
245 ENDR("first_tab_perm");
246 }
247 #endif /* TABLEAUXTRUE */
248
fill_left_down_matrix(b)249 INT fill_left_down_matrix(b) OP b;
250 /* AK 060988 */
251 /* schiebt inhalt einer matrix nach links, dann nach unten,
252 sofern dieser inhalt integer zahlen */
253 /* AK 051289 V1.1 */ /* AK 150891 V1.3 */
254 {
255 INT i,j,k,l,m;
256 for (i=S_M_HI(b)-1; i>=0L; i--)
257 {
258 k=0L;
259 for (j=0L;j<S_M_LI(b); j++)
260 if (not EMPTYP(S_M_IJ(b,i,j)))
261 {
262 m=S_M_IJI(b,i,j);
263 /* der zu verschiebende eintrag */
264 /* k ist die spalte in der der
265 eintrag hinkommt */
266 freeself(S_M_IJ(b,i,j));
267 for (l=S_M_HI(b)-1; l>=0L; l--)
268 if (EMPTYP(S_M_IJ(b,l,k))) break;
269 /* l ist die zeile in der der
270 eintrag hinkommt */
271 M_I_I(m,S_M_IJ(b,l,k));
272 k++;
273 }
274
275 }
276 return(OK);
277 }
278
279
280 #ifdef POLYTRUE
divideddiff_rz(rzt,poly,ergebnis)281 INT divideddiff_rz(rzt,poly,ergebnis) OP rzt, poly, ergebnis;
282 /* 270887 zur berechnung des ergebnis des operators delta bei
283 anwendung auf das polynom poly */
284 /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
285 {
286 INT i = 0 ;
287 INT erg = OK;
288 CTO(POLYNOM,"divideddiff_rz",poly);
289 CE3(rzt,poly,ergebnis,divideddiff_rz);
290
291 erg += copy_polynom(poly,ergebnis);
292
293 if (EMPTYP(rzt))
294 goto endr_ende;
295
296 while (i < S_V_LI(rzt))
297 {
298 erg += divideddifference(S_V_I(rzt,i),ergebnis,ergebnis);
299 i++;
300 };
301 ENDR("divideddiff_rz");
302 }
303
304
max_divideddiff(n,poly,e)305 INT max_divideddiff(n,poly,e) OP n,poly,e;
306 /* applies the maximal permutation */
307 /* AK 180291 V1.2 */ /* AK 150891 V1.3 */
308 {
309 OP p = callocobject();
310 INT erg=OK;
311
312 if ((erg=last_permutation(n,p)) != OK) goto md1;
313 if ((erg=divideddiff_permutation(p,poly,e)) != OK) goto md1;
314 md1:
315 freeall(p);
316 return erg;
317 }
318
319
divideddiff_permutation(perm,poly,c)320 INT divideddiff_permutation(perm,poly,c) OP perm,poly,c;
321 /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150591 V1.2 */
322 /* AK 150891 V1.3 */
323 {
324 OP rzt;
325 INT erg = OK;
326
327 CTO(PERMUTATION,"divideddiff_permutation",perm);
328
329 rzt = callocobject();
330 erg += rz_perm(perm,rzt);
331 erg += divideddiff_rz(rzt,poly,c);
332 erg += freeall(rzt);
333 ENDR("divideddiff_permutation");
334 }
335
divideddiff_lc(lc,poly,c)336 INT divideddiff_lc(lc,poly,c) OP lc,poly,c;
337 /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
338 {
339 INT erg = OK; /* AK 020392 */
340 OP rzt;
341 CTTO(INTEGERVECTOR,VECTOR,"divideddiff_lc(1)",lc);
342 CTO(POLYNOM,"divideddiff_lc(2)",poly);
343
344 rzt = callocobject();
345 erg += rz_lehmercode(lc,rzt);
346 erg += divideddiff_rz(rzt,poly,c);
347 erg += freeall(rzt);
348 ENDR("divideddiff_lc");
349 }
350
divdiff(a,b,c)351 INT divdiff(a,b,c) OP a,b,c;
352 /* AK 180393 */
353 {
354 INT erg = OK;
355 COP("divdiff(1)",a);
356 COP("divdiff(2)",b);
357 COP("divdiff(3)",c);
358 CE3(a,b,c,divdiff);
359
360 switch(S_O_K(a))
361 {
362 case INTEGER:
363 switch(S_O_K(b))
364 {
365 case POLYNOM:
366 erg += divideddifference(a,b,c);
367 break;
368 #ifdef SCHUBERTTRUE
369 case SCHUBERT:
370 erg += divdiff_schubert(a,b,c);
371 break;
372 #endif
373 default:
374 erg += WTT("divdiff",a,b);
375 break;
376 };
377 break;
378 case PERMUTATION:
379 if (S_P_K(a) == VECTOR)
380 {
381 switch(S_O_K(b))
382
383 {
384 case POLYNOM:
385 erg += divideddiff_permutation(a,b,c);
386 break;
387 #ifdef SCHUBERTTRUE
388 case SCHUBERT:
389 erg += divdiff_perm_schubert(a,b,c);
390 break;
391 #endif
392 default:
393 erg += WTT("divdiff",a,b);
394 break;
395 };
396 break;
397 }
398 if (S_P_K(a) == BAR)
399 {
400 switch(S_O_K(b))
401
402 {
403 case POLYNOM:
404 erg += divdiff_bar(a,b,c);
405 break;
406 };
407 break;
408 }
409 default:
410 erg += WTT("divdiff",a,b);
411 break;
412 }
413 ENDR("divdiff");
414 }
415
416
417
divideddifference(i,poly,c)418 INT divideddifference(i,poly,c) OP i,poly,c;
419 /* AK 270887
420 zur berechnung des ergebnis des operators delta_i bei
421 anwendung auf das polynom poly */
422 /* AK 110789 V1.0 */ /* AK 151289 V1.1 */ /* AK 150891 V1.3 */
423 {
424
425 OP zeiger, zwischen;
426 INT index,j,k, expo1, expo2 ,erg = OK;
427
428 CTO(INTEGER,"divideddifference(1)",i);
429 CTO(POLYNOM,"divideddifference(2)",poly);
430 index = S_I_I(i) -1L;
431 SYMCHECK(index < 0, "divideddifference:index < 1");
432 CE3(i,poly,c,divideddifference);
433
434
435 init(POLYNOM,c);
436
437 if (EMPTYP(poly))
438 goto rr;
439 if (S_L_S(poly) == NULL) /* AK 040392 */
440 {
441 erg += copy(poly,c);
442 goto rr;
443 }
444
445 zwischen = callocobject();
446 zeiger = poly;
447 while (zeiger != NULL)
448 {
449 if (S_L_S(zeiger) == NULL)
450 {
451 error("divideddifference:self == NULL");
452 erg += ERROR;
453 goto rr;
454 }
455 if (not VECTORP(S_PO_S(zeiger)))
456 {
457 printobjectkind(S_PO_S(zeiger));
458 error("kind != VECTOR in divideddifference");
459 erg += ERROR;
460 goto rr;
461 };
462
463 if (S_I_I(i) == S_PO_SLI(zeiger))
464 /* operiert auf letzten exponenten */
465 {
466 erg += inc(S_PO_S(zeiger));
467 M_I_I(0L,S_PO_SI(zeiger,S_I_I(i)));
468 }
469 else if (S_I_I(i) > S_PO_SLI(zeiger)) goto dividedend;
470 expo1 = S_PO_SII(zeiger,index);
471 expo2 = S_PO_SII(zeiger,index + 1L);
472 if (expo1 > expo2)
473 {
474 for (j=expo1-1L,k=expo2 ;j>= expo2; j--,k++)
475 {
476 erg += b_skn_po(callocobject(),callocobject(),NULL,zwischen);
477 erg += copy(S_PO_S(zeiger),S_PO_S(zwischen));
478 erg += copy(S_PO_K(zeiger),S_PO_K(zwischen));
479 M_I_I(j,S_PO_SI(zwischen,index));
480 M_I_I(k,S_PO_SI(zwischen,index+1L));
481 erg += add_apply(zwischen,c);
482 erg += freeself(zwischen);
483 };
484 }
485 else if (expo1 < expo2)
486 {
487 for (j=expo2-1L,k=expo1 ;j>= expo1; j--,k++)
488 {
489 erg += b_skn_po(callocobject(),callocobject(),NULL,zwischen);
490 COPY(S_PO_S(zeiger),S_PO_S(zwischen));
491 erg += addinvers(S_PO_K(zeiger),S_PO_K(zwischen));
492 M_I_I(j,S_PO_SI(zwischen,index));
493 M_I_I(k,S_PO_SI(zwischen,index+1));
494 erg += add_apply(zwischen,c);
495 erg += freeself(zwischen);
496 }
497 };
498 dividedend:
499 zeiger = S_PO_N(zeiger);
500 };
501 FREEALL(zwischen);
502 rr:
503 ENDR("divideddifference");
504 }
505 #endif /* POLYTRUE */
506
507 #endif /* PERMTRUE */
508
509 #ifdef KRANZTRUE
510
s_kr_g(a)511 OP s_kr_g(a) OP a;
512 /* select_kranz_grobpermutation */
513 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
514 /* AK 110804 V3.0 */
515 {
516 INT erg = OK;
517 CTO(KRANZ,"s_kr_g(1)",a);
518 {
519 return(s_v_i(a,0L));
520 }
521 ENDO("s_kr_g");
522 }
523
s_kr_v(a)524 OP s_kr_v(a) OP a;
525 /* select_kranz_vector */
526 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
527 {
528 return(s_v_i(a,1L));
529 }
530
c_kr_g(a,b)531 INT c_kr_g(a,b) OP a,b;
532 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
533 {
534 return(c_v_i(a,0L,b));
535 }
536
c_kr_v(a,b)537 INT c_kr_v(a,b) OP a,b;
538 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
539 {
540 return(c_v_i(a,1L,b));
541 }
542
s_kr_i(a,i)543 OP s_kr_i(a,i) OP a; INT i;
544 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
545 {
546 return(s_v_i(s_kr_v(a),i));
547 }
548
s_kr_gli(a)549 INT s_kr_gli(a) OP a;
550 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
551 {
552 return(s_p_li(s_kr_g(a)));
553 }
554
s_kr_gi(a,i)555 OP s_kr_gi(a,i) OP a; INT i;
556 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
557 /* AK 200804 V3.0 */
558 {
559 INT erg = OK;
560 CTO(KRANZ,"s_kr_gi(1)",a);
561 SYMCHECK(i<0,"s_kr_gi(2)<0");
562 {
563 return s_p_i(s_kr_g(a),i);
564 }
565 ENDO("s_kr_gi");
566 }
567
568
s_kr_gl(a)569 OP s_kr_gl(a) OP a;
570 /* AK 170889 V1.1 */ /* AK 150891 V1.3 */
571 {
572 return(s_p_l(s_kr_g(a)));
573 }
574
init_kranz(a)575 INT init_kranz(a) OP a;
576 /* AK Fri Jan 27 12:29:38 MEZ 1989 */
577 /* AK 150891 V1.3 */
578 /* AK 110804 V3.0 */
579 {
580 init(VECTOR,a);
581 m_il_v(2L,a);
582 C_O_K(a,KRANZ);
583 return(OK);
584 }
585
b_perm_vector_kranz(p,v,a)586 INT b_perm_vector_kranz(p,v,a) OP p,v,a;
587 /* dies initialisiert eine kranz product struktur */
588 /* ein vector aus 2 teilen
589 wobei der erste eintrag ein eine permutation aus der s_n
590 der zweite eintrag ein vector von n eintraegen
591 */
592 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
593 {
594 INT erg = OK;
595 CTO(PERMUTATION,"b_perm_vector_kranz(1)",p);
596 CTO(VECTOR,"b_perm_vector_kranz(2)",v);
597 {
598 erg += init(KRANZ,a);
599 c_kr_g(a,p);
600 c_kr_v(a,v);
601 }
602 ENDR("b_perm_vector_kranz");
603 }
604
random_kranz(gn,vn,a)605 INT random_kranz(gn,vn,a) OP gn,vn,a;
606 /* random element of kranz produkt */
607 /* AK 120804 V3.0 */
608 {
609 INT erg = OK;
610 CTO(INTEGER,"random_kranz(1)",gn);
611 SYMCHECK(S_I_I(gn)<1,"random_kranz(1)<1");
612 CTO(INTEGER,"random_kranz(2)",vn);
613 SYMCHECK(S_I_I(vn)<1,"random_kranz(2)<1");
614 CE3(gn,vn,a,random_kranz);
615 {
616 INT i;
617 erg += init_kranz(a);
618 erg += random_permutation(gn,S_KR_G(a));
619 erg += m_l_v(gn,S_KR_V(a));
620 for (i=0;i<S_I_I(gn);i++)
621 erg += random_permutation(vn,S_KR_I(a,i));
622 }
623 ENDR("random_kranz");
624 }
625
scan_kranz(a)626 INT scan_kranz(a) OP a;
627 /* AK 151289 V1.1 */ /* AK 150891 V1.3 */
628 {
629 INT i;
630 INT erg = OK;
631 CTO(EMPTY,"scan_kranz(1)",a);
632 init(KRANZ,a);
633
634 printeingabe("input of the element of the wreath product of two");
635 printeingabe("symmetric groups");
636 printeingabe("input of the base permutation");
637 scan(PERMUTATION,s_kr_g(a));
638 erg += m_il_v(s_kr_gli(a),s_kr_v(a));
639 for (i=0L;i<s_kr_gli(a);i++)
640 {
641 printf("input of the %ld. permutation permuted by the base permutation\n",i+1L);
642 scan(PERMUTATION,s_kr_i(a,i));
643 }
644 ENDR("scan_kranz");
645 }
646
mult_kranz_kranz(a,b,c)647 INT mult_kranz_kranz(a,b,c) OP a,b,c;
648 /* AK Fri Jan 27 14:13:14 MEZ 1989 */
649 /* multipliziert zwei elemente eines kranzprodukts */
650 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
651 /* AK 120804 V3.0 */
652 {
653 INT erg = OK;
654 CTO(KRANZ,"mult_kranz_kranz(1)",a);
655 CTO(KRANZ,"mult_kranz_kranz(2)",b);
656 CTO(EMPTY,"mult_kranz_kranz(3)",c);
657 {
658 erg += init(KRANZ,c);
659 MULT(S_KR_G(a),S_KR_G(b),S_KR_G(c));
660 /* grobperm. werden normal multipliziert */
661 erg += operate_perm_vector(S_KR_G(b),S_KR_V(a),S_KR_V(c));
662 erg += mult(S_KR_V(c),S_KR_V(b),S_KR_V(c));
663 }
664 ENDR("mult_kranz_kranz");
665 }
666
invers_kranz(a,b)667 INT invers_kranz(a,b) OP a,b;
668 /* AK 030902 */
669 /* AK 120804 V3.0 */
670 {
671 INT erg = OK;
672 CTO(KRANZ,"invers_kranz(1)",a);
673 CTO(EMPTY,"invers_kranz(2)",b);
674 {
675 INT i;
676 erg += init(KRANZ,b);
677 erg += invers_permutation(s_kr_g(a),s_kr_g(b));
678 erg += m_il_v(s_kr_gli(a), s_kr_v(b));
679 for (i=0;i<s_kr_gli(a);i++)
680 erg += invers(s_kr_i(a,i),s_kr_i(b,i));
681 erg += operate_perm_vector(s_kr_g(b),s_kr_v(b),s_kr_v(b));
682 }
683 ENDR("invers_kranz");
684 }
685
einsp_kranz(a)686 INT einsp_kranz(a) OP a;
687 /* AK 030902 */
688 /* AK 200804 V3.0 */
689 {
690 INT erg = OK;
691 CTO(KRANZ,"einsp_kranz(1)",a);
692 {
693 INT i;
694 if (not einsp_permutation(S_KR_G(a))) return FALSE;
695 for (i=0;i<S_KR_GLI(a);i++)
696 {
697 if (not einsp(S_KR_I(a,i))) return FALSE;
698 }
699 return TRUE;
700 }
701 ENDR("einsp_kranz");
702 }
703
freeself_kranz(a)704 INT freeself_kranz(a) OP a;
705 /* AK 030902 */
706 {
707 INT erg = OK;
708 CTO(KRANZ,"freeself_kranz(1)",a);
709 C_O_K(a,VECTOR);
710 erg += freeself_vector(a);
711 ENDR("freeself_kranz");
712 }
713
first_kranztypus(w,parts,c)714 INT first_kranztypus(w,parts,c) OP w,parts,c;
715 /* AK 310889 */
716 /* kranztypus ist ein vector mit zwei eintraegen.
717 der erste eintrag eine komposition
718 der zweite eintrag ist eine vector mit partitionen als
719 komponeten.
720 */
721 /* AK 181289 V1.1 */ /* AK 120691 V1.2 */ /* AK 150891 V1.3 */
722 {
723 INT erg = OK;
724 CTO(INTEGER,"first_kranztypus(1)",w);
725 CTO(INTEGER,"first_kranztypus(2)",parts);
726 CE3(w,parts,c,first_kranztypus);
727 {
728 INT i;
729 OP a;
730
731 erg += m_il_v(2L,c);
732 erg += first_composition(w,parts,S_V_I(c,0L));
733 erg += m_il_v(S_I_I(parts),S_V_I(c,1L));
734 for (i=0L;i<S_I_I(parts);i++)
735 {
736 a =S_V_I(S_V_I(c,1L),i);
737 if (not EMPTYP(a))
738 erg += freeself(a);
739 if (S_V_II(S_V_I(c,0L),i) > 0L)
740 erg += first_partition(S_V_I(S_V_I(c,0L),i),a);
741 }
742 }
743 ENDR("first_kranztypus");
744 }
745
next_kranztypus(alt,c)746 INT next_kranztypus(alt,c) OP alt,c;
747 /* AK 310889 */
748 /* kranztypus ist ein vector mit zwei eintraegen.
749 der erste eintrag eine komposition
750 der zweite eintrag ist eine vector mit partitionen als
751 komponenten.
752 return TRUE falls ok
753 FALSE falls letzter typus
754 */
755 /* AK 181289 V1.1 */ /* AK 130691 V1.2 */ /* AK 150891 V1.3 */
756 {
757 INT i,j,l ;
758 OP a;
759 OP b;
760 if (alt != c) copy(alt,c);
761
762 b = S_V_I(c,0L); /* die composition */
763 l = S_V_LI(b); /* anzahl teile der composition */
764 for (i=l-1;i>=0L;i--)
765 {
766 a = S_V_I(S_V_I(c,1L),i); /* partition */
767 if (not EMPTYP(a))
768 if (next(a,a)) goto nk310889;
769 }
770 if (i < 0L) if (next(b,b) == FALSE) return(FALSE);
771 nk310889:
772 for (j=i+1; j < l; j++)
773 {
774 a = S_V_I(S_V_I(c,1L),j);
775 if (not EMPTYP(a))
776 freeself(a);
777 if (S_V_II(b,j) > 0L) first_partition(S_V_I(b,j),a);
778 }
779 return(TRUE);
780 }
781 #endif /* KRANZTRUE */
782
makevectorof_kranztypus(w,parts,c)783 INT makevectorof_kranztypus(w,parts,c) OP w,parts,c;
784 /* AK 310889 */ /* AK 181289 V1.1 */ /* AK 120691 V1.2 */ /* AK 150891 V1.3 */
785 {
786 INT erg = ERROR;
787 #ifdef KRANZTRUE
788 erg =OK;
789 CTO(INTEGER,"makevectorof_kranztypus(1)",w);
790 CTO(INTEGER,"makevectorof_kranztypus(2)",parts);
791 CE3(w,parts,c,makevectorof_kranztypus);
792 {
793 OP a = callocobject();
794 INT i=0L;
795 erg += m_il_v(1L,c);
796 erg += first_kranztypus(w,parts,a); /* ergebnis ist vector */
797 COPY(a,S_V_I(c,0L));
798 while (next_kranztypus(a,a))
799 {
800 INC(c);
801 i++;
802 COPY(a,S_V_I(c,i));
803 }
804 FREEALL(a);
805 }
806 #endif
807 ENDR("makevectorof_kranztypus");
808 }
809
kranztypus_to_matrix(a,b)810 INT kranztypus_to_matrix(a,b) OP a,b;
811 /* AK 010989 */
812 /* kranztypus als matrix */
813 /* b wird eine matrix */
814 /* kranztypus ist ein vector mit zwei eintraegen.
815 der erste eintrag eine komposition
816 der zweite eintrag ist eine vector mit partitionen als
817 komponeten. */
818 /* AK 081289 V1.1 */ /* AK 120691 V1.2 */ /* AK 150891 V1.3 */
819 /* AK 050902 V2.0 */
820 {
821 INT erg = OK;
822 #ifdef KRANZTRUE
823 CTO(VECTOR,"kranztypus_to_matrix(1)",a);
824 SYMCHECK(S_V_LI(a)!=2,"kranztypus_to_matrix(1):wrong length of vector");
825 CTO(COMPOSITION,"kranztypus_to_matrix(1.0)",S_V_I(a,0));
826 CTO(VECTOR,"kranztypus_to_matrix(1.1)",S_V_I(a,1));
827 CE2(a,b,kranztypus_to_matrix);
828 {
829 INT z,s,i,j;
830 OP summe = callocobject();
831 OP h1,h2;
832 /* z = Anzahl der zeilen */
833 /* s = Anzahl der spalten */
834
835 s = S_V_LI(S_V_I(a,0L));
836 SYM_sum(S_V_I(a,0L),summe);/* composition ist vector */
837 z = S_I_I(summe);
838 FREEALL(summe);
839 m_ilih_nm(s,z,b);
840 C_O_K(b,KRANZTYPUS);
841 for (i=0L;i<s;i++)
842 {
843 h1 = S_V_I(a,0L); /* composition */
844 if (S_V_II(h1,i) > 0L) {
845 h2 = S_V_I(S_V_I(a,1L),i) ; /* i-te partition */
846 for (j=0L;j<S_PA_LI(h2);j++)
847 INC(S_M_IJ(b,S_PA_II(h2,j) -1L,i));
848 }
849 }
850 }
851 #endif
852 ENDR("kranztypus_to_matrix");
853 }
854
matrix_to_kranztypus(a,b)855 INT matrix_to_kranztypus(a,b) OP a,b;
856 /* AK 010989 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
857 {
858 INT i,j,s;
859 OP h;
860 #ifdef KRANZTRUE
861 if (not EMPTYP(b))
862 freeself(b);
863
864 m_il_v(2L,b);
865 m_il_v(S_M_LI(a),S_V_I(b,1L));
866 m_il_v(S_M_LI(a),S_V_I(b,0L));
867 C_O_K(S_V_I(b,0L),COMPOSITION);
868 for (j=0L;j<S_M_LI(a);j++)
869 {
870 s = 0L;
871 for (i=0L;i<S_M_HI(a);i++)
872 s = s + S_M_IJI(a,i,j)*(i+1L);
873 /* s ist das gewicht */
874 if (s > 0L) {
875 h = S_V_I(S_V_I(b,1L),j);
876 /* h ist die partition */
877 b_ks_pa(EXPONENT,callocobject(),h);
878 m_il_integervector(S_M_HI(a),S_PA_S(h));
879 for (i=0L;i<S_M_HI(a);i++)
880 M_I_I(S_M_IJI(a,i,j),S_PA_I(h,i));
881 t_EXPONENT_VECTOR(h,h);
882 }
883 M_I_I(s,S_V_I(S_V_I(b,0L),j));
884 }
885 #endif
886 return(OK);
887 }
888
889 #ifdef KRANZTRUE
kranztypus_kranztypus_monom(a,b,c)890 INT kranztypus_kranztypus_monom(a,b,c) OP a,b,c;
891 /* AK 010989 */
892 /* der erste kranztypus ist das F_lambda
893 der zweite eine klasse von der gleichen uneigentlichen partition
894 das ergebnis ist ein monom induziert durch eine typus-matrix
895 */
896 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
897 {
898 INT i;
899 OP a1=S_V_I(a,0L);
900 OP a2=S_V_I(a,1L),b2=S_V_I(b,1L);
901 OP erg = callocobject();
902 OP h1 = callocobject();
903
904 if (not EMPTYP(c))
905 freeself(c);
906 b_skn_po(callocobject(),callocobject(),NULL,c);
907 M_I_I(1L,S_PO_K(c));
908
909 for (i=0L;i<S_V_LI(a1);i++)
910 {
911 if (S_V_II(a1,i) > 0L) {
912 if (not EMPTYP(h1))
913 if (S_O_K(h1) != INTEGER) freeself(h1);
914 charvalue(S_V_I(a2,i),S_V_I(b2,i),erg,NULL);
915 mult(erg,S_PO_K(c),h1);
916 ordcen(S_V_I(b2,i),erg);
917 div(h1,erg,S_PO_K(c));
918 }
919 }
920 freeall(erg);
921 freeall(h1);
922 if (not nullp(S_PO_K(c)))
923 kranztypus_to_matrix(b,S_PO_S(c));
924 else freeself(c); /* polynom == list */
925 return(OK);
926 }
927
kranztypus_charakteristik(a,b)928 INT kranztypus_charakteristik(a,b) OP a,b;
929 /* AK 010989 */ /* aus einem kranztypus wird F_lambda berechnet */
930 /* AK 181289 V1.1 */ /* AK 120691 V1.2 */ /* AK 150891 V1.3 */
931 {
932 OP c,d;
933 INT i;
934 if (S_O_K(a) == KRANZTYPUS) {
935 c = callocobject();
936 matrix_to_kranztypus(a,c);
937 kranztypus_charakteristik(c,b);
938 freeall(c);
939 return(OK);
940 }
941 /* a ist ein vektor */
942 c = callocobject();
943 copy(a,c);
944 if (not EMPTYP(b))
945 freeself(b);
946
947 for (i=0L; i<S_V_LI(S_V_I(a,0L)); i++)
948 if (S_V_II(S_V_I(a,0L),i) > 0L)
949 first_partition(S_V_I(S_V_I(a,0L),i),
950 S_V_I(S_V_I(c,1L),i));
951
952 do {
953 d = callocobject();
954 kranztypus_kranztypus_monom(a,c,d);
955 if (not EMPTYP(d))
956 insert(d,b,NULL,NULL);
957 else
958 freeall(d);
959 } while (
960 next_kranztypus(c,c) &&
961 eq( S_V_I(c,0L),S_V_I(a,0L))
962 );
963
964 freeall(c);
965 return(OK);
966 }
967
charakteristik_to_ypolynom(a,b,grad,ct)968 INT charakteristik_to_ypolynom(a,b,grad,ct) OP a,b,grad,ct;
969 /* AK 040989 */
970 /* A ist charakteristik, b wird ypolynom */
971 /* grad ist der grad der symmetrischen gruppe G in GwrS_n*/
972 /* ct ist chartafel von S_n */
973 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
974 {
975 OP z = a;
976 OP c;
977 OP partv = callocobject();
978
979 makevectorofpart(grad,partv);
980 if (not EMPTYP(b))
981 freeself(b);
982
983 while (z != NULL)
984 {
985 c = callocobject();
986 matrix_monom_ypolynom(z,c,grad,partv,ct);
987 insert(c,b,NULL,NULL);
988 z = S_PO_N(z);
989 }
990 freeall(partv);
991 return(OK);
992 }
993
matrix_monom_ypolynom(a,b,grad,partv,ct)994 INT matrix_monom_ypolynom(a,b,grad,partv,ct) OP a,b,grad,partv,ct;
995 /* AK 040989 */
996 /* eingabe a ist ein monom mit matrix kranztypus
997 ausgabe b ist ein gleiches polynom in den y variablen */
998 /* grad ist der grad der symmetrischen gruppe G in GwrS_n*/
999 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1000 {
1001 INT i,j;
1002 OP m=S_PO_S(a); /* matrix */
1003 OP c = callocobject();
1004 INT erg = OK;
1005 FREESELF(b);
1006 M_I_I(1L,b);
1007 for (i= 0L;i<S_M_HI(m); i++)
1008 for (j=0L;j<S_M_LI(m) ; j++)
1009 {
1010 if (S_M_IJI(m,i,j) > 0L) {
1011 s_x_nu_to_ypolynom(m,grad,i,j,c,partv,ct);
1012 MULT_APPLY(c,b);
1013 }
1014 }
1015 MULT_APPLY(S_PO_K(a),b);
1016 freeall(c);
1017 ENDR("matrix_monom_ypolynom");
1018 }
1019
s_x_nu_to_ypolynom(m,grad,i,j,c,partv,ct)1020 INT s_x_nu_to_ypolynom(m,grad,i,j,c,partv,ct) INT i,j; OP m,grad,c,partv,ct;
1021 /* AK 040989 */ /* ein einzelne transformation */ /* m ist die matrix */
1022 /* c wird polynom */
1023 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1024 {
1025 INT i1,j1,i2;
1026 OP h1,h2,h3,d,f;
1027 INT erg = OK;
1028 h1 = callocobject();
1029 h2 = callocobject();
1030 h3 = callocobject();
1031 d = callocobject();
1032 f = callocobject();
1033
1034 init(POLYNOM,c);
1035
1036 erg += fakul(grad,f);
1037 for (i2=0L;i2<S_V_LI(partv);i2++)
1038 {
1039 COPY(S_M_IJ(ct,j,i2),h2);
1040 /* equiv zu
1041 charvalue_tafel_part(S_V_I(partv,j),S_V_I(partv,i2),h2,ct,partv);
1042 */
1043 if (nullp(h2)) continue;
1044 erg += ordcon(S_V_I(partv,i2),h1);
1045 FREESELF(d);
1046 erg += b_skn_po(callocobject(),callocobject(),NULL,d);
1047 erg += div(h1,f,h3);
1048 MULT(h3,h2,S_PO_K(d));
1049 erg += m_ilih_m(S_M_LI(m),S_M_HI(m),S_PO_S(d));
1050 C_O_K(S_PO_S(d),KRANZTYPUS);
1051 for (i1=0L;i1<S_M_HI(m);i1++)
1052 for (j1=0L;j1<S_M_LI(m);j1++)
1053 M_I_I(0L,S_M_IJ(S_PO_S(d),i1,j1));
1054 M_I_I(1L,S_M_IJ(S_PO_S(d),i,i2));
1055 erg += add_apply(d,c);
1056 }
1057
1058 erg += hoch(c,S_M_IJ(m,i,j),c);
1059
1060 FREEALL(f);
1061 FREEALL(d);
1062 FREEALL(h2);
1063 FREEALL(h3);
1064 FREEALL(h1);
1065
1066 ENDR("s_x_nu_to_ypolynom");
1067 }
1068
kranztafel(a,b,kt,d,h)1069 INT kranztafel(a,b,kt,d,h) OP a,b,kt,d,h;
1070 /* a,b sind integer werte
1071 kt wird die charaktertafel von s_b wr s_a
1072 d wird der vektor der ordnung der konjugiertenklassen
1073 h wird der vektor der label der konjugiertenklassen */
1074 /* AK 181289 V1.1 */ /* AK 050391 V1.2 */ /* AK 150891 V1.3 */
1075 {
1076 OP c,e,f,h1,ct,m;
1077 INT i;
1078 INT erg = OK;
1079
1080 CTO(INTEGER,"kranztafel(1)",a);
1081 CTO(INTEGER,"kranztafel(2)",b);
1082 SYMCHECK(S_I_I(a) < 1,"kranztafel: a < 1");
1083 SYMCHECK(S_I_I(b) < 1,"kranztafel: b < 1");
1084
1085 if (S_O_K(old_kranz_tafel) == VECTOR) /* AK 170893 */
1086 {
1087 if (S_V_II(old_kranz_tafel,0L) == S_I_I(a))
1088 if (S_V_II(old_kranz_tafel,1L) == S_I_I(b))
1089 {
1090 erg += copy(S_V_I(old_kranz_tafel,2L),kt);
1091 erg += copy(S_V_I(old_kranz_tafel,3L),d);
1092 erg += copy(S_V_I(old_kranz_tafel,4L),h);
1093 goto kt_ende;
1094 }
1095 }
1096 else
1097 erg += m_il_v(5L,old_kranz_tafel);
1098
1099 c=callocobject(); e=callocobject(); f=callocobject();
1100 h1=callocobject(); ct=callocobject(); m=callocobject();
1101
1102
1103 if (not EMPTYP(kt))
1104 erg += freeself(kt);
1105 if (not EMPTYP(d))
1106 erg += freeself(d);
1107 if (not EMPTYP(h))
1108 erg += freeself(h);
1109
1110 erg += makevectorofpart(b,f);
1111 erg += makevectorof_kranztypus(a,S_V_L(f),c);
1112 erg += m_il_v(S_V_LI(c),h);
1113 for(i = 0L; i<S_V_LI(c);i++) {
1114 erg += kranztypus_to_matrix(S_V_I(c,i),S_V_I(h,i));
1115 }
1116
1117 erg += SYM_sort(h);
1118
1119 erg += chartafel(b,ct);
1120
1121 erg += m_ilih_m(S_V_LI(c),S_V_LI(c),kt);
1122 for(i = 0L; i<S_V_LI(h);i++) {
1123 erg += kranztypus_charakteristik(S_V_I(h,i),d);
1124 erg += charakteristik_to_ypolynom(d,e,b,ct);
1125 erg += co040989(e,kt,h,i);
1126 }
1127
1128 erg += freeall(e);
1129 erg += freeall(ct);
1130 erg += freeall(c);
1131
1132 erg += fakul(a,d);
1133 erg += fakul(b,m);
1134 erg += hoch(m,a,m);
1135 erg += mult_apply(d,m);
1136 erg += mult_apply(m,kt);
1137
1138 erg += freeself(d);
1139 erg += m_il_v(S_V_LI(h),d);
1140 for(i = 0L; i<S_V_LI(h);i++) {
1141 erg += typusorder(S_V_I(h,i),b,a,S_V_I(d,i),f);
1142 }
1143
1144 erg += co_div_040989(kt,d);
1145 erg += freeall(f);
1146 erg += freeall(h1);
1147 erg += freeall(m);
1148
1149 erg += copy(a,S_V_I(old_kranz_tafel,0L));
1150 erg += copy(b,S_V_I(old_kranz_tafel,1L));
1151 erg += copy(kt,S_V_I(old_kranz_tafel,2L));
1152 erg += copy(d,S_V_I(old_kranz_tafel,3L));
1153 erg += copy(h,S_V_I(old_kranz_tafel,4L));
1154 kt_ende:
1155 ENDR("kranztafel");
1156 }
1157
latex_kranztafel(h,g,d)1158 INT latex_kranztafel(h,g,d) OP h,d,g;
1159 /* AK 051289 V1.1 */
1160 /* g ist matrix der charakterwerte
1161 d ist vector der ordnung der konjugiertenklassen
1162 h ist vector der label der konjugiertenklassen */
1163 /* AK 070291 V1.2 texout for output */ /* AK 150891 V1.3 */
1164 {
1165 INT i,j,j1,i1;
1166 for (i=0L;i<S_V_LI(h); i++) {
1167 fprintf(texout,"$ %ld$ ",i+1L);
1168 tex(S_V_I(h,i));
1169 tex(S_V_I(d,i));
1170 fprintf(texout,"\n\n\\smallskip\n");
1171 }
1172 for (i=0L;i<S_M_HI(g);i+=15L)
1173 for (j=0L;j<S_M_LI(g);j+=15L)
1174 {
1175 fprintf(texout,"\n\\begin{tabular}{|c||");
1176 for (j1=j;(j1<S_M_LI(g))&&(j1<j+15L);j1++) fprintf(texout,"c|");
1177 fprintf(texout,"}\n \\hline \n & ");
1178 for (j1=j;(j1<S_M_LI(g))&&(j1<j+15L);j1++) {
1179 fprintf(texout,"%ld",j1+1L);
1180 if ((j1+1 <j+15L) &&(j1+1 <S_M_LI(g))) fprintf(texout,"&");
1181 }
1182 fprintf(texout,"\n \\\\ \\hline \\hline");
1183 for (i1=i;(i1<S_M_HI(g))&&(i1<i+15L);i1++)
1184 {
1185 fprintf(texout,"\n %ld&",i1+1L);
1186 for (j1=j;(j1<S_M_LI(g))&&(j1<j+15L);j1++)
1187 {
1188 tex(S_M_IJ(g,i1,j1));
1189 if ((j1+1 <j+15L) &&(j1+1 <S_M_LI(g))) fprintf(texout,"&");
1190 }
1191 fprintf(texout,"\n \\\\ \\hline");
1192 }
1193 fprintf(texout,"\n\\end{tabular} ");
1194 }
1195 return(OK);
1196 }
1197
co_div_040989(a,d)1198 static INT co_div_040989(a,d) OP a,d;
1199 /* AK dividiert die spalten durch den ersten eintrag */
1200 /* d vector der klassenordnungen */
1201 /* AK 081289 V1.1 */ /* AK 150891 V1.3 */
1202 {
1203 INT i,j;
1204 OP z;
1205 INT erg = OK;
1206 z = S_M_S(a);
1207 for (i=0L;i<S_M_HI(a);i++)
1208 for (j=0L;j<S_M_LI(a);j++)
1209 {
1210 erg += ganzdiv(z,S_V_I(d,j),z);
1211 z++;
1212 }
1213 return erg;
1214 }
1215
1216
co040989(a,b,c,i)1217 static INT co040989(a,b,c,i) OP a,b,c; INT i;
1218 /* a ist ypoly, b ist matrix, c vector von matrixtypus, i ist zeile in Matrix */
1219 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1220 {
1221 INT i2=0L;
1222 OP z = a;
1223 OP m,ll;
1224 while ( z != NULL)
1225 {
1226 m = S_PO_S(z);
1227 while (NEQ(m,S_V_I(c,i2))) {
1228 ll = S_M_IJ(b,i,i2);
1229 if (not EMPTYP(ll))
1230 if (S_O_K(ll) != INTEGER) freeself(ll);
1231 M_I_I(0L,ll);
1232 i2++;
1233 if (i2 >= S_V_LI(c))
1234 {
1235 fprintf(stderr,"m=");
1236 fprintln(stderr,m);
1237 fprintf(stderr,"a=");
1238 fprintln(stderr,a);
1239 fprintf(stderr,"c=");
1240 fprintln(stderr,c);
1241 error("co040989: not found");
1242 }
1243 }
1244 /* i2 ist jetzt der index */
1245 copy(S_PO_K(z),S_M_IJ(b,i,i2));
1246 i2++;
1247 z = S_PO_N(z);
1248 }
1249 z = S_M_IJ(b,i,i2);
1250 while(i2 < S_M_LI(b)) {
1251 if(not EMPTYP(z)) if (S_O_K(z) != INTEGER) freeself(z);
1252 M_I_I(0L,z);
1253 i2++;z++;
1254 }
1255 return(OK);
1256 }
1257
typusorder(a,ggrad,ngrad,b,vec)1258 INT typusorder(a,ggrad,ngrad,b,vec) OP b,a,ggrad,ngrad,vec;
1259 /* ordnung der konjugiertenklasse mit typus==MATRIX
1260 ggrad ist grad der symmetrischen gruppe G */
1261 /* ngrad ist grad der symmetrischen gruppe S_n */
1262 /* vec ist vector der partition von G */
1263 /* result is b */
1264 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1265 {
1266 INT i,j;
1267 OP f = callocobject();
1268 OP h = callocobject();
1269 OP p;
1270 OP k = callocobject();
1271 OP h1 = callocobject();
1272 OP h2 = callocobject();
1273 OP gorder = callocobject();
1274 INT erg = OK; /* AK 090692 */
1275 erg += fakul(ggrad,gorder);
1276 erg += hoch(gorder,ngrad,h2);
1277 erg += fakul(ngrad,h);
1278 MULT(h2,h,f);
1279 p = S_V_I(vec,0L);
1280
1281 if (not EMPTYP(b))
1282 erg += freeself(b);
1283 M_I_I(1L,b);
1284 for (j=0L;j<S_M_LI(a);j++)
1285 {
1286 erg += ordcon(p,h);
1287 for (i=0L;i<S_M_HI(a);i++)
1288 if (S_M_IJI(a,i,j) != 0L) {
1289 FREESELF(k);
1290 FREESELF(h2);
1291 FREESELF(h1);
1292 M_I_I(i+1,k);
1293 MULT(gorder,k,h2);
1294 erg += div(h,h2,h1);
1295 erg += hoch(h1,S_M_IJ(a,i,j),k);
1296 erg += fakul(S_M_IJ(a,i,j),h1);
1297 erg += div(k,h1,h2);
1298 MULT_APPLY(h2,b);
1299 }
1300 p++; /* p is now next partition */
1301 }
1302 MULT_APPLY(f,b);
1303 erg += freeall(f); erg += freeall(k);
1304 erg += freeall(h1); erg += freeall(h);
1305 erg += freeall(gorder);erg += freeall(h2);
1306 ENDR("typusorder");
1307 }
1308 /* ende des teiles fuer das kranzprodukt */
1309 #endif /* KRANZTRUE */
1310
1311
numberof_shufflepermutation(mx,n)1312 INT numberof_shufflepermutation(mx,n) OP mx,n;
1313 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1314 {
1315 #ifdef SHUFFLETRUE
1316 INT i;
1317 OP a=callocobject();
1318 OP b=callocobject();
1319 i=0L;
1320 first_permutation(n,b);
1321 do {
1322 copy(b,a);
1323 i++;
1324 } while (next_shufflepermutation(mx,a,b) != LASTSHUFFLE);
1325
1326 freeall(b);
1327 freeall(a);
1328 return(i);
1329 #else /* SHUFFLETRUE */
1330 return error("numberof_shufflepermutation:SHUFFLE not defined");
1331 #endif /* SHUFFLETRUE */
1332 }
1333
next_shufflevector(mx,a,b)1334 INT next_shufflevector(mx,a,b) OP a,b; OP mx;
1335 /* bsp 34555 --> 44555
1336 33344 --> 00444 */
1337 /* AK 260789 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1338 {
1339 #ifdef SHUFFLETRUE
1340
1341 INT k,i;
1342 INT grenze = S_V_LI(a)-S_I_I(mx);
1343 copy(a,b);
1344 for (i=grenze-1L;i>=0L;i--)
1345 if (S_V_II(b,i) == 0L)
1346 {
1347 M_I_I(1L,S_V_I(b,i));
1348 return(OK);
1349 };
1350 for (i=1L;i<grenze;i++) /* i=1 statt i=0 */
1351 if (S_V_II(b,i) > S_V_II(b,i-1L)) break;
1352
1353 k=i-1;
1354 if (eq(S_V_I(b,k),mx))
1355 return(LASTSHUFFLE);
1356
1357 inc(S_V_I(b,k));
1358 for (i=k-1;i>=0L;i--)
1359 M_I_I(0L,S_V_I(b,i));
1360 return OK;
1361 #else /* SHUFFLETRUE */
1362 return error("next_shufflevector:SHUFFLE not defined");
1363 #endif /* SHUFFLETRUE */
1364 }
1365
next_shufflepermutation(mx,perm,erg)1366 INT next_shufflepermutation(mx,perm,erg) OP mx,perm,erg;
1367 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1368 {
1369 #ifdef SHUFFLETRUE
1370 INT e;
1371 OP a=callocobject();
1372 OP b=callocobject();
1373 lehmercode(perm,a);
1374 e = next_shufflevector(mx,a,b);
1375 if (e != LASTSHUFFLE)
1376 lehmercode(b,erg);
1377 freeall(a);
1378 freeall(b);
1379 return(e);
1380 #else /* SHUFFLETRUE */
1381 return error("next_shufflepermutation:SHUFFLE not defined");
1382 #endif /* SHUFFLETRUE */
1383 }
1384
1385 #ifdef PERMTRUE
test_perm()1386 INT test_perm()
1387 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1388 {
1389 OP a = callocobject();
1390 OP b = callocobject();
1391 OP c = callocobject();
1392
1393 printf("test_perm:scan(a)");
1394 scan(PERMUTATION,a);
1395 println(a);
1396 printf("test_perm:copy(a,b)");
1397 copy(a,b);
1398 println(b);
1399 printf("test_perm:mult(a,b,b)");
1400 mult(a,b,b);
1401 println(b);
1402 printf("test_perm:invers(b,a)");
1403 invers(b,a);
1404 println(a);
1405 printf("test_perm:even(b)");
1406 if (even(b))
1407 printeingabe("is even");
1408 else
1409 printeingabe("is not even");
1410 printf("test_perm:inc(a)");
1411 inc(a);
1412 println(a);
1413 printf("test_perm:UD_permutation(a,b)");
1414 UD_permutation(a,b);
1415 println(b);
1416 printf("test_perm:random_permutation(134L,b)");
1417 m_i_i(134L,a);
1418 random_permutation(a,b);
1419 println(b);
1420 printf("test_perm:makevectoroftranspositions(5L,c)");
1421 m_i_i(5L,a);
1422 makevectoroftranspositions(a,c);
1423 println(c);
1424
1425 freeall(a);
1426 freeall(b);
1427 freeall(c);
1428 return(OK);
1429 }
1430
tex_lc(perm)1431 INT tex_lc(perm) OP perm;
1432 /* AK 101187 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */
1433 /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 150891 V1.3 */
1434 {
1435 INT i;
1436 if (S_V_LI(perm)<10L)
1437 {
1438 fprintf(texout,"\\ $");
1439 texposition += 2L;
1440 for (i=0L;i<S_V_LI(perm);i++)
1441 {
1442 fprintf(texout,"%ld",S_V_II(perm,i));
1443 texposition ++;
1444 }
1445 fprintf(texout,"$\\ ");
1446 texposition += 3L;
1447 }
1448 else {
1449 fprintf(texout,"\\ $(");
1450 texposition += 4L;
1451 for (i=0L;i<S_V_LI(perm);i++)
1452 {
1453 fprintf(texout,"%ld",S_V_II(perm,i));
1454 if (i != S_V_LI(perm)-1L) fprintf(texout,",");
1455 texposition += 3L;
1456 }
1457 fprintf(texout,")$\\ ");
1458 texposition += 3L;
1459 };
1460 if (texposition >60L)
1461 {
1462 fprintf(texout,"\n");
1463 texposition = 0L;
1464 }
1465 return(OK);
1466 }
1467
tex_permutation(perm)1468 INT tex_permutation(perm) OP perm;
1469 /* AK 101187 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */
1470 /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 150891 V1.3 */
1471 {
1472 INT i;
1473 if (S_P_LI(perm)<10L)
1474 {
1475 fprintf(texout,"\\ $");
1476 texposition += 3L;
1477 for (i=0L;i<S_P_LI(perm);i++)
1478 {
1479 fprintf(texout,"%ld",S_P_II(perm,i));
1480 texposition += 1L;
1481 }
1482 fprintf(texout,"$\\ ");
1483 texposition += 3L;
1484 }
1485 else {
1486 fprintf(texout,"\\ $(");
1487 for (i=0L;i<S_P_LI(perm);i++)
1488 {
1489 texposition += 3L;
1490 fprintf(texout,"%ld",S_P_II(perm,i));
1491 if (i != S_P_LI(perm)-1L) fprintf(texout,",");
1492 }
1493 fprintf(texout,")$\\ ");
1494 texposition += 3;
1495 };
1496
1497 if (texposition > 60L)
1498 {
1499 fprintf(texout,"\n");
1500 texposition = 0L;
1501 }
1502 return(OK);
1503 }
1504
tex_rz(obj)1505 INT tex_rz(obj) OP obj;
1506 /* AK 101187 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */
1507 /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 150891 V1.3 */
1508 {
1509 INT i;
1510 INT erg = OK;
1511 CTO(VECTOR,"tex_rz(1)",obj);
1512
1513 fprintf(texout,"\\ $");
1514 for (i=0L;i<S_V_LI(obj);i++)
1515 fprintf(texout,"\\sigma_{%ld}\\ ",S_V_II(obj,i));
1516 fprintf(texout,"$\\ ");
1517 ENDR("tex_rz");
1518 }
1519
1520
m_perm_paareperm(a,b)1521 INT m_perm_paareperm(a,b) OP a,b;
1522 /* 140488 */
1523 /* diese routine berechnet die induzierte permutation in n ueber 2
1524 oder anders gesprochen:
1525 berechnet die operation von pi aus S_n auf der identitaet
1526 in S_(n ueber 2) */
1527 /* AK 170789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1528 /* AK 180598 V2.0 */
1529 {
1530 OP c;
1531 INT i,j,ni,nj,e=1L,z=1L;
1532 INT erg = OK;
1533
1534 CPT(VECTOR,"m_perm_paareperm",a);
1535 CE2(a,b,m_perm_paareperm);
1536
1537 c = callocobject();
1538
1539 erg += binom(S_P_L(a),cons_zwei,c);
1540 /* c ist jetzt die laenge der ergebnis permutation */
1541 /* c = n ueber 2 */
1542 erg += b_ks_p(VECTOR,callocobject(),b);
1543 erg += b_l_v(c,S_P_S(b));
1544 /* die permutation ist nun initialisiert */
1545
1546
1547 z=0L;
1548 for(i=0L;i<S_P_LI(a);i++)
1549 for(j=i+1;j<S_P_LI(a);j++)
1550 {
1551 ni = S_P_II(a,i); nj = S_P_II(a,j);
1552 if (ni>nj) { e=ni; ni=nj; nj=e; };
1553 /* ni < nj ist ergebnis der permutation */
1554 /* nun nur noch den index bestimmen */
1555 /* der ist e */
1556 e = (nj-ni-1L)+((S_P_LI(a)+S_P_LI(a)-ni)*(ni-1L))/2L ;
1557 /* e ist der index des neuen paars speicher */
1558 M_I_I(e+1L,S_P_I(b,z));
1559 z++;
1560 };
1561 ENDR("m_perm_paareperm");
1562 }
1563
eq_permutation(a,b)1564 INT eq_permutation(a,b) OP a,b;
1565 /* AK 120104 */
1566 {
1567 INT erg = OK;
1568 CTO(PERMUTATION,"eq_permutation(1)",a);
1569 CTO(PERMUTATION,"eq_permutation(2)",b);
1570 if (S_P_K(a) == S_P_K(b))
1571 {
1572 switch (S_P_K(a))
1573 {
1574 case ZYKEL:
1575 case VECTOR:
1576 return eq_integervector_integervector(S_P_S(a),S_P_S(b));
1577 default:
1578 return EQ(S_P_S(a),S_P_S(b));
1579 }
1580 }
1581 else
1582 {
1583 fprintf(stderr,"kind a = %ld\nkind b = %ld\n", S_P_K(a), S_P_K(b));
1584 debugprint(b);
1585 return error("eq_permutation:different kinds of permutations");
1586 }
1587 ENDR("eq_permutation");
1588 }
1589
1590
comp_permutation(a,b)1591 INT comp_permutation(a,b) OP a, b;
1592 /* AK 130587 als gr*/ /* AK 060488 als comp*/
1593 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */
1594 /* AK 070891 V1.3 comp_vector */
1595 /* AK 050898 V2.0 */
1596 {
1597 INT erg = OK;
1598 CTO(PERMUTATION,"comp_permutation(1)",a);
1599 CTO(PERMUTATION,"comp_permutation(2)",b);
1600 if (S_P_K(a) == S_P_K(b))
1601 return comp(S_P_S(a),S_P_S(b));
1602 else
1603 {
1604 fprintf(stderr,"kind a = %ld\nkind b = %ld\n", S_P_K(a), S_P_K(b));
1605 debugprint(b);
1606 return error("comp_permutation:different kinds of permutations");
1607 }
1608 ENDR("comp_permutation");
1609 }
1610
1611
first_lehmercode(l,res)1612 INT first_lehmercode(l,res) OP l, res;
1613 /* l beleibt erhalten */
1614 /* AK 040487 */ /* firstlemercode = 0000...0000 */
1615 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1616 {
1617 INT i;
1618 INT erg = OK;
1619 CTO(INTEGER,"first_lehmercode(1)",l);
1620 erg += m_il_v(S_I_I(l),res);
1621 for (i=0L;i<S_V_LI(res);i++) M_I_I(0L,S_V_I(res,i));
1622 ENDR("first_lehmercode");
1623 }
1624
last_lehmercode(l,res)1625 INT last_lehmercode(l,res) OP l, res;
1626 /* 270887 */ /* lastlehmercode = 0123...n-1 */
1627 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1628 {
1629 INT i,j;
1630 INT erg = OK;
1631
1632 CTO(INTEGER,"last_lehmercode",l);
1633 j=S_I_I(l)-1;
1634 erg += m_il_v(S_I_I(l),res);
1635 for (i=0L;i<S_I_I(l);i++,j--)
1636 M_I_I(j,S_V_I(res,i));
1637 ENDR("last_lehmercode");
1638 }
1639
first_permutation(l,res)1640 INT first_permutation(l,res) OP l, res;
1641 /* AK 040487 */ /* l bleibt erhalten */
1642 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1643 /* ohne lehmercode AK 291091 */
1644 /* AK 050898 V2.0 */
1645 /* parameter may be equal */
1646 {
1647 INT i,erg=OK,li;
1648 CTO(INTEGER,"first_permutation",l);
1649 li = S_I_I(l);
1650 erg += m_il_p(li,res);
1651 for(i=0L;i<li;i++) M_I_I(i+1L,S_P_I(res,i));
1652 C_O_K(S_P_S(res),INTEGERVECTOR);
1653 ENDR("first_permutation");
1654 }
1655
1656
next_permutation_lex(start,next)1657 INT next_permutation_lex(start,next) OP start,next;
1658 /* AK 160591 V1.2 */ /* AK 150891 V1.3 */
1659 { /* Fischer Krause */
1660 INT r,s,i,j,erg;
1661 if (check_equal_2(start,next,next_permutation_lex,&erg) == EQUAL)
1662 goto fe;
1663 copy(start,next);
1664 for (r=S_P_LI(next)-2L;r>=0;r--)
1665 if (S_P_II(next,r) < S_P_II(next,r+1L)) break;
1666 if (r == -1L)
1667 {
1668 erg = LASTPERMUTATION;
1669 goto fe;
1670 }
1671 for (s=0L; s<S_P_LI(next)-r-1; s++)
1672 if (S_P_II(next,r) > S_P_II(next,r+s+1L) ) break;
1673 swap(S_P_I(next,r),S_P_I(next,r+s));
1674 for (i=r+1,j=S_P_LI(next)-1;i<j;i++,j--)
1675 swap(S_P_I(next,i),S_P_I(next,j));
1676 erg = OK;
1677 fe:
1678 return erg;
1679 }
1680
1681
next_permutation(a,b)1682 INT next_permutation(a,b) OP a,b;
1683 /* AK 280901 */
1684 /* parameter may be equal */
1685 {
1686 INT erg = OK;
1687 CTO(PERMUTATION,"next_permutation(1)",a);
1688 erg += copy(a,b);
1689 return next_apply_permutation(b);
1690 ENDR("next_permutation");
1691 }
1692
1693
next_apply_permutation(a)1694 INT next_apply_permutation(a) OP a;
1695 /* AK 280901 */
1696 /* lex next permutation */
1697 {
1698 INT i,j,k,erg = OK;
1699 CPT(VECTOR,"next_apply_permutation(1)",a);
1700 if (next_perm_v == NULL) {
1701 next_perm_v = CALLOCOBJECT();
1702 m_il_nv(S_P_LI(a)+1,next_perm_v);
1703 }
1704 if (S_V_LI(next_perm_v) < (S_P_LI(a)+1) ) {
1705 i = S_V_LI(next_perm_v);
1706 inc_vector_co(next_perm_v,S_P_LI(a) - S_V_LI(next_perm_v) + 5);
1707 for (;i<S_V_LI(next_perm_v);i++) M_I_I(0,S_V_I(next_perm_v,i));
1708 }
1709
1710 /* hilfsvector ist initialisiert */
1711 for (i=0,j=S_P_LI(a)-1;j>=0;j--)
1712 {
1713 M_I_I(1,S_V_I(next_perm_v,S_P_II(a,j)));
1714 if (S_P_II(a,j) > i) i = S_P_II(a,j);
1715 else {
1716 /* schauen was hinkommt */
1717 for (k=S_P_II(a,j)+1;k<S_V_LI(next_perm_v);k++)
1718 if (S_V_II(next_perm_v,k)==1) {
1719 M_I_I(k,S_P_I(a,j));
1720 M_I_I(0,S_V_I(next_perm_v,k));
1721 break;
1722 }
1723 /* increasing filling for the remaining part */
1724 for (k=0,j++;j<S_P_LI(a);k++)
1725 if (S_V_II(next_perm_v,k) == 1) {
1726 M_I_I(0,S_V_I(next_perm_v,k));
1727 M_I_I(k,S_P_I(a,j)); j++; }
1728 return OK;
1729 }
1730 }
1731 for (i=0;i<S_V_LI(next_perm_v);i++)
1732 M_I_I(0,S_V_I(next_perm_v,i));
1733 return LASTPERMUTATION;
1734 ENDR("next_permutation_apply");
1735 }
1736
1737
1738
next_lehmercode(start,n)1739 INT next_lehmercode(start,n) OP start,n;
1740 /* erzeugt den lexikographisch naechsten l.c. */
1741 /* 040487 */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1742 {
1743 INT i,j;
1744 copy(start,n);
1745 for (i=S_V_LI(n)-1L,j=0L;i>=0L;i--,j++)
1746 {
1747 if (S_V_II(n,i) < j)
1748 return(inc(S_V_I(n,i)));
1749 else C_I_I(S_V_I(n,i),0L);
1750 };
1751 freeself(n);
1752 return(LASTLEHMERCODE);
1753 }
1754
1755
1756 #ifdef PARTTRUE
vexillaryp_permutation(perm,part)1757 INT vexillaryp_permutation(perm,part) OP perm,part;
1758 /* AK 290986 */
1759 /* AK 031187 vergleiche hierzu kapitel 5.0 der diplomarbeit
1760 dort wird das kriterium fuer den test auf vexillary beschrieben */
1761 /* in part der sortierte lehmercode von perm zurueck gegeben AK 110488 */
1762 /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1763 {
1764 INT erg;
1765 OP zwischen = callocobject();
1766 OP zwei = callocobject();
1767 OP a = callocobject(),b= callocobject(),c = callocobject();
1768 OP d;
1769
1770 if (part == NULL) d = callocobject();
1771 else d = part;
1772
1773 invers_permutation(perm,a);
1774 lehmercode_permutation(a,b);
1775 m_v_pa(b,zwischen);freeall(b);
1776 lehmercode_permutation(perm,c);
1777 m_v_pa(c,d);freeall(c);
1778 conjugate(d,zwei);
1779 erg = eq(zwischen,zwei);
1780 if (d != part) freeall(d);
1781 freeall(zwischen);
1782 freeall(zwei);
1783 freeall(a);
1784 return(erg);
1785 }
1786 #endif /* PARTTRUE */
1787
1788
1789
lehmercode_permutation(perm,vec)1790 INT lehmercode_permutation(perm,vec) OP perm, vec;
1791 /* AK 221087 diese procedure berechnet zur permutation perm = [p1,....,pn]
1792 den zugehoerigen lehmercode vec [v1,...,vn] */
1793 /* AK 100789 V1.0 */ /* AK 111289 V1.1 */ /* AK 150891 V1.3 */
1794 {
1795 INT i,j,k;
1796 INT erg = OK;
1797 CTO(PERMUTATION,"lehmercode_permutation(1)",perm);
1798
1799 if (S_P_K(perm) == ZYKEL) /* AK 291091 */
1800 erg += t_ZYKEL_VECTOR(perm,perm);
1801 else if (S_P_K(perm) == BAR)
1802 {
1803 erg += lehmercode_bar(perm,vec);
1804 goto aa;
1805 }
1806
1807 erg += m_il_v(S_P_LI(perm),vec);
1808 /* erzeugt ein Vectorobject */
1809 for(i=0L;i<S_P_LI(perm);i++)
1810 {
1811 k=0L;
1812 for(j=i+1L;j<S_P_LI(perm);j++)
1813 if (S_P_II(perm,j) < S_P_II(perm,i)) k++;
1814 /* k ist die anzahl der permutationselemente
1815 rechts von pi, die kleiner sind */
1816 M_I_I(k,(S_V_S(vec)+i));
1817 /* k wird an der richtigen stelle im
1818 vector notiert */
1819 };
1820 aa:
1821 ENDR("lehmercode_permutation");
1822 }
1823
1824
lehmercode_vector(vec,b)1825 INT lehmercode_vector(vec,b) OP vec, b;
1826 /* AK 221087 diese procedure berechnet aus dem lehmercode vec = [v1,....,vn]
1827 die zugehoerige permutation b [e1,...,en] */
1828 /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1829 {
1830 INT i,j,k;
1831 INT erg = OK; /* AK 131093 */
1832 OP self,liste;
1833 if (not VECTORP(vec))
1834 {
1835 erg = ERROR;
1836 goto lc_ende;
1837 }
1838
1839
1840 k=(INT)0;
1841 for (j=S_V_LI(vec)-1L,i=(INT)0; j>=(INT)0; j--,i++)
1842 {
1843 if (not INTEGERP(S_V_I(vec,j))) /* AK 131093 */
1844 {
1845 erg = ERROR;
1846 goto lc_ende;
1847 }
1848 if (S_V_II(vec,j) < (INT)0)
1849 {
1850 erg = ERROR;
1851 goto lc_ende;
1852 }
1853 if (S_V_II(vec,j) > i) /* entry to big */
1854 {
1855 if (S_V_II(vec,j)-i > k) k = S_V_II(vec,j)-i;
1856 }
1857 }
1858
1859 if (k > (INT)0) /* to increase vector */
1860 {
1861 self = callocobject();
1862 liste = callocobject();
1863 erg += m_il_nv(k,self);
1864 erg += append(vec,self,liste);
1865 erg += lehmercode_vector(liste,b);
1866 erg += freeall(self);
1867 erg += freeall(liste);
1868 goto lc_ende;
1869 }
1870
1871 self = CALLOCOBJECT();
1872 liste = CALLOCOBJECT();
1873
1874 erg += m_il_integervector(S_V_LI(vec),self);
1875 erg += m_il_integervector(S_V_LI(vec),liste);
1876 /* initialisierung zweier vektoren fuer
1877 eine Liste und fuer die zu berechnende Permutation */
1878 for(i=(INT)0;i<S_V_LI(liste);i++) M_I_I(i+1L,(S_V_I(liste,i)));
1879 /* liste ist jetzt ein vector [1,2,3,....,n] */
1880 for(i=(INT)0;i<S_V_LI(vec);i++)
1881 {
1882 k=S_V_II(vec,i);
1883 /* k ist ist das i-te Element aus vec, also vi */
1884 M_I_I(S_V_II(liste,k),S_V_I(self,i));
1885 /* daher ist ei = k-te Element aus der aktuellen Liste*/
1886 for (j=k;j<(S_V_LI(vec)-1L)-i;j++)
1887 /* in der liste wird das k-te Element gestrichen.
1888 und von rechts aufgefuellt */
1889 C_I_I(S_V_I(liste,j),S_V_II(liste,j+1L));
1890 };
1891 FREEALL(liste);
1892 erg += b_ks_p(VECTOR,self,b);
1893 C_O_K(S_P_S(b),INTEGERVECTOR);
1894 lc_ende:
1895 ENDR("lehmercode_vector");
1896 }
1897
signum_permutation(perm,b)1898 INT signum_permutation(perm,b) OP perm, b;
1899 /* AK 240102 */
1900 /* AK 220704 V3.0 */
1901 {
1902 INT erg = OK;
1903 CPT(VECTOR,"signum_permutation(1)",perm);
1904 CTTO(INTEGER,EMPTY,"signum_permutation(2)",b);
1905 {
1906 INT i,j,res = 1;
1907 for (i=0;i<S_P_LI(perm);i++)
1908 for (j=i+1;j<S_P_LI(perm);j++)
1909 if ((S_P_II(perm,j) - S_P_II(perm,i )) < 0) res *= (-1);
1910 M_I_I(res,b);
1911 }
1912 CTO(INTEGER,"signum_permutation(2e)",b);
1913 ENDR("signum_permutation");
1914 }
1915
1916
1917
numberof_inversionen(a,b)1918 INT numberof_inversionen(a,b) OP a,b;
1919 /* b becomes number of inversions in a */
1920 /* AK 250889 V1.1 */ /* AK 150891 V1.3 */
1921 /* AK 220704 V3.0 */
1922 {
1923 INT erg = OK;
1924 CPTT(VECTOR,ZYKEL,"numberof_inversionen(1)",a);
1925 {
1926 OP c;
1927 c = CALLOCOBJECT();
1928 erg += lehmercode_permutation(a,c); /*result is a vector */
1929 erg += SYM_sum(c,b);
1930 FREEALL(c);
1931 }
1932 ENDR("numberof_inversionen");
1933 }
1934
lehmercode2_permutation(perm,vec)1935 INT lehmercode2_permutation(perm,vec) OP perm,vec;
1936 /* zweites verfahren */ /*AK 070488 */ /* ist langsamer */
1937 /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1938 {
1939 INT i,j,k;
1940 copy_vector(S_P_S(perm),vec);
1941 for (i=(INT)0;i<S_V_LI(vec);)
1942 {
1943 k = S_V_II(vec,i)-1L;
1944 M_I_I(k,S_V_I(vec,i));
1945 i++;
1946 for (j=i;j<S_V_LI(vec);j++)
1947 if (S_V_II(vec,j)>k)
1948 M_I_I(S_V_II(vec,j)-1L,S_V_I(vec,j));
1949 };
1950 return(OK);
1951 }
1952
1953
invers_permutation(perm,b)1954 INT invers_permutation(perm,b) OP perm,b;
1955 /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1956 {
1957 INT i,erg = OK;
1958 OP self;
1959
1960 CTO(PERMUTATION,"invers_permutation(1)",perm);
1961 CTO(EMPTY,"invers_permutation(2)",b);
1962
1963 if (S_P_K(perm) == BAR)
1964 {
1965 erg += invers_bar(perm,b);
1966 goto ee;
1967 }
1968 if (S_P_K(perm) != VECTOR) /* AK 010692 */
1969 return error("invers_perm: wrong perm type");
1970
1971 /* now the input is OK */
1972
1973 self = callocobject();
1974 erg += m_il_integervector(S_P_LI(perm),self);
1975 for ( i=(INT)0;i<S_V_LI(self); i++)
1976 M_I_I(i+1L,S_V_I(self,S_P_II(perm,i)-1L));
1977 erg += b_ks_p(VECTOR,self,b);
1978 ee:
1979 ENDR("invers_permutation");
1980 }
1981
1982
1983
callocpermutation()1984 static struct permutation * callocpermutation()
1985 /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
1986 {
1987 struct permutation *
1988 b = (struct permutation *)
1989 SYM_MALLOC((int)1 * sizeof(struct permutation));
1990 if (b == NULL)
1991 error("callocpermutation:no mem");
1992 mem_counter_perm++;
1993 return b;
1994 }
1995
m_il_p(l,p)1996 INT m_il_p(l,p) INT l; OP p;
1997 /* AK 200691 V1.2 */ /* AK 060891 V1.3 */
1998 /* AK 100902 V2.1 */
1999 {
2000 INT erg =OK;
2001 SYMCHECK(l<0,"m_il_p:l<0");
2002 erg += b_ks_p(VECTOR,callocobject(),p) ;
2003 erg += m_il_integervector(l,S_P_S(p)) ;
2004 ENDR("m_il_p");
2005 }
2006
m_l_p(l,p)2007 INT m_l_p(l,p) OP l,p;
2008 /* AK 100902 V2.1 */
2009 /* generates a permutation object with empty entries */
2010 {
2011 INT erg =OK;
2012 CTO(INTEGER,"m_l_p(1)",l);
2013 SYMCHECK(S_I_I(l)<0,"m_il_p:l<0");
2014 erg += b_ks_p(VECTOR,CALLOCOBJECT(),p) ;
2015 erg += m_il_integervector(S_I_I(l),S_P_S(p)) ;
2016 ENDR("m_l_p");
2017 }
2018
m_ks_p(kind,self,p)2019 INT m_ks_p(kind,self,p) OBJECTKIND kind; OP self,p;
2020 /* AK 210690 V1.1 */ /* AK 130691 V1.2 */ /* AK 060891 V1.3 */
2021 {
2022 INT erg = OK;
2023 COP("m_ks_p(3)",p);
2024
2025 if (self == p) {
2026 OP sc;
2027 sc = CALLOCOBJECT();
2028 COPY(self,sc);
2029 erg += b_ks_p(kind,sc,p);
2030 }
2031 else {
2032 erg += b_ks_p(kind,callocobject(),p) ;
2033 COPY(self,S_P_S(p));
2034 }
2035
2036 ENDR("m_ks_p");
2037 }
2038
b_ks_p(kind,self,p)2039 INT b_ks_p(kind,self,p) OBJECTKIND kind; OP self,p;
2040 /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 130691 V1.2 */
2041 /* AK 060891 V1.3 */
2042 {
2043 OBJECTSELF b;
2044 INT erg = OK;
2045 COP("b_ks_p(3)",p);
2046
2047 b.ob_permutation = callocpermutation();
2048 erg += b_ks_o(PERMUTATION, b,p);
2049 C_P_S(p,self);
2050 C_P_K(p,kind);
2051 ENDR("b_ks_p");
2052 }
2053
scan_permutation_cycle(a)2054 INT scan_permutation_cycle(a) OP a;
2055 /* AK 010692 */
2056 {
2057 INT erg = OK;
2058 CTO(EMPTY,"scan_permutation_cycle(1)",a);
2059 erg += b_ks_p(ZYKEL,callocobject(),a);
2060 erg += printeingabe("input of a permutation in cycle notation");
2061 erg += scan(INTEGERVECTOR,S_P_S(a));
2062 ENDR("scan_permutation_cycle");
2063 }
2064
strong_check_permutationp(a)2065 INT strong_check_permutationp(a) OP a;
2066 /* AK 030594 */
2067 {
2068 OP h;
2069 INT i;
2070
2071 if (a == NULL)
2072 return FALSE;
2073 if (S_O_K(a) != PERMUTATION)
2074 return FALSE;
2075 if (
2076 (S_P_K(a) == ZYKEL)
2077 ||
2078 (S_P_K(a) == VECTOR)
2079 )
2080 {
2081 if (S_P_S(a) == NULL)
2082 return FALSE;
2083 if (
2084 (S_O_K(S_P_S(a)) != INTEGERVECTOR) &&
2085 (S_O_K(S_P_S(a)) != VECTOR) )
2086 return FALSE;
2087 for (i=0;i<S_P_LI(a);i++) /* AK 181203 */
2088 {
2089 if (S_P_II(a,i)<1) return FALSE;
2090 if (S_P_II(a,i)>S_P_LI(a) ) return FALSE;
2091 }
2092 h = callocobject();
2093 m_il_v(S_P_LI(a),h);
2094 for (i=(INT)0;i<S_V_LI(h);i++)
2095 M_I_I(i+(INT)1, S_V_I(h,i));
2096 for (i=(INT)0;i<S_V_LI(h);i++)
2097 M_I_I((INT)0, S_V_I(h,S_P_II(a,i) -(INT)1));
2098
2099 i = nullp(h);
2100 freeall(h);
2101 return i;
2102 }
2103 return FALSE;
2104 }
2105
scan_permutation(a)2106 INT scan_permutation(a) OP a;
2107 /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 040391 V1.2 */
2108 /* AK 060891 V1.3 */
2109 {
2110 INT erg=OK;
2111 CTO(EMPTY,"scan_permutation(1)",a);
2112 spa:
2113 erg = OK;
2114 erg += b_ks_p(VECTOR,callocobject(),a);
2115 erg += printeingabe("input of a permutation in list notation");
2116 erg += scan(INTEGERVECTOR,S_P_S(a));
2117 if (not strong_check_permutationp(a))
2118 {
2119 fprintln(stderr,a);
2120 printeingabe("wrong input, please enter a permutation");
2121 goto spa;
2122 }
2123 ENDR("scan_permutation");
2124 }
2125
2126
mult_apply_permutation(a,b)2127 INT mult_apply_permutation(a,b) OP a,b;
2128 /* AK 051198 V2.0 */
2129 /* b = ab */
2130 /* AK 221104 V3.0 */
2131 {
2132 INT erg = OK;
2133 CTO(PERMUTATION,"mult_apply_permutation(1)",a);
2134 {
2135 OP c;
2136 c = CALLOCOBJECT();
2137 erg += swap(b,c);
2138 erg += mult_permutation(a,c,b);
2139 FREEALL(c);
2140 }
2141 ENDR("mult_apply_permutation");
2142 }
2143
mult_permutation(a,b,c)2144 INT mult_permutation(a,b,c) OP a,b,c;
2145 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2146 {
2147 INT erg = OK;
2148 CTO(PERMUTATION,"mult_permutation(1)",a);
2149 CTO(PERMUTATION,"mult_permutation(2)",b);
2150 CTO(EMPTY,"mult_permutation(3)",c);
2151 {
2152 INT i;
2153 OP d = NULL; /* AK 270493 */
2154
2155 if ((S_P_K(a) == BAR) && (S_P_K(b) == BAR))
2156 {
2157 erg += mult_bar_bar(a,b,c);
2158 goto endr_ende;
2159 }
2160 if ((S_P_K(a) != VECTOR) || (S_P_K(b) != VECTOR)) /* AK 210192 */
2161 return error("mult_permutation:only for VECTOR type");
2162
2163 if (S_P_LI(a) < S_P_LI(b)) /* AK 270493 */
2164 {
2165 d = callocobject();
2166 erg += m_il_p(S_P_LI(b),d);
2167 for (i=(INT)0;i<S_P_LI(a);i++)
2168 M_I_I(S_P_II(a,i),S_P_I(d,i));
2169 for (;i<S_P_LI(d);i++)
2170 M_I_I(i+1L,S_P_I(d,i));
2171 a = d;
2172 }
2173 else if (S_P_LI(a) > S_P_LI(b)) /* AK 270493 */
2174 {
2175 d = callocobject();
2176 erg += m_il_p(S_P_LI(a),d);
2177 for (i=(INT)0;i<S_P_LI(b);i++)
2178 M_I_I(S_P_II(b,i),S_P_I(d,i));
2179 for (;i<S_P_LI(d);i++)
2180 M_I_I(i+1L,S_P_I(d,i));
2181 b = d;
2182 }
2183 erg += copy_permutation(b,c);
2184 for (i=(INT)0;i<S_P_LI(c);i++)
2185 M_I_I(S_P_II(a,S_P_II(b,i)-1L),S_P_I(c,i));
2186
2187 if (d != NULL)
2188 erg += freeall(d);
2189 }
2190 ENDR("mult_permutation");
2191 }
2192
copy_permutation(a,b)2193 INT copy_permutation(a,b) OP a,b;
2194 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 210291 V1.2 */
2195 /* AK 150891 V1.3 */
2196 {
2197 INT erg; /* 210291 */
2198 erg = b_ks_p(S_P_K(a),callocobject(),b);
2199 erg += m_il_integervector(S_P_LI(a),S_P_S(b));
2200 if (erg != OK)
2201 return erg;
2202 if (memcpy( (char *) S_V_S(S_P_S(b)), (char *) S_V_S(S_P_S(a)),
2203 (int) (S_P_LI(a) * sizeof(struct object))) == NULL)
2204
2205 return ERROR;
2206 else
2207 return OK;
2208 }
2209
2210
length_permutation(a,b)2211 INT length_permutation(a,b) OP a,b;
2212 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */
2213 {
2214 return copy(S_P_L(a),b);
2215 }
sprint_permutation(t,a)2216 INT sprint_permutation(t,a) char *t; OP a;
2217 /* AK 120598 V2.0 */
2218 {
2219 INT erg = OK;
2220 COP("sprint_permutation(1)",t);
2221 CTO(PERMUTATION,"sprint_permutation(2)",a);
2222
2223 if (S_P_K(a) == VECTOR)
2224 erg += sprint(t,S_P_S(a));
2225 else
2226 {
2227 erg += error("fprint_permutation:wrong type of permutation");
2228 }
2229 ENDR("sprint_permutation");
2230 }
2231
fprint_permutation(f,a)2232 INT fprint_permutation(f,a) OP a; FILE *f;
2233 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2234 /* AK 280192 for other types of permutation */
2235 {
2236 INT erg = OK;
2237 INT i,j;
2238 if (
2239 (S_P_K(a) == VECTOR)
2240 ||
2241 (S_P_K(a) == BAR)
2242 ||
2243 (S_P_K(a) == BITREC)
2244 )
2245 {
2246 erg += fprint(f,S_P_S(a));
2247 }
2248 else if (
2249 (S_P_K(a) == ZYKEL)
2250 ||
2251 (S_P_K(a) == BARCYCLE)
2252 )
2253 {
2254 j = S_P_II(a,(INT)0);
2255 fprintf(f,"(");
2256 if (f == stdout)
2257 zeilenposition++;
2258 for (i=(INT)0;i<s_p_li(a);i++)
2259 {
2260 if (S_P_II(a,i) < j) /* new cycle */
2261 {
2262 fprintf(f,")(");
2263 if (f == stdout)
2264 zeilenposition+=2L;
2265 j = S_P_II(a,i);
2266 }
2267 else if (i != (INT)0)
2268 {
2269 fprintf(f,",");
2270 if (f == stdout)
2271 zeilenposition++;
2272 }
2273 erg += fprint(f,S_P_I(a,i));
2274 }
2275 fprintf(f,")");
2276 if (f == stdout)
2277 zeilenposition++;
2278 }
2279 else
2280 {
2281 erg += error("fprint_permutation:wrong type of permutation");
2282 }
2283 return erg;
2284 }
2285
2286
2287
dec_permutation(a)2288 INT dec_permutation(a) OP a;
2289 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2290 {
2291 INT erg = OK;
2292 CTO(PERMUTATION,"dec_permutation(1)",a);
2293 erg += dec_integervector(S_P_S(a));
2294 ENDR("dec_permutation");
2295 }
2296
2297
2298
2299
inc_permutation(perm)2300 INT inc_permutation(perm) OP perm;
2301 /* AK 171187
2302 nur fuer listendarstellung realisiert die Einbettung S_n ---> S_{n+1} */
2303 /* am anfang eine 1 dazu */
2304 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */
2305 {
2306 INT i;
2307 INT erg = OK;
2308 CTO(PERMUTATION,"inc_permutation(1)",perm);
2309 if (S_P_K(perm) != VECTOR)
2310 return error("inc_permutation:wrong kind");
2311 erg += inc(S_P_S(perm));
2312 for(i=S_P_LI(perm)-1L;i>(INT)0;i--)
2313 M_I_I(S_P_II(perm,i-1L)+1L,S_P_I(perm,i));
2314 M_I_I(1L,S_P_I(perm,(INT)0));
2315 ENDR("inc_permutation");
2316 }
2317
2318
2319
last_permutation(l,ree)2320 INT last_permutation(l,ree) OP l, ree;
2321 /* AK 101187 */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */
2322 {
2323 OP zwerg;
2324 INT erg=OK;
2325 CTO(INTEGER,"last_permutation(1)",l);
2326 zwerg = callocobject();
2327 erg += last_lehmercode(l,zwerg);
2328 erg += lehmercode(zwerg,ree);
2329 FREEALL(zwerg);
2330 ENDR("last_permutation");
2331 }
2332
2333
rz_perm(perm,c)2334 INT rz_perm(perm,c) OP perm,c;
2335 /* AK 050198 V2.0 */
2336 /* computes a reduced decomposition of a permutation */
2337 /* AK 270887 */ /* AK 070789 V1.0 */
2338 /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2339 {
2340 INT erg=OK; /* 260292 */
2341 OP lc;
2342 CTO(PERMUTATION,"rz_perm(1)",perm);
2343 lc = callocobject();
2344
2345 erg += lehmercode_permutation(perm,lc);
2346 erg += rz_lehmercode(lc,c);
2347 erg += freeall(lc);
2348 ENDR("rz_perm");
2349 }
2350
rz_lehmercode(lc,b)2351 INT rz_lehmercode(lc,b) OP lc,b;
2352 /* AK 241087
2353 bildet die reduzierte zerlegung des lehmercodes lc
2354 bsp lc = 321200 dann ist ergebnis 32132354
2355 vgl verfahren 1 in diplomarbeit */
2356 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2357 {
2358 INT i = S_V_LI(lc), /* laufvariable durch l.c. */
2359 k , /* laufvariable durch ergebnis */
2360 j,erg = OK;
2361 OP zw;
2362
2363 CTO(VECTOR,"rz_lehmercode(1)",lc);
2364 COP("rz_lehmercode(2)",b);
2365
2366 zw = callocobject();
2367 erg += SYM_sum(lc,zw);
2368 if (NULLP(zw))
2369 {
2370 erg += m_il_integervector((INT)0,b);
2371 erg += freeall(zw);
2372 goto ende;
2373 }
2374 k = S_I_I(zw);
2375 erg += b_l_v(zw,b);
2376 /* die laenge der reduzierten zerlegung ist die summe des lehmercodes */
2377 while (i-- > (INT)0)
2378 if (S_V_II(lc,i) > (INT)0)
2379 for (j=(INT)0;j<S_V_II(lc,i);j++)
2380 {
2381 --k;
2382 if (k < (INT)0) /* AK 271087 */
2383 return(error("rzoflc:k < 0"));
2384
2385 M_I_I(i+1+j,S_V_I(b,k));
2386 };
2387 ende:
2388 ENDR("rz_lehmercode");
2389 }
2390
random_permutation(ln,b)2391 INT random_permutation(ln,b) OP ln, b;
2392 /* AK 150587 */ /* nijnhuis kap 8 */ /* AK 070789 V1.0 */
2393 /* an dieser stelle wird float verwandt */
2394 /* AK 181289 V1.1 */
2395 /* rand() gibt auf verschiedenen rechnern zufallszahlen in unter
2396 schiedlichen bereichen */ /* AK 150891 V1.3 */
2397 /* AK 150296 FMD */
2398 /* AK 110804 V3.0 */
2399 {
2400 INT erg = OK;
2401 CTO(INTEGER,"random_permutation(1)",ln);
2402 SYMCHECK(S_I_I(ln)<1,"random_permutation(1)<1");
2403 {
2404 INT i,l,merk;
2405 INT integerlength;
2406 float zw;
2407 int rand();
2408
2409 integerlength = S_I_I(ln);
2410 erg += first_permutation(ln,b);
2411 for (i=(INT)0;i<integerlength;i++)
2412 {
2413 zw = (float) (rand() % 32767) /32767.0;
2414 l = i + (int)(zw * (integerlength-i));
2415 merk = S_P_II(b,l);
2416 M_I_I(S_P_II(b,i),S_P_I(b,l));
2417 M_I_I(merk,S_P_I(b,i));
2418 }
2419 }
2420 ENDR("random_permutation");
2421 }
2422 #endif /* PERMTRUE */
2423
2424
s_p_s(a)2425 OP s_p_s(a) OP a;
2426 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2427 {
2428 OBJECTSELF c;
2429 c = s_o_s(a);
2430 return(c.ob_permutation->p_self);
2431 }
2432
s_p_k(a)2433 OBJECTKIND s_p_k(a) OP a;
2434 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2435 {
2436 OBJECTSELF c;
2437 c = s_o_s(a);
2438 return(c.ob_permutation->p_kind);
2439 }
2440
s_p_i(a,i)2441 OP s_p_i(a,i) OP a; INT i;
2442 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2443 {
2444 return(s_v_i(s_p_s(a),i));
2445 }
2446
s_p_ii(a,i)2447 INT s_p_ii(a,i) OP a; INT i;
2448 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070891 V1.3 */
2449 {
2450 if (a == NULL)
2451 return error("s_p_ii: a == NULL");
2452 if (not permutationp(a))
2453 return error("s_p_ii: a not permutation");
2454 if (i >= s_p_li(a))
2455 return error("s_p_ii: i to big");
2456 return(s_v_ii(s_p_s(a),i));
2457 }
2458
s_p_l(a)2459 OP s_p_l(a) OP a;
2460 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070891 V1.3 */
2461 {
2462 return(s_v_l(s_p_s(a)));
2463 }
2464
s_p_li(a)2465 INT s_p_li(a) OP a;
2466 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2467 {
2468 if (a == NULL)
2469 return error("s_p_li: a == NULL");
2470 if (not permutationp(a))
2471 return error("s_p_li: a not permutation");
2472 return(s_v_li(s_p_s(a)));
2473 }
2474
c_p_k(a,b)2475 INT c_p_k(a,b) OP a; OBJECTKIND b;
2476 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2477 {
2478 OBJECTSELF c;
2479 if (a == NULL) /* AK 040292 */
2480 return error("c_p_k:NULL object");
2481 if (s_o_k(a) != PERMUTATION) /* AK 040292 */
2482 return error("c_p_k:no PERMUTATION");
2483 if ( /* AK 040292 */
2484 (b != VECTOR)&&
2485 (b != ZYKEL) )
2486 return error("c_p_k:wrong kind");
2487
2488 c = s_o_s(a);
2489 c.ob_permutation->p_kind = b;
2490 return(OK);
2491 }
2492
c_p_s(a,b)2493 INT c_p_s(a,b) OP a,b;
2494 /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2495 {
2496 OBJECTSELF c;
2497 c = s_o_s(a);
2498 c.ob_permutation->p_self = b;
2499 return(OK);
2500 }
2501
2502 #ifdef PERMTRUE
elementarp_permutation(a,b)2503 INT elementarp_permutation(a,b) OP a,b;
2504 /* AK 210889 */ /* AK 230889 */
2505 /* true falls sich die beiden perm durch eine elementartransposition
2506 multipliziert von rechts unterscheiden */
2507 /* AK 250889 V1.1 */ /* AK 150891 V1.3 */
2508 {
2509 INT i;
2510 for (i=(INT)0;i<S_P_LI(a);i++)
2511 {
2512 if (S_P_II(b,i) != S_P_II(a,i)) break;
2513 }
2514 if (i == S_P_LI(a)) return(FALSE); /* zwei gleiche permutationen */
2515 if (i == S_P_LI(a)-1L) {
2516 fprintln(stderr,a);
2517 fprintln(stderr,b);
2518 return error("elementarp: error in permutation");
2519 }
2520 if (S_P_II(a,i) != S_P_II(b,i+1L)) return(FALSE);
2521 if (S_P_II(b,i) != S_P_II(a,i+1L)) return(FALSE); /* keine elementar
2522 transposition */
2523 for(i += 2; i<S_P_LI(a);i++)
2524 if (S_P_II(b,i) != S_P_II(a,i)) return(FALSE);
2525 return(TRUE);
2526
2527 }
2528
2529
objectread_permutation(filename,perm)2530 INT objectread_permutation(filename,perm) OP perm; FILE *filename;
2531 /* AK 291086 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2532 {
2533 INT i;
2534 OBJECTKIND kind;
2535 INT erg = OK;
2536 COP("objectread_permutation(1)",filename);
2537 CTO(EMPTY,"objectwrite_permutation(2)",perm);
2538
2539 erg += b_ks_p((OBJECTKIND)0, callocobject(),perm);
2540 fscanf(filename, "%" SCNINT ,&i); kind = (OBJECTKIND)i;
2541 C_P_K(perm,kind);
2542 erg += objectread(filename,S_P_S(perm));
2543 ENDR("objectread_permutation");
2544 }
2545
2546
2547
objectwrite_permutation(filename,perm)2548 INT objectwrite_permutation(filename,perm) FILE *filename; OP perm;
2549 /* AK 291086 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2550 {
2551 INT erg = OK;
2552 COP("objectwrite_permutation(1)",filename);
2553 CTO(PERMUTATION,"objectwrite_permutation(2)",perm);
2554
2555 fprintf(filename, "%" PRIINT "\n" ,(INT)PERMUTATION);
2556 fprintf(filename, "%" PRIINT "\n" ,(INT)S_P_K(perm));
2557 erg += objectwrite(filename,S_P_S(perm));
2558 ENDR("objectwrite_permutation");
2559 }
2560
zykeltyp(a,b)2561 INT zykeltyp(a,b) OP a,b;
2562 /* AK 170789 V1.0 *//* AK 181289 V1.1 *//* AK 180691 V1.2 *//* AK 150891 V1.3 *//* AK 050898 V2.0 */
2563 {
2564 INT erg = OK;
2565
2566 CE2(a,b,zykeltyp);
2567 CPT(VECTOR,"zykeltyp",a);
2568 erg += zykeltyp_permutation(a,b);
2569 ENDR("zykeltyp");
2570 }
2571
2572
2573
2574 #ifdef PARTTRUE
zykeltyp_permutation_pre190202(a,b)2575 INT zykeltyp_permutation_pre190202(a,b) OP a,b;
2576 /* AK 120488 */ /* AK 170789 V1.0 */ /* AK 181289 V1.1 */ /* AK 180691 V1.2 */
2577 /* AK 150891 V1.3 */
2578 {
2579 INT i,zykellength,alt,n;
2580 INT erg = OK; /* AK 221191 */
2581 OP self;
2582 CPT(VECTOR,"zykeltyp_permutation(1)",a);
2583
2584 self=callocobject();
2585
2586 erg += copy_integervector(S_P_S(a),self);
2587 for (i=(INT)0;i<S_V_LI(self);i++)
2588 if (S_V_II(self,i) != (INT)0) /* noch nicht im zykel */
2589 {
2590 zykellength=1L;
2591 alt=i;
2592 while (S_V_II(self,alt) != (i+1L))
2593 {
2594 n = S_V_II(self,alt)-1L;
2595 M_I_I((INT)0,S_V_I(self,alt));
2596 alt = n;
2597 zykellength++;
2598 };
2599 M_I_I((INT)0,S_V_I(self,alt));
2600 M_I_I(zykellength,S_V_I(self,i));
2601 };
2602 erg += m_v_pa(self,b);
2603 erg += freeall(self);
2604 ENDR("zykeltyp_permutation");
2605 }
2606
zykeltyp_permutation(a,b)2607 INT zykeltyp_permutation(a,b) OP a,b;
2608 /* AK 190202 */
2609 {
2610 INT i,zykellength,alt,n,l=0;
2611 INT erg = OK;
2612 OP self;
2613 CPT(VECTOR,"zykeltyp_permutation(1)",a);
2614 CTO(EMPTY,"zykeltyp_permutation(2)",b);
2615
2616 if (zykeltyp_perm_v == NULL)
2617 {
2618 zykeltyp_perm_v = CALLOCOBJECT();
2619 erg += m_il_nv(2,zykeltyp_perm_v);
2620 }
2621
2622
2623 self=zykeltyp_perm_v;
2624
2625
2626 for (i=(INT)0;i<S_P_LI(a);i++)
2627 if (S_P_II(a,i) > 0) /* noch nicht im zykel */
2628 {
2629 zykellength=1L;
2630 alt=i;
2631 while (S_P_II(a,alt) != (i+1))
2632 {
2633 n = S_P_II(a,alt)-1;
2634 ADDINVERS_APPLY_INTEGER(S_P_I(a,alt));
2635 alt = n;
2636 zykellength++;
2637 };
2638 ADDINVERS_APPLY_INTEGER(S_P_I(a,alt));
2639 M_I_I(zykellength,S_V_I(self,l));
2640 l++;
2641 if (l >= S_V_LI(self)) inc_vector_co(self,10);
2642 };
2643
2644 for (i=(INT)0;i<S_P_LI(a);i++) ADDINVERS_APPLY_INTEGER(S_P_I(a,i));
2645 n = S_V_LI(self);
2646 C_I_I(S_V_L(self),l);
2647 erg += m_v_pa(self,b);
2648 C_I_I(S_V_L(self),n);
2649
2650 ENDR("zykeltyp_permutation");
2651 }
2652
2653
2654
2655
m_part_perm(a,b)2656 INT m_part_perm(a,b) OP a,b;
2657 /* erzeugt aus zykeltyp permutation */
2658 /* AK 120488 */ /* AK 170789 V1.0 */ /* AK 181289 V1.1 */ /* AK 130691 V1.2 */
2659 /* AK 070891 V1.3 */ /* AK 050898 V2.0 */
2660 /* AK 021106 V3.1 */
2661 {
2662 INT i,j,k; /* die adresse in der perm. b */
2663 INT erg = OK; /* AK 221191 */
2664 OP l;
2665
2666 CE2(a,b,m_part_perm);
2667 CTO(PARTITION,"m_part_perm(1)",a);
2668
2669 l=callocobject();
2670
2671 if (S_PA_K(a) == EXPONENT) {
2672 /* AK 151189 */
2673 erg += t_EXPONENT_VECTOR(a,l);
2674 erg += m_part_perm(l,b);
2675 erg += freeall(l);
2676 goto endr_ende;
2677 }
2678 else if (S_PA_K(a) == VECTOR)
2679 {
2680 erg += weight(a,l);
2681 erg += b_ks_p(VECTOR,callocobject(),b);
2682 erg += b_l_v(l,S_P_S(b));
2683 k=0;
2684 for (i=0;i<S_PA_LI(a);i++)
2685 {
2686 /* k ist naechste frei stelle */
2687 M_I_I(k+1L,S_P_I(b,k+S_PA_II(a,i)-1L));
2688 for (j=1L;j<S_PA_II(a,i);j++)
2689 M_I_I(j+k+1L,S_P_I(b,k+j-1L));
2690 k=k+S_PA_II(a,i);
2691 }
2692 }
2693 else
2694 {
2695 erg += error("m_part_perm(1): wrong type of partition");
2696 }
2697 ENDR("m_part_perm");
2698 }
2699 #endif /* PARTTRUE */
2700
2701
2702
zykeltyp_hoch_n(a,b,c)2703 INT zykeltyp_hoch_n(a,b,c) OP a,b,c;
2704 /* AK 160988 */
2705 /* a ist zykeltyp b ist integer c wird der zykeltyp nach b-maligen
2706 anwenden einer permutation vom typ a */
2707 /* AK 170789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */
2708 {
2709 INT i,k;
2710 if (S_O_K(a) != PARTITION)
2711 return(error("zykeltyp_hoch_n:S_O_K(a) != PARTITION"));
2712 if (S_O_K(b) != INTEGER)
2713 return(error("zykeltyp_hoch_n:S_O_K(b) != INTEGER"));
2714 if (S_PA_K(a) == VECTOR)
2715 {
2716 OP d = callocobject();
2717 i = OK;
2718 i += t_VECTOR_EXPONENT(a,d);
2719 i += zykeltyp_hoch_n(d,b,c);
2720 i += freeall(d);
2721 return(i);
2722 }
2723 copy(a,c);
2724 /* nun nachschauen ob ggt von b und den einzelnen
2725 zykellaengen > 1, dann zerfaellt dieser zykel naemlich */
2726
2727 for (i=(INT)0; i<S_PA_LI(a); i++)
2728 if (S_PA_II(a,i) > (INT)0) {
2729 k = ggt_i(S_I_I(b),i+1L);
2730 if (k>1L) {
2731 M_I_I( (
2732 (S_PA_II(c,((i+1L)/k -1L)))
2733 +
2734 (k * S_PA_II(c,i) )
2735 ),
2736 S_PA_I(c, (i+1L)/k -1L)
2737 );
2738 M_I_I((INT)0,S_PA_I(c,i));
2739 };
2740 };
2741 return(OK);
2742 }
2743 #endif /* PERMTRUE */
2744
t_VECTOR_ZYKEL(a,b)2745 INT t_VECTOR_ZYKEL(a,b) OP a,b; /* AK 291091 */
2746 {
2747 return t_vperm_zperm(a,b);
2748 }
2749
t_vperm_zperm(a,b)2750 INT t_vperm_zperm(a,b) OP a,b;
2751 /* aus einer vector-permutation
2752 eine zykel-permutation */
2753 /* folgende darstellung des zykel
2754 zuerst der zykel mit groessten kleinsten element
2755 usw als letztes der zykel mit der 1
2756 */
2757 /* bsp (1256)(387)(49) als
2758 [4,9,3,8,7,1,2,5,6] */
2759 /* AK 050390 V1.1 */ /* AK 080891 V1.3 */
2760 {
2761 INT i,erg =OK;
2762 INT schreibindex;
2763 INT leseindex,altleseindex;
2764 INT startindex=(INT)0,startwert;
2765 INT ergindex = S_P_LI(a)-1;
2766 /* der freie index am rechten ende */
2767 OP c;
2768 CE2(a,b,t_vperm_zperm);
2769
2770 c= callocobject();
2771 erg += copy(a,c);
2772 erg += copy(a,b);
2773 C_P_K(b,ZYKEL);
2774 m_vperm_zperm_again:
2775 for (i=startindex;i<S_P_LI(c);i++)
2776 if (S_P_II(c,i) != (INT)0) break;
2777 if (i == S_P_LI(a))
2778 {
2779 erg += freeall(c);
2780 goto endr_ende;
2781 /* der algorithmus ist fertig wenn
2782 der hilfsvector c=000...0000 */
2783 }
2784
2785 /* ist der erste index mit eintrag != 0 in c
2786 d.h. noch in keinem zykel */
2787
2788 schreibindex=(INT)0;
2789 startwert = i+1; /* der wert mit dem der zykel startet */
2790 leseindex = i;
2791 m_vperm_zperm_next:
2792 M_I_I(leseindex+1L,S_P_I(b,schreibindex));
2793 schreibindex++;
2794 /* zykelelement wurde geschreiben */
2795 altleseindex=leseindex;
2796 leseindex = S_P_II(a,leseindex)-1;
2797 M_I_I((INT)0,S_P_I(c,altleseindex));
2798 if (leseindex+1 == startwert) {
2799 /* der zykel ist zu ende */
2800 /* der zykel muss nach rechts geschoben werden */
2801 do
2802 {
2803 schreibindex--;
2804 M_I_I(S_P_II(b,schreibindex),S_P_I(b,ergindex));
2805 ergindex--;
2806 }
2807 while (schreibindex > (INT)0);
2808 goto m_vperm_zperm_again;
2809 };
2810 goto m_vperm_zperm_next;
2811 ENDR("t_vperm_zperm");
2812 }
2813
t_ZYKEL_VECTOR(a,b)2814 INT t_ZYKEL_VECTOR(a,b) OP a,b; /* AK 291091 */
2815 {
2816 return t_zperm_vperm(a,b);
2817 }
2818
t_zperm_vperm(a,b)2819 INT t_zperm_vperm(a,b) OP a,b;
2820 /* AK 050390 V1.1 */ /* AK 080891 V1.3 */
2821 {
2822 INT index = (INT)0;
2823 INT startwert, schreibindex;
2824 INT erg = OK; /* AK 291091 */
2825 CE2(a,b,t_zperm_vperm);
2826 copy(a,b);
2827 C_P_K(b,VECTOR);
2828 m_zperm_vperm_again:
2829 startwert = S_P_II(a,index); /* zykelanfang */
2830 index++;
2831 schreibindex = startwert-1;
2832
2833 if (index < S_P_LI(a)) /* AK 210597 */
2834 while (S_P_II(a,index) > startwert)
2835 {
2836 M_I_I(S_P_II(a,index), S_P_I(b,schreibindex));
2837 schreibindex = S_P_II(a,index) - 1;
2838 index++;
2839 if (index == S_P_LI(a)) break;
2840 };
2841
2842 /* wir sind am zykelende */
2843 /* index ist anfang naechster zykel */
2844 M_I_I(startwert, S_P_I(b,schreibindex));
2845 if (index != S_P_LI(a)) goto m_zperm_vperm_again;
2846 /* ende der permutation */
2847 ENDR("t_zperm_vperm");
2848 }
2849
2850 #ifdef MATRIXTRUE
2851 #ifdef PERMTRUE
permutation_matrix(a,b)2852 INT permutation_matrix(a,b) OP a,b;
2853 {
2854 return perm_matrix(a,b);
2855 }
2856
2857
perm_matrix(a,b)2858 INT perm_matrix(a,b) OP a,b;
2859 /* AK 181289 permutationsmatrix (0,1) zu einer permutation */
2860 /* AK 181289 V1.1 */
2861 /* AK 150891 V1.3 */
2862 /* FM 210296 */
2863 /* AK 220498 V2.0 */
2864 /* AK 261103 for barred permutations */
2865 /* input: PERMUTATION
2866 output: 01 matrix b_ij = 1 if a(j) = i */
2867 /* AK 060704 V3.0 */
2868 {
2869 INT erg = OK;
2870 CPTT(BAR,VECTOR,"perm_matrix(1)",a);
2871 CE2(a,b,perm_matrix);
2872 {
2873 INT i,j;
2874 erg += m_ilih_m(S_P_LI(a),S_P_LI(a),b);
2875 for (i=0; i<S_P_LI(a); i++)
2876 for (j=0; j<S_P_LI(a); j++)
2877 if (S_P_II(a,j) == i+1L) M_I_I(1,S_M_IJ(b,i,j));
2878 else if (S_P_II(a,j) == -(i+1)) M_I_I(-1,S_M_IJ(b,i,j));
2879 else M_I_I(0,S_M_IJ(b,i,j));
2880 }
2881 ENDR("perm_matrix");
2882 }
2883
perm_matrix_p(a)2884 INT perm_matrix_p(a) OP a;
2885 /* true if a is a permutation matrix */
2886 /* AK 060704 V3.0 */
2887 {
2888 INT erg = OK;
2889 CTTO(MATRIX,INTEGERMATRIX,"perm_matrix_p(1)",a);
2890 {
2891 INT i,j,e;
2892 if (S_M_HI(a) != S_M_LI(a)) return FALSE;
2893 for (i=0;i<S_M_HI(a);i++)
2894 {
2895 e=0;
2896 for (j=0;j<S_M_LI(a);j++)
2897 {
2898 if (NULLP(S_M_IJ(a,i,j))) continue;
2899 else if ((e==0) && EINSP(S_M_IJ(a,i,j))) e++;
2900 else return FALSE;
2901 }
2902 if (e==0) return FALSE;
2903 }
2904 /* now we know each row has one 1 */
2905 /* now check the columns */
2906 for (j=0;j<S_M_LI(a);j++)
2907 {
2908 e=0;
2909 for (i=0;i<S_M_HI(a);i++)
2910 {
2911 if (NULLP(S_M_IJ(a,i,j))) continue;
2912 else if ((e==0) && EINSP(S_M_IJ(a,i,j))) e++;
2913 else return FALSE;
2914 }
2915 if (e==0) return FALSE;
2916 }
2917 return TRUE;
2918 }
2919 ENDR("perm_matrix_p");
2920 }
2921
2922 #endif /* PERMTRUE */
2923 #endif /* MATRIXTRUE */
2924
2925 #ifdef PERMTRUE
einsp_permutation(a)2926 INT einsp_permutation(a) OP a;
2927 /* test auf identitaet */ /* AK 221289 V1.1 */ /* AK 150891 V1.3 */
2928 {
2929 INT erg = OK;
2930 CTO(PERMUTATION,"einsp_permutation(1)",a);
2931 {
2932 INT i,j;
2933 if (S_P_K(a) == VECTOR) {
2934 for (i=S_P_LI(a) -1;i>=0;i--)
2935 if (S_P_II(a,i) != (i+1L)) return(FALSE);
2936 return(TRUE);
2937 }
2938 else if (S_P_K(a) == ZYKEL) {
2939 for (j=1,i=S_P_LI(a) -1;i>=0;i--,j++)
2940 if (S_P_II(a,i) != j ) return(FALSE);
2941 return(TRUE);
2942 }
2943 else if (S_P_K(a) == BAR) {
2944 for (j=S_P_LI(a),i=S_P_LI(a) -1;i>=0;i--,j--)
2945 if (S_P_II(a,i) != j ) return(FALSE);
2946 return(TRUE);
2947 }
2948 else {
2949 WTO("einsp_permutation(1.typ)",a);
2950 }
2951 }
2952 ENDR("einsp_permutation");
2953 }
2954
2955
2956
comp_lex_perm(a,b)2957 INT comp_lex_perm(a,b) OP a,b;
2958 /* AK 070390 V1.1 */ /* AK 150891 V1.3 */
2959 /* AK 020902 V2.0 */
2960 {
2961 return COMP(S_P_S(a),S_P_S(b));
2962 }
2963
2964
2965
2966 #ifdef POLYTRUE
2967
operate_gral_polynom(a,b,c)2968 INT operate_gral_polynom(a,b,c) OP a,b,c;
2969 /* a is GRAL, b is POLYNOM, c becomes POLYNOM */
2970 /* AK 200891 V1.3 */
2971 {
2972 OP z,d;
2973 INT erg = OK;
2974 CTO(GRAL,"operate_gral_polynom(1)",a);
2975 CTO(POLYNOM,"operate_gral_polynom(2)",b);
2976 if (S_L_S(b) == NULL) /* AK 141092 */
2977 return copy(b,c);
2978 erg += init(POLYNOM,c);
2979 z = a;
2980 d = callocobject();
2981 while (z != NULL)
2982 {
2983 erg += operate_perm_polynom(S_PO_S(z),b,d);
2984 erg += mult_apply(S_PO_K(z),d);
2985 erg += add_apply(d,c);
2986 z = S_PO_N(z);
2987 }
2988 erg += freeall(d);
2989 ENDR("operate_gral_polynom");
2990 }
2991
2992
operate_perm_polynom(a,b,c)2993 INT operate_perm_polynom(a,b,c) OP a,b,c;
2994 /* a is PERMUTATION, b is POLYNOM, c becomes POLYNOM */
2995 /* AK 200891 V1.3 */
2996 {
2997 INT erg = OK;
2998 CTO(PERMUTATION,"operate_perm_polynom(1)",a);
2999 SYMCHECK((S_P_K(a) != VECTOR)&&(S_P_K(a) != BAR),
3000 "operate_perm_polynom(1) only for VECTOR or BAR permutations");
3001 CTO(POLYNOM,"operate_perm_polynom(2)",b);
3002 CE3(a,b,c,operate_perm_polynom);
3003 {
3004 OP z,d,aa;
3005 INT j = 1;
3006 if (S_L_S(b) == NULL) /* AK 141092 */
3007 {
3008 erg += copy(b,c);
3009 goto endr_ende;
3010 }
3011 erg += init(POLYNOM,c);
3012
3013 if (S_P_K(a) == VECTOR) aa = a;
3014 else { /* Barred permutation */
3015 INT i;
3016 aa = CALLOCOBJECT();
3017 COPY (a,aa);C_P_K(aa,VECTOR);
3018 for (i=0;i<S_P_LI(aa);i++)
3019 if (S_P_II(aa,i) < 0) { j*=-1; M_I_I(-S_P_II(aa,i),S_P_I(aa,i)); }
3020 }
3021
3022
3023 FORALL(z,b,
3024 {
3025 d = callocobject();
3026 erg += b_sk_mo(callocobject(),callocobject(),d);
3027 if (j == -1) ADDINVERS(S_MO_K(z),S_MO_K(d));
3028 else COPY(S_MO_K(z),S_MO_K(d));
3029
3030 while (S_P_LI(a) > S_MO_SLI(z)) /* AK 230192 */
3031 {
3032 INC(S_MO_S(z));
3033 ;M_I_I(0,S_MO_SI(z,S_MO_SLI(z)-1L));
3034 }
3035 erg += operate_perm_vector(aa,S_MO_S(z),S_MO_S(d));
3036 insert(d,c,add_koeff,NULL);
3037 });
3038 if (a != aa) FREEALL(aa);
3039 }
3040 CTO(POLYNOM,"operate_perm_polynom(3-e)",c);
3041 ENDR("operate_perm_polynom");
3042 }
3043
3044 #endif /* POLYTRUE */
3045
3046
3047
operate_perm_zeilenmatrix(perm,b,c)3048 INT operate_perm_zeilenmatrix(perm,b,c) OP perm,b,c;
3049 {
3050 OP v;
3051 INT i,j;
3052 INT erg = OK;
3053 CTO(PERMUTATION,"operate_perm_zeilenmatrix(1)",perm);
3054 CTO(MATRIX,"operate_perm_zeilenmatrix(2)",b);
3055
3056 v = callocobject();
3057 erg += m_l_v(S_M_H(b), v);
3058 for (i=0;i<S_V_LI(v);i++)
3059 erg += select_row(b,i,S_V_I(v,i));
3060 println(v);
3061 erg += operate_perm_vector(perm,v,v);
3062 erg += m_lh_m(S_M_L(b), S_M_H(b), c);
3063 println(v);
3064 for (i=0;i<S_V_LI(v);i++)
3065 for (j=0;j<S_M_LI(b);j++)
3066 erg += copy(S_V_I(S_V_I(v,i),j) , S_M_IJ(c,i,j) );
3067 ENDR("operate_perm_zeilenmatrix");
3068 }
3069
operate_perm_vector(perm,b,c)3070 INT operate_perm_vector(perm,b,c) OP perm,b,c;
3071 /* AK Fri Jan 27 14:08:25 MEZ 1989 */
3072 /* operates by permuting entries in the vector */
3073 /* AK 030789 V1.0 */ /* AK 020290 V1.1 */ /* AK 150891 V1.3 */
3074 /* AK 120804 V3.0 */
3075 {
3076 INT erg = OK;
3077 CTO(PERMUTATION,"operate_perm_vector",perm);
3078 SYMCHECK(not VECTORP(b),"operate_perm_vector(2): not a vector object");
3079 SYMCHECK(S_P_LI(perm) > S_V_LI(b),"operate_perm_vector:perm too big");
3080 CE3( perm,b,c, operate_perm_vector);
3081 {
3082 INT i;
3083 if (S_P_LI(perm) < S_V_LI(b)) /* AK 230192 */
3084 {
3085 OP d = callocobject();
3086 erg += m_il_p(S_V_LI(b),d);
3087 for (i=0;i<S_P_LI(perm);i++)
3088 erg += m_i_i(S_P_II(perm,i),S_P_I(d,i));
3089 for(;i<S_P_LI(d);i++)
3090 erg += m_i_i(i+1L,S_P_I(d,i));
3091 erg += operate_perm_vector(d,b,c);
3092 FREEALL(d);
3093 }
3094 else{
3095 erg += m_il_v(S_V_LI(b),c);
3096 C_O_K(c,S_O_K(b));
3097 for (i=0;i<S_V_LI(c);i++)
3098 COPY (S_V_I(b,i),S_V_I(c,S_P_II(perm,i) -1) );
3099 }
3100 }
3101 ENDR("operate_perm_vector");
3102 }
3103
3104 #define FREE_PERMUTATION(a) SYM_free((char *) a)
3105
freeself_permutation(a)3106 INT freeself_permutation(a) OP a;
3107 /* AK 110488 */ /* AK 070789 V1.0 */ /* AK 260690 V1.1 */
3108 /* AK 120391 V1.2 */ /* AK 150891 V1.3 */
3109 /* AK 271098 V2.0 */
3110 {
3111 /* it works for INTEGER-Vectors */
3112 OBJECTSELF d;
3113 INT erg = OK;
3114 CTO(PERMUTATION,"freeself_permutation(1)",a);
3115
3116 FREEALL(S_P_S(a));
3117 d = S_O_S(a);
3118 FREE_PERMUTATION(d.ob_permutation);
3119 mem_counter_perm--;
3120 C_O_K(a,EMPTY);
3121 ENDR("freeself_permutation");
3122 }
3123
3124
UD_permutation(a,b)3125 INT UD_permutation(a,b) OP a,b;
3126 /* computes Up-Down-sequence of a permutation */
3127 /* AK 010890 V1.1 */ /* AK 150891 V1.3 */
3128 /* AK 280598 V2.0 */
3129 {
3130 INT i,erg=OK;
3131
3132 CPT(VECTOR,"UD_permutation",a);
3133 CE2(a,b,UD_permutation);
3134 erg += m_il_v(S_P_LI(a)-1L,b);
3135 for (i=0;i+1L < S_P_LI(a);i++)
3136 if (S_P_II(a,i) < S_P_II(a,i+1))
3137 M_I_I(1L,S_V_I(b,i));
3138 else
3139 M_I_I((INT)0,S_V_I(b,i));
3140 ENDR("UD_permutation");
3141 }
3142
comp_permutation_pol(as,bs)3143 INT comp_permutation_pol(as,bs) OP as,bs;
3144 /* comparision of permutations of may be different degrees:
3145 eq if identity on remaining part */
3146 /* AK 200891 V1.3 */
3147 {
3148 INT erg,i;
3149 OP c;
3150 erg=1L;
3151 if (S_P_LI(bs) > S_P_LI(as)) {c=bs;bs=as;as=c;erg= -1L;}
3152 /* as ist laenger als bs */
3153 for (i=(INT)0; i<S_P_LI(as); i++)
3154 {
3155 if (i < S_P_LI(bs))
3156 {
3157 if (S_P_II(as,i) > S_P_II(bs,i)) return erg*1L;
3158 if (S_P_II(as,i) < S_P_II(bs,i)) return erg*-1L;
3159 }
3160 else {
3161 if (S_P_II(as,i) < i+1) return erg*-1L;
3162 if (S_P_II(as,i) > i+1) return erg*1L;
3163 }
3164 }
3165 return (INT)0;
3166 }
3167
gengroup(vec)3168 INT gengroup(vec) OP vec;
3169 /* NiS 220191 V1.3 */
3170 /* input: VECTOR of group elements
3171 output: VECTOR of all elements in the generated group */
3172 {
3173 INT found=0,i,j,k,newfound=1,veclen;
3174 INT erg = OK;
3175 OP a,c,h,z,z1;
3176 CTO(VECTOR,"gengroup(1)",vec);
3177
3178 CALLOCOBJECT3(a,c,h);init(HASHTABLE,h);
3179 for (i=0;i<S_V_LI(vec);i++) { OP d=CALLOCOBJECT();
3180 COPY(S_V_I(vec,i),d);
3181 insert(d,h,NULL,NULL); }
3182 veclen=S_V_LI(vec);
3183
3184 while(newfound != 0)
3185 {
3186 #ifdef UNDEF
3187 for(i=0; i < veclen; i++)
3188 for(j=0; j < veclen; j++)
3189 {
3190 OP z;
3191 FREESELF(c);
3192 MULT(S_V_I(vec,i),S_V_I(vec,j),c);
3193 newfound=1;
3194 z = find_vector(c,vec);
3195 if(z == NULL)
3196 { INC(vec); COPY(c,S_V_I(vec,veclen++)); }
3197 else newfound=0;
3198 }
3199 #endif
3200 cc:
3201 for(i=0; i < veclen; i++)
3202 {
3203 FORALL(z,h, {
3204 FREESELF(c);
3205 MULT(S_V_I(vec,i),z,c);newfound=1;
3206 z1 = find_hashtable(c,h,NULL,NULL);
3207 if(z1 == NULL) { insert(c,h,NULL,NULL);c=CALLOCOBJECT();goto cc;}
3208 else newfound=0;
3209 } );
3210 }
3211 }
3212 t_HASHTABLE_VECTOR(h,vec);
3213 FREEALL3(a,c,h);
3214 ENDR("gengroup");
3215 }
3216 #endif /* PERMTRUE */
3217
3218 /*******************************************************************
3219 * if(pfact(permutation)) continue; *
3220 *******************************************************************/
pfact(a)3221 INT pfact(a) OP a;
3222 /* AL 250791 V1.3 */
3223 {
3224 INT x, i;
3225 x=(INT)0;
3226 for(i=(INT)0;i<S_P_LI(a)-1L;i++)
3227 {
3228 if(x < S_P_II(a,i)) x=S_P_II(a,i);
3229 if((i+1L)==x) { return(TRUE); break;}
3230 }
3231 return(FALSE);
3232 }
3233
3234
makevectoroftranspositions(a,b)3235 INT makevectoroftranspositions(a,b) OP a,b;
3236 /* b becomes VECTOR of all transpositions */
3237 /* AK 250791 V1.3 */
3238 {
3239 INT i,j,k,erg=OK;
3240 CTO(INTEGER,"makevectoroftranspositions(1)",a);
3241
3242 erg += m_il_v((S_I_I(a) * (S_I_I(a)-1L))/2L, b);
3243 for (i=(INT)0;i<S_V_LI(b);i++)
3244 {
3245 erg += first_permutation(a,S_V_I(b,i));
3246 }
3247 k=(INT)0; /* index in vector b */
3248 for (i=(INT)0;i<S_I_I(a);i++)
3249 for (j=i+1L;j<S_I_I(a);j++)
3250 {
3251 M_I_I(j+1,S_P_I(S_V_I(b,k),i));
3252 M_I_I(i+1,S_P_I(S_V_I(b,k),j));
3253 k++;
3254 }
3255 ENDR("makevectoroftranspositions");
3256 }
3257
first_perm_n_invers(a,b,c)3258 INT first_perm_n_invers(a,b,c) OP a,b,c;
3259 /* AK 250892 */
3260 /* a,b,c may be equal */
3261 {
3262 OP d;
3263 INT i,bi=S_I_I(b);
3264 INT erg = OK;
3265 CTO(INTEGER,"first_perm_n_invers",a);
3266 CTO(INTEGER,"first_perm_n_invers",b);
3267 d = callocobject();
3268 erg += m_l_nv(a,d);
3269 for(i=(INT)0;i<S_V_LI(d);i++)
3270 if (S_V_LI(d)-1L-i < bi)
3271 {
3272 erg += m_i_i(S_V_LI(d)-1L-i, S_V_I(d,i) );
3273 bi = bi - (S_V_LI(d)-1L-i); /* BUG ( were missing */
3274 }
3275 else {
3276 erg += m_i_i(bi,S_V_I(d,i));
3277 bi = (INT)0;
3278 break;
3279 }
3280 if (bi > (INT)0)
3281 {
3282 erg += freeall(d);
3283 erg += error("first_perm_n_invers: number of invers too big");
3284 goto endr_ende;
3285 }
3286
3287 erg += lehmercode_vector(d,c);
3288 erg += freeall(d);
3289 ENDR("first_perm_n_invers");
3290 }
3291
next_perm_invers(a,b)3292 INT next_perm_invers(a,b) OP a,b;
3293 /* next perm with a given number of inversions */
3294 /* a and b may be equal */
3295 {
3296 INT erg = OK;
3297 CPT(VECTOR,"next_perm_invers(1)",a);
3298 {
3299 OP c = callocobject();
3300 INT i,j,s,k;
3301 erg += lehmercode(a,c);
3302 s =(INT)0;
3303 for (j=(INT)0,i= S_V_LI(c)-1L; i>= (INT)0; i--,j++)
3304 {
3305 s += S_V_II(c,i);
3306 if ((S_V_II(c,i) < j)) break;
3307 }
3308 if (i < (INT)0) {
3309 freeall(c);
3310 return LAST_PERMUTATION;
3311 }
3312 for (j=i-1L;j>=(INT)0;j--)
3313 if (S_V_II(c,j) > (INT)0) break;
3314 if (j < (INT)0) {
3315 freeall(c);
3316 return LAST_PERMUTATION;
3317 }
3318
3319 /* an j wird um eins erniedrigt */
3320 /* rest wird aufgefuellt */
3321 m_i_i(S_V_II(c,j) -1L, S_V_I(c,j));
3322 s++;
3323
3324 for (i=j+1L,k=S_V_LI(c)-1L-i; i<S_V_LI(c); i++,k--)
3325 if (s >= k) {
3326 m_i_i(k,S_V_I(c,i)); s -= k;
3327 }
3328 else {
3329 m_i_i(s,S_V_I(c,i)); s = (INT)0;
3330 }
3331
3332 erg += lehmercode_vector(c,b);
3333 FREEALL(c);
3334 return erg;
3335 }
3336 ENDR("next_perm_invers");
3337 }
3338
3339 #ifdef PERMTRUE
make_nzykel(n,r)3340 INT make_nzykel(n,r) OP n,r;
3341 /* AK 051198 V2.0 */
3342 /* n and r may be equal */
3343 {
3344 INT i,erg=OK;
3345 CTO(INTEGER,"make_nzykel",n);
3346 erg += m_il_p(S_I_I(n),r);
3347 for (i=(INT)0;i<S_P_LI(r);i++)
3348 M_I_I(i+2L,S_P_I(r,i));
3349 M_I_I(1L,S_P_I(r,i-1));
3350 ENDR("make_nzykel");
3351 }
3352
3353
3354
make_n_id(n,r)3355 INT make_n_id(n,r) OP n,r;
3356 {
3357 INT i,erg=OK;
3358 erg += m_il_p(S_I_I(n),r);
3359 for (i=(INT)0;i<S_P_LI(r);i++)
3360 erg += m_i_i(i+1L,S_P_I(r,i));
3361 return erg;
3362 }
3363
3364
3365
m_INTEGER_elmtrans(i,r)3366 INT m_INTEGER_elmtrans(i,r) OP i,r;
3367 {
3368 return m_INT_elmtrans(S_I_I(i),r);
3369 }
3370
m_INT_elmtrans(i,r)3371 INT m_INT_elmtrans(i,r) INT i; OP r;
3372 /* builds the elementary transposition (i,i+1) in S_{i+1} */
3373 {
3374 OP c,d;
3375 INT erg = OK;
3376 c = callocobject();
3377 d = callocobject();
3378 erg += m_i_i(i,d);
3379 erg += m_i_i(i+1L,c);
3380 erg += make_n_kelmtrans(c,d,r);
3381 erg += freeall(c);
3382 erg += freeall(d);
3383 return erg;
3384 }
3385
make_n_kelmtrans(n,k,r)3386 INT make_n_kelmtrans(n,k,r) OP n,k,r;
3387 /* n degree of permutation */
3388 /* elementary transposition (k,k+1) */
3389 /* AK 210804 V3.0 */
3390 {
3391 INT erg=OK;
3392 CTO(INTEGER,"make_n_kelmtrans(1)",n);
3393 SYMCHECK(S_I_I(n)<2,"make_n_kelmtrans(1)<2");
3394 CTO(INTEGER,"make_n_kelmtrans(2)",k);
3395 SYMCHECK(S_I_I(k)<1,"make_n_kelmtrans(2)<1");
3396 SYMCHECK(S_I_I(k)>=S_I_I(n),"make_n_kelmtrans(2)>=n");
3397 {
3398 INT i;
3399 erg += m_il_p(S_I_I(n),r);
3400 for (i=0;i<S_P_LI(r);i++)
3401 M_I_I(i+1,S_P_I(r,i));
3402 M_I_I(S_I_I(k)+1, S_P_I(r,S_I_I(k)-1));
3403 M_I_I(S_I_I(k), S_P_I(r,S_I_I(k)));
3404 }
3405 ENDR("make_n_kelmtrans");
3406 }
3407
3408
3409
maxorder_young(a,b)3410 INT maxorder_young(a,b) OP a,b;
3411 /* AK 070693 */
3412 /* a is a partition, b becomes the length of the maximum permutation
3413 in the corresponding young group */
3414 {
3415 INT i,erg=OK;
3416 OP c;
3417 if (S_O_K(a) != PARTITION)
3418 return ERROR;
3419 if (S_PA_K(a) != VECTOR)
3420 return ERROR;
3421 c = callocobject();
3422 erg += m_i_i((INT)0,b);
3423 for (i=(INT)0;i<S_PA_LI(a);i++)
3424 {
3425 erg += binom(S_PA_I(a,i),cons_zwei,c);
3426 erg += add_apply(c,b);
3427 }
3428 erg += freeall(c);
3429 if (erg != OK)
3430 EDC("maxorder_young");
3431 return erg;
3432 }
3433 #endif /* PERMTRUE */
3434 #ifdef PERMTRUE
3435 #ifdef PARTTRUE
next_shuffle_part(part,a,b)3436 INT next_shuffle_part(part,a,b) OP part,a,b;
3437 /* AK 090693 */
3438 /* next shuffle permutation according to part shape */
3439 /* to be improved */
3440 /* return TRUE / FALSE */
3441 {
3442 INT e,i,j,k;
3443 OP c = a;
3444 if (a == b)
3445 {
3446 c = callocobject();
3447 *c = *a;
3448 C_O_K(a,EMPTY);
3449 e = next_shuffle_part(part,c,b);
3450 freeall(c);
3451 return e;
3452 }
3453 again:
3454 e = next(c,b);
3455 if (e == FALSE)
3456 return e;
3457 /* now check of correct shape */
3458 j=(INT)0; /* durchlauf permutation */
3459 for (i=(INT)0;i<S_PA_LI(part);i++)
3460 {
3461 for (k=1L,j++; k<S_PA_II(part,i); k++,j++)
3462 if (S_P_II(b,j) < S_P_II(b,j-1))
3463 {
3464 c = b;
3465 goto again;
3466 }
3467 }
3468 return TRUE;
3469 }
3470 #endif /* PARTTRUE */
3471
m_perm_rz_set(a,b)3472 INT m_perm_rz_set(a,b) OP a,b;
3473 /* AK 120194 */
3474 /* enter a permutation a,
3475 output vector of all reduced decompositions */
3476 {
3477 OP d;
3478 INT erg = OK;
3479 CE2(a,b,m_perm_rz_set);
3480 CPT(VECTOR,"m_perm_rz_set(1)",a);
3481
3482 d = CALLOCOBJECT();
3483 erg += numberof_inversionen(a,d);
3484 erg += co_120194(a,b,S_I_I(d),S_I_I(d));
3485 FREEALL(d);
3486 ENDR("m_perm_rz_set");
3487 }
3488
co_120194(a,b,k,l)3489 static INT co_120194(a,b,k,l) OP a,b; INT k,l;
3490 {
3491 int i=(INT)0,j;
3492 OP c,d;
3493 INT erg = OK;
3494
3495 if (k == 0)
3496 {
3497 erg += m_il_v(1L,b) ;
3498 erg += m_il_v(l,S_V_I(b,(INT)0)) ;
3499 goto eee;
3500 }
3501 c = callocobject();
3502 d = callocobject();
3503 erg += m_il_v((INT)0,b);
3504 for (i=1L;i<S_P_LI(a);i++)
3505 {
3506 if (S_P_II(a,i-1) > S_P_II(a,i))
3507 {
3508 erg += copy(a,c);
3509 erg += swap(S_P_I(c,i-1),S_P_I(c,i));
3510 erg += co_120194(c,d,k-1,l);
3511 for (j=(INT)0;j<S_V_LI(d);j++)
3512 {
3513 /* inc(S_V_I(d,j)); */
3514 erg += m_i_i(i,
3515 S_V_I( S_V_I(d,j), /* S_V_LI(S_V_I(d,j)) */ k-1L)
3516 );
3517 }
3518 erg += append(b,d,b);
3519 if (k==1) break;
3520 }
3521 }
3522 erg += freeall(c);
3523 erg += freeall(d);
3524 eee:
3525 return erg;
3526 }
3527
m_perm_rz_number(a,b)3528 INT m_perm_rz_number(a,b) OP a,b;
3529 /* AK 120194 */
3530 /* enter a permutation a,
3531 output number of all reduced decompositions */
3532 {
3533 INT erg = OK;
3534 OP d;
3535 if (check_equal_2(a,b,m_perm_rz_number,&erg) == EQUAL)
3536 goto endr_ende;
3537 CPT(VECTOR,"m_perm_rz_number",a);
3538 d = callocobject();
3539 erg += numberof_inversionen(a,d);
3540 erg += co_120194_1(a,b,S_I_I(d),S_I_I(d));
3541 erg += freeall(d);
3542 ENDR("m_perm_rz_number");
3543 }
3544
co_120194_1(a,b,k,l)3545 static INT co_120194_1(a,b,k,l) OP a,b; INT k,l;
3546 {
3547 int i=(INT)0;
3548 INT erg = OK;
3549 OP c,d;
3550
3551 if (k == 0)
3552 {
3553 erg += m_i_i(1L,b) ;
3554 goto endr_ende;
3555 }
3556 c = callocobject();
3557 d = callocobject();
3558 erg += m_i_i((INT)0,b);
3559 for (i=1L;i<S_P_LI(a);i++)
3560 {
3561 if (S_P_II(a,i-1) > S_P_II(a,i))
3562 {
3563 erg += copy(a,c);
3564 erg += swap(S_P_I(c,i-1),S_P_I(c,i));
3565 erg += co_120194_1(c,d,k-1,l);
3566 erg += add_apply(d,b);
3567 if (k==1) break;
3568 }
3569 }
3570
3571 erg += freeall(c);
3572 erg += freeall(d);
3573 ENDR("internal routine: co_120194_1");
3574 }
3575
cast_apply_perm(a)3576 INT cast_apply_perm(a) OP a;
3577 /* AK 280294 */
3578 {
3579 INT erg = OK;
3580 EOP("cast_apply_perm(1)",a);
3581 switch(S_O_K(a))
3582 {
3583 case VECTOR:
3584 erg += m_ks_p(VECTOR,a,a);
3585 break;
3586 default:
3587 printobjectkind(a);
3588 erg += WTO("cast_apply_perm",a);
3589 break;
3590 }
3591 ENDR("cast_apply_perm");
3592 }
3593
sscan_permutation(t,a)3594 INT sscan_permutation(t,a) OP a; char *t;
3595 /* AK 050194 to read permutation from string
3596 format [1,2,3,..]
3597 */
3598 {
3599 INT erg = OK;
3600 COP("sscan_permutation(1)",t);
3601 CTO(EMPTY,"sscan_permutation(2)",a);
3602
3603 erg += b_ks_p(VECTOR,callocobject(),a);
3604 erg += sscan(t,INTEGERVECTOR,S_P_S(a));
3605 ENDR("sscan_permutation");
3606 }
3607
makevectorofperm(a,b)3608 INT makevectorofperm(a,b) OP a,b;
3609 /* input INTEGER object a
3610 output VECTOR object of length a! with permutations in
3611 order of next */
3612
3613 /* AK 220702 */
3614 {
3615 INT i;
3616 INT erg = OK;
3617 OP c;
3618 CTO(INTEGER,"makevectorofperm(1)",a);
3619 CE2(a,b,makevectorofperm);
3620 c = CALLOCOBJECT();
3621 erg += fakul(a,c);
3622 erg += m_l_v(c,b);
3623 erg += first_permutation(a,c);
3624 i=0;
3625 do {
3626 erg += copy_permutation(c,S_V_I(b,i));
3627 i++;
3628 } while (next_apply(c));
3629 FREEALL(c);
3630 ENDR("makevectorofperm");
3631 }
3632
bruhat_comp_perm(a,b)3633 INT bruhat_comp_perm(a,b) OP a,b;
3634 /* compares according to the strong bruhat order*/
3635 /* 1 if a>b
3636 0 if a=b
3637 -1 if a<b
3638 NONCOMPARABLE else */
3639 {
3640 INT erg,erg2;
3641 erg = bru_comp(a,b);
3642 erg2 = bru_comp(b,a);
3643 if ((erg == TRUE) && (erg2 == TRUE)) return (INT) 0;
3644 if (erg == TRUE) return (INT ) 1;
3645 if ((erg == FALSE) && (erg2 == FALSE)) return NONCOMPARABLE;
3646 return (INT) -1;
3647 }
3648
3649 /* =TRUE if a>=c in the Bruhat order ADD condition when c not long enough */
bru_comp(a,c)3650 INT bru_comp(a,c) OP a,c;
3651 {
3652 INT i,j,k,x,y1,y2;
3653 k=S_P_LI(a);
3654 y1=S_P_II(a,(INT)0);
3655 y2=S_P_II(a,k-1);
3656 if( S_P_II(c,(INT)0) > y1 ) return (FALSE);
3657
3658 if( k < S_P_LI(c) ) {
3659 for (j=k;j<S_P_LI(c);j++)
3660 if (j!=S_P_II(c,j)-1) return FALSE;
3661 }
3662 if( (S_P_LI(c) == k) && (S_P_II(c,k-1) < y2)) return (FALSE);
3663
3664
3665 if (S_P_LI(c) < k) k = S_P_LI(c);
3666
3667 for(i=0L;i<k;i++) {
3668 x=0L;
3669 for(j=0L;j<k;j++){
3670 if ( S_P_II(a,j) >i ) x++;
3671 if ( S_P_II(c,j) >i ) x--;
3672 if (x<0) return (FALSE);
3673 }
3674 }
3675
3676 return (TRUE);
3677 }
3678
t_VECTOR_BITREC(a,bitperm)3679 INT t_VECTOR_BITREC(a,bitperm) OP a,bitperm;
3680 /* AK 200195 */
3681 {
3682 OP c,d,b;
3683 INT i,erg=OK;
3684 CTO(PERMUTATION,"t_VECTOR_BITREC(1)",a);
3685 c = callocobject();
3686 d = callocobject();
3687 b = callocobject();
3688 m_i_i(S_P_LI(a)+1,b);
3689 m_i_i(3,c);
3690 binom(b,c,d);
3691 freeall(c);
3692 m_il_nbv(S_I_I(d),b);
3693 fastrectr(a,d);
3694 for (i=0L;i<S_V_LI(d);i++)
3695 {
3696 co_co_2(S_P_L(a),S_V_I(d,i),b);
3697 }
3698 b_ks_p(BITREC,b,bitperm);
3699 freeall(d);
3700 ENDR("t_VECTOR_BITREC");
3701
3702 }
3703
3704
fastrectr(a,v)3705 INT fastrectr(a,v) OP a,v;
3706 /* AL 1094 */
3707 {
3708 OP b,u;
3709 INT i,k,x,y,z,iv,i1;
3710 b=callocobject();
3711 u=callocobject();
3712
3713 invers(a,b);
3714 init(VECTOR,v);
3715 m_il_v(3L,u);
3716 iv=0L;
3717 for(i=0L;i<S_P_LI(a)-1L;i++)
3718 {
3719 if( S_P_II(a,i)>S_P_II(a,i+1))
3720 {
3721 z= S_P_II(a,i);
3722 x=S_P_II(a,i+1);
3723 for (k=z;k>=x;k--)
3724 {
3725
3726 if ( S_P_II(b,k-1) >= i+2 && S_P_II(b,k) <=i+1)
3727 {
3728 y=0;
3729 for(i1=0;i1<=i;i1++) {
3730 if( S_P_II(a,i1) <k) y++;
3731 }
3732 M_I_I(y,S_V_I(u,0L));
3733 M_I_I(i+1-y,S_V_I(u,1L));
3734 M_I_I(k-y,S_V_I(u,2L));
3735 inc(v);
3736 copy(u,S_V_I(v,iv));
3737 iv++;
3738 }
3739 }
3740 }
3741 }
3742 freeall(b);
3743 freeall(u);
3744 return OK;
3745 }
3746
makevectorofrect_permutation(a,b)3747 INT makevectorofrect_permutation(a,b) OP a,b;
3748 /* AK 130195 */
3749 {
3750 OP c;
3751 INT erg = OK,i;
3752 CTO(INTEGER,"makevectorofrect_permutation(1)",a);
3753 c = callocobject();
3754 erg += makevectorofrect_lehmercode(a,c);
3755 erg += m_il_v(S_V_LI(c),b);
3756 for (i=0;i<S_V_LI(b);i++)
3757 {
3758 erg += lehmercode(S_V_I(c,i),S_V_I(b,i));
3759 erg += freeself(S_V_I(c,i));
3760 }
3761 erg += freeall(c);
3762 ENDR("makevectorofrect_permutation");
3763 }
3764
makevectorofrect_lehmercode(a,b)3765 INT makevectorofrect_lehmercode(a,b) OP a,b;
3766 /* AK 130195 */
3767 {
3768 INT erg = OK,i,j;
3769 CTO(INTEGER,"makevectorofrect(1)",a);
3770 if (S_I_I(a) < (INT)0) erg = ERROR;
3771 else if (S_I_I(a) == (INT)0) erg += m_il_v((INT)0,b);
3772 else {
3773 erg += m_il_v((INT)1,b);
3774 erg += m_l_nv(a,S_V_I(b,(INT)0));
3775 C_O_K(S_V_I(b,0),INTEGERVECTOR);
3776
3777 for (i=1;i<S_I_I(a);i++)
3778 {
3779 for (j=S_V_LI(b)-1;j>0;j--)
3780 {
3781 if (S_V_II(S_V_I(b,j),S_I_I(a)-i) > 0)
3782 {
3783 erg += inc(b);
3784 erg += copy(S_V_I(b,j),S_V_I(b,S_V_LI(b)-1));
3785 C_O_K(S_V_I(b,S_V_LI(b)-1),INTEGERVECTOR);
3786 erg += m_i_i(S_V_II(S_V_I(b,j),S_I_I(a)-i)
3787 ,S_V_I(S_V_I(b,S_V_LI(b)-1),S_I_I(a)-1-i));
3788 }
3789 }
3790 for (j=1L;j<=i;j++)
3791 {
3792 erg += inc(b);
3793 erg += m_l_nv(a,S_V_I(b,S_V_LI(b)-1));
3794 C_O_K(S_V_I(b,S_V_LI(b)-1),INTEGERVECTOR);
3795 erg += m_i_i(j,S_V_I(S_V_I(b,S_V_LI(b)-1),S_I_I(a)-i-1));
3796 }
3797 }
3798
3799 }
3800 ENDR("makevectorofrect");
3801 }
3802
co_co(n,bigr,vec)3803 static INT co_co(n,bigr,vec) OP bigr,vec,n;
3804 /* input bigr and vector which is to be manipulated */
3805 /* n the degree of s_n */
3806 /* insert ones in one block */
3807 {
3808 INT r2,r1,r0,og;
3809 INT x,k,i,j,length_of_cell;
3810 r2 = S_V_II(bigr,2);
3811 r1 = S_V_II(bigr,1);
3812 r0 = S_V_II(bigr,0);
3813 length_of_cell = S_I_I(n)-r1-r0;
3814
3815 k=S_I_I(n); x=r0 + r1;
3816 og = x*(x-1)*(3*k-2*x+1)/6; /* start of block */
3817
3818 for (i=0;i<r1;i++)
3819 {
3820 for (j=0;j<r2;j++)
3821 /*
3822 m_i_i(1,S_V_I(vec,og+i*length_of_cell+j));
3823 */
3824 {
3825 k = og+i*length_of_cell+j;
3826 SET_BV_I(vec,k);
3827 }
3828 }
3829 return OK;
3830 }
3831
co_co_2(n,bigr,vec)3832 static INT co_co_2(n,bigr,vec) OP bigr,vec,n;
3833 /* input bigr and vector which is to be manipulated */
3834 /* n the degree of s_n */
3835 /* insert ones in all blocks */
3836 {
3837 INT i;
3838 INT erg = OK;
3839 OP c;
3840 CTO(INTEGER,"co_co_2(1)",n);
3841 c = callocobject();
3842 copy(bigr,c);
3843 for (i=S_V_II(c,1);i>=1;i--)
3844 {
3845 co_co(n,c,vec);
3846 dec(S_V_I(c,1));
3847 }
3848 copy(bigr,c);
3849 for (i=S_V_II(c,2);i>1;i--)
3850 {
3851 inc(S_V_I(c,0));
3852 dec(S_V_I(c,2));
3853 co_co(n,c,vec);
3854 }
3855 freeall(c);
3856 ENDR("internal routine:co_co_2");
3857 }
3858
order_permutation(a,b)3859 INT order_permutation(a,b) OP a,b;
3860 /* AK 210802 */
3861 /* order of permutation */
3862 /* result is in b
3863 b is minimal integer with a^b = id
3864 */
3865 /* AK V3.1 031106 */
3866 /* a and b may be equal */
3867 {
3868 INT erg = OK;
3869 CTO(PERMUTATION,"order_permutation(1)",a);
3870 {
3871 OP part;
3872 INT i;
3873 part = CALLOCOBJECT();
3874 zykeltyp(a,part);
3875 copy(S_PA_I(part,0),b);
3876 for (i=1;i<S_PA_LI(part);i++) erg += kgv(S_PA_I(part,i),b,b);
3877 FREEALL(part);
3878 }
3879 ENDR("order_permutation");
3880 }
3881
3882
3883
rz_Dn(v,r)3884 INT rz_Dn(v,r) OP v,r;
3885 /* AK 290296 */
3886 /* rz in coxeter gruppe Dn */
3887 {
3888 INT i,j,ii,jj,k,erg=OK;
3889 OP vc;
3890 OP rn;
3891 CTO(PERMUTATION,"rz_Dn",v);
3892 for (i=0;i<S_P_LI(v);i++)
3893 if (S_P_II(v,i) <= 0) goto realdn;
3894 /* ist eigentlich s_n permutation */
3895 C_P_K(v,VECTOR);
3896 erg += rz_perm(v,r);
3897 C_P_K(v,BAR);
3898 goto endr_ende;
3899 realdn:
3900 m_il_v((INT)0,r);
3901 vc = callocobject();
3902 rn = callocobject();
3903 erg += copy(v,vc);
3904 realdn_again:
3905 /* es muss zwei - geben */
3906 for (j=i+1;j<S_P_LI(vc);j++)
3907 if (S_P_II(vc,j) <= (INT)0) break;
3908 if (j == S_P_LI(vc))
3909 error("rz_Dn:perm not in Dn");
3910 erg += m_il_v(i+j,rn);
3911 k=0;
3912 m_i_i(-1,S_V_I(rn,k));
3913 k++;
3914 for (jj=2;jj<=j;jj++)
3915 m_i_i(jj,S_V_I(rn,k++));
3916 for (ii=1;ii<=i;ii++)
3917 m_i_i(ii,S_V_I(rn,k++));
3918 i = S_P_II(vc,i);
3919 j = S_P_II(vc,j);
3920 for (ii=S_P_LI(vc)-1,jj=ii;ii>=0;ii--)
3921 {
3922 if (S_P_II(vc,ii) != i)
3923 if (S_P_II(vc,ii) != j)
3924 {
3925 M_I_I(S_P_II(vc,ii),S_P_I(vc,jj));
3926 jj--;
3927 }
3928 }
3929 M_I_I(-i,S_P_I(vc,1));
3930 M_I_I(-j,S_P_I(vc,0));
3931 append(rn,r,r);
3932 for (i=0;i<S_P_LI(vc);i++)
3933 if (S_P_II(vc,i) <= 0) goto realdn_again;
3934 C_P_K(vc,VECTOR);
3935 erg += rz_perm(vc,rn);
3936 C_P_K(v,BAR);
3937 erg += append(rn,r,r);
3938
3939
3940 erg += freeall(vc);
3941 erg += freeall(rn);
3942 ENDR("rz_Dn");
3943 }
3944
3945
3946
vorgaenger_bruhat(a,b)3947 INT vorgaenger_bruhat(a,b) OP a,b; { return vorgaenger_bruhat_weak(a,b); }
3948
vorgaenger_bruhat_weak(a,b)3949 INT vorgaenger_bruhat_weak(a,b) OP a,b;
3950 /* weak bruhat oder, only elementary transpositions */
3951 {
3952 INT i,l,h;
3953 OP z;
3954 INT erg = OK;
3955 CPT(VECTOR,"vorgaenger_bruhat_weak(1)",a);
3956 CE2(a,b,vorgaenger_bruhat_weak);
3957 for (l=0,i=1;i<S_P_LI(a);i++)
3958 if (S_P_II(a,i) < S_P_II(a,i-1)) l++;
3959 /* l ist the number of decreases */
3960 erg += m_il_v(l,b);
3961 for (l=0,i=1;i<S_P_LI(a);i++)
3962 if (S_P_II(a,i) < S_P_II(a,i-1)) {
3963 z = S_V_I(b,l);
3964 copy_permutation(a,z);
3965 h = S_P_II(z,i);
3966 M_I_I(S_P_II(z,i-1),S_P_I(z,i));
3967 M_I_I(h,S_P_I(z,i-1));
3968 l++;
3969 }
3970 ENDR("vorgaenger_bruhat_weak");
3971 }
3972
vorgaenger_bruhat_strong(a,b)3973 INT vorgaenger_bruhat_strong(a,b) OP a,b;
3974 /* strong bruhat oder, all transpositions */
3975 /* AK 230702 */
3976 {
3977 INT erg = OK;
3978 CPT(VECTOR,"vorgaenger_bruhat_strong(1)",a);
3979 CE2(a,b,vorgaenger_bruhat_strong);
3980 {
3981 INT i;
3982 erg += m_il_v(0,b);
3983 for (i=0;i<S_P_LI(a);i++)
3984 {
3985 INT wi = S_P_II(a,i);
3986 /* to the right and smaller */
3987 INT rightmin=0;
3988 INT j;
3989 for (j=i+1;j<S_P_LI(a);j++)
3990 {
3991 INT wj = S_P_II(a,j);
3992 if ((wj < wi) && (wj > rightmin))
3993 {
3994 OP perm_in_result;
3995 INC(b);
3996 perm_in_result = S_V_I(b,S_V_LI(b)-1);
3997 copy_permutation(a,perm_in_result);
3998 M_I_I(wj,S_P_I(perm_in_result,i));
3999 M_I_I(wi,S_P_I(perm_in_result,j));
4000 rightmin = wj;
4001 }
4002 }
4003 }
4004 }
4005 ENDR("vorgaenger_bruhat_strong");
4006 }
4007
4008 #define BRUHAT_IDEAL_CO(a,b,func)\
4009 {\
4010 INT i,j,k;\
4011 OP c,d,e,z,f;\
4012 c = CALLOCOBJECT();\
4013 d = CALLOCOBJECT();\
4014 e = CALLOCOBJECT();\
4015 erg += numberof_inversionen(a,c); \
4016 INC(c);\
4017 erg += b_l_v(c,b);\
4018 erg += m_o_v(a,S_V_I(b,0));\
4019 for (i=0;i<S_V_LI(b)-1;i++)\
4020 {\
4021 erg += init(BINTREE,d);\
4022 for (j=0;j<S_V_LI(S_V_I(b,i));j++)\
4023 {\
4024 z = S_V_I(S_V_I(b,i),j);\
4025 erg += (*func)(z,e);\
4026 for(k=0;k<S_V_LI(e);k++)\
4027 {\
4028 f = CALLOCOBJECT();\
4029 SWAP(f,S_V_I(e,k));\
4030 insert(f,d,NULL,NULL);\
4031 }\
4032 }\
4033 erg += t_BINTREE_VECTOR(d,S_V_I(b,i+1));\
4034 }\
4035 FREEALL(d);\
4036 FREEALL(e);\
4037 }
4038
bruhat_ideal(a,b)4039 INT bruhat_ideal(a,b) OP a,b; { return bruhat_ideal_weak(a,b); }
4040
bruhat_ideal_weak(a,b)4041 INT bruhat_ideal_weak(a,b) OP a,b;
4042 /* input: PERMUTATION object
4043 output: VECTOR object, i-th entry = i-th level in bruhat ideal */
4044 /* weak bruhat oder, only elementary transpositions */
4045 {
4046 INT erg = OK;
4047 CPT(VECTOR,"bruhat_ideal_weak(1)",a);
4048 CE2(a,b,bruhat_ideal_weak);
4049 BRUHAT_IDEAL_CO(a,b,vorgaenger_bruhat_weak);
4050 ENDR("bruhat_ideal_weak");
4051 }
4052
bruhat_ideal_strong(a,b)4053 INT bruhat_ideal_strong(a,b) OP a,b;
4054 /* input: PERMUTATION object
4055 output: VECTOR object, i-th entry = i-th level in bruhat ideal */
4056 /* strong bruhat oder, all transpositions */
4057 /* AK 230702 */
4058 {
4059 INT erg = OK;
4060 CPT(VECTOR,"bruhat_ideal(1)",a);
4061 CE2(a,b,bruhat_ideal);
4062 BRUHAT_IDEAL_CO(a,b,vorgaenger_bruhat_strong);
4063 ENDR("bruhat_ideal");
4064 }
4065
4066
bruhat_rank_function(a,b)4067 INT bruhat_rank_function(a,b) OP a,b;
4068 {
4069 INT erg = OK;
4070 OP d;
4071 INT i;
4072 CPT(VECTOR,"bruhat_rank_function(1)",a);
4073 d = callocobject();
4074 bruhat_ideal(a,d);
4075 m_il_v(S_V_LI(d),b);
4076 for(i=0;i<S_V_LI(d);i++)
4077 M_I_I(
4078 S_V_LI(S_V_I(d,i)),
4079 S_V_I(b,i)
4080 );
4081 erg += freeall(d);
4082 ENDR("bruhat_rank_function");
4083 }
4084
4085 #define BRUHAT_INTERVAL_CO(a,b,c,func)\
4086 if (EQ(a,b)) {\
4087 erg += m_il_v(1,c);\
4088 erg += m_o_v(a,S_V_I(c,0));\
4089 goto ende;\
4090 }\
4091 {\
4092 OP d,e,f,z;\
4093 INT i,j,k;\
4094 e = CALLOCOBJECT();\
4095 d = CALLOCOBJECT();\
4096 erg += numberof_inversionen(a,d);\
4097 erg += numberof_inversionen(b,e);\
4098 if (le(d,e)) { \
4099 FREEALL(e);\
4100 FREEALL(d);\
4101 m_il_v(0,c); \
4102 goto ende; \
4103 }\
4104 erg += m_il_v(S_I_I(d)-S_I_I(e)+1,c);\
4105 erg += m_o_v(a,S_V_I(c,0));\
4106 for (i=0;i<S_V_LI(c)-1;i++)\
4107 {\
4108 erg += init(BINTREE,d);\
4109 for (j=0;j<S_V_LI(S_V_I(c,i));j++)\
4110 {\
4111 z = S_V_I(S_V_I(c,i),j);\
4112 erg += (*func)(z,e);\
4113 for(k=0;k<S_V_LI(e);k++)\
4114 {\
4115 f = CALLOCOBJECT();\
4116 SWAP(f,S_V_I(e,k));\
4117 insert(f,d,NULL,NULL);\
4118 }\
4119 }\
4120 erg += t_BINTREE_VECTOR(d,S_V_I(c,i+1));\
4121 } \
4122 \
4123 /* ideal til level of b */\
4124 \
4125 /* starting from bottom removing items */\
4126 \
4127 for (j=0;j<S_V_LI(S_V_I(c,i));j++)\
4128 {\
4129 z = S_V_I(S_V_I(c,i),j);\
4130 if (NEQ(z,b)) delete_entry_vector(S_V_I(c,i),j--,S_V_I(c,i));\
4131 }\
4132 \
4133 if (S_V_LI(S_V_I(c,i))== 0) {\
4134 FREEALL(e);\
4135 FREEALL(d);\
4136 m_il_v(0,c); \
4137 goto ende; \
4138 }\
4139 \
4140 /* check backward */\
4141 i--;\
4142 for (;i>0;i--)\
4143 for (j=0;j<S_V_LI(S_V_I(c,i));j++)\
4144 {\
4145 z = S_V_I(S_V_I(c,i),j);\
4146 erg += (*func)(z,e);\
4147 for(k=0;k<S_V_LI(e);k++)\
4148 {\
4149 if (index_vector(S_V_I(e,k),S_V_I(c,i+1)) != -1) goto next;\
4150 }\
4151 /* the entry z does not belong to the ideal */\
4152 delete_entry_vector(S_V_I(c,i),j--,S_V_I(c,i)); \
4153 next: ;\
4154 }\
4155 \
4156 FREEALL(e);\
4157 FREEALL(d);\
4158 }\
4159 ende:;
4160
bruhat_interval_weak(a,b,c)4161 INT bruhat_interval_weak(a,b,c) OP a,b,c;
4162 /* weak bruhat ideal between a and b
4163 */
4164 /* weak = differ by elementary transpositions */
4165 {
4166 INT erg = OK;
4167 CPT(VECTOR,"bruhat_interval_weak(1)",a);
4168 CPT(VECTOR,"bruhat_interval_weak(2)",b);
4169 BRUHAT_INTERVAL_CO(a,b,c,vorgaenger_bruhat_weak);
4170 ENDR("bruhat_interval_weak");
4171 }
4172
bruhat_interval_strong(a,b,c)4173 INT bruhat_interval_strong(a,b,c) OP a,b,c;
4174 /* strong bruhat ideal between a and b
4175 */
4176 /* strong = differ by any transpositions */
4177 {
4178 INT erg = OK;
4179 CPT(VECTOR,"bruhat_interval_strong(1)",a);
4180 CPT(VECTOR,"bruhat_interval_strong(2)",b);
4181 BRUHAT_INTERVAL_CO(a,b,c,vorgaenger_bruhat_strong);
4182 ENDR("bruhat_interval_strong");
4183 }
4184
4185
4186
inversion_matrix_perm(p,e)4187 INT inversion_matrix_perm(p,e) OP p,e;
4188 /* AK 180598 V2.0 */
4189 /* p and e may be equal */
4190 {
4191 INT i,j,k,m;
4192 INT erg = OK;
4193 erg += diagramm_permutation(p,e);
4194 for (j=(INT)0;j<S_M_LI(e); j++)
4195 {
4196 k=j+1L;
4197 for (i=S_M_HI(e)-1L;i>=(INT)0 ; i--)
4198 {
4199 if (EMPTYP(S_M_IJ(e,i,j)))
4200 {
4201 erg += m_i_i(1L,S_M_IJ(e,i,j)) ;
4202 k++;
4203 }
4204 else if (S_M_IJI(e,i,j) == -1L)
4205 erg += m_i_i((INT)0,S_M_IJ(e,i,j));
4206 else if (S_M_IJI(e,i,j) == (INT)0){
4207 erg += m_i_i((INT)0,S_M_IJ(e,i,j));
4208 for (m=j+1L; m<S_M_LI(e);m++)
4209 erg += m_i_i(-1L,S_M_IJ(e,i,m));
4210 for (m=i-1L; m>=(INT)0 ; m--)
4211 if (not EMPTYP(S_M_IJ(e,m,j))) {
4212 if (S_M_IJI(e,m,j) == -1L)
4213 erg += m_i_i((INT)0,S_M_IJ(e,m,j)
4214 );
4215 }
4216 else m_i_i((INT)0,S_M_IJ(e,m,j));
4217
4218 break;
4219 }
4220 else error("inversion_matrix_perm:wrong content");
4221 }
4222 }
4223 ENDR("inversion_matrix_perm");
4224 }
4225
4226 #endif /* PERMTRUE */
4227
4228