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