1 /* file bar.c symmetrica */
2 #include "def.h"
3 #include "macro.h"
4
5 #ifdef PERMTRUE
cast_apply_barperm(a)6 INT cast_apply_barperm(a) OP a;
7 /* AK 280294 */
8 {
9 INT erg = OK;
10 EOP("cast_apply_barperm(1)",a);
11 switch(S_O_K(a))
12 {
13 case VECTOR:
14 erg += m_ks_p(VECTOR,a,a);
15 C_P_K(a,BAR);
16 break;
17 case PERMUTATION:
18 if (S_P_K(a) == BAR)
19 break;
20 else if (S_P_K(a) == VECTOR)
21 {
22 C_P_K(a,BAR);
23 break;
24 }
25 default:
26 printobjectkind(a);
27 erg += WTO("cast_apply_barperm",a);
28 break;
29 }
30 ENDR("cast_apply_barperm");
31 }
32
invers_bar(a,b)33 INT invers_bar(a,b) OP a,b;
34 {
35 INT i,erg =OK,j;
36 CH2D(a,b);
37 erg += b_ks_p(VECTOR,callocobject(),b);
38 erg += absolute(S_P_S(a),S_P_S(b));
39 erg += invers(b,b);
40 for (i=0L;i<S_P_LI(a);i++)
41 if (S_P_II(a,i) < 0)
42 {
43 j = (S_P_II(a,i)+1)* (-1);
44 M_I_I(S_P_II(b,j) * -1, S_P_I(b,j));
45 }
46 C_P_K(b,BAR);
47 ENDR("invers_bar");
48 }
49
new_divdiff_bar(a,b,c)50 INT new_divdiff_bar(a,b,c) OP a,b,c;
51 {
52 OP d;
53 INT erg = OK;
54 CTO(PERMUTATION,"new_divdiff_bar(1)",a);
55 d = callocobject();
56 erg += rz(a,d);
57 erg += new_divideddiff_rz_bar(d,b,c);
58 erg += freeall(d);
59 ENDR("new_divdiff_bar");
60
61 }
divdiff_bar(a,b,c)62 INT divdiff_bar(a,b,c) OP a,b,c;
63 {
64 OP d;
65 INT erg = OK;
66 CTO(PERMUTATION,"divdiff_bar(1)",a);
67 d = callocobject();
68 erg += rz(a,d);
69 erg += divideddiff_rz_bar(d,b,c);
70 erg += freeall(d);
71 ENDR("divdiff_bar");
72
73 }
74
new_divideddiff_rz_bar(rzt,poly,c)75 INT new_divideddiff_rz_bar(rzt,poly,c) OP rzt, poly, c;
76 /* AK 020392 */
77 /* rzt is reduced decomposition of barred permutation */
78 {
79 INT i = 0 ;
80 INT erg = OK;
81 erg += copy (poly,c);
82 if (EMPTYP(rzt))
83 goto endr_ende;
84 while (i < S_V_LI(rzt))
85 {
86 erg += new_divideddifference_bar(S_V_I(rzt,i),c,c);
87 i++;
88 };
89 ENDR("new_divideddiff_rz_bar");
90 }
91
divideddiff_rz_bar(rzt,poly,c)92 INT divideddiff_rz_bar(rzt,poly,c) OP rzt, poly, c;
93 /* AK 020392 */
94 /* rzt is reduced decomposition of barred permutation */
95 {
96 INT i = 0 ;
97 INT erg = OK;
98 erg += copy (poly,c);
99 if (EMPTYP(rzt))
100 goto endr_ende;
101 while (i < S_V_LI(rzt))
102 {
103 erg += divideddifference_bar(S_V_I(rzt,i),c,c);
104 i++;
105 };
106 ENDR("divideddiff_rz_bar");
107 }
108
109 #ifdef POLYTRUE
divideddifference_bar(i,poly,c)110 INT divideddifference_bar(i,poly,c) OP i,poly,c;
111 {
112
113 OP zeiger = poly, zwischen;
114 INT index = S_I_I(i) -1L, j,k, expo1, expo2 ,erg = OK;
115
116 if (EMPTYP(poly)) return(OK);
117 zwischen = callocobject();
118 if (poly == c)
119 {
120 *zwischen = *c;
121 C_O_K(c,0);
122 erg += divideddifference_bar(i,zwischen,c);
123 erg += freeall(zwischen);
124 return erg;
125 };
126 init(POLYNOM,c);
127
128 if (index < 0L) /* symplectic */
129 {
130 index++;
131 copy(poly,zwischen);
132 zeiger =zwischen;
133 while (zeiger != NULL)
134 {
135 if (S_L_S(zeiger) != NULL) {
136 if (S_PO_SLI(zeiger) >= -index)
137 if (S_PO_SII(zeiger,-index -1) % 2L == 1L)
138 addinvers(S_PO_K(zeiger),S_PO_K(zeiger));
139 }
140 zeiger = S_PO_N(zeiger);
141 }
142 sub(poly,zwischen,c);
143 zeiger =c;
144 while (zeiger != NULL)
145 {
146 if (S_L_S(zeiger) != NULL) {
147 if (S_PO_SLI(zeiger) >= -index)
148 {
149 dec(S_PO_SI(zeiger,-index-1L));
150 div(S_PO_K(zeiger),cons_zwei,S_PO_K(zeiger));
151 }
152 }
153 zeiger = S_PO_N(zeiger);
154 }
155 freeall(zwischen);
156 return OK;
157 }
158
159
160 while (zeiger != NULL)
161 {
162 if (S_L_S(zeiger) != NULL)
163 {
164 if (S_O_K(S_PO_S(zeiger)) != VECTOR)
165 {
166 printobjectkind(S_PO_S(zeiger));
167 error("kind != VECTOR in divideddifference_bar");
168 return(ERROR);
169 };
170
171 if (S_I_I(i) == S_PO_SLI(zeiger))
172 /* operiert auf letzten exponenten */
173 {
174 inc(S_PO_S(zeiger));
175 M_I_I(0L,S_PO_SI(zeiger,S_I_I(i)));
176 }
177 else if (S_I_I(i) > S_PO_SLI(zeiger)) goto dividedend;
178 expo1 = S_PO_SII(zeiger,index);
179 expo2 = S_PO_SII(zeiger,index + 1L);
180 if (expo1 > expo2)
181 {
182 for (j=expo1-1L,k=expo2 ;j>= expo2; j--,k++)
183 {
184 b_skn_po(callocobject(),callocobject(),NULL,zwischen);
185 copy(S_PO_S(zeiger),S_PO_S(zwischen));
186 copy(S_PO_K(zeiger),S_PO_K(zwischen));
187 M_I_I(j,S_PO_SI(zwischen,index));
188 M_I_I(k,S_PO_SI(zwischen,index+1L));
189 add_apply(zwischen,c);
190 freeself(zwischen);
191 };
192 }
193 else if (expo1 < expo2)
194 {
195 for (j=expo2-1L,k=expo1 ;j>= expo1; j--,k++)
196 {
197 b_skn_po(callocobject(),callocobject(),NULL,zwischen);
198 copy(S_PO_S(zeiger),S_PO_S(zwischen));
199 addinvers(S_PO_K(zeiger),S_PO_K(zwischen));
200 M_I_I(j,S_PO_SI(zwischen,index));
201 M_I_I(k,S_PO_SI(zwischen,index+1));
202 add_apply(zwischen,c);
203 freeself(zwischen);
204 }
205 };
206 }
207 dividedend:
208 zeiger = S_PO_N(zeiger);
209 };
210 freeall(zwischen);
211 return(OK);
212 }
213 #endif /* POLYTRUE */
214
rz_bar(a,b)215 INT rz_bar(a,b) OP a,b;
216 /* AK 050995 */
217 {
218 INT erg = OK;
219 OP c;
220 CTO(PERMUTATION,"rz_bar(1)",a);
221
222 c = callocobject();
223 erg += lehmercode(a,c);
224 erg += rz_lehmercode_bar(c,b);
225 erg += freeall(c);
226 ENDR("rz_bar");
227 }
228
rz_lehmercode_bar(a,b)229 INT rz_lehmercode_bar(a,b) OP a,b;
230 /* AK 020392 */
231 {
232 OP e,f,g;
233 INT i,j,k;
234 INT erg = OK;
235 CTO(VECTOR,"rz_lehmercode_bar(1)",a);
236
237 g = callocobject();
238 e = S_V_I(a,0L);
239 f = S_V_I(a,1L);
240 erg += SYM_sum(f,g);
241 j=0L;
242 for (i=0L;i<S_V_LI(e);i++)
243 j += S_V_II(e,i)*(i+1L);
244 j += S_I_I(g); /* j is the length of reduced decomposition */
245 erg += m_il_v(j,b);
246 if (j == 0L) goto ende;
247 j=0L; /* position in rc */
248 for (i=0L;i<S_V_LI(e);i++)
249 if (S_V_II(e,i) == 1L)
250 {
251 for (k=i+1L;k>1L;k--,j++)
252 erg += m_i_i(k-1L,S_V_I(b,j));
253 erg += m_i_i(-1L,S_V_I(b,j++));
254 }
255 /* now the rc for the lehmercode in f */
256 erg += rz_lehmercode(f,g);
257 for (i=0L;i<S_V_LI(g);i++,j++)
258 erg += m_i_i(S_V_II(g,i),S_V_I(b,j));
259 ende:
260 erg += freeall(g);
261 ENDR("rz_lehmercode_bar");
262 }
263
sscan_bar(t,a)264 INT sscan_bar(t,a) OP a; char *t;
265 /* AK 050194 to read permutation from string
266 format [1,2,3,..]
267 */
268 {
269 INT erg = OK;
270 COP("sscan_bar(1)",t);
271 CTO(EMPTY,"sscan_bar(2)",a);
272 erg += b_ks_p(VECTOR,callocobject(),a);
273 erg += sscan(t,INTEGERVECTOR,S_P_S(a));
274 C_P_K(a,BAR);
275 ENDR("sscan_permutation");
276 }
277
scan_bar(b)278 INT scan_bar(b) OP b;
279 /* AK 230695 */
280 {
281 INT erg=OK;
282 CTO(EMPTY,"scan_bar(1)",b);
283 spa:
284 erg = OK;
285 erg += b_ks_p(VECTOR,callocobject(),b);
286 erg += printeingabe("input of a barred permutation in list notation");
287 erg += scan(INTEGERVECTOR,S_P_S(b));
288 C_P_K(b,BAR);
289 if (not strong_check_barp(b))
290 {
291 fprintln(stderr,b);
292 printeingabe("wrong input, please enter a barred permutation");
293 goto spa;
294 }
295 ENDR("scan_bar");
296 }
297
strong_check_barp(a)298 INT strong_check_barp(a) OP a;
299 /* AK 230695 */
300 {
301 OP h;
302 INT i,SYM_abs();
303
304 if (a == NULL)
305 return FALSE;
306 if (S_O_K(a) != PERMUTATION)
307 return FALSE;
308 if (
309 (S_P_K(a) == BARCYCLE)
310 ||
311 (S_P_K(a) == BAR)
312 )
313 {
314 if (S_P_S(a) == NULL)
315 return FALSE;
316 if (
317 (S_O_K(S_P_S(a)) != INTEGERVECTOR)
318 &&
319 (S_O_K(S_P_S(a)) != VECTOR)
320 )
321 return FALSE;
322 h = callocobject();
323 m_il_v(S_P_LI(a),h);
324 for (i=0L;i<S_V_LI(h);i++)
325 M_I_I(i+(INT)1, S_V_I(h,i));
326 for (i=0L;i<S_V_LI(h);i++)
327 M_I_I((INT)0, S_V_I(h,SYM_abs(S_P_II(a,i)) -(INT)1));
328 i = nullp(h);
329 freeall(h);
330 return i;
331 }
332 return FALSE;
333 }
334
335
first_bar(a,b)336 INT first_bar(a,b) OP a,b;
337 /* AK 230695 */
338 {
339 INT erg = OK;
340 CTO(INTEGER,"first_bar",a);
341 CE2(a,b,first_bar);
342 erg += first_permutation(a,b);
343 C_P_K(b,BAR);
344 ENDR("first_bar");
345 }
346
max_bar(a,b)347 INT max_bar(a,b) OP a,b;
348 /* AK 060995 */
349 /* barred perm with maiximal reduced length */
350 {
351 INT i,erg = OK;
352 CTO(INTEGER,"max_bar",a);
353 if (check_equal_2(a,b,max_bar,&erg) == EQUAL)
354 return erg;
355 erg += first_bar(a,b);
356 for (i=0;i<S_P_LI(b);i++)
357 M_I_I(S_P_II(b,i) * (-1) , S_P_I(b,i));
358 C_P_K(b,BAR);
359 ENDR("max_bar");
360 }
361
362
ordcon_bar(a,b)363 INT ordcon_bar(a,b) OP a,b;
364 /* AK 260292 */
365 {
366 OP c;
367 INT erg = OK;
368 CTTO(KRANZTYPUS,MATRIX,"ordcon_bar(1)",a);
369 c = callocobject();
370 erg += hoch(cons_zwei,S_M_H(a),b);
371 erg += fakul(S_M_H(a),c);
372 erg += mult_apply(c,b);
373 erg += ordcen_bar(a,c);
374 erg += div(b,c,b);
375 erg += freeall(c);
376 ENDR("ordcon_bar");
377 }
378
ordcen_bar(a,b)379 INT ordcen_bar(a,b) OP a,b;
380 /* AK 260292 */
381 {
382 INT i,j;
383 INT erg = OK;
384 OP c;
385 CTTO(KRANZTYPUS,MATRIX,"ordcen_bar(1)",a);
386 c = callocobject();
387 erg += m_i_i(1L,b);
388 for (i=0L;i<S_M_HI(a);i++)
389 for (j=0L;j<S_M_LI(a);j++)
390 {
391 erg += fakul(S_M_IJ(a,i,j),c);
392 erg += mult_apply(c,b);
393 erg += m_i_i((i+1L) * 2L,c);
394 erg += hoch(c,S_M_IJ(a,i,j),c);
395 erg += mult_apply(c,b);
396 }
397 erg += freeall(c);
398 ENDR("ordcen_bar");
399 }
400
makevectorof_class_rep_bar(a,b)401 INT makevectorof_class_rep_bar(a,b) OP a,b;
402 /* AK 260292 */
403 {
404 INT i,erg=OK;
405 OP c;
406 CTO(INTEGER,"makevectorof_class_rep_bar(1)",a);
407 c = callocobject();
408
409 erg += makevectorof_class_bar(a,c);
410 erg += m_il_v(S_V_LI(c),b);
411 for (i=0L;i<S_V_LI(c);i++)
412 erg += class_rep_bar(S_V_I(c,i),S_V_I(b,i));
413 erg += freeall(c);
414 ENDR("makevectorof_class_rep_bar");
415 }
416
makevectorof_class_bar(a,b)417 INT makevectorof_class_bar(a,b) OP a,b;
418 /* AK 260292 */
419 {
420 INT i,erg=OK;
421 OP c;
422 CTO(INTEGER,"makevectorof_class_bar(1)",a);
423 c = callocobject();
424
425 erg += makevectorof_kranztypus(a,cons_zwei,c);
426 erg += m_il_v(S_V_LI(c),b);
427 for (i=0L;i<S_V_LI(b);i++)
428 erg += kranztypus_to_matrix(S_V_I(c,i),S_V_I(b,i));
429 erg += freeall(c);
430 erg += SYM_sort(b); /* AK 130592 */
431 ENDR("makevectorof_class_bar");
432 }
433
class_rep_bar(a,b)434 INT class_rep_bar(a,b) OP a,b;
435 /* AK 260292 */
436 {
437 INT i,j,k=0L,l;
438 m_il_p(S_M_HI(a),b);
439 C_P_K(b,BAR);
440 for (i=0L;i<S_M_HI(a);i++)
441 {
442 for (j=0L;j<S_M_IJI(a,i,0L);j++)
443 {
444 for (l=0L;l<=i;l++)
445 {
446 m_i_i(k+2L,S_P_I(b,k));
447 k++;
448 }
449 m_i_i(-(k-i),S_P_I(b,k-1L)); /* damit ist ein i+1 Zykel
450 mit -
451 fertig */
452 }
453 for (j=0L;j<S_M_IJI(a,i,1L);j++)
454 {
455 for (l=0L;l<=i;l++)
456 {
457 m_i_i(k+2L,S_P_I(b,k));
458 k++;
459 }
460 m_i_i(k-i,S_P_I(b,k-1L)); /* damit ist ein i+1 Zykel
461 fertig */
462 }
463 }
464 return OK;
465 }
466
467
class_bar(a,b)468 INT class_bar(a,b) OP a,b;
469 /* AK 260292 */
470 {
471 INT i,j,k,m,n;
472 INT erg = OK;
473 OP c;
474 CTO(PERMUTATION,"class_bar(1)",a);
475 c = callocobject();
476 erg += m_ilih_nm(2L,S_P_LI(a),b);
477 erg += t_BAR_BARCYCLE(a,c);
478 m = ((S_P_II(c,0L) < 0L) ? -S_P_II(c,0L) : S_P_II(c,0L) );
479 j=0L;n=0L;
480 for (i=0L;i<S_P_LI(c);i++)
481 {
482 k = ((S_P_II(c,i) < 0L) ? -S_P_II(c,i) : S_P_II(c,i) );
483 /* wert ohne vorzeichen */
484 if (k < m) /* d.h. hier geht ein neuer Zykel los */
485 {
486 /* j ist laenge, n anzahl minus */
487 INC_INTEGER (S_M_IJ(b,j-1L,n%2L));
488 m = ((S_P_II(c,i) < 0L) ? -S_P_II(c,i) : S_P_II(c,i) );
489 /* m ist der wert am zykel anfang */
490 j = 1L;
491 n = ((S_P_II(c,i) < 0L) ? 1L : 0L );
492 }
493 else {
494 j++; /* der zykel geht weiter */
495 if (S_P_II(c,i) < 0L) n ++; /* noch ein minus */
496 }
497 }
498 INC_INTEGER (S_M_IJ(b,j-1L,n%2L));
499 erg += freeall(c);
500 ENDR("class_bar");
501 }
502
t_BARCYCLE_BAR(a,b)503 INT t_BARCYCLE_BAR(a,b) OP a,b;
504 /* AK 260292 */
505 {
506 INT i,j;
507 INT erg = OK;
508 OP c;
509 CTO(PERMUTATION,"t_BARCYCLE_BAR",a);
510 CE2(a,b,t_BARCYCLE_BAR);
511
512 c = callocobject();
513 erg += copy_permutation(a,c);
514 for (i=0L;i<S_P_LI(c); i++)
515 if (S_P_II(c,i) < 0L) M_I_I(-S_P_II(c,i), S_P_I(c,i));
516 C_P_K(c,ZYKEL);
517 erg += t_zperm_vperm(c,b);
518 C_P_K(b,BAR);
519 for (i=0L;i<S_P_LI(a); i++)
520 if (S_P_II(a,i) < 0L)
521 for (j=0L;j<S_P_LI(b); j++)
522 if (S_P_II(b,j) == - S_P_II(a,i))
523 {
524 M_I_I(-S_P_II(b,j), S_P_I(b,j));
525 break;
526 }
527 erg += freeall(c);
528 ENDR("t_BARCYCLE_BAR");
529 }
530
t_BAR_BARCYCLE(a,b)531 INT t_BAR_BARCYCLE(a,b) OP a,b;
532 /* AK 260292 */
533 {
534 INT i,j;
535 OP c = callocobject();
536 copy(a,c);
537 for (i=0L;i<S_P_LI(c); i++)
538 if (S_P_II(c,i) < 0L) M_I_I(-S_P_II(c,i), S_P_I(c,i));
539 C_P_K(c,VECTOR);
540 t_vperm_zperm(c,b);
541 C_P_K(b,BARCYCLE);
542 for (i=0L;i<S_P_LI(a); i++)
543 if (S_P_II(a,i) < 0L)
544 for (j=0L;j<S_P_LI(b); j++)
545 if (S_P_II(b,j) == - S_P_II(a,i))
546 {
547 M_I_I(-S_P_II(b,j), S_P_I(b,j));
548 break;
549 }
550 freeall(c);
551 return OK;
552 }
553
mult_bar_bar(a,b,c)554 INT mult_bar_bar(a,b,c) OP a,b,c;
555 /* AK 250292 */
556 {
557 INT i;
558 INT erg = OK;
559 CTO(PERMUTATION,"mult_bar_bar(1)",a);
560 CTO(PERMUTATION,"mult_bar_bar(2)",b);
561 SYMCHECK( S_P_LI(a) != S_P_LI(b) ,
562 "mult_bar_bar: different lengths");
563
564 erg += m_il_p(S_P_LI(a),c);
565 C_P_K(c,BAR);
566 for (i=0L;i<S_P_LI(c);i++)
567 {
568 if (S_P_II(b,i) < 0L)
569 {
570 /* if (S_P_II(a, - S_P_II(b,i) -1L) > 0L) */
571 erg += m_i_i(- S_P_II(a,- S_P_II(b,i)-1L), S_P_I(c,i));
572 /* else
573 erg += m_i_i(- S_P_II(a,- S_P_II(b,i)-1L), S_P_I(c,i));*/
574 }
575 else
576 erg += m_i_i(S_P_II(a,S_P_II(b,i)-1L), S_P_I(c,i));
577
578 }
579 ENDR("mult_bar_bar");
580 }
581
random_bar(n,b)582 INT random_bar(n,b) OP n,b;
583 /* AK 250292 */
584 {
585 OP a,c;
586 INT i,erg = OK;
587 CTO(INTEGER,"random_bar(1)",n);
588 CTO(EMPTY,"random_bar(2)",b);
589
590 a = callocobject();
591 c = callocobject();
592 erg += m_il_v(2L,a);
593 erg += m_l_nv(n,S_V_I(a,0L));
594 erg += random_permutation(n,c);
595 erg += lehmercode(c,S_V_I(a,1L));
596 for (i=0L;i<S_I_I(n);i++)
597 {
598 erg += random_integer(c,NULL,NULL);
599 if (oddp(c))
600 erg += m_i_i(1L,S_V_I(S_V_I(a,0L),i));
601 }
602 erg += lehmercode_vector_bar(a,b);
603 erg += freeall(c);
604 erg += freeall(a);
605 ENDR("random_bar");
606 }
607
length_bar(a,b)608 INT length_bar(a,b) OP a,b;
609 /* AK 250292 */
610 {
611 OP c,d;
612 INT i,erg = OK;
613 CTO(PERMUTATION,"length_bar(1)",a);
614 CTO(EMPTY,"length_bar(2)",b);
615 c = callocobject();
616 d = callocobject();
617 erg += lehmercode_bar(a,c);
618 erg += SYM_sum(S_V_I(c,1L),b);
619 for(i=0L;i<S_P_LI(a);i++)
620 {
621 if (S_V_II(S_V_I(c,0L),i) == 1L)
622 {
623 erg += m_i_i(i+1L,d);
624 erg += add_apply(d,b);
625 }
626 }
627 erg += freeall(c);
628 erg += freeall(d);
629 ENDR("length_bar");
630 }
631
lehmercode_bar(a,b)632 INT lehmercode_bar(a,b) OP a,b;
633 /* AK 250292 */
634 {
635 INT i,j;
636 INT erg = OK;
637 CTO(PERMUTATION,"lehmercode_bar(1)",a);
638 SYMCHECK(S_P_K(a) != BAR,"lehmercode_bar(1):no barred permutation");
639
640 m_il_v(2L,b);
641 m_l_nv(S_P_L(a),S_V_I(b,0L));
642 m_l_nv(S_P_L(a),S_V_I(b,1L));
643 for (i=0L;i<S_P_LI(a);i++)
644 {
645 if (S_P_II(a,i) < 0L)
646 m_i_i(1L,S_V_I(S_V_I(b,0L),-S_P_II(a,i) -1L));
647 for (j=i+1L;j<S_P_LI(a);j++)
648 if (S_P_II(a,j) < S_P_II(a,i))
649 inc(S_V_I(S_V_I(b,1L),i));
650 }
651 ENDR("lehmercode_bar");
652 }
653
654
next_apply_bar(a)655 INT next_apply_bar(a) OP a;
656 /* AK 120902 V2.1 */
657 {
658 return next_bar(a,a);
659 }
next_bar(a,b)660 INT next_bar(a,b) OP a,b;
661 /* AK 230695 */
662 /* AK 120902 V2.1 */
663 /* a and b may be equal */
664 {
665 INT erg,i;
666 OP c,d;
667 c = callocobject();
668 d = callocobject();
669 lehmercode_bar(a,c);
670 m_il_v(2L,d);
671 erg = next_lehmercode(S_V_I(c,1L),S_V_I(d,1L));
672 if (erg != LASTLEHMERCODE)
673 {
674 copy(S_V_I(c,0L),S_V_I(d,0L));
675 goto bb;
676 }
677 /* now next distribution of minus */
678 copy(S_V_I(c,0L),S_V_I(d,0L));
679 erg = 0;
680 for (i=0;i<S_V_LI(S_V_I(d,0L));i++)
681 if (S_V_II(S_V_I(d,0L),i) == 1) erg++;
682 /* erg == gewicht */
683 if (erg == S_P_LI(a))
684 {
685 erg = LASTPERMUTATION;
686 goto aa;
687 }
688 first_lehmercode(S_P_L(a),S_V_I(d,1L));
689 /* now vector of minus */
690 for (i=1;i<S_V_LI(S_V_I(d,0L));i++)
691 if ((S_V_II(S_V_I(d,0L),i) == 0) &&
692 (S_V_II(S_V_I(d,0L),i-1) == 1) )
693 {
694 M_I_I(1,S_V_I(S_V_I(d,0L),i));
695 M_I_I(0,S_V_I(S_V_I(d,0L),i-1));
696 goto bb;
697 }
698 /* now all the minus are on the right end */
699 for (i=0;i<= erg;i++)
700 M_I_I(1,S_V_I(S_V_I(d,0L),i));
701 for (;i<S_P_LI(a);i++)
702 M_I_I(0,S_V_I(S_V_I(d,0L),i));
703
704 bb:
705 lehmercode_vector_bar(d,b);
706 erg = OK;
707
708 aa:
709 freeall(c);
710 freeall(d);
711 return erg;
712 }
713
714
lehmercode_vector_bar(a,b)715 INT lehmercode_vector_bar(a,b) OP a,b;
716 /* AK 250292 */
717 {
718 INT i,j,k;
719 OP self,liste,vec;
720 k= S_V_LI(S_V_I(a,0L));
721
722 self = callocobject();
723 liste = callocobject();
724
725 m_il_v(k,self);
726 m_il_v(k,liste);
727 /* initialisierung zweier vektoren fuer
728 eine Liste und fuer die zu berechnende Permutation */
729 j=0L;
730 for(i=k-1L;i>=0L;i--)
731 {
732 if (S_V_II(S_V_I(a,0L),i) == 1L)
733 m_i_i(-i-1L,S_V_I(liste,j++));
734 }
735 for(i=0L;i<k;i++)
736 {
737 if (S_V_II(S_V_I(a,0L),i) == 0L)
738 m_i_i(i+1L,S_V_I(liste,j++));
739 }
740 /* liste ist jetzt ein vector [..neg..pos..] */
741 vec = S_V_I(a,1L);
742 for(i=0L;i<S_V_LI(vec);i++)
743 {
744 k=S_V_II(vec,i);
745 /* k ist ist das i-te Element aus vec, also vi */
746 M_I_I(S_V_II(liste,k),S_V_I(self,i));
747 /* daher ist ei = k-te Element aus der aktuellen Liste*/
748 for (j=k;j<(S_V_LI(vec)-1L)-i;j++)
749 /* in der liste wird das k-te Element gestrichen.
750 und von rechts aufgefuellt */
751 C_I_I(S_V_I(liste,j),S_V_II(liste,j+1L));
752 };
753 freeall(liste);
754
755 b_ks_p(BAR,self,b);
756 /* bildung einer Permutation aus dem vector */
757 return(OK);
758 }
759
760 #ifdef POLYTRUE
761
new_divideddifference_bar(i,poly,c)762 INT new_divideddifference_bar(i,poly,c) OP i,poly,c;
763 {
764 divideddifference_bar(i,poly,c);
765 /* if (S_I_I(i) > 0)
766 addinvers(c,c); */
767 return OK;
768 }
769
scalarproduct_bar_schubert(a,b,g)770 INT scalarproduct_bar_schubert(a,b,g) OP a,b,g;
771 {
772 INT erg = OK;
773 OP c,d,e,f;
774 CTO(PERMUTATION,"scalarproduct_bar_schubert(1)",a);
775 CTO(SCHUBERT,"scalarproduct_bar_schubert(2)",b);
776
777 c = callocobject();
778 d = callocobject();
779 e = callocobject();
780 f = callocobject();
781 erg += max_bar(S_P_L(a),c);
782 erg += mult(b,c,d);
783 erg += m_bar_schubert(a,e);
784 erg += m_bar_schubert(d,f);
785 erg += mult(f,e,e);
786 erg += divdiff(c,e,g);
787 erg += freeall(c);
788 erg += freeall(d);
789 erg += freeall(e);
790 erg += freeall(f);
791 ENDR("scalarproduct_bar_schubert");
792 }
793
starting_bar_schubert(n,res)794 INT starting_bar_schubert(n,res) OP n,res;
795 {
796 OP a,b,c,y,e,d;
797 INT i;
798 FILE *fp;
799 char s[100];
800
801 sprintf(s,"startbarschubert%ld",S_I_I(n));
802 fp = fopen(s,"r");
803 if (fp != NULL)
804 {
805 objectread(fp,res);
806 fclose(fp);
807 return OK;
808 }
809
810 a=callocobject();y=callocobject();e=callocobject();
811 b=callocobject();
812 c=callocobject();d=callocobject();
813
814
815 m_i_staircase(n,c);
816 m_part_qelm(c,b);
817
818 compute_elmsym_with_alphabet(b,n,res);
819 b_skn_po(callocobject(),callocobject(),NULL,d);
820 if (((S_I_I(n)*(S_I_I(n)-1))/2)%2 == 0)
821 m_i_i(1L,S_PO_K(d));
822 else
823 m_i_i(-1L,S_PO_K(d));
824 m_il_v(S_I_I(n),S_PO_S(d));
825 for (i=0;i<S_PO_SLI(d);i++)
826 M_I_I(S_I_I(n)-1-i, S_PO_SI(d,i));
827 mult_apply(d,res);
828
829 freeall(a);
830 freeall(b);
831 freeall(e);
832 freeall(c);freeall(d);freeall(y);
833 fp = fopen(s,"w");
834 if (fp != NULL)
835 objectwrite(fp,res);
836 fclose(fp);
837 return OK;
838 }
839
m_bar_schubert(bar,res)840 INT m_bar_schubert(bar,res) OP bar,res;
841 {
842 OP a,b,c,y,e,d;
843 INT erg = OK;
844 CTO(PERMUTATION,"m_bar_schubert(1)",bar);
845
846
847 CE2(bar,res,m_bar_schubert);
848
849 a=callocobject();y=callocobject();e=callocobject();
850 b=callocobject();
851 c=callocobject();d=callocobject();
852
853 erg += starting_bar_schubert(S_P_L(bar),c);
854
855
856 erg += max_bar(S_P_L(bar),e);
857 erg += mult(bar,e,b);
858
859 erg += freeself(res);
860 erg += new_divdiff_bar(b,c,res);
861
862 erg += freeall(a);
863 erg += freeall(b);
864 erg += freeall(e);
865 erg += freeall(c);
866 erg += freeall(d);
867 erg += freeall(y);
868 ENDR("m_bar_schubert");
869 }
870
871 #endif /* POLYTRUE */
872
t_bar_doubleperm(a,b)873 INT t_bar_doubleperm(a,b) OP a,b;
874 {
875 INT i,k;
876 b_ks_p(VECTOR,callocobject(),b);
877 m_il_v(S_P_LI(a)*2,S_P_S(b));
878 for (i=0,k=S_P_LI(b)-1; i<S_P_LI(a);i++,k--)
879 {
880 if (S_P_II(a,i) < 0)
881 {
882 M_I_I(S_P_II(a,i)+S_P_LI(a)+1, S_P_I(b,i));
883 M_I_I(-S_P_II(a,i)+S_P_LI(a), S_P_I(b,k));
884 }
885 else
886 {
887 M_I_I(S_P_II(a,i)+S_P_LI(a), S_P_I(b,i));
888 M_I_I(-S_P_II(a,i)+S_P_LI(a)+1, S_P_I(b,k));
889 }
890 }
891 return OK;
892 }
893
bar_rectr(a,v)894 INT bar_rectr(a,v) OP a,v;
895 /* input double perm output rectr */
896 /* half of rectr of s_2n */
897 {
898 OP b,u; INT i,k,x,y,z,iv,i1;
899 b=callocobject();u=callocobject();
900 invers(a,b); init(VECTOR,v);m_il_v(3L,u);iv=0L;
901 for(i=0L;i<S_P_LI(a)-1L;i++)
902 {if( S_P_II(a,i)>S_P_II(a,i+1))
903 {z= S_P_II(a,i); x=S_P_II(a,i+1);
904 for (k=z;k>=x;k--)
905 {if ( S_P_II(b,k-1) >= i+2 && S_P_II(b,k) <=i+1)
906 {y=0; for(i1=0;i1<=i;i1++) { if( S_P_II(a,i1) <k) y++;}
907 if( (k+1L+i < S_P_LI(a)) ||( (k+1L+i== S_P_LI(a)) && (i+1<=k)) )
908 { M_I_I(y,S_V_I(u,0L)); M_I_I(i+1-y,S_V_I(u,1L));
909 M_I_I(k-y,S_V_I(u,2L));
910 inc(v);copy(u,S_V_I(v,iv)); iv++; } }}} }
911 freeall(b);freeall(u);
912 return OK;
913 }
914
comp_bigr_perm(u,perm)915 INT comp_bigr_perm(u,perm) OP u,perm;
916 /* compare bigrassmannian (= vector of length 3 ) with permutation */
917 /* returns TRUE if u <= perm in bruhat order FALSE else */
918 /* works for s_n */
919 { INT i,x,r0,r1,r2;
920 r0=S_V_II(u,0L);r1=S_V_II(u,1L);r2=S_V_II(u,2L); x=0L;
921 for(i=0L;i<r0+r1;i++) { if (S_P_II(perm,i) >r0+r2 ) x++; }
922 if(x< r1) return (FALSE); else return (TRUE);
923 }
924
925 /* rectrices de Sn sur 3 composantes; renvoie 1 si u <= v , 0 sinon */
comp_bigr_bigr(u,v)926 INT comp_bigr_bigr(u,v) OP u,v;
927 /* compares according bruhat */
928 /* returns 1 if u <= v */
929 /* works for s_n */
930 { if (S_V_II(u,0L)< S_V_II(v,0L) ) return 0L;
931 if (S_V_II(u,1L)>S_V_II(v,1L)) return 0L;
932 if (S_V_II(u,2L)>S_V_II(v,2L)) return 0L;
933 if (S_V_II(u,0L)+ S_V_II(u,1L)+S_V_II(u,2L) >S_V_II(v,0L)+S_V_II(v,1L)+S_V_II(v,2L) ) return 0L;
934 return 1L;
935 }
936
937 #endif /* PERMTRUE */
938