1
2 #include "def.h"
3 #include "macro.h"
4
5 static INT rh_kostka();
6 static INT rh_insert();
7 static INT rh_delete();
8 static INT rh_ausgabemat();
9 static OP lookupinschurspeicher();
10 static INT kostka_tab_partition();
11 static INT kostka_tab_skewpartition();
12 static INT neu_n_kostka();
13 static INT nspeicherkostka();
14
15
16 #define RH_MAX 100
17
18
19
20
21 #ifdef KOSTKATRUE
22
kostka_number(inh,shape,res)23 INT kostka_number(inh,shape,res) OP inh,shape,res;
24 /* AK 020890 V1.1 */ /* AK 210891 V1.3 */
25 /* AK 240398 V2.0 */
26 {
27 OP d;
28 INT i;
29 INT erg = OK;
30 CE3(inh,shape,res,kostka_number);
31
32 if (S_O_K(inh) == PARTITION) /* AK 100992 */
33 d = S_PA_S(inh);
34 else if (S_O_K(inh) == VECTOR)
35 d = inh;
36 else if (S_O_K(inh) == INTVECTOR)
37 d = inh;
38 else
39 {
40 WTO(inh,"kostka_number:content");
41 goto endr_ende;
42 }
43
44 for (i=(INT)0;i<S_V_LI(d);i++)
45 if (S_O_K(S_V_I(d,i)) != INTEGER)
46 {
47 erg += error("kostka_number: wrong content type");
48 goto endr_ende;
49 }
50
51 if (S_O_K(shape) == PARTITION)
52 erg += kostka_number_partition(d,shape,res);
53 else if (S_O_K(shape) == SKEWPARTITION)
54 erg += kostka_number_skewpartition(d,shape,res);
55 else
56 WTO(shape,"kostka_number:shape");
57
58 ENDR("kostka_number");
59 }
60
61 static INT mkn_co();
kostka_number_partition(a,b,c)62 INT kostka_number_partition(a,b,c) OP a,b,c;
63 /* inhalt, umriss, res */
64 /* AK 240901 */
65 /* much faster, uses recursion with skew partition */
66 {
67 OP d;
68 INT erg = OK;
69 CTO(PARTITION,"kostka_number_partition",b);
70 CTO(EMPTY,"kostka_number_partition(3)",c);
71
72 d = CALLOCOBJECT();
73 erg += m_pa_s(b,d);
74 erg += mkn_co(d,a,c);
75 FREEALL(d);
76 ENDR("kostka_number_partition");
77 }
78
kostka_number_skewpartition(a,b,c)79 INT kostka_number_skewpartition(a,b,c) OP a,b,c;
80 /* AK 240901 */
81 /* inhalt, umriss, res */
82 {
83 OP d;
84 INT erg = OK;
85 CTO(SKEWPARTITION,"kostka_number_skewpartition",b);
86 CTO(EMPTY,"kostka_number_skewpartition(3)",c);
87
88 d = callocobject();
89 erg += part_part_skewschur(S_SPA_G(b),S_SPA_K(b),d);
90 erg += mkn_co(d,a,c);
91 erg += freeall(d);
92 ENDR("kostka_number_skewpartition");
93 }
94
mkn_co(b,a,c)95 static INT mkn_co(b,a,c) OP b,a,c;
96 /* b is schur
97 a is inhalt */
98 {
99 INT i,erg=OK;
100 OP s,z;
101 CTO(EMPTY,"mkn_co(2)",c);
102
103 s = CALLOCOBJECT();
104 for (i=0;i<S_V_LI(a);i++)
105 if (S_V_II(a,i) > 0)
106 {
107 erg += init(HASHTABLE,s);
108 erg += schur_part_skewschur(b,S_V_I(a,i),s);
109 SWAP(b,s);
110 }
111
112 CTO(HASHTABLE,"mkn_co(internal)",b);
113 FORALL(z,b,{ goto ee; } );
114 M_I_I(0,c);
115 goto ende;
116 ee:
117 COPY(S_MO_K(z),c);
118 ende:
119 FREEALL(s);
120 CTTO(INTEGER,LONGINT,"mkn_co(res)",c);
121 ENDR("internal to kostka_number_partition");
122 }
123
124
kostka_tafel(a,b)125 INT kostka_tafel(a,b) OP a,b;
126 /* AK 220488 */
127 /* AK 220897 S1R */
128 /* AK 160299 input tested */
129 {
130 INT erg=OK;
131 CTO(INTEGER,"kostka_tafel",a);
132 if (S_I_I(a) == 0)
133 {
134 erg += m_ilih_m((INT)0, (INT)0, b);
135 goto endr_ende;
136 }
137 if (S_I_I(a) < 0)
138 {
139 error("kostka_tafel:weight <= 0");
140 goto endr_ende;
141 }
142 C1R(a,"kostka_tafel",b);
143 erg += neu_n_kostka(a,b);
144 S1R(a,"kostka_tafel",b);
145 ENDR("kostka_tafel");
146 }
147
invers_kostka_tafel(a,b)148 INT invers_kostka_tafel(a,b) OP a,b;
149 /* AK 220897 */
150 /* AK 171297 input tested */
151 {
152 INT erg = OK;
153 OP c;
154 CTO(INTEGER,"invers_kostka_tafel",a);
155 if (S_I_I(a) == 0)
156 {
157 erg += m_ilih_m((INT)0, (INT)0, b);
158 goto endr_ende;
159 }
160 else if ( S_I_I(a) < 0 )
161 {
162 erg += error("invers_kostka_tafel: weight < 0");
163 goto endr_ende;
164 }
165 C1R(a,"invers_kostka_tafel",b);
166
167
168 c = callocobject();
169 erg += kostka_tafel(a,c);
170 erg += invers(c,b);
171 erg += freeall(c);
172
173 S1R(a,"invers_kostka_tafel",b);
174 ENDR("invers_kostka_tafel");
175 }
176
make_n_transpositionmatrix(dim,mat)177 INT make_n_transpositionmatrix(dim,mat) OP dim,mat;
178 /* 300388 berechnet die matrix J [MD p.55]
179 J_PQ = 1 <==> conjugierte Partition von P ist Q, null sonst */
180 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
181 /* AK 210891 V1.3 */
182 {
183 INT i;
184 INT erg = OK;
185 OP conpart;
186 OP vector;
187
188 CTO(INTEGER,"make_n_transpositionmatrix(1)",dim);
189
190 conpart=callocobject();
191 vector=callocobject();
192
193 erg += init_kostka(dim,mat,vector);
194 for (i=(INT)0;i<s_m_hi(mat);i++)
195 {
196 erg += conjugate(S_V_I(vector,i),conpart);
197 M_I_I(1L,S_M_IJ(mat,i,indexofpart(conpart)));
198 };
199 erg += freeall(conpart);
200 erg += freeall(vector);
201 ENDR("make_n_transpositionmatrix");
202 }
203
204
205
tex_kostka(koma,vector)206 INT tex_kostka(koma,vector) OP koma,vector;
207 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
208 /* koma ist die matrix, vector der vector der partitionen */
209 /* AK 070291 V1.2 prints to texout */
210 /* AK 210891 V1.3 */
211 {
212 INT i,j;
213 fprintf(texout,"$ \\matrix { ");
214 for (i=(INT)0;i<S_V_LI(vector);i++)
215 {
216 fprintf(texout," & ");
217 fprint(texout,S_V_I(vector,i));
218 texposition = (INT)0;
219 };
220 fprintf(texout," \\cr \n");
221 for (i=(INT)0;i<S_V_LI(vector);i++)
222 {
223 fprint(texout,S_V_I(vector,i)) ;
224 texposition = (INT)0;
225 for (j=(INT)0;j<=i;j++)
226 { fprintf (texout," & ");
227 fprintf(texout," %ld ",S_M_IJI(koma,i,j)); };
228 for (j=i+1L;j<S_V_LI(vector);j++)
229 fprintf(texout," & ");
230 fprintf(texout," \\cr \n");
231 };
232 fprintf(texout," } $"); return(OK);
233 }
234
scan_kostka(a)235 INT scan_kostka(a) OP a;
236 /* AK 280388 */ /* AK 170789 V1.0 */ /* AK 181289 V1.1 */
237 /* AK 210891 V1.3 */
238 {
239 OP i = callocobject();
240 INT erg = OK;
241 CTO(EMPTY,"scan_kostka(1)",a);
242
243 printeingabe("Weight of the Kostka matrix");
244 erg += scan(INTEGER,i);
245 erg += kostka_tafel(i,a);
246 erg += freeall(i);
247 ENDR("scan_kostka");
248 }
249
lookupinschurspeicher(part,c)250 static OP lookupinschurspeicher(part,c) OP part,c;
251 /* sucht in speicher die entsprechenden eintraege
252 falls nicht vorhanden werden sie berechnet
253 140687 */
254 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
255 /* AK 210891 V1.3 */
256 {
257 INT i;
258 OP w,zeigerw,zeigeri;
259
260 w = callocobject();
261
262 /* sortiert nach gewicht und index der partition */
263
264 weight_partition(part,w); /* gewicht w ist erster index */
265 i = indexofpart(part); /* index i der part. ist 2. index */
266
267 zeigerw = S_V_I(c,S_I_I(w)-1L);
268 /* zeiger auf zeile in der speicher- matrix mit partitionen vom gewicht w*/
269
270 if (EMPTYP(zeigerw)) /* wenn in zeile w noch keine eintraege */
271 {
272 /* laenge der zeile w ist gerade anzahl
273 der part vom gewicht w */
274 m_il_v(numberofpart_i(w),zeigerw);
275 /* schaffe speicherplatz fuer zeile w */
276 };
277
278 zeigeri = S_V_I(zeigerw,i); /* zeiger auf spaltenindex */
279
280 freeself(w);
281 if (EMPTYP(zeigeri))
282 {
283 OP einspart;
284 OP einspartschur;
285 OP kurzergebnis;
286
287 if (i==0) /* einteilige partition */
288 {
289 copy_partition(part,w);
290 b_pa_s(w,zeigeri); /* dann die schurfunktion {n} */
291 return zeigeri; /* ende */
292 }
293 einspart = callocobject();
294 einspartschur = callocobject();
295
296 m_i_pa(S_PA_I(part,S_PA_LI(part)-1L),einspart);
297 b_pa_s(einspart,einspartschur);
298 /* einspartschur ist schurfunktion
299 aus dem letzten element von part */
300
301 copy_partition(part,w); dec(w);
302 /* w ist part ohne letztes element*/
303 kurzergebnis=lookupinschurspeicher (w,c);
304 freeall(w);
305 /* w war nur zum suchen noetig */
306
307
308 mult_schur_schur(kurzergebnis,einspartschur,zeigeri);
309 freeall(einspartschur);
310 return zeigeri;
311 };
312
313 /* falls ergebnis im speicher */
314 freeall(w);
315 return zeigeri;
316 }
317
318
319
neu_n_kostka(n,komatrix)320 static INT neu_n_kostka(n,komatrix) OP n,komatrix;
321 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
322 /* AK 210891 V1.3 */
323 {
324 OP speicher = callocobject();
325 /* hier werden die bereits berechneten schurfunktionen
326 gespeichert */
327
328 m_il_v((INT)150,speicher);
329 /* d.h maximal bis dim 150 */
330 /* initialisieren der Matrix */
331
332 nspeicherkostka(n,speicher,komatrix);
333 freeall(speicher);
334 return(OK);
335 }
336
337
338
allkostka(n)339 INT allkostka(n) OP n;
340 /* AK 190687 gibt alle kostkamatrizen bis n aus */
341 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
342 /* AK 210891 V1.3 */
343 {
344 OP speicher = callocobject();
345 /* hier werden die bereits berechneten schurfunktionen
346 gespeichert */
347 OP lauf = callocobject();
348 /* lauf variable bis n */
349 /* initialisieren des speichers */
350 OP komatrix = callocobject() ;
351
352 m_il_v(150L,speicher);
353 /* d.h maximal bis dim 150 */
354 /* initialisieren der Matrix */
355
356
357 for (M_I_I(1L,lauf);le(lauf,n);inc(lauf))
358 {
359 OP var = callocobject();
360 copy(lauf,var);
361 printf("kostkamatrix fuer ");
362 println(lauf);
363 nspeicherkostka(var,speicher,komatrix);
364 println(komatrix);
365 freeself(komatrix);
366 }
367
368 freeall(lauf); freeall(komatrix); freeall(speicher); return(OK);
369 }
370
371
372
nspeicherkostka(n,sp,komatrix)373 static INT nspeicherkostka(n,sp,komatrix) OP n; OP komatrix; OP sp;
374 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
375 {
376 INT i,j,pi,pj, k,partadr;
377 INT erg = OK;
378 OP zeiger;
379 OP schur;
380 OP vector;
381 OP prepart;
382
383 CTO(INTEGER,"nspeicherkostka(1)",n);
384
385 schur = callocobject();
386 vector = callocobject();
387 prepart = callocobject();
388
389
390 init_kostka(n,komatrix,vector);
391 /* initialisieren der 1. Zeile */
392 M_I_I(1L,S_M_IJ(komatrix,(INT)0,(INT)0));
393 /* globale schleife ueber alle partitionen */
394
395 for (i=1L;i<S_V_LI(vector);i++)
396 {
397 /* suche die benachbarte partition bzgl
398 der dominanzordnung */
399 prepartdom(S_V_I(vector,i),&pi,&pj,prepart);
400 j=(i-1L);
401 while (NEQ(prepart,S_V_I(vector,j))) j--;
402 /* j ist jetzt die adresse von prepart in partvec */
403 /* pi, pj die zeilennummer in denen getauscht wurde um
404 den dominanten nachbarn zu erhalten
405 */
406 make_neu_partij_schur(S_V_I(vector,i),pi,pj,schur,sp);
407 /* die zeile j der matrix wird in die zeile i kopiert */
408 for (k=(INT)0;k<=j;k++)
409 M_I_I(S_M_IJI(komatrix,j,k),S_M_IJ(komatrix,i,k));
410 /* jetzt werden die beitraege von schur addiert */
411 zeiger = schur;
412 while (zeiger != NULL)
413 {
414 partadr=(INT)0;
415 while(NEQ(S_S_S(zeiger),S_V_I(vector,partadr)))
416 partadr++;
417 /* partadr ist index des monoms von zeiger */
418
419 ADD_APPLY(S_S_K(zeiger),S_M_IJ(komatrix,i,partadr));
420
421 zeiger = S_S_N(zeiger);
422 };
423 freeself(schur);
424 freeself(prepart);
425 };
426 freeall(schur); freeall(prepart); freeall(vector);
427 ENDR("nspeicherkostka");
428 }
429
430
431
removepartij(part,i,j,neupart)432 INT removepartij(part,i,j,neupart) OP part,neupart; INT i,j;
433 /* AK 260587 */
434 /* entfernt aus partition part die Teile i,j
435 und ergibt so die neue partition neupart */
436 /* bsp: removepartij(1224568, 2,3, neupart ist dann 12568 */
437 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
438 /* AK 210891 V1.3 */
439 {
440 INT l,nl;
441 INT erg = OK;
442 OP self;
443 CTO(PARTITION,"removepartij(1)",part);
444
445 if (not EMPTYP(neupart)) freeself(neupart);
446 if (S_PA_LI(part) <2L)
447 { error("partition der laenge < 2 in removepartij");
448 return(ERROR); }
449 else if (S_PA_LI(part) == 2L) return(OK);
450
451
452 self = CALLOCOBJECT();
453 erg += m_il_v(S_PA_LI(part)-2L,self);
454 erg += b_ks_pa(VECTOR,self,neupart);
455
456 nl =(INT)0; /* adr. in neupart */
457
458 for (l=(INT)0;l<S_PA_LI(part);l++)
459 if ((l!=i)&&(l!=j))
460 {
461 M_I_I(S_PA_II(part,l),S_PA_I(neupart,nl));
462 nl++;
463 };
464
465 ENDR("removepartij");
466 }
467
468
469
make_ij_part(part,i,j,neupart)470 INT make_ij_part(part,i,j,neupart) INT i,j; OP part,neupart;
471 /* macht zweizeilige Partition aus den teilen i und j der
472 partition part */
473 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
474 /* AK 210891 V1.3 */
475 {
476 INT erg = OK;
477 OP self;
478 CTO(PARTITION,"make_ij_part(1)",part);
479
480 if (S_PA_LI(part) <2L)
481 {
482 erg += error("partition der laenge < 2 in removepartij");
483 goto endr_ende;
484 }
485
486 self = CALLOCOBJECT();
487 erg += m_il_v(2,self);
488 erg += b_ks_pa(VECTOR,self,neupart);
489 M_I_I(S_PA_II(part,i),S_PA_I(neupart,(INT)0));
490 M_I_I(S_PA_II(part,j),S_PA_I(neupart,1L));
491 ENDR("make_ij_part");
492 }
493
494
495
make_partij_perm(part,i,j,perm)496 INT make_partij_perm(part,i,j,perm) OP part,perm; INT i,j;
497 /* AK 190587 */
498 /* es gilt i<j
499 partition ist eine aufsteigende zahlenfolge
500 prozedur bildet aus einer partition p = [p1,p2,..,pn]
501 eine permutation, die den index zum schubert-
502 polynom fuer
503 {pi,pj} x {p1}x..x{pi-1}x{pi+1}x..x{pj-1}x{pj+1}x..x{pn}
504 bildet */
505 /* ok am 190587 */ /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
506 /* AK 210891 V1.3 */
507 {
508 OP permlength = callocobject();
509 OP zw = callocobject();
510 OP code = callocobject();
511 INT l,
512 codeadresse ;/* stelle zum einfuegen im code */
513
514 /*
515 als erstes die laenge der permutation berechnen
516 */
517
518 if (not EMPTYP(perm)) freeself(perm);
519 weight_partition(part,permlength);
520 sub(permlength,S_PA_I(part,i),permlength);
521 length(part,zw);
522 add(zw,permlength,permlength);
523 INC_INTEGER(permlength);
524
525 /* den lehmercode aufbauen */
526 m_il_v(S_I_I(permlength),code); freeall(permlength);
527 for (l=(INT)0;l<S_I_I(permlength);l++) M_I_I((INT)0,S_V_I(code,l));
528 M_I_I(S_PA_II(part,i),S_V_I(code,1L));
529 M_I_I(S_PA_II(part,j),S_V_I(code,2L));
530 codeadresse = 2L + S_PA_II(part,j) + 1L;
531 for (l=(INT)0;l<S_PA_LI(part);l++)
532 {
533 if ((l!=i) && (l!=j))
534 {
535 M_I_I(S_PA_II(part,l),S_V_I(code,codeadresse));
536 codeadresse += S_PA_II(part,l);
537 codeadresse++;
538 };
539 }
540 /* den code umwandeln in permutation */
541
542 lehmercode_vector(code,perm);
543 /* alles unnoetige wieder freigeben */
544
545 freeall(code); freeall(zw);
546 return(OK);
547 }
548
549
550
make_neu_partij_schur(part,i,j,schur,sp)551 INT make_neu_partij_schur(part,i,j,schur,sp)
552 OP part,schur, sp;INT i,j;
553 /* AK 140687 */ /* mit lookup */ /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
554 /* AK 210891 V1.3 */
555 {
556 INT erg = OK;
557 OP a,b,zweizeilenpart,kleinerpart;
558
559 CTO(PARTITION,"make_neu_partij_schur(1)",part);
560
561 a = callocobject();
562 zweizeilenpart = callocobject();
563 kleinerpart = callocobject();
564
565 if (not EMPTYP(schur)) freeself(schur);
566 removepartij(part,i,j,kleinerpart);
567 make_ij_part(part,i,j,zweizeilenpart);
568 b_pa_s(zweizeilenpart,a);/*zweizeilenpart muss nicht freigegeben
569 werden */
570 if (EMPTYP(kleinerpart))
571 erg += copy(a,schur);
572 else {
573 b=lookupinschurspeicher(kleinerpart,sp);
574 mult_schur_schur(a,b,schur);
575 };
576
577 freeall(a);
578 freeall(kleinerpart);
579 ENDR("make_neu_partij_schur");
580 }
581
582
583
make_partij_schur(part,i,j,schur)584 INT make_partij_schur(part,i,j,schur) OP part,schur; INT i,j;
585 /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
586 /* AK 210891 V1.3 */
587 {
588 OP perm = callocobject();
589 make_partij_perm(part,i,j,perm);
590 if (not EMPTYP(schur)) freeself(schur);
591 newtrans(perm,schur); freeall(perm); return(OK);
592 }
593
594
595
prepartdom(part,i,j,prepart)596 INT prepartdom(part,i,j,prepart) OP part,prepart; INT *i,*j;
597 /* AK 190587 */
598 /* berechnet einen groesseren nachbarn prepart
599 der Partition part bezueglich der
600 dominanzordnung
601 dazu wird der satz verwandt, dass ein dominanter nachbar
602 sich nur durch ein verschobenes kaestchen im young-diagramm
603 unterscheidet
604 i ist die zeile in part wo ein kaestchen weggenommen wird
605 j ist die zeile in part wo es angefuegt wird */
606 /* ok 200587 */ /* AK 200789 V1.0 */ /* AK 181289 V1.1 */
607 /* AK 210891 V1.3 */
608 {
609 INT l;
610 INT erg = OK;
611
612 CTO(PARTITION,"prepartdom(1)",part);
613 if (part == prepart) {
614 error("prepartdom:identical");
615 goto endr_ende;
616 }
617
618 FREESELF(prepart);
619
620 *i = (INT)0;
621 /* falls die partition part mit 1 beginnt */
622 if (einsp(S_PA_I(part,(INT)0)))
623 {
624 OP self;
625 self = CALLOCOBJECT();
626 erg += m_il_v(S_PA_LI(part) - 1L,self);
627 erg += b_ks_pa(VECTOR,self,prepart);
628
629 /* prepart ist dann um eins kuerzer */
630 /* kopiere part ohne den ersten teil*/
631 for (l=1L;l<S_PA_LI(part);l++)
632 M_I_I(S_PA_II(part,l),S_PA_I(prepart,(l-1L)));
633 /* suche die stelle zum anfuegen des kaestchenens */
634 for (l=1L;l<S_PA_LI(prepart);l++)
635 if (S_PA_II(prepart,l) > S_PA_II(prepart,(l-1L)))
636 {
637 INC_INTEGER(S_PA_I(prepart,(l-1L)));
638 *j = l; goto prepartende;
639 };
640 /* der Sonderfall falls in der letzten Zeile ein
641 kaestchen angefuegt wird */
642 INC_INTEGER(S_PA_I(prepart,(l-1L)));
643 *j = l; goto prepartende;
644 }
645 else {
646 /* part beginnt mit > 1 */
647
648 copy_partition(part,prepart);
649 DEC_INTEGER(S_PA_I(prepart,(INT)0));
650 for (l=2L;l<S_PA_LI(prepart);l++)
651 if (S_PA_II(prepart,l) > S_PA_II(prepart,(l-1L)))
652 {
653 INC_INTEGER(S_PA_I(prepart,(l-1L)));
654 *j = l-1L; goto prepartende;
655 };
656 INC_INTEGER(S_PA_I(prepart,(l-1L)));
657 *j = l-1L; goto prepartende;
658 };
659 prepartende:
660 ENDR("prepartdom");
661 }
662
663
664
init_kostka(n,koma,vector)665 INT init_kostka(n,koma,vector) OP koma,n,vector;
666 /* AK 250587 */ /* AK 200789 V1.0 */
667 /* koma wird eine Matrix gross genug, vector ein vector der partitionen */
668 /* AK 181289 V1.1 */
669 /* AK 210891 V1.3 */
670 {
671 INT i,j,l;
672
673 if (not EMPTYP(koma)) freeself(koma);
674 if (not EMPTYP(vector)) freeself(vector);
675 makevectorofpart(n,vector);
676 l = S_V_LI(vector);
677 m_ilih_m(l,l,koma); /* AK 030189 */
678 for (i=(INT)0;i<l;i++) for (j=(INT)0;j<l;j++) M_I_I((INT)0,S_M_IJ(koma,i,j));
679 return(OK);
680 }
681
682
683
684
test_kostka()685 INT test_kostka()
686 /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
687 {
688 OP a = callocobject();
689 OP b = callocobject();
690 OP c = callocobject();
691
692 printf("test_kostka:scan(a)");
693 scan(KOSTKA,a);println(a);
694 printf("test_kostka:add(a,a,b)");
695 add(a,a,b);
696 println(b);
697 printf("test_kostka:mult(a,b,b)"); mult(a,b,b); println(b);
698 #ifdef BRUCHTRUE
699 printf("test_kostka:invers(a,b)");
700 invers(b,a);
701 println(a);
702 #endif /* BRUCHTRUE */
703 printf("test_kostka:make_n_transpositionmatrix(a,b)");
704 scan(INTEGER,a);
705 make_n_transpositionmatrix(a,b); println(b);
706 printf("test_kostka:scan(PARTITION,a)(inh)"); scan(PARTITION,a);
707 printf("test_kostka:scan(PARTITION,b)(umriss)"); scan(PARTITION,b);
708 printf("test_kostka:kostka_number(a,b,c)");
709 kostka_number(a,b,c);println(c);
710
711 freeall(a);freeall(b);
712 return(OK);
713 }
714
715
716
kostka_tab(shape,content,c)717 INT kostka_tab(shape,content,c) OP shape,content,c;
718 /* AK 131190 V1.1 */
719 /* AK 160791 V1.3 */
720 /* return: LIST of TABLEAUX or SKEWTABLEAUX */
721 /* AK 100902 V2.1 */
722 {
723 INT i,erg = OK;
724
725 CE3(shape,content,c,kostka_tab);
726 if (S_O_K(content) == PARTITION) /* AK 100992 */
727 content = S_PA_S(content);
728 else if (S_O_K(content) == VECTOR);
729 else if (S_O_K(content) == INTEGERVECTOR);
730 else
731 {
732 WTO(content,"kostka_tab(2)");
733 goto endr_ende;
734 }
735
736 for (i=(INT)0;i<S_V_LI(content);i++)
737 if (S_O_K(S_V_I(content,i)) != INTEGER)
738 {
739 erg += error("kostka_tab: wrong content type");
740 goto endr_ende;
741 }
742
743 switch (S_O_K(shape))
744 {
745 case PARTITION:
746 if (S_PA_LI(shape) == 0) /* AK 100902 */
747 {
748 OP d;
749 erg += init(LIST,c);
750 d = CALLOCOBJECT();
751 erg += m_u_t(shape,d);
752 insert(d,c,NULL,NULL);
753 }
754 else
755 erg += kostka_tab_partition(shape,content,c);
756 break;
757 case SKEWPARTITION:
758 erg += kostka_tab_skewpartition(shape,content,c);
759 break;
760 default:
761 WTO(shape,"kostka_tab(1)");
762 goto endr_ende;
763 }
764 ENDR("kostka_tab");
765 }
766
767
768
769 typedef INT KO_INTARRAY[RH_MAX];
770
kostka_tab_partition(a,b,c)771 static INT kostka_tab_partition(a,b,c) OP a,b,c;
772 /* Ralf Hager 1989 */
773 /* a ist partition fuer umriss */ /* b ist vector fuer inhalt */
774 /* c wird liste mit allen tableau */ /* AK 271289 V1.1 */
775 /* AK 210891 V1.3 */
776 {
777 INT i,j;
778
779 INT *um,*hilf,*ziel,len,n;
780 INT (* tab)[RH_MAX];
781 INT x,*inh,*hilf_zwei,k;
782 INT counter = (INT)0;
783 tab = (KO_INTARRAY *) SYM_calloc(RH_MAX*RH_MAX,sizeof(INT));
784 ziel = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
785 hilf = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
786 hilf_zwei = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
787 inh = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
788 um = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
789
790 init(BINTREE,c); /* AK 170392 */
791
792 for (i=1L;i <=S_PA_LI(a); i++)
793 hilf_zwei[i] = S_PA_II(a,S_PA_LI(a)-i);
794 x = S_PA_LI(a);
795 n = hilf_zwei[1];
796 um[1] = k = x;
797 j = 2L;
798 while(k >= 1L)
799 {
800 counter = (INT)0;
801 for(i=j;i<=hilf_zwei[k];++i) { counter++; um[i] = x; }
802 k--;
803 x=k;
804 j+= counter;
805 }
806 for(i=1L;i<=n;++i) hilf[i] = um[i];
807 um[0] = -1L;
808 for(i=(INT)0;i<n;++i)
809 { um[i+1] = um[1]+i; ziel[i+1] = um[i+1] - hilf[i+1]; }
810 len = S_V_LI(b);
811 for (i=1L;i <= S_V_LI(b); i++)
812 inh[i] = S_V_II(b,i-1L);
813
814 SYM_free(hilf_zwei);
815 SYM_free(hilf);
816 rh_kostka(tab,um,ziel,inh,(INT)0,(INT)0,inh[1],1L,len,n,um[1],c,a);
817 SYM_free(um);
818 SYM_free(ziel);
819 SYM_free(inh);
820 SYM_free(tab);
821 t_BINTREE_LIST(c,c); /* AK 170392 */
822 return(OK);
823
824 }
825
826
827
828
rh_kostka(tab,um,ziel,inh,k,i,zahl,st,len,n,deg,c,d)829 static INT rh_kostka(tab,um,ziel,inh,k,i,zahl,st,len,n,deg,c,d)
830 INT tab[RH_MAX][RH_MAX];
831 INT um[RH_MAX];
832 INT ziel[RH_MAX];
833 INT inh[RH_MAX];
834 INT k,i,zahl,st,len,n,deg;
835 OP c,d;
836 {
837 INT l;
838
839 if(i==zahl)
840 {
841 if(st==len)
842 rh_ausgabemat(tab,deg,n,c,d);
843 else
844 rh_kostka(tab,um,ziel,inh,(INT)0,(INT)0,
845 inh[st+1],st+1L,len,n,deg,c,d);
846 }
847 else
848 {
849 for(l=k+1L;l<=n;++l)
850 {
851 if(((um[l]-1L) > um[l-1])&&(um[l] > ziel[l]))
852 {
853 um[l]--;
854 rh_insert(tab[l],st,len);
855 rh_kostka(tab,um,ziel,inh,l,
856 i+1L,zahl,st,len,n,deg,c,d);
857 rh_delete(tab[l],st,len);
858 um[l]++;
859 }
860 }
861 }
862 return(OK);
863 }
864
865
866
rh_ausgabemat(tab,n,laenge,c,d)867 static INT rh_ausgabemat(tab,n,laenge,c,d)
868 INT tab[RH_MAX][RH_MAX],n,laenge; OP c,d;
869 /* c ist liste, d ist umriss */
870 /* Ralf Hager 1989 */ /* AK 281289 V1.1 */ /* AK 210891 V1.3 */
871 {
872 INT i;
873 INT j;
874 INT erg = OK;
875 OP e = callocobject();
876 OP f = callocobject();
877
878 erg += copy(d,e);
879 erg += m_u_t(e,f);
880 for(i=1L;i<=n;++i)
881 for(j=1L;j<=laenge;++j)
882 {
883 if (tab[j][i] > (INT)0)
884 M_I_I(tab[j][i],S_T_IJ(f,i-1L,j-1L));
885 }
886
887 insert(f,c,NULL,NULL);
888 erg += freeall(e); /* AK 130392 */
889 return erg;
890 }
891
892
rh_insert(v,z,len)893 static INT rh_insert(v,z,len) INT v[RH_MAX]; INT z,len;
894 {
895 INT i;
896
897 for(i=1L;i<=len;++i)
898 if(v[i]==(INT)0) { v[i]=z; break; }
899 return(OK);
900 }
901
902
rh_delete(v,z,len)903 static INT rh_delete(v,z,len) INT v[RH_MAX]; INT z,len;
904 {
905 INT i;
906
907 for(i=len;i>=1L;--i)
908 if(v[i]>(INT)0) { v[i]=(INT)0; break; }
909 return(OK);
910 }
911
912
kostka_character(a,b)913 INT kostka_character(a,b) OP a,b;
914 /* AK 020290 V1.1 */
915 /* AK 210891 V1.3 */
916 {
917 OP c = callocobject();
918 m_part_kostkaperm(a,c);
919 newtrans(c,b);
920 freeall(c);
921 return(OK);
922 }
923
924
m_part_kostkaperm(a,b)925 INT m_part_kostkaperm(a,b) OP a,b;
926 /* AK 020290 V1.1 */
927 /* AK 210891 V1.3 */
928 {
929 INT i,j;
930 OP z;
931 OP c = callocobject();
932 OP d = callocobject();
933 weight(a,c);
934 m_il_v(S_I_I(c) + S_PA_LI(a),d);
935 z = S_V_S(d);
936 for (i=(INT)0;i<S_PA_LI(a);i++)
937 { M_I_I(S_PA_II(a,i), z++);
938 for (j=0;j<S_PA_II(a,i);j++) M_I_I((INT)0,z++);
939 }
940 lehmercode(d,b);
941 freeall(c);freeall(d);
942 return(OK);
943 }
944
945
moebius_tafel(n,m)946 INT moebius_tafel(n,m) OP n,m;
947 /* eins an den eintraegn der kostkatafel */
948 /* AK 300790 V1.1 */
949 /* AK 210891 V1.3 */
950
951 {
952 INT i , j;
953 OP c = callocobject();
954 kostka_tafel(n,c);
955 for (i=0;i<S_M_HI(c); i++)
956 for (j=0;j<S_M_HI(c); j++)
957 if (not nullp(S_M_IJ(c,i,j))) {
958 if (S_O_K(S_M_IJ(c,i,j)) != INTEGER)
959 freeself(S_M_IJ(c,i,j));
960 m_i_i(1L,S_M_IJ(c,i,j)); }
961 invers(c,m);
962 freeall(c);
963 return(OK);
964 }
965
966
967
968
stirling_second_number_kostka(n,k,result)969 INT stirling_second_number_kostka(n,k,result) OP n,k,result;
970 /* computes stirling number of the second kind,
971 using kostkanumbers */
972 /* AK 300790 V1.1 */
973 /* AK 210891 V1.3 */
974 {
975 OP lp = callocobject();
976 OP pv = callocobject();
977 OP h1 = callocobject();
978 OP h2 = callocobject();
979 OP h3 = callocobject();
980 OP h4 = callocobject();
981 INT i,j;
982 m_i_i((INT)0,result); /* freese result first */
983 makevectorofpart(n,pv);
984 for (i=0;i<S_V_LI(pv);i++)
985 {
986 if (S_PA_LI(S_V_I(pv,i)) == S_I_I(k))
987 {
988 m_i_i((INT)0,h4);
989 for (j=0;j<S_V_LI(pv);j++)
990 {
991 kostka_number(S_V_I(pv,i),S_V_I(pv,j),h1);
992 kostka_number(S_V_I(pv,S_V_LI(pv)-1L),S_V_I(pv,j),h2);
993 mult(h1,h2,h3);
994 add_apply(h3,h4);
995 }
996 t_VECTOR_EXPONENT(S_V_I(pv,i),h3);
997 for(j=(INT)0;j<S_PA_LI(h3);j++)
998 {
999 fakul(S_PA_I(h3,j),h2);
1000 div(h4,h2,h4);
1001 }
1002 add(h4,result,result);
1003 }
1004 }
1005 freeall(h1); freeall(h2); freeall(h3); freeall(h4);
1006 freeall(lp);freeall(pv);
1007 return(OK);
1008 }
1009
1010
1011
1012
stirling_second_number(n,k,result)1013 INT stirling_second_number(n,k,result) OP n,k,result;
1014 /* AK 010890 V1.1 */
1015 /* using rekursion */
1016 /* AK 210891 V1.3 */
1017 {
1018 OP a,b,c,d,e;
1019 if (negp(n) ) return error("stirling_second_number:neg n");
1020 if (negp(k) ) return error("stirling_second_number:neg k");
1021 if (lt(n,k) ) return m_i_i((INT)0,result);
1022 if (eq(n,k) ) return m_i_i(1L,result);
1023 if (nullp(n)) return m_i_i((INT)0,result);
1024 if (nullp(k)) return m_i_i((INT)0,result);
1025 if (einsp(k)) return m_i_i(1L,result);
1026 a = callocobject(); b = callocobject(); c = callocobject();
1027 d = callocobject(); e = callocobject();
1028
1029 M_I_I(1L,a);
1030 copy(n,b);dec(b);
1031 copy(k,d);dec(d);
1032 m_i_i((INT)0,result);
1033 while (lt(a,n))
1034 {
1035 binom(b,a,c);
1036 stirling_second_number(a,d,e);
1037 mult(c,e,e);
1038 add(e,result,result);
1039 inc(a);
1040 }
1041 freeall(a); freeall(b); freeall(c); freeall(d); freeall(e);
1042 return OK;
1043 }
1044
1045
stirling_first_tafel(a,b)1046 INT stirling_first_tafel(a,b) OP a,b;
1047 {
1048 INT erg = OK;
1049 erg += stirling_second_tafel(a,b);
1050 erg += invers(b,b);
1051 return erg;
1052 }
1053
1054
stirling_second_tafel(a,b)1055 INT stirling_second_tafel(a,b) OP a,b;
1056 {
1057 INT i,j;
1058 INT erg = OK;
1059 OP oi=callocobject();
1060 OP oj=callocobject();
1061 erg += m_ilih_m(S_I_I(a)+1L,S_I_I(a)+1L,b);
1062 for (i=(INT)0; i<=S_I_I(a); i++)
1063 for (j=(INT)0; j<=S_I_I(a); j++)
1064 {
1065 M_I_I(i,oi);
1066 M_I_I(j,oj);
1067 erg += stirling_second_number_tafel(oi,oj,S_M_IJ(b,i,j),b);
1068 }
1069 erg += freeall(oi);
1070 erg += freeall(oj);
1071 return erg;
1072 }
1073
1074
stirling_second_number_tafel(n,k,result,t)1075 INT stirling_second_number_tafel(n,k,result,t) OP n,k,result,t;
1076 /* AK 010890 V1.1 */
1077 /* using rekursion */
1078 /* AK 210891 V1.3 */
1079 {
1080 OP a,b,c,d,e;
1081 if (negp(n) ) return error("stirling_second_number:neg n");
1082 if (negp(k) ) return error("stirling_second_number:neg k");
1083 if (lt(n,k) ) return m_i_i((INT)0,result);
1084 if (eq(n,k) ) return m_i_i(1L,result);
1085 if (nullp(n)) return m_i_i((INT)0,result);
1086 if (nullp(k)) return m_i_i((INT)0,result);
1087 if (einsp(k)) return m_i_i(1L,result);
1088
1089 if (lt(n,S_M_H(t))) /* wert is in tafel */
1090 {
1091 if (not EMPTYP(S_M_IJ(t,S_I_I(n),S_I_I(k))))
1092 return copy(S_M_IJ(t,S_I_I(n),S_I_I(k)), result);
1093 }
1094
1095 a = callocobject(); b = callocobject(); c = callocobject();
1096 d = callocobject(); e = callocobject();
1097
1098 M_I_I(1L,a);
1099 copy(n,b);dec(b);
1100 copy(k,d);dec(d);
1101 m_i_i((INT)0,result);
1102 while (lt(a,n))
1103 {
1104 binom(b,a,c);
1105 stirling_second_number_tafel(a,d,e,t);
1106 mult(c,e,e);
1107 add(e,result,result);
1108 inc(a);
1109 }
1110 freeall(a); freeall(b); freeall(c); freeall(d); freeall(e);
1111 return OK;
1112 }
1113
1114
kostka_tab_skewpartition(a,b,c)1115 static INT kostka_tab_skewpartition(a,b,c) OP a,b,c;
1116 /* Ralf Hager 1989 */ /* a ist skewpartition fuer umriss */
1117 /* b ist vector fuer inhalt */ /* c wird liste mit allen tableau */
1118 /* AK 020890 V1.1 */ /* AK 210891 V1.3 */
1119 {
1120 INT i,j;
1121
1122 INT *um,*hilf,*ziel,len,n;
1123 INT (* tab)[RH_MAX];
1124 INT x,*inh,*hilf_zwei,k,m;
1125 INT counter = (INT)0;
1126 OP cp = callocobject();
1127
1128 tab = (KO_INTARRAY *) SYM_calloc(RH_MAX*RH_MAX,sizeof(INT));
1129 ziel = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
1130 hilf = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
1131 hilf_zwei = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
1132 inh = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
1133 um = (INT *) SYM_malloc(RH_MAX * sizeof(INT));
1134
1135 init(BINTREE,c); /* AK 170392 */
1136
1137 for (i=1L;i <=S_SPA_GLI(a); i++)
1138 hilf_zwei[i] = S_SPA_GII(a,S_SPA_GLI(a)-i);
1139 x = S_SPA_GLI(a);
1140 n = hilf_zwei[1];
1141 um[1] = k = x;
1142 j = 2L;
1143 while(k >= 1L)
1144 {
1145 counter = (INT)0;
1146 for(i=j;i<=hilf_zwei[k];++i) { counter++; um[i] = x; }
1147 k--;
1148 x=k;
1149 j+= counter;
1150 }
1151 for(i=1L;i<=n;++i) hilf[i] = um[i];
1152 um[0] = -1L;
1153 for(i=(INT)0;i<n;++i)
1154 { um[i+1] = um[1]+i; ziel[i+1] = um[i+1] - hilf[i+1]; }
1155 m= S_SPA_KLI(a);
1156 conjugate(S_SPA_K(a),cp);
1157 m = S_PA_LI(cp);
1158 for(i=(INT)0;i<m;++i) {
1159 for (j=(INT)0;j<S_PA_II(cp,m-i-1); j++)
1160 {
1161 tab[i+1][j+1]= -7L;
1162 }
1163 }
1164 for(i=(INT)0;i<m;++i) {
1165 um[i+1]=um[i+1]-S_PA_II(cp,m-i-1);
1166 }
1167 len = ((S_SPA_GLI(a) > S_V_LI(b)) ? S_SPA_GLI(a) : S_V_LI(b) ) ;
1168 for (i=1L;i <= S_V_LI(b); i++) inh[i] = S_V_II(b,i-1L);
1169 for (;i<=len;i++) inh[i]=(INT)0; /* AK 240593 */
1170 SYM_free(hilf);
1171 SYM_free(hilf_zwei);
1172
1173 rh_kostka(tab,um,ziel,inh,(INT)0,(INT)0,inh[1],1L,
1174 len,n,um[1]+S_PA_II(cp,m-1),c,a);
1175 freeall(cp);
1176 t_BINTREE_LIST(c,c); /* AK 170392 */
1177 SYM_free(um);
1178 SYM_free(ziel);
1179 SYM_free(inh);
1180 SYM_free(tab);
1181 return(OK);
1182
1183 }
1184
1185
1186
1187 /* bricknumber */
1188
1189 static INT bco();
1190
SYMMETRICA_bricknumber(umriss,cont,res)1191 INT SYMMETRICA_bricknumber(umriss,cont,res)
1192 /* brick tabloids linke in remmel egecioglu:
1193 disc appl math 34 (1991) 107-120 */
1194 /* AK 120901 */
1195 OP umriss,cont,res;
1196 {
1197 INT erg = OK,i,j=0;
1198 /* rekursion per zeile */
1199 /* der cont muss sortiert sein */
1200 OP ni,bb;
1201 CE3(umriss,cont,res,SYMMETRICA_bricknumber);
1202
1203 if (S_O_K(umriss) == PARTITION) umriss = S_PA_S(umriss);
1204 if (S_O_K(cont) == PARTITION) {
1205 cont = S_PA_S(cont);
1206 ni = cont;
1207 }
1208 else {
1209 j=1;
1210 ni = callocobject();
1211 erg += copy_integervector(cont,ni);
1212 erg += sort_vector(ni); /* ansteigend */
1213 }
1214 if (umriss == cont) {
1215 j=1;
1216 ni = callocobject();
1217 erg += copy_integervector(umriss,ni);
1218 erg += sort_vector(ni); /* ansteigend */
1219 }
1220 erg += m_i_i(0,res);
1221 bb = callocobject();
1222 erg += m_il_nv(S_V_LI(umriss),bb);
1223 for (i=0;i<S_V_LI(bb);i++)
1224 erg += m_il_nv(S_V_II(ni,S_V_LI(ni)-1),S_V_I(bb,i));
1225 erg += bco(0,0,umriss,ni,res,bb);
1226 if (j==1) erg += freeall(ni);
1227 erg += freeall(bb);
1228 ENDR("SYMMETRICA_bricknumber");
1229 }
1230
bco(spalte,zeile,umriss,cont,res,bb)1231 static INT bco(spalte,zeile,umriss,cont,res,bb) int spalte,zeile;OP umriss,cont,res,bb;
1232 {
1233 INT erg = OK;
1234 int i,temp,tt=0;
1235
1236
1237 if (zeile >= S_V_LI(umriss)) {
1238 /* end of recursion */
1239 erg += inc(res);
1240 goto endr_ende;
1241 }
1242
1243 if (S_V_II(umriss,zeile) == 0) {
1244 /* es kann an die naechste zeile gegangen werden, das ergebnis von dort
1245 muss mit dem pasenden multimomial coeff multipliziert werden */
1246
1247 OP newres = callocobject();
1248 OP mn = callocobject();
1249 erg += m_i_i(0,newres);
1250
1251 /* in bb[zeile] ist die besetzung der unteren zeile
1252 nun multinomial coeff berechnen fuer die multiplikation */
1253
1254 for (i=0;i<S_V_LI(S_V_I(bb,zeile));i++)
1255 M_I_I(S_I_I(newres)+S_V_II(S_V_I(bb,zeile),i),newres);
1256
1257 /* new res ist die summe ueber die multnomial koeff, d.h. das was oben hinkommt
1258 bei der berechnung des multinomial koeff */
1259
1260 if (S_I_I(newres) > 1) {
1261 if (S_I_I(newres) < 13) {
1262 erg += multinom_small(newres,S_V_I(bb,zeile),mn);
1263 tt=1; }
1264 else
1265 erg += multinom(newres,S_V_I(bb,zeile),mn);
1266 }
1267 else m_i_i(1,mn);
1268
1269 /* in mn ist nun der multinomial koeff */
1270
1271
1272 erg += m_i_i(0,newres);
1273 erg += bco(0,zeile+1,umriss,cont,newres,bb);
1274
1275 /* nun noch multiplizieren */
1276 if (tt==1) {
1277 if (S_I_I(mn) > 1)
1278 erg += mult_apply_integer(mn,newres);
1279 }
1280 else
1281 erg += mult_apply(mn,newres);
1282 erg += add_apply(newres,res);
1283 freeall(newres);
1284 freeall(mn);
1285 goto endr_ende;
1286 }
1287
1288 /* die unterste zeile ist noch nicht gefuellt */
1289 /* da ansteigend gefuellt wird, muss
1290 abspalte im cont gesucht werden ob weitere
1291 eintraege moeglich */
1292
1293 for (i=spalte;i<S_V_LI(cont);i++)
1294 {
1295 if ((i>0) &&
1296 (S_V_II(cont,i) == S_V_II(cont,i-1)))
1297 continue;
1298 else if (S_V_II(cont,i) > 0) {
1299 if (S_V_II(cont,i) <= S_V_II(umriss,zeile)) {
1300 temp = S_V_II(cont,i);
1301 M_I_I(0,S_V_I(cont,i));
1302 m_i_i( s_v_ii(umriss,zeile)-temp,s_v_i(umriss,zeile));
1303 INC_INTEGER(S_V_I(S_V_I(bb,zeile),temp-1));
1304 erg += bco(i+1,zeile,umriss,cont,res,bb);
1305 DEC_INTEGER(S_V_I(S_V_I(bb,zeile),temp-1));
1306 M_I_I(temp,S_V_I(cont,i));
1307 M_I_I( S_V_II(umriss,zeile)+temp,S_V_I(umriss,zeile));
1308 }
1309 else goto endr_ende; /* wenn schon das trum an der stelle i nicht
1310 rein passt, dann auch keine die spaeter kommen,
1311 da ja der cont ansteigend sortiert ist */
1312 }
1313 }
1314 ENDR("internal bricknumber routine");
1315 }
1316
1317 /* to compute the transition matrices */
1318
newindexofpart_co11(a,b)1319 static INT newindexofpart_co11(a,b) OP a,b;
1320 /* AK 030102 */
1321 {
1322 INT h;
1323 if (S_PA_HASH(a) == -1) C_PA_HASH(a,hash_partition(a));
1324 h = S_PA_HASH(a) % S_V_LI(b);
1325 if (h < 0) h += S_V_LI(b);
1326 return (S_V_II(b,h));
1327 }
1328
newtafel(a,b,tf)1329 static INT newtafel(a,b,tf) OP a,b; INT (*tf)();
1330 /* AK 030102 */
1331 {
1332 INT erg = OK,i,j;
1333 INT f = 2;
1334 OP c,h1,h2;
1335 CTO(INTEGER,"newtafel(1)",a);
1336 c = CALLOCOBJECT();
1337 h2 = CALLOCOBJECT();
1338 erg += makevectorofpart(a,c);
1339 again:
1340 init_size_hashtable(h2,S_V_LI(c)*f);
1341 C_O_K(h2,INTEGERVECTOR);
1342 for (i=0;i<S_V_LI(h2);i++) M_I_I(-1,S_V_I(h2,i));
1343 for (i=0;i<S_V_LI(c);i++)
1344 {
1345 INT h;
1346 C_PA_HASH(S_V_I(c,i),hash(S_V_I(c,i)));
1347 h = S_PA_HASH(S_V_I(c,i)) % S_V_LI(h2);
1348 if (h <0) h += S_V_LI(h2);
1349
1350 if (S_V_II(h2, h) != -1) /* coll */ { f++; goto again; }
1351 M_I_I(i, S_V_I(h2,h));
1352 }
1353
1354
1355 erg += m_ilih_nm(S_V_LI(c),S_V_LI(c),b);
1356 NEW_HASHTABLE(h1);
1357 for (i=0;i<S_V_LI(c);i++)
1358 {
1359 OP z;
1360 CTO(HASHTABLE,"newtafel(i1)",h1);
1361 (*tf)(S_V_I(c,i),h1);
1362 CTO(HASHTABLE,"newtafel(i2)",h1);
1363 FORALL(z,h1, {
1364 j = newindexofpart_co11(S_MO_S(z),h2);
1365 FREESELF(S_M_IJ(b,i,j));
1366 COPY(S_MO_K(z),S_M_IJ(b,i,j));
1367 FREESELF(S_MO_K(z));
1368 M_I_I(0,S_MO_K(z));
1369 });
1370 }
1371 FREEALL(c);
1372 FREEALL(h1);
1373 FREEALL(h2);
1374 ENDR("chartafel");
1375 }
1376
SYMMETRICA_HM(a,b)1377 INT SYMMETRICA_HM(a,b) OP a,b;
1378 /* AK 040102 */
1379 {
1380 INT erg = OK;
1381 CTO(INTEGER,"SYMMETRICA_HM(1)",a);
1382 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_HM:parameter < 0");
1383 newtafel(a,b,t_HOMSYM_MONOMIAL);
1384 ENDR("SYMMETRICA_HM");
1385 }
1386
SYMMETRICA_HE(a,b)1387 INT SYMMETRICA_HE(a,b) OP a,b;
1388 /* AK 040102 */
1389 {
1390 INT erg = OK;
1391 CTO(INTEGER,"SYMMETRICA_HE(1)",a);
1392 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_HE:parameter < 0");
1393 newtafel(a,b,t_HOMSYM_ELMSYM);
1394 ENDR("SYMMETRICA_HE");
1395 }
1396
SYMMETRICA_HS(a,b)1397 INT SYMMETRICA_HS(a,b) OP a,b;
1398 /* AK 040102 */
1399 {
1400 INT erg = OK;
1401 CTO(INTEGER,"SYMMETRICA_HS(1)",a);
1402 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_HS:parameter < 0");
1403 newtafel(a,b,t_HOMSYM_SCHUR);
1404 ENDR("SYMMETRICA_HE");
1405 }
1406
SYMMETRICA_HP(a,b)1407 INT SYMMETRICA_HP(a,b) OP a,b;
1408 /* AK 040102 */
1409 {
1410 INT erg = OK;
1411 CTO(INTEGER,"SYMMETRICA_HP(1)",a);
1412 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_HP:parameter < 0");
1413 newtafel(a,b,t_HOMSYM_POWSYM);
1414 ENDR("SYMMETRICA_HP");
1415 }
1416
1417 /* from schur */
1418
SYMMETRICA_SM(a,b)1419 INT SYMMETRICA_SM(a,b) OP a,b;
1420 /* AK 040102 */
1421 {
1422 INT erg = OK;
1423 CTO(INTEGER,"SYMMETRICA_SM(1)",a);
1424 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_SM:parameter < 0");
1425 newtafel(a,b,t_SCHUR_MONOMIAL);
1426 ENDR("SYMMETRICA_SM");
1427 }
1428
SYMMETRICA_SE(a,b)1429 INT SYMMETRICA_SE(a,b) OP a,b;
1430 /* AK 040102 */
1431 {
1432 INT erg = OK;
1433 CTO(INTEGER,"SYMMETRICA_SE(1)",a);
1434 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_SE:parameter < 0");
1435 newtafel(a,b,t_SCHUR_ELMSYM);
1436 ENDR("SYMMETRICA_SE");
1437 }
1438
SYMMETRICA_SH(a,b)1439 INT SYMMETRICA_SH(a,b) OP a,b;
1440 /* AK 040102 */
1441 /* AK 270202 via MS */
1442 {
1443 INT erg = OK;
1444 OP c;
1445 CTO(INTEGER,"SYMMETRICA_SH(1)",a);
1446 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_SH:parameter < 0");
1447
1448 c = CALLOCOBJECT();
1449 erg += newtafel(a,c,t_MONOMIAL_SCHUR);
1450 erg += transpose(c,b);
1451 FREEALL(c);
1452 ENDR("SYMMETRICA_EH");
1453 }
1454
SYMMETRICA_SP(a,b)1455 INT SYMMETRICA_SP(a,b) OP a,b;
1456 /* AK 040102 */
1457 {
1458 INT erg = OK;
1459 CTO(INTEGER,"SYMMETRICA_SP(1)",a);
1460 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_SP:parameter < 0");
1461 newtafel(a,b,t_SCHUR_POWSYM);
1462 ENDR("SYMMETRICA_SP");
1463 }
1464
1465 /* from monomial */
1466
SYMMETRICA_MH(a,b)1467 INT SYMMETRICA_MH(a,b) OP a,b;
1468 /* AK 040102 */
1469 {
1470 INT erg = OK;
1471 CTO(INTEGER,"SYMMETRICA_MH(1)",a);
1472 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_MH:parameter < 0");
1473 newtafel(a,b,t_MONOMIAL_HOMSYM);
1474 ENDR("SYMMETRICA_MH");
1475 }
1476
SYMMETRICA_ME(a,b)1477 INT SYMMETRICA_ME(a,b) OP a,b;
1478 /* AK 040102 */
1479 {
1480 INT erg = OK;
1481 CTO(INTEGER,"SYMMETRICA_ME(1)",a);
1482 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_ME:parameter < 0");
1483 newtafel(a,b,t_MONOMIAL_ELMSYM);
1484 ENDR("SYMMETRICA_ME");
1485 }
1486
SYMMETRICA_MS(a,b)1487 INT SYMMETRICA_MS(a,b) OP a,b;
1488 /* AK 040102 */
1489 {
1490 INT erg = OK;
1491 CTO(INTEGER,"SYMMETRICA_MS(1)",a);
1492 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_MS:parameter < 0");
1493 newtafel(a,b,t_MONOMIAL_SCHUR);
1494 ENDR("SYMMETRICA_MS");
1495 }
1496
SYMMETRICA_MP(a,b)1497 INT SYMMETRICA_MP(a,b) OP a,b;
1498 /* AK 040102 */
1499 {
1500 INT erg = OK;
1501 CTO(INTEGER,"SYMMETRICA_MP(1)",a);
1502 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_MP:parameter < 0");
1503 newtafel(a,b,t_MONOMIAL_POWSYM);
1504 ENDR("SYMMETRICA_MP");
1505 }
1506
1507 /* from elmsym */
1508
SYMMETRICA_EM(a,b)1509 INT SYMMETRICA_EM(a,b) OP a,b;
1510 /* AK 040102 */
1511 {
1512 INT erg = OK;
1513 CTO(INTEGER,"SYMMETRICA_EM(1)",a);
1514 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_EM:parameter < 0");
1515 newtafel(a,b,t_ELMSYM_MONOMIAL);
1516 ENDR("SYMMETRICA_EM");
1517 }
1518
SYMMETRICA_EH(a,b)1519 INT SYMMETRICA_EH(a,b) OP a,b;
1520 /* AK 040102 */
1521 {
1522 INT erg = OK;
1523 CTO(INTEGER,"SYMMETRICA_EH(1)",a);
1524 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_EH:parameter < 0");
1525 newtafel(a,b,t_ELMSYM_HOMSYM);
1526 ENDR("SYMMETRICA_EH");
1527 }
1528
SYMMETRICA_ES(a,b)1529 INT SYMMETRICA_ES(a,b) OP a,b;
1530 /* AK 040102 */
1531 {
1532 INT erg = OK;
1533 CTO(INTEGER,"SYMMETRICA_ES(1)",a);
1534 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_ES:parameter < 0");
1535 newtafel(a,b,t_ELMSYM_SCHUR);
1536 ENDR("SYMMETRICA_ES");
1537 }
1538
SYMMETRICA_EP(a,b)1539 INT SYMMETRICA_EP(a,b) OP a,b;
1540 /* AK 040102 */
1541 {
1542 INT erg = OK;
1543 CTO(INTEGER,"SYMMETRICA_EP(1)",a);
1544 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_EP:parameter < 0");
1545 newtafel(a,b,t_ELMSYM_POWSYM);
1546 ENDR("SYMMETRICA_EP");
1547 }
1548 /* from powsym */
1549
SYMMETRICA_PM(a,b)1550 INT SYMMETRICA_PM(a,b) OP a,b;
1551 /* AK 040102 */
1552 {
1553 INT erg = OK;
1554 CTO(INTEGER,"SYMMETRICA_PM(1)",a);
1555 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_PM:parameter < 0");
1556 newtafel(a,b,t_POWSYM_MONOMIAL);
1557 ENDR("SYMMETRICA_PM");
1558 }
1559
SYMMETRICA_PE(a,b)1560 INT SYMMETRICA_PE(a,b) OP a,b;
1561 /* AK 040102 */
1562 {
1563 INT erg = OK;
1564 CTO(INTEGER,"SYMMETRICA_PE(1)",a);
1565 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_PE:parameter < 0");
1566 newtafel(a,b,t_POWSYM_ELMSYM);
1567 ENDR("SYMMETRICA_PE");
1568 }
1569
SYMMETRICA_PS(a,b)1570 INT SYMMETRICA_PS(a,b) OP a,b;
1571 /* AK 040102 */
1572 {
1573 INT erg = OK;
1574 CTO(INTEGER,"SYMMETRICA_PS(1)",a);
1575 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_PS:parameter < 0");
1576 newtafel(a,b,t_POWSYM_SCHUR);
1577 ENDR("SYMMETRICA_PS");
1578 }
1579
SYMMETRICA_PH(a,b)1580 INT SYMMETRICA_PH(a,b) OP a,b;
1581 /* AK 040102 */
1582 {
1583 INT erg = OK;
1584 CTO(INTEGER,"SYMMETRICA_PH(1)",a);
1585 SYMCHECK(S_I_I(a)<0,"SYMMETRICA_PH:parameter < 0");
1586 newtafel(a,b,t_POWSYM_HOMSYM);
1587 ENDR("SYMMETRICA_PH");
1588 }
1589
1590
1591 #endif /* KOSTKATRUE */
1592