1 #include "def.h"
2 #include "macro.h"
3 /* AK 141086 */
4 /* symchar.c */
5
6 static struct symchar * callocsymchar();
7 static INT calculate();
8 static INT removestrip();
9 static INT addstrip();
10 static INT removestrip_char();
11 static INT addstrip_char();
12 static INT stripexistp();
13 static INT stripexistp_char();
14 static INT (*sef)() = NULL, (*asf)() = NULL, (*rsf)() = NULL;
15
16 INT chartafel_symfunc();
17
18 #ifdef CHARTRUE
augpart(part)19 INT augpart(part) OP part;
20 /* bsp: 1113 --> 1236 */
21 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
22 {
23 INT i;
24 C_O_K(part,AUG_PART);
25 for (i=(INT)0;i<S_PA_LI(part); i++)
26 C_I_I(S_PA_I(part,i),S_PA_II(part,i)+i);
27 return OK;
28 }
29
30
31
stripexistp_char(part,length,i)32 static INT stripexistp_char(part,length,i) OP part; register INT length,i;
33 /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */
34 {
35 /* register INT j; */
36 unsigned char *z = S_PA_CI(part,i);
37 register INT h2;
38
39 h2 = *z;
40
41 for (; i>=(INT)0;i--,z--)
42 if ( (*z + length) == h2)
43 return(FALSE);
44 return(TRUE);
45 }
46
47
48
49
stripexistp(part,length,i)50 static INT stripexistp(part,length,i) OP part; register INT length,i;
51 /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */
52 {
53 /* register INT j; */
54 OP z = S_PA_I(part,i);
55 register INT h2;
56
57 h2 = S_I_I(z);
58
59 for (; i>=(INT)0;i--,z--)
60 if ( (S_I_I(z) + length) == h2)
61 return(FALSE);
62 return(TRUE);
63 }
64
65
66
67
addstrip_char(part,k,i,hi)68 static INT addstrip_char(part,k,i,hi) OP part; register INT k,hi,i;
69 /* part vom Typ CHARPARTITION */
70 {
71 /* register INT l; */
72 i=i-hi;
73 /* in l wird angesetzt */
74 while ((k--)>(INT)0)
75 {
76 if (i == S_PA_LI(part)-(INT)1)
77 {
78 S_PA_CII(part,i)=S_PA_CII(part,i)
79 +(unsigned char)k+(unsigned char)1;
80 goto addstripende;
81 }
82 else if (S_PA_CII(part,i) < S_PA_CII(part,(i+(INT)1)))
83 S_PA_CII(part,i)++;
84 else if (S_PA_CII(part,i) == S_PA_CII(part,(i+(INT)1)))
85 S_PA_CII(part,++i)++;
86 else
87 error("addstrip_char:");
88 }
89 addstripende:
90 return OK;
91 }
92
93
94
95
addstrip(part,k,i,hi)96 static INT addstrip(part,k,i,hi) OP part; register INT k,hi,i;
97 {
98 /* register INT l; */
99 OP z;
100 i -=hi;
101 /* in l wird angesetzt */
102 z = S_PA_I(part,i);
103 while ((k--)>(INT)0)
104 {
105 if (i == S_PA_LI(part)-(INT)1)
106 {
107 C_I_I(z,S_I_I(z)+k+1);
108 goto addstripende;
109 }
110 /*
111 else if (S_I_I(z) < S_I_I(z+1))
112 INC_INTEGER(z);
113 else if (S_I_I(z) == S_I_I(z+1))
114 {
115 i++;
116 z++;
117 INC_INTEGER(z);
118 }
119 else
120 error("addstrip:");
121 */
122 if (S_I_I(z) == S_I_I(z+1))
123 { i++; z++; }
124 INC_INTEGER(z);
125 }
126 addstripende:
127 return OK;
128 }
129
130
131
132
removestrip_char(part,k,i)133 static INT removestrip_char(part,k,i) OP part; register INT k; INT i;
134 /* erzeugt neue partition part in der ab der zeile i ein
135 streifen der laenge length entfernt wurde .
136 ergebnis ist die hakenlaenge */
137 /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */
138 {
139 register INT l;
140 l=i;
141 while ((k--)>(INT)0)
142 {
143 if (i == (INT)0)
144 S_PA_CII(part,(INT)0)--;
145 else if (S_PA_CII(part,i) > S_PA_CII(part,(i-(INT)1)))
146 S_PA_CII(part,i)--;
147 else
148 S_PA_CII(part,--i)--;
149 };
150 return(l-i);
151 }
152
153
154
removestrip(part,k,i)155 static INT removestrip(part,k,i) OP part; register INT k; INT i;
156 /* erzeugt neue partition part in der ab der zeile i ein
157 streifen der laenge length entfernt wurde .
158 ergebnis ist die hakenlaenge */
159 /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */
160 {
161 register INT l;
162 OP z;
163 l=i;
164 z = S_PA_I(part,i);
165 while ((k--)>0)
166 {
167 if (i == 0)
168 {
169 DEC_INTEGER(z);
170 }
171 else if (S_I_I(z) > S_I_I(z-1) )
172 {
173 DEC_INTEGER(z);
174 }
175 else
176 {
177 z--;
178 i--;
179 DEC_INTEGER(z);
180 }
181 };
182 return(l-i);
183 }
184 #endif /* CHARTRUE */
185 #define REMOVESTRIP(part,length,j)\
186 k=length;l=j;m=j;\
187 while ((k--)>(INT)0)\
188 {\
189 if (m == (INT)0) \
190 DEC_INTEGER(S_PA_I((part),(INT)0));\
191 else if (S_PA_II((part),m) > S_PA_II((part),(m-(INT)1)))\
192 DEC_INTEGER(S_PA_I((part),m));\
193 else \
194 DEC_INTEGER(S_PA_I((part),--m));\
195 };\
196 hooklength=l-m;
197
198 #ifdef CHARTRUE
calculate(sign,rep,part,res)199 static INT calculate(sign,rep,part,res) INT sign; OP part, res, rep;
200 /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 250291 V1.2 */
201 /* AK 200891 V1.3 */
202 {
203 INT i,hooklength,l;
204 OP newrep;
205 INT erg=OK;
206 INT (*lsef)() = sef, (*lasf)() = asf, (*lrsf)() = rsf;
207
208 if (S_PA_LI(part) == (INT)0)
209 {
210 if (sign==(INT)1)
211 INC(res);
212 else if (sign == -1L)
213 DEC(res);
214 else
215 erg += ERROR;
216 goto ende;
217 };
218 if (S_PA_LI(part) == 1L) /* Robinson Lemma 4.11 */
219 {
220 if (S_PA_LI(rep) == 1L)
221 {
222 M_I_I(1L,res);
223 goto ende;
224 }
225 if (S_PA_II(rep,S_PA_LI(rep)-2L) > S_PA_LI(rep)-1L )
226 goto ende;
227
228 /* rep is haken */
229 for (i=(INT)0;i<S_PA_LI(rep);i++)
230 if (S_PA_II(rep,i) > i) break;
231 i = S_PA_LI(rep)-i;
232 /* i is laenge der part */
233 if (sign==1L)
234 if (i % 2L == (INT)0)
235 DEC(res);
236 else
237 INC(res);
238 else
239 if (i % 2L == (INT)0)
240 INC(res);
241 else
242 DEC(res);
243 goto ende;
244 }
245 if (S_PA_II(part,S_PA_LI(part)-1) == 1L)
246 /* AK 150988 */ /* dimension */
247 /* all parts are 1, so we compute the dimension */
248 {
249 newrep = CALLOCOBJECT();
250 erg += dimension_augpart(rep,newrep);
251 if (sign == -1L)
252 ADDINVERS_APPLY(newrep);
253 ADD_APPLY(newrep,res);
254 FREEALL(newrep);
255 goto ende;
256 }
257 l = S_PA_LI(part)-1L; /* AK 040293 */
258 for (i=S_PA_LI(rep)-1L;i>=(INT)0;i--)
259 if (S_PA_II(part,l) <= S_PA_II(rep,i))
260 if ((*lsef)( rep, S_PA_II(part,l), i))
261
262 {
263 hooklength = (*lrsf)( rep, S_PA_II(part,l), i);
264 if (S_O_K(part) == PARTITION)
265 DEC_INTEGER(S_PA_L(part));
266 else if (S_O_K(part) == CHARPARTITION) /* AK 130593 */
267 S_PA_C(part)[0]--;
268 erg += calculate( ((hooklength % 2L == (INT)0) ?
269 sign : - sign),
270 rep, part, res);
271 if (S_O_K(part) == PARTITION) /* AK 130593 */
272 INC_INTEGER(S_PA_L(part));
273 else if (S_O_K(part) == CHARPARTITION)
274 S_PA_C(part)[0]++;
275 erg += (*lasf)(rep, S_PA_II(part,l), i,hooklength);
276 };
277 ende:
278 ENDR("calculate");
279 }
280
281
282
charvalue_tafel_part(rep,part,res,tafel,pv)283 INT charvalue_tafel_part(rep,part,res,tafel,pv) OP part,rep,res,tafel,pv;
284 /* AK 260690 V1.1 */ /* AK 250291 V1.2 */
285 /* tafel ist charactertafel, pv ist vector der partitionen */
286 /* AK 200891 V1.3 */
287 {
288 INT i=0,j=0,k;
289 INT erg = OK;
290 CTO(PARTITION,"charvalue_tafel_part(1)",rep);
291 CTO(PARTITION,"charvalue_tafel_part(2)",part);
292 CTO(VECTOR,"charvalue_tafel_part(5)",pv);
293 CTO(MATRIX,"charvalue_tafel_part(4)",tafel);
294
295 for (k=(INT)0; k<= S_V_LI(pv); k++)
296 if (EQ(rep,S_V_I(pv,k))) {i=k; break; }
297 for (k=(INT)0; k<= S_V_LI(pv); k++)
298 if (EQ(part,S_V_I(pv,k))) {j=k; break; }
299 COPY(S_M_IJ(tafel,i,j),res);
300 ENDR("charvalue_tafel_part");
301 }
302
charvalue(rep,part,res,tafel)303 INT charvalue(rep,part,res,tafel) OP part, rep, res; OP tafel;
304 /* tafel ist zeiger auf charactertafel mit werten, sonst NULL AK 130189 */
305 /* part ist der zykeltyp oder eine PERMUTATION */
306 /* rep ist irr. darstellung */
307 /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 050391 V1.2 */
308 /* AK 200891 V1.3 */
309 {
310 OP newrep;
311 INT erg=OK;
312
313 CTTTO(CHARPARTITION,PARTITION,SKEWPARTITION, "charvalue(1)",rep);
314 CTTTO(CHARPARTITION,PARTITION,PERMUTATION, "charvalue(2)",part);
315
316 if (S_O_K(rep) == SKEWPARTITION) /* AK 170392 */
317 {
318 erg += error("charvalue:rep == SKEWPARTITION not yet implemented");
319 goto endr_ende;
320 }
321
322 if (S_O_K(part) == PERMUTATION)
323 {
324 OP newpart;
325 newpart = CALLOCOBJECT();
326 erg += zykeltyp(part,newpart);
327 erg += charvalue(rep,newpart,res,tafel);
328 FREEALL(newpart);
329 goto endr_ende;
330 }
331 if (tafel != NULL)
332 {
333 INT i = indexofpart(rep),
334 j = indexofpart(part);
335 CTO(MATRIX,"charvalue(4)",tafel);
336 erg += copy(S_M_IJ(tafel,i,j),res);
337 goto endr_ende;
338 }
339
340 if (S_PA_II(part,S_PA_LI(part)-1L) == 1L)
341 /* es wird die dimension berechnet */
342 {
343 erg += dimension_partition(rep,res);
344 goto endr_ende;
345 };
346
347
348 if (rep == part)
349 {
350 newrep = callocobject();
351 erg += copy(rep,newrep);
352 erg += charvalue(newrep,part,res,NULL);
353 erg += freeall(newrep);
354 return erg;
355 }
356
357 FREESELF(res);
358
359 if (S_O_K(rep) == PARTITION)
360 erg += c_PARTITION_AUGPART(rep);
361 else if (S_O_K(rep) == CHARPARTITION)
362 erg += c_CHARPARTITION_CHARAUGPART(rep);
363
364 if (S_O_K(rep) == AUG_PART)
365 {
366 sef = stripexistp;
367 asf = addstrip;
368 rsf = removestrip;
369 }
370 if (S_O_K(rep) == CHAR_AUG_PART)
371 {
372 sef = stripexistp_char;
373 asf = addstrip_char;
374 rsf = removestrip_char;
375 }
376
377 M_I_I((INT)0,res);
378 erg += calculate(1L,rep,part,res);
379
380 if (S_O_K(rep) == AUG_PART)
381 erg += c_AUGPART_PARTITION(rep);
382 else if (S_O_K(rep) == CHAR_AUG_PART)
383 erg += c_CHARAUGPART_CHARPARTITION(rep);
384 ENDR("charvalue");
385 }
386
387
388
chartafel_partvector(a,erg,pv)389 INT chartafel_partvector(a,erg,pv) OP a; OP erg,pv;
390 /* AK 260690 V1.1 */ /* AK 200891 V1.3 */
391 {
392 return chartafel(a,erg);
393 }
394
395
396 #ifdef MATRIXTRUE
397
chartafel(a,b)398 INT chartafel(a,b) OP a,b;
399 /* computes the table of irreducible characters of the symmetric group
400 of degree a */
401 /* AK V2.0 300998 */ /* AK V3.0 280705 */
402 {
403 INT erg=OK;
404 CTO(INTEGER,"chartafel(1)",a);
405 SYMCHECK(S_I_I(a)<0,"chartafel: input < 0");
406 CE2(a,b,chartafel);
407 if (S_I_I(a) <= (INT) 1)
408 {
409 erg += m_ilih_m((INT)1,(INT)1,b);
410 M_I_I(1,S_M_IJ(b,0,0));
411 goto ende;
412 }
413 C1R(a,"char_tafel",b); /* AK 171297 */
414
415 if (S_I_I(a) <= 16)
416 erg += chartafel_nonbit(a,b);
417 else
418 erg += chartafel_symfunc(a,b);
419
420 S1R(a,"char_tafel",b);
421 ende:
422 CTO(MATRIX,"chartafel(e2)",b);
423 ENDR("chartafel");
424 }
425
newindexofpart(a,b)426 static INT newindexofpart(a,b) OP a,b;
427 /* AK 030102 */
428 {
429 INT h;
430 if (S_PA_HASH(a) == -1) C_PA_HASH(a,hash_partition(a));
431 h = S_PA_HASH(a) % S_V_LI(b);
432 if (h < 0) h += S_V_LI(b);
433 return (S_V_II(b,h));
434 }
435
newchartafel(a,b)436 static INT newchartafel(a,b) OP a,b;
437 /* AK 030102 */
438 {
439 INT erg = OK,i,j;
440 INT f = 2;
441 OP c,h1,h2;
442
443 CTO(INTEGER,"chartafel(1)",a);
444 c = CALLOCOBJECT();
445 h2 = CALLOCOBJECT();
446 erg += makevectorofpart(a,c);
447 again:
448 init_size_hashtable(h2,S_V_LI(c)*f);
449 C_O_K(h2,INTEGERVECTOR);
450 for (i=0;i<S_V_LI(h2);i++) M_I_I(-1,S_V_I(h2,i));
451 for (i=0;i<S_V_LI(c);i++)
452 {
453 INT h;
454 C_PA_HASH(S_V_I(c,i),hash(S_V_I(c,i)));
455 h = S_PA_HASH(S_V_I(c,i)) % S_V_LI(h2);
456 if (h <0) h += S_V_LI(h2);
457
458 if (S_V_II(h2, h) != -1) /* coll */ { f++; goto again; }
459 M_I_I(i, S_V_I(h2,h));
460 }
461
462
463 erg += m_ilih_nm(S_V_LI(c),S_V_LI(c),b);
464 NEW_HASHTABLE(h1);
465 for (i=0;i<S_V_LI(c);i++)
466 {
467 OP z;
468 t_POWSYM_SCHUR(S_V_I(c,i),h1);
469 FORALL(z,h1, {
470 j = newindexofpart(S_MO_S(z),h2);
471 CLEVER_COPY(S_MO_K(z),S_M_IJ(b,j,i));
472 FREESELF(S_MO_K(z));
473 M_I_I(0,S_MO_K(z));
474 });
475 }
476 FREEALL3(c,h1,h2);
477 ENDR("chartafel");
478 }
479
480
chartafel_symfunc(a,b)481 INT chartafel_symfunc(a,b) OP a,b;
482 {
483 INT erg = OK;
484 CTO(INTEGER,"chartafel_symfunc",a);
485 SYMCHECK(S_I_I(a)<0,"chartafel_symfunc: input < 0");
486 if (S_I_I(a) <= 1)
487 {
488 erg += m_ilih_m((INT)1,(INT)1,b);
489 M_I_I(1,S_M_IJ(b,0,0));
490 goto ende;
491 }
492 newchartafel(a,b);
493 ende:
494 ENDR("chartafel_symfunc");
495 }
496
chartafel_bit(a,res)497 INT chartafel_bit(a,res) OP a; OP res;
498 /* AK 161294 */
499 /* a and res may be equal */
500 {
501 OP conjpart,vec,bitvec;
502 INT dim; /* 231187 AK dimension der matrix */
503 INT i,j; INT index;
504 INT erg = OK;
505 CTO(INTEGER,"chartafel_bit",a);
506 SYMCHECK(S_I_I(a)<0,"chartafel_bit: input < 0");
507 if (S_I_I(a) <= 1)
508 {
509 erg += m_ilih_m((INT)1,(INT)1,res);
510 M_I_I(1,S_M_IJ(res,0,0));
511 goto endr_ende;
512 }
513
514 conjpart = callocobject(); /* AK 290888 */
515 vec = callocobject();
516 bitvec = callocobject();
517
518 erg += makevectorofpart(a,vec);
519 dim = S_V_LI(vec);
520 erg += m_il_v(dim,bitvec);
521 for (i=0L;i<dim;i++)
522 t_VECTOR_BIT(S_V_I(vec,i),S_V_I(bitvec,i));
523
524
525 erg += m_ilih_m(dim,dim,res);
526
527 i = dim-1L; j=(INT)0;
528 do {
529 erg += charvalue_bit(S_V_I(bitvec,i),S_V_I(vec,j),
530 S_M_IJ(res,S_M_HI(res)-1L,j),NULL);
531 j++;
532 }
533 while( j < dim);
534 /* das war der alternierende Character */
535
536
537 for (j=(INT)0;j<S_M_LI(res);j++)
538 M_I_I(1L,S_M_IJ(res,(INT)0,j));
539 /* das war der eins - Character */
540
541 i=(INT)0;
542 do {
543 if (EMPTYP(S_M_IJ(res,i,(INT)0)))
544 /* d.h. zeile noch nicht berechnet */
545 {
546 j=(INT)0;
547 do {
548 if ( ( S_PA_LI(S_V_I(vec,i)) /* vgl JK Cor 2.4.9 */
549 -1L
550 +S_PA_II(S_V_I(vec,i),S_PA_LI(S_V_I(vec,i))-1L)
551 )
552 >=
553 ( S_PA_II(S_V_I(vec,j),S_PA_LI(S_V_I(vec,j))-1L) )
554 )
555 erg += charvalue_bit(S_V_I(bitvec,i),S_V_I(vec,j),
556 S_M_IJ(res,i,j),NULL);
557 else
558 M_I_I((INT)0,S_M_IJ(res,i,j));
559 j++;
560 }
561 while( j < dim);
562 /* AK 290888 berechnung des assozierten characters */
563 conjugate(S_V_I(vec,i),conjpart);
564
565 for (index = i+1L;index<dim;index ++)
566 if (EQ(conjpart,S_V_I(vec,index)))
567 break;
568
569 if (index < dim)
570 for (j=(INT)0;j<S_M_LI(res);j++)
571 erg += mult( S_M_IJ(res,i,j),
572 S_M_IJ(res,S_M_HI(res)-1L,j),
573 S_M_IJ(res,index,j));
574 /* character *
575 alternierender character */
576 };
577 i++;
578 }
579 while( i < dim);
580
581 erg += freeall(conjpart);
582 erg += freeall(vec);
583 erg += freeall(bitvec);
584 ENDR("chartafel_bit");
585 }
586
chartafel_nonbit(a,res)587 INT chartafel_nonbit(a,res) OP a; OP res;
588 /* AK 221187 ergebnis ist vom typ matrix*/
589 /* AK 240387 */ /* berechnet chartafel der s-a aus */
590 /* AK 170789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */
591 /* AK 121297 a == res is possible
592 a is of type INTEGER
593 if a = 0 the result is the 1 1x1 matrix */
594 {
595 OP conjpart;
596 OP vec;
597 INT dim; /* 231187 AK dimension der matrix */
598 INT i,j;
599 INT index;
600
601 INT erg = OK;
602 CTO(INTEGER,"chartafel_nonbit",a);
603 SYMCHECK(S_I_I(a)<0,"chartafel_nonbit: input < 0");
604 if (S_I_I(a) <= 1)
605 {
606 m_ilih_m((INT)1,(INT)1,res);
607 M_I_I(1,S_M_IJ(res,0,0));
608 goto ende;
609 }
610
611 conjpart = callocobject(); /* AK 290888 */
612 vec = callocobject();
613
614 erg += makevectorofpart(a,vec);
615 dim = S_V_LI(vec);
616 erg += m_ilih_m(dim,dim,res); /* AK 231187 res ist damit initialisiert */
617
618 i = dim-1L; j=(INT)0;
619 do {
620 erg += charvalue(S_V_I(vec,i),S_V_I(vec,j),
621 S_M_IJ(res,S_M_HI(res)-1L,j),NULL);
622 j++; }
623 while( j < dim);
624 /* das war der alternierende Character */
625
626 for (j=(INT)0;j<S_M_LI(res);j++)
627 M_I_I(1L,S_M_IJ(res,(INT)0,j));
628 /* das war der eins - Character */
629
630 i=(INT)0;
631 do {
632 if (EMPTYP(S_M_IJ(res,i,(INT)0)))
633 /* d.h. zeile noch nicht berechnet */
634 {
635 j=(INT)0;
636 do {
637 if ( ( S_PA_LI(S_V_I(vec,i)) /* vgl JK Cor 2.4.9 */
638 -1L
639 +S_PA_II(S_V_I(vec,i),S_PA_LI(S_V_I(vec,i))-1L)
640 )
641 >=
642 ( S_PA_II(S_V_I(vec,j),S_PA_LI(S_V_I(vec,j))-1L) )
643 )
644 erg += charvalue(S_V_I(vec,i),S_V_I(vec,j),
645 S_M_IJ(res,i,j),NULL);
646 else
647 M_I_I((INT)0,S_M_IJ(res,i,j));
648 j++;
649 }
650 while( j < dim);
651 /* AK 290888 berechnung des assozierten characters */
652 conjugate(S_V_I(vec,i),conjpart);
653
654 for (index = i+1L;index<dim;index ++)
655 if (EQ(conjpart,S_V_I(vec,index)))
656 break;
657
658 if (index < dim)
659 for (j=(INT)0;j<S_M_LI(res);j++)
660 erg += mult( S_M_IJ(res,i,j),
661 S_M_IJ(res,S_M_HI(res)-1L,j),
662 S_M_IJ(res,index,j));
663 /* character *
664 alternierender character */
665 };
666 i++;
667 }
668 while( i < dim);
669
670 erg += freeall(conjpart);
671 erg += freeall(vec);
672 ende:
673 ENDR("chartafel_nonbit");
674 }
675 #endif /* CHARTRUE */
676 #endif /* MATRIXTRUE */
677
678
c_i_n(mu,n,erg,tafel)679 INT c_i_n(mu,n,erg,tafel) OP mu,n,erg,tafel;
680 /* berechnet aus n INTEGER
681 mu PARTITION den wert c_mu,n =
682 Mittelwert der summe ueber die Werte des mu-ten
683 irreduziblen Charakters von den n-ten Potenzen der
684 x aus S_m, m= gewicht von mu */
685 /* AK 190988 */
686 /* AK wenn tafel != NULL ist dies ein zeiger auf die
687 zugehoerige charactertafel */
688 /* AK 200789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
689 {
690 #ifdef CHARTRUE
691 OP m = callocobject(),ord=callocobject();
692 OP laufpart=callocobject(),exp=callocobject();
693 OP zw=callocobject(),zwerg=callocobject(),hocherg=callocobject();
694 weight(mu,m);
695 first_partition(m,laufpart); /* vom typ VECTOR */
696 freeself(erg);M_I_I((INT)0,erg); /* vorbesetzen mit 0 */
697
698 do {
699 ordcon(laufpart,ord);
700 t_VECTOR_EXPONENT(laufpart,exp);
701 zykeltyp_hoch_n(exp,n,hocherg);
702 t_EXPONENT_VECTOR(hocherg,zw);
703 charvalue(mu,zw,zwerg,tafel);
704 mult(zwerg,ord,zwerg);
705 add(erg,zwerg,erg);
706 }
707 while(next(laufpart,laufpart));
708
709 fakul(m,zwerg);
710 div(erg,zwerg,erg); /* noch durch gruppenordnung dividieren */
711
712 freeall(m);freeall(zwerg);freeall(laufpart);freeall(ord);freeall(exp);
713 freeall(hocherg);freeall(zw);
714 return(OK);
715 #else
716 error("c_i_n:SYMCHAR not available");return(ERROR);
717 #endif /* CHARTRUE */
718 }
719
720
symchar_hoch_n(a,n,erg)721 INT symchar_hoch_n(a,n,erg) OP a,n,erg;
722 /* der SYMCHAR a wird verallgemeinert zu a^n
723 d.h. die klasse alpha erhaelt den wert auf alpha hoch n */
724 /* AK 200988 */
725 /* AK 200789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
726 {
727 #ifdef CHARTRUE
728 INT i,index;
729 OP zw=callocobject(),zw2=callocobject();
730 copy(a,erg);
731 for (i=(INT)0;i<S_SC_WLI(erg);i++)
732 {
733 t_VECTOR_EXPONENT(S_SC_PI(erg,i),zw);
734 zykeltyp_hoch_n(zw,n,zw2);
735 freeself(zw);
736 t_EXPONENT_VECTOR(zw2,zw);
737 index=indexofpart(zw);
738 copy(S_SC_WI(a,index),S_SC_WI(erg,i));
739 freeself(zw); freeself(zw2);
740 }
741 return(OK);
742 #else
743 error("symchar_hoch_n:SYMCHAR not available");return(ERROR);
744 #endif /* CHARTRUE */
745 }
746
c_i_n_an(mu,n,erg,tafel)747 INT c_i_n_an(mu,n,erg,tafel) OP mu,n,erg,tafel;
748 /* berechnet aus n INTEGER
749 mu PARTITION den wert c_mu,n =
750 Mittelwert der summe ueber die Werte des mu-ten
751 irreduziblen Charakters von den n-ten Potenzen der
752 x aus S_m, m= gewicht von mu */
753 /* AK 190988 */
754 /* AK wenn tafel != NULL ist dies ein zeiger auf die
755 zugehoerige charactertafel */
756 /* AK 200789 V1.0 */ /* AK 260690 V1.1 */ /* AK 200891 V1.3 */
757 {
758 #ifdef CHARTRUE
759 OP m = callocobject(),ord=callocobject();
760 OP laufpart=callocobject(),exp=callocobject();
761 OP zw=callocobject(),zwerg=callocobject(),hocherg=callocobject();
762 weight(mu,m);
763 first_partition(m,laufpart); /* vom typ VECTOR */
764 freeself(erg);M_I_I((INT)0,erg); /* vorbesetzen mit 0 */
765
766 do {
767 if ((s_i_i(m) - s_pa_li(laufpart))%2 == 0) {
768 ordcon(laufpart,ord);
769 t_VECTOR_EXPONENT(laufpart,exp);
770 zykeltyp_hoch_n(exp,n,hocherg);
771 t_EXPONENT_VECTOR(hocherg,zw);
772 charvalue(mu,zw,zwerg,tafel);
773 mult(zwerg,ord,zwerg);
774 add(erg,zwerg,erg);}
775 }
776 while(next(laufpart,laufpart));
777
778 fakul(m,zwerg);
779 div(erg,zwerg,erg); /* noch durch gruppenordnung dividieren */
780 freeself(zw);
781 M_I_I(2L,zw);mult(erg,zw,erg);
782
783 freeall(m);freeall(zwerg);freeall(laufpart);freeall(ord);freeall(exp);
784 freeall(hocherg);freeall(zw); return(OK);
785 #else
786 error("c_i_n_an:SYMCHAR not available");return(ERROR);
787 #endif /* CHARTRUE */
788 }
789
790
791 #ifdef CHARTRUE
m_part_centralsc(part,c)792 INT m_part_centralsc(part,c) OP part,c;
793 /* AK 010888 curtis/reiner p.235 */
794 /* AK 140789 V1.0 */ /* AK 100191 V1.1 */ /* AK 220791 V1.3 */
795 /* AK 010498 V2.0 */
796 {
797 INT i,erg=OK;
798 OP zw,zw2;
799 CTO(PARTITION,"m_part_centralsc(1)",part);
800 zw = callocobject();
801 zw2 = callocobject();
802 erg += m_part_sc(part,c);
803 erg += dimension(part,zw); /* fehler vorher ordcen */
804 for (i=(INT)0; i<S_SC_PLI(c);i++)
805 {
806 erg += ordcon(S_SC_PI(c,i),zw2);
807 erg += mult_apply(zw2,S_SC_WI(c,i));
808 }
809 erg += div(c,zw,c);
810 erg += freeall(zw);
811 erg += freeall(zw2);
812 ENDR("m_part_centralsc");
813 }
814
m_part_sc(part,res)815 INT m_part_sc(part,res) OP part,res;
816 /* AK 200891 V1.3 */
817 {
818 INT erg = OK;
819 CTO(PARTITION,"m_part_sc(1)",part);
820 erg += m_part_sc_tafel(part,res,NULL);
821 ENDR("m_part_sc");
822 }
823
824
m_part_sc_tafel(part,res,ct)825 INT m_part_sc_tafel(part,res,ct) OP part,res;OP ct;
826 /* den irreduziblen character zur partition part */
827 /* AK 140789 V1.0 */
828 /* AK 210690 V1.1 */ /* ct == NULL oder charactertafel */
829 /* AK 200891 V1.3 */
830 /* AK 060498 V2.0 */
831 {
832 OP dim;
833 INT i=(INT)0,j;
834 INT erg = OK;
835 CTO(PARTITION,"m_part_sc_tafel",part);
836
837 dim = callocobject();
838 erg += weight(part,dim);
839 erg += b_d_sc(dim,res);
840 if (S_I_I(dim) < 2) /* AK 060498 */
841 {
842 M_I_I(1,S_SC_WI(res,0));
843 goto endr_ende;
844 }
845 if (ct == NULL) {
846 for (i=(INT)0;i<S_SC_PLI(res);i++)
847 erg += charvalue(part,S_SC_PI(res,i),
848 S_SC_WI(res,i),NULL);
849 }
850 else {
851 j = indexofpart(part);
852 for (i=(INT)0;i<S_SC_PLI(res);i++)
853 erg += copy(S_M_IJ(ct,j,i),S_SC_WI(res,i));
854 }
855 ENDR("m_part_sc_tafel");
856 }
857
858
ntopaar_symchar(a,b)859 INT ntopaar_symchar(a,b) OP a,b; /* sind symchar */
860 /* 280488 ohne representanten */
861 /* diese routine berechnet den induzierten charcter
862 aus s_n in s_(n ueber 2) */
863 /* AK 170789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
864 {
865 OP dimb;
866 OP perm;
867 OP grosseperm;
868 OP faktor;
869 OP typ;
870 OP ordnung;
871 OP ordnung2;
872 OP help;
873
874 INT j,index, erg = OK;
875
876 CTO(SYMCHAR,"ntopaar_symchar(1)",a);
877
878 perm = callocobject();
879 grosseperm = callocobject();
880 faktor = callocobject();
881 typ = callocobject();
882 ordnung = callocobject();
883 ordnung2 = callocobject();
884 help = callocobject();
885
886 dimb=callocobject();
887 M_I_I(2L,dimb);
888 erg += binom(S_SC_D(a),dimb,dimb);
889 /* dimb ist dimension von b */
890 erg += m_d_sc(dimb,b);
891 /* b ist nun initialisiert */
892
893 erg += fakul(S_SC_D(b),help);
894 erg += fakul(S_SC_D(a),faktor);
895 erg += div(help,faktor,faktor); /* der konstante faktor */
896
897 for (j=(INT)0;j<S_SC_PLI(a);j++)
898 /* dies ist eine schleife ueber alle
899 konjugiertenklassen der unter-gruppe
900 */
901 {
902 if (not nullp(S_SC_WI(a,j)))
903 {
904 erg += m_part_perm(S_SC_PI(a,j),perm);
905 erg += m_perm_paareperm(perm,grosseperm);
906 erg += zykeltyp(grosseperm,typ);
907 /* typ ist der zykeltyp der induzierten
908 permutation */
909 index=indexofpart(typ);
910 erg += ordcon(S_SC_PI(a,j),ordnung);
911 erg += ordcon(typ,ordnung2);
912 erg += freeself(help);
913
914 erg += mult(S_SC_WI(a,j) , ordnung,help);
915 erg += mult(help,faktor,help);
916 erg += div(help, ordnung2,help);
917 erg += add(help,S_SC_WI(b,index),S_SC_WI(b,index));
918 }
919 };
920
921 erg += freeall(dimb);
922 erg += freeall(help);
923 erg += freeall(ordnung);
924 erg += freeall(perm);
925 erg += freeall(grosseperm);
926 erg += freeall(faktor);
927 erg += freeall(typ);
928 erg += freeall(ordnung2);
929 ENDR("ntopaar_symchar");
930 }
931
932
933
reduce_symchar(a,b)934 INT reduce_symchar(a,b) OP a,b;
935 /* AK 200891 V1.3 */
936 {
937 INT erg = OK;
938 CE2(a,b,reduce_symchar);
939 erg += reduce_symchar_tafel(a,b,NULL);
940 ENDR("reduce_symchar");
941 }
942
943 #ifdef SCHURTRUE
reduce_symchar_tafel(a,b,ct)944 INT reduce_symchar_tafel(a,b,ct) OP a,b;OP ct;
945 /* a ist symchar , b ist wird schurfunktion */
946 /* AK 170789 V1.0 */
947 /* AK 030190 V1.1 */ /* AK 210690 ct==NULL oder charactertafel */
948 /* AK 200891 V1.3 */
949 /* AK 290998 V2.0 */
950 /* a and b may be equal */
951 {
952 INT i;
953 INT erg = OK;
954 OP zw1,res;
955
956 CTO(SYMCHAR,"reduce_symchar_tafel",a);
957 if (a == b) /* AK 290998 */
958 {
959 zw1 = callocobject();
960 erg += reduce_symchar_tafel(a,zw1,ct);
961 erg += freeall(zw1);
962 goto endr_ende;
963 }
964 erg += init(SCHUR,b);
965 zw1=callocobject();
966 res=callocobject();
967
968 for (i=(INT)0;i<S_SC_PLI(a);i++)
969 {
970 erg += m_part_sc_tafel(S_SC_PI(a,i),zw1,ct);
971 erg += scalarproduct_symchar(zw1,a,res);
972 if (not nullp(res))
973 {
974 OP zw = callocobject();
975 erg += b_skn_s(callocobject(),callocobject(),NULL,zw);
976 erg += copy(S_SC_PI(a,i),S_S_S(zw));
977 erg += copy(res,S_S_K(zw));
978 insert(zw,b,NULL,comp_monomvector_monomvector);
979 }
980 else {
981 }
982 };
983
984 erg += freeall(res);
985 erg += freeall(zw1);
986 ENDR("reduce_symchar_tafel");
987 }
988 #endif /* SCHURTRUE */
989
990
scalarproduct_symchar(a,b,c)991 INT scalarproduct_symchar(a,b,c) OP a,b,c;
992 /* skalarproduct von a und b nach c */
993 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
994 /* a b and c may be equal */
995 /* AK 120898 V2.0 */
996 {
997 INT i;
998 OP zw, zw2, invord;
999 INT erg = OK;
1000 CTO(SYMCHAR,"scalarproduct_symchar",a);
1001 CTO(SYMCHAR,"scalarproduct_symchar",b);
1002
1003
1004 if (neq(S_SC_D(a), S_SC_D(b)))
1005 {
1006 erg += error("scalarproduct_symchar: different degrees");
1007 goto endr_ende;
1008 }
1009
1010 zw = callocobject();
1011 zw2 = callocobject();
1012 invord = callocobject();
1013 M_I_I(0,zw);
1014
1015 for (i=(INT)0;i<S_SC_PLI(a);i++)
1016 {
1017 erg += mult(S_SC_WI(a,i),S_SC_WI(b,i),zw2);
1018 erg += inversordcen(S_SC_PI(a,i),invord);
1019 erg += mult_apply(invord,zw2);
1020 erg += add_apply(zw2,zw);
1021 };
1022
1023 erg += swap(zw,c);
1024 erg += freeall(zw);
1025 erg += freeall(invord);
1026 erg += freeall(zw2);
1027 ENDR("scalarproduct_symchar");
1028 }
1029
1030
1031
char_matrix_scalar_product(a,i,b,j,partvec,erg,convec)1032 INT char_matrix_scalar_product(a,i,b,j,partvec,erg,convec) OP a,b,erg,partvec;
1033 INT i,j; OP convec;
1034 /* AK Tue Jan 24 07:36:11 MEZ 1989 */
1035 /* berechnet skalarproduct bei charactertafeln
1036 dabei wird aus a zeile i und aus b zeile j verwendet
1037 partvec ist vectorofpartition zu den tafeln
1038 AK 260189
1039 convec ist wenn != NULL vector konjugiertenklassen ordnung */
1040 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1041 {
1042 INT k;
1043 OP zw = callocobject(),zw2 = callocobject(), fak, hcv;
1044
1045
1046 if (neq (s_m_l(a),s_m_l(b)))
1047 error("char_matrix_scalar_product:different length of matrix");
1048
1049 if (convec == NULL)
1050 {
1051 hcv = callocobject();
1052 m_il_v(S_V_LI(partvec),hcv);
1053 for (k=(INT)0;k<s_m_li(a);k++)
1054 ordcon(S_V_I(partvec,k),S_V_I(hcv,k));
1055 }
1056 else hcv = convec;
1057
1058
1059 freeself(erg);
1060 M_I_I((INT)0,erg);
1061
1062 for (k=(INT)0;k<S_M_LI(a);k++)
1063 {
1064 mult(S_M_IJ(a,i,k),S_M_IJ(b,j,k),zw2);
1065 mult(S_V_I(hcv,k),zw2,zw);
1066 add(zw,erg,erg);
1067 freeself(zw);
1068 };
1069
1070 fak=callocobject();
1071 fakul(s_pa_i(S_V_I(partvec,(INT)0),(INT)0),fak);
1072 div(erg,fak,erg);
1073
1074
1075 freeall(zw);
1076 freeall(fak);
1077 freeall(zw2);
1078 if (convec == NULL) freeall(hcv);
1079 return(OK);
1080 }
1081
1082
1083
mult_apply_symchar(a,b)1084 INT mult_apply_symchar(a,b) OP a,b;
1085 /* a is SYMCHAR */
1086 /* AK 050391 V1.2 */ /* AK 160891 V1.3 */
1087 /* AK 060498 V2.0 */
1088 {
1089 OP c;
1090 INT erg = OK;
1091 CTO(SYMCHAR,"mult_apply_symchar(1)",a);
1092 EOP("mult_apply_symchar(2)",b);
1093
1094 switch (S_O_K(b))
1095 {
1096 case SYMCHAR:
1097 erg += mult_apply(S_SC_W(a),S_SC_W(b));
1098 goto masende;
1099 default: /* AK 160891 */
1100 c = callocobject();
1101 *c = *b;
1102 erg += C_O_K(b,EMPTY);
1103 erg += mult(a,c,b);
1104 erg += freeall(c);
1105 break;
1106 }
1107 masende:
1108 ENDR("mult_apply_symchar");
1109 }
1110
1111
1112
mult_symchar_symchar(a,b,c)1113 INT mult_symchar_symchar(a,b,c) OP a,b,c;
1114 /* AK Wed Mar 8 10:32:46 MEZ 1989 */
1115 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1116 {
1117 INT erg = OK;
1118 erg += copy(b,c);
1119 erg += mult(S_SC_W(a),S_SC_W(b),S_SC_W(c));
1120 return erg;
1121 }
1122
1123
1124
comp_symchar(a,b)1125 INT comp_symchar(a,b) OP a,b;
1126 /* AK Thu Jan 3 14:53:38 MEZ 1991 */
1127 /* AK 050391 V1.2 */ /* AK 200891 V1.3 */
1128 {
1129 if (S_O_K(b) != SYMCHAR)
1130 {
1131 error("comp_symchar: wrong second kind");
1132 return ERROR;
1133 }
1134 if ( neq( S_SC_D(a), S_SC_D(b) ) )
1135 {
1136 debugprint(S_SC_D(a));
1137 debugprint(S_SC_D(b));
1138 error("comp_symchar: different degrees");
1139 return ERROR;
1140 }
1141 return
1142 comp( S_SC_W(a), S_SC_W(b) );
1143 }
1144
1145
mult_apply_scalar_symchar(a,b)1146 INT mult_apply_scalar_symchar(a,b) OP a,b;
1147 /* AK 060498 V2.0 */
1148 {
1149 INT erg = OK;
1150 CTO(SYMCHAR,"mult_apply_scalar_symchar(2)",b);
1151 erg += mult_apply_scalar_vector(a,S_SC_W(b));
1152 ENDR("mult_apply_scalar_symchar");
1153 }
1154
mult_scalar_symchar(a,b,c)1155 INT mult_scalar_symchar(a,b,c) OP a,b,c;
1156 /* AK 010888 */
1157 /* a skalar b symchar c wird symchar */
1158 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1159 /* AK 060498 V2.0 */
1160 {
1161 INT erg = OK;
1162 CTO(SYMCHAR,"mult_scalar_symchar",b);
1163 erg += copy(b,c);
1164 erg += mult(a,S_SC_W(b),S_SC_W(c));
1165 ENDR("mult_scalar_symchar");
1166 }
1167
1168
1169
copy_symchar(a,b)1170 INT copy_symchar(a,b) OP a,b;
1171 /* AK 110588 */
1172 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1173 {
1174 INT erg=OK;
1175 erg += b_wpd_sc(callocobject(),callocobject(),callocobject(),b);
1176 erg += copy(S_SC_D(a),S_SC_D(b));
1177 erg += copy(S_SC_P(a),S_SC_P(b));
1178 erg += copy(S_SC_W(a),S_SC_W(b));
1179 return erg;
1180 }
1181
1182
1183
reduce_inner_tensor_sc(a,b,c)1184 INT reduce_inner_tensor_sc(a,b,c) OP a,b,c;
1185 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1186 /* AK 070898 V2.0 */
1187 /* a,b,c, may be equal */
1188 {
1189 OP d,e,f;
1190 INT erg = OK;
1191 CTO(PARTITION,"reduce_inner_tensor_sc",a);
1192 CTO(PARTITION,"reduce_inner_tensor_sc",b);
1193 d = callocobject();
1194 e = callocobject();
1195 f = callocobject();
1196 erg += m_part_sc(a,d);
1197 erg += m_part_sc(b,e);
1198 erg += inner_tensor_sc(d,e,f);
1199 erg += reduce_symchar(f,c);
1200 erg += freeall(d);
1201 erg += freeall(e);
1202 erg += freeall(f);
1203 ENDR("reduce_inner_tensor_sc");
1204 }
1205
inner_tensor_sc(a,b,c)1206 INT inner_tensor_sc(a,b,c) OP a,b,c;
1207 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1208 {
1209 if (neq(S_SC_D(a),S_SC_D(b))) {
1210 error("inner_tensor_sc:different degrees");
1211 return(ERROR);
1212 };
1213
1214 copy(a,c);
1215 mult(S_SC_W(a),S_SC_W(b),S_SC_W(c));
1216 return(OK);
1217 }
1218
reduceninpaar(a,b)1219 INT reduceninpaar(a,b) OP a,b;
1220 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1221 {
1222 OP c;
1223 OP d;
1224 INT erg = OK;
1225 CTO(PARTITION,"reduceninpaar(1)",a);
1226 c = callocobject(); d = callocobject();
1227
1228 erg += m_part_sc(a,c);
1229 erg += ntopaar_symchar(c,d);
1230 erg += reduce_symchar(d,b);
1231 erg += freeall(c);
1232 erg += freeall(d);
1233 ENDR("reduceinpaar");
1234 }
1235
1236
makevectorofshuffle(max,len,vec)1237 INT makevectorofshuffle(max,len,vec) OP max,len,vec;
1238 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1239 {
1240 INT i;
1241 INT erg = OK;
1242
1243 erg += m_il_v(numberof_shufflepermutation(max,len),vec);
1244 erg += first_permutation(len,S_V_I(vec,(INT)0));
1245 for (i=1L;i<S_V_LI(vec);i++)
1246 next_shufflepermutation(max,S_V_I(vec,i-1),S_V_I(vec,i));
1247 return erg;
1248 }
1249
1250
add_apply_symchar(a,b)1251 INT add_apply_symchar(a,b) OP a,b;
1252 /* AK 250391 V1.2 */ /* AK 200891 V1.3 */
1253 {
1254 INT erg = OK;
1255 CTO(SYMCHAR,"add_apply_symchar",b);
1256 erg += add_apply(S_SC_W(a),S_SC_W(b));
1257 ENDR("add_apply_symchar");
1258 }
1259
1260
1261
add_symchar(a,b,c)1262 INT add_symchar(a,b,c) OP a,b,c;
1263 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1264 {
1265 INT erg = OK;
1266 CTO(SYMCHAR,"add_symchar",a);
1267 CTO(SYMCHAR,"add_symchar",b);
1268 if (S_SC_DI(a) != S_SC_DI(b))
1269 {
1270 erg += error("add_symchar: different weight");
1271 goto endr_ende;
1272 }
1273 erg += b_wpd_sc(callocobject(),callocobject(),callocobject(),c);
1274 erg += copy_integer(S_SC_D(a),S_SC_D(c));
1275 erg += copy_vector(S_SC_P(a),S_SC_P(c));
1276 erg += add_vector(S_SC_W(a),S_SC_W(b),S_SC_W(c));
1277 ENDR("add_symchar");
1278 }
1279
addinvers_apply_symchar(a)1280 INT addinvers_apply_symchar(a) OP a;
1281 /* AK 201289 V1.1 */ /* AK 200891 V1.3 */
1282 {
1283 return(addinvers_apply(S_SC_W(a)));
1284 }
1285
1286
addinvers_symchar(a,c)1287 INT addinvers_symchar(a,c) OP a,c;
1288 /* AK 140789 V1.0 */ /* AK 201289 V1.1 */ /* AK 250391 V1.2 */
1289 /* AK 200891 V1.3 */
1290 {
1291 INT erg = OK;
1292 CTO(SYMCHAR,"addinvers_symchar(1)",a);
1293 erg += b_wpd_sc(callocobject(),callocobject(),callocobject(),c);
1294 COPY(S_SC_D(a),S_SC_D(c));
1295 COPY(S_SC_P(a),S_SC_P(c));
1296 erg += addinvers(S_SC_W(a),S_SC_W(c));
1297 ENDR("addinvers_symchar");
1298 }
1299
1300
freeself_symchar(a)1301 INT freeself_symchar(a) OP a;
1302 /* AK 140789 V1.0 */ /* AK 060290 V1.1 */ /* AK 250391 V1.2 */
1303 /* AK 200891 V1.3 */
1304 {
1305 OBJECTSELF d;
1306 INT erg = OK;
1307 CTO(SYMCHAR,"freeself_symchar(1)",a);
1308 erg += freeall(S_SC_W(a));
1309 erg += freeall(S_SC_P(a));
1310 erg += freeall(S_SC_D(a));
1311 d = S_O_S(a);
1312 SYM_free(d.ob_symchar);
1313 C_O_K(a,EMPTY);
1314 ENDR("freeself_symchar");
1315 }
1316
objectread_symchar(fp,a)1317 INT objectread_symchar(fp,a) FILE *fp; OP a;
1318 /* AK 260291 V1.2 */ /* AK 200891 V1.3 */
1319 {
1320 INT erg =OK;
1321 erg += b_wpd_sc(callocobject(),callocobject(),callocobject(),a);
1322 erg += objectread(fp,S_SC_D(a));
1323 erg += objectread(fp,S_SC_P(a));
1324 erg += objectread(fp,S_SC_W(a));
1325 return erg;
1326 }
1327
objectwrite_symchar(fp,a)1328 INT objectwrite_symchar(fp,a) FILE *fp; OP a;
1329 /* AK 260291 V1.2 */ /* AK 200891 V1.3 */
1330 {
1331 INT erg=OK;
1332 fprintf(fp, "%" PRIINT "\n" ,(INT)SYMCHAR);
1333 erg += objectwrite(fp,S_SC_D(a));
1334 erg += objectwrite(fp,S_SC_P(a));
1335 erg += objectwrite(fp,S_SC_W(a));
1336 return erg;
1337 }
1338
nullp_symchar(a)1339 INT nullp_symchar(a) OP a;
1340 /* AK 010692 */
1341 {
1342 return nullp(S_SC_W(a));
1343 }
1344
tex_symchar(a)1345 INT tex_symchar(a) OP a;
1346 /* AK 150692 */
1347 {
1348 return tex(S_SC_W(a));
1349 }
1350
einsp_symchar(a)1351 INT einsp_symchar(a) OP a;
1352 /* AK 010692 */
1353 {
1354 return einsp(S_SC_W(a));
1355 }
1356
fprint_symchar(fp,a)1357 INT fprint_symchar(fp,a) FILE *fp; OP a;
1358 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1359 {
1360 INT i;
1361 for (i=(INT)0; i<S_SC_WLI(a);i++)
1362 {
1363 fprint(fp,S_SC_PI(a,i)); fprintf(fp,":");
1364 fprint(fp,S_SC_WI(a,i)); fprintf(fp,",");
1365 if (fp == stdout)
1366 if (zeilenposition>(INT)70)
1367 { zeilenposition = (INT)0; fprintf(fp,"\n"); }
1368 else zeilenposition += 2L;
1369 }
1370 return(OK);
1371 }
1372
scan_symchar(a)1373 INT scan_symchar(a) OP a;
1374 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1375 {
1376 OP dim;
1377 INT i;
1378 extern INT zeilenposition;
1379 INT erg = OK;
1380 CTO(EMPTY,"scan_symchar(1)",a);
1381 erg += printeingabe(" enter the degree of the symmetric group");
1382 dim = callocobject();
1383 erg += scan(INTEGER,dim);
1384 erg += b_d_sc(dim,a);
1385
1386 erg += printeingabe(" enter the character-value on the given class");
1387 for (i=(INT)0;i<S_SC_PLI(a);i++)
1388 {
1389 erg += print(S_SC_PI(a,i));
1390 printf(" ");
1391 zeilenposition++;
1392 erg += scan(INTEGER,S_SC_WI(a,i));
1393 };
1394 ENDR("scan_symchar");
1395 }
1396
m_d_sc(dim,ergebnis)1397 INT m_d_sc(dim,ergebnis) OP dim,ergebnis;
1398 /* AK 040391 V1.2 */ /* AK 200891 V1.3 */
1399 /* dim, ergebnis may be equal */
1400 {
1401 OP c;
1402 INT erg = OK;
1403 CTO(INTEGER,"m_d_sc(1)",dim);
1404 c = callocobject();
1405 M_I_I(S_I_I(dim),c);
1406 erg += b_d_sc(c,ergebnis);
1407 ENDR("m_d_sc");
1408 }
1409
b_d_sc(dim,ergebnis)1410 INT b_d_sc(dim,ergebnis) OP dim,ergebnis;
1411 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1412 {
1413 INT erg = OK; /* AK 301091 */
1414 CTO(INTEGER,"b_d_sc(1)",dim);
1415 SYMCHECK (dim == ergebnis, "b_d_sc:input and output are equal");
1416
1417 erg += b_wpd_sc(callocobject(),callocobject(),dim,ergebnis);
1418 erg += makevectorofpart(dim,S_SC_P(ergebnis));
1419 erg += m_il_nv(S_SC_PLI(ergebnis),S_SC_W(ergebnis));
1420 ENDR("b_d_sc");
1421 }
1422
1423
callocsymchar()1424 static struct symchar * callocsymchar()
1425 /* 110488 AK erste prozedur beim einfuehren eines neuen datentyps */
1426 /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1427 {
1428 struct symchar *erg
1429 = (struct symchar *) SYM_calloc((int)1,sizeof(struct symchar));
1430 if (erg == NULL)
1431 no_memory();
1432 return(erg);
1433 }
1434
m_wpd_sc(wert,parlist,dim,ergebnis)1435 INT m_wpd_sc(wert,parlist,dim,ergebnis) OP wert,parlist,dim,ergebnis;
1436 /* AK Fri Jan 4 09:25:43 MEZ 1991 */
1437 /* AK 200891 V1.3 */
1438 {
1439 b_wpd_sc(callocobject(),callocobject(),callocobject(),ergebnis);
1440 copy(wert, S_SC_W(ergebnis));
1441 copy(parlist, S_SC_P(ergebnis));
1442 copy(dim, S_SC_D(ergebnis));
1443 return OK;
1444 }
1445
b_wpd_sc(wert,parlist,dim,ergebnis)1446 INT b_wpd_sc(wert,parlist,dim,ergebnis) OP wert,parlist,dim,ergebnis;
1447 /* die zweite prozedur bei neuen typen */
1448 /* AK 110488 erzeugt aus der werteliste den symcharacter */
1449 /* AK 140789 V1.0 */ /* AK 030190 V1.1 */ /* AK 200891 V1.3 */
1450 {
1451 OBJECTSELF d;
1452
1453 if (ergebnis==NULL)/* kein speicher reserviert fuer das ergebnis */
1454 {/*020488*/error("ergebnis == NULL in m_w_sc");return(ERROR);};
1455
1456 d.ob_symchar = callocsymchar(); /* AK 161189 */
1457 b_ks_o(SYMCHAR, d, ergebnis);
1458
1459 c_sc_w(ergebnis,wert);
1460 c_sc_p(ergebnis,parlist);
1461 c_sc_d(ergebnis,dim);
1462 return(OK);
1463 }
1464
s_sc_w(a)1465 OP s_sc_w(a) OP a;
1466 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1467 {
1468 OBJECTSELF c;
1469 c = s_o_s(a);
1470
1471 return(c.ob_symchar->sy_werte);
1472 }
1473
s_sc_wi(a,i)1474 OP s_sc_wi(a,i) OP a;INT i;
1475 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1476 {
1477 return(s_v_i(s_sc_w(a),i));
1478 }
1479
s_sc_wii(a,i)1480 INT s_sc_wii(a,i) OP a;INT i;
1481 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1482 {
1483 return(s_v_ii(s_sc_w(a),i));
1484 }
1485
s_sc_wli(a)1486 INT s_sc_wli(a) OP a;
1487 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1488 {
1489 return(s_v_li(s_sc_w(a)));
1490 }
1491
s_sc_p(a)1492 OP s_sc_p(a) OP a;
1493 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1494 {
1495 OBJECTSELF c;
1496 c = s_o_s(a);
1497
1498 return(c.ob_symchar->sy_parlist);
1499 }
1500
s_sc_pi(a,i)1501 OP s_sc_pi(a,i) OP a;INT i;
1502 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1503 {
1504 return(s_v_i(s_sc_p(a),i));
1505 }
1506
s_sc_pli(a)1507 INT s_sc_pli(a) OP a;
1508 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1509 {
1510 return(s_v_li(s_sc_p(a)));
1511 }
1512
s_sc_di(a)1513 INT s_sc_di(a) OP a;
1514 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1515 {
1516 return(s_i_i(s_sc_d(a)));
1517 }
s_sc_d(a)1518 OP s_sc_d(a) OP a;
1519 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1520 {
1521 OBJECTSELF c;
1522 c = s_o_s(a);
1523
1524 return(c.ob_symchar->sy_dimension);
1525 }
1526
c_sc_d(a,b)1527 INT c_sc_d(a,b) OP a,b;
1528 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1529 {
1530 OBJECTSELF c;
1531 c = s_o_s(a);
1532
1533 c.ob_symchar->sy_dimension = b;
1534 return(OK);
1535 }
1536
c_sc_p(a,b)1537 INT c_sc_p(a,b) OP a,b;
1538 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1539 {
1540 OBJECTSELF c;
1541 c = s_o_s(a);
1542
1543 c.ob_symchar->sy_parlist = b;
1544 return(OK);
1545 }
1546
c_sc_w(a,b)1547 INT c_sc_w(a,b) OP a,b;
1548 /* AK 140789 V1.0 */ /* AK 200891 V1.3 */
1549 {
1550 OBJECTSELF c;
1551 c = s_o_s(a);
1552
1553 c.ob_symchar->sy_werte = b;
1554 return(OK);
1555 }
1556
1557 #endif /* CHARTRUE */
1558
innermaxmofn(m,n,erg)1559 INT innermaxmofn(m,n,erg) OP m,n,erg;
1560 {
1561 /* AK 091189 */
1562 /* geschrieben fuer regev, diese routine berechnet fuer
1563 eingebe
1564 INTEGER m
1565 INTEGER n die zerlegung der summe der inneren tensorquadrate der
1566 partitionen von n die hoechstens m teile haben
1567 ergebnis ist vom typ SCHUR
1568 */
1569 /* AK 200891 V1.3 */
1570 #ifdef CHARTRUE
1571 OP a = callocobject();
1572 OP b = callocobject();
1573 OP c = callocobject();
1574 OP d = callocobject();
1575 first_partition(n,a);
1576 do {
1577 if (le(s_pa_l(a),m)) {
1578 m_part_sc(a,b);mult(b,b,c);
1579 add(c,d,d);
1580 }
1581 } while(next(a,a));
1582 reduce_symchar(d,erg);
1583 freeall(a); freeall(b); freeall(c); freeall(d);
1584 return(OK);
1585 #endif /* CHARTRUE */
1586 }
1587
1588
1589 #ifdef CHARTRUE
1590 #ifdef KOSTKATRUE
young_tafel(a,res,ct,kt)1591 INT young_tafel(a,res,ct,kt) OP a, res, ct, kt;
1592 /* AK Mon Jan 23 09:59:22 MEZ 1989 */
1593 /* a ist dimension res wird MATRIX
1594 ct ist wenn ungleich NULL die charatertafel
1595 kt ist wenn ungleich NULL die kostkatafel */
1596 /* AK 200789 V1.0 */ /* AK 020290 V1.1 */ /* AK 200891 V1.3 */
1597 /* AK 011098 V2.0 */
1598 /* a and res may be equal */
1599 {
1600 OP zw /* zwischenergebnis */,
1601 hct,hkt;
1602 INT i,j,k,dim;
1603 INT erg = OK;
1604 C1R(a,"young_tafel",res);
1605
1606
1607 if (a == res)
1608 {
1609 zw = callocobject();
1610 erg += copy(a,zw);
1611 erg += young_tafel(zw,res,ct,kt);
1612 erg += freeall(zw);
1613 goto endr_ende;
1614 }
1615
1616 dim = numberofpart_i(a);
1617 erg += m_ilih_nm(dim,dim,res);
1618
1619 if (ct == NULL)
1620 {
1621 hct = callocobject();
1622 erg += chartafel(a,hct);
1623 }
1624 else hct = ct;
1625 if (kt == NULL)
1626 {
1627 hkt = callocobject();
1628 erg += kostka_tafel(a,hkt);
1629 }
1630 else hkt = kt;
1631
1632 /* hct und hkt zeigen nun auf charactertafel und kostkatafel */
1633 /* um den youngcharacter zu berechnen sind nur mehr multiplikation
1634 von zeilen und spalten noetig */
1635
1636 zw = callocobject();
1637 for (i=(INT)0; i<S_M_HI(res); i++)
1638 for (j=(INT)0; j<S_M_HI(res); j++)
1639 {
1640 for (k=(INT)0; k<S_M_HI(res); k++)
1641 {
1642 erg += mult(S_M_IJ(hkt,i,k),S_M_IJ(hct,k,j),zw);
1643 erg += add_apply(zw,S_M_IJ(res,i,j));
1644 }
1645 };
1646
1647 if (kt == NULL)
1648 erg += freeall(hkt);
1649 if (ct == NULL)
1650 erg += freeall(hct);
1651 /* die berechneten tafeln werden wieder geloescht */
1652
1653 erg += freeall(zw);
1654
1655 S1R(a,"young_tafel",res);
1656 ENDR("young_tafel");
1657 }
1658 #endif /* KOSTKATRUE */
1659
1660
1661
1662
m_part_youngsc(a,b)1663 INT m_part_youngsc(a,b) OP a,b;
1664 /* AK 020591 V1.2 */ /* AK 200891 V1.3 */
1665 {
1666 return young_character(a,b,NULL);
1667 }
1668
young_character(a,res,yt)1669 INT young_character(a,res,yt) OP a,res,yt;
1670 /* AK Mon Jan 23 13:04:51 MEZ 1989 */
1671 /* a ist PARTITION res wird SYMCHAR
1672 yt ist NULL oder sonst young_tafel */
1673 /* AK 200789 V1.0 */ /* AK 100190 V1.1 */ /* AK 020591 V1.2 */
1674 /* AK 200891 V1.3 */
1675 /* AK 011098 V2.0 */
1676 /* a and res may be equal */
1677 {
1678 OP hyt;
1679 OP d;
1680 INT i,j,erg=OK;
1681
1682 d = callocobject();
1683
1684 if (a == res)
1685 {
1686 erg += copy(a,d);
1687 erg += young_character(d,res,yt);
1688 erg += freeall(d);
1689 goto endr_ende;
1690 }
1691
1692 erg += weight(a,d);
1693 if (yt == NULL)
1694 {
1695 hyt = callocobject();
1696 erg += young_tafel(d,hyt,NULL,NULL);
1697 }
1698 else
1699 hyt = yt;
1700
1701 /* hyt zeigt nun auf youngtafel, nun nurmehr zeile rauslesen */
1702 erg += b_d_sc(d,res);
1703 i = indexofpart(a);
1704
1705 for (j=(INT)0; j<S_SC_PLI(res); j++)
1706 erg += copy(S_M_IJ(hyt,i,j),S_SC_WI(res,j));
1707
1708 if (yt == NULL)
1709 erg += freeall(hyt);
1710
1711 ENDR("young_character");
1712 }
1713
1714 #endif /* CHARTRUE */
1715
1716 #ifdef CHARTRUE
1717 #ifdef MATRIXTRUE
young_scalar_tafel(n,res,yt)1718 INT young_scalar_tafel(n,res,yt) OP n,res,yt;
1719 /* AK Tue Jan 24 07:24:26 MEZ 1989 */
1720 /* tafel der skalar produkte der young_charactere
1721 n ist INTEGER dimension
1722 res wird MATRIX des ergebnis
1723 yt ist wenn != NULL die young_tafel */
1724 /* AK 200789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1725 {
1726 OP hyt, vecpart = callocobject();
1727 OP convec = callocobject(); /* vector mit der konjugiertenklassen
1728 ordnung */
1729 INT i,j,k,dim;
1730 makevectorofpart(n,vecpart);
1731 dim = S_V_LI(vecpart);
1732 m_il_v(dim,convec);
1733 for (k=(INT)0;k<dim;k++)
1734 ordcon(S_V_I(vecpart,k), S_V_I(convec,k));
1735 m_ilih_m(dim,dim,res);
1736 if (yt == NULL)
1737 {
1738 hyt = callocobject();
1739 young_tafel(n,hyt,NULL,NULL);
1740 }
1741 else
1742 hyt = yt;
1743 /* hyt zeigt auf youngtafel */
1744 for ( i=(INT)0;i<S_M_HI(res);i++)
1745 for ( j=(INT)0;j<S_M_HI(res);j++)
1746 char_matrix_scalar_product(hyt,i,hyt,j,vecpart,S_M_IJ(res,i,j),
1747 convec);
1748 if (yt == NULL)
1749 freeall(hyt);
1750 freeall(vecpart);
1751 freeall(convec);
1752 return(OK);
1753 }
1754 #endif /* MATRIXTRUE */
1755 #endif /* CHARTRUE */
1756
1757 #ifdef CHARTRUE
1758 #ifdef MATRIXTRUE
young_alt_scalar_tafel(n,res,yt)1759 INT young_alt_scalar_tafel(n,res,yt) OP n,res,yt;
1760 /* AK Tue Jan 24 09:05:18 MEZ 1989 */
1761 /* tafel der skalar produkte des young_characters
1762 mit dem young_character * alternierenden character
1763 n ist INTEGER dimension
1764 res wird MATRIX des ergebnis
1765 yt ist wenn != NULL die young_tafel */
1766 /* AK 200789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */
1767 {
1768 OP hyt;
1769 OP vecpart = callocobject();
1770 OP hat = callocobject(); /* wird tafel des alternierenden mal
1771 youngcharacter */
1772 OP altchar = callocobject(); /* alternierender character */
1773 OP lastpart = callocobject(); /* index des alt. character */
1774 INT i,j,k,dim;
1775 OP convec = callocobject();
1776
1777
1778 makevectorofpart(n,vecpart);
1779 dim = S_V_LI(vecpart);
1780 m_il_v(dim,convec);
1781 for (k=(INT)0;k<dim;k++) ordcon(S_V_I(vecpart,k), S_V_I(convec,k));
1782 m_ilih_m(dim,dim,res);
1783 if (yt == NULL) { hyt = callocobject(); young_tafel(n,hyt,NULL,NULL);}
1784 else hyt = yt;
1785 /* hyt zeigt auf youngtafel */
1786 last_partition(n,lastpart);
1787 m_part_sc(lastpart,altchar);
1788 copy(hyt,hat);
1789 for ( i=(INT)0;i<S_M_HI(res);i++)
1790 for ( j=(INT)0;j<S_M_HI(res);j++)
1791 mult(S_SC_WI(altchar,j),S_M_IJ(hat,i,j),S_M_IJ(hat,i,j));
1792 freeall(altchar);freeall(lastpart);
1793 for ( i=(INT)0;i<S_M_HI(res);i++)
1794 for ( j=(INT)0;j<S_M_HI(res);j++)
1795 char_matrix_scalar_product
1796 (hyt,i,hat,j,vecpart,
1797 S_M_IJ(res,i,j),
1798 convec);
1799 if (yt == NULL) freeall(hyt);
1800 freeall(vecpart); freeall(hat); freeall(convec); return(OK);
1801 }
1802 #endif /* MATRIXTRUE */
1803 #endif /* CHARTRUE */
1804
1805 #ifdef CHARTRUE
test_symchar()1806 INT test_symchar()
1807 /* AK 200891 V1.3 */
1808 {
1809 OP a = callocobject();
1810 OP b = callocobject();
1811 OP c = callocobject();
1812 FILE *fp1, *fp2;
1813
1814 printf("test_symchar:scan(a)"); scan(SYMCHAR,a);println(a);
1815 printf("test_symchar:add(a,a,b)"); add(a,a,b); println(b);
1816 printf("test_symchar:add_apply(a,b)"); add_apply(a,b); println(b);
1817 printf("test_symchar:mult(a,b,b)"); mult(a,b,b); println(b);
1818 printf("test_symchar:mult_apply(a,b)"); mult_apply(a,b); println(b);
1819 printf("test_symchar:reduce_symchar(b,c)");
1820 reduce_symchar(b,c); println(c);
1821 printf("test_symchar:M_I_I(-1L,c);mult(c,b,b)");
1822 M_I_I(-1L,c); mult(c,b,b); println(b);
1823 printf("test_symchar:objectwrite(,b)");
1824 fp1 = fopen("klo","w"); objectwrite(fp1,b); fclose(fp1);
1825 printf("test_symchar:objectread(,b)");
1826 fp2 = fopen("klo","r"); objectread(fp2,b); fclose(fp2); println(b);
1827 printf("test_symchar:tex(b)"); tex(b);
1828 printf("test_symchar:hoch(a,cons_zwei,b)");
1829 hoch(a,cons_zwei,b); println(b);
1830 printf("test_symchar:scalarproduct(a,b,b)"); scalarproduct(a,b,b);
1831 println(b);
1832 printf("test_symchar:charvalue(a,b,c);scan(PARTITION,a)");
1833 scan(PARTITION,a);
1834 printf("test_symchar:charvalue(a,b,c);scan(PERMUTATION,b)");
1835 scan(PERMUTATION,b);
1836 printf("test_symchar:charvalue(a,b,c)");charvalue(a,b,c,NULL);
1837 println(c);
1838 printf("test_symchar:M_I_I(7L,c);chartafel(c,b)");
1839 M_I_I(7L,c); chartafel(c,b); println(b);
1840 printf("test_symchar:M_I_I(7L,c);young_tafel(c,b)");
1841 M_I_I(7L,c); young_tafel(c,b,NULL,NULL); println(b);
1842 printf("test_symchar:M_I_I(7L,c);an_tafel(c,b)");
1843 M_I_I(7L,c); an_tafel(c,b); println(b);
1844
1845 freeall(a);freeall(b);freeall(c);
1846 return(OK);
1847 }
1848
1849 #endif /* CHARTRUE */
1850 /* now follows spechts method to compute an irreducible character */
1851
1852 #ifdef CHARTRUE
specht_m_part_sc(a,b)1853 INT specht_m_part_sc(a,b) OP a,b;
1854 /* AK 200891 V1.3 */
1855 {
1856 OP c = callocobject();
1857 INT erg = OK;
1858 erg += specht_irred_characteristik(a,c);
1859 erg += characteristik_to_symchar(c,b);
1860 erg += freeall(c);
1861 return erg;
1862 }
1863 #endif /* CHARTRUE */
1864 #ifdef MATRIXTRUE
1865 #ifdef CHARTRUE
specht_irred_characteristik(a,b)1866 INT specht_irred_characteristik(a,b) OP a,b;
1867 /* input PARTITION a
1868 output POLYNOM b */
1869 /* AK 200891 V1.3 */
1870 {
1871 INT i,j;
1872 OP c,d;
1873 if (S_O_K(a) != PARTITION)
1874 return error("specht_ireed_characteristik: not PART");
1875 c = callocobject();
1876 if (S_PA_K(a) != VECTOR)
1877 {
1878 t_EXPONENT_VECTOR(a,c);
1879 i = specht_irred_characteristik(c,b);
1880 freeall(c);
1881 return i;
1882 }
1883 d = callocobject();
1884 m_ilih_m(S_PA_LI(a),S_PA_LI(a),c);
1885 for (i=(INT)0;i<S_PA_LI(a);i++)
1886 for (j=(INT)0;j<S_PA_LI(a);j++)
1887 {
1888 m_i_i(S_PA_II(a,S_PA_LI(a)-1L-i)+j-i,d);
1889 specht_powersum(d,S_M_IJ(c,i,j));
1890 }
1891 det_imm_matrix(c,b);
1892 freeall(c); freeall(d);
1893 return OK;
1894 }
1895 #endif /* MATRIXTRUE */
1896 #endif /* CHARTRUE */
1897
1898 #ifdef CHARTRUE
specht_powersum(a,b)1899 INT specht_powersum(a,b) OP a,b;
1900 /* input INTEGERobject a
1901 output POLYNOMobject */
1902 /* AK 200891 V1.3 */
1903 {
1904 static OP speicher = NULL; /* for the computed results */
1905 OP c,d,e,f,g;
1906 INT j;
1907 if (S_O_K(a) != INTEGER) return error("specht_powersum:a != INTEGER");
1908 if (nullp(a)) return m_scalar_polynom(cons_eins,b);
1909 if (negp(a)) return m_scalar_polynom(cons_null,b);
1910 if (S_I_I(a) >= (INT)100) return error("specht_powersum:a too big");
1911
1912 if (speicher == NULL) {
1913 speicher = callocobject();m_il_v((INT)100,speicher); }
1914 if (not EMPTYP(S_V_I(speicher, S_I_I(a))))
1915 return copy(S_V_I(speicher, S_I_I(a)),b);
1916
1917 /* not yet computed */
1918 c = callocobject(); d = callocobject(); g=callocobject();
1919 e = callocobject(); f = callocobject();
1920 if (not EMPTYP(b)) freeself(b);
1921 first_part_EXPONENT(a,c);
1922 do {
1923 b_skn_po(callocobject(),callocobject(),NULL,d);
1924 m_il_v(S_PA_LI(c),S_PO_S(d));
1925 for (j=(INT)0;j<S_PA_LI(c);j++)
1926 m_i_i(S_PA_II(c,j), S_PO_SI(d,j) );
1927 /* now the exponents of the monom are ok */
1928 m_i_i((INT)1,g);
1929 for (j=(INT)0;j<S_PA_LI(c);j++)
1930 {
1931 fakul(S_PA_I(c,j), e);
1932 /* div(S_PO_K(d),e,S_PO_K(d)); */
1933 m_i_i(j+(INT)1,f);
1934 hoch(f,S_PA_I(c,j),f); mult_apply(e,f);
1935 mult_apply(f,g);
1936 /* div(S_PO_K(d),f,S_PO_K(d)); */
1937 }
1938 invers(g,S_PO_K(d));
1939 add_apply(d,b);
1940 } while(next(c,c));
1941
1942 freeall(c); freeall(d); freeall(e); freeall(f); freeall(g);
1943 copy(b, S_V_I(speicher, S_I_I(a)));
1944 return OK;
1945 }
1946
1947
characteristik_to_symchar(a,b)1948 INT characteristik_to_symchar(a,b) OP a,b;
1949 /* input: characteristik a
1950 output: coressponding sym character b */
1951 /* AK 200891 V1.3 */
1952 {
1953 INT i,j,oben,unten,mitte;
1954 INT erg = OK;
1955 OP z = a;
1956 OP c,d,e,f,h;
1957 CTO(POLYNOM,"characteristik_to_symchar(1)",a);
1958 c = callocobject(); d = callocobject();
1959 e = callocobject(); f = callocobject();
1960 h = callocobject();
1961
1962 m_ks_pa(EXPONENT,S_PO_S(z),d);
1963 weight (d,c); /* c is the degree of the symm group */
1964 m_d_sc(c,b); /* b is a SYMCHAR object */
1965 m_il_v(S_SC_WLI(b),h);
1966 for (i=(INT)0;i<S_SC_PLI(b);i++)
1967 t_VECTOR_EXPONENT(S_SC_PI(b,i),S_V_I(h,i));
1968 while (z != NULL)
1969 {
1970 m_ks_pa(EXPONENT,S_PO_S(z),c);
1971 t_EXPONENT_VECTOR(c,d);
1972 unten=(INT)0;oben=S_V_LI(h)-(INT)1;
1973 aaa:
1974 mitte = unten + (oben-unten) /2L;
1975 if ((i=comp_colex_part(d,S_SC_PI(b,mitte))) == (INT)0)
1976 {i = mitte;goto aab;}
1977 else if (i>(INT)0) unten=mitte+(INT)1;
1978 else oben=mitte-(INT)1;
1979 if ( oben < unten ) {
1980 fprintln(stderr,d);
1981 fprintln(stderr,h);
1982 error("characteristik_to_symchar:part not found");
1983 }
1984 goto aaa;
1985 aab: /* part gefunden */
1986 /* i = indexofpart(c); */
1987 copy(S_PO_K(z), S_SC_WI(b,i));
1988 for (j=(INT)0;j<S_PA_LI(c);j++)
1989 {
1990 fakul(S_PA_I(c,j), e);
1991 mult_apply(e,S_SC_WI(b,i));
1992 m_i_i(j+(INT)1,f);
1993 hoch(f,S_PA_I(c,j),f);
1994 mult_apply(f,S_SC_WI(b,i));
1995 }
1996 z = S_PO_N(z);
1997 }
1998 freeall(c); freeall(f); freeall(e); freeall(h); freeall(d);
1999 ENDR("characteristik_to_symchar");
2000 }
2001
2002
2003
characteristik_symchar(a,b)2004 INT characteristik_symchar(a,b) OP a,b;
2005 /* AK 020191 */
2006 /* enter symchar a
2007 out: polynom b */
2008 /* AK 200891 V1.3 */
2009 {
2010 INT i,j;
2011 OP c = callocobject();
2012 OP d = callocobject();
2013 OP e = callocobject();
2014 OP f = callocobject();
2015
2016 if (not EMPTYP(b)) freeself(b);
2017
2018 for (i = (INT)0; i< S_SC_PLI(a); i++)
2019 {
2020 t_VECTOR_EXPONENT(S_SC_PI(a,i),c);
2021 b_skn_po(callocobject(),callocobject(),NULL,d);
2022 m_il_v(S_SC_DI(a),S_PO_S(d));
2023 for (j=(INT)0;j<S_SC_DI(a);j++)
2024 if (j >= S_PA_LI(c) ) m_i_i((INT)0,S_PO_SI(d,j));
2025 else m_i_i(S_PA_II(c,j), S_PO_SI(d,j) );
2026 /* now the exponents of the monom are ok */
2027 copy(S_SC_WI(a,i) , S_PO_K(d) );
2028 for (j=(INT)0;j<S_PA_LI(c);j++)
2029 {
2030 fakul(S_PA_I(c,j), e);
2031 div(S_PO_K(d),e,S_PO_K(d));
2032 m_i_i(j+(INT)1,f);
2033 hoch(f,S_PA_I(c,j),f);
2034 div(S_PO_K(d),f,S_PO_K(d));
2035 }
2036 add(d,b,b);
2037 }
2038
2039 freeall(c); freeall(d); freeall(e); freeall(f);
2040 return OK;
2041 }
2042
2043
2044
c_ijk_sn(a,b,c,g)2045 INT c_ijk_sn(a,b,c,g) OP a,b,c,g;
2046 /* structur constanten classen multiplikation in s_n
2047 Curtis Reiner Methods of representation theory I p.216
2048 AK 020891 V1.3 */
2049 {
2050 return c_ijk_sn_tafel(a,b,c,g,NULL);
2051 }
2052
2053
c_ijk_sn_tafel(a,b,c,g,ct)2054 INT c_ijk_sn_tafel(a,b,c,g,ct) OP a,b,c,g,ct;
2055 /* ct may be the corresponding charactertable
2056 or NULL */
2057 /* AK 150206 C3.0 */
2058 {
2059 OP d,e,f,h,h2;
2060 INT i,erg=OK;
2061
2062 CTO(PARTITION,"c_ijk_sn(1)",a);
2063 CTO(PARTITION,"c_ijk_sn(2)",b);
2064 CTO(PARTITION,"c_ijk_sn(3)",c);
2065 if (a == g) {
2066 e = CALLOCOBJECT();
2067 SWAP(g,e);
2068 erg += c_ijk_sn_tafel(e,b,c,g,ct);
2069 FREEALL(e);
2070 goto endr_ende;
2071 }
2072 if (b == g) {
2073 e = CALLOCOBJECT();
2074 SWAP(g,e);
2075 erg += c_ijk_sn_tafel(a,e,c,g,ct);
2076 FREEALL(e);
2077 goto endr_ende;
2078 }
2079 if (c == g) {
2080 e = CALLOCOBJECT();
2081 SWAP(g,e);
2082 erg += c_ijk_sn_tafel(a,b,e,g,ct);
2083 FREEALL(e);
2084 goto endr_ende;
2085 }
2086
2087
2088 d=callocobject();
2089 e=callocobject();
2090 f=callocobject();
2091 h=callocobject();
2092 h2=callocobject();
2093
2094 erg += weight_partition(a,d);
2095 erg += weight_partition(b,h2);
2096 if (neq (d,h2) )
2097 {
2098 erg += error("c_ijk_sn_tafel: different weights of partitions");
2099 goto ee;
2100 }
2101 erg += weight(c,h2);
2102 if (neq (d,h2) )
2103 {
2104 erg += error("c_ijk_sn_tafel: different weights of partitions");
2105 goto ee;
2106 }
2107 erg += makevectorofpart(d,e);
2108 erg += ordcon(a,f);
2109 erg += ordcon(b,g);
2110 erg += mult_apply(f,g);
2111 erg += m_i_i((INT)0,h);
2112 if (ct == NULL) {
2113 for (i=(INT)0;i<S_V_LI(e);i++)
2114 {
2115 erg += charvalue(S_V_I(e,i),a,f,NULL);
2116 erg += charvalue(S_V_I(e,i),b,h2,NULL);
2117 MULT_APPLY(f,h2);
2118 erg += charvalue(S_V_I(e,i),c,f,NULL);
2119 MULT_APPLY(f,h2);
2120 erg += dimension(S_V_I(e,i),f);
2121 erg += div_apply(h2,f); /* h2 = h2/f */
2122 ADD_APPLY(h2,h);
2123 }
2124 }
2125 else {
2126 INT ai,bi,ci;
2127 ai = indexofpart(a);
2128 bi = indexofpart(b);
2129 ci = indexofpart(c);
2130
2131
2132 for (i=(INT)0;i<S_V_LI(e);i++)
2133 {
2134 FREESELF(h2);
2135 MULT(S_M_IJ(ct,i,ai), S_M_IJ(ct,i,bi), h2);
2136 MULT_APPLY(S_M_IJ(ct,i,ci),h2);
2137 erg += div_apply(h2,S_M_IJ(ct,i,S_V_LI(e)-1)); /* dimension */
2138 ADD_APPLY(h2,h);
2139 }
2140 }
2141 MULT_APPLY(h,g);
2142 erg += fakul(d,f);
2143 erg += div_apply(g,f);
2144
2145 ee:
2146 FREEALL5(d,e,f,h,h2);
2147 ENDR("c_ijk_sn_tafel");
2148 }
2149
co_290802(ai,bi,ci,f,ct,factor)2150 static INT co_290802(ai,bi,ci,f,ct,factor) INT ai,bi,ci; OP f,ct,factor;
2151 /* special verison of c_ijk_sn */
2152 {
2153 INT i;
2154 INT erg = OK;
2155 OP h2;
2156 h2 = CALLOCOBJECT();
2157 m_i_i(0,f);
2158
2159 for (i=(INT)0;i<S_M_HI(ct);i++)
2160 {
2161 FREESELF(h2);
2162 MULT(S_M_IJ(ct,i,ai), S_M_IJ(ct,i,bi), h2);
2163 MULT_APPLY(S_M_IJ(ct,i,ci),h2);
2164 erg += div_apply(h2,S_M_IJ(ct,i,S_M_LI(ct)-1)); /* dimension */
2165 ADD_APPLY(h2,f);
2166 }
2167 MULT_APPLY(factor,f);
2168 FREEALL(h2);
2169 ENDR("internal:co_290802");
2170 }
2171
2172
c_ij_sn(a,b,c)2173 INT c_ij_sn(a,b,c) OP a,b,c;
2174 {
2175 return class_mult_part_part(a,b,c);
2176 }
2177
class_mult(a,b,c)2178 INT class_mult(a,b,c) OP a,b,c;
2179 /* class multiplication in the symmetric group */
2180 /* input may also be SCHUR, in this case these are class sums */
2181 /* AK 280802 */
2182 {
2183 INT erg = OK;
2184 CTTO(SCHUR,PARTITION,"class_mult(1)",a);
2185 CTTO(SCHUR,PARTITION,"class_mult(2)",b);
2186 CE3(a,b,c,class_mult);
2187 if (S_O_K(a) == PARTITION) {
2188 if (S_O_K(b) == PARTITION)
2189 erg += class_mult_part_part(a,b,c);
2190 else /* SCHUR */
2191 {
2192 OP z,d;
2193 init(SCHUR,c);
2194 FORALL(z,b,{
2195 d = CALLOCOBJECT();
2196 class_mult_part_part(a,S_MO_S(z),d);
2197 MULT_APPLY(S_MO_K(z),d);
2198 insert(d,c,add_koeff,comp_monomschur);
2199 });
2200 }
2201 }
2202 else {
2203 if (S_O_K(b) == PARTITION)
2204 {
2205 OP z,d;
2206 init(SCHUR,c);
2207 FORALL(z,a,{
2208 d = CALLOCOBJECT();
2209 class_mult_part_part(b,S_MO_S(z),d);
2210 MULT_APPLY(S_MO_K(z),d);
2211 insert(d,c,add_koeff,comp_monomschur);
2212 });
2213 }
2214 else /* two schur functions */
2215 {
2216 OP z1,z2,d;
2217 init(SCHUR,c);
2218 FORALL(z1,a,{
2219 FORALL(z2,b,{
2220 d = CALLOCOBJECT();
2221 class_mult_part_part(S_MO_S(z2),S_MO_S(z1),d);
2222 MULT_APPLY(S_MO_K(z1),d);
2223 MULT_APPLY(S_MO_K(z2),d);
2224 insert(d,c,add_koeff,comp_monomschur);
2225 });
2226 });
2227 }
2228 }
2229
2230 ENDR("class_mult");
2231 }
2232
class_mult_part_part(a,b,c)2233 INT class_mult_part_part(a,b,c) OP a,b,c;
2234 /* complete expansion of class multiplication
2235 result: SCHUR
2236 input: two partitions of the same weight */
2237 /* AK 270802 */
2238 {
2239 INT erg = OK;
2240 CTO(PARTITION,"class_mult_part_part(1)",a);
2241 CTO(PARTITION,"class_mult_part_part(2)",b);
2242 {
2243 OP d,e,f,ct,factor;
2244 INT ai,bi,ei;
2245 d = callocobject();
2246 e = callocobject();
2247 weight(a,d);
2248 weight(b,e);
2249 if (neq(d,e)) {
2250 error("class_mult_part_part:partitions of different weight");
2251 goto ee;
2252 }
2253 f = callocobject();
2254 ct = callocobject();
2255 factor = callocobject();
2256 ordcon(a,factor);
2257 ordcon(b,f); mult_apply(f,factor);
2258 fakul(e,f); div_apply(factor,f);
2259 /* factor is computed */
2260
2261 chartafel(e,ct);
2262 init(SCHUR,c);
2263 first_partition(d,e);
2264 ai = indexofpart(a);
2265 bi = indexofpart(b);
2266 ei = 0;
2267 do {
2268 co_290802(ai,bi,ei,f,ct,factor);
2269 if (not nullp(f)) {
2270 OP m;
2271 m = callocobject();
2272 m_sk_mo(e,f,m);
2273 insert(m,c,add_koeff,comp_monomschur);
2274 }
2275 ei++;
2276 }
2277 while (next_apply(e));
2278 FREEALL(f);
2279 FREEALL(ct);
2280 FREEALL(factor);
2281 ee:
2282 erg += freeall(d);
2283 erg += freeall(e);
2284 }
2285 ENDR("class_mult_part_part");
2286 }
2287
2288
2289
2290 #ifdef SCHURTRUE
t_SCHUR_SYMCHAR(a,b)2291 INT t_SCHUR_SYMCHAR(a,b) OP a,b;
2292 /* input SCHUR output character */
2293 {
2294 OP z = a;
2295 OP c;
2296 INT erg = OK;
2297
2298 if (S_O_K(a) != SCHUR)
2299 {
2300 cast_apply_schur(a); /* AK 280494 */
2301 if (S_O_K(a) != SCHUR)
2302 return WTO("t_SCHUR_SYMCHAR",a);
2303 }
2304
2305 CE2(a,b,t_SCHUR_SYMCHAR);
2306 c = callocobject();
2307
2308 while(z != NULL)
2309 {
2310 erg += m_part_sc(S_S_S(z),c);
2311 erg += mult_apply(S_S_K(z),c);
2312 if (z != a)
2313 erg += add_apply(c,b);
2314 else
2315 erg += swap(c,b);
2316 z = S_S_N(z);
2317 }
2318 erg += freeall(c);
2319
2320 ENDR("t_SCHUR_SYMCHAR");
2321 }
2322 #endif /* SCHURTRUE */
2323
2324
vminus_tabloid(a,b)2325 INT vminus_tabloid(a,b) OP a,b;
2326 /* eingabe tableau, ausgabe tabloid */
2327 /* AK 270295 */
2328 {
2329 OP f,g,x,z,h;
2330 INT erg = OK;
2331 CTO(TABLEAUX,"vminus_tabloid(1)",a);
2332 CE2(a,b,vminus_tabloid);
2333
2334 x = callocobject();
2335 f = callocobject();
2336 g = callocobject();
2337 erg += vminus(a,f);
2338 z =f;
2339 erg += init(LIST,b);
2340 while (z!=NULL) {
2341 erg += operate_perm_tableaux(S_PO_S(z),a,x);
2342 h=callocobject();
2343 erg += sort_rows_tableaux_apply(x);
2344 erg += m_sk_mo(x,S_PO_K(z),h);
2345 insert(h,b,add_koeff,NULL);
2346 z = S_PO_N(z);
2347 }
2348 erg += freeall(x);
2349 erg += freeall(f);
2350 erg += freeall(g);
2351
2352 ENDR("vminus_tabloid");
2353 }
2354
2355 #endif /* CHARTRUE */
2356