1 /* SYMMETRICA hiccup.c */
2 /* HICCUP module to calculate explicit representation matrices
3 of the Hecke algebra of type A. Uses the Specht module
4 generalisation described by R.C.King and B.G.Wybourne in
5 J.Math.Phys.33(1), pp4-14 (1992).
6 The Specht modules are irreducible in the generic case when
7 q is not a root of unity. Otherwise they may reduce.
8 Routines which deal with those non-generic irreducibles which
9 are labelled by two-rowed partitions start from about line 1210.
10
11 Programmed by Trevor Welsh, Bayreuth, November 1995.
12 (Modified 12/1/96.)
13
14 Data structure for q-linear combinations of tableaux is as follows:
15
16 LIST --> LIST (next)
17 --> MONOM --> TABLEAUX
18 --> MONOPOLY (LIST) --> MONOPOLY (next)
19 --> MONOM --> INTEGER (power)
20 --> INTEGER (coefficient).
21
22 A similar structure is used for q-linear combinations of permutations.
23
24 */
25
26 #define NORMALISE 1 /* if 1, monopolies are tidied up wrt roots of unity */
27
28 #include "def.h"
29 #include "macro.h"
30
31 static OP children=NULL; /* AK 150197 */
32
33
34 /* function prototypes for generic representation routines */
35
36 #ifdef UNDEF
37 INT generate_standard_tableaux (OP partition, OP std);
38 INT hecke_generator_reps (OP partition, OP vector);
39 INT represent_hecke_element (OP partition, OP hecke, OP mat);
40 INT build_lc (OP schizo, OP list);
41 INT hecke_action_lc_on_lc (OP tableaux, OP hecke, OP result);
42 INT standardise_cold_tableaux_list (OP tableaux, OP result);
43 INT input_tableau (OP partit, OP tab);
44 INT input_lc_permutations (OP save);
45 INT substitute_one_matrix (OP mat);
46 INT substitute_one_monopoly (OP mp);
47
48 INT set_garnir_parameters (OP partition);
49 INT free_garnir_parameters (void);
50 INT set_useful_monopolies (void);
51 INT free_useful_monopolies (void);
52 #endif
53 void set_multiplier (OP extra);
54 #ifdef UNDEF
55 hecke_action (OP tableau, OP permutation, OP list);
56 INT hecke_action_perm_on_lc (OP tableaux, OP permutation);
57 INT find_non_rowstandard_pos (OP tableau, INT *r, INT *c);
58 INT columns_standardise_tableau (OP tableau, INT *sig);
59 INT column_standardise_tableau (OP tableau, INT col, INT *sig);
60 static int standardise_tableau_list (OP list, OP expression);
61 static int standardise_tableau (OP tableau, OP expression);
62 garnir_juggle (OP tableau, INT power, INT coeff);
63 static garnir_generate (INT head, INT wag);
64 static garnir_result (OP tableau, OP mp_coeff, OP acc_list);
65 INT enter_list_to_matrix (OP matrix, INT column, OP standard, OP express);
66 static INT construct_mo_mp (INT power, INT coeff, OP mo_po);
67 memory_check (void *query);
68
69
70 /* function prototypes for non-generic representation routines */
71
72 INT root_dimension (OP partition, OP p_root, OP dim);
73 INT generate_root_tableaux (OP partition, OP p_root, OP std);
74 INT hecke_root_generator_reps (OP partition, OP p_root, OP vector);
75 INT root_represent_hecke_action (OP partition,
76 OP p_root, OP hecke, OP mat);
77 INT root_standardise_cold_tableaux_list (OP tableaux, OP p_root, OP result);
78
79 INT set_root_parameters (OP partition, OP p_root);
80 INT free_root_parameters (void);
81 INT find_non_root_standard_pos (OP tableau);
82 #endif
83 void set_root_multiplier (OP extra);
84 void root_standardise_tableau_list (OP list, OP expression);
85 void root_standardise_tableau (OP tableau, OP expression);
86 void root_juggle (OP tableau, INT power, INT coeff);
87 void strip_juggle (OP tableau, INT power, INT coeff);
88 void root_garnir_result (OP tableau, OP mp_coeff, OP acc_list);
89 #ifdef UNDEF
90 INT root_normalise_monopoly (OP mono);
91 #endif
92 void generate_sym_tableaux_list (INT piece, OP sym_list);
93 void coset_generate (INT head, INT wag);
94 #ifdef UNDEF
95 INT remove_mp_qnumber_fac (OP mp, INT qn);
96 INT remove_vec_qnumber (INT qn);
97
98
99 /* function prototypes for matrix representation checking routines */
100
101 INT check_hecke_generators (OP vector, OP p_root, INT flag);
102 INT check_hecke_quadratic (OP mat, OP p_root, INT flag);
103 INT check_braid (OP mat1, OP mat2, OP p_root, INT flag);
104 INT check_commute (OP mat1, OP mat2, OP p_root, INT flag);
105 INT set_cyclotomic_parameters (OP p_root);
106 INT free_cyclotomic_parameters ();
107 INT check_zero_matrix (OP mat, OP p_root);
108
109
110 /* function prototypes to add or multiply hecke algebra elements */
111
112 INT hecke_add (OP hecke1, OP hecke2, OP result);
113 INT hecke_mult (OP hecke1, OP hecke2, OP result);
114 INT hecke_scale (OP hecke, OP power, OP coeff);
115
116 INT hecke_action_perm_on_hecke (OP heck, OP permutation);
117
118
119 /* function prototypes for some debugging routines */
120
121 strip_buggle (OP tableau);
122 dump_lc_list (OP list);
123 dump_monopoly (OP mp);
124 #endif
125 static int standardise_tableau ();
126 static int standardise_tableau_list();
127 static int garnir_juggle ();
128 static INT free_garnir_parameters();
129 static INT set_garnir_parameters();
130 static int garnir_generate ();
131 static int garnir_result ();
132 static INT construct_mo_mp ();
133 static void hecke_accum (OP perm, OP mp_coeff, OP acc_list);
134
135 #ifdef TABLEAUXTRUE
generate_standard_tableaux(partition,std)136 INT generate_standard_tableaux (partition,std)
137 OP partition;
138 OP std;
139
140 /* generates all the S_n standard tableaux for the partition.
141 returns the number of standard tableaux, else ERROR.
142 */
143
144 {
145 OP t,last,n;
146 INT count=0;
147
148 /* validate parameters */
149
150 if (partition==NULL || S_O_K(partition)!=PARTITION)
151 {
152 printf("generate_standard_tableaux() did not receive a partition as it was expecting!\n");
153 return(ERROR);
154 }
155
156 weight(partition,n=callocobject());
157 last_partition(n,last=callocobject());
158 kostka_tab(partition,last,std);
159
160 freeall(n);
161 freeall(last);
162
163 if (!empty_listp(std))
164 for (t=std;t!=NULL;t=S_L_N(t),count++);
165
166 return(count);
167 }
168 #endif /* TABLEAUXTRUE */
169
170 #ifdef PARTTRUE
hecke_generator_reps(partition,vector)171 INT hecke_generator_reps ( partition, vector)
172 OP partition;
173 OP vector;
174
175 /* for the given partition produces a vector of matrices, the ith
176 of which represents the ith generator s_i.
177 */
178
179 {
180 INT i,ni;
181 OP n,p,lc,mat;
182
183 /* validate parameters */
184
185 if (partition==NULL || S_O_K(partition)!=PARTITION)
186 {
187 printf("hecke_generator_reps() did not receive a partition as it was expecting!\n");
188 return(ERROR);
189 }
190
191 weight(partition,n=callocobject());
192 ni=S_I_I(n);
193 freeall(n);
194
195 /* construct and intialize a permutation which will be passed to
196 the representing routines. */
197
198 m_il_p(ni,p=callocobject());
199 for (i=0;i<ni;i++)
200 m_i_i(i+1,S_P_I(p,i));
201
202 /* encase this permutation in a linear combination list */
203
204 build_lc(p,lc=callocobject()); /* p part of lc */
205
206 /* construct the vector to build the results */
207
208 m_il_v(--ni,vector);
209
210 /* loop through all simple transpositions, obtaining representations */
211
212 for (i=0;i<ni;i++)
213 {
214 C_I_I(S_P_I(p,i),i+2);
215 C_I_I(S_P_I(p,i+1),i+1);
216
217 represent_hecke_element(partition,lc,s_v_i(vector,i));
218
219 C_I_I(S_P_I(p,i),i+1);
220 }
221
222 freeall(lc);
223 return(OK);
224 }
225 #endif /* PARTTRUE */
226
represent_hecke_element(partition,hecke,mat)227 INT represent_hecke_element (partition, hecke, mat) OP partition;
228 OP hecke;
229 OP mat;
230
231 /* Constructs the explicit (Specht) matrix representative in that
232 representation labelled by partition, of the element
233 of the hecke algebra A_{n-1} obtained by canonically mapping
234 the list of permutations from the symmetric group.
235 */
236
237 {
238 INT k;
239 INT erg = OK;
240 OP temp,e,list,std_tableaux,t,tab_list,tab_cop,go_perm,perm_cop,coeff;
241
242 /* validate parameters */
243 CTO(PARTITION,"represent_hecke_element",partition);
244 CTO(LIST,"represent_hecke_element",hecke);
245
246
247 if ( !empty_listp(hecke) )
248 {
249 CTO(MONOM,"represent_hecke_element",S_L_S(hecke));
250 CTO(PERMUTATION,"represent_hecke_element",S_MO_S(S_L_S(hecke)));
251 }
252
253 /* construct the list of standard tableaux and
254 make a matrix of the right size for the results */
255
256 std_tableaux=callocobject();
257 k=generate_standard_tableaux(partition,std_tableaux);
258 m_ilih_m(k,k,mat);
259 /* set the partition parameters */
260 set_garnir_parameters(partition);
261 /* run through the standard tableaux, acting on each with the
262 permutation list, standardising the result and entering that
263 result into the appropriate column of the matrix. */
264 for (t=std_tableaux,k=0;t!=NULL;t=S_L_N(t),k++)
265 {
266 list=callocobject(); /* to accumualte results from all perms */
267 init(LIST,list);
268 tab_list=callocobject(); /* to store results of each action */
269 for (go_perm=hecke;go_perm!=NULL;go_perm=S_L_N(go_perm))
270 {
271 tab_cop=callocobject();
272 erg += copy_tableaux(S_L_S(t),tab_cop);
273 erg += build_lc(tab_cop,tab_list); /* tab_cop part of list */
274 perm_cop=callocobject();
275 erg += copy_permutation(S_MO_S(S_L_S(go_perm)),perm_cop);
276 hecke_action_perm_on_lc(tab_list,perm_cop); /* perm_cop is freed in hecke_action_perm_on_lc */
277
278 for (temp=tab_list;temp!=NULL;temp=S_L_N(temp))
279 {
280 coeff=callocobject();
281 erg += mult_monopoly_monopoly(S_MO_K(S_L_S(go_perm)),S_MO_K(S_L_S(temp)), coeff);
282 garnir_result(S_MO_S(S_L_S(temp)),coeff,list); /* coeff is destroyed */
283 }
284 freeself(tab_list);
285 }
286 erg += freeall(tab_list);
287
288 e = callocobject();
289 erg += init(LIST,e);
290 standardise_tableau_list(list,e);
291 freeall(list);
292
293 enter_list_to_matrix(mat,k,std_tableaux,e);
294 erg += freeall(e);
295 }
296
297 free_garnir_parameters();
298 erg += freeall(std_tableaux);
299 ENDR("represent_hecke_element");
300 }
301
tex_hecke_monopoly(a)302 INT tex_hecke_monopoly(a) OP a;
303 /* to output an element as q-polynomial */
304 /* AK 201296 */
305 {
306 OP z;
307 z = a;
308 if (S_O_K(a) != MONOPOLY)
309 return tex(a);
310 while (z != NULL)
311 {
312 if (not einsp(S_MO_K(S_L_S(z))))
313 {
314 if (negeinsp(S_MO_K(S_L_S(z))))
315 fprintf(texout," - ");
316 else
317 tex (S_MO_K(S_L_S(z)));
318 }
319 fprintf (texout," q^{%ld} ",S_I_I(S_MO_S(S_L_S(z))));
320 z = S_L_N(z);
321 if (z != NULL)
322 {
323 if (posp(S_MO_K(S_L_S(z))))
324 fprintf(texout,"+");
325 }
326 }
327 return OK;
328 }
329
330
hecke_dg(part,perm,res)331 INT hecke_dg(part,perm,res) OP part,perm,res;
332 {
333 INT erg = OK;
334 OP c,d;
335 CTO(PARTITION,"hecke_dg",part);
336 CTO(PERMUTATION,"hecke_dg",perm);
337
338 c = callocobject();
339 d = callocobject();
340 erg += copy(perm,d);
341 erg += build_lc (d,c); /* d part of c */
342 erg += represent_hecke_element(part,c,res);
343 erg += freeall(c);
344 ENDR("hecke_dg");
345 }
346
build_lc(schizo,list)347 INT build_lc ( schizo, list)
348 OP schizo;
349 OP list;
350
351 /* The entered object (schizo), which is either a TABLEAUX or a PERMUTATION,
352 is converted into a linear combination of such objects - the linear
353 combination consists of one term (schizo) with MONOPOLY coefficient
354 1. schizo is incoporated into the list and should NOT be subsequently
355 freed alone.
356 */
357
358 {
359 OP mo_mp,monom;
360 INT erg = OK;
361 CTTO(TABLEAUX,PERMUTATION,"build_lc",schizo);
362 erg += construct_mo_mp((INT)0,(INT)1,mo_mp=callocobject());
363 erg += b_sk_mo(schizo,mo_mp,monom=callocobject());
364 erg += b_sn_l(monom,NULL,list);
365 ENDR("build_lc");
366 }
367
368
hecke_action_lc_on_lc(tableaux,hecke,result)369 INT hecke_action_lc_on_lc ( tableaux, hecke, result)
370 OP tableaux;
371 OP hecke;
372 OP result;
373
374 /* Applies the linear combination of hecke algebra elements to the
375 linear combination of tableaux. Neither of the inputs is changed.
376 All initialisation is taken care of, so the user just has to
377 create a list of tableaux, and a list of permutations
378 then submit it here. The result is added to result.
379 */
380
381 {
382 OP go_perm,coeff,temp,imitate,perm_cop;
383
384 /* first validate the inputs */
385
386 if (S_O_K(tableaux)!=LIST
387 || (!empty_listp(tableaux)
388 && (S_O_K(S_L_S(tableaux)) != MONOM
389 || S_O_K(S_MO_S(S_L_S(tableaux))) != TABLEAUX )))
390 {
391 error("hecke_action_lc_on_lc() did not receive a linear combination of tableaux as it was expecting!\n");
392 return(ERROR);
393 }
394
395 if (S_O_K(hecke)!=LIST
396 || (!empty_listp(hecke)
397 && (S_O_K(S_L_S(hecke)) != MONOM
398 || S_O_K(S_MO_S(S_L_S(hecke))) != PERMUTATION )))
399 {
400 error("hecke_action_lc_on_lc() did not receive a linear combination of permutations as it was expecting!\n");
401 return(ERROR);
402 }
403
404 /* if result is not already a list, then make it one */
405
406 if (S_O_K(result)!=LIST)
407 init(LIST,result);
408
409 /* return if there is nothing to process */
410
411 if (empty_listp(tableaux) || empty_listp(hecke))
412 return(OK);
413
414 set_garnir_parameters(s_t_u(S_MO_S(S_L_S(tableaux))));
415
416 /* For each element of the permutation list, make a copy of the
417 tableaux list, and act on it with a copy of the permutation.
418 Then go though the resulting list of tableaux, multiplying
419 them by the coefficient of the permutation, and accumulating
420 them to result. */
421
422 imitate=callocobject();
423 for (go_perm=hecke;go_perm!=NULL;go_perm=S_L_N(go_perm))
424 {
425 copy_list(tableaux,imitate);
426 copy_permutation(S_MO_S(S_L_S(go_perm)),perm_cop=callocobject());
427
428 hecke_action_perm_on_lc(imitate,perm_cop); /* perm_cop freed in hecke_... */
429
430 for (temp=imitate;temp!=NULL;temp=S_L_N(temp))
431 {
432 mult_monopoly_monopoly(S_MO_K(S_L_S(go_perm)),S_MO_K(S_L_S(temp)),
433 coeff=callocobject());
434 garnir_result(S_MO_S(S_L_S(temp)),coeff,result); /* coeff is destroyed */
435 }
436 freeself(imitate);
437 }
438 freeall(imitate);
439 free_garnir_parameters();
440 return(OK);
441 }
442
443
standardise_cold_tableaux_list(tableaux,result)444 INT standardise_cold_tableaux_list ( tableaux, result)
445 OP tableaux;
446 OP result;
447
448 /* Similar to the function standardise_tableau_list(), but all initialisation
449 is taken care of, so the user just has to create a list of tableaux,
450 and then submit it here. The result is added to result which, if not
451 already a list, is made into a list.
452 tableaux is unchanged by this function.
453 */
454
455 {
456 OP a,imitate;
457
458 /* first validate the input */
459
460 if (S_O_K(tableaux)!=LIST
461 || (!empty_listp(tableaux)
462 && (S_O_K(S_L_S(tableaux)) != MONOM
463 || S_O_K(S_MO_S(S_L_S(tableaux))) != TABLEAUX )))
464 {
465 printf("standardise_cold_tableaux_list() did not receive a linear combination of tableaux as it was expecting!\n");
466 return(ERROR);
467 }
468
469 /* if result is not already a list, then make it one */
470
471 if (S_O_K(result)!=LIST)
472 init(LIST,result);
473
474 /* return if there is nothing to process */
475
476 if (empty_listp(tableaux))
477 return(OK);
478
479 set_garnir_parameters(s_t_u(S_MO_S(S_L_S(tableaux))));
480 imitate=callocobject();
481
482 for (a=tableaux;a!=NULL;a=S_L_N(a))
483 {
484 set_multiplier(S_MO_K(S_L_S(a)));
485 copy_tableaux(S_MO_S(S_L_S(a)),imitate);
486 standardise_tableau(imitate,&result);
487 freeself(imitate);
488 }
489
490 freeall(imitate);
491 free_garnir_parameters();
492 return(OK);
493 }
494
495 #ifdef TABLEAUXTRUE
496
497
input_tableau(partit,tab)498 INT input_tableau ( partit, tab)
499 OP partit;
500 OP tab;
501
502 /* Requests a tableau from the user of the appropriate shape. A check
503 is made on the entries. If they are not distinct and from 1...n,
504 then ERROR is returned.
505 */
506
507
508 {
509 INT i,j,rows;
510 INT *entries;
511 OP w;
512
513 if (S_O_K(partit)!=PARTITION)
514 {
515 printf("input_tableau() did not receive a partition as it was expecting!\n");
516 return(ERROR);
517 }
518
519 weight(partit,w=callocobject());
520 entries=(INT*)SYM_calloc(S_I_I(w),sizeof(INT));
521
522 m_u_t(partit,tab);
523
524 printf("Please input tableau entries row by row, longest row first.\n");
525
526 rows=s_t_hi(tab);
527 for (i=0;i<rows;i++)
528 for (j=0;j<S_T_UII(tab,rows-1-i);j++)
529 {
530 scan(INTEGER,S_T_IJ(tab,i,j));
531 if (S_T_IJI(tab,i,j)<=S_I_I(w))
532 entries[S_T_IJI(tab,i,j)-1]++;
533 }
534
535 /* now check that there are single entries 1,2,...,weight_of_partit. */
536
537 for (i=S_I_I(w)-1;i>=0 && entries[i]==1;i--);
538 if (i<0)
539 return(OK);
540 else
541 {
542 printf("Inappropriate tableau was entered!\n");
543 return(ERROR);
544 }
545 }
546 #endif /* TABLEAUXTRUE */
547
548
input_lc_permutations(save)549 INT input_lc_permutations (save) OP save;
550
551 {
552 char resp[8];
553 OP a,b,c,perm,poly,monom,temp;
554
555 init(LIST,save);
556
557 a=callocobject();
558 b=callocobject();
559
560 do
561 {
562 fprintf(stderr,"Enter permutation (coefficient to follow):\n");
563 scan(PERMUTATION,perm=callocobject());
564 init(MONOPOLY,poly=callocobject());
565
566 do
567 {
568 fprintf(stderr,"Enter exponent: \n");
569 scan(INTEGER,a);
570 fprintf(stderr,"Enter coefficient: \n");
571 scan(INTEGER,b);
572
573 m_skn_mp(a,b,NULL,c=callocobject());
574 insert(c,poly,add_koeff,NULL);
575 fprintf(stderr,"Current term is: \n");
576 fprint(stderr,poly);
577 fprintf(stderr," * ");
578 fprintln(stderr,perm);
579
580 fprintf(stderr,"continue adding to coefficient? \n");
581 scanf("%6s",resp);
582
583 } while (resp[0]=='y');
584
585 b_sk_mo(perm,poly,monom=callocobject());
586
587 if (empty_listp(save))
588 {
589 c_l_s(save,monom);
590 }
591 else
592 {
593 b_ks_o(S_O_K(save),S_O_S(save),temp=callocobject());
594 /* c_o_s(save,NULL); */
595 c_o_k(save,EMPTY);
596 b_sn_l(monom,temp,save);
597 }
598
599 fprintf(stderr,"continue adding terms? \n");
600 scanf("%6s",resp);
601
602 } while (resp[0]=='y');
603
604 freeall(a);
605 freeall(b);
606 return(OK);
607 }
608
609
substitute_one_matrix(mat)610 INT substitute_one_matrix (mat) OP mat;
611
612 /* every entry in the matrix that is a MONOPOLY object is changed
613 an INTEGER object having the value obtained by setting q=1 in
614 the original entry. Returns an ERROR if a MATRIX is not passed.
615 */
616
617 {
618 INT i,j;
619
620 if (S_O_K(mat)!=MATRIX)
621 {
622 printf("substitute_one_matrix() did not receive a matrix as it was expecting!\n");
623 return(ERROR);
624 }
625
626 for (i=0;i<s_m_hi(mat);i++)
627 for (j=0;j<s_m_li(mat);j++)
628 {
629 if (S_O_K(S_M_IJ(mat,i,j))==MONOPOLY)
630 substitute_one_monopoly(S_M_IJ(mat,i,j));
631 }
632 return(OK);
633 }
634
635
substitute_one_monopoly(mp)636 INT substitute_one_monopoly (mp) OP mp;
637
638 /* replaces the MONOPOLY object with an INTEGER object obtained
639 by setting q=1 in the original monopoly.
640 Returns an ERROR if a MONOPOLY is not passed.
641 */
642
643 {
644 INT a=0;
645 OP temp;
646
647 if (S_O_K(mp)!=MONOPOLY)
648 {
649 error("substitute_one_monopoly() did not receive a monopoly as it was expecting!\n");
650 return(ERROR);
651 }
652
653 if (!empty_listp(mp))
654 for (temp=mp;temp!=NULL;temp=S_L_N(temp))
655 a+=S_I_I(S_MO_K(S_L_S(temp)));
656 m_i_i(a,mp);
657 return(OK);
658 }
659
660
661
662 static INT *part,*conj,*entry_list;
663 static INT *garnir_sym,*garnir_inv;
664 static INT garnir_ready=0,no_rows,no_cols,garnir_len,no_boxs;
665 static INT lcol,rcol,grow,glength,gright,gleft;
666 static OP template;
667 static OP q_mp,qm1_mp; /* monopolys storing q and q-1 */
668 static INT monopoly_ready=0;
669
670 static OP multiplier; /* multiply by this prior to accumulating to all */
671 static OP all; /* list accumulating standard terms found */
672
673
set_garnir_parameters(partition)674 static INT set_garnir_parameters (partition) OP partition;
675
676 /* From the partition received, information in a convenient form
677 is generated, ready for use by the standardisation methods.
678 It is only invoked if garnir_ready==0. This is so that if
679 every set_garnir_parameters() is, in the code, paired with
680 a free_garnir_paramters(), then we need only invoke this
681 latter routine if garnir_ready==1.
682 */
683
684 {
685 INT i,j;
686 INT erg = OK;
687
688 if (garnir_ready++)
689 return(OK);
690
691 /* validate parameters */
692 CTO(PARTITION,"set_garnir_parameters",partition);
693
694 no_rows=S_PA_LI(partition);
695 no_cols=S_PA_II(partition,no_rows-1);
696
697 part=(INT*)SYM_calloc(no_rows,sizeof(INT));
698 conj=(INT*)SYM_calloc(no_cols,sizeof(INT));
699 garnir_sym=(INT*)SYM_calloc(no_rows+1,sizeof(INT));
700 garnir_inv=(INT*)SYM_calloc(no_rows+1,sizeof(INT));
701 entry_list=(INT*)SYM_calloc(no_rows+1,sizeof(INT));
702
703 /* put the parts in weakly decresing order
704 (as the tableaux entries are indexed) */
705
706 for (i=no_boxs=0;i<no_rows;i++)
707 no_boxs += (part[i] = S_PA_II(partition,no_rows-1-i));
708
709 /* calculate conjugate partition */
710
711 for (j=no_cols-1,i=1;j>=0;j--)
712 {
713 while (i<no_rows && part[i]>j) i++;
714 conj[j]=i;
715 }
716
717 /* set up arrays that will be used to store certain permutations */
718
719 for (i=0;i<=no_rows;i++)
720 garnir_sym[i]=garnir_inv[i]=i;
721
722 garnir_len=0;
723
724 set_useful_monopolies();
725
726 ENDR("set_garnir_parameters");
727 }
728
729
free_garnir_parameters()730 static INT free_garnir_parameters ()
731
732 /* Frees the five arrays that were constructed to facilitate Garnir
733 relations. But only if garnir_ready==1.
734 */
735
736 {
737 if (!--garnir_ready)
738 {
739 SYM_free(part);
740 SYM_free(conj);
741 SYM_free(garnir_sym);
742 SYM_free(garnir_inv);
743 SYM_free(entry_list);
744 free_useful_monopolies();
745 }
746
747 return(OK);
748 }
749
750
set_useful_monopolies()751 INT set_useful_monopolies ()
752
753 /* create monopolys which store (q) and (q-1) for ready use */
754
755 {
756 OP temp;
757 if (monopoly_ready++)
758 return(OK);
759
760 q_mp=callocobject();
761 qm1_mp=callocobject();
762 temp=callocobject();
763 construct_mo_mp(1,1,q_mp);
764 construct_mo_mp(1,1,qm1_mp);
765 construct_mo_mp(0,-1,temp);
766 C_L_N(qm1_mp,temp); /* to link q and -1 */
767
768 return(OK);
769 }
770
771
free_useful_monopolies()772 INT free_useful_monopolies ()
773
774 /* Frees the monopolies created by the above.
775 But only if monopoly_ready==1.
776 */
777
778 {
779 if (!--monopoly_ready)
780 {
781 freeall(q_mp);
782 freeall(qm1_mp);
783 }
784
785 return(OK);
786 }
787
788
set_multiplier(extra)789 void set_multiplier (extra) OP extra;
790
791 /* all standard tableaux that are now found are added to the list
792 after their coefficients have been multiplied by extra
793 (which will usually be a MONOPOLY object).
794 */
795
796 {
797 multiplier=extra;
798 }
799
800
hecke_action(tableau,permutation,list)801 int hecke_action ( tableau, permutation, list)
802 OP tableau;
803 OP permutation;
804 OP list;
805
806 /* The permutation acts upon the tableau to produce a
807 monom list, each element of which consists of a tableau
808 and a monopoly coefficient.
809 Requires that set_garnir_parameters() has been invoked.
810 */
811
812 {
813 OP perm_cop,tab_cop,tab_mp,tab_mo;
814
815 /* make a copy of the original permutation so that we can
816 manipulate it */
817
818 copy_permutation(permutation,perm_cop=callocobject());
819
820 /* and form a list with the tableau as only element */
821
822 copy_tableaux(tableau,tab_cop=callocobject());
823 construct_mo_mp(0,1,tab_mp=callocobject());
824 b_sk_mo(tab_cop,tab_mp,tab_mo=callocobject());
825 b_sn_l(tab_mo,NULL,list);
826
827 hecke_action_perm_on_lc(list,perm_cop); /* perm_cop freed in hecke_action_perm_on_lc */
828 }
829 static INT axel_ll,axel_kk;
830
hecke_action_perm_on_lc(tableaux,permutation)831 INT hecke_action_perm_on_lc ( tableaux, permutation)
832 OP tableaux;
833 OP permutation;
834
835 /* Applies the hecke algebra permutation to the linear combination
836 of tableaux.
837 This list is updated with the result and the permutation is
838 freed. There is no attempt to collect terms in the result.
839 Requires that set_garnir_parameters() has been invoked.
840 An ERROR may be generated if permutation is from a group bigger
841 than the entries from tableaux.
842 */
843
844 {
845 INT i,j,k,ll;
846 INT trev_lo_col,lo_row,hi_col,hi_row;
847 OP tab,temp,new,coeff,monom,ext;
848 /*
849 println(tableaux);
850 println(permutation);
851 */
852
853 if (empty_listp(tableaux))
854 {
855 freeall(permutation);
856 return(OK);
857 }
858
859 /* ensure that set_garnir_parameters() has been invoked */
860
861 set_garnir_parameters(s_t_u(S_MO_S(S_L_S(tableaux))));
862
863 while (1)
864 { /* look for a right factor s_k in reduced expression for permutation */
865
866 for (k=S_P_LI(permutation)-1;k>0
867 && S_P_II(permutation,k)>S_P_II(permutation,k-1);k--);
868
869 if (!k) /* none present */
870 break;
871
872 /* now apply s_k to list of tableaux */
873
874 temp=tableaux;
875 while (temp!=NULL)
876 {
877 tab=S_MO_S(S_L_S(temp));
878 /* println(tab); */
879 lo_row= -1;
880 hi_row= -1;
881 /* printf("1\n"); */
882
883 /* trawl through positions of tableau looking for k & k+1 */
884
885 for (j=0;j<no_cols;j++)
886 {
887 /*printf("1.2 no_cols=%d j=%d trev_lo_col=%d\n",no_cols,j,trev_lo_col);*/
888 axel_ll=ll=trev_lo_col; /* do not remove
889 this is to prevent optimizer
890 from generating wrong code on btm2x5 */
891 axel_ll=ll=lo_row; /* do not remove
892 this is to prevent optimizer
893 from generating wrong code on btm2x5 */
894 axel_kk=ll=hi_col; /* do not remove
895 this is to prevent optimizer
896 from generating wrong code on btm2x5 */
897 for (i=0;i<conj[j];i++)
898 {
899 /*
900 printf("2 i=%d conj[j]=%d trev_lo_col=%d\n",i,conj[j],trev_lo_col);
901 println(tab);
902 */
903 axel_kk=ll=hi_col; /* do not remove
904 this is to prevent optimizer
905 from generating wrong code on btm2x5 */
906 if (S_T_IJI(tab,i,j) == k+1)
907 {
908 if (lo_row> -1) /* position of k already located */
909 {
910 /* printf("3 lo_row=%d trev_lo_col=%d k=%d\n",lo_row,trev_lo_col,k);*/
911 /* enact the tranposition; coefficient is unchanged */
912
913 /* printf("1 i=%d j=%d lo_row=%d trev_lo_col=%d\n",i,j,lo_row,trev_lo_col); */
914 C_I_I(S_T_IJ(tab,lo_row,trev_lo_col),k+1);
915 C_I_I(S_T_IJ(tab,i,j),k);
916
917 temp=S_L_N(temp);
918 goto there; /* end processing of current tableau */
919 }
920 else
921 {
922 hi_row=i;
923 /* printf("4\n");*/
924 hi_col=j;
925 }
926 }
927 else if (S_T_IJI(tab,i,j)==k)
928 {
929 axel_kk=ll=hi_col; /* do not remove
930 this is to prevent optimizer
931 from generating wrong code on btm2x5 */
932 axel_ll=ll=hi_row; /* do not remove
933 this is to prevent optimizer
934 from generating wrong code on btm2x5 */
935 if (hi_row > -1) /* position of k+1 already located */
936 {
937 /*printf("5\n");*/
938 /* form a new element in the list, obtained by
939 simple tranposition and multiply coeff by q. */
940
941 new=callocobject();
942 copy_tableaux(tab,new);
943 C_I_I(S_T_IJ(new,hi_row,hi_col),k);
944 C_I_I(S_T_IJ(new,i,j),k+1);
945 /*printf("2 i=%d j=%d hi_row=%d hi_col=%d\n",i,j,hi_row,hi_col);*/
946 mult_monopoly_monopoly(q_mp,S_MO_K(S_L_S(temp)),
947 coeff=callocobject());
948 b_sk_mo(new,coeff,monom=callocobject());
949 b_sn_l(monom,S_L_N(temp),ext=callocobject());
950 C_L_N(temp,ext);
951
952 /* multiply old coefficient by q-1 */
953
954 mult_apply_monopoly(qm1_mp,S_MO_K(S_L_S(temp)));
955
956 temp=S_L_N(ext);
957 goto there; /* end processing of current tableau */
958 }
959 else
960 {
961 /*printf("6 i=%d j=%d\n",i,j);*/
962 lo_row=i;
963 trev_lo_col=j;
964 /*printf("6 lo_row=%d trev_lo_col=%d\n",lo_row,trev_lo_col);*/
965 }
966 axel_ll=ll=trev_lo_col; /* do not remove
967 this is to prevent optimizer
968 from generating wrong code on btm2x5 */
969 }
970 axel_ll=ll=trev_lo_col; /* do not remove
971 this is to prevent optimizer
972 from generating wrong code on btm2x5 */
973 }
974 axel_ll=ll=trev_lo_col; /* do not remove
975 this is to prevent optimizer
976 from generating wrong code on btm2x5 */
977 }
978
979 /* if we get here then we have not found both k & k+1 */
980
981 fprintf(stderr,"Incompatible permutation in hecke_action_perm_on_lc()\n");
982 return(ERROR);
983
984 there:
985 ;
986 }
987 /* need to change the permutation */
988
989 i=S_P_II(permutation,k-1);
990 C_I_I(S_P_I(permutation,k-1),S_P_II(permutation,k));
991 C_I_I(S_P_I(permutation,k),i);
992
993 }
994 /* free the permutation since it has been corrupted */
995
996 /*printf("se:");
997 println(tableaux);*/
998 freeall(permutation);
999 free_garnir_parameters();
1000 return(OK);
1001 }
1002
1003
find_non_rowstandard_pos(tableau,r,c)1004 INT find_non_rowstandard_pos ( tableau, r, c) OP tableau; INT *r; INT *c;
1005
1006 /* locates the row and column of an entry at which that to its right
1007 is smaller. Requires that set_garnir_parameters() has been invoked. */
1008
1009 {
1010 INT i,j,l,e1,e2;
1011
1012 for (i=0;i<no_rows;i++)
1013 {
1014 l=part[i];
1015
1016 e1=S_T_IJI(tableau,i,0);
1017 for (j=1;j<l;j++)
1018 {
1019 if (e1 > (e2=S_T_IJI(tableau,i,j)) )
1020 {
1021 *r=i,*c=j-1;
1022 return(OK);
1023 }
1024 e1=e2;
1025 }
1026 }
1027
1028 /* no row-nonstandardness */
1029
1030 *r= *c= -1;
1031 return(OK);
1032 }
1033
1034
columns_standardise_tableau(tableau,sig)1035 INT columns_standardise_tableau ( tableau,sig) OP tableau; INT *sig;
1036
1037 /* sorts the columns of the TABLEAUX tableau into standard order.
1038 Requires that set_garnir_parameters() has been invoked. */
1039
1040 {
1041 INT c;
1042
1043 for (c=0;c<no_cols;c++)
1044 column_standardise_tableau(tableau,c,sig);
1045
1046 return(OK);
1047 }
1048
1049
column_standardise_tableau(tableau,col,sig)1050 INT column_standardise_tableau ( tableau, col, sig) OP tableau; INT col; INT *sig;
1051
1052 /* sorts only the (col)th column of the TABLEAUX tableau into
1053 standard order. The length of the permutation (in terms of
1054 position transpositions) is added to *sig.
1055 Requires that set_garnir_parameters() has been invoked. */
1056
1057 {
1058 INT i,k,e1,e2,r1,r2,s=0;
1059
1060 r1=0;
1061 r2=conj[col];
1062
1063 /* search for an entry smaller than that above */
1064
1065 e1=S_T_IJI(tableau,r1,col);
1066 for (i=r1+1;i<r2;i++)
1067 {
1068 if (e1 > (e2=S_T_IJI(tableau,i,col)))
1069 {
1070 /* we've found such an entry: now see how far it can be
1071 moved up the column */
1072
1073 C_I_I(S_T_IJ(tableau,i,col),e1);
1074
1075 for (k=i-2;k>=r1 && e2<S_T_IJI(tableau,k,col);k--)
1076 C_I_I(S_T_IJ(tableau,k+1,col),S_T_IJI(tableau,k,col));
1077
1078 /* so it can be moved up i-k-1 positions (to k+1) */
1079
1080 C_I_I(S_T_IJ(tableau,++k,col),e2);
1081 s+=i-k;
1082
1083 }
1084 else
1085 e1=e2;
1086 }
1087
1088 *sig+=s;
1089 return(OK);
1090 }
1091
1092
standardise_tableau_list(list,expression)1093 static int standardise_tableau_list ( list, expression) OP list;
1094 OP expression;
1095
1096 /* Expresses the monomial list of tableaux with monopoly coefficients
1097 in terms of a list of standard tableaux with monopoly coefficients
1098 Requires that set_garnir_parameters() has been invoked.
1099 */
1100
1101 {
1102 OP a;
1103
1104 for (a=list;a!=NULL;a=S_L_N(a))
1105 {
1106 set_multiplier(S_MO_K(S_L_S(a)));
1107 standardise_tableau(S_MO_S(S_L_S(a)),expression);
1108 }
1109 }
1110
1111
standardise_tableau(tableau,expression)1112 static int standardise_tableau ( tableau, expression) OP tableau;
1113 OP expression;
1114
1115 /* Expresses the tableau in terms of a list of standard tableaux
1116 with polynomial coefficients. tableau is not freed by this
1117 function, but its entries may change.
1118 Requires that set_garnir_parameters() has been invoked,
1119 and that multiplier has been set.
1120 */
1121
1122 {
1123
1124 INT swaps=0;
1125 OP overall;
1126
1127 all=expression;
1128
1129 columns_standardise_tableau(tableau,&swaps);
1130 find_non_rowstandard_pos(tableau,&grow,&lcol);
1131
1132 if (grow<0)
1133 {
1134 overall=callocobject();
1135 construct_mo_mp(0,((swaps&1) ? -1 : 1),overall);
1136 mult_apply_monopoly(multiplier,overall);
1137 garnir_result(tableau,overall,all); /* overall is destroyed */
1138 }
1139 else
1140 garnir_juggle(tableau,(INT)0,(INT)((swaps&1) ? -1 : 1));
1141
1142
1143 }
1144
1145
garnir_juggle(tableau,power,coeff)1146 static int garnir_juggle ( tableau, power, coeff) OP tableau; INT power; INT coeff;
1147
1148 /* Recursive function which is passed a non-standard tableau,
1149 together with its coefficient in the form of
1150 coeff * q^power.
1151 (usually coeff is +1 or -1).
1152 In one invocation, a single Garnir relation is performed:
1153 those which result that are standard are added to the list
1154 of tableaux; those which are non-standard are resubmitted to
1155 this function.
1156 The tableau that is passed is assumed to be standard in columns
1157 AND nonstandard in rows. It is ALSO assumed that the non-standard
1158 position has already been stored in (grow,lcol).
1159 tableau is unchanged by this function,
1160 Requires that set_garnir_parameters() has been invoked.
1161 */
1162
1163 {
1164 INT p,swaps,lcoll,rcoll;
1165 OP store,temp,overall;
1166
1167 template=tableau;
1168
1169 /* obtain lengths of garnir parts and stores entries of these parts */
1170
1171 glength=conj[lcol]+1;
1172 gright=grow+1;
1173 gleft=glength-gright;
1174 rcoll=rcol=(lcoll=lcol)+1;
1175
1176 for (p=0;p<gright;p++)
1177 entry_list[p]=S_T_IJI(tableau,p,rcol);
1178 for (;p<glength;p++)
1179 entry_list[p]=S_T_IJI(tableau,p-1,lcol);
1180
1181 /* start a list for garnir_generate() to put tableaux and their
1182 coeffs into. the final list address is kept in store, so that
1183 the list can be freed later (children is a global variable that
1184 will be overwritten). */
1185
1186 children=callocobject();
1187 init(LIST,children);
1188
1189 garnir_generate(glength,glength-1);
1190 store=children;
1191
1192 /* now order the entries in the two changed columns of each tableau */
1193
1194 for (temp=children;S_L_S(temp)!=NULL;temp=S_L_N(temp))
1195 {
1196 swaps=0;
1197 column_standardise_tableau(S_MO_S(S_L_S(temp)),lcoll,&swaps);
1198 column_standardise_tableau(S_MO_S(S_L_S(temp)),rcoll,&swaps);
1199 find_non_rowstandard_pos(S_MO_S(S_L_S(temp)),&grow,&lcol);
1200
1201 if (grow<0)
1202 { /* then tableau is standard and must be appended to the list */
1203
1204 construct_mo_mp(
1205 power+S_I_I(S_MO_K(S_L_S(temp))),
1206 (swaps+S_I_I(S_MO_K(S_L_S(temp))))&1 ? coeff : -coeff,
1207 overall=callocobject());
1208 mult_apply_monopoly(multiplier,overall);
1209
1210 garnir_result(S_MO_S(S_L_S(temp)),overall,all); /* overall is destroyed */
1211 }
1212 else
1213 { /* it must be resubmitted */
1214
1215 garnir_juggle(S_MO_S(S_L_S(temp)),power+S_I_I(S_MO_K(S_L_S(temp))),
1216 (swaps+S_I_I(S_MO_K(S_L_S(temp))))&1 ? coeff : -coeff);
1217 }
1218 }
1219
1220 freeall(store);
1221 }
1222
1223
garnir_generate(head,wag)1224 static int garnir_generate ( head, wag) INT head; INT wag;
1225
1226 /* Recursive function which creates all the terms in the Garnir relation,
1227 together with the lengths of the permutations required.
1228 For the purpose of eliminating repetitions, a canonical reduced
1229 expression for permutations is employed. This is of the form:
1230 s_0 s_1s_0 s_2s_1s_0 s_3s_2s_1s_0 s_4s_3s_2s_1s_0 ....,
1231 which consists of syllables of increasing first index, a syllable
1232 being of the form s_ks_{k-1}s_{k-2}...s_0 where 0 <= l <= k.
1233 The permutations act on the right and are built up in their
1234 reduced form from right to left.
1235 The current permutation (which is stored in garnir_sym; and its
1236 inverse in garnir_inv) has most recent index as wag and the index
1237 of the most recently completed syllable as head. Its length is
1238 given by garnir_len.
1239 This routine tests all possible transpositions which give a
1240 standard Garnir term and which adjoin to the left of the current
1241 permutation to give another in canonical form.
1242 Requires that set_garnir_parameters() has been invoked.
1243 */
1244
1245 {
1246 INT i,j,p,s;
1247 OP pl,mon,child,ext;
1248
1249 garnir_len++; /* all found permutations will have length 1 more */
1250
1251 for (i=0;i<gright;i++)
1252 {
1253 s=garnir_sym[i];
1254
1255 if ( (s<wag || (s==wag+1 && s<head))
1256
1257 /* so that the permutation will be canonically represented */
1258
1259 && (j=garnir_inv[s+1]) >= gright)
1260
1261 /* s is in the right column, s+1 is in the left */
1262
1263 { /* swap the entries in sym & inv to keep track of permutation */
1264
1265 garnir_inv[garnir_sym[i]=s+1]=i;
1266 garnir_inv[garnir_sym[j]=s]=j;
1267
1268 /* place the entries in the tableau in the corresponding way */
1269
1270 child=callocobject();
1271 copy_tableaux(template,child);
1272
1273 for (p=0;p<gright;p++)
1274 C_I_I(S_T_IJ(child,p,rcol),entry_list[garnir_sym[p]]);
1275 for (;p<glength;p++)
1276 C_I_I(S_T_IJ(child,p-1,lcol),entry_list[garnir_sym[p]]);
1277
1278 /* store tableau with its length in the list */
1279
1280 m_i_i(garnir_len,pl=callocobject());
1281 b_sk_mo(child,pl,mon=callocobject());
1282 b_sn_l(mon,children,ext=callocobject());
1283 children=ext;
1284
1285 /* resubmit with the updated permutation's info */
1286
1287 if (s<wag)
1288 garnir_generate(wag,s);
1289 else
1290 garnir_generate(head,wag+1);
1291
1292 /* remove permutation */
1293
1294 garnir_inv[garnir_sym[i]=s]=i;
1295 garnir_inv[garnir_sym[j]=s+1]=j;
1296 }
1297 }
1298
1299 garnir_len--; /* restores value */
1300 }
1301
1302
garnir_result(tableau,mp_coeff,acc_list)1303 static int garnir_result ( tableau, mp_coeff, acc_list) OP tableau;
1304 OP mp_coeff;
1305 OP acc_list;
1306
1307 /* Adds mp_coeff * tableau to our standard list: acc_list.
1308 tableau is unchanged, and copied when necessary. mp_coeff is
1309 destroyed. The list is maintained
1310 in lexicographic order (reading across rows, then top to bottom).
1311 */
1312
1313 {
1314 OP a,b,term;
1315 OP t,temp;
1316 INT co;
1317
1318 if (empty_listp(acc_list))
1319 {
1320 t=callocobject();
1321 copy_tableaux(tableau,t);
1322 term=callocobject();
1323 b_sk_mo(t,mp_coeff,term);
1324 c_l_s(acc_list,term); /* assuming that the self exists
1325 for an empty list */
1326 }
1327 else
1328 { /* look for tableau in list */
1329
1330 for (a=acc_list,b=NULL;
1331 a!=NULL && (co=comp_tableaux(S_MO_S(S_L_S(a)),tableau))<0;
1332 a=S_L_N(b=a));
1333
1334 if (a==NULL || co>0) /* not present */
1335 {
1336 t=callocobject();
1337 copy_tableaux(tableau,t);
1338 term=callocobject();
1339 b_sk_mo(t,mp_coeff,term);
1340
1341 if (b==NULL) /* insert new first term (before a) */
1342 {
1343 b_ks_o(S_O_K(acc_list),S_O_S(acc_list),temp=callocobject());
1344 /* c_o_s(acc_list,NULL); */
1345 c_o_k(acc_list,EMPTY);
1346 b_sn_l(term,temp,acc_list);
1347 }
1348 else /* insert new term between b and a */
1349 {
1350 b_sn_l(term,a,temp=callocobject());
1351 C_L_N(b,temp);
1352 }
1353 }
1354 else /* term is present - must just add coefficients */
1355 {
1356 insert(mp_coeff,S_MO_K(S_L_S(a)),add_koeff,NULL);
1357 }
1358 }
1359 }
1360
1361
enter_list_to_matrix(matrix,column,standard,express)1362 INT enter_list_to_matrix ( matrix, column, standard, express) OP matrix;
1363 INT column;
1364 OP standard;
1365 OP express;
1366
1367 /* express is an ordered list of standard tableaux with monopoly
1368 coefficients. this expression is used to construct a column
1369 of the matrix, by comparing the tableaux with the list of standard
1370 tableaux.
1371 For those tableaux that are not present in the list, or have 0
1372 coefficient, the column gets an INTEGER object with value 0.
1373 */
1374
1375 {
1376 INT r;
1377
1378 /* account for an empty expression */
1379
1380 if (empty_listp(express))
1381 express=NULL;
1382
1383 /* find first non_zero term */
1384
1385 while (express!=NULL && empty_listp(S_MO_K(S_L_S(express))))
1386 express=S_L_N(express);
1387
1388 for (r=0; standard!=NULL; standard=S_L_N(standard),r++)
1389 {
1390 if ( express == NULL
1391 || comp_tableaux(S_L_S(standard),S_MO_S(S_L_S(express))) )
1392
1393 m_i_i(0L,S_M_IJ(matrix,r,column));
1394 else
1395 { /* need to transfer the coefficient across */
1396
1397 copy(S_MO_K(S_L_S(express)),S_M_IJ(matrix,r,column));
1398
1399 /* now look for next non-zero entry */
1400
1401 do
1402 {
1403 express=S_L_N(express);
1404 } while (express!=NULL && empty_listp(S_MO_K(S_L_S(express))));
1405 }
1406 }
1407 }
1408
1409
construct_mo_mp(power,coeff,mo_po)1410 static INT construct_mo_mp ( power, coeff, mo_po)
1411 INT power;
1412 INT coeff;
1413 OP mo_po;
1414
1415 /* Constructs a monopoly object representing the 1-term, 1-variable
1416 polynomial: coeff * x^power.
1417 */
1418
1419 {
1420 OP p,c;
1421 INT erg = OK;
1422
1423 p=callocobject();
1424 c=callocobject();
1425 M_I_I(power,p);
1426 M_I_I(coeff,c);
1427 erg += b_skn_mp(p,c,NULL,mo_po);
1428 ENDR("internal hiccup.c:construct_mo_mp");
1429 }
1430
1431
1432 #ifdef UNDEF
memory_check(query)1433 memory_check (query) void *query;
1434
1435 /* Exits with an error message if the passed item is NULL: presumably
1436 this results from a memory allocation when none is left.
1437 */
1438
1439 {
1440 if (query==NULL)
1441 {
1442 printf("Memory error? None left? Exiting!\n");
1443 exit(0);
1444 }
1445 }
1446 #endif
1447
1448 /********************************************************************
1449 ********************************************************************
1450 ********************************************************************
1451
1452 HICCUP routines to calculate explicit representation matrices
1453 of the Hecke algebra of type A in the case where q is a root
1454 of unity: but only for two-rowed cases.
1455
1456 Programmed by Trevor Welsh, Bayreuth, November 1995.
1457
1458 ********************************************************************
1459 ********************************************************************
1460 ********************************************************************/
1461
1462
1463
root_dimension(partition,p_root,dim)1464 INT root_dimension (partition, p_root, dim)
1465 OP partition;
1466 OP p_root;
1467 OP dim;
1468
1469 /* calculates the dimension of the irreducible representation
1470 of the Hecke algebra of type A labelled by partition, at
1471 a primitive (p_root)th of unity. Uses Trevvie's character formula.
1472 */
1473
1474 {
1475 OP parti,neg,hold,vec;
1476 INT r1,r2,no_rows,row1,row2,kappa,o_root;
1477
1478 /* validate parameters */
1479
1480 if (partition==NULL || S_O_K(partition)!=PARTITION)
1481 {
1482 printf("root_dimension() did not receive a partition as it was expecting!\n");
1483 return(ERROR);
1484 }
1485
1486 o_root=S_I_I(p_root);
1487 no_rows=S_PA_LI(partition);
1488
1489 if (o_root<1)
1490 {
1491 printf("ridiculous root of unity!\n");
1492 return(ERROR);
1493 }
1494
1495 if (o_root>1 && no_rows>2)
1496 {
1497 printf("sorry, can only deal with partitions with length 2!\n");
1498 return(ERROR);
1499 }
1500
1501 r1=row1 = no_rows>0 ? S_PA_II(partition,no_rows-1) : 0;
1502 r2=row2 = no_rows>1 ? S_PA_II(partition,no_rows-2) : 0;
1503
1504 if ( (row1+1-row2)%o_root == 0 ) /* Specht module is irreducible */
1505 {
1506 dimension_partition(partition,dim);
1507 }
1508 else
1509 {
1510 m_il_nv(2L,vec=callocobject());
1511 b_ks_pa(VECTOR,vec,parti=callocobject());
1512 neg=callocobject();
1513 hold=callocobject();
1514
1515 m_i_i(0L,hold);
1516 m_i_i(0L,neg);
1517
1518 while (r2>=0)
1519 {
1520 C_I_I(s_pa_i(parti,1L),r1);
1521 C_I_I(s_pa_i(parti,0L),r2);
1522
1523 dimension_partition(parti,hold);
1524 #if DUMP==1
1525 printf("+");
1526 print(hold);
1527 #endif
1528 add_apply(hold,dim);
1529
1530 r1+=o_root;
1531 r2-=o_root;
1532 }
1533
1534
1535 kappa=(row1-row2)/o_root+1;
1536 r2=row1+1-kappa*o_root;
1537 r1=row1+row2-r2;
1538
1539 while (r2>=0)
1540 {
1541 C_I_I(s_pa_i(parti,1L),r1);
1542 C_I_I(s_pa_i(parti,0L),r2);
1543
1544 dimension_partition(parti,hold);
1545 #if DUMP==1
1546 printf("-");
1547 print(hold);
1548 #endif
1549 add_apply(hold,neg);
1550
1551 r1+=o_root;
1552 r2-=o_root;
1553 }
1554
1555 #if DUMP==1
1556 printf("\n");
1557 #endif
1558
1559 addinvers_apply(neg);
1560 add_apply(neg,dim);
1561
1562 freeall(neg);
1563 freeall(hold);
1564 freeall(parti);
1565 }
1566 return(OK);
1567 }
1568
1569
generate_root_tableaux(partition,p_root,std)1570 INT generate_root_tableaux ( partition, p_root, std)
1571 OP partition;
1572 OP p_root;
1573 OP std;
1574
1575 /* generates all the root standard tableaux for the partition,
1576 by generating all standard tableaux and plucking from the list.
1577 returns the number of standard tableaux, else ERROR.
1578 */
1579
1580 {
1581 OP temp,bad,good,top_bad;
1582 OP last,n;
1583 INT count=0;
1584
1585 /* validate parameters */
1586
1587 if (partition==NULL || S_O_K(partition)!=PARTITION)
1588 {
1589 printf("generate_root_tableaux() did not receive a partition as it was expecting!\n");
1590 return(ERROR);
1591 }
1592
1593 if (S_PA_LI(partition)>2)
1594 {
1595 printf("sorry, can only deal with partitions with length 2!\n");
1596 return(ERROR);
1597 }
1598
1599 if (S_I_I(p_root)<1)
1600 {
1601 printf("ridiculous root of unity!\n");
1602 return(ERROR);
1603 }
1604
1605 set_root_parameters(partition,p_root);
1606
1607 /* obtain S_n standard tableaux for partition. trawl through
1608 these, retaining those which are root standard. */
1609
1610 weight(partition,n=callocobject());
1611 last_partition(n,last=callocobject());
1612 kostka_tab(partition,last,std);
1613
1614 freeall(n);
1615 freeall(last);
1616
1617
1618 if (!empty_listp(std))
1619 {
1620 /* start at top of list and look for first root standard tableaux */
1621
1622 for (temp=std;
1623 temp!=NULL && find_non_root_standard_pos(S_L_S(temp))>=0;
1624 temp=S_L_N(bad=temp));
1625
1626 if (temp!=std)
1627 { /* need to release non root standard tableaux, and to
1628 make std point to the first standard. */
1629
1630 if (temp!=NULL)
1631 {
1632 C_L_N(bad,NULL);
1633 b_ks_o(S_O_K(temp),S_O_S(temp),std); /* this frees self of std */
1634 C_O_K(temp,EMPTY);
1635 freeall(temp);
1636 temp=std;
1637 }
1638 else
1639 { /* need to make std into an empty list: the init() routine
1640 also frees the previous list */
1641
1642 init(LIST,std);
1643 }
1644 }
1645
1646 while (temp!=NULL)
1647 {
1648 /* go through list looking for non root standard, and
1649 counting standard tableaux. */
1650
1651 for (temp=S_L_N(good=temp),count++;
1652 temp!=NULL && find_non_root_standard_pos(S_L_S(temp))<0;
1653 temp=S_L_N(good=temp),count++);
1654
1655 /* good contains previous standard, temp non-standard */
1656
1657 if (temp!=NULL)
1658 {
1659 top_bad=temp;
1660
1661 /* now go through non root standard tableaux */
1662
1663 for (temp=S_L_N(bad=temp);
1664 temp!=NULL && find_non_root_standard_pos(S_L_S(temp))>=0;
1665 temp=S_L_N(bad=temp));
1666
1667 /* join the standard one found (temp) with the previous
1668 standard list, and eliminate the intervening tableaux. */
1669
1670 C_L_N(good,temp);
1671 C_L_N(bad,NULL);
1672 freeall(top_bad);
1673 }
1674 }
1675 }
1676
1677
1678 free_root_parameters();
1679 return(count);
1680 }
1681
1682
hecke_root_generator_reps(partition,p_root,vector)1683 INT hecke_root_generator_reps ( partition, p_root, vector)
1684 OP partition;
1685 OP p_root;
1686 OP vector;
1687
1688 /* for the given partition produces a vector of matrices, the ith
1689 of which represents the ith generator s_i.
1690 */
1691
1692 {
1693 INT i,ni;
1694 OP n,p,lc,mat;
1695
1696 /* validate parameters */
1697
1698 if (partition==NULL || S_O_K(partition)!=PARTITION)
1699 {
1700 error("hecke_generator_reps() did not receive a partition as it was expecting!\n");
1701 return(ERROR);
1702 }
1703
1704 if (S_I_I(p_root)<1)
1705 {
1706 error("ridiculous root of unity!\n");
1707 return(ERROR);
1708 }
1709
1710 weight(partition,n=callocobject());
1711 ni=S_I_I(n);
1712 freeall(n);
1713
1714 /* construct and intialize a permutation which will be passed to
1715 the representing routines. */
1716
1717 m_il_p(ni,p=callocobject());
1718 for (i=0;i<ni;i++)
1719 m_i_i(i+1,S_P_I(p,i));
1720
1721 /* encase this permutation in a linear combination list */
1722
1723 build_lc(p,lc=callocobject()); /* p part of lc */
1724
1725 /* construct the vector to build the results */
1726
1727 m_il_v(--ni,vector);
1728
1729 /* loop through all simple transpositions, obtaining representations */
1730
1731 for (i=0;i<ni;i++)
1732 {
1733 C_I_I(S_P_I(p,i),i+2);
1734 C_I_I(S_P_I(p,i+1),i+1);
1735
1736 root_represent_hecke_action(partition,p_root,lc,s_v_i(vector,i));
1737
1738 C_I_I(S_P_I(p,i),i+1);
1739 }
1740
1741 freeall(lc);
1742 return(OK);
1743 }
1744
1745
root_represent_hecke_action(partition,p_root,hecke,mat)1746 INT root_represent_hecke_action (partition, p_root, hecke, mat)
1747 OP partition;
1748 OP p_root;
1749 OP hecke;
1750 OP mat;
1751
1752
1753 /* Constructs the explicit matrix representative in that representation
1754 labelled by partition at p_root of unity, of the element of
1755 the hecke algebra A_{n-1} obtained by canonically mapping
1756 the linear combination of permutations from the symmetric group.
1757 */
1758
1759 {
1760 INT k;
1761 OP temp,e,list,std_tableaux,t,tab_list,tab_cop,go_perm,perm_cop,coeff;
1762
1763 /* validate parameters */
1764
1765 if (partition==NULL || S_O_K(partition)!=PARTITION)
1766 {
1767 printf("root_represent_hecke_action() did not receive a partition as it was expecting!\n");
1768 return(ERROR);
1769 }
1770
1771 if (S_O_K(hecke)!=LIST
1772 || (!empty_listp(hecke)
1773 && (S_O_K(S_L_S(hecke)) != MONOM
1774 || S_O_K(S_MO_S(S_L_S(hecke))) != PERMUTATION )))
1775 {
1776 printf("root_represent_hecke_element() did not receive a linear combination of permutations as it was expecting!\n");
1777 return(ERROR);
1778 }
1779
1780 if (S_I_I(p_root)<1)
1781 {
1782 printf("ridiculous root of unity!\n");
1783 return(ERROR);
1784 }
1785
1786 /* construct the list of standard tableaux and
1787 make a matrix of the right size for the results */
1788
1789 std_tableaux=callocobject();
1790 k=generate_root_tableaux(partition,p_root,std_tableaux);
1791 m_ilih_m(k,k,mat);
1792
1793 /* set the partition parameters */
1794
1795 set_garnir_parameters(partition);
1796 set_root_parameters(partition,p_root);
1797
1798 /* run through the standard tableaux, acting on each with the
1799 permutation, standardising the result and entering that
1800 result into the appropriate column of the matrix. */
1801
1802 for (t=std_tableaux,k=0;t!=NULL;t=S_L_N(t),k++)
1803 {
1804 list=callocobject(); /* to accumualte results from all perms */
1805 init(LIST,list);
1806 tab_list=callocobject(); /* to store results of each action */
1807 for (go_perm=hecke;go_perm!=NULL;go_perm=S_L_N(go_perm))
1808 {
1809 copy_tableaux(S_L_S(t),tab_cop=callocobject());
1810 build_lc(tab_cop,tab_list); /* tab_cop part of tab_list */
1811
1812 copy_permutation(S_MO_S(S_L_S(go_perm)),perm_cop=callocobject());
1813
1814 hecke_action_perm_on_lc(tab_list,perm_cop); /* perm_cop freed in hecke_action_perm_on_lc */
1815
1816 for (temp=tab_list;temp!=NULL;temp=S_L_N(temp))
1817 {
1818 mult_monopoly_monopoly(S_MO_K(S_L_S(go_perm)),S_MO_K(S_L_S(temp)),
1819 coeff=callocobject());
1820 garnir_result(S_MO_S(S_L_S(temp)),coeff,list);
1821 }
1822 freeself(tab_list);
1823 }
1824 freeall(tab_list);
1825
1826 e = callocobject();
1827 init(LIST,e);
1828 root_standardise_tableau_list(list,e);
1829 freeall(list);
1830
1831 enter_list_to_matrix(mat,k,std_tableaux,e);
1832 freeall(e);
1833 }
1834
1835 free_root_parameters();
1836 free_garnir_parameters();
1837
1838 freeall(std_tableaux);
1839 return(OK);
1840 }
1841
1842
root_standardise_cold_tableaux_list(tableaux,p_root,result)1843 INT root_standardise_cold_tableaux_list (tableaux, p_root, result)
1844 OP tableaux;
1845 OP p_root;
1846 OP result;
1847
1848 /* Similar to the function root_standardise_tableau_list(),
1849 but all initialisation
1850 is taken care of, so the user just has to create a list of tableaux,
1851 and then submit it here. The result is added to result which, if not
1852 already a list, is made into a list.
1853 tableaux is unchanged by this function.
1854 */
1855
1856 {
1857 OP a,imitate;
1858
1859 /* first validate the input */
1860
1861 if (S_O_K(tableaux)!=LIST
1862 || (!empty_listp(tableaux)
1863 && (S_O_K(S_L_S(tableaux)) != MONOM
1864 || S_O_K(S_MO_S(S_L_S(tableaux))) != TABLEAUX )))
1865 {
1866 printf("hecke_action_lc_on_lc() did not receive a linear combination of tableaux as it was expecting!\n");
1867 return(ERROR);
1868 }
1869
1870 if (S_PA_LI(s_t_u(S_MO_S(S_L_S(tableaux))))>2)
1871 {
1872 printf("sorry, can only deal with tableaux with less than 2 rows!\n");
1873 return(ERROR);
1874 }
1875
1876 if (S_I_I(p_root)<1)
1877 {
1878 printf("ridiculous root of unity!\n");
1879 return(ERROR);
1880 }
1881
1882 /* if result is not already a list, then make it one */
1883
1884 if (S_O_K(result)!=LIST)
1885 init(LIST,result);
1886
1887 /* return if there is nothing to process */
1888
1889 if (empty_listp(tableaux))
1890 return(OK);
1891
1892 set_garnir_parameters(s_t_u(S_MO_S(S_L_S(tableaux))));
1893 set_root_parameters(s_t_u(S_MO_S(S_L_S(tableaux))),p_root);
1894 imitate=callocobject();
1895
1896 for (a=tableaux;a!=NULL;a=S_L_N(a))
1897 {
1898 set_root_multiplier(S_MO_K(S_L_S(a)));
1899 copy_tableaux(S_MO_S(S_L_S(a)),imitate);
1900 root_standardise_tableau(imitate,result);
1901 freeself(imitate);
1902 }
1903
1904 freeall(imitate);
1905 free_root_parameters();
1906 free_garnir_parameters();
1907 return(OK);
1908 }
1909
1910
1911
1912 /* Note that the following variables have been defined prior to
1913 set_garnir_parameters() and are also made use in the routines
1914 that follow.
1915
1916 INT *part,*conj,*entry_list;
1917 INT lcol,rcol,grow,glength,gright,gleft;
1918 OP children,template;
1919 */
1920
1921 static OP root_multiplier; /* mult by this prior to accumulating to root_all */
1922 static OP root_all; /* list accumulating standard terms found */
1923
1924 static INT root_ready=0,per_len=0;
1925 static INT row1,row2,calx;
1926 static INT root,rootover2,root_cover,kappa,strip,ostrip;
1927 static INT min_tail,max_tail;
1928 static INT piece1,piece2,first_var,left_const,right_const;
1929 static INT *symmetry,*inverse;
1930 static INT *spectrum;
1931 static OP poly,hiccup_log;
1932 static OP ghost;
1933 static OP accumulate;
1934 static OP symmetrised;
1935 static OP mq_mp; /* monopoly storing -q */
1936
1937
set_root_parameters(partition,p_root)1938 INT set_root_parameters ( partition, p_root)
1939 OP partition;
1940 OP p_root;
1941
1942
1943 /* sets a numbers of parameters depending on the Young diagram and the
1944 relevant boundary strip. root_ready keeps an account of how many
1945 times that this routine is called, so that everything can be
1946 freed on the last free_root_parameters() call.
1947 Of course, this assumes that in every routine that calls
1948 set_root_parameters(), there is a corresponding call to
1949 free_root_parameters().
1950 */
1951
1952 {
1953 INT i,no_rows;
1954
1955 if (root_ready++)
1956 return(OK);
1957
1958 /* validate parameters */
1959
1960 if (partition==NULL || S_O_K(partition)!=PARTITION)
1961 {
1962 printf("generate_root_tableaux() did not receive a partition as it was expecting!\n");
1963 return(ERROR);
1964 }
1965
1966 root=S_I_I(p_root);
1967 if (root&1) /* odd */
1968 {
1969 rootover2=root; /* half root if even */
1970 root_cover=root-1; /* minimum power at which to look for improvements */
1971 }
1972 else
1973 root_cover=rootover2=root/2;
1974
1975 no_rows=S_PA_LI(partition);
1976 row1 = no_rows>0 ? S_PA_II(partition,no_rows-1) : 0;
1977 row2 = no_rows>1 ? S_PA_II(partition,no_rows-2) : 0;
1978
1979 /* calculate length of relevant boundary strip */
1980
1981 kappa=(row1-row2)/root+1;
1982 strip=kappa*root;
1983
1984 /* set up arrays to store certain permutations */
1985
1986 symmetry=(INT*)SYM_calloc(strip,sizeof(INT));
1987 inverse=(INT*)SYM_calloc(strip,sizeof(INT));
1988
1989 for (i=0;i<strip;i++)
1990 symmetry[i]=inverse[i]=i;
1991 per_len=0;
1992
1993 /* refine and augment info on lengths of strips */
1994
1995 if (strip-1>row1 || strip-1 == row1-row2)
1996 kappa=strip=ostrip=calx=min_tail=max_tail=0;
1997 else
1998 {
1999 strip-=2; /* so we just add to get co-ord in top row */
2000
2001 ostrip=strip-root+2; /* length of the other strips */
2002 calx=row1-strip; /* final one to check for strip standard */
2003 min_tail=strip+1+row2-row1;
2004 max_tail=row2<root ? row2 : root-1;
2005 }
2006
2007 /* make a tableau to be used to store default entries */
2008
2009 m_u_t(partition,ghost=callocobject());
2010 for (i=0;i<row1;i++)
2011 m_i_i(0L,S_T_IJ(ghost,0,i));
2012 for (i=0;i<row2;i++)
2013 m_i_i(0L,S_T_IJ(ghost,1,i));
2014
2015
2016 /* make zeroed arrays in which to manipulate monopolies at root of unity.
2017 they are made the maximum size need for current root. */
2018
2019 m_il_nv(2*root,poly=callocobject());
2020 m_il_nv(root,hiccup_log=callocobject());
2021
2022 /* and a normal array for fast (!) renormalisation of monopolies */
2023
2024 spectrum=(INT*)SYM_calloc(root,sizeof(INT));
2025
2026 /* make monopoly storing -q */
2027
2028 construct_mo_mp(1,-1,mq_mp=callocobject());
2029
2030 /* the following array will store the action of symmetrising over
2031 i-1 boxes in the second row. */
2032
2033 m_il_v(root-1,symmetrised=callocobject());
2034
2035 return(OK);
2036 }
2037
2038
free_root_parameters()2039 INT free_root_parameters ()
2040
2041 /* frees arrays created by routine above - but only if root_ready==1 */
2042
2043 {
2044 if (!--root_ready)
2045 {
2046 SYM_free(symmetry);
2047 SYM_free(inverse);
2048 freeall(ghost);
2049 freeall(poly);
2050 freeall(hiccup_log);
2051 freeall(symmetrised);
2052 SYM_free(spectrum);
2053 freeall(mq_mp);
2054 }
2055
2056 return(OK);
2057 }
2058
2059
2060
find_non_root_standard_pos(tableau)2061 INT find_non_root_standard_pos (tableau) OP tableau;
2062
2063 /* determines where (in the 2nd row) the tableau is not p-root
2064 standard. It is assumed that set_root_parameters has been invoked.
2065 Also assumed that kappa>0.
2066 */
2067
2068 {
2069 INT i,j;
2070
2071 /* check all relevant positions in 2nd row to find rightmost
2072 which is not strip standard */
2073
2074 if (kappa)
2075 for (i=calx-1;i>=0;i--)
2076 if (S_T_IJI(tableau,1,i)>S_T_IJI(tableau,0,i+strip))
2077 {
2078 if (kappa>1)
2079
2080 /* then we must also check that all positions to right are
2081 not ostrip standard (ostrip=strip-root+2). */
2082
2083 {
2084 for (j=i+root-1;
2085 j<row2 && S_T_IJI(tableau,1,j)>S_T_IJI(tableau,0,j+ostrip);
2086 j++);
2087
2088 }
2089
2090 if (kappa==1 || j>=row2) /* then i gives non-standard pos */
2091 {
2092 return(i);
2093 }
2094 }
2095
2096 return(-1);
2097 }
2098
2099
set_root_multiplier(extra)2100 void set_root_multiplier (extra) OP extra;
2101
2102 /* all standard tableaux that are now found are added to the list
2103 after their coefficients have been multiplied by extra
2104 (which will usually be a MONOPOLY object).
2105 */
2106
2107 {
2108 root_multiplier=extra;
2109 }
2110
2111
root_standardise_tableau_list(list,expression)2112 void root_standardise_tableau_list ( list, expression)
2113 OP list;
2114 OP expression;
2115
2116 /* Expresses the monomial list of tableaux with monopoly coefficients
2117 in terms of a list of standard tableaux with monopoly coefficients
2118 Requires that set_garnir_parameters() and set_root_parameter()
2119 have both been invoked.
2120 */
2121
2122 {
2123 OP a;
2124
2125 for (a=list;a!=NULL;a=S_L_N(a))
2126 {
2127 set_root_multiplier(S_MO_K(S_L_S(a)));
2128 root_standardise_tableau(S_MO_S(S_L_S(a)),expression);
2129 }
2130 }
2131
2132
root_standardise_tableau(tableau,expression)2133 void root_standardise_tableau ( tableau, expression)
2134 OP tableau;
2135 OP expression;
2136
2137 /* Expresses the tableau in terms of a list of standard tableaux
2138 with polynomial coefficients. tableau is not freed by this
2139 function, but its entries may change.
2140 Requires that set_garnir_parameters() and set_root_parameter()
2141 have both been invoked, and that root_multiplier has been set.
2142 */
2143
2144 {
2145 INT swaps=0;
2146 OP overall;
2147
2148 root_all=expression;
2149 columns_standardise_tableau(tableau,&swaps);
2150 find_non_rowstandard_pos(tableau,&grow,&lcol);
2151
2152 if (grow<0)
2153 { /* then tableau is S_n standard - now test root standardness */
2154
2155 if ((lcol=find_non_root_standard_pos(tableau))<0)
2156 {
2157 construct_mo_mp(0,swaps&1 ? -1 : 1,overall=callocobject());
2158 mult_apply_monopoly(root_multiplier,overall);
2159 #if NORMALISE==1
2160 root_garnir_result(tableau,overall,root_all);
2161 #else
2162 garnir_result(tableau,overall,root_all);
2163 #endif
2164 }
2165 else /* S_n standard but not root standard */
2166 {
2167 strip_juggle(tableau,0,swaps&1 ? -1 : 1);
2168 }
2169 }
2170 else /* S_n non-standard */
2171 {
2172 root_juggle(tableau,0,swaps&1 ? -1 : 1);
2173 }
2174 }
2175
2176
root_juggle(tableau,power,coeff)2177 void root_juggle ( tableau, power, coeff)
2178 OP tableau;
2179 INT power;
2180 INT coeff;
2181
2182 /* Recursive function which is passed a non-standard tableau,
2183 together with its coefficient in the form of
2184 coeff * q^power.
2185 (usually coeff is +1 or -1).
2186 In one invocation, a single Garnir relation is performed:
2187 those which result that are standard are added to the list
2188 of tableaux; those which are non-standard are resubmitted to
2189 this function.
2190 The tableau that is passed is assumed to be standard in columns
2191 AND nonstandard in rows. It is ALSO assumed that the non-standard
2192 position has already been stored in (grow,lcol).
2193 tableau is unchanged by this function,
2194 Requires that set_garnir_parameters() and set_root_parameters()
2195 have been invoked.
2196 */
2197
2198 {
2199 INT p,swaps,lcoll,rcoll;
2200 OP store,temp,overall;
2201
2202 template=tableau;
2203
2204 /* obtain lengths of garnir parts and stores entries of these parts */
2205
2206 glength=conj[lcol]+1;
2207 gright=grow+1;
2208 gleft=glength-gright;
2209 rcoll=rcol=(lcoll=lcol)+1;
2210
2211 for (p=0;p<gright;p++)
2212 entry_list[p]=S_T_IJI(tableau,p,rcol);
2213 for (;p<glength;p++)
2214 entry_list[p]=S_T_IJI(tableau,p-1,lcol);
2215
2216 /* start a list for garnir_generate() to put tableaux and their
2217 coeffs into. the final list address is kept in store, so that
2218 the list can be freed later (children is a global variable that
2219 will be overwritten). */
2220
2221 children=callocobject();
2222 init(LIST,children);
2223
2224 garnir_generate(glength,glength-1);
2225 store=children;
2226
2227 /* now order the entries in the two changed columns of each tableau */
2228
2229 for (temp=children;S_L_S(temp)!=NULL;temp=S_L_N(temp))
2230 {
2231 swaps=0;
2232 column_standardise_tableau(S_MO_S(S_L_S(temp)),lcoll,&swaps);
2233 column_standardise_tableau(S_MO_S(S_L_S(temp)),rcoll,&swaps);
2234 find_non_rowstandard_pos(S_MO_S(S_L_S(temp)),&grow,&lcol);
2235
2236 if (grow<0)
2237 { /* then tableau is S_n standard - now test root standardness */
2238
2239 if ((lcol=find_non_root_standard_pos(S_MO_S(S_L_S(temp))))<0)
2240 {
2241 construct_mo_mp(
2242 power+S_I_I(S_MO_K(S_L_S(temp))),
2243 (swaps+S_I_I(S_MO_K(S_L_S(temp))))&1 ? coeff : -coeff,
2244 overall=callocobject());
2245 mult_apply_monopoly(root_multiplier,overall);
2246
2247 #if NORMALISE==1
2248 root_garnir_result(S_MO_S(S_L_S(temp)),overall,root_all);
2249 #else
2250 garnir_result(S_MO_S(S_L_S(temp)),overall,root_all);
2251 #endif
2252 }
2253 else /* S_n standard but not root standard */
2254 {
2255 strip_juggle(S_MO_S(S_L_S(temp)),power+S_I_I(S_MO_K(S_L_S(temp))),
2256 (swaps+S_I_I(S_MO_K(S_L_S(temp))))&1 ? coeff : -coeff);
2257 }
2258 }
2259 else /* S_n non-standard */
2260 {
2261 root_juggle(S_MO_S(S_L_S(temp)),power+S_I_I(S_MO_K(S_L_S(temp))),
2262 (swaps+S_I_I(S_MO_K(S_L_S(temp))))&1 ? coeff : -coeff);
2263 }
2264 }
2265
2266 freeall(store);
2267 }
2268
2269
strip_juggle(tableau,power,coeff)2270 void strip_juggle (tableau, power, coeff)
2271 OP tableau;
2272 INT power;
2273 INT coeff;
2274
2275 /* Recursive function (interlinking with root_juggle()) which is passed
2276 a standard tableau which is not root_standard, together with its
2277 coefficient in the form of
2278 coeff * q^power.
2279 (usually coeff is +1 or -1).
2280 In one invocation, a single strip relation is performed:
2281 those which result that are standard are added to the list
2282 of tableaux; those which are non-standard are resubmitted to
2283 this function or to garnir_juggle().
2284 This enormous function has three mutually exclusive pieces
2285 that perform similar tasks for the cases:
2286 1. No of boxes of strip in second row < root;
2287 2. Otherwise, and kappa==1;
2288 3. Otherwise (kappa>1).
2289 The tableau that is passed is assumed to be standard.
2290 It is ALSO assumed that the 2nd row position of root non-standardness
2291 has already been stored in lcol.
2292 tableau is unchanged by this function,
2293 Requires that set_garnir_parameters() and set_root_parameters()
2294 have been invoked.
2295 */
2296
2297 {
2298 INT i,disp,dispr1,dispr2;
2299 OP save_multiplier,overall,strip_list,tab;
2300 INT row1_pos,row2_pos,b_entry,s_entry;
2301 OP temp,ext,monom,koeff,new,big_list,partit,perm;
2302 INT *map;
2303
2304 /* identify the appropriate list: i becomes no of symmetrised boxes
2305 in 2nd row. disp is the rightward distance from the first box
2306 being symmetrised to the rightmost possible root-1 2nd row boxes
2307 symmetrisation. */
2308
2309 disp=row2-lcol-root+1;
2310 i= disp<0 ? row2-lcol : root-1;
2311
2312 strip_list=s_v_i(symmetrised,i-1);
2313
2314 if (S_O_K(strip_list)==EMPTY)
2315 { /* need to generate the model expression for this standardisation */
2316
2317 generate_sym_tableaux_list(i,strip_list);
2318 }
2319
2320 /* now hijack the multiplier - so that it can be reset */
2321
2322 b_ks_o(S_O_K(root_multiplier),S_O_S(root_multiplier),
2323 save_multiplier=callocobject());
2324 /* c_o_s(root_multiplier,NULL); */
2325 c_o_k(root_multiplier,EMPTY);
2326
2327 /* make an array to store map between canonical root non-standard
2328 tableau and current particular root non-standard tableau. */
2329
2330 map=(INT*)SYM_calloc(row1+row2+1,sizeof(INT));
2331
2332 /* identify the map from the canonical strip relation to the current
2333 problem using the first term in the list. */
2334
2335 tab=S_MO_S(S_L_S(strip_list));
2336
2337 if (disp<=0)
2338 { /* easy case - number of boxes of boundary strip in second row < root.
2339 The stored list is used pretty much as it stands. First form
2340 the map from the canonical non strip-standard tableau (this is
2341 stored as the first element in the list). */
2342
2343 for (i=0;i<row1;i++)
2344 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i);
2345 for (i=0;i<row2;i++)
2346 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i);
2347
2348 /* run through all the tableaux in the list (discarding the first),
2349 map them to the required tableau using the above map, multiply
2350 the root_multiplier by the current coefficient and resubmit */
2351
2352 for (strip_list=S_L_N(strip_list);strip_list!=NULL;
2353 strip_list=S_L_N(strip_list))
2354 {
2355 tab=S_MO_S(S_L_S(strip_list));
2356
2357 for (i=0;i<row1;i++)
2358 C_I_I(S_T_IJ(ghost,0,i),map[S_T_IJI(tab,0,i)]);
2359 for (i=0;i<row2;i++)
2360 C_I_I(S_T_IJ(ghost,1,i),map[S_T_IJI(tab,1,i)]);
2361
2362 mult_monopoly_monopoly(save_multiplier,S_MO_K(S_L_S(strip_list)),
2363 root_multiplier);
2364
2365 find_non_rowstandard_pos(ghost,&grow,&lcol);
2366
2367 if (grow<0)
2368 { /* then tableau is S_n standard - now test root standardness */
2369
2370 if ((lcol=find_non_root_standard_pos(ghost))<0)
2371 {
2372 /* append to the standard list */
2373
2374 construct_mo_mp(power,coeff,overall=callocobject());
2375 mult_apply_monopoly(root_multiplier,overall);
2376
2377 #if NORMALISE==1
2378 root_garnir_result(ghost,overall,root_all);
2379 #else
2380 garnir_result(ghost,overall,root_all);
2381 #endif
2382 }
2383 else /* S_n standard but not root standard */
2384 {
2385 /* in the special case when strip_juggle() calls itself,
2386 ghost could get corrupted (by generate_sym_tableau_list())
2387 before being used. So copy it. */
2388
2389 copy_tableaux(ghost,tab=callocobject());
2390 strip_juggle(tab,power,coeff);
2391 freeall(tab);
2392 }
2393 }
2394 else /* S_n non-standard */
2395 {
2396 root_juggle(ghost,power,coeff);
2397 }
2398
2399 /* discard the current value of multiplier for the current entry */
2400
2401 freeself(root_multiplier);
2402 }
2403 }
2404 else if (kappa==1)
2405 { /* this is a trickier case, where the symmetrised section needs
2406 to be used at different positions to where it has been formed
2407 in the canonical list */
2408
2409 dispr1=row1-disp;
2410 dispr2=row2-disp;
2411
2412 /* This first loop defines the map for the last disp entries
2413 of each row. */
2414
2415 for (i=0;i<disp;i++)
2416 {
2417 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i+dispr1);
2418 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i+dispr2);
2419 }
2420
2421 /* Then provide map for remainder of entries, which after being
2422 mapped are moved disp positions to the left. */
2423
2424 for (i=disp;i<row2;i++)
2425 {
2426 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i-disp);
2427 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i-disp);
2428 }
2429 for (i=row2;i<row1;i++)
2430 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i-disp);
2431
2432 /* go through list, and copy each term, after acting on each with
2433 /* Then as before */
2434
2435 for (strip_list=S_L_N(strip_list);strip_list!=NULL;
2436 strip_list=S_L_N(strip_list))
2437 {
2438 tab=S_MO_S(S_L_S(strip_list));
2439
2440 for (i=0;i<disp;i++)
2441 C_I_I(S_T_IJ(ghost,0,i+dispr1),map[S_T_IJI(tab,0,i)]);
2442
2443 for (i=disp;i<row1;i++)
2444 C_I_I(S_T_IJ(ghost,0,i-disp),map[S_T_IJI(tab,0,i)]);
2445
2446 for (i=0;i<disp;i++)
2447 C_I_I(S_T_IJ(ghost,1,i+dispr2),map[S_T_IJI(tab,1,i)]);
2448
2449 for (i=disp;i<row2;i++)
2450 C_I_I(S_T_IJ(ghost,1,i-disp),map[S_T_IJI(tab,1,i)]);
2451
2452 mult_monopoly_monopoly(save_multiplier,S_MO_K(S_L_S(strip_list)),
2453 root_multiplier);
2454
2455 find_non_rowstandard_pos(ghost,&grow,&lcol);
2456
2457 if (grow<0)
2458 {
2459 if ((lcol=find_non_root_standard_pos(ghost))<0)
2460 {
2461 construct_mo_mp(power,coeff,overall=callocobject());
2462 mult_apply_monopoly(root_multiplier,overall);
2463
2464 #if NORMALISE==1
2465 root_garnir_result(ghost,overall,root_all);
2466 #else
2467 garnir_result(ghost,overall,root_all);
2468 #endif
2469 }
2470 else
2471 {
2472 copy_tableaux(ghost,tab=callocobject());
2473 strip_juggle(tab,power,coeff);
2474 freeall(tab);
2475 }
2476 }
2477 else
2478 {
2479 root_juggle(ghost,power,coeff);
2480 }
2481
2482 freeself(root_multiplier);
2483 }
2484 }
2485 else /* if (kappa>1) */
2486 { /* this is an even trickier case, where the symmetrised section needs
2487 to be used at different positions to where it has been formed
2488 in the canonical list, the entries to its right set up and
2489 acted on by a hecke permutation, before resubmission. */
2490
2491 dispr1=row1-disp;
2492 dispr2=row2-disp;
2493
2494 /* This first loop defines the map for the last disp entries
2495 of each row. */
2496
2497 for (i=0;i<disp;i++)
2498 map[S_T_IJI(tab,1,i)]=2*(dispr2+i)+ostrip+1;
2499
2500 for (i=0;i<disp+ostrip+row2-row1;i++)
2501 map[S_T_IJI(tab,0,i)]=2*(dispr1+1+i)-ostrip;
2502
2503 for (;i<disp;i++)
2504 map[S_T_IJI(tab,0,i)]=row1+row2-disp+1+i;
2505
2506 /* Then provide map for remainder of entries, which after being
2507 mapped are moved disp positions to the left. */
2508
2509 for (i=disp;i<=row2-root;i++)
2510 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i-disp);
2511
2512 for (;i<row2;i++)
2513 map[S_T_IJI(tab,1,i)]=dispr2+ostrip+1-disp+i;
2514
2515 for (i=disp;i<row2+ostrip;i++)
2516 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i-disp);
2517
2518 for (;i<row1 && i<row2+ostrip+disp;i++)
2519 map[S_T_IJI(tab,0,i)]=2*(i+1-disp)-ostrip;
2520
2521 for (;i<row1;i++)
2522 map[S_T_IJI(tab,0,i)]=dispr2+1+i;
2523
2524 /* go through list, and copy each term, after acting on each with
2525 the above permutation */
2526
2527 partit=s_t_u(tableau);
2528 temp=big_list=NULL;
2529
2530 for (;strip_list!=NULL;strip_list=S_L_N(strip_list))
2531 {
2532 tab=S_MO_S(S_L_S(strip_list));
2533
2534 m_u_t(partit,new=callocobject());
2535
2536 for (i=0;i<disp;i++)
2537 m_i_i(map[S_T_IJI(tab,0,i)],S_T_IJ(new,0,i+dispr1));
2538
2539 for (i=disp;i<row1;i++)
2540 m_i_i(map[S_T_IJI(tab,0,i)],S_T_IJ(new,0,i-disp));
2541
2542 for (i=0;i<disp;i++)
2543 m_i_i(map[S_T_IJI(tab,1,i)],S_T_IJ(new,1,i+dispr2));
2544
2545 for (i=disp;i<row2;i++)
2546 m_i_i(map[S_T_IJI(tab,1,i)],S_T_IJ(new,1,i-disp));
2547
2548 /* copy list in the smae order */
2549
2550 copy_list(S_MO_K(S_L_S(strip_list)),koeff=callocobject());
2551 b_sk_mo(new,koeff,monom=callocobject());
2552 b_sn_l(monom,NULL,ext=callocobject());
2553 if (temp==NULL)
2554 big_list=ext;
2555 else
2556 C_L_N(temp,ext);
2557 temp=ext;
2558 }
2559
2560 /* then recursively multiply each by (s_i-q) for each appropriate i. */
2561
2562 for (i=disp-1;i>=0;i--)
2563 {
2564 row1_pos=row2-disp+ostrip+i;
2565 row2_pos=row2-disp+i;
2566 s_entry=row1_pos+row2_pos+1;
2567 b_entry=s_entry+1;
2568
2569 /* act on each term to double the list size */
2570
2571 for (temp=big_list;temp!=NULL;temp=S_L_N(ext))
2572 {
2573 /* put a copy of the term AFTER the current one,
2574 mutliply the new by -q, and transpose the old. */
2575
2576 copy_monom(S_L_S(temp),monom=callocobject());
2577 mult_apply_monopoly(mq_mp,S_MO_K(monom));
2578 C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),0,row1_pos),s_entry);
2579 C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),1,row2_pos),b_entry);
2580
2581 b_sn_l(monom,S_L_N(temp),ext=callocobject());
2582 C_L_N(temp,ext);
2583 }
2584 }
2585
2586 /* now effect a hecke permutation on the list, in order to
2587 take the first element of the big_list to tableau (the
2588 current non root-standard tableau). Then ignore
2589 the first (non root-standard) element; and resubmit for
2590 recursive standardisation.
2591 */
2592
2593 m_il_p(row1+row2,perm=callocobject());
2594 for (i=0;i<b_entry-root;i++)
2595 m_i_i(i+1,S_P_I(perm,i));
2596 for (i=row2_pos-root+2;i<row2;i++)
2597 m_i_i(S_T_IJI(tableau,1,i),
2598 S_P_I(perm,S_T_IJI(S_MO_S(S_L_S(big_list)),1,i)-1));
2599 for (i=row1_pos;i<row1;i++)
2600 m_i_i(S_T_IJI(tableau,0,i),
2601 S_P_I(perm,S_T_IJI(S_MO_S(S_L_S(big_list)),0,i)-1));
2602
2603 temp=S_L_N(big_list);
2604 hecke_action_perm_on_lc(temp,perm); /* perm is freed in hecke_action_perm_on_lc */
2605
2606 for (;temp!=NULL;temp=S_L_N(temp))
2607 {
2608 mult_monopoly_monopoly(save_multiplier,S_MO_K(S_L_S(temp)),
2609 root_multiplier);
2610 tab=S_MO_S(S_L_S(temp));
2611 find_non_rowstandard_pos(tab,&grow,&lcol);
2612
2613 if (grow<0)
2614 {
2615 if ((lcol=find_non_root_standard_pos(tab))<0)
2616 {
2617 construct_mo_mp(power,coeff,overall=callocobject());
2618 mult_apply_monopoly(root_multiplier,overall);
2619
2620 #if NORMALISE==1
2621 root_garnir_result(tab,overall,root_all);
2622 #else
2623 garnir_result(tab,overall,root_all);
2624 #endif
2625 }
2626 else
2627 {
2628 strip_juggle(tab,power,coeff);
2629 }
2630 }
2631 else
2632 {
2633 root_juggle(tab,power,coeff);
2634 }
2635
2636 freeself(root_multiplier);
2637 }
2638 freeall(big_list);
2639 }
2640
2641 /* restore the multiplier */
2642
2643 b_ks_o(S_O_K(save_multiplier),S_O_S(save_multiplier),root_multiplier);
2644 C_O_K(save_multiplier,EMPTY);
2645 freeall(save_multiplier);
2646 SYM_free(map);
2647 }
2648
2649
2650 #if NORMALISE == 1 /* include if we want resultant coefficients
2651 tidied up with respect to the root of unity */
2652
root_garnir_result(tableau,mp_coeff,acc_list)2653 void root_garnir_result ( tableau, mp_coeff, acc_list)
2654 OP tableau;
2655 OP mp_coeff;
2656 OP acc_list;
2657
2658 /* This routine does the same as garnir_result() except that the
2659 coefficients are tidied up somewhat with regard to the root of
2660 unity. It is assumed that set_root_parameters() has been invoked.
2661 Adds mp_coeff * tableau to our standard list: acc_list.
2662 tableau is unchanged, and copied when necessary. mp_coeff is
2663 destroyed. The list is maintained
2664 in lexicographic order (reading across rows, then top to bottom).
2665 */
2666
2667 {
2668 OP a,b,term;
2669 OP t,temp;
2670 INT co;
2671
2672 if (empty_listp(acc_list))
2673 {
2674 if (root_normalise_monopoly(mp_coeff))
2675 {
2676 copy_tableaux(tableau,t=callocobject());
2677 b_sk_mo(t,mp_coeff,term=callocobject());
2678
2679 c_l_s(acc_list,term); /* assuming that the self exists */
2680 } /* for an empty list */
2681 else
2682 freeall(mp_coeff);
2683 }
2684 else
2685 { /* look for tableau in list */
2686
2687 for (a=acc_list,b=NULL;
2688 a!=NULL && (co=comp_tableaux(S_MO_S(S_L_S(a)),tableau))<0;
2689 a=S_L_N(b=a));
2690
2691 if (a==NULL || co>0) /* not present */
2692 {
2693 if (root_normalise_monopoly(mp_coeff))
2694 {
2695 copy_tableaux(tableau,t=callocobject());
2696 b_sk_mo(t,mp_coeff,term=callocobject());
2697
2698 if (b==NULL) /* insert new first term (before a) */
2699 {
2700 b_ks_o(S_O_K(acc_list),S_O_S(acc_list),temp=callocobject());
2701 /* c_o_s(acc_list,NULL); */
2702 c_o_k(acc_list,EMPTY);
2703 b_sn_l(term,temp,acc_list);
2704 }
2705 else /* insert new term between b and a */
2706 {
2707 b_sn_l(term,a,temp=callocobject());
2708 C_L_N(b,temp);
2709 }
2710 }
2711 else
2712 freeall(mp_coeff);
2713 }
2714 else /* term is present - must just add coefficients */
2715 {
2716 insert(mp_coeff,S_MO_K(S_L_S(a)),add_koeff,NULL);
2717 root_normalise_monopoly(S_MO_K(S_L_S(a)));
2718 }
2719 }
2720 }
2721
2722
root_normalise_monopoly(mono)2723 INT root_normalise_monopoly (mono) OP mono;
2724
2725 /* some attempts to simplify the monopoly using the fact that its
2726 over a primitive p_root of unity. Return is 0 if result is
2727 identically zero (not fully implemented), else 1.
2728 */
2729
2730 {
2731 INT i,hi,lo;
2732 OP a,b,mopo;
2733
2734 /* return if nothing to process */
2735
2736 if (empty_listp(mono))
2737 return(0);
2738
2739 /* set whole of working array to zeros */
2740
2741 memset(spectrum,0,root*sizeof(INT));
2742
2743 /* copy monopoly to working array and use q^root=1 to reduce exponents */
2744
2745 for (a=mono;a!=NULL;a=S_L_N(b=a))
2746 spectrum[S_I_I(S_MO_S(S_L_S(a)))%root]+=S_I_I(S_MO_K(S_L_S(a)));
2747
2748 /* if the highest power is tooo low, end processing */
2749
2750 if (S_I_I(S_MO_S(S_L_S(b)))<root_cover)
2751 return(1);
2752
2753 if (rootover2<root) /* even root: reduce using q^(root/2)=-1 */
2754 {
2755 for (i=0;i<rootover2;i++)
2756 spectrum[i]-=spectrum[i+rootover2];
2757 }
2758 else /* try to improve using 1+q+q^2+ ... + q^(root-1) =0 */
2759 {
2760 if (root>1 && (hi=lo=spectrum[i=(root-1)]))
2761 {
2762 for (i--;i>0;i--)
2763 if (!spectrum[i])
2764 goto there; /* don't change what we've got */
2765
2766 else if (spectrum[i]>hi)
2767 hi=spectrum[i];
2768 else if (spectrum[i]<lo)
2769 lo=spectrum[i];
2770
2771 if (lo>0)
2772 for (i=root-1;i>=0;i--)
2773 spectrum[i]-=lo;
2774 else if (hi<0)
2775 for (i=root-1;i>=0;i--)
2776 spectrum[i]-=hi;
2777 }
2778 there:
2779 ;
2780 }
2781
2782 for (i=0;i<rootover2 && !spectrum[i];i++);
2783 if (i==rootover2) /* polynomial is identically zero */
2784 {
2785 init(MONOPOLY,mono);
2786 return(0);
2787 }
2788 else
2789 { /* hijack the first element */
2790 C_I_I(S_MO_S(S_L_S(mono)),i);
2791 C_I_I(S_MO_K(S_L_S(mono)),spectrum[i]);
2792 if (S_L_N(mono)!=NULL)
2793 {
2794 freeall(S_L_N(mono));
2795 C_L_N(mono,NULL);
2796 }
2797 while (1) /* append the rest of the terms */
2798 {
2799 for (i++;i<rootover2 && !spectrum[i];i++);
2800 if (i==rootover2)
2801 break;
2802 construct_mo_mp(i,spectrum[i],mopo=callocobject());
2803 C_L_N(mono,mopo);
2804 mono=mopo;
2805 }
2806 return(1);
2807 }
2808 }
2809
2810
2811 #endif /* for NORMALISE */
2812
2813
generate_sym_tableaux_list(piece,sym_list)2814 void generate_sym_tableaux_list (piece, sym_list)
2815 INT piece;
2816 OP sym_list;
2817
2818 /* generates a list of tableaux which have been symmetrised across
2819 the final piece boxes of the second row and the subsequent
2820 strip-piece-1 boxes of the first row.
2821 Requires that set_root_parameters() has been invoked.
2822 */
2823
2824 {
2825 INT i,e;
2826 OP temp,child,momp,mon,ext;
2827
2828 piece1=strip-piece+1;
2829 piece2=piece;
2830
2831 /* fill into the ghost template the constant entries */
2832
2833 left_const=row2-piece;
2834 right_const=row2+piece1;
2835 first_var=row2+left_const+1;
2836
2837 for (i=0,e=1;i<left_const;i++)
2838 {
2839 C_I_I(S_T_IJ(ghost,0,i),e++);
2840 C_I_I(S_T_IJ(ghost,1,i),e++);
2841 }
2842
2843 for (;i<row2;i++)
2844 {
2845 C_I_I(S_T_IJ(ghost,0,i),e);
2846 C_I_I(S_T_IJ(ghost,1,i),piece2+e++);
2847 }
2848
2849 for (e+=piece2;i<row1;i++)
2850 C_I_I(S_T_IJ(ghost,0,i),e++);
2851
2852 /* store a copy of this tableau in the list - the first */
2853
2854 child=callocobject();
2855 copy_tableaux(ghost,child);
2856
2857 construct_mo_mp(0,1,momp=callocobject());
2858 b_sk_mo(child,momp,mon=callocobject());
2859 b_sn_l(mon,NULL,ext=callocobject());
2860 accumulate=ext;
2861
2862 /* now append to this list all permutations of the entries
2863 in the strip, which are standard in the top row. */
2864
2865 coset_generate(strip,strip);
2866
2867 #if DUMP==1
2868 printf("This is what we get first...\n");
2869 dump_lc_list(accumulate);
2870 #endif
2871
2872 /* send this list for generic standardisation */
2873
2874 init(LIST,sym_list);
2875 standardise_tableau_list(accumulate,sym_list);
2876 freeall(accumulate);
2877
2878 #if DUMP==1
2879 printf("This is what we get before factor removal...\n");
2880 dump_lc_list(sym_list);
2881 #endif
2882
2883 /* there is a factor of [piece]_q! (if [root]_q=0) here that
2884 should be removed */
2885
2886 for (temp=sym_list;temp!=NULL;temp=S_L_N(temp))
2887 remove_mp_qnumber_fac(S_MO_K(S_L_S(temp)),piece);
2888
2889 #if DUMP==1
2890 printf("This is what we get after factor removal...\n");
2891 dump_lc_list(sym_list);
2892 #endif
2893
2894 }
2895
2896
coset_generate(head,wag)2897 void coset_generate (head, wag) INT head; INT wag;
2898
2899 /* Recursive function which creates all the terms in the coset.
2900 Method is much the same as that used for garnir_generate().
2901 See that routine for details.
2902 Requires that set_garnir_parameters() has been invoked.
2903 */
2904
2905 {
2906 INT k,i,j,p,s;
2907 OP child,momp,mon,ext;
2908
2909 for (i=0;i<piece2;i++)
2910 {
2911 s=symmetry[i];
2912
2913 if ( (s<wag || (s==wag+1 && s<head))
2914
2915 /* so that the permutation will be canonically represented */
2916
2917 && (j=inverse[s+1]) > i)
2918
2919 /* s is in the bottom row, s+1 is anywhere to the right */
2920
2921 { /* swap the entries in sym & inv to keep track of permutation */
2922
2923 inverse[symmetry[i]=s+1]=i;
2924 inverse[symmetry[j]=s]=j;
2925
2926 /* place the entries in the tableau in the corresponding way */
2927
2928 child=callocobject();
2929 copy_tableaux(ghost,child);
2930
2931 for (k=0;k<piece2;k++)
2932 C_I_I(S_T_IJ(child,1,k+left_const),first_var+symmetry[k]);
2933
2934 for (k=0;k<piece1;k++)
2935 C_I_I(S_T_IJ(child,0,k+row2),first_var+symmetry[k+piece2]);
2936
2937 /* store tableau in the list */
2938
2939 construct_mo_mp(0,1,momp=callocobject());
2940 b_sk_mo(child,momp,mon=callocobject());
2941 b_sn_l(mon,accumulate,ext=callocobject());
2942 accumulate=ext;
2943
2944 /* resubmit with the updated permutation's info */
2945
2946 if (s<wag)
2947 coset_generate(wag,s);
2948 else
2949 coset_generate(head,wag+1);
2950
2951 /* remove permutation */
2952
2953 inverse[symmetry[i]=s]=i;
2954 inverse[symmetry[j]=s+1]=j;
2955 }
2956 }
2957 }
2958
2959
remove_mp_qnumber_fac(mp,qn)2960 INT remove_mp_qnumber_fac ( mp, qn)
2961 OP mp;
2962 INT qn;
2963
2964 /* The q_number which is passed is divided by [qn]_q! where is it
2965 assumed that we have a root of unity in force and that
2966 set_root_parameters() has already been invoked.
2967 all coefficients are multiplied by -1 since this is what is
2968 going to be required.
2969 */
2970
2971 {
2972 INT i,red;
2973 OP temp,momp,child,mon,ext;
2974
2975 /* zero the vector */
2976
2977 for (i=0;i<2*root;i++)
2978 C_I_I(s_v_i(poly,i),0L);
2979
2980 /* put the monopoly into the vector reducing all powers: q^root=1. */
2981
2982 if (!empty_listp(mp))
2983 {
2984 for (temp=mp;temp!=NULL;temp=S_L_N(temp))
2985 {
2986 red=S_I_I(S_MO_S(S_L_S(temp))) < 0
2987 ? root-1-(-1-S_I_I(S_MO_S(S_L_S(temp))) % root)
2988 /* for -ve powers */
2989 : S_I_I(S_MO_S(S_L_S(temp))) % root;
2990 /* for +ve powers */
2991 add_apply(S_MO_K(S_L_S(temp)),s_v_i(poly,red));
2992 }
2993
2994 /* dont need the list anymore - but need its memory */
2995
2996 freeself(mp);
2997
2998 /* quotient out q_numbers [2]_q, [3]_q, ... , [qn]_q. */
2999
3000 for (i=2;i<=qn;i++)
3001 remove_vec_qnumber(i);
3002
3003 /* this is the place to simplify using the cyclotomic polynomial
3004 for root. For now, just apply q^(root/2)=-1 for even roots.
3005 Adjust the coefficients (using [root]_q=0 for odd root and
3006 1=-q^(root/2) for even root) so as to make the constant term 1.
3007 This is nice!
3008 */
3009
3010 #if DUMP==1
3011 printf("Before rootover: ");
3012 println(poly);
3013 #endif
3014
3015 if (rootover2<root)
3016 {
3017 for (i=0;i<rootover2;i++)
3018 {
3019 C_I_I(s_v_i(poly,i),s_v_ii(poly,i)-s_v_ii(poly,i+rootover2));
3020 C_I_I(s_v_i(poly,i+rootover2),0L);
3021 }
3022
3023 if (s_v_ii(poly,0L)!=1L)
3024 {
3025 C_I_I(s_v_i(poly,rootover2),1L-s_v_ii(poly,0L));
3026 C_I_I(s_v_i(poly,0L),1L);
3027 }
3028 }
3029 else
3030 {
3031 red=s_v_ii(poly,0L)-1;
3032 for (i=root-1;i>0;i--)
3033 C_I_I(s_v_i(poly,i),s_v_ii(poly,i)-red);
3034 C_I_I(s_v_i(poly,0L),1L);
3035 }
3036
3037 #if DUMP==1
3038 printf("After rootover: ");
3039 println(poly);
3040 #endif
3041
3042
3043 /* reconstruct the monopoly list from the poly vector. start
3044 the list with a null since its certain to be non-empty.
3045 then all are multiplied by -1, since this is what is
3046 eventually needed during p-root standardisation. */
3047
3048 accumulate=NULL;
3049
3050 for (i=root-1;i>=0;i--)
3051 if (s_v_ii(poly,i))
3052 {
3053 construct_mo_mp(i,-s_v_ii(poly,i),momp=callocobject());
3054 C_L_N(momp,accumulate);
3055 accumulate=momp;
3056 }
3057
3058 #if DUMP==1
3059 printf("Reduced monpoly:\n");
3060 dump_monopoly(accumulate);
3061 #endif
3062
3063 b_ks_o(S_O_K(accumulate),S_O_S(accumulate),mp);
3064 C_O_K(accumulate,EMPTY);
3065 freeall(accumulate);
3066 }
3067 }
3068
3069
remove_vec_qnumber(qn)3070 INT remove_vec_qnumber ( qn) INT qn;
3071
3072 /* The poly vector object has been loaded with a polynomial which, under
3073 [root]_q=0, it assumed to have a factor of [qn]_q. This factor is
3074 removed. Assumed that qn<root.
3075 Certainly set_root_parameters() should have been invoked,
3076 as well as poly loaded.
3077
3078 This process is not so easy to implement since the factor can be
3079 either [qn]_q or [root-qn]_q, or even a linear combination of the two.
3080 */
3081
3082 {
3083 INT i,p,sweep,stream,current;
3084 INT save1,save2;
3085
3086 /* load the polynomial into a vector hiccup_log: so as to be able to check
3087 easily if [qn]_q is a factor - it is when all entries are the same. */
3088
3089 for (i=0;i<qn;i++)
3090 C_I_I(s_v_i(hiccup_log,i),s_v_ii(poly,i));
3091
3092 for (;i<root;i++)
3093 add_apply(s_v_i(poly,i),s_v_i(hiccup_log,i%qn));
3094
3095 /* now judiciously add in muliples of [root]_q. sweep will allow
3096 us to update hiccup_log easily. */
3097
3098 sweep=root%qn;
3099
3100 while (1)
3101 {
3102
3103 #if DUMP==1
3104 printf("The poly vector: ");
3105 println(poly);
3106
3107 printf("The hiccup_log vector: ");
3108 println(hiccup_log);
3109 #endif
3110
3111 stream=s_v_ii(hiccup_log,qn-1);
3112 for (p=0;p<qn && stream <= (current=s_v_ii(hiccup_log,p));p++,stream=current);
3113
3114 if (p==qn)
3115 break; /* since all values are the same */
3116
3117 /* add in [root]_q in appropriate place */
3118
3119 stream-=current;
3120
3121 for (i=p;i<p+root;i++)
3122 C_I_I(s_v_i(poly,i),s_v_ii(poly,i)+stream);
3123
3124 for (i=0;i<sweep && p<qn;i++,p++)
3125 C_I_I(s_v_i(hiccup_log,p),s_v_ii(hiccup_log,p)+stream);
3126 for (p=0;i<sweep;i++,p++)
3127 C_I_I(s_v_i(hiccup_log,p),s_v_ii(hiccup_log,p)+stream);
3128 }
3129
3130 /* now poly should(!) have [qn]_q factor explicitly: remove it */
3131
3132 for (save1=s_v_ii(poly,i=qn-1);i>0;i--)
3133 C_I_I(s_v_i(poly,i),s_v_ii(poly,i)-s_v_ii(poly,i-1));
3134
3135 for (i=qn;i<root+qn;i++)
3136 {
3137 save2=s_v_ii(poly,i);
3138 C_I_I(s_v_i(poly,i),save2-save1+s_v_ii(poly,i-qn));
3139 save1=save2;
3140 }
3141
3142 /* the quotient remains in poly and there are no entries q^root & above */
3143 }
3144
3145
3146 /********************************************************************
3147 ********************************************************************
3148 ********************************************************************
3149
3150 HICCUP routines to cheack that the generated representation
3151 matrices, actually satisfy the algebra relations.
3152
3153 Programmed by Trevor Welsh, Bayreuth, November 1995.
3154
3155 ********************************************************************
3156 ********************************************************************
3157 ********************************************************************/
3158
3159
3160
check_hecke_generators(vector,p_root,flag)3161 INT check_hecke_generators (vector, p_root, flag)
3162 OP vector;
3163 OP p_root;
3164 INT flag;
3165
3166 /* checks that the vector of matrices satisfy the hecke algebra
3167 defining relations. The check is made with respect to the
3168 primitive p_root of unity, if p_root>0.
3169 If flag is non-zero, then the difference between the two sides
3170 of the particular relation is displayed.
3171 */
3172
3173 {
3174 INT i,j,ni;
3175
3176 /* validate parameters */
3177
3178 if (vector==NULL || S_O_K(vector)!=VECTOR)
3179 {
3180 printf("check_hecke_generators() did not receive a vector as it was expecting!\n");
3181 return(ERROR);
3182 }
3183
3184 set_cyclotomic_parameters(p_root);
3185
3186 ni=s_v_li(vector);
3187
3188 for (i=0;i<ni;i++)
3189 {
3190 printf( "%" PRIINT "th square is " ,i+1);
3191 switch (check_hecke_quadratic(s_v_i(vector,i),p_root,flag))
3192 {
3193 case 0:
3194 printf("O.K!\n");
3195 break;
3196 case 1:
3197 printf("O.K for primitive %ldth root!\n",S_I_I(p_root));
3198 break;
3199 case 2:
3200 printf("codswallop!\n");
3201 break;
3202 default:
3203 return(ERROR);
3204 }
3205 }
3206
3207 for (i=1;i<ni;i++)
3208 {
3209 printf( "%" PRIINT "th braid is " ,i);
3210 switch (check_braid(s_v_i(vector,i-1),s_v_i(vector,i),p_root,flag))
3211 {
3212 case 0:
3213 printf("O.K!\n");
3214 break;
3215 case 1:
3216 printf("O.K for primitive %ldth root!\n",S_I_I(p_root));
3217 break;
3218 case 2:
3219 printf("codswallop!\n");
3220 break;
3221 default:
3222 return(ERROR);
3223 }
3224 }
3225
3226 for (i=2;i<ni;i++)
3227 for (j=0;j<i-1;j++)
3228 {
3229 printf( "(%" PRIINT ",%" PRIINT ")th commute is " ,i+1,j+1);
3230 switch (check_commute(s_v_i(vector,i),s_v_i(vector,j),p_root,flag))
3231 {
3232 case 0:
3233 printf("O.K!\n");
3234 break;
3235 case 1:
3236 printf("O.K for primitive %ldth root!\n",S_I_I(p_root));
3237 break;
3238 case 2:
3239 printf("codswallop!\n");
3240 break;
3241 default:
3242 return(ERROR);
3243 }
3244 }
3245
3246 free_cyclotomic_parameters();
3247
3248 return(OK);
3249 }
3250
3251
check_hecke_quadratic(mat,p_root,flag)3252 INT check_hecke_quadratic (mat, p_root, flag)
3253 OP mat;
3254 OP p_root;
3255 INT flag;
3256
3257 /* Checks that the matrix satisfies (mat-q)(mat+1)=0.
3258 If not and flag is non-zero, the LHS is displayed.
3259 */
3260
3261 {
3262 INT i,j,k,erm;
3263 OP id,mq,mo,f1,f2,fp;
3264
3265 /* validate parameters */
3266
3267 if (mat==NULL || S_O_K(mat)!=MATRIX)
3268 {
3269 printf("check_hecke_quadratic() did not receive a matrix as it was expecting!\n");
3270 return(ERROR);
3271 }
3272
3273 k=s_m_hi(mat);
3274
3275 id=callocobject();
3276 m_ilih_nm(k,k,id);
3277 for (i=0;i<k;i++)
3278 C_I_I(S_M_IJ(id,i,i),1L);
3279
3280 construct_mo_mp(1,-1,mo=callocobject());
3281
3282 mq=callocobject();
3283 m_ilih_nm(k,k,mq);
3284 for (i=0;i<k;i++)
3285 {
3286 c_o_k(S_M_IJ(mq,i,i),MONOPOLY);
3287 c_o_s(S_M_IJ(mq,i,i),S_O_S(mo));
3288 }
3289
3290 f1=callocobject();
3291 add_matrix(mat,id,f1);
3292 freeall(id);
3293
3294 f2=callocobject();
3295 add_matrix(mat,mq,f2);
3296 freeall(mo);
3297 for (i=0;i<k;i++)
3298 c_o_k(S_M_IJ(mq,i,i),EMPTY);
3299 freeall(mq);
3300
3301
3302 fp=callocobject();
3303 mult_matrix_matrix(f1,f2,fp);
3304 freeall(f1);
3305 freeall(f2);
3306
3307 erm=check_zero_matrix(fp,p_root);
3308
3309 if (flag && erm>1)
3310 println(fp);
3311
3312 freeall(fp);
3313 return(erm);
3314 }
3315
3316
check_braid(mat1,mat2,p_root,flag)3317 INT check_braid (mat1, mat2, p_root, flag)
3318 OP mat1;
3319 OP mat2;
3320 OP p_root;
3321 INT flag;
3322
3323 /* checks that the matrices satisfy m1*m2*m1 == m2*m1*m2.
3324 If not and flag is non-zero, the difference is displayed.
3325 */
3326
3327 {
3328 INT erm;
3329 INT i,j;
3330 OP mat12,mat121,mat212;
3331
3332 /* validate parameters */
3333
3334 if (mat1==NULL || mat2==NULL || S_O_K(mat1)!=MATRIX || S_O_K(mat2)!=MATRIX)
3335 {
3336 printf("check_braid() did not receive matrices as it was expecting!\n");
3337 return(ERROR);
3338 }
3339
3340 mult_matrix_matrix(mat1,mat2,mat12=callocobject());
3341 mult_matrix_matrix(mat12,mat1,mat121=callocobject());
3342 mult_matrix_matrix(mat2,mat12,mat212=callocobject());
3343 freeall(mat12);
3344
3345 for (i=s_m_hi(mat212)-1;i>=0;i--)
3346 for (j=s_m_li(mat212)-1;j>=0;j--)
3347 addinvers_apply(S_M_IJ(mat212,i,j));
3348
3349 add_apply(mat121,mat212);
3350 freeall(mat121);
3351
3352 erm=check_zero_matrix(mat212,p_root);
3353
3354 if (flag && erm>1)
3355 println(mat212);
3356
3357 freeall(mat212);
3358
3359 return(erm);
3360 }
3361
3362
check_commute(mat1,mat2,p_root,flag)3363 INT check_commute (mat1, mat2, p_root, flag)
3364 OP mat1;
3365 OP mat2;
3366 OP p_root;
3367 INT flag;
3368
3369 /* checks that the matrices satisfy m1*m2 == m2*m1.
3370 If not and flag is non-zero, the difference is displayed.
3371 */
3372
3373 {
3374 INT erm;
3375 INT i,j;
3376 OP mat12,mat21;
3377
3378 /* validate parameters */
3379
3380 if (mat1==NULL || mat2==NULL || S_O_K(mat1)!=MATRIX || S_O_K(mat2)!=MATRIX)
3381 {
3382 printf("check_commute() did not receive matrices as it was expecting!\n");
3383 return(ERROR);
3384 }
3385
3386 mult_matrix_matrix(mat1,mat2,mat12=callocobject());
3387 mult_matrix_matrix(mat2,mat1,mat21=callocobject());
3388
3389 for (i=s_m_hi(mat21)-1;i>=0;i--)
3390 for (j=s_m_li(mat21)-1;j>=0;j--)
3391 addinvers_apply(S_M_IJ(mat21,i,j));
3392
3393 add_apply(mat12,mat21);
3394 freeall(mat12);
3395
3396 erm=check_zero_matrix(mat21,p_root);
3397
3398 if (flag && erm>1)
3399 println(mat21);
3400
3401 freeall(mat21);
3402
3403 return(erm);
3404 }
3405
3406
3407 static INT c_root=0,c_rootover2,cyclo_ready=0,cyclo_roof;
3408 static OP tomic=NULL;
3409 static INT *c_vec=NULL;
3410
3411
set_cyclotomic_parameters(p_root)3412 INT set_cyclotomic_parameters (p_root) OP p_root;
3413
3414 /* sets paramters needed by check_zero_matrix() at roots of unity. */
3415
3416 {
3417 OP a,b;
3418 INT i;
3419
3420 if ( (c_root=S_I_I(p_root))>0 && !cyclo_ready++)
3421 {
3422 c_rootover2 = c_root&1 ? 0 : c_root/2;
3423
3424 c_vec=(INT*)SYM_calloc(c_root,sizeof(INT));
3425
3426 a=callocobject();
3427 tomic=callocobject();
3428 make_cyclotomic_monopoly(p_root,tomic);
3429
3430 /* need highest power in cyclotomic */
3431
3432 for (a=tomic;a!=NULL;a=S_L_N(b=a));
3433 cyclo_roof=S_I_I(S_MO_S(S_L_S(b)));
3434
3435 /* Note that its coefficient must be +1 */
3436 }
3437
3438 return(OK);
3439 }
3440
free_cyclotomic_parameters()3441 INT free_cyclotomic_parameters ()
3442 {
3443 if (!--cyclo_ready)
3444 {
3445 freeall(tomic);
3446 tomic=NULL;
3447 SYM_free(c_vec);
3448 c_vec=NULL;
3449 c_root=0;
3450 }
3451 }
3452
3453
check_zero_matrix(mat,p_root)3454 INT check_zero_matrix ( mat, p_root)
3455 OP mat;
3456 OP p_root;
3457
3458 /* checks that the passed matrix is zero at the appropriate
3459 root of unity.
3460 returns: -1 ERROR;
3461 0 matrix is zero, whatever the value of q;
3462 1 matrix is zero, if q is primitive p_root of unity;
3463 2 matrix is non-zero, if is not a primitive p_root of unity.
3464 */
3465
3466 {
3467 INT i,j,k,l,erm=0,non=0;
3468 OP a,op;
3469
3470 if (mat==NULL || S_O_K(mat)!=MATRIX)
3471 {
3472 printf("check_null_matrix() did not receive a matrix as it was expecting!\n");
3473 return(ERROR);
3474 }
3475
3476 set_cyclotomic_parameters(p_root);
3477
3478 for (i=0;i<S_M_HI(mat);i++)
3479 for (j=0;j<S_M_LI(mat);j++)
3480 {
3481 switch (S_O_K(op=S_M_IJ(mat,i,j)))
3482 {
3483 case INTEGER:
3484 if (S_I_I(op)!=0)
3485 {
3486 erm=1;
3487 goto there;
3488 }
3489 break;
3490 case MONOPOLY:
3491 if (!empty_listp(op))
3492 if (c_root>0)
3493 {
3494 for (k=0;k<c_root;c_vec[k++]=0);
3495 for (a=op;a!=NULL;a=S_L_N(a))
3496 c_vec[S_I_I(S_MO_S(S_L_S(a)))%c_root]
3497 +=S_I_I(S_MO_K(S_L_S(a)));
3498
3499 /* if c_root is even, do the obvious reduction */
3500 /* don't bother!
3501
3502 if (c_rootover2)
3503 { for (k=c_rootover2;k<c_root;k++)
3504 c_vec[k-c_rootover2]-=c_vec[k];
3505 t=c_rootover2-1;
3506 }
3507 else
3508 t=c_root-1;
3509 */
3510
3511 /* now reduce using the cyclotomic polynomial */
3512
3513 for (k=c_root-1;k>=0;k--)
3514 {
3515 if (c_vec[k])
3516 if (k<cyclo_roof)
3517 {
3518 /* code folded from here */
3519 /* code folded from here */
3520 erm=1;
3521 goto there; /* entry is non-zero */
3522 /* unfolding */
3523 /* unfolding */
3524 }
3525 else
3526 {
3527 /* code folded from here */
3528 /* code folded from here */
3529 non++; /* counts generic non-zeros */
3530 for (a=tomic;a!=NULL;a=S_L_N(a))
3531 c_vec[S_I_I(S_MO_S(S_L_S(a)))+k-cyclo_roof]
3532 -=S_I_I(S_MO_K(S_L_S(a)))*c_vec[k];
3533 /* unfolding */
3534 /* unfolding */
3535 }
3536 }
3537 }
3538 else
3539 {
3540 for (a=op;a!=NULL;a=S_L_N(a))
3541 if (S_I_I(S_MO_S(S_L_S(a))))
3542 {
3543 erm=1;
3544 goto there; /* entry is non-zero */
3545 }
3546 }
3547 break;
3548 default:
3549 /* shouldn't be here! */
3550 printf("matrix has unrecognised entry!\n");
3551 break;
3552
3553 }
3554 }
3555
3556 there:
3557 free_cyclotomic_parameters();
3558 if (erm)
3559 return(2);
3560 else if (non)
3561 return(1);
3562 else
3563 return(0);
3564
3565 }
3566
3567
3568
3569
3570 /********************************************************************
3571 ********************************************************************
3572 ********************************************************************
3573
3574 The following routines enable arbitrary hecke algebra elements
3575 to be added or multiplied. They are not used by any of the
3576 previous routines. They make use only of the routines
3577 set_useful_monopolies() and free_useful_monopolies.
3578
3579 ********************************************************************
3580 ********************************************************************
3581 ********************************************************************/
3582
3583
3584
hecke_add(hecke1,hecke2,result)3585 INT hecke_add ( hecke1, hecke2, result)
3586 OP hecke1;
3587 OP hecke2;
3588 OP result;
3589
3590 /* Adds hecke1 and hecke2, each of which is an hecke algebra
3591 element expressed as a q-linear combination of permutations.
3592 Neither of the inputs is changed.
3593 The result is added to result.
3594 */
3595
3596 {
3597 OP go_perm,coeff;
3598
3599 /* first validate the inputs */
3600
3601 if (S_O_K(hecke1)!=LIST
3602 || (!empty_listp(hecke1)
3603 && (S_O_K(S_L_S(hecke1)) != MONOM
3604 || S_O_K(S_MO_S(S_L_S(hecke1))) != PERMUTATION )))
3605 {
3606 printf("hecke_mult() did not receive a linear combination of permutations as it was expecting!\n");
3607 return(ERROR);
3608 }
3609
3610 if (S_O_K(hecke2)!=LIST
3611 || (!empty_listp(hecke2)
3612 && (S_O_K(S_L_S(hecke2)) != MONOM
3613 || S_O_K(S_MO_S(S_L_S(hecke2))) != PERMUTATION )))
3614 {
3615 printf("hecke_mult() did not receive a linear combination of permutations as it was expecting!\n");
3616 return(ERROR);
3617 }
3618
3619 /* if result is not already a list, then make it one */
3620
3621 if (S_O_K(result)!=LIST)
3622 init(LIST,result);
3623
3624 /* return if there is nothing to process */
3625
3626 if (empty_listp(hecke1) || empty_listp(hecke2))
3627 return(OK);
3628
3629 /* If result is empty, copy hecke1 to it. Otherwise accumulate
3630 hecke1 to it. Then accumulate hecke2 to result.
3631 */
3632
3633 if (empty_listp(result))
3634 {
3635 copy_list(hecke1,result);
3636 }
3637 else
3638 {
3639 for (go_perm=hecke1;go_perm!=NULL;go_perm=S_L_N(go_perm))
3640 {
3641 copy_list(S_MO_K(S_L_S(go_perm)),coeff=callocobject());
3642 hecke_accum(S_MO_S(S_L_S(go_perm)),coeff,result);
3643 }
3644 }
3645
3646 for (go_perm=hecke2;go_perm!=NULL;go_perm=S_L_N(go_perm))
3647 {
3648 copy_list(S_MO_K(S_L_S(go_perm)),coeff=callocobject());
3649 hecke_accum(S_MO_S(S_L_S(go_perm)),coeff,result);
3650 }
3651
3652 return(OK);
3653 }
3654
3655
hecke_mult(hecke1,hecke2,result)3656 INT hecke_mult ( hecke1, hecke2, result)
3657 OP hecke1;
3658 OP hecke2;
3659 OP result;
3660
3661 /* Multiplies hecke1 and hecke2, each of which is an hecke algebra
3662 element expressed as a q-linear combination of permutations.
3663 Neither of the inputs is changed.
3664 The result is added to result.
3665 An ERROR might result if elements of the hecke algebras are
3666 permutations from differing groups. */
3667
3668 {
3669 OP go_perm,coeff,temp,imitate,perm_cop;
3670
3671 /* first validate the inputs */
3672
3673 if (S_O_K(hecke1)!=LIST
3674 || (!empty_listp(hecke1)
3675 && (S_O_K(S_L_S(hecke1)) != MONOM
3676 || S_O_K(S_MO_S(S_L_S(hecke1))) != PERMUTATION )))
3677 {
3678 printf("hecke_mult() did not receive a linear combination of permutations as it was expecting!\n");
3679 return(ERROR);
3680 }
3681
3682 if (S_O_K(hecke2)!=LIST
3683 || (!empty_listp(hecke2)
3684 && (S_O_K(S_L_S(hecke2)) != MONOM
3685 || S_O_K(S_MO_S(S_L_S(hecke2))) != PERMUTATION )))
3686 {
3687 printf("hecke_mult() did not receive a linear combination of permutations as it was expecting!\n");
3688 return(ERROR);
3689 }
3690
3691 /* if result is not already a list, then make it one */
3692
3693 if (S_O_K(result)!=LIST)
3694 init(LIST,result);
3695
3696 /* return if there is nothing to process */
3697
3698 if (empty_listp(hecke1) || empty_listp(hecke2))
3699 return(OK);
3700
3701 /* For each element of the hecke1 list, make a copy of the hecke2
3702 list, and act on it with a copy of the permutation. Then go
3703 though the resulting list, multiplying each by the
3704 coefficient of the permutation, and accumulating them to result.
3705 */
3706
3707 imitate=callocobject();
3708 for (go_perm=hecke1;go_perm!=NULL;go_perm=S_L_N(go_perm))
3709 {
3710 copy_list(hecke2,imitate);
3711 copy_permutation(S_MO_S(S_L_S(go_perm)),perm_cop=callocobject());
3712
3713 hecke_action_perm_on_hecke(imitate,perm_cop);
3714
3715 for (temp=imitate;temp!=NULL;temp=S_L_N(temp))
3716 {
3717 mult_monopoly_monopoly(S_MO_K(S_L_S(go_perm)),S_MO_K(S_L_S(temp)),
3718 coeff=callocobject());
3719 hecke_accum(S_MO_S(S_L_S(temp)),coeff,result);
3720 }
3721 freeself(imitate);
3722 }
3723 freeall(imitate);
3724 return(OK);
3725 }
3726
3727
hecke_scale(hecke,power,coeff)3728 INT hecke_scale ( hecke, power, coeff)
3729 OP hecke;
3730 OP power;
3731 OP coeff;
3732
3733 /* Multiplies hecke, which is an hecke algebra element expressed as
3734 a q-linear combination of permutations, by coeff*q^power.
3735 hecke is updated with the result.
3736 */
3737
3738 {
3739 OP go_perm,temp;
3740
3741 /* first validate the inputs */
3742
3743 if (S_O_K(hecke)!=LIST
3744 || (!empty_listp(hecke)
3745 && (S_O_K(S_L_S(hecke)) != MONOM
3746 || S_O_K(S_MO_S(S_L_S(hecke))) != PERMUTATION )))
3747 {
3748 error("hecke_scale() did not receive a linear combination of permutations as it was expecting!\n");
3749 return(ERROR);
3750 }
3751
3752 if (S_O_K(power)!=INTEGER || S_O_K(coeff)!=INTEGER)
3753 {
3754 error("hecke_scale() did not receive the INTEGER parameters it was expecting!\n");
3755 return(ERROR);
3756 }
3757
3758 /* return if there is nothing to process */
3759
3760 if (empty_listp(hecke))
3761 return(OK);
3762
3763 /* For each element of the hecke list, multiply the coefficient. */
3764
3765 for (go_perm=hecke;go_perm!=NULL;go_perm=S_L_N(go_perm))
3766 {
3767 if ( !empty_listp(temp=S_MO_K(S_L_S(go_perm))) )
3768 for (;temp!=NULL;temp=S_L_N(temp))
3769 {
3770 add_apply_integer_integer(power,S_MO_S(S_L_S(temp)));
3771 mult_apply_integer_integer(coeff,S_MO_K(S_L_S(temp)));
3772 }
3773 }
3774
3775 return(OK);
3776 }
3777
3778
hecke_action_perm_on_hecke(heck,permutation)3779 INT hecke_action_perm_on_hecke ( heck, permutation)
3780 OP heck;
3781 OP permutation;
3782
3783 /* Applies the hecke algebra permutation to the hecke algebra
3784 element (linear combination of permutations).
3785 This list is updated with the result and the permutation is
3786 freed. There is no attempt to collect terms in the result.
3787 Requires that set_garnir_parameters() has been invoked.
3788 An ERROR may be generated if permutation is from a group bigger
3789 than the entries from heck.
3790 */
3791
3792 {
3793 INT i,j,k,lo_one,hi_one;
3794 OP perm,temp,new,coeff,monom,ext;
3795
3796 if (empty_listp(heck))
3797 {
3798 freeall(permutation);
3799 return(OK);
3800 }
3801
3802 set_useful_monopolies();
3803
3804 while (1)
3805 { /* look for a right factor s_k in reduced expression for permutation */
3806
3807 for (k=S_P_LI(permutation)-1;k>0
3808 && S_P_II(permutation,k)>S_P_II(permutation,k-1);k--);
3809
3810 if (!k) /* none present */
3811 break;
3812
3813 /* now apply s_k to hecke algebra list */
3814
3815 temp=heck;
3816 while (temp!=NULL)
3817 {
3818 perm=S_MO_S(S_L_S(temp));
3819 lo_one=hi_one= -1;
3820
3821 /* trawl through positions of perm looking for k & k+1 */
3822
3823 for (i=0;i<S_P_LI(perm);i++)
3824 if (S_P_II(perm,i)==k+1)
3825 {
3826 if (lo_one>-1) /* position of k already located */
3827 {
3828 /* enact the tranposition; coefficient is unchanged */
3829
3830 C_I_I(S_P_I(perm,lo_one),k+1);
3831 C_I_I(S_P_I(perm,i),k);
3832
3833 temp=S_L_N(temp);
3834 goto there; /* end processing of current perm */
3835 }
3836 else
3837 {
3838 hi_one=i;
3839 }
3840 }
3841 else if (S_P_II(perm,i)==k)
3842 {
3843 if (hi_one>-1) /* position of k+1 already located */
3844 {
3845 /* form a new element in the list, obtained by
3846 simple tranposition and multiply coeff by q. */
3847
3848 copy_permutation(perm,new=callocobject());
3849 C_I_I(S_P_I(new,hi_one),k);
3850 C_I_I(S_P_I(new,i),k+1);
3851 mult_monopoly_monopoly(q_mp,S_MO_K(S_L_S(temp)),
3852 coeff=callocobject());
3853 b_sk_mo(new,coeff,monom=callocobject());
3854 b_sn_l(monom,S_L_N(temp),ext=callocobject());
3855 C_L_N(temp,ext);
3856
3857 /* multiply old coefficient by q-1 */
3858
3859 mult_apply_monopoly(qm1_mp,S_MO_K(S_L_S(temp)));
3860
3861 temp=S_L_N(ext);
3862 goto there; /* end processing of current perm */
3863 }
3864 else
3865 {
3866 lo_one=i;
3867 }
3868 }
3869
3870 /* if we get here then we have not found both k & k+1 */
3871
3872 fprintf(stderr,"Incompatible permutations in hecke_action_perm_on_hecke()\n");
3873 free_useful_monopolies();
3874 return(ERROR);
3875
3876 there:
3877 ;
3878 }
3879 /* need to change the permutation */
3880
3881 i=S_P_II(permutation,k-1);
3882 C_I_I(S_P_I(permutation,k-1),S_P_II(permutation,k));
3883 C_I_I(S_P_I(permutation,k),i);
3884
3885 }
3886 /* free the permutation since it has been corrupted */
3887
3888 freeall(permutation);
3889 free_useful_monopolies();
3890 return(OK);
3891 }
3892
3893
3894
hecke_accum(perm,mp_coeff,acc_list)3895 static void hecke_accum ( perm, mp_coeff, acc_list)
3896 OP perm;
3897 OP mp_coeff;
3898 OP acc_list;
3899
3900 /* Adds mp_coeff * perm to our list: acc_list. perm is unchanged, and
3901 copied when necessary. mp_coeff is incorporated or destroyed.
3902 The list is maintained in lexicographic order.
3903 */
3904
3905 {
3906 OP a,b,term;
3907 OP t,temp;
3908 INT co;
3909
3910 if (empty_listp(acc_list))
3911 {
3912 t=callocobject();
3913 copy_permutation(perm,t);
3914 term=callocobject();
3915 b_sk_mo(t,mp_coeff,term);
3916 c_l_s(acc_list,term);
3917 }
3918 else
3919 { /* look for tableau in list */
3920
3921 for (a=acc_list,b=NULL;
3922 a!=NULL && (co=comp_permutation(S_MO_S(S_L_S(a)),perm))<0;
3923 a=S_L_N(b=a));
3924
3925 if (a==NULL || co>0) /* not present */
3926 {
3927 t=callocobject();
3928 copy_permutation(perm,t);
3929 term=callocobject();
3930 b_sk_mo(t,mp_coeff,term);
3931
3932 if (b==NULL) /* insert new first term (before a) */
3933 {
3934 b_ks_o(S_O_K(acc_list),S_O_S(acc_list),temp=callocobject());
3935 /* c_o_s(acc_list,NULL); */
3936 C_O_K(acc_list,EMPTY);
3937 b_sn_l(term,temp,acc_list);
3938 }
3939 else /* insert new term between b and a */
3940 {
3941 b_sn_l(term,a,temp=callocobject());
3942 C_L_N(b,temp);
3943 }
3944 }
3945 else /* term is present - must just add coefficients */
3946 {
3947 insert(mp_coeff,S_MO_K(S_L_S(a)),add_koeff,NULL);
3948
3949 }
3950 }
3951 }
3952
3953
3954
3955 /********************************************************************
3956 ********************************************************************
3957 ********************************************************************
3958
3959 The following routines are/were useful for debugging the above!
3960 Otherwise, they are not required.
3961
3962 ********************************************************************
3963 ********************************************************************
3964 ********************************************************************/
3965
3966
3967
3968 #ifdef DUMP
3969
3970
dump_lc_list(list)3971 dump_lc_list (list) OP list;
3972
3973 {
3974 OP mo;
3975
3976 if (list==NULL)
3977 {
3978 printf("list is NULL!");
3979 }
3980 else if (S_O_K(list)!=LIST)
3981 {
3982 printf("this is not a list!\n");
3983 }
3984 else if ( (list->ob_self).ob_list==NULL )
3985 {
3986 printf("list has null self!\n");
3987 }
3988 else if (S_L_S(list)==NULL)
3989 {
3990 printf("list self part is absent! (empty list?)\n");
3991
3992 /* this should be the case for an empty list (i.e. zero) */
3993 }
3994 else
3995 {
3996 mo=S_L_S(list);
3997
3998 printf("term (kind %ld) is (kind %ld):\n",S_O_K(mo),S_O_K(S_MO_S(mo)));
3999 println(S_MO_S(mo));
4000 printf("coefficient (kind %ld) is:\n",S_O_K(S_MO_K(mo)));
4001 dump_monopoly(S_MO_K(mo));
4002
4003 list=S_L_N(list);
4004 if (list!=NULL)
4005 dump_lc_list(list);
4006 }
4007 }
4008
4009
dump_monopoly(mp)4010 dump_monopoly (mp)
4011 OP mp;
4012 {
4013 OP mo;
4014
4015 if (mp==NULL)
4016 {
4017 printf("monopoly is NULL!");
4018 }
4019 else if (S_O_K(mp)!=MONOPOLY)
4020 {
4021 printf("this is not a monopoly!\n");
4022 }
4023 else if ( (mp->ob_self).ob_list==NULL )
4024 {
4025 printf("monopoly has null self!\n");
4026 }
4027 else if (S_L_S(mp)==NULL)
4028 {
4029 printf("monopoly self part is absent! (empty list?)\n");
4030
4031 /* this should be the case for an empty list (i.e. zero) */
4032
4033 }
4034 else
4035 {
4036 mo=S_L_S(mp);
4037 printf("+ (kind %ld) ",S_O_K(mo));
4038 fflush(stdout);
4039 printf("(%d * q^(%d)) ",
4040 S_I_I(S_MO_K(S_L_S(mp))),
4041 S_I_I(S_MO_S(S_L_S(mp))));
4042 mp=S_L_N(mp);
4043 if (mp==NULL)
4044 printf(".\n");
4045 else
4046 dump_monopoly(mp);
4047 }
4048 }
4049
4050
strip_buggle(tableau)4051 strip_buggle ( tableau) OP tableau;
4052
4053
4054 {
4055 INT i,disp,dispr1,dispr2;
4056 OP save_multiplier,overall,strip_list,tab;
4057 INT row1_pos,row2_pos,b_entry,s_entry;
4058 OP temp,ext,monom,koeff,new,big_list,partit,perm;
4059 FILE *fp;
4060
4061 if ((lcol=find_non_root_standard_pos(tableau))<0)
4062 {
4063 printf("Input tableau is standard.\n");
4064 return;
4065 }
4066
4067 /* identify the appropriate list: i becomes no of symmetrised boxes
4068 in 2nd row. disp is the rightward distance from the first box
4069 being symmetrised to the rightmost possible root-1 2nd row boxes
4070 symmetrisation. */
4071
4072 disp=row2-lcol-root+1;
4073 i= disp<0 ? row2-lcol : root-1;
4074
4075 printf("lcol=%ld, disp=%ld.\n",lcol,disp);
4076
4077 strip_list=s_v_i(symmetrised,i-1);
4078
4079 if (S_O_K(strip_list)==EMPTY)
4080 { /* need to generate the model expression for this standardisation */
4081
4082 generate_sym_tableaux_list(i,strip_list);
4083 }
4084
4085 /* identify the map from the canonical strip relation to the current
4086 problem using the first term in the list. */
4087
4088 tab=S_MO_S(S_L_S(strip_list));
4089
4090 if (disp<=0)
4091 { /* easy case - use stored list pretty much as it stands. First form
4092 the map from the canonical non strip-standard tableau (this is
4093 stored as the first element in the list). */
4094
4095 printf("1st case: lcol=%ld, disp=%ld.\n",lcol,disp);
4096
4097 for (i=0;i<row1;i++)
4098 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i);
4099 for (i=0;i<row2;i++)
4100 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i);
4101 }
4102 else if (kappa==1)
4103 { /* this is a trickier case, where the symmetrised section needs
4104 to be used at different positions to where it has been formed
4105 in the canonical list */
4106
4107 printf("2nd case: lcol=%ld, disp=%ld.\n",lcol,disp);
4108
4109 dispr1=row1-disp;
4110 dispr2=row2-disp;
4111
4112 /* This first loop defines the map for the last disp entries
4113 of each row. */
4114
4115 for (i=0;i<disp;i++)
4116 {
4117 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i+dispr1);
4118 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i+dispr2);
4119 }
4120
4121 /* Then provide map for remainder of entries, which after being
4122 mapped are moved disp positions to the left. */
4123
4124 for (i=disp;i<row2;i++)
4125 {
4126 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i-disp);
4127 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i-disp);
4128 }
4129 for (i=row2;i<row1;i++)
4130 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i-disp);
4131 }
4132 else /* if (kappa>1) */
4133 { /* this is an even trickier case, where the symmetrised section needs
4134 to be used at different positions to where it has been formed
4135 in the canonical list, the entries to its right set up, permuted,
4136 and enacted upon. */
4137
4138 printf("3rd case: lcol=%ld, disp=%ld.\n",lcol,disp);
4139
4140 dispr1=row1-disp;
4141 dispr2=row2-disp;
4142
4143 /* This first loop defines the map for the last disp entries
4144 of each row. */
4145
4146 for (i=0;i<disp;i++)
4147 map[S_T_IJI(tab,1,i)]=2*(dispr2+i)+ostrip+1;
4148
4149 for (i=0;i<disp+ostrip+row2-row1;i++)
4150 map[S_T_IJI(tab,0,i)]=2*(dispr1+1+i)-ostrip;
4151
4152 for (;i<disp;i++)
4153 map[S_T_IJI(tab,0,i)]=row1+row2-disp+1+i;
4154
4155 /* Then provide map for remainder of entries, which after being
4156 mapped are moved disp positions to the left. */
4157
4158 for (i=disp;i<=row2-root;i++)
4159 map[S_T_IJI(tab,1,i)]=S_T_IJI(tableau,1,i-disp);
4160
4161 for (;i<row2;i++)
4162 map[S_T_IJI(tab,1,i)]=dispr2+ostrip+1-disp+i;
4163
4164 for (i=disp;i<row2+ostrip;i++)
4165 map[S_T_IJI(tab,0,i)]=S_T_IJI(tableau,0,i-disp);
4166
4167 for (;i<row1 && i<row2+ostrip+disp;i++)
4168 map[S_T_IJI(tab,0,i)]=2*(i+1-disp)-ostrip;
4169
4170 for (;i<row1;i++)
4171 map[S_T_IJI(tab,0,i)]=dispr2+1+i;
4172
4173 printf("[ ");
4174 for (i=1;i<=row1+row2;i++)
4175 printf("%2ld ",i);
4176 printf("]\n");
4177 printf("[ ");
4178 for (i=1;i<=row1+row2;i++)
4179 printf("%2ld ",map[i]);
4180 printf("]\n");
4181
4182 /* go through list, and copy each term, after acting on each with
4183 the above permutation */
4184
4185 partit=s_t_u(tableau);
4186 temp=big_list=NULL;
4187
4188 for (;strip_list!=NULL;strip_list=S_L_N(strip_list))
4189 {
4190 tab=S_MO_S(S_L_S(strip_list));
4191
4192 m_u_t(partit,new=callocobject());
4193
4194 for (i=0;i<disp;i++)
4195 m_i_i(map[S_T_IJI(tab,0,i)],S_T_IJ(new,0,i+dispr1));
4196
4197 for (i=disp;i<row1;i++)
4198 m_i_i(map[S_T_IJI(tab,0,i)],S_T_IJ(new,0,i-disp));
4199
4200 for (i=0;i<disp;i++)
4201 m_i_i(map[S_T_IJI(tab,1,i)],S_T_IJ(new,1,i+dispr2));
4202
4203 for (i=disp;i<row2;i++)
4204 m_i_i(map[S_T_IJI(tab,1,i)],S_T_IJ(new,1,i-disp));
4205
4206 /* need to change this so that the list
4207 is copied in the correct order */
4208
4209 copy_list(S_MO_K(S_L_S(strip_list)),koeff=callocobject());
4210 b_sk_mo(new,koeff,monom=callocobject());
4211 b_sn_l(monom,NULL,ext=callocobject());
4212 if (temp==NULL)
4213 big_list=ext;
4214 else
4215 C_L_N(temp,ext);
4216 temp=ext;
4217 }
4218
4219 /* then recursively multiply each by (s_i-q) for each appropriate i. */
4220
4221 for (i=disp-1;i>=0;i--)
4222 {
4223 row1_pos=row2-disp+ostrip+i;
4224 row2_pos=row2-disp+i;
4225 s_entry=row1_pos+row2_pos+1;
4226 b_entry=s_entry+1;
4227
4228 /* act on each term to double the list size */
4229
4230 for (temp=big_list;temp!=NULL;temp=S_L_N(ext))
4231 {
4232 /* put a copy of the term AFTER the current one,
4233 mutliply the new by -q, and transpose the old. */
4234
4235 copy_monom(S_L_S(temp),monom=callocobject());
4236 mult_apply_monopoly(mq_mp,S_MO_K(monom));
4237 C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),0,row1_pos),s_entry);
4238 C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),1,row2_pos),b_entry);
4239
4240 b_sn_l(monom,S_L_N(temp),ext=callocobject());
4241 C_L_N(temp,ext);
4242 }
4243 }
4244
4245
4246 fp=fopen("dump1.dat","w");
4247 fprintln(fp,big_list);
4248 fclose(fp);
4249
4250
4251 /* now effect a hecke permutation on the list, in order to
4252 take the first element of the big_list to tableau (the
4253 current non root-standard tableau). Then ignore
4254 the first (non root-standard) element; and resubmit for
4255 recursive standardisation.
4256 */
4257
4258 m_il_p(row1+row2,perm=callocobject());
4259 for (i=0;i<b_entry-root;i++)
4260 m_i_i(i+1,S_P_I(perm,i));
4261
4262 printf("Required 1 permutation is:\n");
4263 println(perm);
4264
4265 for (i=row2_pos-root+2;i<row2;i++)
4266 m_i_i(S_T_IJI(tableau,1,i),
4267 S_P_I(perm,S_T_IJI(S_MO_S(S_L_S(big_list)),1,i)-1));
4268
4269 printf("Required 2 permutation is:\n");
4270 println(perm);
4271
4272 for (i=row1_pos;i<row1;i++)
4273 m_i_i(S_T_IJI(tableau,0,i),
4274 S_P_I(perm,S_T_IJI(S_MO_S(S_L_S(big_list)),0,i)-1));
4275
4276 printf("Required 4 permutation is:\n");
4277 println(perm);
4278
4279 hecke_action_perm_on_lc(big_list,perm);
4280
4281 fp=fopen("dump2.dat","w");
4282 fprintln(fp,big_list);
4283 fclose(fp);
4284
4285 freeall(big_list);
4286 }
4287
4288 }
4289
4290
4291 #endif
4292
4293
4294
4295