symmetrica-2.0/0000755017361200001450000000000011027741047013410 5ustar tabbottcrontabsymmetrica-2.0/bar.c0000400017361200001450000005522610726021607014316 0ustar tabbottcrontab/* file bar.c symmetrica */ #include "def.h" #include "macro.h" #ifdef PERMTRUE INT cast_apply_barperm(a) OP a; /* AK 280294 */ { INT erg = OK; EOP("cast_apply_barperm(1)",a); switch(S_O_K(a)) { case VECTOR: erg += m_ks_p(VECTOR,a,a); C_P_K(a,BAR); break; case PERMUTATION: if (S_P_K(a) == BAR) break; else if (S_P_K(a) == VECTOR) { C_P_K(a,BAR); break; } default: printobjectkind(a); erg += WTO("cast_apply_barperm",a); break; } ENDR("cast_apply_barperm"); } INT invers_bar(a,b) OP a,b; { INT i,erg =OK,j; CH2D(a,b); erg += b_ks_p(VECTOR,callocobject(),b); erg += absolute(S_P_S(a),S_P_S(b)); erg += invers(b,b); for (i=0L;i= -index) if (S_PO_SII(zeiger,-index -1) % 2L == 1L) addinvers(S_PO_K(zeiger),S_PO_K(zeiger)); } zeiger = S_PO_N(zeiger); } sub(poly,zwischen,c); zeiger =c; while (zeiger != NULL) { if (S_L_S(zeiger) != NULL) { if (S_PO_SLI(zeiger) >= -index) { dec(S_PO_SI(zeiger,-index-1L)); div(S_PO_K(zeiger),cons_zwei,S_PO_K(zeiger)); } } zeiger = S_PO_N(zeiger); } freeall(zwischen); return OK; } while (zeiger != NULL) { if (S_L_S(zeiger) != NULL) { if (S_O_K(S_PO_S(zeiger)) != VECTOR) { printobjectkind(S_PO_S(zeiger)); error("kind != VECTOR in divideddifference_bar"); return(ERROR); }; if (S_I_I(i) == S_PO_SLI(zeiger)) /* operiert auf letzten exponenten */ { inc(S_PO_S(zeiger)); M_I_I(0L,S_PO_SI(zeiger,S_I_I(i))); } else if (S_I_I(i) > S_PO_SLI(zeiger)) goto dividedend; expo1 = S_PO_SII(zeiger,index); expo2 = S_PO_SII(zeiger,index + 1L); if (expo1 > expo2) { for (j=expo1-1L,k=expo2 ;j>= expo2; j--,k++) { b_skn_po(callocobject(),callocobject(),NULL,zwischen); copy(S_PO_S(zeiger),S_PO_S(zwischen)); copy(S_PO_K(zeiger),S_PO_K(zwischen)); M_I_I(j,S_PO_SI(zwischen,index)); M_I_I(k,S_PO_SI(zwischen,index+1L)); add_apply(zwischen,c); freeself(zwischen); }; } else if (expo1 < expo2) { for (j=expo2-1L,k=expo1 ;j>= expo1; j--,k++) { b_skn_po(callocobject(),callocobject(),NULL,zwischen); copy(S_PO_S(zeiger),S_PO_S(zwischen)); addinvers(S_PO_K(zeiger),S_PO_K(zwischen)); M_I_I(j,S_PO_SI(zwischen,index)); M_I_I(k,S_PO_SI(zwischen,index+1)); add_apply(zwischen,c); freeself(zwischen); } }; } dividedend: zeiger = S_PO_N(zeiger); }; freeall(zwischen); return(OK); } #endif /* POLYTRUE */ INT rz_bar(a,b) OP a,b; /* AK 050995 */ { INT erg = OK; OP c; CTO(PERMUTATION,"rz_bar(1)",a); c = callocobject(); erg += lehmercode(a,c); erg += rz_lehmercode_bar(c,b); erg += freeall(c); ENDR("rz_bar"); } INT rz_lehmercode_bar(a,b) OP a,b; /* AK 020392 */ { OP e,f,g; INT i,j,k; INT erg = OK; CTO(VECTOR,"rz_lehmercode_bar(1)",a); g = callocobject(); e = S_V_I(a,0L); f = S_V_I(a,1L); erg += sum(f,g); j=0L; for (i=0L;i1L;k--,j++) erg += m_i_i(k-1L,S_V_I(b,j)); erg += m_i_i(-1L,S_V_I(b,j++)); } /* now the rc for the lehmercode in f */ erg += rz_lehmercode(f,g); for (i=0L;i 0L) */ erg += m_i_i(- S_P_II(a,- S_P_II(b,i)-1L), S_P_I(c,i)); /* else erg += m_i_i(- S_P_II(a,- S_P_II(b,i)-1L), S_P_I(c,i));*/ } else erg += m_i_i(S_P_II(a,S_P_II(b,i)-1L), S_P_I(c,i)); } ENDR("mult_bar_bar"); } INT random_bar(n,b) OP n,b; /* AK 250292 */ { OP a,c; INT i,erg = OK; CTO(INTEGER,"random_bar(1)",n); CTO(EMPTY,"random_bar(2)",b); a = callocobject(); c = callocobject(); erg += m_il_v(2L,a); erg += m_l_nv(n,S_V_I(a,0L)); erg += random_permutation(n,c); erg += lehmercode(c,S_V_I(a,1L)); for (i=0L;i=0L;i--) { if (S_V_II(S_V_I(a,0L),i) == 1L) m_i_i(-i-1L,S_V_I(liste,j++)); } for(i=0L;i 0) addinvers(c,c); */ return OK; } INT scalarproduct_bar_schubert(a,b,g) OP a,b,g; { INT erg = OK; OP c,d,e,f; CTO(PERMUTATION,"scalarproduct_bar_schubert(1)",a); CTO(SCHUBERT,"scalarproduct_bar_schubert(2)",b); c = callocobject(); d = callocobject(); e = callocobject(); f = callocobject(); erg += max_bar(S_P_L(a),c); erg += mult(b,c,d); erg += m_bar_schubert(a,e); erg += m_bar_schubert(d,f); erg += mult(f,e,e); erg += divdiff(c,e,g); erg += freeall(c); erg += freeall(d); erg += freeall(e); erg += freeall(f); ENDR("scalarproduct_bar_schubert"); } INT starting_bar_schubert(n,res) OP n,res; { OP a,b,c,y,e,d; INT i; FILE *fp; char s[100]; sprintf(s,"startbarschubert%ld",S_I_I(n)); fp = fopen(s,"r"); if (fp != NULL) { objectread(fp,res); fclose(fp); return OK; } a=callocobject();y=callocobject();e=callocobject(); b=callocobject(); c=callocobject();d=callocobject(); m_i_staircase(n,c); m_part_qelm(c,b); compute_elmsym_with_alphabet(b,n,res); b_skn_po(callocobject(),callocobject(),NULL,d); if (((S_I_I(n)*(S_I_I(n)-1))/2)%2 == 0) m_i_i(1L,S_PO_K(d)); else m_i_i(-1L,S_PO_K(d)); m_il_v(S_I_I(n),S_PO_S(d)); for (i=0;iS_P_II(a,i+1)) {z= S_P_II(a,i); x=S_P_II(a,i+1); for (k=z;k>=x;k--) {if ( S_P_II(b,k-1) >= i+2 && S_P_II(b,k) <=i+1) {y=0; for(i1=0;i1<=i;i1++) { if( S_P_II(a,i1) r0+r2 ) x++; } if(x< r1) return (FALSE); else return (TRUE); } /* rectrices de Sn sur 3 composantes; renvoie 1 si u <= v , 0 sinon */ INT comp_bigr_bigr(u,v) OP u,v; /* compares according bruhat */ /* returns 1 if u <= v */ /* works for s_n */ { if (S_V_II(u,0L)< S_V_II(v,0L) ) return 0L; if (S_V_II(u,1L)>S_V_II(v,1L)) return 0L; if (S_V_II(u,2L)>S_V_II(v,2L)) return 0L; 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; return 1L; } #endif /* PERMTRUE */ symmetrica-2.0/bar.doc0000600017361200001450000000661310726170272014642 0ustar tabbottcrontabCOMMENT: BARRED PERMUTATION ------------------ These are elements of group S_2 wreath S_n, the elements are objects of the type PERMUTATION, but where the kind of the permutation is BAR or BARCYCLE. The permutation is of length n, and the entries are between 1 and n , but may be positiv or negativ. NAME: class_bar SYNOPSIS: INT class_bar(OP a,b) DESCRIPTION: computes the label of the conjugacy class of the element a. NAME: class_rep_bar SYNOPSIS: INT class_rep_bar(OP a,b) DESCRIPTION: you enter the label of a class, and the routine computes a element 'b' of that class NAME: first_bar SYNOPSIS: INT first_bar(OP a,b) DESCRIPTION: computes the first barred permutation = [1,2,3..] of degree a. a must be a INTEGER object. NAME: lehmercode_bar SYNOPSIS: INT lehmercode_bar(OP a,b) DESCRIPTION: computes the lehmercode of a barred permutation a. The result is a two-element VECTOR object, whose two entries are INTEGER - VECTOR objects, whose length are the length of the PERMUTATION object a. The first VECTOR is a 0-1 vector, the i-th entry is one if the element i+1 is negativ in the PERMUTATION object a. The second VECTOR is the ordinary Lehmercode of a permutation, but taken into account that we have negative entries. EXAMPLE: given the barred permutation 3 -5 2 -1 4 the result of lehmercode_bar is [[1,0,0,0,1][3,0,1,0,0]] NAME: lehmercode_vector_bar SYNOPSIS: INT lehmercode_vector_bar(OP a,b) DESCRIPTION: is the inverse routine to the above routine lehmercode_bar NAME: length_bar SYNOPSIS: INT length_bar(OP a,b) DESCRIPTION: computes the reduced length of the barred permutation a. NAME: makevectorof_class_bar SYNOPSIS: INT makevectorof_class_bar(OP a,b) DESCRIPTION: computes a vector with all labelings of the classes of the group S_2 wreath S_a NAME: makevectorof_class_rep_bar SYNOPSIS: INT makevectorof_class_rep_bar(OP a,b) DESCRIPTION: computes a vector with reps of all the classes of the group S_2 wreath S_a, the ordering of classes is as in the function makevectorof_class_bar. NAME: mult_bar_bar SYNOPSIS: INT mult_bar_bar(OP a,b,c) DESCRIPTION: multiplies first b than a , the result becomes c. Better to use the general routine mult(OP,OP,OP) NAME: next_bar SYNOPSIS: INT next_bar(OP a,b) DESCRIPTION : computes the next barred permutation b. The algorithm uses the lehmercode. The last barred permutation will be [-1,-2,-3,...] NAME: ordcen_bar SYNOPSIS: INT ordcen_bar(OP a,b) DESCRIPTION: computes the order of the centralicer of the class labeled by 'a'. NAME: ordcon_bar SYNOPSIS: INT ordcon_bar(OP a,b) DESCRIPTION: computes the order of the class labeled by 'a'. NAME: random_bar SYNOPSIS: INT random_bar(OP a,b) DESCRIPTION: computes a random element of given length, so b becomes an elements of S_2 wreath S_a, a is an INTEGER object. NAME: scan_bar SYNOPSIS: INT scan_bar(OP a) DESCRIPTION: reads a barred permutation from input, and checks wether the input was correct. You may better use the routine scan(BARPERM,a). NAME: t_BAR_BARCYCLE SYNOPSIS: INT t_BAR_BARCYCLE(OP a,b); DESCRIPTION: transforms a barred permutation 'a' in list-notation into cycle notation BUG: a and b must be different NAME: t_BARCYCLE_BAR SYNOPSIS: INT t_BARCYCLE_BAR(OP a,b); DESCRIPTION: transforms a barred permutation 'a' in cycle-notation into list notation BUG: a and b must be different symmetrica-2.0/bi.c0000400017361200001450000010445510726021607014143 0ustar tabbottcrontab#include "def.h" #include "macro.h" /* AK 291288 */ typedef struct node { char * _key; /* dies enthaelt ein object */ struct node * _l, * _r; char _rtag; } Node; #define KEY(p) ((p) -> _key) #define LINKS(p) ((p) -> _l) #define RECHTS(p) ((p) -> _r) #define RTAG(p) ((p) -> _rtag) /* TSEARCH(3C) */ typedef enum { preorder, postorder, endorder, leaf } VISIT; static INT AK_twalk(); static void AK_tfree(); static char ** AK_tsearch(); static char ** AK_tdelete(); static char ** AK_tfind(); static void walk(); static void freeself_bintree_action(); static void fprint_bintree_action(); static void insert_bt_bt_action(); static void copy_bintree_action(); static void t_BINTREE_LIST_action(); static void t_BINTREE_SCHUR_action(); static void t_BINTREE_POLYNOM_action(); static void t_BINTREE_HOMSYM_action(); static void t_BINTREE_ELMSYM_action(); static void t_BINTREE_POWSYM_action(); static void t_BINTREE_MONOMIAL_action(); static void t_BINTREE_SCHUBERT_action(); static void t_BINTREE_GRAL_action(); static void t_BINTREE_SCHUR_action_apply(); static void t_BINTREE_POLYNOM_action_apply(); static void t_BINTREE_HOMSYM_action_apply(); static void t_BINTREE_POWSYM_action_apply(); static void t_BINTREE_MONOMIAL_action_apply(); static void t_BINTREE_ELMSYM_action_apply(); static char *_bt_p1, *_bt_p2, *_bt_p3; /* fur twalk */ #define TWALK(a,b) AK_twalk((Node *)a,b) #define TSEARCH AK_tsearch #define TFIND(a,b,c) AK_tfind((char*)a,(Node **) b,c) #define TDELETE AK_tdelete #ifdef BINTREETRUE static void freeself_bintree_action(a,type) OP *a; VISIT type; /* AK 210891 V1.3 */ { if ((type==postorder) || (type==leaf)) freeall(*a); } INT freeself_bintree(a) OP a; /* AK 050891 V1.3 */ { OBJECTSELF d ; d = S_O_S(a); AK_tfree(& d.ob_charpointer,freeself_bintree_action,NULL,NULL,NULL); C_O_K(a,EMPTY); return OK; /* AK 050891 */ } INT init_bintree(a) OP a; /* AK 050891 V1.3 */ { OBJECTSELF d; C_O_K(a,BINTREE); d.ob_charpointer = (char *) NULL; C_O_S(a,d); return(OK); } static void length_bintree_action(a,type,l) OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { OP p1 = (OP ) _bt_p1; if ((type==postorder)|| (type==leaf)) { inc(p1); } } static void fprint_bintree_action(a,type,l) OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { FILE *p1 = (FILE *) _bt_p1; if ((type==postorder)|| (type==leaf)) { fprint(p1,*a); fprintf(p1," "); if (p1==stdout) { zeilenposition++; if (zeilenposition >70L) { fprintf(p1,"\n"); zeilenposition=0L; } } } } INT length_bintree(a,b) OP a,b; /* AK 211097 */ { void length_bintree_action(); OBJECTSELF d; m_i_i(0,b); d = S_O_S(a); if (d.ob_charpointer == NULL) { } else { _bt_p1 = (char *) b; TWALK(d.ob_charpointer,length_bintree_action); } return OK; } INT fprint_bintree(fp,a) FILE *fp; OP a; /* AK 050891 V1.3 */ /* gibt einen bintree aus */ { void fprint_bintree_action(); OBJECTSELF d; d = S_O_S(a); if (d.ob_charpointer == NULL) { fprintf(fp,"empty tree"); if (fp == stdout) zeilenposition += 10L; } else { _bt_p1 = (char *) fp; _bt_p2 = (char *) NULL; _bt_p3 =(char *) NULL; TWALK(d.ob_charpointer,fprint_bintree_action); } return OK; } INT insert_bintree(a,bt,eh,cf) OP a,bt; INT (*cf)(), (*eh)(); /* fuegt a in bintree bt ein */ /* cf ist die vergleichsfunktion eh gibt die operation bei schon vorhandenem gleichen eintrag an */ /* AK 040189 */ /* AK 210891 V1.3 */ { INT erg = OK; char ** result; if (S_O_K(a) == BINTREE) { OBJECTSELF d; d = S_O_S(a); if (d.ob_charpointer == NULL) /* AK 300997 */ { freeall(a); return INSERTOK; } d = S_O_S(bt); if (d.ob_charpointer == NULL) /* AK 300997 */ { swap(a,bt); freeall(a); return INSERTOK; } return insert_bt_bt(a,bt,eh,cf); } else if ( LISTP(a) ) { OP z; z = a; if (S_L_S(z) != NULL) while (z != NULL) { insert_bintree(S_L_S(z),bt,eh,cf); C_L_S(z,NULL); z = S_L_N(z); } FREEALL(a); return INSERTOK; } if (cf == NULL) cf = comp; /* default wert */ result = TSEARCH(a, &((S_O_S(bt)).ob_charpointer) ,cf); if (*result == (char *)a) return INSERTOK; /* d.h. das element wurde eingefuegt */ else /* d.h. es wurde ein gleiches element festgestelt und result ist ein pointer darauf */ { if (eh != NULL) (*eh)(a,*result); if (EMPTYP((OP)*result)) /* eq-handle hat geloescht */ { OP z = (OP)*result; *z = *a; TDELETE(a,&((S_O_S(bt)).ob_charpointer) ,cf); C_O_K(z,EMPTY); FREEALL(z); } FREEALL(a); return INSERTEQ; } ENDR("insert_bintree"); } INT insert_bt_bt(a,bt,eh,cf) OP a,bt; INT (*cf)(), (*eh)(); /* fuegt a was auch bintree ist in bintree bt ein */ /* cf ist die vergleichsfunktion eh gibt die operation bei schon vorhandenem gleichen eintrag an */ /* AK 090189 */ /* AK 210891 V1.3 */ { OBJECTSELF d; INT erg = OK; CTO(BINTREE,"insert_bt_bt(1)",a); CTO(BINTREE,"insert_bt_bt(2)",bt); d = S_O_S(a); AK_tfree(&d.ob_charpointer,insert_bt_bt_action,bt,eh,cf); C_O_K(a,EMPTY); /* leer setzen */ erg += freeall(a); ENDR("insert_bt_bt"); } static void insert_bt_bt_action(a,type,bt,eh,cf)OP *a,bt; VISIT type; INT (*eh)(),(*cf)(); /* AK 210891 V1.3 */ { INT insert_erg; if ((type==postorder)|| (type==leaf)) { insert_erg = insert_bintree(*a,bt,eh,cf); } } INT copy_bintree(a,b) OP a,b; /* AK 210891 V1.3 */ { OBJECTSELF d; init(BINTREE,b); d = S_O_S(a); _bt_p1 = (char *) b; _bt_p2 = (char *) NULL; _bt_p3 = (char *) NULL; TWALK(d.ob_charpointer,copy_bintree_action); return OK; } static void copy_bintree_action(a,type,l) OP *a; VISIT type; INT l; /* AK 210891 V1.3 */ { OP bt = (OP) _bt_p1; if ((type==postorder)|| (type==leaf)) { OP c=callocobject(); copy(*a,c); insert_bintree(c,bt,NULL,NULL); } } OP find_user_bintree(a,b,f) OP a,b; INT (*f)(); { char ** result; result = TFIND(a, &((S_O_S(b)).ob_charpointer) ,f); if (result == NULL) return NULL; return (OP) *result; } OP find_bintree(a,b) OP a,b; /* test ob a in b */ /* AK 050396 */ { char ** result; result = TFIND(a, &((S_O_S(b)).ob_charpointer) ,comp); if (result == NULL) return NULL; return (OP) *result; } static Node ** bi_find(k,rootp,compar, parent, c) char *k; register Node ** rootp; INT (*compar)(); Node ** parent; INT *c; /* AK 210891 V1.3 */ { *parent = (Node *) 0; if (rootp && *rootp) for (;;) { if ((*c = (*compar) (k,KEY(*rootp))) == 0L) break; *parent = *rootp; if( *c < 0L) { rootp = & LINKS(*parent); if (! *rootp) break; } else { rootp = & RECHTS(*parent); if (RTAG(*parent)) break; } } return (rootp); } static char ** AK_tfind(k,rootp,compar) char *k; register Node ** rootp; INT (*compar)(); { Node * parent; INT c; if ((rootp = bi_find(k,rootp,compar, &parent, &c))) if (*rootp && (c == 0)) return (&KEY(*rootp)); return NULL; } static char ** AK_tdelete(k,rootp,compar) char *k; register Node ** rootp; INT (*compar)(); { /* Schreiner: UNIX Sprechstude p.248 */ register Node *p; char **result; Node * parent; INT c; if (! (rootp = bi_find(k,rootp,compar,&parent, &c)) || ! * rootp || c) return (char **) 0; result = ! parent ? & KEY (*rootp): & KEY(parent); if (!RTAG(*rootp)) { Node * R = RECHTS(*rootp); if (!LINKS(*rootp)) { p = *rootp, *rootp=R, SYM_free(p); return result; } if (! LINKS(R)) LINKS(R) = LINKS(*rootp), SYM_free(*rootp), *rootp = R; else { p = R; while(LINKS(LINKS(p))) p = LINKS(p); LINKS(LINKS(p)) = LINKS(*rootp); SYM_free(*rootp), *rootp = LINKS(p); LINKS(p) = RTAG(LINKS(p))? (Node *)0: RECHTS(LINKS(p)); RECHTS(*rootp) = R, RTAG(*rootp)=0; } if ((p = LINKS(*rootp))) { while (! RTAG(p)) p = RECHTS(p); RECHTS(p) = *rootp, RTAG(p)=1; } } else if ((p=LINKS(*rootp))) { while(! RTAG(p)) p = RECHTS(p); RECHTS(p) = RECHTS(*rootp), RTAG(p)=1; p = *rootp, *rootp = LINKS(p), SYM_free(p); } else if (parent && RECHTS(parent) == *rootp) { p = *rootp; RECHTS(parent) = RECHTS(p), RTAG(parent) = 1; SYM_free(p); } else SYM_free(*rootp), *rootp = (Node *)0; return result; } static char ** AK_tsearch(k,rootp,compar) char *k; register Node ** rootp; INT (*compar)(); /* AK 210891 V1.3 */ { register Node *p; Node * parent; INT c; if ((rootp = bi_find(k,rootp,compar, &parent, &c))) if (*rootp && c == 0) return (&KEY(*rootp)); else if ((p = (Node *) SYM_malloc(sizeof(Node)))) { KEY(p) =k; LINKS(p) = (Node *) 0; if (parent && c>0) { RECHTS(p) = RECHTS(parent); RECHTS(parent) = p, RTAG(parent)= 0; } else { RECHTS(p) = parent; * rootp = p; } RTAG(p) = 1; return (&KEY(p)); } return ((char**) 0); } static void walk(root,action,l) register Node *root; void (*action) (); INT l; /* fuer parameter bei action */ /* AK 210891 V1.3 */ { if (! LINKS(root) && RTAG(root)) (*action) (&KEY(root), leaf, l); else { (*action) (&KEY(root), preorder, l); if (LINKS(root)) walk(LINKS(root), action, l+1L); (*action) (&KEY(root), postorder, l); if (! RTAG(root)) walk(RECHTS(root), action, l+1L); (*action) (&KEY(root), endorder, l); } } static INT AK_twalk(root,action) Node *root; void (*action) (); /* AK 210891 V1.3 */ { if (root) walk(root,action,0L); return OK; } static void AK_tfree(rootp,a,bt,eh,cf) Node **rootp; void (*a)(); OP bt; INT (*eh)(); INT (*cf)(); /* AK 210891 V1.3 */ { register Node *root,*p; if (!rootp || ! (root = *rootp)) return; * rootp = (Node *)0; for (;;) { while ((p = LINKS(root))) root = p; if (RTAG(root)) { if (a) (* a)(&KEY(root), leaf,bt,eh,cf); do { p=RECHTS(root),SYM_free(root),root=p; if (! root) return; if (a) (* a)(&KEY(root),postorder,bt,eh,cf); } while(RTAG(root)); } else { if (a) (* a)(&KEY(root),postorder,bt,eh,cf); } p=RECHTS(root),SYM_free(root),root=p; } } INT t_BINTREE_VECTOR(a,b) OP a,b; /* input: BINTREE object a output: sorted VECTOR object b with copy of the objects in a as content */ /* a and b may be equal */ /* AK V2.0 170298 */ { INT erg = OK; OP c; CTO(BINTREE,"t_BINTREE_VECTOR",a); c = callocobject(); erg += t_BINTREE_LIST(a,c); erg += t_LIST_VECTOR(c,b); erg += freeall(c); ENDR("t_BINTREE_VECTOR"); } INT t_BINTREE_LIST(a,b) OP a,b; /* wandelt einen BINTREE in ein LIST object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_LIST_action(); INT erg = OK; /* AK 170392 */ OP h, *h2; OBJECTSELF d; CTO(BINTREE,"t_BINTREE_LIST",a); CE2(a,b,t_BINTREE_LIST); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(LIST,b); goto endr_ende; } h = callocobject(); erg += b_sn_l(NULL,NULL,h); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; erg += TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_LIST_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else erg += b_sn_l(NULL,NULL,b); C_O_K(S_L_N(h),EMPTY); freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); ENDR("t_BINTREE_LIST"); } static void t_BINTREE_LIST_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder) || (type==leaf)) { **(OP **)_bt_p1 = callocobject(); b_sn_l(callocobject(),NULL,**(OP **)_bt_p1); copy(*a,S_L_S(**(OP **)_bt_p1)); *(OP **)_bt_p1 = & S_L_N(**(OP **)_bt_p1); } } #ifdef SCHURTRUE INT t_BINTREE_SCHUR_apply(a) OP a; /* AK 010198 V2.0 */ { OP b; void t_BINTREE_SCHUR_action_apply(); OP *h2,h; OBJECTSELF d; INT erg = OK; b = CALLOCOBJECT(); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(SCHUR,a); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_s(NULL,NULL,h); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_SCHUR_action_apply); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_s(NULL,NULL,b); } C_O_K(S_L_N(h),EMPTY); FREEALL(S_L_N(h)); C_L_N(h,NULL); FREEALL(h); erg += swap(b,a); FREEALL(b); ENDR("t_BINTREE_SCHUR_apply"); } INT t_BINTREE_SCHUR(a,b) OP a,b; /* wandelt einen BINTREE in ein SCHUR object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_SCHUR_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; CTO(BINTREE,"t_BINTREE_SCHUR(1)",a); if (a == b) { erg += t_BINTREE_SCHUR_apply(a); goto endr_ende; } d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(SCHUR,b); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,SCHUR); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_SCHUR_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,SCHUR); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); FREEALL(h); ENDR("t_BINTREE_SCHUR"); } static void t_BINTREE_SCHUR_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_s(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } static void t_BINTREE_SCHUR_action_apply(a,type,l)OP *a;VISIT type;INT l; /* AK 080199 V2.0 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_s(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); swap(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } INT t_BINTREE_POWSYM_apply(a) OP a; /* AK 010198 V2.0 */ { OP b; void t_BINTREE_POWSYM_action_apply(); OP *h2,h; OBJECTSELF d; INT erg = OK; CTO(BINTREE,"t_BINTREE_POWSYM_apply(1)",a); b = CALLOCOBJECT(); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(POWSYM,a); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,POWSYM); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_POWSYM_action_apply); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,POWSYM); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); erg += swap(b,a); erg += freeall(b); ENDR("t_BINTREE_POWSYM_apply"); } INT t_BINTREE_POWSYM(a,b) OP a,b; /* wandelt einen BINTREE in ein POWSYM object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_POWSYM_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; CTO(BINTREE,"t_BINTREE_POWSYM(1)",a); if (a == b) { erg += t_BINTREE_POWSYM_apply(a); goto endr_ende; } d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(POWSYM,b); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,POWSYM); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_POWSYM_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,POWSYM); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); ENDR("t_BINTREE_POWSYM"); } static void t_BINTREE_POWSYM_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_l(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,POWSYM); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } static void t_BINTREE_POWSYM_action_apply(a,type,l)OP *a;VISIT type;INT l; /* AK 080199 V2.0 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_l(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,POWSYM); swap(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } INT t_BINTREE_ELMSYM_apply(a) OP a; /* AK 010198 V2.0 */ { OP b; void t_BINTREE_ELMSYM_action_apply(); OP *h2,h; OBJECTSELF d; INT erg = OK; CTO(BINTREE,"t_BINTREE_ELMSYM_apply(1)",a); b = CALLOCOBJECT(); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(ELMSYM,a); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,ELMSYM); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_ELMSYM_action_apply); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,ELMSYM); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); erg += swap(b,a); erg += freeall(b); ENDR("t_BINTREE_ELMSYM_apply"); } INT t_BINTREE_ELMSYM(a,b) OP a,b; /* wandelt einen BINTREE in ein ELMSYM object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_ELMSYM_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; CTO(BINTREE,"t_BINTREE_ELMSYM(1)",a); if (a == b) { erg += t_BINTREE_ELMSYM_apply(a); goto endr_ende; } d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(ELMSYM,b); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,ELMSYM); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_ELMSYM_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,ELMSYM); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); ENDR("t_BINTREE_ELMSYM"); } static void t_BINTREE_ELMSYM_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_l(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,ELMSYM); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } static void t_BINTREE_ELMSYM_action_apply(a,type,l)OP *a;VISIT type;INT l; /* AK 080199 V2.0 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_l(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,ELMSYM); swap(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } INT t_BINTREE_HOMSYM_apply(a) OP a; /* AK 010198 V2.0 */ { OP b; void t_BINTREE_HOMSYM_action_apply(); OP *h2,h; OBJECTSELF d; INT erg = OK; CTO(BINTREE,"t_BINTREE_HOMSYM_apply(1)",a); b = CALLOCOBJECT(); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(HOMSYM,a); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,HOMSYM); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_HOMSYM_action_apply); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,HOMSYM); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); erg += swap(b,a); erg += freeall(b); ENDR("t_BINTREE_HOMSYM_apply"); } INT t_BINTREE_HOMSYM(a,b) OP a,b; /* wandelt einen BINTREE in ein HOMSYM object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_HOMSYM_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; CTO(BINTREE,"t_BINTREE_HOMSYM(1)",a); if (a == b) { erg += t_BINTREE_HOMSYM_apply(a); goto endr_ende; } d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(HOMSYM,b); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,HOMSYM); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_HOMSYM_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,HOMSYM); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); ENDR("t_BINTREE_HOMSYM"); } static void t_BINTREE_HOMSYM_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_l(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,HOMSYM); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } static void t_BINTREE_HOMSYM_action_apply(a,type,l)OP *a;VISIT type;INT l; /* AK 080199 V2.0 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_l(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,HOMSYM); swap(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } #endif /* SCHURTRUE */ #ifdef SCHUBERTTRUE INT t_BINTREE_SCHUBERT(a,b) OP a,b; /* wandelt einen BINTREE in ein SCHUBERT object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_SCHUBERT_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; CTO(BINTREE,"t_BINTREE_SCHUBERT(1)",a); CE2(a,b,t_BINTREE_SCHUBERT); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(SCHUBERT,b); goto endr_ende; } h = callocobject(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,SCHUBERT); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_SCHUBERT_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,SCHUBERT); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); ENDR("t_BINTREE_SCHUBERT"); } static void t_BINTREE_SCHUBERT_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = callocobject(); b_sn_l(callocobject(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,SCHUBERT); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } #endif /* SCHUBERTTRUE */ static void t_BINTREE_GRAL_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = callocobject(); b_sn_l(callocobject(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,GRAL); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } INT t_BINTREE_GRAL(a,b) OP a,b; /* wandelt einen BINTREE in ein GRAL object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_GRAL_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; CE2(a,b,t_BINTREE_GRAL); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(GRAL,b); goto endr_ende; } h = callocobject(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,GRAL); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_GRAL_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,GRAL); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); ENDR("t_BINTREE_GRAL"); } INT test_bintree() { OP a,b,c; a = callocobject(); b = callocobject(); c = callocobject(); printeingabe("test_bintree:init(BINTREE,a) "); init(BINTREE,a); println(a); printeingabe("test_bintree:insert(5L,a) "); m_i_i(5L,b);insert(b,a,NULL,NULL); println(a); printeingabe("test_bintree:insert(7L,a) "); b = callocobject(); m_i_i(7L,b); insert(b,a,NULL,NULL); println(a); printeingabe("test_bintree:copy(a,c) "); copy(a,c); println(c); printeingabe("test_bintree:insert(9L,c) "); b = callocobject(); m_i_i(9L,b); insert(b,c,NULL,NULL); println(c); freeall(a); freeall(c); return OK; } INT t_BINTREE_MONOMIAL_apply(a) OP a; /* AK 010198 V2.0 */ { OP b; void t_BINTREE_MONOMIAL_action_apply(); OP *h2,h; OBJECTSELF d; INT erg = OK; b = callocobject(); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(MONOMIAL,a); goto endr_ende; } h = callocobject(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,MONOMIAL); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_MONOMIAL_action_apply); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,MONOMIAL); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); erg += swap(b,a); erg += freeall(b); ENDR("t_BINTREE_MONOMIAL_apply"); } INT t_BINTREE_MONOMIAL(a,b) OP a,b; /* wandelt einen BINTREE in ein MONOMIAL object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_MONOMIAL_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; if (a == b) { erg += t_BINTREE_MONOMIAL_apply(a); goto endr_ende; } d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(MONOMIAL,b); goto endr_ende; } h = callocobject(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,MONOMIAL); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_MONOMIAL_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,MONOMIAL); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); erg += freeall(h); ENDR("t_BINTREE_MONOMIAL"); } static void t_BINTREE_MONOMIAL_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = callocobject(); b_sn_l(callocobject(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,MONOMIAL); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } static void t_BINTREE_MONOMIAL_action_apply(a,type,l)OP *a;VISIT type;INT l; /* AK 080199 V2.0 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = callocobject(); b_sn_l(callocobject(),NULL,**(OP**)_bt_p1); C_O_K(**(OP**)_bt_p1,MONOMIAL); swap(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } #endif /* BINTREETRUE */ #ifdef BINTREETRUE INT t_BINTREE_POLYNOM_apply(a) OP a; /* AK 010198 V2.0 */ { OP b; void t_BINTREE_POLYNOM_action_apply(); OP *h2,h; OBJECTSELF d; INT erg = OK; b = CALLOCOBJECT(); d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(POLYNOM,a); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_s(NULL,NULL,h); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_POLYNOM_action_apply); if (S_L_N(h) != NULL) *b = *S_L_N(h); else erg += b_sn_po(NULL,NULL,b); C_O_K(S_L_N(h),EMPTY); FREEALL(S_L_N(h)); C_L_N(h,NULL); FREEALL(h); erg += swap(b,a); FREEALL(b); ENDR("t_BINTREE_POLYNOM_apply"); } INT t_BINTREE_POLYNOM(a,b) OP a,b; /* wandelt einen BINTREE in ein POLYNOM object um */ /* die liste ist nach den gleichen vergleich sortiert */ /* AK 070390 V1.1 */ /* AK 050891 V1.3 */ { void t_BINTREE_POLYNOM_action(); OP *h2,h; INT erg = OK; OBJECTSELF d; CTO(BINTREE,"t_BINTREE_POLYNOM(1)",a); if (a == b) { erg += t_BINTREE_POLYNOM_apply(a); goto endr_ende; } d = S_O_S(a); if (d.ob_charpointer == NULL) { erg += init(POLYNOM,b); goto endr_ende; } h = CALLOCOBJECT(); erg += b_sn_l(NULL,NULL,h); C_O_K(h,POLYNOM); h2 = &S_L_N(h); _bt_p1 = (char *)&h2; _bt_p2 = (char *)NULL; _bt_p3 = (char *)NULL; TWALK((S_O_S(a)).ob_charpointer,t_BINTREE_POLYNOM_action); if (S_L_N(h) != NULL) *b = *S_L_N(h); else { erg += b_sn_l(NULL,NULL,b); C_O_K(b,POLYNOM); } C_O_K(S_L_N(h),EMPTY); erg += freeall(S_L_N(h)); C_L_N(h,NULL); FREEALL(h); ENDR("t_BINTREE_POLYNOM"); } static void t_BINTREE_POLYNOM_action(a,type,l)OP *a;VISIT type;INT l; /* AK 210891 V1.3 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_po(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); copy_monom(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } static void t_BINTREE_POLYNOM_action_apply(a,type,l)OP *a;VISIT type;INT l; /* AK 080199 V2.0 */ { if ((type==postorder)|| (type==leaf)) { **(OP**)_bt_p1 = CALLOCOBJECT(); b_sn_po(CALLOCOBJECT(),NULL,**(OP**)_bt_p1); swap(*a,S_L_S(**(OP**)_bt_p1)); *(OP**)_bt_p1 = & S_L_N(**(OP**)_bt_p1); } } #endif /* BINTREETRUE */ symmetrica-2.0/bi.doc0000600017361200001450000000053410726170273014465 0ustar tabbottcrontabCOMMENT: BINTREE ------- This is a object which implements a tree structure, which is used for high speed insertion of results into s sorted structure. NAME: t_BINTREE_LIST SYNOPSIS: INT t_BINTREE_LIST(OP a,b) DESCRIPTION: you have a BINTREE object a, which will be transformed into a equivalent LIST object b. a and b may be equal. symmetrica-2.0/boe.c0000400017361200001450000022766410726021607014326 0ustar tabbottcrontab/* file boe.c */ #include "def.h" #include "macro.h" static INT op_transpo_tab(); static INT vander_gen(); /* AK 180791 berechnung der specht darstellung Wilhelm Specht: Mathematische Zeitschrift 39 (1935) 696-711 */ #ifdef TABLEAUXTRUE INT makevectorofspecht_poly(a,d) OP a,d; /* AK 210703 */ /* computes the vector of all specht polynomials for a given shape, i.e. basis of ordinary specht modul */ { INT erg =OK,i; CTTO(PARTITION,SKEWPARTITION,"makevectorofspecht_poly(1)",a); { OP e = CALLOCOBJECT(); erg += makevectorofSYT(a,e); erg += m_il_v(S_V_LI(e),d); for (i=0L;i 2L)) l++; } /*** Berechnung der benoetigten Permutationen (12)(r-1,r) ***************/ erg += m_il_nv(l,res); j = 0L; for(i=0;i 2L) { M_I_I(S_V_II(rz,i+1)-1L,S_V_I(res,j)); j++; } } if(S_V_II(rz,i) > 2L) { M_I_I(S_V_II(rz,i)-1L,S_V_I(res,j)); j++; M_I_I(S_V_II(rz,i+1)-1L,S_V_I(res,j)); j++; } } /*** Speichenplatzfreigabe **********************************************/ erg += freeall(rz); erg += freeall(sig); /*** Rueckkehr in die aufrufende Routine ********************************/ if (erg != OK) { error("an_rz_perm : error during computation."); return ERROR; } return OK; } /* Ende von an_rz_perm */ #endif /* PERMTRUE */ /****************************************************************************/ /* */ /* Name: an_trafo_odg() */ /* Diese Routine berechnet die darstellende unitaere Matrix einer */ /* Permutation perm in der Darstellung zu einer Partition part, einge- */ /* schraenkt auf die An durch Transformation der darstellenden Matrix */ /* ueber der Sn. */ /* Rueckgabewert: OK oder error. */ /* */ /****************************************************************************/ /* PF 140992 */ #ifdef MATRIXTRUE INT an_trafo_odg(part,perm,D) OP part; /* Vektor, der die Darstellung beschreibt: */ /* 1. Komponente : Partition */ /* 2. Komponente : 0L oder 1L */ OP perm; /* Darzustellende Permutation */ OP D; /* Ende: unitaere Matrix zu [part](perm) */ { OP n; /* Gewicht von part */ OP conpar; /* konjugierte Partition zu part */ OP dim; /* Dimension der Matrix ueber der Sn */ OP sig; /* Signum von perm */ INT i; INT erg = OK; /* Variable zum Ablaufcheck */ INT alt_odg_trafo(); /* Routine zur Transformation einer zerfallen- */ /* den Darstellung */ INT trafo_check(); /* Routine zum Testen der Anordnung der Bloecke */ /* nach der Transformation */ CTO(VECTOR,"an_trafo_odg(1)",part); CTO(PERMUTATION,"an_trafo_odg(2)",perm); CTO(PARTITION,"an_trafo_odg(1.1)",S_V_I(part,0)); CTO(INTEGER,"an_trafo_odg(1.2)",S_V_I(part,1)); if (not EMPTYP(D)) erg += freeself(D); /*** Test, ob perm in der An liegt **************************************/ sig = callocobject(); erg += signum(perm,sig); if(S_I_I(sig) == -1L) { erg += freeall(sig); error("an_trafo_odg : permutation not in An"); return erg; } /*** Test, ob Laenge von perm mit dem Gewicht von part uebereinstimmt ***/ n = callocobject(); erg += weight(S_V_I(part,0L),n); if(S_I_I(n) != S_P_LI(perm)) { erg += freeall(sig); erg += freeall(n); error("an_trafo_odg : permutation and partition don't agree"); return erg; } /*** Falls n = 1 oder n = 2, wird D = (1) zurueckgegeben. ***************/ if((S_P_LI(perm) == 1L) || (S_P_LI(perm) == 2L)) { erg += m_ilih_m(1L,1L,D); M_I_I(1L,S_M_IJ(D,0L,0L)); erg += freeall(sig); erg += freeall(n); return erg; } /*** Berechnung der Matrix **********************************************/ /*** Falls die Partition part nicht selbstassoziiert ist, ist die ***/ /*** darstellende Matrix gleich der Matrix fuer die Sn. ***/ erg += odg(S_V_I(part,0L),perm,D); conpar = callocobject(); erg += conjugate(S_V_I(part,0L),conpar); if(part_comp(S_V_I(part,0L),conpar) != 0L) { erg += freeall(sig); erg += freeall(n); erg += freeall(conpar); return erg; } /*** Falls die Partition part selbstassoziiert ist, wird die dar- ***/ /*** stellende Matrix der Sn so transformiert, dass sie in zwei ***/ /*** inaequivalente unitaere Darstellungen zerfaellt. ***/ erg += alt_odg_trafo(S_V_I(part,0L),D); /*** Dann wird mit Hilfe einer Test-Routine nachgeprueft, in ***/ /*** welchem der beiden Bloecke die gesuchte Matrixdarstellung ***/ /*** steht. Die uebrigen Teile der Matrix werden geloescht. ***/ dim = callocobject(); M_I_I(S_M_LI(D),dim); if(trafo_check(S_V_I(part,0L)) == S_V_II(part,1L)) for(i=0L;i=l))) j = k-fac; else j = S_V_LI(tab)-k-1-fac; erg += invers(dist1,S_M_IJ(res,i,j)); erg += hoch(S_M_IJ(res,i,j),zwei,S_M_IJ(res,i,j)); erg += addinvers_apply(S_M_IJ(res,i,j)); erg += add_apply(eins,S_M_IJ(res,i,j)); erg += squareroot(S_M_IJ(res,i,j),S_M_IJ(res,i,j)); erg += mult_apply(dist2,S_M_IJ(res,i,j)); if(!(((fac==0L) && (k=l)))) { erg += add(eins,S_V_I(sig,S_V_LI(sig)-1L),exp); erg += hoch(zwei,exp,exp); erg += hoch(im,exp,exp); erg += mult_apply(S_V_I(sig,fac+i),exp); if(ref == 0L) erg += addinvers_apply(exp); erg += mult_apply(exp,S_M_IJ(res,i,j)); } } } /*** Speicherplatzfreigabe **********************************************/ erg += freeall(conpar); erg += freeall(tab); erg += freeall(n); erg += freeall(vgl_tab); erg += freeall(dist1); erg += freeall(dist2); erg += freeall(eins); erg += freeall(zwei); erg += freeall(im); erg += freeall(exp); /*** Rueckkehr in die aufrufende Routine ********************************/ ENDR("gen_mat"); } /* Ende von gen_mat */ #endif /* MATRIXTRUE */ /****************************************************************************/ /* */ /* Name: gen_smat() */ /* Diese Routine berechnet die darstellende seminormale Matrix ueber */ /* der An des erzeugenden Elements (12)(index+1L,index+2L) zur irre- */ /* duziblen Darstellung [part]+ oder [part]-. Dabei bestimmt die Zahl */ /* ref welcher Block der Matrix berechnet wird, die sonst durch Trans- */ /* formation der darstellenden Matrix ueber der Sn entstehen wuerde. */ /* Rueckgabewert: OK oder error. */ /* */ /****************************************************************************/ /* PF 280992 */ INT gen_smat(part,index,ref,res) OP part; /* selbstassoziierte Partition */ INT index; /* Nummer der erzeugenden Permutation, deren */ /* darstellende Matrix berechnet werden soll */ INT ref; /* INTEGER-Wert: 0L, falls der Block links oben */ /* berechnet werden soll, */ /* 1L, sonst. */ OP res; /* Ende: darstellende Matrix von [part]+ bzw. */ /* [part]- der Permutation (12)(index+1,index+2)*/ { OP conpar; /* konjugierte Partition zu part */ OP h_part; /* Hakenpartition zu part */ OP tab; /* Vektor der Standardtableaux zu part */ OP sig; /* Vorzeichenvektor der Permutationen zu den */ /* Standardtableaux zu part */ OP vgl_tab; /* Tableau (index+1,index+2)*Standardtableau */ OP dist1; /* Axialdistanz von index+1 und index+2 */ OP dist2; /* Axialdistanz von 1 und 2 */ OP n; /* Grad der An */ OP eins; /* INTEGER 1L */ OP zwei; /* INTEGER 2L */ OP im; /* komlpexe Einheit -i */ OP exp; /* Vorfaktor bei der Belegung */ OP psi, /* Tableaufunktionswerte */ psii,psij; INT i,j,k,l; INT fac; /* Faktor bei der Indizierung */ INT erg = OK; /* Variable zum Ablaufcheck */ INT make_all_st_tabs(); /* Routine zur Berechnung der Standardtableaux */ /* zu part */ INT get_index(); /* Routine zur Bestimmung des Index eines Tab- */ /* leaus im Tableauvektor */ if (not EMPTYP(res)) erg += freeself(res); /*** Test, ob ref = 0L oder 1L ******************************************/ if((ref != 0L) && (ref != 1L)) { error("gen_smat : wrong reference INTEGER "); return erg; } /*** Test, ob index < n-1 ***********************************************/ n = callocobject(); erg += weight(part,n); if(S_I_I(n) - 2L < index) { erg += freeall(n); error("gen_smat : index of generating element too big "); return erg; } /*** Test, ob die Partition part selbstassoziiert ist *******************/ conpar = callocobject(); erg += conjugate(part,conpar); if(part_comp(part,conpar) != 0L) { erg += freeall(n); erg += freeall(conpar); error("gen_smat : partition is not selfassociated "); return erg; } /*** Falls part = (2,1) oder part = (2,2), sind die Matrizen eindi- ***/ /*** mensional und koennen direkt angegeben werden. ***/ n = callocobject(); erg += weight(part,n); if((S_I_I(n) == 3L) || (S_I_I(n) == 4L)) { h_part = callocobject(); erg += hook_part(part,h_part); erg += m_ilih_m(1L,1L,res); if(index == 1L) erg += wert(ref,h_part,S_M_IJ(res,0L,0L)); else M_I_I(1L,S_M_IJ(res,0L,0L)); erg += freeall(conpar); erg += freeall(h_part); erg += freeall(n); return erg; } /*** Zunaechst berechnen wir die Standardtableaux zur Partition part ***/ /*** und den Vorzeichenvetor der Permutationen, die das erste ***/ /*** Standardtableau in das i-te ueberfuehren. ***/ tab = callocobject(); sig = callocobject(); erg += make_all_st_tabs(part,tab); erg += make_tab_signs(part,sig); /*** Belegung der darstellenden Matrix von (1 2)(index+1,index+2) *******/ vgl_tab = callocobject(); dist1 = callocobject(); dist2 = callocobject(); eins = callocobject(); zwei = callocobject(); im = callocobject(); exp = callocobject(); psii = callocobject(); psij = callocobject(); psi = callocobject(); M_I_I(1L,eins); M_I_I(2L,zwei); erg += addinvers(eins,im); erg += squareroot(im,im); erg += addinvers_apply(im); l = S_V_LI(tab)/2L; fac = ref*l; erg += m_ilih_nm(l,l,res); for(i=0L;i=l))) j = k-fac; else j = S_V_LI(tab)-k-1-fac; erg += invers(dist1,S_M_IJ(res,i,j)); erg += hoch(S_M_IJ(res,i,j),zwei,S_M_IJ(res,i,j)); erg += addinvers_apply(S_M_IJ(res,i,j)); erg += add_apply(eins,S_M_IJ(res,i,j)); erg += squareroot(S_M_IJ(res,i,j),S_M_IJ(res,i,j)); erg += mult_apply(dist2,S_M_IJ(res,i,j)); if(!(((fac==0L) && (k=l)))) { erg += add(eins,S_V_I(sig,S_V_LI(sig)-1L),exp); erg += hoch(zwei,exp,exp); erg += hoch(im,exp,exp); erg += mult_apply(S_V_I(sig,fac+i),exp); if(ref ==0L) erg += addinvers_apply(exp); erg += mult_apply(exp,S_M_IJ(res,i,j)); } erg += tab_funk(n,part,S_V_I(tab,fac+i),psii); erg += tab_funk(n,part,S_V_I(tab,fac+j),psij); erg += div(psij,psii,psi); erg += squareroot(psi,psi); erg += mult_apply(psi,S_M_IJ(res,i,j)); } } /*** Speicherplatzfreigabe **********************************************/ erg += freeall(conpar); erg += freeall(tab); erg += freeall(n); erg += freeall(vgl_tab); erg += freeall(dist1); erg += freeall(dist2); erg += freeall(eins); erg += freeall(zwei); erg += freeall(im); erg += freeall(exp); erg += freeall(psii); erg += freeall(psij); erg += freeall(psi); /*** Rueckkehr in die aufrufende Routine ********************************/ if (erg != OK) { error("gen_smat : error during computation."); return ERROR; } return OK; } /* Ende von gen_smat */ /****************************************************************************/ /* */ /* Name: get_ax_dist() */ /* Diese Routine berechnet die Axialdistanz der Punkte r und s im */ /* Standardtableau tab. */ /* Rueckgabewert: OK oder error. */ /* */ /****************************************************************************/ /* PF 071092 */ INT get_ax_dist(tab,r,s,res) OP tab,res; INT r,s; /* tab Standardtableau */ /* r,s Zahlen zwischen denen die Axialdistanz berechnet werden soll. */ /* res: Axialdistanz von r und s in tab */ { OP s1; /* Positionsvektor [i,j], falls tab(i,j) = r */ OP s2; /* Positionsvektor [k,l], falls tab(k,l) = s */ INT erg = OK; /* Variable zum Ablaufcheck */ if (not EMPTYP(res)) erg += freeself(res); /*** Berechnung der Positionen (i,j) und (k,l), an denen r bzw. s in ***/ /*** tab stehen. ***/ s1 = callocobject(); s2 = callocobject(); erg += get_position(tab,r,s1); erg += get_position(tab,s,s2); /*** Berechnung der Axialdistanz ****************************************/ M_I_I(S_V_II(s2,0L)-S_V_II(s2,1L)+S_V_II(s1,1L)-S_V_II(s1,0L),res); /*** Speicherplatzfreigabe **********************************************/ erg += freeall(s1); erg += freeall(s2); /*** Rueckkehr in die aufrufende Routine ********************************/ if (erg != OK) EDC("get_ax_dist"); return erg; } /* Ende von get_ax_dist */ /****************************************************************************/ /* */ /* Name: get_position() */ /* Diese Routine berechnet die Position des Zahl r in dem Standard- */ /* tableau tab und schreibt sie in den Vektor res = [i,j] der Laenge 2. */ /* Rueckgabewert: 0L, falls r gefunden wurde, */ /* -1L, sonst. */ /* */ /****************************************************************************/ /* PF 071092 */ INT get_position(tab,r,res) OP tab, res; INT r; /* tab Standardtableau */ /* i Zahl die gesucht werden soll */ /* res Positionsvektor [i,j], falls tab(i,j) = r */ { INT erg = OK; /* Variable zum Ablaufcheck */ INT i,j; if (not EMPTYP(res)) erg += freeself(res); /*** Suche der Zahl r im Standardtableau tab ****************************/ erg += m_il_v(2L,res); for(i=0L;i0;i--) /*** ... und pruefe, ob die Zahl n in dieser Zeile auftreten kann. ***/ if(S_PA_II(par,i) > S_PA_II(par,i-1)) { /*** Berechne die Partition, die entsteht, wenn n aus dem ***/ /*** Tableau entfernt wird und erzeuge alle moeglichen ***/ /*** Tableaux zu dieser Partition, fuege die Zahl n an ***/ /*** entsprechender Stelle wieder ein und haenge alle so ***/ /*** gefundenen Tableaux an den Ergebnisvektor an. ***/ erg += copy(par,new_par); erg += sub(S_PA_I(new_par,i),eins,S_PA_I(new_par,i)); erg += make_all_st_tabs(new_par,zw); for(j=0;j0;j--) erg += copy(S_PA_I(par,j),S_V_I(hilf,j-1)); erg += m_v_pa(hilf,new_par); k++; } erg += make_all_st_tabs(new_par,zw); for(j=0;j1, wird der Faktor phi berechnet. **************************/ phi = callocobject(); pos = callocobject(); M_I_I(1L,phi); erg += get_position(tab,S_I_I(n),pos); if(!(S_V_II(pos,0L) == 0L)) { eins = callocobject(); wert = callocobject(); M_I_I(1L,eins); for(i=0L;i=0L;i--) erg += mult_apply(S_V_I(mat,S_V_II(rz,i)-1L),D); /*** Speicherplatzfreigabe **********************************************/ erg += freeall(sig); erg += freeall(conpar); erg += freeall(rz); erg += freeall(mat); erg += freeall(n); /*** Rueckkehr in die aufrufende Routine ********************************/ if (erg != OK) EDC("an_odg"); return erg; } /* Ende von an_odg */ /****************************************************************************/ /****************************************************************************/ /****************************************************************************/ /* */ /* Name: an_sdg() */ /* Diese Routine berechnet die darstellende seminormale Matrix einer */ /* Permutation perm in der Darstellung zu einer Partition part, einge- */ /* schraenkt auf die An durch direkte Belegung. */ /* Rueckgabewert: OK oder error. */ /* */ /****************************************************************************/ /* PF 280992 */ /* PF 130593 */ INT an_sdg(part,perm,D) OP part,perm,D; /* PF 1993 */ /* AK 220704 V3.0 */ /* part Vektor, der die Darstellung beschreibt: */ /* 1. Komponente : Partition */ /* 2. Komponente : 0L oder 1L */ /* perm Darzustellende Permutation */ /* D result is seminormale Matrix zu [part](perm) */ { INT erg = OK; { #ifdef DGTRUE OP conpar; /* konjugierte Partition zu part */ OP sig; /* Signum von perm */ OP n; /* Gewicht von part */ OP rz; /* Zerlegungsvektor von perm in erzeugende Elemente */ /* der An */ OP mat; /* Vektor der darstellenden Matrizen der erzeugen- */ /* den Elemente der An */ OP dim; /* Dimension von D */ INT i,l; INT an_rz_perm(); /* Routine zur Zerlegung von perm in erzeugende */ /* Elemente (12)(r-1,r) der An */ INT trafo_check(); /* Routine zum Testen der Anordnung der Bloecke */ /* durch die Transformation */ INT gen_smat(); /* Routine zur Berechnung der darstellenden Matri- */ /* zen der erzeugenden Elemente */ FREESELF(D); /*** Test, ob perm in der An liegt **************************************/ sig = callocobject(); erg += signum(perm,sig); if(S_I_I(sig) == -1L) { FREEALL(sig); erg += error("an_sdg : permutation not in An"); goto endr_ende; } /*** Test, ob Laenge von perm mit dem Gewicht von part uebereinstimmt ***/ n = callocobject(); erg += weight(S_V_I(part,0L),n); if(S_I_I(n) != S_P_LI(perm)) { FREEALL2(sig,n); erg += error("an_sdg : permutation and partition don't agree"); goto endr_ende; } /*** Falls n = 1 oder n = 2, wird D = (1) zurueckgegeben. ***************/ if((S_P_LI(perm) == 1L) || (S_P_LI(perm) == 2L)) { erg += m_ilih_m(1L,1L,D); M_I_I(1L,S_M_IJ(D,0L,0L)); FREEALL2(sig,n); goto endr_ende; } /*** Berechnung der Matrix **********************************************/ /*** Falls es sich um die Identitaet handelt, wird die Einheitsmatrix ***/ /*** ausgegeben. ***/ if(einsp(perm)) { dim = callocobject(); erg += dimension_partition(S_V_I(part,0L),dim); erg += m_lh_nm(dim,dim,D); for(i=0;i=0L;i--) erg += mult_apply(S_V_I(mat,S_V_II(rz,i)-1L),D); FREEALL5(sig,conpar,rz,mat,n); #endif } ENDR("an_sdg"); } symmetrica-2.0/boe.doc0000600017361200001450000001575610726170273014654 0ustar tabbottcrontabNAME: specht_poly SYNOPSIS: INT specht_poly(OP a,b) DESCRIPTION: you enter a TABLEAUX object a, and the output is the corresponding Specht polynomial b, a object of the type POLYNOM. The mathematical background is described in Specht: Math. Zeitschr. ?? You may enter also a skewtableaux. EXAMPLE: #include "def.h" #include "macro.h" BEGIN scan(TABLEAUX,a); specht_poly(a,b); println(b); END NAME: specht_dg SYNOPSIS: INT specht_dg(OP a,b,c) DESCRIPTION: you enter a PARTITION or SKEWPARTITION object a, and a PERMUTATION object b, and the output is the corresponding representation of the symmetric group. This representation is integral and in the case of a PARTITION object a, it is irreducible. EXAMPLE: #include "def.h" #include "macro.h" BEGIN scan(scanobjectkind(),a); scan(PERMUTATION,b); specht_dg(a,b,c); println(c); END NAME: an_odg SYNOPSIS: INT an_odg(OP part,perm,D) DESCRIPTION: computes the unitary matrix D representing a PERMUTATION perm in the irreducible resresentation [part] of a partition part restricted to An (part has to be a VECTOR of length 2, the compnents of which are a partition and an integer 0L or 1L). 0L means, that [part]+ is concerned in case of a selfconjugate partition, and 1L indicates [part]-. NAME: an_rz_perm SYNOPSIS: INT an_rz_perm(OP per,res) DESCRIPTION: computes the decomposition of the PERMUTATION per into the generating elements (1,2)(2,3), .... ,(1,2)(n-1,n) of An. The result is a VECTOR of INTEGER, which is to read from right to left. NAME: an_sdg SYNOPSIS: INT an_sdg(OP part,perm,D) DESCRIPTION: computes the seminormal matrix D representing a PERMUTATION perm in the irreducible resresentation [part] of a partition part restricted to An (part has to be a VECTOR of length 2, the compnents of which are a partition and an integer 0L or 1L). 0L means, that [part]+ is concerned in case of a selfconjugate partition, and 1L indicates [part]-. NAME: an_trafo_odg SYNOPSIS: INT an_trafo_odg(OP part,perm,D) DESCRIPTION: computes the unitary matrix D representing a PERMUTATION perm in the irreducible resresentation [part] of a partition part restricted to An (part has to be a VECTOR of length 2, the components of which are a partition and an integer 0L or 1L). 0L means, that [part]+ is concerned in case of a selfconjugate partition, and 1L indicates [part]-. The result arises from the transformation of the according matrix of [part] over Sn. NAME: an_trafo_sdg SYNOPSIS: INT an_trafo_sdg(OP part,perm,D) DESCRIPTION: computes the seminormal matrix D representing a PERMUTATION perm in the irreducible resresentation [part] of a partition part restricted to An (part has to be a VECTOR of length 2, the components of which are a partition and an integer 0L or 1L). 0L means, that [part]+ is concerned in case of a selfconjugate partition, and 1L indicates [part]-. The result arises from the transformation of the according matrix of [part] over Sn. NAME: alt_sdg_trafo SYNOPSIS: INT alt_sdg_trafo(OP part,D) DESCRIPTION: transforms the seminormal MATRIX D, belonging to the irreducible representation [part] of a selfconjugate PARTITION part of Sn into a matrix containing only two blocks in the main diagonal, the blocks of the seminormal matrices belonging to [part]+ and [part]-. NAME: alt_odg_trafo SYNOPSIS: INT alt_odg_trafo(OP part,D) DESCRIPTION: transforms the orthogonal MATRIX D, belonging to the irreducible representation [part] of a selfconjugate PARTITION part of Sn into a matrix containing only two blocks in the main diagonal, the blocks of the orthogonal matrices belonging to [part]+ and [part]-. NAME: gen_mat SYNOPSIS: INT gen_mat(OP part;INT index,ref;OP res) DESCRIPTION: computes the unitary matrix representing the permutation (12)(index+1,index+2) within the irreducible representation [part]+ oder [part]- of the selfconjugated PARTITION part, where the number ref handles, which part of the representing martix, transformed by alt_odg_trafo(), has to be given back as result. ref=0L indicates the first block, and ref=1L the second. NAME: gen_smat SYNOPSIS: INT gen_smat(OP part;INT index,ref;OP res) DESCRIPTION: computes the seminormal matrix representing the permutation (12)(index+1,index+2) within the irreducible representation [part]+ oder [part]- of the selfconjugated PARTITION part, where the number ref handles, which part of the representing martix, transformed by alt_odg_trafo(), has to be given back as result. ref=0L indicates the first block, and ref=1L the second. NAME: get_ax_dist SYNOPSIS: INT get_ax_dist(OP tab;INT r,s;OP res) DESCRIPTION: computes the axial distance between the INTEGERs r and s in a standard-young-TABLEAU tab. NAME: get_position SYNOPSIS: INT get_position(OP tab;INT r;OP res) DESCRIPTION: computes the position of the INTEGER r in a TABLEAU tab. The first appearence of r is taken. The result is a VECTOR of length 2 of INTEGER. NAME: make_all_st_tabs SYNOPSIS: INT make_all_st_tabs(OP par,res) DESCRIPTION: computes all standard-young-tableaux belonging to a PARTITION par ordered in last letter sequence. The result is a VECTOR. BUG: The matrices in which the tableaux are stated can be bigger than necessary! NAME: make_tab_signs SYNOPSIS: INT make_tab_signs(OP par,res) DESCRIPTION: computes a vector of integers, that contain the signs of the permutations transforming the first standard-young-tableau of a PARTITION par into the ith, where the tableaux are ordered according the last letter sequence. NAME: mat_comp SYNOPSIS: INT mat_comp(OP a,b) DESCRIPTION: compares two MATRICES a and b allowing the entries to be of type SQ_RADICAL. RETURN: 0L in case a equal b, else 1L. NAME: op_transpo_tab SYNOPSIS: INT op_transpo_tab(INT transpo;OP tab,res) DESCRIPTION: computes the TABLEAU (transpo,transpo+1)*tab, where tab is a TABLEAU, too. NAME: tab_funk SYNOPSIS: INT tab_funk(OP n,part,tab,res) DESCRIPTION: computes the value of the tableau function of a TABLEAU tab belonging to a PARTITION part of a INTEGER n. tab has to be a standard-young-tableau. NAME: tab_index SYNOPSIS: INT tab_index(OP tab,vector) DESCRIPTION: computes the index of a TABLEAU tab in a VECTOR of tableaux vector. RETURN: index, in case that tab is in vector, else -1. NAME: trafo_check SYNOPSIS: INT trafo_check(OP part) DESCRIPTION: checks in case of a selfconjugate PARTITION part, where the representing matrices of the representation [part]+ and [part]- will occur, if the representing martix of [part] is reduced with the transforming matrices given by B.M. Puttaswamaiah (1963), as implemented in alt_odg_trafo. RETURN: 0L in case that [part]+ is in the first block, else 1L. symmetrica-2.0/bruch.c0000400017361200001450000016377010726021610014653 0ustar tabbottcrontab/* SYMMETRICA source code file: bruch.c */ #include "def.h" #include "macro.h" static INT ggt_mp(); static INT lowcf_br(); static INT lowcf_br(); INT kuerzen_yn; static struct bruch * callocbruch(); static INT freebruch(); static int bruch_speicherindex=-1; /* AK 301001 */ static int bruch_speichersize=0; /* AK 301001 */ static struct bruch **bruch_speicher=NULL; /* AK 301001 */ static INT mem_counter_bruch=0; #ifdef BRUCHTRUE INT bruch_anfang() /* AK 100893 */ { mem_counter_bruch=0; return OK; } #define B_OU_B(oben,unten,ergebnis)\ ( C_O_K(ergebnis,BRUCH),\ (ergebnis->ob_self).ob_bruch=callocbruch(),\ C_B_O(ergebnis,oben) ,\ C_B_U(ergebnis,unten) ,\ C_B_I(ergebnis,NGEKUERZT) \ ) INT bruch_ende() /* AK 100893 */ /* this function is called to clean up data structures concerning BRUCH objects */ /* this function is called from the function ende */ { INT erg = OK; if (no_banner != TRUE) if (mem_counter_bruch != 0L) { fprintf(stderr,"mem_counter_bruch = %ld\n",mem_counter_bruch); erg += error("bruch memory not freed"); goto endr_ende; } if (bruch_speicher!=NULL) { INT i; for (i=0;i<=bruch_speicherindex;i++) SYM_free(bruch_speicher[i]); SYM_free(bruch_speicher); } bruch_speicher=NULL; bruch_speicherindex=-1; bruch_speichersize=0; ENDR("bruch_ende"); } INT add_bruch_scalar(a,b,c) OP a, b, c; /* AK 050789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OP d; CTO(BRUCH,"add_bruch_scalar(1)",a); CTO(EMPTY,"add_bruch_scalar(3)",c); d = callocobject(); erg += m_scalar_bruch(b,d); erg += add_bruch_bruch(a,d,c); /* hat kuerzen */ FREEALL(d); ENDR("add_bruch_scalar"); } INT add_bruch_integer(a,b,c) OP a,b,c; /* AK 251001 */ { INT erg = OK; OP d; CTO(BRUCH,"add_bruch_integer(1)",a); CTO(INTEGER,"add_bruch_integer(2)",b); CTO(EMPTY,"add_bruch_integer(3)",c); erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),c); d = CALLOCOBJECT(); MULT_INTEGER(b,S_B_U(a),d); ADD(d,S_B_O(a),S_B_O(c)); FREEALL(d); COPY(S_B_U(a),S_B_U(c)); erg += kuerzen(c); ENDR("add_bruch_integer"); } INT random_bruch(a) OP a; /* AK 191093 */ { INT erg = OK; CTO(EMPTY,"random_bruch(1)",a); rb_again: erg += b_ou_b(callocobject(),callocobject(),a); /* a is freed automatically */ erg += random_integer(S_B_O(a),NULL,NULL); erg += random_integer(S_B_U(a),cons_zwei,NULL); kuerzen(a); if (S_O_K(a) != BRUCH) goto rb_again; ENDR("random_bruch"); } INT add_bruch_bruch(a,b,c) OP a, b, c; /* AK 050789 V1.0 */ /* AK 181289 V1.1 */ /* AK 270291 V1.2 */ /* AK 200891 V1.3 */ { OP zw2; INT erg =OK; CTO(BRUCH,"add_bruch_bruch(1)",a); CTO(BRUCH,"add_bruch_bruch(2)",b); CTO(EMPTY,"add_bruch_bruch(3)",c); erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),c); MULT(S_B_U(a),S_B_U(b),S_B_U(c)); zw2 = CALLOCOBJECT(); MULT(S_B_O(a), S_B_U(b), S_B_O(c)); MULT(S_B_U(a), S_B_O(b), zw2); ADD_APPLY(zw2,S_B_O(c)); FREEALL(zw2); erg += kuerzen(c); ENDR("add_bruch_bruch"); } INT absolute_bruch(a,b) OP a,b; /* AK 150393 */ { INT erg = OK; CTO(BRUCH,"absolute_bruch(1)",a); CTO(EMPTY,"absolute_bruch(2)",b); erg += b_ou_b(callocobject(),callocobject(),b); erg += absolute(S_B_O(a),S_B_O(b)); erg += absolute(S_B_U(a),S_B_U(b)); ENDR("absolute_bruch"); } INT add_bruch(a,b,c) OP a,b,c; /* AK 310888 */ /* AK 050789 V1.0 */ /* AK 181289 V1.1 */ /* AK 270291 V1.2 */ /* AK 200891 V1.3 */ /*CC 190995 */ { INT erg = OK; CTO(BRUCH,"add_bruch(1)",a); CTO(EMPTY,"add_bruch(3)",c); switch(S_O_K(b)) { case INTEGER: erg += add_bruch_integer(a,b,c); goto aiende; case LONGINT: erg += add_bruch_scalar(a,b,c); goto aiende; case BRUCH: erg += add_bruch_bruch(a,b,c); goto aiende; #ifdef POLYTRUE case LAURENT: { OP tp2; tp2=callocobject(); erg += m_ou_b(b,cons_eins,tp2); erg += kuerzen(tp2); erg += add_bruch_bruch(a,tp2,c); erg += freeall(tp2); } break; /*CC*/ case MONOPOLY: { OP tp2=callocobject(); erg += m_ou_b(b,cons_eins,tp2); erg += add_bruch_bruch(a,tp2,c); erg += freeall(tp2); } break; case POLYNOM: /* if (has_one_variable(b)) { OP tp2=callocobject(); erg += m_ou_b(b,cons_eins,tp2); erg += kuerzen(tp2); erg += add_bruch_bruch(a,tp2,c); erg += freeall(tp2); } else */ erg += add_scalar_polynom(a,b,c); goto aiende; #endif /* POLYTRUE */ #ifdef SCHURTRUE /* AK 240102 */ case SCHUR: erg += add_schur(b,a,c); goto aiende; case HOMSYM: erg += add_homsym(b,a,c); goto aiende; case POWSYM: erg += add_powsym(b,a,c); goto aiende; case ELMSYM: erg += add_elmsym(b,a,c); goto aiende; case MONOMIAL: erg += add_monomial(b,a,c); goto aiende; #endif /* SCHURTRUE */ case SQ_RADICAL: erg += add_scalar_sqrad(a,b,c); goto aiende; case CYCLOTOMIC: erg += add_scalar_cyclo(a,b,c); goto aiende; default : erg += WTO("add_bruch(2)",b); }; erg += kuerzen(c); aiende: ENDR("add_bruch"); } INT negp_bruch(a) OP a; /* AK 050789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK 221298 V2.0 */ /* TRUE if a < 0 */ { if (negp(S_B_O(a))) { if (negp(S_B_U(a))) return(FALSE); else return(TRUE); } else if (NULLP(S_B_O(a))) /* AK 221298 */ return FALSE; /* now S_B_O > 0 */ if (negp(S_B_U(a))) return(TRUE); return(FALSE); } INT einsp_bruch(a) OP a; /* AK 050789 V1.0 */ /* AK 081289 V1.1 */ /* AK 200891 V1.3 */ { return EQ(S_B_O(a),S_B_U(a)); } INT negeinsp_bruch(a) OP a; /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ { INT erg; CTO(BRUCH,"negeinsp_bruch(1)",a); addinvers_apply(S_B_O(a)); erg = EQ(S_B_O(a),S_B_U(a)); addinvers_apply(S_B_O(a)); return(erg); ENDR("negeinsp_bruch"); } INT nullp_bruch(a) OP a; /* AK 050789 V1.0 */ /* AK 201289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"nullp_bruch(1)",a); return (NULLP(S_B_O(a))); ENDR("nullp_bruch"); } INT addinvers_bruch(a,b) OP a,b; /* AK 290388*/ /* AK 050789 V1.0 */ /* AK 201289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"addinvers_bruch(1)",a); CTO(EMPTY,"addinvers_bruch(2)",b); erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),b); ADDINVERS(S_B_O(a),S_B_O(b)); COPY(S_B_U(a),S_B_U(b)); if (NEGP(S_B_O(b)) && NEGP(S_B_U(b))) { ADDINVERS_APPLY(S_B_O(b)); ADDINVERS_APPLY(S_B_U(b)); } C_B_I(b,S_B_I(a)); ENDR("addinvers_bruch"); } INT addinvers_apply_bruch(a) OP a; /* AK 201289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"addinvers_apply_bruch(1)",a); ADDINVERS_APPLY(S_B_O(a)); if (NEGP(S_B_O(a)) && NEGP(S_B_U(a))) { ADDINVERS_APPLY(S_B_O(a)); ADDINVERS_APPLY(S_B_U(a)); } ENDR("addinvers_apply_bruch"); } INT invers_apply_bruch(a) OP a; /* AK 161001 */ { INT erg = OK; CTO(BRUCH,"invers_apply_bruch(1)",a); erg += swap(S_B_O(a),S_B_U(a)); ENDR("invers_apply_bruch"); } INT invers_bruch(a,b) OP a,b; /* AK 031286 */ /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"invers_bruch(1)",a); CTO(EMPTY,"invers_bruch(2)",b); erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),b); COPY(S_B_U(a),S_B_O(b)); COPY(S_B_O(a),S_B_U(b)); C_B_I(b,S_B_I(a)); ENDR("invers_bruch"); } INT mult_bruch_integer(a,b,c) OP a,b,c; /* AK 040789 V1.0 */ /* AK 081289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OP d; CTO(BRUCH,"mult_bruch_integer(1)",a); CTO(INTEGER,"mult_bruch_integer(2)",b); CTO(EMPTY,"mult_bruch_integer(3)",c); if (INTEGRALP(S_B_O(a)) && INTEGRALP(S_B_U(a)) ) { d = CALLOCOBJECT(); GGT_INTEGER(b,S_B_U(a),d); if (EQ(d,S_B_U(a))) { GANZDIV(b,d,c); MULT_APPLY(S_B_O(a),c); FREEALL(d); goto ende; } B_OU_B(CALLOCOBJECT(),CALLOCOBJECT(),c); GANZDIV(S_B_U(a),d,S_B_U(c)); GANZDIV_INTEGER(b,d,S_B_O(c)); FREEALL(d); MULT_APPLY(S_B_O(a),S_B_O(c)); if (NEGP(S_B_O(c)) && NEGP(S_B_U(c))) { ADDINVERS_APPLY(S_B_O(c)); ADDINVERS_APPLY(S_B_U(c)); } C_B_I(c,GEKUERZT); goto ende; } /* denominator or nominator not a integer */ /* AK 060502 */ COPY(a,c); MULT_APPLY(b,S_B_O(c)); erg += kuerzen(c); ende: CTTTTO(LONGINT,INTEGER,S_O_K(S_B_O(a)),BRUCH,"mult_bruch_integer(e3)",c); ENDR("mult_bruch_integer"); } INT mult_bruch_longint(a,b,c) OP a,b,c; /* AK 040789 V1.0 */ /* AK 081289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OP d; CTO(BRUCH,"mult_bruch_longint(1)",a); CTO(LONGINT,"mult_bruch_longint(2)",b); CTO(EMPTY,"mult_bruch_longint(3)",c); d = CALLOCOBJECT(); GGT_LONGINT(b,S_B_U(a),d); if (EQ(d,S_B_U(a))) { GANZDIV(b,d,c); MULT_APPLY(S_B_O(a),c); FREEALL(d); goto endr_ende; } B_OU_B(CALLOCOBJECT(),CALLOCOBJECT(),c); GANZDIV(S_B_U(a),d,S_B_U(c)); GANZDIV_LONGINT(b,d,S_B_O(c)); FREEALL(d); MULT_APPLY(S_B_O(a),S_B_O(c)); if (NEGP(S_B_O(c)) && NEGP(S_B_U(c))) { ADDINVERS_APPLY(S_B_O(c)); ADDINVERS_APPLY(S_B_U(c)); } C_B_I(c,GEKUERZT); CTTTTO(INTEGER,LONGINT,S_O_K(S_B_O(a)),BRUCH,"mult_bruch_longint(e3)",c); ENDR("mult_bruch_longint"); } INT mult_bruch_bruch(a,b,c) OP a,b,c; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"mult_bruch_bruch(1)",a); CTO(BRUCH,"mult_bruch_bruch(2)",b); CTTO(EMPTY,BRUCH,"mult_bruch_bruch(3)",c); if (S_O_K(c) == BRUCH) { FREESELF(S_B_O(c)); FREESELF(S_B_U(c)); } else B_OU_B(CALLOCOBJECT(),CALLOCOBJECT(),c); if ( INTEGRALP(S_B_O(a)) && INTEGRALP(S_B_U(a)) && INTEGRALP(S_B_O(b)) && INTEGRALP(S_B_U(b)) ) { OP d = CALLOCOBJECT(); OP e = CALLOCOBJECT(); GGT(S_B_O(a),S_B_U(b),d); if (not EINSP(d)) { GANZDIV(S_B_O(a),d,S_B_O(c)); GANZDIV(S_B_U(b),d,S_B_U(c)); } else { COPY(S_B_O(a),S_B_O(c)); COPY(S_B_U(b),S_B_U(c)); } FREESELF(d); GGT(S_B_U(a),S_B_O(b),d); if (not EINSP(d)) { GANZDIV(S_B_O(b),d,e); MULT_APPLY(e,S_B_O(c)); } else { MULT_APPLY(S_B_O(b),S_B_O(c)); } FREESELF(e); if (not EINSP(d)) { GANZDIV(S_B_U(a),d,e); MULT_APPLY(e,S_B_U(c)); } else { MULT_APPLY(S_B_U(a),S_B_U(c)); } if (NEGP(S_B_O(c)) && NEGP(S_B_U(c))) { ADDINVERS_APPLY(S_B_O(c)); ADDINVERS_APPLY(S_B_U(c)); } C_B_I(c,GEKUERZT); FREEALL(e); FREEALL(d); goto ende; } MULT(S_B_O(a),S_B_O(b),S_B_O(c)); MULT(S_B_U(a),S_B_U(b),S_B_U(c)); erg += kuerzen(c); ende: ENDR("mult_bruch_bruch"); } INT tex_bruch(a) OP a; /* AK 070291 V1.2 */ /* AK 300791 V1.3 */ /* AK 200891 V1.3 */ { INT erg = OK,merk; CTO(BRUCH,"tex_bruch(1)",a); merk = texmath_yn; if (texmath_yn != (INT)1) { fprintf(texout,"$"); texmath_yn = (INT)1; } fprintf(texout,"{"); erg += tex(S_B_O(a)); fprintf(texout," \\over "); erg += tex(S_B_U(a)); fprintf(texout,"}"); texposition += (INT)10; texmath_yn = merk; if (texmath_yn != (INT)1) /* d.h. no math mode any more */ fprintf(texout,"$"); ENDR("tex_bruch"); } INT fprint_bruch(a,b) FILE *a; OP b; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 040391 V1.2 */ /* AK 200891 V1.3 */ { extern INT zeilenposition; fprint(a,S_B_O(b)); fprintf(a,"/"); if (a == stdout) { if (zeilenposition > 70L) { zeilenposition = 0L; fprintf(a,"\n"); } else zeilenposition++; } fprint(a,S_B_U(b)); return OK; } INT freeself_bruch(bruch) OP bruch; /* AK 050789 V1.0 */ /* AK 211189 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; FREEALL(S_B_O(bruch)); FREEALL(S_B_U(bruch)); erg += freebruch(S_O_S(bruch).ob_bruch); C_O_K(bruch,EMPTY); ENDR("freeself_bruch"); } INT copy_bruch(von,nach) OP von, nach; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"copy_bruch(1)",von); CTO(EMPTY,"copy_bruch(2)",nach); B_OU_B(CALLOCOBJECT(),CALLOCOBJECT(),nach); COPY(S_B_O(von),S_B_O(nach)); COPY(S_B_U(von),S_B_U(nach)); C_B_I(nach,S_B_I(von)); ENDR("copy_bruch"); } static struct bruch * callocbruch() /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { struct bruch *ergebnis; mem_counter_bruch++; if (bruch_speicherindex >= 0) /* AK 301001 */ return bruch_speicher[bruch_speicherindex--]; ergebnis = (struct bruch *) SYM_malloc( sizeof(struct bruch)); if (ergebnis == NULL) no_memory(); return ergebnis; } static INT freebruch(v) struct bruch *v; /* AK 231001 */ { INT erg = OK; if (bruch_speicherindex+1 == bruch_speichersize) { if (bruch_speichersize == 0) { bruch_speicher = (struct bruch **) SYM_malloc(100 * sizeof(struct bruch *)); if (bruch_speicher == NULL) { erg += error("no memory"); goto endr_ende; } bruch_speichersize = 100; } else { bruch_speicher = (struct bruch **) SYM_realloc (bruch_speicher, 2 * bruch_speichersize * sizeof(struct bruch *)); if (bruch_speicher == NULL) { erg += error("no memory"); goto endr_ende; } bruch_speichersize = 2 * bruch_speichersize; } } mem_counter_bruch--; bruch_speicher[++bruch_speicherindex] = v; ENDR("freebruch"); } INT m_ou_b(oben,unten,ergebnis) OP oben, unten,ergebnis; /* AK 221190 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),ergebnis); COPY(oben, S_B_O(ergebnis)); COPY(unten, S_B_U(ergebnis)); CTO(BRUCH,"m_ou_b(3-end)",ergebnis); ENDR("m_ou_b"); } INT b_ou_b(oben,unten,ergebnis) OP oben, unten,ergebnis; /* AK 050789 V1.0 */ /* AK 071289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OBJECTSELF d; if (oben == unten) { erg += error("b_ou_b:identical objects"); goto endr_ende; } d.ob_bruch = callocbruch(); erg += b_ks_o(BRUCH, d, ergebnis); C_B_O(ergebnis,oben); C_B_U(ergebnis,unten); C_B_I(ergebnis,NGEKUERZT); ENDR("b_ou_b"); } INT m_ioiu_b(oben,unten,ergebnis) INT oben,unten; OP ergebnis; /* AK 030389 ein bruch mit einem integer eintrag im zaehler und einem integer eintrag im nenner z.b. oben = 3 unten = 5 --> 3/5 */ /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),ergebnis); M_I_I(oben,S_B_O(ergebnis)); M_I_I(unten,S_B_U(ergebnis)); return erg; } INT scan_bruch(a) OP a; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ /* AK 220998 V2.0 */ { OBJECTKIND kind; INT erg = OK; CTO(EMPTY,"scan_bruch(1)",a); erg += b_ou_b(callocobject(),callocobject(),a); erg += printeingabe("input of a fractional number"); erg += printeingabe("input of the nominator"); kind = scanobjectkind(); erg += scan(kind,S_B_O(a)); erg += printeingabe("input of the denominator"); kind = scanobjectkind(); erg += scan(kind,S_B_U(a)); erg += kuerzen(a); ENDR("scan_bruch"); } INT scan_integerbruch(a) OP a; /* AK 220998 V2.0 */ { INT erg = OK; CTO(EMPTY,"scan_integerbruch(1)",a); erg +=b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),a); erg += printeingabe("input of a fraction two INTEGER objects"); erg += printeingabe("input of the nominator"); erg += scan(INTEGER,S_B_O(a)); erg += printeingabe("input of the denominator"); erg += scan(INTEGER,S_B_U(a)); CTO(BRUCH,"scan_integerbruch(i)",a); erg += kuerzen_integral(a); ENDR("scan_integerbruch"); } OP s_b_o(a) OP a; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; INT erg = OK; CTO(BRUCH, "s_b_o",a); c = s_o_s(a); return(c.ob_bruch->b_oben); ENDO("s_b_o"); } OP s_b_u(a) OP a; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; INT erg = OK; CTO(BRUCH, "s_b_u(1)",a); c = s_o_s(a); return(c.ob_bruch->b_unten); ENDO("s_b_u"); } INT s_b_i(a) OP a; /* notiert gekuerzt oder nicht */ { INT erg = OK; OBJECTSELF c; CTO(BRUCH, "s_b_i(1)",a); c = s_o_s(a); return(c.ob_bruch->b_info); ENDR("s_b_i") } INT s_b_oi(a) OP a; /* AK 240789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { return(s_i_i(s_b_o(a))); } INT s_b_ui(a) OP a; /* AK 240789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { return(s_i_i(s_b_u(a))); } INT c_b_o(a,b) OP a,b; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_bruch->b_oben = b; return(OK); } INT c_b_u(a,b) OP a,b; /* AK 050789 V1.0 */ /* AK 010290 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_bruch->b_unten = b; return(OK); } INT posp_bruch(a) OP a; /* AK 040590 V1.1 */ /* AK 200891 V1.3 */ /* AK 190298 V2.0 */ /* TRUE if >= 0 */ { INT erg = OK; CTO(BRUCH,"posp_bruch",a); if (NULLP(S_B_O(a))) return TRUE; if (posp(S_B_O(a))) { if (posp(S_B_U(a))) return TRUE; else return FALSE; } if (negp(S_B_U(a))) return TRUE; else return FALSE; ENDR("posp_bruch"); } INT comp_bruch(a,b) OP a,b; /* AK 050789 V1.0 */ /* AK 310190 V1.1 */ /* fehler beseitigt von Isabel Klein */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"comp_bruch(1)",a); if (S_O_K(b) == BRUCH) { /* a/b < c/d <==> ad < cb */ INT ret; OP c,d; c = CALLOCOBJECT(); d = CALLOCOBJECT(); MULT(S_B_O(a),S_B_U(b),c); MULT(S_B_O(b),S_B_U(a),d); if ( (NEGP(S_B_U(a)) && NEGP(S_B_U(b))) || (POSP(S_B_U(a)) && POSP(S_B_U(b))) ) ret = comp(c,d); else ret = comp(d,c); FREEALL(c); FREEALL(d); return(ret); } else if (scalarp(b)) return comp_bruch_scalar(a,b); else WTO("comp_bruch(2)",b); ENDR("comp_bruch"); } INT comp_bruch_scalar(a,b) OP a,b; /* AK 050789 V1.0 */ /* AK 310190 V1.1 */ /* AK 200891 V1.3 */ { INT erg=0; OP c; CTO(BRUCH,"comp_bruch_scalar(1)",a); c = CALLOCOBJECT(); MULT(S_B_U(a),b,c); erg = COMP(S_B_O(a),c); FREEALL(c); if (NEGP(S_B_U(a))) erg = -erg; /* AK 271192 */ return(erg); ENDR("comp_bruch_scalar"); } INT kuerzen_integer_integer(); INT kuerzen_integer_longint(); INT kuerzen_longint_integer(); INT kuerzen_longint_longint(); INT kuerzen(bruch) OP bruch; { INT erg = OK; CTTTO(LONGINT,INTEGER,BRUCH,"kuerzen(1)",bruch); if (S_O_K(bruch) != BRUCH) goto ende; if (kuerzen_yn == 1L) goto ende; /* d.h. nicht kuerzen */ if (S_O_K(S_B_O(bruch)) == INTEGER) { if (S_O_K(S_B_U(bruch)) == INTEGER) { erg += kuerzen_integer_integer(bruch); goto ende; } else if (S_O_K(S_B_U(bruch)) == LONGINT) { erg += kuerzen_integer_longint(bruch); goto ende; } else goto nf; } else if (S_O_K(S_B_O(bruch)) == LONGINT) { if (S_O_K(S_B_U(bruch)) == INTEGER) { erg += kuerzen_longint_integer(bruch); goto ende; } else if (S_O_K(S_B_U(bruch)) == LONGINT) { erg += kuerzen_longint_longint(bruch); goto ende; } else goto nf; } nf: erg += krz(bruch); ende: ENDR("kuerzen"); } INT kuerzen_integer_integer(bruch) OP bruch; { INT erg = OK; INT ggterg; CTO(BRUCH,"kuerzen_integer_integer(1)",bruch); CTO(INTEGER,"kuerzen_integer_integer(1-nominator)",S_B_O(bruch)); CTO(INTEGER,"kuerzen_integer_integer(1-denominator)",S_B_U(bruch)); if (kuerzen_yn == 1L) { goto ende; /* d.h. nicht kuerzen */ } if (NULLP_INTEGER(S_B_O(bruch))) { freeself_bruch(bruch); M_I_I(0,bruch); goto ende; } ggterg = ggt_i(S_B_UI(bruch),S_B_OI(bruch)); if (ggterg == S_B_UI(bruch)) { freeself_bruch(bruch); M_I_I(S_B_OI(bruch) / ggterg,bruch); goto ende; } if (-ggterg == S_B_UI(bruch)) { freeself_bruch(bruch); M_I_I(- S_B_OI(bruch) / ggterg,bruch); goto ende; } if (ggterg != 1) { M_I_I(S_B_OI(bruch)/ggterg,S_B_O(bruch)); M_I_I(S_B_UI(bruch)/ggterg,S_B_U(bruch)); } if (NEGP_INTEGER(S_B_O(bruch)) && NEGP_INTEGER(S_B_U(bruch))) { ADDINVERS_APPLY_INTEGER(S_B_O(bruch)); ADDINVERS_APPLY_INTEGER(S_B_U(bruch)); } C_B_I(bruch,GEKUERZT); ende: ENDR("kuerzen_integer_integer"); } INT kuerzen_integer_longint(bruch) OP bruch; { INT erg = OK; OP ggterg; CTO(BRUCH,"kuerzen_integer_longint(1)",bruch); CTO(INTEGER,"kuerzen_integer_longint(1-nominator)",S_B_O(bruch)); CTO(LONGINT,"kuerzen_integer_longint(1-denominator)",S_B_U(bruch)); if (kuerzen_yn == 1L) { goto ende; /* d.h. nicht kuerzen */ } if (NULLP_INTEGER(S_B_O(bruch))) { freeself_bruch(bruch); M_I_I(0,bruch); goto ende; } if (EINSP_INTEGER(S_B_O(bruch))) { C_B_I(bruch,GEKUERZT); goto ende; } ggterg = CALLOCOBJECT(); erg += ggt_integer_longint(S_B_O(bruch),S_B_U(bruch),ggterg); CTO(INTEGER,"kuerzen_integer_longint(i1)",ggterg); if (S_I_I(ggterg) != 1) { GANZDIV_APPLY_INTEGER(S_B_O(bruch),ggterg); GANZDIV_APPLY_LONGINT(S_B_U(bruch),ggterg); } FREEALL(ggterg); if (S_O_K(S_B_U(bruch)) == INTEGER) if (S_B_UI(bruch) == 1) { freeself_bruch(bruch); M_I_I(S_B_OI(bruch),bruch); goto ende; } else if (S_B_UI(bruch) == -1) { freeself_bruch(bruch); M_I_I( - S_B_OI(bruch),bruch); goto ende; } if (NEGP(S_B_O(bruch)) && NEGP(S_B_U(bruch))) { ADDINVERS_APPLY(S_B_O(bruch)); ADDINVERS_APPLY(S_B_U(bruch)); } C_B_I(bruch,GEKUERZT); ende: CTO(ANYTYPE,"kuerzen_integer_longint(e1)",bruch); ENDR("kuerzen_integer_longint"); } INT kuerzen_longint_integer(bruch) OP bruch; { INT erg = OK; OP ggterg; CTO(BRUCH,"kuerzen_longint_integer(1)",bruch); CTO(LONGINT,"kuerzen_longint_integer(1-nominator)",S_B_O(bruch)); CTO(INTEGER,"kuerzen_longint_integer(1-denominator)",S_B_U(bruch)); if (kuerzen_yn == 1L) { goto ende; /* d.h. nicht kuerzen */ } if (NULLP_LONGINT(S_B_O(bruch))) { freeself_bruch(bruch); M_I_I(0,bruch); goto ende; } ggterg = CALLOCOBJECT(); erg += ggt_integer_longint(S_B_U(bruch),S_B_O(bruch),ggterg); CTO(INTEGER,"kuerzen_integer_longint(i1)",ggterg); if (S_I_I(ggterg) != 1) { GANZDIV_APPLY_INTEGER(S_B_U(bruch),ggterg); GANZDIV_APPLY_LONGINT(S_B_O(bruch),ggterg); } FREEALL(ggterg); if (S_B_UI(bruch) == 1) { if (S_O_K(S_B_O(bruch)) == INTEGER) { INT wi = S_B_OI(bruch); freeself_bruch(bruch); M_I_I(wi,bruch); } else /* LONGINT */ { OP d; d = CALLOCOBJECT(); SWAP(S_B_O(bruch),d); erg += freeself_bruch(bruch); SWAP(d,bruch); FREEALL(d); } goto ende; } else if (S_B_UI(bruch) == -1) { if (S_O_K(S_B_O(bruch)) == INTEGER) { INT wi = S_B_OI(bruch); freeself_bruch(bruch); M_I_I(-wi,bruch); } else /* LONGINT */ { OP d; d = CALLOCOBJECT(); SWAP(S_B_O(bruch),d); erg += freeself_bruch(bruch); ADDINVERS_APPLY(d); SWAP(d,bruch); FREEALL(d); } goto ende; } if (NEGP(S_B_O(bruch)) && NEGP(S_B_U(bruch))) { ADDINVERS_APPLY(S_B_O(bruch)); ADDINVERS_APPLY(S_B_U(bruch)); } C_B_I(bruch,GEKUERZT); ende: ENDR("kuerzen_longint_integer"); } INT kuerzen_longint_longint(bruch) OP bruch; { INT erg = OK; OP ggterg; CTO(BRUCH,"kuerzen_longint_longint(1)",bruch); CTO(LONGINT,"kuerzen_longint_longint(1-nominator)",S_B_O(bruch)); CTO(LONGINT,"kuerzen_longint_longint(1-denominator)",S_B_U(bruch)); if (kuerzen_yn == 1L) { goto ende; /* d.h. nicht kuerzen */ } if (NULLP_LONGINT(S_B_O(bruch))) { freeself_bruch(bruch); M_I_I(0,bruch); goto ende; } ggterg = CALLOCOBJECT(); erg += ggt_longint_longint(S_B_U(bruch),S_B_O(bruch),ggterg); if (not EINSP(ggterg)) { GANZDIV_APPLY_LONGINT(S_B_U(bruch),ggterg); GANZDIV_APPLY_LONGINT(S_B_O(bruch),ggterg); } FREEALL(ggterg); if (S_O_K(S_B_U(bruch))== INTEGER) if (S_B_UI(bruch) == 1) { if (S_O_K(S_B_O(bruch)) == INTEGER) { INT wi = S_B_OI(bruch); freeself_bruch(bruch); M_I_I(wi,bruch); } else /* LONGINT */ { OP d; d = CALLOCOBJECT(); SWAP(S_B_O(bruch),d); erg += freeself_bruch(bruch); SWAP(d,bruch); FREEALL(d); } goto ende; } else if (S_B_UI(bruch) == -1) { if (S_O_K(S_B_O(bruch)) == INTEGER) { INT wi = S_B_OI(bruch); freeself_bruch(bruch); M_I_I(-wi,bruch); } else /* LONGINT */ { OP d; d = CALLOCOBJECT(); SWAP(S_B_O(bruch),d); erg += freeself_bruch(bruch); ADDINVERS_APPLY(d); SWAP(d,bruch); FREEALL(d); } goto ende; } if (NEGP(S_B_O(bruch)) && NEGP(S_B_U(bruch))) { ADDINVERS_APPLY(S_B_O(bruch)); ADDINVERS_APPLY(S_B_U(bruch)); } C_B_I(bruch,GEKUERZT); ende: ENDR("kuerzen_longint_longint"); } INT kuerzen_integral(bruch) OP bruch; /* AK 050789 V1.0 */ /* AK 061289 V1.1 */ /* AK 100791 V1.3 */ /* bruch is a BRUCH object with oben and unten both are integral, i.e. INTEGER or LONGINT */ { return kuerzen(bruch); } INT m_scalar_bruch(a,b) OP a,b; /* AK 210387 macht aus scalar bruch */ /* die integerzahl 5 wird z.B. 5/1 */ /* AK 050789 V1.0 */ /* AK 040590 V1.1 */ /* AK 050789 V1.0 */ /* AK 061289 V1.1 */ /* AK 100791 V1.3 */ { return m_ou_b(a,cons_eins,b); } #define MAS_B_CO(b)\ if (S_O_K(S_B_U(b)) == INTEGER)\ if (S_B_UI(b) == (INT)1)\ {\ c = CALLOCOBJECT();\ SWAP(S_B_O(b),c);\ FREESELF(b);\ SWAP(c,b);\ FREEALL(c);\ }\ else if (S_B_UI(b) == (INT)-1)\ {\ c = CALLOCOBJECT();\ SWAP(S_B_O(b),c);\ FREESELF(b);\ SWAP(c,b);\ FREEALL(c);\ ADDINVERS_APPLY(b);\ } INT mult_apply_scalar_bruch(a,b) OP a,b; /* AK 150290 V1.1 */ /* AK 100791 V1.3 */ { INT erg = OK; OP c; CTO(BRUCH,"mult_apply_scalar_bruch(2)",b); c = CALLOCOBJECT(); erg += ggt(a,S_B_U(b),c); GANZDIV_APPLY(S_B_U(b),c); erg += ganzdiv(a,c,c); erg += mult_apply(c,S_B_O(b)); FREEALL(c); MAS_B_CO(b); /* check on 1 in denominator */ /* ist bereits gekuerzt */ ENDR("mult_apply_scalar_bruch"); } INT mult_apply_integer_bruch(a,b) OP a,b; /* AK 251001 */ { INT erg = OK; OP c,d; CTO(INTEGER,"mult_apply_integer_bruch(1)",a); CTO(BRUCH,"mult_apply_integer_bruch(2)",b); if (INTEGRALP(S_B_O(b)) && INTEGRALP(S_B_U(b))) { c = CALLOCOBJECT(); GGT_INTEGER(a,S_B_U(b),c); GANZDIV_APPLY(S_B_U(b),c); d = CALLOCOBJECT(); GANZDIV(a,c,d); MULT_APPLY_INTEGER(d,S_B_O(b)); FREEALL(c); FREEALL(d); MAS_B_CO(b); /* check on 1 in denominator */ /* ist bereits gekuerzt */ goto ende; } /* nominator or denominator is not integer */ /* AK 060502 */ MULT_APPLY_INTEGER(a,S_B_O(b)); erg += kuerzen(b); ende: ENDR("mult_apply_integer_bruch"); } INT mult_apply_longint_bruch(a,b) OP a,b; /* AK 291001 */ { INT erg = OK; OP c,d; CTO(LONGINT,"mult_apply_longint_bruch(1)",a); CTO(BRUCH,"mult_apply_longint_bruch(2)",b); c = CALLOCOBJECT(); GGT_LONGINT(a,S_B_U(b),c); GANZDIV_APPLY(S_B_U(b),c); d = CALLOCOBJECT(); GANZDIV(a,c,d); MULT_APPLY(d,S_B_O(b)); FREEALL(c); FREEALL(d); MAS_B_CO(b); /* check on 1 in denominator */ /* ist bereits gekuerzt */ ENDR("mult_apply_longint_bruch"); } INT mult_apply_bruch_integer(a,b) OP a,b; /* AK 251001 */ { INT erg = OK; OP c,d; CTO(BRUCH,"mult_apply_bruch_integer(1)",a); CTO(INTEGER,"mult_apply_bruch_integer(2)",b); if (NULLP_INTEGER(b)) goto ae; c = CALLOCOBJECT(); GGT_INTEGER(b,S_B_U(a),c); CTO(INTEGER,"mult_apply_bruch_integer:internal",c); if (EQ_INTEGER(c,S_B_U(a))) { M_I_I(S_I_I(b)/S_I_I(c),b); FREEALL(c); MULT_APPLY(S_B_O(a),b); goto ae; } d = CALLOCOBJECT(); B_OU_B(CALLOCOBJECT(),CALLOCOBJECT(),d); GANZDIV(S_B_U(a),c,S_B_U(d)); M_I_I(S_I_I(b)/S_I_I(c),c); MULT_INTEGER(c,S_B_O(a),S_B_O(d)); if (NEGP(S_B_O(d)) && NEGP(S_B_U(d))) { ADDINVERS_APPLY(S_B_O(d)); ADDINVERS_APPLY(S_B_U(d)); } C_B_I(d,GEKUERZT); FREEALL(c); SWAP(d,b); FREEALL(d); C_B_I(b,GEKUERZT); /* ist bereits gekuerzt */ ae: ENDR("mult_apply_bruch_integer"); } INT mult_apply_bruch_longint(a,b) OP a,b; /* AK 251001 */ { INT erg = OK; OP c,d; CTO(BRUCH,"mult_apply_bruch_longint(1)",a); CTO(LONGINT,"mult_apply_bruch_longint(2)",b); c = CALLOCOBJECT(); GGT_LONGINT(b,S_B_U(a),c); if (EQ(c,S_B_U(a))) { GANZDIV_APPLY(b,c); FREEALL(c); MULT_APPLY(S_B_O(a),b); goto ende; } d = CALLOCOBJECT(); B_OU_B(CALLOCOBJECT(),CALLOCOBJECT(),d); GANZDIV(S_B_U(a),c,S_B_U(d)); ganzdiv(b,c,c); /* AK 121201 */ MULT(c,S_B_O(a),S_B_O(d)); FREEALL(c); SWAP(d,b); FREEALL(d); /* ist bereits gekuerzt */ C_B_I(b,GEKUERZT); if (NEGP(S_B_O(b)) && NEGP(S_B_U(b))) { ADDINVERS_APPLY(S_B_O(b)); ADDINVERS_APPLY(S_B_U(b)); } ende: ENDR("mult_apply_bruch_longint"); } INT mult_apply_bruch_bruch(a,b) OP a,b; /* AK 281001 */ { INT erg = OK; OP c,d; CTO(BRUCH,"mult_apply_bruch_bruch(1)",a); CTO(BRUCH,"mult_apply_bruch_bruch(2)",b); c = CALLOCOBJECT(); d = CALLOCOBJECT(); GGT(S_B_O(a),S_B_U(b),c); GANZDIV(S_B_O(a),c,d); GANZDIV_APPLY(S_B_U(b),c); FREESELF(c); GGT(S_B_O(b),S_B_U(a),c); GANZDIV_APPLY(S_B_O(b),c); MULT_APPLY(d,S_B_O(b)); FREESELF(d); GANZDIV(S_B_U(a),c,d); MULT_APPLY(d,S_B_U(b)); if (EINSP(S_B_U(b))) { SWAP(S_B_O(b),c); FREESELF(b); SWAP(c,b); } else if (NEGEINSP(S_B_U(b))) { SWAP(S_B_O(b),c); FREESELF(b); ADDINVERS_APPLY(c); SWAP(c,b); } FREEALL(c); FREEALL(d); CTO(ANYTYPE,"mult_apply_bruch_bruch(e2)",b); ENDR("mult_apply_bruch_bruch"); } INT mult_apply_bruch_scalar(a,b) OP a,b; /* AK 140290 V1.1 */ /* AK 200891 V1.3 */ /* b = b*a */ { INT erg = OK; OP c; CTO(BRUCH,"mult_apply_bruch_scalar",a); c = callocobject(); *c = *b; C_O_K(b,EMPTY); erg += copy_bruch(a,b); erg += mult_apply_scalar_bruch(c,b); /* hat kuerzen */ erg += freeall(c); ENDR("mult_apply_bruch_scalar"); } INT add_apply_bruch_bruch_pre261101(a,b) OP a,b; /* b = b + a */ /* AK 220390 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OP c; CTO(BRUCH,"add_apply_bruch_bruch(1)",a); CTO(BRUCH,"add_apply_bruch_bruch(2)",b); SYMCHECK((S_B_I(a) != GEKUERZT),"add_apply_bruch_bruch:(1) not reduced"); SYMCHECK((S_B_I(b) != GEKUERZT),"add_apply_bruch_bruch:(2) not reduced"); c = CALLOCOBJECT(); MULT(S_B_O(a),S_B_U(b),c); MULT_APPLY(S_B_U(a), S_B_U(b)); MULT_APPLY(S_B_U(a), S_B_O(b)); ADD_APPLY(c,S_B_O(b)); FREEALL(c); if (NULLP(S_B_O(b)) ) { FREESELF(b); M_I_I(0,b); } else { C_B_I(b,NGEKUERZT); KUERZEN(b); } ENDR("add_apply_bruch_bruch"); } INT add_apply_bruch_bruch(a,b) OP a,b; /* b = b + a */ /* AK 220390 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OP c,d,e; CTO(BRUCH,"add_apply_bruch_bruch(1)",a); CTO(BRUCH,"add_apply_bruch_bruch(2)",b); if (S_B_I(a) != GEKUERZT) goto safe; if (S_B_I(b) != GEKUERZT) goto safe; /* SYMCHECK((S_B_I(a) != GEKUERZT),"add_apply_bruch_bruch:(1) not reduced"); SYMCHECK((S_B_I(b) != GEKUERZT),"add_apply_bruch_bruch:(2) not reduced"); */ if (INTEGRALP(S_B_O(a)) && INTEGRALP(S_B_U(a)) && INTEGRALP(S_B_O(b)) && INTEGRALP(S_B_U(b)) ) { c = CALLOCOBJECT(); GGT(S_B_U(a), S_B_U(b), c); if (not EINSP(c)) { d = CALLOCOBJECT(); GANZDIV(S_B_U(a),c,d); /* damit wir der bruch b erweitert */ e = CALLOCOBJECT(); GANZDIV(S_B_U(b),c,e); /* dmit wird der bruch a erweitert */ MULT_APPLY(d,S_B_U(b)); MULT_APPLY(d,S_B_O(b)); FREESELF(c); MULT(S_B_O(a),e,c); ADD_APPLY(c,S_B_O(b)); FREEALL(d); FREEALL(e); } else { FREESELF(c); MULT(S_B_O(a),S_B_U(b),c); MULT_APPLY(S_B_U(a),S_B_O(b)); ADD_APPLY(c,S_B_O(b)); MULT_APPLY(S_B_U(a),S_B_U(b)); } FREEALL(c); if (NULLP(S_B_O(b)) ) { FREESELF(b); M_I_I(0,b); } else { C_B_I(b,NGEKUERZT); KUERZEN(b); } goto ende; } /* nominator or denominator not integer */ /* AK 060502 */ safe: c = CALLOCOBJECT(); SWAP(c,b); erg += add_bruch_bruch(a,c,b); FREEALL(c); ende: ENDR("add_apply_bruch_bruch"); } INT add_apply_bruch_scalar(a,b) OP a,b; /* AK 220390 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OP c; CTO(BRUCH,"add_apply_bruch_scalar(1)",a); c = CALLOCOBJECT(); *c = *b; C_O_K(b,EMPTY); erg += add_bruch_scalar(a,c,b); FREEALL(c); ENDR("add_apply_bruch_scalar"); } INT add_apply_bruch_integer(a,b) OP a,b; /* AK 251001 */ { INT erg = OK; OP c; CTO(BRUCH,"add_apply_bruch_integer(1)",a); CTO(INTEGER,"add_apply_bruch_integer(2)",b); c = CALLOCOBJECT(); MULT_INTEGER(b,S_B_U(a),c); C_O_K(b,EMPTY); B_OU_B(CALLOCOBJECT(),CALLOCOBJECT(),b); ADD(c,S_B_O(a),S_B_O(b)); FREEALL(c); COPY(S_B_U(a),S_B_U(b)); KUERZEN(b); ENDR("add_apply_bruch_integer"); } INT add_apply_scalar_bruch(a,b) OP a,b; /* AK 220390 V1.1 */ /* AK 050791 V1.3 */ { OP c; INT erg = OK; c = CALLOCOBJECT(); *c = *b; C_O_K(b,EMPTY); erg += add_bruch_scalar(c,a,b); FREEALL(c); ENDR("add_apply_scalar_bruch"); } INT add_apply_integer_bruch(a,b) OP a,b; /* AK 251001 */ /* not yet optimal, better with ggt */ { OP c; INT erg = OK; CTO(INTEGER,"add_apply_integer_bruch(1)",a); CTO(BRUCH,"add_apply_integer_bruch(2)",b); c = CALLOCOBJECT(); MULT_INTEGER(a,S_B_U(b),c); ADD_APPLY(c,S_B_O(b)); FREEALL(c); C_B_I(b,NGEKUERZT); KUERZEN(b); ENDR("add_apply_integer_bruch"); } INT add_apply_bruch(a,b) OP a,b; /* AK 220390 V1.1 */ /* AK 190291 V1.2 */ /* AK 050791 V1.3 */ /* a is bruch */ { INT erg = OK; CTO(BRUCH,"add_apply_bruch(1)",a); switch (S_O_K(b)) { case BRUCH: erg += add_apply_bruch_bruch(a,b); /* hat kuerzen */ break; case LONGINT: erg += add_apply_bruch_scalar(a,b); /* hat kuerzen */ break; case INTEGER: erg += add_apply_bruch_integer(a,b); /* hat kuerzen */ break; default: { OP c = callocobject(); *c = *b; C_O_K(b,EMPTY); erg += add_bruch(a,c,b); /* hat kuerzen */ erg += freeall(c); break; } } ENDR("add_apply_bruch"); } INT mult_apply_bruch(a,b) OP a,b; /* a is BRUCHobject */ /* AK 140290 V1.1 */ /* AK 190291 V1.2 */ /* AK 200891 V1.3 */ { OP c; INT erg=OK; CTO(BRUCH,"mult_apply_bruch(1)",a); /*CC 260696*/ if(bruch_not_scalar(a)) { erg += mult_apply(S_B_O(a),b); c=callocobject(); erg += copy(b,c); erg += m_ou_b(c,S_B_U(a),b); erg += kuerzen(b); erg += freeall(c); goto endr_ende; } switch (S_O_K(b)) { case BRUCH: erg += mult_apply(S_B_O(a),S_B_O(b)); erg += mult_apply(S_B_U(a),S_B_U(b)); C_B_I(b,NGEKUERZT); erg += kuerzen(b); break; case INTEGER: erg+= mult_apply_bruch_integer(a,b); break; case LONGINT: erg+= mult_apply_bruch_longint(a,b); break; #ifdef MATRIXTRUE case KRANZTYPUS : case MATRIX: erg += mult_apply_scalar_matrix(a,b); break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += mult_apply_bruch_monom(a,b); break; #endif /* MONOMTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += mult_apply_scalar_symchar(a,b); break; #endif /* CHARTRUE */ #ifdef POLYTRUE case SCHUR: case POW_SYM: case ELM_SYM: case HOM_SYM: case MONOMIAL: case SCHUBERT: case GRAL: case MONOPOLY: case POLYNOM: erg += mult_apply_bruch_polynom(a,b); break; #endif /* POLYTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: erg += mult_apply_scalar_sqrad(a,b); break; case CYCLOTOMIC: erg += mult_apply_scalar_cyclo(a,b); break; #endif /* NUMBERTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case COMPOSITION: case WORD: case VECTOR: erg += mult_apply_scalar_vector(a,b); break; case HASHTABLE: erg += mult_apply_bruch_hashtable(a,b); break; #endif /* VECTORTRUE */ default: c = callocobject(); erg+=mult(a,b,c); erg+=freeself(b); *b = *c; C_O_K(c,EMPTY); erg += freeall(c); } ENDR("mult_apply_bruch"); } #endif /* BRUCHTRUE */ #ifdef BRUCHTRUE INT mult_bruch(a,b,c) OP a,b,c; /* AK 050789 V1.0 */ /* AK 140290 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"mult_bruch(1)",a); CTO(EMPTY,"mult_bruch(3)",c); switch( S_O_K(b)) { case BRUCH: erg += mult_bruch_bruch(a,b,c); break; #ifdef LONGINTTRUE case LONGINT: erg += mult_bruch_longint(a,b,c); break; #endif /* LONGINTTRUE */ #ifdef INTEGERTRUE case INTEGER: erg += mult_bruch_integer(a,b,c); break; #endif /* INTEGERTRUE */ #ifdef MATRIXTRUE case MATRIX: erg += mult_scalar_matrix(a,b,c); break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += mult_scalar_monom(a,b,c); break; #endif /* MONOMTRUE */ case LAURENT: erg += copy(a,c); erg += mult(b,S_B_O(c), S_B_O(c)); break; #ifdef POLYTRUE case POLYNOM: if ( (has_one_variable(b)) && ((!scalarp(S_B_O(a))) ||(!scalarp(S_B_U(a)))) ) { OP tp2; tp2=callocobject(); erg += m_ou_b(b,cons_eins,tp2); erg += mult_bruch_bruch(a,tp2,c); erg += freeall(tp2); } else erg += mult_scalar_polynom(a,b,c); goto ende; case GRAL: erg += mult_scalar_gral(a,b,c); goto ende; #ifdef SCHUBERTTRUE case SCHUBERT: erg += mult_scalar_schubert(a,b,c); goto ende; #endif #endif /* POLYTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += mult_scalar_sqrad(a,b,c); goto ende; #endif /* SQRADTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += mult_scalar_cyclo(a,b,c); goto ende; #endif /* CYCLOTRUE */ #ifdef SCHURTRUE case ELM_SYM: erg += mult_elmsym_scalar(b,a,c); goto ende; case HOM_SYM: erg += mult_homsym_scalar(b,a,c); goto ende; case POW_SYM: erg += mult_powsym_scalar(b,a,c); goto ende; case MONOMIAL: erg += mult_monomial_scalar(b,a,c); goto ende; case SCHUR: erg += mult_schur_scalar(b,a,c); goto ende; #endif /* SCHURTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += mult_scalar_symchar(a,b,c); goto ende; #endif /* CHARTRUE */ #ifdef VECTORTRUE case VECTOR: erg += mult_scalar_vector(a,b,c); break; #endif /* VECTORTRUE */ default: WTO("mult_bruch(2)",b); goto ende; }; ende: ENDR("mult_bruch"); } INT test_bruch() /* AK 150290 V1.1 */ /* AK 200891 V1.3 */ { OP a= callocobject(); OP b= callocobject(); OP c= callocobject(); printf("test_bruch:scan(a) "); scan(BRUCH,a); println(a); printf("test_bruch:scan(b) "); scan(BRUCH,b); println(b); printf("test_bruch:posp(a) "); if (posp(a)) { printf(" a ist positiv\n"); } else { printf(" a ist nicht positiv\n"); } printf("test_bruch:einsp(a) "); if (einsp(a)) { printf(" a ist eins\n"); } else { printf(" a ist nicht eins\n"); } printf("test_bruch:add(a,b,c) "); add(a,b,c); println(c); printf("test_bruch:mult(a,b,c) "); mult(a,b,c); println(c); printf("test_bruch:kuerzen(c) "); kuerzen(c); println(c); freeall(a); freeall(b); freeall(c); return(OK); } INT objectwrite_bruch(f,a) FILE *f; OP a; /* AK 200690 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(BRUCH,"objectwrite_bruch(2)",a); fprintf(f,"%ld\n", (INT)BRUCH); erg += objectwrite(f,S_B_O(a)); erg += objectwrite(f,S_B_U(a)); ENDR("objectwrite_bruch"); } INT objectread_bruch(f,a) FILE *f; OP a; /* AK 200690 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; COP("objectread_bruch(1)",f); erg += b_ou_b(callocobject(),callocobject(),a); erg += objectread(f,S_B_O(a)); erg += objectread(f,S_B_U(a)); CTO(BRUCH,"objectread_bruch(i)",a); erg += kuerzen(a); ENDR("objectread_bruch"); } INT cast_apply_bruch(a) OP a; /* AK 210294 */ { INT erg = OK; EOP("cast_apply_bruch(1)",a); switch S_O_K(a) { case BRUCH: break; case INTEGER: erg += m_ioiu_b(S_I_I(a), (INT) 1, a); break; case LONGINT: erg += m_ou_b(a,cons_eins,a); break; } CTO(BRUCH,"cast_apply_bruch(e1)",a); ENDR("cast_apply_bruch"); } #endif /* BRUCHTRUE */ /* Met dans dg le degre du monopoly mp */ INT dg_mp(mp,dg) OP mp,dg; { OP z,za=NULL; if(not EMPTYP(dg)) freeself(dg); z=mp; while(z !=NULL) { za=z; z=S_L_N(z); } copy(S_PO_S(za),dg); return(OK); } /* Met dans ld le coefficient du terme maximal du monopoly mp */ INT ldcf_mp(mp,ld) OP mp,ld; { OP z,za=NULL; if(not EMPTYP(ld)) freeself(ld); z=mp; while(z !=NULL) { za=z; z=S_L_N(z); } copy(S_PO_K(za),ld); return(OK); } INT t_POLYNOM_MONOPOLY(a,b) OP a,b; /* CC */ /* take only the first variable */ { OP z,hh; INT erg = OK; CTO(POLYNOM,"t_POLYNOM_MONOPOLY(1)",a); CE2(a,b,t_POLYNOM_MONOPOLY); init(MONOPOLY,b); if (not NULLP(a)) { z=a; while(z!=NULL) { hh=callocobject(); erg += m_sk_mo(S_V_I(S_PO_S(z),0L),S_PO_K(z),hh); insert(hh,b,add_koeff,NULL); z=S_PO_N(z); } } ENDR("t_POLYNOM_MONOPOLY"); } /* n est de type INTEGER po est de type POLYNOM ou MONOPOLY pg est le pgcd de n et des coefficients de po Retourne ERROR si le pgcd n'est pas definie */ INT gcd_int_po(n,po,pg) OP n,po,pg; { OP z,tmp,k; if(not EMPTYP(pg)) freeself(pg); z=po; if(NULLP(z)){ copy(n,pg);return(OK);} tmp=callocobject(); copy(n,tmp); while(z!=NULL) { k=S_PO_K(z); if(S_O_K(k)==BRUCH) krz(k); if(S_O_K(k)!=INTEGER) return ERROR; ggt(tmp,k,tmp); z=S_L_N(z); } copy(tmp,pg); freeall(tmp); return(OK); } /* Calcule le pgcd de a et b qui sont de type quelconque. Retourne ERROR si le pgcd de a et b n'existe pas */ INT pgcd(a,b,c) OP a,b,c; { OP aa,bb,nb; if(S_O_K(a)==BRUCH) krz(a); if(S_O_K(b)==BRUCH) krz(b); if((S_O_K(a)==BRUCH)||(S_O_K(b)==BRUCH)) return ERROR; if((S_O_K(a)==INTEGER)&&(S_O_K(b)==INTEGER)) { ggt(a,b,c);return(OK); } if(NULLP(a)) { if(has_one_variable(b)==TRUE) { copy(b,c);return(OK); } else return ERROR; } if(NULLP(b)) { if(has_one_variable(a)==TRUE) { copy(a,c);return(OK); } else return ERROR; } if(scalarp(a)) { copy(a,c); return(OK); } if(scalarp(b)) { copy(b,c); return(OK); } if(S_O_K(a)==POLYNOM) { nb=callocobject(); numberofvariables(a,nb); if(S_I_I(nb)>1L) { freeall(nb); return(ERROR); } else { freeall(nb); aa=callocobject(); t_POLYNOM_MONOPOLY(a,aa); } } else { aa=callocobject(); copy(a,aa); } if(S_O_K(b)==POLYNOM) { nb=callocobject(); numberofvariables(b,nb); if(S_I_I(nb)>1L) { freeall(nb); return(ERROR); } else { freeall(nb); bb=callocobject(); t_POLYNOM_MONOPOLY(b,bb); } } else { bb=callocobject(); copy(b,bb); } ggt_mp(aa,bb,c); freeall(aa);freeall(bb); return OK; } /* Lance le pgcd de 2 polynomes non nuls de type MONOPOLY Computes the gcd of 2 MONOPOLY objects */ static INT ggt_mp(a,b,c) OP a,b,c; { OP dg1,dg2; INT dgi1,dgi2; dg1=callocobject();dg2=callocobject(); dg_mp(a,dg1); dg_mp(b,dg2); dgi1=S_I_I(dg1); dgi2=S_I_I(dg2); if(dgi1==0) copy(a,c); else if(dgi2==0) copy(b,c); else if(dgi1>dgi2) gcd_mp(a,b,c); else gcd_mp(b,a,c); freeall(dg1);freeall(dg2); return(OK); } /* Calcule le pgcd de 2 polynomes de type MONOPOLY a et b degre(a)>degre(b)>0 Algo d'Euclide non optimise */ INT gcd_mp_lent(a,b,c) OP a,b,c; { OP aa,bb,qp,rp; aa=callocobject(); qp=callocobject(); rp=callocobject(); bb=callocobject(); copy(a,aa);copy(b,bb); while(1) { quores_monopoly(aa,bb,qp,rp); if(nullp_monopoly(rp)) break; copy(bb,aa); copy(rp,bb); } copy(bb,c); freeall(bb);freeall(aa); return OK; } /* Calcule le pgcd de 2 polynomes de type MONOPOLY a et b degre(a)>degre(b)>0 */ INT gcd_mp(a,b,c) OP a,b,c; { OP av,nv,ld,dlt,tp,aa,bb,qp,rp; INT avi,nvi,dlti; INT erg = OK; CTO(MONOPOLY,"gcd_mp(1)",a); CTO(MONOPOLY,"gcd_mp(2)",b); tp=callocobject(); aa=callocobject(); bb=callocobject(); av=callocobject(); nv=callocobject(); ld=callocobject(); dlt=callocobject(); qp=callocobject(); rp=callocobject(); dg_mp(a,av);avi=S_I_I(av); dg_mp(b,nv);nvi=S_I_I(nv); copy(a,aa);copy(b,bb); while(nvi>0) { dlti=avi-nvi+1; M_I_I(dlti,dlt); ldcf_mp(b,ld); hoch(ld,dlt,tp); MULT_APPLY(tp,aa); FREESELF(qp); FREESELF(rp); quores_monopoly(aa,bb,qp,rp); if(nullp_monopoly(rp)) break; else { copy(bb,aa); copy(rp,bb); avi=nvi; dg_mp(bb,nv); nvi=S_I_I(nv); } } copy(bb,c); freeall(tp); freeall(aa); freeall(ld); freeall(dlt); freeall(bb); freeall(av); freeall(nv); freeall(qp); /* AK 130297 */ freeall(rp); /* AK 130297 */ ENDR("gcd_mp"); } /* mp est de type MONOPOLY. Renvoie TRUE si mp est une constante FALSE sinon */ INT mp_is_cst(mp) OP mp; { OP z; INT i,boo; z=mp;i=0L;boo=0L; while(z!=NULL) { if(i > 0L) return FALSE; if(S_I_I(S_PO_S(z))==0L) boo=1L; z=S_L_N(z); i++; } if(boo==1L) return TRUE; else return FALSE; } /*Simplifie fc3 renvoie ERROR si fc3 est une fraction rationnelle avec 0 au denominateur */ INT bruch_not_scalar(a) OP a; /* Returns 1 if a is built with MONOPOLY or POLYNOM object. Returns 0 if not. */ { INT tp1,tp2; if(S_O_K(S_B_O(a))==MONOPOLY || S_O_K(S_B_O(a))==POLYNOM ||S_O_K(S_B_U(a))==MONOPOLY || S_O_K(S_B_U(a))==POLYNOM) return 1; tp1=tp2=0L; if( (S_O_K(S_B_O(a))==BRUCH && bruch_not_scalar(S_B_O(a))) || (S_O_K(S_B_U(a))==BRUCH && bruch_not_scalar(S_B_U(a))) ) return 1; return 0; } /* ma0 est une matrice de polynomes, fractions rationnelles, entiers... Transforme les types MONOPOLY de ma0 en type POLYNOM dans ma */ INT t_MA_MONOPOLY_MA_POLYNOM(ma0,ma) OP ma0, ma; { INT i,j; OP tp,ttp1,tp1,ttp2,tp2; m_ilih_m(S_M_LI(ma0),S_M_HI(ma0),ma); for(i=0L;i #include "def.h" #include "macro.h" static INT gl_generate(); static INT sp_generate (); static INT or_generate (); static INT pn_generate (); /************************************************************************* Routines to calculate dimensions of the classical groups *************************************************************************/ INT gl_dimension (n,partition,dim) OP n; OP partition; OP dim; /* general linear group */ { INT i,j,no_rows,no_cols; INT erg = OK; OP part,conj; OP top,bot,nc,nob,hook; if (partition==NULL || s_o_k(partition)!=PARTITION || n==NULL || !(s_o_k(n)==INTEGER || s_o_k(n)==LONGINT) ) { printf("gl_dimension() did not receive the correct objects!\n"); m_i_i(0L,dim); return(ERROR); } no_rows=s_pa_li(partition); if (!no_rows) { m_i_i(1L,dim); return(OK); } no_cols=s_pa_ii(partition,no_rows-1); if (no_rows > s_i_i(n)) { printf("The partition passed to gl_dimension() has tooo many parts!\n"); m_i_i(0L,dim); return(ERROR); } /* put the parts in decreasing order and construct the conjugate */ m_il_v(no_rows,part=callocobject()); m_il_v(no_cols,conj=callocobject()); for (i=0;i=0;j--) { while (ij) i++; m_i_i(i,s_v_i(conj,j)); } /* initialise a few things for the hook length calculation */ m_i_i(1L,top=callocobject()); m_i_i(1L,bot=callocobject()); m_i_i(0L,hook=callocobject()); nob=callocobject(); copy(n,nc=callocobject()); /* visit all the boxes of Young diagram, accumulating hook length factors and numerator factors */ for (i=0;i s_i_i(r)+(nullp(res)?0:1) ) /* allow one extra part for odd dimensions! */ { printf("The partition passed to sp_dimension() has tooo many parts!\n"); m_i_i(0L,dim); return(ERROR); } if (!nullp(res)) { printf("Warning! sp_dimension received odd group specification!\n"); } freeall(r); freeall(res); /* put the parts in decreasing order and construct the conjugate: we need to make them longer with enough zeros. */ square=no_rows>no_cols?no_rows:no_cols; m_il_v(square,part=callocobject()); m_il_v(square,conj=callocobject()); for (i=0;i=no_cols;j--) m_i_i(0,s_v_i(conj,j)); for (i=1;j>=0;j--) { while (ij) i++; m_i_i(i,s_v_i(conj,j)); } /* initialise a few things for the hook length calculation */ m_i_i(1L,top=callocobject()); m_i_i(1L,bot=callocobject()); m_i_i(0L,hook=callocobject()); nob=callocobject(); /* visit all the boxes of Young diagram, accumulating hook length factors and numerator factors */ for (i=0;i1)) ) { printf("The partition passed to or_dimension() has tooo many parts!\n"); m_i_i(0L,dim); return(ERROR); } /* put the parts in decreasing order and construct the conjugate: we need to make them longer with enough zeros. */ if (s_o_k(dum)!=INTEGER || bal>no_rows) bal=no_rows; square=bal>no_cols?bal:no_cols; m_il_v(square,part=callocobject()); m_il_v(square,conj=callocobject()); for (i=0;i=no_cols;j--) m_i_i(0,s_v_i(conj,j)); for (i=1;j>=0;j--) { while (ij) i++; m_i_i(i,s_v_i(conj,j)); } /* initialise a few things for the hook length calculation */ m_i_i(1L,top=callocobject()); m_i_i(1L,bot=callocobject()); m_i_i(0L,hook=callocobject()); nob=callocobject(); /* visit all the boxes of Young diagram, accumulating hook length factors and numerator factors */ for (i=0;ino_rows) bal=no_rows; square=bal>no_cols?bal:no_cols; m_il_v(square,part=callocobject()); m_il_v(square,conj=callocobject()); for (i=0;i=no_cols;j--) m_i_i(0,s_v_i(conj,j)); for (i=1;j>=0;j--) { while (ij) i++; m_i_i(i,s_v_i(conj,j)); } /* initialise a few things for the hook length calculation */ m_i_i(1L,top=callocobject()); m_i_i(1L,bot=callocobject()); m_i_i(0L,hook=callocobject()); nob=callocobject(); copy(n,nm=callocobject()); dec(nm); /* visit all the boxes of Young diagram, accumulating hook length factors and numerator factors. for spin cases, use symplectic formula! */ for (i=0;i s_i_i(n)) { printf("The partition passed to gl_tableaux() has tooo many parts!\n"); init(LIST,list); return(ERROR); } /* put the parts in decreasing order: append a zero part */ part=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); filling=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); for (i=0;i=un_part[row+1];j--) { /* start with 0 of entry in the current row - up to up_part[row+1]-up_part[row] */ if (j0) gl_generate(new_tab,un_part,filling,entry,row-1); else /* start putting in a different entry: must update the unfilled bit */ { /* find lowest unfilled row */ for (i=no_rows-1;filling[i]==0;i--); if (i>=0) { new_fill=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); gl_generate(new_tab,filling,new_fill,entry-1,i); SYM_free(new_fill); } else /* tableau is full: need to store it. */ { b_sn_l(new_tab,standard,ext=callocobject()); standard=ext; count++; return(OK); } } } freeall(new_tab); } return(OK); } INT sp_tableaux (n,partition,list) OP n; OP partition; OP list; /* generates standard tableaux for the symplectic group Sp(n) */ { INT i; INT *filling; OP empty_tab; if (partition==NULL || s_o_k(partition)!=PARTITION || n==NULL || !(s_o_k(n)==INTEGER || s_o_k(n)==LONGINT) ) { printf("sp_tableaux() did not receive the correct objects!\n"); init(LIST,list); return(ERROR); } ni=s_i_i(n); ri=ni/2; no_rows=s_pa_li(partition); if (!no_rows) /* If the partition is 0, then create a single 1x1 tableau with entry 0. */ { OP vec,par,tab; m_il_v(1L,vec=callocobject()); m_i_i(1L,s_v_i(vec,0L)); b_ks_pa(VECTOR,vec,par=callocobject()); m_u_t(par,tab=callocobject()); m_i_i(0L,s_t_ij(tab,0L,0L)); b_sn_l(tab,NULL,list); freeall(par); return(1L); } if (no_rows > ri+(ni&1)) /* allow one extra part for odd dimensions! */ { printf("The partition passed to sp_tableaux() has tooo many parts!\n"); init(LIST,list); return(ERROR); } if (ni&1) { printf("Warning! sp_tableaux received odd group specification!\n"); } /* put the parts in decreasing order: append a zero part */ part=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); filling=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); for (i=0;i=un_part[row+1];j--) { /* start with 0 of entry in the current row - up to up_part[row+1]-up_part[row] */ if (j0) sp_generate(new_tab,un_part,filling,entry,row-1); else /* start putting in a different entry: must update the unfilled bit */ { /* find lowest unfilled row */ for (i=no_rows-1;filling[i]==0;i--); if (i>=0) { new_fill=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); if (entry>0) sp_generate(new_tab,filling,new_fill,-entry,i); else if (entry<0) sp_generate(new_tab,filling,new_fill,-entry-1,i); else sp_generate(new_tab,filling,new_fill,ri,i); SYM_free(new_fill); } else /* tableau is full: need to store it. */ { b_sn_l(new_tab,standard,ext=callocobject()); standard=ext; count++; return(OK); } } } freeall(new_tab); } return(OK); } INT or_tableaux (n,partition,list) OP n; OP partition; OP list; /* generates standard tableaux for the orthogonal group O(n) */ { INT i; INT *filling; OP empty_tab; if (partition==NULL || s_o_k(partition)!=PARTITION || n==NULL || s_o_k(n)!=INTEGER ) { printf("or_tableaux() did not receive the correct objects!\n"); init(LIST,list); return(ERROR); } ni=s_i_i(n); ri=ni/2; no_rows=s_pa_li(partition); if (!no_rows) /* If the partition is 0, then create a single 1x1 tableau with entry 0. */ { OP vec,par,tab; m_il_v(1L,vec=callocobject()); m_i_i(1L,s_v_i(vec,0L)); b_ks_pa(VECTOR,vec,par=callocobject()); m_u_t(par,tab=callocobject()); m_i_i(0L,s_t_ij(tab,0L,0L)); b_sn_l(tab,NULL,list); freeall(par); return(1L); } if (ni1) ) { printf("The partition passed to or_tableaux() has tooo many parts!\n"); init(LIST,list); return(ERROR); } /* put the parts in decreasing order: append a zero part */ part=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); filling=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); for (i=0;i=0 && part[i]<2;i--); /* start the recursive tableaux generation process - if n is even then the first entrys are 0. Otherwise ri. */ m_u_t(partition,empty_tab=callocobject()); standard=NULL; count=level=0; or_generate(empty_tab,part,filling,ni&1?0:ri,no_rows-1,no_rows,++i); /* put the tableaux list into the argument to this routine */ if (standard==NULL) init(LIST,list); else { b_ks_o(s_o_k(standard),s_o_s(standard),list); SYM_free(standard); } freeall(empty_tab); SYM_free(part); SYM_free(filling); return(count); } static INT or_generate (skew_tab, un_part, filling, entry, row, alpha, beta) OP skew_tab; INT *un_part; INT *filling; INT entry; INT row; INT alpha; INT beta; /* recursive function to generate standard tableaux for the orthogonal group O(n). skew_tab is a partially filled tableaux. One iteration of this function puts a number of _entry into the row _row. un_part gives the shape of the unfilled part of the tableau before ANY _entry was placed. filling is the changed unfilled part after _entry s are included, but only for rows below that currently being considered. */ { INT j,j_start; INT *new_fill; OP new_tab,new_part,ext; copy_tableaux(skew_tab,new_tab=callocobject()); /* if we are entering a 1 or -1 then we need special consideration */ if (entry==1) { /* first fill the top row with -1 */ for (j=0;j=beta */ { if (alpha+beta==-2*entry || (alpha+beta==-1-2*entry && (beta==0 || (alpha0 && filling[alpha]==0 && un_part[alpha]0) { if (row==alpha-1 && beta==0 && alpha==2*entry) j_start=0; } else if (alpha+beta==ni) /* here entry is 0 and ni is odd */ { if (row==alpha-1 && beta==0) j_start=0; else if (row==beta-1) j_start=1; } /* now place the entries that are forced */ for (j=j_start;j0) alpha--; if (j_start<=1 && un_part[row]>1) beta--; /* now loop between 0 and as many as possible in current row */ for (j=j_start;j>=un_part[row+1];j--) { if (j0) or_generate(new_tab,un_part,filling,entry,row-1,alpha,beta); else /* just done the top row */ { if (filling[row]==0) /* tableau is now full */ { b_sn_l(new_tab,standard,ext=callocobject()); standard=ext; count++; level--; return(OK); } else /* start putting in a different entry: must update the unfilled bit */ { new_fill=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); memcpy(new_fill,filling,(no_rows+1)*sizeof(INT)); if (entry>0) or_generate(new_tab,filling,new_fill,-entry, alpha-1,alpha,beta); else if (entry<0) or_generate(new_tab,filling,new_fill,-entry-1, alpha-1,alpha,beta); else or_generate(new_tab,filling,new_fill,ri, alpha-1,alpha,beta); SYM_free(new_fill); } } } freeall(new_tab); } level--; return(OK); } INT so_tableaux (n,partition,flag,list) INT flag;OP n; OP partition; OP list; /* generates standard tableaux for the special orthogonal group SO(n). First generates tableaux for O(n) and if relevant (n even AND no. parts equal to n/2) extracts the required tableaux from this set. flag=-1 selects the - representation and if +1 selects the + representation. */ { INT i,e,c,f,count; OP trawl,back; if (partition==NULL || s_o_k(partition)!=PARTITION || n==NULL || s_o_k(n)!=INTEGER ) { printf("so_tableaux() did not receive the correct objects!\n"); init(LIST,list); return(ERROR); } no_rows=s_pa_li(partition); ni=s_i_i(n); ri=ni/2; if (ri0) f=0; else /* undocumented option! */ f=(ri&1)?1:0; for (trawl=list,back=NULL;trawl!=NULL;) { for (i=c=0;i=-i && e<=i) ) /* entry tooo small here */ { if (back!=NULL) { c_l_n(back,s_l_n(trawl)); c_l_n(trawl,NULL); freeall(trawl); trawl=s_l_n(back); } else /* at top of list */ { trawl=s_l_n(trawl); c_l_n(list,NULL); freeself(list); b_ks_o(LIST,s_o_s(trawl),list); SYM_free(trawl); trawl=list; } } else { trawl=s_l_n(back=trawl); count++; } } } return(count); } INT pn_tableaux (n,partition,list) OP n; OP partition; OP list; /* generates standard spin tableaux for the spin orthogonal group O(n) */ { INT i; INT *filling; OP empty_tab,r,hafling; if (partition==NULL || s_o_k(partition)!=PARTITION || n==NULL || s_o_k(n)!=INTEGER ) { printf("or_tableaux() did not receive the correct objects!\n"); init(LIST,list); return(ERROR); } ni=s_i_i(n); ri=ni/2; no_rows=s_pa_li(partition); if (ri=0 && s_t_iji(spin,i,0)>0;i--); if (i>=0) { c_i_i(s_t_ij(spin,i,0),i+1); for (i++;i=0 && s_t_iji(spin,i,0)>0;i--); if (i>=0) { c_i_i(s_t_ij(spin,i,0),i+1); for (i++;i=un_part[row+1];j--) { if (j0) pn_generate(new_tab,un_part,filling,entry,row-1); else /* just done the top row */ { /* find lowest unfilled row */ for (i=no_rows-1;filling[i]==0;i--); if (i>=0) { new_fill=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); if (entry>0) pn_generate(new_tab,filling,new_fill,-entry,i); else if (entry<0) pn_generate(new_tab,filling,new_fill,-entry-1,i); else pn_generate(new_tab,filling,new_fill,ri,i); SYM_free(new_fill); } else /* tableau is full: need to store it. */ { copy_tableaux(spin,spin_cop=callocobject()); b_sk_mo(new_tab,spin_cop,mon=callocobject()); b_sn_l(mon,standard,ext=callocobject()); standard=ext; count++; return(OK); } } } freeall(new_tab); } level--; return(OK); } INT sn_tableaux ( n, partition, flag, list) OP n; OP partition; INT flag; OP list; /* generates standard spin tableaux for the spin orthogonal group SO(n). If relevant (n is even), flag=-1 selects the - representation and flag=+1 selects the + representation. */ { INT i,f; INT *filling; OP empty_tab,r,hafling; if (partition==NULL || s_o_k(partition)!=PARTITION || n==NULL || s_o_k(n)!=INTEGER ) { printf("sn_tableaux() did not receive the correct objects!\n"); init(LIST,list); return(ERROR); } ni=s_i_i(n); ri=ni/2; no_rows=s_pa_li(partition); if (ri0) f=0; else if (flag<0) f=1; else f=ri&1; /* undocumented: includes tableau with all spins barred */ /* put the parts in decreasing order: append a zero part */ part=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); filling=(INT*)SYM_calloc(no_rows+1,sizeof(INT)); for (i=0;i=0 && s_t_iji(spin,i,0)>0;i--); if (i>=0) { c_i_i(s_t_ij(spin,i,0),i+1); if ( !((ri-i)&1) ) /* need to change last entry */ addinvers_apply_integer(s_t_ij(spin,ri-1,0)); for (i++;i=0 && s_t_iji(spin,i,0)>0;i--); if (i>=0) { c_i_i(s_t_ij(spin,i,0),i+1); if ( !((ri-i)&1) ) /* need to change last entry */ addinvers_apply_integer(s_t_ij(spin,ri-1,0)); for (i++;i0) inc(S_V_I(term,e-1)); else if (e<0) dec(S_V_I(term,-e-1)); } b_skn_po(term,callocobject(),NULL,pol=callocobject()); m_i_i(1L,s_po_k(pol)); insert(pol,character,NULL,NULL); } SYM_free(part); return(OK); } INT spin_tableaux_character ( list, r, character) OP list; OP r; OP character; /* Takes a list of standard spin-tableaux (maximum entry r) and computes the corresponding character by summing over all such tableaux, the monomial formed by multplying indeterminants for each entry (negative entries give the indeterminant to the negative power) in the spin part and the square of the indeterminants for each entry in the tensor part. Thus, in the resulting polynomial, each exponent is twice the value it should be (to accommodate half odd integer values). A spin-tableau is regarded as a pair of tableaux (in a MONOM object), the koeff part is a single column of height the rank (r) giving the spin indices, the self part is the set of usual tensor indices. */ { INT i,j,e; OP trawl,term,pol; if (s_o_k(list)!=LIST || s_o_k(r)!=INTEGER || (!empty_listp(list) && (s_o_k(s_l_s(list))!=MONOM || s_o_k(s_mo_k(s_l_s(list)))!=TABLEAUX || s_o_k(s_mo_s(s_l_s(list)))!=TABLEAUX))) { printf("spin_tableaux_character() did not receive correct arguments!"); return(ERROR); } if (empty_listp(list)) { init(POLYNOM,character); return(OK); } if (!emptyp(character)) freeself(character); /* get the shape of the first tableau and assume the others are of the same shape. */ no_rows=s_pa_li(s_t_u(s_mo_s(s_l_s(list)))); ri=s_i_i(r); /* length of spin column */ /* put the parts in decreasing order: */ part=(INT*)SYM_calloc(no_rows,sizeof(INT)); for (i=0;i0) { inc(S_V_I(term,e-1)); inc(S_V_I(term,e-1)); } else if (e<0) { dec(S_V_I(term,-e-1)); dec(S_V_I(term,-e-1)); } } for (i=0;i0) { inc(S_V_I(term,e-1)); } else if (e<0) { dec(S_V_I(term,-e-1)); } } b_skn_po(term,callocobject(),NULL,pol=callocobject()); m_i_i(1L,s_po_k(pol)); insert(pol,character,NULL,NULL); } SYM_free(part); return(OK); } INT gl_character ( n, partition, character) OP n; OP partition; OP character; /* calculates the character (in n indeterminants) of the representation of GL(n) labelled by partition. This is the Schur function. */ { INT erg; OP t_list; if (s_pa_li(partition)==0) /* null partition => char=1 */ erg=m_i_i(1L,character); else { erg=gl_tableaux(n,partition,t_list=callocobject()); if (erg>=0) erg=tableaux_character(t_list,n,character); freeall(t_list); } return(erg); } INT sp_character ( n, partition, character)OP n; OP partition; OP character; /* calculates the character (in [n/2] indeterminants) of the representation of Sp(n) labelled by partition. */ { INT erg; OP t_list,r; if (s_pa_li(partition)==0) erg=m_i_i(1L,character); else { erg=sp_tableaux(n,partition,t_list=callocobject()); m_i_i(s_i_i(n)/2L,r=callocobject()); if (erg>=0) erg=tableaux_character(t_list,r,character); freeall(t_list); freeall(r); } return(erg); } INT or_character ( n, partition, character) OP n,partition,character; /* calculates the character (in [n/2] indeterminants) of the ordinary representation of O(n) labelled by partition. */ { INT erg; OP t_list,r; if (s_pa_li(partition)==0) erg=m_i_i(1L,character); else { erg=or_tableaux(n,partition,t_list=callocobject()); m_i_i(s_i_i(n)/2L,r=callocobject()); if (erg>=0) erg=tableaux_character(t_list,r,character); freeall(t_list); freeall(r); } return(erg); } INT so_character ( n, partition, flag, character) OP n,partition,character; INT flag; /* calculates the character (in [n/2] indeterminants) of the ordinary representation of SO(n) labelled by partition. In the case where n is even AND no. parts equal to n/2, we need to specify the + or - representation: flag=-1 selects the - representation and if +1 selects the + representation. */ { INT erg; OP t_list,r; if (s_pa_li(partition)==0) erg=m_i_i(1L,character); else { erg=so_tableaux(n,partition,flag,t_list=callocobject()); m_i_i(s_i_i(n)/2L,r=callocobject()); if (erg>=0) erg=tableaux_character(t_list,r,character); freeall(t_list); freeall(r); } return(erg); } INT pn_character ( n, partition, character)OP n; OP partition; OP character; /* calculates the character (in [n/2] indeterminants) of the spin representation of O(n) labelled by partition. */ { INT erg; OP t_list,r; erg=pn_tableaux(n,partition,t_list=callocobject()); m_i_i(s_i_i(n)/2L,r=callocobject()); if (erg>=0) erg=spin_tableaux_character(t_list,r,character); freeall(t_list); freeall(r); return(erg); } INT sn_character ( n, partition, flag, character) OP n; OP partition; INT flag; OP character; /* calculates the character (in [n/2] indeterminants) of the spin representation of SO(n) labelled by partition. If relevant (n is even), flag=-1 selects the - representation and flag=+1 selects the + representation. */ { INT erg; OP t_list,r; erg=sn_tableaux(n,partition,flag,t_list=callocobject()); m_i_i(s_i_i(n)/2L,r=callocobject()); if (erg>=0) erg=spin_tableaux_character(t_list,r,character); freeall(t_list); freeall(r); return(erg); } symmetrica-2.0/classical.doc0000600017361200001450000005041410726170273016033 0ustar tabbottcrontabCOMMENT: The CLASSICAL.C module deals with the calculation of the dimensions, standard tableaux and characters of the irreducible representations of the classical groups. This file first gives a very brief description of the labelling scheme for representations of classical groups in terms of partitions. It then describes the SYMMETRICA routines which calculate the dimensions, standard tableaux and characters of all irreducible representations of the classical groups. Finally, it describes three example programs which make use of these routines. In all cases, the set of irreducible representations of the classical groups may be naturally indexed by a subset of the set of partitions, half partitions (for the spin representations of O(n)) or signed partitions (for some O(n) representations). This labelling scheme is described in [BKW83], [Wy92], [We92]. In [We92] (see chapter 2), the specification of the irreducibles is slightly different to the others for certain modules of O(n). Namely, in [BKW83] and [Wy92], an asterisk is used to distinguish representations of O(n) which are associate (differ by a factor of the determinant of the group element) whereas in [We92], associate representations are labelled by different partitions. This latter notation is adhered to in these routines. The only case where a partition alone does not serve to uniquely identify the representation is for SO(2r) ordinary representations where the partition has exactly r non-zero parts, and for all spin representations of SO(2r). In such cases, there are two inequivalent representations corresponding to the partition in question. These two representations are usually distinguished by augmenting the partition label with + or -. These two representations have the same dimension and so are not distinguished in the dimension calculating routines. The representation labels are summarised here where the (descending) partition p=(p(1),p(2),...,p(s)) has s non-zero parts and its conjugate is p'=(p'(1),p'(2),...): Ordinary representations GL(n) | p : s<=n Sp(2r) | p : s<=r Sp(2r+1) | p : s<=r+1 O(n) | p : p'(1)+p'(2)<=n SO(2r+1) | p : s<=r SO(2r) | p : s #ifdef unix #undef MSDOS #include #endif /* unix */ #include /* for the routine clock,time */ #ifdef unix #include #endif /* unix */ OP cons_drei; /* global INTEGER variable 3 */ OP cons_zwei; /* global INTEGER variable 2 */ OP cons_eins; /* global INTEGER variable 1 */ OP cons_negeins;/* global INTEGER variable -1 */ OP cons_null; /* global INTEGER variable 0 */ FILE *texout; /* global variable for texoutput */ INT no_banner = FALSE; /* AK 281293 */ INT no_mem_check=TRUE; /* AK 100893 */ INT english_tableau=FALSE; /* AK 290995 */ INT doffset=0L; /* global for debugprint AK 160393 */ INT freeall_speichersize_max = (INT) 1000000; int SYM_free(a) char *a; { if (sym_timelimit > 0L) check_time(); free(a); return 0; } char * SYM_malloc(a) int a; { INT erg = OK; char *res; INT err; if (sym_timelimit > 0L) check_time(); SYMCHECK( (a < 0) , "SYM_malloc: size < 0"); sca: res = (char*)malloc(a); if (res == NULL) { err=error("SYM_malloc: no memory"); if (err==ERROR_RETRY) goto sca; if (err==ERROR_EXPLAIN) { fprintf(stderr,"I wanted %d Byte of Memory", a); } } return res; ENDTYP("SYM_malloc",char *); } char * SYM_calloc(a,b) int a,b; { char *erg; INT err; if (sym_timelimit > 0L) check_time(); if ( a < 0 ) { err = error("SYM_calloc: negative number of entries"); if (err==ERROR_EXPLAIN) { fprintf(stderr,"I wanted %d pieces of size %d", a,b); } return NULL; } else if ( b < 0 ) { err = error("SYM_calloc: negative size"); if (err==ERROR_EXPLAIN) { fprintf(stderr,"I wanted %d pieces of size %d", a,b); } return NULL; } sca: erg=(char*) calloc(a,b); if (erg == NULL) { err=error("SYM_calloc: no memory"); if (err==ERROR_RETRY) { goto sca; } if (err==ERROR_EXPLAIN) { fprintf(stderr,"I wanted %d pieces of size %d", a,b); goto sca; } } return erg; } char * SYM_realloc(a,b) char *a; int b; { char *erg; INT err= -1; if (sym_timelimit > 0L) check_time(); sca: erg = (char *)realloc(a,b); if (erg == NULL) { err=error("SYM_realloc: no memory"); if (err == ERROR_RETRY) { goto sca; } if (err==ERROR_EXPLAIN) { fprintf(stderr,"I wanted %d Byte of Memory", b); goto sca; } } return erg; } INT anfang() /* AK 070890 V1.1 */ /* AK 210891 V1.3 */ /* AK 260298 V2.0 */ /* AK 280705 V3.0 */ { time_t l; INT erg = OK; void srand(); if (not no_banner) { printeingabe("SYMMETRICA VERSION 3.0 - STARTING"); printeingabe(TITELTEXT); } time(&l); l = l * l * clock(); #ifdef unix l = l * getpid(); #endif srand((unsigned long)l); memcheck("anfang"); fflush(stdout); fflush(stderr); erg += speicher_anfang(); NEW_INTEGER(cons_drei,3); NEW_INTEGER(cons_zwei,2); NEW_INTEGER(cons_eins,1); NEW_INTEGER(cons_negeins,-1); NEW_INTEGER(cons_null,0); /* needed in start_longint */ texmath_yn=0L; /* not in math mode */ #ifdef LONGINTTRUE start_longint(); #endif /* LONGINTTRUE */ check_time_co = NULL; /* co routine called in check time, may be set by other programms */ texout = stdout; #ifdef NUMBERTRUE /* 291091: TPMcD */ /* The third parameter is NULL or the name of a file with cyclotomic data */ setup_numbers(STD_BASIS,TRUE, NULL); #endif /* NUMBERTRUE */ #ifdef BRUCHTRUE bruch_anfang(); /* AK 100893 */ #endif /* BRUCHTRUE */ #ifdef VECTORTRUE vec_anfang(); /* AK 100893 */ #endif /* VECTORTRUE */ #ifdef PARTTRUE part_anfang(); /* AK 040903 */ #endif /* PARTTRUE */ #ifdef TABLEAUXTRUE tab_anfang(); /* AK 100893 */ #endif /* TABLEAUXTRUE */ #ifdef PERMTRUE perm_anfang(); /* AK 100893 */ #endif /* PERMTRUE */ #ifdef LISTTRUE list_anfang(); /* AK 100893 */ #endif /* LISTTRUE */ #ifdef POLYTRUE monom_anfang(); /* AK 100893 */ #endif /* POLYTRUE */ #ifdef FFTRUE ff_anfang(); /* AK 011204 */ #endif /* FFTRUE */ #ifdef GRTRUE galois_anfang(); /* AK 271106 */ #endif /* GRTRUE */ #ifdef LOCALTRUE local_anfang(); /* AK 280705 */ #endif /* checks on type of constants */ CTO(INTEGER,"anfang(e1)",cons_zwei); CTO(INTEGER,"anfang(e2)",cons_eins); CTO(INTEGER,"anfang(e3)",cons_negeins); CTO(INTEGER,"anfang(e4)",cons_null); CTO(INTEGER,"anfang(e5)",cons_drei); ENDR("anfang"); } INT ende() /* AK 070890 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; char t[100]; #ifdef SCHURTRUE schur_ende(); #endif /* SCHURTRUE */ #ifdef NUMBERTRUE /* 29.10.91: TPMcD */ release_numbers(); #endif /* NUMBERTRUE */ #ifdef POLYTRUE monom_release(); #endif /* POLYTRUE */ #ifdef TABLEAUXTRUE tab_ende(); /* AK 100893 */ #endif /* TABLEAUXTRUE */ hash_ende(); #ifdef POLYTRUE monom_ende(); /* AK 100893 */ /* nach schur ende */ #endif /* POLYTRUE */ #ifdef BRUCHTRUE bruch_ende(); /* AK 100893 */ #endif /* BRUCHTRUE */ #ifdef PARTTRUE part_ende(); #endif /* PARTTRUE */ #ifdef LISTTRUE list_ende(); /* AK 100893 */ #endif /* LISTTRUE */ #ifdef PERMTRUE perm_ende(); /* AK 100893 */ #endif /* PERMTRUE */ #ifdef FFTRUE ff_ende(); #endif /* FFTRUE */ #ifdef GRTRUE galois_ende(); /* AK 271106 */ #endif /* GRTRUE */ #ifdef LOCALTRUE local_ende(); /* AK 280705 */ #endif #ifdef NUMBERTRUE /* AK 310893 */ nb_ende(); #endif /* NUMBERTRUE */ #ifdef LONGINTTRUE longint_ende(); #endif /* LONGINTTRUE */ #ifdef VECTORTRUE vec_ende(); /* AK 100893 */ #endif /* VECTORTRUE */ if ( /* AK 190194 */ (S_O_K(cons_drei) != INTEGER) || (S_O_K(cons_null) != INTEGER) || (S_O_K(cons_zwei) != INTEGER) || (S_O_K(cons_eins) != INTEGER) || (S_O_K(cons_negeins) != INTEGER) || (S_I_I(cons_null) != (INT) 0) || (S_I_I(cons_zwei) != (INT) 2) || (S_I_I(cons_eins) != (INT) 1) || (S_I_I(cons_negeins) != (INT) -1) ) erg += error("ende: wrong constant values e.g. cons_null"); erg += freeall(cons_null); erg += freeall(cons_zwei); erg += freeall(cons_drei); erg += freeall(cons_eins); erg += freeall(cons_negeins); erg += speicher_ende(); memcheck("ende"); if (not no_banner) { printeingabe("\nSYMMETRICA VERSION 3.0 - ENDING"); sprintf(t,"last changed: %s",TITELTEXT); /* AK 181194 */ printeingabe(t); } fflush(stdout); fflush(stderr); return erg; } INT runtime(l) long *l; /* AK 270689 V1.0 */ /* AK 070890 V1.1 */ /* AK 210891 V1.3 */ { #ifdef UNDEF #ifdef unix struct tms buffer; times(&buffer); *l = (long) buffer.tms_utime; #else /* clock ist POSIX */ *l = (long) clock()/60; #endif /* unix */ #endif *l = (long) clock()/CLOCKS_PER_SEC; return OK; } INT get_time(a) OP a; /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ /* AK 300998 V2.0 */ { long l; runtime(&l); return m_i_i((INT)l,a); } INT print_time() /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { long l; runtime(&l); printf("zeit:%ld\n",l);return OK; } INT fusedmemory(fn,stelle) FILE *fn; char *stelle; /* AK 270689 V1.0 */ /* AK 010290 V1.1 */ /* AK 130691 V1.2 */ /* AK 210891 V1.3 */ { #ifdef unix #ifndef linux /* struct mallinfo mallinfo(); struct mallinfo ergebnis; free(calloc(1,1)); ergebnis = mallinfo(); fprintf(fn,"%s: ",stelle); fprintf(fn,"%d ",ergebnis.uordblks); fprintf(fn,"%d\n",ergebnis.usmblks); return(OK); */ #endif /* linux */ #endif /* unix */ #ifdef TURBOC /* fprintf(fn,"%s: ",stelle); fprintf(fn,"%ul\n",coreleft()); return(OK); */ #endif /* TURBOC */ return(OK); } INT mem_small() /* anzahl small memory zurueck */ /* AK 270689 V1.0 */ /* AK 070890 V1.1 */ /* AK 210891 V1.3 */ { #ifdef unix #ifndef linux /* struct mallinfo mallinfo(); struct mallinfo ergebnis; ergebnis = mallinfo(); return(ergebnis.usmblks); */ #endif /*linux */ #endif /* unix */ return(0); } INT memcheck(stelle) char *stelle; /* informationen ueber memory 31/10/86 */ /* AK 270689 V1.0 */ /* AK 010290 V1.1 */ /* AK 210891 V1.3 */ { #ifdef unix #ifndef linux /* struct mallinfo mallinfo(); struct mallinfo ergebnis; if (no_mem_check == TRUE) return OK; SYM_free(SYM_calloc(1,1)); ergebnis = mallinfo(); printf("memory information %s\n",stelle); printf("total space %d\n",ergebnis.arena); printf("block number %d\n",ergebnis.ordblks); printf("small blocks %d\n",ergebnis.smblks); printf("used blocks %d\n",ergebnis.uordblks); printf("free blocks %d\n",ergebnis.fordblks); printf("used sm. blocks %d\n",ergebnis.usmblks); printf("free sm. blocks %d\n",ergebnis.fsmblks); return(OK); */ #endif /*linux */ #endif /* unix */ return(OK); } INT sym_background = 0L; INT sym_www = 0L; INT sym_timelimit = 0L; INT fatal_error(fehlertext) char *fehlertext; /* AK 270295 */ { fprintf(stderr,"fatal error in function %s\n",fehlertext); exit(11); return OK; } INT error(fehlertext) char *fehlertext; /* if answer == a ==> abort if answer == e ==> explain if answer == g ==> go on if answer == r ==> retry if answer == s ==> go on supress error texts if answer == f ==> go on forever else exit */ /* AK 270689 V1.0 */ /* AK 070890 V1.1 */ /* AK 070291 V1.2 explanation of possible input */ /* AK 210891 V1.3 */ { char antwort[2]; static int forever=0; if (forever==2) return ERROR; if (sym_www) { printf("ERROR: %s?: ",fehlertext); exit(ERROR_BACKGROUND); } fflush(stdout); fflush(stderr); fprintf(stderr, "\nenter a to abort with core dump, g to go, f to supress\n"); fprintf(stderr, "s to supress further error text, r to retry, e to explain, else stop\n"); fprintf(stderr,"ERROR: %s?: ",fehlertext); fflush(stderr); if (sym_background) { fprintf(stderr,"\nerror occured in background mode finishing SYMMETRICA\n"); exit(ERROR_BACKGROUND); } if (forever==1) return ERROR; antwort[0]='X'; scanf("%s",antwort); if (antwort[0] == 'a') abort(); if (antwort[0] == 'f') {forever = 1; return ERROR;} if (antwort[0] == 's') {forever = 2; return ERROR;} if (antwort[0] == 'g') return ERROR; if (antwort[0] == 'r') return ERROR_RETRY; if (antwort[0] == 'e') return ERROR_EXPLAIN; exit(1); /* AK 121192 */ } INT no_memory() /* AK 090792 */ { return error("no memory left"); } INT debugprint(a) OP a; /* AK 260788 */ /* AK 030789 V1.0 */ /* AK 130690 V1.1 */ /* AK 210891 V1.3 */ { OBJECTKIND kind; INT i,j,k; char *text=NULL; for (i=0L;i= '0') && (a <= '9')); } int SYM_strlen(a) char *a; /* AK 030294 */ { int i=0; while (*a++) i++; return i; } int SYM_memcmp(a,b,c) char *a,*b; /* AK 210294 */ { return memcmp(a,b,c); } int SYM_abs(a) INT a; /* AK 230695 */ { return (a>0 ) ? a : -a; } INT mem_size(a) OP a; /* AK 150295 */ { INT erg = OK; if (a == NULL) return 0; switch(S_O_K(a)) { case EMPTY: case INTEGER: return sizeof(struct object); case MATRIX: case INTEGERMATRIX: case KOSTKA: return mem_size_matrix(a); case LONGINT: return mem_size_longint(a); /* AK 080903 */ case COMPOSITION: case WORD: case SUBSET: case INTEGERVECTOR: case VECTOR: return mem_size_vector(a); case HASHTABLE: return mem_size_hashtable(a); default: erg += WTO("mem_size",a);goto endr_ende; } ENDR("mem_size"); } symmetrica-2.0/def.h0000400017361200001450000033141310726021700014302 0ustar tabbottcrontab/* file def.h SYMMETRICA */ /* INT should always be 4 byte */ #ifndef DEF_H #ifdef __alpha typedef int INT; typedef unsigned int UINT; #else /* __alpha */ typedef long INT; typedef unsigned long UINT; #endif /* __alpha */ #include #include #include #include #ifndef TITELTEXT #define TITELTEXT " Thu Feb 26 14:58:10 MET 1998 " #endif # define NO_REDUCE (INT)0 /* TPMcD */ # define POWER_REDUCE (INT)1 /* TPMcD */ # define STD_BASIS (INT)2 /* TPMcD */ #ifdef ULTRIX #define unix #include #endif /* ULTRIX */ #undef TRUE #undef FALSE #define REPORT (INT)3 #define TRUE (INT)1 #define FALSE (INT)0 #define OK (INT)0 #define ERROR (INT)-1 #define ERROR_RETRY (INT)-5 /* AK 020294 */ #define ERROR_EXPLAIN (INT)-6 /* AK 250195 */ /* exit values of symmetrica, parameters to exit */ #define ERROR_BACKGROUND (int) 101 /* AK 210297 */ /* error called while in background mode */ #define ERROR_TIMELIMIT (int) 100 /* AK 210297 */ /* time limit */ #define I2PE (INT)1502960 /* 2 equal parameter */ #define not ! #define IMPROPER (INT)1001 /* MD */ #define NONCOMPARABLE (INT)10 #define FIRSTVARINDEX (INT)11125 #define VARTYP (INT)11124 #define LETTERS (INT)11122 #define NUMERICAL (INT)11223 #define EQUAL (INT)300792 /* return value of check_equal_ */ #define NORESULT (INT)20996 /* return value of check_result_ */ #define FREE (char)1 #define NOFREE (char)0 #define t_SQRAD_CYCLO convert_sqrad_cyclo /* definitionen fuer object.c */ typedef INT OBJECTKIND; /* 4 byte */ typedef union { INT ob_INT; INT * ob_INTpointer; char *ob_charpointer; struct bruch *ob_bruch; struct graph *ob_graph; struct list *ob_list; struct longint *ob_longint; struct matrix *ob_matrix; struct monom *ob_monom; struct number *ob_number; /* MD */ struct partition *ob_partition; struct permutation *ob_permutation; struct reihe *ob_reihe; struct skewpartition *ob_skewpartition; struct symchar *ob_symchar; struct tableaux *ob_tableaux; struct vector *ob_vector; } OBJECTSELF; struct object { OBJECTKIND ob_kind; OBJECTSELF ob_self; }; typedef struct object * OP; /* die verschiedenen typen */ #define INVISIBLE (OBJECTKIND)-2 /* 110102 */ #define INFREELIST (OBJECTKIND)-1 /* 210995 */ #define EMPTY (OBJECTKIND)0 /* 290590 */ #define INTEGER (OBJECTKIND)1 #define VECTOR (OBJECTKIND)2 #define PARTITION (OBJECTKIND)3 #define BRUCH (OBJECTKIND)4 #define FRACTION (OBJECTKIND)4 #define PERMUTATION (OBJECTKIND)6 #define SKEWPARTITION (OBJECTKIND)7 /* 020488 */ #define TABLEAUX (OBJECTKIND)8 /* 020488 */ #define POLYNOM (OBJECTKIND)9 #define SCHUR (OBJECTKIND)10 #define MATRIX (OBJECTKIND)11 #define AUG_PART (OBJECTKIND)12 #define HOM_SYM (OBJECTKIND)13 #define HOMSYM (OBJECTKIND)13 #define SCHUBERT (OBJECTKIND)14 #define INTEGERVECTOR (OBJECTKIND)15 #define INTEGER_VECTOR (OBJECTKIND)15 #define INTVECTOR (OBJECTKIND)15 #define INT_VECTOR (OBJECTKIND)15 #define KOSTKA (OBJECTKIND)16 #define INTINT (OBJECTKIND)17 /* nur fuer test-zwecke */ #define SYMCHAR (OBJECTKIND)18 #define WORD (OBJECTKIND)19 #define LIST (OBJECTKIND)20 /* 210688 */ #define MONOM (OBJECTKIND)21 /*230688*/ #define LONGINT (OBJECTKIND)22 /* 170888 */ #define GEN_CHAR (OBJECTKIND)23 /* 280888 nur fuer test-zwecke */ #define BINTREE (OBJECTKIND)24 /* 291288 */ #define GRAPH (OBJECTKIND)25 /* 210889 */ #define COMPOSITION (OBJECTKIND)26 /* 300889 */ #define KRANZTYPUS (OBJECTKIND)27 /* 280390 */ #define POW_SYM (OBJECTKIND)28 #define POWSYM (OBJECTKIND)28 #define MONOMIAL (OBJECTKIND)29 /* 090992 */ #define BTREE (OBJECTKIND)30 #define KRANZ (OBJECTKIND)31 #define GRAL (OBJECTKIND)32 /* 200691 */ #define GROUPALGEBRA (OBJECTKIND)32 /* 170693 */ #define ELM_SYM (OBJECTKIND)33 /* 090992 */ #define ELMSYM (OBJECTKIND)33 /* 090992 */ #define FINITEFIELD (OBJECTKIND) 35 /* 250193 */ #define FF (OBJECTKIND) 35 /* 250193 */ #define REIHE (OBJECTKIND) 36 /* 090393 */ #define CHARPARTITION (OBJECTKIND) 37 /* 130593 */ /* internal use */ #define CHAR_AUG_PART (OBJECTKIND) 38 /* 170593 */ /* internal use */ #define INTEGERMATRIX (OBJECTKIND)40 /* AK 141293 */ #define CYCLOTOMIC (OBJECTKIND) 41 /* MD */ #define MONOPOLY (OBJECTKIND) 42 /* MD */ #define SQ_RADICAL (OBJECTKIND) 43 /* MD */ #define BITVECTOR (OBJECTKIND) 44 #define LAURENT (OBJECTKIND)45 #define SUBSET (OBJECTKIND)47 /* AK 220997 */ #define FASTPOLYNOM (OBJECTKIND)211093 #define EXPONENTPARTITION (OBJECTKIND)240298 #define SKEWTABLEAUX (OBJECTKIND)20398 #define PARTTABLEAUX (OBJECTKIND)10398 #define BARPERM (OBJECTKIND)230695 #define REVERSEPARTITION (OBJECTKIND)150703 /* only for input */ #define PERMVECTOR (OBJECTKIND)180998 #define PERM_VECTOR (OBJECTKIND)180998 #define PERMUTATIONVECTOR (OBJECTKIND)180998 #define PERMUTATION_VECTOR (OBJECTKIND)180998 #define INTEGERBRUCH (OBJECTKIND)220998 #define INTEGER_BRUCH (OBJECTKIND)220998 #define INTEGERFRACTION (OBJECTKIND)220998 #define INTEGER_FRACTION (OBJECTKIND)220998 #define HASHTABLE (OBJECTKIND)120199 #define QUEUE (OBJECTKIND)251103 #define GALOISRING (OBJECTKIND)211106 #define ANYTYPE (OBJECTKIND)201201 /* for tracing, checking */ #define INTTYPE (OBJECTKIND)020102 /* for tracing, checking */ #ifdef DGUX #define signed #endif /* DGUX */ #ifdef sun #define signed #endif #ifdef hpux #define signed #endif struct loc { INT w2,w1,w0; struct loc *nloc; }; struct longint { struct loc *floc; signed char signum; /* -1,0,+1 */ INT laenge; }; #define GANZSIGNUM(x) ((x)->signum) /* AK 051294 */ #define GANZLAENGE(x) ((x)->laenge) #define GANZNEG(x) ( (x)->signum = -(x)->signum) struct ganzdaten { INT basis,basislaenge,auspos,auslaenge,auszz; char folgezeichen; }; struct zahldaten { char ziffer[13]; INT mehr; INT ziffernzahl; struct loc *fdez; }; struct vector { OP v_length; OP v_self; }; struct REIHE_variablen { INT index; INT potenz; struct REIHE_variablen *weiter; }; struct REIHE_mon { OP coeff; struct REIHE_variablen *zeiger; struct REIHE_mon *ref; }; struct REIHE_poly { INT grad; struct REIHE_mon *unten; struct REIHE_poly *rechts; }; struct reihe { INT exist; INT reihenart; /* Werte: -1,0,1 */ INT z; /* bei Operationen pot und transform */ struct reihe *x,*y; /* Zeiger auf Ursprung bei Verknuepfung */ struct reihe *p; /* zeigt auf Potenzenliste */ INT (*eingabefkt)(); /* zeiger auf Eingabefunktion */ char ope; /* Operation */ struct REIHE_poly *infozeig; }; /* Zeiger auf Reihenglieder */ typedef struct reihe* REIHE_zeiger; struct list { OP l_self; OP l_next; }; struct partition { OBJECTKIND pa_kind; OP pa_self; INT pa_hash; /* AK 240901 */ /* hashwert -1 falls nicht berechnet */ }; #define LASTPARTITION 1234 #define EXPONENT (OBJECTKIND)88 #define FROBENIUS (OBJECTKIND)92 #define LASTCOMP 1234L #define LASTSUBSET 1234L #define LAST_SUBSET 1234L struct permutation { OBJECTKIND p_kind; OP p_self; }; #define LASTLEHMERCODE 12L #define LASTPERMUTATION 13L #define LAST_PERMUTATION 13L #define LAST_FF (INT)170194 #define LASTSHUFFLE 12048802L #define ZYKEL (OBJECTKIND)40888 /* fuer zykelschreibweise */ #define BITREC (OBJECTKIND)230195 /* fuer bitvector rectrice */ #define BAR (OBJECTKIND)25 /* AK 260292 fuer barred perm */ #define BARCYCLE (OBJECTKIND)26 /* AK 260292 fuer barred perm */ struct monom { OP mo_self; OP mo_koeff; }; struct bruch { OP b_oben; OP b_unten; INT b_info; }; #define GEKUERZT 40892L #define NGEKUERZT 408921L struct matrix { OP m_length; OP m_height; OP m_self; INT m_hash; }; #define SINGULAER 2903884 struct skewpartition { OP spa_gross; OP spa_klein; }; struct tableaux { OP t_umriss; OP t_self; }; struct symchar{ OP sy_werte; OP sy_parlist; OP sy_dimension; }; struct graph { OBJECTKIND gr_kind; OP gr_self; }; #define NACHBARLISTE (OBJECTKIND) 1 typedef struct { OP index, deg, poly, autos; } CYCLO_DATA; /* MD */ typedef struct { OP index, deg, poly; } FIELD_DATA; /* MD */ union data { CYCLO_DATA *c_data; FIELD_DATA *f_data; OP o_data; } ; /* MD */ struct number { OP n_self; union data n_data; }; /* MD */ /* return value fuer insert */ #define INSERTEQ 301288 /* falls eq */ #define INSERTOK 3012881 /* falls insert */ #define BINOMLIMIT 13 extern INT binom_values[BINOMLIMIT][BINOMLIMIT]; #ifdef ALLTRUE #define INTEGERTRUE 1 #define VECTORTRUE 1 #define PARTTRUE 1 #define PERMTRUE 1 #define LONGINTTRUE 1 #define MATRIXTRUE 1 #define SCHURTRUE 1 #define HOMSYMTRUE 1 #define POWSYMTRUE 1 #define ELMSYMTRUE 1 #define MONOMIALTRUE 1 #define BRUCHTRUE 1 #define CHARTRUE 1 #define KOSTKATRUE 1 #define SCHUBERTTRUE 1 #define SHUFFLETRUE 1 #define SKEWPARTTRUE 1 #define TABLEAUXTRUE 1 #define WORDTRUE 1 #define KRANZTRUE 1 #define BINTREETRUE 1 #define MONOPOLYTRUE 1 #define SQRADTRUE 1 #define CYCLOTRUE 1 #define NUMBERTRUE 1 #define DGTRUE 1 #define WTTRUE 1 #define SABTRUE 1 #define PLETTRUE 1 #define ZONALTRUE 1 #define GRALTRUE 1 #define FFTRUE 1 #define REIHETRUE 1 #define POLYTRUE 1 #define LAURENTTRUE 1 #define GRTRUE 1 #endif #ifdef FFTRUE #define VECTORTRUE 1 #endif #ifdef GRTRUE #define VECTORTRUE 1 #endif #ifdef POLYTRUE #define VECTORTRUE 1 #endif #ifdef DGTRUE #define SABTRUE 1 /* for gl-m reps */ #define MATRIXTRUE 1 #define CHARTRUE 1 #define PARTTRUE 1 #define NUMBERTRUE 1 #define TABLEAUXTRUE 1 #endif #ifdef ZONALTRUE #define KOSTKATRUE 1 #define CHARTRUE 1 #define MATRIXTRUE 1 #define POLYTRUE 1 #define PARTTRUE 1 #endif #ifdef NUMBERTRUE #define INTEGERTRUE 1 #define BRUCHTRUE 1 #define LISTTRUE 1 #define MONOMTRUE 1 #define SQRADTRUE 1 #define CYCLOTRUE 1 #define MONOPOLYTRUE 1 #endif #ifdef PLETTRUE #define SCHURTRUE 1 #define MATRIXTRUE 1 #define TABLEAUXTRUE 1 #define CHARTRUE 1 #endif #ifdef SKEWPARTTRUE #define PARTTRUE 1 #endif #ifdef KOSTKATRUE #define MATRIXTRUE 1 #define SCHURTRUE 1 #endif #ifdef CHARTRUE #define INTEGERTRUE 1 #define LONGINTTRUE 1 #define VECTORTRUE 1 #define PARTTRUE 1 #define MATRIXTRUE 1 #define SCHURTRUE 1 #define BRUCHTRUE 1 #define KOSTKATRUE 1 #define NUMBERTRUE 1 #define SQRADTRUE 1 #define CYCLOTRUE 1 #define MONOPOLYTRUE 1 #endif #ifdef SCHUBERTTRUE #define POLYTRUE 1 #define PARTTRUE 1 #define PERMTRUE 1 #define VECTORTRUE 1 #define INTEGERTRUE 1 #endif #ifdef TABLEAUXTRUE #define WORDTRUE 1 #define VECTORTRUE 1 #define MATRIXTRUE 1 #endif #ifdef SCHURTRUE #define BINTREETRUE 1 #define POLYTRUE 1 #define PARTTRUE 1 #define PERMTRUE 1 #define INTEGERTRUE 1 #define VECTORTRUE 1 #define SKEWPARTTRUE 1 #endif #ifdef BINTREETRUE #define INTEGERTRUE 1 #endif #ifdef POLYTRUE #define LISTTRUE 1 #define MONOMTRUE 1 #define VECTORTRUE 1 #endif #ifdef PERMTRUE #define PARTTRUE 1 #define INTEGERTRUE 1 #define VECTORTRUE 1 #endif #ifdef PARTTRUE #define INTEGERTRUE 1 #define VECTORTRUE 1 #endif #ifdef VECTORTRUE #define INTEGERTRUE 1 #endif extern INT no_mem_check; extern INT sym_no_results; /* 0 == stored results will be used */ /* 1 == stored results will not be used */ extern OP cons_eins; extern OP cons_negeins; extern OP cons_null; extern OP cons_zwei; extern OP cons_drei; extern FILE *texout; extern INT (*check_time_co)(); extern INT zeilenposition; /* position inside one row of stdout output */ extern INT row_length; /* length of one outputrow */ extern INT tex_row_length; /* length of one tex outputrow */ extern INT integer_format; /* if > 0 number of positions for INTEGER output */ extern INT english_tableau; extern INT no_banner; extern INT kuerzen_yn; extern INT texmath_yn; /* 1 in mathmode */ /* 0 not in mathmode */ extern INT scanoutput_yn; /* 1 no output */ /* 0 bitte output */ extern INT texposition; extern INT doffset; /* AK 160393 */ extern INT sym_background; extern INT sym_www; extern INT sym_timelimit; extern INT freeall_speicherposition;/* global variable for callocobject/freeall */ extern INT freeall_speichersize;/* global variable for callocobject/freeall */ extern OP *freeall_speicher; /* global variable for callocobject/freeall */ extern int SYM_free(); extern char* SYM_malloc(); extern char* SYM_realloc(); extern char* SYM_calloc(); #define SPEICHERSIZE (INT)10000 extern INT freeall_speichersize_max; /* global variable for managment of object space */ #ifdef LONGINTTRUE extern struct ganzdaten gd; /* a global datastructure */ #endif #define div SYM_div #define DEF_H /* from here automatically generated */ extern INT absolute(); extern INT absolute_bruch(); extern INT absolute_integervector(); extern INT absolute_longint(); extern INT absolute_matrix(); extern INT absolute_vector(); extern INT a_charvalue_co(); extern INT a_charvalue(); extern INT add(); extern INT add_adjacency_matrix(); extern INT add_apply(); extern INT add_apply_bruch(); extern INT add_apply_bruch_bruch(); extern INT add_apply_bruch_bruch_pre261101(); extern INT add_apply_bruch_integer(); extern INT add_apply_bruch_scalar(); extern INT add_apply_cyclo(); extern INT add_apply_default(); extern INT add_apply_ff(); extern INT add_apply_gral(); extern INT add_apply_gral_gral(); extern INT add_apply_hashtable(); extern INT add_apply_hashtable(); extern INT add_apply_integer(); extern INT add_apply_integer_bruch(); extern INT add_apply_integer_integer(); extern INT add_apply_integer_longint(); extern INT add_apply_integervector(); extern INT add_apply_laurent(); extern INT add_apply_longint(); extern INT add_apply_longint_integer(); extern INT add_apply_longint_longint(); extern INT add_apply_matrix(); extern INT add_apply_matrix_matrix(); extern INT add_apply_monopoly(); extern INT add_apply_polynom(); extern INT add_apply_polynom_polynom(); extern INT add_apply_polynom_scalar(); extern INT add_apply_polynom_schubert(); extern INT add_apply_reihe(); extern INT add_apply_scalar_bruch(); extern INT add_apply_scalar_polynom(); extern INT add_apply_schubert(); extern INT add_apply_schubert_schubert(); extern INT add_apply_sqrad(); extern INT add_apply_symchar(); extern INT add_apply_symfunc(); extern INT add_apply_symfunc_symfunc(); extern INT add_apply_vector(); extern INT add_bruch(); extern INT add_bruch_bruch(); extern INT add_bruch_integer(); extern INT add_bruch_scalar(); extern INT add_cyclo(); extern INT add_cyclo_cyclo(); extern INT add_elmsym(); extern INT add_elmsym_elmsym(); extern INT add_ff(); extern INT add_galois(); extern INT add_homsym(); extern INT add_homsym_homsym(); extern INT add_integer(); extern INT add_integer_integer(); extern INT add_integer_longint(); extern INT add_integervector(); extern INT addinvers_apply(); extern INT addinvers_apply_bruch(); extern INT addinvers_apply_cyclo(); extern INT addinvers_apply_elmsym(); extern INT addinvers_apply_ff(); extern INT addinvers_apply_galois(); extern INT addinvers_apply_hashtable(); extern INT addinvers_apply_homsym(); extern INT addinvers_apply_integer(); extern INT addinvers_apply_laurent(); extern INT addinvers_apply_longint(); extern INT addinvers_apply_monom(); extern INT addinvers_apply_monomial(); extern INT addinvers_apply_monopoly(); extern INT addinvers_apply_polynom(); extern INT addinvers_apply_powsym(); extern INT addinvers_apply_schur(); extern INT addinvers_apply_sqrad(); extern INT addinvers_apply_symchar(); extern INT addinvers_apply_vector(); extern INT addinvers(); extern INT addinvers_bruch(); extern INT addinvers_cyclo(); extern INT addinvers_ff(); extern INT addinvers_integer(); extern INT addinvers_longint(); extern INT addinvers_matrix(); extern INT addinvers_monom(); extern INT addinvers_monopoly(); extern INT addinvers_polynom(); extern INT addinvers_reihe(); extern INT addinvers_sqrad(); extern INT addinvers_symchar(); extern INT addinvers_vector(); extern INT add_koeff(); extern INT add_laurent(); extern INT add_longint(); extern INT add_longint_integer(); extern INT add_longint_longint(); extern INT add_matrix(); extern INT add_matrix_matrix(); extern INT add_monom(); extern INT add_monomial(); extern INT add_monomial_monomial(); extern INT add_monom_schur(); extern INT add_monopoly(); extern INT add_monopoly_monopoly(); extern INT add_partition(); extern INT add_part_part(); extern INT add_polynom(); extern INT add_polynom_polynom(); extern INT add_powsym(); extern INT add_powsym_powsym(); extern INT add_reihe(); extern INT add_scalar_cyclo(); extern INT add_scalar_monopoly(); extern INT add_scalar_polynom(); extern INT add_scalar_sqrad(); extern INT add_schubert(); extern INT add_schubert_schubert(); extern INT add_schur(); extern INT add_schur_schur(); extern INT add_sqrad(); extern INT add_sqrad_sqrad(); extern INT add_staircase_part(); extern INT add_symchar(); extern INT addtoallvectorelements(); extern INT add_vector(); extern INT ak_make_alt_classes(); extern INT ak_make_alt_partitions(); extern INT ak_plet_phm_integer_partition_(); extern INT all_01_matrices(); extern INT allclasses(); extern INT allclasssums(); extern INT all_codes(); extern INT all_codes(); extern INT all_codes_neu(); extern INT alle_teiler(); extern INT all_inj_codes(); extern INT all_inj_codes(); extern INT all_irred_polynomials(); extern INT allkostka(); extern INT all_lines(); extern INT all_lyndon_words(); extern INT all_orbits_set_rankf(); extern INT all_orbits_set_trace(); extern INT all_orbits_unset_rankf(); extern INT all_orbits_unset_trace(); extern INT all_orbits(); extern INT all_plactic_word(); extern INT all_points(); extern INT all_points_phg(); extern INT all_points_phg(); extern INT all_ppoly(); extern INT all_weintrauben(); extern INT alt_dimension(); extern INT alt_odg_trafo(); extern INT alt_sdg_trafo(); extern INT anfang(); extern INT an_odg(); extern INT an_rz_perm(); extern INT an_sdg(); extern INT an_tafel(); extern INT an_trafo_odg(); extern INT an_trafo_sdg(); extern INT append(); extern INT append_apply(); extern INT append_apply_part(); extern INT append_apply_vector(); extern INT append_behind_matrix_matrix(); extern INT append_below_matrix_matrix(); extern INT append_column_matrix(); extern INT append_part_part(); extern INT append_vector(); extern INT apply_INJDT(); extern INT augpart(); extern INT bar_rectr(); extern INT basis_mod_dg(); extern INT bdg(); extern INT b_d_sc(); extern INT bestimme_D(); extern INT bestimme_D(); extern INT bestimme_fixpunkt(); extern INT bestimme_konjugiertenklasse(); extern INT bestimme_zufallsmatrizen(); extern INT bestimme_zufallsmatrizen(); extern INT b_gk_spa(); extern INT bideterminant(); extern INT bideterminant_tableaux(); extern INT bideterminant_vector(); extern INT bilde_htupel(); extern INT bilde_htupel(); extern INT bin_ggt(); extern INT binom(); extern INT binom_small(); extern INT binom_small(); extern INT binom_small(); extern INT b_i_pa(); extern INT bit(); extern INT bit_longint(); extern INT b_kl_pa(); extern INT b_ksd_n(); extern INT b_ks_o(); extern INT b_ks_pa(); extern INT b_ks_p(); extern INT b_lh_m(); extern INT b_lh_nm(); extern INT b_lhs_m(); extern INT b_l_nv(); extern INT b_ls_v(); extern INT b_l_v(); extern INT b_matrix_tableaux(); extern INT b_ou_b(); extern INT b_o_v(); extern INT b_pa_mon(); extern INT b_pa_s(); extern INT b_perm_vector_kranz(); extern INT brauer_char(); extern INT brouwerlowerbound(); extern INT brouwerupperbound(); extern INT bruch_anfang(); extern INT bruch_ende(); extern INT bruch_not_scalar(); extern INT bru_comp(); extern INT bruhat_comp_perm(); extern INT bruhat_ideal(); extern INT bruhat_ideal_strong(); extern INT bruhat_ideal_weak(); extern INT bruhat_interval_strong(); extern INT bruhat_interval_weak(); extern INT bruhat_rank_function(); extern INT b_scalar_elmsym(); extern INT b_scalar_homsym(); extern INT b_scalar_monomial(); extern INT b_scalar_powsym(); extern INT b_scalar_schur(); extern INT b_sk_mo(); extern INT b_skn_mp(); extern INT b_skn_po(); extern INT b_skn_s(); extern INT b_skn_sch(); extern INT b_sn_e(); extern INT b_sn_h(); extern INT b_sn_l(); extern INT b_sn_mon(); extern INT b_sn_po(); extern INT b_sn_ps(); extern INT b_sn_s(); extern INT b_s_po(); extern INT build_gls_dist(); extern INT build_gls_dist(); extern INT build_lc (); extern INT build_propab_vector(); extern INT b_us_t(); extern INT b_u_t(); extern INT B_W(); extern INT B_W(); extern INT b_wpd_sc(); extern INT calculate_fixed_point_number(); extern OP callocobject(); extern INT callocobject_anfang(); extern INT callocobject_ende(); extern OP callocobject_fast(); extern OP callocobject_magma(); extern INT cardinality_pgkq(); extern INT cast_apply_barperm(); extern INT cast_apply_bruch(); extern INT cast_apply_elmsym(); extern INT cast_apply_ff(); extern INT cast_apply_homsym(); extern INT cast_apply_integer(); extern INT cast_apply(); extern INT cast_apply_matrix(); extern INT cast_apply_monom(); extern INT cast_apply_monomial(); extern INT cast_apply_monopoly(); extern INT cast_apply_part(); extern INT cast_apply_perm(); extern INT cast_apply_polynom(); extern INT cast_apply_powsym(); extern INT cast_apply_schur(); extern INT cast_apply_tableaux(); extern INT cast_elmsym(); extern INT cast_homsym(); extern INT cast_monomial(); extern INT cast_powsym(); extern INT cast_schur(); extern INT c_AUGPART_PARTITION(); extern INT c_b_o(); extern INT c_b_u(); extern INT c_CHARAUGPART_CHARPARTITION(); extern INT c_CHARPARTITION_CHARAUGPART(); extern INT cc_muir_mms_partition_partition_(); extern INT cc_muir_mms_partition_partition_(); extern INT cc_plet_pes_integer_partition(); extern INT cc_plet_phs_integer_partition(); extern INT cc_plet_pss_integer_partition(); extern INT cc_plet_pss_partition_partition(); extern INT Cdeg(); extern INT c_ff_di(); extern INT c_ff_ip(); extern INT Cgen(); extern INT c_gr_k(); extern INT c_gr_s(); extern INT change_column_ij(); extern INT change_row_ij(); extern INT characteristic_polynom_faster(); extern INT characteristic_polynom(); extern INT characteristic_polynom_superfast(); extern INT characteristik_symchar(); extern INT characteristik_to_symchar(); extern INT character_polynom(); extern INT charakteristik_to_ypolynom(); extern INT charge_tableaux(); extern INT charge_word(); extern INT char_matrix_scalar_product(); extern INT chartafel(); extern INT chartafel_bit(); extern INT chartafel_nonbit(); extern INT chartafel_partvector(); extern INT chartafel_symfunc(); extern INT chartafel_symfunc(); extern INT charvalue_bit (); extern INT charvalue(); extern INT charvalue_tafel_part(); extern INT check_braid (); extern INT check_commute (); extern INT check_equal_2a(); extern INT check_equal_2(); extern INT check_equal_3(); extern INT check_equal_4(); extern INT check_hecke_generators (); extern INT check_hecke_quadratic (); extern INT check_longint(); extern INT check_result_0(); extern INT check_result_1(); extern INT check_result_2(); extern INT check_result_3(); extern INT check_result_5(); extern INT check_selforthogonal_generatormatrix(); extern INT check_time(); extern INT check_zeilenposition(); extern INT check_zero_matrix (); extern INT c_i_i(); extern INT c_ijk_sn(); extern INT c_ijk_sn_tafel(); extern INT c_ij_sn(); extern INT c_i_n_an(); extern INT c_i_n(); extern INT c_kr_g(); extern INT c_kr_v(); extern INT class_bar(); extern INT class_label_glnq_co(); extern INT class_label_glnq(); extern INT class_label(); extern INT class_mult(); extern INT class_mult_part_part(); extern INT class_mult_schurmonom(); extern INT class_mult_schur(); extern INT class(); extern INT class_rep_bar(); extern INT class_rep_kranz(); extern INT class_rep(); extern INT c_l_n(); extern INT clone_size_hashtable(); extern INT c_l_s(); extern INT c_m_h(); extern INT c_m_hash(); extern INT c_m_l(); extern INT c_mo_k(); extern INT c_mo_s(); extern INT c_m_s(); extern INT c_n_d(); extern INT c_n_s(); extern INT co_070295(); extern INT code_mod_into_ord2(); extern INT code_mod_into_ord(); extern INT coeff_of_in(); extern INT c_o_k(); extern INT co_k_dimmod(); extern INT columns_standardise_tableau (); extern INT column_standardise_tableau (); extern INT columnwordoftableaux(); extern INT comp(); extern INT comp_bigr_bigr(); extern INT comp_bigr_perm(); extern INT comp_bruch(); extern INT comp_bruch_scalar(); extern INT comp_bv(); extern INT comp_colex_part(); extern INT comp_colex_schurmonom(); extern INT comp_colex_vector(); extern INT comp_cyclo(); extern INT comp_ff(); extern INT comp_galois(); extern INT comp_integer(); extern INT comp_integer_integer(); extern INT comp_integermatrix(); extern INT comp_integervector(); extern INT comp_kranztafel(); extern INT complete_complete_plet(); extern INT complete_schur_plet(); extern INT complex_conjugate(); extern INT comp_lex_perm(); extern INT comp_list(); extern INT comp_list_co(); extern INT comp_longint(); extern INT comp_longint_integer(); extern INT comp_matrix(); extern INT comp_monom(); extern INT comp_monomelmsym(); extern INT comp_monomhomsym(); extern INT comp_monommonomial(); extern INT comp_monompowsym(); extern INT comp_monomschur(); extern INT comp_monomvector_monomvector(); extern INT comp_monopoly(); extern INT comp_number(); extern INT comp_numeric_vector(); extern INT comp_partition(); extern INT comp_partition_partition(); extern INT comp_permutation(); extern INT comp_permutation_pol(); extern INT comp_polynom(); extern INT comp_polynom_scalar(); extern INT comp_reihe(); extern INT comp_skewpartition(); extern INT comp_skewpartition_skewpartition(); extern INT comp_sqrad(); extern INT comp_symchar(); extern INT comp_tableaux(); extern INT compute_complete_with_alphabet(); extern INT compute_elmsym_with_alphabet(); extern INT compute_gl_charvalue(); extern INT compute_gl_c_ijk(); extern INT compute_gl_cl_classorder(); extern INT compute_gl_il_dimension(); extern INT compute_monomial_with_alphabet(); extern INT compute_power_with_alphabet(); extern INT compute_schur(); extern INT compute_schur_with_alphabet_det(); extern INT compute_schur_with_alphabet(); extern INT compute_skewschur_with_alphabet_det(); extern INT compute_zonal_with_alphabet(); extern INT comp_vector(); extern INT comp_word(); extern INT conj_cyclo(); extern INT conj_sqrad(); extern INT conjugate(); extern INT conjugate_elmsym(); extern INT conjugate_homsym(); extern INT conjugate_monomial(); extern INT conjugate_partition(); extern INT conjugate_powsym(); extern INT conjugate_schur(); extern INT conjugate_tableaux(); extern INT conjugation(); extern INT consp_polynom(); extern INT contain_comp_part(); extern INT content(); extern INT content_polynom(); extern INT content_tableaux(); extern INT content_word(); extern INT convert_cyclo_scalar(); extern INT convert_radical_cyclo(); extern INT convert_sqrad_cyclo(); extern INT convert_sqrad_scalar(); extern INT co_polya3_sub(); extern INT co_polya_sub(); extern INT copy(); extern INT copy_bintree(); extern INT copy_bitvector(); extern INT copy_bruch(); extern INT copy_composition(); extern INT copy_elmsym(); extern INT copy_ff(); extern INT copy_galois(); extern INT copy_graph(); extern INT copy_hashtable(); extern INT copy_homsym(); extern INT copy_integer(); extern INT copy_integermatrix(); extern INT copy_integervector(); extern INT copy_kranztypus(); extern INT copy_kranz(); extern INT copy_laurent(); extern INT copy_list(); extern INT copy_longint(); extern INT copy_matrix(); extern INT copy_monom(); extern INT copy_monomial(); extern INT copy_number(); extern INT copy_partition(); extern INT copy_permutation(); extern INT copy_polynom(); extern INT copy_powsym(); extern INT copy_queue(); extern INT copy_reihe(); extern INT copy_schur(); extern INT copy_skewpartition(); extern INT copy_subset(); extern INT copy_symchar(); extern INT copy_tableaux(); extern INT copy_vector(); extern INT copy_word(); extern INT c_o_s(); extern INT Cosinus_eingabe(); extern INT co_table_of_R_nkq(); extern INT co_zykelind_pglkq(); extern INT c_pa_hash(); extern INT c_pa_k(); extern INT c_PARTITION_AUGPART(); extern INT c_pa_s(); extern INT c_p_k(); extern INT c_p_s(); extern INT c_sc_d(); extern INT c_sch_n(); extern INT c_sc_p(); extern INT c_sc_w(); extern INT c_s_n(); extern INT c_spa_g(); extern INT c_spa_k(); extern INT c_t_s(); extern INT c_t_u(); extern INT c_v_i(); extern INT c_v_l(); extern INT c_v_s(); extern INT cycliccodes_poly_matrix(); extern INT cyclic_tafel(); extern INT cyclo_an_tafel(); extern INT cyclo_odg(); extern INT debruijn_all_functions(); extern INT debruijn_inj_functions(); extern INT debugprint(); extern INT debugprint_ff(); extern INT debugprint_longint(); extern INT debugprint_object(); extern INT debugprint_reihe(); extern INT dec(); extern INT dec_integer(); extern INT dec_integervector(); extern INT dec_longint(); extern INT decompose_primepower(); extern INT dec_partition(); extern INT dec_permutation(); extern INT decp_mat(); extern INT decreasingp_vector(); extern INT dec_vector(); extern INT degree_monopoly(); extern INT degree_polynom(); extern INT delete_column_matrix(); extern INT delete_entry_vector(); extern INT delete_row_matrix(); extern INT derivative(); extern INT det270588(); extern INT det(); extern INT det_imm_matrix(); extern INT det_mat_imm(); extern INT det_matrix(); extern INT det_mat_tri(); extern INT dg_mp(); extern INT diagramm_permutation(); extern INT dimension_augpart(); extern INT dimension_bit(); extern INT dimension_mod(); extern INT dimension(); extern INT dimension_partition(); extern INT dimension_schubert(); extern INT dimension_schur(); extern INT dimension_skewpartition(); extern INT dimension_symmetrization(); extern INT dimino(); extern INT display(); extern INT display_schubert(); extern INT distanzdiagramm(); extern INT div(); extern INT div_apply(); extern INT div_apply_integer(); extern INT div_default(); extern INT divdiff(); extern INT divdiff_bar(); extern INT divdiff_perm_schubert(); extern INT divdiff_schubert(); extern INT divideddifference_bar(); extern INT divideddifference(); extern INT divideddiff_lc(); extern INT divideddiff_permutation(); extern INT divideddiff_rz_bar(); extern INT divideddiff_rz(); extern INT dixonwilf_bincodes(); extern INT dixonwilf_primcodes(); extern INT dixonwilf_primcodes(); extern INT dixon_wilf_transversal(); extern INT dom_comp_part(); extern INT double_apply(); extern INT double_apply_default(); extern INT double_apply_longint(); extern INT double_hashtable(); extern INT ds_j_wt(); extern INT durfee_size_part(); extern INT dynamicp(); extern INT dz_i_wt(); extern INT E_eingabe(); extern INT eins(); extern INT eins_default(); extern INT eins_ff(); extern INT eins_ff_given_q(); extern INT eins_galois(); extern INT eins_gr_given_c_d(); extern INT einsp(); extern INT einsp_bitvector(); extern INT einsp_bruch(); extern INT einsp_cyclotomic(); extern INT einsp_ff(); extern INT einsp_galois(); extern INT einsp_integer(); extern INT einsp_integervector(); extern INT einsp_kranz(); extern INT einsp_longint(); extern INT einsp_matrix(); extern INT einsp_monopoly(); extern INT einsp_permutation(); extern INT einsp_polynom(); extern INT einsp_reihe(); extern INT einsp_schubert(); extern INT einsp_sqrad(); extern INT einsp_symchar(); extern INT einsp_symfunc(); extern INT einsp_vector(); extern INT elementarp_permutation(); extern INT elementary_schur_plet(); extern INT embedding_mod_into_ord(); extern INT empty_listp(); extern INT empty_object(); extern INT emptyp(); extern INT ende(); extern INT en_forme(); extern INT enter_list_to_matrix (); extern INT eq(); extern INT eq_cyclotomic(); extern INT eq_fieldobject_int(); extern INT eq_integer(); extern INT eq_integervector_integervector(); extern INT eq_longint_longint(); extern INT eq_matrix(); extern INT eq_monomsymfunc(); extern INT eq_monomsymfunchash(); extern INT eq_partition(); extern INT eq_partition_partition(); extern INT eq_permutation(); extern INT eq_sqrad(); extern INT equal_2_error(); extern INT equal_parts(); extern INT eq_vector(); extern INT eqv(); extern INT error_during_computation_code(); extern INT error_during_computation(); extern INT error(); extern INT ersetze_zeile(); extern INT euler_phi(); extern INT eval_2schubert(); extern INT eval_char_polynom(); extern INT eval_monopoly(); extern INT eval_polynom_dir_prod(); extern INT eval_polynom(); extern INT even(); extern INT even_integer(); extern INT even_longint(); extern INT even_partition(); extern INT even_permutation(); extern INT exchange_alphabets(); extern INT exor_bitvector_apply(); extern INT Exp_eingabe(); extern INT extended_ggt(); extern INT factorize(); extern INT factorize_integer(); extern INT fakul_longintresult(); extern INT fakul(); extern INT fastrectr(); extern INT fatal_error(); extern INT ferrers(); extern INT ferrers_partition(); extern INT ferrers_skewpartition(); extern INT ff_anfang(); extern INT ff_ende(); extern INT fill_left_down_matrix(); extern INT filter_apply_hashtable(); extern INT filter_apply_list(); extern INT filter_list(); extern OP find_1result_hashtable(); extern OP find_2result_hashtable(); extern OP find (); extern OP find_bintree(); extern INT find_code_given_nkqd(); extern INT find_code_given_nkqd_gen_tim_bou(); extern OP find_hashtable(); extern INT find_knuth_tab_entry(); extern OP findmax_elmsym(); extern OP findmax_homsym(); extern OP findmax_monomial(); extern OP findmax_powsym(); extern OP findmax_schur(); extern OP findmax_vector(); extern OP findmin_elmsym(); extern OP findmin_homsym(); extern OP findmin_monomial(); extern OP findmin_powsym(); extern OP findmin_schur(); extern OP find_monomial(); extern INT find_non_root_standard_pos (); extern INT find_non_rowstandard_pos (); extern OP find_schur(); extern INT find_tab_entry(); extern OP find_teh_integer(); extern OP find_teh_integer(); extern OP find_tem_integer(); extern OP find_tep_integer(); extern OP find_tep_integer(); extern OP find_the_integer(); extern OP find_thm_integer(); extern OP find_thp_integer(); extern OP find_thp_integer(); extern OP find_tme_integer(); extern OP find_tme_integer(); extern OP find_tmh_integer(); extern OP find_tmh_integer(); extern OP find_tmh_integer(); extern OP find_tpe_integer(); extern OP find_tph_integer(); extern OP find_user_bintree(); extern OP find_vector(); extern INT first_bar(); extern INT first_composition(); extern INT first_ff(); extern INT first_ff_given_q(); extern INT first_gfp_vector(); extern INT first_gfp_vector(); extern INT first_gr_given_c_d(); extern INT first(); extern INT first_kranztypus(); extern INT first_lehmercode(); extern INT first_lex_tableaux(); extern INT first_part_EXPONENT(); extern INT first_partition(); extern INT first_part_VECTOR(); extern INT first_perm_n_invers(); extern INT first_permutation(); extern INT first_pgp_vector(); extern INT first_pgp_vector(); extern INT first_prime_factor(); extern INT first_subset(); extern INT first_tableaux(); extern INT first_tab_perm(); extern INT fprint_bintree(); extern INT fprint_bitvector(); extern INT fprint_bm(); extern INT fprint_bruch(); extern INT fprint_ff(); extern INT fprint_graph(); extern INT fprint_hashtable(); extern INT fprint_integer(); extern INT fprint_list(); extern INT fprintln(); extern INT fprint_longint(); extern INT fprint_matrix(); extern INT fprint_monom(); extern INT fprint_number(); extern INT fprint(); extern INT fprint_partition(); extern INT fprint_permutation(); extern INT fprint_queue(); extern INT fprint_reihe(); extern INT fprint_skewpartition(); extern INT fprint_symchar(); extern INT fprint_tableaux(); extern INT fprint_vector(); extern INT freeall(); extern INT freeall_magma(); extern INT free_cyclotomic_parameters (); extern INT freemonom(); extern INT freepartition(); extern INT free_root_parameters (); extern INT freeself(); extern INT freeself_bintree(); extern INT freeself_bitvector(); extern INT freeself_bruch(); extern INT freeself_ff(); extern INT freeself_galois(); extern INT freeself_graph(); extern INT freeself_hashtable(); extern INT freeself_integer(); extern INT freeself_integermatrix(); extern INT freeself_integervector(); extern INT freeself_kranz(); extern INT freeself_kranztypus(); extern INT freeself_laurent(); extern INT freeself_list(); extern INT freeself_longint(); extern INT freeself_matrix(); extern INT freeself_monom(); extern INT freeself_number(); extern INT freeself_partition(); extern INT freeself_permutation(); extern INT freeself_reihe(); extern INT freeself_skewpartition(); extern INT freeself_symchar(); extern INT freeself_tableaux(); extern INT freeself_vector(); extern INT free_useful_monopolies (); extern INT freevectorstruct(); extern INT freevectorstruct(); extern INT frip_latex_matrix_to_table(); extern INT frip_latex_matrix_to_table(); extern INT frip_latex_zykelind(); extern INT frobenius_elmsym(); extern INT frobenius_homsym(); extern INT frobenius_monomial(); extern INT frobenius_powsym(); extern INT frobenius_schur(); extern INT from_loesung_to_generatormatrix(); extern INT from_loesung_to_generatormatrix(); extern INT from_loesung_to_maximaldistanz(); extern INT from_loesung_to_minimaldistanz(); extern INT from_loesung_to_minimaldistanz(); extern INT from_loesung_to_weightenumerator(); extern INT from_loesung_to_weightenumerator(); extern INT fusedmemory(); extern INT galois_anfang(); extern INT galois_ende(); extern INT ganzdiv(); extern INT ganzdiv_apply(); extern INT ganzdiv_apply_integer(); extern INT ganzdiv_apply_longint(); extern INT ganzdiv_apply_longint_integer(); extern INT ganzdiv_apply_longint_longint(); extern INT ganzdiv_integer(); extern INT ganzdiv_integer_integer(); extern INT ganzdiv_integer_longint(); extern INT ganzdiv_longint(); extern INT ganzdiv_longint_integer(); extern INT ganzdiv_longint_longint(); extern INT ganzsquareroot(); extern INT ganzsquareroot_integer(); extern INT ganzsquareroot_longint(); extern INT garnir(); extern INT gauss_form(); extern INT gauss_form(); extern INT gauss_numbers(); extern INT gauss_polynom(); extern INT GaussRecInternal(); extern INT gauss_schubert_polynom(); extern INT gauss_triangular_apply_co(); extern INT gauss_triangular_apply_nodiv(); extern INT gauss_triangular_apply(); extern INT gcd_ex(); extern INT gcd_int_po(); extern INT gcd_mp(); extern INT gcd_mp_lent(); extern INT ge(); extern INT generate_root_tableaux (); extern INT generate_standard_tableaux (); extern INT generator_glkq_singer(); extern INT generator_glkq_sn(); extern INT generators_glnq(); extern INT generators_slnq(); extern INT gengroup(); extern INT gen_mat(); extern INT genpoly_QRcode(); extern INT gen_smat(); extern INT get_ax_dist(); extern INT get_bm_ij(); extern INT get_bv_i(); extern INT get_ff_irred(); extern INT get_galois_irred(); extern INT get_incidence(); extern INT get_incidence_caps(); extern INT get_incidence(); extern INT get_incidence_phg(); extern INT get_incidence_set_maxorbits(); extern INT get_index(); extern INT get_level_vector_of_verband(); extern INT get_orb_rep(); extern INT get_perm(); extern INT get_position(); extern INT get_tex_polynom_parameter(); extern INT get_time(); extern INT gewicht_v(); extern INT gewicht_wt(); extern INT Ggen(); extern INT ggt(); extern INT ggt_field_polynom(); extern INT ggt_i(); extern INT ggt_integer(); extern INT ggt_integer_integer(); extern INT ggt_integer_integer_slow(); extern INT ggt_integer_longint(); extern INT ggt_integer_slow(); extern INT ggt_longint(); extern INT ggt_longint_integer(); extern INT ggt_longint_longint(); extern INT ggt_longint_longint_sub(); extern INT ggt_polynom(); extern INT giambelli_matrix(); extern INT gl_character (); extern INT gl_dimension (); extern INT glm_B_W(); extern INT glm_B_W(); extern INT glm_get_BV(); extern INT glm_get_BV(); extern INT glm_homtest(); extern INT glmndg(); extern INT glm_sab(); extern INT glm_sab(); extern INT glpdg(); extern INT gl_tableaux (); extern INT gr(); extern INT gram_schmidt(); extern INT grf_An(); extern INT grf_arb(); extern INT grf_Cn(); extern INT grf_Dn(); extern INT grf_Sn(); extern INT griesmerbound(); extern INT group_gen(); extern INT grouporder_kranz(); extern INT growingorder_schur(); extern INT gt(); extern INT gupta_nm(); extern INT gupta_nm_speicher(); extern INT gupta_tafel(); extern INT half_apply(); extern INT half_apply_longint(); extern INT hall_littlewood(); extern INT hall_littlewood_alt(); extern INT hall_littlewood_dij(); extern INT hall_littlewood_tafel(); extern INT hamming_distance_vector(); extern INT hash(); extern INT hash_ende(); extern INT hash_ff(); extern INT hash_integervector(); extern INT hash_list(); extern INT hash_matrix(); extern INT hash_monompartition(); extern INT hash_partition(); extern INT hash_skewpartition(); extern INT hashv(); extern INT has_one_variable(); extern INT hecke_action_lc_on_lc (); extern INT hecke_action_perm_on_hecke (); extern INT hecke_action_perm_on_lc (); extern INT hecke_add (); extern INT hecke_dg(); extern INT hecke_generator_reps (); extern INT hecke_mult (); extern INT hecke_root_generator_reps (); extern INT hecke_scale (); extern INT hfix_in_ww(); extern INT hoch(); extern INT hoch_bruch(); extern INT hoch_bruch_integer(); extern INT hoch_bruch_longint(); extern INT hoch_default(); extern INT hoch_default(); extern INT hoch_integer(); extern INT hoch_integer_integer(); extern INT hoch_integer_longint(); extern INT hoch_longint(); extern INT hoch_longint_integer(); extern INT hoch_longint_longint(); extern INT hoch_pre200902(); extern INT _homtest(); extern INT _homtest(); extern INT hook_diagramm(); extern INT hook_length_augpart(); extern INT hook_length(); extern INT hookp(); extern INT hook_partition(); extern INT hook_part(); extern INT horizontal_sum(); extern INT hplus(); extern INT idempotent(); extern INT immanente_matrix(); extern INT inc(); extern INT inc_bitvector(); extern INT inc_integer(); extern INT inc_longint(); extern INT inc_matrix(); extern INT inc_matrix_column_co(); extern INT inc_matrix_row_co(); extern INT inc_partition(); extern INT inc_permutation(); extern INT inc_reihe(); extern INT inc_tableaux(); extern INT inc_vector(); extern INT inc_vector_co(); extern INT index_galois(); extern INT indexofpart(); extern INT index_vector(); extern INT index_vector_binary(); extern INT inf_bitvector_apply(); extern INT inf_bitvector(); extern INT init_bintree(); extern INT init_cyclo(); extern INT init_elmsym(); extern INT init_galois_global(); extern INT init_hall_littlewood(); extern INT init_hashtable(); extern INT init_homsym(); extern INT init(); extern INT init_kostka(); extern INT init_kranz(); extern INT init_longint(); extern INT init_monomial(); extern INT init_polynom(); extern INT init_powsym(); extern INT init_queue(); extern INT init_reihe(); extern INT init_schur(); extern INT init_size_hashtable(); extern INT init_sqrad(); extern INT innermaxmofn(); extern INT inner_tensor_sc(); extern INT input_glmn(); extern INT input_lc_permutations (); extern INT input_tableau (); extern INT insert(); extern INT insert_bintree(); extern INT insert_bt_bt(); extern INT insert_elmsym_hashtable(); extern INT insert_entry_vector(); extern INT insert_hashtable(); extern INT insert_hashtable_hashtable(); extern INT insert_homsym_hashtable(); extern INT insert_list_list_2(); extern INT insert_list_list(); extern INT insert_list(); extern INT insert_monomial_hashtable(); extern INT insert_powsym_hashtable(); extern INT insert_scalar_hashtable(); extern INT insert_schur_hashtable(); extern INT integer_factor(); extern INT integer_factors_to_integer(); extern INT integer_primep(); extern INT integer_primep(); extern INT intlog(); extern INT intlog_int(); extern INT intlog_longint(); extern INT invers(); extern INT invers_apply(); extern INT invers_apply_bruch(); extern INT invers_apply_integer(); extern INT invers_apply_longint(); extern INT invers_bar(); extern INT invers_bitvector(); extern INT invers_bruch(); extern INT invers_cyclo(); extern INT inverse_jeudetaquin_tableaux(); extern INT inverse_nilplactic_jeudetaquin_tableaux(); extern INT invers_ff(); extern INT invers_galois(); extern INT invers_integer(); extern INT inversion_matrix_perm(); extern INT invers_kostka_tafel(); extern INT invers_kranz(); extern INT invers_laurent(); extern INT invers_longint(); extern INT invers_matrix(); extern INT invers_monopoly(); extern INT inversordcen(); extern INT invers_permutation(); extern INT invers_polynom(); extern INT invers_POLYNOM(); extern INT invers_sqrad(); extern INT is_graphical(); extern INT is_scalar_polynom(); extern INT is_scalar_reihe(); extern INT is_selfconjugate(); extern INT jacobi(); extern INT jacobitrudimatrix(); extern INT jeudetaquin_tableaux(); extern INT johnson_graph_adjacency_matrix(); extern INT kgv(); extern INT kk_280604 (); extern INT Kn_adjacency_matrix(); extern INT knuth_row_delete_step(); extern INT knuth_row_insert_step(); extern INT knuth_twoword(); extern INT konj_gral_perm(); extern INT konj_perm_perm(); extern INT konjugation2(); extern INT konjugation(); extern INT konjugierende(); extern INT konjugiertenklassen_glkp(); extern INT konjugiertenklassen_glkp(); extern INT kostka_character(); extern INT kostka_number(); extern INT kostka_number_partition(); extern INT kostka_number_skewpartition(); extern INT kostka_tab(); extern INT kostka_tafel(); extern INT kranztafel(); extern INT kranztypus_charakteristik(); extern INT kranztypus_kranztypus_monom(); extern INT kranztypus_to_matrix(); extern INT kronecker(); extern INT kronecker_product(); extern INT krz(); extern INT kuerzen(); extern INT kuerzen_integer_integer(); extern INT kuerzen_integer_integer(); extern INT kuerzen_integer_longint(); extern INT kuerzen_integer_longint(); extern INT kuerzen_integral(); extern INT kuerzen_longint_integer(); extern INT kuerzen_longint_integer(); extern INT kuerzen_longint_longint(); extern INT kuerzen_longint_longint(); extern INT kung_formel(); extern INT lagrange_polynom(); extern INT last_lehmercode(); extern INT lastof(); extern INT lastof_integervector(); extern INT lastof_partition(); extern INT lastof_skewpartition(); extern INT lastof_vector(); extern INT lastp(); extern INT last_part_EXPONENT(); extern INT last_partition(); extern INT last_part_VECTOR(); extern INT last_permutation(); extern INT lastp_list(); extern INT latex_glm_dar(); extern INT latex_kranztafel(); extern INT latex_line(); extern INT latex_verband(); extern INT latticepword(); extern INT l_complete_complete_plet(); extern INT l_complete_schur_plet(); extern INT ldcf_monopoly(); extern INT ldcf_mp(); extern INT ldrei_neu(); extern INT ldrei_neu_get_zeitlimit(); extern INT ldrei_neu_set_anzahl(); extern INT ldrei_neu_set_keepgls(); extern INT ldrei_neu_set_mckay(); extern INT ldrei_neu_set_zeitlimit(); extern INT le(); extern INT leftkey_wt(); extern INT lehmercode2_permutation(); extern INT lehmercode(); extern INT lehmercode_bar(); extern INT lehmercode_permutation(); extern INT lehmercode_tableaux(); extern INT lehmercode_vector_bar(); extern INT lehmercode_vector(); extern INT l_elementary_schur_plet(); extern INT length(); extern INT length_bar(); extern INT length_bintree(); extern INT length_comp_part(); extern INT length_list(); extern INT length_partition(); extern INT length_permutation(); extern INT length_reihe(); extern INT length_skewpartition(); extern INT length_vector(); extern INT line_of_two_points(); extern INT list_anfang(); extern INT list_ende(); extern INT listp(); extern INT local_anfang(); extern INT local_ende(); extern INT longint_ende(); extern INT l_outerproduct_schur_lrs(); extern INT l_powerproduct_schur_plet(); extern INT l_power_schur_plet(); extern INT l_schur_powerproduct_schur_plet_mult(); extern INT l_schur_power_schur_plet_mult(); extern INT l_schur_schur_plet(); extern INT l_schur_schur_pletbis(); extern INT lt(); extern INT lyndon_orb(); extern INT m_2schubert_wt(); extern INT mahh_hashtable_hashtable_(); extern INT mahh_integer_homsym_(); extern INT mahh_partition_hashtable_(); extern INT make_all_st_tabs(); extern INT make_alt_classes(); extern INT makealtclassreps(); extern INT make_alt_partitions(); extern INT make_coprimes(); extern INT make_cyclotomic_monopoly(); extern INT make_ij_part(); extern INT make_index_coeff_power_cyclo(); extern INT make_index_power_cyclo(); extern INT make_monopoly_sqrad(); extern INT make_neu_partij_schur(); extern INT make_n_id(); extern INT make_n_kelmtrans(); extern INT make_n_transpositionmatrix(); extern INT make_nzykel(); extern INT make_partij_perm(); extern INT make_partij_schur(); extern INT make_real_cycletype(); extern INT make_scalar_cyclo(); extern INT make_scalar_sqrad(); extern INT make_tab_signs(); extern INT make_unitary0_monopoly(); extern INT make_unitary_eins_monopoly(); extern INT makevectorof_class_bar(); extern INT makevectorof_class_rep_bar(); extern INT makevectorof_kranztypus(); extern INT makevectorofpart_EXPONENT(); extern INT makevectorofpart(); extern INT makevectorofperm(); extern INT makevectorofrect_lehmercode(); extern INT makevectorofrect_permutation(); extern INT makevectorofshuffle(); extern INT makevectorofspecht_poly(); extern INT makevectorofsubsets(); extern INT makevectorofsymspecht_poly(); extern INT makevectorofSYT(); extern INT makevectoroftableaux(); extern INT makevectoroftranspositions(); extern INT makevectorofvectors(); extern INT makevectorofwords(); extern INT maple_polynom(); extern INT mapp_hashtable_hashtable_(); extern INT mapp_hashtable_hashtable_(); extern INT matrix_knuth(); extern INT matrix_monom_ypolynom(); extern INT matrixp(); extern INT matrix_to_kranztypus(); extern INT matrix_twoword(); extern INT max(); extern INT max_bar(); extern INT max_degree_reihe(); extern INT maxdegree_schubert(); extern INT max_divideddiff(); extern INT max_integervector(); extern INT max_matrix(); extern INT maxorder_young(); extern INT maxpart_comp_part(); extern INT maxrindexword(); extern INT max_tableaux(); extern INT max_vector(); extern INT m_bar_schubert(); extern INT m_cosinus_reihe(); extern INT m_d_sc(); extern INT mee_elmsym__(); extern INT mee_hashtable__(); extern INT mee_hashtable_hashtable_(); extern INT mee_hashtable_hashtable_(); extern INT mee_hashtable_hashtable_(); extern INT mee_integer__(); extern INT mee_integer_hashtable_(); extern INT mee_integer_hashtable_(); extern INT mee_integer_hashtable_(); extern INT mee_integer_partition_(); extern INT mee_integer_partition_(); extern INT mee_partition__(); extern INT mee_partition__(); extern INT mee_partition_partition_(); extern INT m_eins_reihe(); extern INT memcheck(); extern INT mem_elmsym__(); extern INT mem_ende(); extern INT mem_integer__(); extern INT mem_integer_hashtable_(); extern INT mem_integer_hashtable_(); extern INT mem_integer_hashtable_(); extern INT mem_integer_partition_(); extern INT mem_partition__(); extern INT mem_size(); extern INT mem_size_hashtable(); extern INT mem_size_longint(); extern INT mem_size_matrix(); extern INT mem_size_vector(); extern INT mem_small(); extern INT mes_elmsym__(); extern INT mes_ende(); extern INT mes_hashtable__(); extern INT mes_integer__(); extern INT mes_integer_hashtable_(); extern INT mes_integer_hashtable_(); extern INT mes_integer_partition_(); extern INT mes_integer_partition_(); extern INT mes_integer_partition_(); extern INT mes_partition__(); extern INT mes_partition__(); extern INT m_ff_vector(); extern INT m_forall_monomials_in_a(); extern INT m_forall_monomials_in_ab(); extern INT m_forall_monomials_in_b(); extern INT m_function_reihe(); extern INT m_gk_spa(); extern INT m_gl_alt(); extern INT m_gl_chartafel(); extern INT m_gl_cl(); extern INT m_gl_co(); extern INT m_gl_cr(); extern INT m_gl_cyclic(); extern INT m_gl_first(); extern INT m_gl_ge_cl(); extern INT m_gl_glnq(); extern INT m_gl_go(); extern INT m_gl_hyp(); extern INT m_gl_il(); extern INT m_gl_nc(); extern INT m_gl_next(); extern INT m_gl_sym(); extern INT m_gl_symkranz(); extern INT mhh_hashtable__(); extern INT mhh_hashtable_hashtable_(); extern INT mhh_hashtable_hashtable_(); extern INT mhh_hashtable_hashtable_(); extern INT mhh_homsym__(); extern INT mhh_partition__(); extern INT mhh_partition__(); extern INT mhh_partition_hashtable_(); extern INT mhh_partition_hashtable_(); extern INT mhh_partition_partition_(); extern INT mhm_hashtable__(); extern INT mhm_homsym__(); extern INT mhm_integer__(); extern INT mhm_integer_hashtable_hashtable(); extern INT mhm_integer_partition_hashtable(); extern INT mhm_null__(); extern INT mhm_partition__(); extern INT mhp_co(); extern INT mhp_hashtable__(); extern INT mhp_homsym__(); extern INT mhp_integer__(); extern INT mhp_integer__(); extern INT mhp_integer_hashtable_(); extern INT mhp_integer_hashtable_(); extern INT mhp_integer_hashtable_(); extern INT mhp_integer_hashtable_(); extern INT mhp_integer_partition_(); extern INT mhp_integer_partition_(); extern INT mhp_partition__(); extern INT mhs_hashtable__(); extern INT mhs_homsym__(); extern INT mhs_integer__(); extern INT mhs_integer__(); extern INT mhs_integer_partition_(); extern INT mhs_partition__(); extern INT m_i_elmsym(); extern INT m_i_i(); extern INT m_iindex_iexponent_monom(); extern INT m_iindex_monom(); extern INT m_iindex_monopoly(); extern INT m_il_bv(); extern INT m_ilih_bm(); extern INT m_ilih_m(); extern INT m_ilih_nm(); extern INT m_il_integervector(); extern INT m_il_nbv(); extern INT m_il_nv(); extern INT m_i_longint(); extern INT m_il_pa(); extern INT m_il_p(); extern INT m_il_v(); extern INT min(); extern INT m_index_monom(); extern INT mindist_neu(); extern INT mindist(); extern INT mindist_submatrix(); extern INT minimaldistanz(); extern INT minimaldistanz(); extern INT minimal_extension(); extern INT minimum_distance(); extern INT min_integervector(); extern INT min_matrix(); extern INT min_tableaux(); extern INT m_INTEGER_elmtrans(); extern INT m_INT_elmtrans(); extern INT m_int_pa(); extern INT min_vector(); extern INT m_ioiu_b(); extern INT m_i_pa(); extern INT m_i_powsym(); extern INT m_i_schubert(); extern INT m_i_schur(); extern INT m_i_staircase(); extern INT m_kl_pa(); extern INT m_ksd_n(); extern INT m_ks_pa(); extern INT m_ks_p(); extern INT m_lehmer_schubert_monom_summe(); extern INT m_lehmer_schubert_qpolynom(); extern INT m_lh_m(); extern INT m_lh_nm(); extern INT m_l_nv(); extern INT m_l_p(); extern INT m_l_v(); extern INT m_matrix_tableaux(); extern INT m_matrix_umriss(); extern INT m_merge_partition_partition(); extern INT m_merge_partition_partition(); extern INT m_merge_partition_partition(); extern INT m_merge_partition_partition(); extern INT m_merge_partition_partition(); extern INT m_merge_partition_partition(); extern INT m_merge_partition_partition(); extern INT m_merge_partition_partition(); extern INT mmm___(); extern INT mmm___(); extern INT mmm_ende(); extern INT mmm_hashtable__(); extern INT mmm_hashtable_hashtable_(); extern INT mmm_hashtable_hashtable_(); extern INT mmm_integer__(); extern INT mmm_integer_hashtable_(); extern INT mmm_integer_hashtable_(); extern INT mmm_integer_partition_(); extern INT mmm_integer_partition_(); extern INT mmm_monomial__(); extern INT mmm_null_partition_(); extern INT mmm_null_partition_(); extern INT mmm_partition__(); extern INT mmm_partition_partition_(); extern INT mmm_partition_partition_(); extern INT mmm_partition_partition_(); extern INT mmm_partition_partition_(); extern INT mms___(); extern INT mms_hashtable__(); extern INT mms_hashtable_partition_(); extern INT mms_integer__(); extern INT mms_integer_partition_(); extern INT mms_monomial__(); extern INT mms_null__(); extern INT mms_partition__(); extern INT mms_partition_partition_(); extern INT m_nc_kranz(); extern INT mod(); extern INT mod_apply(); extern INT mod_apply_integer(); extern INT mod_apply_integer_longint(); extern INT mod_apply_longint(); extern INT moddg(); extern INT mod_dg_sbd(); extern INT mod_integer_integer(); extern INT mod_longint_integer(); extern INT mod_longint_integer_via_ganzsquores(); extern INT mod_matrix(); extern INT mod_monom(); extern INT mod_part(); extern INT mod_polynom(); extern INT mod_vector(); extern INT moebius(); extern INT moebius_tafel(); extern INT monom_anfang(); extern INT monom_ende(); extern INT monomial_recursion(); extern INT monomial_recursion(); extern INT monomial_recursion2(); extern INT monomial_recursion2(); extern INT monomial_recursion(); extern INT monom_release(); extern INT m_ou_b(); extern INT move_1result_hashtable(); extern INT move_2result_hashtable(); extern INT m_o_v(); extern INT m_pa_e(); extern INT m_pa_h(); extern INT m_pa_mon(); extern INT m_pa_ps(); extern INT m_part_centralsc(); extern INT m_part_kostkaperm(); extern INT m_part_part_perm(); extern INT m_part_perm(); extern INT m_part_qelm(); extern INT m_part_Qschur(); extern INT m_part_sc(); extern INT m_part_sc_tafel(); extern INT m_part_tableaux(); extern INT m_part_youngsc(); extern INT m_pa_s(); extern INT m_perm_2schubert_monom_summe(); extern INT m_perm_2schubert_operating_monom_summe(); extern INT m_perm_2wt_summe(); extern INT m_perm_paareperm(); extern INT m_perm_reihe(); extern INT m_perm_rz_number(); extern INT m_perm_rz_set(); extern INT m_perm_sch(); extern INT m_perm_schubert_dimension(); extern INT m_perm_schubert_monom_summe(); extern INT m_perm_schubert_qpolynom(); extern INT m_perm_schur(); extern INT m_perm_sdwt_summe(); extern INT m_perm_skwt_summe(); extern INT m_perm_snwt_summe(); extern INT m_perm_tableaux_summe(); extern INT m_perm_wt_summe(); extern INT mp_is_cst(); extern INT mpp___(); extern INT mpp___(); extern INT mpp_ende(); extern INT mpp_hashtable__(); extern INT mpp_hashtable_hashtable_(); extern INT mpp_hashtable_hashtable_(); extern INT mpp_hashtable_hashtable_(); extern INT mpp_hashtable_hashtable_(); extern INT mpp_hashtable_hashtable_(); extern INT mpp_hashtable_hashtable_(); extern INT mpp_hashtable_hashtable_(); extern INT mpp_integer__(); extern INT mpp_integer_hashtable_(); extern INT mpp_integer_hashtable_(); extern INT mpp_integer_partition_(); extern INT mpp_integer_partition_(); extern INT mpp_partition__(); extern INT mpp_partition_partition_(); extern INT mpp_partition_partition_(); extern INT mpp_powsym__(); extern INT mps___(); extern INT mps_ende(); extern INT mps_hashtable__(); extern INT mps_hashtable__(); extern INT mps_hashtable__pre100102(); extern INT mps_integer__(); extern INT mps_integer_partition_(); extern INT mps_integer_partition_(); extern INT mps_integer_partition_(); extern INT mps_null__(); extern INT mps_partition__(); extern INT mps_powsym__(); extern INT m_scalar_bruch(); extern INT m_scalar_elmsym(); extern INT m_scalar_homsym(); extern INT m_scalar_monomial(); extern INT m_scalar_polynom(); extern INT m_scalar_powsym(); extern INT m_scalar_reihe(); extern INT m_scalar_schubert(); extern INT m_scalar_schur(); extern INT m_sinus_reihe(); extern INT m_skewpart_skewperm(); extern INT m_sk_gr(); extern INT m_sk_mo(); extern INT m_skn_mp(); extern INT m_skn_po(); extern INT m_skn_sch(); extern INT m_skn_s(); extern INT m_sn_l(); extern INT m_s_po(); extern INT mss___(); extern INT mss_ende(); extern INT mss_hashtable__(); extern INT mss_hashtable_hashtable_(); extern INT mss_hashtable_hashtable_(); extern INT mss_hashtable_hashtable_maxpart_maxlength(); extern INT mss_hashtable__maxpart_maxlength(); extern INT mss___maxpart_maxlength(); extern INT mss_partition__(); extern INT mss_partition__maxpart_maxlength(); extern INT mss_partition_partition_(); extern INT mss_partition_partition_maxpart_maxlength(); extern INT mss_schur__(); extern INT mss_schur__maxpart_maxlength(); extern INT m_tableaux_polynom(); extern INT m_tableaux_tableauxpair(); extern INT m_T_pol_summe(); extern INT m_T_tableaux_summe(); extern INT m_T_wt_summe(); extern INT mult(); extern INT multadd_apply(); extern INT multadd_apply_default(); extern INT multadd_apply_ff(); extern INT mult_apply(); extern INT mult_apply_bruch(); extern INT mult_apply_bruch_bruch(); extern INT mult_apply_bruch_hashtable(); extern INT mult_apply_bruch_integer(); extern INT mult_apply_bruch_longint(); extern INT mult_apply_bruch_monom(); extern INT mult_apply_bruch_polynom(); extern INT mult_apply_bruch_scalar(); extern INT mult_apply_cyclo(); extern INT mult_apply_default (); extern INT mult_apply_elmsym(); extern INT mult_apply_elmsym_elmsym(); extern INT mult_apply_ff(); extern INT mult_apply_gral(); extern INT mult_apply_homsym(); extern INT mult_apply_homsym_homsym(); extern INT mult_apply_homsym_schur(); extern INT mult_apply_integer(); extern INT mult_apply_integer_bruch(); extern INT mult_apply_integer_hashtable(); extern INT mult_apply_integer_integer(); extern INT mult_apply_integer_integervector(); extern INT mult_apply_integer_longint(); extern INT mult_apply_integer_matrix(); extern INT mult_apply_integer_monom(); extern INT mult_apply_integer_polynom(); extern INT mult_apply_longint(); extern INT mult_apply_longint_bruch(); extern INT mult_apply_longint_integer(); extern INT mult_apply_longint_longint(); extern INT mult_apply_longint_matrix(); extern INT mult_apply_longint_polynom(); extern INT mult_apply_matrix(); extern INT mult_apply_matrix_matrix(); extern INT mult_apply_monom(); extern INT mult_apply_monomial(); extern INT mult_apply_monomial_monomial(); extern INT mult_apply_monopoly(); extern INT mult_apply_permutation(); extern INT mult_apply_polynom(); extern INT mult_apply_polynom_polynom(); extern INT mult_apply_polynom_scalar(); extern INT mult_apply_powsym(); extern INT mult_apply_powsym_powsym(); extern INT mult_apply_reihe(); extern INT mult_apply_scalar_bruch(); extern INT mult_apply_scalar_cyclo(); extern INT mult_apply_scalar_hashtable(); extern INT mult_apply_scalar_matrix(); extern INT mult_apply_scalar_monom(); extern INT mult_apply_scalar_monopoly(); extern INT mult_apply_scalar_polynom(); extern INT mult_apply_scalar_sqrad(); extern INT mult_apply_scalar_symchar(); extern INT mult_apply_scalar_vector(); extern INT mult_apply_schur(); extern INT mult_apply_schur_schur(); extern INT mult_apply_sqrad(); extern INT mult_apply_symchar(); extern INT mult_apply_vector(); extern INT mult_apply_vector_vector(); extern INT mult_bar_bar(); extern INT mult_bruch(); extern INT mult_bruch_bruch(); extern INT mult_bruch_hashtable(); extern INT mult_bruch_integer(); extern INT mult_bruch_longint(); extern INT mult_cyclo(); extern INT mult_cyclo_cyclo(); extern INT mult_disjunkt_polynom_polynom(); extern INT mult_elmsym(); extern INT mult_elmsym_elmsym(); extern INT mult_elmsym_homsym(); extern INT mult_elmsym_monomial(); extern INT mult_elmsym_powsym(); extern INT mult_elmsym_scalar(); extern INT mult_elmsym_schur(); extern INT mult_ff(); extern INT mult_ff_ff(); extern INT mult_ff_integer(); extern INT mult_galois_galois(); extern INT mult_galois(); extern INT mult_gral(); extern INT mult_gral_gral(); extern INT mult_hashtable_hashtable(); extern INT mult_hashtable_hashtable(); extern INT mult_hashtable_hashtable_faktor(); extern INT mult_hashtable_hashtable_faktor(); extern INT mult_homsym(); extern INT mult_homsym_elmsym(); extern INT mult_homsym_homsym(); extern INT mult_homsym_monomial(); extern INT mult_homsym_powsym(); extern INT mult_homsym_scalar(); extern INT mult_homsym_schur(); extern INT mult_imatrix_imatrix(); extern INT multinom(); extern INT multinom_small(); extern INT mult_integer(); extern INT mult_integer_bruch(); extern INT mult_integer_hashtable(); extern INT mult_integer_integer(); extern INT mult_integer_longint(); extern INT mult_integer_monom(); extern INT multiplicity_part(); extern INT mult_kranz_kranz(); extern INT mult_laurent(); extern INT mult_longint(); extern INT mult_longint_integer(); extern INT mult_longint_integer_via_ganzsmul(); extern INT mult_longint_longint(); extern INT mult_matrix(); extern INT mult_matrix_matrix(); extern INT mult_matrix_vector(); extern INT mult_monom(); extern INT mult_monomial(); extern INT mult_monomial_elmsym(); extern INT mult_monomial_homsym(); extern INT mult_monomial_monomial(); extern INT mult_monomial_powsym(); extern INT mult_monomial_scalar(); extern INT mult_monomial_schur(); extern INT mult_monopoly(); extern INT mult_monopoly_monopoly(); extern INT mult_monopoly_polynom(); extern INT mult_nc_kranz(); extern INT mult_perm_fix(); extern INT mult_permutation(); extern INT mult_polynom(); extern INT mult_polynom_polynom(); extern INT mult_power_schur(); extern INT mult_powsym(); extern INT mult_powsym_elmsym(); extern INT mult_powsym_homsym(); extern INT mult_powsym_monomial(); extern INT mult_powsym_powsym(); extern INT mult_powsym_scalar(); extern INT mult_powsym_schur(); extern INT mult_reihe(); extern INT mult_scalar_cyclo(); extern INT mult_scalar_gral(); extern INT mult_scalar_matrix(); extern INT mult_scalar_monom(); extern INT mult_scalar_monopoly(); extern INT mult_scalar_polynom(); extern INT mult_scalar_schubert(); extern INT mult_scalar_sqrad(); extern INT mult_scalar_symchar(); extern INT mult_scalar_vector(); extern INT mult_schubert_monom(); extern INT mult_schubert_polynom(); extern INT mult_schubert_schubert(); extern INT mult_schubert_variable (); extern INT mult_schur(); extern INT mult_schur_elmsym(); extern INT mult_schur_homsym(); extern INT mult_schur_monomial(); extern INT mult_schur_powsym(); extern INT mult_schur_scalar(); extern INT mult_schur_schur(); extern INT mult_schur_schur_maxlength(); extern INT mult_schur_schur_maxpart_maxlength(); extern INT mult_schur_schur_maxpart_maxlength(); extern INT mult_sqrad(); extern INT mult_sqrad_sqrad(); extern INT mult_symchar_symchar(); extern INT mult_vector_matrix(); extern INT mult_vector_vector(); extern INT m_umriss_tableaux(); extern INT m_us_t(); extern INT m_u_t(); extern INT m_vcl_kranz(); extern INT m_vco_kranz(); extern INT m_vec_grad_nc_hyp(); extern INT m_vec_poly(); extern INT m_vector_diagonalmatrix(); extern INT m_vector_ff(); extern INT m_vector_graph(); extern INT m_vec_vec_poly(); extern INT m_v_pa(); extern INT m_v_po_mz(); extern INT m_v_s(); extern INT m_word_wt(); extern INT m_wpd_sc(); extern INT m_wt_tableaux(); extern INT m_wttab_tableaux(); extern INT m_wt_wtkontertab(); extern INT m_wt_wttab(); extern INT mx_outerproduct_schur_lrs(); extern INT mx_powerproduct_schur_plet(); extern INT mx_power_schur_plet(); extern INT mx_schur_powerproduct_schur_plet_mult(); extern INT mx_schur_power_schur_plet_mult(); extern INT mx_schur_schur_plet(); extern INT mx_schur_schur_pletbis(); extern INT mxx_null__(); extern INT mxx_null__(); extern INT mxx_null__(); extern INT mxx_null__(); extern INT mxx_null__(); extern INT my_conjugation(); extern INT my_quasinormalform_neu(); extern INT mz_extrahieren(); extern INT mz_vereinfachen(); extern INT nachfolger_young(); extern INT nb_ende(); extern INT ndg(); extern INT negeinsp(); extern INT negeinsp_bruch(); extern INT negeinsp_integer(); extern INT negeinsp_longint(); extern INT negeinsp_polynom(); extern INT negp(); extern INT negp_bruch(); extern INT negp_integer(); extern INT negp_longint(); extern INT negp_polynom(); extern INT neg_sum(); extern INT neq(); extern INT neqparts_partition(); extern INT new_divdiff_bar(); extern INT new_divideddifference_bar(); extern INT new_divideddiff_rz_bar(); extern INT new_orbit(); extern INT newtrans_eins(); extern INT newtrans_lehmer(); extern INT newtrans_limitfunction(); extern INT newtrans_limit_limitfunction(); extern INT newtrans_maxpart_maxlength(); extern INT newtrans_maxpart_maxlength(); extern INT newtrans_maxpart(); extern INT newtrans(); extern INT next_apply_bar(); extern INT next_apply_composition(); extern INT next_apply_ff(); extern INT next_apply_gr(); extern INT next_apply(); extern INT next_apply_partition(); extern INT next_apply_permutation(); extern INT next_apply_subset(); extern INT next_bar(); extern INT next_composition(); extern INT next_ff(); extern INT next_gfp_vector(); extern INT next_gfp_vector(); extern INT next_gr(); extern INT next_kranztypus(); extern INT next_lehmercode(); extern INT next_lex_tableaux(); extern INT next_lex_vector(); extern INT next_part_EXPONENT_apply(); extern INT next_part_EXPONENT(); extern INT next_partition_apply(); extern INT next_partition(); extern INT next_part_VECTOR_apply(); extern INT next_part_VECTOR(); extern INT next_perm_invers(); extern INT next_permutation(); extern INT next_permutation_lex(); extern INT next_pgp_vector(); extern INT next_pgp_vector(); extern INT next_shuffle_part(); extern INT next_shufflepermutation(); extern INT next_shufflevector(); extern INT next_subset(); extern INT next(); extern INT n_fold_kronecker_product(); extern INT no_memory(); extern INT no_orbits_arb(); extern INT normal_laurent(); extern INT not_yet_implemented(); extern INT nth_root_ff_given_q(); extern INT ntopaar_symchar(); extern INT null(); extern INT null_default(); extern INT null_ff(); extern INT null_ff_given_q(); extern INT null_galois(); extern INT null_gr_given_c_d(); extern INT null_object(); extern INT nullp(); extern INT nullp_bitvector(); extern INT nullp_bruch(); extern INT nullp_cyclo(); extern INT nullp_elmsym(); extern INT nullp_ff(); extern INT nullp_galois(); extern INT nullp_homsym(); extern INT nullp_integer(); extern INT nullp_integermatrix(); extern INT nullp_integervector(); extern INT nullp_longint(); extern INT nullp_matrix(); extern INT nullp_monomial(); extern INT nullp_monopoly(); extern INT nullp_polynom(); extern INT nullp_powsym(); extern INT nullp_reihe(); extern INT nullp_schubert(); extern INT nullp_schur(); extern INT nullp_sqrad(); extern INT nullp_symchar(); extern INT nullp_vector(); extern INT number_01_matrices(); extern INT number_nat_matrices(); extern INT number_of_bits(); extern INT numberof_class_kranz(); extern INT number_of_digits(); extern INT numberof_inversionen(); extern INT number_of_irred_poly_of_degree(); extern INT numberofmonomials(); extern INT numberofpart_i(); extern INT numberofpart(); extern INT numberofparts_exact_parts(); extern INT numberofparts_ge(); extern INT numberofparts_le_parts(); extern INT numberofselfconjugatepart(); extern INT numberof_shufflepermutation(); extern INT number_of_subspaces(); extern INT number_of_subspaces(); extern INT numberofvariables(); extern INT nu_v_v_pgp(); extern INT nu_v_v_pgp(); extern INT nxt_ym(); extern INT objectread_bruch(); extern INT objectread_bv(); extern INT objectread_ff(); extern INT objectread(); extern INT objectread_gral(); extern INT objectread_hashtable(); extern INT objectread_integer(); extern INT objectread_list(); extern INT objectread_longint(); extern INT objectread_matrix(); extern INT objectread_monom(); extern INT objectread_monopoly(); extern INT objectread_number(); extern INT objectread_partition(); extern INT objectread_permutation(); extern INT objectread_schur(); extern INT objectread_skewpartition(); extern INT objectread_symchar(); extern INT objectread_tableaux(); extern INT objectread_vector(); extern INT objectwrite_bruch(); extern INT objectwrite_bv(); extern INT objectwrite_ff(); extern INT objectwrite(); extern INT objectwrite_gral(); extern INT objectwrite_hashtable(); extern INT objectwrite_integer(); extern INT objectwrite_list(); extern INT objectwrite_longint(); extern INT objectwrite_matrix(); extern INT objectwrite_monom(); extern INT objectwrite_number(); extern INT objectwrite_partition(); extern INT objectwrite_permutation(); extern INT objectwrite_schur(); extern INT objectwrite_skewpartition(); extern INT objectwrite_symchar(); extern INT objectwrite_tableaux(); extern INT objectwrite_vector(); extern INT odd(); extern INT oddify_longint(); extern INT oddify_longint(); extern INT odd_longint(); extern INT oddpartsp(); extern INT odd_to_strict_part(); extern INT odg(); extern INT old_number_01_matrices(); extern INT operate_gral_polynom(); extern INT operate_perm_bideterminant(); extern INT operate_perm_polynom(); extern INT operate_perm_spaltenmatrix(); extern INT operate_perm_tableaux(); extern INT operate_perm_vector(); extern INT operate_perm_zeilenmatrix(); extern INT orbit(); extern INT orbit_set_max_size(); extern INT orbit_words(); extern INT orblen(); extern INT or_character (); extern INT ordcen_bar(); extern INT ordcen(); extern INT ordcon_bar(); extern INT ordcon(); extern INT order_class_kranz(); extern INT order_ff(); extern INT order_permutation(); extern INT or_dimension (); extern INT ordnung_affkq(); extern INT ordnung_glkq(); extern INT or_tableaux (); extern INT outerproduct_schubert(); extern INT outerproduct_schur(); extern INT outerproduct_schur_limit(); extern INT outerproduct_schur_limitfunction(); extern INT outerproduct_schur_limit_limitfunction(); extern INT outerproduct_schur_lrs(); extern INT p2_schursum(); extern INT p2_schursum(); extern INT part_anfang(); extern INT part_comp(); extern INT part_ende(); extern INT partitionp(); extern INT part_part_skewschur(); extern INT perm_anfang(); extern INT Perm_eingabe(); extern INT perm_ende(); extern INT perm_matrix(); extern INT perm_matrix_p(); extern INT perm_tableaux(); extern INT permutation_matrix(); extern INT permutationp(); extern INT permutationsdarstellung_matrix_pgl(); extern INT permutationsdarstellung_matrix_pgl(); extern INT perm_weintraube(); extern INT pes___(); extern INT pes___(); extern INT pes_elmsym__(); extern INT pes_ende(); extern INT pes_hashtable__(); extern INT pes_integer__(); extern INT pes_integer_hashtable_(); extern INT pes_integer_hashtable_(); extern INT pes_integer_partition_(); extern INT pes_integer_partition_(); extern INT pes_null__(); extern INT pes_null_partition_(); extern INT pes_null_partition_(); extern INT pes_partition__(); extern INT pfact(); extern INT pfaffian_matrix(); extern INT pgcd(); extern INT phm___(); extern INT phm___(); extern INT phm_ende(); extern INT phm_hashtable__(); extern INT phm_hashtable_hashtable_(); extern INT phm_homsym__(); extern INT phm_integer__(); extern INT phm_integer_hashtable_(); extern INT phm_integer_hashtable_(); extern INT phm_integer_integer_(); extern INT phm_integer_integer_(); extern INT phm_integer_partition_(); extern INT phm_integer_partition_(); extern INT phm_null__(); extern INT phm_null_partition_(); extern INT phm_null_partition_(); extern INT phm_partition__(); extern INT p_hook_diagramm(); extern INT p_hook_weight(); extern INT phs___(); extern INT phs___(); extern INT phs___(); extern INT phs_ende(); extern INT phs_hashtable__(); extern INT phs_homsym__(); extern INT phs_integer__(); extern INT phs_integer_hashtable_(); extern INT phs_integer_hashtable_(); extern INT phs_integer_partition_(); extern INT phs_integer_partition_(); extern INT phs_null__(); extern INT phs_null_partition_(); extern INT phs_partition__(); extern INT pictex_skwt_liste(); extern INT pictex_snwt_liste(); extern INT pictex_wt(); extern INT pictex_wt_liste(); extern INT pictex_wt_liste_co(); extern INT planep(); extern INT plane_tableau(); extern INT plaziere_verband(); extern INT plet_elmsym_elmsym(); extern INT plet_elmsym_homsym(); extern INT plet_elmsym_monomial(); extern INT plet_elmsym_powsym(); extern INT plet_elmsym_schur(); extern INT plet_homsym_elmsym(); extern INT plet_homsym_homsym(); extern INT plet_homsym_monomial(); extern INT plet_homsym_monomial_via_ppm(); extern INT plet_homsym_powsym(); extern INT plet_homsym_schur(); extern INT plethysm(); extern INT plethysm_schur_monomial(); extern INT plethysm_schur_schur(); extern INT plet_monomial_elmsym(); extern INT plet_monomial_homsym(); extern INT plet_monomial_monomial(); extern INT plet_monomial_powsym(); extern INT plet_monomial_schur(); extern INT plet_powsym_elmsym(); extern INT plet_powsym_homsym(); extern INT plet_powsym_monomial(); extern INT plet_powsym_powsym(); extern INT plet_powsym_schur(); extern INT plet_powsym_schur_via_ppm(); extern INT plet_schur_elmsym(); extern INT plet_schur_elmsym_pre101201(); extern INT plet_schur_homsym(); extern INT plet_schur_monomial(); extern INT plet_schur_monomial_new(); extern INT plet_schur_powsym(); extern INT plet_schur_schur(); extern INT plet_schur_schur_pol(); extern INT plet_schur_schur_via_phs(); extern INT pl_j_wt(); extern INT pn_character (); extern INT pn_dimension (); extern INT pn_tableaux (); extern INT point(); extern INT pol_sd_wt(); extern INT pol_sn_wt(); extern INT pol_wt(); extern INT polya1_sub(); extern INT polya2_sub(); extern INT polya3_sub(); extern INT polya_const_sub(); extern INT polya_multi_const_sub(); extern INT polya_multi_sub(); extern INT polya_n_sub(); extern INT polya_sub(); extern OP pop(); extern INT posp(); extern INT posp_bruch(); extern INT posp_integer(); extern INT posp_longint(); extern INT posp_polynom(); extern INT posp_vector(); extern INT pos_sum(); extern INT powerproduct_schur_plet(); extern INT power_schur_plet(); extern INT power_schur_plet_old(); extern INT ppe___(); extern INT ppe___(); extern INT ppe___(); extern INT ppe___(); extern INT ppe___(); extern INT ppe___(); extern INT ppe_ende(); extern INT ppe_hashtable__(); extern INT ppe_hashtable_hashtable_(); extern INT ppe_integer__(); extern INT ppe_integer_hashtable_(); extern INT ppe_integer_hashtable_(); extern INT ppe_integer_integer_(); extern INT ppe_integer_partition_(); extern INT ppe_integer_partition_(); extern INT ppe_null__(); extern INT ppe_null_partition_(); extern INT ppe_null_partition_(); extern INT ppe_partition__(); extern INT ppe_powsym__(); extern INT pph___(); extern INT pph___(); extern INT pph___(); extern INT pph___(); extern INT pph___(); extern INT pph___(); extern INT pph_ende(); extern INT pph_hashtable__(); extern INT pph_hashtable_hashtable_(); extern INT pph_integer__(); extern INT pph_integer_hashtable_(); extern INT pph_integer_hashtable_(); extern INT pph_integer_integer_(); extern INT pph_integer_integer_(); extern INT pph_integer_partition_(); extern INT pph_integer_partition_(); extern INT pph_null__(); extern INT pph_null_partition_(); extern INT pph_null_partition_(); extern INT pph_partition__(); extern INT pph_powsym__(); extern INT ppm___(); extern INT ppm___(); extern INT ppm___(); extern INT ppm___(); extern INT ppm___(); extern INT ppm_ende(); extern INT ppm_hashtable__(); extern INT ppm_hashtable_hashtable_(); extern INT ppm_integer__(); extern INT ppm_integer_hashtable_(); extern INT ppm_integer_hashtable_(); extern INT ppm_integer_integer_(); extern INT ppm_integer_integer_(); extern INT ppm_integer_partition_(); extern INT ppm_integer_partition_(); extern INT ppm_null__(); extern INT ppm_null_partition_(); extern INT ppm_null_partition_(); extern INT ppm_partition__(); extern INT ppm_powsym__(); extern INT ppp___(); extern INT ppp___(); extern INT ppp___(); extern INT ppp___(); extern INT ppp_ende(); extern INT ppp_hashtable__(); extern INT ppp_hashtable_hashtable_(); extern INT ppp_integer__(); extern INT ppp_integer_hashtable_(); extern INT ppp_integer_hashtable_(); extern INT ppp_integer_partition_(); extern INT ppp_integer_partition_(); extern INT ppp_null__(); extern INT ppp_null_partition_(); extern INT ppp_null_partition_(); extern INT ppp_partition__(); extern INT ppp_powsym__(); extern INT pps___(); extern INT pps_ende(); extern INT pps_hashtable__(); extern INT pps_hashtable_hashtable_(); extern INT pps_integer__(); extern INT pps_null__(); extern INT pps_null_partition_(); extern INT pps_null_partition_(); extern INT pps_partition__(); extern INT pps_powsym__(); extern INT prepartdom(); extern INT primep(); extern INT primep_ff(); extern INT prime_power_p(); extern INT primitive_element_ff_given_q(); extern INT primitive_element_ff(); extern INT print_cyclo_data(); extern INT print_cyclo_list(); extern INT print_cyclo_table(); extern INT printeingabe(); extern INT println_bm(); extern INT println(); extern INT println_schub_lehmer(); extern INT printobjectkind(); extern INT print(); extern INT print_schubert_difference(); extern INT print_stat_hashtable(); extern INT print_time(); extern INT print_type(); extern INT pr_j_wt(); extern INT p_root_part(); extern INT p_root_schur(); extern INT prsym(); extern INT p_schursum(); extern INT p_schursum(); extern INT psh___(); extern INT psh_ende(); extern INT psh_hashtable__(); extern INT psh_integer__(); extern INT psh_integer_homsym_(); extern INT psh_null__(); extern INT psh_partition__(); extern INT psh_partition__(); extern INT psh_partition_homsym_(); extern INT psh_partition_partition_(); extern INT psh_schur__(); extern INT psl_apply_i_integer(); extern INT psl_apply_i_longint(); extern INT psl_apply_longint(); extern INT psm___(); extern INT psm_ende(); extern INT p_splitpart(); extern INT p_splitpart2(); extern INT p_splitpart(); extern INT psr_apply_i_integer(); extern INT psr_apply_i_longint(); extern INT pss___(); extern INT pss___(); extern INT pss_ende(); extern INT pss_hashtable__(); extern INT pss_hashtable_hashtable_(); extern INT pss_integer__(); extern INT pss_integer_hashtable_(); extern INT pss_integer_hashtable_(); extern INT pss_integer_integer_(); extern INT pss_integer_integer_(); extern INT pss_integer_partition_(); extern INT pss_integer_partition_(); extern INT pss_integer_schur_(); extern INT pss_null__(); extern INT pss_null_partition_(); extern INT pss_null_partition_(); extern INT pss_partition__(); extern INT pss_partition_hashtable_(); extern INT pss_partition_partition_(); extern INT pss_partition_partition_(); extern INT pss_partition_schur_(); extern INT pss_partition_schur_(); extern INT pss_schur__(); extern INT pss_schur__(); extern INT P_symmetrized_bideterminant(); extern INT push(); extern INT put_exactlength_limit_schur(); extern INT put_length_limit_schur(); extern INT q_core(); extern INT q_core_sign(); extern INT qdimension(); extern INT qdimension_schubert(); extern INT qsort_vector(); extern INT quadraticp(); extern INT quadratic_remainders(); extern INT quasi_normal_form(); extern INT quasinormalform(); extern INT quasi_normal_form(); extern INT quores(); extern INT quores_integer(); extern INT quores_longint(); extern INT quores_monopoly(); extern INT quores_monopoly_pre300402(); extern INT raise_power_monopoly(); extern INT random_adjacency_matrix(); extern INT random_bar(); extern INT random_bruch(); extern INT random_bv(); extern INT random_char_ff(); extern INT random_ff(); extern INT random_ff_given_q(); extern INT random_generator_diag_subgroup(); extern INT random_generator_sk_subgroup(); extern INT random_generator_small_glkq_singersubgroup(); extern INT random_gral(); extern INT random_gr_given_c_d(); extern INT random_integer(); extern INT random_integervector(); extern INT random_kranz(); extern INT random_longint(); extern INT random_monom(); extern INT random_part_EXPONENT(); extern INT random_partition_exponent(); extern INT random_partition(); extern INT random_permutation(); extern INT random_polynom(); extern INT random_reihe(); extern INT random_subgroup_glk_grcd_2gen(); extern INT random_subgroup_glk_grcd_cyclic(); extern INT random_subgroup_glk_grcd_diagonal(); extern INT random_subgroup_glk_grcd(); extern INT random_subgroup_glk_grcd_smaller_k(); extern INT random_subgroup_glk_grcd_stabilizer(); extern INT random_subgroup_glkq(); extern INT random_subgroup_glkq_1gen(); extern INT random_subgroup_glkq_2gen(); extern INT random_subgroup_glkq_2gen(); extern INT random_subgroup_glkq_3gen(); extern INT random_subgroup_glkq_3gen(); extern INT random_subgroup_glkq_block(); extern INT random_subgroup_glkq_cyclic(); extern INT random_subgroup_glkq_cyclic(); extern INT random_subgroup_glkq_diagonal(); extern INT random_subgroup_glkq_diagonal(); extern INT random_subgroup_glkq(); extern INT random_subgroup_glkq_perm_cyclic(); extern INT random_subgroup_glkq_perm_cyclic(); extern INT random_subgroup_glkq_perm_diagonal(); extern INT random_subgroup_glkq_perm(); extern INT random_subgroup_glkq_prim(); extern INT random_subgroup_glkq_prim(); extern INT random_subgroup_glkq_smaller_k(); extern INT random_subgroup_glkq_smaller_k(); extern INT random_subgroup_glkq_upper_cyclic(); extern INT random_subgroup_glkq_upper_cyclic(); extern INT random_word(); extern INT rank(); extern INT rank_ff(); extern INT rank_k_subset(); extern INT rank_line(); extern INT rank_permutation(); extern INT rank_point(); extern INT red_dia_perm(); extern INT redf_cap(); extern INT redf_cap_hoch(); extern INT redf_cup(); extern INT redf_cup_hoch(); extern INT reduce_ff(); extern INT reduce_inner_tensor_sc(); extern INT reduce_nc(); extern INT reduce_nc_kranz(); extern INT reduceninpaar(); extern INT reduce_symchar(); extern INT reduce_symchar_tafel(); extern INT reell_gram_schmidt(); extern INT reell_gram_schmidt(); extern INT release_numbers(); extern INT remove_hook(); extern INT remove_mp_qnumber_fac (); extern INT removepartij(); extern INT remove_part_integer(); extern INT remove_part_part(); extern INT remove_vec_qnumber (); extern INT remove_zero_terms(); extern INT reorder_hall_littlewood(); extern INT reorder_schur(); extern INT reorder_vector(); extern INT reorder_vector_apply(); extern INT represent_hecke_element (); extern INT reset_basis(); extern INT reset_saving(); extern INT reverse_bitvector(); extern INT reverse_vector(); extern INT rg_factorize(); extern INT rg_order_ff(); extern INT rg_quasi_normal_form(); extern INT rh_test(); extern INT ribbon_matrix(); extern INT ribbon_partition(); extern INT rightkey_wt(); extern INT rindexword_sub(); extern INT rindexword(); extern INT rm_rindex(); extern INT root_dimension (); extern INT root_normalise_monopoly (); extern INT root_represent_hecke_action (); extern INT root_standardise_cold_tableaux_list (); extern INT row_column_matrices(); extern INT rowwordoftableaux(); extern INT R_roftableaux(); extern INT runtime(); extern INT rz(); extern INT rz_bar(); extern INT rz_Dn(); extern INT rz_lehmercode_bar(); extern INT rz_lehmercode(); extern INT rz_perm(); extern INT sab(); extern INT sab_input(); extern INT S_a_rofword(); extern INT save_cyclo_list(); extern INT Sbar_nkq_maxgrad(); extern INT Sbar_nkq_maxgrad(); extern INT s_b_i(); extern INT s_bm_hi(); extern INT s_bm_li(); extern OP s_b_o(); extern INT s_b_oi(); extern OP s_b_u(); extern INT s_b_ui(); extern INT s_bv_li(); extern INT scalarp(); extern INT scalarproduct(); extern INT scalarproduct_bar_schubert(); extern INT scalarproduct_elmsym(); extern INT scalarproduct_homsym(); extern INT scalarproduct_homsym_monomial(); extern INT scalarproduct_monomial(); extern INT scalarproduct_nc(); extern INT scalarproduct_powsym(); extern INT scalarproduct_powsym_powsym(); extern INT scalarproduct_schubert(); extern INT scalarproduct_schur(); extern INT scalarproduct_schur_schur(); extern INT scalarproduct_symchar(); extern INT scalarproduct_vector(); extern INT scale_monopoly(); extern INT scan_bar(); extern INT scan_bitvector(); extern INT scan_bruch(); extern INT scan_cyclo(); extern INT scan_elmsym(); extern INT scan_exponentpartition(); extern INT scan_fastpolynom(); extern INT scan_ff(); extern INT scan_galois(); extern INT scan_gl_nc(); extern INT scan_gral(); extern INT scan_homsym(); extern INT scan_integerbruch(); extern INT scan_integer(); extern INT scan_integermatrix(); extern INT scan_integervector(); extern INT scan(); extern INT scan_kostka(); extern INT scan_kranz(); extern INT scan_laurent(); extern INT scan_list(); extern INT scan_longint(); extern INT scan_matrix(); extern INT scan_monom(); extern INT scan_monomial(); extern INT scan_monopoly(); extern INT scan_nc_kranz(); extern OBJECTKIND scanobjectkind(); extern INT scan_partition(); extern INT scan_parttableaux(); extern INT scan_permutation(); extern INT scan_permutation_cycle(); extern INT scan_permvector(); extern INT scan_polynom(); extern INT scan_powsym(); extern INT scan_printeingabe(); extern INT scan_reihe(); extern INT scan_reversepartition(); extern INT scan_schubert(); extern INT scan_schur(); extern INT scan_skewpartition(); extern INT scan_skewsymmetric_matrix(); extern INT scan_skewtableaux(); extern INT scan_sqrad(); extern INT scan_symchar(); extern INT scan_tableaux(); extern INT scan_vector(); extern INT scan_word(); extern INT schensted_row_delete_step(); extern INT schensted_row_insert_step(); extern INT schen_word(); extern INT schicht_print(); extern INT schnitt_mat(); extern INT schnitt_schur(); extern INT schubertp(); extern INT schur_ende(); extern INT schur_part_skewschur(); extern INT schur_powerproduct_schur_plet_mult(); extern INT schur_power_schur_plet_mult(); extern INT schur_schur_pletbis(); extern INT schur_schur_plet(); extern INT sdg(); extern INT sd_i_wt(); extern INT Sd_wt(); extern INT select_coeff_polynom(); extern INT select_coeff_reihe(); extern INT select_column(); extern INT select_column_tableaux(); extern INT select_degree_reihe(); extern OP select_i(); extern INT select_row(); extern INT select_row_tableaux(); extern INT set_bm_ij(); extern INT set_bv_i(); extern INT set_cyclotomic_parameters (); extern INT set_lo_nopoint(); extern INT set_root_parameters (); extern INT set_tex_polynom_parameter(); extern INT setup_numbers(); extern INT set_useful_monopolies (); extern OP s_ff_c(); extern INT s_ff_ci(); extern INT s_ff_di(); extern INT s_ff_ii(); extern OBJECTKIND s_gr_k(); extern OP s_gr_kn(); extern OP s_gr_kni(); extern OP s_gr_koor(); extern OP s_gr_koori(); extern OP s_gr_na(); extern OP s_gr_nai(); extern OP s_gr_s(); extern OP s_gr_xkoori(); extern OP s_gr_ykoori(); extern INT signum(); extern INT signum_permutation(); extern INT s_i_i(); extern INT singularp(); extern INT Sinus_eingabe(); extern INT s_i_wt(); extern INT skewpartitionp(); extern INT skewplane_plane(); extern INT skip_comment(); extern INT skip_integer(); extern INT skip(); extern INT s_ki_wt(); extern OP s_kr_g(); extern OP s_kr_gi(); extern OP s_kr_gl(); extern INT s_kr_gli(); extern OP s_kr_i(); extern OP s_kr_v(); extern INT Sk_wt(); extern OP s_lc_poly(); extern OP s_l_n(); extern OP s_l_s(); extern OP s_m_h(); extern INT s_m_hash(); extern INT s_m_hi(); extern OP s_m_ij(); extern INT s_m_iji(); extern OP s_m_l(); extern INT s_m_li(); extern OP s_mo_k(); extern INT s_mo_ki(); extern OP s_mo_s(); extern OP s_mo_si(); extern INT s_mo_sii(); extern OP s_mo_sl(); extern INT s_mo_sli(); extern OP s_m_s(); extern OP s_mz_po(); extern OP s_mz_v(); extern OP s_mz_vi(); extern INT s_mz_vii(); extern INT sn_character (); extern OP s_n_d(); extern OP s_n_dcd(); extern OP s_n_dci(); extern OP s_n_dcp(); extern INT sn_dimension (); extern INT s_ni_wt(); extern INT S_nkq_maxgrad(); extern INT S_nkq_maxgrad(); extern OP s_n_s(); extern INT sn_tableaux (); extern INT sn_weintraube(); extern INT Sn_wt(); extern INT so_character (); extern INT so_dimension (); extern OBJECTKIND s_o_k(); extern INT sort(); extern INT sort_rows_tableaux_apply(); extern INT sort_vector(); extern OBJECTSELF s_o_s(); extern INT so_tableaux (); extern INT s_pa_hash(); extern OP s_pa_i(); extern INT s_pa_ii(); extern OBJECTKIND s_pa_k(); extern OP s_pa_l(); extern INT s_pa_li(); extern INT spaltenanfang(); extern INT spaltenende(); extern INT spalten_summe(); extern OP s_pa_s(); extern INT sp_br(); extern INT sp_character (); extern INT sp_dimension (); extern INT specht_dg(); extern INT specht_irred_characteristik(); extern INT specht_m_part_sc(); extern INT specht_poly(); extern INT specht_powersum(); extern INT special_eq(); extern INT special_mult_apply_homsym_homsym(); extern INT speicher_anfang(); extern INT speicher_ende(); extern OP s_p_i(); extern INT s_p_ii(); extern INT spin_tableaux_character (); extern OBJECTKIND s_p_k(); extern OP s_p_l(); extern INT s_p_li(); extern INT split_hashtable(); extern INT split(); extern INT splitpart(); extern INT splitpart(); extern INT splitpart(); extern OP s_po_k(); extern INT s_po_ki(); extern OP s_po_n(); extern OP s_po_s(); extern OP s_po_si(); extern INT s_po_sii(); extern OP s_po_sl(); extern INT s_po_sli(); extern INT sprint_ff(); extern INT sprint_integer(); extern INT sprint_integervector(); extern INT sprint_longint(); extern INT sprint_partition(); extern INT sprint_permutation(); extern INT sprint_skewpartition(); extern INT sprint(); extern INT sprint_vector(); extern OP s_p_s(); extern INT sp_tableaux (); extern INT square_apply(); extern INT square_apply_integer(); extern INT square_apply_longint(); extern INT square_free_part_0(); extern INT square_free_part(); extern INT squareroot(); extern INT squareroot_bruch(); extern INT squareroot_integer(); extern INT squareroot_longint(); extern INT S_rofword(); extern INT sscan_bar(); extern INT sscan_bitvector(); extern INT sscan_elmsym(); extern INT sscan_homsym(); extern INT sscan_integer(); extern INT sscan_integervector(); extern INT sscan_longint(); extern INT sscan_partition(); extern INT sscan_permutation(); extern INT sscan_permvector(); extern INT sscan_reversepartition(); extern INT sscan_schur(); extern INT sscan(); extern INT sscan_word(); extern OP s_sc_d(); extern INT s_sc_di(); extern OP s_sch_k(); extern INT s_sch_ki(); extern OP s_sch_n(); extern OP s_sch_s(); extern OP s_sch_si(); extern INT s_sch_sii(); extern OP s_sch_sl(); extern INT s_sch_sli(); extern OP s_sc_p(); extern OP s_sc_pi(); extern INT s_sc_pli(); extern OP s_sc_w(); extern OP s_sc_wi(); extern INT s_sc_wii(); extern INT s_sc_wli(); extern OP s_s_k(); extern INT s_s_ki(); extern OP s_s_n(); extern OP s_spa_g(); extern OP s_spa_gi(); extern INT s_spa_gii(); extern INT s_spa_gli(); extern OP s_spa_k(); extern OP s_spa_ki(); extern INT s_spa_kii(); extern INT s_spa_kli(); extern OP s_s_s(); extern OP s_s_si(); extern INT s_s_sii(); extern OP s_s_sl(); extern INT s_s_sli(); extern INT standardise_cold_tableaux_list (); extern INT standardise_cyclo(); extern INT standardp(); extern INT starpart(); extern INT starting_bar_schubert(); extern INT start_longint(); extern INT starttableaux(); extern INT std_perm(); extern OP s_t_h(); extern INT s_t_hi(); extern OP s_t_ij(); extern INT s_t_iji(); extern INT stirling_first_tafel(); extern INT stirling_numbers_second_kind_vector(); extern INT stirling_second_number_kostka(); extern INT stirling_second_number(); extern INT stirling_second_number_tafel(); extern INT stirling_second_tafel(); extern OP s_t_l(); extern INT s_t_li(); extern INT store_result_0(); extern INT store_result_1(); extern INT store_result_2(); extern INT store_result_3(); extern INT store_result_4(); extern INT store_result_5(); extern INT strictp(); extern INT strict_to_odd_part(); extern INT strong_check_barp(); extern INT strong_check_permutationp(); extern INT strong_generators(); extern OP s_t_s(); extern OP s_t_u(); extern OP s_t_ug(); extern INT s_t_ugii(); extern INT s_t_ugli(); extern OP s_t_ui(); extern INT s_t_uii(); extern OP s_t_uk(); extern INT s_t_ukii(); extern INT s_t_ukli(); extern OP s_t_ul(); extern INT s_t_uli(); extern OP s_t_us(); extern INT sub(); extern INT sub_apply(); extern INT sub_comp_bv(); extern INT sub_comp_part(); extern INT sub_default(); extern INT sub_part_part(); extern INT substitute_one_matrix (); extern INT substitute_one_monopoly (); extern INT sum(); extern INT sum_integervector(); extern INT sum_matrix(); extern INT sum_vector(); extern INT sup_bitvector_apply(); extern INT sup_bitvector(); extern OP s_v_i(); extern INT s_v_ii(); extern OP s_v_l(); extern INT s_v_li(); extern OP s_v_s(); extern INT swap(); extern OP s_w_i(); extern INT s_w_ii(); extern OP s_w_l(); extern INT s_w_li(); extern OP s_w_s(); extern INT S_wt(); extern INT s_x_nu_to_ypolynom(); extern INT symchar_hoch_n(); extern INT SYMMETRICA_bricknumber(); extern INT SYMMETRICA_EH(); extern INT SYMMETRICA_EM(); extern INT SYMMETRICA_EP(); extern INT SYMMETRICA_ES(); extern INT SYMMETRICA_HE(); extern INT SYMMETRICA_HM(); extern INT SYMMETRICA_HP(); extern INT SYMMETRICA_HS(); extern INT SYMMETRICA_ME(); extern INT SYMMETRICA_MH(); extern INT SYMMETRICA_MP(); extern INT SYMMETRICA_MS(); extern INT SYMMETRICA_PE(); extern INT SYMMETRICA_PH(); extern INT SYMMETRICA_PM(); extern INT SYMMETRICA_PS(); extern INT SYMMETRICA_SE(); extern INT SYMMETRICA_SH(); extern INT SYMMETRICA_SM(); extern INT SYMMETRICA_SP(); extern INT symmetricp(); extern INT symmetricp_i(); extern INT symmetricp_matrix(); extern INT t_2SCHUBERT_POLYNOM(); extern INT tab_anfang(); extern INT tab_ende(); extern INT tab_funk(); extern INT tableaux_character (); extern INT tableauxp(); extern INT table_of_gauss_numbers(); extern INT table_of_Rbar_nkq(); extern INT table_of_R_nkq(); extern INT table_of_Sbar_nkq(); extern INT table_of_S_nkq(); extern INT table_of_Tbar_nkq(); extern INT table_of_T_nkq(); extern INT table_of_W_nkq(); extern INT tab_wt(); extern INT t_augpart_part(); extern INT t_BAR_BARCYCLE(); extern INT t_BARCYCLE_BAR(); extern INT t_bar_doubleperm(); extern INT Tbar_nkq_file(); extern INT Tbar_nkq_maxgrad(); extern INT Tbar_nkq_maxgrad(); extern INT t_BINTREE_ELMSYM(); extern INT t_BINTREE_ELMSYM_apply(); extern INT t_BINTREE_GRAL(); extern INT t_BINTREE_HOMSYM(); extern INT t_BINTREE_HOMSYM_apply(); extern INT t_BINTREE_LIST(); extern INT t_BINTREE_MONOMIAL(); extern INT t_BINTREE_MONOMIAL_apply(); extern INT t_BINTREE_POLYNOM(); extern INT t_BINTREE_POLYNOM_apply(); extern INT t_BINTREE_POWSYM(); extern INT t_BINTREE_POWSYM_apply(); extern INT t_BINTREE_SCHUBERT(); extern INT t_BINTREE_SCHUR(); extern INT t_BINTREE_SCHUR_apply(); extern INT t_BINTREE_VECTOR(); extern INT t_BIT_VECTOR(); extern INT t_BITVECTOR_INTVECTOR(); extern INT t_BRUCH_LAURENT(); extern INT teh_elmsym__faktor(); extern INT teh_ende(); extern INT teh___faktor(); extern INT teh_hashtable__faktor(); extern INT teh_integer__faktor(); extern INT teh_integer__faktor(); extern INT teh_partition__faktor(); extern INT teh_partition__faktor_pre290102(); extern INT t_ELMSYM_ELMSYM(); extern INT t_ELMSYM_HASHTABLE(); extern INT t_ELMSYM_HOMSYM(); extern INT t_ELMSYM_MONOMIAL(); extern INT t_ELMSYM_POWSYM(); extern INT t_ELMSYM_SCHUR(); extern INT t_ELMSYM_SCHUR_pre041201(); extern INT tem_ende(); extern INT tem_integer__faktor(); extern INT tem_integer__faktor(); extern INT tem_partition__faktor(); extern INT tep_elmsym__faktor(); extern INT tep_ende(); extern INT tep___faktor(); extern INT tep___faktor(); extern INT tep___faktor(); extern INT tep___faktor(); extern INT tep___faktor(); extern INT tep___faktor(); extern INT tep_hashtable__faktor(); extern INT tep_integer__faktor(); extern INT tep_integer__faktor(); extern INT tep_integer__faktor(); extern INT tep_partition__faktor(); extern INT tep_partition__faktor_pre040202(); extern INT tes_elmsym__faktor(); extern INT tes___faktor(); extern INT tes_hashtable__faktor(); extern INT tes_integer__faktor(); extern INT tes_integer__faktor(); extern INT tes_partition__faktor(); extern INT test_bintree(); extern INT test_brc(); extern INT test_bruch(); extern INT test_callocobject(); extern INT test_dcp(); extern INT test_integer(); extern INT test_kostka(); extern INT test_list(); extern INT test_longint(); extern INT test_matrix(); extern INT test_mdg(); extern INT test_ndg(); extern INT test_number(); extern INT test_object(); extern INT test_perm(); extern INT test_plet(); extern INT test_poly(); extern INT test_schubert(); extern INT test_schur(); extern INT test_symchar(); extern INT test_word(); extern INT tex_2schubert_monom_summe(); extern INT tex_bruch(); extern INT tex_cyclo(); extern INT tex_dia_wt(); extern INT tex_hall_littlewood(); extern INT tex_hecke_monopoly(); extern INT tex_integer(); extern INT tex_kostka(); extern INT tex_lc(); extern INT tex_list(); extern INT tex_longint(); extern INT tex_matrix_co(); extern INT tex_matrix(); extern INT tex_monom(); extern INT tex_monom_plus(); extern INT tex_monopoly(); extern INT tex(); extern INT tex_partition(); extern INT tex_permutation(); extern INT tex_polynom(); extern INT t_EXPONENT_VECTOR(); extern INT t_EXPONENT_VECTOR_apply(); extern INT tex_rz(); extern INT tex_schubert(); extern INT tex_schur(); extern INT tex_sqrad(); extern INT tex_symchar(); extern INT tex_tableaux(); extern INT tex_vector(); extern INT tex_weintraube(); extern INT t_forall_monomials_in_a(); extern INT t_FROBENIUS_VECTOR(); extern INT t_galois_polynom(); extern INT t_HASHTABLE_ELMSYM(); extern INT t_HASHTABLE_ELMSYM_apply(); extern INT t_HASHTABLE_HOMSYM(); extern INT t_HASHTABLE_HOMSYM_apply(); extern INT t_HASHTABLE_MONOMIAL(); extern INT t_HASHTABLE_MONOMIAL_apply(); extern INT t_HASHTABLE_POLYNOM(); extern INT t_HASHTABLE_POLYNOM_apply(); extern INT t_HASHTABLE_POLYNOM_apply(); extern INT t_HASHTABLE_POWSYM(); extern INT t_HASHTABLE_POWSYM_apply(); extern INT t_HASHTABLE_SCHUR(); extern INT t_HASHTABLE_SCHUR_apply(); extern INT t_HASHTABLE_VECTOR(); extern INT the_integer__faktor(); extern INT the_integer__faktor(); extern INT thm_ende(); extern INT thm_integer__faktor(); extern INT thm_integer__faktor(); extern INT thm_partition__faktor(); extern INT t_HOMSYM_ELMSYM(); extern INT t_HOMSYM_HASHTABLE(); extern INT t_HOMSYM_HOMSYM(); extern INT t_HOMSYM_MONOMIAL(); extern INT t_HOMSYM_POWSYM(); extern INT t_HOMSYM_SCHUR(); extern INT thp_ende(); extern INT thp___faktor(); extern INT thp___faktor(); extern INT thp___faktor(); extern INT thp___faktor(); extern INT thp___faktor(); extern INT thp___faktor(); extern INT thp_homsym__faktor(); extern INT thp_integer__faktor(); extern INT thp_integer__faktor(); extern INT thp_integer__faktor(); extern INT thp_partition__faktor(); extern INT thp_partition__faktor_pre300102(); extern INT tidy(); extern INT t_INTEGER_FF(); extern INT t_INTEGER_LAURENT(); extern INT t_int_longint(); extern INT t_INTVECTOR_BITVECTOR(); extern INT t_INTVECTOR_UCHAR(); extern INT t_j_wt(); extern INT t_LAURENT_OBJ(); extern INT t_LIST_POLYNOM(); extern INT t_LIST_VECTOR(); extern INT t_longint_int(); extern INT t_loop_partition(); extern INT t_loop_partition(); extern INT tl_set_index_inc(); extern INT tl_set_max_numb(); extern INT tl_set_prime(); extern INT t_MA_MONOPOLY_MA_POLYNOM(); extern INT tme_ende(); extern INT tme___faktor(); extern INT tme___faktor(); extern INT tme_hashtable__faktor(); extern INT tme_integer__faktor(); extern INT tme_integer__faktor(); extern INT tme_monomial__faktor(); extern INT tme_monomial__faktor(); extern INT tme_partition__faktor(); extern INT tmh_ende(); extern INT tmh___faktor(); extern INT tmh___faktor(); extern INT tmh_integer__faktor(); extern INT tmh_integer__faktor(); extern INT tmh_integer__faktor(); extern INT tmh_integer__faktor(); extern INT tmh_monomial__faktor(); extern INT tmh_partition__faktor(); extern INT t_MONOMIAL_ELMSYM(); extern INT t_MONOMIAL_HASHTABLE(); extern INT t_MONOMIAL_HOMSYM(); extern INT t_MONOMIAL_MONOMIAL(); extern INT t_MONOMIAL_POWSYM(); extern INT t_MONOMIAL_SCHUR(); extern INT t_MONOPOLY_LAURENT(); extern INT t_MONOPOLY_POLYNOM(); extern INT tmp___faktor(); extern INT tmp___faktor(); extern INT tmp___faktor(); extern INT tmp___faktor(); extern INT tmp_integer__faktor(); extern INT tmp_int__faktor(); extern INT tmp_monomial__faktor(); extern INT tmp_monomial__faktor(); extern INT tmp_partition__faktor(); extern INT T_nkq_file(); extern INT T_nkq_maxgrad(); extern INT T_nkq_maxgrad_erweitert(); extern INT T_nkq_maxgrad_erweitert(); extern INT T_nkq_maxgrad(); extern INT t_OBJ_LAURENT(); extern INT t_PARTITION_AUGPART(); extern INT tpe___faktor(); extern INT tpe_hashtable__faktor(); extern INT tpe_integer__faktor(); extern INT tpe_partition__faktor(); extern INT tpe_partition__faktor_pre300102(); extern INT tpe_powsym__faktor(); extern INT t_PERMUTATION_SCHUBERT(); extern INT tph___faktor(); extern INT tph_hashtable__faktor(); extern INT tph_integer__faktor(); extern INT tph_partition__faktor(); extern INT tph_partition__faktor_pre300102(); extern INT tph_powsym__faktor(); extern INT tpm___faktor(); extern INT tpm_hashtable__faktor(); extern INT tpm_integer__faktor(); extern INT tpm_partition__faktor(); extern INT tpm_powsym__faktor(); extern INT t_POLYNOM_ELMSYM(); extern INT t_polynom_galois(); extern INT t_POLYNOM_LAURENT(); extern INT t_POLYNOM_MONOMIAL(); extern INT t_POLYNOM_MONOPOLY(); extern INT t_POLYNOM_POWER(); extern INT t_POLYNOM_SCHUBERT(); extern INT t_POLYNOM_SCHUR(); extern INT t_POLYNOM_T(); extern INT t_POWSYM_ELMSYM(); extern INT t_POWSYM_HASHTABLE(); extern INT t_POWSYM_HOMSYM(); extern INT t_POWSYM_MONOMIAL(); extern INT t_POWSYM_POWSYM(); extern INT t_POWSYM_SCHUR(); extern INT t_productexponent(); extern INT t_productexponent(); extern INT t_productexponent(); extern INT t_productexponent(); extern INT t_productexponent(); extern INT t_productexponent(); extern INT tps___faktor(); extern INT trace(); extern INT trace_matrix(); extern INT trafo_check(); extern INT trans2formlist(); extern INT transform_apply_list(); extern INT transformlist(); extern INT trans_index_monopoly_cyclo(); extern INT transpose(); extern INT transpose_matrix(); extern INT transpose_second_matrix(); extern INT t_REIHE_POLYNOM(); extern INT t_SCHUBERT_POLYNOM(); extern INT t_SCHUBERT_SCHUR(); extern INT t_SCHUR_ELMSYM(); extern INT t_SCHUR_HASHTABLE(); extern INT t_SCHUR_HOMSYM(); extern INT t_schur_jacobi_trudi(); extern INT t_SCHUR_MONOMIAL(); extern INT t_SCHUR_MONOMIAL_pre211101(); extern INT t_schur_naegelsbach(); extern INT t_SCHUR_POWSYM(); extern INT t_SCHUR_SCHUR(); extern INT t_SCHUR_SYMCHAR(); extern INT tse___faktor(); extern INT tse___faktor(); extern INT tse___faktor_slow(); extern INT tse_integer__faktor(); extern INT tse_partition__faktor(); extern INT tse_partition__faktor_pre040202(); extern INT tse_schur__faktor(); extern INT tsh_eval_jt(); extern INT tsh___faktor(); extern INT tsh___faktor(); extern INT tsh_hashtable__faktor(); extern INT tsh_integer__faktor(); extern INT tsh_integer__faktor(); extern INT tsh_jt(); extern INT tsh_partition__faktor(); extern INT tsh_partition__faktor_pre240102(); extern INT tsh_partition__faktor_pre310102(); extern INT tsh_schur__faktor(); extern INT tsm___faktor(); extern INT tsm_integer__faktor(); extern INT tsm_partition__faktor(); extern INT tsm_schur__faktor(); extern INT tsm_schur__faktor(); extern INT tsp___faktor(); extern INT tsp___faktor(); extern INT tsp___faktor(); extern INT tsp___faktor(); extern INT tsp___faktor(); extern INT tsp_integer__faktor(); extern INT t_splitpart(); extern INT t_splitpart(); extern INT t_splitpart(); extern INT t_splitpart(); extern INT t_splitpart(); extern INT t_splitpart(); extern INT tsp_partition__faktor(); extern INT tsp_schur__faktor(); extern INT tsp_schur__faktor(); extern INT t_UCHAR_INTVECTOR(); extern INT t_VECTOR_BIT(); extern INT t_VECTOR_BITREC(); extern INT t_VECTOR_EXPONENT(); extern INT t_VECTOR_FROB(); extern INT t_VECTOR_FROBENIUS(); extern INT t_VECTOR_LIST(); extern INT t_VECTOR_POLYNOM(); extern INT t_VECTOR_ZYKEL(); extern INT t_vperm_zperm(); extern INT T_weintraube(); extern INT twoword_knuth(); extern INT twoword_matrix(); extern INT txx_null__faktor(); extern INT txx_null__faktor(); extern INT typusorder(); extern INT t_zperm_vperm(); extern INT t_ZYKEL_VECTOR(); extern INT UD_permutation(); extern INT umriss_tableaux(); extern INT unimodalp(); extern INT unitp_galois(); extern INT unrank_degree_permutation(); extern INT unrank_given_q_ff(); extern INT unrank_given_qk_point(); extern INT unrank_k_subset(); extern INT unrank_permutation(); extern INT unrank_subset(); extern INT unset_bm_ij(); extern INT unset_bv_i(); extern INT usersort_vector(); extern INT vander(); extern INT variety_poly(); extern INT vec_anfang(); extern INT vec_ende(); extern INT vec_mat_mult(); extern INT vec_mat_mult(); extern INT vectorofzerodivisors_galois(); extern INT vectorp(); extern INT vertikal_sum(); extern INT vexillaryp(); extern INT vexillaryp_permutation(); extern INT vminus_hecke(); extern INT vminus_tabloid(); extern INT vminus(); extern INT vorgaenger_bruhat(); extern INT vorgaenger_bruhat_strong(); extern INT vorgaenger_bruhat_weak(); extern INT vorgaenger_young(); extern INT vorgaenger_young_skewpartition(); extern INT weight(); extern INT weight_augpart(); extern INT weight_partition(); extern INT weight_skewpartition(); extern INT weight_tableaux(); extern INT weight_vector(); extern INT weintraube_monom(); extern INT weintrauben_polynom(); extern INT weintraube_vector(); extern INT werte_Polynom_aus(); extern INT werte_Polynom_aus(); extern INT wert(); extern INT which_part(); extern INT W_nkq_maxgrad(); extern INT W_nkq_maxgrad(); extern INT wordoftableaux(); extern INT word_schen(); extern INT word_tableaux(); extern INT word_wt(); extern INT wrong_type_oneparameter(); extern INT wrong_type_twoparameter(); extern INT wt_liste_gewicht(); extern INT wt_word(); extern INT ym_min(); extern INT young_alt_scalar_tafel(); extern INT young_character(); extern INT young_ideal(); extern INT youngp(); extern INT young_polynom(); extern INT young_scalar_tafel(); extern INT young_tafel(); extern INT zeilenanfang(); extern INT zeilenende(); extern INT zeilen_summe(); extern INT zentralprim(); extern INT zerlege_nk_codes(); extern INT zerlege_nk_codes(); extern INT zykeldarstellung_matrix(); extern INT zykeldarstellung_matrix_red(); extern INT zykelind_aff1Zn(); extern INT zykelind_affkq(); extern INT zykelind_affkzn(); extern INT zykelind_An(); extern INT zykelind_arb(); extern INT zykelind_centralizer(); extern INT zykelind_Cn(); extern INT zykelind_cube(); extern INT zykelind_cube_edges(); extern INT zykelind_cube_edges_extended(); extern INT zykelind_cube_extended(); extern INT zykelind_cube_faces(); extern INT zykelind_cube_faces_extended(); extern INT zykelind_cube_vertices(); extern INT zykelind_cube_vertices_extended(); extern INT zykelind_dec(); extern INT zykelind_dec_apply(); extern INT zykelind_dir_prod(); extern INT zykelind_dir_prod_apply(); extern INT zykelind_dir_summ(); extern INT zykelind_dir_summ_apply(); extern INT zykelind_Dn(); extern INT zykelind_dodecahedron(); extern INT zykelind_dodecahedron_edges(); extern INT zykelind_dodecahedron_edges_extended(); extern INT zykelind_dodecahedron_extended(); extern INT zykelind_dodecahedron_faces(); extern INT zykelind_dodecahedron_faces_extended(); extern INT zykelind_dodecahedron_vertices(); extern INT zykelind_dodecahedron_vertices_extended(); extern INT zykelind_exponentiation(); extern INT zykelind_glkq(); extern INT zykelind_glkzn(); extern INT zykelind_hoch_dir_prod(); extern INT zykelind_hoch_dir_summ(); extern INT zykelind_inc(); extern INT zykelind_kranz(); extern INT zykelind_on_2sets(); extern INT zykelind_on_ksubsets(); extern INT zykelind_on_ktuples(); extern INT zykelind_on_ktuples_injective(); extern INT zykelind_on_pairs(); extern INT zykelind_on_pairs_disjunkt(); extern INT zykelind_on_pairs_oriented(); extern INT zykelind_on_pairs_reduced(); extern INT zykelind_on_power_set(); extern INT zykelind_pglkq(); extern INT zykelind_plethysm(); extern INT zykelind_Sn(); extern INT zykelind_stabilizer_part(); extern INT zykelind_superp_lin_dir_graphs(); extern INT zykelind_test(); extern INT zykelind_tetraeder(); extern INT zykelind_tetraeder_edges(); extern INT zykelind_tetraeder_edges_extended(); extern INT zykelind_tetraeder_extended(); extern INT zykelind_tetraeder_faces(); extern INT zykelind_tetraeder_faces_extended(); extern INT zykelind_tetraeder_vertices(); extern INT zykelind_tetraeder_vertices_extended(); extern INT zykeltyp(); extern INT zykeltyp_hoch_n(); extern INT zykeltyp_permutation(); extern INT zykeltyp_pi_hoch(); #endif symmetrica-2.0/di.c0000400017361200001450000012734410726021610014141 0ustar tabbottcrontab #include"def.h" #include"macro.h" /***********************************************************************/ /***********************************************************************/ /* */ /* Algorithmus von DIXON-WILF */ /* -------------------------- */ /* */ /* Dieses Programm berechnet Bahnrepresentanten der Bahnen einer Gruppe*/ /* G, die auf einer Menge M operiert. Es handelt sich um eine gewich- */ /* tete Version des Algorithmus von Dixon/Wilf. */ /* Die Represanten sind gleichverteilt auf den Bahnen von G auf M. */ /* Je nach Aufruf koennen entweder ein Beispielsatz von Bahnrepresen- */ /* tanten oder eine Bahnentransversale (oder Teile davon) erzeugt */ /* werden. */ /* */ /* Aufruf 1: */ /* --------- */ /* dixon_wilf_examples(G,weight,anz,FP); */ /* */ /* In diesem Fall werden anz Bahnrepresentanten in die Struktur FP */ /* geschrieben. (VECTOR von VECTOREN, die Laenge der einzelnen Rep- */ /* praesentanten ist gleich dem Grad der operierenden Permutations- */ /* gruppe. Diese muss in der Struktur G (VECTOR von PERMUTATIONEN) */ /* uebergeben werden. Es genuegt ein beliebiges Erzeugendensystem, */ /* da die komplette Gruppe daraus erzeugt wird. */ /* Der VECTOR weight enthaelt die Anzahl der verschiedenen Gewichte, */ /* also die eigentliche Information ueber die Menge, auf der operiert */ /* wird. */ /* Der ungewichtete Fall kann mit diesem Programm ebenfalls simuliert */ /* werden. */ /* */ /* */ /* Aufruf 2: */ /* --------- */ /* dixon_wilf_transversal(G,weight,anz,FP); */ /* */ /* In diesem Fall werden anz Bahnrepresentanten aus verschiedenen */ /* Bahnen in die Struktur FP geschrieben. */ /* (VECTOR von VECTOREN, die Laenge der einzelnen Rep- */ /* praesentanten ist gleich dem Grad der operierenden Permutations- */ /* gruppe. Diese muss in der Struktur G (VECTOR von PERMUTATIONEN) */ /* uebergeben werden. Es genuegt ein beliebiges Erzeugendensystem, */ /* da die komplette Gruppe daraus erzeugt wird. */ /* */ /* Der VECTOR weight enthaelt die Anzahl der verschiedenen Gewichte, */ /* also die eigentliche Information ueber die Menge, auf der operiert */ /* wird. */ /* Der ungewichtete Fall kann mit diesem Programm ebenfalls simuliert */ /* werden. */ /* */ /* Ist die eingegebene Zahl anz groesser als die Zahl der Bahnen, so */ /* werden |M//G| Representanten in FP zurueckgegeben. */ /* */ /* Wird anz mit 0L uebergeben, so werden ebenfalls |M//G| Representan-*/ /* ten berechnet. */ /* */ /*---------------------------------------------------------------------*/ /* Written by: Ralf Hager Oktober 1992 */ /*---------------------------------------------------------------------*/ /* */ /***********************************************************************/ /***********************************************************************/ #define war_schon_da(a,b) ((index_vector(a,b) == -1L ) ? 1L : 0L) static INT get_edge(); static INT bestimme_egf(); static INT mult_g_fix(); static INT berechne_Mgi(); static INT MGgen(); static INT berechne_Mgi_z(); static INT bestimme_pz(); static INT besetze_fixpunkt(); static INT Mggen(); /***********************************************************************/ /* */ /* Routine: Ggen */ /* Ausgehend von einem Erzeugendensystem S von Permutationen */ /* wir die Gruppe G erzeugt und in D abgespeichert. */ /* */ /***********************************************************************/ /* RH 031092 */ INT Ggen(G) OP G; { INT i; INT j; OP D = callocobject(); OP hperm = callocobject(); if(!einsp(S_V_I(G,0L))) { m_il_v(S_V_LI(G)+1L,D); m_il_nv(S_P_LI(S_V_I(G,0L)),S_V_I(D,0L)); first_permutation(S_P_L(S_V_I(G,0L)),S_V_I(D,0L)); for(i=1L;i S_V_II(a,i)) { M_I_I(0L,erg); break; } M_I_I(1L,zw); copy(S_V_I(a,i),x); for(k=0L;k 0L) { binom(x,S_V_I(S_V_I(b,k),i),zw); sub(x,S_V_I(S_V_I(b,k),i),x); mult(zw,erg,erg); } } } copy(erg,mg); freeall(erg); freeall(zw); freeall(x); freeall(y); freeall(sum); return OK; } /***********************************************************************/ /* */ /* Routine: build_propab_vector */ /* -------- */ /* */ /* Im Vektor propab werden die Wahrscheinlichkeiten fuer die Konju- */ /* tenklassen der Gruppe G gemaess folgender Verteilung bestimmt: */ /* */ /* */ /* |C_i| * |M_gi| */ /* P(C_i) = --------------- */ /* |G| * |M//G| */ /* */ /* */ /* In propab[i] steht dabei stehts sum_j=1L_to_i(P(C_j) */ /* */ /***********************************************************************/ /* RH 031092 */ INT build_propab_vector(propab,Cdeg,G,orb,Mg) OP propab,Cdeg,G,orb,Mg; { OP zaehler = callocobject(); OP nenner = callocobject(); OP zw = callocobject(); OP sum = callocobject(); INT i; M_I_I(0L,sum); mult(S_V_L(G),orb,nenner); for(i=0L;i0L) { for(j=0L;j S_I_I(MG)) anz_fp = S_I_I(MG); else anz_fp = S_I_I(anz); k = 0L; count = 0L; while(k < anz_fp) { for(j=0;j 0L) add(FP,Mgi,Mgi); } else { if(S_V_II(weight,ind) > 0L) { first_partition(S_V_I(weight,ind), S_V_I(multipart,ind)); do { for(k=0L;k S_I_I(z)) { copy(multizyk, erg); M_I_I(1L,BEENDEN); } } } else { if(S_I_I(sum) < S_I_I(z)) { if(S_V_II(weight,ind) > 0L) { first_partition(S_V_I(weight,ind), S_V_I(multipart,ind)); do { for(k=0L;k 0L) { M_I_I(S_V_II(a,i),oben); for(j=0L;j 0L) { k = 0L; while(k < S_V_II(S_V_I(ergzyk,j),i)) { besetzt = 1L; zaehler = 0L; while(besetzt) { random_integer(z,unten,oben); for(l=0L;l 0L) { i-= w; (*e1)++; w--; } (*e2) = (*e1)+i; } return OK; } /***********************************************************************/ /***********************************************************************/ /* */ /* Konstruktion von Bahnrepraesentatnen vorgegebener Laenge einer */ /* Gruppe G, die auf m^n operiert. */ /* */ /*---------------------------------------------------------------------*/ /* Written by: Ralf Hager November 1992 */ /*---------------------------------------------------------------------*/ /* */ /***********************************************************************/ /***********************************************************************/ /***********************************************************************/ /* */ /* Die Erzeuger der Gruppe G, die auf dem File stehen muessen werden */ /* als Vektor von Permutationen gespeichert. */ /* */ /* Es wird keine Pruefung vorgenommen, ob die Eingaben sinnvoll sind */ /* z.B. len | |G|, usw. */ /* */ /* Auch hier, wie bei allen Anwendungen von Dixon-Wilf sind nur kleine */ /* Gruppen sinnvoll, da die Konjugiertenkl. berechnet werden muessen */ /* */ /* Wird beim Aufruf des Programms get_orb_rep der letzte Parameter */ /* mit 0L besetzt, so wird nur die Anzahl der Bahnrepraesentanten */ /* berechnet, bei 1L werden sie konstruiert. Beidesmal steht das Ergeb-*/ /* nis in L. */ /* Die Anzahlberechnung empfiehlt sich vorab, denn bei mehr als ca. */ /* 5000 zu konstruierenden Fixpunkten treten eventuell Speicherplatz- */ /* probleme auf. */ /* */ /* ------------------------------------------------------------------- */ /* */ /* Der Vorteil bei diesem Programm besteht darin, dass nur fuer einige */ /* Gewichte die Fixpunkte berechnet werden, alle uebrigen dann durch */ /* Einfaerben gewonnen werden. */ /* Dadurch werden z.B. fuer G = C_7 , auf 7^7 nur ca. 11400 Versuche */ /* durchgefuehrt, es gibt aber 117648 Lyndon-Woerter. */ /* */ /* Durch das noch nicht optimal programmierte Einfaerben waechst der */ /* Aufwand mit wachsendem m besonders stark. */ /* */ /* ------------------------------------------------------------------- */ /* */ /***********************************************************************/ INT get_orb_rep(G,m,n,L,len,konstr) OP G; OP m; OP n; OP L; OP len; INT konstr; { INT i; INT j; INT k; INT c_fp = 0L; INT c_lyn = 0L; INT c_v = 0L; INT count = 0L; INT Canz = 0L; INT ind = 0L; INT anz_fp = 0L; INT hfix_in_ww(); INT Cgen(); OP weight = callocobject(); OP anz = callocobject(); OP FP = callocobject(); OP part = callocobject(); OP perm = callocobject(); OP fix = callocobject(); OP hfix = callocobject(); OP Cdegrees = callocobject(); OP C = callocobject(); OP Mg = callocobject(); OP MG = callocobject(); OP propab = callocobject(); OP perm_vec = callocobject(); OP p = callocobject(); OP b = callocobject(); OP hweight = callocobject(); OP weight_watcher = callocobject(); if(S_I_I(n) == 1L) { if(konstr == 0L) M_I_I(S_I_I(m),L); else { m_il_nv(S_I_I(m),L); for(i=0L;i S_I_I(MG)) anz_fp = S_I_I(MG); else anz_fp = S_I_I(anz); k = 0L; count = 0L; while(k < anz_fp) { for(j=0;j0L) { m_il_nv(S_I_I(m),b); m_il_nv(0L,weight_watcher); m_il_nv(0L,perm_vec); copy(S_V_I(FP,0L),fix); sort(fix); get_perm(hweight,p,b,S_I_I(n),S_I_I(m),0L, perm_vec,weight_watcher,fix); if(konstr == 1L) for(i=0L;i 0L) for(i=0L;i0;i--) if ((*e)[i] != 0) return 0; return 1; } #define UE_ADDG(a,b) (((a)+(b)) >= Charakteristik ?\ ((a)+(b))-Charakteristik: (a)+(b)) #define UE_MULTG(a,b) ((a) && (b) ? ((a)*(b)) % Charakteristik : 0 ) #define UE_FREE(a) do { SYM_FREE(*a); *a=NULL; } while(0) INT ff_anfang() /* AK 011204 */ { INT i; for (i=0;i s_ff_di(a)) error("s_ff_ii: index too big"); return * (s_ff_ip(a)+i); } static INT UE_addg(a,b) INT a,b; /* Summation : a,b sind die Summanden (Integerzahlen) */ { if (!b) return(a); if (!a) return(b); if (a+b>=Charakteristik) return(a+b-Charakteristik); return(a+b); } static INT UE_subg (a,b) INT a,b;/* Subtraktion : a,b sind Integerzahlen */ { if (!b) return(a); if (!a) return(Charakteristik-b); if (a>=b) return(a-b); return(Charakteristik+a-b); } static INT UE_multg(a,b) INT a,b; /* Multiplikation : a,b sind Faktoren (Integerzahlen) */ { if (a && b) return((a*b) % Charakteristik); return((INT)0); } static INT UE_divg(a,b) INT a,b;/* Division : a,b sind Integerzahlen */ /* UE */ { INT j,i,s; if (!b) { error("UE_divg:zero-division "); return(ERROR); } if (!a || b==(INT)1) return(a); s = a; j = b; i = Charakteristik-2L; while(i>(INT)0) { while(!i % 2L) { i /= 2L; j =(j*j) % Charakteristik; if (j==(INT)1) return(s); } i--; s = (s*j) % Charakteristik; } return(s); } /******************************************************************************/ /* Gaussalgorithmen : Algorithmen fuer Gleichungssystemloesung */ /* */ /* Verfasser : Ulrich Eidt */ /* Stand : 07.11.91 */ /******************************************************************************/ /******************************************************************************/ /* Funktion gausszerlegu fuehrt die Dreieckszerlegung PA = LR durch */ /* Uebergabeparameter : Mat : ist die Matrix */ /* n : Dimension der Matrix */ /* P : Platz fuer Permutationsvektor */ /* */ /* Rueckgabeparameter : 0 falls Matrix singulaer */ /* 1 falls Zerlegung erfolgreich durchgefuehrt */ /* */ /* Bemerkungen : - Die Eintraege der Matrix Mat sind Zeile fuer Zeile von oben*/ /* nach unten in Mat eingetragen. */ /* - Die Funktionen add,sub,mult,div werden verwendet. */ /* Diese stehen in EndlArithmet.c */ /******************************************************************************/ static INT gausszerlegu(Mat,n,P) INT **Mat; INT n; INT *P; { INT i,j,k=(INT)0,StellePermutation,Zwischenspeicher; /* { INT ii,jj; printf("(1)\n"); for (ii=0;ii 0 */ StellePermutation = -1; for (i=k;i 0) { StellePermutation = i; i = n+1; } /* Falls kein Eintrag <> 0 : Abbruch da Matrix singulaer */ if (StellePermutation < (INT)0) { /* { INT ii,jj; printf("(2)\n"); for (ii=0;ii k) for (j=(INT)0;j=(INT)0;k--) { b[k] = UE_divg(b[k],Mat[k][k]); for (i=(INT)0;i<=k-(INT)1;i++) b[i] = UE_subg(b[i],UE_MULTG(Mat[i][k],b[k])); } return OK; } /******************************************************************************/ /* Funktion reduzierpoly fuehrt die Reduktion eines Polynoms modulo eines */ /* anderen durch. Funktion nur fuer endliche Koerper verwendbar. */ /* */ /* Bemerkungen : - Funktion ohne Rueckgabeparameter. */ /* - Polynome werden in Potenzaufsteigender Reihenfolge */ /* sortiert, beginnend bei 0. ZB. Pol = x^2 + x + 3 wird */ /* uebergeben als : Pol[0] = 3, Pol[1] = 1, Pol[3] = 1. */ /* - ReduzierPolynom wird als normiert vorrausgesetzt, dh. in */ /* der Funktion wird der Koeffizient der hoechsten Potenz */ /* automatisch als 1 angenommen. */ /* - Polynom wird in der Funktion geaendert und enthaelt */ /* beim Abschluss der Funktion das reduzierte Polynom. */ /* - die Funktionen UE_multg,UE_addg,UE_subg werden verwendet. */ /* */ /* Autor : Ulrich Eidt */ /* Stand : 04.11.91 */ /******************************************************************************/ static INT reduzierpoly(Polynom,Grad,ReduzierPolynom,GradReduzierPol) INT *Polynom; /* enthaelt das Polynom vor Reduktion */ INT Grad; /* Grad des Polynoms vorher */ INT *ReduzierPolynom; /* Polynom nach dem reduziert wird */ INT GradReduzierPol; /* Grad des Polynoms nach dem reduziert wird */ { INT Polynomzeiger, i, Stelle, Faktor; /* falls Grad < GradReduzierPol ohne Aenderung zurueck */ if (Grad < GradReduzierPol) { return OK; } Polynomzeiger = Grad; /* Reduzieren, solange der Grad reduzierten Polynoms < Grad ReduzierPolynoms */ while (Polynomzeiger >= GradReduzierPol) { Faktor = Polynom[Polynomzeiger]; /* Reduzierung nur noetig, falls der Koeffizient <> 0 */ if (Faktor) { Polynom[Polynomzeiger] = (INT)0; for (i=(INT)0;i 1) { Mult_Tafel_Speicher = (INT ***) SYM_realloc(Mult_Tafel_Speicher, sizeof(INT**)* Mult_Tafel_Counter); Mult_Tafel_Grad = (INT *) SYM_realloc(Mult_Tafel_Grad, sizeof(INT)* Mult_Tafel_Counter); Mult_Tafel_Charakteristik = (INT *) SYM_realloc(Mult_Tafel_Charakteristik, sizeof(INT)* Mult_Tafel_Counter); UE_Platz_Mult_Speicher = (INT **) SYM_realloc(UE_Platz_Mult_Speicher, sizeof(INT*)* Mult_Tafel_Counter); } else { Mult_Tafel_Speicher = (INT ***) SYM_malloc( sizeof(INT**)* Mult_Tafel_Counter); Mult_Tafel_Grad = (INT *) SYM_malloc( sizeof(INT)* Mult_Tafel_Counter); Mult_Tafel_Charakteristik = (INT *) SYM_malloc( sizeof(INT)* Mult_Tafel_Counter); UE_Platz_Mult_Speicher = (INT **) SYM_malloc( sizeof(INT*)* Mult_Tafel_Counter); } Mult_Tafel_Speicher[Mult_Tafel_Counter-1] = Mult_Tafel; Mult_Tafel_Grad[Mult_Tafel_Counter-1] = UE_Erw_Grad; Mult_Tafel_Charakteristik[Mult_Tafel_Counter-1] = Charakteristik; UE_Platz_Mult_Speicher[Mult_Tafel_Counter-1] = UE_Platz_Mult; return OK; } /******************************************************************************/ /* Funktion erzmulttafel berechnet die Multiplikationstafel fuer die */ /* Normalbasis. */ /* */ /* Uebergabeparameter : */ /* - Erweiterungsgrad : Gibt den gewuenschten Erweiterungsgrad an */ /* - zweitAufruf : 1=Aufruf aus erzeugePol, 0 normaler Aufruf */ /* -1=Aufruf aus erzeugePol mit Tracepolynombergabe */ /* - Tracepolynom : Tracepolynom, falls bueergeben */ /* */ /* Rueckgabeparameter : 0 falls Tafel nicht erzeugt werden konnte. */ /* 1 sonst. */ /* */ /* Bemerkungen: */ /* - Funktionen, die benutzt werden (also eingebunden sein */ /* muessen) : */ /* liestracepol : aufgerufen von erzmulttafel() */ /* zu finden in LiesTracePol.c */ /* reduzierpoly : aufgerufen von erzmulttafel() */ /* zu finden in ReduzierPoly.c */ /* gausszerlegu : aufgerufen in erzmulttafel() */ /* zu finden in GaussAlgorit.c */ /* gaussaufloes : aufgerufen in erzmulttafel() */ /* zu finden in GaussAlgorit.c */ /* UE_addg,UE_subg,UE_multg,UE_divg : aufgerufen von reduzierpoly(), */ /* gausszerlegu() */ /* zu finden in EndlArithmet.c */ /* */ /* Zur Implementierung: */ /* Zunaechst wird das Tracecompatible Polynom eingelesen, und falls dies */ /* erfolgreich war die noetigen Speicherbelegungen durchgefuehrt. */ /* */ /* Dann wird die Normalbasis in der Polynomialen Basis ermittelt und sowohl */ /* in Tafel als auch in Gaussmatrix abgespeichert. Dafuer wird immer in */ /* Grosspolynom das letzte Basiselement^Erweiterungsgrad (= Frobeniushomom.)*/ /* eingelesen und nach Tracepolynom reduziert. */ /* */ /* Mit Gausszerlegu() wird die Basistransformation (Gleichungssystem) */ /* Polynomialbasis -> Normalbasis ermoeglicht. */ /* */ /* Diese Transformation wird auf die gewuenschten x - Potenzen in Polynomial-*/ /* basis angewendet, die man erhaelt, indem die in Tafel abgespeicherten */ /* Polynome mit x multipliziert, und dann reduziert. */ /* */ /* Autoer : Ulrich Eidt */ /* Stand : 05.11.91 */ /******************************************************************************/ #define FASTCHECKMULTTAFEL(grad) \ /* AK 221104 V3.0 */ \ do { \ INT i; \ for (i=0, Mult_Tafel =NULL ;i Erweiterungsgrad */ INT Grosspolzeiger;/* Hilfszeiger fuer Grosspolynom */ INT Gradgrosspol; /* Gibt den Grad von Grosspolynom an */ INT *Tracepolynom; /* Tracecompatibles Polynom */ INT *Permutation; /* Permutationsvektor bei Gleichungssystemloesung */ INT i,j; /* Laufvariable */ INT *ax; int k; #ifdef UNDEF Mult_Tafel=NULL; /* schaue ob schon von frueher da AK 070294 */ for (i=0;i=0) /* UWH */ { /* UWH */ Tracepolynom = (INT *) SYM_calloc(Erweiterungsgrad,sizeof(INT)); if (liestracepol(Erweiterungsgrad,Tracepolynom,zweitAufruf) != OK) /* UWH */ { SYM_free((char *) Tracepolynom); return error("ff.c: internal error FF-41"); /* printf("Tracecompatibles Polynom nicht beschaffbar!\n"); */ } /* UWH */ } else Tracepolynom = para_Tracepolynom; /* AK 040294 */ /* Bestehende Tafeln freimachen, falls nicht Aufruf aus erzeugePol */ for (i=0;i=0) /* UWH */ SYM_free((char *) Tracepolynom); return OK; } } UE_Platz_Mult = (INT *) UE_malloc(Erweiterungsgrad *Erweiterungsgrad* sizeof(INT)); /* Abspeichern der jeweiligen Zeilenanfaenge der Matrix, um Multiplikationen */ /* bei der Addressierung zu vermeiden */ Mult_Tafel = (INT **) UE_malloc(Erweiterungsgrad*sizeof(INT*)); k=(INT)0; for (i=(INT)0;i=0) SYM_free((char *) Tracepolynom); Mult_Tafel[0][0] = (INT)1; UE_Erw_Grad = (INT)1; insert_mt(); return(OK); } Grosspolynom = (INT *) SYM_calloc(Erweiterungsgrad*Charakteristik, sizeof(INT)); Gaussmatrix = (INT *) UE_malloc(Erweiterungsgrad*Erweiterungsgrad* sizeof(INT)); Permutation = (INT *) UE_malloc(Erweiterungsgrad*sizeof(INT)); /* Abspeichern der jeweiligen Zeilenanfaenge der Matrix, um Multiplikationen */ /* bei der Addressierung zu vermeiden */ Gau = (INT **) UE_malloc(Erweiterungsgrad*sizeof(INT*)); k=(INT)0; ax = Gaussmatrix; for (i=(INT)0;i=0) /* UWH */ SYM_free((char *) Tracepolynom); SYM_free((char *) Permutation); SYM_free((char *) Gau); error("internal error FF200"); return ERROR; } /* Berechnung der Tafeleintraege von x*x^(p^i) in der Normalbasis */ for (i=(INT)0;i=0) /* UWH */ SYM_free((char *) Tracepolynom); SYM_free((char *) Permutation); SYM_free((char *) Gau); UE_Erw_Grad = Erweiterungsgrad; insert_mt(); return OK; } /******************************************************************************/ /* Funktion UE_kgv berechnet das kleinste gemeinsame Vielfache von zwei */ /* Integerzahlen. */ /******************************************************************************/ static INT UE_kgv(a,b) INT a,b; { INT c,d; if (a==1) return b; if (b==1) return a; c = a; d = b; while(c && d) { c = c % d; if(c) d = d % c; } if(c) return(a*b/c); else return(a*b/d); } #ifdef UNDEF /******************************************************************************/ /* Funktion UE_sqrt berechnet die abgerundete integer-Wurzel einer Integerzahl*/ /******************************************************************************/ static INT UE_sqrt(x) INT x; { INT i; if (x==(INT)0) return((INT)0); for (i=(INT)1;i x) return(i-(INT)1); return((INT)1); } #endif /******************************************************************************/ /* Funktion UE_power berechnet die y-te Potenz von x */ /******************************************************************************/ static INT UE_power(x,y) INT x,y; { INT i, s = (INT)1; for (i=(INT)0;i 2 && ((p % 2L) == (INT)0)) return((INT)0); else { for (i=3L;i<=s;i+=2L) { if ((p % i) == (INT)0) return((INT)0); } } return((INT)1); } #endif /******************************************************************************/ /* FUNKTIONEN FUER ENDLICHE KOERPER */ /* Die folgenden Funktionen stellen eine Arithmetik fuer endliche Koerper in */ /* Normalbasenrepraesentation dar. Ein Koerperelement wird wie folgt */ /* abgespeichert: */ /* e[0] enthaelt den Erweiterungsgrad, die weiteren */ /* Stellen die Eintraege des es bezueglich der entsprechenden */ /* Normalbasis. e[0] = 0 ist gleichbedeutend mit 'nicht definiert'. */ /* */ /* Verfasser : Ulrich Eidt */ /* Stand : 04.11.91 */ /******************************************************************************/ /******************************************************************************/ /* Funktion minimalErw stellt den Koerper mit dem kleinsten Erweiterungsgrad */ /* fest, in dem ein e enthalten ist. Ist dieser kleiner als e[0] */ /* so wird die Speicherung des ees auf den kleinsten moeglichen Erwei- */ /* terungsgrad angepasst. */ /* Ein e ist genau dann aus einem Unterkoerper, wenn fuer einen Teiler */ /* m des Erweiterungsgrades sich die Eintraege immer nach m Eintraegen wieder-*/ /* holen. */ /******************************************************************************/ static INT minimalErw(e) INT **e; { INT i,j,maximum=(*e)[0]/2L,Grad=(*e)[0],minGrad=(INT)0; INT erfolgreich; /* falls nicht definiert keine Aenderungen */ if ((*e)[0] == 0) return OK; /* Teiler suchen nur bis zum maximalen Teiler */ while(minGrad<=maximum) { minGrad++; /* Nur Teiler muessen ueberprueft werden */ if (!(Grad % minGrad)) { erfolgreich = 1; for (i=minGrad;i minGrad nicht der minimale Erweiterungsgrad */ erfolgreich = 0; j = minGrad+(INT)1; i = Grad; } if (erfolgreich) { **e = minGrad; goto endeme; } } } endeme: return OK; } INT s_ff_ci(a) OP a; /* AK 080306 V3.0 */ /* select finite field characteristik as INT */ { return S_V_II(a,0); } OP s_ff_c(a) OP a; /* AK 080306 V3.0 */ /* select finite field characteristik */ { return S_V_I(a,0); } INT s_ff_di(a) OP a; /* select finite field degree as INT */ /* AK 130704 V3.0 */ { return S_FF_II(a,0); } INT copy_ff(a,b) OP a,b; /* AK 100393 */ /* AK 221104 V3.0 */ { INT erg = OK; { OBJECTSELF ma,mb; INT al,i; init_ff(b); COPY(S_FF_C(a),S_FF_C(b)); /*characteristic*/ COPY(S_FF_ME(a),S_FF_ME(b)); /* minimal extension ??*/ ma = S_O_S(S_V_I(a,1)); al = *(S_O_S(S_V_I(a,1)).ob_INTpointer); UE_Erw_Grad=al; mb.ob_INTpointer = (INT *) UE_malloc((al+1) * sizeof(INT)); for (i=0;i<=al;i++) *(mb.ob_INTpointer+i) = *(ma.ob_INTpointer+i); C_O_S(S_V_I(b,1),mb); } ENDR("copy_ff"); } INT scan_ff(a) OP a; { OP b; INT erg = OK; b = callocobject(); printeingabe("Enter the Characteristik of the finite field"); erg += scan(INTEGER,b); Charakteristik = S_I_I(b); erg += init_ff(a); /* AK 160594 */ erg += copy(b,S_FF_C(a)); erg += UE_scan(& S_FF_IP(a)); erg += freeall(b); ENDR("scan_ff"); } /******************************************************************************/ /* Funktion UE_scan uebernimmt das Einlesen der Koerperelemente */ /* */ /* Struktur : 0-te Stelle enthaelt den Grad der Koerpererweiterung */ /* Die darauffolgenden Stellen enthalten das e */ /******************************************************************************/ static INT UE_scan(Koerperzeiger) INT **Koerperzeiger; { INT i,j=(INT)0,ZeichenZeiger = (INT)1,*Koerperelement; char *Zeichen; Koerperelement = *Koerperzeiger; Zeichen = (char *) SYM_calloc(500,sizeof(char)); printeingabe("input of a finite field element"); printeingabe("degree of extension"); scanf("%ld",&i); SYM_free((char *) Koerperelement); Koerperelement = (INT *) UE_malloc((i+1)*sizeof(INT)); *Koerperzeiger = Koerperelement; for (j=(INT)0;j<=i;j++) Koerperelement[j] = (INT)0; fprintf(stderr,"input of %ld entries, seperated by comma",i); fprintf(stderr,"\nmissing entries are 0\n"); scanf("%s",Zeichen); j = (INT)1; ZeichenZeiger = (INT)0; while (j<=i) { /* 44 = 'Komma' */ while (Zeichen[ZeichenZeiger]!=44 && Zeichen[ZeichenZeiger]!=0) { Koerperelement[j] = Koerperelement[j] * 10 + Zeichen[ZeichenZeiger] - 48; ZeichenZeiger++; } ZeichenZeiger++; j++; } for (j=(INT)1;j<=i;j++) Koerperelement[j] %= Charakteristik; Koerperelement[0] = i; UE_Erw_Grad = i; /* minimalErw(Koerperzeiger); */ SYM_free(Zeichen); /* AK 051093 */ return OK; } /******************************************************************************/ /* Funktion UE_Platz stellt ein undefiniertes Koerperelement bereit. */ /******************************************************************************/ static INT UE_Platz(Koerperzeiger) INT **Koerperzeiger; { if (UE_Erw_Grad < 0) { error("ff.c: internal error FF331"); } *Koerperzeiger = (INT *) UE_malloc((UE_Erw_Grad+1)*sizeof(INT)); (*Koerperzeiger)[0] = (INT)0; return OK; } static INT UE_Free(a) INT **a; /* AK 060294 */ { SYM_free(*a); *a = NULL; return OK; } #ifdef UNDEF /******************************************************************************/ /* Funktion UE_Zeige gibt ein Koerperelement auf dem Bildschirm aus. */ /******************************************************************************/ static INT UE_Zeige(Koerperzeiger) INT **Koerperzeiger; { return UE_fZeige(stdout,Koerperzeiger); } #endif /******************************************************************************/ /* Funktion UE_fZeige gibt ein Koerperelement auf f aus. */ /******************************************************************************/ static INT UE_fZeige(f,Koerperzeiger) INT **Koerperzeiger; FILE *f; /* AK 201204 V3.0 */ { INT i,*Koerperelement; if ((*Koerperzeiger)[0] == (INT)0) { return error("ff.c: internal error FF1"); } /* minimalErw(Koerperzeiger); */ Koerperelement = *Koerperzeiger; for (i=(INT)1;i Charakteristik, "random_ff:internal error 070295"); SYMCHECK (S_FF_II(b,1) < 0, "random_ff:internal error 170304"); #endif } ENDR("random_ff"); } INT random_char_ff(a,b) OP a,b; /* AK 220294 */ /* AK 280704 V3.0 */ { INT erg = OK; CTO(INTEGER,"random_char_ff(1)",a); SYMCHECK(not primep(a),"random_char_ff: no prime"); { #ifdef FFTRUE Charakteristik = S_I_I(a); return random_ff(b); #endif } ENDR("random_char_ff"); } INT addinvers_ff(a,b) OP a,b; /* AK 280704 V3.0 */ { INT erg = OK; CTO(FF,"addinvers_ff(1)",a); { #ifdef FFTRUE Charakteristik = S_FF_CI(a); erg += init_ff(b); erg += UE_negativ(& S_FF_IP(a), & S_FF_IP(b)); erg += m_i_i(Charakteristik,S_FF_C(b)); SYMCHECK (S_FF_II(b,1) > Charakteristik, "addinvers_ff:internal error 070295"); SYMCHECK (S_FF_II(b,1) < 0, "addinvers_ff:internal error 170304"); #endif } ENDR("addinvers_ff"); } INT invers_ff(a,b) OP a,b; /* AK 280704 V3.0 */ { INT erg = OK; CTO(FF,"invers_ff(1)",a); { #ifdef FFTRUE Charakteristik = S_FF_CI(a); erg += init_ff(b); erg += UE_invers(& S_FF_IP(a), & S_FF_IP(b)); erg += m_i_i(Charakteristik,S_FF_C(b)); SYMCHECK (S_FF_II(b,1) > Charakteristik, "invers_ff:internal error 070295"); SYMCHECK (S_FF_II(b,1) < 0, "invers_ff:internal error 170304"); #endif } ENDR("invers_ff"); } INT mult_ff_integer(a,b,c) OP a,b,c; /* AK 070802 */ /* AK 280704 V3.0 */ { INT erg = OK; CTO(FF,"mult_ff_integer(1)",a); CTO(INTEGER,"mult_ff_integer(2)",b); CTO(EMPTY,"mult_ff_integer(3)",c); { #ifdef FFTRUE OP d; d = CALLOCOBJECT(); COPY_INTEGER(b,d); cast_apply_ff(d); erg += mult_ff_ff(a,d,c); FREEALL(d); #endif } ENDR("mult_ff_integer"); } INT mult_ff_ff(a,b,c) OP a,b,c; /* AK 070802 */ /* AK 280704 V3.0 */ { INT erg = OK; CTO(FF,"mult_ff_ff(1)",a); CTO(FF,"mult_ff_ff(2)",b); if (S_O_K(c) != FF) FREESELF(c); CTTO(FF,EMPTY,"mult_ff_ff(3)",c); SYMCHECK(S_FF_CI(a) != S_FF_CI(b),"mult_ff_ff:different characteristic"); { #ifdef FFTRUE Charakteristik = S_FF_CI(a); if (S_O_K(c) != FF) erg += init_ff(c); else { INT *ap,*bp; ap =S_FF_IP(a); bp =S_FF_IP(c); // printf("*ap = %d *bp = %d\n",*ap,*bp); if (*ap > *bp) bp = (INT*) SYM_realloc(bp,(S_FF_DI(a)+1)*sizeof(INT)); bp[0]=*ap; C_FF_IP(c,bp); M_I_I(0,S_FF_ME(c)); // println(c); } M_I_I(Charakteristik,S_FF_C(c)); if ((S_FF_DI(a)==1) && (S_FF_DI(b)==1)) /* AK 270705 */ { INT *cp; cp = S_FF_IP(c); cp[0]=1; cp[1]=(S_FF_II(a,1)*S_FF_II(b,1)) % Charakteristik; } else UE_mult(& S_FF_IP(a), & S_FF_IP(b), & S_FF_IP(c) ); SYMCHECK (S_FF_II(c,1) > Charakteristik, "mult_ff_ff:internal error 070295"); SYMCHECK (S_FF_II(c,1) < 0, "mult_ff_ff:internal error 170304"); #endif } ENDR("mult_ff_ff"); } INT einsp_ff(a) OP a; { #ifdef FFTRUE if (UE_ist_eins(& S_FF_IP(a)) == (INT)1) return TRUE; #endif return FALSE; } INT add_ff(a,b,c) OP a,b,c; { INT erg = OK; #ifdef FFTRUE if (NULLP(b)) return copy(a,c); if (S_O_K(b) != FF) /* AK 230294 */ cast_apply_ff(b); if ((S_O_K(a) != FF) || (S_O_K(b) != FF)) return WTT("add_ff",a,b); if (S_FF_CI(a) != S_FF_CI(b)) error("add_ff:different characteristic"); Charakteristik = S_FF_CI(a); erg += init_ff(c); erg += UE_add(& S_FF_IP(a), &S_FF_IP(b), &S_FF_IP(c)); erg += m_i_i(Charakteristik,S_FF_C(c)); SYMCHECK (S_FF_II(c,1) > Charakteristik, "add_ff:internal error 070295"); SYMCHECK (S_FF_II(c,1) < 0, "add_ff:internal error 170304"); #endif /* FFTRUE */ ENDR("add_ff"); } INT t_INTEGER_FF(a,b,c) OP a,b,c; /* AK 070394 */ /* AK 091204 V3.0 */ /* a is INTEGER b is INTEGER = Charakteristik c becomes FF */ { INT erg = OK; CTO(INTEGER,"t_INTEGER_FF(1)",a); CTO(INTEGER,"t_INTEGER_FF(2)",b); /* CE3(a,b,c,t_INTEGER_FF); AK 200802 */ { #ifdef FFTRUE INT i; Charakteristik = S_I_I(b); i = S_I_I(a) % Charakteristik; /* AK 210802 mod added */ while (i<0) i += Charakteristik; /* AK 070295 */ erg += init_ff(c); /* c must not be empty */ erg += UE_Int_Aequivalent(i, &S_FF_IP(c)); M_I_I(Charakteristik,S_FF_C(c)); #endif /* FFTRUE */ } ENDR("t_INTEGER_FF"); } INT cast_apply_ff(a) OP a; /* AK 230294 */ { INT erg = OK,i; #ifdef FFTRUE switch (S_O_K(a)) { case INTEGER: i = S_I_I(a); erg += init_ff(a); erg += UE_Int_Aequivalent(i, &S_FF_IP(a)); erg += m_i_i(Charakteristik,S_FF_C(a)); break; default: printobjectkind(a); erg += error("cast_apply_ff: transfer not possible"); break; } SYMCHECK (S_FF_II(a,1) > Charakteristik, "cast_apply_ff:internal error 070295"); SYMCHECK (S_FF_II(a,1) < 0, "cast_apply_ff:internal error 170304"); #endif /* FFTRUE */ ENDR("cast_apply_ff"); } INT minimal_extension(ff) OP ff; { INT erg = OK; CTO(FF,"minimal_extension(1)",ff); { erg = reduce_ff(ff); } ENDR("minimal_extension"); } #ifdef FFTRUE /******************************************************************************/ /* Funktion UE_add belegt Ergebzeig mit seins+szwei */ /******************************************************************************/ static INT UE_add(seins,szwei,Ergebzeig) INT **seins; INT **szwei, **Ergebzeig; { INT i,j,k,*Summ1hilf,*Summ2hilf,*Summand_eins,*Summand_zwei,*Ergebnis; INT h1=0,h2=0; Summand_eins = *seins; Summand_zwei = *szwei; Ergebnis = *Ergebzeig; /* Falls der Grad einer der Summanden nicht Den Erweiterungsgrad teilt, */ /* Wird eine Koerpererweiterung noetig */ if (!UE_Erw_Grad || (UE_Erw_Grad % Summand_eins[0]+UE_Erw_Grad%Summand_zwei[0])) { minimalErw(seins); minimalErw(szwei); } if (!UE_Erw_Grad || (UE_Erw_Grad % Summand_eins[0]+UE_Erw_Grad%Summand_zwei[0])) { k = UE_kgv(Summand_eins[0],Summand_zwei[0]); if ( erzmulttafel(k,(INT)0,NULL) != OK) /* UWH */ return error("ff.c:internal error FF70"); } /* ist der Grad einer der Summanden m nicht gleich dem aktuellen Grad, so */ /* muss eine Einbettung vorgenommen werden, indem man die Koeffizienten */ /* ( / m)-mal wiederholt. */ if (Summand_eins[0] != UE_Erw_Grad) { k=1; Summ1hilf = (INT *) UE_malloc((UE_Erw_Grad+1)*sizeof(INT)); h1=1; for (i=(INT)0;i / m)-mal wiederholt. */ if (Faktor_eins[0] != UE_Erw_Grad) { k=(INT)1; Fakt1hilf = (INT *) UE_malloc((UE_Erw_Grad+1)*sizeof(INT)); for (i=(INT)0;i(INT)0) { while(!(i % 2L)) { i /= 2L; UE_mult(&Elemhelp,&Elemhelp,&Elemhelp); } i--; UE_mult(Ergebnis,&Elemhelp,Ergebnis); } SYM_free((char *) Elemhelp); return OK; } /******************************************************************************/ /* Funktion invers berechnet 1/e und gibt das Ergebnis in Ergebzeig aus.*/ /******************************************************************************/ static INT UE_invers(e,Ergebnis) INT **e,**Ergebnis; { INT i; if ((*e)[0] == 1 && (*e)[1] == (INT)0) { return error("UE_invers:division by 0"); /* (*Ergebnis)[0] = (INT)0; return OK; */ } /* 1/e = e^(Charakteristik^(Erweiterungsgrad des ees)-2) */ i = UE_power(Charakteristik,(*e)[0])-2; UE_hoch(e,i,Ergebnis); return OK; } /******************************************************************************/ /* Funktion UE_ist_null testet, ob e = 0 */ /* Rueckgabewert : 1 falls e = 0, 0 sonst */ /******************************************************************************/ static INT UE_ist_null(e) INT **e; { /* AK 020304 */ /* INT i; for (i=(*e)[0];i>0;i--) if ((*e)[i] != 0) return 0; return 1; */ UE_IST_NULL(e); } /******************************************************************************/ /* Funktion UE_ist_eins testet, ob e = 1 */ /* Rueckgabewert : 1 falls e = 1, 0 sonst */ /******************************************************************************/ static INT UE_ist_eins(e) INT **e; { /* AK 020304 */ INT i; for (i=1;i<=(*e)[0];i++) if ((*e)[i] != 1) return 0; return 1; } /******************************************************************************/ /* Funktion Int_Aequivalent berechnet zu einer Integerzahl a das zugehoerige */ /* Grundkoerperelement und belegt Ergebnis damit. */ /******************************************************************************/ static INT UE_Int_Aequivalent(a,Ergebnis) INT a; INT **Ergebnis; { /* falls Ergebniselement nicht den benoetigten Erweiterungsgrad hat */ if ((*Ergebnis)[0] < (INT)1) { SYM_free((char*) (*Ergebnis)); *Ergebnis = (INT *) UE_malloc(2*sizeof(INT)); } (*Ergebnis)[0] = 1; (*Ergebnis)[1] = a % Charakteristik; if ( (*Ergebnis)[1] < 0 ) (*Ergebnis)[1]=(*Ergebnis)[1] +Charakteristik; /* AK 170304 */ UE_Erw_Grad = 1; /* AK 190100 */ return OK; } /******************************************************************************/ /* Funktion UE_ist_gleich vergleicht e_eins mit e_zwei */ /* Rueckgabewert : 1 falls e_eins > e_zwei, */ /* -1 falls e_eins < e_zwei, */ /* 0 falls e_eins = e_zwei. */ /******************************************************************************/ static INT UE_ist_gleich(e_eins,e_zwei) INT **e_eins, **e_zwei; { INT i,j,k,*Elem1hilf,*Elem2hilf; INT gemein_grad; /* falls die ee verschiedene Erweiterungsgrade ueber dem Grundkoerper */ /* haben, muessen sie in den gemeinsammen Erweiterungskoerper eingebettet */ /* werden. */ if ((*e_eins)[0] != (*e_zwei)[0]) { gemein_grad = UE_kgv((*e_eins)[0],(*e_zwei)[0]); if ((*e_eins)[0] != gemein_grad) { k=(INT)1; Elem1hilf = (INT *) UE_malloc((gemein_grad+1)*sizeof(INT)); for (i=(INT)0;i 0 && Elem1hilf[k] < Elem2hilf[k]) k = -1; if (k > 0 && Elem1hilf[k] > Elem2hilf[k]) k = 1; /* Speicher, fallsbenoetigt freigeben */ if (*e_eins!=Elem1hilf) SYM_free ((char *) Elem1hilf); if (*e_zwei!=Elem2hilf) SYM_free ((char *) Elem2hilf); return(k); } INT order_ff(a,b) OP a,b; /* AK 170194 */ { INT erg = OK; if (a == b) return ERROR; CTO(FF,"order_ff",a); erg += erzmulttafel(UE_Erw_Grad,0,NULL); /* UWH */ erg += m_i_i(UE_order( & S_FF_IP(a) ), b); ENDR("order_ff"); } /******************************************************************************/ /* Funktion UE_order berechnet das kleinste m mit e^m = 1 */ /* Rueckgabewert : die berechnete Ordnung. */ /******************************************************************************/ static INT UE_order(e) INT **e; { INT maxord = UE_power(Charakteristik,(*e)[0])-(INT)1; INT maxteiler = maxord/2L; INT i,*Ergebnis; UE_Platz(&Ergebnis); for (i=(INT)1;i<=maxteiler;i++) if (!(maxord % i)) { UE_hoch(e,i,&Ergebnis); if (UE_ist_eins(&Ergebnis)) { SYM_free(Ergebnis); return i; } } UE_Free(&Ergebnis); return(maxord); } /******************************************************************************/ /* Funktion UE_Random erzeugt ein zufaelliges e im Koerper des aktuellen*/ /* Grades. */ /******************************************************************************/ static INT UE_Random(e) INT **e; { INT i; /* Der Erweiterungsgrad des ees muss mit dem aktuellen uebereinstimmen */ SYM_free(*e); /* AK 170393 */ *e = (INT *) UE_malloc((UE_Erw_Grad+1)*sizeof(INT)); (*e)[0] = UE_Erw_Grad; /* Zufallserzeugung */ for (i=(INT)1;i<=UE_Erw_Grad;i++) (*e)[i] = rand() % Charakteristik; /* minimalErw(e); */ /* AK 020304 */ return OK; } #ifdef UNDEF UE_main() { INT u=1,i,j=0,*test,*test_eins,*test_zwei; UE_Erw_Grad = (INT)0; do { printf("Geben sie die gewuenschte Charakteristik ein "); scanf("%d",&Charakteristik); fflush(stdout); j = UE_prim(Charakteristik); if (!j) printf("\n Dies ist keine Primzahl!\n"); } while (!j); while(u) { UE_Platz(&test); UE_scan(&test); printf("\n"); UE_Platz(&test_eins); UE_scan(&test_eins); printf("\n"); UE_Platz(&test_zwei); UE_add(&test,&test_eins,&test_zwei); UE_Zeige(&test); printf(" + \n"); UE_Zeige(&test_eins); printf(" = \n"); UE_Zeige(&test_zwei); if (UE_ist_null(&test_zwei)) printf("ist Null\n"); if (UE_ist_eins(&test_zwei)) printf("ist Eins\n"); printf("\n\n"); UE_mult(&test,&test_eins,&test_zwei); UE_Zeige(&test); printf(" * \n"); UE_Zeige(&test_eins); printf(" = \n"); UE_Zeige(&test_zwei); if (UE_ist_null(&test_zwei)) printf("ist Null\n"); if (UE_ist_eins(&test_zwei)) printf("ist Eins\n"); printf("\n\n"); UE_invers(&test_zwei,&test_eins); printf("1/ "); UE_Zeige(&test_zwei); printf(" = "); UE_Zeige(&test_eins); if (UE_ist_null(&test_eins)) printf("ist Null\n"); if (UE_ist_eins(&test_eins)) printf("ist Eins\n"); printf("\n\n"); UE_negativ(&test_zwei,&test_eins); printf("0- "); UE_Zeige(&test_zwei); printf(" = "); UE_Zeige(&test_eins); if (UE_ist_null(&test_eins)) printf("ist Null\n"); if (UE_ist_eins(&test_eins)) printf("ist Eins\n"); UE_Free(&test); UE_Free(&test_eins); UE_Free(&test_zwei); printf("Momentane Koerpererweiterung: %d\n",UE_Erw_Grad); printf("Ende = 1 Weiter = 2 neuer Grad und weiter = 3 "); scanf("%d",&i); if (i==1) u=(INT)0; if (i==3) { printf("Grad :"); scanf("%ld",&UE_Erw_Grad); erzmulttafel(UE_Erw_Grad,0,NULL); /* UWH */ } } } #endif /* UNDEF */ static INT init_ff(a) OP a; { INT erg = OK; erg += m_il_v(3L,a); /* first = characteristic second = vector of components of ff third = minimalErw = y=1/unknown=0 */ C_O_K(a,FINITEFIELD); erg += UE_Platz(&S_FF_IP(a)); M_I_I(0,S_FF_ME(a)); return erg; } INT debugprint_ff(a) OP a; /* AK 160393 */ { INT i; INT *iv; for (i=(INT)0;i0;i--) if ( *(ai+i) < (Charakteristik-1) ) { *(ai+i) = *(ai+i) + 1; for (i++;i<=l;i++) { *(ai+i) = 0; } return OK; } if (i == 0) return LAST_FF; } erg = ERROR; ENDR("next_ff"); } /****************************************************************************/ /* Funktion einfuegTrace fuegt ein neu berechnetes Polynom in die */ /* entsprechende Datei ein. */ /* bergabeparameter Grad Erweiterungsgrad der Datei */ /* tracePolynom einzutragendes Polynom */ /****************************************************************************/ void einfuegTrace(Grad,tracePolynom) INT Grad; INT *tracePolynom; { INT j; INT i; INT Laenge; char Zeichenkette[50]; /* "G:" */ if (Datei==NULL) { // error("internal error FF311"); return; } Laenge = getString(Grad,Zeichenkette); fseek(Datei,0,2); putc('G',Datei); for (i=0;i=0;i--) { if (Polynom[i]) { return(i); } } return(-1); } /****************************************************************************/ /* Funktion spezNormiert normiert Polynom */ /* bergabeparameter : Polynom, NormalPolynom,Grad */ /****************************************************************************/ static INT *spezNormiert(Polynom,Grad) INT *Polynom; INT Grad; { INT i; INT maxGrad = spezGrad(Polynom,Grad); INT Faktor = Polynom[maxGrad]; if (Faktor==1) return(Polynom); Faktor = UE_divg(1,Faktor); for (i=maxGrad;i>=0;i--) Polynom[i] = UE_multg(Polynom[i],Faktor); return(Polynom); } /***************************************************************************/ /* Funktion spezEinsGGT berprft, ob GGT(Pol1,Pol2) = 1 */ /* bergabeparameter Pol1, Pol2, Grad = Grad der Polynome */ /* Rckgabewert : 1, falls GGT = 1, 0 sonst */ /***************************************************************************/ static INT spezEinsGGT(Pol1,Pol2,Grad) INT *Pol1; INT *Pol2; INT Grad; { INT i; INT *hilf1pol; INT *hilf2pol; if (!(hilf1pol = (INT *) UE_malloc((Grad+1)*sizeof(INT)))) return no_memory(); if (!(hilf2pol = (INT *) UE_malloc((Grad+1)*sizeof(INT)))) { SYM_free((char *) hilf1pol); return no_memory(); } for (i=0;i<=Grad;i++) { hilf1pol[i] = Pol1[i]; hilf2pol[i] = Pol2[i]; } while (spezGrad(hilf1pol,Grad)>=0 && spezGrad(hilf2pol,Grad)>=0) { reduzierpoly(hilf1pol,spezGrad(hilf1pol,Grad),spezNormiert(hilf2pol,Grad),spezGrad(hilf2pol,Grad)); if(spezGrad(hilf1pol,Grad)>=0) reduzierpoly(hilf2pol,spezGrad(hilf2pol,Grad),spezNormiert(hilf1pol,Grad),spezGrad(hilf1pol,Grad)); } /* Grad = 0 bedeutet von 0 verschiedenes Grundkoerperelement */ if (spezGrad(hilf1pol,Grad)==0) { SYM_free((char *) hilf1pol); SYM_free((char *) hilf2pol); return (INT)1; } /* hilf1pol = 0 und hilf2pol von 0 verschiedenes Grundkorperelement */ if (spezGrad(hilf1pol,Grad)<0) if (spezGrad(hilf2pol,Grad)==0) { SYM_free((char *) hilf1pol); SYM_free((char *) hilf2pol); return (INT) 1; } SYM_free((char *) hilf1pol); SYM_free((char *) hilf2pol); return(INT)0; } /****************************************************************************/ /* Funktion spezMult Multiplikation zweier Koerperelemente Modulo */ /* NormalPolynom */ /* bergabeparameter : Faktor1, Faktor2, Ergebnis, NormalPolynom, Grad */ /* */ /* Rckgabeparameter 1, falls ohne Probleme durchgefuehrt, 0 sonst. */ /****************************************************************************/ static INT spezMult(Faktor1,Faktor2,Ergebnis,NormalPolynom,Grad) INT *Faktor1; INT *Faktor2; INT *Ergebnis; INT *NormalPolynom; INT Grad; { INT i; INT j; INT ergebnisGrad=0; INT *zwischenErgebnis; zwischenErgebnis = (INT *) SYM_calloc(Grad+Grad,sizeof(INT)); for (i=0;i0) { while(!(i % 2)) { i /= 2; spezMult(Elemhelp,Elemhelp,Elemhelp,NormalPolynom,Grad); } i--; spezMult(Ergebnis,Elemhelp,Ergebnis,NormalPolynom,Grad); } SYM_free((char *) Elemhelp); return(1); } /****************************************************************************/ /* Funktion triang bildet Dreiecksmatrix von Matrix */ /****************************************************************************/ static void triang(Matrix,Deg) INT **Matrix; INT Deg; { INT i,j,k,l,pp,u; for(i=0;i Ableitung = 0 -> nicht irreduzibel */ if (i == Grad) { SYM_free((char *) Ableitung); return(0); } if (!spezEinsGGT(NormaltestPolynom,Ableitung,Grad)) { SYM_free((char *) Ableitung); return(0); } hf = (INT *) SYM_calloc(Grad,sizeof(INT)); q_mat = (INT *) SYM_calloc(Grad*Grad,sizeof(INT)); x = (INT *) SYM_calloc(Grad*2,sizeof(INT)); Matrix = (INT **) SYM_calloc(Grad,sizeof (INT *)); i=0; for (j=0;j=0;j--) SYM_free((char *) Pol1[j]); SYM_free((char *) Pol1); return(0); } Pol1[Grad-1][1] = 1; /* a */ a_Hoch_q[Charakteristik] = 1; reduzierpoly(a_Hoch_q,Charakteristik,NormalPolynom,Grad); for (i=0;i=0;i--) spezHoch(Pol1[i+1],Charakteristik,Pol1[i],NormalPolynom,Grad); if (!gausszerlegu(Pol1,Grad,Permutation)) { for (i=0;i<=Grad;i++) SYM_free((char *) Pol1[i]); SYM_free((char *) Pol1); SYM_free((char *) Permutation); SYM_free((char *) NormalPolynom); return(0); } else { for (i=0;i<=Grad;i++) SYM_free((char *) Pol1[i]); SYM_free((char *) Pol1); SYM_free((char *) Permutation); SYM_free((char *) NormalPolynom); return(1); } } /****************************************************************************/ /* Funktion getNormalPol erzeugt ein Normalpolynom. */ /* */ /* Uebergabeparameter : NormalPolynom, Grad */ /* */ /* Rueckgabeparameter : OK falls erfolgreich, ERROR sonst */ /****************************************************************************/ static INT getNormalPol(NormalPolynom,Grad) INT *NormalPolynom, Grad; { INT i; INT j; /* Vorbelegung von NormalPolynom */ for (i=1;i0) NormalPolynom[j] = 0; else NormalPolynom[0] = 1; j++; if (j==Grad-1) return(ERROR); } if (j==Grad-1) return(ERROR); NormalPolynom[j]++; } return(OK); } /****************************************************************************/ /* Funktion minimalPolynom berechnet zu einem Element in */ /* Normalbasenreprsentation das Minimalpolynom, */ /* bergabeparameter : Element (Element[0] = Grad, dann die EINTrge a,a^p,.*/ /* minPolynom : Grad eINTrge Platz (da normiert) */ /* (aufsteigende x-Potenzen */ /* Rckgabewert : 1, falls Minimalpoylom berechnet., 0 sonst */ /****************************************************************************/ static INT minimalPolynom(Element,minPolynom) INT *Element; INT *minPolynom; { INT rueckwert = 1; INT Grad = Element[0]; INT i; INT j; INT *ElementPotenz; INT *MinusElementPotenz; INT *zwischElement; INT **Polynom; if(!(Polynom = (INT **) UE_malloc((Grad+1)*sizeof(INT *)))) return no_memory(); UE_Platz(&ElementPotenz); UE_Platz(&MinusElementPotenz); for (i=0;i<=Grad;i++) ElementPotenz[i] = Element[i]; UE_negativ(&ElementPotenz,&MinusElementPotenz); UE_Platz(&zwischElement); /* Minimalpolynom mit 0 vorbelegen */ for(i=0;i<=Grad;i++) { UE_Platz(&Polynom[i]); Polynom[i][0] = (INT)1; Polynom[i][1] = (INT)0; } /* Fuer die Multiplikation mit x-a^q^i starten wir bei der hchsten Potenz, auf diese Weise kann das Schiften fr die x-Multiplikation vernachlssigt werden */ Polynom[Grad][1] = (INT)1; for(i=0;i<=Grad;i++) Polynom[Grad-1][i] = MinusElementPotenz[i]; /* Berechnung des Minimalpolynoms */ for(i=Grad;i>1;i--) { UE_hoch(&ElementPotenz,Charakteristik,&ElementPotenz); UE_negativ(&ElementPotenz,&MinusElementPotenz); for(j=i;j<=Grad;j++) { UE_mult(&MinusElementPotenz,&Polynom[j-1],&zwischElement); UE_add(&Polynom[j-2],&zwischElement,&Polynom[j-2]); } UE_add(&MinusElementPotenz,&Polynom[Grad-1],&Polynom[Grad-1]); } /* berprfung ob Ergebnispolynom nur aus Skalaren besteht */ for (i=0;i 1) { while(!(Gradsich%i) && Gradsich > 1) { Gradsich /= i; if (anzahlPrimfakt>0 && Basis[anzahlPrimfakt-1] == i) Potenz[anzahlPrimfakt-1] ++; else { Basis[anzahlPrimfakt] = i; Potenz[anzahlPrimfakt] = 1; anzahlPrimfakt++; } } i++; } /* Falls nur eine Primpotenz -> Erzeugung, andernfalls Berechnung aus Multiplikationstabellen bestehender Erweiterungspolynome -> Rekursiver Aufruf */ if (anzahlPrimfakt==1) /* Starten des Erzeugungsvorgangs */ { /* Erzeugen eines Normalpolynoms */ UE_Erw_Grad = Grad; /* AK 130197 */ kleinGrad = Grad/Basis[0]; UE_Platz(&kleinElement); if(!(NormalPolynom = (INT *) UE_malloc((Grad+1)*sizeof(INT)))) return no_memory(); if(getNormalPol(NormalPolynom,Grad) != OK) { SYM_free((char *) NormalPolynom); /* printf("Kann kein Normalpolynom zum Grad %d erzeugen.\n",Grad); return(0); */ error("ff.c: internal error FF-40"); } /* Hole Polynom vom Grad p^(n-1) */ if(!(kleinPolynom = (INT *) UE_malloc((kleinGrad+1)*sizeof(INT)))) { SYM_free((char *) NormalPolynom); return no_memory(); } if(!(minPolynom = (INT *) UE_malloc((Grad+1)*sizeof(INT)))) { SYM_free((char *) NormalPolynom); SYM_free((char *) kleinPolynom); return no_memory(); } if(liestracepol(kleinGrad,kleinPolynom,DateiOffen) != OK) { SYM_free((char *) NormalPolynom); SYM_free((char *) minPolynom); SYM_free((char *) kleinPolynom); return error("internal error FF201"); } if(erzmulttafel(Grad,-1,NormalPolynom) != OK) { SYM_free((char *) NormalPolynom); SYM_free((char *) minPolynom); SYM_free((char *) kleinPolynom); return error("internal error FF202"); } kleinElement[0] = kleinGrad; for(i=1;i<=kleinGrad;i++) kleinElement[i] = 0; k = 1; while(k) { j = 1; while(kleinElement[j]==Charakteristik-1) { kleinElement[j] = 0; j++; if (j>kleinGrad) { SYM_free((char *) NormalPolynom); SYM_free((char *) kleinPolynom); SYM_free((char *) minPolynom); UE_Free(& kleinElement); error("internal error FF203"); return ERROR; } } if (j>kleinGrad) { SYM_free((char *) NormalPolynom); SYM_free((char *) kleinPolynom); SYM_free((char *) minPolynom); UE_Free(& kleinElement); error("internal error FF204"); return ERROR; } kleinElement[j]++; /* spur wird mit -Spur von Kleinelement belegt. fuer Trace-kompatibilitaet ist spur == 1 erforderlich auaerdem mua der 1. Koeffizient <> 0 sein, da andernfalls das Element (geschiftet) bereits berprft wurde */ spur = 0; for (i=1;i<=kleinGrad;i++) spur = UE_addg(spur,kleinElement[i]); if(kleinElement[1] && spur == 1) { minimalPolynom(kleinElement,minPolynom); for(i=0;i0;i--) grossElement[i] = grossElement[i-1]; grossElement[0] = Grad; minimalPolynom(grossElement,tracePolynom); UE_Free(& grossElement); /* AK 030294 */ } /****************************************************************************/ else /* Polynom erzeugen aus bestehenden Polynomen */ { /* Belegung von Basis[i] mit Basis[i]^Potenz[i] */ for(i=0;i Lsung x ist a^Grad in Basis 1,a,a^2,a^3, ... Tracecompatibles Polynom f(x) = x^Grad-v[Grad-1]*x^(Grad-1)-v[Grad-2]*x^(Grad-2)-....-v[0] . */ /* Vorbereitungen */ UE_Erw_Grad = Grad; if(!(Permutation = (INT *) UE_malloc(Grad*sizeof(INT)))) return no_memory(); if(!(Gauss = (INT **) UE_malloc(Grad*sizeof(INT*)))) { SYM_free((char *) Permutation); return no_memory(); } if(!(hilfsZeiger = (INT **) UE_malloc((Grad+1)*sizeof(INT*)))) { SYM_free((char *) Permutation); SYM_free((char *) Gauss); return no_memory(); } for(i=0;i<=Grad;i++) UE_Platz(&hilfsZeiger[i]); /* Belegung des 1-Elementes */ hilfsZeiger[0][0] = Grad; for(i=1;i<=Grad;i++) hilfsZeiger[0][i] = 1; /* Belegung von a^1 */ hilfsZeiger[1][0] = Grad; hilfsZeiger[1][1] = 1; for(i=2;i<=Grad;i++) hilfsZeiger[1][i] = 0; /* Belegung von a^2 bis a^(Grad-1) */ for(i=2;i<=Grad;i++) { globalno=1; /* AK 260104*/ UE_mult(&hilfsZeiger[1],&hilfsZeiger[i-1],&hilfsZeiger[i]); globalno=0; } for(i=0;i 99 wird z.B. trac1021.pol gesucht) */ /* wird nach 'G:' gesucht. Die nachfolgenden Zahlen enthalten die */ /* Positionen a[0] bis a[GRAD-1] des zugehrigen Polynoms. */ /* Sollte dieses nicht vorhanden sein, versucht das Programm es zu erzeugen.*/ /* */ /* Rueckgabewert : 0 , falls das Polynom nicht initialisiert werden konnte, */ /* 1 , sonst. */ /* */ /* Verfasser: Ulrich Eidt */ /* Stand : 16.01.94 */ /******************************************************************************/ static INT liestracepol(Grad,tracePolynom,DateiOffen) INT Grad; /* Gibt den gewuenschten Erweiterungsgrad an. */ INT tracePolynom[]; /* Vektor mit Platz fuer die EINTraege des ermittelten */ /* Polynoms (die i-te Stelle von tracePolynom gibt den */ /* Koeffizienten zu x^i an der hoechste Koeffizient wird */ /* (da normiert) nicht belegt)). */ INT DateiOffen; /* Kennzeichen ob die Datei bereits offen ist */ { INT datneu = 0; /* Kennzeichen ob Datei neu */ INT gefunden = 0; /* Kennzeichen ob Polynom gefunden */ INT zahl; /* Einlesevariable */ /* INT gelesen=1;*/ /* Anzahl der gelesenen Zeichen, 0 falls Dateiende*/ INT Pufferzeiger=0; /* Zeiger fuer Bearbeitung des Puffer */ INT hilfsChar=Charakteristik; INT i; INT ret_val = OK; /* Rckgabewert */ char Puffer[50]; /* Einlesepuffer */ char Dateiname[15] ; /* Name der Datei */ char Zeichen; /* Platz fuer ein Zeichen wird benutzt beim */ /* Einlesen des Polynoms */ strcpy(Dateiname,"trace_00.pol"); if (!DateiOffen) { /* Datei oeffnen und erstes Zeichen lesen */ if(Charakteristik<100) { Dateiname[6] = 48+(Charakteristik / 10); Dateiname[7] = 48+(Charakteristik % 10); } else if(Charakteristik>=100000000) { error("ff.c:internal error FF50"); return(0); } else { i = 7; while(hilfsChar) { Dateiname[i--] = 48 + (hilfsChar % 10); hilfsChar /= 10; } } Datei = fopen(Dateiname,"a+"); if (Datei == NULL) { /* Datei = fopen(Dateiname,"w"); if (Datei == NULL) { */ /*printf("Die Datei %s ist nicht erstellbar !\n",Dateiname);*/ // error("ff.c:internal error FF51"); if (erzeugePol(Grad,tracePolynom,0) != OK) return error("ff.c: internal error FF516"); return OK; /* } datneu = 1; */ } } Puffer[0] = 'G'; Pufferzeiger = getString(Grad,&(Puffer[1])); Puffer[Pufferzeiger+1] = ':'; Pufferzeiger += 2; /* Suchen des Strings ('G:') */ fseek(Datei,0,0); i = 0; while(!gefunden && (Zeichen = getc(Datei)) != (char)EOF) { if(Zeichen==Puffer[i]) i++; else i = 0; if (i==Pufferzeiger) gefunden = 1; } /* falls gefunden -> Einlesen */ if (gefunden) { for (i=0;i (char)57) { error("ff.c: internal error FF55"); ret_val = ERROR; } else zahl = zahl*10+(int)Zeichen-48; } tracePolynom[i] = zahl; } } else { if (erzeugePol(Grad,tracePolynom,1) != OK) { error("ff.c: internal error FF56"); fclose(Datei); ret_val = ERROR; } } if (!DateiOffen) { fclose(Datei); Datei = NULL; /* AK 260104 */ } return(ret_val); } INT generators_glnq(n,p,k,v) OP n,p,k,v; /* AK 210104 */ /* Two generating matrices of GL(n,p^k) */ { OP y,z; INT i,j; OP nv,ev,nev; INT erg = OK; CTO(INTEGER,"generators_glnq(1)",n); CTO(INTEGER,"generators_glnq(2)",p); CTO(INTEGER,"generators_glnq(3)",k); SYMCHECK(S_I_I(n)<1,"generators_glnq:degree not > 0 "); SYMCHECK(S_I_I(k)<1,"generators_glnq:power not > 0 "); SYMCHECK(primep(p)==FALSE,"generators_glnq:p not prime "); CE4(n,p,k,v,generators_glnq); CALLOCOBJECT3(nv,ev,nev); erg += m_l_nv(k,nv); erg += m_l_v(k,ev);FORALL(z,ev,{m_i_i(1,z);}); erg += m_l_v(k,nev);FORALL(z,nev,{m_i_i(S_I_I(p)-1,z);}); erg += m_il_v(2,v); z=S_V_I(v,0); erg += m_lh_m(n,n,z); FORALL(y,z,{ m_vector_ff(p,nv,y); }); erg += m_vector_ff(p,ev,S_M_IJ(z,0,S_M_LI(z)-1)); erg += m_vector_ff(p,nev,S_M_IJ(z,0,0)); for (i=0;i0"); SYMCHECK(primep(p)==FALSE,"primitive_element_ff:ip not a prime"); e=callocobject(),a=callocobject(); hoch (p,k,a); first_ff(p,k,e); next(e,e); /* otherwise zero */ do { copy(e,c); i = 1; bb: if (einsp(c) && (i==S_I_I(a)-1)) { copy(e,c); break; } if (einsp(c)) continue; i++; mult_apply(e,c); goto bb; } while(next(e,e)); FREEALL2(a,e); ENDR("primitive_element_ff"); } INT generators_slnq(n,p,k,v) OP n,p,k,v; /* AK 220104 */ /* generator of SL(n,p^k) */ { OP y,z; INT i,j; OP nv,ev,nev; INT erg = OK; CTO(INTEGER,"generators_slnq(1)",n); CTO(INTEGER,"generators_slnq(2)",p); CTO(INTEGER,"generators_slnq(3)",k); SYMCHECK(S_I_I(n)<1,"generators_slnq:degree not > 0 "); SYMCHECK(S_I_I(k)<1,"generators_slnq:power not > 0 "); SYMCHECK(primep(p)==FALSE,"generators_slnq:p not prime "); CE4(n,p,k,v,generators_slnq); nv = callocobject(); m_l_nv(k,nv); ev = callocobject(); m_l_v(k,ev);FORALL(z,ev,{m_i_i(1,z);}); nev = callocobject(); m_l_v(k,nev);FORALL(z,nev,{m_i_i(S_I_I(p)-1,z);}); erg += m_il_v(2,v); z=S_V_I(v,0); erg += m_lh_m(n,n,z); FORALL(y,z,{ m_vector_ff(p,nv,y); }); erg += m_vector_ff(p,ev,S_M_IJ(z,0,S_M_LI(z)-1)); erg += m_vector_ff(p,nev,S_M_IJ(z,0,0)); for (i=0;i=0;i--) AK 290607 { erg += m_i_i(S_FF_II(a,i+1),h); MULT_APPLY(ql,h); ADD_APPLY(h,res); MULT_APPLY(q,ql); } SWAP(b,res); FREEALL4(res,q,ql,h); } ENDR("rank_ff"); } INT unrank_given_q_ff(a,q,b) OP a,q,b; /* a,b may be equal */ /* AK 161204 V3.0 */ { INT erg = OK; CTTO(INTEGER,LONGINT,"unrank_given_q_ff(1)",a); SYMCHECK(NEGP(a),"unrank_given_q_ff(1):negative number"); CTO(INTEGER,"unrank_given_q_ff(2)",q); SYMCHECK(prime_power_p(q)==FALSE,"unrank_given_q_ff(2): no prime power"); { OP v=CALLOCOBJECT(); OP res=CALLOCOBJECT(); OP ca=CALLOCOBJECT(); OP h=CALLOCOBJECT(); INT *ip,i; factorize(q,v); /* v is vector of equal primes */ Charakteristik=S_V_II(v,0); UE_Erw_Grad=S_V_LI(v); erg += init_ff(res); M_I_I(Charakteristik,S_FF_C(res)); ip = S_FF_IP(res); ip[0]=S_V_LI(v); COPY(a,ca); for (i=0;i MAXDEGREE) { UE_IST_NULL( (& S_FF_IP(a))); } else { INT *ip = S_FF_IP(a); INT res,res2; res=memcmp(ip+1, null_ip, S_FF_DI(a)* sizeof(INT)); // res2=UE_ist_null(& S_FF_IP(a)); // printf("res = %d is_null=%d\n", res, res2); if (res == 0) return 1; else return 0; // return res2; } #endif /* FFTRUE */ } /* outside because of macro */ INT mult_ff(a,b,c) OP a,b,c; /* AK 070802 */ { INT erg = OK; #ifdef FFTRUE CTO(FF,"mult_ff(1)",a); CTTO(FF,EMPTY,"mult_ff(3)",c); if (S_O_K(c)==FF) FREESELF(c); switch(S_O_K(b)) { case INTEGER: erg += mult_ff_integer(a,b,c); break; case FF: if (nullp_ff(a)) erg += null_ff(a,c); else erg += mult_ff_ff(a,b,c); break; case MATRIX: /* AK 300304 */ erg += mult_scalar_matrix(a,b,c); break; case MONOM: erg += mult_scalar_monom(a,b,c); break; case POLYNOM: erg += mult_scalar_polynom(a,b,c); break; #ifdef VECTORTRUE case INTEGERVECTOR: case VECTOR: erg += mult_scalar_vector(a,b,c); break; #endif /* VECTORTRUE */ default: WTO("mult_ff(2)",b); break; } #endif /* FFTRUE */ ENDR("mult_ff"); } INT null_ff(a,b) OP a,b; /* given a finite field element, compute the corresponding 0 element */ /* AK 040803 */ /* AK 210704 V3.0 */ { INT erg =OK; CTO(FF,"null_ff(1)",a); { #ifdef FFTRUE INT i,*ip; Charakteristik=S_FF_CI(a); UE_Erw_Grad=S_FF_DI(a); erg += init_ff(b); ip = S_FF_IP(b); for (i=0;i1L) { erg += horizontal_sum(s_pa_i(s_t_u(tab),S_T_HI(tab)-1L-i),y); erg += konjugation(y,tab,i,z); erg += mult_gral_gral(x,z,y); erg += copy(y,x); } } erg += copy(x,h); erg += freeall(u); erg += freeall(w); erg += freeall(x); erg += freeall(y); erg += freeall(z); he: ENDR("hplus"); } INT vminus(tab,v) OP tab,v; /* MB 311290 */ /* AK 200891 V1.3 */ { OP u,w,x,y,z,m,tc; INT erg = OK; INT i; CTO(TABLEAUX,"vminus",tab); if (S_O_K(S_T_U(tab)) != PARTITION) /* AK 310892 */ { return error("vminus:only for TABLEAUX of PARTITION shape"); } if (check_equal_2(tab,v,vminus,&erg) == EQUAL) goto ve; if (tab == v) FATALERROR("vminus"); m = callocobject(); tc = callocobject(); u = callocobject(); w = callocobject(); y = callocobject(); z = callocobject(); if (not EMPTYP(v)) erg += freeself(v); erg += transpose(S_T_S(tab),m); erg += m_matrix_tableaux(m,tc); erg += weight(tc,w); erg += first_permutation(w,u); erg += m_skn_gral(u,cons_eins,NULL,v); for(i=0L;i1L) { erg += vertikal_sum(s_pa_i(S_T_U(tc),S_T_HI(tc)-1-i),y); erg += konjugation(y,tc,i,z); erg += mult(v,z,v); } } erg += freeall(m); erg += freeall(z); erg += freeall(u); erg += freeall(w); erg += freeall(tc); erg += freeall(y); ve: ENDR("vminus"); } INT idempotent(tab,idp) OP tab,idp; /* MB 311290 */ /* AK 200891 V1.3 */ { OP hz,v,h,x; INT erg = OK; hz = callocobject(); h = callocobject(); x = callocobject(); v = callocobject(); erg += hplus(tab,h); erg += vminus(tab,v); erg += mult(h,v,x); erg += dimension(S_T_U(tab),hz); erg += invers(hz,hz); erg += mult(hz,x,idp); erg += freeall(x); erg += freeall(h); erg += freeall(hz); erg += freeall(v); ENDR("idempotent"); } #endif /* TABLEAUXTRUE */ #ifdef CHARTRUE INT zentralprim(part,idp) OP part,idp; /* MB 311290 */ /* AK 200891 V1.3 */ { OP hz,p,v,w,x,y,zt,vecsc; INT ind; INT erg = OK; hz = CALLOCOBJECT(); p = CALLOCOBJECT(); v = CALLOCOBJECT(); w = CALLOCOBJECT(); x = CALLOCOBJECT(); y = CALLOCOBJECT(); init(GRAL,y); zt = CALLOCOBJECT(); vecsc = CALLOCOBJECT(); m_part_sc(part,vecsc); weight(part,w); first_permutation(w,p); do { zykeltyp(p,zt); ind = indexofpart(zt); if(S_I_I(S_V_I(s_sc_w(vecsc),ind))) { m_skn_gral(p,S_V_I(s_sc_w(vecsc),ind), NULL, x); erg += add_apply(x,y); } } while(next_apply(p)); erg += dimension(part,hz); erg += invers(hz,hz); erg += mult(hz,y,v); erg += copy(v,idp); FREEALL(vecsc); FREEALL(v); FREEALL(hz); FREEALL(y); FREEALL(zt); FREEALL(x); FREEALL(p); FREEALL(w); ENDR("zentralprim"); } #endif /* CHARTRUE */ #ifdef POLYTRUE INT konjugation2(gral,perm,res) OP gral, perm, res; /* MB 311290 */ /* AK 200891 V1.3 */ { OP p, v, x, z, zeiger; INT j; p = callocobject(); v = callocobject(); x = callocobject(); z = callocobject(); first_permutation(s_p_l(perm),v); zeiger = gral; while (zeiger != NULL) { copy(v,p); for(j=0L;j0) store_result_2(charac,deg,"galois_mult",mgg_mt); } freeself(mgg_mt); // load mult table check_result_2(charac,deg,"galois_mult",mgg_mt); if (emptyp(mgg_mt)) // first time { OP h=callocobject(); hoch(charac,deg,h); if (S_I_I(h) <= 256) // only table in small cases m_lh_m(h,h,mgg_mt); freeall(h); } copy(charac,mgg_c); copy(deg,mgg_d); mgg_change_counter=0; ENDR("init_galois_global"); } INT galois_anfang() { INT erg =OK; CALLOCOBJECT4(mgg_c,mgg_d,mgg_mt,mgg_pl); M_I_I(0,mgg_c); M_I_I(0,mgg_d); mgg_change_counter=0; ENDR("galois_anfang"); } INT galois_ende() { INT erg =OK; if (S_I_I(mgg_c) != 0) // previously different galois ring { // store mult table if (mgg_change_counter>0) S2R(mgg_c,mgg_d,"galois_mult",mgg_mt); } FREEALL4(mgg_c,mgg_d,mgg_mt,mgg_pl); ENDR("galois_ende"); } INT index_galois(OP g) // index of galois ring element { INT d=S_GR_DI(g); INT c=S_GR_CI(g); INT res=0,i,m; for (i=0,m=1;i= S_M_HI(mgg_mt)) error("mult_galois_galois:I1"); if (p2i >= S_M_HI(mgg_mt)) error("mult_galois_galois:I2"); if (not EMPTYP(S_M_IJ(mgg_mt,p1i,p2i))) // result of multiplicazion is known { copy(S_M_IJ(mgg_mt,p1i,p2i),p3); goto endr_ende; } } CALLOCOBJECT6(poly1,poly2,poly3,poly4,irred,diverg); t_galois_polynom(p1,poly1); t_galois_polynom(p2,poly2); mult(poly1,poly2,poly3); mod(poly3,S_GR_C(p1),poly3); get_galois_irred(p1,irred); quores(poly3,irred,diverg,poly4); mod(poly4,S_GR_C(p1),poly4); t_polynom_galois(poly4,S_GR_CI(p1),S_GR_DI(p1),p3); FREEALL6(poly1,poly2,poly3,poly4,irred,diverg); if (not EMPTYP(mgg_mt)) // check if result available { mgg_change_counter++; copy(p3,S_M_IJ(mgg_mt,p1i,p2i)); } } ENDR("mult_galois"); } INT mult_galois(OP a, OP b, OP c) { INT erg = OK; switch (S_O_K(b)) { case GALOISRING: erg += mult_galois_galois(a,b,c); break; case VECTOR: { INT i; copy(b,c); for (i=0;i=2;i--) if (S_V_II(gr1,i) < c-1) { INC_INTEGER(S_V_I(gr1,i)); for (j=i+1;j=2;i--) if (S_V_II(gr2,i) < c-1) { INC_INTEGER(S_V_I(gr2,i)); for (j=i+1;j1)&&(i>0)) { OP lv; lv=CALLOCOBJECT(); m_il_nv(i,lv); // nv ist die schleife über alle füllungen , nullvektor ist start nn: for (j=S_V_LI(lv)-1;j>=0;j--) { if (S_V_II(lv,j)+1 < S_V_LI(nv)) { inc(S_V_I(lv,j)); for (++j;jgr_kind); } #endif /* GRAPHTRUE */ #ifdef GRAPHTRUE OP s_gr_s(a) OP a; /* AK 210889 */ /* AK 210891 V1.3 */ { OBJECTSELF b; b = s_o_s(a); return(b.ob_graph->gr_self); } #endif /* GRAPHTRUE */ #ifdef GRAPHTRUE INT c_gr_s(a,c) OP a,c; /* AK 210889 */ /* AK 210891 V1.3 */ { OBJECTSELF b; b = s_o_s(a); b.ob_graph->gr_self = c; return(OK); } #endif #ifdef GRAPHTRUE INT c_gr_k(a,c) OP a; OBJECTKIND c; /* change_graph_kind */ /* AK 210889 */ /* AK 210891 V1.3 */ { OBJECTSELF b; b = s_o_s(a); (b.ob_graph)->gr_kind = c; return(OK); } #endif INT m_sk_gr(self,kind,erg) OP self,erg; OBJECTKIND kind; /* make_self_kind_graph */ /* AK 210889 */ /* AK 210891 V1.3 */ { #ifdef GRAPHTRUE struct graph *mallocerg; mallocerg = (struct graph *) malloc(sizeof(struct graph)); if (mallocerg == NULL) { error("m_sk_gr:no memory"); return(ERROR); } c_o_s(erg,mallocerg); c_o_k(erg,GRAPH); c_gr_k(erg,kind); c_gr_s(erg,self); return(OK); #else error("m_sk_gr:GRAPH not available"); return(ERROR); #endif } #ifdef GRAPHTRUE OP s_gr_kn(a) OP a; /* select_graph_knotenliste */ /* AK 210889 */ /* AK 210891 V1.3 */ { /* die knoten elemente sind das erste vector element im self vector */ OP h = s_gr_s(a); if (s_o_k(h) != VECTOR) { error("s_gr_kn:not VECTOR"); return(NULL); } return(s_v_i(h,0L)); } #endif OP s_gr_kni(a,i) OP a; INT i; /* select_graph_knotenliste das ite element*/ /* AK 210889 */ /* AK 210891 V1.3 */ { #ifdef GRAPHTRUE return(s_v_i(s_gr_kn(a),i)); #else error("s_gr_kni:GRAPH not available"); return(NULL); #endif } #ifdef GRAPHTRUE OP s_gr_na(a) OP a; /* select_graph_nachbarschaftsliste */ /* AK 210889 */ /* AK 210891 V1.3 */ { /* die nachbarschaftsliste ist das zweite vector element im self vector */ return(s_v_i(s_gr_s(a),1L)); } #endif OP s_gr_nai(a,i) OP a; INT i; /* select_graph_nachbarschaftsliste das ite Element, was selber ein VECTOR ist */ /* AK 210889 */ /* AK 210891 V1.3 */ { #ifdef GRAPHTRUE return(s_v_i(s_gr_na(a),i)); #else error("s_gr_nai:GRAPH not available"); return(NULL); #endif } #ifdef GRAPHTRUE OP s_gr_koor(a) OP a; /* select_graph_koordinaten */ /* AK 250889 */ /* AK 210891 V1.3 */ { /* die koordinatenliste ist das dritte vector element im self vector */ return(s_v_i(s_gr_s(a),2L)); } #endif OP s_gr_koori(a,i) OP a; INT i; /* select_graph_koordinatenliste das ite Element, was selber ein VECTOR ist */ /* AK 250889 */ /* AK 210891 V1.3 */ { #ifdef GRAPHTRUE return(s_v_i(s_gr_koor(a),i)); #else error("s_gr_koori:GRAPH not available"); return(NULL); #endif } OP s_gr_xkoori(a,i) OP a; INT i; /* select_graph_koordinatenliste das ite Element, was selber ein VECTOR ist und davon die xkoordinate */ /* AK 250889 */ /* AK 210891 V1.3 */ { #ifdef GRAPHTRUE return(s_v_i(s_gr_koori(a,i),0L)); #else error("s_gr_xkoori:GRAPH not available"); return(NULL); #endif } OP s_gr_ykoori(a,i) OP a; INT i; /* select_graph_koordinatenliste das ite Element, was selber ein VECTOR ist und davon die ykoordinate */ /* AK 250889 */ /* AK 210891 V1.3 */ { #ifdef GRAPHTRUE return(s_v_i(s_gr_koori(a,i),1L)); #else error("s_gr_ykoori:GRAPH not available"); return(NULL); #endif } #ifdef GRAPHTRUE INT m_vector_graph(vector,kf,erg) OP vector,erg; INT (* kf)(); /* macht aus einem vector von objecten und einer funktion kf die testet ob zwischen zwei objecten eine kante ist einen graphen */ /* kf gibt true oder false zurueck */ /* AK 210889 */ /* AK 210891 V1.3 */ { INT i,j; INT dt=0; m_sk_gr(callocobject(),NACHBARLISTE,erg); if (dt) { fprintf(stderr,"m_vector_graph:erg(1)="); fprintln(stderr,erg); } m_il_v(2L,s_gr_s(erg)); if (dt) { fprintf(stderr,"m_vector_graph:erg(2)="); fprintln(stderr,erg); } copy(vector,s_gr_kn(erg)); if (dt) { fprintf(stderr,"m_vector_graph:knotenvector="); fprintln(stderr,s_gr_kn(erg)); } /* die knoten sind die elemente im vector */ m_il_v(s_v_li(vector),s_gr_na(erg)); if (dt) { fprintf(stderr,"m_vector_graph:nachbarschaftsliste="); fprintln(stderr,s_gr_na(erg)); } /* die nachbarschaftsliste hat die laenge des vectors */ for (i=0;i=0 ;i--) { fprintf(texout,"\\put(%d,%d){ \n",s_i_i(s_gr_xkoori(a,i)), s_i_i(s_gr_ykoori(a,i))); tex(s_gr_kni(a,i)); fprintf(texout,"}\n"); } /* nun kommen die verbindungen */ for (i=s_v_li(s_gr_koor(a))-1; i>=0 ;i--) for (j=0; js_v_ii(s_gr_nai(a,i),j)) latex_line( xanfang,yanfang, xende,yende); } fprintf(stderr,"\n\\end{picture}\n"); return OK; } #endif /* GRAPHTRUE */ #ifdef GRAPHTRUE INT latex_line(vonx,vony,nachx,nachy) INT vonx,vony,nachx,nachy; /* latex befehl um line zu zeichen */ /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 210891 V1.3 */ { fprintf(texout,"\\bezier{%d}",(nachx-vonx)/1000+(nachy-vony)/1000); fprintf(texout,"(%d,%d)",vonx,vony); fprintf(texout,"(%d,%d)", (vonx+nachx)/2, (vony+nachy)/2); fprintf(texout,"(%d,%d)\n",nachx,nachy); return OK; } #endif /* GRAPHTRUE */ /* AK 240603 */ /* routines for the managment of adjacency matrices */ INT add_adjacency_matrix(a,b,c) OP a,b,c; /* AK builds the adjacancy matrix corresponding to the disjoint union of two graphs */ /* AK 240603 */ { INT erg = OK; INT i,j; CTTO(MATRIX,INTEGERMATRIX,"add_adjacency_matrix(1)",a); CTTO(MATRIX,INTEGERMATRIX,"add_adjacency_matrix(2)",b); SYMCHECK(S_M_HI(a) != S_M_LI(a),"add_adjacency_matrix(1):not quadratic"); SYMCHECK(S_M_HI(b) != S_M_LI(b),"add_adjacency_matrix(1):not quadratic"); CE3(a,b,c,add_adjacency_matrix); m_ilih_nm(S_M_HI(a)+S_M_HI(b),S_M_HI(a)+S_M_HI(b),c); for (i=0;i0 ;i--,ap++,bp++) { if (not EMPTYP(ap)) erg += copy_vector(ap,bp); else C_I_I(bp,S_I_I(ap)); } ENDR("copy_hashtable"); } INT mem_size_hashtable(a) OP a; /* AK 080903 */ { INT erg = OK, res = 0; CTO(HASHTABLE,"mem_size_hashtable(1)",a); res = mem_size_vector(a); res += sizeof(struct object); /* length of hashtable as appendix */ return res; ENDR("mem_size_hashtable"); } INT mult_apply_scalar_hashtable(a,b) OP a,b; /* AK 171001 */ { INT erg = OK; OP z; CTO(HASHTABLE,"mult_apply_scalar_hashtable(1)",b); FORALL(z,b, { MULT_APPLY(a,z); } ); CTO(HASHTABLE,"mult_apply_scalar_hashtable(1-end)",b); ENDR("mult_apply_scalar_hashtable"); } INT mult_apply_integer_hashtable(a,b) OP a,b; /* AK 171001 */ { INT erg = OK; OP z; CTO(HASHTABLE,"mult_apply_integer_hashtable(2)",b); CTO(INTEGER,"mult_apply_integer_hashtable(1)",a); FORALL(z,b, { MULT_APPLY_INTEGER(a,z); } ); ENDR("mult_apply_integer_hashtable"); } INT mult_integer_hashtable(a,b,c) OP a,b,c; /* AK 310102 */ { INT erg = OK; OP z; CTO(HASHTABLE,"mult_integer_hashtable(2)",b); CTO(INTEGER,"mult_integer_hashtable(1)",a); CTO(EMPTY,"mult_integer_hashtable(3)",c); erg += copy_hashtable(b,c); FORALL(z,c, { MULT_APPLY_INTEGER(a,z); } ); ENDR("mult_integer_hashtable"); } INT mult_bruch_hashtable(a,b,c) OP a,b,c; /* AK 310102 */ { INT erg = OK; OP z; CTO(HASHTABLE,"mult_bruch_hashtable(2)",b); CTO(BRUCH,"mult_bruch_hashtable(1)",a); CTO(EMPTY,"mult_bruch_hashtable(3)",c); erg += copy_hashtable(b,c); FORALL(z,c, { MULT_APPLY_BRUCH(a,z); } ); ENDR("mult_bruch_hashtable"); } INT mult_apply_bruch_hashtable(a,b) OP a,b; /* AK 171001 */ { INT erg = OK; OP z; CTO(HASHTABLE,"mult_apply_bruch_hashtable(2)",b); CTO(BRUCH,"mult_apply_bruch_hashtable(1)",a); FORALL(z,b, { MULT_APPLY_BRUCH(a,z); } ); ENDR("mult_apply_bruch_hashtable"); } INT addinvers_apply_hashtable(a) OP a; /* AK 231001 */ { INT erg = OK; OP z; CTO(HASHTABLE,"addinvers_apply_hashtable(1)",a); FORALL(z,a, { ADDINVERS_APPLY(z); } ); ENDR("addinvers_apply_hashtable"); } INT add_apply_hashtable(a,b,eh,ef,hf) OP a,b; INT (*ef)();INT (*hf)(); INT (*eh)(); /* AK 141101 */ /* first lookup a in b, if not yet here it inserts a copy, else it applys the eh function */ { INT erg = OK; OP z; CTO(HASHTABLE,"add_apply_hashtable(2)",b); z = find_hashtable(a,b,ef,hf); if (z == NULL) { OP m; m = CALLOCOBJECT(); COPY(a,m); INSERT_HASHTABLE(m,b,eh,ef,hf); } else { if (eh == NULL) ; else if (eh == add_koeff) { ADD_KOEFF(a,z); if (EMPTYP(z)) DEC_INTEGER(S_V_I(b,S_V_LI(b))); /* counter-- */ } else { (*eh)(a,z); if (EMPTYP(z)) DEC_INTEGER(S_V_I(b,S_V_LI(b))); /* counter-- */ } } ENDR("add_apply_hashtable"); } OP find_hashtable(a,b,ef,hf) OP a,b; INT (*ef)();INT (*hf)(); /* AK 281097 */ /* find a object in hashtable b */ /* return s NULL if not find, else returns OP pointer */ { OP z,z1; INT i,hi,hh,hhh; INT erg = OK; CTO(HASHTABLE,"find_hashtable(2)",b); if (hf == NULL) hf = hash; if (hf == hash_monompartition) hh = HASH_MONOMPARTITION(a); else if (hf == hash) hh = HASH(a); else if (hf == hash1) hh = HASH(S_V_I(a,0)); else hh = (*hf)(a); hi = hh % S_V_LI(b); if (hi < 0) hi += S_V_LI(b); z = S_V_I(b,hi); if (EMPTYP(z)) return NULL; for (i=0,z1 = S_V_S(z) ;iob_self.ob_INT = -1; }\ M_I_I(0,S_V_I(a,i)); \ } while(0) INT init_hashtable(a) OP a; /* AK 281097 */ /* initialize a hashtable */ { INT erg = OK; CTO(EMPTY,"init_hashtable(1)",a); INIT_HASH_TABLE_SIZE(a,1009); ENDR("init_hashtable"); } INT init_size_hashtable(a,b) OP a; INT b; { OP c; INT erg = OK; SYMCHECK( b < 1, "non positive size in init_size_hashtable(2)"); NEW_INTEGER(c,b); while (not primep(c)) INC_INTEGER(c); INIT_HASH_TABLE_SIZE(a,S_I_I(c)); FREEALL(c); ENDR("init_size_hashtable"); } INT clone_size_hashtable(a,b) OP a; INT b; { INT erg = OK; CTO(EMPTY,"clone_size_hashtable(1)",a); CTO(INTTYPE,"clone_size_hashtable(2)",b); INIT_HASH_TABLE_SIZE(a,b); ENDR("clone_size_hashtable"); } INT insert_hashtable_hashtable(a,b,eh , cf,hf) OP a,b; INT (*eh)(), (*cf)(), (*hf)(); { INT erg = OK; OP z; CTO(HASHTABLE,"insert_hashtable_hashtable(1)",a); CTO(HASHTABLE,"insert_hashtable_hashtable(2)",b); FORALL(z,a, { OP f; f = CALLOCOBJECT(); SWAP(z,f); insert_scalar_hashtable(f,b,eh , cf,hf); } ); M_I_I(0,S_V_I(a,S_V_LI(a))); FREEALL(a); ENDR("insert_hashtable_hashtable"); } #define INSERT_SF_HASHTABLE(a,b,eh , cf,hf)\ do {OP z; \ z = a;\ if (S_L_S(z) != NULL)\ while (z!= NULL)\ {\ erg += insert_scalar_hashtable(S_L_S(z), b,eh , cf,hf);\ C_L_S(z,NULL);\ z = S_L_N(z);\ }\ FREEALL(a); \ } while(0) INT insert_monomial_hashtable(a,b,eh , cf,hf) OP a,b; INT (*eh)(), (*cf)(), (*hf)(); /* AK 131101 */ { INT erg = OK; CTO(MONOMIAL,"insert_monomial_hashtable(1)",a); CTO(HASHTABLE,"insert_monomial_hashtable(2)",b); INSERT_SF_HASHTABLE(a,b,eh , cf,hf); ENDR("insert_monomial_hashtable"); } INT insert_schur_hashtable(a,b,eh , cf,hf) OP a,b; INT (*eh)(), (*cf)(), (*hf)(); /* AK 131101 */ { INT erg = OK; CTO(SCHUR,"insert_schur_hashtable(1)",a); CTO(HASHTABLE,"insert_schur_hashtable(2)",b); INSERT_SF_HASHTABLE(a,b,eh , cf,hf); ENDR("insert_schur_hashtable"); } INT insert_homsym_hashtable(a,b,eh , cf,hf) OP a,b; INT (*eh)(), (*cf)(), (*hf)(); /* AK 131101 */ { INT erg = OK; CTO(HOMSYM,"insert_homsym_hashtable(1)",a); CTO(HASHTABLE,"insert_homsym_hashtable(2)",b); INSERT_SF_HASHTABLE(a,b,eh , cf,hf); ENDR("insert_homsym_hashtable"); } INT insert_powsym_hashtable(a,b,eh , cf,hf) OP a,b; INT (*eh)(), (*cf)(), (*hf)(); /* AK 131101 */ { INT erg = OK; CTO(POWSYM,"insert_powsym_hashtable(1)",a); CTO(HASHTABLE,"insert_powsym_hashtable(2)",b); INSERT_SF_HASHTABLE(a,b,eh , cf,hf); ENDR("insert_powsym_hashtable"); } INT insert_elmsym_hashtable(a,b,eh , cf,hf) OP a,b; INT (*eh)(), (*cf)(), (*hf)(); /* AK 131101 */ { INT erg = OK; CTO(ELMSYM,"insert_elmsym_hashtable(1)",a); CTO(HASHTABLE,"insert_elmsym_hashtable(2)",b); INSERT_SF_HASHTABLE(a,b,eh , cf,hf); ENDR("insert_elmsym_hashtable"); } INT insert_hashtable(a,b,eh , cf,hf) OP a,b; INT (*eh)(), (*cf)(), (*hf)(); /* AK 281097 */ /* insert into a hashtable */ /* AK 131101 */ { INT erg = OK; CTO(HASHTABLE,"insert_hashtable(2)",b); if (S_O_K(a) == HASHTABLE) erg += insert_hashtable_hashtable(a,b,eh,cf,hf); else if (S_O_K(a) == MONOMIAL) erg += insert_monomial_hashtable(a,b,eh,cf,hf); else if (S_O_K(a) == SCHUR) erg += insert_schur_hashtable(a,b,eh,cf,hf); else if (S_O_K(a) == ELMSYM) erg += insert_elmsym_hashtable(a,b,eh,cf,hf); else if (S_O_K(a) == HOMSYM) erg += insert_homsym_hashtable(a,b,eh,cf,hf); else if (S_O_K(a) == POWSYM) erg += insert_powsym_hashtable(a,b,eh,cf,hf); else erg += insert_scalar_hashtable(a,b,eh,cf,hf); ENDR("insert_hashtable"); } INT insert_scalar_hashtable(a,b,eh,ef,hf) OP a,b; INT (*eh)(), (*ef)(), (*hf)(); /* AK 281097 */ /* AK 131101 */ { INT i,index,freeindex=-1,hv,hvv; INT erg = OK; OP z,zz; COP("insert_scalar_hashtable(1)",a); CTO(HASHTABLE,"insert_scalar_hashtable(2)",b); /* einfach einfuegen */ if (hf == NULL) hf = hash; if (hf == hash) hv = HASH(a); else if (hf == hash_monompartition) hv = HASH_MONOMPARTITION(a); else hv = (*hf)(a); index = hv % S_V_LI(b); if (index < 0) index += S_V_LI(b); z = S_V_I(b,index); if (EMPTYP(z)) { B_O_V(a,z); INC_INTEGER(S_V_I(b,S_V_LI(b))); /* counter++ */ for (zz=S_V_I(b,index-1),i=index-1; i>=0; i--,zz--) if (EMPTYP(zz)) S_O_S(zz).ob_INT=index; else break; } else { /* collision test */ if (ef == NULL) ef = eq; for (zz= S_V_I(z,S_V_LI(z)-1),i=S_V_LI(z)-1;i>=0;i--,zz--) { if (EMPTYP(zz)) freeindex = i; else { if (hf == hash) hvv=HASH(zz); else if (hf == hash_monompartition) hvv=HASH_MONOMPARTITION(zz); else hvv=(*hf)(zz); if ( (hv == hvv) && ((*ef)(a,zz) == TRUE) ) { /* there is a collision */ if (eh != NULL) { if (eh == add_koeff) {ADD_KOEFF(a,zz);} else (*eh)(a,zz); FREEALL(a); if (EMPTYP(zz)) DEC_INTEGER(S_V_I(b,S_V_LI(b))); /* counter-- */ } else { FREEALL(a); } goto ende; } } } /* nicht da */ if (freeindex < 0) { freeindex = S_V_LI(z); inc_vector_co(z,3); } INC_INTEGER(S_V_I(b,S_V_LI(b))); /* counter++ */ SWAP(a,S_V_I(z,freeindex)); FREEALL(a); } /* AK 240901 */ /* if the table is full, i.e. number of entires > length increase the size by factor 2 */ if ( (S_V_LI(b) < WEIGHT_HASHTABLE(b)) ) erg += double_hashtable(b,hf); ende: ENDR("insert_scalar_hashtable"); } #ifdef UNDEF INT double_hashtable_pre091101(b,hf) OP b; INT (*hf)(); { INT erg = OK; OP d; CTO(HASHTABLE,"double_hashtable(1)",b); d = CALLOCOBJECT(); SWAP(b,d); erg += init_size_hashtable(b,S_V_LI(d)*2); insert_hashtable_hashtable(d,b,NULL,NULL,hf); ENDR("double_hashtable"); } #endif INT print_stat_hashtable(a) OP a; /* AK 0602002 */ { INT i; printf("entries = %ld size = %ld\n",S_V_II(a,S_V_LI(a)),S_V_LI(a)); printf("entires per slot (>1 == collision)\n"); for (i=0;i=0;i--) { if (not EMPTYP(S_V_I(b,i))) { z = S_V_I(b,i); for (j=0;j=l;i--,z--) if (EMPTYP(z)) C_I_I(z,k); else k = i; for (;i>=0;i--,z--) if (EMPTYP(z)) { /* SYMCHECK(S_I_I(z) != -1,"double_hashtable:e2"); */ C_I_I(z,k); } else break; CTO(HASHTABLE,"double_hashtable(1-end)",b); ENDR("double_hashtable"); } INT split_hashtable(a,b,c) OP a,b,c; /* AK 201201 */ { INT i,t=0,h=0,erg = OK; OP z; CTO(HASHTABLE,"split_hashtable(1)",a); CTO(EMPTY,"split_hashtable(2)",b); CTO(EMPTY,"split_hashtable(3)",c); SYMCHECK(WEIGHT_HASHTABLE(a)<=1, "split_hashtable:<2 entries"); m_il_v(S_V_LI(a)+1,b);C_O_K(b,HASHTABLE);M_I_I(S_V_LI(a),S_V_L(b)); m_il_v(S_V_LI(a)+1,c);C_O_K(c,HASHTABLE);M_I_I(S_V_LI(a),S_V_L(c)); for (i=0;i 30 ) /* more then 30 entries *//* AK 260901 */\ erg += init(BINTREE,b);\ else\ erg += init(t,b);\ \ for (i=0;i 30 ) /* more then 30 entries *//* AK 260901 */\ erg += init_bintree(b);\ else\ erg += init(typ,b);\ \ for (i=0;i LIST (next) --> MONOM --> TABLEAUX --> MONOPOLY (LIST) --> MONOPOLY (next) --> MONOM --> INTEGER (power) --> INTEGER (coefficient). A similar structure is used for q-linear combinations of permutations. */ #define NORMALISE 1 /* if 1, monopolies are tidied up wrt roots of unity */ #include "def.h" #include "macro.h" static OP children=NULL; /* AK 150197 */ /* function prototypes for generic representation routines */ #ifdef UNDEF INT generate_standard_tableaux (OP partition, OP std); INT hecke_generator_reps (OP partition, OP vector); INT represent_hecke_element (OP partition, OP hecke, OP mat); INT build_lc (OP schizo, OP list); INT hecke_action_lc_on_lc (OP tableaux, OP hecke, OP result); INT standardise_cold_tableaux_list (OP tableaux, OP result); INT input_tableau (OP partit, OP tab); INT input_lc_permutations (OP save); INT substitute_one_matrix (OP mat); INT substitute_one_monopoly (OP mp); INT set_garnir_parameters (OP partition); INT free_garnir_parameters (void); INT set_useful_monopolies (void); INT free_useful_monopolies (void); set_multiplier (OP extra); hecke_action (OP tableau, OP permutation, OP list); INT hecke_action_perm_on_lc (OP tableaux, OP permutation); INT find_non_rowstandard_pos (OP tableau, INT *r, INT *c); INT columns_standardise_tableau (OP tableau, INT *sig); INT column_standardise_tableau (OP tableau, INT col, INT *sig); static int standardise_tableau_list (OP list, OP expression); static int standardise_tableau (OP tableau, OP expression); garnir_juggle (OP tableau, INT power, INT coeff); static garnir_generate (INT head, INT wag); static garnir_result (OP tableau, OP mp_coeff, OP acc_list); INT enter_list_to_matrix (OP matrix, INT column, OP standard, OP express); static INT construct_mo_mp (INT power, INT coeff, OP mo_po); memory_check (void *query); /* function prototypes for non-generic representation routines */ INT root_dimension (OP partition, OP p_root, OP dim); INT generate_root_tableaux (OP partition, OP p_root, OP std); INT hecke_root_generator_reps (OP partition, OP p_root, OP vector); INT root_represent_hecke_action (OP partition, OP p_root, OP hecke, OP mat); INT root_standardise_cold_tableaux_list (OP tableaux, OP p_root, OP result); INT set_root_parameters (OP partition, OP p_root); INT free_root_parameters (void); INT find_non_root_standard_pos (OP tableau); set_root_multiplier (OP extra); root_standardise_tableau_list (OP list, OP expression); root_standardise_tableau (OP tableau, OP expression); root_juggle (OP tableau, INT power, INT coeff); strip_juggle (OP tableau, INT power, INT coeff); root_garnir_result (OP tableau, OP mp_coeff, OP acc_list); INT root_normalise_monopoly (OP mono); generate_sym_tableaux_list (INT piece, OP sym_list); coset_generate (INT head, INT wag); INT remove_mp_qnumber_fac (OP mp, INT qn); INT remove_vec_qnumber (INT qn); /* function prototypes for matrix representation checking routines */ INT check_hecke_generators (OP vector, OP p_root, INT flag); INT check_hecke_quadratic (OP mat, OP p_root, INT flag); INT check_braid (OP mat1, OP mat2, OP p_root, INT flag); INT check_commute (OP mat1, OP mat2, OP p_root, INT flag); INT set_cyclotomic_parameters (OP p_root); INT free_cyclotomic_parameters (); INT check_zero_matrix (OP mat, OP p_root); /* function prototypes to add or multiply hecke algebra elements */ INT hecke_add (OP hecke1, OP hecke2, OP result); INT hecke_mult (OP hecke1, OP hecke2, OP result); INT hecke_scale (OP hecke, OP power, OP coeff); INT hecke_action_perm_on_hecke (OP heck, OP permutation); /* function prototypes for some debugging routines */ strip_buggle (OP tableau); dump_lc_list (OP list); dump_monopoly (OP mp); #endif static int standardise_tableau (); static int standardise_tableau_list(); static int garnir_juggle (); static INT free_garnir_parameters(); static INT set_garnir_parameters(); static int garnir_generate (); static int garnir_result (); static INT construct_mo_mp (); static void hecke_accum (OP perm, OP mp_coeff, OP acc_list); #ifdef TABLEAUXTRUE INT generate_standard_tableaux (partition,std) OP partition; OP std; /* generates all the S_n standard tableaux for the partition. returns the number of standard tableaux, else ERROR. */ { OP t,last,n; INT count=0; /* validate parameters */ if (partition==NULL || S_O_K(partition)!=PARTITION) { printf("generate_standard_tableaux() did not receive a partition as it was expecting!\n"); return(ERROR); } weight(partition,n=callocobject()); last_partition(n,last=callocobject()); kostka_tab(partition,last,std); freeall(n); freeall(last); if (!empty_listp(std)) for (t=std;t!=NULL;t=S_L_N(t),count++); return(count); } #endif /* TABLEAUXTRUE */ #ifdef PARTTRUE INT hecke_generator_reps ( partition, vector) OP partition; OP vector; /* for the given partition produces a vector of matrices, the ith of which represents the ith generator s_i. */ { INT i,ni; OP n,p,lc,mat; /* validate parameters */ if (partition==NULL || S_O_K(partition)!=PARTITION) { printf("hecke_generator_reps() did not receive a partition as it was expecting!\n"); return(ERROR); } weight(partition,n=callocobject()); ni=S_I_I(n); freeall(n); /* construct and intialize a permutation which will be passed to the representing routines. */ m_il_p(ni,p=callocobject()); for (i=0;i=0 && entries[i]==1;i--); if (i<0) return(OK); else { printf("Inappropriate tableau was entered!\n"); return(ERROR); } } #endif /* TABLEAUXTRUE */ INT input_lc_permutations (save) OP save; { char resp[8]; OP a,b,c,perm,poly,monom,temp; init(LIST,save); a=callocobject(); b=callocobject(); do { fprintf(stderr,"Enter permutation (coefficient to follow):\n"); scan(PERMUTATION,perm=callocobject()); init(MONOPOLY,poly=callocobject()); do { fprintf(stderr,"Enter exponent: \n"); scan(INTEGER,a); fprintf(stderr,"Enter coefficient: \n"); scan(INTEGER,b); m_skn_mp(a,b,NULL,c=callocobject()); insert(c,poly,add_koeff,NULL); fprintf(stderr,"Current term is: \n"); fprint(stderr,poly); fprintf(stderr," * "); fprintln(stderr,perm); fprintf(stderr,"continue adding to coefficient? \n"); scanf("%6s",resp); } while (resp[0]=='y'); b_sk_mo(perm,poly,monom=callocobject()); if (empty_listp(save)) { c_l_s(save,monom); } else { b_ks_o(S_O_K(save),S_O_S(save),temp=callocobject()); /* c_o_s(save,NULL); */ c_o_k(save,EMPTY); b_sn_l(monom,temp,save); } fprintf(stderr,"continue adding terms? \n"); scanf("%6s",resp); } while (resp[0]=='y'); freeall(a); freeall(b); return(OK); } INT substitute_one_matrix (mat) OP mat; /* every entry in the matrix that is a MONOPOLY object is changed an INTEGER object having the value obtained by setting q=1 in the original entry. Returns an ERROR if a MATRIX is not passed. */ { INT i,j; if (S_O_K(mat)!=MATRIX) { printf("substitute_one_matrix() did not receive a matrix as it was expecting!\n"); return(ERROR); } for (i=0;i=0;j--) { while (ij) i++; conj[j]=i; } /* set up arrays that will be used to store certain permutations */ for (i=0;i<=no_rows;i++) garnir_sym[i]=garnir_inv[i]=i; garnir_len=0; set_useful_monopolies(); ENDR("set_garnir_parameters"); } static INT free_garnir_parameters () /* Frees the five arrays that were constructed to facilitate Garnir relations. But only if garnir_ready==1. */ { if (!--garnir_ready) { SYM_free(part); SYM_free(conj); SYM_free(garnir_sym); SYM_free(garnir_inv); SYM_free(entry_list); free_useful_monopolies(); } return(OK); } INT set_useful_monopolies () /* create monopolys which store (q) and (q-1) for ready use */ { OP temp; if (monopoly_ready++) return(OK); q_mp=callocobject(); qm1_mp=callocobject(); temp=callocobject(); construct_mo_mp(1,1,q_mp); construct_mo_mp(1,1,qm1_mp); construct_mo_mp(0,-1,temp); C_L_N(qm1_mp,temp); /* to link q and -1 */ return(OK); } INT free_useful_monopolies () /* Frees the monopolies created by the above. But only if monopoly_ready==1. */ { if (!--monopoly_ready) { freeall(q_mp); freeall(qm1_mp); } return(OK); } int set_multiplier (extra) OP extra; /* all standard tableaux that are now found are added to the list after their coefficients have been multiplied by extra (which will usually be a MONOPOLY object). */ { multiplier=extra; } int hecke_action ( tableau, permutation, list) OP tableau; OP permutation; OP list; /* The permutation acts upon the tableau to produce a monom list, each element of which consists of a tableau and a monopoly coefficient. Requires that set_garnir_parameters() has been invoked. */ { OP perm_cop,tab_cop,tab_mp,tab_mo; /* make a copy of the original permutation so that we can manipulate it */ copy_permutation(permutation,perm_cop=callocobject()); /* and form a list with the tableau as only element */ copy_tableaux(tableau,tab_cop=callocobject()); construct_mo_mp(0,1,tab_mp=callocobject()); b_sk_mo(tab_cop,tab_mp,tab_mo=callocobject()); b_sn_l(tab_mo,NULL,list); hecke_action_perm_on_lc(list,perm_cop); /* perm_cop freed in hecke_action_perm_on_lc */ } static INT axel_ll,axel_kk; INT hecke_action_perm_on_lc ( tableaux, permutation) OP tableaux; OP permutation; /* Applies the hecke algebra permutation to the linear combination of tableaux. This list is updated with the result and the permutation is freed. There is no attempt to collect terms in the result. Requires that set_garnir_parameters() has been invoked. An ERROR may be generated if permutation is from a group bigger than the entries from tableaux. */ { INT i,j,k,ll; INT trev_lo_col,lo_row,hi_col,hi_row; OP tab,temp,new,coeff,monom,ext; /* println(tableaux); println(permutation); */ if (empty_listp(tableaux)) { freeall(permutation); return(OK); } /* ensure that set_garnir_parameters() has been invoked */ set_garnir_parameters(s_t_u(S_MO_S(S_L_S(tableaux)))); while (1) { /* look for a right factor s_k in reduced expression for permutation */ for (k=S_P_LI(permutation)-1;k>0 && S_P_II(permutation,k)>S_P_II(permutation,k-1);k--); if (!k) /* none present */ break; /* now apply s_k to list of tableaux */ temp=tableaux; while (temp!=NULL) { tab=S_MO_S(S_L_S(temp)); /* println(tab); */ lo_row= -1; hi_row= -1; /* printf("1\n"); */ /* trawl through positions of tableau looking for k & k+1 */ for (j=0;j -1) /* position of k already located */ { /* printf("3 lo_row=%d trev_lo_col=%d k=%d\n",lo_row,trev_lo_col,k);*/ /* enact the tranposition; coefficient is unchanged */ /* printf("1 i=%d j=%d lo_row=%d trev_lo_col=%d\n",i,j,lo_row,trev_lo_col); */ C_I_I(S_T_IJ(tab,lo_row,trev_lo_col),k+1); C_I_I(S_T_IJ(tab,i,j),k); temp=S_L_N(temp); goto there; /* end processing of current tableau */ } else { hi_row=i; /* printf("4\n");*/ hi_col=j; } } else if (S_T_IJI(tab,i,j)==k) { axel_kk=ll=hi_col; /* do not remove this is to prevent optimizer from generating wrong code on btm2x5 */ axel_ll=ll=hi_row; /* do not remove this is to prevent optimizer from generating wrong code on btm2x5 */ if (hi_row > -1) /* position of k+1 already located */ { /*printf("5\n");*/ /* form a new element in the list, obtained by simple tranposition and multiply coeff by q. */ new=callocobject(); copy_tableaux(tab,new); C_I_I(S_T_IJ(new,hi_row,hi_col),k); C_I_I(S_T_IJ(new,i,j),k+1); /*printf("2 i=%d j=%d hi_row=%d hi_col=%d\n",i,j,hi_row,hi_col);*/ mult_monopoly_monopoly(q_mp,S_MO_K(S_L_S(temp)), coeff=callocobject()); b_sk_mo(new,coeff,monom=callocobject()); b_sn_l(monom,S_L_N(temp),ext=callocobject()); C_L_N(temp,ext); /* multiply old coefficient by q-1 */ mult_apply_monopoly(qm1_mp,S_MO_K(S_L_S(temp))); temp=S_L_N(ext); goto there; /* end processing of current tableau */ } else { /*printf("6 i=%d j=%d\n",i,j);*/ lo_row=i; trev_lo_col=j; /*printf("6 lo_row=%d trev_lo_col=%d\n",lo_row,trev_lo_col);*/ } axel_ll=ll=trev_lo_col; /* do not remove this is to prevent optimizer from generating wrong code on btm2x5 */ } axel_ll=ll=trev_lo_col; /* do not remove this is to prevent optimizer from generating wrong code on btm2x5 */ } axel_ll=ll=trev_lo_col; /* do not remove this is to prevent optimizer from generating wrong code on btm2x5 */ } /* if we get here then we have not found both k & k+1 */ fprintf(stderr,"Incompatible permutation in hecke_action_perm_on_lc()\n"); return(ERROR); there: ; } /* need to change the permutation */ i=S_P_II(permutation,k-1); C_I_I(S_P_I(permutation,k-1),S_P_II(permutation,k)); C_I_I(S_P_I(permutation,k),i); } /* free the permutation since it has been corrupted */ /*printf("se:"); println(tableaux);*/ freeall(permutation); free_garnir_parameters(); return(OK); } INT find_non_rowstandard_pos ( tableau, r, c) OP tableau; INT *r; INT *c; /* locates the row and column of an entry at which that to its right is smaller. Requires that set_garnir_parameters() has been invoked. */ { INT i,j,l,e1,e2; for (i=0;i (e2=S_T_IJI(tableau,i,j)) ) { *r=i,*c=j-1; return(OK); } e1=e2; } } /* no row-nonstandardness */ *r= *c= -1; return(OK); } INT columns_standardise_tableau ( tableau,sig) OP tableau; INT *sig; /* sorts the columns of the TABLEAUX tableau into standard order. Requires that set_garnir_parameters() has been invoked. */ { INT c; for (c=0;c (e2=S_T_IJI(tableau,i,col))) { /* we've found such an entry: now see how far it can be moved up the column */ C_I_I(S_T_IJ(tableau,i,col),e1); for (k=i-2;k>=r1 && e2= gright) /* s is in the right column, s+1 is in the left */ { /* swap the entries in sym & inv to keep track of permutation */ garnir_inv[garnir_sym[i]=s+1]=i; garnir_inv[garnir_sym[j]=s]=j; /* place the entries in the tableau in the corresponding way */ child=callocobject(); copy_tableaux(template,child); for (p=0;p0) /* not present */ { t=callocobject(); copy_tableaux(tableau,t); term=callocobject(); b_sk_mo(t,mp_coeff,term); if (b==NULL) /* insert new first term (before a) */ { b_ks_o(S_O_K(acc_list),S_O_S(acc_list),temp=callocobject()); /* c_o_s(acc_list,NULL); */ c_o_k(acc_list,EMPTY); b_sn_l(term,temp,acc_list); } else /* insert new term between b and a */ { b_sn_l(term,a,temp=callocobject()); C_L_N(b,temp); } } else /* term is present - must just add coefficients */ { insert(mp_coeff,S_MO_K(S_L_S(a)),add_koeff,NULL); } } } INT enter_list_to_matrix ( matrix, column, standard, express) OP matrix; INT column; OP standard; OP express; /* express is an ordered list of standard tableaux with monopoly coefficients. this expression is used to construct a column of the matrix, by comparing the tableaux with the list of standard tableaux. For those tableaux that are not present in the list, or have 0 coefficient, the column gets an INTEGER object with value 0. */ { INT r; /* account for an empty expression */ if (empty_listp(express)) express=NULL; /* find first non_zero term */ while (express!=NULL && empty_listp(S_MO_K(S_L_S(express)))) express=S_L_N(express); for (r=0; standard!=NULL; standard=S_L_N(standard),r++) { if ( express == NULL || comp_tableaux(S_L_S(standard),S_MO_S(S_L_S(express))) ) m_i_i(0L,S_M_IJ(matrix,r,column)); else { /* need to transfer the coefficient across */ copy(S_MO_K(S_L_S(express)),S_M_IJ(matrix,r,column)); /* now look for next non-zero entry */ do { express=S_L_N(express); } while (express!=NULL && empty_listp(S_MO_K(S_L_S(express)))); } } } static INT construct_mo_mp ( power, coeff, mo_po) INT power; INT coeff; OP mo_po; /* Constructs a monopoly object representing the 1-term, 1-variable polynomial: coeff * x^power. */ { OP p,c; INT erg = OK; p=callocobject(); c=callocobject(); M_I_I(power,p); M_I_I(coeff,c); erg += b_skn_mp(p,c,NULL,mo_po); ENDR("internal hiccup.c:construct_mo_mp"); } #ifdef UNDEF memory_check (query) void *query; /* Exits with an error message if the passed item is NULL: presumably this results from a memory allocation when none is left. */ { if (query==NULL) { printf("Memory error? None left? Exiting!\n"); exit(0); } } #endif /******************************************************************** ******************************************************************** ******************************************************************** HICCUP routines to calculate explicit representation matrices of the Hecke algebra of type A in the case where q is a root of unity: but only for two-rowed cases. Programmed by Trevor Welsh, Bayreuth, November 1995. ******************************************************************** ******************************************************************** ********************************************************************/ INT root_dimension (partition, p_root, dim) OP partition; OP p_root; OP dim; /* calculates the dimension of the irreducible representation of the Hecke algebra of type A labelled by partition, at a primitive (p_root)th of unity. Uses Trevvie's character formula. */ { OP parti,neg,hold,vec; INT r1,r2,no_rows,row1,row2,kappa,o_root; /* validate parameters */ if (partition==NULL || S_O_K(partition)!=PARTITION) { printf("root_dimension() did not receive a partition as it was expecting!\n"); return(ERROR); } o_root=S_I_I(p_root); no_rows=S_PA_LI(partition); if (o_root<1) { printf("ridiculous root of unity!\n"); return(ERROR); } if (o_root>1 && no_rows>2) { printf("sorry, can only deal with partitions with length 2!\n"); return(ERROR); } r1=row1 = no_rows>0 ? S_PA_II(partition,no_rows-1) : 0; r2=row2 = no_rows>1 ? S_PA_II(partition,no_rows-2) : 0; if ( (row1+1-row2)%o_root == 0 ) /* Specht module is irreducible */ { dimension_partition(partition,dim); } else { m_il_nv(2L,vec=callocobject()); b_ks_pa(VECTOR,vec,parti=callocobject()); neg=callocobject(); hold=callocobject(); m_i_i(0L,hold); m_i_i(0L,neg); while (r2>=0) { C_I_I(s_pa_i(parti,1L),r1); C_I_I(s_pa_i(parti,0L),r2); dimension_partition(parti,hold); #if DUMP==1 printf("+"); print(hold); #endif add_apply(hold,dim); r1+=o_root; r2-=o_root; } kappa=(row1-row2)/o_root+1; r2=row1+1-kappa*o_root; r1=row1+row2-r2; while (r2>=0) { C_I_I(s_pa_i(parti,1L),r1); C_I_I(s_pa_i(parti,0L),r2); dimension_partition(parti,hold); #if DUMP==1 printf("-"); print(hold); #endif add_apply(hold,neg); r1+=o_root; r2-=o_root; } #if DUMP==1 printf("\n"); #endif addinvers_apply(neg); add_apply(neg,dim); freeall(neg); freeall(hold); freeall(parti); } return(OK); } INT generate_root_tableaux ( partition, p_root, std) OP partition; OP p_root; OP std; /* generates all the root standard tableaux for the partition, by generating all standard tableaux and plucking from the list. returns the number of standard tableaux, else ERROR. */ { OP temp,bad,good,top_bad; OP last,n; INT count=0; /* validate parameters */ if (partition==NULL || S_O_K(partition)!=PARTITION) { printf("generate_root_tableaux() did not receive a partition as it was expecting!\n"); return(ERROR); } if (S_PA_LI(partition)>2) { printf("sorry, can only deal with partitions with length 2!\n"); return(ERROR); } if (S_I_I(p_root)<1) { printf("ridiculous root of unity!\n"); return(ERROR); } set_root_parameters(partition,p_root); /* obtain S_n standard tableaux for partition. trawl through these, retaining those which are root standard. */ weight(partition,n=callocobject()); last_partition(n,last=callocobject()); kostka_tab(partition,last,std); freeall(n); freeall(last); if (!empty_listp(std)) { /* start at top of list and look for first root standard tableaux */ for (temp=std; temp!=NULL && find_non_root_standard_pos(S_L_S(temp))>=0; temp=S_L_N(bad=temp)); if (temp!=std) { /* need to release non root standard tableaux, and to make std point to the first standard. */ if (temp!=NULL) { C_L_N(bad,NULL); b_ks_o(S_O_K(temp),S_O_S(temp),std); /* this frees self of std */ C_O_K(temp,EMPTY); freeall(temp); temp=std; } else { /* need to make std into an empty list: the init() routine also frees the previous list */ init(LIST,std); } } while (temp!=NULL) { /* go through list looking for non root standard, and counting standard tableaux. */ for (temp=S_L_N(good=temp),count++; temp!=NULL && find_non_root_standard_pos(S_L_S(temp))<0; temp=S_L_N(good=temp),count++); /* good contains previous standard, temp non-standard */ if (temp!=NULL) { top_bad=temp; /* now go through non root standard tableaux */ for (temp=S_L_N(bad=temp); temp!=NULL && find_non_root_standard_pos(S_L_S(temp))>=0; temp=S_L_N(bad=temp)); /* join the standard one found (temp) with the previous standard list, and eliminate the intervening tableaux. */ C_L_N(good,temp); C_L_N(bad,NULL); freeall(top_bad); } } } free_root_parameters(); return(count); } INT hecke_root_generator_reps ( partition, p_root, vector) OP partition; OP p_root; OP vector; /* for the given partition produces a vector of matrices, the ith of which represents the ith generator s_i. */ { INT i,ni; OP n,p,lc,mat; /* validate parameters */ if (partition==NULL || S_O_K(partition)!=PARTITION) { error("hecke_generator_reps() did not receive a partition as it was expecting!\n"); return(ERROR); } if (S_I_I(p_root)<1) { error("ridiculous root of unity!\n"); return(ERROR); } weight(partition,n=callocobject()); ni=S_I_I(n); freeall(n); /* construct and intialize a permutation which will be passed to the representing routines. */ m_il_p(ni,p=callocobject()); for (i=0;i2) { printf("sorry, can only deal with tableaux with less than 2 rows!\n"); return(ERROR); } if (S_I_I(p_root)<1) { printf("ridiculous root of unity!\n"); return(ERROR); } /* if result is not already a list, then make it one */ if (S_O_K(result)!=LIST) init(LIST,result); /* return if there is nothing to process */ if (empty_listp(tableaux)) return(OK); set_garnir_parameters(s_t_u(S_MO_S(S_L_S(tableaux)))); set_root_parameters(s_t_u(S_MO_S(S_L_S(tableaux))),p_root); imitate=callocobject(); for (a=tableaux;a!=NULL;a=S_L_N(a)) { set_root_multiplier(S_MO_K(S_L_S(a))); copy_tableaux(S_MO_S(S_L_S(a)),imitate); root_standardise_tableau(imitate,result); freeself(imitate); } freeall(imitate); free_root_parameters(); free_garnir_parameters(); return(OK); } /* Note that the following variables have been defined prior to set_garnir_parameters() and are also made use in the routines that follow. INT *part,*conj,*entry_list; INT lcol,rcol,grow,glength,gright,gleft; OP children,template; */ static OP root_multiplier; /* mult by this prior to accumulating to root_all */ static OP root_all; /* list accumulating standard terms found */ static INT root_ready=0,per_len=0; static INT row1,row2,calx; static INT root,rootover2,root_cover,kappa,strip,ostrip; static INT min_tail,max_tail; static INT piece1,piece2,first_var,left_const,right_const; static INT *symmetry,*inverse; static INT *spectrum; static OP poly,hiccup_log; static OP ghost; static OP accumulate; static OP symmetrised; static OP mq_mp; /* monopoly storing -q */ INT set_root_parameters ( partition, p_root) OP partition; OP p_root; /* sets a numbers of parameters depending on the Young diagram and the relevant boundary strip. root_ready keeps an account of how many times that this routine is called, so that everything can be freed on the last free_root_parameters() call. Of course, this assumes that in every routine that calls set_root_parameters(), there is a corresponding call to free_root_parameters(). */ { INT i,no_rows; if (root_ready++) return(OK); /* validate parameters */ if (partition==NULL || S_O_K(partition)!=PARTITION) { printf("generate_root_tableaux() did not receive a partition as it was expecting!\n"); return(ERROR); } root=S_I_I(p_root); if (root&1) /* odd */ { rootover2=root; /* half root if even */ root_cover=root-1; /* minimum power at which to look for improvements */ } else root_cover=rootover2=root/2; no_rows=S_PA_LI(partition); row1 = no_rows>0 ? S_PA_II(partition,no_rows-1) : 0; row2 = no_rows>1 ? S_PA_II(partition,no_rows-2) : 0; /* calculate length of relevant boundary strip */ kappa=(row1-row2)/root+1; strip=kappa*root; /* set up arrays to store certain permutations */ symmetry=(INT*)SYM_calloc(strip,sizeof(INT)); inverse=(INT*)SYM_calloc(strip,sizeof(INT)); for (i=0;irow1 || strip-1 == row1-row2) kappa=strip=ostrip=calx=min_tail=max_tail=0; else { strip-=2; /* so we just add to get co-ord in top row */ ostrip=strip-root+2; /* length of the other strips */ calx=row1-strip; /* final one to check for strip standard */ min_tail=strip+1+row2-row1; max_tail=row20. */ { INT i,j; /* check all relevant positions in 2nd row to find rightmost which is not strip standard */ if (kappa) for (i=calx-1;i>=0;i--) if (S_T_IJI(tableau,1,i)>S_T_IJI(tableau,0,i+strip)) { if (kappa>1) /* then we must also check that all positions to right are not ostrip standard (ostrip=strip-root+2). */ { for (j=i+root-1; jS_T_IJI(tableau,0,j+ostrip); j++); } if (kappa==1 || j>=row2) /* then i gives non-standard pos */ { return(i); } } return(-1); } set_root_multiplier (extra) OP extra; /* all standard tableaux that are now found are added to the list after their coefficients have been multiplied by extra (which will usually be a MONOPOLY object). */ { root_multiplier=extra; } root_standardise_tableau_list ( list, expression) OP list; OP expression; /* Expresses the monomial list of tableaux with monopoly coefficients in terms of a list of standard tableaux with monopoly coefficients Requires that set_garnir_parameters() and set_root_parameter() have both been invoked. */ { OP a; for (a=list;a!=NULL;a=S_L_N(a)) { set_root_multiplier(S_MO_K(S_L_S(a))); root_standardise_tableau(S_MO_S(S_L_S(a)),expression); } } root_standardise_tableau ( tableau, expression) OP tableau; OP expression; /* Expresses the tableau in terms of a list of standard tableaux with polynomial coefficients. tableau is not freed by this function, but its entries may change. Requires that set_garnir_parameters() and set_root_parameter() have both been invoked, and that root_multiplier has been set. */ { INT swaps=0; OP overall; root_all=expression; columns_standardise_tableau(tableau,&swaps); find_non_rowstandard_pos(tableau,&grow,&lcol); if (grow<0) { /* then tableau is S_n standard - now test root standardness */ if ((lcol=find_non_root_standard_pos(tableau))<0) { construct_mo_mp(0,swaps&1 ? -1 : 1,overall=callocobject()); mult_apply_monopoly(root_multiplier,overall); #if NORMALISE==1 root_garnir_result(tableau,overall,root_all); #else garnir_result(tableau,overall,root_all); #endif } else /* S_n standard but not root standard */ { strip_juggle(tableau,0,swaps&1 ? -1 : 1); } } else /* S_n non-standard */ { root_juggle(tableau,0,swaps&1 ? -1 : 1); } } root_juggle ( tableau, power, coeff) OP tableau; INT power; INT coeff; /* Recursive function which is passed a non-standard tableau, together with its coefficient in the form of coeff * q^power. (usually coeff is +1 or -1). In one invocation, a single Garnir relation is performed: those which result that are standard are added to the list of tableaux; those which are non-standard are resubmitted to this function. The tableau that is passed is assumed to be standard in columns AND nonstandard in rows. It is ALSO assumed that the non-standard position has already been stored in (grow,lcol). tableau is unchanged by this function, Requires that set_garnir_parameters() and set_root_parameters() have been invoked. */ { INT p,swaps,lcoll,rcoll; OP store,temp,overall; template=tableau; /* obtain lengths of garnir parts and stores entries of these parts */ glength=conj[lcol]+1; gright=grow+1; gleft=glength-gright; rcoll=rcol=(lcoll=lcol)+1; for (p=0;p1). The tableau that is passed is assumed to be standard. It is ALSO assumed that the 2nd row position of root non-standardness has already been stored in lcol. tableau is unchanged by this function, Requires that set_garnir_parameters() and set_root_parameters() have been invoked. */ { INT i,disp,dispr1,dispr2; OP save_multiplier,overall,strip_list,tab; INT row1_pos,row2_pos,b_entry,s_entry; OP temp,ext,monom,koeff,new,big_list,partit,perm; INT *map; /* identify the appropriate list: i becomes no of symmetrised boxes in 2nd row. disp is the rightward distance from the first box being symmetrised to the rightmost possible root-1 2nd row boxes symmetrisation. */ disp=row2-lcol-root+1; i= disp<0 ? row2-lcol : root-1; strip_list=s_v_i(symmetrised,i-1); if (S_O_K(strip_list)==EMPTY) { /* need to generate the model expression for this standardisation */ generate_sym_tableaux_list(i,strip_list); } /* now hijack the multiplier - so that it can be reset */ b_ks_o(S_O_K(root_multiplier),S_O_S(root_multiplier), save_multiplier=callocobject()); /* c_o_s(root_multiplier,NULL); */ c_o_k(root_multiplier,EMPTY); /* make an array to store map between canonical root non-standard tableau and current particular root non-standard tableau. */ map=(INT*)SYM_calloc(row1+row2+1,sizeof(INT)); /* identify the map from the canonical strip relation to the current problem using the first term in the list. */ tab=S_MO_S(S_L_S(strip_list)); if (disp<=0) { /* easy case - number of boxes of boundary strip in second row < root. The stored list is used pretty much as it stands. First form the map from the canonical non strip-standard tableau (this is stored as the first element in the list). */ for (i=0;i1) */ { /* this is an even trickier case, where the symmetrised section needs to be used at different positions to where it has been formed in the canonical list, the entries to its right set up and acted on by a hecke permutation, before resubmission. */ dispr1=row1-disp; dispr2=row2-disp; /* This first loop defines the map for the last disp entries of each row. */ for (i=0;i=0;i--) { row1_pos=row2-disp+ostrip+i; row2_pos=row2-disp+i; s_entry=row1_pos+row2_pos+1; b_entry=s_entry+1; /* act on each term to double the list size */ for (temp=big_list;temp!=NULL;temp=S_L_N(ext)) { /* put a copy of the term AFTER the current one, mutliply the new by -q, and transpose the old. */ copy_monom(S_L_S(temp),monom=callocobject()); mult_apply_monopoly(mq_mp,S_MO_K(monom)); C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),0,row1_pos),s_entry); C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),1,row2_pos),b_entry); b_sn_l(monom,S_L_N(temp),ext=callocobject()); C_L_N(temp,ext); } } /* now effect a hecke permutation on the list, in order to take the first element of the big_list to tableau (the current non root-standard tableau). Then ignore the first (non root-standard) element; and resubmit for recursive standardisation. */ m_il_p(row1+row2,perm=callocobject()); for (i=0;i0) /* not present */ { if (root_normalise_monopoly(mp_coeff)) { copy_tableaux(tableau,t=callocobject()); b_sk_mo(t,mp_coeff,term=callocobject()); if (b==NULL) /* insert new first term (before a) */ { b_ks_o(S_O_K(acc_list),S_O_S(acc_list),temp=callocobject()); /* c_o_s(acc_list,NULL); */ c_o_k(acc_list,EMPTY); b_sn_l(term,temp,acc_list); } else /* insert new term between b and a */ { b_sn_l(term,a,temp=callocobject()); C_L_N(b,temp); } } else freeall(mp_coeff); } else /* term is present - must just add coefficients */ { insert(mp_coeff,S_MO_K(S_L_S(a)),add_koeff,NULL); root_normalise_monopoly(S_MO_K(S_L_S(a))); } } } INT root_normalise_monopoly (mono) OP mono; /* some attempts to simplify the monopoly using the fact that its over a primitive p_root of unity. Return is 0 if result is identically zero (not fully implemented), else 1. */ { INT i,hi,lo; OP a,b,mopo; /* return if nothing to process */ if (empty_listp(mono)) return(0); /* set whole of working array to zeros */ memset(spectrum,0,root*sizeof(INT)); /* copy monopoly to working array and use q^root=1 to reduce exponents */ for (a=mono;a!=NULL;a=S_L_N(b=a)) spectrum[S_I_I(S_MO_S(S_L_S(a)))%root]+=S_I_I(S_MO_K(S_L_S(a))); /* if the highest power is tooo low, end processing */ if (S_I_I(S_MO_S(S_L_S(b)))1 && (hi=lo=spectrum[i=(root-1)])) { for (i--;i>0;i--) if (!spectrum[i]) goto there; /* don't change what we've got */ else if (spectrum[i]>hi) hi=spectrum[i]; else if (spectrum[i]0) for (i=root-1;i>=0;i--) spectrum[i]-=lo; else if (hi<0) for (i=root-1;i>=0;i--) spectrum[i]-=hi; } there: ; } for (i=0;i i) /* s is in the bottom row, s+1 is anywhere to the right */ { /* swap the entries in sym & inv to keep track of permutation */ inverse[symmetry[i]=s+1]=i; inverse[symmetry[j]=s]=j; /* place the entries in the tableau in the corresponding way */ child=callocobject(); copy_tableaux(ghost,child); for (k=0;k0;i--) C_I_I(s_v_i(poly,i),s_v_ii(poly,i)-red); C_I_I(s_v_i(poly,0L),1L); } #if DUMP==1 printf("After rootover: "); println(poly); #endif /* reconstruct the monopoly list from the poly vector. start the list with a null since its certain to be non-empty. then all are multiplied by -1, since this is what is eventually needed during p-root standardisation. */ accumulate=NULL; for (i=root-1;i>=0;i--) if (s_v_ii(poly,i)) { construct_mo_mp(i,-s_v_ii(poly,i),momp=callocobject()); C_L_N(momp,accumulate); accumulate=momp; } #if DUMP==1 printf("Reduced monpoly:\n"); dump_monopoly(accumulate); #endif b_ks_o(S_O_K(accumulate),S_O_S(accumulate),mp); C_O_K(accumulate,EMPTY); freeall(accumulate); } } INT remove_vec_qnumber ( qn) INT qn; /* The poly vector object has been loaded with a polynomial which, under [root]_q=0, it assumed to have a factor of [qn]_q. This factor is removed. Assumed that qn0;i--) C_I_I(s_v_i(poly,i),s_v_ii(poly,i)-s_v_ii(poly,i-1)); for (i=qn;i0. If flag is non-zero, then the difference between the two sides of the particular relation is displayed. */ { INT i,j,ni; /* validate parameters */ if (vector==NULL || S_O_K(vector)!=VECTOR) { printf("check_hecke_generators() did not receive a vector as it was expecting!\n"); return(ERROR); } set_cyclotomic_parameters(p_root); ni=s_v_li(vector); for (i=0;i1) println(fp); freeall(fp); return(erm); } INT check_braid (mat1, mat2, p_root, flag) OP mat1; OP mat2; OP p_root; INT flag; /* checks that the matrices satisfy m1*m2*m1 == m2*m1*m2. If not and flag is non-zero, the difference is displayed. */ { INT erm; INT i,j; OP mat12,mat121,mat212; /* validate parameters */ if (mat1==NULL || mat2==NULL || S_O_K(mat1)!=MATRIX || S_O_K(mat2)!=MATRIX) { printf("check_braid() did not receive matrices as it was expecting!\n"); return(ERROR); } mult_matrix_matrix(mat1,mat2,mat12=callocobject()); mult_matrix_matrix(mat12,mat1,mat121=callocobject()); mult_matrix_matrix(mat2,mat12,mat212=callocobject()); freeall(mat12); for (i=s_m_hi(mat212)-1;i>=0;i--) for (j=s_m_li(mat212)-1;j>=0;j--) addinvers_apply(S_M_IJ(mat212,i,j)); add_apply(mat121,mat212); freeall(mat121); erm=check_zero_matrix(mat212,p_root); if (flag && erm>1) println(mat212); freeall(mat212); return(erm); } INT check_commute (mat1, mat2, p_root, flag) OP mat1; OP mat2; OP p_root; INT flag; /* checks that the matrices satisfy m1*m2 == m2*m1. If not and flag is non-zero, the difference is displayed. */ { INT erm; INT i,j; OP mat12,mat21; /* validate parameters */ if (mat1==NULL || mat2==NULL || S_O_K(mat1)!=MATRIX || S_O_K(mat2)!=MATRIX) { printf("check_commute() did not receive matrices as it was expecting!\n"); return(ERROR); } mult_matrix_matrix(mat1,mat2,mat12=callocobject()); mult_matrix_matrix(mat2,mat1,mat21=callocobject()); for (i=s_m_hi(mat21)-1;i>=0;i--) for (j=s_m_li(mat21)-1;j>=0;j--) addinvers_apply(S_M_IJ(mat21,i,j)); add_apply(mat12,mat21); freeall(mat12); erm=check_zero_matrix(mat21,p_root); if (flag && erm>1) println(mat21); freeall(mat21); return(erm); } static INT c_root=0,c_rootover2,cyclo_ready=0,cyclo_roof; static OP tomic=NULL; static INT *c_vec=NULL; INT set_cyclotomic_parameters (p_root) OP p_root; /* sets paramters needed by check_zero_matrix() at roots of unity. */ { OP a,b; INT i; if ( (c_root=S_I_I(p_root))>0 && !cyclo_ready++) { c_rootover2 = c_root&1 ? 0 : c_root/2; c_vec=(INT*)SYM_calloc(c_root,sizeof(INT)); a=callocobject(); tomic=callocobject(); make_cyclotomic_monopoly(p_root,tomic); /* need highest power in cyclotomic */ for (a=tomic;a!=NULL;a=S_L_N(b=a)); cyclo_roof=S_I_I(S_MO_S(S_L_S(b))); /* Note that its coefficient must be +1 */ } return(OK); } INT free_cyclotomic_parameters () { if (!--cyclo_ready) { freeall(tomic); tomic=NULL; SYM_free(c_vec); c_vec=NULL; c_root=0; } } INT check_zero_matrix ( mat, p_root) OP mat; OP p_root; /* checks that the passed matrix is zero at the appropriate root of unity. returns: -1 ERROR; 0 matrix is zero, whatever the value of q; 1 matrix is zero, if q is primitive p_root of unity; 2 matrix is non-zero, if is not a primitive p_root of unity. */ { INT i,j,k,l,erm=0,non=0; OP a,op; if (mat==NULL || S_O_K(mat)!=MATRIX) { printf("check_null_matrix() did not receive a matrix as it was expecting!\n"); return(ERROR); } set_cyclotomic_parameters(p_root); for (i=0;i0) { for (k=0;k=0;k--) { if (c_vec[k]) if (k0 && S_P_II(permutation,k)>S_P_II(permutation,k-1);k--); if (!k) /* none present */ break; /* now apply s_k to hecke algebra list */ temp=heck; while (temp!=NULL) { perm=S_MO_S(S_L_S(temp)); lo_one=hi_one= -1; /* trawl through positions of perm looking for k & k+1 */ for (i=0;i-1) /* position of k already located */ { /* enact the tranposition; coefficient is unchanged */ C_I_I(S_P_I(perm,lo_one),k+1); C_I_I(S_P_I(perm,i),k); temp=S_L_N(temp); goto there; /* end processing of current perm */ } else { hi_one=i; } } else if (S_P_II(perm,i)==k) { if (hi_one>-1) /* position of k+1 already located */ { /* form a new element in the list, obtained by simple tranposition and multiply coeff by q. */ copy_permutation(perm,new=callocobject()); C_I_I(S_P_I(new,hi_one),k); C_I_I(S_P_I(new,i),k+1); mult_monopoly_monopoly(q_mp,S_MO_K(S_L_S(temp)), coeff=callocobject()); b_sk_mo(new,coeff,monom=callocobject()); b_sn_l(monom,S_L_N(temp),ext=callocobject()); C_L_N(temp,ext); /* multiply old coefficient by q-1 */ mult_apply_monopoly(qm1_mp,S_MO_K(S_L_S(temp))); temp=S_L_N(ext); goto there; /* end processing of current perm */ } else { lo_one=i; } } /* if we get here then we have not found both k & k+1 */ fprintf(stderr,"Incompatible permutations in hecke_action_perm_on_hecke()\n"); free_useful_monopolies(); return(ERROR); there: ; } /* need to change the permutation */ i=S_P_II(permutation,k-1); C_I_I(S_P_I(permutation,k-1),S_P_II(permutation,k)); C_I_I(S_P_I(permutation,k),i); } /* free the permutation since it has been corrupted */ freeall(permutation); free_useful_monopolies(); return(OK); } static void hecke_accum ( perm, mp_coeff, acc_list) OP perm; OP mp_coeff; OP acc_list; /* Adds mp_coeff * perm to our list: acc_list. perm is unchanged, and copied when necessary. mp_coeff is incorporated or destroyed. The list is maintained in lexicographic order. */ { OP a,b,term; OP t,temp; INT co; if (empty_listp(acc_list)) { t=callocobject(); copy_permutation(perm,t); term=callocobject(); b_sk_mo(t,mp_coeff,term); c_l_s(acc_list,term); } else { /* look for tableau in list */ for (a=acc_list,b=NULL; a!=NULL && (co=comp_permutation(S_MO_S(S_L_S(a)),perm))<0; a=S_L_N(b=a)); if (a==NULL || co>0) /* not present */ { t=callocobject(); copy_permutation(perm,t); term=callocobject(); b_sk_mo(t,mp_coeff,term); if (b==NULL) /* insert new first term (before a) */ { b_ks_o(S_O_K(acc_list),S_O_S(acc_list),temp=callocobject()); /* c_o_s(acc_list,NULL); */ C_O_K(acc_list,EMPTY); b_sn_l(term,temp,acc_list); } else /* insert new term between b and a */ { b_sn_l(term,a,temp=callocobject()); C_L_N(b,temp); } } else /* term is present - must just add coefficients */ { insert(mp_coeff,S_MO_K(S_L_S(a)),add_koeff,NULL); } } } /******************************************************************** ******************************************************************** ******************************************************************** The following routines are/were useful for debugging the above! Otherwise, they are not required. ******************************************************************** ******************************************************************** ********************************************************************/ #ifdef DUMP dump_lc_list (list) OP list; { OP mo; if (list==NULL) { printf("list is NULL!"); } else if (S_O_K(list)!=LIST) { printf("this is not a list!\n"); } else if ( (list->ob_self).ob_list==NULL ) { printf("list has null self!\n"); } else if (S_L_S(list)==NULL) { printf("list self part is absent! (empty list?)\n"); /* this should be the case for an empty list (i.e. zero) */ } else { mo=S_L_S(list); printf("term (kind %ld) is (kind %ld):\n",S_O_K(mo),S_O_K(S_MO_S(mo))); println(S_MO_S(mo)); printf("coefficient (kind %ld) is:\n",S_O_K(S_MO_K(mo))); dump_monopoly(S_MO_K(mo)); list=S_L_N(list); if (list!=NULL) dump_lc_list(list); } } dump_monopoly (mp) OP mp; { OP mo; if (mp==NULL) { printf("monopoly is NULL!"); } else if (S_O_K(mp)!=MONOPOLY) { printf("this is not a monopoly!\n"); } else if ( (mp->ob_self).ob_list==NULL ) { printf("monopoly has null self!\n"); } else if (S_L_S(mp)==NULL) { printf("monopoly self part is absent! (empty list?)\n"); /* this should be the case for an empty list (i.e. zero) */ } else { mo=S_L_S(mp); printf("+ (kind %ld) ",S_O_K(mo)); fflush(stdout); printf("(%d * q^(%d)) ", S_I_I(S_MO_K(S_L_S(mp))), S_I_I(S_MO_S(S_L_S(mp)))); mp=S_L_N(mp); if (mp==NULL) printf(".\n"); else dump_monopoly(mp); } } strip_buggle ( tableau) OP tableau; { INT i,disp,dispr1,dispr2; OP save_multiplier,overall,strip_list,tab; INT row1_pos,row2_pos,b_entry,s_entry; OP temp,ext,monom,koeff,new,big_list,partit,perm; FILE *fp; if ((lcol=find_non_root_standard_pos(tableau))<0) { printf("Input tableau is standard.\n"); return; } /* identify the appropriate list: i becomes no of symmetrised boxes in 2nd row. disp is the rightward distance from the first box being symmetrised to the rightmost possible root-1 2nd row boxes symmetrisation. */ disp=row2-lcol-root+1; i= disp<0 ? row2-lcol : root-1; printf("lcol=%ld, disp=%ld.\n",lcol,disp); strip_list=s_v_i(symmetrised,i-1); if (S_O_K(strip_list)==EMPTY) { /* need to generate the model expression for this standardisation */ generate_sym_tableaux_list(i,strip_list); } /* identify the map from the canonical strip relation to the current problem using the first term in the list. */ tab=S_MO_S(S_L_S(strip_list)); if (disp<=0) { /* easy case - use stored list pretty much as it stands. First form the map from the canonical non strip-standard tableau (this is stored as the first element in the list). */ printf("1st case: lcol=%ld, disp=%ld.\n",lcol,disp); for (i=0;i1) */ { /* this is an even trickier case, where the symmetrised section needs to be used at different positions to where it has been formed in the canonical list, the entries to its right set up, permuted, and enacted upon. */ printf("3rd case: lcol=%ld, disp=%ld.\n",lcol,disp); dispr1=row1-disp; dispr2=row2-disp; /* This first loop defines the map for the last disp entries of each row. */ for (i=0;i=0;i--) { row1_pos=row2-disp+ostrip+i; row2_pos=row2-disp+i; s_entry=row1_pos+row2_pos+1; b_entry=s_entry+1; /* act on each term to double the list size */ for (temp=big_list;temp!=NULL;temp=S_L_N(ext)) { /* put a copy of the term AFTER the current one, mutliply the new by -q, and transpose the old. */ copy_monom(S_L_S(temp),monom=callocobject()); mult_apply_monopoly(mq_mp,S_MO_K(monom)); C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),0,row1_pos),s_entry); C_I_I(S_T_IJ(S_MO_S(S_L_S(temp)),1,row2_pos),b_entry); b_sn_l(monom,S_L_N(temp),ext=callocobject()); C_L_N(temp,ext); } } fp=fopen("dump1.dat","w"); fprintln(fp,big_list); fclose(fp); /* now effect a hecke permutation on the list, in order to take the first element of the big_list to tableau (the current non root-standard tableau). Then ignore the first (non root-standard) element; and resubmit for recursive standardisation. */ m_il_p(row1+row2,perm=callocobject()); for (i=0;i H_n to be unambiguously defined as follows. Let s_i be the simple transposition (i,i+1) of S_n, and for w in S_m let w = s_{i_1} s_{i_2} s_{i_3} ... s_{i_l} be a reduced expression for w in that l is the length of w. Then define h(w) = h_{i_1} h_{i_2} h_{i_3} ... h_{i_l}. In fact, the images of all w in S_n provide a basis for H_n (moreover, if q is not a root of unity, then H_n and the group algebra of S_n over the complex numbers are isomorphic). This is made use of in the routines, where elements of H_n are stored as q-linear combinations of permutations: a permutation corresponds to the element of H_n obtained from the map h. In terms of the objects of Symmetrica, an element of H_n is a linked LIST of MONOM objects. The "self" part of each MONOM is the PERMUTATION, and the "koeff" part is its coefficient - a MONOPOLY object representing a polynomial in the single variable q. The MONOPOLY object is itself a linked list of MONOMs representing the individual terms in the polynomial. Here both the "self" and "koeff" parts of the MONOM are INTEGER objects; the former giving the power of the term, and the latter its coefficient. Schematically, this data structure is as follows: LIST --> LIST (next) --> MONOM --> PERMUTATION --> MONOPOLY (LIST) --> MONOPOLY (next) --> MONOM --> INTEGER (power) --> INTEGER (coefficient). In the constructions introduced above, the module corresponding to a particular partition is spanned by tableaux of the shape of that partition. Thus a data structure similar to the above is used to store elements of the module: LIST --> LIST (next) --> MONOM --> TABLEAUX --> MONOPOLY (LIST) --> MONOPOLY (next) --> MONOM --> INTEGER (power) --> INTEGER (coefficient). Each module has a basis which is a subset of the full set of tableaux. For the Specht module, the basis elements are known as standard tableaux (or S_n - standard tableaux). For the root of unity cases a subset of the standard tableaux, known as p-root standard tableaux, provide a basis. At the heart of the module constructions are algorithms that enable a tableau which is not in the basis to be rewritten in terms of those tableaux that are. The action of an arbitrary element of H_n on a tableau (see eq. (3) of [Welsh] which supercedes eqs. (3.8), (3.9) & (3.10) of [Ki & Wy]) then completes the description of the module. /******************************************************************** Here follow routines dealing with the generic irreducible modules. ********************************************************************/ NAME: generate_standard_tableaux SYNOPSIS: INT generate_standard_tableaux (OP partition, OP std) DESCRIPTION: Generates the full set of standard tableaux for the given partition. The tableaux are returned as a lexicographically ordered list. If no error occurs, their number is returned. (The number of standard tableaux may also be obtained from the Symmetrica function dimension_partition (OP pt, OP dim), which is described in the section of user manual concerning PARTITION objects.) RETURN: ERROR or count of standard tableaux. NAME: hecke_generator_reps SYNOPSIS: INT hecke_generator_reps (OP partition, OP vector) DESCRIPTION: For the given partition of n, calculates representation matrices for each of the generators h_1,h_2,...,h_{n-1}. The matrices are stored as MATRIX object elements of a VECTOR of length n-1. RETURN: OK or ERROR. NAME: represent_hecke_element SYNOPSIS: INT represent_hecke_element (OP partition, OP hecke, OP mat) DESCRIPTION: For the given partition of n, calculates the matrix representing the element of H_n given by hecke which is a q-linear combination of PERMUTATIONS as described in the preamble above. RETURN: OK or ERROR. NAME: hecke_dg SYNOPSIS: INT hecke_dg(OP part, OP perm, OP mat) DESCRIPTION: uses the routine represent_hecke_element to compute the matrix representing the permutation perm. NAME: build_lc SYNOPSIS: INT build_lc (OP schizo, OP list) DESCRIPTION: This routine converts schizo, which is either a PERMUTATION object or a TABLEAUX object into a linear combination LIST, of the type described in the preamble above. The LIST has one term (schizo) whose coefficient is a MONOPOLY representing 1. schizo is incorporated into the list and should not be subsequently freed. This routine is sometimes useful before calling hecke_action_lc_on_lc() or standardise_cold_tableaux_list(). RETURN: OK or ERROR. NAME: hecke_action_lc_on_lc SYNOPSIS: INT hecke_action_lc_on_lc (OP tableaux, OP hecke, OP result) DESCRIPTION: The linear combination of Hecke algebra permutations given in hecke, acts on the linear combination of tableaux. The resultant linear combination of (in general, non-standard) tableaux is in result. This result is not ordered and has not had terms collected. RETURN: OK or ERROR. NAME: standardise_cold_tableaux_list SYNOPSIS: INT standardise_cold_tableaux_list (OP tableaux, OP result) DESCRIPTION: The linear combination of tableaux is re-expressed in terms of standard tableaux. The result is an ordered list in which terms have been collected. (This routine makes use of only Garnir & column relations). RETURN: OK or ERROR. NAME: input_tableau SYNOPSIS: INT input_tableau (OP partit, OP tab) DESCRIPTION: Asks the user to input a tableau of the shape specified by the PARTITION object partit. An ERROR is returned if the entries are not distinct elements of {1,2,...,n}, where n is the weight of partit. RETURN: OK or ERROR. NAME: input_lc_permutations SYNOPSIS: INT input_lc_permutations (OP save) DESCRIPTION: Asks the user to input a linear combination of permutations. RETURN: OK. NAME: substitute_one_matrix SYNOPSIS: INT substitute_one_matrix (OP matrix) DESCRIPTION: Every entry of the matrix that is a MONOPOLY polynomial has q=1 substituted. Using this function, the Specht module representations of the Hecke algebra are converted into those of the symmetric group. RETURN: OK or ERROR. NAME: substitute_one_monopoly SYNOPSIS: INT substitute_one_monopoly (OP monopoly) DESCRIPTION: The MONOPOLY polynomial has q=1 substituted (it is converted into an INTEGER object). RETURN: OK or ERROR. COMMENT: /******************************************************************** Here follow routines dealing with the 2-rowed non-generic modules. ********************************************************************/ NAME: root_dimension SYNOPSIS: INT root_dimension (OP partition, OP p_root, OP dim) DESCRIPTION: Calculates the dimension of irreducible representation labelled by partition at primitive p_root of unity. The result is in the INTEGER object dim. (Calculated using eq. (22) of [Welsh].) RETURN: OK or ERROR. NAME: generate_root_tableaux SYNOPSIS: INT generate_root_tableaux (OP partition, OP p_root, OP std) DESCRIPTION: Generates the full set of p-root standard tableaux for the given partition. The tableaux are returned as a lexicographically ordered list. If no error occurs, their number is returned. This number should be equal to that obtained from root_dimension(). (This routine simply generates all standard tableaux and discards those that are not p-root standard.) RETURN: ERROR or the number of p-root standard tableaux. NAME: hecke_root_generator_reps SYNOPSIS: INT hecke_root_generator_reps (OP partition, OP p_root, OP vector) DESCRIPTION: For the given partition of n, and primitive p_root of unity, calculates representation matrices for each of the generators h_1,h_2,...,h_{n-1}. The matrices are stored as MATRIX object elements of a VECTOR of length n-1. RETURN: OK or ERROR NAME: root_represent_hecke_element SYNOPSIS: INT root_represent_hecke_element (OP partition, OP p_root, OP hecke, OP mat) DESCRIPTION: For the given partition of n, and primitive p_root of unity, calculates the matrix representing the element of H_n given by hecke which is a q-linear combination of PERMUTATIONS as described in the preamble above. RETURN: OK or ERROR NAME: root_standardise_cold_tableaux_list SYNOPSIS: INT root_standardise_cold_tableaux_list (OP tableaux, OP p_root, OP result) DESCRIPTION: The linear combination of tableaux is re-expressed in terms of the p_root standard tableaux. The result is an ordered list in which terms have been collected. (This routine makes use of Garnir & column relations and some new relations known as strip relations - yet to be documented). RETURN: OK or ERROR. COMMENT: /******************************************************************** The following routines check the representation matrices ********************************************************************/ NAME: check_hecke_generators SYNOPSIS: INT check_hecke_generators (OP vector, OP p_root, INT flag) DESCRIPTION: This routine checks that the MATRIX object elements of the VECTOR object vector, satisfy the defining relations 1, 2, 3, of the Hecke algebra given in the preamble above. n is deduced from the length of the vector. If p_root=0, then the relations are checked for general q. Otherwise they are checked for q a primitive p_root of unity. For each identity checked, a message is printed indicating whether the identity is OK for general q, whether is it OK provided q is a root of unity with the given primitive index, or whether it is not OK. If flag is non-zero and the relation is not OK then the difference between the two sides is output (untidily!). RETURN: OK or ERROR NAME: check_hecke_quadratic SYNOPSIS: INT check_hecke_quadratic (OP mat, OP p_root, INT flag) DESCRIPTION: Checks that the matrix satisfies the first Hecke algebra relation. ( (m+1)(m-q) == 0 ) If p_root=0, then the relations are checked for general q. Otherwise they are checked for q a primitive p_root of unity. If there is no ERROR, returns 0 if true for all q, 1 if true at primitive p_root of unity, 2 otherwise. If flag is non-zero and the relation is not OK then the left side is output. RETURN: ERROR, 0, 1, or 2 as described above. NAME: check_braid SYNOPSIS: INT check_braid (OP mat1, OP mat2, OP p_root, INT flag) DESCRIPTION: Checks that the matrices satisfy the second Hecke algebra relation. ( m1*m2*m1 == m2*m1*m2 ) If p_root=0, then the relations are checked for general q. Otherwise they are checked for q a primitive p_root of unity. If there is no ERROR, returns 0 if true for all q, 1 if true at primitive p_root of unity, 2 otherwise. If flag is non-zero and the relation is not OK then the difference between the two sides is output. RETURN: ERROR, 0, 1, or 2 as described above. NAME: check_commute SYNOPSIS: INT check_commute (OP mat1, OP mat2, OP p_root, INT flag) DESCRIPTION: Checks that the matrices satisfy the third Hecke algebra relation. ( m1*m2 == m2*m1 ) If p_root=0, then the relations are checked for general q. Otherwise they are checked for q a primitive p_root of unity. If there is no ERROR, returns 0 if true for all q, 1 if true at primitive p_root of unity, 2 otherwise. If flag is non-zero and the relation is not OK then the difference between the two sides is output. RETURN: ERROR, 0, 1, or 2 as described above. NAME: check_zero_matrix SYNOPSIS: INT check_zero_matrix (OP mat, OP p_root) DESCRIPTION: Checks that the matrix is zero. If p_root=0, then the matrix is checked for general q. Otherwise it is checked for q a primitive p_root of unity. If there is no ERROR, returns 0 if zero for all q, 1 if zero at primitive p_root of unity, 2 if non-zero. RETURN: ERROR, 0, 1, or 2 as described above. COMMENT: /******************************************************************** Here follow routines to add or multiply hecke algebra elements ********************************************************************/ NAME: hecke_add SYNOPSIS: INT hecke_add (OP hecke1, OP hecke2, OP result) DESCRIPTION: The hecke algebra elements hecke1 and hecke2, which are linear combinations of permutations as described in the preamble, are added to give result. hecke1 and hecke2 are unchanged. RETURN: ERROR or OK. NAME: hecke_mult SYNOPSIS: INT hecke_mult (OP hecke1, OP hecke2, OP result) DESCRIPTION: The hecke algebra elements hecke1 and hecke2, which are linear combinations of permutations as described in the preamble, are multiplied to give result. hecke1 and hecke2 are unchanged. RETURN: ERROR or OK. NAME: hecke_scale SYNOPSIS: INT hecke_scale (OP hecke, OP power, OP coeff); DESCRIPTION: The hecke algebra element hecke which is a linear combinations of permutations as described in the preamble, is multiplied by coeff*q^power where coeff & power are both INTEGER objects. RETURN: ERROR or OK. COMMENT: /******************************************************************** Here follows a list of prototypes for the routines described above. ********************************************************************/ /* function prototypes for generic representation routines */ INT generate_standard_tableaux (OP partition, OP std); INT hecke_generator_reps (OP partition, OP vector); INT represent_hecke_element (OP partition, OP hecke, OP mat); INT build_lc (OP schizo, OP list); INT hecke_action_lc_on_lc (OP tableaux, OP hecke, OP result); INT standardise_cold_tableaux_list (OP tableaux, OP result); INT input_tableau (OP partit, OP tab); INT input_lc_permutations (OP save); INT substitute_one_matrix (OP mat); INT substitute_one_monopoly (OP mp); /* function prototypes for non-generic representation routines */ INT root_dimension (OP partition, OP p_root, OP dim); INT generate_root_tableaux (OP partition, OP p_root, OP std); INT hecke_root_generator_reps (OP partition, OP p_root, OP vector); INT root_represent_hecke_action (OP partition, OP p_root, OP hecke, OP mat); INT root_standardise_cold_tableaux_list (OP tableaux, OP p_root, OP result); /* function prototypes for matrix representation checking routines */ INT check_hecke_generators (OP vector, OP p_root, INT flag); INT check_hecke_quadratic (OP mat, OP p_root, INT flag); INT check_braid (OP mat1, OP mat2, OP p_root, INT flag); INT check_commute (OP mat1, OP mat2, OP p_root, INT flag); INT check_zero_matrix (OP mat, OP p_root); /* function prototypes to add or multiply hecke algebra elements */ INT hecke_add (OP hecke1, OP hecke2, OP result); INT hecke_mult (OP hecke1, OP hecke2, OP result); INT hecke_scale (OP hecke, OP power, OP coeff); /******************************************************************** Here follow brief descriptions of the example programs. ********************************************************************/ The following programs are each written in the C language, using the Symmetrica object oriented approach. EX1.C This program first requests a partition from the user. It then calculates the dimension of the corresponding irreducible representation of H_n in the generic case (using the function dimension_partition()), and outputs it. It then calculates representation matrices for each of the generators h_1,h_2,...h_{n-1} of H_n. These are stored as elements of the VECTOR object v. They are output. It is then checked that they satisfy the Hecke algebra defining relations. Note that this check may take considerably more time than the generation of the matrices themselves. EX2.C As in EX1.C, a partition is requested, and the dimension of the corresponding irreducible representation calculated and output. The user is then requested for a permutation (which should be input with length not exceeding the weight of the original partition). The matrix representing the element of H_n corresponding to the permutation is calculated and output. Note that in the call to represent_hecke_element(), a linear combination of permutations is required. This is the reason that the call to build_lc() is necessary: it converts the permutation into the required linear combination. A program more sophisticated than EX2.C would enable a linear combination of permutations to be input, and thus the matrix representing an arbitrary element of H_n to be obtained (using e.g., input_lc_permutations(); c.f. EX2X.C & EX4.C). Also note that the object w is not freed, since it is inside l, and is freed when l is freed. EX3.C As in EX1.C, a partition is requested, and the dimension of the corresponding irreducible representation calculated and output. The user is then requested for a tableau of the corresponding shape. This should be input row by row, starting from the top row (or the bottom row if you are French!). The tableau is then expressed in terms of the standard tableaux, and this result output. The earlier declaration english_tableau=TRUE; ensures that the tableaux are output in the conventional way for non-French people. Note that the function standardise_cold_tableaux_list() requires a linear combination of tableaux: hence the preceding call to build_lc(). Here, account is taken of the possibility that the user enters an inappropriate tableau (i.e. not one whose entries are distinct and from {1,2,...,weight_of_partition} ). In such a case, the function input_tableau() will return an ERROR, and the program will end gracefully. EX4.C As in EX1.C, a partition is requested, and the dimension of the corresponding irreducible representation calculated and output. The user is then requested for a tableau, and further for a linear combination of permutations. The action of the latter on the former is calculated and output. This list is then standardised. In essence, the action of an arbitrary element of H_n on a particular vector in the module is calculated. Error checking is rife: if one should occur, the program will exit gracefully. The way in which input_lc_permutations() requests for input is as follows: first a permutation is requested, then its one variable polynomial coefficient is built up a term at a time; an exponent is input followed by its coefficient. The program asks whether there are more terms to be added to the polynomial. When this polynomial coefficient is completed, the program asks whether there are further permutations. If the answer is 'y', then they and their coefficients will be requested. EX5.C As EX4.C except that the result of the action of the Hecke algebra element on the tableau can be subsequently acted on by another Hecke algebra element. And that subsequent result also, and so on. This program is more conveniently used with input redirected from a file (using e.g., a.out 0. COMMENT: For the generation of random INTEGERobjects, look at the following codefragment: . INT i; . . scan(INTEGER,upperbound); scan(INTEGER,lowerbound); for (i=0L;i<1000L;i++) { random_integer(result,lowerbound,upperbound); println(result);freeself(result); } . . . which prints 1000 random numbers between the upper and lower bound. Because this is a lowlevel routine, you have to free the result object, before you call the routine. NAME: random_integer SYNOPSIS: INT random_integer(OP result,lowerbound,upperbound) DESCRIPTION: computes a random INTEGERobject, between upper and lower bound. The result is greater equal lowerbond and strictly less then the upperbound. Both bounds are INTEGER objects. If lowerbound is NULL, then the default is 0. if upperbound is NULL, the default is lowerbound+10 It works also if upperbound is of type LONGINT. RETURN: the returnvalue is OK or ERROR if an error occured NAME: scan_integer SYNOPSIS: INT scan_integer( OP a) DESCRIPTION: the sub routine for reading interactivly an INTEGER object. There will be an error message if it was not possible to interpret the input (e.g. if you enter something, which is no number). You should use scan(INTEGER,a) instead. NAME: test_integer SYNOPSIS: INT test_integer() DESCRIPTION: tests the implementation NAME: mult_integer SYNOPSIS: INT mult_integer(OP a,b,c) DESCRIPTION: this is a undocumented subroutine of INT mult(OP a,b,c) You better use this general routine. NAME: add_integer SYNOPSIS: INT add_integer(OP a,b,c) DESCRIPTION: this is a undocumented subroutine of INT add(OP a,b,c) You better use this general routine. NAME: invers_integer SYNOPSIS: INT invers_integer(OP a,b) DESCRIPTION: this is a undocumented subroutine of INT invers(OP a,b) You better use this general routine. NAME: copy_integer SYNOPSIS: INT copy_integer(OP a,b) DESCRIPTION: this is a undocumented subroutine of INT copy(OP a,b) You better use this general routine. NAME: dec_integer SYNOPSIS: INT dec_integer(OP a) DESCRIPTION: this is a undocumented subroutine of INT dec(OP a). The INTEGER object a is decreased by 1. You better use the general routine dec. NAME: tex_integer SYNOPSIS: INT tex_integer(OP a) DESCRIPTION: this is a undocumented subroutine of INT tex(OP a). The INTEGER object a is transformed into tex-source-code. You better use the general routine tex. NAME: inc_integer SYNOPSIS: INT inc_integer(OP a) DESCRIPTION: this is a undocumented subroutine of INT inc(OP a). The INTEGER object a is increased by 1. You better use the general routine inc. NAME: ggt_integer SYNOPSIS: INT ggt_integer(OP a,b,c) DESCRIPTION: this is a undocumented subroutine of INT ggt(OP a,b,c). The routine computes the greatest common divisor of the two INTEGER objects a and b. You better use the general routine ggt. NAME: mod_integer SYNOPSIS: INT mod_integer(OP a,b,c) DESCRIPTION: this is a undocumented subroutine of INT mod(OP a,b,c). The routine computes the a mod b of the two INTEGER objects a and b. You better use the general routine mod. COMMENT: GLOBAL CONSTANTS ---------------- as you often need special INTEGER objects, there are some global INTEGER objects, there are: OP cons_eins the INTEGER object with value 1 OP cons_null the INTEGER object with value 0 OP cons_zwei the INTEGER object with value 2 OP cons_negeins the INTEGER object with value -1 so you may use these global variables instead of generating your own variables containing these often used INTEGER objects. But you are not allowed to free these variables or changing these variables. This will generate bad results in all the routines which trust on the values of these global variables. GENERAL ROUTINES ---------------- add() add_apply() addinvers() addinvers_apply() comp() copy() div() einsp() fprint() fprintln() ganzdiv() hoch() invers() mod() mult() mult_apply() negp() negeinsp() nullp() objectread() objectwrite() posp() print() println() scan() input from stdin=terminal sscan() tex() symmetrica-2.0/intro.doc0000644017361200001450000000476110726170275015246 0ustar tabbottcrontab SYMMETRICA There are some differences between SYMMETRICA and earlier SYMCHAR Versions, so read this chapter carefully. There is now a unified approach in naming the routines of SYMMETRICA. There are routines to select parts of a bigger object, their names start with s_ ...... which means select_ ..... There are routines to change parts of a bigger object, their names start with c_ ...... which means change_ ...... In order to construct new objects out of smaller ones, you have to look at two different methods. One method is to build out of smaller parts the bigger one, so that the smaller ones are part of the bigger one, so if you delete the bigger one, you also delete the smaller ones, or if you delete the smaller one, you delete also parts of the bigger one. This method of construction is done by routines with the name b_ ...... which means build_ .... The second method is to do the same but to use copies of the smaller objects, so that the bigger object is independent of the smaller one. These are the routines with the name m_ ...... which means make_ ..... These conventions are used for all the routines in SYMMETRICA. HOW TO WRITE A PROGRAM ______________________ You have to write your own C program, using the routines given to you by SYMMETRICA. The general outline is as follows: main() { . . anfang(); . . ende(); . . } So the smallest possible SYMMETRICA progam is main(){anfang();ende();} The whole package handles objects, which may be different things, but which can be handled by the same routine. Look at the following example: main() { OP a,b,c; anfang(); a = callocobject(), b = callocobject(), c = callocobject(); scan(BRUCH,a); scan(BRUCH,b); mult(a,b,c); println(c); freeall(a); freeall(b); freeall(c); ende(); } First you allocate space for the empty object, this is done three times. Then you scan two fractions (BRUCH objects). After this, the fractions are multiplied and the result of that is printed out. Now, if you simply substitute BRUCH by POLYNOM, you can do the same for two polynomials. This is because the standard routines can handle general objects. At the end you free the memory allocated for the three objects. This documentation is seperated into three parts, first a description of the different kind of objects, then a description of the different kinds of standard routines, and as the last part we give some examples, a guide for the installation and a list of all routines. symmetrica-2.0/io.c0000400017361200001450000010256210726021612014151 0ustar tabbottcrontab #include "def.h" #include "macro.h" static INT ausgabe_koeff(); static INT write_polynom(); /* global variables for output */ INT zeilenposition; INT texposition; INT texmath_yn; /* 1 in mathmode */ /* 0 not in mathmode */ INT scanoutput_yn; /* 1 no output */ /* 0 bitte output */ INT row_length = 70; INT tex_row_length = 70; INT integer_format = 0; /* no format */ INT print_type(a) OBJECTKIND a; /* AK 280294 */ /* AK 240398 V2.0 */ { OP b; INT erg = OK; b = CALLOCOBJECT(); C_O_K(b,a); erg += printobjectkind(b); C_O_K(b,EMPTY); FREEALL(b); ENDR("print_type"); } INT printobjectkind(a) OP a; /* AK 270689 V1.0 */ /* AK 020290 V1.1 */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ { INT erg = OK; if (a == NULL) { fprintf(stderr,"object is NULL object\n"); goto endr_ende; } fprintf(stderr,"kind of object is "); switch(S_O_K(a)) { case AUG_PART: fprintf(stderr,"augpart\n");break; case BARPERM: fprintf(stderr,"barred permutation\n");break; case BINTREE: fprintf(stderr,"bintree\n");break; case BITVECTOR: fprintf(stderr,"bitvector\n");break; case BRUCH: fprintf(stderr,"bruch\n");break; case CHARPARTITION: fprintf(stderr,"internal type charpartition\n");break; case COMPOSITION: fprintf(stderr,"composition\n");break; case CYCLOTOMIC: fprintf(stderr,"cyclotomic\n");break; case ELM_SYM: fprintf(stderr,"elementary symmetric function\n");break; case FF: fprintf(stderr,"finite field element\n");break; case GALOISRING: fprintf(stderr,"galois ring element\n");break; case GRAL: fprintf(stderr,"groupalgebra\n");break; case HOM_SYM: fprintf(stderr,"complete symmetric function\n");break; case INTEGER: fprintf(stderr,"integer\n");break; case KOSTKA: fprintf(stderr,"kostka\n");break; case KRANZ: fprintf(stderr,"kranz\n");break; case KRANZTYPUS: fprintf(stderr,"kranztypus\n");break; case LAURENT: fprintf(stderr,"laurent\n");break; case LIST: fprintf(stderr,"list\n");break; case LONGINT: fprintf(stderr,"longint\n");break; case INTEGERMATRIX: fprintf(stderr,"integermatrix\n");break; case MATRIX: fprintf(stderr,"matrix\n");break; case MONOM: fprintf(stderr,"monom\n");break; case MONOMIAL: fprintf(stderr,"monomial symmetric function\n");break; case MONOPOLY: fprintf(stderr,"monopoly\n");break; case PARTITION: fprintf(stderr,"partition\n");break; case PERMUTATION: fprintf(stderr,"permutation\n");break; case POLYNOM: fprintf(stderr,"polynom\n");break; case POW_SYM: fprintf(stderr,"powersum symmetric function\n");break; case REIHE: fprintf(stderr,"power-series\n");break; case SCHUR: fprintf(stderr,"schur-polynom\n");break; case SCHUBERT: fprintf(stderr,"schubert-polynom\n");break; case SKEWPARTITION: fprintf(stderr,"skewpartition\n");break; case SQ_RADICAL: fprintf(stderr,"square-radical\n");break; case SUBSET: fprintf(stderr,"subset\n");break; case SYMCHAR: fprintf(stderr,"symchar\n");break; case TABLEAUX: fprintf(stderr,"tableaux\n");break; case VECTOR: fprintf(stderr,"vector\n");break; case WORD: fprintf(stderr,"word\n");break; case HASHTABLE: fprintf(stderr,"hashtable\n");break; case INTEGERVECTOR: fprintf(stderr,"integervector\n");break; case (OBJECTKIND) 0: fprintf(stderr,"empty-object\n");break; default: fprintf(stderr," %ld ",S_O_K(a)); fprintf(stderr,"unknown\n"); break; }; ENDR("printobjectkind"); } INT ferrers(obj) OP obj; /* AK 290986 */ /* AK 010889 V1.0 */ /* AK 020290 V1.1 */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ { INT erg = OK; COP("ferrers(1)",obj); switch(S_O_K(obj)) { #ifdef PARTTRUE case PARTITION: erg += ferrers_partition(obj); break; #endif /* PARTTRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION: erg += ferrers_skewpartition(obj); break; #endif /* SKEWPARTTRUE */ default: erg += WTO("ferrers",obj); break; } ENDR("ferrers"); } INT scan_printeingabe(text) char *text; /* AK 250194 */ /* AK 240398 V2.0 */ { extern INT scanoutput_yn; /* 1 no output */ /* 0 bitte output */ if (scanoutput_yn == (INT) 0) return printeingabe(text); return OK; } INT printeingabe(text) char *text; /* AK 270689 V1.0 */ /* AK 020290 V1.1 */ /* AK 070291 V1.2 prints to stderr instead to stdout , returns OK */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ { fprintf(stderr,"%s\n",text); return OK; } INT sprint(string, obj) char *string; OP obj; /* AK 020195 */ /* to get length of string use strlen */ /* AK 240398 V2.0 */ { INT erg = OK; COP("sprint(2)",obj); COP("sprint(1)",string); switch(S_O_K(obj)) { #ifdef FFTRUE case FF: erg+= sprint_ff(string,obj); goto spe; #endif case INTEGER: erg+= sprint_integer(string,obj); goto spe; #ifdef LONGINTTRUE case LONGINT: erg+= sprint_longint(string,obj); goto spe; #endif /* LONGINTTRUE */ #ifdef PARTTRUE case SKEWPARTITION: erg+= sprint_skewpartition(string,obj); goto spe; case PARTITION: erg+= sprint_partition(string,obj); goto spe; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION: erg+= sprint_permutation(string,obj); goto spe; #endif /* PERMTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: erg+= sprint_integervector(string,obj); goto spe; case VECTOR: erg+= sprint_vector(string,obj); goto spe; #endif /* VECTORTRUE */ default: WTO("sprint(1)",obj); goto spe; } spe: ENDR("sprint"); } INT fprint(of,obj) FILE *of; OP obj; /* AK 211186 */ /* AK 270689 V1.0 */ /* AK 020290 V1.1 */ /* AK 050891 V1.3 */ /* AK 240398 V2.0 */ { INT erg = OK; COP("fprint(1)",of); COP("fprint(2)",obj); switch(S_O_K(obj)) { #ifdef PARTTRUE case AUG_PART: case PARTITION: erg += fprint_partition(of,obj);break; #endif /* PARTTRUE */ #ifdef BINTREETRUE case BINTREE: erg += fprint_bintree(of,obj);break; #endif /* BINTREETRUE */ #ifdef BRUCHTRUE case BRUCH: erg += fprint_bruch(of,obj);break; #endif /* BRUCHTRUE */ #ifdef FFTRUE case FF: erg += fprint_ff(of,obj);break; #endif /* FFTRUE */ #ifdef INTEGERTRUE case INTEGER: erg += fprint_integer(of,obj);break; #endif /* INTEGERTRUE */ #ifdef LISTTRUE case ELM_SYM: case MONOMIAL: case HOM_SYM: case POW_SYM: case GRAL: case MONOPOLY: case POLYNOM: case SCHUBERT: case SCHUR: case LIST: erg += fprint_list(of,obj);break; #endif /* LISTTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += fprint_longint(of,obj);break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KOSTKA: case KRANZTYPUS: case INTEGERMATRIX: case MATRIX: erg += fprint_matrix(of,obj);break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += fprint_monom(of,obj);break; #endif /* MONOMTRUE */ #ifdef PERMTRUE case PERMUTATION: erg += fprint_permutation(of,obj); break; #endif /* PERMTRUE */ #ifdef REIHETRUE case REIHE: erg += fprint_reihe(of,obj); break; #endif /* REIHETRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION: /*020488 */ erg += fprint_skewpartition(of,obj);break; #endif /* SKEWPARTTRUE */ #ifdef CHARTRUE case SYMCHAR: /*110488 */ erg += fprint_symchar(of,obj);break; #endif /* CHARTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX: /*020488 */ erg += fprint_tableaux(of,obj);break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case QUEUE: erg += fprint_queue(of,obj);break; case HASHTABLE: erg += fprint_hashtable(of,obj);break; case COMPOSITION: case SUBSET: case WORD: case KRANZ: case INTEGERVECTOR: case GALOISRING: case LAURENT: case VECTOR: erg += fprint_vector(of,obj);break; case BITVECTOR: erg += fprint_bitvector(of,obj);break; #endif /* VECTORTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: case CYCLOTOMIC: erg += fprint_number(of,obj);break; #endif /* NUMBERTRUE */ case 0: fprintf(of,"#"); /* AK 310889 */ if (of == stdout) zeilenposition++; break; default: erg += WTO("fprint",obj); break; }; ENDR("fprint"); } INT display(obj) OP obj; /* AK 271087 */ /* AK 270689 V1.0 */ /* AK 020290 V1.1 */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ { INT erg = OK; COP("display(1)",obj); switch(S_O_K(obj)) { #ifdef SCHUBERTTRUE case SCHUBERT: erg += display_schubert(obj); break; #endif /* SCHUBERTTRUE */ default: erg += WTO("display(1)",obj); break; }; ENDR("display"); } INT fprintln(f,obj) FILE *f; OP obj; /* AK 270689 V1.0 */ /* AK 020290 V1.1 */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ /* AK 201204 V3.0 */ { INT erg = OK; COP("fprintln(1)",f); COP("fprintln(2)",obj); erg += fprint(f,obj); putc('\n',f); if (f == stdout) zeilenposition = 0; ENDR("fprintln"); } INT check_zeilenposition(f) FILE *f; /* AK 201204 */ { if (f==stdout) { /* printf("(zp=%d)",zeilenposition); */ if (zeilenposition > row_length) { putchar('\n'); zeilenposition=0; } } return OK; } INT print(obj) OP obj; /* AK 270689 V1.0 */ /* AK 020290 V1.1 */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ /* AK 201204 V3.0 */ { INT erg = OK; COP("print(1)",obj); erg += check_zeilenposition(stdout); erg += fprint(stdout,obj); ENDR("print"); } INT println(obj) OP obj; /* AK 270689 V1.0 */ /* AK 020290 V1.1 */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ { INT erg = OK; COP("println(1)",obj); erg += print(obj); putchar('\n'); zeilenposition = 0; ENDR("println"); } INT skip_comment() /* AK 240398 V2.0 */ { int i; /* here we insert code to implement comments *//* AK 210395 */ sa: i = getc(stdin); if (i == EOF) return error("scan:EOF encountered"); else if (i==' ') goto sa; else if (i=='\t') goto sa; else if (i=='#') /* comments til the end of line */ { while ((i=getc(stdin)) != '\n'); goto sa; } else ungetc(i,stdin); return OK; } INT scan(kind,obj) OBJECTKIND kind; OP obj; /* AK 270787 */ /* AK 280689 V1.0 */ /* AK 020290 V1.1 */ /* AK 050891 V1.3 */ /* AK 240298 V2.0 */ { INT erg = OK; COP("scan(2)",obj); if (not EMPTYP(obj)) erg += freeself(obj); switch(kind) { #ifdef BRUCHTRUE case BRUCH: erg += scan_bruch(obj); break; case INTEGERBRUCH: erg += scan_integerbruch(obj); break; #endif /* BRUCHTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += scan_cyclo(obj); break; #endif /* CYCLOTRUE */ #ifdef ELMSYMTRUE case ELM_SYM: erg += scan_elmsym(obj); break; #endif /* ELMSYMTRUE */ #ifdef GRALTRUE case GRAL: erg += scan_gral(obj); break; #endif /* GRALTRUE */ #ifdef FFTRUE case FF: erg += scan_ff(obj); break; #endif /* FFTRUE */ #ifdef HOMSYMTRUE case HOM_SYM: erg += scan_homsym(obj); break; #endif /* HOMSYMTRUE */ #ifdef INTEGERTRUE case INTEGER: erg += scan_integer(obj); break; #endif /* INTEGERTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: erg += scan_integervector(obj); break; #endif /* VECTORTRUE */ #ifdef MATRIXTRUE case INTEGERMATRIX: erg += scan_integermatrix(obj); break; #endif /* MATRIXTRUE */ #ifdef KOSTKATRUE case KOSTKA: erg += scan_kostka(obj); break; #endif /* KOSTKATRUE */ #ifdef KRANZTRUE case KRANZ: erg += scan_kranz(obj); break; #endif /* KRANZTRUE */ #ifdef LAURENTTRUE case LAURENT: erg += scan_laurent(obj); break; #endif /* LAURENTTRUE */ #ifdef LISTTRUE case LIST: erg += scan_list(obj,(OBJECTKIND)0); break; #endif /* LISTTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += scan_longint(obj); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS: erg += scan_matrix(obj); C_O_K(obj,KRANZTYPUS); break; case MATRIX: erg += scan_matrix(obj); break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += scan_monom(obj); break; #endif /* MONOMTRUE */ #ifdef MONOMIALTRUE case MONOMIAL: erg += scan_monomial(obj); break; #endif /* MONOMIALTRUE */ #ifdef MONOPOLYTRUE case MONOPOLY: erg += scan_monopoly(obj); break; #endif /* MONOPOLYTRUE */ #ifdef PARTTRUE case REVERSEPARTITION: erg += scan_reversepartition(obj); break; case EXPONENTPARTITION: erg += scan_exponentpartition(obj); break; case PARTITION: erg += scan_partition(obj); break; #endif /* PARTTRUE */ #ifdef PERMTRUE case BARPERM: erg += scan_bar(obj); break; case PERMUTATION: erg += scan_permutation(obj); break; #endif /* PERMTRUE */ #ifdef POLYTRUE case FASTPOLYNOM: erg += scan_fastpolynom(obj); break; case POLYNOM: erg += scan_polynom(obj); break; #endif /* POLYTRUE */ #ifdef POWSYMTRUE case POW_SYM: erg += scan_powsym(obj); break; #endif /* POWSYMTRUE */ #ifdef REIHETRUE case REIHE: erg += scan_reihe(obj); break; #endif /* REIHETRUE */ #ifdef SCHUBERTTRUE case SCHUBERT: erg += scan_schubert(obj); break; #endif /* SCHUBERTTRUE */ #ifdef SCHURTRUE case SCHUR: erg += scan_schur(obj); break; #endif /* SCHURTRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION: erg += scan_skewpartition(obj); break; #endif /* SKEWPARTTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += scan_sqrad(obj); break; #endif /* SQRADTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += scan_symchar(obj); break; #endif /* CHARTRUE */ #ifdef TABLEAUXTRUE case PARTTABLEAUX: erg += scan_parttableaux(obj); break; case SKEWTABLEAUX: erg += scan_skewtableaux(obj); break; case TABLEAUX: erg += scan_tableaux(obj); break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case VECTOR: erg += scan_vector(obj); break; case BITVECTOR: erg += scan_bitvector(obj); break; case PERMUTATIONVECTOR: erg += scan_permvector(obj); break; #endif /* VECTORTRUE */ #ifdef WORDTRUE case WORD: erg += scan_word(obj); break; #endif /* WORDTRUE */ default: { fprintf(stderr,"kind = %ld\n",kind); erg += error("scan:wrong type"); goto endr_ende; } }; ENDR("scan"); } INT skip(t,kind) char *t; OBJECTKIND kind; /* AK 300998 */ /* return >= 0 gives the offset in t after the given object */ { INT erg = OK; COP("skip(1)",t); switch(kind) { case INTEGER: { erg = skip_integer(t); if (erg >= 0) return erg; } default: { fprintf(stderr,"kind = %ld\n",kind); erg += error("skip:wrong type"); goto endr_ende; } } ENDR("skip"); } INT sscan(t,kind,obj) char *t; OBJECTKIND kind; OP obj; /* AK 301293 */ { INT erg = OK; COP("sscan(1)",t); COP("sscan(3)",obj); if (not EMPTYP(obj)) erg += freeself(obj); switch(kind) { #ifdef INTEGERTRUE case INTEGER: erg += sscan_integer(t,obj); break; #endif /* INTEGERTRUE */ #ifdef VECTORTRUE case BITVECTOR: erg += sscan_bitvector(t,obj); break; case INTEGERVECTOR: erg += sscan_integervector(t,obj); break; case PERMUTATIONVECTOR: erg += sscan_permvector(t,obj); break; #endif /* VECTORTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += sscan_longint(t,obj); break; #endif /* LONGINTTRUE */ #ifdef PARTTRUE case PARTITION: erg += sscan_partition(t,obj); break; case REVERSEPARTITION: erg += sscan_reversepartition(t,obj); break; #endif /* PARTTRUE */ #ifdef PERMTRUE case BARPERM: erg += sscan_bar(t,obj); break; case PERMUTATION: erg += sscan_permutation(t,obj); break; #endif /* PERMTRUE */ #ifdef SCHURTRUE case ELMSYM: erg += sscan_elmsym(t,obj); break; case HOMSYM: erg += sscan_homsym(t,obj); break; case SCHUR: erg += sscan_schur(t,obj); break; #endif /* SCHURTRUE */ #ifdef WORDTRUE case WORD: erg += sscan_word(t,obj); break; #endif /* WORDTRUE */ default: { fprintf(stderr,"kind = %ld\n",kind); error("sscan:wrong type"); return(ERROR); } }; ENDR("sscan"); } OBJECTKIND scanobjectkind() /* routine zum einlesen des objecttyps 160787 */ /* AK 280689 V1.0 */ /* AK 020290 V1.1 */ /* AK 070291 V1.2 works with stderr instead of stdin */ /* AK 130891 V1.3 */ /* AK 240398 V2.0 */ { INT erg; INT i = 0L; printeingabe("enter kind of object"); /* hier sind neue objecttypen einzufuegen */ #ifdef INTEGERTRUE fprintf(stderr,"integer [1]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* INTEGERTRUE */ #ifdef VECTORTRUE fprintf(stderr,"vector [2]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* VECTORTRUE */ #ifdef PARTTRUE fprintf(stderr,"partition [3]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* PARTTRUE */ #ifdef BRUCHTRUE fprintf(stderr,"bruch [4]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* BRUCHTRUE */ #ifdef PERMTRUE fprintf(stderr,"permutation [6]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* PERMTRUE */ #ifdef SKEWPARTTRUE fprintf(stderr,"skewpart [7]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* SKEWPARTTRUE */ #ifdef TABLEAUXTRUE fprintf(stderr,"tableaux [8]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* TABLEAUXTRUE */ #ifdef POLYTRUE fprintf(stderr,"polynom [9]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* POLYTRUE */ #ifdef SCHURTRUE fprintf(stderr,"schurfunk [10]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* SCHURTRUE */ #ifdef MATRIXTRUE fprintf(stderr,"matrix [11]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* MATRIXTRUE */ #ifdef HOMSYMTRUE fprintf(stderr,"homsym [13]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* HOMSYMTRUE */ #ifdef SCHUBERTTRUE fprintf(stderr,"schubert [14]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* SCHUBERTTRUE */ #ifdef KOSTKATRUE fprintf(stderr,"kostka [16]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* KOSTKATRUE */ #ifdef CHARTRUE fprintf(stderr,"symchar [18]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* CHARTRUE */ #ifdef WORDTRUE fprintf(stderr,"word [19]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* WORDTRUE */ #ifdef LISTTRUE fprintf(stderr,"list [20]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* LISTTRUE */ #ifdef LONGINTTRUE fprintf(stderr,"longint [22]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* LONGINTTRUE */ #ifdef POWSYMTRUE fprintf(stderr,"powersum [28]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* POWSYMTRUE */ #ifdef MONOMIALTRUE fprintf(stderr,"mon. sym. [29]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* MONOMIALTRUE */ #ifdef GRALTRUE fprintf(stderr,"groupalg. [32]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* GRALTRUE */ #ifdef ELMSYMTRUE fprintf(stderr,"elm. sym. [33]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* ELMSYMTRUE */ #ifdef FFTRUE fprintf(stderr,"fin. field [35]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* FFTRUE */ #ifdef REIHETRUE fprintf(stderr,"reihe [36]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* REIHETRUE */ #ifdef CYCLOTRUE fprintf(stderr,"cyclotomic [41]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* CYCLOTRUE */ #ifdef MONOPOLYTRUE fprintf(stderr,"monopoly [42]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* MONOPOLYTRUE */ #ifdef SQRADTRUE fprintf(stderr,"radical [43]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* SQRADTRUE */ fprintf(stderr,"bitvector [44]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #ifdef LAURENTTRUE fprintf(stderr,"laurent [45]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; #endif /* LAURENTTRUE */ fprintf(stderr,"barperm [46]"); if (i++ == 4L)fprintf(stderr,"\n"),i=0L; fprintf(stderr,"\nwhat kind:? "); scanf("%ld",&erg); if (erg == 46) erg = BARPERM; return (OBJECTKIND)erg; } INT objectread(f,obj) FILE *f; OP obj; /* AK 131086 */ /* AK 280689 V1.0 */ /* AK 160190 V1.1 */ /* AK 020591 V1.2 */ /* AK 090891 V1.3 */ /* AK 240398 V2.0 */ { OBJECTKIND kind; INT c,erg=OK,i; COP("objectread(1)",f); COP("objectread(2)",obj); FREESELF(obj); i=fscanf(f,"%ld",&c); SYMCHECK(i!=1,"objectread:could not read datatype"); kind = (OBJECTKIND)c; switch(kind) { case (OBJECTKIND)0: break; #ifdef BRUCHTRUE case BRUCH: erg += objectread_bruch(f,obj); break; #endif /* BRUCHTRUE */ #ifdef FFTRUE case FF: erg += objectread_ff(f,obj); break; #endif /* FFTRUE */ #ifdef INTEGERTRUE case INTEGER: erg += objectread_integer(f,obj); break; #endif /* INTEGERTRUE */ #ifdef LISTTRUE case GRAL: case HOM_SYM: case POW_SYM: case MONOMIAL: case ELM_SYM: case SCHUR: case MONOPOLY: case POLYNOM: case SCHUBERT: case LIST: erg += objectread_list(f,obj); C_O_K(obj,kind); break; #endif /* LISTTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += objectread_longint(f,obj); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case MATRIX: erg += objectread_matrix(f,obj); break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += objectread_monom(f,obj); break; #endif /* MONOMTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: erg += OBJECTREAD_SQRAD(f,obj); break; case CYCLOTOMIC: erg += OBJECTREAD_CYCLO(f,obj); break; #endif /* NUMBERTRUE */ #ifdef PARTTRUE case PARTITION: erg += objectread_partition(f,obj); break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION: erg += objectread_permutation(f,obj); break; #endif /* PERMTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += objectread_symchar(f,obj); break; #endif /* CHARTRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION: erg += objectread_skewpartition(f,obj); break; #endif /* SKEWPARTTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX: erg += objectread_tableaux(f,obj); break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case HASHTABLE: erg += objectread_hashtable(f,obj); break; case COMPOSITION: case INTEGERVECTOR: case VECTOR: case GALOISRING: erg += objectread_vector(f,obj); C_O_K(obj,c); break; case BITVECTOR: erg += objectread_bv(f,obj); break; #endif /* VECTORTRUE */ default: fprintf(stderr,"kind = %ld\n",kind); erg += error("objectread:wrong type"); goto oe; }; oe: ENDR("objectread"); } INT objectwrite(f,obj) FILE *f; OP obj; /* AK 131086 */ /* AK 280689 V1.0 */ /* AK 160190 V1.1 */ /* AK 090891 V1.3 */ /* AK 240398 V2.0 */ { INT erg = OK; COP("objectwrite(1)",f); COP("objectwrite(2)",obj); switch(S_O_K(obj)) { case 0: fprintf(f," %ld ",0L); return(OK); #ifdef BRUCHTRUE case BRUCH: erg += objectwrite_bruch(f,obj);break; #endif /* BRUCHTRUE */ #ifdef FFTRUE case FF: erg += objectwrite_ff(f,obj);break; #endif /* FFTRUE */ #ifdef INTEGERTRUE case INTEGER: erg += objectwrite_integer(f,obj);break; #endif /* INTEGERTRUE */ #ifdef LISTTRUE case GRAL: case HOM_SYM: case POW_SYM: case ELM_SYM: case MONOMIAL: case SCHUR: case MONOPOLY: case POLYNOM: case SCHUBERT: case LIST: erg += objectwrite_list(f,obj); break; #endif /* LISTTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += objectwrite_longint(f,obj);break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS: /* AK 220492 */ case MATRIX: erg += objectwrite_matrix(f,obj);break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += objectwrite_monom(f,obj);break; #endif /* MONOMTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: case CYCLOTOMIC: erg += objectwrite_number(f,obj);break; #endif /* NUMBERTRUE */ #ifdef PARTTRUE case PARTITION: erg += objectwrite_partition(f,obj);break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION:erg += objectwrite_permutation(f,obj);break; #endif /* PERMTRUE */ #ifdef CHARTRUE case SYMCHAR:erg += objectwrite_symchar(f,obj);break; #endif /* CHARTRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION: erg += objectwrite_skewpartition(f,obj); break; #endif /* SKEWPARTTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX: erg += objectwrite_tableaux(f,obj);break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case HASHTABLE: erg += objectwrite_hashtable(f,obj); break; case INTEGERVECTOR: case COMPOSITION: case GALOISRING: case VECTOR: erg += objectwrite_vector(f,obj);break; case BITVECTOR: erg += objectwrite_bv(f,obj); break; #endif default: { printobjectkind(obj); return error("objectwrite:wrong type"); } }; ENDR("objectwrite"); } INT tex(obj) OP obj; /* tex-output of the object obj */ /* AK 101187 */ /* AK 060789 V1.0 */ /* AK 020290 V1.1 */ /* AK 300791 V1.3 */ /* AK 260298 V2.0 */ { INT erg = OK; /* es folgen zwei sonderfaelle */ EOP("tex(1)",obj); switch(S_O_K(obj)) { #ifdef BRUCHTRUE case BRUCH: erg += tex_bruch(obj);break; #endif /* BRUCHTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += tex_cyclo(obj); break; #endif /* CYCLOTRUE */ #ifdef INTEGERTRUE case INTEGER: erg += tex_integer(obj);break; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += tex_longint(obj); break; #endif /* LONGINTTRUE */ #ifdef MONOPOLYTRUE case MONOPOLY: erg += tex_monopoly(obj); break; #endif /* MONOPOLYTRUE */ #ifdef SCHUBERTTRUE case SCHUBERT: erg += tex_schubert(obj); break; #endif /* SCHUBERTTRUE */ #ifdef SCHURTRUE case MONOMIAL: case POW_SYM: case ELM_SYM: case HOM_SYM: case SCHUR:erg += tex_schur(obj); break; #endif /* SCHURTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += tex_symchar(obj); break; #endif /* CHARTRUE */ case GRAL: #ifdef LISTTRUE case LIST: erg += tex_list(obj);break; #endif /* LISTTRUE */ #ifdef MATRIXTRUE case KOSTKA: case MATRIX: erg += tex_matrix(obj);break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += tex_monom(obj);break; #endif /* MONOMTRUE */ #ifdef PARTTRUE case PARTITION: erg+= tex_partition(obj);break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION: erg+= tex_permutation(obj);break; #endif /* PERMTRUE */ #ifdef POLYTRUE case POLYNOM: erg+= tex_polynom(obj);break; #endif /* POLYTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX: erg+= tex_tableaux(obj);break; #endif /* TABLEAUXTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += tex_sqrad(obj);break; #endif /* SQRADTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case SUBSET: case HASHTABLE: case COMPOSITION: case VECTOR: erg += tex_vector(obj); break; #endif /* VECTORTRUE */ default: WTO("tex",obj); break; }; ENDR("tex"); } #ifdef MATRIXTRUE #ifdef POLYTRUE INT latex_glm_dar(M) OP M; /* RH */ /* AK 280192 output to texout */ /* AK 240398 V2.0 */ { INT i; INT j; INT k; INT var = 1L; OP moddy = callocobject(); OP rest = callocobject(); OP vier = callocobject(); if(S_M_LI(M) >= 10) var = 1L; M_I_I(var,vier); ganzdiv(S_M_L(M),vier,moddy); mult(moddy,vier,vier); sub(S_M_L(M),vier,rest); if(S_I_I(moddy) != 0L) { fprintf(texout,"$$\n"); fprintf(texout,"\\left[\n"); for(i=0L;i 0L) if(S_M_IJI(s_po_s(z),k,l) == 1L) fprintf(texout,"x_{%ld %ld} ",k+1L,l+1L); else fprintf(texout,"x_{%ld %ld}^{%ld} ",k+1L,l+1L,S_M_IJI(s_po_s(z),k,l)); } if(S_PO_N(z) != NULL) { fprintf(texout,"+"); } } z = S_PO_N(z); } return OK; } #endif /* POLYTRUE */ static INT ausgabe_koeff(k) OP k; /* AK 280192 output to texout */ /* AK 240398 V2.0 */ { switch(S_O_K(k)) { case INTEGER: { if(S_I_I(k) == 1L) break; if(S_I_I(k) == -1L) { fprintf(texout,"-"); break; } print(k); break; } #ifdef BRUCHTRUE case BRUCH: { kuerzen(k); fprintf(texout,"\\frac{"); ausgabe_koeff(S_B_O(k)); fprintf(texout,"}{"); ausgabe_koeff(S_B_U(k)); fprintf(texout,"}"); break; } #endif /* BRUCHTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: { OP ptr = S_N_S(k); while(ptr != NULL) { fprintf(texout,"\\sqrt{"); ausgabe_koeff(S_PO_S(ptr)); fprintf(texout,"}"); ptr = S_L_N(ptr); } break; } #endif /* NUMBERTRUE */ default: { printobjectkind(k); error("unknown type of coefficient !!!\n"); break; } } return OK; } symmetrica-2.0/io.doc0000600017361200001450000001714110726170275014506 0ustar tabbottcrontabCOMMENT: IO-Functions ------------ NAME: display SYNOPSIS: INT display( OP a) DESCRIPTION: This is a old routine to provide nice output of special objects. RETURN: OK or ERROR BUGS: It only works for SCHUBERT objects. NAME: ferrers SYNOPSIS: INT ferrers( OP a) DESCRIPTION: prints the Ferrers diagramm of a PARTITION object to stdout. RETURN: OK or ERROR BUGS: does not work with SKEWPARTITION object NAME: fprint SYNOPSIS: INT fprint(FILE *fp, OP a) DESCRIPTION: prints the entered object a to the file pointed to by fp. This works for the following kind of objects: AUG_PART, BINTREE, BRUCH, GEN_CHAR, GRAPH, INTEGER, HOM_SYM, PARTITION, GRAL, MONOPOLY, POLYNOM, SCHUBERT, SCHUR, LIST, LONGINT, MATRIX, KOSTKA, KRANZTYPUS, MONOM, PERMUTATION, SKEWPARTITION, SYMCHAR TABLEAUX, COMP, WORD, VECTOR, SQ_RADICAL, CYCLOTOMIC If you print to stdout there is a global variable INT zeilenposition, which is updated to do line breaks after about 70 chars printed to stdout. RETURN: OK or ERROR BUGS: Sometimes the output is not easy to unterstand, there is no difference between a VECTOR object with INTEGER objects and a PERMUTATION object. NAME: fprintln SYNOPSIS: INT fprintln(FILE *fp, OP a) DESCRIPTION: this does the same as fprint but with a trailing newline. RETURN: OK NAME: objectread SYNOPSIS: INT objectread(FILE *fp, OP a) DESCRIPTION: reads an object from the file fp, the object will be in the variable a. The object must have been stored before by the routine objectwrite. This works for the following types: BRUCH, INTEGER, GRAL, HOM_SYM, SCHUR, MONOPOLY, POLYNOM, SCHUBERT, LIST, LONGINT, MATRIX, MONOM, SQ_RADICAL, CYCLOTOMIC, PARTITION, PERMUTATION, SYMCHAR, SKEWPARTITION, TABLEAUX, VECTOR, INTEGERVECTOR, BITVECTOR There is an error message in the case of fp == NULL. BUGS: The format of storage is directly readable and because of that very storage space consuming. not yet implemented for all types NAME: objectwrite SYNOPSIS: INT objectwrite(FILE *fp, OP a) DESCRIPTION: stores the object a in the file pointed by fp. In general the format codes first the type of the object and then it stores the parts of the object. Further information is in the doc files for special objects. At the moment it works for the following types: BRUCH CYCLOTOMIC GRAL HOM_SYM INTEGER LIST LONGINT MATRIX MONOM MONOPOLY PARTITION PERMUTATION POLYNOM SKEWPARTITION SCHUBERT SCHUR SYMCHAR SQ_RADICAL TABLEAUX VECTOR INTEGERVECTOR, BITVECTOR There is an error message in the case of fp == NULL. BUGS: not yet implemented for all types EXAMPLE: #include "def.h" #include "macro.h" main() { OP a,b; FILE *fp1,*fp2; anfang(); a=callocobject(); b=callocobject(); scan(scanobjectkind(),a); fp1=fopen("klo.dat","w"); objectwrite(fp1,a); fclose(fp1); fp1=fopen("klo.dat","r"); objectread(fp1,b); fclose(fp1); println(b); freeall(a); freeall(b); ende(); } NAME: sprint SYNOPSIS: INT sprint(char *t; OP obj) DESCRIPTION: prints an object on a string. It is up to the user that the string is big enough to store the result. At the moment it works for the following types: INTEGER, LONGINT BUGS: not all types are implemented. NAME: print SYNOPSIS: INT print(OP a) DESCRIPTION: prints the object a to stdout. The position on stdout is updated using a global variable 'INT zeilenposition'. At about position 70 it prints a newline to stdout, and changes 'zeilenposition' to 0. It calls the subroutine fprint, and works so for the same types. RETURN: OK if no error BUGS: as in fprint NAME: printeingabe SYNOPSIS: INT printeingabe(char *text) DESCRIPTION: prints the entered text to stderr, this is under normal circumstances the terminal of the user. After the text it prints a newline. CHANGES: in former versions, it printed to stdout RETURN: OK if no error BUGS: there is no variable for the position of the cursor on stderr, like for stdout. NAME: println SYNOPSIS: INT println(OP a) DESCRIPTION: prints the object a to stdout, at the end it prints newline. (compare with print) BUGS: as in print NAME: printobjectkind SYNOPSIS: INT printobjectkind(OP a) DESCRIPTION: print the kind of the object a. This is a routine, which must be changed for every new type of object. EXAMPLE: ...... OP a = callocobject(); scan(INTEGER,a); printobjectkind(a); ...... will print the information integer on the terminal NAME: scan SYNOPSIS: INT scan(OBJECTKIND typ, OP result) DESCRIPTION: reads an object of the specified kind into the object result. The result is freed first to an empty object. You can read the following kinds BRUCH CYCLOTOMIC FASTPOLYNOM GEN_CHAR GRAL HOM_SYM INTEGER INTEGERVECTOR KOSTKA KRANZ KRANZTYPUS LIST LONGINT MATRIX MONOM MONOPOLY PARTITION PERMUTATION POLYNOM SCHUBERT SCHUR SKEWPARTITION SQ_RADICAL SYMCHAR TABLEAUX VECTOR WORD The kind INTEGERVECTOR is a special kind only provided as a type for input. The output during scanning is written using the routine printeingabe, so it prints to stderr, you may redirect it (only on systems where it is possible). RETURN: OK if no error a value different from OK else. BUGS: there is much output during scanning of an object. NAME: sscan SYNOPSIS: INT sscan(char *string, OBJECTKIND typ, OP result) DESCRIPTION: reads an object of the specified kind into the object result. The input is a string entered as the first parameter. You can read the following kinds INTEGER LONGINT PARTITION PERMUTATION SCHUR RETURN: OK if no error a value different from OK else. BUGS: many types are missing EXAMPLE: /* SYMMETRICA */ #include "def.h" #include "macro.h" main() { OP a; anfang(); a = callocobject(); sscan("-1237878456777777", LONGINT, a); println(a); freeall(a); ende(); } NAME: scanobjectkind SYNOPSIS: OBJECTKIND scanobjectkind() DESCRIPTION: reads interactively the kind of an object RETURN: the read kind of object CHANGES: in version 1.1 it prints the text of the interaction to stdout, now it prints to stderr BUGS: not all types are listed NAME: tex SYNOPSIS: INT tex(OP a) DESCRIPTION: gives an output in tex-readible form. It works for the following types of objects: BRUCH CYCLOTOMIC GRAL INTEGER KOSTKA LIST LONGINT MATRIX MONOM MONOPOLY PARTITION PERMUTATION POLYNOM SCHUBERT SCHUR SQ_RADICAL SYMCHAR TABLEAUX VECTOR The position in the file of the texoutput is updated using a global variable INT texposition. CHANGES: in version 1.1 it prints the TeX-output to stdout, now in version 1.2+ it prints to texout, which is in the default case stdout, but may be changed by the user. BUGS: does not work for all types there are too many switches between math mode and no math mode. LaTeX output would also be good. EXAMPLE: #include "def.h" #include "macro.h" main() { OP a; anfang(); a=callocobject(); texout = fopen("klo","w"); scan(BRUCH,a); tex(a); freeall(a); ende(); } and the output will be written to the file klo. symmetrica-2.0/ko.c0000400017361200001450000011775510726021612014165 0ustar tabbottcrontab #include "def.h" #include "macro.h" static INT rh_kostka(); static INT rh_insert(); static INT rh_delete(); static INT rh_ausgabemat(); static OP lookupinschurspeicher(); static INT kostka_tab_partition(); static INT kostka_tab_skewpartition(); static INT neu_n_kostka(); static INT nspeicherkostka(); #define RH_MAX 100 #ifdef KOSTKATRUE INT kostka_number(inh,shape,res) OP inh,shape,res; /* AK 020890 V1.1 */ /* AK 210891 V1.3 */ /* AK 240398 V2.0 */ { OP d; INT i; INT erg = OK; CE3(inh,shape,res,kostka_number); if (S_O_K(inh) == PARTITION) /* AK 100992 */ d = S_PA_S(inh); else if (S_O_K(inh) == VECTOR) d = inh; else if (S_O_K(inh) == INTVECTOR) d = inh; else { WTO(inh,"kostka_number:content"); goto endr_ende; } for (i=(INT)0;i 0) { erg += init(HASHTABLE,s); erg += schur_part_skewschur(b,S_V_I(a,i),s); SWAP(b,s); } CTO(HASHTABLE,"mkn_co(internal)",b); FORALL(z,b,{ goto ee; } ); M_I_I(0,c); goto ende; ee: COPY(S_MO_K(z),c); ende: FREEALL(s); CTTO(INTEGER,LONGINT,"mkn_co(res)",c); ENDR("internal to kostka_number_partition"); } INT kostka_tafel(a,b) OP a,b; /* AK 220488 */ /* AK 220897 S1R */ /* AK 160299 input tested */ { INT erg=OK; CTO(INTEGER,"kostka_tafel",a); if (S_I_I(a) == 0) { erg += m_ilih_m((INT)0, (INT)0, b); goto endr_ende; } if (S_I_I(a) < 0) { error("kostka_tafel:weight <= 0"); goto endr_ende; } C1R(a,"kostka_tafel",b); erg += neu_n_kostka(a,b); S1R(a,"kostka_tafel",b); ENDR("kostka_tafel"); } INT invers_kostka_tafel(a,b) OP a,b; /* AK 220897 */ /* AK 171297 input tested */ { INT erg = OK; OP c; CTO(INTEGER,"invers_kostka_tafel",a); if (S_I_I(a) == 0) { erg += m_ilih_m((INT)0, (INT)0, b); goto endr_ende; } else if ( S_I_I(a) < 0 ) { erg += error("invers_kostka_tafel: weight < 0"); goto endr_ende; } C1R(a,"invers_kostka_tafel",b); c = callocobject(); erg += kostka_tafel(a,c); erg += invers(c,b); erg += freeall(c); S1R(a,"invers_kostka_tafel",b); ENDR("invers_kostka_tafel"); } INT make_n_transpositionmatrix(dim,mat) OP dim,mat; /* 300388 berechnet die matrix J [MD p.55] J_PQ = 1 <==> conjugierte Partition von P ist Q, null sonst */ /* AK 200789 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT i; INT erg = OK; OP conpart; OP vector; CTO(INTEGER,"make_n_transpositionmatrix(1)",dim); conpart=callocobject(); vector=callocobject(); erg += init_kostka(dim,mat,vector); for (i=(INT)0;i S_PA_II(prepart,(l-1L))) { INC_INTEGER(S_PA_I(prepart,(l-1L))); *j = l; goto prepartende; }; /* der Sonderfall falls in der letzten Zeile ein kaestchen angefuegt wird */ INC_INTEGER(S_PA_I(prepart,(l-1L))); *j = l; goto prepartende; } else { /* part beginnt mit > 1 */ copy_partition(part,prepart); DEC_INTEGER(S_PA_I(prepart,(INT)0)); for (l=2L;l S_PA_II(prepart,(l-1L))) { INC_INTEGER(S_PA_I(prepart,(l-1L))); *j = l-1L; goto prepartende; }; INC_INTEGER(S_PA_I(prepart,(l-1L))); *j = l-1L; goto prepartende; }; prepartende: ENDR("prepartdom"); } INT init_kostka(n,koma,vector) OP koma,n,vector; /* AK 250587 */ /* AK 200789 V1.0 */ /* koma wird eine Matrix gross genug, vector ein vector der partitionen */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT i,j,l; if (not EMPTYP(koma)) freeself(koma); if (not EMPTYP(vector)) freeself(vector); makevectorofpart(n,vector); l = S_V_LI(vector); m_ilih_m(l,l,koma); /* AK 030189 */ for (i=(INT)0;i= 1L) { counter = (INT)0; for(i=j;i<=hilf_zwei[k];++i) { counter++; um[i] = x; } k--; x=k; j+= counter; } for(i=1L;i<=n;++i) hilf[i] = um[i]; um[0] = -1L; for(i=(INT)0;i um[l-1])&&(um[l] > ziel[l])) { um[l]--; rh_insert(tab[l],st,len); rh_kostka(tab,um,ziel,inh,l, i+1L,zahl,st,len,n,deg,c,d); rh_delete(tab[l],st,len); um[l]++; } } } return(OK); } static INT rh_ausgabemat(tab,n,laenge,c,d) INT tab[RH_MAX][RH_MAX],n,laenge; OP c,d; /* c ist liste, d ist umriss */ /* Ralf Hager 1989 */ /* AK 281289 V1.1 */ /* AK 210891 V1.3 */ { INT i; INT j; INT erg = OK; OP e = callocobject(); OP f = callocobject(); erg += copy(d,e); erg += m_u_t(e,f); for(i=1L;i<=n;++i) for(j=1L;j<=laenge;++j) { if (tab[j][i] > (INT)0) M_I_I(tab[j][i],S_T_IJ(f,i-1L,j-1L)); } insert(f,c,NULL,NULL); erg += freeall(e); /* AK 130392 */ return erg; } static INT rh_insert(v,z,len) INT v[RH_MAX]; INT z,len; { INT i; for(i=1L;i<=len;++i) if(v[i]==(INT)0) { v[i]=z; break; } return(OK); } static INT rh_delete(v,z,len) INT v[RH_MAX]; INT z,len; { INT i; for(i=len;i>=1L;--i) if(v[i]>(INT)0) { v[i]=(INT)0; break; } return(OK); } INT kostka_character(a,b) OP a,b; /* AK 020290 V1.1 */ /* AK 210891 V1.3 */ { OP c = callocobject(); m_part_kostkaperm(a,c); newtrans(c,b); freeall(c); return(OK); } INT m_part_kostkaperm(a,b) OP a,b; /* AK 020290 V1.1 */ /* AK 210891 V1.3 */ { INT i,j; OP z; OP c = callocobject(); OP d = callocobject(); weight(a,c); m_il_v(S_I_I(c) + S_PA_LI(a),d); z = S_V_S(d); for (i=(INT)0;i= 1L) { counter = (INT)0; for(i=j;i<=hilf_zwei[k];++i) { counter++; um[i] = x; } k--; x=k; j+= counter; } for(i=1L;i<=n;++i) hilf[i] = um[i]; um[0] = -1L; for(i=(INT)0;i S_V_LI(b)) ? S_SPA_GLI(a) : S_V_LI(b) ) ; for (i=1L;i <= S_V_LI(b); i++) inh[i] = S_V_II(b,i-1L); for (;i<=len;i++) inh[i]=(INT)0; /* AK 240593 */ SYM_free(hilf); SYM_free(hilf_zwei); rh_kostka(tab,um,ziel,inh,(INT)0,(INT)0,inh[1],1L, len,n,um[1]+S_PA_II(cp,m-1),c,a); freeall(cp); t_BINTREE_LIST(c,c); /* AK 170392 */ SYM_free(um); SYM_free(ziel); SYM_free(inh); SYM_free(tab); return(OK); } /* bricknumber */ static INT bco(); INT SYMMETRICA_bricknumber(umriss,cont,res) /* brick tabloids linke in remmel egecioglu: disc appl math 34 (1991) 107-120 */ /* AK 120901 */ OP umriss,cont,res; { INT erg = OK,i,j=0; /* rekursion per zeile */ /* der cont muss sortiert sein */ OP ni,bb; CE3(umriss,cont,res,SYMMETRICA_bricknumber); if (S_O_K(umriss) == PARTITION) umriss = S_PA_S(umriss); if (S_O_K(cont) == PARTITION) { cont = S_PA_S(cont); ni = cont; } else { j=1; ni = callocobject(); erg += copy_integervector(cont,ni); erg += sort_vector(ni); /* ansteigend */ } if (umriss == cont) { j=1; ni = callocobject(); erg += copy_integervector(umriss,ni); erg += sort_vector(ni); /* ansteigend */ } erg += m_i_i(0,res); bb = callocobject(); erg += m_il_nv(S_V_LI(umriss),bb); for (i=0;i= S_V_LI(umriss)) { /* end of recursion */ erg += inc(res); goto endr_ende; } if (S_V_II(umriss,zeile) == 0) { /* es kann an die naechste zeile gegangen werden, das ergebnis von dort muss mit dem pasenden multimomial coeff multipliziert werden */ OP newres = callocobject(); OP mn = callocobject(); erg += m_i_i(0,newres); /* in bb[zeile] ist die besetzung der unteren zeile nun multinomial coeff berechnen fuer die multiplikation */ for (i=0;i 1) { if (S_I_I(newres) < 13) { erg += multinom_small(newres,S_V_I(bb,zeile),mn); tt=1; } else erg += multinom(newres,S_V_I(bb,zeile),mn); } else m_i_i(1,mn); /* in mn ist nun der multinomial koeff */ erg += m_i_i(0,newres); erg += bco(0,zeile+1,umriss,cont,newres,bb); /* nun noch multiplizieren */ if (tt==1) { if (S_I_I(mn) > 1) erg += mult_apply_integer(mn,newres); } else erg += mult_apply(mn,newres); erg += add_apply(newres,res); freeall(newres); freeall(mn); goto endr_ende; } /* die unterste zeile ist noch nicht gefuellt */ /* da ansteigend gefuellt wird, muss abspalte im cont gesucht werden ob weitere eintraege moeglich */ for (i=spalte;i0) && (S_V_II(cont,i) == S_V_II(cont,i-1))) continue; else if (S_V_II(cont,i) > 0) { if (S_V_II(cont,i) <= S_V_II(umriss,zeile)) { temp = S_V_II(cont,i); M_I_I(0,S_V_I(cont,i)); m_i_i( s_v_ii(umriss,zeile)-temp,s_v_i(umriss,zeile)); INC_INTEGER(S_V_I(S_V_I(bb,zeile),temp-1)); erg += bco(i+1,zeile,umriss,cont,res,bb); DEC_INTEGER(S_V_I(S_V_I(bb,zeile),temp-1)); M_I_I(temp,S_V_I(cont,i)); M_I_I( S_V_II(umriss,zeile)+temp,S_V_I(umriss,zeile)); } else goto endr_ende; /* wenn schon das trum an der stelle i nicht rein passt, dann auch keine die spaeter kommen, da ja der cont ansteigend sortiert ist */ } } ENDR("internal bricknumber routine"); } /* to compute the transition matrices */ static INT newindexofpart_co11(a,b) OP a,b; /* AK 030102 */ { INT h; if (S_PA_HASH(a) == -1) C_PA_HASH(a,hash_partition(a)); h = S_PA_HASH(a) % S_V_LI(b); if (h < 0) h += S_V_LI(b); return (S_V_II(b,h)); } static INT newtafel(a,b,tf) OP a,b; INT (*tf)(); /* AK 030102 */ { INT erg = OK,i,j; INT f = 2; OP c,h1,h2; CTO(INTEGER,"newtafel(1)",a); c = CALLOCOBJECT(); h2 = CALLOCOBJECT(); erg += makevectorofpart(a,c); again: init_size_hashtable(h2,S_V_LI(c)*f); C_O_K(h2,INTEGERVECTOR); for (i=0;irow_length) { fprintf(stdout,"\n"); zeilenposition = 0L; } } } else while (zeiger != NULL) { if (not LISTP(zeiger)) { erg += WTO("fprint_list:internal",zeiger); goto fple; } erg += fprint(f,S_L_S(zeiger)); fprintf(f," "); if (f == stdout) { zeilenposition += 2L; if (zeilenposition >row_length) { fprintf(stdout,"\n"); zeilenposition = 0L; } } zeiger=S_L_N(zeiger); } fple: ENDR("fprint_list"); } #endif /* LISTTRUE */ INT insert_list(von,nach,eh,cf) OP von,nach; INT (*eh)(), (*cf)(); /* fuegt das object von in die liste nach ein AK 220688 */ /* AK 030789 V1.0 */ /* AK 201289 V1.1 */ /* AK 060891 V1.3 */ /* moegliche faelle: a)zwei listen b)von ist ein scalar und kann in das entsprechende list object umgewandelt werden c)a ist hashtable und die objecte werden eingefuegt d)a ist monom und wird in das entsprechende LIST object umgewandelt */ { OP c; INT erg = OK; if (LISTP(von)) /* fall a */ { erg += insert_list_list(von,nach,eh,cf); goto endr_ende; } if (S_O_K(von) == HASHTABLE) { /* fall c */ if (S_O_K(nach) == MONOMIAL) { erg += t_HASHTABLE_MONOMIAL(von,von); insert_list_list(von,nach,eh,cf); goto endr_ende; } if (S_O_K(nach) == SCHUR) { erg += t_HASHTABLE_SCHUR(von,von); insert_list_list(von,nach,eh,cf); goto endr_ende; } if (S_O_K(nach) == HOMSYM) { erg += t_HASHTABLE_HOMSYM(von,von); insert_list_list(von,nach,eh,cf); goto endr_ende; } if (S_O_K(nach) == POWSYM) { erg += t_HASHTABLE_POWSYM(von,von); insert_list_list(von,nach,eh,cf); goto endr_ende; } if (S_O_K(nach) == ELMSYM) { erg += t_HASHTABLE_ELMSYM(von,von); insert_list_list(von,nach,eh,cf); goto endr_ende; } FORALL(c,von, { OP f; f = CALLOCOBJECT(); erg += swap(c,f); insert_list(f,nach,eh , cf); }); erg += freeall(von); goto endr_ende; } if (S_O_K(nach) == POLYNOM) { if (scalarp(von)) { c = CALLOCOBJECT(); erg += b_skn_po(CALLOCOBJECT(),von,NULL,c); erg += m_il_v(1L,S_PO_S(c)); erg += m_i_i(0L,S_PO_SI(c,0L)); } else if (S_O_K(von) == MONOM) { CTTTTO(INTEGERMATRIX,MATRIX, INTEGERVECTOR,VECTOR,"insert_list(1-monom-self)",S_MO_S(von)); c = CALLOCOBJECT(); erg += b_sn_l(von,NULL,c); C_O_K(c,POLYNOM); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } #ifdef SCHURTRUE else if (S_O_K(nach) == SCHUR) { if (scalarp(von)) { c = CALLOCOBJECT(); erg += b_scalar_schur(von,c); } else if (S_O_K(von) == MONOM) { CTO(PARTITION,"insert_list",S_MO_S(von)); c = CALLOCOBJECT(); erg += b_sn_s(von,NULL,c); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } else if (S_O_K(nach) == HOMSYM) { if (S_O_K(von) == MONOM) { CTO(PARTITION,"insert_list",S_MO_S(von)); c = CALLOCOBJECT(); erg += b_sn_h(von,NULL,c); } else if (scalarp(von)) { c = CALLOCOBJECT(); erg += b_scalar_homsym(von,c); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } else if (S_O_K(nach) == MONOMIAL) { if (S_O_K(von) == MONOM) { CTO(PARTITION,"insert_list",S_MO_S(von)); c = CALLOCOBJECT(); erg += b_sn_mon(von,NULL,c); } else if (scalarp(von)) { c = CALLOCOBJECT(); erg += b_scalar_monomial(von,c); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } else if (S_O_K(nach) == ELMSYM) { if (S_O_K(von) == MONOM) { CTO(PARTITION,"insert_list",S_MO_S(von)); c = CALLOCOBJECT(); erg += b_sn_e(von,NULL,c); } else if (scalarp(von)) { c = CALLOCOBJECT(); erg += b_scalar_elmsym(von,c); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } else if (S_O_K(nach) == POWSYM) { if (scalarp(von)) { c = CALLOCOBJECT(); erg += b_scalar_powsym(von,c); } else if (S_O_K(von) == MONOM) { CTO(PARTITION,"insert_list",S_MO_S(von)); c = CALLOCOBJECT(); erg += b_sn_ps(von,NULL,c); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } #endif /* SCHURTRUE */ #ifdef SCHUBERTTRUE else if (S_O_K(nach) == SCHUBERT) { if (scalarp(von)) { c = CALLOCOBJECT(); erg += b_skn_sch(CALLOCOBJECT(),von,NULL,c); erg += m_ks_p(VECTOR,CALLOCOBJECT(),S_SCH_S(c)); erg += m_il_v(1L,S_SCH_S(c)); erg += m_i_i(1L,S_SCH_SI(c,0L)); } else if (S_O_K(von) == MONOM) { CTO(PERMUTATION,"insert_list",S_MO_S(von)); c = CALLOCOBJECT(); erg += b_sn_l(von,NULL,c); C_O_K(c,SCHUBERT); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } #endif /* SCHUBERTTRUE */ else if (S_O_K(nach) == MONOPOLY) { if (S_O_K(von) == MONOM) { c = CALLOCOBJECT(); erg += b_sn_l(von,NULL,c); C_O_K(c,MONOPOLY); } else { erg += WTT("insert_list(1,2)",von,nach); goto endr_ende; } } else { c = CALLOCOBJECT(); erg += b_sn_l(von,NULL,c); } erg += insert_list_list(c,nach,eh,cf); ENDR("insert_list"); } #ifdef LISTTRUE INT copy_list(von,nach) OP von, nach; /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 060891 V1.3 */ { OBJECTSELF d; /* AK 141091 */ d= S_O_S(von); if (d.ob_list == NULL) return error("copy_list:sos = NULL"); return transformlist(von,nach,copy); } INT lastp_list(list) OP list; /* AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 060891 V1.3 */ { return(S_L_N(list) == NULL); /* das letzte element falls das naechste==NULL */ } static struct list * calloc_list() /* AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 060891 V1.3 */ { /* struct list *a = (struct list *) SYM_MALLOC(sizeof(struct list)); mem_counter_list++; return a; */ struct list *ergebnis; mem_counter_list++; if (list_speicherindex >= 0) /* AK 301001 */ return list_speicher[list_speicherindex--]; ergebnis = (struct list *) SYM_malloc( sizeof(struct list)); if (ergebnis == NULL) no_memory(); return ergebnis; } static INT free_list(a) struct list *a; /* AK 300197 */ { INT erg = OK; COP("free_list(1)",a); /* mem_counter_list--; erg += SYM_free(a); */ if (list_speicherindex+1 == list_speichersize) { if (list_speichersize == 0) { list_speicher = (struct list **) SYM_malloc(100 * sizeof(struct list *)); if (list_speicher == NULL) { erg += error("no memory"); goto endr_ende; } list_speichersize = 100; } else { list_speicher = (struct list **) SYM_realloc (list_speicher, 2 * list_speichersize * sizeof(struct list *)); if (list_speicher == NULL) { erg += error("no memory"); goto endr_ende; } list_speichersize = 2 * list_speichersize; } } mem_counter_list--; list_speicher[++list_speicherindex] = a; ENDR("free_list"); } INT m_sn_l(self,nx,a) OP self,nx,a; /* AK 290590 V1.1 */ /* AK 050891 V1.3 */ { OP s = NULL,n = NULL; INT erg = OK; COP("m_sn_l(3)",a); if (self != NULL) { s = CALLOCOBJECT(); erg += copy(self,s); } if (nx != NULL) { n = CALLOCOBJECT(); erg += copy(nx,n); } erg += b_sn_l(s,n,a); ENDR("m_sn_l"); } INT b_sn_l(self,nx,a) OP self,nx,a; /* build_self next_list AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 050891 V1.3 */ { INT erg =OK; OBJECTSELF d; COP("b_sn_l",a); d.ob_list = calloc_list(); erg += b_ks_o(LIST,d,a); C_L_S(a,self); C_L_N(a,nx); ENDR("b_sn_l"); } INT b_sn_e(self,nx,a) OP self,nx,a; /* build_self next_elmsym AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 050891 V1.3 */ { INT erg =OK; OBJECTSELF d; COP("b_sn_e",a); d.ob_list = calloc_list(); erg += b_ks_o(ELMSYM,d,a); C_L_S(a,self); C_L_N(a,nx); ENDR("b_sn_e"); } INT b_sn_s(self,nx,a) OP self,nx,a; /* build_self next_schur AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 050891 V1.3 */ { INT erg =OK; OBJECTSELF d; COP("b_sn_s",a); d.ob_list = calloc_list(); erg += b_ks_o(SCHUR,d,a); C_L_S(a,self); C_L_N(a,nx); ENDR("b_sn_s"); } INT b_sn_ps(self,nx,a) OP self,nx,a; /* build_self next_powsym AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 050891 V1.3 */ { INT erg =OK; OBJECTSELF d; COP("b_sn_ps",a); d.ob_list = calloc_list(); erg += b_ks_o(POWSYM,d,a); C_L_S(a,self); C_L_N(a,nx); ENDR("b_sn_ps"); } INT b_sn_h(self,nx,a) OP self,nx,a; /* build_self next_homsym AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 050891 V1.3 */ { INT erg =OK; OBJECTSELF d; COP("b_sn_h",a); d.ob_list = calloc_list(); erg += b_ks_o(HOMSYM,d,a); C_L_S(a,self); C_L_N(a,nx); ENDR("b_sn_h"); } INT b_sn_mon(self,nx,a) OP self,nx,a; /* build_self next_monomial AK 210688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 050891 V1.3 */ { INT erg =OK; OBJECTSELF d; COP("b_sn_mon",a); d.ob_list = calloc_list(); erg += b_ks_o(MONOMIAL,d,a); C_L_S(a,self); C_L_N(a,nx); ENDR("b_sn_mon"); } INT b_sn_po(self,nx,a) OP self,nx,a; /* build_self next_polynom AK 230703 */ { INT erg =OK; OBJECTSELF d; COP("b_sn_po",a); d.ob_list = calloc_list(); erg += b_ks_o(POLYNOM,d,a); C_L_S(a,self); C_L_N(a,nx); ENDR("b_sn_po"); } INT hash_list(list) OP list; /* AK 170304 */ { INT erg = 1257; OP z; FORALL(z,list, { erg = erg * 1257 + hash(S_MO_S(z))*hash(S_MO_K(z)); } ); return erg; } INT length_list(list,res) OP list,res; /* AK 220688 */ /* AK 290689 V1.0 */ /* AK 281289 V1.1 */ /* AK 060891 V1.3 */ { OP zeiger = list; INT erg = OK; CTO(EMPTY,"length_list",res); M_I_I(0L,res); if (empty_listp(list)) goto endr_ende; while (zeiger != NULL) /* abbruch bedingung */ { INC_INTEGER(res); zeiger = S_L_N(zeiger); } ENDR("length_list"); } INT filter_list(a,b,tf) OP a,b; INT (*tf)(); /* AK 020394 */ { OP z,zb=b; INT erg = OK, f = 0; COP("filter_list(3)",tf); z = a; while (z != NULL) { if ((*tf)(S_L_S(z)) == TRUE) { if (f == 0) { erg += b_sn_l(CALLOCOBJECT(),NULL,b); C_O_K(b,S_O_K(a)); erg += copy(S_L_S(z),S_L_S(b)); f = 1; } else { C_L_N(zb,CALLOCOBJECT()); erg += b_sn_l(CALLOCOBJECT(),NULL,S_L_N(zb)); erg += copy(S_L_S(z),S_L_S(S_L_N(zb))); zb = S_L_N(zb); C_O_K(zb,S_O_K(a)); } } z = S_L_N(z); } ENDR("filter_list"); } INT transform_apply_list(von,tf) OP von; INT (*tf)(); /* AK 201289 V1.1 */ /* AK 060891 V1.3 */ /* AK 210498 V2.0 */ { OP zeiger = von; INT erg = OK; COP("transform_apply_list(2)",tf); while (zeiger != NULL) { erg += (*tf)(S_L_S(zeiger)); zeiger = S_L_N(zeiger); } ENDR("transform_apply_list"); } INT transformlist(von,nach,tf) OP von, nach;INT (*tf)(); /* AK 270688 */ /* AK 030789 V1.0 */ /* AK 010890 V1.1 */ /* AK 060891 V1.3 */ /* AK 210498 V2.0 */ { OP zeiger = von; OP nachzeiger = nach; OBJECTSELF d; INT erg = OK; /* AK 100893 */ COP("transformlist(3)",tf); if (not EMPTYP(nach)) erg += freeself(nach); while (zeiger != NULL) { d= S_O_S(zeiger); if (d.ob_list == NULL) return error("transformlist:sos = NULL"); if (S_L_S(zeiger) != NULL) { erg += b_sn_l(CALLOCOBJECT(),NULL,nachzeiger); /* AK 100789 b_sn_l() statt init() */ C_O_K(nachzeiger,S_O_K(zeiger)); /* AK 107089 fuer faelle wie polynom etc */ erg += (*tf)(S_L_S(zeiger),S_L_S(nachzeiger)); } else { erg += b_sn_l(NULL,NULL,nachzeiger); C_O_K(nachzeiger,S_O_K(zeiger)); } if (not lastp(zeiger)) C_L_N(nachzeiger,CALLOCOBJECT()); zeiger = S_L_N(zeiger); nachzeiger = S_L_N(nachzeiger); } ENDR("transformlist"); } INT trans2formlist(ve,vz,nach,tf) OP ve,vz,nach; INT (*tf)(); /* AK 270688 *//* ve ist konstante , vz ist liste */ /* AK 030789 V1.0 */ /* AK 211289 V1.1 */ /* AK 060891 V1.3 */ { OP zeiger = vz; OP nachzeiger = nach; INT erg = OK; COP("trans2formlist(4)",tf); while (zeiger != NULL) { erg += b_sn_l(CALLOCOBJECT(),NULL,nachzeiger); C_O_K(nachzeiger,S_O_K(vz)); erg += (*tf)(ve,S_L_S(zeiger),S_L_S(nachzeiger)); if (not lastp(zeiger)) { C_L_N(nachzeiger,CALLOCOBJECT()); nachzeiger = S_L_N(nachzeiger); } zeiger = S_L_N(zeiger); } ENDR("transformlist"); } #endif /* LISTTRUE */ INT comp_list(a,b) OP a,b; { if ((S_L_S(b) == NULL) && (S_L_S(a) == NULL)) return 0; else if (S_L_S(a) == NULL) return -1; else if (S_L_S(b) == NULL) return 1; else return comp_list_co(a,b,comp); } INT comp_list_co(a,b,cf) OP a,b; INT (*cf)(); /* vergleich zweier listen, z.b. 1,1,3 < 1,2,2 z.b. 2,2,3 > 2/3 AK 140788 */ /* AK 030789 V1.0 */ /* AK 010890 V1.1 */ /* AK 060891 V1.3 */ /* self parts are non null */ { INT erg; SYMCHECK(S_L_S(a) == NULL,"comp_list_co:self(1) == NULL"); SYMCHECK(S_L_S(b) == NULL,"comp_list_co:self(2) == NULL"); cla: erg=(*cf)(S_L_S(a),S_L_S(b)); if (erg == 0L) /* gleicher listenanfang */ { if ((S_L_N(a) == NULL)&&(S_L_N(b) == NULL)) return(0L); /* gleich */ else if (S_L_N(a) == NULL) return(-1L); /* a < b */ else if (S_L_N(b) == NULL) return(1L); /* a > b */ else { a = S_L_N(a); b = S_L_N(b); goto cla; } /* rest ist wieder liste */ } else return(erg); ENDR("comp_list_co"); } #ifdef LISTTRUE OP s_l_s(a) OP a; /* AK 010890 V1.1 */ /* AK 060891 V1.3 */ { OBJECTSELF c; if (a == NULL) return error("s_l_s: a == NULL"),(OP)NULL; if (not listp(a)) return error("s_l_s: a not list"),(OP)NULL; c = s_o_s(a); return(c.ob_list->l_self); } OP s_l_n(a) OP a; /* AK 010890 V1.1 */ /* AK 060891 V1.3 */ { OBJECTSELF c; if (a == NULL) return error("s_l_n: a == NULL"),(OP)NULL; if (not listp(a)) return error("s_l_n: a not list"),(OP)NULL; c = s_o_s(a); return(c.ob_list->l_next); } INT c_l_n(a,b) OP a,b; /* AK 010890 V1.1 */ /* AK 060891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_list->l_next = b; return(OK); } INT c_l_s(a,b) OP a,b; /* AK 010890 V1.1 */ /* AK 060891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_list->l_self = b; return(OK); } INT freeself_list(obj) OP obj; /* AK 290689 V1.0 */ /* AK 211189 V1.1 */ /* AK 170591 V1.2 */ /* AK 060891 V1.3 */ { INT erg = OK; OP z = obj,za=NULL; z = S_L_N(obj); while (z != NULL) { za = z; z = S_L_N(z); C_L_N(za,NULL); if (S_L_S(za) != NULL) FREEALL(S_L_S(za)); erg += free_list(S_O_S(za).ob_list); C_O_K(za,EMPTY); FREEALL(za); } if (S_L_S(obj) != NULL) FREEALL(S_L_S(obj)); erg += free_list(S_O_S(obj).ob_list); C_O_K(obj,EMPTY); ENDR("freeself_list"); } INT scan_list(a,givenkind) OP a; OBJECTKIND givenkind; /* genaue art der liste */ /* AK 210688 */ /* AK 030789 V1.0 */ /* AK 010890 V1.1 */ /* AK 060891 V1.3 */ { char antwort[2]; INT erg; /* a ist ein leeres object */ b_sn_l(callocobject(),NULL,a); /* self ist nun initialisiert */ if (givenkind == (OBJECTKIND)0) { /* a ----> kind: LIST self: --| | V |-------------| | self : OP | | next : NULL | |-------------| */ printeingabe("please enter kind of list element"); givenkind = scanobjectkind(); /* nun weiss man das */ } erg=scan(givenkind,S_L_S(a)); if (erg == ERROR) { error("scan_list:error in scaning listelement"); goto endr_ende; } printeingabe("one more listelement y/n"); skip_comment(); /* AK 210395 */ scanf("%s",antwort); if (antwort[0] == 'y') { C_L_N(a,callocobject()); erg += scan_list(S_L_N(a),givenkind); }; ENDR("scan_list"); } #endif /* LISTTRUE */ #ifdef VECTORTRUE #ifdef LISTTRUE INT t_LIST_VECTOR(a,b) OP a,b; /* AK 090889 wandelt eine Liste in einen Vektor um */ /* die daten werden dabei kopiert */ /* AK 090889 V1.1 */ /* AK 060891 V1.3 */ { INT i; INT erg = OK; OP l; if (not LISTP(a)) WTO("t_LIST_VECTOR",a); CE2(a,b,t_LIST_VECTOR); l = callocobject(); erg += length(a,l); erg += b_l_v(l,b); for(i=0L;i0L){ C_L_N(p,nn); nn = S_L_N(nn); p = S_L_N(p); } else { if (eh == NULL); else if (eh == add_koeff) /* AK 011101 */ { ADD_KOEFF(S_L_S(von),S_L_S(nn)); } else (*eh)(S_L_S(von),S_L_S(nn)); if (not EMPTYP(S_L_S(nn))) { /* eh hat nicht geloescht */ C_L_N(p,nn); p = S_L_N(p); nn = S_L_N(nn); } else { FREEALL(S_L_S(nn)); altnext=S_L_N(nn); C_L_N(nn,NULL); /* AK 300197 */ C_L_S(nn,NULL); /* AK 300197 */ FREEALL(nn); /* AK 300197 */ nn = altnext; } FREEALL(S_L_S(von)); altnext=S_L_N(von); C_L_N(von,NULL); /* AK 300197 */ C_L_S(von,NULL); /* AK 300197 */ FREEALL(von); /* AK 300197 */ von = altnext; } } C_L_N(p,NULL); if (von == NULL) von = nn; if (von != NULL) C_L_N(p,von); if (S_L_N(&dummy) == NULL) { C_O_K(nach,EMPTY); init (kind,nach); } else { *nach = *(S_L_N(&dummy)); C_O_K(S_L_N(&dummy),EMPTY); FREEALL(S_L_N(&dummy)); } ende: ENDR("insert_list_list"); } #ifdef LISTTRUE INT objectwrite_list(f,a) FILE *f; OP a; /* AK 210690 V1.1 */ /* AK 100591 V1.2 */ /* AK 060891 V1.3 */ { fprintf(f,"%ld ", (INT)S_O_K(a)); if (S_L_S(a) == NULL) /* 100591 */ fprintf(f,"%ld\n",0L); else { fprintf(f,"%ld\n",1L); objectwrite(f,S_L_S(a)); } if (S_L_N(a) == NULL) { fprintf(f,"%ld\n",0L); return OK; } else { fprintf(f,"%ld\n",1L); return objectwrite(f,S_L_N(a)); } } INT objectread_list(f,a) FILE *f; OP a; /* AK 210690 V1.1 */ /* AK 100591 V1.2 */ /* AK 060891 V1.3 */ { INT i; fscanf(f,"%ld",&i); if (i == 0L) b_sn_l(NULL,NULL,a); else if (i == 1L) { b_sn_l(callocobject(),NULL,a); objectread(f,S_L_S(a)); } else return error("objectread_list: wrong format (1) "); fscanf(f,"%ld",&i); if (i == 0L) return OK; else if (i == 1L) { C_L_N(a,callocobject()); return objectread(f,S_L_N(a)); } else return error("objectread_list: wrong format (2) "); } INT filter_apply_list(a,tf) OP a; INT (*tf)(); /* AK 020394 */ /* if tf return true the elements stays in the list */ /* error beseitigt am 110397 */ /* tf takes a list element as input */ { OP z,zb,vorg=NULL; INT erg = OK; OBJECTKIND typ = S_O_K(a); z = a; if (S_L_S(a) == NULL) goto endr_ende; while (z != NULL) { if ((*tf)(S_L_S(z)) == TRUE) /* stays inside the list */ { if (vorg != NULL) C_L_N(vorg,z); zb = z; z = S_L_N(z); C_L_N(zb,NULL); if (vorg == NULL) { if (a != zb) { *a = *zb; C_O_K(zb,EMPTY); FREEALL(zb); } vorg = a; } else vorg = zb; } else /* remove from the list */ { zb = z; z = S_L_N(z); C_L_N(zb,NULL); if (zb != a) FREEALL(zb); else FREESELF(zb); } } /* end while z!=NULL */ if (vorg == NULL) erg += init(typ,a); ENDR("filter_apply_list"); } #endif /* LISTTRUE */ symmetrica-2.0/list.doc0000600017361200001450000001441610726170275015054 0ustar tabbottcrontabCOMMENT: LIST This is a fundamental datatype of SYMMETRICA. A LIST object consists of two parts, the entry of the list, which is called the self-part, and the next-part of the list, which is again a LIST object. If the next-part is NULL, we are at the end of the list. To select parts of a LIST object we have standard macros and routines: NAME MACRO description ---------------------------------------------------------------- s_l_s S_L_S select_list_self c_l_s C_L_S change_list_self s_l_n S_L_N select_list_next c_l_n C_L_N change_list_next For the construction of a LIST object there are m_sn_l and b_sn_l, whose description follows. NAME: b_sn_l SYNOPSIS: INT b_sn_l(OP self,next,result) DESCRIPTION: constructs a new LIST object using build (using the parameters as partsof the result). If the parameters are NULL than there is no difference between b_sn_l and m_sn_l. First it frees the memory of result, if result is not the empty object. RETURN: ERROR if no space for the new LIST object. NAME: m_sn_l SYNOPSIS: INT m_sn_l(OP self,next,result) DESCRIPTION: constructs a new LIST object using make (using copies of the parameters). If the parameters are NULL than there is no difference between b_sn_l and m_sn_l. First it frees the memory of result, if result is not the empty object. RETURN: ERROR if no space for the new LIST object. OK else. COMMENT: Using the standard initialisation init(LIST,newobject) we produce an empty list, this means self==NULL and next==NULL. For a check whether we have an empty list or not there is a boolean function NAME: empty_listp SYNOPSIS: INT empty_listp (OP list) DESCRIPTION: test whether we have a empty list RETURN: FALSE if not a LIST type object. FALSE if not a empty list (self != NULL) TRUE if a empty list COMMENT: If you have a list, the fundamental operation is insertion into the list. So there are two steps, first the generation of a empty LIST object, and then the insertion into a list. For the first step you simply call the standard routine init(); Look: . . . OP l = callocobject(); init(LIST,l); println(l); . . This prints the message empty list on the terminal. The typical operation is the insertion of a new object into a list. This is done using the routine insert NAME: insert_list SYNOPSIS: INT insert_list(OP element, list INT (* eqhandle)(), (* compfunction)() ) DESCRIPTION: inserts the element into the LIST object list. The second parameter list must be a LIST object. There is no test, whether it is a LIST object. This routine is called by the general routine insert(), which has the same syntax. compfunction is the function for the comparision of the element to insert and the objects, which are already in the list. The list is assumed to be ordered in increasing order. The compfunction is called with two arguments, the element and s_l_s(actual position). The return value is <0 , 0 , >0 like the standard routine comp(). The function eqhandle is called when the element is already in the list. (i.e. comparsion gives 0) It is called with two arguments the element and s_l_s(actual position). If after the call of eqhandle the entry in the list is the empty object, it means that the entry was deleted, this entry is removed from the list. (e.g. cancellation in a polynomial) In the case the first parameter element is a LIST object this routine is a merge of two lists. In general it is not good to delete an element which was inserted into list, because this destroys the list, since it generates a hole in the list. If you call insert with NULL for the two functionpointer, you use the standard comparsion comp(), and no insertion in the case of comp()=0 NAME: lastp_list SYNOPSIS: INT lastp_list(OP l) DESCRIPTION: true if next == NULL a test whether we are at the end of a list NAME: test_list SYNOPSIS: INT test_list() DESCRIPTION: for checking of the installation NAME: t_BINTREE_LIST SYNOPSIS: INT t_BINTREE_LIST(OP bintree, OP list) DESCRIPTION: to transform a BINTREE object into a LIST object NAME: t_LIST_VECTOR SYNOPSIS: INT t_LIST_VECTOR(OP list,OP vector) DESCRIPTION: builds a VECTOR whose entries are copies of the entries of the LIST object. The ordering is preserved of course there is also the invers routine t_VECTOR_LIST, which is documented in the file vc.doc NAME: filter_list SYNOPSIS: INT filter_list(OP oldlist, OP newlist; INT (*cf)()) DESCRIPTION: the routine loops over the LIST object oldlist, and for every self part of the list it calls the function cf, whose single parameter is the self part. If this user provided functions return TRUE the self part becomes a member of the newly build LIST object newlist. If their is no part in the new list the result is a empty object EXAMPLE: INT co_22(a) OP a; { if (S_T_IJI(a,(INT)0,(INT)1) == (INT)2) return TRUE; return FALSE; } .... scan(PARTITION,a); scan(PARTITION,b); kostka_tab(a,b,c); filter_list(c,d,co_22); ... So you have a routine which does the check on the list elements, so the reult is a list of TABLEAUX objects where the entry 2 is on the first row. NAME: filter_list_apply SYNOPSIS: INT filter_list_apply(OP list; INT (*cf)()) DESCRIPTION: the routine loops over the LIST object list, and cuts entries according to the same rules as the routine filter_list does. The only difference is, that the actual LIST object is changed. COMMENT: GENERAL ROUTINES ---------------- comp() lexicographic on entries copy() fprint() fprintln() freeall() freeself() length() length of list objectread() objectwrite() print() println() scan() tex() symmetrica-2.0/lo.c0000400017361200001450000033574110726021613014164 0ustar tabbottcrontab/* SYMMETRICA file:lo.c */ #include "def.h" #include "macro.h" #include /*strcat */ #define EXP 15 #define LO_B 32768 /* 1000000000000000*/ #define BMINUSEINS 32767 /* 111111111111111*/ #define LO_B1 (INT)2147450880/*111111111111111000000000000000*/ #define B2MINUSEINS (INT)2147483647 /*1000000000000000000000000000000 - 1*/ #define Basis 45 #define MSB 16384 #define MAXNEG (INT)(-2147483647-1) /*1000000000000000000000000000000 */ #ifdef LONGINTTRUE struct ganzdaten gd; /* a global datastructure */ static OP rl_o=NULL; /* obere grenze */ static OP rl_m=NULL; /* modulo */ static OP rl_x=NULL; /* ergebnis */ static OP rl_a=NULL; /* multiplier */ #endif INT mult_longint_integer_via_ganzsmul(); static struct longint * calloclongint(); static INT longint_speicher_ende(); static INT nofolgezeichen=0; INT set_lo_nopoint(para) INT para; { nofolgezeichen=para; } static INT ganzadd(); static INT ganzanfang(); static INT ganzaus(); static INT ganzdefiniere(); static INT ganzein(); static INT ganzeven(); static INT ganzfziffer(); /* static INT ganzganzdiv(); */ /* static INT ganzhalf(); */ static INT ganzint(); static INT ganzkopiere(); /* static INT ganzloesche(); */ /* static INT ganzmod(); */ static INT ganzmul(); /* static INT ganzneg(); */ static INT ganzodd(); static INT ganzparam(); static INT ganzquores(); /* static INT ganzsignum(); */ static INT ganzsadd(); static INT ganzsmul(); static INT ganzsquores(); static INT ganzvergleich(); static INT ganz1ziffer(); static INT intganz(); static INT locadd(); static INT locdiv(); static INT lochole(); static INT locint(); static INT loclisterette(); static INT locms1(); /* static INT locmul(); */ static INT locneg(); /* static INT locnull(); */ static INT locodd(); static INT locrette(); static INT locrezliste(); static INT locpsl(); static INT locpsr(); static INT locsadd(); static INT locsdiv(); /* static INT locsgn(); */ static INT locsmul(); static INT locssub(); static INT locsub(); static INT locvgl(); static INT retteziffer(); struct loc **loc_speicher = NULL; INT loc_index = -1; INT loc_size = 0; INT loc_counter = 0; INT mem_counter_loc=0; INT longint_speicherindex=-1; /* AK 301001 */ INT longint_speichersize=0; /* AK 301001 */ struct longint **longint_speicher=NULL; /* AK 301001 */ #define FREE_LONGINT(v)\ FREE_MEMMANAGER(struct longint *,longint_speicher,longint_speicherindex,\ longint_speichersize,mem_counter_loc,v) #ifdef UNDEF do {\ mem_counter_loc--;\ if (longint_speicherindex+1 == longint_speichersize) {\ if (longint_speichersize == 0) {\ longint_speicher = (struct longint **) \ SYM_MALLOC(100 * sizeof(struct longint *));\ SYMCHECK(longint_speicher == NULL,"no memory");\ longint_speichersize = 100;\ }\ else {\ longint_speicher = (struct longint **) SYM_realloc (longint_speicher,\ 2 * longint_speichersize * sizeof(struct longint *));\ SYMCHECK(longint_speicher == NULL,"no memory");\ longint_speichersize = 2 * longint_speichersize;\ }\ }\ longint_speicher[++longint_speicherindex] = v;\ } while(0) #endif /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ #ifdef LONGINTTRUE static INT locadd(lx,ly,cy) struct loc *lx,*ly; INT cy; /* AK 130789 V1.0 */ /* AK 270390 V1.1 */ /* AK 210891 V1.3 */ { static INT hh; hh=ly->w0+cy+lx->w0; lx->w0=(hh&BMINUSEINS); cy = hh >>EXP; hh=ly->w1+cy+lx->w1; lx->w1=(hh&BMINUSEINS); cy = hh >>EXP; hh=ly->w2+cy+lx->w2; lx->w2=(hh&BMINUSEINS); cy = hh >>EXP; return((INT)cy); } #endif /* LONGINTTRUE */ #define LOCADD(lx,ly,cy)\ hh=(ly)->w0+cy+(lx)->w0, (lx)->w0=(hh&BMINUSEINS), cy = hh >>EXP,\ hh=(ly)->w1+cy+(lx)->w1, (lx)->w1=(hh&BMINUSEINS), cy = hh >>EXP,\ hh=(ly)->w2+cy+(lx)->w2, (lx)->w2=(hh&BMINUSEINS), cy = hh >>EXP,cy #define LOCBAS2() Basis #define LOCASS(lx,ly) ((lx)->w2=(ly)->w2,(lx)->w1=(ly)->w1,(lx)->w0=(ly)->w0) #ifdef LONGINTTRUE static INT locdiv(qu,rest,dd,dv) struct loc *qu,*rest,*dd,*dv; /* Division. Bei Eingabe muss gelten: restw2; d5=rest->w1; d4=rest->w0; d3=dd->w2; d2=dd->w1; d1=dd->w0; /* h=dv */ h6=0; h5=0; h4=0; h3=dv->w2; h2=dv->w1; h1=dv->w0; /* qu=0 */ qu->w2=0; qu->w1=0; qu->w0=0; /* m=1 */ m2=0; m1=0; m0=1; while /* h<=d */ ( /* alt h6 =dv */ ( /* alt d6 >0 || d5>0 || d4>0 || (d6==0 && d5==0 && d4==0 && d3>dv->w2 ) || (d6==0 && d5==0 && d4==0 && d3==dv->w2 && d2>dv->w1 ) || (d6==0 && d5==0 && d4==0 && d3==dv->w2 && d2==dv->w1 && d1>dv->w0 ) || (d6==0 && d5==0 && d4==0 && d3==dv->w2 && d2==dv->w1 && d1==dv->w0 ) */ d6 >0 || d5>0 || d4>0 || ( d6==0 && d5==0 && d4==0 && ( d3>dv->w2 || (d3==dv->w2 && ( d2 > dv->w1 || (d2 ==dv->w1 && d1 >= dv->w0) ) ) ) ) ) { while /*h>d */ ( /* alt h6 >d6 || (h6==d6 && h5>d5) || (h6==d6 && h5==d5 && h4>d4) || (h6==d6 && h5==d5 && h4==d4 && h3>d3) || (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2>d2) || (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1>d1 ) */ h6 > d6 || (h6 == d6 && ( h5 > d5 || (h5 == d5 && ( h4 > d4 || (h4 == d4 && ( h3 > d3 || (h3 == d3 && ( h2 > d2 || (h2 == d2 && h1 > d1) ) )) )) )) ) ) { /* h=h/2 */ if (h6&1) { h6--; h5=h5|LO_B; }; if (h5&1) { h5--; h4=h4|LO_B; }; if (h4&1) { h4--; h3=h3|LO_B; }; if (h3&1) { h3--; h2=h2|LO_B; }; if (h2&1) { h2--; h1=h1|LO_B; }; /* alt h6=h6>>1; h5=h5>>1; h4=h4>>1; h3=h3>>1; h2=h2>>1; h1=h1>>1; */ h6 >>= 1; h5 >>= 1; h4 >>= 1; h3 >>= 1; h2 >>= 1; h1 >>= 1; /* m=m/2 */ if (m2&1) { m2--; m1|=LO_B; }; if (m1&1) { m1--; m0|=LO_B; }; /* alt m2=m2>>1; m1=m1>>1; m0=m0>>1; */ m2 >>= 1; m1 >>= 1; m0 >>= 1; } /* d=d-h */ if (h1>d1) { d1+=LO_B; d2--; }; d1-=h1; if (h2>d2) { d2+=LO_B; d3--; }; d2-=h2; if (h3>d3) { d3+=LO_B; d4--; }; d3-=h3; if (h4>d4) { d4+=LO_B; d5--; }; d4-=h4; if (h5>d5) { d5+=LO_B; d6--; }; d5-=h5; d6-=h6; /* qu=qu+m */ qu->w0|=m0; qu->w1|=m1; qu->w2|=m2; } rest->w2=d3; rest->w1=d2; rest->w0=d1; return(OK); } static INT locint(lx,i) struct loc *lx; INT i; /* Umwandlung Integer in loc: lx:=abs(i); locint:=sgn(i) */ /* AK 130789 V1.0 */ /* AK 150290 V1.1 */ /* AK 210891 V1.3 */ { INT s; if (i<(INT)0) { s=(INT)-1; i=0-i; } else if (i>(INT)0) s=(INT)1; else s=(INT)0; lx->w0 = i; lx->w0 &= BMINUSEINS; lx->w1 = i>>EXP; lx->w2 = lx->w1 >>EXP; lx->w1 &= BMINUSEINS; lx->w2 &= BMINUSEINS; return(s); } #define LOCMAX(lx) ((lx)->w0=BMINUSEINS,\ (lx)->w1=BMINUSEINS,(lx)->w2=BMINUSEINS) static INT locms1(lx) struct loc *lx; /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { INT j,c,cc; c=Basis; cc=(INT)1; for (j=(INT)14; (j >=(INT)0) && cc ; j--) { if ( lx->w2 & ( (INT)1 << j )) cc=(INT)0; c--; } if (cc) for (j=(INT)14; (j >=(INT)0) && cc ; j--) { if ( lx->w1 & ( (INT)1 << j )) cc=(INT)0; c--; } if (cc) for (j=(INT)14; (j >=(INT)0) && cc ; j--) { if ( lx->w0 & ( (INT)1 << j )) cc=(INT)0; c--; } if (cc) { fprintf(stderr,"cc=%ld %ld %ld %ld\n",cc,lx->w0,lx->w1,lx->w2); error("internal error:LO7"); } return(c); } #define teile(z) (hh=(z)>>EXP, (z) &= BMINUSEINS, hh) #ifdef UNDEF static INT locmul(ly,lx,la,lb) struct loc *lx,*ly,*la,*lb; /* AK 130789 V1.0 */ /* AK 260390 V1.1 */ /* AK 210891 V1.3 */ { static INT hh; /* AK 260390 */ lx->w0 = la->w0 * lb->w0; lx->w1 = teile(lx->w0) + la->w1 * lb->w0; lx->w2 = teile(lx->w1) + la->w2 * lb->w0; ly->w0 = teile(lx->w2) ; lx->w1 += la->w0 * lb->w1; lx->w2 += teile(lx->w1) + la->w1 * lb->w1; ly->w0 += teile(lx->w2) + la->w2 * lb->w1; ly->w1 = teile(ly->w0) ; lx->w2 += la->w0 * lb->w2; ly->w0 += teile(lx->w2) + la->w1 * lb->w2; ly->w1 += teile(ly->w0) + la->w2 * lb->w2; ly->w2 = teile(ly->w1) ; return OK; } #endif #define LOCMUL(ly,lx,la,lb) /* hh ist noetig */\ (lx)->w0 = (la)->w0 * (lb)->w0,\ (lx)->w1 = teile((lx)->w0) + (la)->w1 * (lb)->w0,\ (lx)->w2 = teile((lx)->w1) + (la)->w2 * (lb)->w0,\ (ly)->w0 = teile((lx)->w2) ,\ (lx)->w1 += (la)->w0 * (lb)->w1,\ (lx)->w2 += teile((lx)->w1) + (la)->w1 * (lb)->w1,\ (ly)->w0 += teile((lx)->w2) + (la)->w2 * (lb)->w1,\ (ly)->w1 = teile((ly)->w0) ,\ (lx)->w2 += (la)->w0 * (lb)->w2,\ (ly)->w0 += teile((lx)->w2) + (la)->w1 * (lb)->w2,\ (ly)->w1 += teile((ly)->w0) + (la)->w2 * (lb)->w2,\ (ly)->w2 = teile((ly)->w1) static INT locneg(lx,cy) struct loc *lx; INT cy; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { if ((cy==0)&&(lx->w0==0)&&(lx->w1==0)&&(lx->w2==0)) { return((INT)0); } else { lx->w0 ^= BMINUSEINS; lx->w1 ^= BMINUSEINS; lx->w2 ^= BMINUSEINS; if (cy == 0 ) { ++lx->w0; if (lx->w0 & LO_B) { ++lx->w1; lx->w0 &= BMINUSEINS; if (lx->w1 & LO_B) { ++lx->w2; lx->w1 &= BMINUSEINS; } } } return(1); } } /* locneg */ #ifdef UNDEF static INT locnull(lx) struct loc *lx; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { lx->w2 =(INT)0; lx->w1 =(INT)0; lx->w0 =(INT)0; return OK; } /* Ende von locnull */ #endif static INT locodd(lx) struct loc *lx; /*locodd:=lx ist ungerade */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { return (INT) (lx->w0 & 1); } INT bit_longint(a,i) OP a; INT i; /* AK 180902 */ /* return bit number i, i=0 lsb, */ { INT erg = OK; CTO(LONGINT,"bit_longint(1)",a); SYMCHECK(i<0,"bit_longint: neg index"); { struct loc *x; x = S_O_S(a).ob_longint->floc; again: if (x == NULL) return 0; if (i>=45) { x = x->nloc; i = i-45; goto again; } if (i>=30) { i = i -30; return (x->w2 >> i) & 1; } if (i>=15) { i = i -15; return (x->w1 >> i) & 1; } if (i>=0) { return (x->w0 >> i) & 1; } } ENDR("bit_longint"); } static INT locpsl(lx,ly,a) struct loc *lx,*ly; INT a; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT s1,s2,s3,s4,s5,i; static struct loc lyy; if (a >= 30) { lx->w2 = lx->w0; lx->w1 = ly->w2; lx->w0 = ly->w1; lyy.w2 = ly->w0; a = a - 30; } else if (a>=15) { lx->w2 = lx->w1; lx->w1 = lx->w0; lx->w0 = ly->w2; lyy.w2 = ly->w1; a = a - 15; } else { lyy.w2 = ly->w2; } /* lyy = *ly; */ if ( a >= Basis) error("internal error:LO8"); for (i=(INT)1; i <= a;i++) { s1= (lyy.w0 & MSB) >> 14; s2= (lyy.w1 & MSB) >> 14; s3= (lyy.w2 & MSB) >> 14; s4= (lx->w0 & MSB) >> 14; s5= (lx->w1 & MSB) >> 14; lyy.w0 <<= 1; lyy.w1 = (lyy.w1 << 1) | s1; lyy.w2 = (lyy.w2 << 1) | s2; lx->w0 = (lx->w0 << 1) | s3; lx->w1 = (lx->w1 << 1) | s4; lx->w2 = (lx->w2 << 1) | s5; } lx->w0 &= BMINUSEINS; lx->w1 &= BMINUSEINS; lx->w2 &= BMINUSEINS; return OK; } /* Ende von locpsl */ static INT locpsr(lx,ly,a) struct loc *lx,*ly; INT a; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT s1,s2,s3,s4,s5,i; static struct loc lxx; if (a >= 30) { ly->w0 = ly->w2; ly->w1 = lx->w0; ly->w2 = lx->w1; lxx.w0 = lx->w2; a = a -30; } else if (a >= 15) { ly->w0 = ly->w1; ly->w1 = ly->w2; ly->w2 = lx->w0; lxx.w0 = lx->w1; a = a -15; } else { lxx.w0 = lx->w0; } /* lxx = *lx; */ if ( a >= Basis) error("internal error:LO9"); for (i=(INT)1; i <= a;i++) { s1= (ly->w1 & 1) << 14; s2= (ly->w2 & 1) << 14; s3= (lxx.w0 & 1) << 14; s4= (lxx.w1 & 1) << 14; s5= (lxx.w2 & 1) << 14; ly->w0 = (ly->w0 >> 1) | s1; ly->w1 = (ly->w1 >> 1) | s2; ly->w2 = (ly->w2 >> 1) | s3; lxx.w0 = (lxx.w0 >> 1) | s4; lxx.w1 = (lxx.w1 >> 1) | s5; lxx.w2 = (lxx.w2 >> 1); } return OK; } /* Ende von locpsr */ static INT locsadd(lx,i) struct loc *lx; INT i; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT cy,hh; if (i<(INT)0) i=(-i); hh=lx->w0+(i%LO_B); lx->w0=(hh & BMINUSEINS); cy = hh >>EXP; hh=lx->w1+(i/LO_B)+cy; lx->w1=(hh & BMINUSEINS); cy = hh >>EXP; hh=lx->w2+cy; lx->w2=(hh & BMINUSEINS); cy = hh >>EXP; return(cy); } static INT locsdiv(qu,di,dd,dv) struct loc *qu,*dd; INT di,dv; /* Division. Bei Eingabe muss gelten: di>EXP; d6=(d5 & LO_B1)>>EXP; d5 &= BMINUSEINS; /* dv umwandeln */ if (dv<(INT)0) return error("internal error:LO11"); dv0=dv & BMINUSEINS; dv1=(dv & LO_B1)>>EXP; dv2=(dv1 & LO_B1)>>EXP; dv1 &= BMINUSEINS; /* d=di*B+dd */ d3=dd->w2; d2=dd->w1; d1=dd->w0; /* h=dv */ h6=0; h5=0; h4=0; h3=dv2; h2=dv1; h1=dv0; /* qu=0 */ qu->w2=0; qu->w1=0; qu->w0=0; /* m=1 */ m2=0; m1=0; m0=1; while /* h<=d */ ( /* alt h6 =dv */ ( /* alt d6 >0 || d5>0 || d4>0 || (d6==0 && d5==0 && d4==0 && d3>dv2 ) || (d6==0 && d5==0 && d4==0 && d3==dv2 && d2>dv1 ) || (d6==0 && d5==0 && d4==0 && d3==dv2 && d2==dv1 && d1>dv0 ) || (d6==0 && d5==0 && d4==0 && d3==dv2 && d2==dv1 && d1==dv0 ) */ d6 >0 || d5>0 || d4>0 || ( d6==0 && d5==0 && d4==0 && ( d3>dv2 || (d3==dv2 && ( d2 > dv1 || (d2 ==dv1 && d1 >= dv0) ) ) ) ) ) { while /* h>d */ ( /* alt h6 >d6 || (h6==d6 && h5>d5) || (h6==d6 && h5==d5 && h4>d4) || (h6==d6 && h5==d5 && h4==d4 && h3>d3) || (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2>d2) || (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1>d1 ) */ h6 > d6 || (h6 == d6 && ( h5 > d5 || (h5 == d5 && ( h4 > d4 || (h4 == d4 && ( h3 > d3 || (h3 == d3 && ( h2 > d2 || (h2 == d2 && h1 > d1) ) )) )) )) )) { /* h=h/2 */ if (h6&1) { h6--; h5|=LO_B; }; if (h5&1) { h5--; h4|=LO_B; }; if (h4&1) { h4--; h3|=LO_B; }; if (h3&1) { h3--; h2|=LO_B; }; if (h2&1) { h2--; h1|=LO_B; }; h6 >>= 1; h5 >>= 1; h4 >>= 1; h3 >>= 1; h2 >>= 1; h1 >>= 1; /* m=m/2 */ if (m2&1) { m2--; m1|=LO_B; }; if (m1&1) { m1--; m0|=LO_B; }; m2 >>= 1; m1 >>= 1; m0 >>= 1; } /* d=d-h */ if (h1>d1) { d1+=LO_B; d2--; }; d1-=h1; if (h2>d2) { d2+=LO_B; d3--; }; d2-=h2; if (h3>d3) { d3+=LO_B; d4--; }; d3-=h3; if (h4>d4) { d4+=LO_B; d5--; }; d4-=h4; if (h5>d5) { d5+=LO_B; d6--; }; d5-=h5; d6-=h6; /* qu=qu+m */ qu->w0|=m0; qu->w1|=m1; qu->w2|=m2; } d3=d3<w2 || lx->w1 || lx->w0 ) return (INT) 1; else return (INT) 0; } /* Ende locsgn */ #endif static INT locsmul(lx,i,ue) struct loc *lx; INT i,ue; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ /* AK 040398 V2.0 */ { INT cy,h0,h1,h2,i0,i1,i2,u0,u1,u2; if (i<0) {i=~i;++i;} if (ue<0) {ue=~ue;++ue;} i0 = i; i0 &= BMINUSEINS; i1 = (i>>15); i1 &= BMINUSEINS; i2 = (i>>30); i2 &= BMINUSEINS; u0 = ue; u0 &= BMINUSEINS; u1 = (ue>>15); u1 &= BMINUSEINS; u2 = (ue>>30); u2 &= BMINUSEINS; h0=(lx->w0)*i0; h0 += u0; cy = (h0 >> 15); h0 &= BMINUSEINS; h1 = (lx->w0)*i1; h1 += (lx->w1)*i0; h1 += cy; h1 += u1; cy = (h1 >> 15); h1 &= BMINUSEINS; h2 = (lx->w0)*i2; h2 += (lx->w1)*i1; h2 += (lx->w2)*i0; h2 += cy; h2 += u2; cy = (h2 >> 15); h2 &= BMINUSEINS; cy += (lx->w1)*i2; cy += (lx->w2)*i1; cy += (((lx->w2)*i2)<<15); lx->w0 = h0 ; lx->w1 = h1 ; lx->w2 = h2 ; return(cy); } static INT locssub(lx,i) struct loc *lx; INT i; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ /* AK 040398 V2.0 */ { INT cy; if (i<0) i=(-i); lx->w0 -= (i%LO_B); if (lx->w0 < 0) { lx->w0 += LO_B; cy = (INT)1; } else cy =(INT)0; lx->w1=lx->w1-((i/LO_B)%LO_B)-cy; if (lx->w1 < 0) { lx->w1 += LO_B; cy = (INT)1; } else cy =(INT)0; lx->w2=lx->w2-((i/LO_B)/LO_B) - cy; if (lx->w2 < 0) { lx->w2 += LO_B; cy = (INT)1; } else cy = (INT)0; return(cy); } static INT locsub(lx,ly,cy) struct loc *lx,*ly; INT cy; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ /* AK 040398 V2.0 */ { lx->w0=lx->w0- ly->w0 -cy; if (lx->w0 <(INT)0) { lx->w0 += LO_B; cy = (INT)1; } else cy =(INT)0; lx->w1=lx->w1- ly->w1- cy; if (lx->w1 <(INT)0) { lx->w1 += LO_B; cy = (INT)1; } else cy =(INT)0; lx->w2=lx->w2- ly->w2- cy; if (lx->w2 <(INT)0) { lx->w2 += LO_B; cy = (INT)1; } else cy =(INT)0; return(cy); } static INT locsub_cy; #define LOCSUB(lx,ly,cy) \ (lx->w0 -= ly->w0 , lx->w0 -= cy ,\ locsub_cy = (lx->w0 < 0 ? lx->w0 += LO_B, 1 : 0 ),\ lx->w1 -= ly->w1 , lx->w1 -= locsub_cy,\ locsub_cy = (lx->w1 < 0 ? lx->w1 += LO_B, 1 : 0 ),\ lx->w2 -= ly->w2 , lx->w2 -= locsub_cy,\ locsub_cy = (lx->w2 < 0 ? lx->w2 += LO_B, 1 : 0 )\ ) static INT locvgl(lx,ly) struct loc *lx,*ly; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ /* AK 040398 V2.0 */ { if (lx->w2 > ly->w2) return((INT)1); else if (lx->w2 < ly->w2 ) return (INT)-1; else if (lx->w1 > ly->w1) return((INT)1); else if (lx->w1 < ly->w1) return (INT)-1; else if (lx->w0 > ly->w0) return((INT)1); else if (lx->w0 < ly->w0) return (INT)-1; else return((INT)0); } /* Ende locvgl */ static INT ganzadd(x,y) struct longint *x,*y; /* AK: Fri Jan 13 07:24:17 MEZ 1989 */ /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ /* AK 040398 V2.0 */ { INT erg =OK; struct loc *alocx, *alocy, *lloc, *plocx, *plocy; INT cy,xl,ll; signed char xs,ys; INT hh; /* fuer LOCADD */ xs = x->signum; ys = y->signum; xl = x->laenge; if (((xs>=(signed char)0) && (ys>=(signed char)0)) || ((xs<(signed char)0) && (ys<(signed char)0))) { alocx = x->floc; alocy = y->floc; cy = 0; do { cy = LOCADD(alocx,alocy,cy); plocx = alocx; plocy = alocy; alocx = alocx->nloc; alocy = alocy->nloc; } while ((alocx != NULL) && (alocy != NULL)); /* fuege rest an */ if (alocy != NULL) { do { LOCHOLE(&alocx); plocx->nloc = alocx; xl++; cy = LOCADD(alocx,alocy,cy); plocx = alocx; alocx = NULL; plocy = alocy; alocy = alocy->nloc; } while (alocy != NULL); } else { while ((alocx != NULL) && (cy != 0)) { cy = locsadd(alocx,cy); plocx = alocx; alocx = alocx->nloc; } } /* noch ein cy? */ if (cy != 0) { LOCHOLE(&alocx); plocx->nloc = alocx; locint(alocx,cy); xl++; } if (xs == 0) xs = ys; } /* end of first if */ else { alocx = x->floc; alocy = y->floc; cy = 0; /* subtract y from x */ do { cy = LOCSUB(alocx,alocy,cy); plocx = alocx; alocx = alocx->nloc; plocy = alocy; alocy = alocy->nloc; } while ((alocx != NULL) && (alocy != NULL)); /* append the remaining part */ if (alocy != NULL) { do { LOCHOLE(&alocx); plocx->nloc = alocx; xl++; cy = LOCSUB(alocx,alocy,cy); plocx = alocx; alocx = NULL;plocy = alocy;alocy = alocy->nloc; } while (alocy != NULL); } else { while ((alocx != NULL) && (cy != 0)) { cy = locssub(alocx,cy); plocx = alocx; alocx = alocx->nloc; } }; /* normieren von x */ if (cy != 0) { alocx = x->floc; lloc = NULL; ll = 1; cy = 0; do { cy = locneg(alocx,cy); if (LOCSGN(alocx) != 0) { lloc = alocx; xl = ll; } alocx = alocx->nloc; ll++; } while (alocx != NULL); loclisterette(&(lloc->nloc)); xs = -xs; if (xs == 0) xs = -1; } else { alocx = x->floc; lloc = NULL; ll = 1; do { if (LOCSGN(alocx) != 0) { lloc = alocx; xl = ll; } alocx = alocx->nloc; ll++; } while (alocx != NULL); if (lloc == NULL) /* das ergebnis der addition ist null */ { loclisterette(&(x->floc->nloc)); xs = 0; xl =1; } else loclisterette(&(lloc->nloc)); } } x->laenge = xl; x->signum = xs; ENDR("ganzadd"); } static INT ganzsquores(x,rest,y) struct longint *x; INT *rest,y; /* AK Tue Jan 31 07:48:38 MEZ 1989 */ /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ /* AK 130789 V1.0 */ /* AK 200290 V1.1 */ /* AK 210891 V1.3 */ { struct loc *alocx, *blocx, *slocx; INT r; signed char sx,sy; sx = x->signum; if (y>(INT)0) sy=(signed char)1; else if (y<(INT)0) sy = (signed char)-1; else sy=(signed char)0; if (y<(INT)0) y = -y; blocx = x->floc; x->floc = NULL; locrezliste(&blocx); alocx = blocx; slocx = alocx->nloc; r=(INT)0; while (slocx != NULL) { r = locsdiv(alocx,r,alocx,y); alocx = slocx; slocx = alocx->nloc; } r = locsdiv(alocx,r,alocx,y); *rest = r * sx; if (LOCSGN(blocx) !=(INT)0) x->signum = sx*sy; else if (x->laenge == (INT)1) x->signum = (signed char)0; else { alocx = blocx; blocx = blocx->nloc; alocx->nloc = NULL; locrette(&alocx); x->laenge --; x->signum = sx*sy; }; locrezliste(&blocx); x->floc = blocx; return(OK); } #ifdef UNDEF static INT ganzhalf(x) struct longint *x; /* AK 021294 */ { struct loc *alocx, *plocx; INT erg = OK; alocx = x->floc; plocx = NULL; while (alocx != NULL) { alocx->w0 >>= 1; alocx->w0 |= ( (alocx->w1 & 1) << 14); alocx->w1 >>= 1; alocx->w1 |= ( (alocx->w2 & 1) << 14); alocx->w2 >>= 1; if (alocx->nloc != NULL) alocx->w2 |= ( (alocx->nloc->w0 & 1) << 14); if (alocx->nloc == NULL) { if (plocx != NULL) if ((alocx->w0 == 0) && (alocx->w1 == 0)&& (alocx->w2 == 0)) { FREE_LOC(alocx); plocx->nloc = NULL; x->laenge --; goto ende; } } plocx = alocx; alocx = alocx->nloc; } ende: ENDR("internal function:ganzhalf"); } #endif static INT ganzquores(x,rest,y) struct longint *x, *rest, *y; /* AK Mon Mar 13 10:58:11 MEZ 1989 */ /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ /* x = x/y rest = rest */ { INT vgl,cy,cyn,a,i,rl=(INT)0,ql; INT erg =OK; signed char sx,sy; struct loc *alocx, *plocx,*slocx,*blocx,*rlocx,*llocx, *alocy,*plocy,*blocy,*blocq, *locx2,*locx1,*locx0,*locy1,*locy0; struct loc null,q,r,ov,hi,lo; INT fertig; INT hh; /* fuer LOCMUL */ if ((x->floc == y->floc) || (x->floc == rest->floc) || (y->floc == rest->floc)) error("internal error:LO1"); loclisterette(&rest->floc); sx = x->signum; sy = y->signum; if (y->laenge == (INT)1) /* einfache divison */ { LOCNULL(&null); LOCASS(&lo,y->floc); blocx = x->floc; x->floc = NULL; locrezliste(&blocx); alocx = blocx; slocx = alocx->nloc; LOCASS(&r,&null); while (slocx != NULL) { locdiv(alocx,&r,alocx,&lo); alocx = slocx; slocx = slocx->nloc; } locdiv(alocx,&r,alocx,&lo); if (LOCSGN(&r) ==(INT)0) rest->signum = (signed char)0; else rest->signum = sx; LOCHOLE(&rest->floc); LOCASS(rest->floc,&r); rest->laenge = (INT)1; if (LOCSGN(blocx) !=(INT)0) x->signum = sx * sy; else if (x->laenge == (INT)1) x->signum = (signed char)0; else { alocx = blocx; blocx = blocx->nloc; alocx->nloc = NULL; locrette(&alocx); x->laenge --; x->signum = sx * sy; } locrezliste(&blocx); x->floc = blocx; } /* ende der einfachen division */ else if (x->laenge < y->laenge) /* trivial */ { *rest = *x; x->floc = NULL; LOCHOLE(&x->floc); x->signum = (signed char)0; x->laenge = (INT)1; } /* ende des trivialfalles */ else { /* normalfall x->laenge >= y->laenge >= 2 */ /* lange division */ LOCNULL(&null); blocy = y->floc; y->floc = NULL; locrezliste(&blocy); locy1 = blocy; locy0 = blocy->nloc; a = LOCBAS2() - (INT)1 - locms1(locy1); locx1 = x->floc; x->floc = NULL; locrezliste(&locx1); locx2 = NULL; LOCHOLE(&locx2); locx2->nloc = locx1; locx0 = locx1->nloc; /* dividend und divisor normieren. dividend zerlegen */ locpsl(locx2,locx1,a); alocy = locy0; plocy = locy1; alocx = locx0; plocx = locx1; do { locpsl(plocy,alocy,a); locpsl(plocx,alocx,a); plocy = alocy; alocy = alocy->nloc; plocx = alocx; alocx = alocx->nloc; } while (alocy != NULL); locpsl(plocy,&null,a); llocx = plocx; rlocx = alocx; while (alocx != NULL) /* rest des dividenden normieren */ { locpsl(plocx,alocx,a); plocx = alocx; alocx = alocx->nloc; } locpsl(plocx,&null,a); llocx->nloc = NULL; /* dividend getrennt */ /* listen fuer teildividend und divisor umkehren */ blocx = locx2; locrezliste(&blocx); locrezliste(&blocy); /* quotientenliste mit laenge */ blocq = NULL; ql =(INT)0; do { /* divisionsschritt */ if (locvgl(locx2,locy1) ==(INT)0) LOCMAX(&q); else { LOCASS(&r,locx2); locdiv(&q,&r,locx1,locy1); LOCMUL(&hi,&lo,&q,locy0); /* falls (hi,lo) <= (r,locx0):fertig */ vgl = locvgl(&hi,&r); if ((vgl >0) || ((vgl ==(INT)0) && (locvgl(&lo,locx0) >(INT)0))) { locssub(&q,(INT)1); cy = locadd(&r,locy1,(INT)0); if (cy ==(INT)0) { cy = locsub(&lo,locy0,(INT)0); if (cy == (INT)1) cy = locssub(&hi,(INT)1); vgl = locvgl(&hi,&r); if ( (vgl >(INT)0) || ((vgl ==(INT)0) && /* bug 050790 */ (locvgl(&lo,locx0) >(INT)0 ))) cy = locssub(&q,(INT)1); } } }; /* subtrahiere q*divisor von teildivdend llocx = vorgaenger locx0 */ alocy = blocy; alocx = blocx; cy = 0; cyn = 0; LOCNULL(&ov); llocx = NULL; plocx = NULL; do { LOCMUL(&hi,&lo,alocy,&q); cy = locadd(&lo,&ov,cy); LOCASS(&ov,&hi); cyn = locsub(alocx,&lo,cyn); plocx = alocx; alocx = alocx->nloc; alocy = alocy->nloc; if (alocx == locx0) llocx = plocx; } while (alocy != NULL); cy = locsadd(&ov,cy); cyn = locsub(alocx,&ov,cyn); if (cy !=(INT)0) return error("internal error:LO12"); /* falls differenz negativ, q war um 1zu gross. korrektur */ if (cyn == (INT)1) { cyn = locssub(&q,(INT)1); alocx = blocx; alocy = blocy; cy =(INT)0; do { cy = locadd(alocx,alocy,cy); alocx = alocx->nloc; alocy = alocy->nloc; } while (alocy != NULL); cy = locsadd(alocx,cy); if (cy != (INT)1) return error("internal error:LO13"); } /* quotientenziffer q abspeichern . locx2 ist frei dafuer */ locx1->nloc = NULL; if ((blocq == NULL) && (LOCSGN(&q) ==(INT)0)) locrette(&locx2); else { locx2->nloc = blocq; blocq = locx2; locx2 = NULL; LOCASS(blocq,&q); ql ++; }; /* neuer teildividend */ fertig = (rlocx == NULL); if (! fertig) { alocx = blocx; blocx = rlocx; rlocx = rlocx->nloc; blocx->nloc = alocx; locx2 = locx1; locx1 = locx0; locx0 = llocx; if (locx0 == NULL) locx0 = blocx; } } while (! fertig); /* ende divisionsschritt */ /* quotient */ if (blocq == NULL) { LOCHOLE (&x->floc); x->signum = (signed char)0; x->laenge = (INT)1; } else { x->floc = blocq; blocq = NULL; x->signum = sx * sy; x->laenge = ql; } /* rest normierung rueckgaengig machen fuehrende nullen entfernen */ i =(INT)0; llocx = NULL; plocx = blocx; alocx = plocx->nloc; do { i++; /* Seite 8 von test.p */ locpsr(alocx,plocx,a); if (LOCSGN(plocx) !=(INT)0) { llocx = plocx; rl = i; } plocx = alocx; alocx = alocx->nloc; } while (alocx != NULL); locpsr(&null,plocx,a); if (LOCSGN(plocx) !=(INT)0) { llocx = plocx; rl = i+ (INT)1; } if (llocx == NULL) /* rest 0 */ { loclisterette(&blocx->nloc); rest->floc = blocx; blocx = NULL; rest->signum = (signed char)0; rest->laenge = (INT)1; } else { loclisterette(&llocx->nloc); rest->floc = blocx; blocx = NULL; rest->signum = sx; rest->laenge = rl; } /* divisor. normierung rueckgaengig machen */ plocy = blocy; alocy = plocy->nloc; do { locpsr(alocy,plocy,a); plocy = alocy; alocy = alocy->nloc; } while (alocy != NULL); locpsr(&null,plocy,a); y->floc = blocy; blocy = NULL; } /* lange divison */ ENDR("ganzquores"); } /* ende ganzquores */ #ifdef UNDEF static INT ganzganzdiv(x,y) struct longint *x,*y; /* AK: Tue Mar 14 09:03:44 MEZ 1989 */ /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ /* AK 130789 V1.0 */ /* AK 210891 V1.3 */ { struct longint rest; rest.floc = NULL; ganzquores(x,&rest,y); ganzloesche(&rest); return OK; } #endif #ifdef UNDEF static INT ganzmod(x,rest,y) struct longint *x,*y,*rest; /* AK Tue Mar 14 09:05:54 MEZ 1989 */ /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ /* AK 130789 V1.0 *//* AK 250790 V1.1 */ /* AK 210891 V1.3 */ { return ganzquores(x,rest,y); } #endif static INT ganzein(fp,x) FILE *fp; struct longint *x; /* AK 130789 V1.0 *//* AK 250790 V1.1 */ /* AK 270391 V1.2 */ /* AK 210891 V1.3 */ { INT i; signed char sgn=(signed char)1; char c; fscanf(fp,"%ld",&i); if (i <(INT)0) { sgn = (signed char)-1; i = i *(INT)-1; } ganzint(x, i % gd.basis); while ((c=getc(fp)) == (char) gd.folgezeichen) { fscanf(fp,"%ld",&i); if (i <(INT)0) { return error("internal error LO14"); } ganzsmul(x,gd.basis); ganzsadd(x,i % gd.basis); } x->signum = sgn; return OK; } static INT holeziffer(zd) struct zahldaten *zd; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { struct loc *adez; INT zzmod3,erg = OK; zd->ziffernzahl --; zzmod3 = zd->ziffernzahl % (INT)3; if (zzmod3 ==(INT)0) erg=zd->fdez->w0; if (zzmod3 ==(INT)1) erg=zd->fdez->w1; if (zzmod3 ==(INT)2) erg=zd->fdez->w2; if (zzmod3 ==(INT)0) { adez = zd->fdez; zd->fdez = zd->fdez->nloc; adez->nloc = NULL; locrette(&adez); } return(erg); } static INT ganzfziffer(zd) struct zahldaten *zd; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT z,f0; char buffer[200]; if (zd->ziffernzahl == 0) { zd->mehr = FALSE; //strcpy(zd->ziffer," "); } else { z = holeziffer(zd); if (zd->ziffernzahl > 0) zd->mehr=TRUE; else zd->mehr=FALSE; sprintf(buffer,"%ld",z); f0 = gd.basislaenge-strlen(buffer); sprintf(zd->ziffer,"%s","000000000000"); /* max. 12 Nullen */ sprintf(zd->ziffer + f0,"%ld",z); if (zd->mehr == TRUE) { if (nofolgezeichen) sprintf(zd->ziffer,"%s", zd->ziffer); else sprintf(zd->ziffer,"%s%c", zd->ziffer,gd.folgezeichen); } else { if (nofolgezeichen) sprintf(zd->ziffer,"%s",zd->ziffer); else sprintf(zd->ziffer,"%s%c",zd->ziffer,' '); } } return(OK); } static INT retteziffer(z,zd) INT z; struct zahldaten *zd; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { struct loc *adez; INT zzmod3; INT erg =OK; zzmod3 = zd->ziffernzahl % (INT)3; if (zzmod3 ==(INT)0) { adez = NULL; LOCHOLE(&adez); adez ->nloc = zd->fdez; zd->fdez = adez; } if (zzmod3 ==(INT)0) zd->fdez->w0 = z; if (zzmod3 ==(INT)1) zd->fdez->w1 = z; if (zzmod3 ==(INT)2) zd->fdez->w2 = z; zd->ziffernzahl ++; ENDR("retteziffer"); } static INT ganz1ziffer(zd,x) struct zahldaten *zd; struct longint *x; /* AK 130789 V1.0 */ /* AK 030790 V1.1 */ /* AK 210891 V1.3 */ { INT z; signed char sgn; struct longint xx; zd->fdez = NULL; zd->ziffernzahl =(INT)0; xx.floc = NULL; (zd->ziffer)[0] = '\0'; lochole(&xx.floc); ganzkopiere(&xx,x); sgn = xx.signum; if (xx.signum < (signed char)0) xx.signum = -xx.signum; while (xx.signum > (signed char)0) { ganzsquores(&xx,&z,gd.basis); retteziffer(z,zd); } if (zd->ziffernzahl ==(INT)0) { zd->mehr = FALSE; // strcpy(zd->ziffer," "); } else { z = holeziffer(zd); z = sgn * z; zd->mehr = (zd->ziffernzahl >(INT)0); if (zd->mehr == TRUE) { if (nofolgezeichen) sprintf(zd->ziffer,"%s%ld",zd->ziffer,z); else sprintf(zd->ziffer,"%s%ld%c",zd->ziffer,z,gd.folgezeichen); } else sprintf(zd->ziffer,"%s%ld",zd->ziffer,z); } locrette(& xx.floc); return(OK); } static INT ganzaus_str(string,x) char *string; struct longint *x; /* AK 020295 */ { struct zahldaten zd; int i,k; string[0]='\0'; if (x->signum == 0) /* AK 060502 */ { strcat(string," 0 "); goto ende; } ganz1ziffer(&zd,x); k = strlen(zd.ziffer); if (zd.ziffer[k-1] == gd.folgezeichen) { zd.ziffer[k-1] = '\0'; k--; } strcat(string,zd.ziffer); i = k; while (zd.mehr == TRUE) { ganzfziffer(&zd); k = strlen(zd.ziffer); if (zd.ziffer[k-1] == gd.folgezeichen) { zd.ziffer[k-1] = '\0'; k--; } strcat(string,zd.ziffer); i+=k; } ende: return OK; } INT mem_size_longint(a) OP a; /* AK V2.0 080903 */ { INT erg = OK, res = 0; struct longint *x; CTO(LONGINT,"mem_size_longint(1)",a); res = sizeof(struct object); res += sizeof(struct longint); x = S_O_S(a).ob_longint; res += ((x->laenge)*sizeof(struct loc)); return res; ENDR("mem_size_longint"); } static INT ganzaus(fp,x) FILE *fp; struct longint *x; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { struct zahldaten zd; char *blanks = (char *) SYM_calloc(201,sizeof(char)); char *zeile = (char *) SYM_calloc(201,sizeof(char)); INT i; if (x->signum == 0) /* AK 060502 */ { fprintf(fp," 0 "); if (fp == stdout) zeilenposition += 3; else if (fp == texout) texposition += 3; goto ende; } for (i=1;i gd.auslaenge) { if (nofolgezeichen) fprintf(fp,"%s",zeile); else fprintf(fp,"%s%s\n",blanks,zeile); strcpy(zeile,zd.ziffer); gd.auszz++; } else strcat(zeile,zd.ziffer); } if (fp == stdout) { zeilenposition += strlen(zeile); zeilenposition += strlen(blanks); } else if (fp == texout) { texposition += strlen(zeile); texposition += strlen(blanks); } if (nofolgezeichen) fprintf(fp,"%s",zeile); else fprintf(fp,"%s%s",blanks,zeile); if (fp == stdout) if (zeilenposition >(INT)70) { fprintf(fp,"\n"); zeilenposition =(INT)0; } if (fp == texout) if (texposition >(INT)70) { fprintf(fp,"\n"); texposition =(INT)0; } gd.auszz++; SYM_free(blanks); SYM_free(zeile); ende: return(OK); } static INT ganzmul(x,y) struct longint *x,*y; /* AK Mon Jan 16 09:26:56 MEZ 1989 */ /* x = x * y */ /* AK 180789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { struct loc *alocx, *alocy, *ploca, *floca, *bloca, *aloca; struct loc hi,lo,ov; INT cy,cya; INT hh; /* fuer LOCADD,LOCMUL */ INT erg =OK; x->signum = x->signum * y ->signum; if (x->signum == (signed char)0) { loclisterette(& (x->floc->nloc)); LOCNULL(x->floc); x->laenge =(INT)1; return OK; /* das ergebnis ist null */ } /* das ergebnis ist nicht null */ x->laenge = x->laenge + y->laenge; floca = NULL; LOCHOLE(&floca); bloca = floca; alocx = x->floc->nloc; ploca = floca; aloca = NULL; while (alocx != NULL) { LOCHOLE(&aloca); ploca->nloc = aloca; ploca = aloca; aloca = NULL; alocx = alocx->nloc; } alocy = y->floc; do { cya =(INT)0; LOCNULL(&ov); cy =(INT)0; alocx = x->floc; aloca = bloca; do { LOCMUL(&hi,&lo,alocx,alocy); cy = LOCADD(&lo,&ov, cy); ov = hi; cya = LOCADD(aloca,&lo,cya); alocx=alocx->nloc; ploca=aloca; aloca = aloca->nloc; } while (alocx != NULL); cy = locsadd(&ov, cy+cya); /* cy ist jetzt 0 */ if (cy !=(INT)0) return error("internal error:LO2"); LOCHOLE(&aloca); ploca->nloc = aloca; LOCASS(aloca,&ov); bloca = bloca->nloc; alocy = alocy->nloc; } while (alocy != NULL); if (LOCSGN(aloca ) ==(INT)0) { locrette(&(ploca->nloc)); x->laenge --; } loclisterette(&x->floc); x->floc = floca; ENDR("ganzmul"); } static INT ganzsmul(x,a) struct longint *x; INT a; /* AK Mon Mar 13 10:08:51 MEZ 1989 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { struct loc *alocx, *plocx; INT ue,erg =OK; if (a==(INT)0) { loclisterette(&(x->floc->nloc)); x->signum = (signed char)locint(x->floc,(INT)0); x->laenge =(INT)1; } else if (a ==(INT)1) ; else if (a ==(INT)-1) x->signum = - x->signum; else { if (a<(INT)0) x->signum = - x->signum; alocx = x->floc; plocx = NULL; if (a<(INT)0) a = -a; ue =(INT)0; do { ue = locsmul(alocx,a,ue); plocx = alocx; alocx = alocx ->nloc; } while (alocx != NULL); if (ue !=(INT)0) { LOCHOLE(&alocx); plocx->nloc = alocx; x->laenge ++; ue = locint(alocx,ue); } } ENDR("ganzsmul"); } static INT ganzsadd(x,y) struct longint *x; INT y; /* AK 180789 V1.0 */ /* AK 070390 V1.1 */ /* AK 210891 V1.3 */ { INT cy,xl,ll; INT erg =OK; signed char xs,ys; struct loc *lloc,*alocx,*plocx=NULL; xl = x->laenge; xs = x->signum; if (y>(INT)0) ys=(signed char)1; else if (y<(INT)0) ys = (signed char)-1; else ys=(signed char)0; if (y<(INT)0) y = -y; if ( ((xs>=(signed char)0)&&(ys>=(signed char)0)) || ((xs<(signed char)0)&&(ys < (signed char)0)) ) { alocx = x->floc; cy = y; while ((alocx != NULL)&&(cy !=(INT)0)) { cy = locsadd(alocx,cy); plocx = alocx; alocx = alocx->nloc; } if (cy !=(INT)0) { LOCHOLE(&alocx); plocx->nloc = alocx; locint(alocx,cy); xl ++; } if (xs == (signed char)0) xs = ys; } else { alocx = x->floc; cy = y; while ((alocx != NULL) && (cy !=(INT)0)) { cy = locssub(alocx,cy); plocx = alocx; alocx = alocx->nloc; } if (cy !=(INT)0) { alocx = x->floc; lloc = NULL; ll = (INT) 1; cy = (INT) 0; do { cy = locneg(alocx,cy); if (LOCSGN(alocx) != (INT) 0 ) { lloc = alocx; xl = ll; } alocx = alocx->nloc; ll ++; } while (alocx != NULL); loclisterette(&(lloc->nloc)); xs = -xs; if (xs == (signed char)0) xs = (signed char)-1; } else { alocx = x->floc; lloc = NULL; ll = (INT)1; do { if (LOCSGN(alocx) !=(INT)0) { lloc = alocx; xl = ll; } alocx = alocx->nloc; ll ++; } while (alocx != NULL); if (lloc == NULL) { loclisterette(&(x->floc->nloc)); xs = (signed char)0; xl = (INT)1; } else loclisterette(&(lloc->nloc)); } } x->laenge = xl; x->signum = xs; ENDR("ganzsadd"); } static INT ganzvergleich(x,y) struct longint *x,*y; /* AK Thu Jan 12 09:08:15 MEZ 1989 */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { struct loc *alocx, *alocy; INT av,lv; signed char sx,sy; sx = x->signum; sy = y->signum; if (sx>sy) return((INT)1); if (sxlaenge > y->laenge) return((INT)sx); if (x->laenge < y->laenge) return((INT)-sy); /* es gilt nicht nur gleiches vorzeichen sondern auch gleiche laenge */ alocx = x->floc; alocy = y->floc; lv = 0; do { av = locvgl(alocx,alocy); if (av != 0) lv = av; alocx = alocx->nloc; alocy = alocy->nloc; } while (alocx != NULL); if (sx>(signed char)0) return(lv); else return(-lv); } static INT intganz(x) struct longint *x; /* AK 150290 V1.1 */ /* umwandlung longint to int falls moeglich sonst fehler */ /* AK 210891 V1.3 */ { if ( x->signum < 0) return - x->floc->w0 - x->floc->w1 * LO_B - x->floc->w2 * LO_B * LO_B ; else return (x->floc->w0&BMINUSEINS) +(x->floc->w1&BMINUSEINS) * LO_B +(x->floc->w2&BMINUSEINS) * LO_B * LO_B; } static INT ganzint(x,i) struct longint *x; INT i; /* AK Thu Jan 12 13:18:53 MEZ 1989 */ /* AK 130789 V1.0 */ /* AK 150290 V1.1 */ /* AK 210891 V1.3 */ { if (x->floc->nloc != NULL) loclisterette(& x->floc->nloc ); if (i == MAXNEG) { /* AK 251001 */ /* sonst ist locint fehlerhaft */ x->laenge = (INT)1; x->signum = (signed char)locint(x->floc,i+1); ganzsadd(x,(INT)-1); } else { x->laenge = (INT)1; x->signum = (signed char)locint(x->floc,i); } return(OK); } static INT ganzeven(x) struct longint *x; /* AK 061190 V1.1 */ /* AK 210891 V1.3 */ { return not locodd(x->floc); } static INT ganzodd(x) struct longint *x; /* AK 061190 V1.1 */ /* AK 210891 V1.3 */ { return locodd(x->floc); } static INT ganzkopiere(x,a) struct longint *x,*a; /* x:= a AK umgeschrieben in C Fri Jan 20 07:46:34 MEZ 1989 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; struct loc *alocx, *plocx, *aloca; if (a->floc == NULL) { /* AK 060502 */ /* a == 0 */ if (x->floc != NULL) FREE_LOC(x->floc); /* was initialised in init_longint */ x->laenge = 0; x->floc = NULL; goto ee; } SYMCHECK( x->floc == a->floc, "internal error:LO4"); x->signum = a->signum; x->laenge = a->laenge; aloca = a->floc; alocx = x->floc; plocx = NULL; do { if (alocx == NULL) { LOCHOLE(&alocx); plocx->nloc = alocx; } LOCASS(alocx,aloca); aloca = aloca->nloc; plocx = alocx; alocx = alocx->nloc; } while (aloca != NULL); /* loclisterette(&(plocx->nloc)); */ if (plocx->nloc != NULL) { FREE_LOC(plocx->nloc); plocx->nloc = NULL; } ee: ENDR("internal function:ganzkopiere"); } INT mult_longint_integer(a,b,c) OP a,b,c; { INT erg = OK,i,j,p,u,s,p2; static INT sp[14],sp2[14]; struct longint *x; struct loc *alocx; CTO(LONGINT,"mult_longint_integer(1)",a); CTO(INTEGER,"mult_longint_integer(2)",b); CTO(EMPTY,"mult_longint_integer(3)",c); if (NULLP_INTEGER(b) || NULLP_LONGINT(a) ) { M_I_I(0,c); goto ende; } x = S_O_S(a).ob_longint; if (x->laenge > 4) { erg += mult_longint_integer_via_ganzsmul(a,b,c); goto ende; } s = x->signum; if (S_I_I(b) < 0) { p = -S_I_I(b); s = -s; } else p = S_I_I(b); if (p > 1073741824) { erg += mult_longint_integer_via_ganzsmul(a,b,c); goto ende; } i=0; alocx = x->floc; xx: sp[i++] = alocx->w0; sp[i++] = alocx->w1; sp[i++] = alocx->w2; if (alocx -> nloc) { alocx = alocx->nloc; goto xx; } sp[i] = 0; sp[i+1] = 0; if (p <= 32768 ) { j = 0;u = 0; while (j <=i) { sp [j] *= p; sp [j] += u; u = sp[j] >> 15; sp [j] &= BMINUSEINS; j++; } } else { j = 0; u = 0;p2 = p >> 15; while (j <=i) { sp2 [j] = sp[j] * p2; sp2 [j] += u; u = sp2[j] >> 15; sp2 [j] &= BMINUSEINS; j++; } j = 0;u = 0; p &= BMINUSEINS; while (j <=i) { sp [j] *= p; sp [j] += u; if (j>0) sp[j] += sp2[j-1]; u = sp[j] >> 15; sp [j] &= BMINUSEINS; j++; } sp[i+1] = sp2[i]+u; /* AK 030502 +u was missing */ } INIT_LONGINT(c); x = S_O_S(c).ob_longint; alocx = x->floc; j = 0;u=0; x ->signum = s; again: alocx->w0 = sp[j++]; alocx->w1 = sp[j++]; alocx->w2 = sp[j++]; if ((j==i) && ( (sp[j] != 0) || (sp[j+1] != 0)) ) { x->laenge ++; LOCHOLE(& alocx->nloc); alocx->nloc->w0 = sp[j]; alocx->nloc->w1 = sp[j+1]; } else if (j < i) { x->laenge ++; LOCHOLE(& alocx->nloc); alocx = alocx->nloc; goto again; } ende: ENDR("mult_longint_integer"); } static INT lochole(aloc) struct loc **aloc; /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { INT erg =OK; CALLOC_MEMMANAGER(struct loc,loc_speicher,loc_index,loc_counter,*aloc); LOCNULL(*aloc); (*aloc)->nloc = NULL; ENDR("lochole"); } static INT loclisterette(aloc) struct loc **aloc; /* AK 130789 V1.0 */ /* AK 010290 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; struct loc *aloc1, *ploc1; if (*aloc != NULL) { aloc1= (*aloc); do { ploc1 = aloc1->nloc; FREE_LOC(aloc1); aloc1 = ploc1; } while (aloc1 != NULL); *aloc = NULL; } ENDR("intenal function:loclisterette"); } static INT locrette(aloc) struct loc **aloc; /* AK 130789 V1.0 */ /* AK 100190 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; if (*aloc != NULL) { FREE_LOC(*aloc); *aloc = NULL; } ENDR("internal function:locrette"); } static INT locrezliste(aloc) struct loc **aloc; /* AK Thu Jan 12 08:06:59 MEZ 1989 */ /* dreht liste um */ /* AK 100190 V1.1 */ /* AK 210891 V1.3 */ { struct loc *lloc,*rloc,*hloc; if (*aloc != NULL) { lloc = NULL; rloc = *aloc; while (rloc != NULL) { hloc = rloc->nloc; rloc->nloc=lloc; lloc=rloc; rloc=hloc; } *aloc = lloc; } return(OK); } static INT schon_da =(INT)0; INT start_longint() /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { OP a,b; INT erg = OK; INT i; SYMCHECK (schon_da == 1, "start_longint: already initialised"); schon_da = 1; ANFANG_MEMMANAGER(loc_speicher,loc_index,loc_size,loc_counter); ANFANG_MEMMANAGER(longint_speicher,longint_speicherindex, longint_speichersize,mem_counter_loc); erg += ganzanfang(); erg += ganzparam((INT)1000000,(INT)2,(INT)70,'.'); a = callocobject(); b = callocobject(); M_I_I((INT)1000,b); for (i=(INT)0;i<(INT)100;i++) { erg += random_integer(a,NULL,NULL); if (S_I_I(a) !=(INT)0) MULT_APPLY_INTEGER(a,b); } erg += random_longint(a,b); FREEALL2(a,b); ENDR("start_longint"); } INT longint_ende() { INT erg = OK; schon_da = (INT)0; if (rl_o != NULL) { erg += freeall(rl_o); rl_o = NULL; } if (rl_m != NULL) { erg += freeall(rl_m); rl_m = NULL; } if (rl_a != NULL) { erg += freeall(rl_a); rl_a = NULL; } if (rl_x != NULL) { erg += freeall(rl_x); rl_x = NULL; } ENDE_MEMMANAGER(loc_speicher,loc_index, loc_size,loc_counter,"loc_speicher not freed"); ENDE_MEMMANAGER(longint_speicher,longint_speicherindex, longint_speichersize,mem_counter_loc, "longint_speicher not freed"); erg += longint_speicher_ende(); ENDR("longint_ende"); } static struct longint * calloclongint() /* AK 170888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT erg =OK; struct longint *ergebnis; CALLOC_MEMMANAGER(struct longint,longint_speicher, longint_speicherindex,mem_counter_loc,ergebnis); return ergebnis; ENDTYP("calloclongint",struct longint *); } static INT longint_speicher_ende() /* AK 230101 */ { INT i; for (i=0;i<=longint_speicherindex;i++) SYM_free(longint_speicher[i]); SYM_free(longint_speicher); longint_speicher=NULL; longint_speicherindex=-1; longint_speichersize=0; return OK; } static INT ganzparam(basis,auspos,auslaenge,folgezeichen) INT basis,auspos,auslaenge; char folgezeichen; /* AK Mon Mar 13 10:24:35 MEZ 1989 */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { if (basis>(INT)1) gd.basis=basis; else return error("internal error:LO5"); if (auspos>(INT)1) gd.auspos=auspos; else gd.auspos = 2; if (basis <= (INT)10) gd.basislaenge = 1; else if (basis <= (INT)100) gd.basislaenge = 2; else if (basis <= (INT)1000) gd.basislaenge = 3; else if (basis <= (INT)10000) gd.basislaenge = 4; else if (basis <= (INT)100000) gd.basislaenge = 5; else if (basis <= (INT)1000000) gd.basislaenge = 6; else if (basis <= (INT)10000000) gd.basislaenge = 7; else if (basis <= (INT)100000000) gd.basislaenge = 8; else if (basis <= (INT)1000000000) gd.basislaenge = 9; else gd.basislaenge = 10; if (auslaenge > gd.basislaenge) gd.auslaenge = auslaenge; else gd.auslaenge = gd.basislaenge+1; gd.folgezeichen = folgezeichen;return(OK); } static INT ganzanfang() /* AK: Tue Mar 14 08:43:55 MEZ 1989 */ /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { gd.auszz =(INT)0; gd.basis = (INT)1000000; gd.basislaenge = (INT)6; gd.folgezeichen = '.'; gd.auspos =(INT)2; gd.auslaenge = (INT)78; return(OK); } static INT ganzdefiniere(x) struct longint *x; /* AK: Tue Mar 14 08:47:54 MEZ 1989 */ /* dieser Teil wurde von Peter Hain in Karlsruhe entworfen. Er schrieb diese Langzahl arithmetik in Pascal und Assembler. In Bayreuth wurden in Form eines Seminars die Assemblerteile in C geschrieben und spaeter wurde von Axel Kohnert die restlichen Pascalteile in C uebersetzt. Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth entworfen */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { x->signum = (signed char)0; x->laenge = (INT)1; x->floc = NULL; lochole(&x->floc); return(OK); } INT init_longint(l) OP l; /* AK 170888 */ /* AK 130789 V1.0 */ /* AK 040790 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; OBJECTSELF c; CTO(EMPTY,"init_longint",l); c.ob_longint = calloclongint(); B_KS_O(LONGINT,c,l); c = S_O_S(l); ganzdefiniere(c.ob_longint); ENDR("init_longint"); } INT sprint_longint(t,l) char *t; OP l; /* AK 020295 */ /* AK 240398 V2.0 */ { INT erg=OK; OBJECTSELF c; CTO(LONGINT,"sprint_longint",l); c = S_O_S(l); erg += ganzaus_str(t, c.ob_longint); ENDR("sprint_longint"); } INT fprint_longint(f,l) FILE *f; OP l; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; OBJECTSELF c; c = S_O_S(l); erg += ganzaus(f, c.ob_longint); ENDR("fprint_longint"); } INT tex_longint(l) OP l; /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 070291 V1.2 texout instaed of stdout for output */ /* AK 210891 V1.3 */ { INT ts = texmath_yn; INT erg = OK; CTO(LONGINT,"tex_longint(1)",l); if (ts == 0L) fprintf(texout," $ "); else fprintf(texout," "); erg += fprint_longint(texout,l); if (ts == 0L) fprintf(texout," $ "); else fprintf(texout," "); if (ts == 0L) texposition += (INT)6; else texposition += (INT)2; ENDR("tex_longint"); } INT copy_longint(a,c) OP a,c; /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 030790 V1.1 */ /* AK 210891 V1.3 */ /* AK 010399 V2.0 */ { INT erg = OK; CTO(LONGINT,"copy_longint(1)",a); CTTO(INTEGER,EMPTY,"copy_longint(2)",c); INIT_LONGINT(c); erg += ganzkopiere(S_O_S(c).ob_longint,S_O_S(a).ob_longint); ENDR("copy_longint"); } INT invers_longint(a,c) OP a,c; /* AK 010399 V2.0 */ { INT erg = OK; CTO(LONGINT,"invers_longint(1)",a); CTTO(INTEGER,EMPTY,"invers_longint(2)",c); erg += m_ou_b(cons_eins,a,c); C_B_I(c,GEKUERZT); ENDR("invers_longint"); } INT freeself_longint(a) OP a; /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 030790 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; struct longint *x; CTO(LONGINT,"freeself_longint(1)",a); x = S_O_S(a).ob_longint; loclisterette(&x->floc); x->laenge =(INT)0; x->signum = (signed char)0; FREE_LONGINT(x); C_O_K(a,EMPTY); ENDR("freeself_longint"); } INT add_longint_longint(a,c,l) OP a,c,l; /* AK 251001 */ { INT erg = OK; CTO(LONGINT,"add_longint(1)",a); CTO(LONGINT,"add_longint(2)",c); CTO(EMPTY,"add_longint(3)",l); erg += copy_longint(a,l); erg += ganzadd(S_O_S(l).ob_longint, S_O_S(c).ob_longint); erg += t_longint_int(l); ENDR("add_longint_longint"); } INT intlog_longint(a) OP a; /* AK 170306 */ { struct longint *as; as = S_O_S(a).ob_longint; return 45 * as->laenge; } INT add_longint(a,c,l) OP a,c,l; /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"add_longint(1)",a); CTO(EMPTY,"add_longint(3)",l); switch(S_O_K(c)) { #ifdef BRUCHTRUE case BRUCH: erg += add_bruch_scalar(c,a,l); if (S_O_K(l) == LONGINT) erg += t_longint_int(l); goto al_ende; #endif /* BRUCHTRUE */ case INTEGER: erg += add_longint_integer(a,c,l); goto al_ende; case LONGINT: { OBJECTSELF ls,cs; erg += copy_longint(a,l); ls = S_O_S(l); cs = S_O_S(c); erg += ganzadd(ls.ob_longint,cs.ob_longint); /* longinteger-addition ist x:= x+y */ erg += t_longint_int(l); }; goto al_ende; #ifdef SCHURTRUE /* AK 240102 */ case SCHUR: erg += add_schur(c,a,l); goto al_ende; case HOMSYM: erg += add_homsym(c,a,l); goto al_ende; case POWSYM: erg += add_powsym(c,a,l); goto al_ende; case ELMSYM: erg += add_elmsym(c,a,l); goto al_ende; case MONOMIAL: erg += add_monomial(c,a,l); goto al_ende; #endif /* SCHURTRUE */ default:{ erg += WTO("add_longint(2)",c); goto al_ende; } }; al_ende: ENDR("add_longint"); } INT mult_longint(a,c,l) OP a,c,l; /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"mult_longint(1)",a); CTO(EMPTY,"mult_longint(3)",l); switch (S_O_K(c)) { #ifdef BRUCHTRUE case BRUCH: erg+=mult_bruch_longint(c,a,l); goto me; #endif /* BRUCHTRUE */ #ifdef INTEGERTRUE case INTEGER: erg+=mult_longint_integer(a,c,l); goto me; #endif /* INTEGERTRUE */ #ifdef MATRIXTRUE case MATRIX: erg+=mult_scalar_matrix(a,c,l); goto me; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg+=mult_scalar_monom(a,c,l); goto me; #endif /* MONOMTRUE */ case LONGINT: erg+=mult_longint_longint(a,c,l); goto me; case POLYNOM: erg+=mult_scalar_polynom(a,c,l); goto me; #ifdef GRALTRUE case GRAL: erg+=mult_scalar_gral(a,c,l); goto me; #endif /* GRALTRUE */ #ifdef SCHUBERTTRUE case SCHUBERT: erg += mult_scalar_schubert(a,c,l); goto me; #endif /* SCHUBERT */ #ifdef SQRADTRUE case SQ_RADICAL: erg += mult_scalar_sqrad(a,c,l); goto me; #endif /* SQRADTRUE */ #ifdef SCHURTRUE case ELMSYM: erg+=mult_elmsym_scalar(c,a,l); goto me; case HOMSYM: erg+=mult_homsym_scalar(c,a,l); goto me; case POWSYM: erg+=mult_powsym_scalar(c,a,l); goto me; case MONOMIAL: erg+=mult_monomial_scalar(c,a,l); goto me; case SCHUR: erg+=mult_schur_scalar(c,a,l); goto me; #endif /* SCHURTRUE */ #ifdef CHARTRUE case SYMCHAR: erg+=mult_scalar_symchar(a,c,l); goto me; #endif /* CHARTRUE */ #ifdef VECTORTRUE case COMPOSITION: case WORD: case INTEGERVECTOR: case VECTOR: erg+=mult_scalar_vector(a,c,l); goto me; #endif /* VECTORTRUE */ default: { erg += WTO("mult_longint(2)",a); break; } }; me: ENDR("mult_longint"); } INT mult_longint_longint(a,c,l) OP a ,c,l; /* AK 310590 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"mult_longint_longint(1)",a); CTO(LONGINT,"mult_longint_longint(2)",c); CTO(EMPTY,"mult_longint_longint(3)",l); erg += copy_longint(a,l); erg += ganzmul(S_O_S(l).ob_longint,S_O_S(c).ob_longint); /* longinteger-multiplikation ist x:= x*y */ ENDR("mult_longint_longint"); } INT square_apply_longint(a) OP a; /* AK 271101 */ { INT erg = OK; OP c; CTO(LONGINT,"square_apply_longint(1)",a); c = CALLOCOBJECT(); erg += copy_longint(a,c); erg += ganzmul(S_O_S(a).ob_longint,S_O_S(c).ob_longint); FREEALL(c); ENDR("square_apply_longint"); } INT absolute_longint(a,b) OP a,b; /* AK 150393 */ { if (negp_longint(a)) return addinvers_longint(a,b); return copy_longint(a,b); } INT addinvers_apply_longint(a) OP a; /* AK 201289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"addinvers_apply_longint(1)",a); GANZNEG(S_O_S(a).ob_longint); ENDR("addinvers_apply_longint"); } INT ggt_longint_longint_sub(a,b,c) OP a,b,c; /* AK 021101 fast als mit mod */ /* ggt ist immer positiv */ { INT erg = OK; INT t; OP d; CTO(LONGINT,"ggt_longint_longint_sub(1)",a); CTO(LONGINT,"ggt_longint_longint_sub(2)",b); CTO(EMPTY,"ggt_longint_longint_sub(3)",c); if (NULLP_LONGINT(a)) { COPY(b,c); if (NEGP(c)) ADDINVERS_APPLY(c); goto endr_ende; } if (NULLP(b)) { COPY(a,c); if (NEGP(c)) ADDINVERS_APPLY(c); goto endr_ende; } d = CALLOCOBJECT(); if (NEGP_LONGINT(a)) erg += addinvers_longint(a,d); else COPY(a,d); if (NEGP(b)) ADDINVERS(b,c); else COPY(b,c); while((t=COMP(d,c)) != 0) { if (t == 1) { ADDINVERS_APPLY(c); ADD_APPLY(c,d); ADDINVERS_APPLY(c); } else { ADDINVERS_APPLY(d); ADD_APPLY(d,c); ADDINVERS_APPLY(d); } } FREEALL(d); ENDR("ggt_longint_longint_sub"); } INT ggt_longint(a,b,c) OP a,b,c; /* AK 191001 */ /* ggt ist immer positiv */ { INT erg = OK; CTO(LONGINT,"ggt_longint(1)",a); CTO(EMPTY,"ggt_longint(3)",c); if (S_O_K(b) == INTEGER) erg += ggt_integer_longint(b,a,c); else if (S_O_K(b) == LONGINT) erg += ggt_longint_longint(a,b,c); else erg += WTO("ggt_longint(2)",b); ENDR("ggt_longint"); } INT ggt_longint_integer(a,b,c) OP a,b,c; /* ggt ist immer positiv */ { return ggt_integer_longint(b,a,c); } INT oddify_longint(); #define ODDIFY(a)\ /* a is even becomes odd */\ /* a is not zero */\ do { \ if (S_O_K(a) == INTEGER) {\ while (EVEN_INTEGER(a)) HALF_APPLY_INTEGER(a);\ }\ else if (S_O_K(a) == LONGINT) {\ oddify_longint(a);\ }\ else {\ do HALF_APPLY(a); while (EVEN(a));\ } \ } while(0) #define ZEROBITS(a,b)\ if (S_O_K(a) == INTEGER) { INT zbi=1;\ b=0; while (not (zbi&S_I_I(a)) ) { b++; zbi <<=1; }\ }\ else /* LONGINT */ {\ struct loc *alocx;\ INT zbi=1;\ b=0;\ alocx = (S_O_S(a).ob_longint) -> floc;\ do {\ if (alocx -> w0 != 0) {\ while (not (zbi&alocx -> w0) ) { b++; zbi <<=1; }\ break;\ }\ else if (alocx -> w1 != 0) {\ b+= 15;\ while (not (zbi&alocx -> w1) ) { b++; zbi <<=1; }\ break;\ }\ else if (alocx -> w2 != 0) {\ b+= 30;\ while (not (zbi&alocx -> w2) ) { b++; zbi <<=1; }\ break;\ }\ else {\ b += 45;\ alocx = alocx->nloc;\ }\ } while(1); \ } INT ggt_longint_longint(a,b,d) OP a,b,d; /* AK 010202 */ /* always positive */ { INT ah,bh,c,erg = OK; OP ac,bc; CTTO(LONGINT,INTEGER,"ggt_longint_longint(1)",a); CTTO(LONGINT,INTEGER,"ggt_longint_longint(2)",b); CTO(EMPTY,"ggt_longint_longint(3)",d); if (NULLP(a)) { COPY(b,d); goto ende; } if (NULLP(b)) { COPY(a,d); goto ende; } ac = d; bc = CALLOCOBJECT(); if (NEGP(a)) ADDINVERS(a,ac); else COPY(a,ac); if (NEGP(b)) ADDINVERS(b,bc); else COPY(b,bc); /* c =0; while (EVEN(ac) && EVEN(bc)) { HALF_APPLY(ac); HALF_APPLY(bc); c++; } ODDIFY(ac); ODDIFY(bc); */ ZEROBITS(ac,ah); ZEROBITS(bc,bh); c = ( ah >= bh ? bh : ah); if (S_O_K(ac) == INTEGER) psr_apply_i_integer(ac,ah); else psr_apply_i_longint(ac,ah); if (S_O_K(bc) == INTEGER) psr_apply_i_integer(bc,bh); else psr_apply_i_longint(bc,bh); /* beide ungerade */ while (not EQ(ac,bc)) if (GT(ac,bc)) { sub_apply(bc,ac); ODDIFY(ac); } else { sub_apply(ac,bc); ODDIFY(bc); } /* while (c) { double_apply(ac) ; c--; } */ if (S_O_K(ac) == INTEGER) psl_apply_i_integer(ac,c); else psl_apply_i_longint(ac,c); FREEALL(bc); ende: ENDR("ggt_longint_longint"); } INT mod_apply_integer_longint(a,b) OP a,b; /* a is INTEGER b is longint a:= a mod b */ { OP c,d; INT erg = OK; CTO(INTEGER,"mod_apply_integer_longint(1)",a); CTO(LONGINT,"mod_apply_integer_longint(2)",b); c = CALLOCOBJECT(); d = CALLOCOBJECT(); SWAP(a,c); erg += quores_integer(c,b,d,a); FREEALL(c); FREEALL(d); ENDR("mod_apply_integer_longint"); } INT mod_longint_integer_via_ganzsquores(a,b,c) OP a,b,c; /* AK 300102 */ /* c = a % b; */ /* the result lies between zero and b , excluding b */ { INT erg = OK; INT rest; OP ac; CTO(LONGINT,"mod_longint_integer(1)",a); CTO(INTEGER,"mod_longint_integer(2)",b); CTTO(INTEGER,EMPTY,"mod_longint_integer(3)",c); SYMCHECK(S_I_I(b) == 0,"mod_longint_integer:second parameter == 0"); SYMCHECK(S_I_I(b) < 0,"mod_longint_integer:second parameter < 0"); ac = CALLOCOBJECT(); COPY(a,ac); erg += ganzsquores(S_O_S(ac).ob_longint,&rest,S_I_I(b)); FREEALL(ac); if (S_I_I(b) < 0) M_I_I(rest+S_I_I(b),c); else M_I_I(rest,c); CTO(INTEGER,"mod_longint_integer(e3)",c); ENDR("mod_longint_integer"); } INT mod_longint_integer(a,b,c) OP a,b,c; /* AK 050202 */ /* c = a % b; */ /* the result lies between zero and b , excluding b */ { INT erg = OK; INT rest,i; struct longint *x; struct loc *alocx; static int sp[12]; CTO(LONGINT,"mod_longint_integer(1)",a); CTO(INTEGER,"mod_longint_integer(2)",b); CTTO(INTEGER,EMPTY,"mod_longint_integer(3)",c); SYMCHECK(S_I_I(b) == 0,"mod_longint_integer:second parameter == 0"); x = S_O_S(a).ob_longint; if (x->laenge > 4) { erg += mod_longint_integer_via_ganzsquores(a,b,c); goto ende; } if (S_I_I(b) >= 32768) { erg += mod_longint_integer_via_ganzsquores(a,b,c); goto ende; } if (S_I_I(b) <= -32768) { erg += mod_longint_integer_via_ganzsquores(a,b,c); goto ende; } i=0; alocx = x->floc; xx: sp[i++] = alocx->w0; sp[i++] = alocx->w1; sp[i++] = alocx->w2; if (alocx -> nloc) { alocx = alocx->nloc; goto xx; } rest = 0; while (i--) rest = (rest * 32768 + sp[i]) % S_I_I(b); if (S_I_I(b) < 0) M_I_I(rest+S_I_I(b),c); else M_I_I(rest,c); ende: /* { OP d; d = CALLOCOBJECT(); mod_longint_integer_via_ganzsquores(a,b,d); println(c); println(d); SYMCHECK(not EQ(c,d),"e2"); FREEALL(d); } */ CTO(INTEGER,"mod_longint_integer(e3)",c); ENDR("mod_longint_integer"); } INT mod_apply_longint(a,b) OP a,b; /* a is of type LONGINT a = a mod b */ /* AK 051001 */ { INT erg = OK; CTO(LONGINT,"mod_apply_longint(1)",a); if (S_O_K(b) == LONGINT) { OBJECTSELF as,bs,cs; OP c; c = CALLOCOBJECT(); *c = *a; C_O_K(a,EMPTY); INIT_LONGINT(a); as = S_O_S(a); bs = S_O_S(b); cs = S_O_S(c); erg += ganzquores(cs.ob_longint, as.ob_longint, bs.ob_longint); if (NEGP_LONGINT(a)) if (POSP_LONGINT(b)) erg += ganzadd(as.ob_longint,bs.ob_longint); else { GANZNEG(bs.ob_longint); erg += ganzadd(as.ob_longint,bs.ob_longint); GANZNEG(bs.ob_longint); } /* now a is positiv */ t_longint_int(a); FREEALL(c); } else if (S_O_K(b) == INTEGER) { OBJECTSELF as; INT rest; as = S_O_S(a); erg += ganzsquores(as.ob_longint,&rest,S_I_I(b)); FREESELF(a); if (rest >= 0) M_I_I(rest,a); else if (S_I_I(b) > 0) M_I_I(rest+S_I_I(b),a); else M_I_I(rest-S_I_I(b),a); } else WTO("mod_apply_longint(2)",b); ENDR("mod_apply_longint"); } INT ganzdiv_apply_longint_integer(a,b) OP a,b; /* a = a/b a is of type longint */ /* AK 081001 */ { INT erg = OK; INT rest; CTO(LONGINT,"ganzdiv_apply_longint_integer(1)",a); CTO(INTEGER,"ganzdiv_apply_longint_integer(2)",b); erg += ganzsquores(S_O_S(a).ob_longint,&rest,S_I_I(b)); T_LONGINT_INT(a); ENDR("ganzdiv_apply_longint_integer"); } INT ganzdiv_apply_longint_longint(a,b) OP a,b; /* a = a/b a is of type longint */ /* AK 081001 */ { INT erg = OK; OP c; CTO(LONGINT,"ganzdiv_apply_longint_longint(1)",a); CTO(LONGINT,"ganzdiv_apply_longint_longint(2)",b); c = CALLOCOBJECT(); INIT_LONGINT(c); erg += ganzquores(S_O_S(a).ob_longint, S_O_S(c).ob_longint, S_O_S(b).ob_longint); FREEALL(c); T_LONGINT_INT(a); ENDR("ganzdiv_apply_longint_longint"); } INT ganzdiv_apply_longint(a,b) OP a,b; /* a = a/b a is of type longint */ /* AK 081001 */ { INT erg = OK; CTO(LONGINT,"ganzdiv_apply_longint(1)",a); if (S_O_K(b) == INTEGER) { erg += ganzdiv_apply_longint_integer(a,b); } else if (S_O_K(b) == LONGINT) { erg += ganzdiv_apply_longint_longint(a,b); } else WTO("ganzdiv_apply_longint",b); ee: ENDR("ganzdiv_apply_longint"); } INT ganzdiv_longint_longint(a,b,c) OP a,b,c; /* AK 291001 */ { OP d; INT erg = OK; CTO(LONGINT,"ganzdiv_longint_longint(1)",a); CTO(LONGINT,"ganzdiv_longint_longint(2)",b); CTO(EMPTY,"ganzdiv_longint_longint(3)",c); if (NULLP_LONGINT(a)) { /* AK 060502 */ M_I_I(0,c); goto ee; } erg += copy_longint(a,c); d = CALLOCOBJECT(); INIT_LONGINT(d); erg += ganzquores(S_O_S(c).ob_longint, S_O_S(d).ob_longint,S_O_S(b).ob_longint); T_LONGINT_INT(c); FREEALL(d); ee: ENDR("ganzdiv_longint_longint"); } INT ganzdiv_longint_integer(a,b,c) OP a,b,c; /* AK 291001 */ { INT d; INT erg = OK; CTO(LONGINT,"ganzdiv_longint_integer(1)",a); CTO(INTEGER,"ganzdiv_longint_integer(2)",b); CTO(EMPTY,"ganzdiv_longint_integer(3)",c); if (NULLP_LONGINT(a)) { /* AK 060502 */ M_I_I(0,c); goto ee; } erg += copy_longint(a,c); erg += ganzsquores(S_O_S(c).ob_longint,&d, S_I_I(b)); T_LONGINT_INT(c); ee: ENDR("ganzdiv_longint_integer"); } INT ganzdiv_integer_longint(a,b,c) OP a,b,c; /* AK 291001 */ { OP d; INT erg = OK; CTO(LONGINT,"ganzdiv_longint_integer(2)",b); CTO(INTEGER,"ganzdiv_longint_integer(1)",a); CTO(EMPTY,"ganzdiv_longint_integer(3)",c); d = CALLOCOBJECT(); erg += m_i_longint(S_I_I(a),d); CTO(LONGINT,"ganzdiv_integer_longint(id)",d); erg += ganzdiv_longint_longint(d,b,c); FREEALL(d); ENDR("ganzdiv_integer_longint"); } INT addinvers_longint(a,l) OP a,l; /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 201289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"addinvers_longint(1)",a); CTO(EMPTY,"addinvers_longint(2)",l); erg += copy_longint(a,l); GANZNEG(S_O_S(l).ob_longint); /* longinteger-addinvers ist x:= -x */ ENDR("addinvers_longint"); } INT invers_apply_longint(l) OP l; /* AK 040901 */ { OP c; INT erg = OK; CTO(LONGINT,"invers_apply_longint(1)",l); if (einsp_longint(l)) erg += m_i_i(1L,l); else { #ifdef BRUCHTRUE c = callocobject(); erg += swap(l,c); erg += b_ou_b(callocobject(),c,l); M_I_I(1L,S_B_O(l)); #endif /* BRUCHTRUE */ } ENDR("invers_apply_longint"); } INT add_apply_longint(a,b) OP a,b; /* AK 120390 V1.1 */ /* AK 190291 V1.2 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"add_apply_longint(1)",a); switch (S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: erg += add_apply_scalar_bruch(a,b); break; #endif /* BRUCHTRUE */ case INTEGER: erg += add_apply_longint_integer(a,b); break; case LONGINT: erg += add_apply_longint_longint(a,b); break; default: /* AK 190291 */ { OP c = callocobject(); *c = *b; C_O_K(b,EMPTY); erg += add_longint(a,c,b); erg += freeall(c); } break; } ENDR("add_apply_longint"); } #ifdef MATRIXTRUE INT mult_apply_longint_matrix(a,b) OP a,b; /* AK 220390 V1.1 */ /* AK 190291 V1.2 */ /* AK 210891 V1.3 */ { OP z = S_M_S(b); INT i; INT erg=OK; CTO(LONGINT,"mult_apply_longint_matrix(1)",a); CTO(MATRIX,"mult_apply_longint_matrix(2)",b); i = S_M_HI(b)*S_M_LI(b); for(;i>0;i--,z++) erg += mult_apply_longint(a,z); ENDR("mult_apply_longint_matrix"); } #endif /* MATRIXTRUE */ INT mult_apply_longint(a,b) OP a,b; /* AK 080390 V1.1 */ /* AK 190291 V1.2 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"mult_apply_longint",a); switch (S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: erg += mult_apply_longint_bruch(a,b); break; #endif /* BRUCHTRUE */ case INTEGER: erg += mult_apply_longint_integer(a,b); break; case LONGINT: erg += mult_apply_longint_longint(a,b); break; #ifdef MATRIXTRUE case KRANZTYPUS: case MATRIX: erg += mult_apply_longint_matrix(a,b); break; #endif /* MATRIXTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += mult_apply_scalar_symchar(a,b); break; #endif /* CHARTRUE */ #ifdef POLYTRUE case MONOM: erg += mult_apply_scalar_monom(a,b); break; case SCHUR: case POW_SYM: case ELM_SYM: case HOM_SYM: case MONOMIAL: case SCHUBERT: case GRAL: case POLYNOM: case MONOPOLY: erg += mult_apply_longint_polynom(a,b); break; #endif /* POLYTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: erg += mult_apply_scalar_sqrad(a,b); break; case CYCLOTOMIC: erg += mult_apply_scalar_cyclo(a,b); break; #endif /* NUMBERTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case COMPOSITION: case WORD: case VECTOR: erg += mult_apply_scalar_vector(a,b); break; case HASHTABLE: erg += mult_apply_scalar_hashtable(a,b); break; #endif /* VECTORTRUE */ default: /* AK 190291 */ { OP c = callocobject(); INT erg=OK; *c = *b; C_O_K(b,EMPTY); erg += mult(a,c,b); erg += freeall(c); } } ENDR("mult_apply_longint"); } INT add_apply_longint_longint(a,b) OP a,b; /* AK 120390 V1.1 */ /* AK 050791 V1.3 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"add_apply_longint_longint(1)",a); CTO(LONGINT,"add_apply_longint_longint(2)",b); if (GANZSIGNUM(S_O_S(a).ob_longint) == GANZSIGNUM(S_O_S(b).ob_longint)) erg += ganzadd(S_O_S(b).ob_longint,S_O_S(a).ob_longint); else { erg += ganzadd(S_O_S(b).ob_longint,S_O_S(a).ob_longint); T_LONGINT_INT(b); } ENDR("add_apply_longint_longint"); } INT mult_apply_longint_longint(a,b) OP a,b; /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; OBJECTSELF as,bs; CTO(LONGINT,"mult_apply_longint_longint(1)",a); CTO(LONGINT,"mult_apply_longint_longint(2)",b); as = S_O_S(a); bs = S_O_S(b); erg += ganzmul(bs.ob_longint,as.ob_longint); ENDR("mult_apply_longint_longint"); } INT add_apply_longint_integer(a,b) OP a,b; /* AK 120390 V1.1 */ /* AK 050791 V1.3 */ { INT erg = OK; OP c; CTO(LONGINT,"add_apply_longint_integer(1)",a); CTO(INTEGER,"add_apply_longint_integer(2)",b); c = CALLOCOBJECT(); *c = *b; C_O_K(b,EMPTY); erg += add_longint_integer(a,c,b); FREEALL(c); ENDR("add_apply_longint_integer"); } INT mult_apply_longint_integer(a,b) OP a,b; /* AK 080390 V1.1 */ /* AK 050791 V1.3 */ { OP c; INT erg = OK; CTO(INTEGER,"mult_apply_longint_integer(2)",b); CTO(LONGINT,"mult_apply_longint_integer(1)",a); c = CALLOCOBJECT(); *c = *b; C_O_K(b,EMPTY); erg += mult_longint_integer(a,c,b); FREEALL(c); CTTO(LONGINT,INTEGER,"mult_apply_longint_integer(e2)",b); /* INTEGER if b==0 */ ENDR("mult_apply_longint_integer"); } INT add_apply_integer_longint(a,b) OP a,b; /* b = a + b */ /* b ist LONGINT, a ist INTEGER */ /* AK 120390 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(INTEGER,"add_apply_integer_longint(1)",a); CTO(LONGINT,"add_apply_integer_longint(2)",b); erg += ganzsadd(S_O_S(b).ob_longint,S_I_I(a)); T_LONGINT_INT(b); ENDR("add_apply_integer_longint"); } INT mult_apply_integer_longint(a,b) OP a,b; /* b = a * b */ /* b ist LONGINT, a ist INTEGER */ /* AK 080290 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(INTEGER,"mult_apply_integer_longint(1)",a); CTO(LONGINT,"mult_apply_integer_longint(2)",b); erg += ganzsmul(S_O_S(b).ob_longint,S_I_I(a)); ENDR("mult_apply_integer_longint"); } INT mult_longint_integer_via_ganzsmul(a,c,l) OP a,c,l; /* a ist LONINT c ist INTEGER */ /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 080290 V1.1 */ /* AK 210891 V1.3 */ /* l = a+c */ { INT erg = OK; OBJECTSELF ls; CTO(INTEGER,"mult_longint_integer(2)",c); CTO(LONGINT,"mult_longint_integer(1)",a); CTO(EMPTY,"mult_longint_integer(3)",l); erg += copy_longint(a,l); ls = S_O_S(l); erg += ganzsmul(ls.ob_longint,S_I_I(c)); ENDR("mult_longint_integer"); } INT add_longint_integer(a,c,l) OP a,c,l; /* a is LONGINT c is INTEGER */ /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; OBJECTSELF ls; CTO(LONGINT,"add_longint_integer(1)",a); CTO(INTEGER,"add_longint_integer(2)",c); CTO(EMPTY,"add_longint_integer(3)",l); erg += copy_longint(a,l); ls = S_O_S(l); erg += ganzsadd(ls.ob_longint,S_I_I(c)); /* longinteger-addition ist x:= x+y */ erg += t_longint_int(l); ENDR("add_longint_integer"); } INT dec_longint(a) OP a; /* AK 230888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF as ; INT erg = OK; CTO(LONGINT,"dec_longint(1)",a); as = S_O_S(a); erg += ganzsadd(as.ob_longint,(INT)-1); ENDR("dec_longint"); } INT inc_longint(a) OP a; /* AK 230888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF as; INT erg = OK; CTO(LONGINT,"inc_longint(1)",a); as = S_O_S(a); erg += ganzsadd(as.ob_longint,1); ENDR("inc_longint"); } INT t_longint_int(a) OP a; /* AK 150290 V1.1 */ /* umwandlung in INTEGER falls moeglich */ /* AK 210891 V1.3 */ { OBJECTSELF cs; INT wert; INT erg = OK; if (S_O_K(a) == INTEGER) return OK; CTO(LONGINT,"t_longint_int(1)",a); cs = S_O_S(a); if (cs.ob_longint ->laenge == (INT)1) if (cs.ob_longint ->floc ->w2 <= 1) /* AK 051101 */ { wert = intganz(cs.ob_longint); FREESELF(a); M_I_I(wert,a); } ENDR("t_longint_int"); } INT einsp_longint(a) OP a; /* AK 271190 V1.1 */ /* AK 250291 V1.2 */ /* AK 210891 V1.3 */ { OBJECTSELF cs; cs = S_O_S(a); if (cs.ob_longint ->laenge == 1) if (cs.ob_longint ->signum == 1) if (cs.ob_longint ->floc ->w2 ==0) if (cs.ob_longint ->floc ->w1 ==0) if (cs.ob_longint ->floc ->w0 ==1) return TRUE; return FALSE; } INT negeinsp_longint(a) OP a; /* AK 070502 */ { OBJECTSELF cs; cs = S_O_S(a); if (cs.ob_longint ->laenge == 1) if (cs.ob_longint ->signum == -1) if (cs.ob_longint ->floc ->w2 ==(INT)0) if (cs.ob_longint ->floc ->w1 ==(INT)0) if (cs.ob_longint ->floc ->w0 == (INT)1) return TRUE; return FALSE; } INT t_int_longint(a,c) OP a,c; /* umwandeln von INTEGER -> LONGINT AK 180888 */ /* AK 130789 V1.0 */ /* AK 150290 V1.1 */ /* AK 250391 V1.2 */ /* AK 210891 V1.3 */ { /* it is possible a == c */ INT erg = OK; INT av = S_I_I(a); struct longint *x; CTO(INTEGER,"t_int_longint(1)",a); FREESELF(c); INIT_LONGINT(c); x = S_O_S(c).ob_longint; if (av==0) /* AK 060502 */ { x->laenge = 0; x->signum = 0; FREE_LOC(x->floc); x->floc = NULL; goto ee; } x->laenge = 1; if (av == MAXNEG) { x->signum = (signed char)locint(x->floc,av+1); ganzsadd(x,(INT)-1); } else x->signum = (signed char)locint(x->floc,av); ee: CTO(LONGINT,"t_int_longint(e2)",c); ENDR("t_int_longint"); } INT comp_longint_integer(a,c) OP a,c; /* AK 011101 */ { INT erg = OK; CTO(LONGINT,"comp_longint(1)",a); CTO(INTEGER,"comp_longint(2)",c); if (NEGP_LONGINT(a)) { if (not NEGP_INTEGER(c)) return -1; /* beide negativ */ if (GANZLAENGE(S_O_S(a).ob_longint) > 1) return -1; if (GANZLAENGE(S_O_S(a).ob_longint) == 1) if ((S_O_S(a).ob_longint) -> floc -> w2 > 1 ) return -1; } else{ if (NEGP_INTEGER(c)) return 1; /* beide positiv */ if (GANZLAENGE(S_O_S(a).ob_longint) > 1) return 1; if (GANZLAENGE(S_O_S(a).ob_longint) == 1) if ((S_O_S(a).ob_longint) -> floc -> w2 > 1 ) return 1; } T_LONGINT_INT(a); CTO(INTEGER,"comp_longint_integer(i1)",a); return COMP_INTEGER_INTEGER(a,c); ENDR("comp_longint_integer"); } INT eq_longint_longint(a,b) OP a,b; /* AK 010202 */ { INT erg = OK; struct longint *al, *bl; struct loc *locxa, *locxb; CTO(LONGINT,"eq_longint_longint(1)",a); CTO(LONGINT,"eq_longint_longint(2)",b); al = S_O_S(a).ob_longint; bl = S_O_S(b).ob_longint; if (al -> signum != bl -> signum) return FALSE; if (al -> laenge != bl -> laenge) return FALSE; locxa = al->floc; locxb = bl->floc; while (locxa != NULL) { if ( (locxa->w0) != (locxb->w0)) return FALSE; if ( (locxa->w1) != (locxb->w1)) return FALSE; if ( (locxa->w2) != (locxb->w2)) return FALSE; locxa = locxa ->nloc; locxb = locxb ->nloc; } return TRUE; ENDR("eq_longint_longint"); } INT comp_longint(a,c) OP a,c; /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */ { OP d; INT erg=OK; CTO(LONGINT,"comp_longint(1)",a); switch(S_O_K(c)) { case INTEGER: return comp_longint_integer(a,c); case LONGINT: { OBJECTSELF as,cs; as=S_O_S(a); cs=S_O_S(c); erg = ganzvergleich(as.ob_longint, cs.ob_longint); return(erg); } #ifdef BRUCHTRUE case BRUCH: { d = callocobject(); m_scalar_bruch(a,d); erg = comp(d,c); freeall(d); return erg; } #endif /* BRUCHTRUE */ default: { WTO("comp_longint(2)",c); break; } }; ENDR("comp_longint"); } INT check_longint(a) OP a; /* AK 071294 */ /* test auf fuehrende Null */ { OBJECTSELF cs; struct loc *alocx; if (S_O_K(a) != LONGINT) return OK; cs = S_O_S(a); alocx = (cs.ob_longint)->floc; while (alocx != NULL) { if (alocx -> nloc == NULL) { if ((alocx->w0 == 0) && (alocx->w1 == 0) && (alocx->w2 == 0) ) error("internal error check_longint:"); } alocx = alocx->nloc; } return OK; } INT half_apply_longint(a) OP a; { INT erg = OK; CTO(LONGINT,"half_apply_longint(1)",a); /* erg += ganzhalf(S_O_S(a).ob_longint); */ psr_apply_i_longint(a,1); ENDR("half_apply_longint"); } INT psr_apply_i_integer(a,i) OP a; INT i; { INT erg = OK; CTO(INTEGER,"psr_apply_i_integer(1)",a); SYMCHECK(i<0,"psr_apply_i_integer:second parameter < 0"); SYMCHECK(S_I_I(a)<0,"psr_apply_i_integer:first parameter < 0"); if (i >= 32) M_I_I(0,a); else M_I_I(S_I_I(a) >> i, a); CTO(INTEGER,"psr_apply_i_integer",a); ENDR("psr_apply_i_integer"); } INT psl_apply_i_integer(a,i) OP a; INT i; { INT erg = OK; CTO(INTEGER,"psl_apply_i_integer(1)",a); SYMCHECK(i<0,"psl_apply_i_integer:second parameter < 0"); SYMCHECK(S_I_I(a)<0,"psl_apply_i_integer:first parameter < 0"); if ( (S_I_I(a) < 32768) /* 2^15 */ && ( i < 16) ) { M_I_I(S_I_I(a) << i, a); } else if ((S_I_I(a) < 8388608)/*2^23*/ && ( i < 8) ) { M_I_I(S_I_I(a) << i, a); } else if ((S_I_I(a) < 134217728)/*2^27*/ && ( i < 4) ) { M_I_I(S_I_I(a) << i, a); } else { erg += t_int_longint(a,a); erg += psl_apply_i_longint(a,i); } CTTO(INTEGER,LONGINT,"psl_apply_i_integer",a); ENDR("psl_apply_i_integer"); } INT psl_apply_i_longint(a,i) OP a; INT i; /* shift left i bits */ /* multiplication by 2^i */ { struct longint *l; struct loc *alocx; INT f,t,c,erg = OK;; CTO(LONGINT,"psl_apply_i_longint(1)",a); SYMCHECK(i<0,"psl_apply_i_longint:second parameter < 0"); l = S_O_S(a).ob_longint; again: alocx = l->floc; if (i >= 15) { t = 0; zz: f = alocx -> w2; alocx -> w2 = alocx -> w1; alocx -> w1 = alocx -> w0; alocx -> w0 = t; if (alocx -> nloc == NULL) { if ( f != 0 ) { LOCHOLE(& alocx -> nloc ); alocx -> nloc -> w0 = f; l->laenge ++; } i -= 15; goto again; } alocx = alocx ->nloc; t = f; goto zz; } /* block shifted */ SYMCHECK(i >= 15,"psl_apply_i_longint(i1)"); if (i==0) goto ende; c = 0; for (t=0;t>=1; c|=16384;/* 2^15 */ } t=0; xx: f = (alocx -> w2 & c) >> (15-i);; alocx -> w2 <<=i; alocx -> w2 &= (BMINUSEINS); alocx -> w2 |= (alocx -> w1 & c ) >> (15-i); alocx -> w1 <<=i; alocx -> w1 &= (BMINUSEINS); alocx -> w1 |= (alocx -> w0 & c ) >> (15-i); alocx -> w0 <<=i; alocx -> w0 &= (BMINUSEINS); alocx -> w0 |= t; if (alocx ->nloc == NULL) { if ( f != 0 ) { LOCHOLE(& alocx -> nloc ); alocx -> nloc -> w0 = f; l->laenge ++; } } else { t = f; alocx = alocx ->nloc; goto xx; } ende: CTO(LONGINT,"psl_apply_i_longint(e1)",a); ENDR("psl_apply_i_longint"); } INT psr_apply_i_longint(a,i) OP a; INT i; { struct longint *l; struct loc *alocx,*plocx; INT f,t,c,erg = OK;; CTO(LONGINT,"psr_apply_i_longint(1)",a); SYMCHECK(i<0,"psr_apply_i_longint:second parameter < 0"); l = S_O_S(a).ob_longint; again: alocx = l->floc; if (i >= 15) { zz: alocx -> w0 = alocx ->w1; alocx -> w1 = alocx ->w2; if (alocx -> nloc == NULL) { alocx ->w2 = 0; i -= 15; goto again; } else { alocx ->w2 = alocx -> nloc -> w0; if ( ( alocx -> nloc -> w1 == 0 ) && ( alocx -> nloc -> w2 == 0 ) && ( alocx -> nloc -> nloc == NULL ) ) { l -> laenge --; FREE_LOC(alocx -> nloc); alocx -> nloc = NULL; i -= 15; goto again; } alocx = alocx -> nloc; goto zz; } } /* block shifted */ SYMCHECK(i >= 15,"psr_apply_i_longint(i1)"); if (i==0) goto ende; c = i; t=0; f = 15-i; while (i--) {t<<=1; t |= 1;} /* now i bits shifted to the right */ alocx -> w0 >>= c; alocx -> w0 |= ( ( alocx -> w1 & t ) << f ); alocx -> w1 >>= c; alocx -> w1 |= ( ( alocx -> w2 & t ) << f ); alocx -> w2 >>= c; if (alocx ->nloc != NULL) alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f ); plocx = alocx; alocx = alocx ->nloc; while (alocx != NULL) { alocx -> w0 >>= c; alocx -> w0 |= ( ( alocx -> w1 & t ) << f ); alocx -> w1 >>= c; alocx -> w1 |= ( ( alocx -> w2 & t ) << f ); alocx -> w2 >>= c; if (alocx ->nloc != NULL) alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f ); if ( (alocx -> nloc == NULL) && (alocx->w0 == 0) && (alocx->w1 == 0)&& (alocx->w2 == 0) ) { l -> laenge --; FREE_LOC(alocx); plocx->nloc = NULL; goto ende; } plocx = alocx; alocx = alocx ->nloc; } ende: T_LONGINT_INT(a); CTTO(INTEGER,LONGINT,"psr_apply_i_longint(e1)",a); ENDR("psr_apply_i_longint"); } INT oddify_longint(a) OP a; { struct longint *l; struct loc *alocx,*plocx; INT f,t,c,erg = OK;; CTO(LONGINT,"oddify_longint(1)",a); l = S_O_S(a).ob_longint; again: alocx = l->floc; if (alocx -> w0 == 0) { zz: alocx -> w0 = alocx ->w1; alocx -> w1 = alocx ->w2; if (alocx -> nloc == NULL) { alocx ->w2 = 0; goto again; } else { alocx ->w2 = alocx -> nloc -> w0; if ( ( alocx -> nloc -> w1 == 0 ) && ( alocx -> nloc -> w2 == 0 ) && ( alocx -> nloc -> nloc == NULL ) ) { l -> laenge --; FREE_LOC(alocx -> nloc); alocx -> nloc = NULL; goto again; } alocx = alocx -> nloc; goto zz; } } c = 0; t=0; f=15; /* max 14 bits */ while ( not (alocx -> w0 & 1) ) { c++; alocx -> w0 >>= 1; t<<=1; t |= 1; f--;} if (c == 0) goto ende; alocx -> w0 |= ( ( alocx -> w1 & t ) << f ); alocx -> w1 >>= c; alocx -> w1 |= ( ( alocx -> w2 & t ) << f ); alocx -> w2 >>= c; if (alocx ->nloc != NULL) alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f ); plocx = alocx; alocx = alocx ->nloc; while (alocx != NULL) { alocx -> w0 >>= c; alocx -> w0 |= ( ( alocx -> w1 & t ) << f ); alocx -> w1 >>= c; alocx -> w1 |= ( ( alocx -> w2 & t ) << f ); alocx -> w2 >>= c; if (alocx ->nloc != NULL) alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f ); if ( (alocx -> nloc == NULL) && (alocx->w0 == 0) && (alocx->w1 == 0)&& (alocx->w2 == 0) ) { l -> laenge --; FREE_LOC(alocx); plocx->nloc = NULL; goto ende; } plocx = alocx; alocx = alocx ->nloc; } ende: t_longint_int(a); SYMCHECK(EVEN(a),"oddify_longint(e1)"); CTTO(INTEGER,LONGINT,"oddify_longint(e1)",a); ENDR("oddify_longint"); } INT psl_apply_longint(a) OP a; /* double */ { INT erg = OK; CTO(LONGINT,"psl_apply_longint(1)",a); erg += psl_apply_i_longint(a,1); CTO(LONGINT,"psl_apply_longint(e1)",a); ENDR("psl_apply_longint"); } INT double_apply_longint(a) OP a; /* AK 010202 */ { INT erg = OK; CTO(LONGINT,"double_apply_longint(1)",a); erg += psl_apply_longint(a); ENDR("double_apply_longint"); } INT quores_longint(a,e,c,d) OP a,e,c,d; /* ganzdiv AK 220888 */ /* c = a / e */ /* d ist rest */ /* AK 130789 V1.0 */ /* AK 150290 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(LONGINT,"quores_longint(1)",a); CTO(EMPTY,"quores_longint(3)",c); CTO(EMPTY,"quores_longint(4)",d); switch (S_O_K(e)) { case INTEGER: { OBJECTSELF cs; INT rest; erg += copy_longint(a,c); cs = S_O_S(c); erg += ganzsquores(cs.ob_longint,&rest,S_I_I(e)); erg += t_longint_int(c); M_I_I(rest,d); goto ql_040393; } case LONGINT: { OBJECTSELF es,cs,ds; erg += copy_longint(a,c); INIT_LONGINT(d); cs = S_O_S(c); es = S_O_S(e); ds = S_O_S(d); erg += ganzquores(cs.ob_longint, ds.ob_longint,es.ob_longint); erg += t_longint_int(c); erg += t_longint_int(d); goto ql_040393; } default: { WTO("quores_longint(2)",e); goto ende; } }; ql_040393: if (negp(d)) if (posp(e)) { erg += add_apply(e,d); erg += dec(c); } else if (negp(e)) { erg += sub(d,e,d); erg += inc(c); } ende: ENDR("quores_longint"); } INT scan_longint(a) OP a; /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF as; printeingabe("longint:"); init(LONGINT,a);as=S_O_S(a); ganzein(stdin,as.ob_longint); if (nullp_longint(a) ) { /* AK 020889 V1.0 */ M_I_I((INT)0,a); } return(OK); } INT posp_longint(a) OP a; /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ /* true if a > 0 */ { OBJECTSELF as; as=S_O_S(a); return GANZSIGNUM(as.ob_longint) == (INT)1; } INT odd_longint(a) OP a; /* AK 061190 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF as; as=S_O_S(a); return ganzodd(as.ob_longint); } INT even_longint(a) OP a; /* AK 061190 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF as; as=S_O_S(a); return ganzeven(as.ob_longint); } INT nullp_longint(a) OP a; /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { INT s; INT erg = OK; OBJECTSELF as; CTO(LONGINT,"nullp_longint(1)",a); as=S_O_S(a); s = GANZSIGNUM(as.ob_longint); if (s != 0) return FALSE; SYMCHECK ((as.ob_longint)->laenge != 0,"nullp_longint:zero wioth wrong length"); return TRUE; ENDR("nullp_longint"); } INT negp_longint(a) OP a; /* AK 190888 */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF as; as=S_O_S(a); return(GANZSIGNUM(as.ob_longint) == -1); } INT objectread_longint(f,l) FILE *f; OP l; /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF ls; INT erg = OK; COP("objectread_longint(1)",f); CTO(EMPTY,"objectread_longint(2)",l); erg += init(LONGINT,l); ls=S_O_S(l); erg += ganzein(f, ls.ob_longint); ENDR("objectread_longint"); } INT objectwrite_longint(f,l) FILE *f; OP l; /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; OBJECTSELF ls; COP("objectwrite_longint(1)",f); CTO(LONGINT,"objectwrite_longint(2)",l); if (nullp_longint(l)) { /* AK 020889 V1.0 */ erg += m_i_i((INT)0,l); erg += objectwrite_integer(f,l); goto owlende; } fprintf(f," %ld ",LONGINT); ls=S_O_S(l); erg += ganzaus(f, ls.ob_longint); fprintf(f,"\n"); owlende: ENDR("objectwrite_longint"); } INT m_i_longint(a,b) OP b;INT a; /* AK 180888 */ /* AK 270689 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */ { OP c; INT erg = OK; COP("m_i_longint(2)",b); c = CALLOCOBJECT(); M_I_I(a,c); /* make INT --> INTEGER */ erg += t_int_longint(c,b); /* transform INTEGER --> LONGINT */ FREEALL(c); CTO(LONGINT,"m_i_longint(e2)",b); ENDR("m_i_longint"); } INT debugprint_longint(a) OP a; /* AK 020390 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF c; INT k; struct loc *alocx; c = s_o_s(a); for (k=0L;klaenge); for (k=0L;ksignum); alocx = c.ob_longint->floc; /* AK 071294 */ while (alocx != NULL) { for (k=0L;kw0,alocx->w1,alocx->w2); alocx= alocx->nloc; } return(OK); } INT sscan_longint(t,a) char *t; OP a; { INT erg = OK; INT vz=(INT)1; char c; OP zehn, faktor; int SYM_isdigit(); COP("sscan_longint(1)",t); CTO(EMPTY,"sscan_longint(2)",a); zehn = callocobject(); M_I_I((INT)10,zehn); faktor = callocobject(); m_i_i((INT)0,a); slagain: c = *t++; if (c == '\0') { erg = ERROR; goto sle; } if (c == ' ') goto slagain; if (c == '-') { if (vz == (INT)-1) { erg = ERROR; goto sle; } vz = (INT)-1; goto slagain; } if (not SYM_isdigit(c)) { erg = ERROR; goto sle; } slb: erg += mult_apply(zehn,a); erg += m_i_i((INT)9-('9'-c),faktor); erg += add_apply(faktor,a); c = *t++; if (c == '\0') { goto sle; } if (not SYM_isdigit(c)) { erg = ERROR; goto sle; } goto slb; sle: erg += freeall(zehn); erg += freeall(faktor); if (vz == (INT)-1) erg += addinvers_apply(a); ENDR("sscan_longint"); } INT test_longint() { /* AK 020390 V1.1 */ /* AK 210891 V1.3 */ OP a = callocobject(); OP b = callocobject(); OP c = callocobject(); start_longint(); printf("test_longint:scan(a)"); scan(LONGINT,a);println(a); printf("test_longint:add(a,a,b)"); add(a,a,b); println(b); printf("test_longint:mult(a,b,b)"); mult(a,b,b); println(b); printf("test_longint:m_i_i((INT)-1,c);mult(c,b,b)"); m_i_i((INT)-1,c); mult(c,b,b); println(b); printf("test_longint:m_i_i((INT)-1,c);add(c,b,b)"); m_i_i((INT)-1,c); add(c,b,b); println(b); #ifdef BRUCHTRUE printf("test_longint:invers(b,a)"); invers(b,a); println(a); #endif /* BRUCHTRUE */ printf("test_longint:mult(b,a,a)"); mult(b,a,a); println(a); printf("test_longint:m_i_i((INT)3,c);div(a,c,b)"); m_i_i((INT)3,c); div(a,c,b); println(b); printf("test_longint:m_i_i((INT)100,c);fakul(c,b)"); m_i_i((INT)100,c); fakul(c,b); println(b); freeall(a);freeall(b);freeall(c); return(OK); } INT random_longint(res,ober) OP res,ober; /* AK 080390 V1.1 */ /* ober ist beim ersten aufruf die obere grenze, spater NULL */ /* AK 210891 V1.3 */ { INT l,i; INT erg = OK; /* AK 030893 */ OP h1,h2,h3; COP("random_longint(1)",res); if (ober == NULL) { if (rl_o == NULL) return( error("random_longint: no initialisation")); } else { CTO(LONGINT,"random_longint(2)",ober); if (rl_o == NULL) { rl_o=callocobject(); rl_a=callocobject(); rl_x=callocobject(); rl_m=callocobject(); } else { erg += freeself(rl_o); erg += freeself(rl_a); erg += freeself(rl_x); erg += freeself(rl_m); } erg += copy(ober,rl_o); h1 = callocobject(); h2 = callocobject(); h3 = callocobject(); l = (S_O_S(ober).ob_longint->laenge) * 3 ; /* laenge */ erg += m_i_i((INT)10,rl_m); erg += m_i_i(l*(INT)6,h1); erg += hoch(rl_m,h1,rl_m); erg += m_i_i((INT)222222,rl_a); erg += m_i_i((INT)1000000,h2); erg += m_i_i((INT)222222,h1); erg += m_i_i((INT)0,rl_x); for (i=1;i<=l;i++) { MULT_APPLY(h2,rl_a); ADD_APPLY(h1,rl_a); erg += random_integer(h3,NULL,h2); MULT_APPLY(h2,rl_x); ADD_APPLY(h3,rl_x); } erg += mod(rl_x,rl_o,res); erg += freeall(h1); erg += freeall(h2); erg += freeall(h3); goto rl_ende; } /* dies ist der fall dass initialisiert ist */ h1 = callocobject(); erg += mult(rl_x,rl_a,h1); erg += mod(h1,rl_m,rl_x); erg += mod(rl_x,rl_o,res); FREEALL(h1); rl_ende: ENDR("random_longint"); } #endif /* LONGINTTRUE */ symmetrica-2.0/lo.doc0000600017361200001450000000515010726170275014506 0ustar tabbottcrontabCOMMENT: LONGINT ------- There is no documentation on the internal structure of the longinter arithmetic. NAME: mult_longint SYNOPSIS: INT mult_longint(OP a,b,c) DESCRIPTION: this is a undocumented subroutine of INT mult(OP a,b,c) You better use this general routine. NAME: add_longint SYNOPSIS: INT add_longint(OP a,b,c) DESCRIPTION: this is a undocumented subroutine of INT add(OP a,b,c) You better use this general routine. NAME: invers_longint SYNOPSIS: INT invers_longint(OP a,b) DESCRIPTION: this is a undocumented subroutine of INT invers(OP a,b) You better use this general routine. NAME: copy_longint SYNOPSIS: INT copy_longint(OP a,b) DESCRIPTION: this is a undocumented subroutine of INT copy(OP a,b) You better use this general routine. NAME: dec_longint SYNOPSIS: INT dec_longint(OP a) DESCRIPTION: this is a undocumented subroutine of INT dec(OP a). The INTEGER object a is decreased by 1. You better use the general routine dec. NAME: tex_longint SYNOPSIS: INT tex_longint(OP a) DESCRIPTION: this is a undocumented subroutine of INT tex(OP a). The INTEGER object a is transformed into tex-source-code. You better use the general routine tex. NAME: inc_longint SYNOPSIS: INT inc_longint(OP a) DESCRIPTION: this is a undocumented subroutine of INT inc(OP a). The INTEGER object a is increased by 1. You better use the general routine inc. NAME: random_longint SYNOPSIS: INT random_longint(OP a,b) DESCRIPTION: this computes a pseudo-random LONGINT number. There are two possible calls, if b is a LONGINT number, it is a new limit for the random LONGINT objects, if it is NULL the old limit is used. The first limit is set during initialisation of SYMMETRICA. COMMENT: There is a pair of routines for the transformation from LONGINT to INT and vice versa. NAME: t_int_longint SYNOPSIS: INT t_int_longint(OP a,b) DESCRIPTION: transforms the INTEGER object a into LONGINT object b. a and b may be equal objects. RETURN: OK if no error NAME: t_longint_int SYNOPSIS: INT t_longint_int(OP a) DESCRIPTION: transforms the LONGINT object a into an INTEGER object, if it is possible, this means that the number which is represented by a, is small enough. RETURN: OK if no error COMMENT: GENERAL ROUTINES ---------------- add() add_apply() invers() mult() mult_apply() scan() sscan(); tex() tex-output symmetrica-2.0/ma.c0000400017361200001450000017306310726021614014145 0ustar tabbottcrontab/* file: matrix.c */ /* AK 091086 */ #include "def.h" #include "macro.h" #ifdef MATRIXTRUE static struct matrix * callocmatrix(); static INT scan_matrix_co(); static INT transform_matrix(a,f,b) OP a,b; INT (*f)(); { INT e = 0L; INT i,j,erg = OK; CTO(MATRIX,"transform_matrix(1)",a); if (a==b) { OP c = callocobject(); *c = *a; C_O_K(b,EMPTY); e = 1L; a = c; } m_ilih_m(S_M_LI(a),S_M_HI(a),b); for (i=0L;i ml) ml = S_V_LI(S_V_I(a,i)); } /* now vector of vector == we can cast */ b = callocobject(); *b = *a; C_O_K(a,EMPTY); erg += m_ilih_m(ml,S_V_LI(b),a); for (i=0;i=0;i--,z++) erg += mem_size(z); return erg; } INT mod_matrix(a,b,c) OP a,b,c; /* AK 300793 */ { INT erg = OK; INT i,j; CTO(MATRIX,"mod_matrix(1)",a); CTO(INTEGER,"mod_matrix(2)",b); CTO(EMPTY,"mod_matrix(3)",c); erg += m_ilih_m(S_M_LI(a),S_M_HI(a),c); for (i=0L;i1;i--,z++) ADD_APPLY(z, b); } ENDR("sum_matrix"); } INT nullp_integermatrix(a) OP a; /* AK 150802 */ /* AK 060704 V3.0 */ { INT erg = OK; CTO(INTEGERMATRIX,"nullp_integermatrix(1)",a); { INT i,j; for (i=0L;i= S_M_HI(a), "delete_row_matrix: index too big"); SYMCHECK(index < 0,"delete_row_matrix: index < 0"); if (a==b) { /* AK 201204 */ OP z,w; for (z=S_M_IJ(a,index,0),i=0;i= S_M_LI(a),"delete_column_matrix: index too big"); SYMCHECK(index <0,"delete_column_matrix: index < 0"); { INT i,j; if (a==b) { OP c = CALLOCOBJECT(); *c = *b; C_O_K(b,EMPTY); erg += delete_column_matrix(c,index,b); FREEALL(c); goto endr_ende; } erg += m_ilih_m(S_M_LI(a)-1L,S_M_HI(a),b); C_O_K(b,S_O_K(a)); for (j=0;j0L; i--,z++) M_I_I(0L,z); ENDR("m_ilih_nm"); } INT m_lh_nm(l,h,m) OP l,h,m; /* AK 110691 V1.2 */ /* mit 0 vorbesetzen */ /* make_length_height_null_matrix */ /* AK 210891 V1.3 */ { INT i,erg = OK; OP z; CTO(INTEGER,"m_lh_nm(1)",l); CTO(INTEGER,"m_lh_nm(2)",h); SYMCHECK(S_I_I(l) < 0,"m_lh_nm:l<0"); SYMCHECK(S_I_I(h) < 0,"m_lh_nm:h<0"); erg += m_lh_m(l,h,m); for (z=S_M_S(m), i=S_M_HI(m) * S_M_LI(m); i>0L; i--,z++) M_I_I(0L,z); ENDR("m_lh_nm"); } INT b_lh_nm(l,h,m) OP l,h,m; /* AK 110691 V1.2 */ /* mit 0 vorbesetzen */ /* build_length_height_null_matrix */ /* AK 210891 V1.3 */ { INT i,erg = OK; OP z; CTO(INTEGER,"b_lh_nm",l); CTO(INTEGER,"b_lh_nm",h); erg += b_lh_m(l,h,m); for (z=S_M_S(m), i=S_M_HI(m) * S_M_LI(m); i>0L; i--,z++) M_I_I(0L,z); ENDR("b_lh_nm"); } INT b_lh_m(l,h,m) OP l,h,m; /* build_length_height_matrix */ /* height und length werden nicht kopiert */ /* AK 250590 V1.1 */ /* AK 110691 V1.2 */ /* AK 210891 V1.3 */ { OP s; INT i; INT erg = OK; CTO(INTEGER,"b_lh_m",l); CTO(INTEGER,"b_lh_m",h); i = S_I_I(l)*S_I_I(h); if (i < 0) { erg += error("b_lh_m:negative values for dimension of a matrix"); } else if (i==0) { erg += b_lhs_m(l,h,NULL,m); } else { s = (OP) SYM_malloc(S_I_I(l)*S_I_I(h)*sizeof(struct object)); for (i=0L;i S_P_II(a,i+1)) return FALSE; if (i > 0) if (S_P_II(a,i) < S_P_II(a,i-2)) return FALSE; } return TRUE; } INT pfaffian_matrix(mat,res) OP mat,res; /* berechnet pfaffian */ /* AK 050995 */ { OP perm,zwerg,zzerg; INT erg = OK; CTO(MATRIX,"pfaffian_matrix(1)",mat); SYMCHECK(not quadraticp(mat),"pfaffian:not quadratic matrix"); SYMCHECK(not evenp(S_M_H(mat)),"pfaffian:size of matrix not even"); perm = callocobject(); zwerg = callocobject(); zzerg = callocobject(); erg += first_permutation(S_M_H(mat),perm); erg += det050995(mat,perm,res); erg += signum(perm,zwerg); erg += mult_apply(zwerg,res); while (next(perm,perm)) { if (co_050995(perm) == TRUE) { erg += det050995(mat,perm,zwerg); erg += signum(perm,zzerg); erg += mult_apply(zwerg,zzerg); erg += add_apply(zzerg,res); } }; FREEALL3(perm,zwerg,zzerg); ENDR("pfaffian_matrix"); } INT immanente_matrix(mat,part,res) OP mat,part,res; /* berechnet immanente */ /* AK270588 */ /* AK 060789 V1.0 */ /* AK 090790 V1.1 */ /* AK 180691 V1.2 */ /* AK 210891 V1.3 */ /* AK 161098 V2.0 */ /* AK 130603 */ { OP perm,nextperm,zwerg,zzerg; INT i,erg = OK; CTTO(MATRIX,INTEGERMATRIX,"immanente_matrix(1)",mat); CTO(PARTITION,"immanente_matrix(2)",part); SYMCHECK(S_M_HI(mat) != S_M_LI(mat),"immanente_matrix:not quadratic matrix"); PARTITION_WEIGHT(part,i); /* AK 130603 */ SYMCHECK(i != S_M_HI(mat),"immanente_matrix:wrong weight of partition"); CE3(mat,part,res,immanente_matrix); perm = CALLOCOBJECT(); zwerg = CALLOCOBJECT(); zzerg = CALLOCOBJECT(); nextperm = CALLOCOBJECT(); erg += first_permutation(S_M_H(mat),perm); erg += det270588(mat,perm,res); erg += charvalue(part,perm,zwerg,NULL); MULT_APPLY(zwerg,res); while (next_apply(perm)) { erg += det270588(mat,perm,zwerg); erg += charvalue(part,perm,zzerg,NULL); MULT_APPLY(zzerg,zwerg); ADD_APPLY(zwerg,res); }; FREEALL4(zzerg,zwerg,perm,nextperm); ENDR("immanente_matrix"); } #endif /* CHARTRUE */ #endif /* PERMTRUE */ INT inc_matrix(a) OP a; /* 250488 */ /* AK 060789 V1.0 *//* AK 130790 V1.1 */ /* AK 180691 V1.2 */ /* AK 210891 V1.3 */ /* AK 240804 V3.0 */ { INT erg = OK; CTTO(MATRIX,INTEGERMATRIX,"inc_matrix(1)",a); { OP l,h; OP b; /* die neue matrix */ INT i,j; CALLOCOBJECT3(l,h,b); COPY_INTEGER(S_M_H(a),h); INC_INTEGER(h); COPY_INTEGER(S_M_L(a),l); INC_INTEGER(l); b_lh_m(l,h,b);C_O_K(b,S_O_K(a)); for (i=0L;ij){ for (k=0L;k<=n;k++) SWAP(S_M_IJ(b,j,k),S_M_IJ(b,r,k)); SWAP(S_V_I(p,j),S_V_I(p,r)); }; /*transformation*/ FREESELF(hr); INVERS(S_M_IJ(b,j,j),hr); for (i=0L;i<=n;i++) MULT_APPLY(hr,S_M_IJ(b,i,j)); CLEVER_COPY(hr,S_M_IJ(b,j,j)); ADDINVERS_APPLY(hr); for (k=0L;k<=n;k++) { if (k==j) k++; /* spalte j nicht anwenden */ if (k>n) break; for (i=0L;i<=n;i++) { if (i==j) i++; /* auf zeile j nicht anwenden */ if (i>n) break; MULT(S_M_IJ(b,i,j),S_M_IJ(b,j,k),hs); ADDINVERS_APPLY(hs); ADD_APPLY(hs,S_M_IJ(b,i,k)); FREESELF(hs); }; MULT_APPLY(hr,S_M_IJ(b,j,k)); }; }; /* end else */ }; /* end while */ // if (erg != OK) goto endr_ende; FREEALL2(hr,hs); erg+=m_il_v(n+1L,hv); if (not singulaer) /*spaltentausch*/ for (i=0L;i<=n;i++) { OP z; z = S_M_IJ(b,i,0); for (k=0;k<=n;k++,z++) CLEVER_COPY(z, S_V_I(hv,S_V_II(p,k))); z = S_M_IJ(b,i,0); for (k=0L;k<=n;k++,z++) CLEVER_COPY(S_V_I(hv,k), z); } FREEALL2(p,hv); if (singulaer) { freeself(b); error("invers_matrix: singulary"); return(SINGULAER); }; } ENDR("invers_matrix"); } INT transpose_matrix(a,b) OP a,b; /* AK 280388 */ /* AK 060789 V1.0 */ /* AK 310790 V1.1 */ /* AK 210891 V1.3 */ /* AK 081204 V3.0 */ /* AK 021106 V3.1 */ { INT erg = OK; CTO(MATRIX,"transpose_matrix(1)",a); CTO(EMPTY,"transpose_matrix(2)",b); { INT i,j; erg += m_ilih_m(S_M_HI(a),S_M_LI(a),b); C_O_K(b,S_O_K(a)); for (i=0;i= S_M_HI(b)) return(1L); else { for (j=0;j=S_M_LI(b)) return(1L); else { res=COMP_INTEGER_INTEGER(x,y); if (res != 0) return(res); x++;y++; }; } } } if ( S_M_HI(b) > S_M_HI(a) ) return -1; if ( S_M_LI(b) > S_M_LI(a) ) return -1; return 0; } INT comp_integermatrix(a,b) OP a, b; /* AK 150802 */ /* in case of equal dimensions lexicographic */ { INT erg = OK; CTO(INTEGERMATRIX,"comp_integermatrix(1)",a); CTO(INTEGERMATRIX,"comp_integermatrix(2)",b); { INT i,j,res; OP x,y; x = S_M_S(a); y = S_M_S(b); for (i=0L;i= S_M_HI(b)) return(1L); else { for (j=(INT)0;j=S_M_LI(b)) return(1L); else { res=COMP_INTEGER_INTEGER(x,y); if (res != 0) return(res); x++;y++; }; } } } if ( S_M_HI(b) > S_M_HI(a) ) return -1; if ( S_M_LI(b) > S_M_LI(a) ) return -1; return 0; } ENDR("comp_integermatrix"); } INT comp_matrix(a,b) OP a, b; /* AK 060789 V1.0 */ /* AK 070290 V1.1 */ /* AK 210891 V1.3 */ { INT i,j,res; OP x,y; x = S_M_S(a); y = S_M_S(b); for (i=(INT)0;i= S_M_HI(b)) return(1L); else { for (j=(INT)0;j=S_M_LI(b)) return(1L); else { res=COMP(x,y); if (res != 0) return(res); x++; y++; }; } } } if ( S_M_HI(b) > S_M_HI(a) ) return(-1L); /* AK 170790 */ if ( S_M_LI(b) > S_M_LI(a) ) return(-1L); /* AK 241195 */ return((INT)0); /* matrizen sind gleich */ } INT add_apply_matrix_matrix(a,b) OP a,b; /* AK 220390 V1.1 */ /* AK 090891 V1.3 */ /* AK 210891 V1.3 */ /* b:= b += a */ { OP c,d; INT erg = OK; CTTTO(MATRIX,INTEGERMATRIX,KRANZTYPUS,"add_apply_matrix_matrix(1)",a); CTTTO(MATRIX,INTEGERMATRIX,KRANZTYPUS,"add_apply_matrix_matrix(2)",b); C_M_HASH(b,-1); if ( (S_M_HI(a) == S_M_HI(b))&& (S_M_LI(a) == S_M_LI(b)) ) { INT i; i = S_M_HI(a)*S_M_LI(a); c = S_M_S(a); d=S_M_S(b); while (i-- > 0) { ADD_APPLY(c,d); c++; d++; } } else if ( (S_M_HI(a) < S_M_HI(b)) && (S_M_LI(a) < S_M_LI(b)) ) { INT i,j; for (i=0;i=S_M_LI(b)) COPY_INTEGER(S_M_L(a),len); else COPY_INTEGER(S_M_L(b),len); if (S_M_HI(a) >=S_M_HI(b)) COPY_INTEGER(S_M_H(a),height); else COPY_INTEGER(S_M_H(b),height); erg += b_lh_m(len,height,ergeb); C_O_K(ergeb,S_O_K(a)); z = S_M_S(ergeb); for (i=0;i0;k--,z--,w--) COPY(z,w); ENDR("copy_matrix"); } INT freeself_kranztypus(a) OP a; /* AK 270390 V1.1 */ /* AK 210891 V1.3 */ /* AK 281098 V2.0 */ { INT erg = OK; CTO(KRANZTYPUS,"freeself_kranztypus(1)",a); { OBJECTSELF d; d=S_O_S(a); SYM_free(S_M_S(a)); FREEALL(S_M_L(a)); FREEALL(S_M_H(a)); SYM_free(d.ob_matrix); C_O_K(a,EMPTY); } ENDR("freeself_kranztypus"); } INT freeself_matrix(matrix) OP matrix; /* AK 060789 V1.0 */ /* AK 071289 V1.1 */ /* AK 100691 V1.2 */ /* AK 160891 V1.3 */ { INT k; OBJECTSELF d; OP z; INT erg = OK; CTO(MATRIX,"freeself_matrix(1)",matrix); d=S_O_S(matrix); z = S_M_IJ(matrix,S_M_HI(matrix)-1L,S_M_LI(matrix)-1L); k = S_M_HI(matrix) * S_M_LI(matrix); for (;k>(INT)0;k--,z--) if (S_O_K(z) == INTEGER) ; else if (EMPTYP(z)); else erg += freeself(z); SYM_free(S_M_S(matrix)); erg += freeall(S_M_L(matrix)); erg += freeall(S_M_H(matrix)); SYM_free(d.ob_matrix); C_O_K(matrix,EMPTY); ENDR("freeself_matrix"); } static struct matrix * callocmatrix() /* AK 060789 V1.0 */ /* AK 220390 V1.1 */ /* AK 160891 V1.3 */ { struct matrix *ergebnis; ergebnis = (struct matrix *) SYM_calloc((int)1,sizeof(struct matrix)); if (ergebnis == NULL) no_memory(); return(ergebnis); } INT scan_integermatrix(ergebnis) OP ergebnis; /* AK 141293 */ { return scan_matrix_co(ergebnis, INTEGER); } INT scan_matrix(ergebnis) OP ergebnis; /* AK 141293 */ { return scan_matrix_co(ergebnis, EMPTY); } INT scan_skewsymmetric_matrix(ergebnis) OP ergebnis; /* AK 060789 V1.0 */ /* AK 310790 V1.1 */ /* AK 080891 V1.3 */ { OP len, height; INT i,j; char a[20]; /* AK 080891 */ OBJECTKIND kind; len = callocobject(); height = callocobject(); aaa: printeingabe("height of skew symmetric matrix"); scan(INTEGER,height); copy(height,len); printeingabe("enter kind of matrix elements"); kind=scanobjectkind(); if (S_I_I(len) <= (INT)0) /* AK 170795 */ { printeingabe("you entered wrong length (<=0), do it again"); goto aaa; } if (S_I_I(height) <= (INT)0) /* AK 170795 */ { printeingabe("you entered wrong height (<=0), do it again"); goto aaa; } b_lh_m(len,height,ergebnis); for (i=0; i=S_M_LI(a),"change_column_ij:i too big "); SYMCHECK(j>=S_M_LI(a),"change_column_ij:j too big "); if (i==j) goto endr_ende; /* AK 190802 */ for (k=0; k=S_M_HI(a),"change_row_ij:i too big "); SYMCHECK(j>=S_M_HI(a),"change_row_ij:j too big "); if (i==j) goto endr_ende; /* AK 190802 */ for (k=(INT)0; km_self); } OP s_m_h(a) OP a; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_matrix->m_height); } OP s_m_l(a) OP a; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_matrix->m_length); } INT s_m_hash(a) OP a; /* AK 110703 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_matrix->m_hash); } INT s_m_hi(a) OP a; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { return(s_i_i(s_m_h(a))); } INT s_m_li(a) OP a; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { return(s_i_i(s_m_l(a))); } INT c_m_s(a,b) OP a,b; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_matrix->m_self = b; return(OK); } INT c_m_h(a,b) OP a,b; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_matrix->m_height = b; return(OK); } INT c_m_hash(a,b) OP a; INT b; /* AK 110703 */ { OBJECTSELF c; c = s_o_s(a); c.ob_matrix->m_hash = b; return(OK); } INT c_m_l(a,b) OP a,b; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_matrix->m_length = b; return(OK); } OP s_m_ij(a,i,j) OP a; INT i,j; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { if (not MATRIXP(a)) { printobjectkind(a); error("s_m_ij:no matrix object"); } if (i < (INT)0) { debugprint(a); fprintf(stderr,"index = %ld\n",i); error("s_m_ij:row index too small"); } if (i >= s_m_hi(a)) { debugprint(a); fprintf(stderr,"index = %ld\n",i); error("s_m_ij:row index too big"); } if (j >= s_m_li(a)) { debugprint(a); fprintf(stderr,"index = %ld\n",j); error("s_m_ij:column index too big"); } if (j < (INT)0) { debugprint(a); fprintf(stderr,"index = %ld\n",j); error("s_m_ij:column index too small"); } return(s_m_s(a) + (s_m_li(a)*i+j) ); } INT s_m_iji(a,i,j) OP a; INT i,j; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 160891 V1.3 */ { return(s_i_i(s_m_ij(a,i,j))); } INT fprint_matrix(f,obj) FILE *f; OP obj; /* AK 211186 */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT i,j; for (i=0;i70L)) {fprintf(stdout,"\n");zeilenposition = 0L;} }; fprintf(f,"]"); }; fprintf(f,"\n"); if (f == stdout) zeilenposition=0L; return(OK); } INT tex_matrix(obj) OP obj; { return tex_matrix_co(obj,tex); } INT tex_matrix_co(obj,f) OP obj; INT (*f)(); /* AK 150988 */ /* AK 310790 V1.1 */ /* AK 070291 V1.2 texout for output */ /* AK 210891 V1.3 */ { INT i,j; INT ts = texmath_yn; /* AK 190892 */ INT erg = OK; CTO(MATRIX,"tex_matrix_co(1)",obj); fprintf(texout,"\n"); if (texmath_yn == 0L) /* d.h. not in math mode */ { fprintf(texout,"$"); texmath_yn=1L; } fprintf(texout,"\\matrix { \n"); texposition = 0L; for (i=0;i=0L; i--) ADD_APPLY(S_M_IJ(a,i,i),b); ENDR("trace_matrix"); } INT symmetricp_matrix(a) OP a; /* AK 150296 */ { INT i,j; if (S_M_HI(a) != S_M_LI(a)) return FALSE; for (i=0L;i0L; i--, z++) if (not EMPTYP(z)) { if (EMPTYP(zb)) zb = z; else if (GR(z,zb)) zb = z; } return copy(zb,b); } INT min_matrix(a,b) OP a,b; /* b becomes copy of the minimum entry */ /* a and b may be equal */ /* AK 140703 */ /* AK 061207 */ { OP z = S_M_S(a),zb = NULL; INT i; for (i=S_M_HI(a)*S_M_LI(a); i>0L; i--, z++) { if (not EMPTYP(z)) { if (zb==NULL) zb = z; else if (LT(z,zb)) zb = z; } } if (zb==NULL) return error("min_matrix: no entries"); else return copy(zb,b); } INT zeilen_summe(a,b) OP a,b; /* AK 281289 summe ueber die Zeilen, ergebnis ist vector */ /* AK 281289 V1.1 */ /* AK 210891 V1.3 */ { INT i,j; INT erg = OK; CTTO(INTEGERMATRIX,MATRIX,"zeilen_summe(1)",a); erg += m_il_nv(S_M_HI(a),b); for (j=0;j= 2L) kronecker_product(a,a,b); for(i=2;i= S_M_HI(a), "select_row: index >= height"); erg += m_il_v(S_M_LI(a),b); for (j=0L;j= S_M_LI(a), "select_column: index >= length"); erg += m_il_v(S_M_HI(a),b); for (j=0;j= S_M_LI(b), "operate_perm_spaltenmatrix: permutation degree too big"); COPY(b,c); for (j=0;j= S_M_LI(S_PO_S(b)), "operate_perm_bideterminant: permutation degree too big"); { OP d; INT i; d = CALLOCOBJECT(); t_LIST_VECTOR(b,d); for(i=0;iob_self) #define S_O_K(a) (((OP)(a))->ob_kind) #define C_O_K(a,b) ((a)->ob_kind = (OBJECTKIND)(b)) #define C_O_S(a,b) S_O_S(a)=(b) #define B_KS_O(a,b,c) do { C_O_S(c,b); C_O_K(c,a); } while(0) #define EMPTYP(a) ((a)->ob_kind == (OBJECTKIND)0) #define EQ_INTEGER(a,b) \ ( S_O_K(b) == INTEGER ?(S_I_I(a) == S_I_I(b)):(comp_integer(a,b) == 0)) #define EQ_PARTITION(a,b) \ ( S_O_K(b) == PARTITION ? eq_partition_partition(a,b) :FALSE ) #define EQ_LONGINT(a,b) \ ( S_O_K(b) == LONGINT ? eq_longint_longint(a,b) :(comp_longint(a,b) == 0)) #define EQ_FF(a,b) \ ( comp_ff(a,b) == 0 ) #define EQ(a,b) \ (\ S_O_K(a) == INTEGER? EQ_INTEGER(a,b) : \ (\ S_O_K(a) == LONGINT? EQ_LONGINT(a,b) :\ ( \ S_O_K(a) == PARTITION?EQ_PARTITION(a,b): \ (\ S_O_K(a)==FF?EQ_FF(a,b): eq(a,b) \ )\ ) \ )\ ) #define S_I_I(a) (((a)->ob_self).ob_INT) #define C_I_I(a,b) (a)->ob_self.ob_INT = (INT)(b) #define M_I_I(a,b) (\ ((b)->ob_self.ob_INT = (INT)(a)),\ ((b)->ob_kind = INTEGER)\ ) #define DEC_INTEGER(a) (((a)->ob_self).ob_INT --) #define INC_INTEGER(a) (((a)->ob_self).ob_INT ++) #define COPY_INTEGER(a,b) M_I_I(S_I_I(a),b) #define FREESELF_INTEGER(a) C_O_K((a),0) #define NULLP_INTEGER(a) (S_I_I(a) == 0) #define POSP_INTEGER(a) (S_I_I(a) > (INT)0) #define NEGP_INTEGER(a) (S_I_I(a) < (INT)0) #define EINSP_INTEGER(a) (S_I_I(a) == (INT)1) #define NEGEINSP_INTEGER(a) (S_I_I(a) == (INT)-1) #define COMP_INTEGER_INTEGER(a,b) ((S_I_I(a) == S_I_I(b))? 0L :\ ((S_I_I(a) > S_I_I(b))? 1L : -1L) ) #define INTEGERP(a) (S_O_K(a) == INTEGER) #define S_V_S(a) ((((a)->ob_self).ob_vector)->v_self) #define C_V_S(a,b) (((((a)->ob_self).ob_vector)->v_self) = ((OP) b)) #define S_V_L(a) ((((a)->ob_self).ob_vector)->v_length) #define C_V_L(a,b) (((((a)->ob_self).ob_vector)->v_length) = (b)) #define S_V_I(a,i) (((((a)->ob_self).ob_vector)->v_self)+(i)) #define C_V_I(a,i,b) ( *(((((a)->ob_self).ob_vector)->v_self)+(i)) = *(b)) #define S_V_II(a,i) (((((((a)->ob_self).ob_vector)->v_self)+(i))\ ->ob_self).ob_INT) #define S_V_LI(a) ((((((a)->ob_self).ob_vector)->v_length)->ob_self).ob_INT) #define B_O_V(a,b) \ do { \ struct vector *callocvectorstruct();\ FREESELF(b);C_O_K(b,VECTOR);b->ob_self.ob_vector = callocvectorstruct();\ C_V_S(b,a);C_V_L(b,CALLOCOBJECT()); M_I_I(1,S_V_L(b)); } while(0) #define INTEGRALP(a) ( (S_O_K(a) == LONGINT) \ || (S_O_K(a) == INTEGER) \ ) #define VECTORP_CO1(a) ( (S_O_K(a) == VECTOR) \ || (S_O_K(a) == WORD) \ || (S_O_K(a) == QUEUE) \ || (S_O_K(a) == INTEGERVECTOR) \ || (S_O_K(a) == COMPOSITION) \ || (S_O_K(a) == HASHTABLE) \ || (S_O_K(a) == LAURENT) \ || (S_O_K(a) == KRANZ) \ || (S_O_K(a) == SUBSET) \ || (S_O_K(a) == FF) \ ) #define VECTORP(a) ((a == NULL)? FALSE: VECTORP_CO1(a)) #define LISTP_CO1(a) ( (S_O_K(a) == LIST) \ || (S_O_K(a) == SCHUR) \ || (S_O_K(a) == GRAL) \ || (S_O_K(a) == POLYNOM) \ || (S_O_K(a) == SCHUBERT) \ || (S_O_K(a) == MONOPOLY) \ || (S_O_K(a) == ELM_SYM) \ || (S_O_K(a) == POW_SYM) \ || (S_O_K(a) == MONOMIAL) \ || (S_O_K(a) == HOM_SYM) \ ) #define LISTP(a) ((a == NULL)? FALSE: LISTP_CO1(a)) #define POLYP(a) ( \ (S_O_K(a) == SCHUR) \ || (S_O_K(a) == GRAL) \ || (S_O_K(a) == POLYNOM) \ || (S_O_K(a) == SCHUBERT) \ || (S_O_K(a) == MONOPOLY) \ || (S_O_K(a) == ELM_SYM) \ || (S_O_K(a) == POW_SYM) \ || (S_O_K(a) == MONOMIAL) \ || (S_O_K(a) == HOM_SYM) \ ) #define S_L_S(a) ((((a)->ob_self).ob_list)->l_self) #define C_L_S(a,b) (((((a)->ob_self).ob_list)->l_self) = (OP)(b)) #define S_L_N(a) ((((a)->ob_self).ob_list)->l_next) #define C_L_N(a,b) (((((a)->ob_self).ob_list)->l_next) = (OP)(b)) #define S_PA_C(a) ((unsigned char *) (S_PA_S(a))) #define S_PA_K(a) ((a)->ob_self.ob_partition->pa_kind) #define C_PA_K(a,b) (((((a)->ob_self).ob_partition)->pa_kind) = b) #define C_PA_HASH(a,b) (((((a)->ob_self).ob_partition)->pa_hash) = b) #define S_PA_S(a) ((a)->ob_self.ob_partition->pa_self) #define S_PA_HASH(a) ((a)->ob_self.ob_partition->pa_hash) #define C_PA_S(a,b) ((a)->ob_self.ob_partition->pa_self = b) #define S_PA_I(a,i) S_V_I((a)->ob_self.ob_partition->pa_self,i) #define S_PA_II(a,i) \ ((S_O_K(a) == CHARPARTITION || S_O_K(a) == CHAR_AUG_PART) ? \ (INT)(S_PA_C(a)[i+1]) : \ S_V_II((a)->ob_self.ob_partition->pa_self,i)) #define S_PA_CII(a,i) (S_PA_C(a)[i+1]) #define S_PA_CI(a,i) (S_PA_C(a)+i+1) #define S_PA_CL(a) (S_PA_C(a)[0]) #define S_PA_L(a) S_V_L(S_PA_S(a)) #define S_PA_LI(a) \ ((S_O_K(a) == CHARPARTITION || S_O_K(a) == CHAR_AUG_PART) ? \ (INT)(S_PA_C(a)[0]) : \ S_V_LI(S_PA_S(a))) #define INC_PARTITION(a) inc_vector(S_PA_S(a)) #define DEC_PARTITION(a) dec_integervector(S_PA_S(a)) #ifdef FAST #define PART_CHECK_KIND(t,a,b) #else #define PART_CHECK_KIND(t,a,b)\ CTO(PARTITION,t,a);\ if (S_PA_K(a) != b)\ wrong_kind_part(t,a,b); #endif extern INT partition_speichersize,partition_speicherindex,mem_counter_part; extern struct partition **partition_speicher; #define FREEPARTITION(d)\ FREE_MEMMANAGER(struct partition *,\ partition_speicher,\ partition_speicherindex,\ partition_speichersize,\ mem_counter_part,\ d) #define B_KS_PA(a,b,c) \ do {\ C_O_K(c,PARTITION);\ CALLOC_MEMMANAGER(struct partition,\ partition_speicher,\ partition_speicherindex,\ mem_counter_part,\ (c ->ob_self).ob_partition);\ /* (c ->ob_self).ob_partition=CALLOCPARTITION();*/\ C_PA_K(c,a);\ C_PA_S(c,b);\ C_PA_HASH(c,-1L); \ } while (0) #define M_KL_PA(a,b,c) \ do { B_KS_PA(a,CALLOCOBJECT(),c);\ erg += m_l_v(b,S_PA_S(c));\ C_O_K(S_PA_S(c),INTEGERVECTOR) );\ while(0) #define B_KL_PA(a,b,c) \ do { B_KS_PA(a,CALLOCOBJECT(),c);\ erg += b_l_v(b,S_PA_S(c));\ C_O_K(S_PA_S(c),INTEGERVECTOR);\ } while(0) #define S_P_K(a) ((((a)->ob_self).ob_permutation)->p_kind) #define C_P_K(a,b) (((((a)->ob_self).ob_permutation)->p_kind) = b) #define S_P_S(a) ((((a)->ob_self).ob_permutation)->p_self) #define C_P_S(a,b) (((((a)->ob_self).ob_permutation)->p_self) = b) #define S_P_I(a,i) S_V_I(((((a)->ob_self).ob_permutation)->p_self),(i)) #define S_P_II(a,i) S_V_II(((((a)->ob_self).ob_permutation)->p_self),(i)) #define S_P_L(a) S_V_L(S_P_S(a)) #define S_P_LI(a) S_V_LI(S_P_S(a)) /* kranz produkt AK 120804 */ #define S_KR_G(a) S_V_I(a,0) #define S_KR_GI(a,i) S_P_I(S_V_I(a,0),i) #define S_KR_GL(a) S_P_L(S_V_I(a,0)) #define S_KR_GLI(a) S_P_LI(S_V_I(a,0)) #define S_KR_V(a) S_V_I(a,1) #define S_KR_VL(a) S_V_L(S_V_I(a,1)) #define S_KR_VLI(a) S_V_LI(S_V_I(a,1)) #define S_KR_I(a,i) S_V_I(S_V_I(a,1),i) #define S_M_L(a) ((((a)->ob_self).ob_matrix)->m_length) #define C_M_L(a,b) (((((a)->ob_self).ob_matrix)->m_length)=(b)) #define S_M_LI(a) ((((((a)->ob_self).ob_matrix)->m_length)->ob_self).ob_INT) #define S_M_H(a) ((((a)->ob_self).ob_matrix)->m_height) #define S_M_HASH(a) ((((a)->ob_self).ob_matrix)->m_hash) #define C_M_H(a,b) (((((a)->ob_self).ob_matrix)->m_height)=(b)) #define S_M_HI(a) ((((((a)->ob_self).ob_matrix)->m_height)->ob_self).ob_INT) #define S_M_S(a) ((((a)->ob_self).ob_matrix)->m_self) #define C_M_S(a,b) (((((a)->ob_self).ob_matrix)->m_self)=(b)) #define C_M_HASH(a,b) (((((a)->ob_self).ob_matrix)->m_hash)=(b)) #define S_M_IJ(a,i,j) ( ((((a)->ob_self).ob_matrix)->m_self)\ + ((((((a)->ob_self).ob_matrix)->m_length)->ob_self).ob_INT)\ * (i) + (j) ) #define S_M_IJI(a,i,j) S_I_I(S_M_IJ(a,i,j)) #define MATRIXP(a) ((S_O_K(a) == MATRIX) || (S_O_K(a) == KRANZTYPUS)\ || (S_O_K(a) == KOSTKA) || (S_O_K(a) == INTEGERMATRIX) ) #define S_MO_S(a) (((a->ob_self).ob_monom)->mo_self) #define C_MO_S(a,b) ((((a->ob_self).ob_monom)->mo_self)=(b)) #define S_MO_K(a) (((a->ob_self).ob_monom)->mo_koeff) #define C_MO_K(a,b) ((((a->ob_self).ob_monom)->mo_koeff)=(b)) #define S_MO_KI(a) ((((a->ob_self).ob_monom)->mo_koeff)->ob_self.ob_INT) #define S_MO_SI(a,i) S_V_I(S_MO_S(a),(i)) #define S_MO_SII(a,i) S_V_II(S_MO_S(a),(i)) #define S_MO_SL(a) S_V_L(S_MO_S(a)) #define S_MO_SLI(a) S_V_LI(S_MO_S(a)) #define COPY_MONOM(a,b) M_SK_MO(S_MO_S(a),S_MO_K(a),b) #define B_SK_MO(a,b,c)\ do { \ C_O_K(c,MONOM);\ CALLOC_MEMMANAGER(struct monom, monom_speicher, monom_speicherindex,mem_counter_monom ,(c->ob_self).ob_monom);\ C_MO_S(c,a) ; \ C_MO_K(c,b); \ } while(0) extern INT monom_speicherindex,mem_counter_monom,monom_speichersize; extern struct monom **monom_speicher; #define FREEMONOM(v) \ FREE_MEMMANAGER(struct monom *,\ monom_speicher,\ monom_speicherindex,\ monom_speichersize,\ mem_counter_monom,\ v) #define FREESELF_MONOM(a)\ do {\ if (S_O_K(S_MO_S(a)) == PARTITION) \ { erg+= freeself_partition(S_MO_S(a)); }\ else if (S_O_K(S_MO_S(a)) == INTEGERMATRIX) \ { erg+= freeself_integermatrix(S_MO_S(a)); }\ else erg += freeself(S_MO_S(a));\ FREE_EMPTY_OBJECT(S_MO_S(a));\ if (S_O_K(S_MO_K(a)) == INTEGER) C_O_K(S_MO_K(a),EMPTY);\ else if (S_O_K(S_MO_K(a)) == LONGINT) erg += freeself_longint(S_MO_K(a));\ else if (S_O_K(S_MO_K(a)) == BRUCH) erg += freeself_bruch(S_MO_K(a));\ else if (S_O_K(S_MO_K(a)) == FF) erg += freeself_ff(S_MO_K(a));\ else erg += freeself(S_MO_K(a));\ FREE_EMPTY_OBJECT(S_MO_K(a));\ FREEMONOM(((a)->ob_self).ob_monom);\ C_O_K(a,EMPTY);\ } while(0) #define S_B_I(a) ((INT)((((a)->ob_self).ob_bruch)->b_info)) #define S_B_O(a) ((OP)((((a)->ob_self).ob_bruch)->b_oben)) #define S_B_OI(a) ((INT)((((((a)->ob_self).ob_bruch)->b_oben)->ob_self).ob_INT)) #define S_B_U(a) ((OP)((((a)->ob_self).ob_bruch)->b_unten)) #define S_B_UI(a) ((INT)((((((a)->ob_self).ob_bruch)->b_unten)->ob_self).ob_INT)) #define FREESELF_BRUCH(a) (freeall(S_B_O(a)),freeall(S_B_U(a)),\ free(S_O_S(a).ob_bruch),C_O_K(a,0),OK) #define C_B_I(a,b) (((((a)->ob_self).ob_bruch)->b_info)=(INT)(b)) #define C_B_O(a,b) (((((a)->ob_self).ob_bruch)->b_oben)=(b)) #define C_B_U(a,b) (((((a)->ob_self).ob_bruch)->b_unten)=(b)) #define EINSP_BRUCH(a) (EQ(S_B_O((a)),S_B_U((a)))) #define BRUCHP(a) (S_O_K(a) == BRUCH) #define S_S_S(a) ((((((((a)->ob_self).ob_list)->l_self))\ ->ob_self).ob_monom)->mo_self) #define S_S_SL(a) S_PA_L( ((((((((a)->ob_self).ob_list)->l_self))\ ->ob_self).ob_monom)->mo_self)\ ) #define S_S_SLI(a) S_PA_LI( ((((((((a)->ob_self).ob_list)->l_self))\ ->ob_self).ob_monom)->mo_self)\ ) #define S_S_SI(a,i) S_PA_I( ((((((((a)->ob_self).ob_list)->l_self))\ ->ob_self).ob_monom)->mo_self)\ ,(i)) #define S_S_SII(a,i) S_PA_II( ((((((((a)->ob_self).ob_list)->l_self))\ ->ob_self).ob_monom)->mo_self)\ ,(i)) #define S_S_K(a) (S_MO_K(((((a)->ob_self).ob_list)->l_self))) #define C_S_K(a,b) (C_MO_K(((((a)->ob_self).ob_list)->l_self),(b))) #define C_S_S(a,b) (C_MO_S(((((a)->ob_self).ob_list)->l_self),(b))) #define S_S_KI(a) (S_MO_KI(((((a)->ob_self).ob_list)->l_self))) #define S_S_N(a) (S_L_N(a)) #define C_S_N(a,b) (C_L_N((a),(b))) #define S_SCH_S(a) (S_MO_S(S_L_S(a))) #define S_SCH_SL(a) (S_P_L(S_MO_S(S_L_S(a)))) #define S_SCH_SLI(a) (S_P_LI(S_MO_S(S_L_S(a)))) #define S_SCH_SI(a,i) S_P_I(S_SCH_S(a),(i)) #define S_SCH_SII(a,i) S_P_II(S_SCH_S(a),(i)) #define S_SCH_K(a) (S_MO_K(S_L_S(a))) #define C_SCH_K(a,b) (C_MO_K(S_L_S(a),(b))) #define S_SCH_KI(a) (S_MO_KI(S_L_S(a))) #define S_SCH_N(a) (S_L_N(a)) #define C_SCH_N(a,b) (C_L_N((a),(b))) #define POLYNOMP(a) (S_O_K(a) == POLYNOM) #define S_PO_S(a) (S_MO_S(S_L_S(a))) #define S_PO_SI(a,i) (S_V_I(S_MO_S(S_L_S(a)),i)) #define S_PO_SIJ(a,i,j) (S_M_IJ(S_MO_S(S_L_S(a)),i,j)) #define S_PO_SIJI(a,i,j) (S_M_IJI(S_MO_S(S_L_S(a)),i,j)) #define S_PO_SII(a,i) (S_V_II(S_MO_S(S_L_S(a)),i)) #define S_PO_SL(a) (S_V_L(S_MO_S(S_L_S(a)))) #define S_PO_SLI(a) (S_V_LI(S_MO_S(S_L_S(a)))) #define S_PO_K(a) (S_MO_K(S_L_S(a))) #define S_PO_KI(a) (S_MO_KI(S_L_S(a))) #define S_PO_N(a) (S_L_N(a)) #define C_PO_N(a,b) (C_L_N((a),(b))) #define C_PO_K(a,b) (C_MO_K(S_L_S(a),(b))) #define COPY_POLYNOM(a,b) copy_list(a,b) #define M_SK_MO(a,b,c) (b_sk_mo(callocobject(),callocobject(),c),\ copy(b,S_MO_K(c)),\ copy(a,S_MO_S(c))) #define S_SPA_G(a) ((((a)->ob_self).ob_skewpartition)->spa_gross) #define S_SPA_GL(a) S_PA_L((((a)->ob_self).ob_skewpartition)->spa_gross) #define S_SPA_GLI(a) S_PA_LI((((a)->ob_self).ob_skewpartition)->spa_gross) #define S_SPA_GI(a,i) S_PA_I(((((a)->ob_self).ob_skewpartition)->spa_gross),i) #define S_SPA_GII(a,i) S_PA_II(((((a)->ob_self).ob_skewpartition)->spa_gross),i) #define S_SPA_GS(a) S_PA_S((((a)->ob_self).ob_skewpartition)->spa_gross) #define S_SPA_K(a) ((((a)->ob_self).ob_skewpartition)->spa_klein) #define S_SPA_KL(a) S_PA_L((((a)->ob_self).ob_skewpartition)->spa_klein) #define S_SPA_KLI(a) S_PA_LI((((a)->ob_self).ob_skewpartition)->spa_klein) #define S_SPA_KI(a,i) S_PA_I(S_SPA_K(a),i) #define S_SPA_KII(a,i) S_PA_II(S_SPA_K(a),i) #define S_SPA_KS(a) S_PA_S((((a)->ob_self).ob_skewpartition)->spa_klein) #define S_T_S(a) ((((a)->ob_self).ob_tableaux)->t_self) #define S_T_U(a) ((((a)->ob_self).ob_tableaux)->t_umriss) #define S_T_IJ(a,i,j) S_M_IJ(S_T_S(a),i,j) #define S_T_H(a) S_M_H(S_T_S(a)) #define S_T_HI(a) S_M_HI(S_T_S(a)) #define S_T_L(a) S_M_L(S_T_S(a)) #define S_T_LI(a) S_M_LI(S_T_S(a)) #define S_T_IJI(a,i,j) S_M_IJI(S_T_S(a),i,j) #define S_T_UG(a) S_SPA_G(S_T_U(a)) #define S_T_UGLI(a) S_SPA_GLI(S_T_U(a)) #define S_T_UGL(a) S_SPA_GL(S_T_U(a)) #define S_T_UGII(a,i) S_SPA_GII(S_T_U(a),i) #define S_T_UGI(a,i) S_SPA_GI(S_T_U(a),i) #define S_T_UK(a) S_SPA_K(S_T_U(a)) #define S_T_UKLI(a) S_SPA_KLI(S_T_U(a)) #define S_T_UKL(a) S_SPA_KL(S_T_U(a)) #define S_T_UKII(a,i) S_SPA_KII(S_T_U(a),i) #define S_T_UKI(a,i) S_SPA_KI(S_T_U(a),i) #define S_T_UL(a) S_PA_L(S_T_U(a)) #define S_T_ULI(a) S_PA_LI(S_T_U(a)) #define S_T_UII(a,i) S_PA_II(S_T_U(a),i) #define S_T_UI(a,i) S_PA_I(S_T_U(a),i) #define TABLEAUXP(a) (S_O_K(a) == TABLEAUX) #define S_W_I(a,i) S_V_I(a,i) #define S_W_II(a,i) S_V_II(a,i) #define S_W_L(a) S_V_L(a) #define S_W_LI(a) S_V_LI(a) #define S_W_S(a) S_V_S(a) #define S_LA_I(a,i) S_V_I(a,i) #define S_LA_II(a,i) S_V_II(a,i) #define S_LA_L(a) S_V_L(a) #define S_LA_LI(a) S_V_LI(a) #define S_LA_S(a) S_V_S(a) #define b_l_w(a,b) (b_l_v(a,b),C_O_K(b,WORD),OK) #define m_l_w(a,b) (m_l_v(a,b),C_O_K(b,WORD),OK) #define m_il_w(a,b) (m_il_v(a,b),C_O_K(b,WORD),OK) #define m_il_nw(a,b) (m_il_nv(a,b),C_O_K(b,WORD),OK) #define m_l_nw(a,b) (m_l_nv(a,b),C_O_K(b,WORD),OK) #define b_l_la(a,b) (b_l_v(a,b),C_O_K(b,LAURENT),OK) #define m_l_la(a,b) (m_l_v(a,b),C_O_K(b,LAURENT),OK) #define m_il_la(a,b) (m_il_v(a,b),C_O_K(b,LAURENT),OK) #define m_il_nla(a,b) (m_il_nv(a,b),C_O_K(b,LAURENT),OK) #define m_l_nla(a,b) (m_l_nv(a,b),C_O_K(b,LAURENT),OK) #define S_SC_D(a) ((((a)->ob_self).ob_symchar)->sy_dimension) #define S_SC_DI(a) S_I_I((((a)->ob_self).ob_symchar)->sy_dimension) #define S_SC_W(a) ((((a)->ob_self).ob_symchar)->sy_werte) #define S_SC_WI(a,i) S_V_I(((((a)->ob_self).ob_symchar)->sy_werte),i) #define S_SC_WII(a,i) S_V_II(((((a)->ob_self).ob_symchar)->sy_werte),i) #define S_SC_P(a) ((((a)->ob_self).ob_symchar)->sy_parlist) #define S_SC_PI(a,i) S_V_I(((((a)->ob_self).ob_symchar)->sy_parlist),i) #define S_SC_PLI(a) S_V_LI(((((a)->ob_self).ob_symchar)->sy_parlist)) #define S_SC_WLI(a) S_V_LI(((((a)->ob_self).ob_symchar)->sy_werte)) /* MD */ #define S_N_S(a) ((((a)->ob_self).ob_number)->n_self) #define C_N_S(a,b) (((((a)->ob_self).ob_number)->n_self) = (b)) #define S_N_D(a) (((((a)->ob_self).ob_number)->n_data).o_data) #define C_N_D(a,b) ((((((a)->ob_self).ob_number)->n_data).o_data) = (b)) #define S_N_DC(a) (((((a)->ob_self).ob_number)->n_data).c_data) #define S_N_DCI(a) ((((((a)->ob_self).ob_number)->n_data).c_data)->index) #define S_N_DCII(a) S_I_I(S_N_DCI(a)) #define S_N_DCD(a) ((((((a)->ob_self).ob_number)->n_data).c_data)->deg) #define S_N_DCP(a) ((((((a)->ob_self).ob_number)->n_data).c_data)->poly) #define OBJECTREAD_CYCLO(f,a) objectread_number((f),(a),CYCLOTOMIC) #define OBJECTREAD_SQRAD(f,a) objectread_number((f),(a),SQ_RADICAL) #define EINSP_MONOPOLY(a) eq_fieldobject_int(MONOPOLY,(a),1L) #define EINSP_CYCLO(a) eq_fieldobject_int(CYCLOTOMIC,(a),1L) #define EINSP_SQRAD(a) eq_fieldobject_int(SQ_RADICAL,(a),1L) #define NEGEINSP_MONOPOLY(a) eq_fieldobject_int(MONOPOLY,(a),-1L) #define NEGEINSP_CYCLO(a) eq_fieldobject_int(CYCLOTOMIC,(a),-1L) #define NEGEINSP_SQRAD(a) eq_fieldobject_int(SQ_RADICAL,(a),-1L) #define evenp(a) even(a) #define oddp(a) odd(a) #define first_ym(a,b) ym_min(a,b) #define addinvers_schubert(a,b) addinvers_polynom(a,b) #define addinvers_schur(a,b) addinvers_polynom(a,b) #define einsp_schur(a) einsp_symfunc(a) #define add_apply_schur(a,b) add_apply_symfunc(a,b) #define add_apply_schur_schur(a,b) add_apply_symfunc_symfunc(a,b) #define m_part_schur(a,b) m_skn_s(a,cons_eins,NULL,b) /* for MONOMIAL */ #define m_v_mon(a,b) (m_v_s(a,b),C_O_K(b,MONOMIAL),OK) #define b_skn_mon(a,b,c,d) (b_skn_s(a,b,c,d),C_O_K(d,MONOMIAL),OK) #define m_skn_mon(a,b,c,d) (m_skn_s(a,b,c,d),C_O_K(d,MONOMIAL),OK) #define addinvers_monomial(a,b) addinvers_polynom(a,b) #define add_apply_monomial(a,b) add_apply_symfunc(a,b) #define add_apply_monomial_monomial(a,b) add_apply_symfunc_symfunc(a,b) #define m_part_monomial(a,b) m_skn_mon(a,cons_eins,NULL,b) #define einsp_monomial(a) einsp_symfunc(a) /* for ELM_SYM */ #define m_v_e(a,b) (m_v_s(a,b),C_O_K(b,ELM_SYM),OK) #define add_monom_elmsym(a,b,c) add_monom_schur(a,b,c) #define addinvers_elmsym(a,b) addinvers_polynom(a,b) #define b_skn_e(a,b,c,d) (b_skn_s(a,b,c,d),C_O_K(d,ELM_SYM),OK) #define m_skn_e(a,b,c,d) (m_skn_s(a,b,c,d),C_O_K(d,ELM_SYM),OK) #define add_apply_elmsym(a,b) add_apply_symfunc(a,b) #define add_apply_elmsym_elmsym(a,b) add_apply_symfunc_symfunc(a,b) #define m_part_elmsym(a,b) m_skn_e(a,cons_eins,NULL,b) #define einsp_elmsym(a) einsp_symfunc(a) /* for POW_SYM */ #define m_v_ps(a,b) (m_v_s(a,b),C_O_K(b,POW_SYM),OK) #define add_monom_powsym(a,b,c) add_monom_schur(a,b,c) #define addinvers_powsym(a,b) addinvers_polynom(a,b) #define b_skn_ps(a,b,c,d) (b_skn_s(a,b,c,d),C_O_K(d,POW_SYM),OK) #define m_skn_ps(a,b,c,d) (m_skn_s(a,b,c,d),C_O_K(d,POW_SYM),OK) #define compute_powsym_with_alphabet(a,b,c) \ compute_power_with_alphabet(a,b,c) #define add_apply_powsym(a,b) add_apply_symfunc(a,b) #define add_apply_powsym_powsym(a,b) add_apply_symfunc_symfunc(a,b) #define m_part_powsym(a,b) m_skn_ps(a,cons_eins,NULL,b) #define einsp_powsym(a) einsp_symfunc(a) /* for HOM_SYM */ #define m_v_h(a,b) (m_v_s(a,b),C_O_K(b,HOM_SYM),OK) #define add_monom_homsym(a,b,c) add_monom_schur(a,b,c) #define addinvers_homsym(a,b) addinvers_schur(a,b) #define b_skn_h(a,b,c,d) (b_skn_s(a,b,c,d),C_O_K(d,HOM_SYM),OK) #define m_skn_h(a,b,c,d) (m_skn_s(a,b,c,d),C_O_K(d,HOM_SYM),OK) #define compute_homsym_with_alphabet(a,b,c) \ compute_complete_with_alphabet(a,b,c) #define add_apply_homsym(a,b) add_apply_symfunc(a,b) #define add_apply_homsym_homsym(a,b) add_apply_symfunc_symfunc(a,b) #define m_part_homsym(a,b) m_skn_h(a,cons_eins,NULL,b) #define einsp_homsym(a) einsp_symfunc(a) /* for nc.c */ #define S_NC_GL(a) S_V_I(a,0L) #define S_NC_C(a) S_V_I(a,1L) #define SYM_GL(a) (S_V_II(a,0L)==1L) /* true falls sym */ #define ALT_GL(a) (S_V_II(a,0L)==2L) /* true falls alt */ #define KRANZ_GL(a) (S_V_II(a,0L)==3L) /* true falls kranz */ #define CYCLIC_GL(a) (S_V_II(a,0L)==4L) /* true falls cyclic */ #define GLNQ_GL(a) (S_V_II(a,0L)==5L) /* true falls gl(n,q) */ #define S_GL_SYM_A(a) S_V_I(a,1L) #define S_GL_ALT_A(a) S_V_I(a,1L) #define S_GL_CYCLIC_A(a) S_V_I(a,1L) #define S_GL_KRANZ_A(a) S_GL_SYM_A(S_V_I(S_V_I(a,1L),0L)) #define S_GL_KRANZ_GLA(a) (S_V_I(S_V_I(a,1L),0L)) #define S_GL_KRANZ_B(a) S_GL_SYM_A(S_V_I(S_V_I(a,1L),1L)) #define S_GL_KRANZ_GLB(a) (S_V_I(S_V_I(a,1L),1L)) #define S_GL_GLNQ_N(a) (S_V_I(S_V_I(a,1L),0L)) #define S_GL_GLNQ_Q(a) (S_V_I(S_V_I(a,1L),1L)) /* for ga.c */ #define m_skn_gral(a,b,c,d) ( m_skn_po(a,b,c,d), C_O_K(d,GRAL), OK ) #define b_skn_gral(a,b,c,d) ( b_skn_po(a,b,c,d), C_O_K(d,GRAL), OK ) #define hplus_hecke(a,b) hplus(a,b) /* for ff.c */ #define S_FF_C(a) S_V_I(a,0) #define S_FF_CI(a) S_V_II(a,0) #define S_FF_IP(a) S_O_S(S_V_I(a,1)).ob_INTpointer #define C_FF_IP(a,p) S_O_S(S_V_I(a,1)).ob_INTpointer=(INT*)p #define S_FF_II(a,i) *((S_O_S(S_V_I(a,1)).ob_INTpointer) + i) #define S_FF_DI(a) S_FF_II(a,0) #define S_FF_ME(a) S_V_I(a,2) #define S_FF_MEI(a) S_V_II(a,2) /* for galois.c */ #define S_GR_CI(a) S_V_II(a,1) #define S_GR_C(a) S_V_I(a,1) #define S_GR_D(a) S_V_I(a,0) #define S_GR_DI(a) S_V_II(a,0) /* for longint */ extern INT loc_index, loc_size,loc_counter; extern struct loc **loc_speicher; extern INT longint_speicherindex,mem_counter_loc,longint_speichersize; extern struct longint **longint_speicher; #define FREE_LOC(a) \ FREE_MEMMANAGER(struct loc *,loc_speicher,loc_index,loc_size,loc_counter,a) #define LOCSGN(lx) ( ((lx)->w2 || (lx)->w1 || (lx)->w0 ) ? 1 : 0 ) #define LOCNULL(lx) ((lx)->w0=0,(lx)->w1=0,(lx)->w2=0) #define LOCHOLE(aloc) \ do {\ CALLOC_MEMMANAGER(struct loc,loc_speicher,loc_index,loc_counter,*(aloc));\ LOCNULL(*(aloc));\ (*(aloc))->nloc = NULL;\ } while(0) #define GANZDEFINIERE(x) \ do {\ (x)->signum = (signed char)0;\ (x)->laenge = (INT)1;\ (x)->floc = NULL;\ LOCHOLE(&((x)->floc)) ;\ } while (0) #define INTGANZ(x) \ ( x->signum < 0 ?\ - x->floc->w0 - x->floc->w1 * LO_B - x->floc->w2 * LO_B * LO_B :\ (x->floc->w0&BMINUSEINS)\ +(x->floc->w1&BMINUSEINS) * LO_B\ +(x->floc->w2&BMINUSEINS) * LO_B * LO_B ) #define T_LONGINT_INT(a)\ if ((S_O_S(a).ob_longint) ->laenge == 1)\ if (S_O_S(a).ob_longint ->floc ->w2 <= 1) /* AK 051101 */\ {\ INT wert = INTGANZ(S_O_S(a).ob_longint);\ FREESELF(a);\ M_I_I(wert,a);\ } #define INIT_LONGINT(l) \ do { \ C_O_K(l,LONGINT); \ CALLOC_MEMMANAGER(struct longint, longint_speicher,\ longint_speicherindex,mem_counter_loc,(l->ob_self).ob_longint);\ GANZDEFINIERE(S_O_S(l).ob_longint);\ } while(0) #define t_INTEGER_LONGINT(a,b) m_i_longint(a,b) #ifdef FAST #define SYMCHECK(a,b) #define COP(text,object) #define CTO(type,text,object) #define CTTO(type,type2,text,object) #define CTTTO(type,type2,type3,text,object) #define CTTTTO(type,type2,type3,type4,text,object) #define CTTTTTO(type,type2,type3,type4,type5,text,object) #define CTTTTTTO(type,type2,type3,type4,type5,type6,text,object) #define CTTTTTTTO(type,type2,type3,type4,type5,type6,type7,text,object) #define CTTTTTTTTO(type,type2,type3,type4,type5,type6,type7,type8,text,object) #define TCTO(type,text,object) #define TCTTO(type,type2,text,object) #define TCTTTO(type,type2,type3,text,object) #define TCTTTTO(type,type2,type3,type4,text,object) #define TCTTTTTO(type,type2,type3,type4,type5,text,object) #define TCTTTTTTO(type,type2,type3,type4,type5,type6,text,object) #define TCTTTTTTTO(type,type2,type3,type4,type5,type6,type7,text,object) #define TCTTTTTTTTO(type,type2,type3,type4,type5,type6,type7,type8,text,object) #else #define SYMCHECK(a,b) if (a) { erg += error(b); goto endr_ende; } #define COP(b,a) if (((void *)a) == NULL) { erg += null_object(b); goto endr_ende;} #define CTO(type,text,object) \ if (type == INTTYPE);\ else { \ COP(text,object);\ if (type == ANYTYPE);\ else if(S_O_K(object) != type) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ }\ } #define CTTO(type,type2,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&(S_O_K(object) != type2)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ } #define CTTTO(type,type2,type3,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&(S_O_K(object) != type2)\ &&(S_O_K(object) != type3)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende; } #define CTTTTO(type,type2,type3,type4,text,object) \ COP(text,object);\ if( (S_O_K(object) != type)\ &&(S_O_K(object) != type2)\ &&(S_O_K(object) != type3) \ &&(S_O_K(object) != type4)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende; } #define CTTTTTO(type,type2,type3,type4,type5,text,object) \ COP(text,object);\ if( (S_O_K(object) != type)\ &&(S_O_K(object) != type2)\ &&(S_O_K(object) != type3)\ &&(S_O_K(object) != type4)\ &&(S_O_K(object) != type5) ) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende; } #define CTTTTTTO(type,type2,type3,type4,type5,type6,text,object) \ COP(text,object);\ if( (S_O_K(object) != type)\ &&(S_O_K(object) != type2)\ &&(S_O_K(object) != type3)\ &&(S_O_K(object) != type4)\ &&(S_O_K(object) != type5)\ &&(S_O_K(object) != type6) ) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende; } #define CTTTTTTTO(type,type2,type3,type4,type5,type6,type7,text,object) \ COP(text,object);\ if( (S_O_K(object) != type)\ &&(S_O_K(object) != type2)\ &&(S_O_K(object) != type3)\ &&(S_O_K(object) != type4)\ &&(S_O_K(object) != type5)\ &&(S_O_K(object) != type7)\ &&(S_O_K(object) != type6) ) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende; } #define CTTTTTTTTO(type,type2,type3,type4,type5,type6,type7,type8,text,object) \ COP(text,object);\ if( (S_O_K(object) != type)\ &&(S_O_K(object) != type2)\ &&(S_O_K(object) != type3)\ &&(S_O_K(object) != type4)\ &&(S_O_K(object) != type5)\ &&(S_O_K(object) != type7)\ &&(S_O_K(object) != type8)\ &&(S_O_K(object) != type6) ) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende; } #define TCTO(type,text,object) \ CTO(type,text,object);\ if (type == INTTYPE) printf("%s= %ld\n",text,(INT)object);\ else { printf("%s=",text);println(object);} #define TCTTO(type,type2,text,object) \ CTTO(type,type2,text,object);\ printf("%s=",text);println(object); #define TCTTTO(type,type2,type3,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&\ (S_O_K(object) != type3)&&(S_O_K(object) != type2)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ }\ printf("%s=",text);println(object); #define TCTTTTO(type,type2,type3,type4,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&(S_O_K(object) != type4)&&\ (S_O_K(object) != type3)&&(S_O_K(object) != type2)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ }\ printf("%s=",text);println(object); #define TCTTTTTO(type,type2,type3,type4,type5,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&(S_O_K(object) != type4)&&\ (S_O_K(object) != type5)&&\ (S_O_K(object) != type3)&&(S_O_K(object) != type2)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ }\ printf("%s=",text);println(object); #define TCTTTTTTO(type,type2,type3,type4,type5,type6,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&(S_O_K(object) != type4)&&\ (S_O_K(object) != type5)&&(S_O_K(object) != type6)&&\ (S_O_K(object) != type3)&&(S_O_K(object) != type2)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ }\ printf("%s=",text);println(object); #define TCTTTTTTTO(type,type2,type3,type4,type5,type6,type7,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&(S_O_K(object) != type4)&&\ (S_O_K(object) != type5)&&(S_O_K(object) != type6)&&\ (S_O_K(object) != type7)&&\ (S_O_K(object) != type3)&&(S_O_K(object) != type2)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ }\ printf("%s=",text);println(object); #define TCTTTTTTTTO(type,type2,type3,type4,type5,type6,type7,type8,text,object) \ COP(text,object);\ if((S_O_K(object) != type)&&(S_O_K(object) != type4)&&\ (S_O_K(object) != type5)&&(S_O_K(object) != type6)&&\ (S_O_K(object) != type7)&&(S_O_K(object) != type8)&&\ (S_O_K(object) != type3)&&(S_O_K(object) != type2)) {\ erg += wrong_type_oneparameter(text,object);\ goto endr_ende;\ }\ printf("%s=",text);println(object); #endif #define C2R(a,b,t,c) if (check_result_2(a,b,t,c) \ != NORESULT) goto strlabel #define S2R(a,b,t,c) erg += store_result_2(a,b,t,c);strlabel: #define C3R(a,b,d,t,c) if (check_result_3(a,b,d,t,c)\ != NORESULT) goto strlabel #define S3R(a,b,d,t,c) erg += store_result_3(a,b,d,t,c);strlabel: #define C5R(a,b,d,e,f,t,c) if (check_result_5(a,b,d,e,f,t,c)\ != NORESULT) goto strlabel #define S5R(a,b,d,e,f,t,c) erg += store_result_5(a,b,d,e,f,t,c);strlabel: #define C0R(t,c) if (check_result_0(t,c)\ != NORESULT) goto strlabel #define S0R(t,c) erg += store_result_0(t,c);strlabel: #define C1R(a,t,c) if (check_result_1(a,t,c)\ != NORESULT) goto strlabel #define S1R(a,t,c) erg += store_result_1(a,t,c);strlabel: #define WTO(text,b) erg += wrong_type_oneparameter(text,b) #define WTT(text,b,c) erg += wrong_type_twoparameter(text,b,c) #define EDC(b) error_during_computation_code(b,erg) #define ENDR(a) endr_ende: if (erg != OK) EDC(a); return erg; #define ENDO(a) endr_ende: if (erg != OK) EDC(a); return (OP) NULL; #define ENDTYP(a,t) endr_ende: if (erg != OK) EDC(a); return (t) NULL; #define NYI(b) not_yet_implemented(b) #define NOP(a) null_object(a) #define EOP(text,object) \ COP(text,object);\ if (EMPTYP(object)) {erg += empty_object(text); goto endr_ende;} #define FATALERROR(text) fatal_error(text) #define CH2D(a,b) if ((a) == (b) ) { erg += equal_2_error(); goto endr_ende;} /* #define CE2(a,b,f) if (check_equal_2(a,b,f,&erg) == EQUAL) goto endr_ende; */ #define CE2A(a,b,f) if (check_equal_2a(a,b,f,&erg) == EQUAL) goto endr_ende; #define CE3(a,b,c,f) \ if ((a==c) && (b == c))\ {\ OP checkequal3_d = callocobject();\ *checkequal3_d = *c;\ C_O_K(c,EMPTY);\ erg += (*f)(checkequal3_d,checkequal3_d,c);\ erg += freeall(checkequal3_d);\ goto endr_ende;\ }\ else if (a==c)\ {\ OP checkequal3_d = callocobject();\ *checkequal3_d = *c;\ C_O_K(c,EMPTY);\ erg += (*f)(checkequal3_d,b,c);\ erg += freeall(checkequal3_d);\ goto endr_ende;\ }\ else if (b==c)\ {\ OP checkequal3_d = callocobject();\ *checkequal3_d = *c;\ C_O_K(c,EMPTY);\ erg += (*f)(a,checkequal3_d,c);\ erg += freeall(checkequal3_d);\ goto endr_ende;\ }\ else\ {\ if (c != NULL)\ FREESELF(c);\ } #define CE4(a,b,c,d,f) \ if (check_equal_4(a,b,c,d,\ f,&erg) == EQUAL) goto endr_ende; #define CE5(a,b,c,d,e,f) \ if (check_equal_5(a,b,c,d,e,\ f,&erg) == EQUAL) goto endr_ende; #define GET_BIT_I(a,i) (((*a) >> (i))&1) /* #define GET_BV_I(a,i) ((*(((unsigned char *)S_V_S(a) ) + ((i)>>3)) >> ((i)&7))&1) */ #define GET_BV_I(a,i) ((*(((unsigned char *)S_V_S(a) ) + ((i)>>3)) >> (7-((i)&7))&1)) #define GET_BV_B(a,i) (*(((unsigned char *)S_V_S(a) ) + (i)>>3)) /* #define UNSET_BV_I(a,i) (*((unsigned char *)S_V_S(a) + ((i)>>3)) &= (~(1 << ((i)&7)))) */ #define UNSET_BV_I(a,i) (\ *((unsigned char *)S_V_S(a) + ((i)>>3)) \ &= (~(1 << (7-((i)&7)) ) )\ ) #define UNSET_BIT_I(a,i) ((*(a)) &= (~(1 << (i)))) /* #define SET_BV_I(a,i) ( *((unsigned char *)S_V_S(a) + ((i)>>3)) |= (1 << ((i)&7))) */ #define SET_BV_I(a,i) ( *((unsigned char *)S_V_S(a) + ((i)>>3)) |= (128 >> ((i)&7))) #define SET_BIT_I(a,i) ( *(a) |= (1 << (i))) #define S_BV_LI(a) (S_V_LI(a) % 8 == 0 ? S_V_LI(a)>>3 : (S_V_LI(a)>>3) +1) #define cons_two cons_zwei #define ANFANG \ int main()\ {\ OP a,b,c,d,e,f,g,h;\ INT i,j,k;\ OP z=NULL;\ anfang();\ a=callocobject();\ b=callocobject();\ c=callocobject();\ d=callocobject();\ e=callocobject();\ f=callocobject();\ g=callocobject();\ h=callocobject(); #define ENDE \ freeall(a);\ freeall(b);\ freeall(c);\ freeall(d);\ freeall(e);\ freeall(f);\ freeall(g);\ freeall(h);\ ende();\ i=j=k=0;z=NULL;\ return 0;\ } #define SYM_BEGIN ANFANG #define SYM_END ENDE #define inhalt(a,b) content(a,b) #define inhalt_tableaux(a,b) content_tableaux(a,b) #define inhalt_word(a,b) content_word(a,b) /* FOR ALL macros */ #define FORALL_HASHTABLE_PRE060202(z,a,B)\ do { \ OP FORALL_E;INT I,J; \ for (FORALL_E=S_V_S(a), I=0; I=0;I--,z--) {B;}\ }\ else if (VECTORP(a)) {\ INT I=S_V_LI(a)-1;\ for (z=S_V_S(a)+I;I>=0;I--,z--) {B;}\ } /* new macros for main functions */ #define ABSOLUTE_INTEGER(a,b) \ M_I_I((S_I_I(a) > 0 ? S_I_I(a) : -S_I_I(a)), b) #define ADD_INTEGER(a,b,c) \ if (S_O_K(b) == INTEGER) erg += add_integer_integer(a,b,c);\ else if (S_O_K(b) == LONGINT) erg += add_longint_integer(b,a,c);\ else if (S_O_K(b) == BRUCH) erg += add_bruch_integer(b,a,c);\ else erg += add_integer(a,b,c) #define ADD(a,b,c) \ if (S_O_K(a) == INTEGER) ADD_INTEGER(a,b,c); \ else if (S_O_K(a) == LONGINT) \ {\ if (S_O_K(b) == INTEGER) erg += add_longint_integer(a,b,c);\ else if (S_O_K(b) == LONGINT) erg += add_longint_longint(b,a,c);\ else erg += add_longint(a,b,c);\ }\ else\ erg += add(a,b,c) #define ADD_APPLY_INTEGER(a,b)\ if (S_O_K(b) == INTEGER) erg += add_apply_integer_integer(a,b);\ else if (S_O_K(b) == LONGINT) erg += add_apply_integer_longint(a,b);\ else if (S_O_K(b) == BRUCH) erg += add_apply_integer_bruch(a,b);\ else erg += add_apply_integer(a,b) #define ADD_APPLY(a,b) \ if (S_O_K(a) == INTEGER) ADD_APPLY_INTEGER(a,b);\ else if (S_O_K(a) == LONGINT) \ {\ if (S_O_K(b) == INTEGER) erg += add_apply_longint_integer(a,b);\ else if (S_O_K(b) == LONGINT) erg += add_apply_longint_longint(a,b);\ else erg += add_apply_longint(a,b);\ }\ else if (S_O_K(a) == BRUCH) \ {\ if (S_O_K(b) == INTEGER) erg += add_apply_bruch_integer(a,b);\ else if (S_O_K(b) == BRUCH) erg += add_apply_bruch_bruch(a,b);\ else erg += add_apply_bruch(a,b);\ }\ else if (S_O_K(a) == INTEGERVECTOR) erg += add_apply_integervector(a,b);\ else if (S_O_K(a) == POLYNOM) erg += add_apply_polynom(a,b);\ else if (S_O_K(a) == FF) erg += add_apply_ff(a,b);\ else\ erg += add_apply(a,b) #define ADDINVERS_INTEGER(a,b) M_I_I(-S_I_I(a),b) #define ADDINVERS(a,b) \ if (S_O_K(a) == INTEGER) ADDINVERS_INTEGER(a,b);\ else if (S_O_K(a) == LONGINT) erg += addinvers_longint(a,b);\ else if (S_O_K(a) == BRUCH) erg += addinvers_bruch(a,b);\ else erg += addinvers(a,b) #define ADDINVERS_APPLY_LONGINT(a) erg += (GANZNEG(S_O_S(a).ob_longint),OK) #define ADDINVERS_APPLY_INTEGER(a) M_I_I( - S_I_I(a),a) #define ADDINVERS_APPLY(a)\ if (S_O_K(a) == INTEGER) ADDINVERS_APPLY_INTEGER(a);\ else if (S_O_K(a) == LONGINT) ADDINVERS_APPLY_LONGINT(a);\ else if (S_O_K(a) == BRUCH) erg += addinvers_apply_bruch(a);\ else if (S_O_K(a) == MONOM) erg += addinvers_apply_monom(a);\ else erg += addinvers_apply(a) #define BINOM_POSINTEGER_POSINTEGER(a,b,c)\ if (S_I_I(a) < BINOMLIMIT) {\ M_I_I( \ ( (S_I_I(b)>S_I_I(a)) ? 0 : binom_values [ S_I_I(a) ] [S_I_I(b)] )\ ,c);\ }\ else binom(a,b,c) /* #ifdef SYMMAGMA #define CALLOCOBJECT() \ ( (freeall_speicherposition >= 0L) ? \ freeall_speicher[freeall_speicherposition--] : \ mem_calloc(sizeof(struct object),1) ) #define CALLOCOBJECT() (OP)mem_calloc(sizeof(struct object),1) #else */ /* freeall_speicherposition is next free object */ #define CALLOCOBJECT() \ ( (freeall_speicherposition >= 0L) ? \ freeall_speicher[freeall_speicherposition--] : \ callocobject_fast() ) /* #endif */ #define CALLOCOBJECT2(a,b) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT(); } while(0) #define CALLOCOBJECT3(a,b,c) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT();c=CALLOCOBJECT(); } while(0) #define CALLOCOBJECT4(a,b,c,d) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT();c=CALLOCOBJECT(); d=CALLOCOBJECT();} while(0) #define CALLOCOBJECT5(a,b,c,d,e) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT();\ c=CALLOCOBJECT(); d=CALLOCOBJECT();\ e=CALLOCOBJECT();} while(0) #define CALLOCOBJECT6(a,b,c,d,e,f) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT();\ c=CALLOCOBJECT(); d=CALLOCOBJECT();\ e=CALLOCOBJECT(); f=CALLOCOBJECT(); } while(0) #define CALLOCOBJECT7(a,b,c,d,e,f,g) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT();\ c=CALLOCOBJECT(); d=CALLOCOBJECT();\ e=CALLOCOBJECT(); f=CALLOCOBJECT(); \ g=CALLOCOBJECT();} while(0) #define CALLOCOBJECT8(a,b,c,d,e,f,g,h) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT();\ c=CALLOCOBJECT(); d=CALLOCOBJECT();\ e=CALLOCOBJECT(); f=CALLOCOBJECT();h=CALLOCOBJECT(); \ g=CALLOCOBJECT();} while(0) #define CALLOCOBJECT9(a,b,c,d,e,f,g,h,i) \ do { a=CALLOCOBJECT(); b=CALLOCOBJECT(); h=CALLOCOBJECT(); i=CALLOCOBJECT();\ c=CALLOCOBJECT(); d=CALLOCOBJECT();\ e=CALLOCOBJECT(); f=CALLOCOBJECT(); \ g=CALLOCOBJECT();} while(0) #define COMP_INTEGER(a,b)\ ( S_O_K(b) == INTEGER ? COMP_INTEGER_INTEGER(a,b) : \ (S_O_K(b) == LONGINT ? - comp_longint_integer(b,a) : comp_integer(a,b) )\ ) #define COMP(a,b)\ ( S_O_K(a) == INTEGER ? COMP_INTEGER(a,b) :\ (S_O_K(a) == LONGINT ? comp_longint(a,b) : \ (S_O_K(a) == INTEGERMATRIX ? comp_integermatrix(a,b) : \ comp(a,b) \ )\ )\ ) #define COPY(a,b) \ ( (S_O_K(a) == INTEGER) ? M_I_I(S_I_I(a),b):\ ( (S_O_K(a) == LONGINT) ? copy_longint(a,b): \ ( (S_O_K(a) == BRUCH) ? copy_bruch(a,b): \ ( (S_O_K(a) == MONOM) ? copy_monom(a,b): \ ( (S_O_K(a) == PARTITION) ? copy_partition(a,b): \ ( (S_O_K(a) == HASHTABLE)? copy_hashtable(a,b): \ ( (S_O_K(a) == MATRIX)? copy_matrix(a,b): \ ( (S_O_K(a) == INTEGERMATRIX)? copy_integermatrix(a,b): \ copy(a,b)\ )\ )\ )\ )\ )\ )\ )\ ) #define CLEVER_COPY_INTEGER(a,b) \ do { switch(S_O_K(b)) {\ case INTEGER:\ case EMPTY:\ M_I_I(S_I_I(a),b);\ break;\ default:\ FREESELF(b);\ M_I_I(S_I_I(a),b);\ break;\ }\ } while (0) #define CLEVER_COPY_FF(a,b) \ do { switch(S_O_K(b)) {\ case INTEGER:\ C_O_K(b,EMPTY);\ case EMPTY:\ erg += copy_ff(a,b);\ break;\ case FF:\ {\ INT *ap,*bp,i;\ COPY(S_FF_C(a),S_FF_C(b));\ COPY(S_FF_ME(a),S_FF_ME(b));\ ap =S_FF_IP(a);bp=S_FF_IP(b);\ if (*ap != *bp)\ bp = (INT*) SYM_realloc(bp,(S_FF_DI(a)+1)*sizeof(INT));\ for(i=0;i<=ap[0];i++) bp[i]=ap[i];\ C_FF_IP(b,bp);\ };\ break; \ default:\ FREESELF(b);\ erg += copy_ff(a,b);\ break;\ }\ } while (0) #define CLEVER_COPY_BRUCH(a,b) \ do { switch(S_O_K(b)) {\ case INTEGER:\ C_O_K(b,EMPTY);\ case EMPTY:\ erg += copy_bruch(a,b);\ break;\ case BRUCH:\ FREESELF(S_B_O(b));\ FREESELF(S_B_U(b));\ COPY(S_B_O(a),S_B_O(b));\ COPY(S_B_U(a),S_B_U(b));\ C_B_I(b,S_B_I(a));\ break;\ default:\ FREESELF(b);\ erg += copy_bruch(a,b);\ break;\ }\ } while (0) #define CLEVER_COPY_LONGINT(a,b)\ do { switch(S_O_K(b)) {\ case INTEGER:\ C_O_K(b,EMPTY);\ case EMPTY:\ erg += copy_longint(a,b);\ break;\ default:\ FREESELF(b);\ erg += copy_longint(a,b);\ break;\ }\ } while(0) #define CLEVER_COPY_PARTITION(a,b)\ do { switch(S_O_K(b)) {\ case INTEGER:\ C_O_K(b,EMPTY);\ case EMPTY:\ erg += copy_partition(a,b);\ break;\ case PARTITION:\ FREESELF(S_PA_S(b));\ if (S_O_K(S_PA_S(a))==INTEGERVECTOR) copy_integervector(S_PA_S(a),S_PA_S(b));\ else COPY(S_PA_S(a),S_PA_S(b));\ C_PA_K(b, S_PA_K(a));\ C_PA_HASH(b, S_PA_HASH(a));\ break;\ default:\ FREESELF(b);\ erg += copy_partition(a,b);\ break;\ }\ } while(0) #define CLEVER_COPY(a,b) \ do { if (S_O_K(a) == INTEGER) CLEVER_COPY_INTEGER(a,b);\ else if (S_O_K(a) == LONGINT) CLEVER_COPY_LONGINT(a,b);\ else if (S_O_K(a) == BRUCH) CLEVER_COPY_BRUCH(a,b);\ else if (S_O_K(a) == PARTITION) CLEVER_COPY_PARTITION(a,b);\ else if (S_O_K(a) == FF) CLEVER_COPY_FF(a,b);\ else { erg += copy(a,b); }\ } while(0) #define DEC(a)\ if (S_O_K(a) == INTEGER) DEC_INTEGER(a);\ else if (S_O_K(a) == LONGINT) erg+= dec_longint(a);\ else dec(a) #define EINSP_LONGINT(a)\ (\ ((S_O_S(a).ob_longint) ->floc ->w0 == 1) \ &&\ ((S_O_S(a).ob_longint) ->floc ->w1 == 0)\ &&\ ((S_O_S(a).ob_longint) ->floc ->w2 == 0)\ &&\ ((S_O_S(a).ob_longint) ->signum == 1)\ &&\ ((S_O_S(a).ob_longint) ->laenge == 1)\ ) #define EINSP(a)\ ( S_O_K(a) == INTEGER ? EINSP_INTEGER(a): \ ( S_O_K(a) == LONGINT ? EINSP_LONGINT(a) : \ ( S_O_K(a) == BRUCH ? EINSP_BRUCH(a) : \ ( einsp(a) ) \ ) \ ) \ ) #define EVEN_INTEGER(a) (S_I_I(a) % 2 == 0) #define EVEN_LONGINT(a) \ (\ ((S_O_S(a).ob_longint) ->signum == 0) \ ||\ ((S_O_S(a).ob_longint) ->floc ->w0 % 2 == 0)\ ) #define EVEN(a) \ ( S_O_K(a) == INTEGER ? (EVEN_INTEGER(a)) : \ ( S_O_K(a) == LONGINT ? EVEN_LONGINT(a) : even(a) )\ ) #define FREE_EMPTY_OBJECT(a)\ do {\ CTO(EMPTY,"FREE_EMPTY_OBJECT(1)",a);\ if (freeall_speichersize+SPEICHERSIZE (INT)0) SYM_free(S_V_S(a));\ FREEALL_INTEGER(S_V_L(a));\ freevectorstruct(S_O_S(a).ob_vector);\ C_O_K(a,EMPTY);\ } while(0) #define FREEALL_INTEGERVECTOR(a) do { \ FREESELF_INTEGERVECTOR(a); FREE_EMPTY_OBJECT(a); } while(0) #define FREESELF(a) \ if (S_O_K(a) == EMPTY);\ else if (S_O_K(a) == INTEGER) C_O_K(a,EMPTY);\ else if (S_O_K(a) == LONGINT) erg += freeself_longint(a); \ else if (S_O_K(a) == BRUCH) erg += freeself_bruch(a); \ else if (S_O_K(a) == PARTITION) erg += freeself_partition(a); \ else if (S_O_K(a) == MATRIX) erg += freeself_matrix(a); \ else if (S_O_K(a) == INTEGERMATRIX) erg += freeself_integermatrix(a); \ else if (S_O_K(a) == MONOM) FREESELF_MONOM(a); \ else if (S_O_K(a) == INTEGERVECTOR) FREESELF_INTEGERVECTOR(a); \ else if (S_O_K(a) == VECTOR) erg += freeself_vector(a); \ else if (S_O_K(a) == HASHTABLE) erg += freeself_hashtable(a); \ else if (LISTP(a)) erg += freeself_list(a); \ else if (S_O_K(a) == PERMUTATION) erg += freeself_permutation(a); \ else if (S_O_K(a) == SKEWPARTITION) erg += freeself_skewpartition(a); \ else if (S_O_K(a) == FF) erg += freeself_ff(a); \ else erg += freeself(a) #define FREESELF2(a,b) do { FREESELF(a); FREESELF(b); } while(0) #define FREESELF2(a,b) do { FREESELF(a); FREESELF(b); } while(0) #define FREESELF3(a,b,c) do { FREESELF(a); FREESELF(b); FREESELF(c); } while(0) #define FREESELF4(a,b,c,d) do { FREESELF2(a,b); FREESELF2(c,d); } while(0) #define FREESELF5(a,b,c,d,e) do { FREESELF2(a,b); FREESELF3(c,d,e); } while(0) #define FREESELF6(a,b,c,d,e,f) do { FREESELF3(a,b,f); FREESELF3(c,d,e); } while(0) #define FREESELF7(a,b,c,d,e,f,g) do { FREESELF4(a,b,f,g); FREESELF3(c,d,e); } while(0) #define FREEALL(a) do { FREESELF(a); FREE_EMPTY_OBJECT(a); } while(0) #define FREEALL2(a,b) do { FREEALL(a); FREEALL(b); } while(0) #define FREEALL3(a,b,c) do { FREEALL(a); FREEALL(b); FREEALL(c); } while(0) #define FREEALL4(a,b,c,d) do { FREEALL(a); FREEALL(b); FREEALL(c);FREEALL(d); } while(0) #define FREEALL5(a,b,c,d,e) do { FREEALL2(a,b); FREEALL3(c,d,e); } while(0) #define FREEALL6(a,b,c,d,e,f) do { FREEALL3(a,b,f); FREEALL3(c,d,e); } while(0) #define FREEALL7(a,b,c,d,e,f,g) do { FREEALL4(a,b,f,g); FREEALL3(c,d,e); } while(0) #define FREEALL8(a,b,c,d,e,f,g,h) do { FREEALL4(a,b,f,g); FREEALL4(c,d,e,h); } while(0) #define FREEALL9(a,b,c,d,e,f,g,h,i) do { FREEALL4(a,b,f,g); FREEALL5(c,d,e,h,i); } while(0) #define GANZDIV_INTEGER(a,b,c) \ if (S_O_K(b) == INTEGER) M_I_I(S_I_I(a)/S_I_I(b),c);\ else if (S_O_K(b) == LONGINT) erg += ganzdiv_integer_longint(a,b,c);\ else erg += ganzdiv_integer(a,b,c) #define GANZDIV_LONGINT(a,b,c) \ if (S_O_K(b) == INTEGER) erg += ganzdiv_longint_integer(a,b,c);\ else if (S_O_K(b) == LONGINT) erg += ganzdiv_longint_longint(a,b,c);\ else erg += ganzdiv_longint(a,b,c) #define GANZDIV(a,b,c) \ if (S_O_K(a) == INTEGER) GANZDIV_INTEGER(a,b,c); \ else if (S_O_K(a) == LONGINT) GANZDIV_LONGINT(a,b,c); \ else\ erg += ganzdiv(a,b,c) #define GANZDIV_APPLY_INTEGER(a,b) \ if (S_O_K(b) == INTEGER) M_I_I(S_I_I(a)/S_I_I(b),a);\ else ganzdiv_apply_integer(a,b) #define GANZDIV_APPLY_LONGINT(a,b) \ if (S_O_K(b) == INTEGER) erg += ganzdiv_apply_longint_integer(a,b);\ else if (S_O_K(b) == LONGINT) erg += ganzdiv_apply_longint_longint(a,b);\ else ganzdiv_apply_longint(a,b) #define GANZDIV_APPLY(a,b) \ if (S_O_K(a) == INTEGER) GANZDIV_APPLY_INTEGER(a,b);\ else if (S_O_K(a) == LONGINT) GANZDIV_APPLY_LONGINT(a,b);\ else\ erg += ganzdiv_apply(a,b); #define GGT_INTEGER(a,b,c) \ if (S_O_K(b) == INTEGER) erg += ggt_integer_integer(a,b,c);\ else if (S_O_K(b) == LONGINT) erg += ggt_integer_longint(a,b,c);\ else erg += ggt_integer(a,b,c) #define GGT_LONGINT(a,b,c) \ if (S_O_K(b) == INTEGER) erg += ggt_integer_longint(b,a,c);\ else if (S_O_K(b) == LONGINT) erg += ggt_longint_longint(a,b,c);\ else erg += ggt_longint(a,b,c) #define GGT(a,b,c) \ if (S_O_K(a) == INTEGER) GGT_INTEGER(a,b,c); \ else if (S_O_K(a) == LONGINT) GGT_LONGINT(a,b,c); \ else\ erg += ggt(a,b,c) #define HALF_APPLY_INTEGER(a) M_I_I((S_I_I(a) >> 1),a) #define HALF_APPLY(a)\ if (S_O_K(a) == INTEGER)\ HALF_APPLY_INTEGER(a);\ else if (S_O_K(a) == LONGINT)\ half_apply_longint(a);\ else\ erg += half_apply(a)\ #define HASH_INTEGERVECTOR(a,res)\ if (S_V_LI(a) == 0) res=4711;\ else {\ INT hash_integer_vector_i;\ res = S_V_II(a,0);\ for (hash_integer_vector_i=1;hash_integer_vector_i= 10000L) ? 5 : 4) #define INTLOGPOS5_3(ai) (( ai >= 1000L) ? INTLOGPOS5_4(ai) : 3) #define INTLOGPOS2_1(ai) (( ai >= 10L) ? 2 : 1) #define INTLOGPOS5_1(ai) (( ai >= 100L) ? INTLOGPOS5_3(ai) : INTLOGPOS2_1(ai)) #define INTLOGPOS7_6(ai) (( ai >= 1000000L) ? 7 : 6) #define INTLOGPOS10_9(ai) (( ai >= 1000000000L)? 10 : 9) #define INTLOGPOS10_8(ai) (( ai >= 100000000L) ? INTLOGPOS10_9(ai) : 8) #define INTLOGPOS10_6(ai) (( ai >= 10000000L ) ? INTLOGPOS10_8(ai) : INTLOGPOS7_6(ai) ) #define INTLOGPOS(ai) (( ai >= 100000L ) ? INTLOGPOS10_6(ai) : INTLOGPOS5_1(ai) ) #define INTLOG(a) ( (S_I_I(a)) >= 0 ? INTLOGPOS(S_I_I(a)) : INTLOGPOS(-S_I_I(a)) ) #define INVERS_INTEGER(a,b) do {\ if (S_I_I(a)==1) M_I_I(1,b); else \ if (S_I_I(a)==-1) M_I_I(-1,b); else \ { b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),b); \ M_I_I(1,S_B_O(b)); \ M_I_I(S_I_I(a),S_B_U(b)); \ C_B_I(b,GEKUERZT); \ }\ } while(0) #define INVERS_LONGINT(a,b) \ do { b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),b); M_I_I(1,S_B_O(b)); \ copy_longint(a,S_B_U(b)); C_B_I(b,GEKUERZT) ; } while(0) #define INVERS_BRUCH(a,b) \ do { b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),b); COPY(S_B_O(a),S_B_U(b)); \ COPY(S_B_U(a), S_B_O(b)); C_B_I(b,S_B_I(a)) ;} while(0) #define INVERS(a,b) \ if (S_O_K(a) == INTEGER) INVERS_INTEGER(a,b);\ else if (S_O_K(a) == LONGINT) INVERS_LONGINT(a,b);\ else if (S_O_K(a) == BRUCH) INVERS_BRUCH(a,b);\ else\ erg += invers(a,b) #define KUERZEN(a)\ if (S_O_K(S_B_O(a)) == INTEGER) {\ if (S_O_K(S_B_U(b)) == INTEGER) erg += kuerzen_integer_integer(a);\ else if (S_O_K(S_B_U(b)) == LONGINT) erg += kuerzen_integer_longint(a);\ else erg += krz(a);\ }\ else if (S_O_K(S_B_O(a)) == LONGINT) {\ if (S_O_K(S_B_U(b)) == INTEGER) erg += kuerzen_longint_integer(a);\ else if (S_O_K(S_B_U(b)) == LONGINT) erg += kuerzen_longint_longint(a);\ else erg += krz(a);\ }\ else krz(a) #define MOD_APPLY_INTEGER(a,b) \ if (S_O_K(b) == INTEGER) M_I_I(S_I_I(a) % S_I_I(b), a);\ else if (S_O_K(b) == LONGINT) erg += mod_apply_integer_longint(a,b);\ else mod_apply(a,b) #define MOD_APPLY(a,b) \ if (S_O_K(a) == INTEGER) MOD_APPLY_INTEGER(a,b);\ else if (S_O_K(a) == LONGINT) erg += mod_apply_longint(a,b);\ else erg += mod_apply(a,b) #define MULT_APPLY_INTEGER_INTEGER(a,b) \ if ( NULLP_INTEGER(a) || NULLP_INTEGER(b) ) \ { \ M_I_I(0,b); \ } \ else if ( (INTLOG(a) + INTLOG(b)) > 9L )\ {\ erg += t_int_longint(b,b);\ erg += mult_apply_integer_longint(a,b);\ }\ else M_I_I(S_I_I(a)*S_I_I(b),b) #define MULT_APPLY_INTEGER(a,b) \ if (S_O_K(b) == INTEGER) MULT_APPLY_INTEGER_INTEGER(a,b);\ else if (S_O_K(b) == LONGINT) erg += mult_apply_integer_longint(a,b);\ else if (S_O_K(b) == BRUCH) erg += mult_apply_integer_bruch(a,b);\ else if (S_O_K(b) == MONOM) erg += mult_apply_integer_monom(a,b);\ else if (POLYP(b)) erg += mult_apply_integer_polynom(a,b);\ else if (S_O_K(b) == HASHTABLE) erg += mult_apply_integer_hashtable(a,b);\ else erg += mult_apply_integer(a,b) #define MULT_APPLY_LONGINT(a,b)\ if (S_O_K(b) == INTEGER) erg += mult_apply_longint_integer(a,b);\ else if (S_O_K(b) == LONGINT) erg += mult_apply_longint_longint(a,b);\ else if (S_O_K(b) == BRUCH) erg += mult_apply_longint_bruch(a,b);\ else if (POLYP(b)) erg += mult_apply_longint_polynom(a,b);\ else erg += mult_apply_longint(a,b) #define MULT_APPLY_BRUCH(a,b)\ if (S_O_K(b) == INTEGER) erg += mult_apply_bruch_integer(a,b);\ else if (S_O_K(b) == LONGINT) erg += mult_apply_bruch_longint(a,b);\ else if (S_O_K(b) == BRUCH) erg += mult_apply_bruch_bruch(a,b);\ else if (POLYP(b)) erg += mult_apply_bruch_polynom(a,b);\ else if (S_O_K(b) == HASHTABLE) erg += mult_apply_bruch_hashtable(a,b);\ else erg += mult_apply_bruch(a,b) #define MULT_APPLY(a,b) \ if (S_O_K(a) == INTEGER) MULT_APPLY_INTEGER(a,b);\ else if (S_O_K(a) == LONGINT) MULT_APPLY_LONGINT(a,b);\ else if (S_O_K(a) == BRUCH) MULT_APPLY_BRUCH(a,b);\ else if (S_O_K(a) == POLYNOM) erg += mult_apply_polynom(a,b);\ else if (S_O_K(a) == FF) erg += mult_apply_ff(a,b);\ else\ erg += mult_apply(a,b) #define MULT_INTEGER_INTEGER(a,b,c) \ if (INTLOG(a) + INTLOG(b) > 9) {\ OP mii_c= CALLOCOBJECT();\ erg += t_int_longint(a,mii_c);\ erg += mult_longint_integer(mii_c,b,c);\ FREEALL(mii_c);\ }\ else\ M_I_I(S_I_I(a)*S_I_I(b),c) #define MULT_INTEGER(a,b,c) \ if (S_O_K(b) == INTEGER) MULT_INTEGER_INTEGER(a,b,c);\ else if (S_O_K(b) == LONGINT) erg += mult_longint_integer(b,a,c);\ else if (S_O_K(b) == BRUCH) erg += mult_bruch_integer(b,a,c);\ else if (S_O_K(b) == CYCLOTOMIC) erg += mult_scalar_cyclo(a,b,c);\ else erg += mult_integer(a,b,c) #define MULT_LONGINT(a,b,c) \ if (S_O_K(b) == INTEGER) erg += mult_longint_integer(a,b,c);\ else if (S_O_K(b) == LONGINT) erg += mult_longint_longint(b,a,c);\ else if (S_O_K(b) == CYCLOTOMIC) erg += mult_scalar_cyclo(a,b,c);\ else erg += mult_longint(a,b,c) #define MULT_BRUCH(a,b,c) \ if (S_O_K(b) == INTEGER) erg += mult_bruch_integer(a,b,c);\ else if (S_O_K(b) == LONGINT) erg += mult_bruch_longint(a,b,c);\ else if (S_O_K(b) == BRUCH) erg += mult_bruch_bruch(a,b,c);\ else if (S_O_K(b) == CYCLOTOMIC) erg += mult_scalar_cyclo(a,b,c);\ else erg += mult_bruch(a,b,c) #define MULT(a,b,c) \ if (S_O_K(a) == INTEGER) MULT_INTEGER(a,b,c); \ else if (S_O_K(a) == LONGINT) MULT_LONGINT(a,b,c); \ else if (S_O_K(a) == BRUCH) MULT_BRUCH(a,b,c);\ else if (S_O_K(a) == CYCLOTOMIC) mult_cyclo(a,b,c);\ else if (S_O_K(a) == FF) mult_ff(a,b,c);\ else if (S_O_K(a) == SQ_RADICAL) mult_sqrad(a,b,c);\ else\ erg += mult(a,b,c) #define MULT_SCALAR_MONOMLIST(a,b,c)\ if ((NULLP(a))|| (NULLP(b))) erg += init(S_O_K(b),c);\ else erg += trans2formlist(a,b,c,mult) #define CLEVER_MULT_INTEGER(a,b,c)\ do {\ FREESELF(c); MULT_INTEGER(a,b,c);\ } while(0) #define CLEVER_MULT_LONGINT(a,b,c)\ do {\ FREESELF(c); MULT_LONGINT(a,b,c);\ } while(0) #define CLEVER_MULT_BRUCH(a,b,c)\ if (S_O_K(b) == BRUCH) {\ switch (S_O_K(c)) {\ case INTEGER: C_O_K(c,EMPTY);\ case EMPTY:\ case BRUCH: erg += mult_bruch_bruch(a,b,c); break;\ default: FREESELF(c); mult_bruch_bruch(a,b,c); break;\ }\ }\ else do { FREESELF(c); MULT_BRUCH(a,b,c); } while(0) #define CLEVER_MULT_FF(a,b,c)\ if (S_O_K(b) == FF) {\ switch (S_O_K(c)) {\ case INTEGER: C_O_K(c,EMPTY);\ case EMPTY:\ case BRUCH: erg += mult_ff_ff(a,b,c); break;\ default: FREESELF(c); mult_ff_ff(a,b,c); break;\ }\ }\ else do { FREESELF(c); erg += mult_ff(a,b,c); } while(0) #define CLEVER_MULT(a,b,c) \ if (S_O_K(a) == INTEGER) CLEVER_MULT_INTEGER(a,b,c); \ else if (S_O_K(a) == LONGINT) CLEVER_MULT_LONGINT(a,b,c); \ else if (S_O_K(a) == BRUCH) CLEVER_MULT_BRUCH(a,b,c);\ else if (S_O_K(a) == FF) CLEVER_MULT_FF(a,b,c);\ else\ do { FREESELF(c); MULT(a,b,c); } while(0) #define NEGEINSP_LONGINT(a)\ (\ ((S_O_S(a).ob_longint) ->floc ->w0 == 1) \ &&\ ((S_O_S(a).ob_longint) ->floc ->w1 == 0)\ &&\ ((S_O_S(a).ob_longint) ->floc ->w2 == 0)\ &&\ ((S_O_S(a).ob_longint) ->signum == -1)\ &&\ ((S_O_S(a).ob_longint) ->laenge == 1)\ ) #define NEGEINSP(a)\ ( S_O_K(a) == INTEGER ? NEGEINSP_INTEGER(a): \ ( S_O_K(a) == LONGINT ? NEGEINSP_LONGINT(a) : \ ( negeinsp(a) ) \ ) \ ) #define NEGP_LONGINT(a) (GANZSIGNUM(S_O_S(a).ob_longint) == (signed char)-1) #define NEGP(a) \ ( S_O_K(a) == INTEGER ? (NEGP_INTEGER(a)) : \ ( S_O_K(a) == LONGINT ? NEGP_LONGINT(a) : negp(a) )\ ) #define NEW_HASHTABLE(c)\ do { c = CALLOCOBJECT(); erg += init_hashtable(c); } while(0) #define CLEAR_HASHTABLE(c) /* removes all entries in a hashtable */ \ do { OP z,zz;INT i,j;\ for (i=0,z=S_V_S(c);ifloc ->w0 % 2 == 1) #define ODD(a) \ ( S_O_K(a) == INTEGER ? (ODD_INTEGER(a)) : \ ( S_O_K(a) == LONGINT ? ODD_LONGINT(a) : odd(a) )\ ) #define PARTITION_WEIGHT(a,i) \ do { \ OP z; \ INT j; \ for(j=S_PA_LI(a),i=0,z=S_V_S(S_PA_S(a));j>0;j--,z++) \ i+=S_I_I(z); \ } while(0) #define MAXPARTI(a) ((S_PA_LI(a) == 0) ? 0 : S_PA_II(a,S_PA_LI(a)-1) ) #define POSP_LONGINT(a) (GANZSIGNUM(S_O_S(a).ob_longint) == (signed char)1) #define POSP(a) \ ( S_O_K(a) == INTEGER ? (POSP_INTEGER(a)) : \ ( S_O_K(a) == LONGINT ? POSP_LONGINT(a) : posp(a) )\ ) #define SWAP(a,b) do { \ struct object swap_object; \ swap_object = *a; \ *a = *b; \ *b = swap_object; \ } while(0) #define CE2(a,b,f) \ if (a==b) {\ OP checkequal2_c = CALLOCOBJECT();\ *checkequal2_c = *b;\ C_O_K(b,EMPTY);\ erg += (*f)(checkequal2_c,b);\ FREEALL(checkequal2_c);\ goto endr_ende;\ }\ else FREESELF(b) /* used for transfunctions */ #define TCE2(a,b,f,typ) \ if (a==b) {\ OP checkequal2_c = CALLOCOBJECT();\ *checkequal2_c = *b;\ C_O_K(b,EMPTY);\ erg += (*f)(checkequal2_c,b);\ FREEALL(checkequal2_c);\ goto endr_ende;\ }\ else if ( (S_O_K(b) != HASHTABLE) && (S_O_K(b) != typ) ) \ FREESELF(b) #define ADD_KOEFF(a,b) \ ADD_APPLY(S_MO_K(a), S_MO_K(b));\ if (NULLP(S_MO_K(b)))\ FREESELF_MONOM(b) #define M_FORALL_MONOMIALS_IN_AB(a,b,c,f,partf)\ {\ OP ff,z,y;\ ff = CALLOCOBJECT();\ FORALL (y,a, {\ FORALL (z,b, {\ FREESELF(ff);\ MULT(S_MO_K(z),S_MO_K(y),ff);\ if (not EINSP(f))\ {\ MULT_APPLY(f,ff);\ }\ erg += (*partf)(S_MO_S(y),S_MO_S(z),c,ff);\ } );\ } );\ FREEALL(ff);\ } #define M2_FORALL_MONOMIALS_IN_AB(a,b,c,f,m,partf)\ {\ OP ff,z,y;\ ff = CALLOCOBJECT();\ FORALL (y,a, {\ FORALL (z,b, {\ FREESELF(ff);\ MULT(S_MO_K(z),S_MO_K(y),ff);\ if (not EINSP(f))\ {\ MULT_APPLY(f,ff);\ }\ erg += (*partf)(S_MO_S(y),S_MO_S(z),c,ff,m);\ } );\ } );\ FREEALL(ff);\ } #define M3_FORALL_MONOMIALS_IN_AB(a,b,c,f,m,l,partf)\ {\ OP ff,z,y;\ ff = CALLOCOBJECT();\ FORALL (y,a, {\ FORALL (z,b, {\ FREESELF(ff);\ MULT(S_MO_K(z),S_MO_K(y),ff);\ if (not EINSP(f))\ {\ MULT_APPLY(f,ff);\ }\ erg += (*partf)(S_MO_S(y),S_MO_S(z),c,ff,m,l);\ } );\ } );\ FREEALL(ff);\ } #define M_FORALL_MONOMIALS_IN_B(a,b,c,f,partf)\ {\ OP ff,z;\ if (not EINSP(f)) {\ ff = CALLOCOBJECT();\ FORALL (z,b, {\ FREESELF(ff);\ MULT(S_MO_K(z),f,ff);\ erg += (*partf)(a,S_MO_S(z),c,ff);\ } );\ FREEALL(ff);\ }\ else {\ FORALL (z,b, {\ erg += (*partf)(a,S_MO_S(z),c,S_MO_K(z));\ } );\ }\ } #define M2_FORALL_MONOMIALS_IN_B(a,b,c,f,m,partf)\ {\ OP ff,z;\ if (not EINSP(f)) {\ ff = CALLOCOBJECT();\ FORALL (z,b, {\ MULT(S_MO_K(z),f,ff);\ erg += (*partf)(a,S_MO_S(z),c,ff,m);\ FREESELF(ff);\ } );\ FREEALL(ff);\ }\ else {\ FORALL (z,b, {\ erg += (*partf)(a,S_MO_S(z),c,S_MO_K(z),m);\ } );\ }\ } #define M3_FORALL_MONOMIALS_IN_B(a,b,c,f,m,l,partf)\ {\ OP ff,z;\ if (not EINSP(f)) {\ ff = CALLOCOBJECT();\ FORALL (z,b, {\ MULT(S_MO_K(z),f,ff);\ erg += (*partf)(a,S_MO_S(z),c,ff,m,l);\ FREESELF(ff);\ } );\ FREEALL(ff);\ }\ else {\ FORALL (z,b, {\ erg += (*partf)(a,S_MO_S(z),c,S_MO_K(z),m,l);\ } );\ }\ } #define M_FORALL_MONOMIALS_IN_A(a,b,c,f,partf)\ {\ OP ff,z;\ if (not EINSP(f)) {\ ff = CALLOCOBJECT();\ FORALL (z,a, {\ MULT(S_MO_K(z),f,ff);\ erg += (*partf)(S_MO_S(z),b,c,ff);\ FREESELF(ff);\ } );\ FREEALL(ff);\ }\ else {\ FORALL (z,a, {\ erg += (*partf)(S_MO_S(z),b,c,S_MO_K(z));\ } );\ }\ } #define M2_FORALL_MONOMIALS_IN_A(a,b,c,f,m,partf)\ {\ OP ff,z;\ if (not EINSP(f)) {\ ff = CALLOCOBJECT();\ FORALL (z,a, {\ MULT(S_MO_K(z),f,ff);\ erg += (*partf)(S_MO_S(z),b,c,ff,m);\ FREESELF(ff);\ } );\ FREEALL(ff);\ }\ else {\ FORALL (z,a, {\ erg += (*partf)(S_MO_S(z),b,c,S_MO_K(z),m);\ } );\ }\ } #define M3_FORALL_MONOMIALS_IN_A(a,b,c,f,m,l,partf)\ {\ OP ff,z;\ if (not EINSP(f)) {\ ff = CALLOCOBJECT();\ FORALL (z,a, {\ MULT(S_MO_K(z),f,ff);\ erg += (*partf)(S_MO_S(z),b,c,ff,m,l);\ FREESELF(ff);\ } );\ FREEALL(ff);\ }\ else {\ FORALL (z,a, {\ erg += (*partf)(S_MO_S(z),b,c,S_MO_K(z),m,l);\ } );\ }\ } #define T_FORALL_MONOMIALS_IN_A(a,b,f,partf)\ {\ OP ff,z;\ if (not EINSP(f)) {\ ff = CALLOCOBJECT();\ FORALL (z,a, {\ MULT(S_MO_K(z),f,ff);\ erg += (*partf)(S_MO_S(z),b,ff);\ FREESELF(ff);\ } );\ FREEALL(ff);\ }\ else {\ FORALL (z,a, {\ erg += (*partf)(S_MO_S(z),b,S_MO_K(z));\ } );\ }\ } #define _NULL_PARTITION_(b,c,f) \ do { OP m;\ CTO(PARTITION,"_NULL_PARTITION_(1)",b);\ m=CALLOCOBJECT(); \ erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m);\ erg += copy_partition(b,S_MO_S(m));\ COPY(f,S_MO_K(m));\ if (S_O_K(c)==HASHTABLE)\ insert_scalar_hashtable(m,c,add_koeff,eq_monomsymfunc,hash_monompartition);\ else \ INSERT_LIST(m,c,add_koeff,comp_monommonomial);\ } while(0) #define WEIGHT_HASHTABLE(a) S_V_II(a,S_V_LI(a)) #define NEQ(a,b) (! EQ(a,b)) #define GR(a,b) (COMP(a,b) > (INT)0) #define GT(a,b) (COMP(a,b) > (INT)0) #define GE(a,b) (COMP(a,b) >= (INT)0) #define LE(a,b) (COMP(a,b) <= (INT)0) #define LT(a,b) (COMP(a,b) < (INT)0) /* speicher managment */ #define FREE_MEMMANAGER(t,s,i,g,c,v)\ do {\ c--;\ if ((i+1) == g) {\ if (g+SPEICHERSIZE =0) v = s[i--];\ else v = (t*) SYM_MALLOC(sizeof(t));\ } while(0) #define ANFANG_MEMMANAGER(s,i,g,c) \ s = NULL; i = -1; c = 0; g = 0 #define ENDE_MEMMANAGER(s,i,g,c,text) \ if (no_banner != TRUE) { SYMCHECK(c, text);} \ if (s != NULL) { \ INT jj;\ for (jj = 0; jj<=i;jj++) SYM_FREE(s[jj]);\ SYM_FREE(s);\ s = NULL;\ }\ i = -1;\ g = 0 #define MACRO_H #endif /* MACRO_H */ symmetrica-2.0/makefile0000600017361200001450000000236310726170072015103 0ustar tabbottcrontab.c.o: cc -c -O2 -DFAST -DALLTRUE $< test: test.c bar.o bi.o boe.o bruch.o classical.o de.o di.o ff.o galois.o ga.o gra.o hash.o hiccup.o io.o ko.o list.o lo.o ma.o mee.o mem.o mes.o mhe.o mhh.o mhm.o mhp.o mhs.o mmm.o mms.o mod_dg_sbd.o mo.o mpp.o mps.o mse.o msh.o msm.o mss.o muir.o na.o nb.o nc.o nu.o part.o pee.o peh.o pem.o perm.o pes.o phe.o phh.o phm.o phs.o plet.o pme.o pmh.o poly.o ppe.o pph.o ppm.o ppp.o pps.o pr.o pse.o psh.o psm.o pss.o rest.o rh.o sab.o sb.o sc.o sr.o ta.o teh.o tem.o tep.o tes.o the.o thm.o thp.o ths.o tme.o tmh.o tmp.o tms.o tpe.o tph.o tpm.o tps.o tse.o tsh.o tsm.o tsp.o vc.o zo.o zykelind.o zyk.o gcc -DALLTRUE -DFAST test.c bar.o bi.o boe.o bruch.o classical.o de.o di.o ff.o galois.o ga.o gra.o hash.o hiccup.o io.o ko.o list.o lo.o ma.o mee.o mem.o mes.o mhe.o mhh.o mhm.o mhp.o mhs.o mmm.o mms.o mod_dg_sbd.o mo.o mpp.o mps.o mse.o msh.o msm.o mss.o muir.o na.o nb.o nc.o nu.o part.o pee.o peh.o pem.o perm.o pes.o phe.o phh.o phm.o phs.o plet.o pme.o pmh.o poly.o ppe.o pph.o ppm.o ppp.o pps.o pr.o pse.o psh.o psm.o pss.o rest.o rh.o sab.o sb.o sc.o sr.o ta.o teh.o tem.o tep.o tes.o the.o thm.o thp.o ths.o tme.o tmh.o tmp.o tms.o tpe.o tph.o tpm.o tps.o tse.o tsh.o tsm.o tsp.o vc.o zo.o zykelind.o zyk.o -o test -lm symmetrica-2.0/matrix.doc0000600017361200001450000001330510726170275015401 0ustar tabbottcrontabCOMMENT: MATRIX ------ This is the data structure for MATRIX objects. It has three components: the length, the height and the selfpart. routine macro description ---------------------------------------------------------------- s_m_s S_M_S select_matrix_self s_m_h S_M_H select_matrix_height s_m_hi S_M_HI select_matrix_height as INT s_m_l S_M_L select_matrix_length s_m_li S_M_LI select_matrix_length as INT s_m_ij S_M_IJ select_matrix_i,j_element s_m_iji S_M_IJI select_matrix_i,j_element as INT c_m_s C_M_S change_matrix_self c_m_h C_M_H change_matrix_height c_m_l C_M_L change_matrix_length b_lhs_m build_length_height_self_matrix b_lh_m build_length_height_matrix m_lh_m make_length_height_matrix m_ilih_m make_integerlength_integerlength_ matrix b_lh_nm build_length_height_null_matrix m_lh_nm make_length_height_null_matrix m_ilih_nm make_integerlength_integerlength_ null_matrix the last three routines initialize the matrix with zero entries The routine s_m_ij differs from S_M_IJ because in the macro S_M_IJ there is no check on the indices. BASIC ROUTINES -------------- NAME: s_m_h SYNOPSIS: OP s_m_h(OP mat) MACRO: S_M_H DESCRIPTION: the parameter must be a MATRIX object, the return value is the height of the matrix, i.e. the INTEGER object which tells how many rows are in the MATRIX object. NAME: s_m_l SYNOPSIS: OP s_m_l(OP mat) MACRO: S_M_L DESCRIPTION: the parameter must be a MATRIX object, the return value is the length of the matrix, i.e. the INTEGER object which tells how many rows are in the MATRIX object. COMMENT: COMMENT: GENERAL ROUTINES FOR MATRICES ----------------------------- NAME: change_column_ij SYNOPSIS: INT change_column_ij(OP mat, INT i,j) DESCRIPTION: interchanges in the MATRIX object mat the columns i,j. NAME: change_row_ij SYNOPSIS: INT change_row_ij(OP mat, INT i,j) DESCRIPTION: interchanges in the MATRIX object mat the rows i,j. NAME: delete_column_matrix SYNOPSIS: INT delete_column_matrix(OP mat, INT i, OP result) DESCRIPTION: deletes in the MATRIX object mat the column i. The result is the MATRIX object result. mat and result may be the same object. NAME: delete_row_matrix SYNOPSIS: INT delete_row_matrix(OP mat, INT i, OP result) DESCRIPTION: deletes in the MATRIX object mat the row i. The result is the MATRIX object result. mat and result may be the same object. NAME: det_mat_imm SYNOPSIS: INT det_mat_imm(OP mat,erg) DESCRIPTION: computes the determinant of the MATRIX mat, it uses the definition as an alternating sum. You should use it if there is no div opertion defined for the entries. e. g. POLYNOM objects as entries. NAME: det_mat_tri SYNOPSIS: INT det_mat_tri(OP mat,erg) DESCRIPTION: computes the determinant of the MATRIX mat, it uses the the trinagulation of the matrix, so you must be careful with non scalar entries, which allow no divison. NAME: pfaffian_matrix SYNOPSIS: INT pfaffian_matrix(OP mat,res) DESCRIPTION: computes the pfaffian of the MATRIX object mat. The result is stored in res. It is not necessary that the matrix is skewsymmetric, but only the parts of the upper triangular part of the matrix are used. NAME: immanente_matrix SYNOPSIS: INT immanente_matrix(OP mat,part,res) DESCRIPTION: computes the immanente labeled by the PARTITION object part of the MATRIX object mat. The result is stored in res. NAME: kronecker_product SYNOPSIS: INT kronecker_product(OP a,b,c) DESCRIPTION: computes the kronecker product of two MATRIX objects. the three parameter may be equal. The result is the object c. NAME: rank SYNOPSIS: INT rank(OP a,b) DESCRIPTION: computes the rank of a matrix, it only works if it possible to apply the function div to the entries of the MATRIX object a NAME: spalten_summe SYNOPSIS: INT spalten_summe(OP mat,res) DESCRIPTION: computes the sum of columns, the result is a VECTOR object whose length is the number of columns NAME: select_row SYNOPSIS: INT select_row(OP mat, INT i, OP vec) DESCRIPTION: transforms a MATRIX object into a VECTOR object, which contains the elements of the labeled row NAME: select_column SYNOPSIS: INT select_column(OP mat, INT i, OP vec) DESCRIPTION: transforms a MATRIX object into a VECTOR object, which contains the elements of the labeled column NAME: test_matrix SYNOPSIS: INT test_matrix() DESCRIPTION: to test the installation of the MATRIX objects NAME: scan_skewsymmetric_matrix SYNOPSIS: INT scan_skewsymmetric_matrix(OP mat) DESCRIPTION: to enter a MATRIX object, which is skew symmetric, so you enter only the upper triangular part. COMMENT: GENERAL ROUTINES ---------------- add() add_apply() comp() copy() einsp() fprint() fprintln() freeall() freeself() inc() appends a new column to the right and a new row at the bottom invers() max() computes the maximum entry mod() applied to all entries of the matrix mult() mult_apply() nullp() objectread() objectwrite() print() println() quadraticp() test if quadratic matrix scan() tex() trace() trace of the matrix transpose() symmetrica-2.0/mee.c0000400017361200001450000001254310726021614014311 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT mee_integer_partition_(); INT mee_integer_hashtable_(); INT m_merge_partition_partition(); INT mee_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(INTEGER,"mee_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"mee_integer__(2)",b); CTTO(HASHTABLE,ELMSYM,"mee_integer__(3)",c); SYMCHECK( S_I_I(a) < 0 , "mee_integer__:integer<0"); if (S_O_K(b) == PARTITION) { erg += mee_integer_partition_(a,b,c,f); goto ende; } else { erg += mee_integer_hashtable_(a,b,c,f); goto ende; } ende: ENDR("mee_integer__"); } INT mee_partition_partition_(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"mee_partition_partition_(1)",a); CTO(PARTITION,"mee_partition_partition_(2)",b); CTTO(HASHTABLE,ELMSYM,"mee_partition_partition_(3)",c); erg += m_merge_partition_partition(a,b,c,f,comp_monomelmsym,eq_monomsymfunc); ENDR("mee_partition_partition_"); } INT mee_partition__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mee_partition__(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"mee_partition__(2)",b); CTTO(HASHTABLE,ELMSYM,"mee_partition__(3)",c); if (S_O_K(b) == PARTITION) { erg += mee_partition_partition_(a,b,c,f); goto ende; } else { M_FORALL_MONOMIALS_IN_B(a,b,c,f,mee_partition_partition_); goto ende; } ende: ENDR("mee_partition__"); } INT mee_elmsym__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += e_a \times e_b \times f */ { INT erg = OK; CTO(ELMSYM,"mee_elmsym__(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"mee_elmsym__(2)",b); CTTO(HASHTABLE,ELMSYM,"mee_elmsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mee_partition__); ENDR("mee_elmsym__"); } INT mee_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += e_a \times e_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mee_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"mee_hashtable__(2)",b); CTTO(HASHTABLE,ELMSYM,"mee_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mee_partition__); ENDR("mee_hashtable__"); } INT mee_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += e_a \times e_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mee_hashtable_hashtable_(1)",a); CTO(HASHTABLE,"mee_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,ELMSYM,"mee_hashtable_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_AB(a,b,c,f,mee_partition_partition_); ENDR("mee_hashtable_hashtable_"); } INT mee_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; OP m; INT i,k; CTO(INTEGER,"mee_integer_partition_(1)",a); CTO(PARTITION,"mee_integer_partition_(2)",b); CTTO(ELMSYM,HASHTABLE,"mee_integer_partition_(3)",c); SYMCHECK( S_I_I(a) < 0 , "mee_integer_partition_:integer<0"); m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); if (S_I_I(a) == 0) { COPY(b,S_MO_S(m)); } else { erg += b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); erg += m_il_integervector(S_PA_LI(b)+1,S_PA_S(S_MO_S(m))); for (i=0,k=0; kELMSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,ELMSYM,"mult_elmsym_elmsym(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"mult_elmsym_elmsym(2)",b); CTTTO(EMPTY,HASHTABLE,ELMSYM,"mult_elmsym_elmsym(3)",c); if (S_O_K(a) == INTEGER) { if (S_O_K(c) == EMPTY) { if (S_O_K(b) == PARTITION) init_elmsym(c); else { t=1; init_hashtable(c); } } erg += mee_integer__(a,b,c,cons_eins); } else if (S_O_K(a) == PARTITION) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mee_partition__(a,b,c,cons_eins); } else if (S_O_K(a) == ELMSYM) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mee_elmsym__(a,b,c,cons_eins); } else /* if (S_O_K(a) == HASHTABLE) */ { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mee_hashtable__(a,b,c,cons_eins); } if (t==1) t_HASHTABLE_ELMSYM(c,c); ENDR("mult_elmsym_elmsym"); } symmetrica-2.0/mem.c0000400017361200001450000001752310726021614014324 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT tem_integer__faktor(); INT mes_integer_partition_(); INT binom_small(); static OP mip_cc=NULL; INT mem_ende() { INT erg = OK; if (mip_cc != NULL) { FREEALL(mip_cc); mip_cc = NULL; } ENDR("mem_ende"); } INT mem_integer_partition_(a,b,c,f) OP a,b,c; OP f; /* a is integer b is partition */ { INT erg = OK,i,j,m,il,jl; OP l,p,bn,oben,unten; OP mo,zi,zj,zm,ilz; CTO(INTEGER,"mem_integer_partition_(1)",a); CTO(PARTITION,"mem_integer_partition_(2)",b); CTTO(HASHTABLE,MONOMIAL,"mem_integer_partition_(3)",c); if (mip_cc == NULL) { mip_cc = CALLOCOBJECT(); erg += init_hashtable(mip_cc); } erg += mes_integer_partition_(a,b,mip_cc,cons_eins); /* pieri rule */ CTO(HASHTABLE,"mem_integer_partition_(mip-cc)",mip_cc); bn = CALLOCOBJECT(); oben = CALLOCOBJECT(); unten = CALLOCOBJECT(); for (il=0,ilz=S_V_S(mip_cc);il= 1 */ INT i; OP d,e; d=CALLOCOBJECT(); e=CALLOCOBJECT(); erg += init_hashtable(e); erg += mes_integer__(S_PA_I(a,0),b,e,f); for (i=1;iSCHUR necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,ELMSYM,"mult_elmsym_schur(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"mult_elmsym_schur(2)",b); CTTTO(EMPTY,HASHTABLE,SCHUR,"mult_elmsym_schur(3)",c); if (S_O_K(a) == INTEGER) { if (S_O_K(c) == EMPTY) { if (S_O_K(b) == PARTITION) init_schur(c); else { t=1; init_hashtable(c); } } erg += mes_integer__(a,b,c,cons_eins); } else if (S_O_K(a) == PARTITION) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mes_partition__(a,b,c,cons_eins); } else if (S_O_K(a) == ELMSYM) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mes_elmsym__(a,b,c,cons_eins); } else /* if (S_O_K(a) == HASHTABLE) */ { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mes_hashtable__(a,b,c,cons_eins); } if (t==1) t_HASHTABLE_SCHUR(c,c); ENDR("mult_elmsym_schur"); } static INT mes_first_pieri(a,b,c) OP a,b,c; { INT i; /* m_il_nv(S_V_LI(b),c); */ if (S_V_LI(b) > mes_ip_v_length) { inc_vector_co(c,S_V_LI(b) - mes_ip_v_length); mes_ip_v_length = S_V_LI(c); } M_I_I(S_V_LI(b),S_V_L(c)); for (i=1;i=0;i--) { if (S_V_II(v,i) > 0) if (w > 0) break; else g+=S_V_II(v,i); if (S_V_II(limit,i) > 0) w+=S_V_II(limit,i)-S_V_II(v,i); M_I_I(0,S_V_I(v,i)); } /* an der stelle i kann nach rechts geschoben werden */ if (i== -1) return FALSE; g++; M_I_I(S_V_II(v,i)-1, S_V_I(v,i)); for (i++; ;i++) { if (S_V_II(limit,i) >= g) { M_I_I(g,S_V_I(v,i)); return TRUE; } else { M_I_I(S_V_II(limit,i),S_V_I(v,i)); g = g - S_V_II(limit,i); } } } INT mes_integer_partition_(a,b,c,f) OP a,b,c,f; /* c += e_a \times s_b \times f*/ /* c is already initialised */ { INT erg = OK; /* pieri rule */ OP limit; OP v; INT i,j,k; OP ps,s; CTO(INTEGER,"mes_integer_partition_(1)",a); CTO(PARTITION,"mes_integer_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"mes_integer_partition_(3)",c); SYMCHECK(S_I_I(a) < 0,"mes_integer_partition_:integer < 0"); if (S_PA_LI(b) == 0) { OP s; s = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),s); COPY(f,S_MO_K(s)); erg += last_partition(a,S_MO_S(s)); INSERT_SCHURMONOM_(s,c); goto ende; } if (S_I_I(a) == 0) { OP s; s = CALLOCOBJECT(); erg += m_sk_mo(b,f,s); INSERT_SCHURMONOM_(s,c); goto ende; } if (mes_ip_limit == NULL) { mes_ip_limit=CALLOCOBJECT(); m_il_integervector(mes_ip_limit_length,mes_ip_limit); limit = mes_ip_limit; } else { M_I_I(mes_ip_limit_length,S_V_L(mes_ip_limit)); limit = mes_ip_limit; } if ((S_PA_II(b,S_PA_LI(b)-1)+1) > mes_ip_limit_length) { inc_vector_co(limit, (S_PA_II(b,S_PA_LI(b)-1)+1) - mes_ip_limit_length); mes_ip_limit_length = S_V_LI(limit); CTO(INTEGERVECTOR,"mes_integer_partition_(i1)",limit); } M_I_I((S_PA_II(b,S_PA_LI(b)-1)+1),S_V_L(mes_ip_limit)); M_I_I(S_I_I(a),S_V_I(limit,0)); for (i=1;i mes_ip_s_length) { inc_vector_co(S_PA_S(S_MO_S(s)), (S_PA_LI(b)+S_I_I(a)) - mes_ip_s_length); mes_ip_s_length = S_PA_LI(S_MO_S(s)); } M_I_I(S_PA_LI(b)+S_I_I(a),S_PA_L(S_MO_S(s))); for (i=0;i0;i--) if (S_V_II(v,i) > 0) { while(S_V_II(ps,j) > i) j--; if (S_V_II(ps,j) != i) error(""); for (k=0;k= 1 */ INT i; OP d,e; d=CALLOCOBJECT(); e=CALLOCOBJECT(); erg += init_hashtable(e); erg += mhe_integer__(S_PA_I(a,0),b,e,f); for (i=1;iELMSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"mult_homsym_elmsym(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"mult_homsym_elmsym(2)",b); CTTTO(EMPTY,HASHTABLE,ELMSYM,"mult_homsym_elmsym(3)",c); if (S_O_K(a) == INTEGER) { if (S_O_K(c) == EMPTY) { if (S_O_K(b) == PARTITION) init_elmsym(c); else { t=1; init_hashtable(c); } } erg += mhe_integer__(a,b,c,cons_eins); } else if (S_O_K(a) == PARTITION) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhe_partition__(a,b,c,cons_eins); } else if (S_O_K(a) == HOMSYM) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhe_homsym__(a,b,c,cons_eins); } else /* if (S_O_K(a) == HASHTABLE) */ { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhe_hashtable__(a,b,c,cons_eins); } if (t==1) t_HASHTABLE_ELMSYM(c,c); CTTO(HASHTABLE,ELMSYM,"mult_homsym_elmsym(res)",c); ENDR("mult_homsym_elmsym"); } symmetrica-2.0/mhh.c0000400017361200001450000001331310726021615014314 0ustar tabbottcrontab #include "def.h" #include "macro.h" static INT mhh_integer_partition_(); static INT mhh_integer_hashtable_(); static INT mhh_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(INTEGER,"mhh_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,HOMSYM,"mhh_integer__(2)",b); CTTO(HASHTABLE,HOMSYM,"mhh_integer__(3)",c); if (S_O_K(b) == PARTITION) { erg += mhh_integer_partition_(a,b,c,f); goto ende; } else { erg += mhh_integer_hashtable_(a,b,c,f); goto ende; } ende: ENDR("mhh_integer__"); } INT mhh_partition_partition_(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; INT m_merge_partition_partition(); CTO(PARTITION,"mhh_partition_partition_(1)",a); CTO(PARTITION,"mhh_partition_partition_(2)",b); CTTO(HASHTABLE,HOMSYM,"mhh_partition_partition_(3-start)",c); erg += m_merge_partition_partition(a,b,c,f,comp_monomhomsym,eq_monomsymfunc); CTTO(HASHTABLE,HOMSYM,"mhh_partition_partition_(3-end)",c); ENDR("mhh_partition_partition_"); } INT mhh_partition__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mhh_partition__(1)",a); CTTTO(HASHTABLE,PARTITION,HOMSYM,"mhh_partition__(2)",b); CTTO(HASHTABLE,HOMSYM,"mhh_partition__(3)",c); if (S_O_K(b) == PARTITION) { erg += mhh_partition_partition_(a,b,c,f); goto ende; } else { M_FORALL_MONOMIALS_IN_B(a,b,c,f,mhh_partition_partition_); goto ende; } ende: ENDR("mhh_partition__"); } INT mhh_partition_hashtable_(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mhh_partition_hashtable_(1)",a); CTO(HASHTABLE,"mhh_partition_hashtable_(2)",b); CTTO(HASHTABLE,HOMSYM,"mhh_partition_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_B(a,b,c,f,mhh_partition_partition_); ENDR("mhh_partition_hashtable_"); } INT mhh_homsym__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += h_a \times s_b \times f */ { INT erg = OK; CTO(HOMSYM,"mhh_homsym__(1)",a); CTTTO(HASHTABLE,PARTITION,HOMSYM,"mhh_homsym__(2)",b); CTTO(HASHTABLE,HOMSYM,"mhh_homsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mhh_partition__); ENDR("mhh_homsym__"); } INT mhh_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += h_a \times b_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mhh_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,HOMSYM,"mhh_hashtable__(2)",b); CTTO(HASHTABLE,HOMSYM,"mhh_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mhh_partition__); ENDR("mhh_hashtable__"); } INT mhh_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += h_a \times h_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mhh_hashtable_hashtable_(1)",a); CTTTO(HASHTABLE,PARTITION,HOMSYM,"mhh_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,HOMSYM,"mhh_hashtable_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_AB(a,b,c,f,mhh_partition_partition_); ENDR("mhh_hashtable_hashtable_"); } static INT mhh_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; OP m; INT i,k; CTO(INTEGER,"mhh_integer_partition_(1)",a); CTO(PARTITION,"mhh_integer_partition_(2)",b); CTTO(HOMSYM,HASHTABLE,"mhh_integer_partition_(3)",c); m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); erg += m_il_v(S_PA_LI(b)+1,S_PA_S(S_MO_S(m))); C_O_K(S_PA_S(S_MO_S(m)),INTEGERVECTOR); for (i=0,k=0; kHOMSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"mult_homsym_homsym(1)",a); CTTTO(HASHTABLE,PARTITION,HOMSYM,"mult_homsym_homsym(2)",b); CTTTO(EMPTY,HASHTABLE,HOMSYM,"mult_homsym_homsym(3)",c); if (S_O_K(a) == INTEGER) { if (S_O_K(c) == EMPTY) { if (S_O_K(b) == PARTITION) init_homsym(c); else { t=1; init_hashtable(c); } } erg += mhh_integer__(a,b,c,cons_eins); } else if (S_O_K(a) == PARTITION) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhh_partition__(a,b,c,cons_eins); } else if (S_O_K(a) == HOMSYM) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhh_homsym__(a,b,c,cons_eins); } else /* if (S_O_K(a) == HASHTABLE) */ { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } if (S_O_K(b) == HASHTABLE) erg += mhh_hashtable_hashtable_(a,b,c,cons_eins); else erg += mhh_hashtable__(a,b,c,cons_eins); } if (t==1) t_HASHTABLE_HOMSYM(c,c); ENDR("mult_homsym_homsym"); } symmetrica-2.0/mhm.c0000400017361200001450000003357710726021616014340 0ustar tabbottcrontab/* multiplication homsym \times monomial = monomial */ #include "def.h" #include "macro.h" INT mhm_integer_partition_(); INT mhm_integer_partition_hashtable(); INT mhm_integer_hashtable_hashtable(); INT thm_integer__faktor(); static INT SYMMETRICA_mhm_co_ip(); static INT hm_coeff(); INT mhm_null__(b,c,f) OP b,c,f; { INT erg = OK; CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mhm_null__(1)",b); CTO(HASHTABLE,"mhm_null__(2)",c); if (S_O_K(b) == PARTITION) { _NULL_PARTITION_(b,c,f); } else /* monomial or hashtable */ { OP z; FORALL(z,b,{ OP d; d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); erg += copy_partition(S_MO_S(z),S_MO_S(d)); COPY(S_MO_K(z),S_MO_K(d)); if (not EINSP(f)) { MULT_APPLY(f,S_MO_K(d)); } INSERT_HASHTABLE(d,c,add_koeff,eq_monomsymfunc,hash_monompartition); }); } ENDR("mhm_null__"); } INT mhm_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(INTEGER,"mhm_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mhm_integer__(2)",b); CTO(HASHTABLE,"mhm_integer__(3)",c); SYMCHECK((S_I_I(a) < 0),"mhm_integer__:parameter < 0"); if (S_I_I(a) == 0) { erg += mhm_null__(b,c,f); goto ende; } else if (S_O_K(b) == PARTITION) { erg += mhm_integer_partition_hashtable(a,b,c,f); goto ende; } else { erg += mhm_integer_hashtable_hashtable(a,b,c,f); goto ende; } ende: ENDR("mhm_integer__"); } INT mhm_partition__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mhm_partition__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mhm_partition__(2)",b); CTO(HASHTABLE,"mhm_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += mhm_null__(b,c,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += mhm_integer__(S_PA_I(a,0),b,c,f); goto ende; } else { /* partition of length >= 1 */ INT i; OP d,e; d=CALLOCOBJECT(); e=CALLOCOBJECT(); erg += init_hashtable(e); erg += thm_integer__faktor(S_PA_I(a,0),e,f); for (i=1;ii */ /* zv ist der letzte teil mit kleinsten teil = i */ /* berechne : h_i * b * h_a + b* h_z */ C_S_N(zv,NULL); ff = CALLOCOBJECT(); init_hashtable(ff); hi = CALLOCOBJECT(); M_I_I(i,hi); erg += mhm_integer__(hi,b,ff,f); erg += mhm_homsym__(a,ff,c,cons_eins); if (z != NULL) erg += mhm_homsym__(z,b,c,f); FREEALL(hi); FREEALL(ff); /* a wieder richtig zusammen bauen */ zv = a; aa: for (j=S_S_SLI(zv);j>0;j--) M_I_I(S_S_SII(zv,j-1),S_S_SI(zv,j)); M_I_I(i,S_S_SI(zv,0)); M_I_I(S_S_SLI(zv)+1,S_S_SL(zv)); if (S_S_N(zv) != NULL) { zv = S_S_N(zv); goto aa; } C_S_N(zv,z); } eee: ENDR("mhm_homsym__"); } INT mhm_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += h_a \times s_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mhm_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mhm_hashtable__(2)",b); CTO(HASHTABLE,"mhm_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mhm_partition__); ENDR("mhm_homsym__"); } INT mhm_integer_partition_hashtable(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; CTO(INTEGER,"mhm_integer_partition_(1)",a); CTO(PARTITION,"mhm_integer_partition_(2)",b); CTO(HASHTABLE,"mhm_integer_partition_(3)",c); SYMCHECK((S_I_I(a) < 0),"mhm_integer_partition_hashtable:integer < 0"); if (S_I_I(a) == 0) { erg += mhm_null__(b,c,f); goto ende; } else if (S_PA_LI(b) == 0) { erg += thm_integer__faktor(a,c,f); /* generates sum over all partitions */ goto ende; } else { erg += SYMMETRICA_mhm_co_ip(a,b,c,f); goto ende; } ende: ENDR("mhm_integer_partition_hashtable"); } INT mhm_integer_hashtable_hashtable(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; CTO(INTEGER,"mhs_integer_hashtable_(1)",a); CTTO(HASHTABLE,MONOMIAL,"mhs_integer_hashtable_(2)",b); CTO(HASHTABLE,"integer_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_B(a,b,c,f,mhm_integer_partition_hashtable); ENDR("mhm_integer_hashtable_hashtable"); } INT mult_homsym_monomial(a,b,c) OP a,b,c; /* AK 111001 */ { INT erg = OK; INT t=0; /* is 1 if transfer HASHTABLE->MONOMIAL necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"mult_homsym_monomial(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mult_homsym_monomial(2)",b); CTTTO(EMPTY,HASHTABLE,MONOMIAL,"mult_homsym_monomial(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } else if (S_O_K(c) == MONOMIAL) { t=1; t_MONOMIAL_HASHTABLE(c,c); } if (S_O_K(a) == INTEGER) { erg += mhm_integer__(a,b,c,cons_eins); goto ende; } else if (S_O_K(a) == PARTITION) { erg += mhm_partition__(a,b,c,cons_eins); goto ende; } else if (S_O_K(a) == HOMSYM) { erg += mhm_homsym__(a,b,c,cons_eins); goto ende; } else /* if (S_O_K(a) == HASHTABLE) */ { erg += mhm_hashtable__(a,b,c,cons_eins); goto ende; } ende: if (t==1) t_HASHTABLE_MONOMIAL(c,c); ENDR("mult_homsym_monomial"); } static INT next_part_EXPONENT_apply_limit(p,be,bp) OP p,be; INT bp; /* next with limit be */ /* bp maximaler eintrag != 0 */ { INT j,i,w,t,h; INT erg = OK; OP z,zz; i = S_PA_LI(p);t=0; for (j=bp, z = S_PA_I(p,bp);j>0;j--,z--) { w = S_I_I(z); if (w > 0) /* schauen ob frei */ { t+=w; if (j >= S_PA_LI(be)) { i = j; } else if (S_PA_II(be,j) == 0) { i = j; } else /* S_PA_II(be,j) > 0 */ { t -= S_PA_II(be,j); if (t>0) i = j; } } else { if (j < S_PA_LI(be)) { if (S_PA_II(be,j) > 0) t-=S_PA_II(be,j); } } } if (i == S_PA_LI(p)) return LASTPARTITION; /* an der stelle i kann decrementiert werden */ w=0; for(j=1,z=S_V_S(S_PA_S(p));j<=i;j++,z++) { h = S_I_I(z); C_I_I(z,0); while (h--) w+=j; } w += (i+1); DEC_INTEGER(S_PA_I(p,i)); /* nun das gewicht w in den kleineren teilen unter bringen, aber das limit beruecksichtigen */ /* zuerst feststellen wie viel vom limit bereits abgearbeitet ist */ for (t=0,j=bp;j>=i;j--) t+= S_PA_II(p,j); /* t teile in p > i */ /* nun feststellen wieviel teile davon das limit ueberdecken */ for (j=S_PA_LI(be)-1,z = S_PA_I(p,j), zz = S_PA_I(be,j);j>=0;j--,z--,zz--) { h = S_I_I(zz); if (t >= h) t -= h; else if (t > 0) { C_I_I(z,h-t); t = 0; w -= S_I_I(z)*(j+1); } else /* t == 0 */ { C_I_I(z,h); w -= h*(j+1); } } i--; t = i; while (w > 0) { if (i==0) /* kein limit mehr, bei t einfuegen */ { M_I_I( S_PA_II(p,t) + (w/ (t+1)) ,S_PA_I(p,t)); if ( (w % (t+1) ) > 0 ) INC_INTEGER(S_PA_I(p, w % (t+1) -1)); return OK; } /* nach links kleineres teil aus dem limit suchen und vergroessern */ for (j=i-1, z = S_PA_I(p,j);j>=0;j--,z--) { nochmal: if ((i-j) > w) continue; if (S_I_I(z) > 0) { DEC_INTEGER(z); INC_INTEGER(S_PA_I(p,i)); w += j; w -= i; if (w == 0) return OK; goto nochmal; } } i--; } SYMCHECK(1,"next_part_EXPONENT_apply_limit:should never be here"); ENDR("next_part_EXPONENT_apply_limit"); } static OP hm_coeff_lo,hm_coeff_oben,hm_coeff_unten; static INT SYMMETRICA_mhm_co_ip(a,b,c,faktor) OP a,b,c; OP faktor; /* addiert das ergebnis von h_a \times m_b zu c */ /* dabei gibt es den coeffizienten faktor */ { INT erg = OK; INT bp; INT i,w,j; OP p; OP be,m,z; CTO(INTEGER,"SYMMETRICA_mhm_co_ip(1)",a); CTO(PARTITION,"SYMMETRICA_mhm_co_ip(2)",b); CTO(HASHTABLE,"SYMMETRICA_mhm_co_ip(3)",c); hm_coeff_lo = CALLOCOBJECT(); hm_coeff_oben=CALLOCOBJECT(); C_O_K(hm_coeff_oben,INTEGER); hm_coeff_unten=CALLOCOBJECT(); C_O_K(hm_coeff_unten,INTEGER); for (i=0,w=S_I_I(a),z=S_V_S(S_PA_S(b));i=0;i--) if (S_PA_II(p,i) > 0 ) break; DEC_INTEGER(S_PA_I(p,i)); M_I_I(1,S_PA_I(p,i+S_I_I(a))); m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); erg += m_il_nv(w,S_PA_S(S_MO_S(m))); C_O_K(S_PA_S(S_MO_S(m)), INTEGERVECTOR); do { FREESELF(S_MO_K(m)); erg += hm_coeff(be,p,S_MO_K(m)); { INT i,j=0,ba=0; OP l; for (l=S_V_S(S_PA_S(p)),i=0; i0) { j += S_I_I(l); ba=i; } /* ba is the last non zero entry in p */ C_I_I(S_PA_L(S_MO_S(m)),j); for (l=S_V_S(S_PA_S(S_MO_S(m))),i=0;i<=ba;i++) if (S_PA_II(p,i)>0) for (j=(INT)0;j=0;i--) { w = S_PA_II(ae,i); if (w > 0) { while(j>=i) { k+= S_I_I(z); j--;z--; } if (k < w) { if (S_O_K(c) == INTEGER) M_I_I(0,c); else m_i_i(0,c); goto endr_ende; } C_I_I(hm_coeff_oben,k); C_I_I(hm_coeff_unten,w); if (t==0) { BINOM_POSINTEGER_POSINTEGER(hm_coeff_oben,hm_coeff_unten,c); t=1; } else { BINOM_POSINTEGER_POSINTEGER(hm_coeff_oben,hm_coeff_unten,hm_coeff_lo); MULT_APPLY(hm_coeff_lo,c); FREESELF(hm_coeff_lo); } k -= w; } } ENDR("internal(2) to mult_homsym_monomial"); } symmetrica-2.0/mhp.c0000400017361200001450000001240610726021617014330 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT mhp_integer_partition_(); INT mhp_integer_hashtable_(); INT mhp_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(INTEGER,"mhp_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mhp_integer__(2)",b); CTTO(HASHTABLE,POWSYM,"mhp_integer__(3)",c); CTO(ANYTYPE,"mhp_integer__(4)",f); if (S_O_K(b) == PARTITION) { erg += mhp_integer_partition_(a,b,c,f); goto ende; } else { erg += mhp_integer_hashtable_(a,b,c,f); goto ende; } ende: CTTO(HASHTABLE,POWSYM,"mhp_integer__(e3)",c); ENDR("mhp_integer__"); } INT mhp_partition__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mhp_partition__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mhp_partition__(2)",b); CTTO(HASHTABLE,POWSYM,"mhp_partition__(3)",c); if (S_PA_LI(a) == 0) { if (S_O_K(b) == PARTITION) { OP d; d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); erg += copy_partition(b,S_MO_S(d)); COPY(f,S_MO_K(d)); INSERT_POWSYMMONOM_(d,c); } else /* powsym or hashtable */ { OP z; FORALL(z,b,{ OP d; d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); erg += copy_partition(S_MO_S(z),S_MO_S(d)); COPY(S_MO_K(z),S_MO_K(d)); if (not EINSP(f)) { MULT_APPLY(f,S_MO_K(d)); } INSERT_POWSYMMONOM_(d,c); }); } goto endr_ende; } else { /* partition of length >= 1 */ INT i; OP d,e; d=CALLOCOBJECT(); e=CALLOCOBJECT(); erg += init_hashtable(e); erg += mhp_integer__(S_PA_I(a,0),b,e,f); for (i=1;iPOWSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"mult_homsym_powsym(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mult_homsym_powsym(2)",b); CTTTO(EMPTY,HASHTABLE,POWSYM,"mult_homsym_powsym(3)",c); if (S_O_K(a) == INTEGER) { if (S_O_K(c) == EMPTY) { if (S_O_K(b) == PARTITION) init_powsym(c); else { t=1; init_hashtable(c); } } erg += mhp_integer__(a,b,c,cons_eins); } else if (S_O_K(a) == PARTITION) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhp_partition__(a,b,c,cons_eins); } else if (S_O_K(a) == HOMSYM) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhp_homsym__(a,b,c,cons_eins); } else /* if (S_O_K(a) == HASHTABLE) */ { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhp_hashtable__(a,b,c,cons_eins); } if (t==1) t_HASHTABLE_POWSYM(c,c); ENDR("mult_homsym_powsym"); } symmetrica-2.0/mhs.c0000400017361200001450000002020610726021617014330 0ustar tabbottcrontab/* SYMMETRICA file mhs.c */ /* multiplication of homsym with schur */ /* result will be schur */ #include "def.h" #include "macro.h" INT mhs_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(INTEGER,"mhs_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"mhs_integer__(2)",b); CTTO(HASHTABLE,SCHUR,"mhs_integer__(3)",c); if (S_O_K(b) == PARTITION) { erg += mhs_integer_partition_(a,b,c,f); goto ende; } else { M_FORALL_MONOMIALS_IN_B(a,b,c,f,mhs_integer_partition_); goto ende; } ende: ENDR("mhs_integer__"); } INT mhs_partition__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mhs_partition__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"mhs_partition__(2)",b); CTTO(HASHTABLE,SCHUR,"mhs_partition__(3)",c); if (S_PA_LI(a) == 0) { if (S_O_K(b) == PARTITION) { OP d; d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); erg += copy_partition(b,S_MO_S(d)); COPY(f,S_MO_K(d)); if (S_O_K(c) == SCHUR) INSERT_LIST(d,c,add_koeff,comp_monomschur); else INSERT_HASHTABLE(d,c,add_koeff,eq_monomsymfunc,hash_monompartition); } else /* schur or hashtable */ { OP z; FORALL(z,b,{ OP d; d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); erg += copy_partition(S_MO_S(z),S_MO_S(d)); COPY(S_MO_K(z),S_MO_K(d)); if (not EINSP(f)) { MULT_APPLY(f,S_MO_K(d)); } if (S_O_K(c) == SCHUR) INSERT_LIST(d,c,add_koeff,comp_monomschur); else INSERT_HASHTABLE(d,c,add_koeff,eq_monomsymfunc,hash_monompartition); }); } goto endr_ende; } else { /* partition of length >= 1 */ INT i; OP d,e; d=CALLOCOBJECT(); e=CALLOCOBJECT(); erg += init_hashtable(e); erg += mhs_integer__(S_PA_I(a,0),b,e,f); for (i=1;iSCHUR necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"mult_homsym_schur(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"mult_homsym_schur(2)",b); CTTTO(EMPTY,HASHTABLE,SCHUR,"mult_homsym_schur(3)",c); if (S_O_K(a) == INTEGER) { if (S_O_K(c) == EMPTY) { if (S_O_K(b) == PARTITION) init_schur(c); else { t=1; init_hashtable(c); } } erg += mhs_integer__(a,b,c,cons_eins); } else if (S_O_K(a) == PARTITION) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhs_partition__(a,b,c,cons_eins); } else if (S_O_K(a) == HOMSYM) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhs_homsym__(a,b,c,cons_eins); } else /* if (S_O_K(a) == HASHTABLE) */ { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mhs_hashtable__(a,b,c,cons_eins); } if (t==1) t_HASHTABLE_SCHUR(c,c); ENDR("mult_homsym_schur"); } static INT mhs_first_pieri(a,b,c) OP a,b,c; { m_il_nv(S_V_LI(b),c); m_i_i(S_I_I(a),S_V_I(c,0)); C_O_K(c,INTEGERVECTOR); return OK; } static INT mhs_next_pieri_limit_apply(limit,v) OP limit,v; { INT i,w=0,g=0; INT erg = OK; CTTO(INTEGERVECTOR,VECTOR,"mhs_next_pieri_limit_apply(1)",limit); CTTO(INTEGERVECTOR,VECTOR,"mhs_next_pieri_limit_apply(2)",v); for (i=S_V_LI(v)-1; i>=0;i--) { if (S_V_II(v,i) > 0) if (w > 0) break; else g+=S_V_II(v,i); if (S_V_II(limit,i) > 0) w+=S_V_II(limit,i)-S_V_II(v,i); M_I_I(0,S_V_I(v,i)); } /* an der stelle i kann nach rechts geschoben werden */ if (i== -1) return FALSE; g++; M_I_I(S_V_II(v,i)-1, S_V_I(v,i)); for (i++; ;i++) { if (S_V_II(limit,i) >= g) { M_I_I(g,S_V_I(v,i)); return TRUE; } else { M_I_I(S_V_II(limit,i),S_V_I(v,i)); g = g - S_V_II(limit,i); } } /* we should never end up here */ ENDR("mhs_next_pieri_limit_apply"); } INT mhs_integer_partition_(a,b,c,f) OP a,b,c,f; /* c += h_a \times s_b \times f*/ /* c is already initialised */ { INT erg = OK; /* pieri rule */ OP limit; OP v; INT i,j; OP ps,s,pa; CTO(INTEGER,"mhs_integer_partition_(1)",a); CTO(PARTITION,"mhs_integer_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"mhs_integer_partition_(3)",c); /*printf("mhs_integer_partition_:a=");println(a); printf("mhs_integer_partition_:b=");println(b); printf("mhs_integer_partition_:c=");println(c); printf("mhs_integer_partition_:f=");println(f);*/ if (S_PA_LI(b) == 0) { OP s; s = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),s); COPY(f,S_MO_K(s)); m_i_pa(a,S_MO_S(s)); if (S_O_K(c) == SCHUR) insert_list(s,c,add_koeff,comp_monomschur); else insert_scalar_hashtable(s,c,add_koeff,eq_monomsymfunc,hash_monompartition); goto ende; } limit = CALLOCOBJECT(); v = CALLOCOBJECT(); m_il_v(S_PA_LI(b)+1,limit); C_O_K(limit,INTEGERVECTOR); M_I_I(S_I_I(a),S_V_I(limit,0)); for (j=1,i=S_PA_LI(b)-1;i>0;i--,j++) M_I_I(S_PA_II(b,i)-S_PA_II(b,i-1),S_V_I(limit,j)); M_I_I(S_PA_II(b,0),S_V_I(limit,j)); ps = CALLOCOBJECT(); pa = CALLOCOBJECT(); s = CALLOCOBJECT(); erg += b_ks_pa(VECTOR,ps,pa); erg += m_il_nv(S_V_LI(limit),ps); C_O_K(ps,INTEGERVECTOR); erg += b_sk_mo(pa,CALLOCOBJECT(),s); COPY(f,S_MO_K(s)); mhs_first_pieri(a,limit,v); do { if (S_V_II(v,S_V_LI(v)-1) > 0) { M_I_I(S_V_LI(v),S_V_L(ps)); M_I_I(S_V_II(v,S_V_LI(v)-1), S_V_I(ps,0)); } else M_I_I(S_V_LI(v)-1,S_V_L(ps)); for (i=S_PA_LI(b)-1,j=0;i>=0;i--,j++) M_I_I(S_PA_II(b,i)+S_V_II(v,j), S_V_I(ps,S_V_LI(ps)-1-j)); if (S_O_K(c) == SCHUR) { OP ss = CALLOCOBJECT(); copy_monom(s,ss); insert_list(ss,c,add_koeff,comp_monomschur); } else { HASH_INTEGERVECTOR(S_PA_S(S_MO_S(s)),j); C_PA_HASH(S_MO_S(s),j); erg += add_apply_hashtable(s,c,add_koeff,eq_monomsymfunc,hash_monompartition); } } while (mhs_next_pieri_limit_apply(limit,v) == TRUE); FREEALL(s); FREEALL(limit); FREEALL(v); ende: ENDR("mhs_integer_partition_"); } symmetrica-2.0/mmm.c0000400017361200001450000003065410726021620014331 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT mmm_integer_partition_(); INT mmm_partition_partition_(); INT mmm_integer_hashtable_(); INT mmm_null_partition_(); INT mmm___(); static INT verf2(); static INT coeff_mmm(); INT mmm_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(INTEGER,"mmm_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mmm_integer__(2)",b); CTTO(HASHTABLE,MONOMIAL,"mmm_integer__(3)",c); if (S_O_K(b) == PARTITION) erg += mmm_integer_partition_(a,b,c,f); else erg += mmm_integer_hashtable_(a,b,c,f); ENDR("mmm_integer__"); } INT mmm_partition__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mmm_partition__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mmm_partition__(2)",b); CTTO(HASHTABLE,MONOMIAL,"mmm_partition__(3)",c); if (S_O_K(b) == PARTITION) { erg += mmm_partition_partition_(a,b,c,f); goto ende; } else { M_FORALL_MONOMIALS_IN_B(a,b,c,f,mmm_partition_partition_); goto ende; } ende: ENDR("mmm_partition__"); } INT mmm_monomial__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += h_a \times s_b \times f */ { INT erg = OK; CTO(MONOMIAL,"mmm_monomial__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mmm_monomial__(2)",b); CTTO(HASHTABLE,MONOMIAL,"mmm_monomial__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mmm_partition__); ENDR("mmm_monomial__"); } INT mmm_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += m_a \times m_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mmm_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mmm_hashtable__(2)",b); CTTO(HASHTABLE,MONOMIAL,"mmm_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mmm_partition__); ENDR("mmm_hashtable__"); } INT mmm_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += m_a \times m_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mmm_hashtable_hashtable_(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mmm_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,MONOMIAL,"mmm_hashtable_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_AB(a,b,c,f,mmm_partition_partition_); ENDR("mmm_hashtable_hashtable_"); } INT mmm_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; OP m; INT i,k; CTO(INTEGER,"mmm_integer_partition_(1)",a); CTO(PARTITION,"mmm_integer_partition_(2)",b); CTTO(MONOMIAL,HASHTABLE,"mmm_integer_partition_(3)",c); SYMCHECK((S_I_I(a) < 0), "mmm_integer_partition_:integer < 0"); if (S_I_I(a) == 0) { erg += mmm_null_partition_(b,c,f); goto eee; } m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); erg += m_il_v(S_PA_LI(b)+1,S_PA_S(S_MO_S(m))); C_O_K(S_PA_S(S_MO_S(m)),INTEGERVECTOR); for (i=0,k=0; k S_PA_LI(b)) { w = a; a = b; b=w; } im = S_PA_II(a,S_PA_LI(a)-1) + S_PA_II(b,S_PA_LI(b)-1); ae = CALLOCOBJECT(); be = CALLOCOBJECT(); w = CALLOCOBJECT(); if (mmm_ce == NULL) { mmm_ce = CALLOCOBJECT(); erg += init_hashtable(mmm_ce); } erg += weight(a,w); t_VECTOR_EXPONENT(b,be); if (S_PA_LI(be) >= im) M_I_I(im,S_PA_L(be)); else { i = S_PA_LI(be); inc_vector_co(S_PA_S(be),im-S_PA_LI(be)); for (;i= im) M_I_I(im,S_PA_L(ae)); else { i = S_PA_LI(ae); inc_vector_co(S_PA_S(ae),im-S_PA_LI(ae)); for (;i=0;starti--) if (S_PA_II(a,starti)>0) break; for (i=starti; i>=0;i--) { /* zuerst schauen ob nicht noch zu grosse teile da sind */ if (S_PA_II(a,i) == 0) continue; /* nun versuchen i zu zerlegen */ if ( (S_PA_II(b,i) > 0) && (S_PA_II(c,i) > 0) && (S_PA_II(b,i) == S_PA_II(c,i)) ) { DEC_INTEGER(S_PA_I(b,i)); DEC_INTEGER(S_PA_I(a,i)); coeff_mmm(a,b,c,res,2*faktor,i); INC_INTEGER(S_PA_I(b,i)); INC_INTEGER(S_PA_I(a,i)); goto weiter; } if (S_PA_II(b,i) > 0) { DEC_INTEGER(S_PA_I(b,i)); DEC_INTEGER(S_PA_I(a,i)); coeff_mmm(a,b,c,res,faktor,i); INC_INTEGER(S_PA_I(b,i)); INC_INTEGER(S_PA_I(a,i)); } if (S_PA_II(c,i) > 0) { DEC_INTEGER(S_PA_I(c,i)); DEC_INTEGER(S_PA_I(a,i)); coeff_mmm(a,b,c,res,faktor,i); INC_INTEGER(S_PA_I(a,i)); INC_INTEGER(S_PA_I(c,i)); } weiter: for (j=0;j 0) && (S_PA_II(c,i-j-1) > 0) /* aber verschieden */ ) { DEC_INTEGER(S_PA_I(b,j)); DEC_INTEGER(S_PA_I(c,i-j-1)); DEC_INTEGER(S_PA_I(a,i)); coeff_mmm(a,b,c,res,faktor,starti); INC_INTEGER(S_PA_I(a,i)); INC_INTEGER(S_PA_I(c,i-j-1)); INC_INTEGER(S_PA_I(b,j)); } } goto eee; } if (i<0) /* null , blatt res erhoehen */ { M_I_I(1*faktor + S_I_I(res),res); goto eee; } eee: ENDR("internal to mult_monomial_monomial"); } INT mult_monomial_monomial(a,b,c) OP a,b,c; /* AK 111001 */ { INT erg = OK; INT t=0; /* is 1 if transfer HASHTABLE->MONOMIAL necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,MONOMIAL,"mult_monomial_monomial(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mult_monomial_monomial(2)",b); CTTTO(EMPTY,HASHTABLE,MONOMIAL,"mult_monomial_monomial(3)",c); if (S_O_K(c) == EMPTY) { if (S_O_K(a) == INTEGER) { if (S_O_K(b) == PARTITION) init_monomial(c); else { t=1; init_hashtable(c); } } else { t=1; init_hashtable(c); } } erg += mmm___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_MONOMIAL(c,c); ENDR("mult_monomial_monomial"); } INT mmm___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,MONOMIAL,"mmm___(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"mmm___(2)",b); CTTO(HASHTABLE,MONOMIAL,"mmm___(3)",c); if (S_O_K(a) == INTEGER) { erg += mmm_integer__(a,b,c,f); } else if (S_O_K(a) == PARTITION) { erg += mmm_partition__(a,b,c,f); } else if (S_O_K(a) == MONOMIAL) { erg += mmm_monomial__(a,b,c,f); } else /* if (S_O_K(a) == HASHTABLE) */ { erg += mmm_hashtable__(a,b,c,f); } ENDR("mmm___"); } static INT verf2(v,a,b,c,limit) OP a,b,c; OP v; INT limit; { INT erg = OK; INT i,j; OP m; CTO(PARTITION,"verf2(1)",a); CTO(PARTITION,"verf2(2)",b); CTO(HASHTABLE,"verf2(3)",c); if (S_PA_LI(a) == 1) { OP d,ps,z,h,h2,p2; d = b; m = CALLOCOBJECT(); ps = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += m_il_integervector(S_PA_LI(d),ps); erg += b_ks_pa(EXPONENT,ps,S_MO_S(m)); for (i = 0,z=S_V_S(S_PA_S(d));i=0;i--,j--) if (j>=0) M_I_I(S_PA_II(b,j),S_V_I(v,i)); else M_I_I(0,S_V_I(v,i)); /* vector v is filled with partition b */ for(i=0,j=0;i 1) if (S_PA_II(a,S_P_II(perm,i)-1) == S_PA_II(a,S_P_II(perm,i)-2) ) if (S_V_II(iperm,S_P_II(perm,i)-2) == 0) goto next_perm; while (S_V_II(subset,j) == 0) j++; /* an der stelle j ist ein eintrag */ M_I_I(S_V_II(v,j)+S_PA_II(a,S_P_II(perm,i)-1),S_V_I(v,j)); M_I_I(i+1,S_V_I(iperm,S_P_II(perm,i)-1)); j++; } i = reorder_vector_apply(v); if (i==0) { goto next_subset; } /* summand gefunden */ d = CALLOCOBJECT(); s = callocobject(); COPY(v,d); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),s); if (i==1) COPY(f,S_MO_K(s)); else ADDINVERS(f,S_MO_K(s)); erg += b_ks_pa(VECTOR,d,S_MO_S(s)); if (S_O_K(c) == HASHTABLE) insert_scalar_hashtable(s,c,add_koeff,eq_monomsymfunc,hash_monompartition); else /* SCHUR */ insert_list(s,c,add_koeff,comp_monomschur); next_subset: ; } while(next_apply(subset)); next_perm: ; /* print(iperm);print(v);println(perm); */ } while (next_apply(perm)); erg += freeall(perm); erg += freeall(iperm); erg += freeall(v); erg += freeall(subset); #endif } ENDR("mms_partition_partition_"); } INT mms_partition__(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTO(PARTITION,"mms_partition__(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mms_partition__(2)",b); CTTO(SCHUR,HASHTABLE,"mms_partition__(3)",c); if (S_O_K(b) == PARTITION) erg += mms_partition_partition_(a,b,c,f); else { M_FORALL_MONOMIALS_IN_B(a,b,c,f,mms_partition_partition_); } ENDR("mms_partition__"); } INT mms_hashtable__(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTO(HASHTABLE,"mms_hashtable__(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mms_hashtable__(2)",b); CTTO(SCHUR,HASHTABLE,"mms_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mms_partition__); ENDR("mms_hashtable__"); } INT mms_hashtable_partition_(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTO(HASHTABLE,"mms_hashtable_partition_(1)",a); CTO(PARTITION,"mms_hashtable_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"mms_hashtable_partition_(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mms_partition_partition_); ENDR("mms_hashtable_partition_"); } INT mms_monomial__(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTO(MONOMIAL,"mms_monomial__(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mms_monomial__(2)",b); CTTO(SCHUR,HASHTABLE,"mms_monomial__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,mms_partition__); ENDR("mms_monomial__"); } INT mms___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(INTEGER,PARTITION,MONOMIAL,HASHTABLE,"mms___(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mms___(2)",b); CTTO(SCHUR,HASHTABLE,"mms___(3)",c); if (S_O_K(a) == INTEGER) { erg += mms_integer__(a,b,c,f); goto ende; } else if (S_O_K(a) == PARTITION) { erg += mms_partition__(a,b,c,f); goto ende; } else if (S_O_K(a) == HASHTABLE) { erg += mms_hashtable__(a,b,c,f); goto ende; } else if (S_O_K(a) == MONOMIAL) { erg += mms_monomial__(a,b,c,f); goto ende; } ende: ENDR("mms___"); } INT mult_monomial_schur(a,b,c) OP a,b,c; { INT erg = OK; INT t=0; CTTTTO(INTEGER,MONOMIAL,PARTITION,HASHTABLE,"mult_monomial_schur(1)",a); CTTTTO(INTEGER,SCHUR,PARTITION,HASHTABLE,"mult_monomial_schur(2)",b); CTTTO(EMPTY,SCHUR,HASHTABLE,"mult_monomial_schur(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mms___(a,b,c,cons_eins); if (t==1) erg += t_HASHTABLE_SCHUR(c,c); CTTO(SCHUR,HASHTABLE,"mult_monomial_schur(3-ende)",c); ENDR("mult_monomial_schur"); } symmetrica-2.0/mo.c0000400017361200001450000041255010726021621014156 0ustar tabbottcrontab/* SYMMETRICA source code file: mo.c */ #include "def.h" #include "macro.h" #ifdef DGTRUE /* Darstellungen werden benoetigt */ #define ALLOCOFFSET 0 #define TL_calloc(a,b) SYM_calloc(a+ALLOCOFFSET,b) #define TL_malloc(a) SYM_malloc(a+ALLOCOFFSET) #define TL_free(a) SYM_free(a) typedef signed char TL_BYTE; typedef signed short TL_2BYTE; #define SYM_memcmp memcmp static close_mat(); static init_mat(); static INT _ber_inx_dec(); static INT modmat(); static INT moddreimat(); static INT r_modgauss(); static INT _modgauss(); static INT p_rel(); static INT p_writemat(); static INT zykel(); static INT modgauss(); static INT ganzgaussmod(); static INT homp(); static INT TL_darmod(); static INT d_mat(); static INT k_dimmod(); static INT _k_moddreimat(); static INT _assoziiere(); static INT alkonmat(); static INT zweikonmat(); static INT mat_comp(); static INT alcoeff(); static INT symdet (); static INT sigper(); static INT alzyk(); static INT k_alzyk(); static INT j_zyk(); static INT inzeil(); static INT zykschnitt (); static INT leer(); static INT a_teilmenge_b(); static INT setmin(); static INT _teste_r_mat_dim(); static INT _red_r_mat(); static INT _diff(); static INT _kleiner(); static INT _ggT(); static INT _v_eintrag(); static INT _ber_dim(); static INT _dimension(); static INT _fakul(); static INT _ber_lambdas(); static INT _r_induk(); static INT _num_part(); static INT _part_reg(); static INT _nexpart(); static INT _k_modgauss(); static INT COEFF(); static INT _search_dec(); static INT _k_zweikonmat(); static INT invp(); static INT fak(); static INT nexgitt(); static INT _ber_idx_pelem(); static INT darmod(); static INT lmatmulp(); static INT rmatmulp(); static INT homtestp(); static INT a_ohne_b_gl_c(); static INT matcopy(); static INT konjugiere(); static INT schnitt(); static INT _ggT_v(); static TL_BYTE AK_buf; #define TL_MOD(a,b) \ ((AK_buf = (((INT)a)%(b)))<0?AK_buf+b:AK_buf) /* mod(a,b)=a mod b >= 0 */ #define TL_ADP(x,y,p) TL_MOD((x)+(y),(INT)p) #define TL_MULP(x,y,p) TL_MOD(((INT)x)*((INT)y),(INT)p) #define TL_DIVP(x,y,p) TL_MULP((x),invp((INT)y,(INT)p),(INT)p) /* Global variables of MODULDAR */ /******************************************************************************* * * Datei MODDGGLB.C * * Globale Variablen, die eventuell geaendert werden muessen. * *******************************************************************************/ /* Ueblicher Headerfile... */ static INT idmat(); /* Globale Variablen des Programmpakets MODULDAR */ /* static INT MAXN = (INT)20; static INT MAXZEILENZ = (INT)20; static INT MAXSPALTENZ = (INT)20; */ static INT MAXDM = (INT)5000; static INT ZYK = (INT)50; static INT PZ[] = { (INT)2,(INT)3,(INT)5,(INT)7,(INT)11,(INT)13,(INT)17,(INT)19,(INT)23,(INT)29,(INT)31}; /* Defines of possible errors */ #define LmbNul (INT)-10 #define LmbEmp (INT)-11 #define LmbLt_null (INT)-12 #define LmbNRg (INT)-13 #define NLe_null (INT)-14 #define NGtMax (INT)-15 #define ZzGtMx (INT)-16 #define SzGtMx (INT)-17 #define DmGtMx ((INT)-18) #define BzNul (INT)-19 #define CntOFl (INT)-20 #define DimLe_null (INT)-21 #define DrtNul (INT)-22 #define GzlNul (INT)-23 #define NoPrm (INT)-24 #define PrmLe_null (INT)-25 #define PrmGtN (INT)-26 #define NoSolu (INT)-27 #define DDmLt_null (INT)-28 #define DDmGMx (INT)-29 #define PerNul (INT)-30 #define PerLe_null (INT)-31 #define PerGtN (INT)-32 #define PeLgGN (INT)-33 #define RTabFt (INT)-99 #define NtEMem (INT)-109 /* Macros for modulararithmetic Die Modulararithmetik berechnet Summen (adp), Produkte (mulp), Inverse (invp) und Quotienten (divp) modulo p. Bei Verwendung der entsprechenden Funktionen muss p als Parameter uebergeben werden. */ /* und schliesslich globale Variablen. */ static INT _zeilenz; static INT q_zeilenz; static INT _spaltenz; static INT _n; static INT _zyk; #ifdef UNDEF #define COEFF(x,y,z) ((z-y)%2L)?(((INT)-1)*fak(x+y-2L*z)*fak(z-y)*fak(z)) \ : (fak(x+y-2L*z)*fak(z-y)*fak(z)) #endif static INT COEFF(x,y,z) INT x,y,z; { return ((z-y)%(INT)2)?(((INT)-1)*fak(x+y-(INT)2*z)*fak(z-y)*fak(z)) : (fak(x+y-(INT)2*z)*fak(z-y)*fak(z)) ; } /*----------------------------------------------------------------------------*/ static INT _k_zweikonmat(lambda,bz,pz) TL_BYTE *lambda, *bz; INT pz; /*----------------------------------------------------------------------------- berechnet die Koeffizientenmatrix B zu einer Partition lambda, deren Laenge gleich zwei ist. Dabei werden die Elemente der Matrix modulo pz abgelegt. (Vgl. MODULKFF.C Funktion zweikonmat().) Variablen: lambda, Partition; pz, Primzahl. Reuckgabe Koeffizientenmatrix bz. Rueckgabewerte: >(INT)0, Dimension der gewoehnlichen irred. Darstellung; (INT)-109, falls nicht genuegend Speicher zur Verfuegung stand. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i,j,l,z,zaehl,mdim,dim; TL_BYTE *g_i,*g_j; TL_BYTE *start; TL_BYTE *_bz; INT g_im,g_jm; start=(TL_BYTE *)TL_calloc((int)_n*3,sizeof(TL_BYTE)); if (!start) return no_memory(); g_i=start+(INT)_n; g_j=g_i+(INT)_n; mdim=MAXDM; g_im=FALSE; if (nexgitt(start,lambda,&g_im)) { SYM_free(start); return no_memory(); } for (z=0;z<_n;g_i[z]=start[z],z++); _bz=bz; for (i=0,g_im=TRUE;g_im;i++) { for (z=0;z<_n;g_j[z]=start[z],z++); for (j=0,g_jm=TRUE;g_jm;j++) { for (l=0,zaehl=(INT)0;l<_n;l++) if (g_i[l]==(TL_BYTE)1 && g_j[l]==(TL_BYTE)1) zaehl++; *_bz++ = (TL_BYTE) TL_MOD( COEFF(_n,zaehl,(INT)lambda[1]) ,pz); if (nexgitt(g_j,lambda,&g_jm)) { SYM_free(start); return no_memory(); } } if (!i) { dim=j; if (dim>MAXDM) { dim *= ((INT)-1); break; } } if (dim(INT)0) { while ((INT)2*y[1]>x[1]) for (i=(INT)0;i<2L;++i) { yh=y[i]; y[i]=x[i]-y[i]; x[i]=yh; } q=x[1]/y[1]; r=x[1]%y[1]; yh=y[0]; y[0]=x[0]-q*y[0]; x[0]=yh; x[1]=y[1]; y[1]=r; } x[0]= z<(INT)0 ? -x[0] : x[0]; /* return(((x[0]%p)<(INT)0) ? x[0]%p+p : x[0]%p); */ return(((z=(x[0]%p))<(INT)0) ? z+p : z); } /* invp */ /* Makros zur Modulararithmetik */ /******************************************************************************* * * Datei MODULKFF.C * Version vom 29.09.89 * * * Zeile Funktion * * * Funktionen fuer Mengenoperationen * --------------------------------- * 88 INT setmin(TL_BYTE *a) * 107 INT a_teilmenge_b(TL_BYTE *a,TL_BYTE *b) * 129 INT leer(TL_BYTE *a) * 148 a_ohne_b_gl_c(TL_BYTE *a,TL_BYTE *b,TL_BYTE *c) * * Funktionen zur Berechnung der Koeffizientenmatrix (B,C_eins,C_zwei) * ----------------------------------------------------------- * 175 INT zykschnitt(INT *t_eins,INT *t_zwei,INT *perm,INT *zykmt) * 216 INT inzeil(INT la,TL_BYTE *zmat,TL_BYTE *fln) * 355 INT j_zyk(INT la,INT j_zwei,TL_BYTE **xm,TL_BYTE *zh) * 454 INT k_alzyk(INT la,INT *zmat,INT *fln,INT *cy) * 523 INT alzyk(INT la,INT *zmat,INT *fln,INT *cy) * 547 INT sigper(INT *fln,INT la) * 586 INT symdet(TL_BYTE *mat,TL_BYTE *slambda,INT li,INT *tsc) * 804 INT fak(INT i) * 820 INT alcoeff(INT *mat,INT *slambda) * 849 INT nexgitt(TL_BYTE *y,TL_BYTE *lambda,INT *mtc) * 918 INT zweikonmat(INT *lambda,INT *perm,INT *bz) * 1003 konjugiere(INT *lambda,INT *lambdastrich) * 1025 schnitt(INT *t_eins,INT *t_zwei,INT *mat) * 1043 INT mat_comp(TL_BYTE *co,TL_BYTE *mat,INT *slamda) * * Hauptfunktion * ------------- * 1099 INT alkonmat(INT *lambda,INT *perm,INT *bz) * *******************************************************************************/ /* Headerfiles wie in jedem C-Programm,... */ /* interne Makros ... */ /* #define IND(a,b,c) (INT)((INT)(a)*(INT)(c)+(INT)(b)) */ #define IND(a,b,c) ((INT)(a)*(INT)(c)+(b)) /* #define COEFF(x,y,z) ((z-y)%2L)?((-1L)*fak(x+y-2L*z)*fak(z-y)*fak(z)) \ : (fak(x+y-2L*z)*fak(z-y)*fak(z)) */ #define INDEX(x) ZYK/2+x /******************************************************************************* * * Funktionen fuer Mengenoperationen ... * * Mengen sind Felder a mit Eintraegen a[i]: * Element i nicht enthalten => a[i]=0 * Element i enthalten => a[i]=1 * *******************************************************************************/ /*----------------------------------------------------------------------------*/ static INT setmin(a) TL_BYTE *a; /*------------------------------------------------------------------------------ errechnet das Minimum der Menge a. Rueckgabewerte: Elementnummer m, falls m Minimum ist; -1L, falls kein Minimum existiert. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_a; INT m; for (m=(INT)0,_a=a;m<_n;m++,_a++) if (*_a) return(m); return(-1L); } /*----------------------------------------------------------------------------*/ static INT a_teilmenge_b(a,b) TL_BYTE *a, *b; /*------------------------------------------------------------------------------ ueberprueft, ob Menge a Teilmenge von Menge b ist. Rueckgabewerte: TRUE, falls a Teilmenge von b ist; FALSE, falls a nicht Teilmenge von b ist. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_a,*_b; INT m; for (m=(INT)0,_a=a,_b=b;m<_n;m++,_a++,_b++) if (*_a) { if (! *_b) return(FALSE); } return(TRUE); } /*----------------------------------------------------------------------------*/ static INT leer(a) TL_BYTE *a; /*------------------------------------------------------------------------------ ueberprueft, ob die Menge a leer ist. Rueckgabewerte: TRUE, falls a leer ist; FALSE, falls a nicht leer ist. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT m; for (m=(INT)0;m<_n;m++,a++) if (*a) return (FALSE); return (TRUE); } /*----------------------------------------------------------------------------*/ static INT a_ohne_b_gl_c(a,b,c) TL_BYTE *a,*b,*c; /*------------------------------------------------------------------------------ berechnet die Menge a\b. Rueckgabe Menge c = a\b. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT m; for (m=(INT)0;m<_n;m++,a++,b++,c++) { if (*b) *c = (TL_BYTE)0; else *c = *a; } return OK; } /******************************************************************************* * * Funktionen fuer die Bestimmung der Koeffizientenmatrix (B,C_eins,C_zwei)... * *******************************************************************************/ /*----------------------------------------------------------------------------*/ static INT zykschnitt (t_eins,t_zwei,perm,zykmt) TL_BYTE *t_eins, *t_zwei, *perm, *zykmt; /*------------------------------------------------------------------------------ berechnet Schnittmatrix zykmt in Abhaengigkeit von der Permutation perm. Rueckgabewerte: (INT)0, falls alles ohne Fehler durchgefuehrt werden konnte; (INT)-109, falls nicht genuegend Speicher zu Verfuegung steht. Rueckgabe Schnittmatrix zykmt. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i,j; TL_BYTE *zeile,*z; INT enthalten; zeile=(TL_BYTE *)TL_calloc((int)_n*(int)_n,sizeof(TL_BYTE)); if (!zeile) return no_memory(); for (i=q_zeilenz,z=zykmt;i>(INT)0;i--,*z++ = (INT)0); /* Berechnung der Zeilenziffernmengen von (perm)T2: */ for (i=_n-1L;i>=(INT)0;--i) zeile[IND(t_zwei[i],perm[i]-1L,_n)]=1L; for (j=(INT)0;j<_n;++j) { enthalten=FALSE; i=(INT)0; do { if (zeile[IND(i,j,_n)]) { ++zykmt[IND(t_eins[j],i,_zeilenz)]; enthalten=TRUE; } else ++i; } while (!enthalten); } SYM_free(zeile); return (INT)0; } /* zykschnitt */ /*----------------------------------------------------------------------------*/ static INT inzeil(la,zmat,fln) INT la; TL_BYTE *zmat, *fln; /*------------------------------------------------------------------------------ bestimmt, falls moeglich, paarweise verschiedene Ziffern i_eins,i2L,...,ilambda1L, welche die injektive erste Zeile eines Elementes von [Ts]c darstellen. (Weitere Erlaeuterung in: Golembiowski, Andreas Zur Berechnung modular irreduzibler Matrixdarstellungen symmetrischer Gruppen mit Hilfe eines Verfahrens von M.Clausen Bayreuther Mathematische Schriften Heft 25L, Bayreuth 1987 SS. 162ff) Variablen: la, Teil der konjugierten Partition; zmat, Schnittmatrix. Rueckgabewerte: (INT)-109, falls kein Speicher zur Verfuegung stand; (INT)0, sonst. Rueckgabe Matrix fln. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i,i_eins,j,j_eins,r,k,m,oz; TL_BYTE **xm,**qu,*ze[2],*un,*hilf; xm=(TL_BYTE **)TL_calloc((int)(_zeilenz+_zeilenz+2L),sizeof(TL_BYTE *)); if (!xm) return no_memory(); qu=xm+(INT)_zeilenz+1L; hilf=(TL_BYTE *)TL_calloc((int)(_zeilenz+_zeilenz+6L)*(INT)_n,sizeof(TL_BYTE)); if (!hilf) { SYM_free(xm); return no_memory(); } un=hilf+(INT)_n; ze[0]=un+(INT)_n; ze[1]=ze[0]+(INT)_n; xm[0]=ze[1]+(INT)_n; for (i=1L;i<=_zeilenz;xm[i]=xm[i-1]+(INT)_n,i++); qu[0]=xm[_zeilenz]+(INT)_n; for (i=1L;i<=_zeilenz;qu[i]=qu[i-1]+(INT)_n,i++); for (j=(INT)0;j=1L) { for (j=(INT)0;fln[j]!=i_eins || j==j_eins;j++); j_eins=j; i=(INT)0; while (fln[j_eins]==i_eins) if (xm[k-1][i] && zmat[IND(i,j_eins,_zeilenz)]) fln[j_eins]=i; else ++i; i_eins=i; --k; } ze[0][i_eins]=(TL_BYTE)1; } else r=la; } SYM_free(hilf); SYM_free(xm); return((INT)0); } /* inzeil */ /*----------------------------------------------------------------------------*/ static INT j_zyk(la,j_zwei,xm,zh) INT la,j_zwei; TL_BYTE **xm, *zh; /*------------------------------------------------------------------------------ berechnet Menge der Zyklen (j_null j_eins ... jk). (Weitere Erlaeuterung in: Golembiowski, Andreas Zur Berechnung modular irreduzibler Matrixdarstellungen symmetrischer Gruppen mit Hilfe eines Verfahrens von M.Clausen Bayreuther Mathematische Schriften Heft 25L, Bayreuth 1987 SS. 166ff) Variablen: la, Element der konjugierten Partition; j_zwei, erstes Element des Zykels; xm, Mengen. Rueckgabewerte: (INT)-109, nicht genug Speicher; (INT)0, sonst. Rueckgabe Vektor zh. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i,k,l,nr,m; static TL_BYTE *j=NULL; static TL_BYTE *ym=NULL,*hilf=NULL,**xm_eins=NULL; static INT old_z = (INT)-1; if (la == (INT)-15) { if (j != NULL) { SYM_free(j); j = NULL; } if (xm_eins != NULL) { SYM_free(xm_eins); xm_eins = NULL; } old_z = (INT)-1; return (INT)0; } if (old_z < _zeilenz) { if (j != NULL) SYM_free(j); if (xm_eins != NULL) SYM_free(xm_eins); j=(TL_BYTE *)TL_calloc((int)_zeilenz+1 + (int)(_zeilenz+2L)*(int)_n ,sizeof(TL_BYTE)); xm_eins=(TL_BYTE **) TL_calloc((int)_zeilenz,sizeof(TL_BYTE *)); if (!j) return no_memory(); if (!xm_eins) { SYM_free(j); return no_memory(); } hilf = j + (int)_zeilenz+1; ym=hilf+_n; xm_eins[0]=ym+_n; for (i=1L;i<_zeilenz;xm_eins[i]=xm_eins[i-1]+_n,i++); old_z = _zeilenz; } j[0]=j_zwei; memset(&zh[INDEX(-la)],0,(ZYK+la+1) * sizeof(TL_BYTE) ); if (la >= ZYK) error("internal error MO-5"); for (i= 0;i=2L;--i) zh[INDEX(l+k+4-i)]=j[i-1]+1L; l=l+k+3L; } ym[j[k-1]]=1L; a_ohne_b_gl_c(xm_eins[j[k]],ym,hilf); if (!leer(hilf)) ++k; else { while (leer(hilf) && (k>=1L)) { xm_eins[j[k-1]][j[k]]=(INT)0; ym[j[k]]=(INT)0; for (m=(INT)0;m<_n;xm_eins[j[k]][m]=xm[j[k]][m],m++); --k; a_ohne_b_gl_c(xm_eins[j[k]],ym,hilf); } if (k>=1L) ++k; } } while (k); } return((INT)0); } /* j_zyk */ /*----------------------------------------------------------------------------*/ static INT k_alzyk(la,zmat,fln,cy) INT la; TL_BYTE *cy; TL_BYTE *zmat, *fln; /*------------------------------------------------------------------------------ initialisiert Felder, die im Unterprogramm j_zyk benoetigt werden, und ruft j_zyk auf. (Weitere Erlaeuterung in: Golembiowski, Andreas Zur Berechnung modular irreduzibler Matrixdarstellungen symmetrischer Gruppen mit Hilfe eines Verfahrens von M.Clausen Bayreuther Mathematische Schriften Heft 25L, Bayreuth 1987 SS. 168ff) Variablen: la, Element der konjugierten Partition; zmat, Schnittmatrix; fln, Matrix aus inzeil. Rueckgabewerte: (INT)-109, nicht genug Speicher; (INT)0, sonst. Rueckgabe Matrix aller Zyklen. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i,j_eins,j_zwei,m; TL_BYTE *zh; TL_BYTE *z_eins,*z_zwei; TL_BYTE **xm; xm=(TL_BYTE **)TL_calloc((int)_zeilenz,sizeof(TL_BYTE *)); if (!xm) return no_memory(); xm[0]=(TL_BYTE *)TL_calloc((int)_zeilenz*(int)_n,sizeof(TL_BYTE)); if (!xm[0]) { SYM_free(xm); return no_memory(); } zh=(TL_BYTE *)TL_calloc((int)_zyk,sizeof(TL_BYTE)); if (!zh) { SYM_free(xm[0]); SYM_free(xm); return no_memory(); } for (i=1L;i<_zeilenz;xm[i]=xm[i-1]+_n,i++); for (j_eins=(INT)0,z_eins=zmat;j_eins=(INT)0) { if (k_alzyk(la,zmat,fln,cy)) return no_memory(); } return((INT)0); } /* alzyk */ /*----------------------------------------------------------------------------*/ static INT sigper(fln,la) TL_BYTE *fln, la; /*------------------------------------------------------------------------------ berechnet sgn(fln). Variablen: fln, gewisses pi* aus inzeil; la, Element aus konjugierter Partition. Rueckgabewert: (INT)-109, falls nicht genuegend Speicher; signum, sonst. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *hilf; INT i,j,k,l,v; hilf=(TL_BYTE *)TL_calloc((int)_zeilenz,sizeof(TL_BYTE)); if (!hilf) return no_memory(); for (i=(INT)0;i<_zeilenz;hilf[i]=fln[i],i++); v=1L; for (i=(INT)0;i=(INT)0) && (hilf[i]!=i)) { l=1L; j=hilf[i]; while (j>=(INT)0 && hilf[j]!=i) { ++l; k=hilf[j]; hilf[j]= -1L; j=k; } if (j>=(INT)0) /* AK 030194 */ hilf[j]= -1L; if (l%2L) v *= (-1L); } SYM_free(hilf); return(v); } /* sigper */ /*----------------------------------------------------------------------------*/ static INT symdet (mat,slambda,li,tsc) TL_BYTE *mat, *slambda; INT li, *tsc; /*------------------------------------------------------------------------------ berechnet einen Faktor des Koeffizienten zur Schnittmatrix mat. (Weitere Erlaeuterung in: Golembiowski, Andreas Zur Berechnung modular irreduzibler Matrixdarstellungen symmetrischer Gruppen mit Hilfe eines Verfahrens von M.Clausen Bayreuther Mathematische Schriften Heft 25L, Bayreuth 1987 SS. 170ff) Variablen: mat, Schnittmatrix; slambda, konjugierte Partition; li, Element aus slambda. Rueckgabewerte: (INT)-108, falls Resttableau falsch; (INT)-109, falls nicht genug Speicher; (INT)0, sonst. Rueckgabe Koeffizientenfaktor tsc. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *cy,*pi,*zmat,*fln,*hfl,*afl,*ii,*z; INT lpi,i,j,k,l,d,la,_li,signum,bv,ik,r,err; TL_BYTE *piset,*mpi,*zm; _li=li; la=slambda[_li]; ++_li; if (la==1L) { if (mat[0]==(_spaltenz-_li+1L)) { *tsc=1L; return((INT)0); } else { *tsc=(INT)0; return((INT)0);/*return(RTabFt);*/ } } cy=(TL_BYTE *)TL_calloc((int)_zeilenz*((int)_zyk+2*(int)_zeilenz+5), sizeof(TL_BYTE)); if (!cy) return no_memory(); mpi=(TL_BYTE *)TL_calloc((int)q_zeilenz+(int)_zeilenz,sizeof(TL_BYTE)); if (!mpi) { SYM_free(cy); return no_memory(); } pi=cy+_zeilenz*_zyk; zmat=pi+_zeilenz*(_zeilenz+1L); fln=zmat+q_zeilenz; hfl=fln+_zeilenz; afl=hfl+_zeilenz; ii=afl+_zeilenz; piset=mpi+_zeilenz; *tsc=(INT)0; matcopy(zmat,mat,_zeilenz); if (alzyk(la,zmat,fln,cy)) { SYM_free(cy); SYM_free(mpi); return no_memory(); } if (fln[0]>=(INT)0) { for (r=(INT)0;r<_zeilenz;afl[r]=fln[r],r++); signum=sigper(fln,la); /* kann nich sein AK 090792 if (signum==NtEMem) { SYM_free(cy); SYM_free(mpi); return(NtEMem); } */ bv= *tsc; if (_li == _spaltenz) *tsc=signum; else { for (j=(INT)0;j1L) --k; if (pi[IND(k-1L,1L,_zeilenz+1L)]) { --k; for (r=(INT)0;r<_zeilenz;fln[r]=afl[r],r++); pi[IND(k,1L,_zeilenz+1L)]=(INT)0; for (r=(INT)0,zm= &piset[IND(k,(INT)0,_zeilenz)];r<_zeilenz;r++,zm++) if (*zm) mpi[r]=(INT)0; lpi -= pi[IND(k,(INT)0,_zeilenz+1L)]; if ((pi[IND(k,(INT)0,_zeilenz+1L)]+1L)%2L) signum *= (-1L); ++ii[k]; goto fl100; } } } SYM_free(cy); SYM_free(mpi); return((INT)0); } /* symdet */ /*----------------------------------------------------------------------------*/ static INT alcoeff(mat,slambda) TL_BYTE *mat, *slambda; /*------------------------------------------------------------------------------ berechnet aus der Schnittmatrix mat und Partition slambda den Koeffizienten. Variablen: mat, Schnittmatrix; slambda, konjugierte Partition zu lambda; Rueckgabewerte: koeff, Koeffizient zu mat und slambda; (INT)-108, falls ein Resttableau falsch war; (INT)-109, falls kein Speicherplatz vorhanden war. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *z; INT i,tsc,faktor; faktor=symdet(mat,slambda,(INT)0,&tsc); if (faktor) return(faktor); if (tsc) { for (i=q_zeilenz,z=mat,faktor=1L;i>(INT)0;i--,z++) if (*z) faktor *= fak((INT) *z); return(faktor*tsc); } else return (INT)0; } /* alcoeff */ /*----------------------------------------------------------------------------*/ static INT zweikonmat(lambda,perm,bz) TL_BYTE *lambda,*perm,*bz; /*------------------------------------------------------------------------------ berechnet die Koeffizientenmatrix bz fuer Partitionen lambda der Laenge 2. Variablen: lambda, eigentliche Partition; perm, Permutation. Rueckgabe Koeffizientenmatrix bz. Rueckgabewerte: dim, Dimension der gewoehnlichen Darstellungen, dim ist negativ, falls dim groesser MAXDM; (INT)-109, falls kein Speicherplatz vorhanden war. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i,j,k,l,z,zaehl[3],mdim,dim; TL_BYTE *hz,*g_i,*g_j,*start,*hilf_zwei,*hilf_drei,*_hz,*_bz,*z_eins; INT g_im,g_jm; start=(TL_BYTE *)TL_calloc((int)_n*5+(int)MAXDM*3,sizeof(TL_BYTE)); if (!start) return no_memory(); g_i=start+_n; g_j=g_i+_n; hilf_zwei=g_j+_n; hilf_drei=hilf_zwei+_n; hz=hilf_drei+_n; mdim=MAXDM; g_im=FALSE; if (nexgitt(start,lambda,&g_im)) { SYM_free(start); return no_memory(); } for (z=(INT)0;z<_n;g_i[z]=start[z],z++); for (i=(INT)0,g_im=TRUE;g_im;++i) { for (z=(INT)0;z<_n;g_j[z]=start[z],z++); for (z=3L*mdim,_hz=hz;z>(INT)0;z--,*_hz++ = (INT)0); for (j=(INT)0,g_jm=TRUE,_hz=hz;g_jm;j++,_hz++) { for (z=(INT)0;z<3L;zaehl[z++]=(INT)0); for (z=(INT)0;z<_n;hilf_zwei[z]=hilf_drei[perm[z]-1]=g_j[z],z++); hilf_zwei[1]=(INT)0; for (l=(INT)0;l<_n;++l) if (g_i[l]==1L) { if (g_j[l]==1L) ++zaehl[0]; if (hilf_zwei[l]==1L) ++zaehl[1]; if (hilf_drei[l]==1L) ++zaehl[2]; } for (z=(INT)0,z_eins=_hz;z<3L;z++,z_eins += mdim) *z_eins=COEFF(_n,(INT)zaehl[z],(INT)lambda[1]); if (nexgitt(g_j,lambda,&g_jm)) { SYM_free(start); return no_memory(); } } if (!i) { dim=j; if (dim>MAXDM) { dim *= (-1L); break; } else _bz=bz; } for (z=(INT)0,_hz=hz;z<3L;z++,_hz += mdim) for (k=(INT)0,z_eins=_hz;k< dim;k++) *_bz++ = *z_eins++; if (dim=i+1L;++j); if ((j<_n) && (lambda[j] < i+1L)) lambdastrich[i]=j; else lambdastrich[i]=_zeilenz; } return OK; } /* konjugiere */ /*----------------------------------------------------------------------------*/ static INT schnitt(t_eins,t_zwei,mat) TL_BYTE *t_eins, *t_zwei, *mat; /*------------------------------------------------------------------------------ berechnet Schnittmatrix zu den Tableaux t_eins und t_zwei. Variablen: t_eins, Tableau; t_zwei, Tableau. Rueckgabe Schnittmatrix mat. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *z; INT i; memset(mat,0,q_zeilenz * sizeof(TL_BYTE)); for (i=(INT)0;i<_n;++i) ++mat[IND(t_eins[i],t_zwei[i],_zeilenz)]; return OK; } /*schnitt*/ struct ak { INT c; INT p; char *ptr; }; static struct ak * ak_tmpfile() { #ifdef UNDEF struct ak *a; a = (struct ak *) TL_calloc((int)1,sizeof(struct ak)); if (a==NULL) return (struct ak *) no_memory(); a->c = (INT)0; /* erste unzulaessige stelle */ a->p = (INT)0; a->ptr = NULL; #endif init_mat(); } static ak_rewind(a) struct ak *a; { a->p = (INT)0; return OK; } static ak_fread(buf,size,numb,a) char **buf; INT size; INT numb; struct ak *a; { size = size * numb; if (a->p + size > a->c) size = a->c - a->p; *buf = a->ptr + a->p; a->p = a->p + size; return a->p; } #define AXSIZE 10000 static ak_fwrite(buf,size,numb,a) char *buf; INT size; INT numb; struct ak *a; { size = size *numb; if (a->ptr == NULL) { a->ptr = (char *)TL_calloc(AXSIZE,1); a->c = AXSIZE; } again: if (a->ptr == NULL) return no_memory(); if (a->p + size > a->c) { a->ptr = (char *) SYM_realloc(a->ptr,a->c + AXSIZE); if (a->ptr == NULL) return no_memory(); a->c = a->c + AXSIZE; goto again; } memcpy(a->ptr + a->p, buf,(int) size); a->p = a->p + size; return a->p; } static ak_fclose(a) struct ak *a; { close_mat(); } /* #define ak_fclose(a) fclose(a) #define ak_tmpfile() tmpfile() #define ak_rewind(a) rewind(a) #define ak_fwrite(buf,size,numb,a) fwrite(buf,size,numb,a) #define ak_fread(buf,size,numb,a) fread(buf,size,numb,a) */ static INT tl_prime = (INT) 9973; static INT tl_max_numb = (INT) 8; static INT tl_index_inc = (INT) 1; static TL_BYTE **mat_table; static TL_2BYTE **koeff_table; static INT *mat_length; static INT mat_size; INT tl_set_prime(p) INT p; { tl_prime = p; } INT tl_set_max_numb(p) INT p; { tl_max_numb = p; } INT tl_set_index_inc(p) INT p; { tl_index_inc = p; } #ifdef UNDEF #define PRIME 9973 /* 40993 */ #define INDEX_INC 1 #define MAX_NUMB 8 TL_BYTE *mat_table[PRIME]; TL_2BYTE *koeff_table[PRIME]; INT mat_length[PRIME]; #endif static init_mat() { INT i,size; TL_BYTE *a,*b; mat_table = (TL_BYTE **) TL_calloc(tl_prime,sizeof(TL_BYTE *)); mat_length = (INT *) TL_calloc(tl_prime,sizeof(INT)); koeff_table = (TL_2BYTE **) TL_calloc(tl_prime,sizeof(TL_2BYTE *)); mat_size = q_zeilenz; size = tl_prime * tl_max_numb * (q_zeilenz + sizeof(TL_2BYTE)); a = (TL_BYTE *) TL_malloc(size * sizeof(TL_BYTE)); b = a; for (i=(INT)0;i 31) { k = q_zeilenz / 32; for (;k>0;k--) for (j=(INT)0; j<32;i+=tl_index_inc,j+=tl_index_inc) if (mat[i]) index += offset[j]; } for (j=(INT)0; i= tl_max_numb) { mat_length[index]++; * (koeff_table[index]+ (mat_length[index] % tl_max_numb) ) = koeff; memcpy(mat_table[index]+ (q_zeilenz* (mat_length[index]%tl_max_numb) ), mat, q_zeilenz * sizeof(TL_BYTE)); } else { mat_length[index]++; * (koeff_table[index]+mat_length[index]-1) = koeff; memcpy(mat_table[index]+ (q_zeilenz*(mat_length[index]-1)), mat, q_zeilenz * sizeof(TL_BYTE)); } } static INT search_mat(co,mat, koeff) TL_BYTE *mat; TL_2BYTE *koeff; INT *co; { INT i=(INT)0,k,j; UINT index=(INT)0; /* compute adress */ if (q_zeilenz > 31) { k = q_zeilenz / 32; for (;k>0;k--) for (j=(INT)0; j<32;i+=tl_index_inc,j+=tl_index_inc) if (mat[i]) index += offset[j]; } for (j=0; i=0 ; i--) if (SYM_memcmp(mat,(mat_table[index])+(q_zeilenz * i), sizeof(TL_BYTE) * q_zeilenz) == 0) { *koeff = * (koeff_table[index] + i); return OK; } return -12L; } /*----------------------------------------------------------------------------*/ static INT mat_comp(co,mat,slambda) INT *co; TL_BYTE *mat,*slambda; /*------------------------------------------------------------------------------ ueberprueft die Schnittmatrix mat, ob mit dieser schon gerechnet wurde. Ist dies der Fall, so ist der Koeffizient gleich. Ansonsten wird fuer mat der neue Koeffizient berechnet. Variablen: co, Zaehler der verschiedenen Schnittmatrizen; mat, Schnittmatrix; slambda, konjugierte Partition zu lambda; Rueckgabe co mit alter bzw. neuer Anzahl der verschiedenen Schnittmatrizen. Rueckgabewerte: koeff, Koeffizient zu mat und slambda; (INT)-109, falls nicht genuegend Speicher vorhanden ist. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT gefunden, i,erg; TL_BYTE *schnittmat ,*z_eins,*z_zwei ,rr ; TL_2BYTE koeff; TL_BYTE *ak_buffer; /* AK 060392 */ i=1L; if ((*co)>(INT)0) { erg = search_mat(co,mat,&koeff); if (erg == OK) return koeff; } ++(*co); koeff = alcoeff(mat,slambda); if (koeff==RTabFt || koeff==NtEMem) return(koeff); write_mat(mat,koeff); return koeff; } /* mat_comp */ /*----------------------------------------------------------------------------*/ static INT alkonmat(lambda,perm,bz) TL_BYTE *lambda, *perm, *bz; /*------------------------------------------------------------------------------ berechnet zu einer Partition lambda und einer Permutation perm die Koeffi- zientenmatrix (B|C(12)|C(perm)). Variablen: lambda, eigentliche Partition; perm, Permutation. Rueckgabewerte: >(INT)0, kein Fehler aufgetreten; (INT)-10, falls Pointer auf lambda NULL ist; (INT)-11, falls lambda leer ist; (INT)-12, falls ein Element von lambda kleiner 0 ist; (INT)-13, falls lambda keine eigentliche Partition ist; // -15L, falls n > MAXN; // -16L, falls Laenge von lambda groesser MAXZEILENZ ist; // -17L, falls erstes Element von lambda groesser MAXSPALTENZ ist; (INT)-18, falls Dimension der gew. irred. Dg. >MAXDIM; (INT)-19, falls Pointer auf bz NULL ist; (INT)-20, falls sich der temporaere File nicht oeffnen laesst; (INT)-30, falls Pointer auf perm NULL ist; (INT)-31, falls Teil von perm <= 0 ist; (INT)-32, falls Teil von perm > n ist; (INT)-33, falls perm zu viele Elemente hat; (INT)-108, falls Resttableau in SYMDET falsch ist; (INT)-109, falls nicht genuegend Speicher vorhanden ist. Rueckgabe Koeffizientenmatrix bz. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *mat,*transmt,*zykmt,*hz,*t_eins,*t_zwei; TL_BYTE *ht,*asslambda,*_hz,*_bz,*z_eins; INT ii,jj,kk,i,k,z,co = (INT)0,co_eins,co_zwei,dim,diag,mdim,dim_,koeff; INT mehr_eins,mehr_zwei; /* Moegliche Eingabefehler... */ if (!lambda) return(LmbNul); else if (!lambda[0]) return(LmbEmp); else if (!bz) return(BzNul); for (i=(INT)0,_n=(INT)0;lambda[i];++i) if (lambda[i]<(TL_BYTE)0) return(LmbLt_null); else _n += lambda[i]; /* if (_n>MAXN) return(NGtMax); else */ if (perm==NULL) return(PerNul); /* for (i=(INT)0;i_n) return(PeLgGN); */ for (i=(INT)0;i<_n;i++) if (perm[i]<=(INT)0) return(PerLe_null); else if (perm[i]>_n) return(PerGtN); for (i=1L;lambda[i];++i) if (lambda[i]>lambda[i-1]) return(LmbNRg); /* Na denn ma' los... */ _zyk=ZYK/2+ZYK+1L; _spaltenz=lambda[0]; /*AK 240194 */ _zeilenz = i ; /* AK 240194 */ /* if ((_spaltenz=lambda[0])>MAXSPALTENZ) return(SzGtMx); if ((_zeilenz=i)>MAXZEILENZ) return(ZzGtMx); */ q_zeilenz=_zeilenz*_zeilenz; if (_zeilenz==2L) { dim_=zweikonmat(lambda,perm,bz); if (dim_<(INT)0) dim=DmGtMx; else dim=dim_; } else { /* allgemeine Partition/Anfang */ init_mat(); mat=(TL_BYTE *)TL_calloc((int)(q_zeilenz+MAXDM)*3+(int)(4*_n),sizeof(TL_BYTE)); if (mat == NULL) { close_mat(); return no_memory(); } transmt=mat+q_zeilenz; zykmt=transmt+q_zeilenz; t_eins=zykmt+q_zeilenz; t_zwei=t_eins+_n; ht=t_zwei+_n; asslambda=ht+_n; hz=asslambda+_n; mdim=MAXDM; konjugiere(lambda,asslambda); for (ii=(INT)0,diag=1L;ii<_zeilenz;++ii) diag *= fak(lambda[ii]); for (ii=(INT)0,kk=(INT)0;ii<_n && lambda[ii];++ii) { for (jj=kk;jj < (kk+lambda[ii]);ht[jj++]= ii); kk += lambda[ii]; } for (z=(INT)0;z<_n;t_zwei[z]=ht[z],z++); co_eins=co_zwei=(INT)0; for (i=(INT)0,mehr_zwei=TRUE;mehr_zwei;++i) { for (z=(INT)0;z<_n;t_eins[z]=ht[z],z++); for (z=3L*mdim,_hz=hz;z>(INT)0;z--,*_hz++ =(INT)0); for (k=(INT)0,mehr_eins=TRUE;mehr_eins;++k) { if (i==k) /*Hauptdiag. von B(lambda) und C(lambda/(12))*/ { hz[i]=diag; if (t_zwei[1]== 1) hz[i+mdim]=((TL_BYTE) -1)*(hz[i]/lambda[0]); else hz[i+mdim]=hz[i]; } else if (iii) co_eins++; } else hz[k+mdim]= hz[k]; } if (zykschnitt(t_zwei,t_eins,perm,zykmt)) { close_mat(); SYM_free(mat); return no_memory(); } /*Berechnung von C(lambda/(1..n)).*/ if (!i && !k) { co=(INT)0; koeff=mat_comp(&co,zykmt,asslambda); if (koeff!=NtEMem && koeff!=RTabFt) hz[2L*mdim]=koeff; else { close_mat(); SYM_free(mat); mehr_zwei = 280194L; nexgitt(NULL,NULL,&mehr_zwei); /* AK 280194 */ return(koeff); } } ii=co; koeff=mat_comp(&co,zykmt,asslambda); if (koeff!=NtEMem && koeff!=RTabFt) hz[k+2L*mdim]=koeff; else { close_mat(); SYM_free(mat); mehr_zwei = 280194L; nexgitt(NULL,NULL,&mehr_zwei); /* AK 280194 */ return(koeff); } if (co>ii) ++co_zwei; if (nexgitt(t_eins,lambda,&mehr_eins)) { close_mat(); SYM_free(mat); return no_memory(); } } if ((_zeilenz==1L) || (_spaltenz==1L)) co=1L; if (!i) { dim=dim_=k; if (dim>MAXDM) { dim_ *= (-1L); dim=DmGtMx; break; } else _bz=bz; } for (z=(INT)0,_hz=hz;z<3L;z++,_hz += mdim) for (k=(INT)0,z_eins=_hz;k(INT)0, Dimension der gew. irred. Darstellung; sonst, s. MODULKFF.C Funktion alkonmat(). ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *mat,*t_eins,*t_zwei,*ht,*slambda,*hz; INT ii,jj,kk,i,k,z,co = (INT)0,dim,diag,mdim,dim_,koeff; INT mehr_eins,mehr_zwei; TL_BYTE *_bz; /* Moegliche Eingabefehler... */ if (!lambda) return(LmbNul); else if (!lambda[0]) return(LmbEmp); else if (!bz) return(BzNul); for (i=(INT)0,_n=(INT)0;lambda[i];++i) if (lambda[i]<0) return(LmbLt_null); else _n += (INT)lambda[i]; /* if (_n>MAXN) return(NGtMax); else */ if (pz<=(INT)0) return(PrmLe_null); else if (pz) { for (i=(INT)0;PZ[i]<=pz;i++); if (pz!=PZ[i-1]) return(NoPrm); } for (i=1L;lambda[i];++i) if (lambda[i]>lambda[i-1]) return(LmbNRg); /* Na denn ma' los... */ /* printeingabe("C1");*/ _zyk=ZYK/2L+ZYK+1L; _zeilenz = i; /* AK 240194 */ _spaltenz = lambda[0]; /* AK 240194 */ /* if ((_spaltenz=lambda[0])>MAXSPALTENZ) return(SzGtMx); if ((_zeilenz=i)>MAXZEILENZ) return(ZzGtMx); */ q_zeilenz=_zeilenz*_zeilenz; if (_zeilenz==2L) { dim_=_k_zweikonmat(lambda,bz,pz); /* kann nich sein AK 090792 if (dim_==NtEMem) return(NtEMem); */ if (dim_<(INT)0) dim=DmGtMx; else dim=dim_; } else { /* allgemeine Partition/Anfang */ /* printeingabe("C2");*/ init_mat(); mat=(TL_BYTE *)TL_calloc((int)(q_zeilenz)+(int)(4*_n)+1,sizeof(TL_BYTE)); if (mat == NULL) { close_mat(); return no_memory(); } t_eins=mat+(INT)q_zeilenz; t_zwei=t_eins+(INT)_n; ht=t_zwei+(INT)_n; /* printeingabe("C3");*/ slambda=ht+_n; mdim=MAXDM; _assoziiere(lambda,slambda,_n); for (ii=(INT)0,diag=1L;ii<_zeilenz;++ii) diag *= fak((INT)lambda[ii]); for (ii=(INT)0,kk=(INT)0;ii<_n && lambda[ii];++ii) { for (jj=kk;jj < (kk+lambda[ii]);jj++) ht[jj]=(TL_BYTE)ii; kk += lambda[ii]; } for (z=(INT)0;z<_n;t_zwei[z]=ht[z],z++); _bz=bz; for (i=(INT)0,mehr_zwei=TRUE;mehr_zwei;++i) { for (z=(INT)0;z<_n;t_eins[z]=ht[z],z++); for (k=0,hz=bz+i,mehr_eins=TRUE;mehr_eins;++k) { /* printeingabe("C4");*/ if (i==k) *_bz++ = (TL_BYTE) TL_MOD(diag,pz); else if (kMAXDM) { dim_ *= (-1L); dim=DmGtMx; error("mo.c:internal error 400"); break; } } if (dim0; kk-= AKSIZE) { for (jj=0;jj 0) ;ii++) { hz[MAXDM*ii+jj] = bz[jj*MAXDM+(kk-ii)]; } for (ii=0;(ii 0) ;ii++) memcpy(&bz[(kk-ii)*MAXDM], &hz[ii * MAXDM], kk-ii); } /* for (i=0;ii;j--) { mu= *z_zwei; *z_zwei++ = *z_eins; *z_eins++ = mu; } if (*_bz) { if ((qu= *_bz)!=(TL_BYTE)1) for (j=dm,z_eins=_bz;j>i;j--,z_eins++) { if (*z_eins) /* AK 010394 */ *z_eins=(TL_BYTE)TL_DIVP(*z_eins,qu,pz); } if (ii;j--,z_eins++,z_zwei++) if (*z_zwei) { *z_eins = TL_MOD( *z_eins - qu * *z_zwei, pz); } } } return OK; } /* _k_moddreimat */ /*----------------------------------------------------------------------------*/ static INT _k_modgauss(bz,pz) TL_BYTE *bz; INT pz; /*------------------------------------------------------------------------------ berechnet mit Hilfe des Gaussalgorithmus ueber GF(pz) die Dimension der modular irreduziblen Darstellung. (Vgl. in MODULDG.C Funktion modgauss().) Variablen: bz, Matrix mit Basis; pz, Primzahl. Rueckgabe bz. Rueckgabewert: Dimension der mod. irred. Darstellung. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_bz,*z_eins,*z_zwei,*z_drei,*z_vier,qu; INT i,j,k,prang; TL_BYTE mu; prang=(INT)0; for (i=dm-1,_bz= &bz[qdm-1];i>0;i--,_bz -= (dm+1L)) if (*_bz) { if ((qu= *_bz)!=(TL_BYTE)1) for (k=i,z_eins=_bz;k=0;j--,z_zwei -= dm) if ((qu= *z_zwei)!=(TL_BYTE)0) for (k=dm,z_drei=z_eins,z_vier=z_zwei;k>i;k--,z_drei++,z_vier++) if (*z_drei) { *z_vier = TL_MOD(*z_vier - qu * *z_drei, pz); } } else prang++; if (bz[0]!=(TL_BYTE)1) { if ((qu=bz[0])==(TL_BYTE)0) prang++; else for (j=0,_bz=bz;j 0L) /* AK 230996 */ check_time(); d=r[0]; if (mode) { sum=(r[d]==1L)? m[d--]+1L : 1L; f=r[d]-1L; if (m[d]!=1L) m[d++]--; r[d]=f; m[d]=(sum/f)+1L; s=sum % f; if (s>(INT)0) { r[++d]=s; m[d]=1L; } r[0]=d; return(m[d]!=n); } else { r[0]=m[1]=1L; r[1]=n; return(n!=1L); } } /* _nexpart */ /*----------------------------------------------------------------------------*/ static INT _part_reg(p,r,m) INT p; TL_BYTE *r, *m; /*------------------------------------------------------------------------------ ueberprueft die Partition gegeben durch r und m, ob sie p-regulaer ist. Variablen: p, Primzahl; r, Partition mit r[0]=Laenge von r und m, r[1]...r[r[0]] Elemente der Partition; m, Vielfachheiten von r[1]...r[r[0]]. Rueckgabewerte: (INT)0, falls Partition nicht p-regulaer; 1L, falls Partition p-regulaer ist. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i; for (i=1L;i<=r[0];i++) if (m[i]>=p) return((INT)0); return(1L); } /* _part_reg */ /*----------------------------------------------------------------------------*/ static INT _num_part(n,pz) INT n,pz; /*------------------------------------------------------------------------------ berechnet fuer pz=0 die Anzahl der Partitionen zu n und fuer pz!=0 die Anzahl der regulaeren Partitionen. Variablen: n, die zu partitionierende Zahl; pz, Primzahl oder 0. Rueckgabewerte: >(INT)0, die Anzahl der (p-regulaeren) Partitionen von n; (INT)-109, falls nicht genuegend Speicher vorhanden war. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT num,d,e; TL_BYTE *r,*m; r=(TL_BYTE *)SYM_calloc(2*(int)(n+1),sizeof(TL_BYTE)); m=r+(INT)n+1L; num=(INT)0; e=1L; d=(INT)0; while (e) { e=d=_nexpart(n,d,r,m); if (pz) { if (_part_reg(pz,r,m)) num++; } else num++; } SYM_free(r); return(num); } /* _num_part */ /*----------------------------------------------------------------------------*/ static INT _r_induk(lambda,n,pz,i,r) TL_BYTE *lambda; INT n,pz,i,r; /*------------------------------------------------------------------------------ ueberprueft die Moeglichkeit einer r-Induktion des zur Partition lambda gehoerenden Tableaux in der Zeile i. Variablen: lambda, Partition zu n; n; pz, Primzahl; i, Zeile des Tableaux; r, die "Ordnung" des anzuhaengenden Knotens. Rueckgabewerte: (INT)0, falls r-Induktion nicht moeglich; 1L, falls r-Induktion moeglich ist. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT len; for (len=(INT)0;lenlambda[i]) return(TL_MOD(lambda[i]-i,pz)==r); else return((INT)0); } else if (i==len) return(TL_MOD(-i,pz)==r); else return((INT)0); } /* _r_induk */ /*----------------------------------------------------------------------------*/ static INT _ber_lambdas(lambda,n,p) INT n,p; TL_BYTE **lambda; /*------------------------------------------------------------------------------ berechnet fuer p=0 alle eigentlichen Partitionen von n und fuer p!=(INT)0, p Primzahl, alle p-regulaeren Partitionen von n. Variablen: n, die zu partitionierende Zahl; p, Primzahl oder (INT)0; Rueckgabe lambda, Vektor von Partitionen. Rueckgabewerte: (INT)0, falls alle Partitionen ohne Fehler berechnet wurden; (INT)-109, falls kein Speicher zur Verfuegung stand. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *r,*m; INT d,e,i,j,k,l; r=(TL_BYTE *)TL_calloc((int)(n+1)*2,sizeof(TL_BYTE)); if (r == NULL) return no_memory(); m=r+(INT)(n+1L); e=1L; k=d=(INT)0; while(e) { d=e=_nexpart(n,d,r,m); if (!p) { for (i=(INT)0;i 12) error("mo:internal error: 500"); if (n<=1L) return(1L); else return ((INT)n*_fakul(n-1L)); } /* _fakul */ /*----------------------------------------------------------------------------*/ static INT _dimension(lambda,n) TL_BYTE *lambda; INT n; /*------------------------------------------------------------------------------ berechnet die Dimension der Darstellung zu einer eigentlichen Partition mit Hilfe der Hakenformel. Variablen: lambda, Partition; n, die partitionierte Zahl. Rueckgabewert: Dimension. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT i,j,l; INT zz,zn; TL_BYTE *slambda; if (n > (INT)12) /* AK 260195 */ { OP p,a; a = callocobject(); p = callocobject(); for (l=(INT)0;lambda[l]>0;l++); b_ks_pa(VECTOR,callocobject(),p); m_il_v(l,S_PA_S(p)); l--; for (i=0;l>=0;i++,l--) m_i_i((INT)(lambda[l]),S_PA_I(p,i)); dimension_partition(p,a); l=s_i_i(a); freeall(a); freeall(p); return l; } slambda=(TL_BYTE *)TL_calloc((int)(n+1),sizeof(TL_BYTE)); if (slambda == NULL) return no_memory(); _assoziiere(lambda,slambda,n); zz=_fakul(n); for (l=(INT)0;l1) { for (i=0;ij;k--) { if (!r_mat[k]) continue; if (_diff(r_mat[j],r_mat[k],c,row)) { for (l=0;ldim[i]) break; else if (dm 0) ; } } } while(end); fclose(dfp); return((INT)0); } /* _search_dec */ /*----------------------------------------------------------------------------*/ static INT _append_dec(decomp,row,col,n,pz) TL_BYTE *decomp; INT row,col,n,pz; /*------------------------------------------------------------------------------ haengt an das Ende des Files 'decommix.dat' eine fuer n und pz noch nicht berechnete Zerlegungsmatrix. Variablen: decomp, Zerlegungsmatrix; row, Zeilenzahl der Zerlegungsmatrix; col, Spaltenzahl der Zerlegungsmatrix; n, Sn; pz, Primzahl. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { FILE *dfp; INT info[4],i,j; dfp=fopen("decommix.dat","a+"); if (!dfp) return ERROR; info[0]=n; info[1]=pz; info[2]=row; info[3]=col; fprintf(dfp,"%ld %ld %ld %ld \n ",info[0],info[1],info[2],info[3]); j = info[2] * info[3]; for (i=(INT)0; i=(INT)0, Dimension der Darstellung; -1L, falls Fehler Aufgetreten ist. Rueckgabe darstellende Matrix dmat, die erst hier dimensioniert wird, falls die Dimension groesser 0 ist. ------------------------------------------------------------------------------*/ { TL_BYTE *part,*bz,*perm; TL_BYTE *darmat[2],*dar; INT pz,dim; INT spe,i,j,l_pa,l_p,gzl; OP dimen; OP lambda; if (equal_parts(llambda,prime)) { fprint(stderr,llambda); fprintln(stderr,prime); return error("moddg: wrong partition, wrong prime"); } if (S_PA_LI(llambda) == 1L) /* AK 020692 */ if (S_PA_II(llambda,(INT)0) == 1L) /* AK 020692 */ { /* AK 020692 */ m_ilih_m(1L,1L,dmat); /* AK 020692 */ m_i_i(1L,S_M_IJ(dmat,(INT)0,(INT)0)); /* AK 020692 */ return OK; /* AK 020692 */ } /* AK 020692 */ dimen=callocobject(); weight(llambda,dimen); if (neq(dimen,S_P_L(pi))) { /* AK 310702 */ fprint(stderr,llambda); fprintln(stderr,pi); error("moddg: wrong permutation, wrong degree"); freeall(dimen); return ERROR; } lambda=callocobject(); conjugate(llambda,lambda); l_pa=S_PA_LI(lambda); l_p=S_P_LI(pi); spe=l_pa+l_p+2L; dimension(lambda,dimen); MAXDM=(INT)S_I_I(dimen); spe += ((INT)MAXDM*(INT)MAXDM*5L); part=(TL_BYTE *)TL_calloc(spe,sizeof(TL_BYTE)); if (!part) { freeall(dimen); freeall(lambda); return(-1L); } perm=part+l_pa+1; bz=perm+l_p+1; for (i=0;i(INT)0, Relation ... ist nicht erfuellt; -1L, Fehler aufgetreten. Rueckgabe relation erhaelt die Nummer der nicht erfuellten Relation oder 0. ------------------------------------------------------------------------------*/ { TL_BYTE *darmat[2],*d[2]; INT dm,i_n,rl,pz; INT i,j; if (!S_M_LI(transmat)) { m_i_i((INT)0,relation); return((INT)0); } dm=(INT)S_M_LI(transmat); i_n=(INT)S_I_I(sn); pz=(INT)S_I_I(prime); darmat[0]=(TL_BYTE *)TL_calloc((int)dm*(int)dm*2,sizeof(TL_BYTE)); if (!darmat[0]) return(-1L); darmat[1]=darmat[0]+(INT)dm*(INT)dm; for (i=(INT)0,d[0]=darmat[0],d[1]=darmat[1];i<(INT)dm;i++) for (j=(INT)0;j<(INT)dm;j++) { *d[0]++ =(INT)S_M_IJI(transmat,i,j); *d[1]++ =(INT)S_M_IJI(nzykmat,i,j); } if ((rl=homtestp(darmat,i_n,dm,pz))<(INT)0) { SYM_free(darmat[0]); return(-1L); } m_i_i((INT)rl,relation); SYM_free(darmat[0]); return((INT)rl); } /* homp */ /*----------------------------------------------------------------------------*/ INT brauer_char(sn,prime,bc) OP sn,prime,bc; /*------------------------------------------------------------------------------ berechnet die Charaktertafel der Brauercharaktere der Sn zur Primzahl prime. Variablen: sn, Sn (objectkind:INTEGER); prime,Primzahl (objectkind:INTEGER). Rueckgabewerte: (INT)0, falls fehlerfrei; -1L, falls Fehler aufgetreten ist. Rueckgabe der Charaktertafel bc. ------------------------------------------------------------------------------*/ { INT _n,p,col,*idx,*idm; INT i,j,k,erg = OK; OP tafel,decomp, su, mu, _su; if (not primep(prime)) return error("brauer_char:second parameter no prime"); _n=(INT)S_I_I(sn); p=(INT)S_I_I(prime); if ((col=_num_part(_n,p))<(INT)0) return(-1L); idx=(INT *)TL_calloc((int)col*2,sizeof(INT)); if (!idx) { return ERROR; } idm=idx+(INT)col; if (_ber_idx_pelem(_n,p,col,idx)) { SYM_free(idx); return(-1L); } tafel=callocobject(); decomp=callocobject(); su=callocobject(); mu=callocobject(); _su=callocobject(); if (decp_mat(sn,prime,decomp)) { SYM_free(idx); freeall(tafel); freeall(decomp); freeall(su); freeall(mu); freeall(_su); return(-1L); } _ber_inx_dec(decomp,idm); chartafel(sn,tafel); m_ilih_m((INT)col,(INT)col,bc); for (i=(INT)0;i<(INT)col;i++) for (j=(INT)0;j<(INT)col;j++) { copy(S_M_IJ(tafel,(INT)idm[i],(INT)idx[j]),su); for (k=(INT)0;kr[0]) *id++ =i; i++; } SYM_free(r); return((INT)0); } /* _ber_idx_pelem */ /*----------------------------------------------------------------------------*/ static INT _ber_inx_dec(dcm,idx) OP dcm; INT *idx; /*------------------------------------------------------------------------------ berechnet in den Spalten der Zerlegungsmatrix dcm den Zeilenindex des ersten Elements !=0. Variablen: dcm, Zerlegungsmatrix; col, Spaltenanzahl der Zerlegungsmatrix; row, Zeilenanzahl der Zerlegungsmatrix. Rueckgabe Indexvektor idx. ------------------------------------------------------------------------------*/ { INT i,j,col,row; INT *id; col=S_M_LI(dcm); row=S_M_HI(dcm); for (i=(INT)0;iMAXDM) return(DDmGMx); else if (darmat==NULL) return (DrtNul); else if (n<=(INT)0) return(NLe_null); /* else if (n>MAXN) return(NGtMax); */ else if (pz<=(INT)0) return(PrmLe_null); else if (pz>n) return(PrmGtN); for (i=(INT)0;PZ[i]<=n && PZ[i]<=pz;i++); if (pz!=PZ[i-1]) return(NoPrm); /* Kein Eingabefehler, also koennen wir loslegen: */ mat=(TL_BYTE *)TL_calloc((int)ddim*(int)ddim*3,sizeof(TL_BYTE)); if (!mat) return no_memory(); mat_eins= &mat[(INT)ddim*(INT)ddim]; invzyk= &mat_eins[(INT)ddim*(INT)ddim]; matcopy(mat,darmat[0],ddim); if (rmatmulp(mat,darmat[0],ddim,pz)<(INT)0) { SYM_free(mat); return no_memory(); } if (!idmat(mat,ddim)) /* t^2 = 1 ? */ { SYM_free(mat); return(1L); } matcopy(mat,darmat[1],ddim); rmatmulp(mat,darmat[0],ddim,pz); matcopy(mat_eins,mat,ddim); az=1L; while (2L*az <= (n-1L)) { matcopy(invzyk,mat_eins,ddim); rmatmulp(mat_eins,invzyk,ddim,pz); az *= 2L; } for (i=az+2L; i<= n; i++) rmatmulp(mat_eins,mat,ddim,pz); if (!idmat(mat_eins,ddim)) /* (s * t) ^ (n-1L) =1 ? */ { SYM_free(mat); return(3L); } matcopy(mat,darmat[1],ddim); az=1L; while (2L*az <= n-1L) { matcopy(mat_eins,mat,ddim); rmatmulp(mat,mat_eins,ddim,pz); az*=2L; } for (i=az+2L;i<=n;++i) rmatmulp(mat,darmat[1],ddim,pz); matcopy(invzyk,mat,ddim); /* s^(-1L) = s^(n-1L) */ rmatmulp(mat,darmat[1],ddim,pz); if (!idmat(mat,ddim)) /* s^n = 1 ? */ { SYM_free(mat); return(2L); } matcopy(mat,darmat[0],ddim); rmatmulp(mat,invzyk,ddim,pz); rmatmulp(mat,darmat[0],ddim,pz); rmatmulp(mat,darmat[1],ddim,pz); matcopy(mat_eins,mat,ddim); rmatmulp(mat_eins,mat,ddim,pz); rmatmulp(mat_eins,mat,ddim,pz); if (!idmat(mat_eins,ddim)) /* (t * s^(-1L) * t * s) ^ 3 = 1 ? */ { SYM_free(mat); return(4L); } k=n/2L; for (j=2L; j<=k; j++) { rmatmulp(mat,darmat[1],ddim,pz); /* in mat ist noch t*s^1*t*s */ lmatmulp(darmat[0],mat,ddim,pz); lmatmulp(invzyk,mat,ddim,pz); lmatmulp(darmat[0],mat,ddim,pz); matcopy(mat_eins,mat,ddim); rmatmulp(mat_eins,mat,ddim,pz); if (!idmat(mat_eins,ddim)) /* (t*s^(-j)*t*s^j)^2 = 1 fuer j=2L,...k ? */ { SYM_free(mat); return(j+3L); } } SYM_free(mat); return((INT)0); } /*homtestp */ /******************************************************************************* * * Datei MODMAT.C * Version vom 11.10.1989 * * * Zeile Funktion * * Funktionen fuer Matrixoperationen * --------------------------------- * 39 INT matcopy(TL_BYTE *ziel,TL_BYTE *quelle,INT dim) * 59 INT rmatmulp(TL_BYTE *lmat,TL_BYTE *rmat,INT pdim,INT pz) * 102 INT lmatmulp(TL_BYTE *lmat,TL_BYTE *rmat,INT pdim,INT pz) * 152 INT idmat(TL_BYTE *z,INT dm) * *******************************************************************************/ /* Uebliche Headerfiles... */ /*----------------------------------------------------------------------------*/ static INT rmatmulp(lmat,rmat,pdim,pz) INT pz, pdim; TL_BYTE *lmat, *rmat; /*----------------------------------------------------------------------------- multipliziert die (pdim x pdim)-Matrix lmat von rechts mit der (pdim x pdim)-Matrix rmat. Dabei werden Multiplikationen und Additionen modulo pz ausgefuehrt. Variablen: lmat, Matrix; rmat, Matrix; pdim, Dimension der Matrizen; pz, Primzahl. Rueckgabe Ergebnismatrix lmat. Ruechgabewerte: (INT)0, falls alles geklappt hat; (INT)-109, falls der noetige Speicher nicht vorhanden war. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { INT h,i,j,k,o_eins,o_zwei; TL_BYTE *aa,*bb,*hilf,*aa_eins; hilf=(TL_BYTE *)TL_calloc((int)pdim,sizeof(TL_BYTE)); if (hilf == NULL) return no_memory(); aa_eins=lmat; for (i=(INT)0 ; i < pdim; ++i) { for (j=(INT)0 ; j < pdim; ++j) { h=(INT)0; bb= &rmat[(INT)j]; aa=aa_eins; for (k=(INT)0; ki;j--) { mu= *z_zwei; *z_zwei++ = *z_eins; *z_eins++ = mu; } if (*_hz) { if ((qu= *_hz)!=1L) for (j=mdm,z_eins=_hz;j>i;j--,z_eins++) { if (*z_eins) *z_eins=TL_DIVP(*z_eins,qu,pz); } if (i<_dm-1L) for (k=i+1L,jz=_hz+_dm_drei;k<_dm;k++,jz += _dm_drei) if ((qu= *jz)!=(INT)0) for (j=mdm,z_eins=jz,z_zwei=_hz;j>i;j--,z_eins++,z_zwei++) if (*z_zwei) { /* mu=(-1L)*(TL_MULP(qu,*z_zwei,pz)); *z_eins=TL_ADP(*z_eins,mu,pz); */ *z_eins = TL_MOD((-1 * qu * *z_zwei) + *z_eins, pz); } } } return OK; } /* moddreimat */ /*----------------------------------------------------------------------------*/ static INT _modgauss(hz,pz,i,mode) INT pz,i,mode; TL_BYTE *hz; /*------------------------------------------------------------------------------ wird benoetigt fuer die Funktionen modgauss und r_modgauss. Variablen: hz, Matrix mit Basis und Darstellungen; pz, Primzahl; i, Anfangswert der Schleife; mode, =1L, fuer modgauss, =3L, fuer r_modgauss; Rueckgabe Matrix hz. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE mu,qu,*_hz,*jz,*z_eins,*z_zwei; INT j,k,mdm; mdm=mode*_dm; for (j=i-1L,_hz= &hz[IND(i,i,_dm_drei)],jz=_hz-_dm_drei;j>=(INT)0;j--,jz -= _dm_drei) if ((qu= *jz)!=(TL_BYTE)0) for (k=mdm,z_eins=_hz,z_zwei=jz;k>i;k--,z_zwei++,z_eins++) if (*z_eins) { mu=(TL_BYTE) (-1L)*(TL_MULP(qu,*z_eins,pz)); *z_zwei= TL_ADP(*z_zwei,mu,pz); } return OK; } /* _modgauss */ /******************************************************************************* * * Funktionen zur Bestimmung der gew. irred. Darstellungen... * *******************************************************************************/ /*----------------------------------------------------------------------------*/ static INT r_modgauss(hz,pz) TL_BYTE *hz; INT pz; /*------------------------------------------------------------------------------ wendet den Gaussalgorithmus ueber GF(pz) auf das (_dm x 3_dm)-Koeffizienten- schema an, wobei die erste (_dm x _dm)-Teilmatrix eine obere Dreiecksmatrix mit 0 oder 1 auf der Hauptdiagonalen sein muss. (Simultanes Loesen von 2_dm linearen Gleichungssystemen.) Variablen: hz, Matrix mit Basis und Darstellungen; pz, Primzahl. Rueckgabe Matrix hz. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_hz; INT i; for (i=_dm-1L,_hz= &hz[IND(_dm-1L,_dm-1L,_dm_drei)];i>(INT)0;i--,_hz -= (_dm_drei+1L)) if (*_hz) _modgauss(hz,pz,i,3L); return OK; } /* r_modgauss */ /*----------------------------------------------------------------------------*/ static INT ganzgaussmod(bz,hz) TL_BYTE *hz, *bz; /*------------------------------------------------------------------------------ loest simultan die in dem (_dm x 3_dm)-Koeffizientenschema bz kodierten 2_dm linearen Gleichungssysteme. Am Ende stehen die Loesungen fuer die gew. irred. Darstellungen in den letzten 2_dm Spalten von bz. Koennen keine ganzz. Loesungen errechnet werden, wird die Berechnung abge- brochen. Variablen: bz, Matrix aus alkonmat; hz, Matrix wie bz. Rueckgabe Matrix hz mit Basis und Matrizen der gewoehnlichen Darstellungen. Rueckgabewerte: (INT)0, falls alles geglueckt ist; -27L, falls keine ganzzahlige Loesung existiert. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_hz,*_bz,*z_eins,*z_zwei,*z_drei; INT i,j,k,pz,su; INT il,cl; INT chance; pz=(INT)29; chance=TRUE; while (chance) { /* Interpretation von bz ueber GF(pz) und Uebergabe an hz */ for (il=(INT)_dm*(INT)_dm_drei,_hz=hz,_bz=bz;il>(INT)0;il--,_hz++,_bz++) if (*_bz) *_hz = (TL_BYTE) TL_MOD(*_bz,pz); else *_hz = (TL_BYTE) 0; /* Anwendung des Gaussalgorithmus ueber GF(pz) */ moddreimat(hz,pz,3L); r_modgauss(hz,pz); /* Rekonstruktion der ganzzahligen Loesungen */ for (i=(INT)0,_hz=hz+_dm;i<_dm;i++,_hz += _dm_drei) for (j=_dm,z_eins=_hz;j<_dm_drei;j++,z_eins++) if (*z_eins) { if ((*z_eins + *z_eins) > pz) *z_eins -= pz; } /* Verifikation der Loesungen: Die Koeffizientenmatrix der Gleichungssysteme (die ersten _dm Spalten von bz) wird mit der Loesungsmatrix (die letzten 2_dm Spalten von hz) multipliziert. Jeder Eintrag der Produktmatrix wird unmittelbar nach seiner Berechnung mit dem entsprechenden Eintrag in den letzten 2_dm Spalten von bz verglichen. cl gibt die Anzahl der Uebereinstimmungen an. */ for(i=(INT)0,cl=(INT)0,_bz=bz;i<_dm;i++,_bz += _dm_drei) for (j=_dm,z_eins=_bz+_dm,_hz=hz+_dm;j<_dm_drei;j++,z_eins++,_hz++) { for (k=(INT)0,su=(INT)0,z_zwei=_hz,z_drei=_bz;k<_dm;k++,z_drei++,z_zwei +=_dm_drei) { if (! *z_zwei) continue; if (! *z_drei) continue; su += (*z_zwei * *z_drei); } if (su == *z_eins) ++cl; } if (cl==((INT)_dm_zwei*(INT)_dm)) chance=FALSE; else { if (pz==(INT)211) { error("internal error: MO_50"); return(NoSolu); } pz=(INT)211; chance=TRUE; } } return((INT)0); } /* ganzgaussmod */ /******************************************************************************* * * Funktionen zur Bestimmung der p-mod. irred. Darstellungen... * *******************************************************************************/ /*----------------------------------------------------------------------------*/ static INT modmat(hz,pr) TL_BYTE *hz; INT pr; /*------------------------------------------------------------------------------ transformiert die (_dm x 3_dm)-Matrix hz nach (hz mod pr). Variablen: hz, Matrix mit Basis und Darstellungen; pr, Primzahl. Rueckgabe Matrix hz gerechnet modulo pr. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_hz; INT il; for (il=(INT)_dm*(INT)_dm_drei,_hz=hz;il>(INT)0;il--,_hz++) if (*_hz) *_hz=(TL_BYTE)TL_MOD(*_hz,pr); else *_hz=(TL_BYTE)0; return OK; } /* modmat */ /*----------------------------------------------------------------------------*/ static INT modgauss(hz,v,pr) TL_BYTE *hz, *v; INT pr; /*------------------------------------------------------------------------------ berechnet mit Hilfe des Gaussalgorithmus ueber GF(pr) die Dimension der p-mod. irred. Darstellung. Der Gaussalgorithmus wird dabei auf die erste (_dm x _dm)-Teilmatrix von hz angewendet, wobei diese eine obere Dreiecks- matrix mit 0 oder 1 auf der Hauptdiagonalen sein muss. Variablen: hz, Matrix mit Basis und Darstellungen; pr, Primzahl. Rueckgabe Nummernvektor v der abhaengigen Spalten in hz. Rueckgabewerte: prang, Dimension der p-modular irreduziblen Darstellung. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_hz,*z_eins,*z_zwei,*_v,qu,su; INT z,i,j,k,prang; prang=(INT)0; for (i=(INT)0;i<_dm;v[i++]=(TL_BYTE)0); for (i=_dm-1L,_hz= &hz[IND(_dm-1L,_dm-1L,_dm_drei)],_v= &v[_dm-1];i>(INT)0; i--,_hz -= (_dm_drei+1L),_v--) if (*_hz) { if ((qu = *_hz)!=(TL_BYTE)1) for (k=i,z_eins=_hz;k<_dm;k++,z_eins++) if (*z_eins) *z_eins= TL_DIVP(*z_eins,qu,pr); _modgauss(hz,pr,i,1L); } else { *_v = (TL_BYTE)i+1; ++prang; } if (hz[0]!=(TL_BYTE)1) { if ((qu=hz[0])==(TL_BYTE)0) { v[0]=(TL_BYTE)1; ++prang; } else for (j=(INT)0,_hz=hz;j<_dm;j++,_hz++) if (*_hz) *_hz = TL_DIVP(*_hz,qu,pr); } prang=_dm-prang; for (i=_dm-2L,_v= &v[_dm-2],_hz= &hz[IND(_dm-2L,_dm-1L,_dm_drei)];i>=(INT)0; i--,_v--,_hz -= (_dm_drei+1L)) if (*_v == (TL_BYTE) i+1) { for (j=i+1L,su=(TL_BYTE)0,z_eins=_hz;!su && j<_dm;j++,z_eins++) if (*z_eins) su=(TL_BYTE)j; if (su) { v[su]=(TL_BYTE)0; z_eins= &hz[IND(i,su,_dm_drei)]; z_zwei= &hz[IND(su,su,_dm_drei)]; for (j=su;j<_dm;++j) { z= *z_eins; *z_eins++ = *z_zwei; *z_zwei++ = z; } } _modgauss(hz,pr,su,1L); } return(prang); } /* modgauss */ /*----------------------------------------------------------------------------*/ static INT p_rel(hz,v,pr) TL_BYTE *hz, *v; INT pr; /*------------------------------------------------------------------------------ Simultane Ermittlung und Anwendung der p-Relationen. (Lineare Algebra!) Variablen: v, Nummern der abhaengigen Spalten in hz; pr, Primzahl; hz, Matrix mit Basis und Darstellungen. Rueckgabe Matrix hz. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_v,*_hz,*z_eins,*z_zwei,*z_drei,*z_vier,mu,su; INT i,j,k; for (i=(INT)0,_v=v,_hz=hz;i<_dm;i++,_v++,_hz += _dm_drei) if (*_v == i+1L) for (j=(INT)0,z_eins=_hz+_dm,z_zwei=hz+_dm;j<_dm_zwei;j++,z_eins++,z_zwei++) if ((mu= *z_eins)!=(TL_BYTE)0) for (k=(INT)0,z_drei=hz+i,z_vier=z_zwei;k<=i-1L;k++,z_drei += _dm_drei,z_vier += _dm_drei) if (*z_drei != (TL_BYTE)0) { su= TL_MULP(mu,*z_drei,pr); *z_vier=TL_ADP(su,*z_vier,pr); } return OK; } /* p_rel */ /*----------------------------------------------------------------------------*/ static INT zykel(liste,zyk) TL_BYTE *liste, *zyk; /*------------------------------------------------------------------------------ berechnet die Zykelschreibweise einer Permutation liste aus ihrer Listen- schreibweise. Dabei steht eine negative Zahl immer als Ende des Zykels. Variablen: liste, Pointer auf die Permutation in Listenschreibweise. Rueckgabe Permutation zyk in Zykelschreibweise. Rueckgabewerte: (INT)0, falls kein Fehler aufgetreten ist; (INT)-109, falls nicht genuegend Speicher vorhanden war. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *z; INT merk,merk_eins,i,j,n; INT fertig; TL_BYTE *besucht; for (n=(INT)0;liste[n];n++); if ((besucht=(TL_BYTE *)TL_calloc((int)n,sizeof(TL_BYTE)))==NULL) return no_memory(); z=zyk; i=(INT)0; *z++ =(TL_BYTE)(merk=merk_eins=1L); fertig=FALSE; do { besucht[i]=(TL_BYTE)1; if (liste[i]==merk_eins) { z--; *z++ = -merk; for (j=(INT)0;j=n || !liste[i]) fertig=TRUE; else *z++ =(TL_BYTE)(merk=merk_eins=i+1L); } else { merk= *z++ =(TL_BYTE)liste[i]; i=liste[i]-1L; } } while (!fertig && i(TL_BYTE)0) fprintf(stream,"%d ",z[i]); else { fprintf(stream,"%d)",-z[i]); klam=1-klam; } } fprintf(stream,")"); break; } fprintf(stream,"\n"); for (i=prang*prang,dar=darmat[q];i>(INT)0;i--,dar++) { if (!(i%prang)) fprintf(stream,"\n"); fprintf(stream,"%3d",*dar); } fprintf(stream,"\n\n\n"); SYM_free(z); } #endif } } return((INT)0); } /* p_writemat */ /*----------------------------------------------------------------------------*/ static INT TL_darmod(hz,lambda,pr,perm,darmat) TL_BYTE *perm,*hz, *lambda, **darmat; INT pr; /*------------------------------------------------------------------------------ berechnet die pr-modular irreduziblen Darstellungsmatrizen fuer zwei Permu- tationen. Dazu muessen die Spalten der ersten (_dm x _dm)-Teilmatrix von hz die zugrunde gelegte Basis kodieren sowie die naechsten beiden (_dm x _dm)- Teilmatrizen von hz die zugehoerigen gewoehnlichen darstellenden Matrizen sein. (_dm ist die gewoehnliche Dimension der Darstellung.) Variablen: hz, Matrix mit der zugrunde gelegten Basis und die zugehoerigen gewoehnlichen Darstellungsmatrizen; lambda, Partition; pr, Primzahl; perm, Permutation. Rueckgabe Matrizen darmat der p-modular irreduziblen Darstellungen. Rueckgabewerte: prang, Dimension der p-modular irreduziblen Darstellungen; (INT)-109, falls nicht genuegend Speicher vorhanden war. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *v; INT prang; if ((v=(TL_BYTE *)TL_calloc((int)_dm,sizeof(TL_BYTE)))==NULL) return no_memory(); modmat(hz,pr); moddreimat(hz,pr,1L); prang=modgauss(hz,v,pr); p_rel(hz,v,pr); if (p_writemat(hz,v,lambda,pr,perm,darmat,prang)) return no_memory(); SYM_free(v); return(prang); } /* TL_darmod */ /******************************************************************************* * * Hauptfunktion zur Berechnung der p-mod. irred. Darstellungen... * *******************************************************************************/ /*----------------------------------------------------------------------------*/ static INT darmod(lambda,dim,bz,pz,gzl,perm,darmat) TL_BYTE *lambda, *bz, *perm, **darmat; INT dim,pz,*gzl; /*------------------------------------------------------------------------------ koordiniert die Berechnung der gew. irred. Darstellungen mit der Berechnung der p-mod. irred. Variablen: lambda, Partition; dim, Dimension der gewoehnlichen Darstellungen; bz, Koeffizientenschema aus alkonmat; pz, Primzahl,fuer welche die p-mod. Darstellungsmatrizen be- rechnet werden; gzl, #(INT)0, d.h. berechne zuerst die gew. irred. Darstellungen, =(INT)0, d.h. gew. irred. Darstellungen existieren schon; perm, Permutation, fuer die die Darstellungen berechnet werden. Rueckgabe Matrizen darmat der p-modular irreduziblen Darstellungen. Rueckgabewerte: prang, Dimension der Darstellung; (INT)-10, falls Pointer auf lambda NULL ist; -11L, falls lambda keinen Eintrag hat; -12L, falls lambda einen Eintrag kleiner 0 hat; -13L, falls lambda keine eigentliche Partition ist; // -15L, falls n MAXN uebersteigt; -18L, falls dim groesser MAXDM ist; -19L, falls Pointer auf bz NULL ist; -21L, falls dim kleiner 1 ist; -22L, falls Pointer auf darmat NULL ist; -23L, falls Pointer auf gzl NULL ist; -24L, falls pz keine Primzahl ist; -25L, falls pz kleiner 1 ist; -26L, falls pz groesser n ist; -27L, falls keine ganzzahlige Loesung bei der Berechnung der gewoehnlichen Darstellungen existiert; (INT)-30, falls Pointer auf perm NULL ist; -31L, falls ein Element von perm kleiner 1 ist; -32L, falls ein Element von perm groesser n ist; -33L, falls Laenge von perm groesser n ist; (INT)-109, falls nicht genuegend Speicher zu Verfuegung steht. Bemerkungen: gzl veraendert sich selbststaendig. Wird darmod mit einem von alkonmat neuberechneten bz aufgerufen, muss gzl einen von 0 verschiedenen Wert haben. Sind die ganzzahligen Loesungen der gewoenlichen Darstellungen berechnet, so ist gzl=(INT)0, und man kann durch nochmaliges Aufrufen von darmod mit diesem die Berechnungen der gew. Darstellungen ueberspringen. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *_hz,*z_eins,*z_zwei,*z_drei; INT prang,n,j,i; TL_BYTE *hz; /* dim x 3dim */ INT il; /* Abfangen moeglicher Uebergabefehler... */ if (lambda==NULL) return(LmbNul); else if (!lambda[0]) return(LmbEmp); for (j=(INT)0,n=(INT)0;lambda[j];j++) if (lambda[j]<(TL_BYTE)0) return(LmbLt_null); else n+=lambda[j]; for (j=1L;lambda[j];j++) if (lambda[j]>lambda[j-1]) return(LmbNRg); if (darmat==NULL) return(DrtNul); else if (gzl==NULL) return(GzlNul); else if (bz==NULL) return(BzNul); else if (dim<=(INT)0) return(DimLe_null); else if (dim>MAXDM) return(DmGtMx); else if (pz<=(INT)0) return(PrmLe_null); else if (pz>n) return(PrmGtN); else if (pz) { for (j=(INT)0;PZ[j]<=n && PZ[j]<=pz;j++); if (pz!=PZ[j-1]) return(NoPrm); } else if (perm==NULL) return(PerNul); for (j=(INT)0;jn) return(PerGtN); /* Auf geht's... */ _dm=dim; _dm_zwei=2L*_dm; _dm_drei=3L*_dm; if ((hz=(TL_BYTE *)TL_calloc((int)_dm_drei*(int)_dm,sizeof(TL_BYTE)))==NULL) return no_memory(); for (il=(INT)_dm*(INT)_dm_drei,z_eins=hz,z_zwei=bz;il>(INT)0;il--) *z_eins++ = *z_zwei++; if (*gzl) { if (lambda[2]) for (i=(INT)0,_hz=hz+1,z_zwei=hz+_dm_drei;i<_dm-1L;i++,_hz += (_dm_drei+1L),z_zwei += (_dm_drei+1L)) { for (j=i+1L,z_eins=_hz,z_drei=z_zwei;j<_dm;j++,z_eins++,z_drei += _dm_drei) *z_drei = *z_eins; for (j=i+1L,z_eins=_hz+_dm,z_drei=z_zwei+_dm;j<_dm;j++,z_eins++,z_drei += _dm_drei) *z_drei = *z_eins; } for (il=(INT)_dm*(INT)_dm_drei,z_eins=bz,z_zwei=hz;il>(INT)0;il--) *z_eins++ = *z_zwei++; /* Berechnung der gewoehnlichen irreduziblen Darstellung mit Hilfe einer modularen Arithmetik. */ *gzl=ganzgaussmod(bz,hz); for (i=(INT)0,z_eins=hz,z_zwei=bz;i<_dm;++i) { for (j=(INT)0;j<_dm;++j) *z_eins++ = *z_zwei++; for (j=_dm;j<_dm_drei;++j) *z_zwei++ = *z_eins++; } } if (!(*gzl)) /* Berechnung der modular irred. Darstellg. */ prang=TL_darmod(hz,lambda,pz,perm,darmat); else prang= *gzl; SYM_free(hz); return(prang); } /* darmod */ INT dimension_mod(part,prim,res) OP part,prim; OP res; /* AK 200294 */ { /* AK 240194 for a single dimension */ TL_BYTE *lambda; TL_BYTE *slambda; INT erg = OK; INT i,dm,omaxdim; INT ak_j; TL_BYTE *bz; INT res_dim; INT n,p; OP w; CTO(INTEGER,"dimension_mod",prim); CTO(PARTITION,"dimension_mod",part); C2R(part,prim,"dimension_mod",res); if (S_I_I(prim) < (INT)0) { fprintf(stderr,"number = %ld\n",S_I_I(prim)); error("dimension_mod: prime number (2. parameter) is negativ"); goto endr_ende; } if (S_I_I(prim) == (INT)0) /* ordinary dimension */ { erg += dimension(part,res); goto s2r; } if (not primep(prim)) { fprintf(stderr,"number = %ld\n",S_I_I(prim)); error("dimension_mod: prime number (2. parameter) is not prime"); goto endr_ende; } if (equal_parts(part,prim)) { erg += m_i_i((INT)0,res); goto s2r; } omaxdim=MAXDM; w = callocobject(); weight(part,w); n = S_I_I(w); p = S_I_I(prim); lambda = (TL_BYTE *)TL_calloc((int)n, sizeof(TL_BYTE)); if (lambda == NULL) { MAXDM=omaxdim; erg += ERROR; goto endr_ende; } for (i=(INT)0;i=(INT)0;i--,ak_j++) lambda[ak_j]=S_PA_II(part,i); dimension(part,w); MAXDM= S_I_I(w); freeall(w); if (MAXDM<(INT)0) { MAXDM=omaxdim; SYM_free(lambda); error("dimension_mod:internal error"); erg =MAXDM; goto endr_ende; } slambda=(TL_BYTE *)TL_calloc((int)(n+1),sizeof(TL_BYTE)); if (slambda == NULL) { MAXDM=omaxdim; SYM_free(lambda); erg += ERROR; goto endr_ende; } bz=(TL_BYTE *)TL_calloc((int)MAXDM*(int)MAXDM,sizeof(TL_BYTE)); if (bz == NULL) { MAXDM=omaxdim; SYM_free(slambda); SYM_free(lambda); erg += ERROR; goto endr_ende; } _assoziiere(lambda,slambda,n); if ((dm=k_alkonmat(slambda,bz,p))<(INT)0) { res_dim=dm; MAXDM=omaxdim; goto dme; } if ((res_dim=k_dimmod(bz,MAXDM,p))<(INT)0) { MAXDM=omaxdim; SYM_free(bz); SYM_free(slambda); SYM_free(lambda); goto endr_ende; } dme: SYM_free(bz); SYM_free(slambda); SYM_free(lambda); m_i_i(res_dim,res); j_zyk((INT)-15,(INT)0,NULL,NULL); /* AK 020294 */ s2r: S2R(part,prim,"dimension_mod",res); ENDR("dimension_mod"); } INT schnitt_mat(part,prim,res) OP part,prim; OP res; /* input: partition part prime number: p output integer matrix modulo p, whose rang = degree of mod irrep */ /* AK 200294 */ /* AK 070498 V2.0 */ { TL_BYTE *lambda; TL_BYTE *slambda; INT i,j,dm,omaxdim; INT ak_j; TL_BYTE *bz; INT res_dim; INT n,p; OP w; INT erg = OK; CE3(part,prim,res,schnitt_mat); if (equal_parts(part,prim)) return m_i_i((INT)0,res); C2R(part,prim,"schnitt_mat",res); omaxdim=MAXDM; w = callocobject(); weight(part,w); n = S_I_I(w); p = S_I_I(prim); lambda = (TL_BYTE *)TL_calloc((int)n, sizeof(TL_BYTE)); if (lambda == NULL) { MAXDM=omaxdim; return no_memory(); } for (i=(INT)0;i=(INT)0;i--,ak_j++) lambda[ak_j]=S_PA_II(part,i); dimension(part,w); MAXDM= S_I_I(w); freeall(w); /* _dimension(lambda,n); */ if (MAXDM<(INT)0) { MAXDM=omaxdim; SYM_free(lambda); error("dimension_mod:internal error"); return(MAXDM); } slambda=(TL_BYTE *)TL_calloc((int)(n+1),sizeof(TL_BYTE)); if (slambda == NULL) { MAXDM=omaxdim; SYM_free(lambda); return no_memory(); } bz=(TL_BYTE *)TL_calloc((int)MAXDM*(int)MAXDM,sizeof(TL_BYTE)); if (bz == NULL) { MAXDM=omaxdim; SYM_free(slambda); SYM_free(lambda); return no_memory(); } _assoziiere(lambda,slambda,n); if ((dm=k_alkonmat(slambda,bz,p))<(INT)0) { res_dim=dm; MAXDM=omaxdim; goto dme; } erg += m_ilih_m(MAXDM,MAXDM,res); for (i=0;i=i+1;++j); if ((j(INT)0 ; i--) *bb++= *aa++; return OK; } /* matcopy */ /*----------------------------------------------------------------------------*/ static INT fak(x) INT x; /*------------------------------------------------------------------------------ berechnet x!. Variable: x, natuerliche Zahl. Rueckgabewert: x!. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { if (x<=1L) return(1L); else return (x*fak(x-1L)); } /*fak*/ /*----------------------------------------------------------------------------*/ static INT nexgitt(y,lambda,mtc) TL_BYTE *lambda, *y; INT *mtc; /*------------------------------------------------------------------------------ berechnet aus Tableau y und Partition lambda das naechste Tableau y. Variablen: y, Tableau; lambda, Partition. Rueckgabe neues Tableau y, falls ein neues existiert (mtc = TRUE). Rueckgabewerte: (INT)0, falls kein Fehler aufgetreten ist; (INT)-109, falls kein Speicherplatz vorhanden war. ------------------------------------------------------------------------------*/ /* TL 0790 */ /* AK 210891 V1.3 */ { TL_BYTE *hilf; static TL_BYTE *h=NULL; static int _nn = 0; INT m,i,j,l,merke; INT durch; if (*mtc == 280194L) { if (h != NULL) SYM_free(h); h = NULL; return OK; } if (_nn != _n) { if (h != NULL) SYM_free(h); h = NULL; } if (h == NULL) { h=(TL_BYTE *)TL_calloc(_n+_n,sizeof(TL_BYTE)); _nn = _n; } if (!h) return no_memory(); hilf=h+_n; memcpy(h,y,_n * sizeof(TL_BYTE)); if (!(*mtc)) for (i=(INT)0,j=(INT)0;lambda[i];++i) { for (l=j;l(l=h[i-1])) { if ((lambda[l]-lambda[m])> (hilf[l]-hilf[m]+(TL_BYTE)1)) { durch=TRUE; merke=l; j=merke+(TL_BYTE)1; while ((hilf[j]==(TL_BYTE)0) || ((lambda[l]-lambda[j])< (hilf[l]-hilf[j]+(TL_BYTE)2))) ++j; h[i-1]=j; --hilf[j]; ++hilf[merke]; for (l=i;l<_n;++l) if (j<_n) { for (j=(TL_BYTE)0;!hilf[j];++j); h[l]=j; --hilf[j]; } } } --i; if (i == (INT)0) *mtc=FALSE; } while (!durch && *mtc); } memcpy(y,h,_n * sizeof(TL_BYTE) ); return (INT)0; } /*nexgitt*/ #endif /* DGTRUE */ symmetrica-2.0/moddg.doc0000600017361200001450000000320410726170276015165 0ustar tabbottcrontabCOMMENT: MODDG ----- NAME: brauer_char SYNOPSIS: INT brauer_char(OP sn,OP prime,OP bc) DESCRIPTION: computes the table (MATRIX object) of brauer characters for the symmetric group of degree sn (INTEGER object) and given prime (INTEGER object) NAME: decp_mat SYNOPSIS: INT decp_mat(OP n,OP p,OP dmat) DESCRIPTION: computes the decomposition matrix to the symmetric group Sn of degree n for the prime p. The result is the MATRIX object dmat. The routine first looks for the file decommix.dat in the actual directory. This file is generated during a previous run of the routine decp_mat. So if the values are already stored in this file you get an imediate answer. Problems arise if the data in this file is corrupted because of errors in previous runs. So to get the programm working correctly you have to remove this file decommix.dat NAME: dimension_mod SYNOPSIS: INT dimension_mod(OP part, OP prim, OP res) DESCRIPTION: computes the dimension of the modular irreducible representation labeled by the PARTITION object part, modulo the INTEGER object prim. NAME: schnitt_mat SYNOPSIS: INT schnitt_mat(OP part, OP n, OP res) DESCRIPTION: this computes the matrix, whose modular rang gives the dimenion of the irreducible modular representation. NAME: moddg SYNOPSIS: INT moddg(prime,llambda,pi,dmat) OP prime; OP llambda; OP pi; OP dmat; DESCRIPTION: computes a modular irreducible representation for the PERMUTATION object pi. The result is a MATRIX object with INTEGER entries. The representation is labbeled by the PARTITION object llambda. The prime is the first parameter, a INTEGER object. symmetrica-2.0/mod_dg_sbd.c0000400017361200001450000004534210726021622015626 0ustar tabbottcrontab/*mod_dg_sbd.c berechnet eine darstellende matrix, nach basisaenderung der bideterminanten modular um die übliche bezeichnung zu bekommen, wird die conjugierte partition genommen */ /* es wird nur die erste standard bi determinant ausgerechnet, die übrigen mit operate perm dabei wird die permutation genommen die von SYT 0 zu SYT i führt */ /* es wird keine ff arithmetik verwendet */ #include "def.h" #include "macro.h" /* standard bideterminanten */ /* polynom indiziert mit integer matrix */ /* */ /* basis fuer specht modul mit sbd */ static OP zero_one_matrices = NULL; static init_zero_one(OP part); static close_zero_one(); static INT operate_perm_spaltenmatrix_new(a,b,c) OP a,b,c; /* vertausch spalten gemaess der permutation */ /* spalte 0 nur wenn permutation auch 0 enthaelt */ /* AK 080802 */ { INT erg = OK; INT i,j; CTO(PERMUTATION,"operate_perm_spaltenmatrix(1)",a); CTTO(INTEGERMATRIX,MATRIX,"operate_perm_spaltenmatrix(2)",b); CE3(a,b,c,operate_perm_spaltenmatrix); SYMCHECK(S_P_LI(a) > S_M_LI(b), "operate_perm_spaltenmatrix: permutation degree too big"); COPY(b,c); for (j=0;j S_I_I(b+i)) return -1; ; return 0; } static INT get_symm_specht_poly(a,i,c) OP a,c; INT i; /* AK 210703 */ /* ite reihe von a ist symmetrized specht polynom write it as object of type POLYNOM */ { INT j,erg = OK; init(HASHTABLE,c); for (j=0;j ms) { INT inkr; inkr=S_PA_LI(b)+S_PA_LI(a)-ms+10; M_I_I(ms,S_PA_L(S_MO_S(mpp_pp_m))); erg += inc_vector_co(S_PA_S(S_MO_S(mpp_pp_m)), inkr); ms = S_PA_LI(S_MO_S(mpp_pp_m)); for (i=ms-1; inkr > 0; inkr--) M_I_I(0,S_PA_I(S_MO_S(mpp_pp_m),i)); } C_I_I(S_PA_L(S_MO_S(mpp_pp_m)), S_PA_LI(b)+S_PA_LI(a) ); for ( ap = S_V_S(S_PA_S(a)), bp = S_V_S(S_PA_S(b)), mp = S_V_S(S_PA_S(S_MO_S(mpp_pp_m))), i=S_PA_LI(a), j=S_PA_LI(b), k=S_PA_LI(S_MO_S(mpp_pp_m)); k>0; k--,mp++ ) { if (j == 0) { C_I_I(mp, S_I_I(ap) ); i--; ap++; } else if (i == 0) { C_I_I(mp, S_I_I(bp) ); j--; bp++; } else if (S_I_I(bp) < S_I_I(ap) ) { C_I_I(mp, S_I_I(bp) ); j--; bp++; } else { C_I_I(mp, S_I_I(ap) ); i--; ap++; } } CLEVER_COPY(f,S_MO_K(mpp_pp_m)); if (S_O_K(c) == HASHTABLE) { HASH_INTEGERVECTOR(S_PA_S(S_MO_S(mpp_pp_m)),j); C_PA_HASH(S_MO_S(mpp_pp_m),j); erg += add_apply_hashtable(mpp_pp_m,c,add_koeff,hf,hash_monompartition); } else /* LIST */ { OP mm; mm = CALLOCOBJECT(); COPY(mpp_pp_m,mm); INSERT_LIST(mm,c,add_koeff,lf); } C_I_I(S_PA_L(S_MO_S(mpp_pp_m)), ms); ENDR("m_merge_partition_partition"); } INT mpp_partition__(a,b,c,f) OP a,b,c; OP f; /* AK 311001 */ { INT erg = OK; CTO(PARTITION,"mpp_partition__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mpp_partition__(2)",b); CTTO(HASHTABLE,POWSYM,"mpp_partition__(3)",c); if (S_O_K(b) == PARTITION) { erg += mpp_partition_partition_(a,b,c,f); goto ende; } else { M_FORALL_MONOMIALS_IN_B(a,b,c,f,mpp_partition_partition_); goto ende; } ende: ENDR("mpp_partition__"); } INT mpp_powsym__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += h_a \times s_b \times f */ { INT erg = OK; CTO(POWSYM,"mpp_powsym__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mpp_powsym__(2)",b); CTTO(HASHTABLE,POWSYM,"mpp_powsym__(3)",c); if (S_O_K(b) == PARTITION) { M_FORALL_MONOMIALS_IN_A(a,b,c,f,mpp_partition_partition_); goto ende; } else { M_FORALL_MONOMIALS_IN_AB(a,b,c,f,mpp_partition_partition_); goto ende; } ende: ENDR("mpp_powsym__"); } INT mpp_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 061101 */ /* c += h_a \times s_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mpp_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mpp_hashtable__(2)",b); CTTO(HASHTABLE,POWSYM,"mpp_hashtable__(3)",c); if (S_O_K(b) == PARTITION) { M_FORALL_MONOMIALS_IN_A(a,b,c,f,mpp_partition_partition_); goto ende; } else { M_FORALL_MONOMIALS_IN_AB(a,b,c,f,mpp_partition_partition_); goto ende; } ende: ENDR("mpp_hashtable__"); } INT mpp_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a \times p_b \times f */ { INT erg = OK; CTO(HASHTABLE,"mpp_hashtable_hashtable_(1)",a); CTO(HASHTABLE,"mpp_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,POWSYM,"mpp_hashtable_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_AB(a,b,c,f,mpp_partition_partition_); ENDR("mpp_hashtable_hashtable_"); } INT mpp_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; OP m; INT i,k; CTO(INTEGER,"mpp_integer_partition_(1)",a); CTO(PARTITION,"mpp_integer_partition_(2)",b); CTTO(POWSYM,HASHTABLE,"mpp_integer_partition_(3)",c); m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); erg += m_il_v(S_PA_LI(b)+1,S_PA_S(S_MO_S(m))); C_O_K(S_PA_S(S_MO_S(m)),INTEGERVECTOR); for (i=0,k=0; kPOWSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"mult_powsym_powsym(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mult_powsym_powsym(2)",b); CTTTO(EMPTY,HASHTABLE,POWSYM,"mult_powsym_powsym(3)",c); if (S_O_K(a) == INTEGER) { if (S_O_K(c) == EMPTY) { if (S_O_K(b) == PARTITION) init_powsym(c); else { t=1; init_hashtable(c); } } erg += mpp_integer__(a,b,c,cons_eins); } else if (S_O_K(a) == PARTITION) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mpp_partition__(a,b,c,cons_eins); } else if (S_O_K(a) == POWSYM) { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mpp_powsym__(a,b,c,cons_eins); } else /* if (S_O_K(a) == HASHTABLE) */ { if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mpp_hashtable__(a,b,c,cons_eins); } if (t==1) t_HASHTABLE_POWSYM(c,c); ENDR("mult_powsym_powsym"); } INT mpp___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"mpp___(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"mpp___(2)",b); CTTO(HASHTABLE,POWSYM,"mpp___(3)",c); if (S_O_K(a) == INTEGER) { erg += mpp_integer__(a,b,c,f); } else if (S_O_K(a) == PARTITION) { erg += mpp_partition__(a,b,c,f); } else if (S_O_K(a) == POWSYM) { erg += mpp_powsym__(a,b,c,f); } else /* if (S_O_K(a) == HASHTABLE) */ { erg += mpp_hashtable__(a,b,c,f); } ENDR("mpp___"); } symmetrica-2.0/mps.c0000400017361200001450000002403710726021623014343 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT mps_integer_partition_(); INT mxx_null__(); INT mps_hashtable__(); static OP mps_ip_d = NULL; static INT mps_ip_l = 50; INT mps_ende() { INT erg = OK; if (mps_ip_d != NULL) { CTO(MONOM,"mps_ende(i1)",mps_ip_d); FREEALL(mps_ip_d); mps_ip_d = NULL; } ENDR("mps_ende"); } INT mult_power_schur(a,b,c) OP a,b,c; /* for compability */ { return mult_powsym_schur(a,b,c); } INT mps_null__(b,c,f) OP b,c,f; /* c = c + p_0 * s_b * f */ { INT erg = OK; CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"mps_null__(1)",b); CTTO(SCHUR,HASHTABLE,"mps_null__(2)",c); erg += mxx_null__(b,c,f); ENDR("mps_null"); } INT mps_integer__(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTO(INTEGER,"mps_integer__(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"mps_integer__(2)",b); CTTO(SCHUR,HASHTABLE,"mps_integer__(3)",c); CTO(ANYTYPE,"mps_integer__(4)",f); SYMCHECK((S_I_I(a) < 0),"mps_integer__:parameter<0"); if (S_I_I(a) == 0) { erg += mps_null__(b,c,f); goto eee; } else if (S_O_K(b) == INTEGER) { OP ff; ff = CALLOCOBJECT(); erg += first_partition(b,ff); erg += mps_integer_partition_(a,ff,c,f); FREEALL(ff); goto eee; } else if (S_O_K(b) == PARTITION) { erg += mps_integer_partition_(a,b,c,f); goto eee; } else /* SCHUR HASHTABLE */ { M_FORALL_MONOMIALS_IN_B(a,b,c,f,mps_integer_partition_); goto eee; } eee: CTTO(SCHUR,HASHTABLE,"mps_integer__(e3)",c); ENDR("mps_integer__"); } INT mps_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"mps_partition__(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"mps_partition__(2)",b); CTTO(HASHTABLE,SCHUR,"mps_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += mps_integer__(cons_null,b,c,f); } else if (S_PA_LI(a) == 1) { erg += mps_integer__(S_PA_I(a,0),b,c,f); } else { INT i; OP d,e; d=CALLOCOBJECT(); e=CALLOCOBJECT(); erg += init_hashtable(e); erg += mps_integer__(S_PA_I(a,0),b,e,f); for (i=1;i mps_ip_l) { M_I_I(mps_ip_l, S_PA_L(S_MO_S(d))); inc_vector_co(S_PA_S(S_MO_S(d)), S_I_I(a)+S_PA_LI(b)-mps_ip_l); mps_ip_l = S_I_I(a)+S_PA_LI(b); } C_I_I( S_PA_L(S_MO_S(d)) , S_I_I(a)+S_PA_LI(b)); for (i=(INT)0; i= 0) && ( maxpart < ms[stacklevel][3])) stacklevel--; else if (ms[stacklevel][1] == ms[stacklevel][0]) /* this means it is grassmanian */ { OP ent=CALLOCOBJECT(); /* eintrag */ b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),ent); b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(ent)); m_il_integervector((INT) ms[stacklevel][1] + 1, S_PA_S(S_MO_S(ent))); if (koeff != 0) M_I_I(koeff,S_MO_K(ent)); else COPY(newtrans_koeff,S_MO_K(ent)); for (i=(short)0,j=(short)0; i<= ms[stacklevel][1]; i++) if ( (ps[stacklevel] [i]) - i - 1 > 0 ) { M_I_I((INT) (ps[stacklevel] [i]) - i - (INT)1, S_PA_I(S_MO_S(ent),j)); j++; } if (j>1) M_I_I((INT)j, S_PA_L(S_MO_S(ent))); /* j eingefuegt AK 170790 */ else if (j==1) /* AK 121093 */ /* noetig da ein vector der laenge 1 ein object ist */ { i = S_PA_II(S_MO_S(ent),(INT)0); m_il_integervector((INT)1,S_PA_S(S_MO_S(ent))); M_I_I(i,S_PA_I(S_MO_S(ent),(INT)0)); } if ( (maxlength == -1) && (maxpart == -1) ) INSERT_SCHURMONOM_(ent,e); else if ( (maxlength == -1) || (MAXPARTI(S_MO_S(ent)) <=maxpart) ) INSERT_SCHURMONOM_(ent,e); else if ( (maxpart == -1) || (S_PA_LI(S_MO_S(ent)) <= maxlength) ) INSERT_SCHURMONOM_(ent,e); else FREEALL(ent); stacklevel--; } else newtrans_nextstep(); /* compute next level from last entry in stack */ if (stacklevel != -1) goto mainaa; ende: ENDR("newtrans_main"); } static INT newtrans_main_hashtable(perm,e,maxpart,maxlength)OP perm,e; INT maxpart; INT maxlength; { INT erg = OK; short i,j; INT koeff=0,k; OP ent; CTO(HASHTABLE,"newtrans_main_hashtable(2)",e); SYMCHECK(maxpart < -1, "newtrans_main_hashtable:wrong value maxpart"); SYMCHECK(maxlength < -1, "newtrans_main_hashtable:wrong value maxlength"); if (newtrans_koeff) { if (S_O_K(newtrans_koeff) == INTEGER) koeff = S_I_I(newtrans_koeff); } else koeff = 1; if (nmh_ent == NULL) { nmh_ent = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),nmh_ent); b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(nmh_ent)); m_il_integervector(SR_LENGTH,S_PA_S(S_MO_S(nmh_ent))); } ent = nmh_ent; newtrans_start(perm); mainaa: if ( (maxpart >= 0) && ( maxpart < ms[stacklevel][3])) stacklevel--; else if (ms[stacklevel][1] == ms[stacklevel][0]) /* this means it is grassmanian */ { INT w=0; M_I_I((INT) ms[stacklevel][1] + 1, S_PA_L(S_MO_S(ent))); FREESELF(S_MO_K(ent)); if (koeff != 0) M_I_I(koeff,S_MO_K(ent)); else COPY(newtrans_koeff,S_MO_K(ent)); for (i=(short)0,j=(short)0; i<= ms[stacklevel][1]; i++) if ( (ps[stacklevel] [i]) - i - 1 > 0 ) { M_I_I((INT) (ps[stacklevel] [i]) - i - (INT)1, S_PA_I(S_MO_S(ent),j)); w += S_PA_II(S_MO_S(ent),j); j++; } if (j>1) M_I_I((INT)j, S_PA_L(S_MO_S(ent))); /* j eingefuegt AK 170790 */ else if (j==1) /* AK 121093 */ /* noetig da ein vector der laenge 1 ein object ist */ { i = S_PA_II(S_MO_S(ent),(INT)0); M_I_I(1,S_PA_L(S_MO_S(ent))); M_I_I(i,S_PA_I(S_MO_S(ent),(INT)0)); } if ( ( (maxpart == -1) || (MAXPARTI(S_MO_S(ent)) <=maxpart) ) && ( (maxlength == -1) || (S_PA_LI(S_MO_S(ent)) <=maxlength) ) ) { INT eq_monomsymfunchash(); HASH_INTEGERVECTOR(S_PA_S(S_MO_S(ent)),k); C_PA_HASH(S_MO_S(ent),k); if ( w < 70 ) add_apply_hashtable(ent,e,add_koeff,eq_monomsymfunchash,hash_monompartition); else add_apply_hashtable(ent,e,add_koeff,eq_monomsymfunc,hash_monompartition); } stacklevel--; } else newtrans_nextstep(); /* compute next level from last entry in stack */ if (stacklevel != -1) goto mainaa; ENDR("newtrans_main_hashtable"); } static INT newtrans_nextstep() /* AK 200891 V1.3 */ { short i,j; short maxplace = ms [stacklevel][0]; /* the position before the last decrease */ char maxentry = ps [stacklevel][ms [stacklevel][0]]; /* this is the entry at the maximal place */ char rightlessvalue,h; /* this is the value on this place */ char minimalleftvalue; /* the minimal value to the left which is allowed to be exchanged with entry on the maxplace */ short startloop; /* first we look whether we could reduce the length of the perm */ char *pss = ps[stacklevel]; char *pssp; short *mss = ms[stacklevel]; for (i=mss[2] -1; i>0; i--) if (pss[i] == (char)i+1) mss[2]--; else break; /* now we have reduced the length of the alphabet */ /* now we compute these rightvalues */ for (i=mss[2] - 1; i> 0 ; i--) if ( pss[i] < maxentry) break; /* i is now the required place */ rightlessvalue = pss[i]; /* now we have to exchange */ pss[i] = maxentry; pss[maxplace] = rightlessvalue; /* you must look whether rightlessvalue == 1 because this means you have to enlarge the permutation */ startloop = maxplace-1; if (rightlessvalue == 1) { mss[2]++; for (i=mss[2]-1; i>0 ; i--) pss[i]=pss[i-1]+1; pss[0]=(char)1; mss[0]++; mss[1]++; rightlessvalue=2; maxplace++; startloop=0; } /* now we have to compute all possible changes to the left */ minimalleftvalue = 0; for (pssp=pss+startloop,i=startloop; i>=0; i--,pssp--) { /* if (( pss[i] < rightlessvalue) && ( pss[i] > minimalleftvalue)) */ if (( *pssp < rightlessvalue) && ( *pssp > minimalleftvalue)) { /* now these things have to be copied and to be exchanged */ if (stacklevel+1 == SR_DEPTH) /* this means the stack is to small */ error("newtrans:stackoverflow");/* AK 121192 */ /* you generate a copy of the upper stack-entry */ if (i>0) { memcpy( ps[stacklevel+1], pss, (int)(mss[2])); memcpy( ms[stacklevel+1], mss,8); } /* you got a copy */ pss[maxplace]=pss[i]; pss[i]=rightlessvalue; minimalleftvalue = pss[maxplace]; /* pss[maxplace] = *pssp; *pssp = rightlessvalue; minimalleftvalue = pss[maxplace]; */ /* new value for maximal schur part *//* AK 211201 */ if ((h=(rightlessvalue - i - 1)) > mss[3]) mss[3] = h; /* we have now to compute the new values for minstack and ms */ for (j=mss[1]+1;j=0;j--) if (pss[j] > pss[j+1]) break; mss[0] = j; /* this is the new value of the msentry */ if (minimalleftvalue == (rightlessvalue - 1)) return(0); else { stacklevel++; pss=ps[stacklevel]; mss=ms[stacklevel]; } } if ((i==0)&&(minimalleftvalue==0)) /* you have to enlarge the permutation */ { mss[2]++; for (i=mss[2]-1; i>0 ; i--) pss[i]=pss[i-1]+1; pss[0]=(char)1; mss[1]++; mss[0]++; rightlessvalue++; maxplace++; pss[maxplace]=pss[i]; pss[i]=rightlessvalue; minimalleftvalue = pss[maxplace]; /* we have now to compute the new values for minstack and ms */ for (j=mss[1]+1;j=0;j--) if (pss[j] > pss[j+1]) break; mss[0] = j; /* this is the new value of the msentry */ return(0); } } stacklevel--; return OK; } #ifdef UNDEF static INT newtrans_printstack() /* AK 200891 V1.3 */ { /* the routine prints the stack */ short i,j; for (i=0;i<=stacklevel;i++) { char *pss = ps[i]; for (j=0;j SR_LENGTH) /* the error condition the perm do not fit into the stack */ { fprintln(stderr,perm); fprintf(stderr, "please enter a permutation of a length <= %d\n",SR_LENGTH); erg += error("newtrans_start:internal error"); goto endr_ende; } ms[0][2]=permlength; ms[0][3]=0; for (i=0; i ms[0][3]) ms[0][3]=(S_P_II(perm,i) - i - 1); } /* now we are looking for the first and the last decrease */ for (i=1; i=0; i--) if (ps [0][i] > ps [0][i+1]) break; /* now i+1 is the index of the last decrease */ ms [0][0] = i; stacklevel=0; ENDR("newtrans_start:internal function"); } INT newtrans_lehmer(perm,c) OP perm,c; /* perm und c may be equal */ { OP d; INT erg = OK; CTTO(VECTOR,INTEGERVECTOR,"newtrans_lehmer(1)",perm); erg += lehmercode(perm,d = CALLOCOBJECT()); erg += newtrans_maxpart_maxlength(d,c,-1,-1); FREEALL(d); ENDR("newtrans_lehmer"); } INT newtrans_eins(c) OP c; /* AK 211201 */ { INT erg = OK; OP m; CTTTO(SCHUR,HASHTABLE,BINTREE,"newtrans_eins(1)",c); m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += first_partition(cons_null,S_MO_S(m)); if (newtrans_koeff != NULL) COPY(newtrans_koeff,S_MO_K(m)); else M_I_I(1,S_MO_K(m)); INSERT_SCHURMONOM_(m,c); ENDR("newtrans_eins"); } INT newtrans(perm,c) OP perm,c; /* AK 221289 V1.1 */ /* AK 130891 V1.3 */ /* AK 180598 V2.0 */ /* perm and c may be equal */ /* is c a HASHTABLE,BINTREE,SCHUR it will be used for inserting */ /* die globale variable newtrans_koeff may be used for faktor */ { INT erg = OK; CTO(PERMUTATION,"newtrans(1)",perm); newtrans_maxpart_maxlength(perm,c,-1,-1); CTTTO(SCHUR,HASHTABLE,BINTREE,"newtrans(res)",c); ENDR("newtrans"); } INT newtrans_maxpart(perm,e,maxpart) OP perm,e; INT maxpart; { return newtrans_maxpart_maxlength(perm,e,maxpart,-1); } INT newtrans_maxpart_maxlength(perm,e,maxpart,maxlength) OP perm,e; INT maxpart;INT maxlength; /* AK 211201 there is a limit on the maximal size of the parts in the result -1 is no limit */ /* AK 120603 there is a limit on the maximal length of the parts in the result -1 is no limit */ { INT erg = OK; CTO(PERMUTATION,"newtrans_maxpart_maxlength(1)",perm); SYMCHECK(maxpart < -1,"newtrans_maxpart_maxlength:wrong value for maxpart"); SYMCHECK(maxlength < -1,"newtrans_maxpart_maxlength:wrong value for maxlength"); if ( (S_O_K(e) == BINTREE) || (S_O_K(e) == SCHUR) || (S_O_K(e) == HASHTABLE) ) { if (einsp_permutation(perm)) { erg += newtrans_eins(e); goto ende; } else { erg += newtrans_main(perm,e,maxpart,maxlength); goto ende; } } else { if (einsp_permutation(perm)) { erg += m_scalar_schur(cons_eins,e); if (newtrans_koeff != NULL) erg += copy(newtrans_koeff,S_S_K(e)); goto ende; } SYMCHECK(perm == e, "newtrans_maxpart:identical parameters"); erg += init(BINTREE,e); erg += newtrans_main(perm,e,maxpart,maxlength); erg += t_BINTREE_SCHUR(e,e); goto ende; } ende: CTTTO(SCHUR,HASHTABLE,BINTREE,"newtrans(res)",e); ENDR("newtrans_maxpart"); } INT newtrans_limit_limitfunction(perm,c,d,f,limit) OP perm,c,d,limit; INT (*f)(); /* AK 221289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(PERMUTATION,"newtrans_limit_limitfunction(1)",perm); erg += init(BINTREE,c); erg += newtrans_main_limit_limitfunction(perm,c,d,f,limit); erg += t_BINTREE_SCHUR(c,c); ENDR("newtrans_limit_limitfunction"); } INT newtrans_limitfunction(perm,c,f,limit) OP perm,c,limit; INT (*f)(); /* AK 221289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(PERMUTATION,"newtrans_limitfunction(1)",perm); erg += init(BINTREE,c); erg += newtrans_main_limitfunction(perm,c,f,limit); erg += t_BINTREE_SCHUR(c,c); ENDR("newtrans_limitfunction"); } static INT newtrans_main_limit_limitfunction(perm,c,d,f,limit) OP d,perm,c,limit; INT (*f)(); /* d is a limit on the length of the partitions */ /* AK 221289 V1.1 */ /* AK 200891 V1.3 */ { short i,j; if (ps == NULL) { ps= (axk * ) SYM_calloc( SR_DEPTH,sizeof(axk)); if (ps== NULL) return no_memory(); } if (ms == NULL) { ms = (axl *) SYM_calloc( SR_DEPTH,sizeof(axl)); if (ms == NULL) return no_memory(); } newtrans_start(perm); mainaa: if (ms[stacklevel][1] == ms[stacklevel][0]) /* this means it is grassmanian */ { OP ent; /* eintrag */ if ((INT)ms[stacklevel][1] + 1 <= S_I_I(d)) { /* partition ist kurz genug */ ent = callocobject(); init(MONOM,ent); init(PARTITION,S_MO_S(ent)); m_il_integervector((INT) ms[stacklevel][1] + 1, S_PA_S(S_MO_S(ent))); M_I_I((INT)1,S_MO_K(ent)); for (i=(short)0,j=(short)0; i<= ms[stacklevel][1]; i++) if ( (ps[stacklevel] [i]) - i - 1 > 0 ) { M_I_I((INT) (ps[stacklevel] [i]) - i - (INT)1, S_PA_I(S_MO_S(ent),j)); j++; } if (j>1) M_I_I((INT)j, S_PA_L(S_MO_S(ent))); else if (j==1) /* AK 121093 */ { i = S_PA_II(S_MO_S(ent),(INT)0); m_il_integervector((INT)1,S_PA_S(S_MO_S(ent))); M_I_I(i,S_PA_I(S_MO_S(ent),(INT)0)); } if ((*f)(S_MO_S(ent),limit) == TRUE) { insert(ent,c, add_koeff,comp_monomvector_monomvector); } else freeall(ent); } stacklevel--; } else newtrans_nextstep(); /* compute next level from last entry in stack */ if (stacklevel != -1) goto mainaa; return(OK); } static INT newtrans_main_limitfunction(perm,c,f,limit) OP perm,c,limit; INT (*f)(); /* limit is a limit on the length of the partitions */ /* AK 221289 V1.1 */ /* AK 200891 V1.3 */ { short i,j; if (ps == NULL) { ps= (axk * ) SYM_calloc( SR_DEPTH,sizeof(axk)); if (ps== NULL) return no_memory(); } if (ms == NULL) { ms = (axl *) SYM_calloc( SR_DEPTH,sizeof(axl)); if (ms == NULL) return no_memory(); } newtrans_start(perm); mainaa: if (ms[stacklevel][1] == ms[stacklevel][0]) /* this means it is grassmanian */ { OP ent; /* eintrag */ ent = callocobject(); init(MONOM,ent); init(PARTITION,S_MO_S(ent)); m_il_integervector((INT) ms[stacklevel][1] + 1, S_PA_S(S_MO_S(ent))); M_I_I((INT)1,S_MO_K(ent)); for (i=(short)0,j=(short)0; i<= ms[stacklevel][1]; i++) if ( (ps[stacklevel] [i]) - i - 1 > 0 ) { M_I_I((INT) (ps[stacklevel] [i]) - i - (INT)1, S_PA_I(S_MO_S(ent),j)); j++; } if (j>1) M_I_I((INT)j, S_PA_L(S_MO_S(ent))); else if (j==1) /* AK 121093 */ { i = S_PA_II(S_MO_S(ent),(INT)0); m_il_integervector(1,S_PA_S(S_MO_S(ent))); M_I_I(i,S_PA_I(S_MO_S(ent),(INT)0)); } if ((*f)(S_MO_S(ent),limit) == TRUE) insert(ent,c, add_koeff,comp_monomschur); else freeall(ent); stacklevel--; } else newtrans_nextstep(); /* compute next level from last entry in stack */ if (stacklevel != -1) goto mainaa; return(OK); } INT mss_partition_partition_maxpart_maxlength(a,b,c,f,m,l) OP a,b,c,f; INT m,l; { INT erg = OK; OP d; CTO(PARTITION,"mss_partition_partition_maxpart_maxlength(1)",a); CTO(PARTITION,"mss_partition_partition_maxpart_maxlength(2)",b); CTTO(HASHTABLE,SCHUR,"mss_partition_partition_maxpart_maxlength(3)",c); SYMCHECK(m < -1,"mss_partition_partition_maxpart_maxlength:maxpart < -1"); SYMCHECK(l < -1,"mss_partition_partition_maxpart_maxlength:maxlength < -1"); d=CALLOCOBJECT(); newtrans_koeff=f; erg += m_part_part_perm(a,b,d); erg += newtrans_maxpart_maxlength(d,c,m,l); newtrans_koeff=NULL; FREEALL(d); CTTO(HASHTABLE,SCHUR,"mss_partition_partition_maxpart_maxlength(3-end)",c); ENDR("mss_partition_partition_maxpart_maxlength"); } INT mss_partition_partition_(a,b,c,f) OP a,b,c,f; { return mss_partition_partition_maxpart_maxlength(a,b,c,f,-1,-1); } INT mss_partition__maxpart_maxlength(a,b,c,f,m,l) OP a,b,c,f; INT m,l; { INT erg = OK; CTO(PARTITION,"mss_partition__maxpart_maxlength(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mss_partition__maxpart_maxlength(2)",b); CTTO(HASHTABLE,SCHUR,"mss_partition__maxpart_maxlength(3)",c); SYMCHECK(m < -1,"mss_partition__maxpart_maxlength:maxpart < -1"); if (S_O_K(b) == PARTITION) { erg += mss_partition_partition_maxpart_maxlength(a,b,c,f,m,l); goto ende; } else if (S_O_K(b) == HASHTABLE) { M3_FORALL_MONOMIALS_IN_B(a,b,c,f,m,l,mss_partition_partition_maxpart_maxlength); goto ende; } else if (S_O_K(b) == SCHUR) { M3_FORALL_MONOMIALS_IN_B(a,b,c,f,m,l,mss_partition_partition_maxpart_maxlength); goto ende; } else{ WTO("mss_partition__maxpart_maxlength(2)",b); goto ende; } ende: ENDR("mss_partition__maxpart_maxlength"); } INT mss_partition__(a,b,c,f) OP a,b,c,f; { return mss_partition__maxpart_maxlength(a,b,c,f,-1,-1); } INT mss_schur__maxpart_maxlength(a,b,c,f,m,l) OP a,b,c,f; INT m,l; { INT erg = OK; CTTO(SCHUR,HASHTABLE,"mss_schur__maxpart_maxlength(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mss_schur__maxpart_maxlength(2)",b); CTTO(HASHTABLE,SCHUR,"mss_schur__maxpart_maxlength(3)",c); SYMCHECK(m < -1,"mss_schur__maxpart:maxpart < -1"); SYMCHECK(l < -1,"mss_schur__maxpart:maxlength < -1"); if (S_O_K(b) == PARTITION) { M3_FORALL_MONOMIALS_IN_A(a,b,c,f,m,l,mss_partition_partition_maxpart_maxlength); goto ende; } else if (S_O_K(b) == HASHTABLE) { M3_FORALL_MONOMIALS_IN_AB(a,b,c,f,m,l,mss_partition_partition_maxpart_maxlength); goto ende; } else if (S_O_K(b) == SCHUR) { M3_FORALL_MONOMIALS_IN_AB(a,b,c,f,m,l,mss_partition_partition_maxpart_maxlength); goto ende; } else{ WTO("mss_schur__maxpart_maxlength(2)",b); goto ende; } ende: ENDR("mss_schur__maxpart_maxlength"); } INT mss_schur__(a,b,c,f) OP a,b,c,f; { return mss_schur__maxpart_maxlength(a,b,c,f,-1,-1); } INT mss_hashtable__(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTO(SCHUR,HASHTABLE,"mss_hashtable__(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mss_hashtable__(2)",b); CTTO(HASHTABLE,SCHUR,"mss_hashtable__(3)",c); erg += mss_schur__(a,b,c,f); ENDR("mss_hashtable__"); } INT mss_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 071201 */ /* from pss_..*/ { INT erg = OK; CTTO(SCHUR,HASHTABLE,"mss_hashtable_hashtable_(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mss_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,SCHUR,"mss_hashtable_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_AB(a,b,c,f,mss_partition_partition_); ENDR("mss_hashtable_hashtable_"); } INT mss_hashtable__maxpart_maxlength(a,b,c,f,m,l) OP a,b,c,f; INT m,l; { INT erg = OK; CTTO(SCHUR,HASHTABLE,"mss_hashtable__maxpart_maxlength(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mss_hashtable__maxpart_maxlength(2)",b); CTTO(HASHTABLE,SCHUR,"mss_hashtable__maxpart_maxlength(3)",c); erg += mss_schur__maxpart_maxlength(a,b,c,f,m,l); ENDR("mss_hashtable__maxpart_maxlength"); } INT mss_hashtable_hashtable_maxpart_maxlength(a,b,c,f,m,l) OP a,b,c,f; INT m,l; /* AK 071201 */ { INT erg = OK; CTTO(SCHUR,HASHTABLE,"mss_hashtable_hashtable_maxpart_maxlength(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mss_hashtable_hashtable_maxpart_maxlength(2)",b); CTTO(HASHTABLE,SCHUR,"mss_hashtable_hashtable_maxpart_maxlength(3)",c); M3_FORALL_MONOMIALS_IN_AB(a,b,c,f,m,l,mss_partition_partition_maxpart_maxlength); ENDR("mss_hashtable_hashtable_maxpart_maxlength"); } INT mss___maxpart_maxlength(a,b,c,f,m,l) OP a,b,c,f; INT m,l; { INT erg = OK; CTTTO(PARTITION,SCHUR,HASHTABLE,"mss___maxpart_maxlength(1)",a); CTTTO(PARTITION,SCHUR,HASHTABLE,"mss___maxpart_maxlength(2)",b); CTTO(HASHTABLE,SCHUR,"mss___maxpart_maxlength(3)",c); SYMCHECK(m < -1,"mss___maxpart_maxlength:maxpart < -1"); SYMCHECK(l < -1,"mss___maxpart_maxlength:maxlength < -1"); if (S_O_K(a) == PARTITION) { erg += mss_partition__maxpart_maxlength(a,b,c,f,m,l); goto ende; } else if (S_O_K(a) == SCHUR) { erg += mss_schur__maxpart_maxlength(a,b,c,f,m,l); goto ende; } else if (S_O_K(a) == HASHTABLE) { erg += mss_hashtable__maxpart_maxlength(a,b,c,f,m,l); goto ende; } else{ WTO("mss___maxpart_maxlength(1)",a); goto ende; } ende: ENDR("mss___maxpart_maxlength"); } INT mss___(a,b,c,f) OP a,b,c,f; { return mss___maxpart_maxlength(a,b,c,f,-1,-1); } INT mult_schur_schur(a,b,c) OP a, b, c; /* 221086 */ /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 050891 V1.3 */ /* AK 170298 V2.0 */ { INT erg = OK; INT t=0; CTTTO(HASHTABLE,PARTITION,SCHUR,"mult_schur_schur(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"mult_schur_schur(2)",b); CTTTO(EMPTY,SCHUR,HASHTABLE,"mult_schur_schur(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mss___maxpart_maxlength(a,b,c,cons_eins,-1,-1); if (t == 1) { erg += t_HASHTABLE_SCHUR(c,c); } CTTO(SCHUR,HASHTABLE,"mult_schur_schur(3-end)",c); ENDR("mult_schur_schur"); } INT mult_schur_schur_maxlength(a,b,c,l) OP a, b, c,l; { return mult_schur_schur_maxpart_maxlength(a,b,c,cons_negeins,l); } INT mult_schur_schur_maxpart_maxlength(a,b,c,m,l) OP a, b, c,m,l; /* 221086 */ /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 050891 V1.3 */ /* AK 170298 V2.0 */ /* if c is HASHTABLE or SCHUR the result will be added */ { INT erg = OK; INT t=0; CTTTO(HASHTABLE,PARTITION,SCHUR,"mult_schur_schur_maxpart_maxlength(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"mult_schur_schur_maxpart_maxlength(2)",b); CTTTO(EMPTY,SCHUR,HASHTABLE,"mult_schur_schur_maxpart_maxlength(3)",c); CTO(INTEGER,"mult_schur_schur_maxpart_maxlength(4)",m); CTO(INTEGER,"mult_schur_schur_maxpart_maxlength(5)",l); SYMCHECK((S_I_I(m) < -1),"mult_schur_schur_maxpart_maxlength:maxpart < -1"); SYMCHECK((S_I_I(l) < -1),"mult_schur_schur_maxpart_maxlength:maxlength < -1"); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } erg += mss___maxpart_maxlength(a,b,c,cons_eins,S_I_I(m),S_I_I(l)); if (t == 1) { erg += t_HASHTABLE_SCHUR(c,c); } CTTO(SCHUR,HASHTABLE,"mult_schur_schur(3-end)",c); ENDR("mult_schur_schur"); } INT m_part_part_perm(a,b,c) OP a,b,c; /* input: two partition objects output: starting permutation for transition for multiplication */ /* AK 050988 */ /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK 060498 V2.0 */ /* a,b,c may be equal */ { OP d; OP z; INT i,j,erg = OK; CTO(PARTITION,"m_part_part_perm(1)",a); CTO(PARTITION,"m_part_part_perm(2)",b); NEW_VECTOR(d, S_PA_LI(a) + S_PA_LI(b) + MAXPARTI(a) + MAXPARTI(b) ); z = S_V_S(d); for (i=(INT)0; i< S_PA_LI(a); i++,z++) M_I_I(S_PA_II(a,i),z); for (j=(INT)0 ; j < MAXPARTI(a); j++,i++,z++) M_I_I((INT)0,z); for (j=(INT)0; j < S_PA_LI(b); j++,i++,z++) M_I_I(S_PA_II(b,j),z); for (j=(INT)0 ; j< MAXPARTI(b); j++,i++,z++) M_I_I((INT)0,z); erg += lehmercode_vector(d,c); erg += freeall(d); ENDR("m_part_part_perm"); } INT outerproduct_schur(a,b,c) OP a, b, c; /* AK 071086 */ /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 050891 V1.3 */ /* a: PARTITION b: PARTITION c: BINTREE,SCHUR,HASHTABLE result will be inserted */ { INT erg = OK; OP d; CTO(PARTITION,"outerproduct_schur(1)",a); CTO(PARTITION,"outerproduct_schur(2)",b); CTTTTO(EMPTY,HASHTABLE,SCHUR,BINTREE,"outerproduct_schur(3)",c); if (S_O_K(c) == EMPTY) init(SCHUR,c); /* AK 250402 */ d=CALLOCOBJECT(); erg += m_part_part_perm(a,b,d); erg += newtrans_maxpart_maxlength(d,c,-1,-1); FREEALL(d); ENDR("outerproduct_schur"); } INT m_perm_schur(a,b) OP a,b; /* AK 270788 */ /* zerlegt das Schubertpolynom X_a in eine Summe von Schurpolynomen */ /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(PERMUTATION,"m_perm_schur",a); erg += newtrans_maxpart_maxlength(a,b,-1,-1); ENDR("m_perm_schur"); } INT outerproduct_schur_limit_limitfunction(a,b,c,k,f,l) OP k, a, b, c,l; INT (*f)(); /* 071086 */ /* a b sind partitionen */ /* AK 071189 */ /* AK 181289 V1.1 */ /* AK 180391 V1.2 */ /* AK 200891 V1.3 */ /* k ist ein limit fuer die groesse */ { OP d; INT erg = OK; CTO(PARTITION,"outerproduct_schur_limit_limitfunction(1)",a); CTO(PARTITION,"outerproduct_schur_limit_limitfunction(2)",b); d=callocobject(); if (not EMPTYP(c)) erg += freeself(c); erg += m_part_part_perm(a,b,d); erg += newtrans_limit_limitfunction(d,c,k,f,l); erg += freeall(d); ENDR("outerproduct_schur_limit_limitfunction"); } INT outerproduct_schur_limitfunction(a,b,c,f,l) OP a, b, c,l; INT (*f)(); /* 071086 */ /* a b sind partitionen */ /* AK 071189 */ /* AK 181289 V1.1 */ /* AK 180391 V1.2 */ /* AK 200891 V1.3 */ { OP d; INT erg = OK; CTO(PARTITION,"outerproduct_schur_limitfunction(1)",a); CTO(PARTITION,"outerproduct_schur_limitfunction(2)",b); d=callocobject(); if (not EMPTYP(c)) erg += freeself(c); erg += m_part_part_perm(a,b,d); erg += newtrans_limitfunction(d,c,f,l); erg += freeall(d); ENDR("outerproduct_schur_limitfunction"); } INT outerproduct_schur_limit(a,b,c,l) OP a, b, c,l; /* 071086 */ /* a b sind partitionen */ /* AK 071189 */ /* AK 181289 V1.1 */ /* AK 180391 V1.2 */ /* AK 200891 V1.3 */ { OP d=callocobject(); if (not EMPTYP(c)) freeself(c); m_part_part_perm(a,b,d); newtrans_limitfunction(d,c,neqparts_partition,l); freeall(d); return(OK); } #ifdef SKEWPARTTRUE INT m_skewpart_skewperm(a,b) OP a,b; /* AK 221289 V1.1 */ /* AK 010791 V1.2 */ /* es wird die permutation fuer die berechnung der skew schur funktion berechnet */ /* vgl. m_part_part_perm() */ /* AK 130891 V1.3 */ /* a and b may be equal */ { OP d ; /* d wird der code vector */ INT k,i,j,h; INT lg = S_SPA_GLI(a); INT lk = S_SPA_KLI(a); /* die laengen der beiden partitionen */ INT erg = OK; CTO(SKEWPARTITION,"m_skewpart_skewperm(1)",a); d = CALLOCOBJECT(); for (i=0,j=0;i it will become schur object c is schur object -> result will inserted into c c is hashtable object -> result will be inserted c is an other object, it will become schur object the result is the expansion of the skew schur function a/b in the basis of schur functions the global object part_part_skewschur_koeff may be used as a faktor to be inserted */ { OP d,e; INT i,j,t=0; INT erg = OK; CTO(PARTITION,"part_part_skewschur(1)",a); CTO(PARTITION,"part_part_skewschur(2)",b); if ( (S_O_K(c) != HASHTABLE) && (S_O_K(c) != SCHUR) ) CE3(a,b,c,part_part_skewschur); CTTTO(EMPTY,SCHUR,HASHTABLE,"part_part_skewschur(3)",c); i = S_PA_LI(a)-1; j = S_PA_LI(b)-1; if (j > i) { /* result is 0 */ if (S_O_K(c)==EMPTY) init_schur(c); goto ende; } for(;j>=0;j--,i--) if (S_PA_II(a,i) < S_PA_II(b,j)) { /* result is 0 */ if (S_O_K(c)==EMPTY) init_schur(c); goto ende; } /* zuerst test ob b kleiner a */ /* falls nicht ist das ergebnis ein leeres schur object */ if (S_O_K(c) == EMPTY) { erg += init_hashtable(c); t = 1; } d = CALLOCOBJECT(); e = CALLOCOBJECT(); erg += b_gk_spa(CALLOCOBJECT(),CALLOCOBJECT(),d); erg += copy_partition(a,S_SPA_G(d)); erg += copy_partition(b,S_SPA_K(d)); erg += m_skewpart_skewperm(d,e); FREEALL(d); newtrans_koeff = part_part_skewschur_koeff; erg += newtrans_maxpart_maxlength(e,c,-1,-1); newtrans_koeff = NULL; FREEALL(e); if (t==1) t_HASHTABLE_SCHUR(c,c); ende: CTTO(SCHUR,HASHTABLE,"part_part_skewschur(res)",c); ENDR("part_part_skewschur"); } #endif /* SKEWPARTTRUE */ INT mult_apply_schur_schur(a,b) OP a,b; /* platzhalter */ /* b = b*a */ { INT erg = OK; OP c; CTTO(HASHTABLE,SCHUR,"mult_apply_schur_schur",a); CTTO(HASHTABLE,SCHUR,"mult_apply_schur_schur",b); c = CALLOCOBJECT(); if (S_O_K(b) == HASHTABLE) erg += init_hashtable(c); erg += mult_schur_schur(a,b,c); SWAP(c,b); FREEALL(c); ENDR("mult_apply_schur_schur"); } #endif /* SCHURTRUE */ symmetrica-2.0/muir.c0000400017361200001450000004323010726021626014517 0ustar tabbottcrontab #include "def.h" #include "macro.h" static INT l_schur_monomial_mult_new(); INT cc_muir_mms_partition_partition_(a,b,c,f) OP a,b,c,f; /* AK 071201 called from mms_partition_partition_ */ { INT erg = OK; OP wa,wb; CTO(PARTITION,"cc_muir_mms_partition_partition_(1)",a); CTO(PARTITION,"cc_muir_mms_partition_partition_(2)",b); CTO(HASHTABLE,"cc_muir_mms_partition_partition_(3)",c); wa = CALLOCOBJECT(); weight_partition(a,wa); wb = CALLOCOBJECT(); weight_partition(b,wb); add_apply(wa,wb); l_schur_monomial_mult_new(wb,b,a,c,f); FREEALL2(wa,wb); ENDR("cc_muir_mms_partition_partition_"); } typedef INT PLETCHAR; struct cel{ struct cel *prec; struct cel *suiv; PLETCHAR *tab; long coef; }; struct lst{ struct cel *deb; }; static INT muir_lim_new(limit,cond,s,psi,plst) PLETCHAR limit,cond,*s,*psi; struct lst *plst; /* CC */ { PLETCHAR lg_s, avv=0, lg_psi, sig, sigav=0, j, bl=0, max,mv; PLETCHAR *uu, *av, *def, *pos, *tb, *bav, *bdef, *bpos, *btb; register PLETCHAR *buu,*bs; register PLETCHAR k,tp,tmp; struct cel *pcrt,*q=NULL,*ins; long lp; bs=s+1; while(*bs) bs++; tmp=bs-(s+1); lg_s=tmp; tp=0; bs=psi+1; while(*bs) tp+= *bs++; lg_psi=bs-(psi+1); tmp=lg_s+tp; s=(PLETCHAR *) SYM_realloc(s,(tmp+20)*sizeof(PLETCHAR)); buu=s+lg_s+2; for(k=0;k<= tp;k++,buu++) *buu=0; uu=(PLETCHAR *)SYM_calloc(tmp+2,sizeof(PLETCHAR)); av=(PLETCHAR *)SYM_calloc(tmp+2,sizeof(PLETCHAR)); def=(PLETCHAR *)SYM_calloc(tmp+2,sizeof(PLETCHAR)); tb=(PLETCHAR *)SYM_MALLOC((lg_psi+2)*sizeof(PLETCHAR)); pos=(PLETCHAR *)SYM_MALLOC((lg_psi+2)*sizeof(PLETCHAR)); pcrt=(struct cel *)SYM_MALLOC(sizeof(struct cel)); pcrt->prec=pcrt->suiv=NULL; plst->deb=pcrt; mv=0; pcrt->coef=1L; if(cond==0 || (cond==1 && limit >= *(s+1) + *(psi+1))) { pcrt->coef=1L; bav=av+1; bdef=def+1; buu=s+1; while(*buu) { *bav=*bdef=*buu; buu++;bav++,bdef++; } bpos=pos+1; btb=tb+1; bdef=def+1; bav= av+1; buu= psi+1; for(k=1; k<=lg_psi; bpos++,btb++,bdef++,bav++,k++,buu++) { *bpos=k; *btb= *buu; *bdef += *buu; *bav += *buu; } *bpos=0; *btb=0; avv=lg_psi-1; *(bav-1)=0; if(lg_psi>lg_s) { buu=(PLETCHAR *)SYM_MALLOC((lg_psi+1)*sizeof(PLETCHAR)); *bdef=0; } else { buu=(PLETCHAR *)SYM_MALLOC((lg_s+1)*sizeof(PLETCHAR)); *(def+lg_s+1)=0; } bs=def+1; pcrt->tab=buu; while(*bs) *buu++ = *bs++; *buu=0; sigav=1; j=lg_psi; bpos=pos+lg_psi; btb=tb+lg_psi; } else { if(lg_psi> lg_s) { buu=(PLETCHAR *)SYM_MALLOC((lg_psi+1)*sizeof(PLETCHAR)); pcrt->tab=buu; bs=s+1;bdef=psi+1; for(k=0;ktab=buu; bs=s+1;bdef=psi+1; for(k=0;k=1;k--,tp--,bs--) { if(*bs==tp){bl=1;break;} if(*bs>tp){bl=2;break;} } if(bl==1) continue; if(bl==0 && *bdef+ *btb -(j-1) > limit) continue; if(btb-tb==lg_psi) { avv=j-1; bs=av+1; sigav=sig; buu= uu+1; for(k=1;k<=avv;k++,bs++,buu++) *bs= *buu; *bs=0; } *bpos++ =j; *bdef += *btb++; *buu = *bdef; bs=buu; for(tp=j;tp>k+1;tp--,bs--) { mv= *bs; *bs= *(bs-1)+1; *(bs-1)=mv-1; sig= -sig; } if(btb-tb==lg_psi+1) break; } ins=(struct cel *)SYM_MALLOC(sizeof(struct cel)); ins->prec=pcrt;pcrt->suiv=ins; ins->suiv=NULL; ins->coef=sig; if (j>lg_s) bs=(PLETCHAR *)SYM_MALLOC((j+1)*sizeof(PLETCHAR)); else bs=(PLETCHAR *)SYM_MALLOC((lg_s+1)*sizeof(PLETCHAR)); ins->tab=bs; buu=uu+1; while(*buu) *bs++ = *buu++; *bs=0; pcrt=ins; *bpos-- =0; *btb-- =0; mv=0;bl=1; j=lg_psi; } aa: for(;j>=1;j--,btb--,bpos--) { bdef=def+ *bpos; bs=s+ *bpos; while(1) { tp= *bpos+1- *btb; if( ( (tp>lg_s) && ( (j>1&&tp> *(bpos-1)) || (j==1)) ) || ( (cond==0) && (*bpos+1+lg_psi-j>limit) ) ) { /*Shift is finished*/ tmp=*btb; max= -1; buu=btb+1; for(k=j+1;k<=lg_psi;k++,buu++) if(*buumax) { max= *buu;tp=k; } if(max!= -1) { /*Can put *buu at the position *bpos*/ *btb=max;tb[tp]=tmp; if(j>1) *bpos= *(bpos-1)+1; else *bpos= 1; bdef= def+ *bpos; bs=s+ *bpos; *bdef= *btb+ *bs; tp= *bpos>*btb+1? *bpos- *btb:1; tmp= *bdef-1; buu=bdef-1; for(k= *bpos-1;k>=tp;k--,tmp--,buu--) if(*buu==tmp)break; if(k==tp-1) { /*Succeed*/ j++;bpos++;btb++; bs++;bdef++; goto bb; } }/*End of if(max!= -1)*/ else break; }/*End of if(tp>lg_s&&(j>1&&tp> *(bpos-1)||j==1))*/ else { /*Shift*/ (*bpos)++; bdef++;bs++; *bdef= *btb+ *bs; *(bdef-1) -= *btb; tp= *bpos>*btb+1? *bpos- *btb:1; tmp= *bdef-1; buu=bdef-1; for(k= *bpos-1;k>=tp;k--,tmp--,buu--) if(*buu==tmp)break; if(k==tp-1) { /*Succeed*/ j++;bpos++;btb++; bs++;bdef++; goto bb; } }/*End of else if(tp>lg_s&&(j>1&&tp> *(bpos-1)||j==1))*/ }/*End of while(1)*/ }/*End of for(;j>=1;...)*/ goto cc; bb: for(;j<=lg_psi;j++,bpos++,btb++,bs++,bdef++) { bl=1; if(j!=lg_psi) { max= -1; buu=btb; for(k=j;k<=lg_psi;k++,buu++) if(max< *buu) { max= *buu;tp=k; } /*max must be different from -1*/ tmp= *btb; *btb=max; tb[tp]=tmp; } /*not else because nothing changes if(j==lg_psi)*/ *bpos= *(bpos-1)+1; /*j must be >1*/ *bdef= *btb+ *bs; tp= *bpos>*btb+1? *bpos- *btb:1; tmp= *bdef-1; buu=bdef-1; for(k= *bpos-1;k>=tp;k--,tmp--,buu--) if(*buu==tmp)break; if(k!=tp-1) goto aa; }/* End of for(;j<=lg_psi;...*/ bpos--;btb--;j--; if(cond==0) { if(bl==1) { /*bs is free*/ bdef=def+1; buu=uu+1; for(k=1;k<= *bpos;k++,bdef++,buu++) *buu= *bdef; sig=1; bs=uu+2; for(k=2;k<= *(bpos-1);k++,bs++) { buu=bs; for(tp=k;tp>1;tp--,buu--) { if(*buu> *(buu-1)) { tmp= *buu; *buu= *(buu-1)+1; *(buu-1)=tmp-1; sig= -sig; } else break; } } sigav=sig; bav=av+1;buu=uu+1;avv= *bpos-1; for(k=1;k<=avv;k++,buu++,bav++) *bav= *buu; } else { sig=sigav; buu=uu+1;bav=av+1; for(k=1;k<=avv;k++,buu++,bav++) *buu= *bav; bs=s+avv+1; for(;k<= *bpos-1;k++,buu++,bs++,bav++) *bav= *buu= *bs; *buu= *btb+ *bs; avv= *bpos-1; } /*buu is equal to uu + *bpos*/ for(k= *bpos;k>1;k--,buu--) if(*buu> *(buu-1)) { tmp= *buu; *buu= *(buu-1)+1; *(buu-1)=tmp-1; sig= -sig; } else break; } else { if(bl==1) { /*bs is free*/ bdef=def+1; if(*bdef>limit){ goto aa;} buu=uu+1; for(k=1;k<= *bpos;k++,bdef++,buu++) *buu= *bdef; sig=1; bs=uu+2; for(k=2;k<= *bpos-1;k++,bs++) { buu=bs; for(tp=k;tp>1;tp--,buu--) { if(*buu> *(buu-1)) { tmp= *buu; *buu= *(buu-1)+1; *(buu-1)=tmp-1; sig= -sig; } else break; } if(tp==1 && tmp-1 >limit){ goto aa;} } sigav=sig; bav=av+1;buu=uu+1;avv= *bpos-1; for(k=1;k<=avv;k++,buu++,bav++) *bav= *buu; for(k= *bpos;k>1;k--,buu--) if(*buu> *(buu-1)) { tmp= *buu; *buu= *(buu-1)+1; *(buu-1)=tmp-1; sig= -sig; } else break; if(tp==1 && tmp-1 >limit) goto aa; } else { if(*(def+1)>limit){bl=1;goto aa;} sig=sigav; buu=uu+1;bav=av+1; for(k=1;k<=avv;k++,buu++,bav++) *buu= *bav; bs=s+avv+1; for(;k<= *bpos-1;k++,buu++,bs++,bav++) *bav= *buu= *bs; *buu= *btb+ *bs; avv= *bpos-1; /*buu is equal to uu + *bpos*/ for(k= *bpos;k>1;k--,buu--) if(*buu> *(buu-1)) { tmp= *buu; *buu= *(buu-1)+1; *(buu-1)=tmp-1; sig= -sig; } else break; } } bs=s+ *bpos+1; buu=uu+ *bpos+1; while(*bs) *buu++ = *bs++; *buu=0; tmp=buu-uu; if(bl==1) { buu=uu+1; bs=pcrt->tab; while(*buu) { if(*buu< *bs) { q=pcrt;pcrt=pcrt->suiv; if(pcrt==NULL) { pcrt=(struct cel *)SYM_MALLOC(sizeof(struct cel)); pcrt->prec=q; pcrt->suiv=NULL; q->suiv=pcrt; bs=(PLETCHAR *)SYM_MALLOC(tmp*sizeof(PLETCHAR)); pcrt->tab=bs; buu=uu+1; while(*buu) *bs++ = *buu++; *bs=0; pcrt->coef= sig; bl=0;goto aa; }/*End of if(pcrt==NULL)*/ else { mv=1; /*to right*/ break; } }/*End of if(*buu < *bs*/ else if (*buu > *bs) { q=pcrt; pcrt=pcrt->prec; mv= -1; /*to left*/ break; } bs++; buu++; }/*End of while(*buu)*/ if(*buu==0) { lp=pcrt->coef+sig; if(lp==0L) { pcrt->prec->suiv=pcrt->suiv; /*Always a preceeding term*/ if(pcrt->suiv !=NULL) pcrt->suiv->prec=pcrt->prec; q=pcrt->prec; SYM_free((char *)pcrt->tab); SYM_free((char *)pcrt); pcrt=q; } else pcrt->coef=lp; bl=0;goto aa; } }/*End of if(bl==1)*/ else { mv=1; q=pcrt; pcrt=pcrt->suiv; } if(mv==1) { while(pcrt!=NULL) { buu=uu+1; bs=pcrt->tab; while(*bs) /*buu==0 => *bs==0*/ { if(*buu< *bs) { q=pcrt; pcrt=pcrt->suiv; break; } else if(*buu>*bs) { ins=(struct cel *)SYM_MALLOC(sizeof(struct cel)); ins->prec=q; ins->suiv=pcrt; q->suiv=ins; pcrt->prec=ins; bs=(PLETCHAR *)SYM_MALLOC(tmp*sizeof(PLETCHAR));ins->tab=bs; buu=uu+1; while(*buu) *bs++= *buu++; *bs=0; ins->coef=sig; pcrt=ins;mv=0;bl=0;goto aa; } buu++; bs++; }/*End of while(*buu)*/ if(*bs==0) { lp=pcrt->coef+sig; if(lp==0L) { q->suiv=pcrt->suiv; if(pcrt->suiv != NULL) pcrt->suiv->prec=q; SYM_free((char *)pcrt->tab); SYM_free((char *)pcrt); pcrt=q; } else pcrt->coef=lp; mv=0;bl=0;goto aa; } }/*End of while pcrt!=NULL*/ if(pcrt==NULL) { pcrt=(struct cel *)SYM_MALLOC(sizeof(struct cel)); pcrt->prec=q; pcrt->suiv=NULL; q->suiv=pcrt; bs=(PLETCHAR *)SYM_MALLOC(tmp*sizeof(PLETCHAR)); pcrt->tab=bs; buu=uu+1; while(*buu) *bs++ = *buu++; *bs=0; pcrt->coef= sig; mv=0;bl=0;goto aa; } }/*End of if(mv==1)*/ else if(mv== -1) { while(pcrt!=NULL) { buu=uu+1; bs=pcrt->tab; while(*buu) { if(*buu> *bs) { q=pcrt;pcrt=pcrt->prec;break; } else if(*buu<*bs) { ins=(struct cel *)SYM_MALLOC(sizeof(struct cel)); ins->prec=pcrt; ins->suiv=q; q->prec=ins; pcrt->suiv=ins; bs=(PLETCHAR *)SYM_MALLOC(tmp*sizeof(PLETCHAR)); ins->tab=bs; buu=uu+1; while(*buu) *bs++= *buu++; *bs=0; ins->coef=sig; pcrt=ins;mv=0;bl=0;goto aa; } buu++; bs++; }/*End of while(*buu)*/ if(*buu==0) { lp=pcrt->coef+sig; if(lp==0L) { pcrt->prec->suiv=q; q->prec=pcrt->prec; SYM_free((char *)pcrt->tab); SYM_free((char *)pcrt); pcrt=q->prec; } else pcrt->coef=lp; mv=0; bl=0;goto aa; } }/*End of while pcrt!=NULL*/ /*Never pcrt==NULL => pg never in this part*/ }/*End of if(mv==-1)*/ cc: if(cond==1 && plst->deb->suiv!=NULL && limit < *(s+1)+ *(psi+1)) plst->deb=plst->deb->suiv; SYM_free((char *)pos); SYM_free((char *)av); SYM_free((char *)s); SYM_free((char *)def); SYM_free((char *)tb); SYM_free((char *)uu); return OK; } static INT t_lst_SYM_new(lst,res,f)struct cel * lst; OP res; OP f; { INT erg = OK; register PLETCHAR *baf,i; PLETCHAR lg; struct cel *q; OP pol,pa,v,cf; COP("t_lst_SYM_new(2)",res); if(lst==NULL) { return OK;} while(lst!=NULL) { pol=CALLOCOBJECT(); v=CALLOCOBJECT(); pa=CALLOCOBJECT(); cf=CALLOCOBJECT(); baf=lst->tab; while(*baf) baf++; lg=baf-lst->tab; m_il_v((INT)lg,v); baf--; for(i=0L;icoef,cf); /* coeff must be int */ MULT_APPLY(f,cf); b_sk_mo(pa,cf,pol); insert_scalar_hashtable(pol,res,add_koeff,eq_monomsymfunc,hash_monompartition); /* AK 031001 wrong order otherwise */ q=lst; lst=lst->suiv; SYM_free(q->tab); SYM_free((char *)q); } ENDR("plet.c:internal"); } static INT l_schur_monomial_mult_new(lg,a,b,c,f) OP lg,a,b,c,f; { INT i; register PLETCHAR *bs; PLETCHAR *s,*psi; struct lst lst; lst.deb=NULL; bs=(PLETCHAR *)SYM_MALLOC((S_PA_LI(a)+2)*sizeof(PLETCHAR)); s=bs++; for(i=S_PA_LI(a)-1L;i>=0L;i--,bs++) *bs=(PLETCHAR)S_PA_II(a,i); *bs=(PLETCHAR)0; bs=(PLETCHAR *)SYM_MALLOC((S_PA_LI(b)+2)*sizeof(PLETCHAR)); psi=bs++; for(i=S_PA_LI(b)-1L;i>=0L;i--,bs++) *bs=(PLETCHAR)S_PA_II(b,i); *bs=(PLETCHAR)0; muir_lim_new((PLETCHAR)S_I_I(lg),(PLETCHAR)0,s,psi,&lst); t_lst_SYM_new(lst.deb,c,f); SYM_free(psi); return OK; } symmetrica-2.0/na.c0000400017361200001450000007537310726021626014156 0ustar tabbottcrontab#include "def.h" #include "macro.h" #ifdef DGTRUE /* Darstellungen */ static INT homtest(); static INT tf_idmat(); static INT imult(); /* static INT nw_nexperm(); static INT test_nw_nexperm(); static INT nw_nexpart(); static INT test_nw_nexpart(); */ /*** maximale Laenge von Permutationen ***/ #define TFNMAX 200 #define FIRST_ST 0 #define NEXT_ST 1 /* Zugriff auf das Element (i,j) in der oberen D-Matrix m der Dimension fa; Diagonale ist 1! */ #define ODM(m,fa,i,j) m[((long)fa-1L)*(long)(i)-((long)(i)\ *((long)(i)+1L))/2L+(j)-1L] /* Zugriff auf das Element (i,j) in der quadratischen Matrix m der Dimension fa */ #define MAT(v,fa,i,j) v[(long)fa*(long)(i)+(long)(j)] /* imult.c */ static INT imult(a,b,d) OP a,b,d; /* TF 210989 */ /* multipliziert zwei INTEGER matrizen */ /* AK 191289 V1.1 */ /* AK 210891 V1.3 */ { OP c; /* sonderfaelle bei gleichen variablennamen */ if (a == d) { c =callocobject(); copy(a,c); imult(c,b,d); freeall(c); return(OK); } if (b == d) { c =callocobject(); copy(b,c); imult(a,c,d); freeall(c); return(OK); } /*freigabe des speichers belegt durch d */ freeself(d); /*falls beides leere objecte => d auch leer */ if (emptyp(a) || emptyp(b)) return(OK); if (nullp(a)) return(m_i_i(0L,d)); if (nullp(b)) return(m_i_i(0L,d)); if (einsp(b)) return(copy(a,d)); if (einsp(a)) return(copy(b,d)); if (S_O_K(a)==MATRIX && S_O_K(b)==MATRIX) return(mult_imatrix_imatrix(a,b,d)); else { printobjectkind(a); printobjectkind(b); error("kann ich nicht multiplizieren"); return(ERROR); } } /**************************************/ /*** Spezialfall: zwei INT-Matrizen ***/ /**************************************/ INT mult_imatrix_imatrix(a,b,c) OP a,b,c; /* TF 210989 */ { #ifdef MATRIXTRUE INT i,j,k,ha,lb,la; OP ll, height,pi,pj; INT zi,aiki,bkji; /* zwischen ergebnis bei matrix-multiplikation */ if (S_M_LI(a) != S_M_HI(b)) { error("matrizen koennen nicht multipliziert werden"); return(ERROR); }; ll=callocobject(); height=callocobject(); COPY_INTEGER(S_M_H(a),height); ha=S_M_HI(a); COPY_INTEGER(S_M_L(b),ll); lb=S_M_LI(b); la=S_M_LI(a); b_lh_m(ll,height,c); for (i=0L;i1L)); } if (sig) m_i_i(-sgn,sig); if (sgn<0L) { sgn=1L; s=0L; for (i=1L; i ai) d++; s+=d; if (s % 2L && d < i) { for (d=0L; S_P_II(a,d) >= ai; d++); for (j=d+1L; j S_P_II(a,d)) d=j; break; } else if ((s%2L)==0L && d>0L) { for (d=0L; S_P_II(a,d)<=ai; d++); for (j=d+1L; jai && S_P_II(a,j) 0 nach Nijenhuis/Wilf * T. Fuerbringer * ***************************************************************************/ /*************************************************************************** * * Prozedur: * INT nw_nexpart(mode,n,part) * * Beschreibung: * mode=0: * "nexpart" berechnet erste Partition (n). * Rueckgabe erfolgt in part. * * Statische Variable: * r[0]: Anzahl verschiedener Ziffern in r[1...]; * r[i] (i>0): Eine Ziffer der Partition; * m[i] (i>0): Vielfachheit von r[i]; * mode<>0: * Die nach Hijenhuis/Wilf auf part folgende Partition wird * berechnet. * * Rueckgabe: * 0: part ist letzte Partition, sonst !=0. * ***************************************************************************/ static INT nw_nexpart(mode,n,part) INT mode; OP n,part; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { INT i,j,d,s,sum,f; static INT ni,r[50],m[50]; d=r[0]; if (mode!=0L) { sum=(r[d]==1L)? m[d--]+1L : 1L; f=r[d]-1L; if (m[d]!=1L) m[d++]--; r[d]=f; m[d]=(sum/f)+1L; s= sum % f; if (s>0L) { r[++d]=s; m[d]=1L; } r[0]=d; f=0L; for (i=1L; i<=d; f+=m[i++]); m_il_v(f,S_PA_S(part)); f=0L; for (i=1L; i<=d; i++) for (j=m[i]; j>0L; j--) m_i_i(r[i],S_PA_I(part,f++)); return((INT)(m[d]!=ni)); } else { r[0]=m[1]=1L; ni=r[1]=s_i_i(n); b_ks_pa(VECTOR,callocobject(),part); m_il_v(1L,s_pa_s(part)); M_I_I(ni,S_PA_I(part,0L)); return((INT)(ni!=1L)); } } #ifdef TEST static INT test_nw_nexpart() /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { OP part = callocobject(); OP n = callocobject(); INT e; scan(INTEGER,n); e=nw_nexpart(0L,n,part); println(part); while(e!=0L) { e=nw_nexpart(1L,n,part); println(part); } } #endif #endif /************************ 1.TEIL ************************************* * bestehend aus PERMFIND.C, NEXTST.C, NATDG.C *********************************************************************/ /*** Zeiger auf Bereich fuer Standardtableaux ***/ static int *stptr = (int *)0L; /*** momentan gueltige Dimension ***/ static int stdim = 0; /*** Zugriff auf x-tes Tableau ***/ #define STAB(x) (stptr+x*(n+1)) /******************************************************************** * * PERMFIND.C * * Prozeduren zur Berechnung von Vertikal- und Horizontalpermutationen * und deren Vorzeichen. * ********************************************************************/ /******************************************************************** * * Prozedur: * void ltmult(pi,t1,t2) * * Beschreibung: * ltmult multipliziert die Permutation pi von links mit * der Transposition (t1 t2). * ********************************************************************/ static void ltmult( pi , t1 , t2 ) int *pi; int t1; int t2; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { register int flag = 0; /* flag protokolliert die Anzahl getauschter Elemente */ while (flag<2) { if (*++pi == t1) { *pi=t2; flag++; } else if (*pi == t2) { *pi=t1; flag++; } } } /******************************************************************** * * Prozedur: * int sign(pi) * * Beschreibung: * sign berechnet das Vorzeichen der Permutation pi. * * Rueckgabe: * Vorzeichen * ********************************************************************/ static int sign(pi ) int *pi; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { int k,j,i,s,anz; int d[TFNMAX]; /*** d protokolliert, auf welche Elemente in pi schon zugegriffen wurde ***/ for (i=1; i<=pi[0]; d[i++]=0); /*** Vorzeichen berechnen ***/ s=1; /* sign := 1 */ k=1; /* Elementindex, ab dem gesucht wird */ anz=0; /* Anzahl erledigter Elemente */ while (anz < pi[0]) { i=k++; while (d[i]) i++; /* suche unberuehrtes Element */ j=i; d[i]=1; anz++; while (pi[i]!=j) /* durchlaufe zu i gehoerenden Zykel */ { s= -s; /* Vorzeichen dreht sich staendig um */ i=pi[i]; d[i]=1; /* alle Zykelelemente als erledigt kennzeichnen */ anz++; if (k==i) k++; /* vor i muss nicht mehr gesucht werden */ } } return(s); } /******************************************************************** * * Prozedur: * int find_pq(alpha,t1,t2,q,ps) * * Beschreibung: * Seien t1 und t2 Tableaux zum Rahmen [alpha]. * find_pq sucht q aus V(t1), ps aus H(q*t1) mit t2= ps*q t1. * * Rueckgabe: * 0 gefunden, -1 sonst. * ********************************************************************/ static int find_pq(alpha,t1,t2,q,ps) int *alpha,*t1,*t2; int *q; int *ps; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { register int ss,zs,ks,n,i; int tloc[TFNMAX]; int d[TFNMAX],z,k,ks_pos,k_pos; int zpos[TFNMAX],spos[TFNMAX]; n=tloc[0]=ps[0]=q[0]=t1[0]; /*** erstmal vorbesetzen ***/ for (i=1; i<=n; i++) { d[i]=0; /* Zugriffsprotokoll auf Elemente in t2 */ q[i]=i; /* q := id */ tloc[i]=t1[i]; /* tloc:=t1, da in t1 selbst keine Elemente getauscht werden duerfen */ } /*** bestimme Zeilen- und Spaltenpositionen der Elemente im Tableau tloc ***/ i=1; /* Laufindex durchs Tableau tloc */ for (zs=1; zs<=alpha[0]; zs++) /* Zeilen */ for (ss=1; ss<=alpha[zs]; ss++) /* Spalten */ { ks=tloc[i++]; zpos[ks]=zs; spos[ks]=ss; } /*** durchlaufe nun t2 v.l.n.r. und v.o.n.u.: Position (zs,ss) ***/ ks_pos=1; /* Position des Laufelements im Vektor t2 */ k_pos=0; /* Position von Element k in tloc */ for (zs=1; zs<=alpha[0]; zs++) { for (ss=1; ss<=alpha[zs]; ss++) { ks=t2[ks_pos++]; /* ks ist das Element in Zeile zs, Spalte ss */ z=zpos[ks]; /* z ist Zeilenposition von ks in tloc */ if (z != zs) /* z!=zs, dann muss man in tloc vertauschen */ { k=tloc[k_pos+spos[ks]]; /* Vertauschungselement in tloc an Position (zs,s), wobei s die Spalten- position von ks in tloc ist */ if (d[k]) return(-1); /* Fehler: Element wurde schon mal getauscht: kein q gefunden */ ltmult(q,k,ks); /* sonst: q = (k ks)q */ ltmult(tloc,k,ks); /* und tloc ebenso */ zpos[ks]=zs; /* auch die Zeilenpositionen sind neu */ zpos[k]=z; } d[ks]=1; /* ks erledigt */ } k_pos+=alpha[zs]; /* k_pos zeigt jetzt auf 1. Element in der naechsten Zeile von tloc */ } /*** Nun muss ggf. noch ps bestimmt werden. Das ist aber fuer dieses Programm nicht notwendig. Fuer andere Anwendungen sind die Kommentarklammern zu entfernen ***/ /* for (i=1; i<=n; i++) ps[tloc[i]]=t2[i]; */ return(0); } /******************************************************************** * * NEXTST.C * * Prozeduren zur Berechnung der Standardtableaux * (geordnet nach der letzten Ziffer) * ********************************************************************/ /******************************************************************** * * Prozedur: * void set_LL_min(st,talpha,alpha) * * Beschreibung: * set_LL_min belegt das Tableau zum Teilrahmen talpha von alpha * so vor, dass es im Teilrahmen LL-kleinstes ist. st ist das zu * alpha gehoerende Tableau. * ********************************************************************/ static void set_LL_min(st,talpha,alpha) int *st; int *talpha; int *alpha; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { register int k,s,z,*pos; /*** k ist die einzusetzende Ziffer, d.h k=1,2,... ***/ k=1; /*** Durchlaufe nun den Teilrahmen spalten- und zeilenweise ***/ for (s=1; s<=talpha[1]; s++) { pos=st+s; /* "absolute" (Vektor-)Position in st */ for (z=1; talpha[z] >= s; z++) { *pos=k++; pos+=alpha[z]; /* eine Zeile weiter */ if (z >= talpha[0]) break; } } } /******************************************************************** * * Prozedur: * int nextst(mode,alpha,st) * * Beschreibung: * * mode=FIRST_ST: * nextst berechnet das LL-kleinste Standardtableau. * * mode=NEXT_ST: * nextst berechnet das auf st folgende Tableau in der LLS. * * Rueckgabe: * 0 zeigt an, dass st schon letztes war, sonst 1. * ********************************************************************/ static int nextst(mode,alpha,st) int mode; int *alpha; int *st; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { int talpha[TFNMAX]; register int n,s,z,zz,pos,i,j,k; /*** LL-kleinstes ***/ if (mode==FIRST_ST) { st[0]=0; /* n bestimmen */ for (i=1; i<=alpha[0]; i++) st[0]+=alpha[i]; set_LL_min(st,alpha,alpha); return(1); } else /*** LL-naechstes ***/ { /*** berechne kleinstes Teiltableau, so dass man die groesste Ziffer darin nach unten schieben kann ***/ n=st[0]; talpha[0]=1; talpha[1]=1; /* Teiltableau talpha mit [1] vorbesetzen */ for (i=2; i<=n; i++) /* durchlaufe alle Ziffern 2,...,n */ { /*** bestimme Zeile z und "absolute" Position k von i in st ***/ z=1; /* (1,1) ist immer mit 1 besetzt -> uebergehen */ s=2; k=1; while (st[++k]!=i) { if (s++>=alpha[z]) { s=1; z++; } } /*** erweitere Rahmen talpha um Kaestchen fuer i ***/ if (z > talpha[0]) { talpha[0]++; talpha[z]=0; } talpha[z]++; /*** pruefe nun in talpha, ob man i nach unten bringen kann ***/ if (talpha[0] > 1 && talpha[1] > 1) /* talpha gross genug ? */ { pos=k+alpha[z]-s; for (zz=z+1; zz <= talpha[0]; zz++) /* die Zeilen unter z testen */ { pos+=talpha[zz]; /* pos zeigt auf Endziffer in Zeile zz */ if (zz==talpha[0]) /* Ist zz die letzte Zeile ... */ j=1; else if (talpha[zz] > talpha[zz+1]) /* oder steht nichts darunter, ... */ j=1; /* so ist tauschen mglich */ else j=0; /* sonst nicht */ if (j && st[pos] < i) /* Tauschen erlaubt, falls Endziffer kleiner als Ziffer i ist */ { s=st[pos]; /* tausche i mit st[pos] */ st[pos]=i; st[k]=s; if (--talpha[zz]==0) talpha[0]--; /* Teiltableau ohne Ziffer i neu sortieren */ if (talpha[0] > 1 && talpha[1] > 1) set_LL_min(st,talpha,alpha); return(1); /* fertig */ } pos+=alpha[zz]-talpha[zz]; /* sonst naechste Zeile testen */ } } } /*** alle Ziffern getestet und keine Tauschmoeglichkeit gefunden: letztes Tableau erreicht ***/ return(0); } } /******************************************************************** * * NATDG.C (ohne getdim) * * Prozeduren zur Berechnung der natuerlichen Darstellung der Sn * Version mit Pufferung aller Standardtableaux. * ********************************************************************/ /******************************************************************** * * Prozedur: * int allst(alpha,n) * * Beschreibung: * allst berechnet alle Standardtableaux, belegt entsprechend * viel Speicher und liefert Zeiger auf den Speicherbereich. * Der Bereich muss mit free(Bereich) freigegeben werden. * * Rueckgabe: * 0 (OK) oder <>0 (FEHLER) ********************************************************************/ static int allst(alpha,n) int *alpha; int n; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { int i,e,*b; int st[TFNMAX]; if (stptr) { SYM_free(stptr); stptr=(int *)0L; } stptr=b=(int *)SYM_malloc(sizeof(int)*(long)(n+1)*(long)stdim); if (!b) return(-1); e=nextst(FIRST_ST,alpha,st); while (e) { for (i=0; i<=n; *b++=st[i++]); e=nextst(NEXT_ST,alpha,st); } return(0); } /******************************************************************** * * Prozedur: * int koeff(alpha,pi,stk,stj) * * Beschreibung: * koeff berechnet den Koeffizienten der Permutation pi * im Gruppenalgebra-Element e(kj) := e(k)*pi(kj). * Dabei beziehen sich k und j auf die zugehoerigen LLS-geordneten * Standardtableaux stk und stj, wobei stj = pi(kj)stk. * * Rueckgabe: * Koeffizient -1,0,1 * ********************************************************************/ static int koeff(alpha,pi,stk,stj) int *alpha; int *pi; int *stk; int *stj; /* AK 191289 V1.1 */ /* TF 011289 */ { int i,ps[TFNMAX],q[TFNMAX]; int t2[TFNMAX]; /*** berechne Tableau t2 = pi * st[j] ***/ t2[0]=pi[0]; for (i=1; i<=pi[0]; i++) t2[i]=pi[stj[i]]; /*** finde nun Permutationen q,ps ***/ if (find_pq(alpha,stk,t2,q,ps)<0) return(0); /*** der Koeffizient ist dann sgn(q) ***/ return(sign(q)); } /******************************************************************** * * Prozedur: * int koeffid(alpha,stk,stj) * * Beschreibung: * koeffid ist ein Spezialfall von koeff fuer pi=id. * * Rueckgabe: * Koeffizient -1,0,1 * ********************************************************************/ static int koeffid(alpha,stk,stj) int *alpha; int *stk; int *stj; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { int ps[TFNMAX],q[TFNMAX]; /*** finde nun Permutationen q,ps ***/ if (find_pq(alpha,stk,stj,q,ps) < 0) return(0); /*** der Koeffizient ist dann sgn(q) ***/ return(sign(q)); } /******************************************************************** * * Prozedur: * int ndg_L_alpha(alpha,la) * * Beschreibung: * ndg_L_alpha berechnet die Matrix L_alpha := M_alpha ^ (-1), * mit M_alpha = (( koeff(id,e(kj) )). * Die Matrix L_alpha wird in la zurueckgegeben. * Es wird nur die rechte obere Haelfte der oberen Dreiecksmatrix * gespeichert. Auch die Diagonale aus Einsen wird nicht gespeichert. * Die Matrix liegt dann in Vektorform vor. Auf die Komponenten * kann mit dem Makro ODM(la,z,s) zugegriffen werden. * * Rueckgabe: * 0, -1 fuer Fehler * ********************************************************************/ static int ndg_L_alpha(alpha,la) int *alpha; int *la; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { int dim,n,*TF_la,*TF_la1,*TF_la2,o1,o2,i,k; int id[TFNMAX]; int j; int stj,stk; /*** erstmal n aus der Partition berechnen ***/ n=0; for (i=1; i<=alpha[0]; n+=alpha[i++]); id[0]=n; for (i=1; i<=n; i++) id[i]=i; TF_la=la; /*** alle Tableaux berechnen, dim muss bekannt sein ***/ if (stptr) { SYM_free(stptr); stptr=(int *)0L; } dim=stdim; if (allst(alpha,n)) return(-1); /*** M_alpha transponiert berechnen ***/ for (stj=0; stj < dim ; stj++) for (stk=stj+1; stk < dim; stk++) *TF_la++=koeffid(alpha,STAB(stk),STAB(stj)); /**** dann L_alpha := M_alpha hoch -1 berechnen ***/ for (j=dim-1; j>=1; j--) { TF_la=la+dim*(long)j-((long)j*((long)j+1L))/2L-(long)j-1L; TF_la1=TF_la2= &ODM(la,dim,j-1,j); for (i=j-1; i>=0; i--) { *TF_la1= -(*TF_la1); /* ODM(la,dim,i,j) */ TF_la1 -= dim-i-1; /* eine Zeile aufwaerts */ } for (k=j+1; k= 0; i--) { if ((o1= *TF_la1)!=0) /* ODM(la,dim,i,j) */ ODM(la,dim,i,k) += o1*o2; TF_la1 -= dim-i-1; /* eine Zeile hoch */ } } } return(0); } /******************************************************************** * * Prozedur: * int ndg_P_pi(alpha,pi,p) * * Beschreibung: * ndg_P_pi berechnet die Koeffizientenmatrix P_pi zur Permutation * pi. * Die Matrix wird wie bei L_alpha als Vektor gespeichert. * Zugriff erfolgt mit dem Makro MAT(pi,z,s). * * Rueckgabe: * 0 * ********************************************************************/ static int ndg_P_pi(alpha,pi,p) int *alpha; int *pi; int *p; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { int n,k,*TF_p; int pi1[TFNMAX]; int stj,stk; TF_p=p; /*** berechne pi1 = pi hoch -1 ***/ n=pi1[0]=pi[0]; for (k=1; k<=n; k++) pi1[pi[k]]=k; /*** berechne Koeffizientenmatrix ***/ for (stk=0; stk < stdim; stk++) for (stj=0; stj < stdim; stj++) *TF_p++=koeff(alpha,pi1,STAB(stj),STAB(stk)); return(0); } /******************************************************************** * * Prozedur: * int tfmult(la,p,dim,fp,dig) * * Beschreibung: * tfmult berechnet Produkt p=la*p. Dabei wird die Dreiecksstruktur * bei la zugrunde gelegt, ebenso die Vektorform der Matrizen. * Als Ergebnis erhaelt man die Darstellungsmatrix. * * Ist fp!=NULL, so werden Werte mit Breite auf FILE * fp ausgegeben. Bei dig=0 werden die Werte nur durch * ein Leerzeichen getrennt. * * Rueckgabe: * Charakterwert fuer P(pi) * ********************************************************************/ static int tfmult(la,p,dim,fp,dig) int *la; int *p; int dim; FILE *fp; int dig; /* AK 191289 V1.1 */ /* TF 011289 */ /* AK 210891 V1.3 */ { int o1,p2,*TF_la,*TF_p,*TF_pp,i,j; int h,k,ch; char format[6]; /*** Format-String fuer die Ausgabe ***/ if (dig) sprintf(format,"%%%dd",dig); else strcpy(format,"%d "); /*** multipliziere Matrizen ***/ ch=0; /* Charakter = 0 */ for (j=0; j 0) ? h+o1 : h-o1 ; } *TF_p=h; /* MAT(p,dim,i,j) */ if (i==j) ch+=h; TF_p+=dim; } } /*** Ausgabe ***/ if (fp!=NULL) { TF_la=p; for (i=0; i 1L)) { error("no memory available for matrices"); return(ERROR); } alpha[0]=(int)S_PA_LI(part); for (i=0L; i /* #include AK 200206 */ /* for isspace AK 160192 */ #include "def.h" #include "macro.h" int myisspace (int i) { if (i=='\t') return 1; if (i=='\n') return 1; if (i=='\r') return 1; if (i=='\v') return 1; if (i=='\f') return 1; if (i==' ') return 1; return 0; } #define INIT_CYCLO(a) \ do {\ erg += b_ksd_n(CYCLOTOMIC, CALLOCOBJECT(), NULL, a);\ } while(0) #define nb_quores(a,b,c,d) quores(a,b,c,d) /* AK 050393 */ static INT space_saving = TRUE; static INT basis_type = STD_BASIS; /* STATIC VARIABLES RELATING TO THE MAINTENANCE OF CYCLOTOMIC DATA */ #ifdef CYCLOTRUE /* cyclo_table points to an array of CYCLO_DATA with */ /* no_cyclos cyclos. cyclo_table_set is a flag which */ /* indicates whether the table is present or not. */ static INT cyclo_table_set = 0L, cyclo_list_set = 0L; static INT zzno_cyclos; static CYCLO_DATA *zzcyclo_table; static OP zzcyclo_list = NULL, zzcyclo_tail = NULL; static INT number_mem; #endif /* CYCLOTRUE */ static INT setup_prime_table(); static INT integer_factor_0(); static INT integer_factor_1(); static INT insert_zero_into_monopoly(); static INT integer_coefficients(); static INT find_sqrad_data(); static INT adjust_sqrad_data(); static INT fprint_sqrad(); static INT fprint_cyclo(); static INT standardise_cyclo_0(); static INT make_index_monopoly_cyclo(); static INT add_cyclo_cyclo_0(); static INT mult_cyclo_cyclo_0(); static INT invers_cyclo_norm(); static INT SCMPCO(); # ifdef CYCLOTRUE static INT setup_cyclotomic_table(); static CYCLO_DATA *cyclo_ptr(); static CYCLO_DATA *add_cyclo_data(); static INT free_cyclo_list(); static INT free_cyclo_table(); # endif OP s_n_s(a) OP a; /* AK 080891 V1.3 */ { if (a == NULL) { error("s_n_s:a == NULL"); return (OP) NULL; } return (((a)->ob_self).ob_number)->n_self; } INT c_n_s(a,b) OP a,b; /* AK 200891 V1.3 */ { ((a->ob_self).ob_number)->n_self = b; return OK; } OP s_n_d(a) OP a; /* AK 200891 V1.3 */ { if (a == NULL) { error("s_n_d:a == NULL"); return (OP) NULL; } return (((((a)->ob_self).ob_number)->n_data).o_data); } INT c_n_d(a,b) OP a,b; /* AK 200891 V1.3 */ { ((((((a)->ob_self).ob_number)->n_data).o_data) = (b)); return OK; } OP s_n_dci(a) OP a; /* AK 200891 V1.3 */ { return ((((((a)->ob_self).ob_number)->n_data).c_data)->index); } OP s_n_dcd(a) OP a; /* AK 200891 V1.3 */ { return ((((((a)->ob_self).ob_number)->n_data).c_data)->deg); } OP s_n_dcp(a)OP a; /* AK 200891 V1.3 */ { return ((((((a)->ob_self).ob_number)->n_data).c_data)->poly); } /****************** factors.c **********************/ /* 26.07.91: TPMcD. */ /*************************************************************/ /* Determines and returns the number of digits of the */ /* integer a. a may be an INTEGER or a LONGINT. */ INT number_of_digits(a) OP a; /* 04.04.90: TPMcD */ /* AK 200891 V1.3 */ { INT i = 1L; OP b = CALLOCOBJECT(); OP ten = CALLOCOBJECT(); M_I_I(10L,ten); copy(a,b); if (LT(b,cons_null) == TRUE) addinvers_apply(b); while (GE(b,ten) == TRUE) { ganzdiv(b,ten,b); i++; } freeall(b); freeall(ten); return(i); } INT number_of_bits(a) OP a; /* 04.04.90: TPMcD */ /* AK 200891 V1.3 */ /* AK 300102 */ /* AK 180902 V2.1 */ { INT erg = OK; CTTO(INTEGER,LONGINT,"number_of_bits(1)",a); { INT i = 1L; OP b,ten; if (S_O_K(a) == INTEGER) /* AK 280705 */ { INT ai = S_I_I(a); while (ai >= 2) { ai /= 2; i++; } return i; } b = CALLOCOBJECT(); COPY(a,b); if (LT(b,cons_null) == TRUE) ADDINVERS_APPLY(b); while (GE(b,cons_zwei) == TRUE) { ganzdiv(b,cons_zwei,b); i++; } freeall(b); return(i); } ENDR("number_of_bits"); } INT integer_factors_to_integer(l,a) OP l,a; /* 10.05.90: TPMcD */ /* AK 200891 V1.3 */ /* 01.10.91: TPMcD */ { INT ret = ERROR; #ifdef MONOPOLYTRUE OP b = CALLOCOBJECT(); OP ptr; if (S_O_K(l) != MONOPOLY) goto exit_label; if (not EMPTYP(a)) freeself(a); M_I_I(1L,a); ptr = l; if (EMPTYP(S_PO_S(ptr))) ptr = S_L_N(ptr); /* skip the empty term */ while (ptr != NULL) { hoch(S_PO_S(ptr),S_PO_K(ptr),b); mult(a,b,a); ptr = S_L_N(ptr); } ret = OK; exit_label: freeall(b); #else error("integer_factors_to_integer: MONOPOLY not available"); #endif return(ret); } /*Given the number n, which should be an positive INTEGER or LONGINT */ /*or a MONOPOLY representing a factorisation of an integer greater */ /*than 1 , the result returns the list of positive integers coprime to n.*/ INT make_coprimes(number,result) OP number, result; /* 01.05.91: TPMcD */ /* AK 200891 V1.3 */ /* 01.10.91: TPMcD */ { INT end_flag = 0L, flag= -1L; /* AK 040292 */ INT erg = ERROR; OP ptr, ptr_zwei, ptr_drei, num=NULL; #ifdef MONOPOLYTRUE OP new, list=NULL; OP vec,prime,count_eins,count_zwei; CTTTO(INTEGER,MONOPOLY,LONGINT,"make_coprimes(1)",number); vec = CALLOCOBJECT(); prime = CALLOCOBJECT(); count_eins = CALLOCOBJECT(); count_zwei = CALLOCOBJECT(); init(LIST,result); if (S_O_K(number) == MONOPOLY) { list = number; num = CALLOCOBJECT(); flag = 1L; /* remember to free num */ integer_factors_to_integer(list,num); } else { if (((S_O_K(number) != INTEGER) && (S_O_K(number) != LONGINT)) || (LT(number,cons_eins) == TRUE)) goto exit_label; if (EQ(number,cons_eins) == TRUE) { new = CALLOCOBJECT(); M_I_I((INT)1,new); insert(new,result,NULL,NULL); erg = OK; goto exit_label; } num = number; list = CALLOCOBJECT(); flag = 0L; /* remember to free list */ integer_factor(num,list); } m_i_i((INT)1,count_eins); init(LIST,vec); ptr = vec; while (TRUE) { /* vec is initialised to the list of numbers 1 , . . ., num */ S_L_S(ptr) = CALLOCOBJECT(); copy(count_eins,S_L_S(ptr)); if (LT(count_eins,num) == TRUE) { new = CALLOCOBJECT(); S_L_N(ptr) = new; ptr = new; init(LIST,new); INC(count_eins); } else { S_L_N(ptr) = NULL; break; } } ptr = list; while (ptr != NULL) { copy(S_PO_S(ptr),prime); /* copy(cons_eins,count_eins); copy(cons_eins,count_zwei); */ M_I_I(1,count_eins); M_I_I(1,count_zwei); ptr_zwei = vec; while (LE(count_eins,num) == TRUE) { /* delete all multiples of prime from vec */ if (EQ(count_zwei,prime) == TRUE) { /* copy(cons_eins,count_zwei); */ M_I_I(1,count_zwei); if (not EMPTYP(S_L_S(ptr_zwei))) /* AK */ FREESELF(S_L_S(ptr_zwei)); } else INC_INTEGER(count_zwei); INC_INTEGER(count_eins); ptr_zwei = S_L_N(ptr_zwei); } ptr = S_L_N(ptr); } ptr = result; ptr_drei = result; copy(cons_eins,count_eins); ptr_zwei = vec; while (TRUE) { if (EQ(count_eins,num) == TRUE) end_flag = 1L; if (not EMPTYP(S_L_S(ptr_zwei))) { S_L_S(ptr) = CALLOCOBJECT(); copy(count_eins,S_L_S(ptr)); if (end_flag) { S_L_N(ptr) = NULL; break; } else { new = CALLOCOBJECT(); init(LIST,new); S_L_N(ptr) = new; ptr_drei = ptr; ptr = new; } } if (end_flag) { freeall(ptr); S_L_N(ptr_drei) = NULL; break; } INC(count_eins); ptr_zwei = S_L_N(ptr_zwei); } erg = OK; exit_label: FREEALL4(vec,prime,count_eins,count_zwei); if (flag == 1L) freeall(num); else if (flag != -1L) freeall(list); /* AK 040292 */ #endif ENDR("make_coprimes"); } INT euler_phi(a,b) OP a,b; /* AK number of numbers coprime to a */ /* AK 310191 V1.2 */ /* AK 200891 V1.3 */ { OP c = CALLOCOBJECT(); INT erg; erg = make_coprimes(a,c); erg += length(c,b); erg += freeall(c); return erg; } INT prime_power_p(a) OP a; /* AK 290304 true if power of a prime */ /* AK 161204 V3.0 */ { INT erg = OK; CTTO(INTEGER,LONGINT,"prime_power_p(1)",a); if (NULLP(a)) return FALSE; if (NEGP(a)) return FALSE; { OP b; INT res; b = CALLOCOBJECT(); factorize(a,b); if (EQ(S_V_I(b,0),S_V_I(b,S_V_LI(b)-1))) res = TRUE; else res = FALSE; FREEALL(b); return res; } ENDR("prime_power_p"); } INT primep(a) OP a; /* AK 220294 true if prime */ /* AK 161204 V3.0 */ { OP c,d,e; INT erg = TRUE; if (EQ(a,cons_zwei)) { erg = TRUE; goto p1; } if (negp(a) || NULLP(a) || EVEN(a) ) { erg = FALSE; goto p1; } CALLOCOBJECT3(c,d,e); ganzsquareroot(a,c); M_I_I(3,d); while (le(d,c)) { mod(a,d,e); if (NULLP(e) ) { erg = FALSE; break; } ADD_APPLY(cons_zwei,d); } FREEALL3(c,d,e); p1: return erg; ENDR("primep"); } /* INTEGER SQUARE ROOTS */ /* If a is a non-negative integer (INTEGER or LONGINT) */ /* s is set to the integer part of its square root. */ /* In this case, the return value is OK or IMPROPER */ /* according as the integer is a perfect square or not. */ /* Otherwise, the return value is ERROR. */ static INT nb_square_root(a,s) OP a,s; /* 04.04.90: TPMcD */ /* AK 200891 V1.3 */ { INT a_eins,d_eins,e_eins,ret = ERROR; INT erg = OK; OP b,c,d,e,diff; CTTO(INTEGER,LONGINT,"nb_square_root(1)",a); b = CALLOCOBJECT(); c = CALLOCOBJECT(); d = CALLOCOBJECT(); e = CALLOCOBJECT(); diff = CALLOCOBJECT(); if (negp(a)) /* a < 0L */ { fprintf(stderr,"Negative number has no real square root\n"); goto exit_label; } if (NULLP(a)) { m_i_i(0l,s); ret = OK; goto exit_label; } d_eins = number_of_digits(a); e_eins = (d_eins + 1L) / 2L; M_I_I(10L,d); M_I_I(e_eins-1L,b); hoch(d,b,b); MULT(d,b,c); FREESELF(d); MULT(b,b,d); if (EQ(a,d) == TRUE) { copy(b,s); ret = OK; goto exit_label; } do { FREESELF(d); ADD(b,c,d); if (negp(d)) error("square_root : negative integer unexpectedly encountered\n"); half_apply(d); FREESELF(diff); ADDINVERS(b,diff); ADD_APPLY(c,diff); FREESELF(e); MULT(d,d,e); a_eins = COMP(a,e); if (a_eins < 0L) copy(d,c); else if (a_eins > 0L) copy(d,b); else { copy(d,s); ret = OK; goto exit_label; } } while (GE(diff,cons_zwei) == TRUE); copy(b,s); ret = IMPROPER; exit_label: FREEALL5(b,c,d,e,diff); CTTO(INTEGER,LONGINT,"nb_square_root(e2)",s); return(ret); ENDR("nb_square_root"); } #ifdef LONGINTTRUE INT ganzsquareroot_longint(a,b) OP a,b; /* AK 040291 */ /* AK 200891 V1.3 */ { INT erg ; erg = nb_square_root(a,b); return (erg == IMPROPER ? OK : erg); /* AK 200194 */ } #endif /* LONGINTTRUE */ INT ganzsquareroot_integer(a,b) OP a,b; /* AK 040291 */ /* AK 200891 V1.3 */ { INT erg ; erg = nb_square_root(a,b); return (erg == IMPROPER ? OK : erg); /* AK 200194 */ } /* INTEGER FACTORISATION */ /* Routines for prime factorization of integers. */ /* prime_table points to an array of INT with the first no_primes primes.*/ /* prime_table_set is a flag which indicates whether the table is present*/ /* or not. */ static INT prime_table_set = 0L, no_primes; static INT *prime_table; /*Reads the table of primes from the file PRIMES.DAT. The first entry */ /*should be no_primes, then the list of primes. Assumes that INT means */ /*long int. Returns OK if the table is set; otherwise, returns ERROR. */ static INT setup_prime_table() /* 040490 TPMcD */ /* AK 200891 V1.3 */ /* 29.10.91 TPMcD */ { # ifdef PRIMES_FILE FILE *f; if ( (f = fopen("PRIMES.DAT","r")) == NULL || fscanf(f," %ld",&no_primes) == 0 || no_primes < 1L || (prime_table = (INT *)SYM_calloc((int)no_primes,sizeof(INT))) == NULL ) { no_primes = 0L; return(ERROR); } for (i=0L;i= 2 */ copy(cons_zwei,f); nb_quores(f,cons_zwei,q,r); if (nullp(r)) { if (einsp(q)) /* f = 2 */ flag = 0L; else /* f is even and greater than 2 */ INC(f); } nb_quores(c,f,q,r); while (LE(f,e) == TRUE) { while (nullp(r)) { /* The value of c entering this loop is divisible by f exactly k times, where k refers to its value exiting the loop. */ if (first_prime != NULL) { copy(f,first_prime); ret = OK; goto exit_label; } if (myfirst) { M_I_I(1L,k); new_factor = 1L; myfirst = 0L; } else INC(k); ganzdiv(c,f,c); nb_quores(c,f,q,r); } if (new_factor) { /* make new monomial and insert in the factor list */ g = CALLOCOBJECT(); m_sk_mo(f,k,g); insert(g,l,add_koeff,NULL); new_factor = 0L; if (EQ(c,cons_eins) == TRUE) break; nb_square_root(c,e_eins); /* reduce the upper limit of the trial factors */ if (LT(e_eins,e) == TRUE) copy(e_eins,e); /* the current c is a prime or it has prime factors */ /* are less than f_eins, and the factorization is 'complete'. */ if (LT(e,f) == TRUE) break; } myfirst = 1L; /* Increase f by 2 and find corresponding q and r */ INC(f); if (flag) INC(f); flag = 1L; nb_quores(c,f,q,r); } copy(c,b); ret = OK; exit_label: freeall(c); freeall(q); freeall(r); freeall(f); freeall(k); freeall(e); freeall(e_eins); #else /* MONOPOLYTRUE */ error("integer_factor_1: MONOPOLY not available"); #endif /* MONOPOLYTRUE */ return(ret); } /* This is the main integer factorization routine. */ /* a -- the integer to be factored; */ /* l -- a list in which the prime factors of a and their exponents */ /* are inserted as monomials with the primes as the selfs and the */ /* exponents as the koeffs. l need not be initialized to a MONOPOLY. */ INT integer_factor(a,l) OP a,l; /* 040490: TPMcD */ /* AK 200891 V1.3 */ /* 04.10.91: TPMcD */ { INT erg = ERROR; OP b,c,d,e; CTTO(INTEGER,LONGINT,"integer_factor(1)",a); CE2(a,l,integer_factor); b = CALLOCOBJECT(); c = CALLOCOBJECT(); d = CALLOCOBJECT(); e = CALLOCOBJECT(); init(MONOPOLY,l); /*First factorize using the list of primes in "PRIMES.DAT" */ if (integer_factor_0(a,l,b,c,NULL) != OK) { copy(a,b); M_I_I(1L,c); } if (EQ(b,cons_eins) == TRUE) /* Factorization complete. */ { erg = OK; goto exit_label; } copy(b,d); if (integer_factor_1(b,c,d,e,l,NULL) == OK) { /* If e > 1 , it is a prime greater than those in l */ m_i_i(1L,c); if (gt(e,c) == TRUE) { m_sk_mo(e,c,d); insert(d,l,add_koeff,NULL); m_i_i(1L,e); d = CALLOCOBJECT(); } erg = OK; } else printf("\ninteger_factor: factorization error"); exit_label: FREEALL4(b,c,d,e); CTO(MONOPOLY,"integer_factor(e2)",l); ENDR("integer_factor"); } /* This routine finds the smallest prime factor of an integer. */ /* a -- the integer; first_prime -- its smallest prime factor. */ INT first_prime_factor(a,first_prime) OP a,first_prime; /* 04.04.90: TPMcD */ /* AK 200891 V1.3 */ /* 04.10.91: TPMcD */ { INT ret = ERROR; #ifdef MONOPOLYTRUE OP b = CALLOCOBJECT(); OP c = CALLOCOBJECT(); OP d = CALLOCOBJECT(); OP e = CALLOCOBJECT(); OP l = CALLOCOBJECT(); if (S_O_K(a) != INTEGER && S_O_K(a) != LONGINT) goto exit_label; init(MONOPOLY,l); m_i_i(1L,first_prime); copy(a,d); if (LT(d,cons_null) == TRUE) addinvers(d,d); if (einsp(d)) { ret = OK; goto exit_label; } if (integer_factor_0(d,l,b,c,first_prime) == OK) if (einsp(first_prime)) if (integer_factor_1(d,c,d,e,l,first_prime) != OK || einsp(first_prime)) goto exit_label; ret = OK; exit_label: if (ret != OK) printf("\nfirst_prime_factor: factorization error"); freeall(b); freeall(c); freeall(d); freeall(e); freeall(l); #else error("integer_factor: MONOPOLY not available"); #endif return(ret); } /* SQUARE-FREE PARTS */ /* This routine find the square-free part of the integer, which is */ /* given as a prime factors list. */ /* la -- a MONOPOLY containing the prime factorization of the integer */ /* lb, lc -- return the MONOPOLYs containing the prime factorization */ /* of the square-free and square parts, respectively. */ /* The parameters la,lb,lc must be distinct. */ INT square_free_part_0(la,lb,lc) OP la,lb,lc; /* 14.06.90: TPMcD */ /* AK 200891 V1.3 */ { INT erg = ERROR; INT flag_b = 1L, flag_c = 1L; OP u , x , y , z , ptr, w; CTO(MONOPOLY,"square_free_part_0(1)",la); u = CALLOCOBJECT(); x = CALLOCOBJECT(); y = CALLOCOBJECT(); z = CALLOCOBJECT(); ptr = la; init(MONOPOLY,lb); init(MONOPOLY,lc); while (ptr != NULL) { copy(S_PO_S(ptr),u); /* the prime */ copy(S_PO_K(ptr),x); /* the exponent */ if (negp(x)) error("square_free_part_0 : unexpected negative exponent"); nb_quores(x,cons_zwei,z,y); if (nullp(y)) /* even power */ { w = CALLOCOBJECT(); m_sk_mo(u,z,w); insert(w,lc,add_koeff,NULL); flag_c = 0L; } else { if (not nullp(z)) { w = CALLOCOBJECT(); m_sk_mo(u,z,w); insert(w,lc,add_koeff,NULL); flag_c = 0L; } w = CALLOCOBJECT(); m_sk_mo(u,cons_eins,w); insert(w,lb,add_koeff,NULL); flag_b = 0L; } ptr = S_L_N(ptr); } if (flag_b) { w = CALLOCOBJECT(); m_sk_mo(cons_eins,cons_eins,w); insert(w,lb,add_koeff,NULL); } if (flag_c) { w = CALLOCOBJECT(); m_sk_mo(cons_eins,cons_eins,w); insert(w,lc,add_koeff,NULL); } erg = OK; freeall(u); freeall(x); freeall(y); freeall(z); CTO(MONOPOLY,"square_free_part_0(e2)",lb); CTO(MONOPOLY,"square_free_part_0(e3)",lc); ENDR("square_free_part_0"); } /* This routine find the square-free part of the integer, i.e. the */ /* product of the prime factors (and -1 , if the integer is < 0. */ /* a -- the integer, it is either an INTEGER, LONGINT or a */ /* MONOPOLY containing the prime factorization of an integer. */ /* b -- the square-free part. a = b * c  2 */ /* c -- the square-root of the square part. */ /* la -- returns a MONOPOLY containing the prime factorization of */ /* a if a is not a MONOPOLY and la is not NULL. */ /* lb, lc -- returns the MONOPOLYs containing the prime */ /* factorizations of b and c. */ /* The parameters a,b,c must be distinct. If la,lb,lc are not */ /* NULL they must be distinct also. */ INT square_free_part(a,b,c,la,lb,lc) OP a,b,c,la,lb,lc; /* 14.06.90: TPMcD */ /* AK 200891 V1.3 */ /* 04.10.91: TPMcD */ { INT erg = ERROR; OP la_tmp=NULL, lb_tmp=NULL, lc_tmp=NULL; CTTTO(INTEGER,LONGINT,MONOPOLY,"square_free_part(1)",a); if (S_O_K(a) == INTEGER || S_O_K(a) == LONGINT) { if (la == NULL) la_tmp = CALLOCOBJECT(); else la_tmp = la; init(MONOPOLY,la_tmp); integer_factor(a,la_tmp); } else if (S_O_K(a) == MONOPOLY) la_tmp = a; else goto exit_label; if (lb == NULL) lb_tmp = CALLOCOBJECT(); else lb_tmp = lb; init(MONOPOLY,lb_tmp); if (lc == NULL) lc_tmp = CALLOCOBJECT(); else lc_tmp = lc; init(MONOPOLY,lc_tmp); square_free_part_0(la_tmp,lb_tmp,lc_tmp); integer_factors_to_integer(lb_tmp,b); integer_factors_to_integer(lc_tmp,c); erg = OK; exit_label: if (la == NULL && la_tmp != a) freeall(la_tmp); if (lb == NULL) freeall(lb_tmp); if (lc == NULL) freeall(lc_tmp); CTTO(INTEGER,LONGINT,"square_free_part(e2)",b); CTTO(INTEGER,LONGINT,"square_free_part(e3)",c); ENDR("square_free_part"); } /* The Jacobi Symbol: (a/b) b odd. a and b are integers. c must point to a location different from a and b. if a and b have a common factor, c is set to 0 and ERROR is returned. otherwise, c is set to the the jacobi symbol (a/b). Note that b must be odd. */ INT jacobi(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ { INT erg = OK; OP x , y , z , w , y_eins , y_zwei , z_eins , z_zwei , four , eight ; INT ret = ERROR; INT d, f = 0L; CTTO(INTEGER,LONGINT,"jacobi(1)",a); CTTO(INTEGER,LONGINT,"jacobi(2)",b); CE3(a,b,c,jacobi); M_I_I(0,c); if (EVEN(b)) { printf("Jacobi Symbol: Second integer must be odd\n"); goto e2; } x =CALLOCOBJECT(), y = CALLOCOBJECT(), z = CALLOCOBJECT(), w = CALLOCOBJECT(), y_eins = CALLOCOBJECT(), y_zwei = CALLOCOBJECT(), z_eins = CALLOCOBJECT(), z_zwei = CALLOCOBJECT(), four = CALLOCOBJECT(), eight = CALLOCOBJECT(); M_I_I(4,four); M_I_I(8,eight); COPY(a,x); COPY(b,y); if (NEGP(y)) ADDINVERS_APPLY(y); while (NEQ(y,cons_eins)) { mod(x,y,z); if (NULLP(z)) /* The numbers not relatively prime*/ goto exit_label; if (ODD(z)) { FREESELF(w); ADDINVERS(y,w); ADD_APPLY(w,z); } d = 0L; while (EVEN(z)) { d = 1L - d; ganzdiv(z,cons_zwei,z); if (NULLP(z)) /*The numbers not relatively prime*/ goto exit_label; } FREESELF(x);COPY(y,x); FREESELF(y_eins);COPY(y,y_eins); DEC(y_eins); mod(y_eins,eight,y_zwei); FREESELF(z_eins);COPY(z,z_eins); DEC(z_eins); mod(z_eins,eight,z_zwei); FREESELF(y_eins);MULT(y_zwei,z_zwei,y_eins); mod(y_eins,eight,y_eins); if (GE(y_eins,four)) f = 1L - f; if (d) /* an odd power of two */ { INC(y); mod(y,eight,y_eins); if (GE(y_eins,four)) f = 1L - f; } if (NEGP(z)) ADDINVERS_APPLY(z); FREESELF(y);COPY(z,y); } m_i_i(1,c); if (f) M_I_I(-1,c); ret = OK; exit_label: FREEALL(x); FREEALL(y); FREEALL(z); FREEALL(w); FREEALL(y_eins); FREEALL(y_zwei); FREEALL(z_eins); FREEALL(z_zwei); FREEALL(four); FREEALL(eight); e2: return(ret); ENDR("jacobi"); } /* The Kronecker Symbol: (a/b). a square-free and congruent to 0 or 1 mod 4. a and b are integers. c must point to a location different from a and b. if a and b have a common factor, c is set to 0 and ERROR is returned. otherwise, c is set to the the jacobi symbol (a/b). Note that b must be odd. */ INT kronecker(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ { INT flag = 0L; INT ret = ERROR; INT erg = OK; OP a_eins = CALLOCOBJECT(), a_zwei = CALLOCOBJECT(), b_null = CALLOCOBJECT(), b_eins = CALLOCOBJECT(), b_zwei = CALLOCOBJECT(), b_drei = CALLOCOBJECT(), four = CALLOCOBJECT(); if (c == a || c == b || nullp(a) || nullp(b)) goto exit_label; COPY(a,a_eins); COPY(b,b_eins); if (NEGP(b_eins)) ADDINVERS_APPLY(b_eins); M_I_I(4L,four); copy(cons_null,c); mod(a_eins,four,a_zwei); if (NULLP(a_zwei)) flag = 1L; else if (!einsp(a_zwei)) goto exit_label; nb_quores(b_eins,cons_zwei,b_zwei,b_drei); copy(cons_null,b_null); if (NULLP(b_drei)) /* b is even. */ { if (flag) /* a is even also. */ goto exit_label; do { INC(b_null); copy(b_zwei,b_eins); nb_quores(b_eins,cons_zwei,b_zwei,b_drei); } while (nullp(b_drei)); } /* b_eins is the largest odd factor of b. */ nb_quores(b_null,cons_zwei,b_null,b_zwei); if (NULLP(b_zwei)) /* b is divisible by an odd power of two and a is odd. */ { m_i_i(8L,b_drei); mod(a_eins,b_drei,b_zwei); if (NEQ(b_zwei,cons_eins)) flag = 1L; /* negate the final value */ } else flag = 0L; /* At this point, b_eins is odd */ jacobi(a_eins,b_eins,c); if (flag) ADDINVERS_APPLY(c); ret = OK; exit_label: FREEALL(a_eins); FREEALL(a_zwei); FREEALL(four); FREEALL(b_null); FREEALL(b_eins); FREEALL(b_zwei); FREEALL(b_drei); return(ret); ENDR("kronecker"); } /****************** fields_0.c **********************/ /* 26.07.91: TPMcD. */ /*************************************************************/ INT eq_cyclotomic(a,b) OP a,b; /* AK 210202 */ { INT erg = OK,r; OP c; CTO(CYCLOTOMIC,"eq_cyclotomic(1)",a); if (S_O_K(b) != CYCLOTOMIC) return FALSE; c = CALLOCOBJECT(); sub(a,b,c); r = NULLP(c); FREEALL(c); return r; ENDR("eq_cyclotomic"); } INT eq_sqrad(a,b) OP a,b; /* AK 180702 */ { INT erg = OK,r; OP c; CTO(SQ_RADICAL,"eq_sqrad(1)",a); if (S_O_K(b) != SQ_RADICAL) return FALSE; c = CALLOCOBJECT(); sub(a,b,c); r = NULLP(c); FREEALL(c); return r; ENDR("eq_sqrad"); } INT eq_fieldobject_int(type,a,i) OBJECTKIND type; OP a; INT i; /* AK 200891 V1.3 */ { INT ret = FALSE; OP b = CALLOCOBJECT(); OP c = CALLOCOBJECT(); INT erg = OK; M_I_I(-i,b); switch(S_O_K(a)) { #ifdef MONOPOLYTRUE case MONOPOLY: add_scalar_monopoly(b,a,c); ret = nullp_monopoly(c); break; #endif /* MONOPOLYTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: add_scalar_cyclo(b,a,c); ret = nullp_monopoly(S_N_S(c)); break; #endif /* CYCLOTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: add_scalar_sqrad(b,a,c); ret = nullp_monopoly(S_N_S(c)); break; #endif /* SQRADTRUE */ default: error("eq_fieldobject_int: invalid type\n"); } FREEALL(b); FREEALL(c); return(ret); ENDR("eq_fieldobject_int"); } #ifdef NUMBERTRUE static struct number * callocnumber() /* 22.06.90: TPMcD */ /* AK 200891 V1.3 */ { struct number *result=(struct number *) SYM_calloc(1,sizeof(struct number)); if (result == NULL) error("callocnumber:no mem"); number_mem++; return(result); } #endif /* NUMBERTRUE */ INT m_ksd_n(kind,self,data,result) OBJECTKIND kind; OP self,data,result; /* AK 230191 */ /* AK 200891 V1.3 */ { INT erg = ERROR; #ifdef NUMBERTRUE erg = b_ksd_n(kind,CALLOCOBJECT(),CALLOCOBJECT(),result); if ((S_O_K(self) != MONOPOLY) || ((kind == SQ_RADICAL) && (S_O_K(data) != LIST))) return( error("m_ksd_n: invalid self or data") ); erg += copy(self,S_N_S(result)); erg += copy(data,S_N_D(result)); #endif /* NUMBERTRUE */ return erg; } INT init_sqrad(a) OP a; /* AK 010993 */ { INT erg = OK; CTO(EMPTY,"init_sqrad(1)",a); erg += b_ksd_n(SQ_RADICAL, CALLOCOBJECT(), CALLOCOBJECT(), a); ENDR("init_sqrad"); } INT init_cyclo(a) OP a; /* AK 010993 */ { INT erg = OK; CTO(EMPTY,"init_cyclo(1)",a); erg += b_ksd_n(CYCLOTOMIC, CALLOCOBJECT(), NULL, a); ENDR("init_cyclo"); } #ifdef NUMBERTRUE INT b_ksd_n(kind,self,data,result) OBJECTKIND kind; OP self,data,result; /* 22.06.90: TPMcD */ /* 3.04.91: TPMcD. */ /* AK 200891 V1.3 */ { OBJECTSELF obself; if (not EMPTYP(result)) freeself(result); obself.ob_number = callocnumber(); b_ks_o(kind,obself,result); if (EMPTYP(self)) init(MONOPOLY,self); if (kind == SQ_RADICAL && EMPTYP(data)) init(LIST,data); if ((S_O_K(self) != MONOPOLY) || ((kind == SQ_RADICAL) && (S_O_K(data) != LIST))) return( error("b_ksd_n: invalid self or data") ); S_N_S(result) = self; S_N_D(result) = data; return(OK); } #endif /* NUMBERTRUE */ INT objectwrite_number(f,number) FILE *f; OP number; /* AK 200891 V1.3 */ { #ifdef NUMBERTRUE fprintf(f," %ld\n",(INT)S_O_K(number)); objectwrite(f,S_N_S(number)); switch (S_O_K(number)) { case SQ_RADICAL: objectwrite(f,S_N_D(number)); break; case CYCLOTOMIC: objectwrite(f,S_N_DCI(number)); break; default: error("Invalid number type\n"); } return(OK); #else /* NUMBERTRUE */ error("objectwrite_number:NUMBER not available"); return(ERROR); #endif /* NUMBERTRUE */ } INT objectread_number(f,number,type) FILE *f; OP number; OBJECTKIND type; /* AK 200891 V1.3 */ { #ifdef NUMBERTRUE init(type,number); objectread(f,S_N_S(number)); switch (S_O_K(number)) { case SQ_RADICAL: objectread(f,S_N_D(number)); break; case CYCLOTOMIC: { OP index = CALLOCOBJECT(); objectread(f,index); S_N_DC(number) = add_cyclo_data(index); } break; default: error("Invalid number type\n"); } return(OK); #endif /* NUMBERTRUE */ } INT fprint_number(f,n) FILE *f; OP n; /* AK 200891 V1.3 */ { INT saving; #ifdef NUMBERTRUE switch (S_O_K(n)) { case SQ_RADICAL: /* Are all coefficients fractions with denominator 2 */ if (S_O_K(S_PO_K(S_N_S(n))) == BRUCH) { OP nn = CALLOCOBJECT(); saving = space_saving; space_saving = FALSE; mult_scalar_sqrad(cons_zwei,n,nn); space_saving = saving; if (integer_coefficients(S_N_S(nn)) == TRUE) { fprintf(f," 1/2 ("); fprint_sqrad(f,nn); fprintf(f,")"); freeall(nn); zeilenposition += 7L; return(OK); } freeall(nn); } fprintf(f," ( "); fprint_sqrad(f,n); fprintf(f," )"); zeilenposition += 5L; break; case CYCLOTOMIC: fprintf(f," ( "); fprint_cyclo(f,n); fprintf(f," )"); zeilenposition += 5L; break; default: ; } #endif /* NUMBERTRUE */ return(OK); } INT freeself_number(n) OP n; /* AK 200891 V1.3 */ { #ifdef NUMBERTRUE OBJECTSELF d; INT erg = OK; d = S_O_S(n); erg = freeall(S_N_S(n)); if (erg == ERROR) return error("freeself_number:error in freeall S_N_S"); switch (S_O_K(n)) { case SQ_RADICAL: if (not EMPTYP(S_N_D(n))) freeall(S_N_D(n)); else error("freeself_number: no data to release"); break; case CYCLOTOMIC: break; default: ; } SYM_free(d.ob_number); number_mem--; C_O_K(n,EMPTY); #endif /* NUMBERTRUE */ return OK; } INT comp_number(a,b) OP a,b; /* 21.07.91 TPMcD: still incomplete */ /* AK 200891 V1.3 */ { #ifdef NUMBERTRUE switch (S_O_K(a)) { case SQ_RADICAL: comp_sqrad(a,b); break; case CYCLOTOMIC: comp_cyclo(a,b); break; default: return error("comp_number:invalid number type\n"); } return(OK); #else /* NUMBERTRUE */ return error("comp_number:NUMBER not available"); #endif /* NUMBERTRUE */ } INT copy_number(a,b) OP a,b; /* AK 200891 V1.3 */ /* AK 060498 V2.0 */ { #ifdef NUMBERTRUE if (a == b) error("copy_number: First and second arguments are the same\n"); init(S_O_K(a),b); if (S_N_S(a) != NULL) copy(S_N_S(a),S_N_S(b)); switch (S_O_K(a)) { case SQ_RADICAL: copy(S_N_D(a),S_N_D(b)); break; case CYCLOTOMIC: S_N_DC(b) = S_N_DC(a); break; default: return error("copy_number:invalid number type\n"); } return(OK); #endif /* NUMBERTRUE */ } INT complex_conjugate(a,b) OP a,b; { OP ptr; if (a != b) copy(a,b); #ifdef NUMBERTRUE switch (S_O_K(b)) { case SQ_RADICAL: ptr = S_N_S(b); while (ptr != NULL) { if (not EMPTYP(S_PO_K(ptr))) complex_conjugate(S_PO_K(ptr),S_PO_K(ptr)); if (LT(S_PO_S(ptr),cons_null) == TRUE) addinvers_apply(S_PO_K(ptr)); ptr = S_L_N(ptr); } break; case CYCLOTOMIC: ptr = S_N_S(b); while (ptr != NULL) { if (not EMPTYP(S_PO_K(ptr))) { complex_conjugate(S_PO_K(ptr),S_PO_K(ptr)); addinvers_apply(S_PO_S(ptr)); add_apply(S_N_DCI(b),S_PO_S(ptr)); } ptr = S_L_N(ptr); } break; default: break; } #endif /* NUMBERTRUE */ return(OK); } INT setup_numbers(basis,saving,filename) INT basis, saving; char *filename; /* 29.10.91: TPMcD */ { #ifdef CYCLOTRUE number_mem = (INT)0; #endif /* CYCLOTRUE */ #ifdef MONOPOLYTRUE setup_prime_table(); #endif /* MONOPOLYTRUE */ #ifdef NUMBERTRUE basis_type = basis; space_saving = saving; setup_cyclotomic_table(filename); #endif /* NUMBERTRUE */ return(OK); } INT release_numbers() /* 29.10.91: TPMcD */ { #ifdef MONOPOLYTRUE if (prime_table_set) { SYM_free(prime_table); prime_table = NULL; } #endif #ifdef NUMBERTRUE if (cyclo_table_set) { free_cyclo_table(); SYM_free(zzcyclo_table); cyclo_table_set = 0; /* AK 120202 */ } if (cyclo_list_set) { free_cyclo_list(); freeall(zzcyclo_list); cyclo_list_set = 0; /* AK 120202 */ } #endif return(OK); } INT nb_ende() { #ifdef CYCLOTRUE if (number_mem != 0L) fprintf(stderr,"error in number memory %ld\n",number_mem); return OK; #endif } INT reset_basis(basis) INT basis; { #ifdef NUMBERTRUE basis_type = basis; if (basis == NO_REDUCE || basis == POWER_REDUCE) printf("\nWARNING: not a valid basis\n"); #endif return(OK); } INT reset_saving(saving) INT saving; { #ifdef NUMBERTRUE space_saving = saving; #endif return(OK); } INT tex_monom_plus(form,a) INT form; OP a; /* AK 200891 V1.3 */ { return tex_monom(a);/* AK return */ } #ifdef UNDEF /*Multiplies the entries in two lists pairwise, putting the resulting */ /*objects in a list. Duplicate objects are ignored. */ static INT mult_lists(a,b,c) OP a, b, c; /* 26.08.90: TPMcD. */ /* AK 200891 V1.3 */ /* 04.10.91: TPMcD */ { INT flag = 0L; #ifdef LISTTRUE OP new, a_ptr, b_ptr, c_tmp; if (c == a || c == b) { flag = 1L; c_tmp = CALLOCOBJECT(); } else c_tmp = c; init(LIST, c_tmp); b_ptr = b; while (b_ptr != NULL) { a_ptr = a; while (a_ptr != NULL) { new = CALLOCOBJECT(); mult(S_L_S(a_ptr), S_L_S(b_ptr), new); insert(new,c_tmp,NULL,NULL); a_ptr = S_L_N(a_ptr); }; b_ptr = S_L_N(b_ptr); } if (flag) { copy(c_tmp,c); freeall(c_tmp); } return(OK); #else error("mult_lists: LIST not available"); return(ERROR); #endif } #endif INT tidy(a) OP a; /* AK 200891 V1.3 */ /* 04.10.91: TPMcD */ { INT i,j; OP ptr; switch (S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH : tidy(S_B_O(a)); tidy(S_B_U(a)); break; #endif /* BRUCHTRUE */ case INTEGER : break; #ifdef LISTTRUE case POLYNOM: case LIST : ptr = a; while (ptr != NULL) { tidy(S_L_S(ptr)); ptr = S_L_N(ptr); } break; #endif /* LISTTRUE */ #ifdef LONGINTTRUE case LONGINT : break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case MATRIX : for (i=0L;iMONOPOLY"); break; default: erg += WTO("cast_apply_monopoly:can not convert",a); break; } } ENDR("cast_apply_monopoly"); } INT scan_monopoly(a) OP a; /* AK 200990 */ /* AK 220191 V1.2 */ /* a becomes a monopoly */ /* AK 200891 V1.3 */ { OBJECTKIND kt,st; INT erg = OK; CTO(EMPTY,"scan_monopoly(1)",a); erg += printeingabe("type of monopoly self "); st=scanobjectkind(); erg += printeingabe("type of monopoly koeff "); kt=scanobjectkind(); erg += SCMPCO(st,kt,a); ENDR("scan_monopoly"); } #endif /* MONOPOLYTRUE */ static INT SCMPCO(self_type,coeff_type,result) /* scan_monopoly_co */ OBJECTKIND self_type,coeff_type; OP result; /* 04.06.90: TPMcD. */ /* 1.04.91: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { INT ret = ERROR; INT i,n; # ifdef MONOPOLYTRUE OP x = CALLOCOBJECT(), y = CALLOCOBJECT(), z; char a[30]; init(MONOPOLY,result); printeingabe("Length of list: "); /* AK 080891 */ scanf("%ld",&n); for (i=0L;i 60L) { zeilenposition = 0L; fprintf(f,"\n"); } if (einsp(S_PO_S(ptr))) rational = 1L; /* A rational term */ else rational = 0L; /* print the coefficient part of a term */ if (!negp(S_PO_K(ptr)) && !myfirst) fprintf(f," +"); if (negeinsp(S_PO_K(ptr))) { if (rational) fprintf(f," - 1"); else fprintf(f," -"); } else if (einsp(S_PO_K(ptr))) { if (rational) fprintf(f," 1"); } else { fprintf(f," "); fprint(f,S_PO_K(ptr)); } if (not rational) /* print the radical part of a term */ { fprintf(f," sqr("); fprint(f,S_PO_S(ptr)); fprintf(f,")"); zeilenposition += 6L; } ptr = S_L_N(ptr); myfirst = 0L; } return(OK); } #endif /* SQRADTRUE */ INT tex_sqrad(a) OP a; /* 020491: TPMcD. */ /* AK 200891 V1.3 */ /* 041091: TPMcD */ { INT myfirst = 1L; # ifdef SQRADTRUE OP ptr = S_N_S(a); find_sqrad_data(a); if (nullp_sqrad(a)) { fprintf(texout," 0\n"); return(OK); } fprintf(texout," "); while (ptr != NULL) { if (!negp(S_PO_K(ptr)) && !myfirst) fprintf(texout," + {"); else fprintf(texout,"{"); tex(S_PO_K(ptr)); if (NEQ(S_PO_S(ptr),cons_eins)) { fprintf(texout,"} \\sqrt{"); tex(S_PO_S(ptr)); } fprintf(texout,"}"); ptr = S_L_N(ptr); myfirst = 0L; } fprintf(texout," "); return(OK); #else error("tex_sqrad: SQ_RADICAL not available"); return(ERROR); #endif } static INT find_sqrad_data(a) OP a; /* 23.06.90: TPMcD. */ /* AK 200891 V1.3 */ /* 04.10.91: TPMcD */ { #ifdef SQRADTRUE OP new, num, next_num, ptr, next_ptr, data_ptr, list_ptr, list_copy = CALLOCOBJECT(), prime_list = CALLOCOBJECT(), quo = CALLOCOBJECT(), rem = CALLOCOBJECT(); if (S_N_D(a) == NULL) S_N_D(a) = CALLOCOBJECT(); data_ptr = S_N_D(a); /* Assume the data is OK if it is a non-empty LIST */ if (not EMPTYP(data_ptr) && S_O_K(data_ptr) == LIST && not empty_listp(data_ptr)) { goto fsd_ende; } init(LIST,data_ptr); copy(S_N_S(a),list_copy); ptr = list_copy; num = S_PO_S(ptr); if (LT(num,cons_null) == TRUE) /* negative radicals */ { new = CALLOCOBJECT(); M_I_I(-1L,new); insert_list(new,data_ptr,NULL,NULL); while (ptr != NULL) /*multiply negative radicals by -1*/ { num = S_PO_S(ptr); if (LT(num,cons_null) == TRUE) addinvers_apply(num); else break; ptr = S_L_N(ptr); } } ptr = list_copy; while (ptr != NULL) { num = S_PO_S(ptr); if (not einsp(num) && not nullp(num)) { integer_factor(num,prime_list); list_ptr = prime_list; while (list_ptr != NULL) { new = CALLOCOBJECT(); copy(S_PO_S(list_ptr),new);/* new is the next prime */ next_ptr = S_L_N(ptr); while (next_ptr != NULL) { next_num = S_PO_S(next_ptr); if (NEQ(next_num,cons_eins) == TRUE) { nb_quores(next_num,new,quo,rem); if (nullp(rem)) /* AK 120891 */ copy(quo,next_num); } next_ptr = S_L_N(next_ptr); } insert_list(new,data_ptr,NULL,NULL); list_ptr = S_L_N(list_ptr); } freeself(prime_list); } ptr = S_L_N(ptr); } fsd_ende: freeall(list_copy); freeall(prime_list); freeall(rem); freeall(quo); return(OK); #else error("find_sqrad_data: SQ_RADICAL not available"); return(ERROR); #endif } /* a: the sqrad */ static INT adjust_sqrad_data(a) OP a; /* 15.04.91: TPMcD. */ /* AK 200891 V1.3 */ { INT inserted = 1L; INT erg = OK; OP new=NULL, quo, rem, ptr, data_ptr, a_copy, prime_list, num_ptr; if (S_O_K(a) != SQ_RADICAL) return(ERROR); if (S_N_D(a) == NULL || EMPTYP(S_N_D(a))) return(find_sqrad_data(a)); if (empty_listp(S_N_D(a))) return(OK); prime_list = CALLOCOBJECT(); init(LIST,prime_list); a_copy = CALLOCOBJECT(); copy(a,a_copy); ptr = S_N_S(a_copy); num_ptr = S_PO_S(ptr); if (LT(num_ptr,cons_null) == TRUE) /*negative radicals */ { new = CALLOCOBJECT(); M_I_I(-1L,new); insert_list(new,prime_list,NULL,NULL); while (ptr != NULL)/*multiply negative radicals by -1 */ { num_ptr = S_PO_S(ptr); if (LT(num_ptr,cons_null) == TRUE) addinvers_apply(num_ptr); else break; ptr = S_L_N(ptr); } } data_ptr = S_N_D(a); quo = CALLOCOBJECT(); rem = CALLOCOBJECT(); while (data_ptr != NULL) { if (negeinsp(S_L_S(data_ptr))) /* negatives have been taken care of*/ { data_ptr = S_L_N(data_ptr); continue; } if (inserted) new = CALLOCOBJECT(); copy(S_L_S(data_ptr),new); /* new is the next prime*/ inserted = 0L; ptr = S_N_S(a_copy); while (ptr != NULL) { num_ptr = S_PO_S(ptr); if (einsp(num_ptr) || nullp(num_ptr)) { ptr = S_L_N(ptr); continue; } nb_quores(num_ptr,new,quo,rem); if (nullp(rem)) { copy(quo,num_ptr); if (not inserted) { insert(new,prime_list,NULL,NULL); inserted = 1L; } } ptr = S_L_N(ptr); } data_ptr = S_L_N(data_ptr); } if (not inserted) FREESELF(new); else new = CALLOCOBJECT(); make_monopoly_sqrad(S_N_S(a_copy),new); /* reconstitute the sqrad */ if (convert_sqrad_scalar(new) == ERROR) { FREESELF(S_N_D(a)); FREEALL(prime_list); find_sqrad_data(a); } else { FREEALL(S_N_D(a)); S_N_D(a) = prime_list; } FREEALL(quo); FREEALL(rem); FREEALL(new); FREEALL(a_copy); return(OK); ENDR("adjust_sqrad_data"); } /* a: the sqrad; b: the radical; c: the conjugate */ INT conj_sqrad(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { OP la, lb, rem, minus, ptr, new; #ifdef SQRADTRUE if (not EMPTYP(c)) /* AK 060993 */ freeself(c); la = CALLOCOBJECT(); lb = CALLOCOBJECT(); rem = CALLOCOBJECT(); minus = CALLOCOBJECT(); M_I_I(-1L,minus); init(MONOPOLY,la); init(MONOPOLY,lb); ptr = S_N_S(a); if (EQ(b,minus) == TRUE) while (ptr != NULL) { new = CALLOCOBJECT(); copy(S_L_S(ptr),new); if (LT(S_MO_S(new),cons_null) == TRUE) insert_list(new,lb,NULL,NULL); else insert_list(new,la,NULL,NULL); ptr = S_L_N(ptr); } else while (ptr != NULL) { new = CALLOCOBJECT(); copy(S_L_S(ptr),new); mod(S_MO_S(new),b,rem); if (nullp(rem)) /* AK 120891 */ insert_list(new,lb,NULL,NULL); else insert_list(new,la,NULL,NULL); ptr = S_L_N(ptr); } if (empty_listp(lb)) insert_zero_into_monopoly(lb); mult_apply_scalar_monopoly(minus,lb); insert(lb,la,NULL,NULL); if (c == a) freeall(S_N_S(a)); else { init(SQ_RADICAL,c); copy(S_N_D(a),S_N_D(c)); } remove_zero_terms(la); if (S_N_S(c) != NULL) { freeall(S_N_S(c)); /* AK 060993 */ } S_N_S(c) = la; freeall(rem); freeall(minus); return(OK); #else /* SQRADTRUE */ error("conj_sqrad: SQ_RADICAL not available"); return(ERROR); #endif /* SQRADTRUE */ } #ifdef SQRADTRUE INT squareroot_integer(a,b) OP a,b; /* AK 040291 V1.2 */ /* AK 200891 V1.3 */ { INT erg = OK; OP c; CTTO(INTEGER,LONGINT,"squareroot_integer(1)",a); CTO(EMPTY,"squareroot_integer(2)",b); if (NULLP_INTEGER(a)) { M_I_I(0,b); goto ende; } c = CALLOCOBJECT(); erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,c); COPY_INTEGER(a,S_PO_S(c)); M_I_I(1,S_PO_K(c)); erg += make_monopoly_sqrad(c,b); FREEALL(c); ende: ENDR("squareroot_integer"); } INT squareroot_longint(a,b) OP a,b; /* AK 040291 V1.2 */ /* AK 200891 V1.3 */ { return squareroot_integer(a,b); } #endif /* SQRADTRUE */ #ifdef SQRADTRUE INT squareroot_bruch(a,b) OP a,b; /* AK 040291 V1.2 */ /* AK 200891 V1.3 */ /* 04.10.91: TPMcD */ { INT erg=OK; OP c,d; CTO(BRUCH,"squareroot_bruch(1)",a); CTO(EMPTY,"squareroot_bruch(2)",b); c = CALLOCOBJECT(); d = CALLOCOBJECT(); MULT(S_B_O(a),S_B_U(a),c); erg += squareroot(c,b); erg += invers(S_B_U(a),d); MULT_APPLY(d,b); FREEALL(c); FREEALL(d); CTO(SQ_RADICAL,"squareroot_bruch(e2)",b); ENDR("squareroot_bruch"); } INT convert_sqrad_scalar(a) OP a; /* 5.04.91: TPMcD. */ /* AK 200891 V1.3 */ { INT ret = ERROR; OP tmp; if (S_O_K(a) != SQ_RADICAL || S_L_N(S_N_S(a)) != NULL) return(ret); tmp = S_PO_S(S_N_S(a)); if (not einsp(tmp) && not nullp(tmp)) return(ret); ret = OK; if (nullp(tmp)) { m_i_i(0L,a); return(ret); } tmp = CALLOCOBJECT(); copy(S_PO_K(S_N_S(a)),tmp); copy(tmp,a); freeall(tmp); return OK; } #endif /* SQRADTRUE */ /* Convert the square root of an integer a to a cyclotomic number */ INT convert_radical_cyclo(a,b) OP a,b; /* AK 200891 V1.3 */ /* 29.10.91: TPMcD */ { INT myeven, posi, last = 1L,ff=0; OP new, ptr, mono_ptr; INT erg = OK; # ifdef NUMBERTRUE OP k,m,mpos,x,y,z,w,atmp,four; CTTO(INTEGER,LONGINT,"convert_radical_cyclo(1)",a); if (EINSP(a)) ff=1; k = CALLOCOBJECT(); m = CALLOCOBJECT(); mpos = CALLOCOBJECT(); x = CALLOCOBJECT(); y = CALLOCOBJECT(); z = CALLOCOBJECT(); w = CALLOCOBJECT(); four = CALLOCOBJECT(); if (not negp(a) && nb_square_root(a,k) == OK) { make_scalar_cyclo(k,b); goto exit_label; } if (a == b) { atmp = CALLOCOBJECT(); copy(a,atmp); } else atmp = a; FREESELF(b); INIT_CYCLO(b); mono_ptr = CALLOCOBJECT(); init(MONOPOLY,mono_ptr); M_I_I(4L,four); integer_factor_1(atmp,cons_zwei,cons_zwei,m,y,NULL); /* a = 4k * 2l * m * l=0 ,m=1(4): return 2k * r(m) * l=0 ,m=3(4): return 2(k-1) * r(4*m) * l=1 return 2(k-1) * r(8*m) */ ptr = y; if (empty_listp(ptr)) /* a > 0 and a is odd */ { myeven = 0L; posi = 1L; } else if (EQ(S_PO_S(ptr),cons_zwei)) /* a > 0 and a is even */ { myeven = 1L; posi = 1L; } else { ptr = S_L_N(ptr); if (ptr == NULL) /* a < 0 and a is odd */ { myeven = 0L; posi = 0L; } else { myeven = 1L; posi = 0L; } } if (!posi) addinvers_apply(m); if (myeven) { nb_quores(S_PO_K(ptr),cons_zwei,k,z); if (NULLP(z)) /* AK 120891 */ /* a = 4k * m */ last = 0L; hoch(cons_zwei,k,w); /* w = 2k */ } else { copy(cons_eins,w); last = 0L; } if (!last) { mod(m,four,z); if (!EINSP(z)) { div_apply(w,cons_zwei); MULT_APPLY(four,m); } } else { div_apply(w,cons_zwei); /* w := w/2 */ MULT_APPLY(four,m); MULT_APPLY(cons_zwei,m); } copy(m,mpos); if (NEGP(mpos)) addinvers_apply(mpos); make_coprimes(mpos,y); ptr = y; while (ptr != NULL) { if (kronecker(m,S_L_S(ptr),z) == OK) { new = CALLOCOBJECT(); m_sk_mo(S_L_S(ptr),z,new); insert(new,mono_ptr,add_koeff,NULL); } ptr = S_L_N(ptr); } remove_zero_terms(mono_ptr); make_index_monopoly_cyclo(mpos,mono_ptr,b,0L); MULT_APPLY(w,b); FREEALL(mono_ptr); if (a == b) FREEALL(atmp); exit_label: FREEALL(k); FREEALL(m); FREEALL(mpos); FREEALL(x); FREEALL(y); FREEALL(z); FREEALL(w); FREEALL(four); erg += standardise_cyclo_0(b,basis_type); { /* so to get the positive squareroot */ double realpart=0.0; double fac = 6.2830 / ((double) S_N_DCII(b) ); FORALL(w,S_N_S(b), { realpart += (double)(S_MO_KI(w)) * cos( fac* (double)S_I_I(S_MO_S(w)) ); }); if (realpart < 0.0 ) if (ff==0) ADDINVERS_APPLY(b); } # endif CTO(ANYTYPE,"convert_radical_cyclo(e2)",b); ENDR("convert_radical_cyclo"); } # ifdef NUMBERTRUE INT convert_sqrad_cyclo(a,b) OP a,b; /* 29.10.91: TPMcD */ { OP c, ptr; INT erg = OK; CTO(SQ_RADICAL,"convert_sqrad_cyclo(1)",a); CE2(a,b,convert_sqrad_cyclo); M_I_I(0,b); c = CALLOCOBJECT(); ptr = S_N_S(a); while (ptr != NULL) { convert_radical_cyclo(S_PO_S(ptr),c); MULT_APPLY(S_PO_K(ptr),c); ADD_APPLY(c,b); ptr = S_L_N(ptr); } FREEALL(c); ENDR("convert_sqrad_cyclo"); } #endif /* NUMBERTRUE */ /****************** fields_3.c **********************/ /* 26.07.91: TPMcD. */ /*************************************************************/ /* CYCLOTOMIC */ /* a : the index, b : the monopoly, c : the result */ INT trans_index_monopoly_cyclo(a,b,c) OP a,b,c; /* AK 300791 for compatibility */ /* AK 200891 V1.3 */ { return make_index_monopoly_cyclo(a,b,c,POWER_REDUCE); } static INT make_index_monopoly_cyclo(a,b,c,tid) OP a,b,c; INT tid; /* 30.05.90: TPMcD. */ /* 3.04.91: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { OP c_tmp; INT flag = 0L; INT erg = OK; CYCLO_DATA *c_ptr = NULL; if (S_O_K(b) != MONOPOLY) error("make_index_monopoly_cyclo: 2nd parameter is wrong type\n"); if ((c_ptr = add_cyclo_data(a)) == (CYCLO_DATA *) NULL) error("make_index_monopoly_cyclo: unable to create cyclotomic data\n"); if (c == b) { flag = 1L; c_tmp = CALLOCOBJECT(); } else { FREESELF(c); INIT_CYCLO(c); c_tmp = S_N_S(c); } init(MONOPOLY, c_tmp); if (empty_listp(c_tmp)) insert_zero_into_monopoly(c_tmp); copy(b, c_tmp); if (flag) { init(CYCLOTOMIC,c); S_N_S(c) = c_tmp; } S_N_DC(c) = c_ptr; if (tid != NO_REDUCE) standardise_cyclo_0(c,tid); ENDR("make_index_monopoly_cyclo"); } INT standardise_cyclo(a) OP a; /* 25.10.91: TPMcD */ { return(standardise_cyclo_0(a,basis_type)); } static INT standardise_cyclo_0(a,tid) OP a; INT tid; /* 09.09.90: TPMcD. */ /* 4.04.91: TPMcD. */ /* AK 200891 V1.3 */ /* 25.10.91: TPMcD */ { INT erg=OK, ret = ERROR; CYCLO_DATA *c_ptr; OP ptr, new, mono, e, poly_eins, poly_zwei; /* OP half=NULL; */ if (S_O_K(a) != CYCLOTOMIC || tid == NO_REDUCE) return(OK); /* if (EVEN(S_N_DC(a)->index)) { half = CALLOCOBJECT(); ganzdiv(S_N_DC(a)->index,cons_zwei,half); } */ ptr = S_N_S(a); c_ptr = S_N_DC(a); mono = CALLOCOBJECT(); init(MONOPOLY,mono); e = CALLOCOBJECT(); if ( not empty_listp(ptr)) while (ptr != NULL) { erg = mod(S_PO_S(ptr),c_ptr->index,e); new = CALLOCOBJECT(); m_sk_mo(e,S_PO_K(ptr),new); /* if (EVEN(c_ptr->index)) if (GE(e,half)) { sub_apply(half,S_MO_S(new)); ADDINVERS_APPLY(S_MO_K(new)); } */ insert(new,mono,add_koeff,NULL); ptr = S_L_N(ptr); } FREEALL(e); /* if (EVEN(S_N_DC(a)->index)) FREEALL(half); */ if (empty_listp(mono)) insert_zero_into_monopoly(mono); switch((int)tid) { case (int)POWER_REDUCE: poly_zwei = mono; break; case (int)STD_BASIS: poly_eins = CALLOCOBJECT(); poly_zwei = CALLOCOBJECT(); quores_monopoly(mono,c_ptr->poly,poly_eins,poly_zwei); FREEALL(mono); FREEALL(poly_eins); break; default: return error("standardise_cyclo_0: unknown cyclotomic basis"); break; } FREEALL(S_N_S(a)); S_N_S(a) = poly_zwei; ret = OK; return(ret); ENDR("standardise_cyclo_0"); } #ifdef CYCLOTRUE INT make_scalar_cyclo(a,b) OP a,b; /* 5.04.91: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { OP c = CALLOCOBJECT(); OP d = CALLOCOBJECT(); M_I_I(1L,c); b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,d); copy(a,S_PO_K(d)); M_I_I(0L,S_PO_S(d)); make_index_monopoly_cyclo(c,d,b,NO_REDUCE); freeall(c); freeall(d); return(OK); } INT make_index_power_cyclo(a,c,d) OP a,c,d; { return make_index_coeff_power_cyclo(a,cons_eins,c,d); } INT make_index_coeff_power_cyclo(a,b,c,d) OP a,b,c,d; /* 30.05.90: TPMcD. */ /* 17.07.91: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { INT erg = OK; erg += init(CYCLOTOMIC,d); erg += b_skn_mp(CALLOCOBJECT(),CALLOCOBJECT(),NULL,S_N_S(d)); erg += mod(c,a,S_PO_S(S_N_S(d))); erg += copy(b,S_PO_K(S_N_S(d))); if (S_N_DC(d) != NULL) error("internal error:MIC1"); S_N_DC(d) = add_cyclo_data(a); if (space_saving) convert_cyclo_scalar(d); ENDR("make_index_coeff_power_cyclo"); } INT scan_cyclo(a) OP a; /* AK 240191 V1.2 */ /* a becomes cyclotomic */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { OP b = CALLOCOBJECT(); OP c = CALLOCOBJECT(); INT erg = OK; erg += printeingabe("degree of cyclotomic field"); erg += scan(INTEGER,b); erg += printeingabe("self of cyclotomic field"); erg += scan(MONOPOLY,c); erg += make_index_monopoly_cyclo(b,c,a,basis_type); erg += freeall(b); erg += freeall(c); return erg; } #endif /* CYCLOTRUE */ /* a: the scalar, b: the cyclo, c: the result */ INT add_scalar_cyclo(a,b,c) OP a,b,c; /* 30.05.90: TPMcD. */ /* AK 080891 V1.3 */ /* 23.10.91: TPMcD */ { OP ptr; INT erg = OK; #ifdef CYCLOTRUE if (c == a) error("First and third arguments equal\n"); if (c != b) copy(b,c); ptr = CALLOCOBJECT(); erg += init(MONOPOLY,ptr); C_L_S(ptr,CALLOCOBJECT()); erg += m_sk_mo(cons_null,a,S_L_S(ptr)); erg += add_apply(ptr,S_N_S(c)); erg += freeall(ptr); if (space_saving) convert_cyclo_scalar(c); #endif /* CYCLOTRUE */ return erg; } /* a: the scalar, b: the cyclo, c: the result */ #ifdef CYCLOTRUE INT mult_apply_scalar_cyclo(a,b) OP a,b; /* AK 060498 V2.0 */ { OP c; INT erg = OK; CTO(CYCLOTOMIC,"mult_apply_scalar_cyclo",b); c = CALLOCOBJECT(); SWAP(c,b); erg += mult_scalar_cyclo(a,c,b); erg += freeall(c); ENDR("mult_apply_scalar_cyclo"); } INT mult_scalar_cyclo(a,b,c) OP a, b, c; /* 06.09.90: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { INT erg = OK; CTO(CYCLOTOMIC,"mult_scalar_cyclo(2)",b); CTO(EMPTY,"mult_scalar_cyclo(3)",c); if (NULLP(a)) { M_I_I(0,c); } else { erg += init(CYCLOTOMIC,c); FREESELF(S_N_S(c)); erg += mult_scalar_monopoly(a,S_N_S(b),S_N_S(c)); S_N_DC(c) = S_N_DC(b); if (space_saving) convert_cyclo_scalar(c); } ENDR("mult_scalar_cyclo"); } #endif /* a,b: the cyclos, c: the result */ INT add_cyclo_cyclo(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { return( add_cyclo_cyclo_0(a,b,c,basis_type) ); } static INT add_cyclo_cyclo_0(a,b,c,tid) OP a,b,c; INT tid; /* 06.09.90: TPMcD. */ /* 5.04.91: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { OP temp_eins, temp_zwei, temp_drei, temp_vier; INT erg = OK; if (S_O_K(a) != CYCLOTOMIC || S_O_K(b) != CYCLOTOMIC) return( error ("add_cyclo_cyclo_0: argument not CYCLOTOMIC") ); temp_eins = CALLOCOBJECT(); temp_zwei = CALLOCOBJECT(); temp_drei = CALLOCOBJECT(); temp_vier = CALLOCOBJECT(); copy(S_N_S(a),temp_eins); copy(S_N_S(b),temp_zwei); ggt(S_N_DCI(a),S_N_DCI(b),temp_drei); ganzdiv(S_N_DCI(a),temp_drei,temp_vier); raise_power_monopoly(temp_vier,temp_zwei); ganzdiv(S_N_DCI(b),temp_drei,temp_vier); raise_power_monopoly(temp_vier,temp_eins); MULT_APPLY(S_N_DCI(a),temp_vier); init(CYCLOTOMIC, c); FREESELF(S_N_S(c)); add_monopoly_monopoly(temp_eins,temp_zwei,S_N_S(c)); S_N_DC(c) = add_cyclo_data(temp_vier); if (tid != NO_REDUCE) standardise_cyclo_0(c,tid); if (space_saving) convert_cyclo_scalar(c); FREEALL(temp_eins); FREEALL(temp_zwei); FREEALL(temp_drei); FREEALL(temp_vier); ENDR("nb.c:add_cyclo_cyclo_0"); } INT mult_cyclo_cyclo(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ { INT erg = OK; CTO(CYCLOTOMIC,"mult_cyclo_cyclo(1)",a); CTO(CYCLOTOMIC,"mult_cyclo_cyclo(2)",b); CTO(EMPTY,"mult_cyclo_cyclo(3)",c); erg += mult_cyclo_cyclo_0(a,b,c,basis_type); /* AK return inserted */ CTO(ANYTYPE,"mult_cyclo_cyclo(i3)",c); erg += standardise_cyclo_0(c,basis_type); CTO(ANYTYPE,"mult_cyclo_cyclo(e3)",c); ENDR("mult_cyclo_cyclo"); } static INT mult_cyclo_cyclo_0(a,b,c,tid) OP a,b,c; INT tid; /* 06.09.90: TPMcD. */ /* 5.04.91: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { OP temp_eins, temp_zwei, temp_drei, temp_vier; INT erg = OK; CTO(CYCLOTOMIC,"mult_cyclo_cyclo_0(1)",a); CTO(CYCLOTOMIC,"mult_cyclo_cyclo_0(2)",b); if ( (NULLP(a) || NULLP(b)) && space_saving ) { m_i_i(0L,c); return(OK); } temp_eins = CALLOCOBJECT(); temp_zwei = CALLOCOBJECT(); temp_drei = CALLOCOBJECT(); temp_vier = CALLOCOBJECT(); COPY(S_N_S(a),temp_eins); COPY(S_N_S(b),temp_zwei); ggt(S_N_DCI(a),S_N_DCI(b),temp_drei); ganzdiv(S_N_DCI(a),temp_drei,temp_vier); raise_power_monopoly(temp_vier,temp_zwei); ganzdiv(S_N_DCI(b),temp_drei,temp_vier); raise_power_monopoly(temp_vier,temp_eins); MULT_APPLY(S_N_DCI(a),temp_vier); init(CYCLOTOMIC, c); FREESELF(S_N_S(c)); mult_monopoly_monopoly(temp_eins,temp_zwei,S_N_S(c)); if ((S_N_DC(c) = add_cyclo_data(temp_vier)) == (CYCLO_DATA *) NULL) error("Unable to find cyclotomic data\n"); if (tid != NO_REDUCE) standardise_cyclo_0(c,tid); if (space_saving) convert_cyclo_scalar(c); FREEALL(temp_eins); FREEALL(temp_zwei); FREEALL(temp_drei); FREEALL(temp_vier); ENDR("mult_cyclo_cyclo_0"); } INT add_cyclo(a,b,c) OP a,b,c; /* AK 070891 V1.3 */ { INT erg = OK; #ifdef CYCLOTRUE switch(S_O_K(b)) { case INTEGER: case LONGINT: case SQ_RADICAL: case BRUCH: erg += add_scalar_cyclo(b,a,c); break; case CYCLOTOMIC: erg += add_cyclo_cyclo(a,b,c); break; case POLYNOM: erg += add_scalar_polynom(a,b,c); break; default: printobjectkind(b); erg += error("add_cyclo: wrong second type\n"); break; } convert_cyclo_scalar(c); #endif return erg; } INT mult_cyclo(a,b,c) OP a,b,c; /* 24.07.91: TPMcD. */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(CYCLOTOMIC,"mult_cyclo(1)",a); CTO(EMPTY,"mult_cyclo(3)",c); if (NULLP(a)){ M_I_I(0,c); goto ende; } if (NULLP(b)){ M_I_I(0,c); goto ende; } switch(S_O_K(b)) { case INTEGER: case SQ_RADICAL: /* AK 220891 */ case LONGINT: case BRUCH: erg += mult_scalar_cyclo(b,a,c); break; #ifdef MATRIXTRUE case MATRIX: erg += mult_scalar_matrix(a,b,c); break; #endif /* MATRIXTRUE */ #ifdef POLYTRUE case SCHUR: case POW_SYM: case HOM_SYM: case ELM_SYM: case MONOMIAL: case POLYNOM: erg += mult_scalar_polynom(a,b,c); break; #endif /* POLYTRUE */ #ifdef SCHUBERTTRUE case SCHUBERT: erg += mult_scalar_schubert(a,b,c); break; #endif /* SCHUBERTTRUE */ case VECTOR: erg += mult_scalar_vector(a,b,c); break; case CYCLOTOMIC: erg += mult_cyclo_cyclo(a,b,c); break; default: WTO("mult_cyclo(2)",b); break; } convert_cyclo_scalar(c); ende: ENDR("mult_cyclo"); } INT addinvers_cyclo(a,b) OP a,b; /* AK 200891 V1.3 */ { INT erg = OK; CTO(CYCLOTOMIC,"addinvers_cyclo(1)",a); CTO(EMPTY,"addinvers_cyclo(2)",b); erg += mult_scalar_cyclo(cons_negeins,a,b); CTO(CYCLOTOMIC,"addinvers_cyclo(e2)",b); ENDR("addinvers_cyclo"); } /* a: the cyclo, b: the auto, c: the conjugate */ INT conj_cyclo(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { # ifdef CYCLOTRUE if (S_O_K(a) != CYCLOTOMIC) return(ERROR); if (c != a) copy(a,c); raise_power_monopoly(b,S_N_S(c)); standardise_cyclo_0(c,basis_type); # endif return(OK); } /* a: the cyclo, b: the inverse */ INT invers_cyclo(a,b) OP a,b; /* AK 200891 V1.3 */ { INT ret = ERROR; # ifdef CYCLOTRUE OP c = CALLOCOBJECT(); ret = invers_cyclo_norm(a,b,c); freeall(c); # endif return(ret); } /* a: the cyclo, b: the inverse, c: the norm */ static INT invers_cyclo_norm(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ { INT flag = 0L, saving = space_saving; # ifdef CYCLOTRUE OP ptr, tmp, b_tmp; if (S_O_K(a) != CYCLOTOMIC) return(ERROR); if (nullp_cyclo(a)) return(error("invers_cyclo_norm: cannot invert 0\n")); if (c == a || c == b) return(error("invers_cyclo_norm: illegal 3rd parameter\n")); if (b == a) { b_tmp = CALLOCOBJECT(); flag = 1L; } else { if (not EMPTYP(b)) /* AK */ freeself(b); b_tmp = b; } space_saving = FALSE; tmp = CALLOCOBJECT(); /* M_I_I(1L,tmp); */ make_scalar_cyclo(cons_eins,b_tmp); ptr = S_N_DC(a)->autos; ptr = S_L_N(ptr); /* Skip the trivial automorphism */ while (ptr != NULL) { conj_cyclo(a,S_L_S(ptr),tmp); mult_cyclo_cyclo_0(tmp,b_tmp,b_tmp,POWER_REDUCE); ptr = S_L_N(ptr); } mult_cyclo_cyclo_0(a,b_tmp,tmp,basis_type); if (convert_cyclo_scalar(tmp) == ERROR) { freeall(tmp); if (flag) freeall(b_tmp); return(error("invers_cyclo_norm: norm is not scalar\n")); } copy(tmp,c); if (negp(tmp)) { mult_scalar_sqrad(cons_negeins,b_tmp,b_tmp); addinvers_apply(tmp); } invers(tmp,tmp); mult_apply_scalar_cyclo(tmp,b_tmp); if (flag) { copy(b_tmp,b); freeall(b_tmp); } freeall(tmp); space_saving = saving; # endif return(OK); } INT add_apply_cyclo(a,b) OP a,b; /* AK 200891 V1.3 */ { INT erg = OK; OP c; CTO(CYCLOTOMIC,"add_apply_cyclo(1)",a); c = CALLOCOBJECT(); SWAP(c,b); erg += add_cyclo(a,c,b); FREEALL(c); ENDR("add_apply_cyclo"); } INT mult_apply_cyclo(a,b) OP a,b; /* AK 200891 V1.3 */ { INT ret; #ifdef CYCLOTRUE OP c; c = CALLOCOBJECT(); ret = mult_cyclo(a,b,c); copy(c,b); freeall(c); #endif return(ret); } INT addinvers_apply_cyclo(a) OP a; /* AK 200891 V1.3 */ { OP b; INT erg = OK; CTO(CYCLOTOMIC,"addinvers_apply_cyclo(1)",a); b = CALLOCOBJECT(); SWAP(b,a); erg += addinvers_cyclo(b,a); FREEALL(b); ENDR("addinvers_apply_cyclo"); } INT nullp_cyclo(a) OP a; /* AK 200891 V1.3 */ { #ifdef CYCLOTRUE if (S_O_K(a) != CYCLOTOMIC) return(ERROR); if (EMPTYP(S_N_S(a))) { error("nullp_cyclo: cyclo with empty self\n"); return(TRUE); } return(nullp_monopoly(S_N_S(a))); #else return(ERROR); #endif } #ifdef CYCLOTRUE INT comp_cyclo(a,b) OP a,b; /* AK 200891 V1.3 */ { return(comp_list(S_N_S(a),S_N_S(b))); } #endif /* CYCLOTRUE */ # ifdef CYCLOTRUE INT convert_cyclo_scalar(a) OP a; /* 5.04.91: TPMcD. */ /* AK 200891 V1.3 */ { INT ret = ERROR; OP tmp; if (S_O_K(a) != CYCLOTOMIC || S_L_N(S_N_S(a)) != NULL) goto exit_label; tmp = S_PO_S(S_N_S(a)); if (not nullp(tmp)) goto exit_label; tmp = CALLOCOBJECT(); copy(S_PO_K(S_N_S(a)),tmp); copy(tmp,a); freeall(tmp); ret = OK; exit_label: return(ret); } #endif /* CYCLOTRUE */ #ifdef CYCLOTRUE static INT fprint_cyclo(f,a) FILE *f; OP a; /* 25.09.91: TPMcD. */ { INT myfirst = 1L, flag; OP ptr; standardise_cyclo_0(a,basis_type); ptr = S_N_S(a); zeilenposition += 2L; if (nullp_cyclo(a)) { fprintf(f," 0"); return(OK); } while (ptr != NULL) { flag = 0L; if (zeilenposition > 60L) { zeilenposition = 0L; fprintf(f,"\n"); } if (!negp(S_PO_K(ptr)) && !myfirst) fprintf(f," +"); if (negeinsp(S_PO_K(ptr))) { flag = 1L; fprintf(f," -"); } else if (!einsp(S_PO_K(ptr))) { fprintf(f," "); fprint(f,S_PO_K(ptr)); } else { fprintf(f," "); flag = 1L; } if (not nullp(S_PO_S(ptr))) { fprintf(f," E("); fprint(f,S_N_DCI(a)); fprintf(f,")"); if (!einsp(S_PO_S(ptr))) { fprintf(f,"^"); fprint(f,S_PO_S(ptr)); } zeilenposition += 5L; } else if (flag) fprintf(f," 1"); ptr = S_L_N(ptr); myfirst = 0L; } return(OK); } #endif /* CYCLOTRUE */ #ifdef CYCLOTRUE INT tex_cyclo(a) OP a; /* 4.04.91: TPMcD. */ /* AK 200891 V1.3 */ /* 23.10.91: TPMcD */ { INT myfirst = 1L; OP ptr = S_N_S(a); if (nullp_cyclo(a)) { fprintf(texout," 0\n"); return(OK); } fprintf(texout,"\n"); while (ptr != NULL) { if (!negp(S_PO_K(ptr)) && !myfirst) fprintf(texout," + {"); else fprintf(texout,"{"); tex(S_PO_K(ptr)); if (not nullp(S_PO_S(ptr))) { fprintf(texout,"} \\omega_{"); tex(S_N_DCI(a)); fprintf(texout,"} {"); tex(S_PO_S(ptr)); } fprintf(texout,"}\n"); ptr = S_L_N(ptr); myfirst = 0L; } fprintf(texout,"\n"); return(OK); } #endif /* CYCLOTRUE */ /* ROUTINES RELATING TO THE MAINTENANCE OF CYCLOTOMIC DATA */ # ifdef CYCLOTRUE /*Reads the table of cyclos from the file CYCLOS.DAT. The first entry */ /*should be no_cyclos, then the list of cyclo_data. Returns OK if the */ /*table is set; otherwise, returns ERROR. */ static INT setup_cyclotomic_table(filename) char *filename; /* 30.08.90: TPMcD */ /* AK 200891 V1.3 */ { INT i=0; FILE *f; CYCLO_DATA *ptr; char name[50], *char_ptr; if (cyclo_table_set || filename == NULL) return(OK); if ((f = fopen(filename,"r")) == NULL) { printf("\nFile containing cyclo data: "); char_ptr = name; while( (*char_ptr = fgetc(stdin)) != '\n') { if (myisspace(*char_ptr)) continue; char_ptr++; i++; if (i > (INT)48) break; } *char_ptr = /* NULL; AK 290494 */ '\0'; if (strlen(name) == 0) return(ERROR); if ((f = fopen(name,"r")) == NULL) { printf("Unable to open %s\n",name); return(ERROR); } } if ( fscanf(f," %ld",&zzno_cyclos) == 0 || zzno_cyclos < 1L || (zzcyclo_table = (CYCLO_DATA *) SYM_calloc((int)zzno_cyclos,sizeof(CYCLO_DATA)) ) == NULL ) { zzno_cyclos = 0L; printf("\nCyclo data table creation error"); return(ERROR); } ptr = zzcyclo_table - 1; for (i=0L;iindex = CALLOCOBJECT(); objectread(f,ptr->index); ptr->deg = CALLOCOBJECT(); objectread(f,ptr->deg); ptr->poly = CALLOCOBJECT(); objectread(f,ptr->poly); ptr->autos = CALLOCOBJECT(); objectread(f,ptr->autos); } cyclo_table_set = 1L; fclose(f); return(OK); } static CYCLO_DATA *add_cyclo_data(index) OP index; /* AK 200891 V1.3 */ { CYCLO_DATA *ptr = NULL; OP ptr_eins, ptr_zwei=NULL; if ((ptr = cyclo_ptr(index)) != NULL) return(ptr); ptr = (CYCLO_DATA *) SYM_calloc(1,sizeof(CYCLO_DATA)); if (ptr == NULL) return(NULL); ptr->index = CALLOCOBJECT(); COPY(index,ptr->index); ptr->poly = CALLOCOBJECT(); if (make_cyclotomic_monopoly(index,ptr->poly) == ERROR) { SYM_free(ptr); return(NULL); } ptr_eins = ptr->poly; while(ptr_eins != NULL) { ptr_zwei = ptr_eins; ptr_eins = S_L_N(ptr_eins); } ptr->deg = CALLOCOBJECT(); COPY(S_PO_S(ptr_zwei),ptr->deg); ptr->autos = CALLOCOBJECT(); make_coprimes(ptr->index,ptr->autos); ptr_eins = CALLOCOBJECT(); init(LIST,ptr_eins); /* Some compilers require this cast, others dislike it */ /* (CYCLO_DATA *) S_L_S(ptr_eins) = ptr; */ C_L_S(ptr_eins,ptr); /* S_L_N(ptr_eins) = NULL; */ C_L_N(ptr_eins,NULL); if (cyclo_list_set) S_L_N(zzcyclo_tail) = ptr_eins; else { cyclo_list_set = 1L; zzcyclo_list = ptr_eins; } zzcyclo_tail = ptr_eins; return(ptr); } static CYCLO_DATA *cyclo_ptr(index) OP index; /* AK 200891 V1.3 */ { CYCLO_DATA *ptr = NULL; OP list_ptr; INT i; if (cyclo_table_set) { ptr = zzcyclo_table - 1; for (i=0L;iindex) == TRUE) return(ptr); } } if (cyclo_list_set) { list_ptr = zzcyclo_list; while (list_ptr != NULL) { ptr = (CYCLO_DATA *) S_L_S(list_ptr); if (ptr == NULL) error("cyclo_ptr: null pointer\n"); if (EQ(index,ptr->index) == TRUE) return(ptr); list_ptr = S_L_N(list_ptr); } } return(NULL); } static INT free_cyclo_list() /* 29.10.91: TPMcD */ { OP list_ptr; OBJECTSELF list_self; CYCLO_DATA *cp; list_ptr = zzcyclo_list; while (list_ptr != NULL) { list_self = S_O_S(list_ptr); cp = (CYCLO_DATA *)S_L_S(list_ptr); freeall(cp->index); freeall(cp->deg); freeall(cp->poly); freeall(cp->autos); SYM_free(cp); C_L_S(list_ptr,NULL); /* Wg speicherverwaltung */ list_ptr = S_L_N(list_ptr); } return(OK); } INT print_cyclo_data(ptr) CYCLO_DATA *ptr; /* AK 200891 V1.3 */ { printf("Index "); print(ptr->index); printf("\tDegree "); println(ptr->deg); printf("Polynomial "); println(ptr->poly); printf("Automorphism exponents "); println(ptr->autos); return OK; } static INT free_cyclo_table() /* AK 310893 */ { CYCLO_DATA *ptr; INT i; if (!cyclo_table_set) return(ERROR); ptr = zzcyclo_table; for (i=0L;iindex); freeall(ptr->deg); freeall(ptr->poly); freeall(ptr->autos); ptr++; } return(OK); } INT print_cyclo_table() /* AK 200891 V1.3 */ { CYCLO_DATA *ptr; INT i; if (!cyclo_table_set) return(ERROR); printf("Number of cyclo data on table: %ld\n",zzno_cyclos); ptr = zzcyclo_table; for (i=0L;i (INT)48) break; } *char_ptr = /* NULL; AK 290494 */ '\0'; if (strlen(name) == 0) return(ERROR); if ((f = fopen(name,"r+")) == NULL) { if((f = fopen(name,"w")) == NULL) { printf("Unable to open %s\n",name); return(ERROR); } else new = 1L; } } else strcpy(name,filename); if (new) { fprintf(f," \n\n"); printf("Initialising %s\n",name); i = 0L; } else { fseek(f,0L,0); fscanf(f,"%ld",&i); fseek(f,0L,2); printf("Cyclo data being appended to file %s.\n",name); } list_ptr = zzcyclo_list; while (list_ptr != NULL) { ptr = (CYCLO_DATA *) S_L_S(list_ptr); fprintf(f,"\n"); objectwrite(f,ptr->index); objectwrite(f,ptr->deg); objectwrite(f,ptr->poly); objectwrite(f,ptr->autos); list_ptr = S_L_N(list_ptr); i++; } fseek(f,0L,0); fprintf(f,"%8ld",i); fclose(f); return(OK); } #endif #ifdef NUMBERTRUE INT test_number() { OP a = CALLOCOBJECT(); OP b = CALLOCOBJECT(); printeingabe("test_number: squareroot(2L,a)"); squareroot(cons_zwei,a); println(a); printeingabe("test_number: squareroot(11L,a)^-1"); m_i_i(19L,b); squareroot(b,a); invers(a,b); println(b); printeingabe("test_number: euler_phi(311L,a)"); m_i_i(311L,b); euler_phi(b,a); println(b); freeall(a); freeall(b); return OK; } #endif /* NUMBERTRUE */ INT t_MONOPOLY_POLYNOM(a,b) OP a,b; /* AK 171194 */ /* AK 170206 V3.0 */ { INT erg = OK; CTO(MONOPOLY,"t_MONOPOLY_POLYNOM(1)",a); CE2(a,b,t_MONOPOLY_POLYNOM); { OP c; init(POLYNOM,b); if (S_L_S(a) != NULL) { while (a != NULL) { c = CALLOCOBJECT(); m_iindex_iexponent_monom(0,S_I_I(S_PO_S(a)),c); copy(S_PO_K(a),S_PO_K(c)); insert(c,b,NULL,NULL); a = S_L_N(a); } } } ENDR("t_MONOPOLY_POLYNOM"); } INT invers_monopoly(lau, res) OP lau,res; { INT erg = OK; CTO(MONOPOLY,"invers_monopoly(1)",lau); CTO(EMPTY,"invers_monopoly(2)",res); erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),res); M_I_I((INT)1,S_B_O(res)); erg += copy(lau,S_B_U(res)); C_B_I(res,GEKUERZT); ENDR("invers_monopoly"); } INT degree_monopoly(mp,dg) OP mp,dg; /*CC 010496*/ /* -1 if null */ { /* Puts in dg the degree of the MONOPOLY object mp*/ OP z,za=NULL; INT erg = OK; CTO(MONOPOLY,"degree_monopoly(1)",mp); FREESELF(dg); if(NULLP(mp)) M_I_I(-1L,dg); else { z=mp; while(z !=NULL) { za=z; z=S_L_N(z); } COPY(S_PO_S(za),dg); } ENDR("degree_monopoly"); } /* Puts in ld the leading coefficient of the MONOPOLY object mp. */ INT ldcf_monopoly(mp,ld) OP mp,ld; { INT erg=OK; OP z,za=NULL; FREESELF(ld); if (NULLP(mp)) error("ldcf_monopoly: null monopoly"); else { z=mp; while(z !=NULL) { za=z; z=S_L_N(z); } COPY(S_PO_K(za),ld); } ENDR("ldcf_monopoly"); } INT has_one_variable(a) OP a; /* AK 310106 */ { /* Returns TRUE, if a is an MONOPOLY object, or is of type POLYNOM with 0 or 1 variable. */ OP nb; INT erg =OK; if(S_O_K(a)==MONOPOLY) return TRUE; if(S_O_K(a)==POLYNOM) { nb=CALLOCOBJECT(); numberofvariables(a,nb); if(S_I_I(nb)<=1L) { FREEALL(nb);return TRUE; } FREEALL(nb); } return FALSE; ENDR("has_one_variable"); } symmetrica-2.0/nb.doc0000600017361200001450000011047110726170276014477 0ustar tabbottcrontabCOMMENT: I am enclosing two document files relating to nb.c. They are separated by rows of ####'s. The first deals with routines in nb.c which are global, and the second with those that are static. They are incomplete in three ways, perhaps. (i) I have not yet included enough examples. (ii) Some of the remarks about return values may not be correct. I have not checked them very carefully. (iii) You may consider that, in some respects, there is too much in them and, in particular, that the statics should not be included. ############################################################ NB.DOC ###### ELEMENTS IN NUMBER FIELDS ------------------------- This module contains routines for manipulating elements in number fields. For the current implementation, two type of number field are available: (i): Cyclotomic fields, (ii): Square radical fields -- i.e. extensions of the rational number field by finitely many square roots of rational integers. The objects in SYMMETRICA which implement these numbers are known as cyclos and sqrads and have the SYMMETRICA types CYCLOTOMIC and SQ_RADICAL, respectively. They are based on an object known as a monopoly and of type MONOPOLY which implements a polynomial in one variable. In what follows, a monopoly in the variable x may be denoted by p(x) or a_n * x:n + a_(n-1) * x:(n-1) + . . . + a_1 * x + a_0. When this represents a cyclo, x will be the 'basic' primitive m-th root of unity e:(2 * pi * i / m) for an appropriate positive integer m -- m will be known as the index of the cyclo. When the monopoly above represents a sqrad, the sqrad corresponds to the number a_n * \sqrt(n) + a_(n-1) * \sqrt(n-1) + . . . + a_1. The following gives further details of the three structures MONOPOLY, CYCLOTOMIC, SQ_RADICAL A monopoly is an object of type MONOPOLY, with two fields -- a self and a next. Thus, it is syntactically the same as a list. Its next is a monopoly or NULL. Its self is a monom whose coefficient is a scalar (integer or rational number) and whose self is a non-negative integer. Note that no check is made to see whether these constraints are satisfied, but certain routines will behave strangely if they are violated. There is a number object with two fields -- self and data. The self is a monopoly. A cyclo is an number object of type CYCLOTOMIC whose data field is a pointer to a block of four items -- the index, the corresponding cyclotomic polynomial, its degree and the 'automorphisms' of the field (in fact, the integers between 1 and the index and coprime to it). A sqrad is a number object whose data is a list of the prime divisors (including -1) of the integers occuring as selfs of the terms of its monopoly. Data relating to cyclotomic numbers are held in a table (read from a file named CYCLOS.DAT) and in a list. A newly created cyclo with a known index (i.e. known to the table or the list) has a data pointer pointing to the known table or list item. A newly created cyclo with a new index has a new data item created and appended to the list. At any time, the list of data items may be appended to CYCLOS.DAT. Although descriptions of the basic routines for manipulating the various types of number, one should normally use the general routines given at the end of this document. For example, use add(x,y) rather than add_scalar_cyclo(x,y), since the general routines have type-checking built in. ELEMENTARY ROUTINES RELATING TO INTEGERS. ----------------------------------------- NAME: number_of_digits SYNOPSIS: INT number_of_digits(OP a) DESCRIPTION: Determines the number of digits of the integer a. a may be an INTEGER or a LONGINT. RETURN: The number of digits. NAME: integer_factors_to_integer SYNOPSIS: INT integer_factors_to_integer(OP l,OP a) DESCRIPTION: l is a MONOPOLY representing the factorization of an integer into integers with integer exponents. These factors are combined to reform the integer. RETURN: OK or ERROR NAME: make_coprimes SYNOPSIS: INT make_coprimes(OP number,OP result) DESCRIPTION: Given the number n, which should be a positive INTEGER or LONGINT or a MONOPOLY representing a factorisation of an integer greater than 1, the result returns the list of positive integers coprime to n. RETURN: OK or ERROR NAME: euler_phi SYNOPSIS: INT euler_phi(OP a,OP b) DESCRIPTION: Determines the number of numbers coprime to an integer a and returns it in b. The object a may be INTEGER object or LONGINT object. RETURN: OK or ERROR !! NAME: ganzsquareroot_longint SYNOPSIS: INT ganzsquareroot_longint(OP a,OP b) DESCRIPTION: a is a non-negative LONGINT object. b is set to the integer part of its square root. In this case, the return value is OK or IMPROPER according as the integer is a perfect square or not. Otherwise, the return value is ERROR. RETURN: OK, IMPROPER or ERROR NAME: ganzsquareroot_integer SYNOPSIS: INT ganzsquareroot_integer(OP a,OP b) DESCRIPTION: a is a non-negative INTEGER object. b is set to the integer part of its square root. In this case, the return value is OK or IMPROPER according as the integer is a perfect square or not. Otherwise, the return value is ERROR. RETURN: OK, IMPROPER or ERROR NAME: primep SYNOPSIS: INT primep(OP a) DESCRIPTION: returns TRUE if a is prime number FALSE else COMMENT: INTEGER FACTORISATION --------------------- There is a simple routine for prime factorization of integers. A table of prime factors is either read from a file PRIMES.DAT or constructed directly. An integer is factored by first using the primes in the table, and then continuing through all odd numbers following the greatest prime in the table. NAME: setup_prime_table SYNOPSIS: INT setup_prime_table() DESCRIPTION: Creates a table of rational prime numbers. If the source is compiled with PRIME_FILE #defined, it searches for a file in the current directory named PRIMES.DAT, and reads the table of primes from that file. The first entry should be the number of primes in the file, then the list of primes (assumes that INTs are longs). If PRIME_FILE is not #defined, a table of the first 15 primes is set up. Returns OK if the table is set; otherwise, returns ERROR. RETURN: OK or ERROR NAME: first_prime_factor SYNOPSIS: INT first_prime_factor(OP a,OP first_prime) DESCRIPTION: This routine finds the smallest prime factor of an integer a. The prime found is returned as first_prime. RETURN: OK or ERROR NAME: square_free_part SYNOPSIS: INT square_free_part(OP a,OP b,OP c,OP la,OP lb,OP lc) DESCRIPTION: This routine find the square-free part of the integer a, i.e. the product of the prime factors which occur to an odd exponent and -1, if the integer is negative. a may be either an INTEGER, LONGINT or a MONOPOLY containing the prime factorization of an integer. b and c return the the square-free part the square-root of the square part, respectively. Thus, a = b * c ** 2, and b has no repeated prime factors. If a is not a MONOPOLY and la is not NULL, la returns a MONOPOLY containing the prime factorization of a. If they are not NULL, lb and lc return MONOPOLYs containing the prime factorizations of b and c. The parameters a,b,c must be distinct. If la,lb,lc are not NULL they must be distinct also. This routine makes use of the ancillary routine square_free_part_0. RETURN: OK or ERROR NAME: square_free_part_0 SYNOPSIS: INT square_free_part_0( OP la,lb,lc) DESCRIPTION: This routine find the square-free part of the integer, which is given as a prime factors list la -- a MONOPOLY containing the prime factorization of the integer. lb and lc return MONOPOLYs containing the prime factorization of the square-free part and square-root of the square part, respectively. That is, lb has no prime (including -1), occurring with an exponent > 1. The parameters la,lb,lc must be distinct. RETURN: OK or ERROR NAME: jacobi SYNOPSIS: INT jacobi(a,b,c) OP a,b,c; DESCRIPTION: The Jacobi Symbol: (a/b) b odd. a and b are integers. c must point to a location different from a and b. If a and b have a common factor, c is set to 0 and ERROR is returned. Otherwise, c is set to the the jacobi symbol (a/b). Note that b must be odd. RETURN: OK or ERROR NAME: kronecker SYNOPSIS: INT kronecker(a,b,c) OP a,b,c; DESCRIPTION: The Kronecker Symbol: (a/b). a square-free and congruent to 0 or 1 mod 4. a and b are integers. c must point to a location different from a and b. If a and b have a common factor, c is set to 0 and ERROR is returned. Otherwise, c is set to the the kronecker symbol (a/b). Note that b must be odd. RETURN: OK or ERROR NAME: b_skn_mp SYNOPSIS: INT b_skn_mp( OP s,k,n,e) DESCRIPTION: Build a monopoly whose self is s, coefficient is k and next is n. b_skn_mp uses the objects supplied as arguments, while m_skn_mp uses copies of them. RETURN: OK or ERROR (!) NAME: m_skn_mp SYNOPSIS: INT m_skn_mp( OP s,k,n,e) DESCRIPTION: Make a monopoly whose self is s, coefficient is k and next is n. b_skn_mp uses the objects supplied as arguments, while m_skn_mp uses copies of them. RETURN: OK or ERROR (!) EXAMPLE: Making the monopoly corresponding to -1 * x : 10 + 4 * x : 17. It is assumed that all OP identifiers point to objects created by callocobject. (1) m_i_i(17L,b); m_i_i(4L,c); b_skn_mp(b,c,d,a); b = callocobject(); /* need new objects for these pointers */ c = callocobject(); m_i_i(10L,b); m_i_i(-1L,c); b_skn_mp(b,c,NULL,d); /* at this stage the monopoly is complete */ The statement 'println(a);' causes the output 4 17 -1 10 The statement 'objectwrite(stdout,a);' causes the output where, for convenience, some lines have been joined and the components have been annotated: 126 1 21 1 4 1 17 1 MONOPOLY nonNULL MONOM INTEGER value INTEGER value more terms 126 1 21 1 -1 1 10 0 MONOPOLY nonNULL MONOM INTEGER value INTEGER value no more terms (2) The following creates the same monopoly, the insert routine carries out some sorting. init(MONOPOLY,a); m_i_i(10L,b); m_i_i(-1L,c); h = callocobject(); m_sk_mo(b,c,h); insert(h,a,add_koeff,NULL); m_i_i(17L,b); m_i_i(4L,c); h = callocobject(); m_sk_mo(b,c,h); insert(h,a,add_koeff,NULL); The statement 'println(a);' causes the output -1 10 4 17 The statement 'objectwrite(stdout,a);' causes the output:ce, 126 1 21 1 -1 1 10 1 126 1 21 1 4 1 17 0 NAME: scan_monopoly SYNOPSIS: INT scan_monopoly(a) OP a; DESCRIPTION: Routines for inputting a monopoly from stdin. scan_monopoly requests the type of self and coefficient. It then transfers control to SCMPCO which requests the number of terms in the monopoly and inputs the terms one by one. This is a subroutine of scan. It is better to use the general routine scan. RETURN: OK or ERROR NAME: remove_zero_terms SYNOPSIS: INT remove_zero_terms(a) OP a; DESCRIPTION: Removes those terms from a MONOPOLY with zero coefficients unless this makes the list empty. In this case, one term with self and coefficient both 0 is left. RETURN: OK or ERROR NAME: add_scalar_monopoly SYNOPSIS: INT add_scalar_monopoly( OP a,b,c) DESCRIPTION: subroutine of add NAME: mult_scalar_monopoly SYNOPSIS: INT mult_scalar_monopoly( OP a,b,c) DESCRIPTION: subroutine of mult NAME: add_monopoly_monopoly SYNOPSIS: INT add_monopoly_monopoly( OP a, b, c) DESCRIPTION: subroutine of add NAME: mult_monopoly_monopoly SYNOPSIS: INT mult_monopoly_monopoly(OP a, b, c) DESCRIPTION: subroutine of mult NAME: add_monopoly SYNOPSIS: INT add_monopoly( OP a,b,c) DESCRIPTION: subroutine of add NAME: add_apply_monopol SYNOPSIS: INT add_apply_monopoly( OP a,b) DESCRIPTION: Addition of objects of type INTEGER, LONGINT, BRUCH and MONOPOLY. Subroutine of add_apply NAME: mult_monopoly SYNOPSIS: INT mult_monopoly( OP a,b,c) DESCRIPTION: for the multiplication of a object a of type MONOPOLY with an arbitray object b, the result is the object c. Subroutine of mult RETURN: OK if no error occured. NAME: mult_apply_monopoly SYNOPSIS: INT mult_apply_monopoly(OP a,b) DESCRIPTION: Multiplication of objects of type INTEGER, LONGINT, BRUCH, MATRIX, MONOM, POLYNOM, SCHUBERT, VECTOR and MONOPOLY, Better to use the general routine mult_apply NAME: addinvers_monopoly SYNOPSIS: INT addinvers_monopoly( OP a,b) DESCRIPTION: subroutine of the general routine addinvers NAME: addinvers_apply_monopoly SYNOPSIS: INT addinvers_apply_monopoly(OP a) DESCRITPION: subroutine of the general routine addinvers_apply NAME: nullp SYNOPSIS: INT nullp_monopoly(OP a) DESCRIPTION: subroutine of the general routine nullp. NAME: comp_monopoly SYNOPSIS: INT comp_monopoly(OP a,b) DESCRIPTION: Compares monopolies as lists, using comp_list() RETURN: 0 (= equal) <0 if a0 if a>b NAME: quores_monopoly SYNOPSIS: INT quores_monopoly( OP poly,dpoly,qpoly,rpoly) DESCRIPTION: Carries out the division algorithm on polynomials of one variable to find the quotient (qpoly) and remainder (rpoly). The result is poly = dpoly * qpoly + rpoly, where rpoly has degree less than dpoly, or represents 0. The parameters poly, dpoly, qpoly and rpoly must all be different. RETURN: OK or ERROR NAME: raise_power_monopoly SYNOPSIS: INT raise_power_monopoly( OP a, b) DESCRIPTION: Multiplies all the self components of the terms of the monopoly b by the scalar a. Viewing the monopoly as a polynomial p(x), this has the effect of replacing it by p(x**a). RETURN: OK or ERROR NAME: scale_monopoly SYNOPSIS: INT scale_monopoly(a,b) OP a, b; DESCRIPTION: Viewing the monopoly b as a polynomial p(x), the effect of this routine is to replace it by p(a*x). RETURN: OK or ERROR NAME: objectread_monopoly SYNOPSIS: INT objectread_monopoly(f,a) FILE *f; OP a; DESCRIPTION: Reads a monopoly a from the stream f. RETURN: OK or ERROR NAME: tex_monopoly SYNOPSIS: INT tex_monopoly(a) OP a; DESCRIPTION: Outputs a monopoly in a form suitable for TeX processing. It is treated as a polynomial in x. Subroutine of the general routine tex. RETURN: OK or ERROR NAME: make_unitary0_monopoly SYNOPSIS: INT make_unitary0_monopoly(number,result) OP number, result; DESCRIPTION: Given the number n, which should be an positive INTEGER or LONGINT, the result returns the monopoly corresponding to x**n-1. RETURN: OK or ERROR NAME: make_unitary1_monopoly SYNOPSIS: INT make_unitary1_monopoly(number,result) OP number, result; DESCRIPTION: Given the number n, which should be an positive INTEGER or LONGINT, the result returns the MONOPOLY x**(n-1) + x**(n-2) + ... + x + 1. RETURN: OK or ERROR NAME: make_cyclotomic_monopoly SYNOPSIS: INT make_cyclotomic_monopoly(number,result) OP number, result; DESCRIPTION: Given the number n, which should be an positive INTEGER or LONGINT or a MONOPOLY representing a factorisation of an integer greater than 1, the result returns the cyclotomic polynomial of index n, phi_n(x). RETURN: OK or ERROR NAME: t_MONOPOLY_POLYNOM SYNOPSIS: INT t_MONOPOLY_POLYNOM(OP a,b) DESCRIPTION: converts a MONOPOLY object a into a POLYNOM object b with one variable. NAME: eq_fieldobject_int SYNOPSIS: INT eq_fieldobject_int(type,a,i) OBJECTKIND type; OP a; INT i; DESCRIPTION: Determines if the 'field object' (a monopoly, sqrad or cyclo) is equal to the integer i. Returns OK for equality. There are six associated macros: EINSP_MONOPOLY(a) eq_fieldobject_int(MONOPOLY,(a),1L) EINSP_CYCLO(a) eq_fieldobject_int(CYCLOTOMIC,(a),1L) EINSP_SQRAD(a) eq_fieldobject_int(SQ_RADICAL,(a),1L) NEGEINSP_MONOPOLY(a) eq_fieldobject_int(MONOPOLY,(a),-1L) NEGEINSP_CYCLO(a) eq_fieldobject_int(CYCLOTOMIC,(a),-1L) NEGEINSP_SQRAD(a) eq_fieldobject_int(SQ_RADICAL,(a),-1L) RETURN: OK or ERROR NAME: b_ksd_n SYNOPSIS: INT b_ksd_n(kind,self,data,result) OBJECTKIND kind; OP self,data,result; DESCRIPTION: build a number object (sqrad or cyclo), whose type is 'kind', and with the given self and data. b_ksd_n uses the objects supplied as arguments, while m_ksd_n uses copies of them. RETURN: OK or ERROR (!) NAME: m_ksd_n SYNOPSIS: INT m_ksd_n(kind,self,data,result) OBJECTKIND kind; OP self,data,result; DESCRIPTION: Make a number object (sqrad or cyclo), whose type is 'kind', and with the given self and data. b_ksd_n uses the objects supplied as arguments, while m_ksd_n uses copies of them. RETURN: OK or ERROR (!) NAME: objectwrite_number SYNOPSIS: INT objectwrite_number(f,number) FILE *f; OP number; DESCRIPTION: writes a number (sqrad or cyclo) to a stream. In the case of a cyclo, the only part of the data transferred is the index. RETURN: OK or ERROR NAME: objectread_number SYNOPSIS: INT objectread_number( FILE *f; OP number; OBJECTKIND type) DESCRIPTION: Reads a number (sqrad or cyclo) from a stream. In the case of a cyclo, the only part of the data transferred is the index. There are two associated macros: OBJECTREAD_CYCLO(f,a) objectread_number((f),(a),CYCLOTOMIC) OBJECTREAD_SQRAD(f,a) objectread_number((f),(a),SQ_RADICAL) RETURN: OK or ERROR NAME: fprint_number SYNOPSIS: INT fprint_number(f,n) FILE *f; OP n; DESCRIPTION: Prints the number n on the stream f. The self is printed first and is separated by a colon from the data list in the case of a sqrad and the index in the case of a cyclo. RETURN: OK or ERROR COMMENT: There are the standard routines and macros NAME MACRO DESCRIPTION RETURN TYPE --------------------------------------------------------------------------- c_n_s C_N_S change number self INT c_n_d C_N_D change number data INT s_n_s S_N_S select number self OP s_n_d S_N_D select number sqrad data OP s_n_dci S_DCI_I select number cyclo data:index OP s_n_dcd S_DCI_D select number cyclo data:degree OP s_n_dcp S_DCI_P select number cyclo data:poly OP NAME: mult_lists SYNOPSIS: INT mult_lists(a,b,c) OP a, b, c; DESCRIPTION: Multiplies the entries in two lists pairwise, putting the resulting objects in a list. Duplicate objects are ignored. RETURN: OK or ERROR NAME: tidy SYNOPSIS: INT tidy(a) OP a; DESCRIPTION: Tidies up an object which contains cyclos in some of its components. Such cyclos are reduced modulo the cyclotomic polynomial. RETURN: OK or ERROR NAME: make_monopoly_sqrad SYNOPSIS: INT make_monopoly_sqrad(a,b) OP a,b; DESCRIPTION: Makes b a sqrad whose self is a copy of the monopoly a. Also determines the data of the sqrad. RETURN: OK or ERROR NAME: make_scalar_sqrad SYNOPSIS: INT make_scalar_sqrad(a,b) OP a,b; DESCRIPTION: Makes b a sqrad whose self is 1 and whose coefficient is a. RETURN: OK or ERROR NAME: scan_sqrad SYNOPSIS: INT scan_sqrad(a) OP a; DESCRIPTION: Input a sqrad directly from standard input. RETURN: OK or ERROR NAME: add_scalar_sqrad SYNOPSIS: INT add_scalar_sqrad(a,b,c) OP a,b,c; DESCRIPTION: this is a subroutine of the general routine add NAME: mult_scalar_sqrad SYNOPSIS: INT mult_scalar_sqrad(a,b,c) OP a, b, c; DESCRIPTION: this is a subroutine of the general routine mult NAME: add_sqrad_sqrad SYNOPSIS: INT add_sqrad_sqrad(a,b,c) OP a, b, c; DESCRIPTION: this is a subroutine of the general routine add NAME: mult_sqrad_sqrad SYNOPSIS: INT mult_sqrad_sqrad(a,b,c) OP a, b, c; DESCRIPTION: this is a subroutine of the general routine mult NAME: add_sqrad SYNOPSIS: INT add_sqrad(a,b,c) OP a,b,c; DESCRIPTION: this is a subroutine of the general routine add NAME: add_apply_sqrad SYNOPSIS: INT add_apply_sqrad(a,b) OP a,b; DESCRIPTION: Addition of objects of type INTEGER, LONGINT, BRUCH, POLYNOM, SQ_RADICA or CYCLOTOMIC. This is a subroutine of the general routine add_apply NAME: mult_sqrad SYNOPSIS: INT mult_sqrad(a,b,c) OP a,b,c; DESCRIPTION: this is a subroutine of the general routine mult NAME: mult_apply_sqrad SYNOPSIS: INT mult_apply_sqrad(a,b) OP a,b; DESCRIPTION: Multiplication of objects the first of type SQ_RADICAL and the second of type INTEGER, LONGINT, CYCLOTOMIC, BRUCH, MATRIX, MONOM, VECTOR, SQ_RADICAL, POLYNOM or SCHUBERT. this is a subroutine of the general routine mult_apply NAME: addinvers_sqrad SYNOPSIS: INT addinvers_sqrad(a,b) OP a,b; DESCRIPTION: this is a subroutine of the general routine addinvers NAME: addinvers_apply_sqrad SYNOPSIS: INT addinvers_apply_sqrad(a) OP a; DESCRIPTION: this is a subroutine of the general routine addinvers_apply NAME: invers_sqrad SYNOPSIS: INT invers_sqrad(a,b) OP a,b; DESCRIPTION: this is a subroutine of the general routine invers NAME: nullp_sqrad SYNOPSIS: INT nullp_sqrad(a) OP a; DESCRIPTION: this is a subroutine of the general routine nullp SYNOPSIS: INT comp_sqrad(a,b) OP a,b; DESCRIPTION: Uses comp_list on the self fields. NAME: tex_sqrad SYNOPSIS: INT tex_sqrad(a) OP a; DESCRIPTION: Outputs a sqrad in a form suitable for TeX processing. Each term of the self is expressed in the form: coefficient * \sqrt (self). RETURN: OK or ERROR NAME: squareroot_integer SYNOPSIS: INT squareroot_integer(a,b) OP a,b; DESCRIPTION: b is a sqrad whose square is the scalar a, which is a INTEGER object. This is a subroutine of the generalroutine squareroot RETURN: OK or ERROR NAME: squareroot_longint SYNOPSIS: INT squareroot_longint(a,b) OP a,b; DESCRIPTION: b is a sqrad whose square is the scalar a, which is a LONGINT object. This is a subroutine of the generalroutine squareroot RETURN: OK or ERROR NAME: squareroot_bruch SYNOPSIS: INT squareroot_bruch(a,b) OP a,b; DESCRIPTION: b is a sqrad whose square is the scalar a, which is a BRUCH object. This is a subroutine of the generalroutine squareroot RETURN: OK or ERROR NAME: convert_radical_cyclo SYNOPSIS: INT convert_radical_cyclo(a,b) OP a,b; DESCRIPTION: Converts the square root of an integer a to a cyclo b. RETURN: OK NAME: trans_index_monopoly_cyclo SYNOPSIS: INT trans_index_monopoly_cyclo(a,b,c) OP a,b,c; DESCRIPTION: Given a positive integer a and a monopoly b corresponding to the polynomial p(x), a cyclo c is constructed whose index is a and which repersents the cyclotomic number p(x) where x is the basic primitive a-th root of unity. p(x) is reduced modulo x:a - 1 but not modulo phi_a(x). RETURN: OK or ERROR NAME: field_check_cyclo SYNOPSIS: INT field_check_cyclo(a) OP a; DESCRIPTION: Check if element of field element , the CYCLOTOMIC object a, is essentially an INTEGER, and if so, transform to an object of type INTEGER. RETURN: OK or ERROR NAME: field_check_sqrad SYNOPSIS: INT field_check_sqrad(a) OP a; DESCRIPTION: Check if element of field element, the SQ_RADICAL object a, is essentially an INTEGER, and if so, transform to an object of type INTEGER. RETURN: OK or ERROR NAME: make_scalar_cyclo SYNOPSIS: INT make_scalar_cyclo(a,b) OP a,b; DESCRIPTION: transfer a scalar object l into an CYCLOTOMIC object b. NAME: make_index_coeff_power_cyclo SYNOPSIS: INT make_index_coeff_power_cyclo(a,b,c,d) OP a,b,c,d; DESCRIPTION: The monomial b * x:c is treated as a cyclotomic number, where x is the basic primitive a-th root of unity. A cyclo d is constructed corresponding to this number. RETURN: OK or ERROR NAME: scan_cyclo SYNOPSIS: INT scan_cyclo(a) OP a; DESCRIPTION: Input a cyclo directly from standard input. Subroutine of the general routine scan. RETURN: OK or ERROR NAME: add_scalar_cyclo SYNOPSIS: INT add_scalar_cyclo(a,b,c) OP a,b,c; DESCRIPTION: this is a subroutine of the general routine add NAME: mult_scalar_cyclo SYNOPSIS: INT mult_scalar_cyclo(a,b,c) OP a, b, c; DESCRIPTION: this is a subroutine of the general routine mult NAME: add_cyclo_cyclo SYNOPSIS: INT add_cyclo_cyclo(a,b,c) OP a,b,c; DESCRIPTION: c is completely tidied. this is a subroutine of the general routine add NAME: mult_cyclo_cyclo SYNOPSIS: INT mult_cyclo_cyclo(a,b,c) OP a,b,c; DESCRIPTION: c is completely tidied. this is a subroutine of the general routine mult NAME: add_cyclo SYNOPSIS: INT add_cyclo(a,b,c) OP a,b,c; DESCRIPTION: this is a subroutine of the general routine add NAME: add_apply_cyclo SYNOPSIS: INT add_apply_cyclo(a,b) OP a,b; DESCRIPTION: Adds a cyclo to an object of type INTEGER, LONGINT, BRUCH, SQ_RADICAL, CYCLOTOMIC or POLYNOM. this is a subroutine of the general routine add_apply NAME: mult_cyclo SYNOPSIS: INT mult_cyclo(a,b,c) OP a,b,c; DESCRIPTION: this is a subroutine of the general routine mult NAME: mult_apply_cyclo SYNOPSIS: INT mult_apply_cyclo(a,b) OP a,b; DESCRIPTION: Multiplies a cyclo with an object of type INTEGER, LONGINT, BRUCH, SQ_RADICAL, CYCLOTOMIC, POLYNOM, SCHUBERT, VECTOR or MATRIX. this is a subroutine of the general routine mult_apply NAME: addinvers_cyclo SYNOPSIS: INT addinvers_cyclo(a,b) OP a,b; DESCRIPTION: this is a subroutine of the general routine addinvers NAME: addinvers_apply_cyclo SYNOPSIS: INT addinvers_apply_cyclo(a) OP a; DESCRIPTION: this is a subroutine of the general routine addinvers_apply NAME: invers_cyclo SYNOPSIS: INT invers_cyclo(a,b) OP a,b; DESCRIPTION: this is a subroutine of the general routine invers NAME: nullp_cyclo SYNOPSIS: INT nullp_cyclo(a) OP a; DESCRIPTION: this is a subroutine of the general routine nullp NAME: comp_cyclo SYNOPSIS: INT comp_cyclo(a) OP a; DESCRIPTION: Uses comp_list on the self fields. NAME: conj_cyclo SYNOPSIS: INT conj_cyclo(a,b,c) OP a,b,c; DESCRIPTION: If a represents the cyclotomic number p(x), where x is the basic primitive n-th root of unity, c is a cyclo representing the number p(x:b). If b is coprime to n, this is an algebraic conjugate of p(x). RETURN: OK or ERROR NAME: tex_cyclo SYNOPSIS: INT tex_cyclo(a) OP a; DESCRIPTION: Outputs a cyclo in a form suitable for TeX processing. Each term of the self is expressed in the form: coefficient * \omega_{index} : (self). RETURN: OK or ERROR NAME: setup_cyclotomic_table SYNOPSIS: INT setup_cyclotomic_table() DESCRIPTION: Reads the table of cyclos from the file CYCLOS.DAT. The first entry should be no_cyclos, then the list of cyclo_data. Returns OK if the table is set; otherwise, returns ERROR. RETURN: OK or ERROR NAME: print_cyclo_data SYNOPSIS: INT print_cyclo_data(ptr) CYCLO_DATA *ptr; DESCRIPTION: Prints at stdout the cyclotomic data pointed to by ptr, prefacing the entries by Index, Degree, Polynomial and Automorphism exponents respectively. RETURN: NAME: print_cyclo_table SYNOPSIS: INT print_cyclo_table() DESCRIPTION: Prints the data corresponding to each item on the cyclo table. RETURN: OK or ERROR NAME: print_cyclo_list SYNOPSIS: INT print_cyclo_list() DESCRIPTION: Prints the data corresponding to each item on the cyclo list. RETURN: OK or ERROR NAME: save_cyclo_list SYNOPSIS: INT save_cyclo_list() DESCRIPTION: Appends the data corresponding to each item on the cyclo list to the file CYCLOS.DAT -- the file is created if it does not exist. There is no check for duplication of data. RETURN: OK or ERROR COMMENT: ---------------------------------------------------------------------- GENERAL ROUTINES ---------------- NAME DESCRIPTION ---------------------------------------------------------------------- add() mult() addinvers() invers() nullp() comp() copy() fprint() fprintln() freeall() freeself() objectread() objectwrite() scan() tex() COMMENT: ############################################################ STATIC.DOC ########## THE STATIC ROUTINES ------------------- NAME: integer_factor_0 SYNOPSIS: static INT integer_factor_0(a,l,g,m,first_prime) OP a,l,g,m, first_prime; DESCRIPTION: This routine factorizes an integer using the table of primes. a is the integer to be factored; l is a monopoly in which the prime factors of a, which are contained in the table, and their exponents are inserted as monomials with the primes as the selfs and the exponents as the koeffs; g is the remaining factor; m is the last number tried as a factor. If it is non-NULL, first_prime is set to the first prime factor and the routine returns as soon as it is found. For a full factorization, it must be set to NULL. The parameters a,l,g,m and first_prime must be different. RETURN: OK or ERROR NAME: integer_factor_1 SYNOPSIS: static INT integer_factor_1(a,f1,f2,b,l,first_prime) OP a,f1,f2,b,l,first_prime; DESCRIPTION: This routine finds all prime factors of the integer a between two bounds f1 (the lower) and f2. If f1 is even, it is replaced by f1 + 1. l is a monopoly in which the prime factors of a, between the given bounds, and their exponents are inserted as monomials with the primes as the selfs and the exponents as the koeffs. b is set to the remaining factor. If it is non-NULL, first_prime is set to the first prime factor and the routine returns as soon as it is found. For a full factorization, it must be set to NULL. The parameters a,l,b, f1,f2 and first_prime must be different. RETURN: OK or ERROR NAME: integer_factor_2 /* deleted */ SYNOPSIS: DESCRIPTION: This routine finds a partial prime factorisation of the integer a with all the primes on a list l0. l is a monopoly to hold the factorisation and b is set to the remaining factor. a,l,b,l0 must be different. RETURN: OK or ERROR NAME: integer_factor SYNOPSIS: static INT integer_factor(a,l) OP a,l; DESCRIPTION: This is the main integer factorization routine. a is the integer to be factored. l is a monopoly to hold the factorisation. l need not be initialized to a MONOPOLY. RETURN: OK or ERROR NAME: callocnumber SYNOPSIS: static struct number * callocnumber() DESCRIPTION: Creates a number object and returns a pointer to it. RETURN: A pointer or NULL NAME: insert_zero_into_monopoly SYNOPSIS: static INT insert_zero_into_monopoly(a) OP a; DESCRIPTION: Converts an empty monopoly into a non-empty one. RETURN: OK or ERROR NAME: find_sqrad_data SYNOPSIS: static INT find_sqrad_data(a) OP a; DESCRIPTION: Finds the list of prime factors of the radicals of a sqrad a and -1 if one of these radicals is negative, and inserts this list in the appropriate field of a. RETURN: OK or ERROR NAME: adjust_sqrad_data SYNOPSIS: static INT adjust_sqrad_data(a) OP a; DESCRIPTION: This adjusts an incomplete data list of primes for the sqrad a to make it complete. It may result in the list having too many primes. RETURN: OK or ERROR NAME: conj_sqrad SYNOPSIS: static INT conj_sqrad(a,b,c) OP a,b,c; DESCRIPTION: Obtains the conjugate of the sqrad a with respect to the automorphism x + y * \sqrt(b) -> x - y * \sqrt(b) of the number field F = E(\sqrt(b)), where [E:F] = 2, and F is generated by the square roots of the elements on the data list of a. The variable c returns the conjugate. RETURN: OK or ERROR NAME: convert_sqrad_scalar SYNOPSIS: static INT convert_sqrad_scalar(a) OP a; DESCRIPTION: If a is a sqrad not involving radicals, it is converted to a scalar -- the coefficient of \sqrt(1). RETURN: OK or ERROR NAME: make_index_monopoly_cyclo SYNOPSIS: static INT make_index_monopoly_cyclo(a,b,c,tid) OP a,b,c; int tid; DESCRIPTION: Given a positive integer a and a monopoly b corresponding to the polynomial p(x), a cyclo c is constructed whose index is a and which repersents the cyclotomic number p(x) where x is the basic primitive a-th root of unity. The parameter tid specifies the amount of tidying up required -- see the standardise_cyclo routine. RETURN: OK or ERROR NAME: standardise_cyclo SYNOPSIS: static INT standardise_cyclo(a,tid) OP a; int tid; DESCRIPTION: This routine carries out a tidying-up process on the monopoly p(x) corresponding to the cyclo a. If tid = 0, the monopoly p(x) is not tidied up in any way. if tid = 1, p(x) is reduced modulo x:n - 1; and if tid = 2, it is reduced modulo phi_n(x), where n denotes the index. RETURN: OK or ERROR NAME: add_cyclo_cyclo_0 mult_cyclo_cyclo_0 SYNOPSIS: static INT add_cyclo_cyclo_0(a,b,c,tid) OP a,b,c; int tid; static INT mult_cyclo_cyclo_0(a,b,c,tid) OP a,b,c; int tid; DESCRIPTION: Adding and multiplying with tidying facilities. RETURN: OK or ERROR NAME: invers_cyclo_norm SYNOPSIS: static INT invers_cyclo_norm(a,b,c) OP a,b,c; DESCRIPTION: Calculates the inverse and norm of the cyclo a and returns them as b and c respectively. The norm of a is the product of its conjugates in the cyclotomic field corresponding to the index of a. RETURN: OK or ERROR NAME: add_cyclo_data SYNOPSIS: static CYCLO_DATA *add_cyclo_data(index) OP index; DESCRIPTION: Creates the data associated with a new cyclotomic index and appends it to the global list of cyclotomic data. A pointer to this data is returned. RETURN: pointer or NULL NAME: cyclo_ptr SYNOPSIS: static CYCLO_DATA *cyclo_ptr(index) OP index; DESCRIPTION: DESCRIPTION: Returns a pointer to data associated with the cyclotomic index given -- the pointer points to a table item or a list item -- or NULL if the data is neither on the table or the list. RETURN: pointer or NULL static INT convert_cyclo_scalar(a) OP a; NAME: convert_cyclo_scalar SYNOPSIS: static INT convert_cyclo_scalar(a) OP a; DESCRIPTION: If a is a cyclo not involving roots of unity, it is converted to a scalar -- the coefficient of x:0. RETURN: OK or ERROR ############################################################ symmetrica-2.0/nc.c0000400017361200001450000017500710726021627014154 0ustar tabbottcrontab/* nc.c SYMMETRICA source code */ #include "def.h" #include "macro.h" static INT m_nc_sym(); static INT m_nc_alt(); /* PF 060292 */ /* PF 040692 */ /***********************************************************************/ /* */ /* Diese Routine berechnet den Vektor der Konjugiertenklassen */ /* der An. */ /* Rueckgabewert: OK oder error */ /* */ /***********************************************************************/ INT ak_make_alt_classes(n,res) OP n; /* Gewicht der Partitionen */ OP res; /* Vektor der Konjugiertenklassen der An */ { OP par; /* Partition von n */ OP per; /* Permutation */ OP sgn; /* Signum der Permutation */ OP l; /* Anzahl der verschiedenen Konjugiertenklassen der An */ INT i=0L; INT erg=OK; INT alt_dimension(); /* Hilfsroutinen */ INT split(); CTO(INTEGER,"ak_make_alt_classes(1)",n); FREESELF(res); /*** Test auf Ganzzahligkeit von n ************************************/ SYMCHECK (S_I_I(n) <= 0, "ak_make_alt_classes : n <= 0"); /*** Speicherplatzreservierung fuer die Objekte ***********************/ par=callocobject(); per=callocobject(); sgn=callocobject(); l=callocobject(); /*** Berechnung des Partitionenvektors (eigentlich eine Matrix) *********/ erg += alt_dimension(n,l); erg += m_il_v(S_I_I(l),res); erg += first_partition(n,par); do { erg += m_part_perm(par,per); erg += signum(per,sgn); if(S_I_I(sgn) == 1L) { if(split(n,par)==1L) { m_il_v(2L,S_V_I(res,i)); erg += copy(par,S_V_I(S_V_I(res,i),0L)); erg += m_i_i(0L,S_V_I(S_V_I(res,i),1L)); i++; m_il_v(2L,S_V_I(res,i)); erg += copy(par,S_V_I(S_V_I(res,i),0L)); erg += m_i_i(1L,S_V_I(S_V_I(res,i),1L)); } else { erg += copy(par,S_V_I(res,i)); } i++; } } while(next(par,par)); /*** Speicherplatzfreigabe *********************************************/ erg += freeall(par); erg += freeall(per); erg += freeall(sgn); erg += freeall(l); /*** Rueckkehr in die aufrufende Routine *******************************/ ENDR("ak_make_alt_classes"); } /* Ende von make_alt_classes */ INT ak_make_alt_partitions(n,res) OP n; /* Gewicht der Partitionen */ OP res; /* Vektor der irred. Darst. der An */ { OP par; /* Partition von n */ OP conpar; /* konjugierte Partition */ OP l; /* Anzahl der verschiedenen irred. Darst. der An */ INT i=0L,j; INT erg=OK; INT alt_dimension(); /* Hilfsroutinen */ INT part_comp(); /*** Test auf Ganzzahligkeit von n ************************************/ CTO(INTEGER,"ak_make_alt_partitions",n); if (S_I_I(n) <= 0L) { error("ak_make_alt_partitions : n <= 0"); return ERROR; } /*** Speicherplatzreservierung fuer die Objekte **********************/ par=callocobject(); conpar=callocobject(); l=callocobject(); /*** Berechnung des Partitionenvektors (eigentlich eine Matrix) *******/ erg += alt_dimension(n,l); erg += m_il_v(S_I_I(l),res); erg += first_partition(n,par); do { erg += conjugate(par,conpar); j=part_comp(par,conpar); if(j==0L) /* zerfaellt */ { erg += m_il_v(2L,S_V_I(res,i)); erg += copy(par,S_V_I(S_V_I(res,i),0L)); erg += m_i_i(0L,S_V_I(S_V_I(res,i),1L)); i++; erg += m_il_v(2L,S_V_I(res,i)); erg += copy(par,S_V_I(S_V_I(res,i),0L)); erg += m_i_i(1L,S_V_I(S_V_I(res,i),1L)); i++; } else if (j>0L) { /* zerfaellt nicht */ erg += copy(par,S_V_I(res,i)); i++; } } while(next_apply(par)); /*** Speicherplatzfreigabe *********************************************/ FREEALL3(par,conpar,l); /*** Rueckkehr in die aufrufende Routine *******************************/ ENDR("ak_make_alt_partitions"); } INT scan_gl_nc(a,b) OP a,b; /* AK 100692 */ { OBJECTKIND k; INT i,erg = OK; OP c; CTO(EMPTY,"scan_gl_nc(2)",b); c = callocobject(); erg += printeingabe("input of a character"); erg += printeingabe("grouplabel = "); println(a); erg += m_il_v(2L,b); copy(a,S_NC_GL(b)); erg += printeingabe("type of charactervalues"); k = scanobjectkind(); erg += m_gl_cl(a,c); erg += m_il_v(S_V_LI(c),S_NC_C(b)); for (i=0L;i0L, falls a>b */ /* */ /***********************************************************************/ INT part_comp(a,b) OP a,b; { OP l; INT i; l=callocobject(); if (S_PA_LI(a) > S_PA_LI(b)) m_i_i(S_PA_LI(b),l); else m_i_i(S_PA_LI(a),l); i=0L; do i++; while(iS_PA_II(b,S_PA_LI(b)-i)) { freeall(l); return 1L; } freeall(l); return 0L; } /**************************************************************************/ /* Diese Routine berechnet zu einer Partition die Standardpermutation */ /* in umgekehrter Reihenfolge wie m_part_perm(). */ /* Rueckgabewert: OK oder error. */ /**************************************************************************/ #ifdef PERMTRUE INT std_perm(a,b) OP a,b; /* erzeugt aus zykeltyp standardpermutation */ { INT i,j,k; /* die adresse in der perm. b */ OP l; l=callocobject(); weight(a,l); if (not EMPTYP(b)) freeself(b); b_ks_p(VECTOR,callocobject(),b); b_l_v(l,S_P_S(b)); C_O_K(S_P_S(b),INTEGERVECTOR); k=0L; for (i=S_PA_LI(a)-1L;i>=0L;i--) { /* k ist naechste frei stelle */ M_I_I(k+1L,S_P_I(b,k+S_PA_II(a,i)-1L)); for (j=1L;j=0L;i--) { M_I_I(S_M_IJI(std_first,1L,i)+1,S_P_I(std,k)); k++; l=S_M_IJI(std_first,1L,i); for(j=0L;j=0L) { erg += copy(par,S_M_IJ(res,0L,i)); if(part_comp(par,conpar)==0L && S_I_I(n)!=1L) { i++; erg += copy(par,S_M_IJ(res,0L,i)); erg += m_i_i(1L,S_M_IJ(res,1L,i)); } i++; } } while(next(par,par)); /*** Speicherplatzfreigabe *********************************************/ erg += freeall(par); erg += freeall(conpar); erg += freeall(l); /*** Rueckkehr in die aufrufende Routine *******************************/ if (erg != OK) { error("make_alt_partitions : error during computation."); return ERROR; } return OK; }/* Ende von make_alt_partitions */ #endif /* MATRIXTRUE */ /* PF 060292 */ /* PF 040692 */ /***********************************************************************/ /* */ /* Diese Routine berechnet den Vektor der Konjugiertenklassen */ /* der An. */ /* Rueckgabewert: OK oder error */ /* */ /***********************************************************************/ #ifdef MATRIXTRUE INT make_alt_classes(n,res) OP n; /* Gewicht der Partitionen */ OP res; /* Vektor der Konjugiertenklassen der An */ { OP par; /* Partition von n */ OP per; /* Permutation */ OP sgn; /* Signum der Permutation */ OP l; /* Anzahl der verschiedenen Konjugiertenklassen der An */ INT i=0L; INT erg=OK; INT alt_dimension(); /* Hilfsroutinen */ INT split(); CTO(INTEGER,"make_alt_classes(1)",n); FREESELF(res); /*** Test auf Ganzzahligkeit von n ************************************/ SYMCHECK (S_I_I(n) <= 0,"make_alt_classes : n <=0"); /*** Speicherplatzreservierung fuer die Objekte ***********************/ par=callocobject(); per=callocobject(); sgn=callocobject(); l=callocobject(); /*** Berechnung des Partitionenvektors (eigentlich eine Matrix) *********/ erg += alt_dimension(n,l); erg += m_ilih_nm(S_I_I(l),2L,res); erg += first_partition(n,par); do { erg += m_part_perm(par,per); erg += signum(per,sgn); if(S_I_I(sgn) == 1L) { erg += copy(par,S_M_IJ(res,0L,i)); if(split(n,par)==1L) { i++; erg += copy(par,S_M_IJ(res,0L,i)); erg += m_i_i(1L,S_M_IJ(res,1L,i)); } i++; } } while(next(par,par)); /*** Speicherplatzfreigabe *********************************************/ erg += freeall(par); erg += freeall(per); erg += freeall(sgn); erg += freeall(l); /*** Rueckkehr in die aufrufende Routine *******************************/ ENDR("make_alt_classes"); } /* Ende von make_alt_classes */ #endif /* MATRIXTRUE */ /* PF 040692 */ /* PF 100692 */ /**********************************************************************/ /* */ /* Diese Routine berechnet die Dimension der Charaktertafel der */ /* An, d.h. die Anzahl der gewoehnlichen irreduziblen Darstel- */ /* lungen der An. */ /* Rueckgabewert: OK oder error */ /* */ /**********************************************************************/ INT alt_dimension(n,res) OP n,res; { OP par; /* Partition von n */ OP conpar; /* konjugierte Partition */ INT erg=OK; INT part_comp(); /* Hilfsroutine */ CTO(INTEGER,"alt_dimension(1)",n); FREESELF(res); /*** Test auf Ganzzahligkeit von n ************************************/ SYMCHECK(S_I_I(n) <= 0,"alt_dimension : n <= 0"); /*** Speicherplatzreservierung ****************************************/ par=callocobject(); conpar=callocobject(); /*** Berechnung der Anzahl irreduzibler Darstellungen der An ***********/ erg += m_i_i(0L,res); erg += first_partition(n,par); do { erg += conjugate(par,conpar); if(part_comp(par,conpar)>=0L) { erg += inc(res); if(part_comp(par,conpar)==0L && S_I_I(n)!=1L) erg += inc(res); } } while(next(par,par)); /*** Speicherplatzfreigabe ********************************************/ erg += freeall(par); erg += freeall(conpar); /*** Rueckkehr in die aufrufende Routine *******************************/ ENDR("alt_dimension"); } /* Ende von alt_dimension */ /* PF 040692 */ /* PF 100692 */ /*****************************************************************************/ /* DIESE ROUTINE UEBERPRUEFT, OB DIE KONJUGIERTENKLASSE PAR UEBER */ /* DER An ZERFAELLT. */ /* RUECKGABEWERT: 1 FALLS DIE KLASSE ZERFAELLT, */ /* 0 SONST. */ /*****************************************************************************/ INT split(n,par) OP n,par; { INT i; OP v; OP w; /*** Spezialfall n=1 ***/ if (S_I_I(n) == 1L) return 0L; w=callocobject(); v=callocobject(); m_l_nv(n,v); for(i=0L;i 1L) { freeall(w); freeall(v); return 0L; } freeall(w); freeall(v); return 1L; } /* PF 070592 *//* PF 010692 */ /* AK 020692 */ /****************************************************************************/ /* */ /* Diese Routine berechnet die Charaktertafel der alternierenden Gruppe */ /* An fuer eine beliebige natuerliche Zahl n. */ /* VERSION 1.2 PF040592 */ /****************************************************************************/ #ifdef MATRIXTRUE INT an_tafel(n,tafel) OP n,tafel; { OP v_part; /* Vektor der Partitionen von n */ OP par; /* Partition von n */ OP conpar; /* assoziierte Partition zu par */ OP per; /* Permutation aus der Konjugiertenklasse (par) */ OP sgn; /* Signum der Permutation per */ OP split_class; /* Hakenpartition h(par), falls par selbstassoziiert */ OP info_pa;/* Infovektor fuer die irreduziblen Darstellungen */ OP info_cc; /* Infovektor fuer die Konjugiertenklassen */ OP hilf; /* Hilfsobjekt zum Umspeichern */ INT i,j; /* Zaehlvariable zum Durchlauf der Infovektoren */ INT l=0L; /* Groesse der Charaktertafel der An */ INT zeile,spalte; /* Indexvariable bei der Belegung der Charaktertafel */ INT erg=OK; /* Rueckgabewert */ /*** Test auf Ganzzahligkeit von n ************************************/ CTO(INTEGER,"an_tafel",n); CE2(n,tafel,an_tafel); if (S_I_I(n) <= 0L) { erg += error("an_tafel : n is negativ."); goto endr_ende; } /*** Die Charaktertafel der A1, und die der A2 ist [1] ****************/ if ((S_I_I(n) == 2L) || (S_I_I(n) == 1L)) { erg += m_ilih_m(1L,1L,tafel); /* AK 120692 */ erg += m_i_i(1L,S_M_IJ(tafel,0L,0L)); goto endr_ende; } C1R(n,"an_tafel",tafel); /*** Speicherplatzreservierung der Objekte ****************************/ v_part = callocobject(); conpar = callocobject(); par = callocobject(); per = callocobject(); sgn = callocobject(); hilf = callocobject(); split_class = callocobject(); info_cc = callocobject(); info_pa = callocobject(); /*** Initialisierung der Zahl 2 und des Partitionsvektors *************/ erg += makevectorofpart(n,v_part); /*** Initialisierung der Infovektoren als Nullvektoren ****************/ erg += m_il_nv(S_V_LI(v_part),info_pa); erg += copy(info_pa,info_cc); /*** Belegung der Infovektoren ****************************************/ /*** Durchlaufe die Partitionen von n mit par. ***/ i = 0L; erg += first_partition(n,par); do { /*** Falls die Konjugiertenklasse (par) in der An liegt, wird in ***/ /*** info_cc an der entsprechenden Stelle eine 1 eingetragen. ***/ erg += m_part_perm(par,per); erg += signum(per,sgn); if (S_I_I(sgn) == 1L) { erg += m_i_i(1L,S_V_I(info_cc,i)); l++; } /*** Falls par selbstassoziiert ist, wird in info_pa fuer diese ***/ /*** Partition und in info_cc fuer die zugehoerige Hakenpartition ***/ /*** eine 2 eingetragen. ***/ erg += conjugate(par,conpar); if (comp(par,conpar) == 0L) { erg += m_i_i(2L,S_V_I(info_pa,i)); erg += hook_part(par,split_class); erg += m_i_i(2L,S_V_I(info_cc,indexofpart(split_class))); l++; } /*** Falls par lexikographisch groesser als die dazu assoziierte ***/ /*** Partition ist, erhaelt info_pa den Eintrag 1. ***/ else if (S_V_II(info_pa,indexofpart(conpar)) == 0L) erg += m_i_i(1L,S_V_I(info_pa,i)); i++; } while(next_apply(par)); /***********************************************************************/ /*** Initialisierung der Charaktertafel als Nullmatrix *****************/ erg += m_ilih_m(l,l,tafel); /*** Belegung der Charaktertafel ***************************************/ zeile = 0L; spalte = 0L; /*** Durchlaufe den Infovektor der irreduziblen Darstellungen mit i ***/ for(i=0L;i0L) { erg += charvalue(S_V_I(v_part,i), S_V_I(v_part,j), S_M_IJ(tafel,zeile,spalte), NULL); spalte++; if(S_V_II(info_cc,j)==2L) { erg += copy(S_M_IJ(tafel,zeile,spalte-1L), S_M_IJ(tafel,zeile,spalte)); spalte++; } } } zeile++; spalte = 0L; } /*** Im Falle einer zerfallenden irreduziblen Darstellung ***/ /*** muessen zwei Zeilen in der Charaktertafel berechnet ***/ /*** werden. ***/ if(S_V_II(info_pa,i)==2L) { erg += hook_part(S_V_I(v_part,i),split_class); /*** Durchlaufe den Infovektor der Konjugiertenklassen mit j. ***/ for(j=0L;j=0L; i--) { elementwert = S_PA_II(par,i); elementwert = 2L *(elementwert-j) + 1L; if (elementwert > 0L) { erg += c_i_i(element,elementwert); erg += append(v,element,hilfsvector); erg += copy(hilfsvector,v); } j++; } erg += m_v_pa(v,res); erg += freeall(v); erg += freeall(element); erg += freeall(hilfsvector); ENDR("hook_part"); } #endif /* PARTTRUE */ #ifdef PERMTRUE INT m_gl_first(a,b) OP a,b; /* AK 291092 */ { if (CYCLIC_GL(a)) return first_permutation(S_GL_CYCLIC_A(a),b); if (SYM_GL(a)) return first_permutation(S_GL_SYM_A(a),b); if (ALT_GL(a)) return first_permutation(S_GL_ALT_A(a),b); return error("m_gl_first: can not handle group label"); } INT m_gl_next(a,b,c) OP a,b,c; /* AK 291092 */ /* loop over all group elements */ { OP d; INT erg,i,j; if (b == c) { d = callocobject(); *d = *c; C_O_K(c,EMPTY); erg = m_gl_next(a,d,c); freeall(d); return erg; } if (SYM_GL(a)) { return next(b,c); } if (ALT_GL(a)) { erg = next(b,c); if (erg == FALSE) return erg; /* d.h. b war letzte permutation */ while (oddp(c)) { erg = next_apply(c); if (erg == FALSE) /* es gibt kein permutation aus an nach der permutation b */ { copy(b,c); return FALSE; } } return TRUE; } if (CYCLIC_GL(a)) { if (S_P_II(b,0L) == S_P_LI(b)) return FALSE; /* war die letzte */ copy(b,c); for (i=1L,j=0L;i=0;i--) if ( S_V_II(uc,i) < S_V_II(vc,i)-1) { if (i==0) { incr: inc(S_V_I(uc,i)); for (j=i+1;j S_PA_II(pa,i-1)) goto incr; else if (S_V_II(uc,i) < S_V_II(uc,i-1) ) goto incr; else continue; } /* keine weitere klasse */ FREEALL3(f,uc,vc); } while(next_apply(pa)); FREEALL2(pa,cm); ENDR("class_label_glnq"); } /* for the computation of c_ijk with group labels */ /* AK 080306 */ /* berechnung c_ijk mit gl */ INT class_rep(OP gl, OP cl, OP res) /* AK 080306 */ /* input group label gl class label cl output representing element */ { INT erg = OK; if (SYM_GL(gl)) erg += m_part_perm(cl,res); else if (ALT_GL(gl)) { if (S_O_K(cl) == PARTITION) erg += m_part_perm(cl,res); else if (S_O_K(cl)==VECTOR) { erg += std_perm(S_V_I(cl,0),res); if (S_V_II(cl,1)==1) { OP trans=callocobject(); make_n_kelmtrans(S_P_L(res),cons_eins,trans); mult(res,trans,res); mult(trans,res,res); freeall(trans); } } else error("class_rep(1): wrong cl for alternating group"); } else NYI("class_rep"); ENDR("class_rep"); } INT class_label(OP gl, OP ge, OP res) /* AK 080306 */ /* gl is grouplabel ge is a group element res becomes the corresponding class label */ { return m_gl_ge_cl(gl,ge,res); } INT compute_gl_charvalue(OP gl, OP il, OP cl, OP res) /* computes value of the irreducible character il on the class cl */ { INT erg = OK; if (SYM_GL(gl)) erg += charvalue(il,cl,res,NULL); else if (ALT_GL(gl)) { OP h=callocobject(); class_rep(gl,cl,h); if (S_O_K(il) == VECTOR) erg += a_charvalue_co(S_V_I(il,0),h,res,S_V_II(il,1)); else erg += a_charvalue_co(il,h,res,0); freeall(h); } else NYI("compute_gl_charvalue"); ENDR("compute_gl_charvalue"); } INT compute_gl_il_dimension(OP gl, OP il, OP res) { INT erg = OK; if (SYM_GL(gl)) erg += dimension(il,res); else if (ALT_GL(gl)) { if (S_O_K(il) == VECTOR) { erg += dimension(S_V_S(il),res); erg += half_apply(res); } else erg += dimension(il,res); } else NYI("compute_gl_il_dimension"); ENDR("compute_gl_il_dimension"); } INT compute_gl_cl_classorder(OP gl, OP cl, OP res) { INT erg = OK; if (SYM_GL(gl)) erg += ordcon(cl,res); else if (ALT_GL(gl)) { if (S_O_K(cl) == VECTOR) { erg += ordcon(S_V_S(cl),res); erg += half_apply(res); } else erg += ordcon(cl,res); } else NYI("compute_gl_cl_classorder"); ENDR("compute_gl_cl_classorder"); } INT compute_gl_c_ijk(OP gl, OP i, OP j, OP k, OP res) /* AK 080306 */ /* gl is grouplabel i,j,k are class labels of this group label res will be the result */ { INT erg = OK; if (SYM_GL(gl)) c_ijk_sn(i,j,k,res); else { /* we use the formula of curtis reiner */ OP il,h,ki,h1,h2,h3; INT l; CALLOCOBJECT3(il,h,ki); CALLOCOBJECT3(h1,h2,h3); m_i_i(0,res); /* ki is the class containing the inverse element */ class_rep(gl,k,h1); invers(h1,h1); class_label(gl,h1,ki); m_gl_il(gl,il); for (l=0;l 0 ? S_I_I(a): - S_I_I(a)),c); goto ende; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += absolute_longint(a,c); goto ende; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case MATRIX: erg += absolute_matrix(a,c); goto ende; #endif /* MATRIXTRUE */ #ifdef VECTORTRUE case WORD: case COMPOSITION: case VECTOR: erg += absolute_vector(a,c); goto ende; case INTEGERVECTOR: erg += absolute_integervector(a,c); goto ende; #endif /* VECTORTRUE */ default: erg += WTO("absolute(1)",a); goto ende; } ende: ENDR("absolute"); } INT transpose(a,b) OP a,b; /* AK 280388 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140891 V1.3 */ { INT erg=OK; COP("transpose(1)",a); COP("transpose(2)",b); CE2(a,b,transpose); switch (S_O_K(a)) { #ifdef MATRIXTRUE case KOSTKA: case KRANZTYPUS: case MATRIX: erg += transpose_matrix(a,b); goto ende; #endif /* MATRIXTRUE */ default: WTO("transpose(1)",a); goto ende; }; ende: ENDR("transpose"); } INT sub(a,b,c) OP a,b,c; /* AK 300388 */ /* c = a - b */ /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 270291 V1.2 */ /* AK 140891 V1.3 */ /* AK 260398 V2.0 */ { INT erg = OK; EOP("sub(1)",a); EOP("sub(2)",b); COP("sub(3)",c); CE3(a,b,c,sub); switch(S_O_K(a)) { default: erg += sub_default(a,b,c); break; } ENDR("sub"); } INT sub_default(a,b,c) OP a,b,c; /* AK 220202 */ { OP d; INT erg = OK; CTO(EMPTY,"sub_default(3)",c); CTO(ANYTYPE,"sub_default(1)",a); CTO(ANYTYPE,"sub_default(2)",b); d=CALLOCOBJECT(); ADDINVERS(b,d); ADD(a,d,c); FREEALL(d); CTO(ANYTYPE,"sub_default(e3)",c); ENDR("sub_default"); } INT sub_apply(a,b) OP a,b; /* AK 300102 */ /* b := b-a; */ { INT erg = OK; EOP("sub_apply(1)",a); EOP("sub_apply(2)",b); if (a == b) { erg += m_i_i(0,a); } else { ADDINVERS_APPLY(a); ADD_APPLY(a,b); ADDINVERS_APPLY(a); } ENDR("sub_apply"); } INT kgv(p1,second,d) OP p1, second, d; /* 031186 */ /* d = kgv(p1,second) */ /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 290591 V1.2 */ /* AK 140891 V1.3 */ /* AK 260398 V2.0 */ { INT erg = OK; OP a,b; EOP("kgv(1)",p1); EOP("kgv(2)",second); COP("kgv(3)",d); a=callocobject(); b=callocobject(); erg += mult(p1,second,a); erg += ggt(p1,second,b); erg += div(a,b,d); erg += freeall(a); erg += freeall(b); ENDR("kgv"); } INT signum(a,c) OP a,c; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */ /* AK 260398 V2.0 */ { INT erg=OK; EOP("signum(1)",a); COP("signum(2)",c); CE2(a,c,signum); switch (S_O_K(a)) { #ifdef PERMTRUE case PERMUTATION: erg += signum_permutation(a,c);break; #endif /* PERMTRUE */ default: erg += WTO("signum",a); break; }; ENDR("signum"); } INT lehmercode(a,b) OP a,b; /* berechnet den lehmercode entweder einer permuation oder eines vectors AK 270787 */ /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */ /* AK 260398 V2.0 */ { INT erg=OK; CE2(a,b,lehmercode); switch (S_O_K(a)) { #ifdef PERMTRUE case PERMUTATION: erg += lehmercode_permutation(a,b); break; case VECTOR: case INTEGERVECTOR: erg += lehmercode_vector(a,b); break; #endif /* PERMTRUE */ default: WTO("lehmercode",a); break; }; ENDR("lehmercode"); } INT add(a,b,d) OP a,b,d; /* AK 160986 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 270291 V1.2 */ /* AK 070891 V1.3 */ /* d = a+b */ { INT erg=OK; EOP("add(1)",a); EOP("add(2)",b); COP("add(3)",d); CE3(a,b,d,add); switch(S_O_K(a)) { #ifdef MONOPOLYTRUE case MONOPOLY: erg += add_monopoly (a,b,d); goto add_ende; #endif /* MONOPOLYTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += add_cyclo (a,b,d); goto add_ende; #endif /* CYCLOTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += add_sqrad (a,b,d); goto add_ende; #endif /* SQRADTRUE */ case INTEGER : erg += add_integer(a,b,d); break; case LAURENT : erg += add_laurent(a,b,d); break; #ifdef FFTRUE case FF: erg += add_ff(a,b,d); break; #endif /* FFTRUE */ #ifdef GRTRUE case GALOISRING: erg += add_galois(a,b,d); break; #endif /* GRTRUE */ #ifdef REIHETRUE case REIHE: erg += add_reihe(a,b,d); break; #endif /* REIHETRUE */ #ifdef PARTTRUE case PARTITION: erg += add_partition(a,b,d); break; #endif /* PARTTRUE */ #ifdef POLYTRUE case GRAL: case POLYNOM : erg += add_polynom(a,b,d); break; case MONOM : erg += add_monom(a,b,d); break; #endif /* POLYTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: erg += add_integervector(a,b,d); break; case VECTOR : erg += add_vector(a,b,d); break; #endif /* VECTORTRUE */ #ifdef SCHURTRUE case SCHUR : erg += add_schur(a,b,d); break; #endif /* SCHURTRUE */ #ifdef LONGINTTRUE case LONGINT : erg += add_longint(a,b,d); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS: case INTEGERMATRIX: case MATRIX : erg += add_matrix(a,b,d); break; #endif /* MATRIXTRUE */ #ifdef MONOMIALTRUE case MONOMIAL : erg += add_monomial(a,b,d); break; #endif /* MONOMIALTRUE */ #ifdef ELMSYMTRUE case ELM_SYM : erg += add_elmsym(a,b,d); break; #endif /* ELMSYMTRUE */ #ifdef HOMSYMTRUE case HOM_SYM : erg += add_homsym(a,b,d); break; #endif /* HOMSYMTRUE */ #ifdef POWSYMTRUE case POW_SYM : erg += add_powsym(a,b,d); break; #endif /* POWSYMTRUE */ #ifdef SCHUBERTTRUE case SCHUBERT: erg += add_schubert(a,b,d); break; #ifdef UNDEF { switch(S_O_K(b)) { case SCHUBERT : erg += add_schubert_schubert( a,b,d); break; default : { printobjectkind(b); return error("add_schubert:wrong second type"); } }; break; } #endif #endif /* SCHUBERTTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += add_symchar(a,b,d); break; #endif #ifdef BRUCHTRUE case BRUCH : erg += add_bruch (a,b,d); break; #endif /* BRUCHTRUE */ default: { if (nullp(a)) { erg += copy(b,d); break; } if (nullp(b)) { erg += copy(a,d); break; } printobjectkind(a); printobjectkind(b); return error("add: wrong types"); } }; add_ende: ENDR("add"); } INT sort(a) OP a; /* sortiert das object in aufsteigender reihenfolge AK 270787 */ /* AK 160986 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 070891 V1.3 */ { INT erg = OK; EOP("sort(1)",a); switch(S_O_K(a)) { #ifdef VECTORTRUE case INTEGERVECTOR: case VECTOR : erg += sort_vector(a);break; #endif /* VECTORTRUE */ default: erg += WTO("sort",a); break; }; ENDR("sort"); } INT length(a,d) OP a,d; /* 160986 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140891 V1.3 */ /* AK 240398 V2.0 */ { INT erg = OK; EOP("length(1)",a); COP("length(2)",d); CE2(a,d,length); switch(S_O_K(a)) { #ifdef BINTREETRUE case BINTREE : erg += length_bintree(a,d); break; #endif /* PARTTRUE */ #ifdef LISTTRUE case GRAL: case HOM_SYM: case POW_SYM: case ELM_SYM: case MONOMIAL: case LIST: case POLYNOM: case MONOPOLY: /* MD */ case SCHUBERT: case SCHUR: erg += length_list(a,d); break; #endif /* LISTTRUE */ #ifdef PARTTRUE case PARTITION : erg += length_partition(a,d); break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION : erg += length_permutation(a,d); break; #endif /* PERMTRUE */ #ifdef REIHETRUE case REIHE : erg += length_reihe(a,d); break; #endif /* REIHETRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION : erg += length_skewpartition(a,d); break; #endif /* SKEWPARTTRUE */ #ifdef VECTORTRUE case WORD: case COMPOSITION: case INTEGERVECTOR: case VECTOR : erg += length_vector(a,d); break; #endif /* VECTORTRUE */ default: erg += WTO("length",a); break; }; ENDR("length"); } INT content(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140891 V1.3 */ /* AK 240398 V2.0 */ { INT erg=OK; CE2(a,b,content); switch(S_O_K(a)) { #ifdef TABLEAUXTRUE case TABLEAUX : erg += content_tableaux(a,b ); break; #endif /* TABLEAUXTRUE */ #ifdef WORDTRUE case WORD : erg += content_word(a,b); break; #endif /* WORDTRUE */ default: erg += WTO("content",a); break; }; ENDR("content"); } INT sum(a,res) OP a,res; /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 120391 V1.2 */ /* AK 140891 V1.3 */ /* AK 170298 V2.0 */ { INT erg = OK; COP("sum(1)",a); COP("sum(2)",res); CE2(a,res,sum); switch(S_O_K(a)) { #ifdef VECTORTRUE case INTEGERVECTOR: case SUBSET: case COMPOSITION : erg += sum_integervector(a,res); break; case VECTOR : erg += sum_vector(a,res); break; #endif /* VECTORTRUE */ #ifdef PARTTRUE case PARTITION: erg += weight_partition(a,res); break; #endif /* PARTTRUE */ #ifdef MATRIXTRUE case MATRIX : case KOSTKA : case KRANZTYPUS : case INTEGERMATRIX : erg += sum_matrix(a,res); break; #endif /* MATRIXTRUE */ default: erg += WTO("sum",a); break; }; ENDR("sum"); } INT conjugate(a,res) OP a,res; /* AK 280689 V1.0 */ /* AK 281289 V1.1 */ /* AK 120891 V1.3 */ /* AK V2.0 170298 */ { INT erg = OK; COP("conjugate(1)",a); COP("conjugate(2)",res); CE2(a,res,conjugate); switch(S_O_K(a)) { #ifdef PARTTRUE case PARTITION: erg += conjugate_partition(a,res); break; #endif /* PARTTRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION : /* AK 020890 V1.1 */ erg += b_gk_spa( callocobject(), callocobject(), res); erg += conjugate_partition(S_SPA_G(a),S_SPA_G(res)); erg += conjugate_partition(S_SPA_K(a),S_SPA_K(res)); break; #endif /* SKEWPARTTRUE */ #ifdef MONOMTRUE case MONOM: erg += b_sk_mo(callocobject(),callocobject(),res); erg += copy(S_MO_K(a),S_MO_K(res)); erg += conjugate(S_MO_S(a),S_MO_S(res)); break; #endif /* MONOMTRUE */ #ifdef SCHURTRUE case SCHUR: erg += conjugate_schur(a,res); break; case MONOMIAL: erg += conjugate_monomial(a,res); break; case HOM_SYM: erg += conjugate_homsym(a,res); break; case ELM_SYM: erg += conjugate_elmsym(a,res); break; case POW_SYM: erg += conjugate_powsym(a,res); break; #endif /* SCHURTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX: erg += conjugate_tableaux(a,res,conjugate); break; #endif /* TABLEAUXTRUE */ default: erg += WTO("conjugate",a); break; }; ENDR("conjugate"); } INT addinvers(a,res) OP a,res; /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 270291 V1.2 */ /* AK 140891 V1.3 */ { INT erg = OK; COP("addinvers(1)",a); COP("addinvers(2)",res); CE2(a,res,addinvers); switch(S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH : erg += addinvers_bruch(a,res); break; #endif /* BRUCHTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += addinvers_cyclo (a,res); break; #endif /* CYCLOTRUE */ #ifdef FFTRUE case FF : erg += addinvers_ff(a,res); break; #endif /* FFTRUE */ #ifdef INTEGERTRUE case INTEGER : erg+= addinvers_integer(a,res); break; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT : erg+= addinvers_longint(a,res); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case MATRIX : erg+= addinvers_matrix(a,res); break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM : erg+= addinvers_monom(a,res); break; #endif /* MONOMTRUE */ #ifdef MONOPOLYTRUE case MONOPOLY: erg+= addinvers_monopoly (a,res); break; #endif /* MONOPOLYTRUE */ #ifdef POLYTRUE case ELM_SYM: case POW_SYM: case MONOMIAL: case HOM_SYM: case SCHUR: case SCHUBERT: case GRAL: case POLYNOM : erg += addinvers_polynom(a,res); break; #endif /* POLYTRUE */ #ifdef REIHETRUE /* AK 020893 */ case REIHE : erg += addinvers_reihe(a,res); break; #endif /* REIHETRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg+= addinvers_sqrad (a,res); break; #endif /* SQRADTRUE */ #ifdef CHARTRUE case SYMCHAR : erg += addinvers_symchar(a,res); break; #endif /* CHARTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case VECTOR : erg += addinvers_vector(a,res); break; #endif /* VECTORTRUE */ default: erg += WTO("addinvers(1)",a); break; }; ENDR("addinvers"); } INT binom_values[BINOMLIMIT][BINOMLIMIT] = { {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,0}, {1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,0}, {1, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,0}, {1, 3, 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,0}, {1, 4, 6, 4, 1, 0, 0, 0, 0, 0, 0, 0,0}, {1, 5,10, 10, 5, 1, 0, 0, 0, 0, 0, 0,0}, {1, 6,15, 20, 15, 6, 1, 0, 0, 0, 0, 0,0}, {1, 7,21, 35, 35, 21, 7, 1, 0, 0, 0, 0,0}, {1, 8,28, 56, 70, 56, 28, 8, 1, 0, 0, 0,0}, {1, 9,36, 84,126,126, 84, 36, 9, 1, 0, 0,0}, {1,10,45,120,210,252,210,120, 45, 10, 1, 0,0}, {1,11,55,165,330,462,462,330,165, 55,11, 1,0}, {1,12,66,220,495,792,924,792,495,220,66,12,1} }; INT binom_small(oben,unten,d) OP oben, unten, d; /* we know 0<= oben <= BINOMLIMIT 0<= unten all three a different, d is freed */ { INT erg = OK; CTO(INTEGER,"binom_small",oben); CTO(INTEGER,"binom_small",unten); CTO(EMPTY,"binom_small",d); SYMCHECK(S_I_I(oben) < 0 ,"binom_small:oben <0"); SYMCHECK(S_I_I(oben) > BINOMLIMIT ,"binom_small:oben > BINOMLIMIT"); SYMCHECK(S_I_I(unten) < 0 ,"binom_small:unten <0"); if (S_I_I(unten) > S_I_I(oben)) M_I_I(0,d); else M_I_I( binom_values [ S_I_I(oben) ] [S_I_I(unten)] ,d); ENDR("binom_small"); } INT binom(oben , unten, d) OP oben, unten, d; /* AK 041186 */ /* d = oben ! / unten ! * (oben -unten)! */ /* auf integer umgestellt am 120187 */ /* AK 280689 V1.0 */ /* AK 010290 V1.1 */ /* AK 140891 V1.3 */ /* AK 030892 oben may be POLYNOM */ /* AK 160703 oben or unten may be equal to d */ { OP a,b,c; INT i,ui; INT erg = OK; CTO(INTEGER,"binom(2)",unten); SYMCHECK(S_I_I(unten) < 0,"binom:unten < 0"); ui = S_I_I(unten); if (unten == d) /* AK160703 */ { a = CALLOCOBJECT(); SWAP(a,d); erg += binom(oben,a,d); FREEALL(a); goto ende; } if (oben == d) /* AK160703 */ { a = CALLOCOBJECT(); SWAP(a,d); erg += binom(a,unten,d); FREEALL(a); goto ende; } if (S_O_K(oben) == POLYNOM) /* AK 030892 */ { CALLOCOBJECT2(c,b); COPY(oben,c); M_I_I(-1,b); CLEVER_COPY(oben,d); for (i=1;i= 0L) { binom(a,b,c); (schalter++ % 2L == 0L ? add(c,d,d): sub(d,c,d)); dec(b); }; FREEALL(c); goto binomende; } if (S_I_I(oben)==S_I_I(unten)) { M_I_I(1L,d); goto ende;} if (S_I_I(oben)S_I_I(unten);i--) { M_I_I(i,a); MULT_APPLY_INTEGER(a,d); } GANZDIV_APPLY(d,b); /* d = d/b */ binomende: FREEALL(a); FREEALL(b); ende: ENDR("binom"); } INT inc(a) OP a; /* AK 280689 V1.0 */ /* AK 081289 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; EOP("inc(1)",a); switch(S_O_K(a)) { #ifdef INTEGERTRUE case INTEGER : INC_INTEGER(a); break; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT : erg += inc_longint(a); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS: case INTEGERMATRIX: case MATRIX : erg += inc_matrix(a); break; #endif /* MATRIXTRUE */ #ifdef PARTTRUE case PARTITION : INC_PARTITION(a); break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION : erg += inc_permutation(a); break; #endif /* PERMTRUE */ #ifdef REIHETRUE case REIHE : erg += inc_reihe(a); break; #endif /* REIHETRUE */ #ifdef TABLEAUXTRUE case TABLEAUX : erg += inc_tableaux(a); break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case SUBSET: case COMPOSITION: case VECTOR : erg += inc_vector(a); break; case BITVECTOR: erg += inc_bitvector(a); break; #endif /* VECTORTRUE */ default: erg += WTO("inc(1)",a); break; }; ENDR("inc"); } INT dec(a) OP a; /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; EOP("dec(1)",a); switch(S_O_K(a)) { #ifdef INTEGERTRUE case INTEGER : erg += dec_integer(a); break; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT : erg += dec_longint(a); break; #endif /* LONGINTTRUE */ #ifdef PARTTRUE case PARTITION : erg += dec_partition(a); break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION : erg += dec_permutation(a); break; #endif /* PERMTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: erg += dec_integervector(a); break; case VECTOR : erg += dec_vector(a); break; #endif /* VECTORTRUE */ default: erg += WTO("dec(1)",a); break; }; ENDR("dec"); } INT qdimension(n,d) OP n, d; /* AL 180393 */ { INT erg = OK; EOP("qdimension(1)",n); COP("qdimension(2)",d); CE2(n,d,qdimension); switch (S_O_K(n)) { #ifdef SCHUBERTTRUE /* AL 180393 */ case SCHUBERT: erg += dimension_schubert(n,d); break; #endif /* SCHUBERTTRUE */ default: WTO("qdimension(1)",n); break; } ENDR("qdimension"); } INT dimension(n,d) OP n, d; /* AK 011288 */ /* AK 060789 V1.0 */ /* AK 131289 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; EOP("dimension(1)",n); COP("dimension(2)",d); CE2(n,d,dimension); switch (S_O_K(n)) { #ifdef PARTTRUE case AUG_PART: erg += dimension_augpart(n,d); break; case PARTITION: erg += dimension_partition(n,d); break; #endif /* PARTTRUE */ #ifdef SCHUBERTTRUE /* AL 180393 */ case SCHUBERT: erg += dimension_schubert(n,d); break; #endif /* SCHUBERTTRUE */ #ifdef SCHURTRUE /* AK 020890 V1.1 */ case SCHUR: erg += dimension_schur(n,d); break; #endif /* SCHURTRUE */ #ifdef SKEWPARTTRUE /* AK 020890 V1.1 */ case SKEWPARTITION: erg += dimension_skewpartition(n,d); break; #endif /* SKEWPARTTRUE */ default: erg += WTO("dimension",n); break; } ENDR("dimension"); } INT div(a,b,c) OP a,b,c; /* exact division */ { INT erg = OK; EOP("div(1)",a); EOP("div(2)",b); COP("div(3)",c); CE3(a,b,c,div); switch(S_O_K(a)) { default: erg += div_default(a,b,c); break; } ENDR("div"); } INT div_default(a,b,d) OP a,b,d; /* AK 280689 V1.0 */ /* AK 071289 V1.1 */ /* AK 250391 V1.2 */ /* AK 140891 V1.3 */ /* d := a/b */ { /* AK 031286 als invers*mult */ INT erg = OK; OP c; CTO(ANYTYPE,"div_default(1)",a); CTO(ANYTYPE,"div_default(2)",b); CTO(EMPTY,"div_default(3)",d); c = CALLOCOBJECT(); INVERS(b,c); MULT(a,c,d); FREEALL(c); CTO(ANYTYPE,"div_default(e3)",d); ENDR("div_default"); } INT quores(a,b,c,d) OP a,b,c,d; /* c = ganzdiv(a,b) d = mod(a,b) */ /* AK 050291 V1.2 */ /* AK 140891 V1.3 */ { OP e; INT erg=OK; SYMCHECK( c == d ,"quores: two result in one variable"); if (a == c) { e =CALLOCOBJECT(); *e = *a; C_O_K(c,EMPTY); erg +=quores(e,b,c,d); FREEALL(e); goto quoresende; } if (a == d) { e =CALLOCOBJECT(); *e = *a; C_O_K(d,EMPTY); erg +=quores(e,b,c,d); FREEALL(e); goto quoresende; } if (b == c) { e =CALLOCOBJECT(); *e = *b; C_O_K(c,EMPTY); erg +=quores(a,e,c,d); FREEALL(e); goto quoresende; } if (b == d) { e =CALLOCOBJECT(); *e = *b; C_O_K(d,EMPTY); erg +=quores(a,e,c,d); FREEALL(e); goto quoresende; } if (not EMPTYP(d)) erg += freeself(d); if (not EMPTYP(c)) erg += freeself(c); if (EMPTYP(a) || EMPTYP(b)) goto quoresende; if (nullp(b)) { debugprint(a); debugprint(b); error("quores:null division"); goto endr_ende; } if (einsp(b)) { erg += copy(a,c); erg += null(a,d); /* AK 170206 */ goto quoresende; } switch(S_O_K(a)) { #ifdef INTEGERTRUE case INTEGER : erg += quores_integer(a,b,c,d);break; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT : erg += quores_longint(a,b,c,d);break; #endif /* LONGINTTRUE */ #ifdef MONOPOLYTRUE case MONOPOLY : erg += quores_monopoly(a,b,c,d);break; case POLYNOM: { OP aa,bb,cc,dd; aa = CALLOCOBJECT(); bb = CALLOCOBJECT(); cc = CALLOCOBJECT(); dd = CALLOCOBJECT(); t_POLYNOM_MONOPOLY(a,aa); t_POLYNOM_MONOPOLY(b,bb); erg += quores_monopoly(aa,bb,cc,dd); t_MONOPOLY_POLYNOM(cc,c); t_MONOPOLY_POLYNOM(dd,d); FREEALL4(aa,bb,cc,dd); break; } #endif /* MONOPOLYTRUE */ default: erg += WTT("quores",a,b); break; } quoresende: ENDR("quores"); } INT mod(a,b,c) OP a,b,c; /* AK 040393 */ /* AK 030498 V2.0 */ /* c := a % b; */ { OP d; INT erg = OK; EOP("mod(1)",a); EOP("mod(2)",b); SYMCHECK(NULLP(b),"mod: second parameter = zero"); CE3(a,b,c,mod); if (matrixp(a)) /* AK 300793 */ { if (S_O_K(b) == INTEGER) { erg += mod_matrix(a,b,c); goto endr_ende; } } else if (vectorp(a)) /* AK 101198 */ { if (S_O_K(b) == INTEGER) { erg += mod_vector(a,b,c); goto endr_ende; } } else if (S_O_K(a)==MONOM) { erg += mod_monom(a,b,c); goto endr_ende; } else if (S_O_K(a)==POLYNOM) { erg += mod_polynom(a,b,c); goto endr_ende; } else if (LISTP(a)) { OP s,k,z; erg += init(S_O_K(a),c); FORALL(z,a,{ k = CALLOCOBJECT(); erg += mod(S_MO_K(z),b,k); if (NULLP(k) ) FREEALL(k); else { s = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),k,s); COPY(S_MO_S(z),S_MO_S(s)); insert(s,c,NULL,NULL); } }); goto endr_ende; } d = CALLOCOBJECT(); if (S_O_K(a) == INTEGER) erg += quores_integer(a,b,d,c); else if (S_O_K(a) == LONGINT) erg += quores_longint(a,b,d,c); else if (S_O_K(a) == MONOPOLY) erg += quores_monopoly(a,b,d,c); else erg += WTO("mod",a); FREEALL(d); ENDR("mod"); } INT ganzdiv(a,b,c) OP a,b,c; /*AK 040393 */ /* c := a/b */ { OP d ; INT erg = OK; if (a == b) { m_i_i(1,c); goto endr_ende; } CE3(a,b,c,ganzdiv); d = callocobject(); if (S_O_K(a) == INTEGER) erg += quores_integer(a,b,c,d); else if (S_O_K(a) == LONGINT) erg += quores_longint(a,b,c,d); else if (S_O_K(a) == MONOPOLY) erg += quores_monopoly(a,b,c,d); else WTO("ganzdiv",a); erg += freeall(d); ENDR("ganzdiv"); } INT ganzdiv_longint(a,b,c) OP a,b,c; /* AK 051001 */ /* c = a/b */ { INT erg = OK; OP d; CTO(LONGINT,"ganzdiv_longint(1)",a); CTO(EMPTY,"ganzdiv_longint(3)",c); d = callocobject(); erg += quores_longint(a,b,c,d); erg += freeall(d); ENDR("ganzdiv_longint"); } INT ganzdiv_integer_integer(a,b,c) OP a,b,c; /* AK 291001 */ { INT erg = OK; CTO(INTEGER,"ganzdiv_integer_integer(1)",a); CTO(INTEGER,"ganzdiv_integer_integer(2)",b); CTO(EMPTY,"ganzdiv_integer_integer(3)",c); M_I_I(S_I_I(a) / S_I_I(b),c); ENDR("ganzdiv_integer_integer"); } INT ganzdiv_integer(a,b,c) OP a,b,c; /* AK 051001 */ /* a is INTEGER */ { INT erg = OK; OP d; CTO(INTEGER,"ganzdiv_integer(1)",a); CTO(EMPTY,"ganzdiv_integer(2)",c); if (S_O_K(b) == INTEGER) { M_I_I(S_I_I(a) / S_I_I(b),c); } else { d = CALLOCOBJECT(); erg += quores_integer(a,b,c,d); FREEALL(d); } ENDR("ganzdiv_integer"); } INT mod_apply_integer(a,b) OP a,b; /* AK 011101 */ /* a = a mod b */ { INT erg = OK; CTO(INTEGER,"mod_apply_integer(1)",a); switch(S_O_K(b)) { case INTEGER: M_I_I(S_I_I(a) % S_I_I(b), a); break; case LONGINT: erg += mod_apply_integer_longint(a,b); break; default: erg += WTO("mod_apply_integer(2)",b); break; } ENDR("mod_apply_integer"); } INT mod_apply(a,b) OP a,b; /* AK 051001 */ /* a := a mod b */ /* a and b may be identic */ { INT erg = OK; OP c; EOP("mod_apply(1)",a); EOP("mod_apply(2)",b); if (a == b) { erg += m_i_i(0,a); goto endr_ende; } switch(S_O_K(a)) { case INTEGER: erg += mod_apply_integer(a,b); goto endr_ende; case LONGINT: erg += mod_apply_longint(a,b); goto endr_ende; default: break; } c = callocobject(); erg += swap(a,c); erg += mod(c,b,a); erg += freeall(c); ENDR("mod_apply"); } INT ganzdiv_apply_integer(a,b) OP a,b; /* AK 011101 */ /* a := a/b */ { INT erg = OK; CTO(INTEGER,"ganzdiv_apply_integer(1)",a); switch (S_O_K(b) ) { case INTEGER: M_I_I(S_I_I(a)/S_I_I(b),a); break; default: { OP c; c = CALLOCOBJECT(); *c = *a; C_O_K(a,EMPTY); erg += ganzdiv_integer(c,b,a); FREEALL(c); } break; } ENDR("ganzdiv_apply_integer"); } INT div_apply_integer(a,b) OP a,b; /* AK 011101 */ /* a = a / b */ { INT erg = OK; CTO(INTEGER,"div_apply_integer(1)",a); switch (S_O_K(b) ) { case INTEGER: if (S_I_I(b) == 1); else if (S_I_I(b) == -1) ADDINVERS_APPLY(a); else if ((S_I_I(a) % S_I_I(b)) == 0) M_I_I(S_I_I(a)/S_I_I(b),a); else { erg += m_ioiu_b(S_I_I(a),S_I_I(b),a); erg += kuerzen(a); } break; default: { OP c; c = CALLOCOBJECT(); *c = *a; C_O_K(a,EMPTY); erg += div(c,b,a); FREEALL(c); } break; } ENDR("div_apply_integer"); } INT ganzdiv_apply(a,b) OP a,b; /* AK 151294 */ /* a := a/b */ /* a and b may be identic */ { INT erg = OK; EOP("ganzdiv_apply",a); EOP("ganzdiv_apply",b); if (a == b) { erg += m_i_i((INT)1,a); goto endr_ende; } switch(S_O_K(a)) { case INTEGER: erg += ganzdiv_apply_integer(a,b); break; case LONGINT: erg += ganzdiv_apply_longint(a,b); break; default: { OP c; c = CALLOCOBJECT(); *c = *a; C_O_K(a,EMPTY); erg += ganzdiv(c,b,a); FREEALL(c); } break; } ENDR("ganzdiv_apply"); } INT div_apply(a,b) OP a,b; /* AK 151294 */ /* a := a/b */ /* a and b may be identic */ /* AK 291104 V3.0 */ { INT erg = OK; EOP("div_apply(1)",a); EOP("div_apply(2)",b); if (a == b) erg += eins(a,a); else { switch(S_O_K(a)) { case INTEGER: erg += div_apply_integer(a,b); break; default: { OP c; c = CALLOCOBJECT(); *c = *a; C_O_K(a,EMPTY); erg += div(c,b,a); FREEALL(c); } break; } } ENDR("div_apply"); } INT fakul(n,d) OP n, d; /* AK 081086 */ /* d = n! */ /* auf integer umgestellt 120187 */ /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060391 V1.2 */ /* AK 140891 V1.3 */ /* n and d may be identic */ { INT erg = OK; EOP("fakul(1)",n); COP("fakul(2)",d); CTO(INTEGER,"fakul(1)",n); SYMCHECK(S_I_I(n) < 0,"fakul:negativ INTEGER"); if (S_I_I(n) > (INT)12) { #ifdef LONGINTTRUE erg+=fakul_longintresult(n,d); goto endr_ende; #else /* LONGINTTRUE */ erg += error("fakul:overflow no LONGINT available"); goto endr_ende; #endif /* LONGINTTRUE */ } if (d != n) FREESELF(d); switch(S_I_I(n)) { case 0: case 1: M_I_I(1L,d);break; case 2: M_I_I(2L,d);break; case 3: M_I_I(6L,d);break; case 4: M_I_I(24L,d);break; case 5: M_I_I(120L,d);break; case 6: M_I_I(720L,d);break; case 7: M_I_I(5040L,d);break; case 8: M_I_I(40320L,d);break; case 9: M_I_I(362880,d);break; case 10: M_I_I(3628800L,d);break; case 11: M_I_I(39916800L,d);break; case 12: M_I_I(479001600L,d);break; } ENDR("fakul"); } #ifdef LONGINTTRUE INT fakul_longintresult(n,res) OP n,res; /* AK 180888 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140591 V1.2 */ /* AK 140891 V1.3 */ /* n is of type INTEGER and > 12 */ /* n and res may be identic */ { OP i = callocobject(); OP s = callocobject(); INT erg = OK,ni; CTO(INTEGER,"fakul_longintresult",n); ni = S_I_I(n); erg += m_i_longint(479001600L,res); /* 12! */ M_I_I(13L,i); while (S_I_I(i) <= ni) { if ((S_I_I(i)+4) > ni) { erg += mult_apply_integer_longint(i,res); INC_INTEGER(i); } else { if (S_I_I(i) < 120) { M_I_I((S_I_I(i)*(S_I_I(i)+1)* (S_I_I(i)+2)*(S_I_I(i)+3)),s); erg += mult_apply_integer_longint(s,res); M_I_I(S_I_I(i)+4,i); } else if (S_I_I(i) < 700) { M_I_I((S_I_I(i)*(S_I_I(i)+1)*(S_I_I(i)+2)),s); erg += mult_apply_integer_longint(s,res); M_I_I(S_I_I(i)+3,i); } else if (S_I_I(i) < 20000) { M_I_I((S_I_I(i)*(S_I_I(i)+1)),s); erg += mult_apply_integer_longint(s,res); M_I_I(S_I_I(i)+2,i); } else { erg += mult_apply_integer_longint(i,res); INC_INTEGER(i);} } } FREEALL2(i,s); ENDR("fakul_longint"); } #endif /* LONGINTTRUE */ #define GGT_INT_INT(ai,bi,res)\ do { \ INT c;\ if (ai < 0) ai = -ai;\ if (bi < 0) bi = -bi;\ if (ai == 0) {\ res = bi;\ }\ else if (bi == 0) {\ res = ai;\ }\ else if ( ai == 1 || bi == 1) {\ res = 1;\ }\ else if (ai == bi) {\ res = ai;\ }\ else {\ c =0;\ while ((ai & 1) == 0 && (bi & 1) == 0)\ {\ ai >>= 1;\ bi >>= 1;\ c++;\ }\ while ((ai & 1) == 0)\ ai >>= 1;\ while ((bi & 1) == 0)\ bi >>= 1;\ /* beide ungerade */\ \ while (ai != bi)\ if (ai > bi)\ {\ ai -= bi;\ do\ ai >>= 1;\ while ((ai & 1) == 0);\ }\ else\ {\ bi -= ai;\ do\ bi >>= 1;\ while ((bi & 1) == 0);\ }\ res = ai << c;\ }\ } while (0) INT ggt_integer_integer(a,b,d) OP a,b,d; /* AK 300102 */ /* always positive */ { INT res,ai,bi,erg = OK; CTO(INTEGER,"ggt_integer_integer(1)",a); CTO(INTEGER,"ggt_integer_integer(2)",b); CTTO(EMPTY,INTEGER,"ggt_integer_integer(3)",d); ai = S_I_I(a); bi = S_I_I(b); GGT_INT_INT(ai,bi,res); M_I_I(res,d); ENDR("ggt_integer_integer"); } INT ggt_integer(a,b,c) OP a,b,c; { INT erg = OK; CTO(INTEGER,"ggt_integer(1)",a); CTO(EMPTY,"ggt_integer(3)",c); switch(S_O_K(b)) { case INTEGER: erg += ggt_integer_integer(a,b,c); goto endr_ende; case LONGINT: erg += ggt_integer_longint(a,b,c); goto endr_ende; default: erg += WTO("ggt_integer(2)",b); goto endr_ende; } ENDR("ggt_integer"); } INT ggt_integer_longint(a,b,d) OP a,b,d; /* always positive */ /* AK 300102 */ { INT erg = OK; OP ac; CTO(INTEGER,"ggt_integer_longint(1)",a); CTO(LONGINT,"ggt_integer_longint(2)",b); CTTO(INTEGER,EMPTY,"ggt_integer_longint(3)",d); if (S_I_I(a) == 0) { C_O_K(d,EMPTY); erg += copy_longint(b,d); } else { INT t=0; ac = CALLOCOBJECT(); if (NEGP_INTEGER(a)) { ADDINVERS_APPLY_INTEGER(a); t=1; } erg += mod_longint_integer(b,a,ac); erg += ggt_integer_integer(ac,a,d); if (t==1) { ADDINVERS_APPLY_INTEGER(a); t=0; } FREEALL(ac); } ENDR("ggt_integer_longint"); } INT ggt_i(i,j) INT i, j; /* AK 010202 */ { INT res; GGT_INT_INT(i,j,res); return res; } INT ggt_integer_integer_slow(a,b,c) OP a,b,c; { return ggt_integer(a,b,c); } INT ggt_integer_slow(a,b,c) OP a,b,c; /* AK 021101 faster als mit div und mod */ /* AK 261101 ggt immer positiv */ { INT erg = OK; INT t; OP d; CTO(INTEGER,"ggt_integer(1)",a); CTTO(LONGINT,INTEGER,"ggt_integer(2)",b); CTO(EMPTY,"ggt_integer(3)",c); if (NULLP_INTEGER(a)) { COPY(b,c); if (NEGP(c)) ADDINVERS_APPLY(c); goto endr_ende; } if (NULLP(b)) { COPY(a,c); if (NEGP(c)) ADDINVERS_APPLY(c); goto endr_ende; } d = CALLOCOBJECT(); if (NEGP_INTEGER(a)) erg += ADDINVERS_INTEGER(a,d); else COPY(a,d); if (NEGP(b)) ADDINVERS(b,c); else COPY(b,c); while((t=COMP(d,c)) != 0) { if (t == 1) { ADDINVERS_APPLY(c); ADD_APPLY(c,d); ADDINVERS_APPLY(c); } else { ADDINVERS_APPLY(d); ADD_APPLY(d,c); ADDINVERS_APPLY(d); } } FREEALL(d); ENDR("ggt_integer"); } INT ggt(a,b,c) OP a,b,c; /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 010290 V1.1 */ /* AK 140591 V1.2 */ /* AK 140891 V1.3 */ /* AK 030498 V2.0 */ /* AK 261101 ggt ist immer positiv */ { OP i,j; INT erg=OK,comperg; EOP("ggt(1)",a); EOP("ggt(2)",b); COP("ggt(3)",c); CE3(a,b,c,ggt); if (S_O_K(a) == INTEGER) { erg+=ggt_integer(a,b,c); goto endr_ende; } else if (S_O_K(a) == LONGINT) { erg+=ggt_longint(a,b,c); goto endr_ende; } else if ( (S_O_K(a) == MONOPOLY ) && (S_O_K(b) == MONOPOLY) ) /* AK 170206 */ /* only with finite field coeffs */ { if (S_O_K(S_PO_K(a) ) != FF) error("ggt-monopoly: only finite field coeffs "); if (S_O_K(S_PO_K(b) ) != FF) error("ggt-monopoly: only finite field coeffs "); { OP aa = CALLOCOBJECT(); OP bb = CALLOCOBJECT(); t_MONOPOLY_POLYNOM(a,aa); t_MONOPOLY_POLYNOM(b,bb); ggt_field_polynom(aa,bb,c); t_POLYNOM_MONOPOLY(c,c); freeall(bb); freeall(aa); } } else { erg += WTO("ggt(1)",a); goto endr_ende; } ENDR("ggt"); } #ifdef UNDEF INT hoch_pre200902(a,b,c) OP a,b,c; { INT erg = OK; EOP("hoch(1)",a); EOP("hoch(2)",b); COP("hoch(3)",c); CE3(a,b,c,hoch); switch(S_O_K(a)) { case INTEGER: erg += hoch_integer(a,b,c); break; case LONGINT: erg += hoch_longint(a,b,c); break; case BRUCH: erg += hoch_bruch(a,b,c); break; default: erg += hoch_default(a,b,c); break; } ENDR("hoch"); } #endif INT hoch(a,b,c) OP a,b,c ; /* c = a^b */ /* algorithm 1.2.3 in cohen:a course in computational algebraic number theory */ /* AK 200902 V2.1 */ { INT erg = OK; EOP("hoch(1)",a); CTTO(INTEGER,LONGINT,"hoch(2)",b); COP("hoch(3)",a); CE3(a,b,c,hoch); { eins(a,c); if (not NULLP(b)) { INT f; OP N,z; N = CALLOCOBJECT(); z = CALLOCOBJECT(); if (NEGP(b)) { ADDINVERS(b,N); INVERS(a,z); } else { COPY(b,N); COPY(a,z); } f = number_of_bits(N)-1; CLEVER_COPY(z,c); while (1) { INT i; if (f == 0) break; else f--; square_apply(c); if (bit(N,f)) MULT_APPLY(z,c); } FREEALL2(N,z); } } ENDR("hoch"); } INT hoch_default(basis,expon,ergeb) OP basis, ergeb, expon; /* AK 041186 ergeb = basis ** expon */ /* AK 031286 ok */ /* AK 280689 V1.0 */ /* AK 160190 V1.1 */ /* AK 090891 V1.3 */ /* AK 030496 V2.0 */ { INT erg = OK; CTTO(INTEGER,LONGINT,"hoch_default(2)",expon); CTO(EMPTY,"hoch_default(1)",ergeb); if (NEGP(expon)) { OP c=callocobject(); erg += invers(basis,c); erg += addinvers_apply(expon); erg += hoch_default(c,expon,ergeb); erg += addinvers_apply(expon); erg += freeall(c); goto endr_ende; } else if (NULLP(expon)) M_I_I(1,ergeb); else if (EINSP(expon)) COPY(basis,ergeb); else { OP n = callocobject(); OP a = callocobject(); COPY(expon,n); COPY(basis,a); COPY(basis,ergeb); /* AK 290692 */ DEC(n); /* AK 290692 */ while (not NULLP(n)) { MULT_APPLY(a,ergeb); DEC(n); } FREEALL2(a,n); }; ENDR("hoch_default"); } INT invers(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 070789 sonderfaelle 0 und 1 */ /* AK 081289 V1.1 */ /* AK 250391 V1.2 */ /* AK 140891 V1.3 */ { INT erg = OK; EOP("invers(1)",a); COP("invers(2)",b); /* no test on null , e.g. permutation */ if (EINSP(a)) /* AK 070789 */ { if (a == b) goto endr_ende; CLEVER_COPY(a,b); goto endr_ende; } CE2(a,b,invers); switch(S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH : erg += invers_bruch(a,b); break; #endif /* BRUCHTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += invers_cyclo (a,b); break; #endif /* CYCLOTRUE */ #ifdef FFTRUE case FF : erg += invers_ff(a,b); break; #endif /* FFTRUE */ #ifdef GRTRUE case GALOISRING: erg += invers_galois(a,b); break; #endif /* GRTRUE */ #ifdef LAURENTTRUE case LAURENT : erg += invers_laurent(a,b); break; #endif /* LAURENTTRUE */ #ifdef MONOPOLYTRUE case MONOPOLY : erg += invers_monopoly(a,b); break; #endif /* MONOPOLYTRUE */ #ifdef LONGINTTRUE case LONGINT : erg += invers_longint(a,b); break; #endif /* LONGINTTRUE */ #ifdef INTEGERTRUE case INTEGER : erg += invers_integer(a,b); break; #endif /* INTEGERTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS: case KOSTKA : case MATRIX : erg += invers_matrix(a,b); break; #endif /* MATRIXTRUE */ #ifdef PERMTRUE case PERMUTATION : erg += invers_permutation(a,b); break; #endif /* PERMTRUE */ #ifdef KRANZTRUE case KRANZ : erg += invers_kranz(a,b); break; #endif /* KRANZTRUE */ #ifdef POLYTRUE case POLYNOM : /* CC */ erg += invers_POLYNOM(a,b); break; #endif /* POLYTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += invers_sqrad (a,b); break; #endif /* SQRADTRUE */ default: erg += WTO("invers(1)",a); break; }; ENDR("invers"); } INT multadd_apply_default(a,b,c) OP a,b,c; { INT erg =OK; OP d; d=CALLOCOBJECT(); MULT(a,b,d); ADD_APPLY(d,c); FREEALL(d); ENDR("multadd_apply_default"); } INT multadd_apply(a,b,c) OP a,b,c; /* c += a*b */ /* AK 170607 */ { INT erg =OK; if ( (S_O_K(a) != S_O_K(b)) || (S_O_K(c) != S_O_K(b)) ) { multadd_apply_default(a,b,c); } else { switch(S_O_K(a)) { case FF: multadd_apply_ff(a,b,c); break; default: multadd_apply_default(a,b,c); break; } } ENDR("multadd_apply"); } INT mult(a,b,d) OP a,b,d; /* AK 280689 V1.0 */ /* AK 081289 V1.1 */ /* AK 140891 V1.3 */ /* AK 070498 V2.0 */ { INT erg = OK; EOP("mult(1)",a); EOP("mult(2)",b); COP("mult(3)",d); CE3(a,b,d,mult); switch(S_O_K(a)) { #ifdef MONOPOLYTRUE case MONOPOLY: erg+=mult_monopoly (a,b,d); break; #endif /* MONOPOLYTRUE */ #ifdef MONOMTRUE case MONOM: erg+=mult_monom (a,b,d); break; #endif /* MONOMTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg+=mult_cyclo (a,b,d); break; #endif /* CYCLOTRUE */ #ifdef REIHETRUE case REIHE: erg+=mult_reihe(a,b,d); break; #endif /* REIHETRUE */ #ifdef FFTRUE case FF: erg+=mult_ff(a,b,d); break; #endif /* FFTRUE */ #ifdef GRTRUE case GALOISRING: erg+=mult_galois(a,b,d); break; #endif /* GRTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg+=mult_sqrad (a,b,d); break; #endif /* SQRADTRUE */ #ifdef BRUCHTRUE case BRUCH : erg+=mult_bruch(a,b,d); break; #endif /* BRUCHTRUE */ #ifdef INTEGERTRUE case INTEGER : erg+=mult_integer(a,b,d); break; #endif /* INTEGERTRUE */ #ifdef LAURENTTRUE case LAURENT : erg+=mult_laurent(a,b,d); break; #endif /* LAURENTTRUE */ #ifdef POLYTRUE case POLYNOM : erg+=mult_polynom(a,b,d); break; #endif /* POLYTRUE */ #ifdef SCHUBERTTRUE case SCHUBERT : switch(S_O_K(b)) { case BRUCH: case LONGINT: case INTEGER: erg+=mult_scalar_schubert(b, a, d); break; case POLYNOM: erg+=mult_schubert_polynom(a,b,d); break; case SCHUBERT: erg+=mult_schubert_schubert(a,b,d); break; }; break; #endif /* SCHUBERTTRUE */ #ifdef SCHURTRUE case SCHUR : erg += mult_schur(a,b,d); break; case MONOMIAL: erg += mult_monomial(a,b,d); break; case POW_SYM : erg += mult_powsym(a,b,d); break; case ELM_SYM : erg += mult_elmsym(a,b,d); break; case HOM_SYM : erg+=mult_homsym(a,b,d); break; #endif /* SCHURTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS: case KOSTKA : case MATRIX : erg+=mult_matrix(a,b,d); break; #endif /* MATRIXTRUE */ #ifdef LONGINTTRUE case LONGINT: erg+=mult_longint(a,b,d); break; #endif /* LONGINTTRUE */ #ifdef PERMTRUE case PERMUTATION: erg+=mult_permutation(a,b,d); break; #endif /* PERMTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case VECTOR : switch(S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: #endif /* BRUCHTRUE */ case LONGINT: case INTEGER: erg+=mult_scalar_vector(b,a,d); break; case VECTOR: case INTEGERVECTOR: erg+=mult_vector_vector(a,b,d); break; #ifdef MATRIXTRUE case MATRIX: erg+=mult_vector_matrix(a,b,d); break; #endif /* MATRIXTRUE */ default: printobjectkind(b); error("mult_vector:wrong second type"); return ERROR; }; break; #endif /* VECTORTRUE */ #ifdef CHARTRUE case SYMCHAR : switch(S_O_K(b)) { case BRUCH: case LONGINT: case INTEGER: erg+=mult_scalar_symchar(b,a,d); break; case SYMCHAR: erg+=mult_symchar_symchar(a,b,d); break; default: printobjectkind(b); error("mult_symchar in mult:wrong second type"); return ERROR; }; break; #endif /* CHARTRUE */ #ifdef KRANZTRUE case KRANZ : switch(S_O_K(b)) { case KRANZ: erg+=mult_kranz_kranz(a,b,d); break; default: printobjectkind(b); error("mult_kranz in mult:wrong second type"); return ERROR; }; break; #endif /*KRANZTRUE */ #ifdef GRALTRUE case GRAL: erg += mult_gral(a,b,d); break; #endif default: WTT("mult",a,b); } ENDR("mult"); } INT scalarproduct(a,b,c) OP a,b,c; /* AK 010888 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140891 V1.3 */ { INT erg=OK; EOP("scalarproduct",a); EOP("scalarproduct",b); CE3(a,b,c,scalarproduct); CTO(EMPTY,"scalarproduct(3)",c); switch(S_O_K(a)) { #ifdef SCHUBERTTRUE case SCHUBERT: erg += scalarproduct_schubert(a,b,c); break; #endif /* SCHURTRUE */ #ifdef SCHURTRUE case SCHUR : erg += scalarproduct_schur(a,b,c); break; #endif /* SCHURTRUE */ #ifdef MONOMIALTRUE case MONOMIAL : erg += scalarproduct_monomial(a,b,c); break; #endif /* MONOMIALTRUE */ #ifdef HOMSYMTRUE case HOMSYM : erg += scalarproduct_homsym(a,b,c); break; #endif /* HOMSYMTRUE */ #ifdef ELMSYMTRUE case ELMSYM : erg += scalarproduct_elmsym(a,b,c); break; #endif /* ELMSYMTRUE */ #ifdef POWSYMTRUE case POWSYM : erg += scalarproduct_powsym(a,b,c); break; #endif /* POWSYMTRUE */ #ifdef CHARTRUE case SYMCHAR : erg += scalarproduct_symchar(a,b,c); break; #endif /* CHARTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case VECTOR : erg += scalarproduct_vector(a,b,c); break; #endif /* VECTORTRUE */ default: erg += WTT("scalarproduct",a,b); break; }; ENDR("scalarproduct"); } #ifdef POLYTRUE INT vander(n,res) OP n,res; /* AK 300588 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140891 V1.3 */ /* n and res may be equal */ { INT ni,i,j,erg = OK; OP a,b,c; EOP("vander",n); CTO(INTEGER,"vander",n); ni = S_I_I(n); m_i_i(1L,res); a = callocobject(); b = callocobject(); c = callocobject(); for (i=2L;i<=ni;i++) for (j=1L;j -1073741824) && /* 2^30 */ (S_I_I(a) < 1073741824) ) { M_I_I( (S_I_I(a)<<1),a); } else { erg += t_int_longint(a,a); erg += double_apply_longint(a); } goto ende; case LONGINT: erg += double_apply_longint(a); goto ende; case BRUCH: double_apply(S_B_O(a)); erg += kuerzen(a); goto ende; default: erg += double_apply_default(a); goto ende; } ende: ENDR("double_apply"); } INT add_apply(a,b) OP a,b; /* b = a + b */ /* AK 120390 V1.1 */ /* AK 140591 V1.2 */ /* AK 140891 V1.3 */ /* AK 270298 V2.0 */ { INT erg = OK; EOP("add_apply(1)",a); EOP("add_apply(2)",b); if (a == b) { erg += double_apply(a); goto endr_ende; } /* switching according to the first type */ switch(S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH: erg += add_apply_bruch(a,b); break; #endif /* BRUCHTRUE */ #ifdef FFTRUE case FF: erg += add_apply_ff(a,b); break; #endif /* FFTRUE */ #ifdef POLYTRUE case GRAL: erg += add_apply_gral(a,b) ; break; #endif /* POLYTRUE */ case INTEGER: erg += add_apply_integer(a,b); break; #ifdef LONGINTTRUE case LONGINT: erg += add_apply_longint(a,b); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS: case MATRIX: erg += add_apply_matrix(a,b); break; #endif /* MATRIXTRUE */ #ifdef REIHETRUE case REIHE: erg += add_apply_reihe(a,b); break; #endif /* REIHETRUE */ #ifdef SCHUBERTTRUE case SCHUBERT: erg += add_apply_schubert(a,b); break; #endif /* SCHUBERTTRUE */ #ifdef SCHURTRUE case POW_SYM: case MONOMIAL: case HOM_SYM: case ELM_SYM: case SCHUR: erg += add_apply_symfunc(a,b); break; #endif /* SCHURTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += add_apply_symchar(a,b); break; #endif /* CHARTRUE */ #ifdef POLYTRUE case POLYNOM: erg += add_apply_polynom(a,b); break; #endif /* POLYTRUE */ case VECTOR: erg += add_apply_vector(a,b); break; case INTEGERVECTOR: erg += add_apply_integervector(a,b); break; #ifdef MONOPOLYTRUE case MONOPOLY: erg += add_apply_monopoly (a,b); break; #endif /* MONOPOLYTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += add_apply_cyclo (a,b); break; #endif /* CYCLOTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += add_apply_sqrad (a,b); break; #endif /* SQRADTRUE */ default: erg += add_apply_default(a,b); break; } ende: ENDR("add_apply"); } INT add_apply_default(a,b) OP a,b; /* AK 040302 */ { INT erg = OK; OP c; EOP("add_apply_default(1)",a); EOP("add_apply_default(2)",b); c = CALLOCOBJECT(); SWAP(b,c); ADD(a,c,b); FREEALL(c); ENDR("add_apply_default"); } INT multinom_small(a,b,c) OP a,b,c; /* AK 120901 */ { INT erg = OK,i; switch(S_I_I(a)) { case 1: M_I_I(1L,c);break; case 2: M_I_I(2L,c);break; case 3: M_I_I(6L,c);break; case 4: M_I_I(24L,c);break; case 5: M_I_I(120L,c);break; case 6: M_I_I(720L,c);break; case 7: M_I_I(5040L,c);break; case 8: M_I_I(40320L,c);break; case 9: M_I_I(362880,c);break; case 10: M_I_I(3628800L,c);break; case 11: M_I_I(39916800L,c);break; case 12: M_I_I(479001600L,c);break; default: error("wrong int value in multinom_small");goto endr_ende; } for (i=0;i= 0. c is freed first. The object a may INTEGER or POLYNOM. The object b must be INTEGER. BUGS: It works only for INTEGER objects. Not for LONGINT NAME: conjugate SYNOPSIS: INT conjugate(OP in, out) DESCRIPTION: computes the conjugate partition, it works for PARTITION and SKEWPARTITION. the variables in and out may be equal. In the case of a wrong input you gat an error message. The variable out is freed before the computation. It also works for SCHUR and the other symmetric functions, here it is applied to the partitions labeling one summand. Other symmetric functions are: HOM_SYM, ELM_SYM, POW_SYM, MONOMIAL RETURN: OK or ERROR in the case of an error BUGS: should work for CYCLOTOMIC, also for GRAL and PERMUTATION and MATRIX (but different parameters) EXAMPLE: ...... a = callocobject(); b = callocobject(); scan(PARTITION,a); conjugate(a,b); println(b); ...... NAME: dec SYNOPSIS: INT dec(OP a) DESCRIPTION: decrease a by one, if a is INTEGER or LONGINT. In the case of a VECTOR, PERMUTATION, PARTITION, the last element is discarded. RETURN: OK or ERROR NAME: det SYNOPSIS: INT det(a,b) DESCRIPTION: computes the determinant of the MATRIX a. a may also be of type KRANZTYPUS. a and b may be equal, b is freed first. BUGS: it uses an algorithm with triangulisation, so it works only for entries which allow the routine div. To avoid this algorithm use det_mat_imm NAME: dimension SYNOPSIS: INT dimension(OP label, result) DESCRIPTION: Computes the dimension of the representation of the symmetric group labeled by the input. It works for the following input objects: PARTITION, SCHUR, SKEWPARTITION, AUGPART, SCHUBERT. label and result may be equal. result is freed first RETURN: OK or ERROR NAME: div SYNOPSIS: INT div(a,b,c) DESCRIPTION: computes c = a/b. It is exact division, it means that the division of to INTEGERS or LONGINTS gives a BRUCH object. If you want to avoid this use ganzdiv. The routine uses invers and mult, so it works for all objects which have invers and mutl defined. RETURN: OK or ERROR NAME: fakul SYNOPSIS: INT fakul(OP a,b) DESCRIPTION: b becomes a!. a is an INTEGER object. a must be >= 0. a and b may be equal. b is freed first. BUGS: LONGINT should be possible for a. RETURN: OK or ERROR EXAMPLE: #include "def.h" #include "macro.h" main() { OP b,h2; anfang(); b=callocobject(); h2=callocobject(); scan(INTEGER,h2); fakul(h2,b); println(b); freeall(b); freeall(h2); ende(); } NAME: ganzdiv SYNOPSIS: INT ganzdiv(a,b,c) DESCRIPTION: computes the integer part of the division a / b. it works for INTEGER and LONGINT a and b. The varaibles a b c may be equal. c is freed first. You must be careful if you have a negativ object a. you compute the next smaller INTEGER, so a=-5, b=2 ==> c=-3. comprae this with INT quores(). RETURN: OK or ERROR BUGS: sometimes you have POLYNOM etc. objects, which are integers, but you can not use this routine. e.g. the POLYNOM 4 [0,0,0] is the INTEGER object 4. NAME: ganzsquareroot SYNOPSIS: INT ganzsquareroot(a,b) DESCRIPTION: computes the integer part of the squareroot of the input object a. The result is in b, which is freed first. It works for INTEGER objects a. The variables a and may be equal. BUGS: It doesnt work for LONGINT objects. RETURN: OK or ERROR. NAME: ggt SYNOPSIS: INT ggt(a,b,c) DESCRIPTION: computes the gcd of a and b the result is c. The variables a b c may be equal. c is freed first. The routine works for all objects which allow absolute, posp, comp, mod, addinvers, negp so it works only for INTEGER and LONGINT RETURN: OK or ERROR BUGS: POLYNOM would be useful NAME: hoch SYNOPSIS: INT hoch(OP basis,exponent,result) DESCRIPTION: computes basis^exponent to result. result is freed to an empty object first. The variables basis exponent and result may be equal. Following types are allowed exponent: INTEGER LONGINT basis: all types, which can be multiplied using mult_apply The input variables may be equal. The exponent may be a negative value. RETURN: OK if no error ERROR else. NAME: inc SYNOPSIS: INT inc(OP a) DESCRIPTION: increase a by one, if a is INTEGER or LONGINT. In the case of VECTOR an empty object is appended. The same in the case of PARTITION object. In the case of an PERMUTATION object, there will be inserted a leading fixpoint. In the case of MATRIX or KRANZTYPUS object there will be a further column and a further row at the ends, with empty objects. In the case of REIHE it computes the next coefficent. RETURN: OK or ERROR BUGS: may be also useful for BRUCH, SQ_RADICAL, CYCLOTOMIC (addition of 1) NAME: inhalt SYNOPSIS: INT inhalt(OP a,b) DESCRIPTION: computes the content of a TABLEAUX or a WORD object. The content must be INTEGER object >= 1. First b ist freed. a and b may be equal. b becomes a VECTOR object RETURN: OK or ERROR NAME: invers SYNOPSIS: INT invers(OP a,b) DESCRIPTION: computes the multiplicative inverse of the object a. It works for BRUCH, CYCLOTOMIC, INTEGER, FINITEFIELD, LONGINT, MATRIX, KOSTKA, KRANZTYPUS, PERMUTATION, SQ_RADICAL. a nd b may be equal. b is freed first. RETURN: OK or ERROR NAME: invers_apply SYNOPSIS: INT invers_apply(OP a) DESCRIPTION: changes a to its multiplicative inverse. It works for INTEGER, in all other cases it calls invers. RETURN: OK or ERROR BUGS: more types should be implemented. NAME: kgv SYNOPSIS: INT kgv(a,b,c) DESCRIPTION: computes the lcm of the input objects a and b. The result is stored in c. The routine needed ar ggt mult and div RETURN: OK or ERROR NAME: lehmercode SYNOPSIS: INT lehmercode(OP a,b) DESCRIPTION: computes the lehmercode of the object a. a may be a PERMUTATION object or an VECTOR object. The VECTOR object must contain INTEGER objects. the variables a and b may be equal. b is freed first. RETURN: OK or ERROR BUGS: there is no test on INTEGER objects in the VECTOR objects. lehmercode for barred permutations is missing NAME: length SYNOPSIS: INT length(OP a,b) DESCRIPTION: computes the length of LIST type objects or VECTOR type objects. So it works for the following types GRAL HOM_SYM LIST POLYNOM MONOPOLY SCHUBERT SCHUR PARTITION PERMUTATION SKEWPARTITION VECTOR WORD COMP a and b may be equal. BUGS: It doesnt work for SQ_RADICAL CYCLOTOMIC RETURN: OK if there is no error, else != OK NAME: max SYNOPSIS: INT max(OP a,b) DESCRIPTION: b becomes a copy of the maximum object in a. It works for MATRIX,VECTOR,WORD objects. If we have the wrong type it prints an error message RETURN: OK or ERROR BUGS: the variables a and b must be different. The routine does not work for LIST, BINTREE It would be useful to enter a function for comparision. It would be useful to have a routine min NAME: mod SYNOPSIS: INT mod(OP a,b,c) DESCRIPTION: Computes a mod b, where a,b could be out of INTEGER or LONGINT. The result is always positive, 12 mod 5 = 2 -12 mod 5 = 3 12 mod -5 = 2 -12 mod -5 = 3 The variables a b c may be equal, c is freed first The routine also works if the first parameter is a MATRIX object and the second parameter is a INTEGER object, in this case the routine is applied to all entries of the matrix. RETURN: ERROR if b is 0 BUGS: MONOPOLY and POLYNOM would be useful NAME: moebius SYNOPSIS: INT moebius(OP a,b) DESCRIPTION: computes the number theoretic moebius function of the input object a. NAME: mult SYNOPSIS: INT mult(OP a,b,c) DESCRIPTION: it multiplies the two objects a and b and the result will be in c. First there is a check whether a,b,c not NULL then whether a and b are no empty objects. Then it frees the object c. Now it multiplies. It is not necessary, that a,b,c are different. See also mult_apply(); Multiplies two objects, and the result is a new object. Look at the following list of possible datatypes. BRUCH,CYCLOTOMIC,GRAL,FINITEFIELD, HOM_SYM, INTEGER,KRANZTYPUS,KOSTKA,LONGINT,MATRIX,MONOPOLY PERMUTATION,POLYNOM,SCHUR,SCHUBERT,REIHE SYMCHAR,SQ_RADICAL,VECTOR. RETURN: OK or ERROR BUGS: many combinations are missing EXAMPLE: main() { OP a = callocobject(); OP b = callocobject(); scan(POLYNOM,a); scan(BRUCH,b); mult(a,b,b); println(b); freeall(a); freeall(b); } This example multiplies a BRUCHobject and a POLYNOMobject, which gives a POLYNOMobject with BRUCHobjects as coefficients. NAME: mult_apply SYNOPSIS: INT mult_apply(OP a,b) DESCRIPTION: mult a to b, at the moment this works for the following types of a: BRUCH GRAL INTEGER LONGINT MONOPOLY CYCLOTOMIC REIHE MATRIX POLYNOM REIHE SCHUBERT SCHUR SQ_RADICAL SYMCHAR SQ_RADICAL VECTOR. a and b may be equal RETURN: OK or ERROR BUGS: not all combinations are implemented NAME: multinom SYNOPSIS: INT multinom(OP a,b,c) DESCRIPTION: missing NAME: qdimension SYNOPSIS: INT qdimension(OP label, result) DESCRIPTION: Computes the qdimension of the representation of the symmetric group labeled by the input. It works for the following input objects: SCHUBERT. label and result may be equal. result is freed first RETURN: OK or ERROR NAME: quores SYNOPSIS: INT quores(OP a,b,c,d) DESCRIPTION: c becomes the result of the integer division a by b. d becomes the result of a mod b types of a,b: INTEGER LONGINT c and d must be different, the remaining varaibales may be equal. c and d are freed first. BUGS: POLYNOM, MONOPOLY would be useful NAME: scalarproduct SYNOPSIS: INT scalarproduct(OP a,b,c) DESCRIPTION: c becomes the scalarproduct of a and b. This works for VECTOR objects, where it is the euklidean and for SYMCHAR objects, where it is the scalarproduct of two characters of the symmetric group. It works also for SCHUR objects. a b c may be equal, c is freed first. BUGS: The scalarproduct of vector, works only for reell entries, not for CYCLOTOMIC NAME: signum SYNOPSIS: INT signum(OP a,b) DESCRIPTION: b becomes the signum of the PERMUTATION object a. b is freed first. BUGS: a and b must be different NAME: sort SYNOPSIS: INT sort(OP a) DESCRIPTION: the VECTOR object a is sorted by comp(). RETURN: OK or ERROR BUGS: should work also for LIST and BINTREE it should be possible to specify the comp - function As for CYCLOTOMIC and SQ_RADICAL we do not have comp you will get problems with such entries. NAME: squareroot SYNOPSIS: INT squareroot(OP a,b) DESCRIPTION: b becomes the squareroot of a. It works for INTEGER, LONGINT, BRUCH. If the input is not quadratic the output is a object of type SQ_RADICAL. The variables a and b may be equal. RETURN: OK or ERROR NAME: sub SYNOPSIS: INT sub(OP a,b,c) DESCRIPTION: c = a - b computes the difference of two objects, it first calls the routine addinvers, then the routine add, so it is limited two the objects which can be handled by these two routines. The input varaibles may be equal. There is a check on errors during the computation. RETURN: OK or ERROR NAME: sum SYNOPSIS: INT sum(OP a,b) DESCRIPTION: b becomes the sum of the VECTOR object a. It must be possible to add the entries. a and b may be equal. b is freed first. It also works for COMP objects. RETURN: OK or ERROR BUGS: it would be good to have the same for LIST and BINTREE objects. NAME: trace SYNOPSIS: INT trace(OP a,b) DESCRIPTION: a is a MATRIX object. So also the type KRANZTYPUS works for a. a and b may be equal. b is freed first. b becomes the sum over the diagonal elements of the matrix. RETURN: OK or ERROR NAME: transpose SYNOPSIS: INT transpose(OP a,b) DESCRIPTION: computes the transpose of a MATRIX object a. It also works for KOSTKA and KRANZTYPUS, which are also MATRIX objects. The variable a and b may be equal. RETURN: OK or ERROR NAME: vander SYNOPSIS: INT vander(OP a,b) DESCRIPTION: a is a INTEGER object, and b becomes the POLYNOM object, which is the determinant of the vandermonde matrix. Only reasonable for small values of a. BUGS: a and b must be different. Slow algorithm. NAME: weight SYNOPSIS: INT weight(OP a,b) DESCRIPTION: b becomes the wheight of a. This works a of type AUG_PART,PARTITION, SKEWPARTITION, TABLEAUX. a and b may be equal variables. b is freed first symmetrica-2.0/object.doc0000600017361200001450000000646310726170277015354 0ustar tabbottcrontabCOMMENT: OBJECT The object is the only datatype of SYMMETRICA. It is a structure with two components. The first one is the kind, this is an information, which allows the system to decide how to handle the object. (e.g. there are different subroutines to add INTEGER objects or POLYNOM objects) Using the kind-information the global routine add can switch to the correct subroutine. This information is of the datatype OBJECTKIND which is defined in the file "def.h". There are several known kinds of objects. An incomplete list follows EMPTY INTEGER VECTOR PARTITION PERMUTATION LIST POLYNOM SCHUR MATRIX . . . The complete list is in the file "def.h", which defines these names. They are covered in the following chapters of this documentation. The header of the chapters are the names of the different values of the kind. The first step in a program of SYMMETRICA is the generation of an object. This object is always an empty object. This is done in the following program #include "def.h" #include "macro.h" main() { OP object; anfang(); object = callocobject(); /* generation of an object */ freeall(object); /* deletion of an object */ ende(); } Using the routine callocobject() you generate an empty object. This object must have been declared using the type OP, which is also defined in "def.h". After all you have to delete the object, this is done using the standard routine freeall(), which works for all objects, not only with empty objects. If you print an empty object you will get a "#", which is the symbol for the empty object. If you change the above code into . . . object = callocobject(); /* generation of an object */ println(object); freeall(object); /* deletion of an object */ . . . you get the following line # To get the information about the kind of an object, you have the routine s_o_k(), look at the following part of the pseudostandard routine print: . . INT print(a) OP a; . switch(s_o_k(a)) { case INTEGER: return(print_integer(a)); . } . . the complete description: NAME: s_o_k SYNOPSIS: OBJECTKIND s_o_k(OP object) DESCRIPTION: As OP is a pointer, there is first a check, whether it is the NULL pointer, then it returns the kind of the object RETURN: The returnvalue is the kind, or in the case of an error the value (OBJECTKIND)ERROR. You have to cast because in the normal case ERROR is of type INT. MACRO: There is a macro S_O_K without a check COMMENT: To change the kind of an object, you have the routine c_o_k() NAME: c_o_k SYNOPSIS: INT c_o_k(OP object; OBJECTKIND kind) DESCRIPTION: As OP is a pointer, there is first a check, whether it is the NULL pointer, then the kind of the object is changed to kind RETURN: The returnvalue is OK, or ERROR if an error occured MACRO: There is a macro C_O_K without a check COMMENT: The second part of an object, are the datas themself. The type is defined in "def.h" as OBJECTSELF NAME: s_o_s SYNOPSIS: OBJECTSELF s_o_s(OP a) DESCRIPTION: acess the self part of an object. This is a union of different datatypes according to the kind part of the object MACRO: S_O_S NAME: c_o_s SYNOPSIS: INT c_o_s(OP a, OBJECTSELF self) DESCRIPTION: changes the self part of an object a. MACRO: C_O_S symmetrica-2.0/part.c0000400017361200001450000035737010726021631014522 0ustar tabbottcrontab/* SYMMETRICA V2.0 260298 */ /* file: part.c */ #include "def.h" #include "macro.h" static struct partition * callocpartition(); static void utiliser(); static void repartir(); static INT ordcon_char(); static INT m060588(); static INT m060588b(); INT mem_counter_part=(INT)0; /* AK 100893 */ INT partition_speicherindex=-1; /* AK 301001 */ INT partition_speichersize=0; /* AK 301001 */ struct partition **partition_speicher=NULL; /* AK 301001 */ static OP nb_e = NULL; /* result in number of part */ #ifdef PARTTRUE INT t_CHARPARTITION_PARTITION(); static char * part_kind_to_text(k) OBJECTKIND k; { switch(k) { case EXPONENT: return "exponent"; case VECTOR: return "vector"; case BITVECTOR: return "bitvector"; case FROBENIUS: return "frobenius"; default: return "unknown"; } } static INT wrong_kind_part(t,a,b) char *t; OP a; OBJECTKIND b; { char s[200]; sprintf(s,"%s: wrong kind of partition, should be %s but it was %s", t,part_kind_to_text(b),part_kind_to_text(S_PA_K(a))); error(s); return ERROR; } INT hookp(a) OP a; /* AK 110888 */ /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 180391 V1.2 */ /* AK 210891 V1.3 */ /* AK V2.0 160698 */ { INT erg = OK; PART_CHECK_KIND("hookp",a,VECTOR); if (S_PA_LI (a) <= 1) return(TRUE); if (S_PA_II (a, S_PA_LI(a) - 2) == 1) return(TRUE); return(FALSE); ENDR("hookp"); } INT inc_partition(a) OP a; /* AK 2.0 090298 */ { INT erg = OK; CTO(PARTITION,"inc_partition(1)",a); erg += inc_vector(S_PA_S(a)); ENDR("inc_partition"); } INT m_i_staircase(a,b) OP a,b; /* AK 2.0 090298 */ /* input: INTEGER object a output: PARTITION object 1,2,3,4,...,a */ { INT i; INT erg = OK; CTO(INTEGER,"m_i_staircase",a); if (S_I_I(a) <= (INT)0) { erg += error("m_i_staircase:input <= 0"); goto endr_ende; } CE2(a,b,m_i_staircase); erg += b_ks_pa(VECTOR,callocobject(),b); erg += m_l_v(a,S_PA_S(b)); C_O_K(S_PA_S(b),INTEGERVECTOR); for (i=0;i 1) return FALSE; return TRUE; } else { debugprint(a); return error("strictp:wrong type of partiton"); } ENDR("strictp"); } INT oddpartsp(a) OP a; /* AK 080306 V3.0 true if all parts odd */ { INT i; INT erg =OK; CTO(PARTITION,"oddpartsp(1)",a); if (S_PA_K(a) == VECTOR) { for (i=0;i S_PA_LI(a), "sub_part_part:second partition too big"); CE3(a,b,c,sub_part_part); if (S_PA_LI(a) == S_PA_LI(b)) { for (i=0;i=(INT)0;i--,j--) M_I_I(S_PA_II(a,i) + S_PA_II(b,j),S_PA_I(c,j)); } else { erg += copy_partition(a,c); for (i=S_PA_LI(a)-1,j=S_PA_LI(b)-1;j>=(INT)0;i--,j--) M_I_I(S_PA_II(a,i) + S_PA_II(b,j),S_PA_I(c,i)); } ENDR("add_part_part"); } INT remove_part_integer(a,b,c) OP a,b,c; /* AK 100202 */ /* 234,2 --> 34 */ { INT erg = OK; OP d; CTO(PARTITION,"remove_part_integer(1)",a); CTO(INTEGER,"remove_part_integer(2)",b); CTO(EMPTY,"remove_part_integer(3)",c); d = CALLOCOBJECT(); erg += m_i_pa(b,d); erg += remove_part_part(a,d,c); FREEALL(d); CTO(PARTITION,"remove_part_integer(e3)",c); ENDR("remove_part_integer"); } INT remove_part_part(a,b,c) OP a,b,c; /* AK 070995 */ /* 23344 , 24 ->> 334 */ /* AK 2.0 090298 */ { INT erg = OK; INT i,j,k; OP d; CTO(PARTITION,"remove_part_part(1)",a); CTO(PARTITION,"remove_part_part(2)",b); CTO(EMPTY,"remove_part_part(3)",c); if (S_PA_K(a) != S_PA_K(b)) { erg += error("remove_part_part entered different kind of partitions"); goto endr_ende; } else if (S_PA_K(a) == VECTOR) { d = CALLOCOBJECT(); erg += m_il_nv(S_PA_LI(a),d); for (i=0,j=0,k=0;i=0;i--) if( S_PA_II(a,i) > S_I_I(b) ) M_I_I(S_PA_II(a,i),S_PA_I(a,i+1)); else { M_I_I(S_I_I(b),S_PA_I(a,i+1)); goto ende; } M_I_I(S_I_I(b),S_PA_I(a,0)); goto ende; } else if (S_PA_K(a) == EXPONENT) { if (S_PA_LI(a) >= S_I_I(b)) { INC_INTEGER(S_PA_I(a,S_I_I(b)-1)); } else { INT l; l = S_PA_LI(a); inc_vector_co(S_PA_S(a), S_I_I(b) - S_PA_LI(a) ); for (;l=0;j--) if (k == -1) goto ende; else if (i == -1) { M_I_I(S_PA_II(b,k), S_PA_I(a,j)); k--; } else if (S_PA_II(b,k) > S_PA_II(a,i)) { M_I_I(S_PA_II(b,k), S_PA_I(a,j)); k--; } else { M_I_I(S_PA_II(a,i), S_PA_I(a,j)); i--; } goto ende; } else if (S_PA_K(a) == EXPONENT) { INT i,l,ol; l = (S_PA_LI(a) > S_PA_LI(b) ? S_PA_LI(a) : S_PA_LI(b) ); /* l is the maximum of lengthes */ ol = S_PA_LI(a); if (l > S_PA_LI(a)) erg += inc_vector_co(S_PA_S(a), l - S_PA_LI(a) ); for (i=0;i 1222334 */ /* AK 2.0 090298 */ { OP d; INT erg = OK; CTO(PARTITION,"append_part_part(1)",a); if (S_O_K(b) == INTEGER) { d = callocobject(); erg += first_partition(b,d); erg += append_part_part(a,d,c); erg += freeall(d); goto endr_ende; } else if (S_O_K(b) == VECTOR) { erg += copy(b,c); erg += inc(c); erg += copy_partition(a,S_V_I(c,S_V_LI(c)-1)); goto endr_ende; } else if (S_O_K(b) == EMPTY) { erg += copy_partition(a,c); goto endr_ende; } CTO(PARTITION,"append_part_part(2)",b); if (S_PA_K(a) != S_PA_K(b)) { erg += error("append_part_part: different kind of partitions"); } else if (S_PA_K(a) == VECTOR) { /* d = callocobject(); erg += append(S_PA_S(a),S_PA_S(b),d); erg += m_v_pa(d,c); erg += freeall(d); */ /* the following is faster */ /* AK 260901 */ INT i,j,k; B_KS_PA(VECTOR,CALLOCOBJECT(),c); erg += m_il_v(S_PA_LI(a)+S_PA_LI(b),S_PA_S(c)); C_O_K(S_PA_S(c),INTEGERVECTOR); /* AK 011101 */ for (i=0,j=0,k=0;i S_I_I(n) ,"first_subset:input variable k > n"); CE3(n,k,c,first_subset); { INT i; erg += m_l_nv(n,c); for (i=0;i=0;i--) { if (S_V_II(c,i) == 0) break; else m++; } /* m ist die anzahl der gelesenen 1en bis zur 0 */ for (; i>=0 ;i--) { if (S_V_II(c,i) == 1) break; } if (i == -1) return LAST_SUBSET; M_I_I(0, S_V_I(d,i)); M_I_I(1,S_V_I(d,i+1)); for (i=i+2; m>0 ; i++,m--) M_I_I(1,S_V_I(d,i)); for (; i=0;i--) { if (S_V_II(c,i) == 0) break; else m++; } /* m ist die anzahl der gelesenen 1en bis zur 0 */ for (; i>=0 ;i--) { if (S_V_II(c,i) == 1) break; } if (i == -1) return LAST_SUBSET; M_I_I(0, S_V_I(c,i)); M_I_I(1,S_V_I(c,i+1)); for (i=i+2; m>0 ; i++,m--) M_I_I(1,S_V_I(c,i)); for (; i=(INT)0; i--,j--) if (S_V_II(newcomp,i) == (INT)0) { rest += S_V_II(newcomp,j); C_I_I(S_V_I(newcomp,j),(INT)0); } else if (S_V_II(newcomp,i) > (INT)0) { DEC_INTEGER(S_V_I(newcomp,i)); C_I_I(S_V_I(newcomp,j),S_V_II(newcomp,j)+1+rest); return(OK); }; return(LASTCOMP); } INT is_selfconjugate(part) OP part; /* AK 180703 */ { INT erg = OK,res; OP c; CTO(PARTITION,"is_selfconjugate(1)",part); c = CALLOCOBJECT(); conjugate_partition(part,c); res = EQ(c,part); FREEALL(c); return res; ENDR("is_selfconjugate"); } INT conjugate_partition(part,b) OP part, b; /* AK 220587 */ /* AK 060789 V1.0 */ /* AK 240490 V1.1 */ /* AK 200891 V1.3 */ /* AK 200298 V2.0 */ { INT i,j,k=(INT)0,m; /* k ist die adresse an der geschrieben wird im b */ INT erg = OK; CTO(PARTITION,"conjugate_partition",part); CE2(part,b,conjugate_partition); if (S_PA_K(part) == EXPONENT) /* AK 170692 */ { OP c = callocobject(); erg += t_EXPONENT_VECTOR(part,c); erg += conjugate_partition(c,b); erg += freeall(c); erg += t_VECTOR_EXPONENT(b,b); goto endr_ende; } else if (S_PA_K(part) == BITVECTOR) /* AK 090703 */ { COPY(part,b); erg += reverse_bitvector(S_PA_S(b),S_PA_S(b)); erg += invers_bitvector(S_PA_S(b),S_PA_S(b)); goto endr_ende; } else if (S_PA_K(part) == FROBENIUS) { B_KS_PA(FROBENIUS,callocobject(),b); erg += m_il_v((INT)2,S_PA_S(b)); erg += copy_integervector(S_V_I(S_PA_S(part),0), S_V_I(S_PA_S(b),1) ); erg += copy_integervector(S_V_I(S_PA_S(part),1), S_V_I(S_PA_S(b),0) ); goto endr_ende; } else if (S_PA_K(part) != VECTOR) { erg += error("conjugate_partition: works only for VECTOR,EXPONENT,FROBENIUS type"); goto endr_ende; } if (S_PA_LI(part) == (INT)0) { erg += copy_partition(part,b); goto endr_ende; } erg += m_il_pa(S_PA_II(part,S_PA_LI(part)-1),b); j = S_PA_LI(part) - 1; /* dies sind die adressen in den beiden partitionen */ m = S_PA_LI(b)+S_PA_LI(part)+1; /* dies ist die laenge der permutation + 1 */ for( i=m-1; i > (INT)0 ; i--) { if (j>=0) if (i == S_PA_II(part,j)+j+1 ) j-- ; else { M_I_I(m-i- k - 1,S_PA_I(b,k)); k++ ; } else { M_I_I(m-i- k - 1,S_PA_I(b,k)); k++ ; } } ENDR("conjugate_partition"); } INT ferrers_partition(part) OP part; /* AK 060789 V1.0 */ /* AK 150690 V1.1 */ /* AK 200891 V1.3 */ /* AK 240298 V2.0 */ { INT i,j; INT erg = OK; OP z; CTO(PARTITION,"ferrers_partition",part); if (S_PA_K(part) == EXPONENT) { z = callocobject(); erg += t_EXPONENT_VECTOR(part,z); erg += ferrers_partition(z); erg += freeall(z); goto endr_ende; } PART_CHECK_KIND("ferrers_partition",part,VECTOR); printf("\n"); for (i=(INT)0; irow_length)) { fprintf(f,"\n"); zeilenposition = (INT)0; } ENDR("fprint_partition"); } INT sprint_partition(f,partobj) char *f; OP partobj; /* AK V2.0 200298 */ { INT i; INT erg = OK; CTO(PARTITION,"sprint_partition",partobj); if (S_PA_K(partobj) == FROBENIUS) /* AK 101292 */ { erg += sprint(f,S_PA_S(partobj)); goto endr_ende; } else if (S_PA_K(partobj) == BITVECTOR) { erg+= sprint(f,S_PA_S(partobj)); goto endr_ende; } f[0]='\0'; /* AK 151298 to handle zero partition */ for( i = (INT)0; i S_I_I(n)/2L) { erg += m_i_i((INT)0,res); } else { i = callocobject(); j = callocobject(); zw = callocobject(); /* initialisieren i = n-m, j = m, res = 0 */ M_I_I(S_I_I(n)-S_I_I(m),i); COPY_INTEGER(m,j); erg += m_i_i((INT)0,res); while(S_I_I(j) <= S_I_I(i) ) { erg += gupta_nm(i,j,zw); if (S_O_K(zw) != INTEGER) add_apply(zw,res); else if (not NULLP_INTEGER(zw)) add_apply(zw,res); /* nicht aufrufen falls 0 */ INC_INTEGER(j); } erg += freeall(zw); erg += freeall(i); erg += freeall(j); } ENDR("gupta_nm"); } #ifdef MATRIXTRUE INT gupta_tafel(mx,mat) OP mx,mat; /* AK 220888 */ /* AK 060789 V1.0 */ /* AK 120390 V1.1 */ /* AK 200891 V1.3 */ /* AK 200298 V2.0 */ /* mx and mat may be equal */ { INT erg = OK; CTO(INTEGER,"gupta_tafel(1)",mx); { INT i,j,k; OP h,l; h = callocobject(); l = callocobject(); M_I_I(S_I_I(mx),h); M_I_I((S_I_I(mx) / 2L)+1,l); erg += b_lh_nm(l,h,mat); for (i=0; i< S_I_I(mx); i++) for (j=0;j<=i/2L;j++) { for (k=(INT)0; j+k < (i-j)/2L ; k++) /* die rekursion */ ADD_APPLY(S_M_IJ(mat,i-j-1,j+k),S_M_IJ(mat,i,j)); INC(S_M_IJ(mat,i,j)); }; } ENDR("gupta_tafel"); } INT gupta_nm_speicher(n,m,res) OP n,m,res; /* AK 120390 V1.1 */ /* AK 200891 V1.3 */ /* AK 200298 V2.0 */ /* n,m,res may be equal */ { OP mat; INT erg = OK; CTO(INTEGER,"gupta_nm_speicher",n); CTO(INTEGER,"gupta_nm_speicher",m); if (S_I_I(n) <= 0) { erg += error("gupta_nm_speicher;input <= 0"); goto endr_ende; } if (S_I_I(n) == S_I_I(m)) { M_I_I(1,res); goto endr_ende; } if (S_I_I(m) > S_I_I(n)/2L) { M_I_I(0,res); goto endr_ende; } mat = callocobject(); erg += gupta_tafel(n,mat); erg += copy(S_M_IJ(mat,S_I_I(n)-1,S_I_I(m)-1),res); erg += freeall(mat); ENDR("gupta_nm_speicher"); } #endif /* MATRIXTRUE */ INT hook_length_augpart(p,i,j,res) OP p,res; INT i,j; /* AK 060988 hakenlaenge */ /* AK 060789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ /* p and res may be equal */ { INT e,k; INT erg = OK; OP z; CTO(AUG_PART,"hook_length_augpart(1)",p); FREESELF(res); if (i >= S_PA_LI(p)) { M_I_I(0,res); goto ende; } z = S_PA_I(p,i); if (j >= S_I_I(z)-i) { M_I_I(0,res); goto ende; } else { e = S_I_I(z) - j - i; /* nun noch die zeilen dazu */ for (z--,k=i-1; k>= 0; k--,z--) if (S_I_I(z) -1 -k >= j) e++; else break; M_I_I(e,res); goto ende; } ende: CTO(INTEGER,"hook_length_augpart(e4)",res); ENDR("hook_length_augpart"); } INT hook_diagramm(p,m) OP p,m; /* AK 010295 */ /* AK V2.0 100298 */ /* input: PARTITION object output: MATRIX object with hooklength */ { INT erg = OK, i,j; PART_CHECK_KIND("hook_diagramm(1)",p, VECTOR); CE2(p,m,hook_diagramm); erg += m_ilih_m(S_PA_II(p,S_PA_LI(p)-1), S_PA_LI(p), m); for (i=0;i= S_PA_LI(p)) { M_I_I(0,b); goto ende; } if (j >= S_PA_II(p,S_PA_LI(p)-1-i)) { M_I_I(0,b); goto ende; } e = S_PA_II(p,S_PA_LI(p)-1-i) - j; /* nun noch die zeilen dazu */ for (k=i+1; k= j) e++; else break; M_I_I(e,b); ende: ENDR("hook_length"); } INT dimension_partition(a,b) OP a,b; /* AK 150988 */ /* AK 060789 V1.0 */ /* AK 080290 V1.1 */ /* AK 050391 V1.2 */ /* AK 200891 V1.3 */ /* AK 200298 V2.0 */ /* input: PARTITION object ouput: dimension of corresponding irreducible Sn character INTEGER object or LONGINT object */ /* a and b may be equal */ { OP zaehler, nenner, zw; INT i,j; INT erg = OK; CTO(PARTITION,"dimension_partition(1)",a); if (S_PA_K(a) == EXPONENT) /* AK 170692 */ { zw = callocobject(); erg += t_EXPONENT_VECTOR(a,zw); erg += dimension_partition(zw,b); erg += freeall(zw); } else if (S_PA_K(a) != VECTOR) { error("dimension_partition: wrong kind of partition"); erg = ERROR; } else { zw = callocobject(); zaehler = callocobject(); erg = weight(a,zw); erg += fakul(zw,zaehler); FREESELF(zw); NEW_INTEGER(nenner,1); for (i=(INT)0;i (INT)0) M_I_I(S_PA_LI(part), S_PA_I(part,(INT)0)); ENDR("last_part_EXPONENT"); } INT first_part_VECTOR(n,part) OP n,part; /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { return first_partition(n,part); } INT last_part_VECTOR(n,part) OP n,part; /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { return last_partition(n,part); } INT first_part_EXPONENT(n,part) OP n,part; /* AK 170298 V2.0 */ /* input: n = INTEGER object >= 0 output: PARTITION-EXPONENT object 00000...00001 of given weight n */ /* n and part may be equal */ { INT i; INT erg = OK; CTO(INTEGER,"first_part_EXPONENT",n); i = S_I_I(n); SYMCHECK((i < 0) ,"first_part_EXPONENT:input < 0"); B_KS_PA(EXPONENT,callocobject(),part); erg += m_il_nv(i,S_PA_S(part)); if (i > 0) M_I_I(1, S_PA_I(part,S_PA_LI(part)-1)); C_O_K(S_PA_S(part), INTEGERVECTOR); ENDR("first_part_EXPONENT"); } INT last_partition(n,part) OP n,part; /* AK 190587 */ /* die prozedur erzeugt aus der Zahl n die Partition [1^n], die letzte Partition bezueglich nextpartition bzgl. Dominanzordnung und auch lexikographisch */ /* n wird nicht verwendet */ /* AK 060789 V1.0 */ /* AK 300590 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT i; INT erg = OK; /* AK 020692 */ CTO(INTEGER,"last_partition",n); SYMCHECK((S_I_I(n) < 0) ,"last_partition:input < 0"); CE2(n,part,last_partition); B_KS_PA(VECTOR,CALLOCOBJECT(),part); erg += m_l_v(n,S_PA_S(part)); for (i=0;i 1) /* bsp: 2345 --> 11345 */ { NEW_INTEGER(length,S_PA_LI(part)+1); B_KL_PA(VECTOR,length,next); M_I_I(1,S_PA_I(next,(INT)0)); M_I_I(S_PA_II(part,(INT)0)-1,S_PA_I(next,1)); for (i=2L;i 1) break; if (i == S_PA_LI(part)) { res = LASTPARTITION; goto ende; } k = S_PA_LI(part) -i; /* restlaenge */ m = S_PA_II(part,i); n = m - 1 ; /* neuer wert in next */ j = (i + m) / n; o =(i + m) % n ; if (o == (INT)0) j--; length = CALLOCOBJECT(); M_I_I( j+k, length); B_KL_PA(VECTOR,length,next); if (o != (INT)0) { M_I_I(o ,S_PA_I(next,(INT)0)); o=1; }; for (m=o;m<=j;m++) M_I_I(n, S_PA_I(next,m)); for (;m(INT)0) { index=i++; break; }; } memcpy( (char *)S_PA_I(next,i), (char *)S_PA_I(part,i), (int) (l-i+1)*sizeof(struct object) ); summe = S_PA_II(part,(INT)0); /* an der stelle index wird der index um eins decrementiert */ summe = summe + index + 1; M_I_I(S_PA_II(part,index)-1, S_PA_I(next,index)); /* nun nach rechts wieder aufbauen */ for (i=index-1;i>=(INT)0;i--) { value = summe / (i+1); M_I_I(value,S_PA_I(next,i)); summe = summe % (i+1); if (summe == (INT)0) break; i = summe; } ENDR("next_part_EXPONENT"); } INT next_part_EXPONENT_apply(part) OP part; /* AK V2.0 211100 */ { INT l = S_PA_LI(part); INT i,index=(INT)0,k; INT summe; INT value; if (l == (INT)0) return(LASTPARTITION); if (S_PA_II(part,(INT)0) == l) return(LASTPARTITION); /* part = n 0 0 0 0 0 0 ... */ for (i=1;i<=l;i++) { k = S_PA_II(part,i); if (k>(INT)0) { index=i++; break; }; } summe = S_PA_II(part,(INT)0); M_I_I(0,S_PA_I(part,(INT)0)); /* an der stelle index wird der index um eins decrementiert */ summe = summe + index + 1; M_I_I(S_PA_II(part,index)-1, S_PA_I(part,index)); /* nun nach rechts wieder aufbauen */ for (i=index-1;i>=(INT)0;i--) { value = summe / (i+1); M_I_I(value,S_PA_I(part,i)); summe = summe % (i+1); if (summe == (INT)0) break; i = summe; } return(OK); } INT numberofpart_i(n) OP n; /* AK 060789 V1.0 */ /* AK 120390 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ /* return the number of partitions as an INT */ { OP zw; INT i; INT erg = OK; CTO(INTEGER,"numberofpart_i(1)",n); SYMCHECK(S_I_I(n) < 0,"numberofpart_i: parameter < 0"); zw=CALLOCOBJECT(); erg += numberofpart(n,zw); SYMCHECK(S_O_K(zw)!=INTEGER,"numberofpart_i:result too big"); i=S_I_I(zw); FREEALL(zw); return(i); ENDR("numberofpart_i"); } INT numberofselfconjugatepart(a,c) OP a,c; /* AK 231202 */ /* computes the number of self conjugate partitions using the fact that his number is equal to the number of partitions with distinct odd parts */ /* using generating function */ { INT erg =OK,ai; CTO(INTEGER,"numberofselfconjugatepart(1)",a); ai = S_I_I(a); if (ai <0) erg += m_i_i(0,c); else if (ai <= 1) erg += m_i_i(1,c); else if (ai == 2) erg += m_i_i(0,c); else { OP v = CALLOCOBJECT(); INT i,j; m_il_nv(ai+1,v); M_I_I(1,S_V_I(v,0)); M_I_I(1,S_V_I(v,1)); for (i=3;i<=ai;i+=2) { for (j=S_V_LI(v)-1;j>=i;j--) ADD_APPLY(S_V_I(v,j-i),S_V_I(v,j)); } SWAP(S_V_I(v,ai),c); FREEALL(v); } ENDR("numberofselfconjugatepart"); } INT numberofparts_ge(a,b,c) OP a,b,c; /* number of partitions of a with maximal part >=b */ /* AK 180803 */ { INT erg = OK; CTO(INTEGER,"numberofparts_ge(1)",a); CTO(INTEGER,"numberofparts_ge(2)",b); SYMCHECK(S_I_I(a) < 0,"numberofparts_ge(1>=0)"); if (S_I_I(b)<=0) erg += numberofpart(a,c); else if (GT(b,a)) erg += m_i_i(0,c); else { OP ai,bi,ci; CALLOCOBJECT3(ai,bi,ci); COPY(b,bi); COPY(a,ai); erg += m_i_i(0,c); while (LE(bi,ai)) { numberofparts_exact_parts(ai,bi,ci); ADD_APPLY(ci,c); INC(bi); } FREEALL3(ai,bi,ci); } ENDR("numberofparts_ge"); } INT numberofparts_le_parts(a,b,c) OP a,b,c; /* number of partitions of a with maximal b parts */ /* using generating function */ /* AK 230103 */ { INT erg = OK; CTO(INTEGER,"numberofparts_le_parts(1)",a); CTO(INTEGER,"numberofparts_le_parts(2)",b); SYMCHECK(S_I_I(a) < 0,"numberofparts_le_parts(1>=0)"); SYMCHECK(S_I_I(b) <0,"numberofparts_le_parts(2>=0)"); { if (EQ(a,b) ) numberofpart(a,c); else if (NULLP(b)) m_i_i(0,c); else if (EINSP(b)) m_i_i(1,c); else { OP v,v2; INT i,j,k,ai = S_I_I(a), bi=S_I_I(b); if (nb_e == NULL) { nb_e = CALLOCOBJECT(); m_il_v(bi+1,nb_e); } else if (S_V_LI(nb_e) > bi) { OP nv = S_V_I(nb_e,bi); if (not EMPTYP(nv)) { if (S_V_LI(nv) > ai) { CLEVER_COPY(S_V_I(nv,ai),c); goto endr_ende; } else FREESELF(nv); } } else { inc_vector_co(nb_e,bi); } v = CALLOCOBJECT(); v2 = CALLOCOBJECT(); m_il_nv(ai+1,v); m_il_v(ai+1,v2); for (i=0;i<=ai;i++) M_I_I(1,S_V_I(v,i)); for (i=2;i<=bi;i++) { m_il_nv(ai+1,v2); for (j=i;j<=ai;j+=i) for (k=ai;k>=j;k--) ADD_APPLY(S_V_I(v,k-j),S_V_I(v2,k)); ADD_APPLY(v2,v); } CLEVER_COPY(S_V_I(v,ai),c); SWAP(v,S_V_I(nb_e,bi)); FREEALL(v); FREEALL(v2); } } ENDR("numberofparts_le_parts"); } INT numberofparts_exact_parts(a,b,c) OP a,b,c; /* number of partitions of a with exact b parts */ /* using generating function */ /* AK 230103 */ { INT erg = OK; CTO(INTEGER,"numberofparts_exact_parts(1)",a); CTO(INTEGER,"numberofparts_exact_parts(2)",b); SYMCHECK(S_I_I(a) < 0,"numberofparts_exact_parts(1>=0)"); SYMCHECK(S_I_I(b) <0,"numberofparts_exact_parts(2>=0)"); { if (EQ(a,b) ) m_i_i(1,c); else if (NULLP(b)) m_i_i(0,c); else if (LT(a,b)) m_i_i(0,c); else { INT ai=S_I_I(a),bi=S_I_I(b),i; M_I_I(ai-bi,a); numberofparts_le_parts(a,b,c); M_I_I(ai,a); } } ENDR("numberofparts_exact_parts"); } static int rec01(); INT numberofpart(n, res) OP n,res; /* AK 191202 */ /* bressoud: proofs and confirmations p.37 */ /* input INTEGER n output: number of partitions INTEGER or LONGINT */ { INT erg = OK; OP v; CTO(INTEGER,"numberofpart(1)",n); if (S_I_I(n) < 0) erg += m_i_i(0,res); else { INT i; v = CALLOCOBJECT(); erg += m_il_v(S_I_I(n)+1,v); for (i=0;i<=S_I_I(n);i++) rec01(i,v); SWAP(res,S_V_I(v,S_I_I(n))); FREEALL(v); } ENDR("numberofpart"); } static int rec01(INT ni, OP vec) /* to compute number of partitions */ { INT erg = OK; if (ni<0) return; if (not EMPTYP(S_V_I(vec,ni))) return; else if (ni<=1) M_I_I(1,S_V_I(vec,ni)); else { INT m,og; og = ni/3+3; m_i_i(0,S_V_I(vec,ni)); for (m=1;m= 0;i--) { j=zeilenanfang(tab,i); /* erster erlaubter index */ if (not EMPTYP(S_T_IJ(tab,i,j))) break; }; lasti = i; /* lasti ist zeile in der letzter eintrag */ grenze = zeilenende(tab,lasti); for ( j=zeilenanfang(tab,lasti); /* erster erlaubter index */ j<= grenze; j++) if (EMPTYP(S_T_IJ(tab,lasti,j))) break; lastj = j; /* lastj ist letzter eintrag + 1 */ if (lastj <= grenze) { /* d.h. in der zeile kann noch eingetragen werden */ INT m; m = S_T_IJI(tab,lasti,lastj-1); /* m = der letzte eintrag */ if (lasti == /* s_t_hi(tab)-1*/ 0) /* letzte zeile */ M_I_I(m,S_T_IJ(tab,lasti,lastj)); /* rechts anfuegen der gleichen zahl */ else if (EMPTYP(S_T_IJ(tab,lasti-1,lastj))) /* bei schief unterhalb leer */ M_I_I(m,S_T_IJ(tab,lasti,lastj)); /* rechts anfuegen der gleichen zahl */ else { /* schauen ob unterhalb groesserer eintrag */ m = (S_T_IJI(tab,lasti-1,lastj) >= m ? S_T_IJI(tab,lasti-1,lastj)+1 : m); if (m > S_I_I(alph)) goto m060588nein; /* kann nicht einsetzen */ M_I_I(m,S_T_IJ(tab,lasti,lastj)); }; goto again; /* return(m060588(tab,alph,res)); */ }; /* falls in der zeile nicht mehr eingetragen werden kann */ i = i+1; /* neue zeilenzahl */ if (i < S_T_HI(tab)) { j = zeilenanfang(tab,i); /* neue spaltenzahl */ if (not EMPTYP(s_t_ij(tab,i-1,j))) /* unterhalb der neuen position ist ein eintrag */ { if (S_T_IJI(tab,i-1,j)+1 > S_I_I(alph)) goto m060588nein; M_I_I(s_t_iji(tab,i-1,j)+1,s_t_ij(tab,i,j)); return(m060588(tab,alph,res)); } else M_I_I(1,s_t_ij(tab,i,j)); }; /* nun sind wir am ende */ b = CALLOCOBJECT(); c = CALLOCOBJECT(); copy(tab,b); b_s_po(b,c); insert(c,res,NULL,NULL); /* jetzt muss versucht werden das naechste tableaux zu bekommen */ m060588nein: if (m060588b(tab,alph) == TRUE) /* m060588(tab,alph,res); */ goto again; /* d.h noch nicht letztes tableaux */ return(OK); } static INT m060588b(tab,alph) OP tab,alph; /* es wird versucht das naechste tableaux zu bekommen */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT i,j; INT lastj = zeilenanfang(tab,0); INT erg = OK; for (i=S_T_HI(tab)-1; i>=0 ;i--) for (j= S_T_LI(tab)-1;j >= (INT)0; j--) if (not EMPTYP(S_T_IJ(tab,i,j))) /* es gibt einen eintrag */ if (i == 0 && j == lastj) return(FALSE); /* wir sind am ende */ else if (S_T_IJI(tab,i,j) < S_I_I(alph)) { INC(S_T_IJ(tab,i,j)); return(TRUE); } else { FREESELF(S_T_IJ(tab,i,j)); return(m060588b(tab,alph)); } return(FALSE); ENDR("m060588b"); } #endif /* TABLEAUXTRUE */ INT t_augpart_part(a,b) OP a,b; /* AK 150988 */ /* AK 060789 V1.0 */ /* AK 170190 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT i,s=0; INT erg = OK; CTO(AUG_PART,"t_augpart_part(1)",a); copy(a,b); C_O_K(b,PARTITION); for (i=(INT)0;i S_PA_LI(b)) l=S_PA_LI(b); else l = S_PA_LI(a); /* this code is slower ac = (char *) S_V_S(S_PA_S(a)); bc = (char *) S_V_S(S_PA_S(b)); if (memcmp(ac,bc, sizeof(struct object) * l ) != 0) return FALSE; */ ap = S_V_S(S_PA_S(a)); bp = S_V_S(S_PA_S(b)); for (i=0;i l) { for (;l l) { for (;l S_PA_LI(b)) { erg = (INT)memcmp(ac,bc, (sizeof(struct object) * S_PA_LI(b) )); if (erg == (INT)0) erg = (INT)1; goto cpende; } } else if (S_PA_K(a) == EXPONENT) { if (S_PA_LI(a) == S_PA_LI(b)) /* AK 011097 */ { erg = (INT)memcmp( (char *) S_V_S(S_PA_S(a)), (char *) S_V_S(S_PA_S(b)), ( sizeof(struct object) * S_PA_LI(a) )); goto cpende; } for ( i=(INT)0; i= S_PA_LI(b) ) { if (S_PA_II(a,i) != (INT)0) { erg = (INT)1; goto cpende; } } else if (S_PA_II(a,i) > S_PA_II(b,i)) { erg = (INT)1; goto cpende; } else if (S_PA_II(a,i) < S_PA_II(b,i)) { erg = (INT)-1; goto cpende; } } for ( ; i(INT)0) { if (S_PA_II(part,i) == S_PA_II(part,(i-1))) { INC_INTEGER(sp); MULT_APPLY_INTEGER(sp,ergeb); } else M_I_I(1,sp); }; MULT_APPLY_INTEGER(S_PA_I(part,i),ergeb); }; erg += invers_apply(ergeb); FREEALL(sp); ENDR("inversordcen"); } INT ordcon(part,res) OP part, res; /* AK 200387 */ /* AK 060789 */ /* AK 060789 V1.0 */ /* AK 081289 V1.1 */ /* AK 070891 V1.3 */ /* AK V2.0 200298 */ /* AK V3.1 300306 */ /* input: PARTITION object or PERMUTATION object output: INTEGER or LONGINT object giving the size of the conjugacy class in S_n labled by the partition or the size of the class containing the permutation */ { INT i; INT erg = OK; OP ergebnis,sp; OP h1; if (S_O_K(part) == CHARPARTITION) /* AK 170593 */ { erg+= ordcon_char(part,res); goto endr_ende; } else if (S_O_K(part)==PERMUTATION) /* AK 300306 */ { OP p; p = CALLOCOBJECT(); erg += zykeltyp_permutation(part,p); erg += ordcon(p,res); FREEALL(p); goto endr_ende; } PART_CHECK_KIND("ordcon(1)",part,VECTOR); CE2(part,res,ordcon); NEW_INTEGER(sp,1); NEW_INTEGER(ergebnis,1); for (i=(INT)0; i(INT)0) { if (S_PA_II(part,i) == S_PA_II(part,(i-1))) { INC_INTEGER(sp); erg += mult_apply_integer(sp,ergebnis); } else M_I_I(1,sp); }; erg += mult_apply_integer(S_PA_I(part,i),ergebnis); }; h1 = callocobject(); erg += weight_partition(part,h1); erg += fakul(h1,sp); erg += freeall(h1); erg += ganzdiv(sp,ergebnis,res); /* diese division ist ganzzahlig */ erg += freeall(sp); erg += freeall(ergebnis); ENDR("ordcon"); } static INT ordcon_char(part,res) OP part, res; /* AK V2.0 200298 */ { INT i; INT erg = OK; OP ergebnis,sp; OP h1,h2; CTO(CHARPARTITION,"ordcon_char(1)",part); if (S_PA_K(part) != VECTOR) return ERROR; h1 = callocobject(); h2 = callocobject(); sp=callocobject(); M_I_I(1,sp); ergebnis=callocobject(); M_I_I(1,ergebnis); if (not EMPTYP(res)) if (S_O_K(res) != INTEGER) erg += freeself(res); for (i=(INT)0; i(INT)0) { if (S_PA_CII(part,i) == S_PA_CII(part,(i-1))) { INC_INTEGER(sp); erg += mult_apply_integer(sp,ergebnis); } else M_I_I(1,sp); }; M_I_I(S_PA_CII(part,i),h2); /* AK 170593 */ erg += mult_apply_integer(h2,ergebnis); }; erg += weight_partition(part,h1); erg += fakul(h1,sp); erg += freeall(h1); erg += ganzdiv(sp,ergebnis,res); /* diese division ist ganzzahlig */ erg += freeall(sp); erg += freeall(ergebnis); erg += freeall(h2); ENDR("ordcon_char"); } static int mycc(a,b) OP a,b; { return (int)(S_I_I(a)-S_I_I(b)); } INT m_v_pa(vec,part) OP vec, part; /* AK 060789 V1.0 */ /* AK 240490 V1.1 */ /* AK 150591 V1.2 */ /* AK 070891 V1.3 */ /* AK V2.0 200298 */ /* input: VECTOR object with INTEGER entries >= 0 output: PARTITION object got by ordering the entries and removinf the zeros */ { INT i,j, erg=OK; OP self; CE2(vec,part,m_v_pa); CTTO(VECTOR,INTEGERVECTOR,"m_v_pa",vec); if (S_V_LI(vec) == 0) { null: erg += m_il_pa(0,part); goto ende; } self = CALLOCOBJECT(); if (S_O_K(vec) == VECTOR) { C_O_K(vec,INTEGERVECTOR); erg += copy_integervector(vec,self); C_O_K(vec,VECTOR); /* AK 080502 */ } else erg += copy_integervector(vec,self); qsort(S_V_S(self), S_V_LI(self), sizeof(struct object), mycc); if (S_V_II(self,0) < 0) { INT err; FREEALL(self); err=error("m_v_pa: negativ entries"); if (err == ERROR_EXPLAIN) { fprintf(stderr,"the wrong input vector was "); fprintln(stderr,vec); } } i = 0; while ((i= 0 */ /* i == 0 ==> part = [] */ /* AK 210704 V3.0 */ { INT erg = OK; COP("m_i_pa(2)",result); CTO(INTEGER,"m_i_pa(1)",i); SYMCHECK((S_I_I(i) < 0),"m_i_pa:integer < 0"); { OP c; c = CALLOCOBJECT(); M_I_I(S_I_I(i),c); erg += b_i_pa(c,result); } ENDR("m_i_pa"); } INT b_i_pa(integer,res) OP integer,res; /* AK 140687 */ /* Bsp: 5 --> [5] */ /* AK 060789 V1.0 */ /* AK 280890 V1.1 */ /* AK 070891 V1.3 */ /* AK 200298 V2.0 */ /* input: INTEGER object integer output: PARTITION object [i] in VECTOR notation */ /* integer becomes a part of res */ /* integer >= 0 */ /* integer == 0 ==> part = [] */ /* AK 210704 V3.0 */ { INT erg = OK; COP("b_i_pa(2)",res); CTO(INTEGER,"b_i_pa(1)",integer); SYMCHECK((S_I_I(integer) < 0),"b_i_pa(1):integer < 0"); SYMCHECK((integer == res),"b_i_pa(1,2):identical objects"); { erg += b_ks_pa(VECTOR,CALLOCOBJECT(),res); if (S_I_I(integer) > 0) erg += b_o_v(integer,S_PA_S(res)); else { erg += m_il_v(0,S_PA_S(res)); FREEALL(integer); } C_O_K(S_PA_S(res),INTEGERVECTOR); } ENDR("b_i_pa"); } INT m_ks_pa(kind,self,ergebnis) OP self,ergebnis; OBJECTKIND kind; /* make_kind.self_partition */ /* AK 300590 V1.1 */ /* AK 070891 V1.3 */ /* AK V2.0 200298 */ /* self and ergebnis may be equal */ { OP s = NULL; INT erg = OK; COP("m_ks_pa(3)",ergebnis); if (self != NULL) { s = CALLOCOBJECT(); erg += copy(self,s); } erg += b_ks_pa(kind,s,ergebnis); ENDR("m_ks_pa"); } INT b_ks_pa(kind,self,c) OP self,c; OBJECTKIND kind; /* build_kind_self_partition */ /* AK 060789 V1.0 */ /* AK 300590 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { OBJECTSELF d; INT erg = OK; COP("b_ks_pa(3)",c); d.ob_partition = callocpartition(); erg += b_ks_o(PARTITION, d, c); C_PA_K(c,kind); C_PA_S(c,self); C_PA_HASH(c,-1); if (kind == VECTOR) { if (VECTORP(self)) C_O_K(self,INTEGERVECTOR); /* AK 011101 */ } else if (kind == EXPONENT) { if (VECTORP(self)) C_O_K(self,INTEGERVECTOR); /* AK 011101 */ } ENDR("b_ks_pa"); } INT m_kl_pa(a,b,c) OBJECTKIND a; OP b,c; /* AK 060789 V1.0 */ /* AK 280890 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT erg = OK; CTO(INTEGER,"m_kl_pa(2)",b); erg += b_ks_pa(a,callocobject(),c) ; erg += m_l_v(b,S_PA_S(c)); C_O_K(S_PA_S(c), INTEGERVECTOR); ENDR("m_kl_pa"); } INT b_kl_pa(a,b,c) OBJECTKIND a; OP b,c; /* AK 180893 */ /* AK V2.0 200298 */ { INT erg = OK; CTO(INTEGER,"b_kl_pa(2)",b); erg += b_ks_pa(a,callocobject(),c) ; erg += b_l_v(b,S_PA_S(c)); if (a == VECTOR) C_O_K(S_PA_S(c),INTEGERVECTOR); else if (a == EXPONENT) C_O_K(S_PA_S(c),INTEGERVECTOR); ENDR("b_kl_pa"); } INT dec_partition(a) OP a; /* AK 060789 V1.0 */ /* AK 261190 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ /* removes the biggest part of the partition */ /* stops if length = 0 */ { INT i; INT erg = OK; CTO(PARTITION,"dec_partition",a); if (S_PA_K(a) == VECTOR) { if (S_PA_LI(a) > (INT)0) erg += dec_integervector(S_PA_S(a)); } else if (S_PA_K(a) == EXPONENT) { for(i=S_PA_LI(a)-1;i>=(INT)0;i--) if (S_PA_II(a,i) > (INT)0) { M_I_I(S_PA_II(a,i)-1,S_PA_I(a,i)); goto endr_ende; } } else { erg += error("dec_partition:works only for VECTOR, EXPONENT"); } ENDR("dec_partition"); } INT lastof_partition(a,b) OP a,b; /* returns the biggest part of the partition */ /* zero if partition of length 0 */ /* AK 060789 V1.0 */ /* AK 261190 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT erg = OK; CTO(PARTITION,"lastof_partition(1)",a); CTO(EMPTY,"lastof_partition(2)",b); if (S_PA_K(a) == VECTOR) { if (S_PA_LI(a) == 0) M_I_I(0,b); else M_I_I(S_PA_II(a,S_PA_LI(a)-1),b); } else if (S_PA_K(a) == EXPONENT) { INT i; M_I_I(0,b); for (i=S_PA_LI(a)-1; i>=0; i--) if (S_PA_II(a,i) > 0) { M_I_I(i+1,b); break; } } else { erg += error("lastof_partition works only with VECTOR or EXPONENT type partitions"); } ENDR("lastof_partition"); } INT length_partition(a,b) OP a,b; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ /* AK 140901 */ /* input: PARTITION object output: INTEGER object = number of parts of the partition */ { INT erg = OK; CTO(PARTITION,"length_partition(1)",a); CTO(EMPTY,"length_partition(2)",b); switch(S_PA_K(a)) { case VECTOR: erg += length_vector(S_PA_S(a),b); break; case EXPONENT: erg += sum_integervector(S_PA_S(a),b); break; case FROBENIUS: /* AK 140901 */ if (S_V_LI(S_V_I(S_PA_S(a),0)) == 0) M_I_I(0,b); else M_I_I(S_V_II(S_V_I(S_PA_S(a),0),0) +1, b); break; default: erg += error("length_partition: wrong kind of part"); break; } ENDR("length_partition"); } INT weight_partition(a,b) OP a,b; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ /* input: PARTITION object output: INTEGER object */ { INT i ,res=(INT)0; INT erg = OK; CTO(EMPTY,"weight_partition(2)",b); CTTO(CHARPARTITION,PARTITION,"weight_partition(1)",a); if (S_O_K(a) == CHARPARTITION) if (S_PA_K(a) == VECTOR) { for (i=S_PA_CL(a)-1;i>=(INT)0;i--) res += S_PA_CII(a,i); M_I_I(res,b); goto endr_ende; } if (S_PA_K(a) == VECTOR) { for (i=S_PA_LI(a)-1;i>=(INT)0;i--) res += S_PA_II(a,i); M_I_I(res,b); } else if (S_PA_K(a) == EXPONENT) { for (i=S_PA_LI(a)-1;i>=(INT)0;i--) res += (i+1) * S_PA_II(a,i); M_I_I(res,b); } else if (S_PA_K(a) == FROBENIUS) { OP c = callocobject(); erg += sum_integervector(S_V_I(S_PA_S(a),0),b); erg += sum_integervector(S_V_I(S_PA_S(a),1),c); erg += add_apply_integer(c,b); erg += freeall(c); erg += add_apply_integer(S_V_L(S_V_I(S_PA_S(a),0)),b); } else { erg += error("weight_partition: wrong kind of part"); } ENDR("weight_partition"); } INT scan_exponentpartition(c) OP c; /* AK V2.0 200298 */ { INT erg=OK; COP("scan_exponentpartition(1)",c); spa: erg += b_ks_pa(EXPONENT,callocobject(),c); erg += printeingabe("Please input a partition as vector"); erg += printeingabe("of integers (multiplicities) >= 0."); erg += scan(INTEGERVECTOR,S_PA_S(c)); if (partitionp(c) != TRUE) /* AK 170692 */ { erg += printeingabe("Sorry, you did not enter a partition"); erg += printeingabe("please try again."); erg += freeself(c); goto spa; } ENDR("scan_exponentpartition"); } INT scan_partition(c) OP c; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 250291 V1.2 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT erg=OK; COP("scan_partition(1)",c); spa: erg += b_ks_pa(VECTOR,callocobject(),c); erg += printeingabe("Please input a partition as increasing vector"); erg += printeingabe("of integers > 0."); erg += scan(INTEGERVECTOR,S_PA_S(c)); if (partitionp(c) != TRUE) /* AK 170692 */ { erg += printeingabe("Sorry, you did not enter a partition"); erg += printeingabe("please try again."); erg += freeself(c); goto spa; } ENDR("scan_partition"); } INT scan_reversepartition(c) OP c; /* AK 150703 */ { INT erg=OK; OP d; COP("scan_reversepartition(1)",c); spa: d = CALLOCOBJECT(); erg += printeingabe("Please input a partition as decreasing vector"); erg += printeingabe("of integers > 0."); erg += scan(INTEGERVECTOR,d); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),c); erg += reverse_vector(d,S_PA_S(c)); FREEALL(d); if (partitionp(c) != TRUE) /* AK 170692 */ { erg += printeingabe("Sorry, you did not enter a partition"); erg += printeingabe("please try again."); FREESELF(c); goto spa; } ENDR("scan_partition"); } OP s_pa_s(a) OP a; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_partition->pa_self); } INT s_pa_hash(a) OP a; /* AK 240901 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_partition->pa_hash); } OBJECTKIND s_pa_k(a) OP a; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_partition->pa_kind); } OP s_pa_i(a,i) OP a; INT i; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { return(s_v_i(s_pa_s(a),i)); } INT s_pa_ii(a,i) OP a; INT i; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT erg = OK; CTO(PARTITION,"s_pa_ii",a); return(s_v_ii(s_pa_s(a),i)); ENDR("s_pa_ii"); } OP s_pa_l(a) OP a; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT erg = OK; CTO(PARTITION,"s_pa_l",a); return(s_v_l(s_pa_s(a))); ENDO("s_pa_l"); } INT s_pa_li(a) OP a; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(PARTITION,"s_pa_li",a); return(s_v_li(s_pa_s(a))); ENDR("s_pa_li"); } INT c_pa_k(a,b) OP a; OBJECTKIND b; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { OBJECTSELF c; c = s_o_s(a); c.ob_partition->pa_kind = b; return(OK); } INT c_pa_s(a,b) OP a,b; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { OBJECTSELF c; c = s_o_s(a); c.ob_partition->pa_self = b; return(OK); } INT c_pa_hash(a,b) OP a; INT b; /* AK 240901 */ { OBJECTSELF c; c = s_o_s(a); c.ob_partition->pa_hash = b; return(OK); } INT objectread_partition(filename,part) OP part; FILE *filename; /* AK 291086 zum einlesen einer partition von einem file */ /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT kind; INT erg = OK; COP("objectread_partition(1)",filename); COP("objectread_partition(2)",part); fscanf(filename,"%ld",&kind); erg += b_ks_pa((OBJECTKIND)kind, callocobject(),part); erg += objectread(filename,S_PA_S(part)); if (S_PA_K(part) == VECTOR) C_O_K(S_PA_S(part),INTEGERVECTOR); /* AK 030502 to be compatible with old data */ ENDR("objectread_partition"); } INT objectwrite_partition(filename,part) FILE *filename; OP part; /* AK 291086 */ /* zum schreiben einer partition auf einen file */ /* AK 060789 V1.0 */ /* AK 200690 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ { INT erg = OK; COP("objectwrite_partition(1)",filename); COP("objectwrite_partition(2)",part); fprintf(filename,"%ld\n",(INT)PARTITION); fprintf(filename,"%ld\n",(INT)S_PA_K(part)); erg += objectwrite(filename,S_PA_S(part)); ENDR("objectwrite_partition"); } INT m_il_pa(i,p) INT i; OP p; /* AK 130803 */ /* partition object of kind VECTOR of given length with undefined entries */ { INT erg =OK; SYMCHECK(i<0,"m_il_pa: negative length"); B_KS_PA(VECTOR,CALLOCOBJECT(),p); erg += m_il_integervector(i,S_PA_S(p)); ENDR("m_il_pa"); } INT t_VECTOR_EXPONENT(von,nach) OP von,nach; /* AK 190588 */ /* AK 060789 V1.0 */ /* AK 200690 V1.1 */ /* AK 200891 V1.3 */ /* AK V2.0 020698 */ /* in the exponent noattion the i-th entry of the vector contains the number of parts of size i+1 e.g. 234 --> 011100000 */ { INT i,w; OP l; INT erg = OK; PART_CHECK_KIND("t_VECTOR_EXPONENT",von,VECTOR); CE2(von,nach,t_VECTOR_EXPONENT); l=CALLOCOBJECT(); PARTITION_WEIGHT(von,w); M_I_I(w,l); erg += b_ks_pa(EXPONENT,CALLOCOBJECT(),nach); erg += b_l_nv(l,S_PA_S(nach)); C_O_K(S_PA_S(nach),INTEGERVECTOR); for (i=(INT)0;i0) { j += S_I_I(l); ba=i; } /* ba is the last non zero entry in a */ if (t_exp_vec_app_c==NULL) { NEW_INTEGERVECTOR(c,j); t_exp_vec_app_c = c; } else { c = t_exp_vec_app_c; if (j > S_V_LI(c)) erg += inc_vector_co(c,j-S_V_LI(c)+5); } s=j; for (i=0,z=S_V_S(c);i<=ba;i++) if (S_PA_II(a,i)>0) for (j=(INT)0;j0) { j += S_PA_II(a,i); ba=i; } /* ba is the last non zero entry in a */ l = CALLOCOBJECT(); M_I_I(j,l); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),b); erg += b_l_v(l,S_PA_S(b)); C_O_K(S_PA_S(b), INTEGERVECTOR); for (i=(INT)0;i<=ba;i++) if (S_PA_II(a,i)>0) for (j=(INT)0;j=(INT)0;i--) k = k + S_PA_II(a,i) - i; M_I_I(k,b); ENDR("weight_augpart"); } INT contain_comp_part(a,b) OP a,b; /* AK V2.0 090298 */ /* true if a sub b */ { INT i; if (S_PA_LI(a) > S_PA_LI(b)) return FALSE; for (i=0;i S_PA_II(b,S_PA_LI(b)-1-i)) return FALSE; } return TRUE; } INT length_comp_part(a,b) OP a,b; /* returns 0 if equal length returns >0 if length(a) > length(b) returns <0 if length(a) < length(b) */ /* AK 161001 */ { INT erg = OK; PART_CHECK_KIND("length_comp_part(1)",a,VECTOR); PART_CHECK_KIND("length_comp_part(2)",b,VECTOR); return S_PA_LI(a) - S_PA_LI(b); ENDR("length_comp_part"); } INT maxpart_comp_part(a,b) OP a,b; /* returns 0 if equal maximal part returns >0 if maximal part(a) > maximal part(b) returns <0 if maximal part(a) < maximal part(b) */ /* AK 191001 */ { INT erg = OK; PART_CHECK_KIND("maxpart_comp_part(1)",a,VECTOR); PART_CHECK_KIND("maxpart_comp_part(2)",b,VECTOR); if (S_PA_LI(a) == 0) { if (S_PA_LI(b) == 0) return 0; else return -1; } if (S_PA_LI(b) == 0) return 1; return S_PA_II(a,S_PA_LI(a)-1) - S_PA_II(b,S_PA_LI(b)-1); ENDR("maxpart_comp_part"); } INT sub_comp_part(a,b) OP a,b; /* returns 0 on equal 1 if a bigger according to containment -1 if smaller NONCOMPARABLE else */ /* AK V2.0 250298 */ /* a and b may be equal */ { INT erg=0,i,j; PART_CHECK_KIND("sub_comp_part",a,VECTOR); PART_CHECK_KIND("sub_comp_part",b,VECTOR); for (i=S_PA_LI(a)-1, j=S_PA_LI(b)-1;i>=0;i--,j--) { if (j<(INT)0) /* length of a > length of b */ { if (erg == -1) return NONCOMPARABLE; return 1; } if (S_PA_II(a,i) > S_PA_II(b,j)) { if (erg == -1) return NONCOMPARABLE; erg = 1; continue; } if (S_PA_II(a,i) < S_PA_II(b,j)) { if (erg == 1) return NONCOMPARABLE; erg = -1; continue; } } if (j >= 0) { return -1; } return erg; ENDR("sub_comp_part"); } INT dom_comp_part(a,b) OP a,b; /* returns 0 on equal 1 if a bigger according dominance -1 smaller NONCOMPARABLE if not comparable */ /* AK 140591 V1.2 */ /* AK 200891 V1.3 */ /* AK V2.0 200298 */ /* a and b may be equal */ /* AK V3.1 131006 */ { INT i,j,s1,s2; INT l,erg = (INT)0; PART_CHECK_KIND("dom_comp_part",a,VECTOR); PART_CHECK_KIND("dom_comp_part",b,VECTOR); l = (S_PA_LI(a) > S_PA_LI(b)) ? S_PA_LI(a) : S_PA_LI(b) ; /* l is the length of the longer partition */ for (i=(INT)0; i s2) erg = (INT)1; if (s1 < s2) erg = (INT)-1; } else if ( erg == 1 ) { if (s1 < s2) return NONCOMPARABLE; /* not comparable */ } else if ( erg == -1 ) { if (s1 > s2) return NONCOMPARABLE; /* not comparable */ } else { erg = error("dom_comp_part:internal error"); goto endr_ende; } } return erg; ENDR("dom_comp_part"); } INT even_partition(a,b) OP a,b; /* AK V2.0 200298 */ /* AK V3.1 131006 */ { OP c; INT erg; c = callocobject(); weight(a,c); sub(c,S_PA_L(a),c); erg = even(c); freeall(c); return erg; } INT random_part_EXPONENT(n,b) OP n,b; /* AK V2.0 250298 */ { return random_partition_exponent(n,b); } INT random_partition_exponent(n,b) OP n,b; /* new random partition nijnhuis wilf p.76 */ /* AK 151092 also for longint */ /* AK V2.0 200298 */ /* input: INTEGER object output: PARTITION object of given weight in EXPONENT notation */ /* AK V3.1 131006 */ { OP k,z,multi,p,d,m,i,isum,is,i1,j; INT nlast; INT erg = OK; CTO(INTEGER,"random_partition_exponent",n); CE2(n,b,random_partition_exponent); if (S_I_I(n) < (INT)0) { erg += error("random_partition_exponent: n < 0"); goto endr_ende; } else if (S_I_I(n) == (INT)0) { erg += first_part_EXPONENT(n,b); goto endr_ende; } CALLOCOBJECT5(z,k,m,p,i); CALLOCOBJECT6(i1,j,is,isum,d,multi); nlast = 0; erg += m_l_nv(n,multi); erg += m_l_v(n,p); /* l10: */ if (S_I_I(n) <= nlast) goto l30; /* l20:*/ erg += m_i_i(1,S_V_I(p,(INT)0)); erg += m_i_i(nlast + (INT)1, m); /* erg += add(nlast,cons_eins,m); */ /* erg += copy_integer(n,nlast); */ nlast = S_I_I(n); if (S_I_I(n) == (INT)1) goto l30; for(copy(m,i); le(i,n); inc(i)) { erg += m_i_i((INT)0,isum); for (m_i_i(1,d); le(d,i); inc_integer(d) ) { erg += m_i_i((INT)0,is); erg += copy(i,i1); l24: erg += sub(i1,d,i1); if (lt(i1,cons_null) ) goto l22; if (eq(i1,cons_null) ) goto l25; erg += add_apply(S_V_I(p,S_I_I(i1)-1),is); goto l24; l25: erg += inc(is); l22: erg += mult_apply(d,is); erg += add_apply(is,isum); } erg += ganzdiv(isum,i,S_V_I(p,S_I_I(i)-1)); } l30: erg += copy(n,m); erg += m_i_i((INT)0,k); l40: erg += mult(m,S_V_I(p,S_I_I(m)-1),d); erg += random_integer(z,cons_eins,d); erg += m_i_i((INT)0,d); l110: erg += inc(d); /*l60:*/ erg += copy(m,i1); erg += m_i_i((INT)0,j); l150: erg += inc(j); /*l70:*/ erg += sub(i1,d,i1); /*l80:*/ if (lt(i1,cons_null)) goto l110; if (eq(i1,cons_null)) goto l90; erg += mult(d,S_V_I(p,S_I_I(i1)-1),is); erg += sub(z,is,z); /* l130: */ if (le(z,cons_null)) goto l145; goto l150; l90: erg += sub(z,d,z); /* l100: */ if (le(z,cons_null)) goto l145; goto l110; l145: erg += add_apply(j,S_V_I(multi,S_I_I(d)-1)); erg += add_apply(j,k); /* l160:*/ erg += copy(i1,m); /*l170:*/ if (neq(m,cons_null)) goto l40; FREEALL5(z,k,m,p,i); FREEALL5(i1,j,is,isum,d); erg += b_ks_pa(EXPONENT,multi,b); /* do not free multi */ ENDR("random_partition_exponent"); } INT random_partition(n,p) OP n,p; /* AK 230298 V2.0 */ /* input: INTEGER object n output: PARTITION object of given weight in VECTOR notation */ /* n and p may be equal */ { OP c; INT erg = OK; CTO(INTEGER,"random_partition(1)",n); SYMCHECK(S_I_I(n)<0, "random_partition(1)<0"); if (S_I_I(n) < 2) erg += first_partition(n,p); else { c = CALLOCOBJECT(); erg += random_partition_exponent(n,c); erg += t_EXPONENT_VECTOR(c,p); FREEALL(c); } ENDR("random_partition"); } INT t_FROBENIUS_VECTOR(a,b) OP a,b; /* AK 270603 V2.0 */ { INT erg =OK; OP l,r; INT d,i,k; PART_CHECK_KIND("t_FROBENIUS_VECTOR",a,FROBENIUS); CE2(a,b,t_FROBENIUS_VECTOR); r = S_V_I(S_PA_S(a),0); /* right of main dia */ l = S_V_I(S_PA_S(a),1); /* left of main dia */ d = S_V_LI(l); /* durfee size */ if (d == 0) { first_partition(cons_null,b); goto endr_ende; } erg += m_il_pa(S_V_II(l,0)+1, b); for (i=0;i=0)&&(S_PA_II(a,j) > i); i++,j--) ; erg += m_il_v(i,S_V_I(S_PA_S(b),(INT)0)); erg += m_il_v(i,S_V_I(S_PA_S(b),1)); c = callocobject(); erg += conjugate(a,c); for (j=(INT)0;j0) { if(i==d-1) return 0; if(x>=pdc[i]) { v[i]=pdc[i]; x -= pdc[i--]; } else { v[i] = x; x = 0; } } return 1; } /********************************************************************** * partitions avec contraintes * **********************************************************************/ static void repartir(aa,rang,contrib,pdc,v,lv,dd,e) OP dd,e; int rang, contrib, lv, pdc[], v[]; struct axelclaude *aa; { int d,l,i; int *w, *pdcv; pdcv = (int *) SYM_calloc(lv,sizeof(int)); w = (int *) SYM_calloc(lv,sizeof(int)); d=1; l=lv-1; while(1) { remplir(contrib,pdc,v,d,l); utiliser(aa,rang,v,lv,dd,e); if(rangnbl-1) { for(i=1;i<=l;i++) pdcv[i]=pdc[i]-v[i]; repartir(aa,rang+1,aa->pdl[rang+1],pdcv,w,lv,dd,e); } i=l-1; contrib = v[l]; while(i>0) if(v[i]==pdc[i]) contrib += v[i--]; else if(contrib==0) contrib=v[i--]; else break; if(i>0) { v[i]++; contrib--; d=i+1; continue; } else break; } SYM_free(pdcv); SYM_free(w); } /******************************************************************* * exploitation d'une ligne construite * *******************************************************************/ static void utiliser(aa,rang,v,lv,d,e) OP d,e; struct axelclaude *aa; int rang,v[], lv; { int i, j; /* for(i=1;imat[rang][i]=v[i]; */ for(i=1;imat[(rang*aa->nbc) +i]=v[i]; if(rang==aa->nbl-1) { inc(e); for(i=1;inbl;i++) { for(j=1;jmat[(i*aa->nbc) +j],S_M_IJ(d,i-1,j-1) ); } copy(d,S_V_I(e,S_V_LI(e)-1)); } } static INT sscan_partition_co(); INT sscan_reversepartition(t,a) OP a; char *t; { INT erg = OK; OP d; sscan_partition_co(t,a); d=CALLOCOBJECT(); reverse_vector(S_PA_S(a),d); COPY(d,S_PA_S(a)); FREEALL(d); SYMCHECK (not partitionp(a),"sscan_reversepartition:no partition entered"); ENDR("sscan_reversepartition"); } INT sscan_partition(t,a) OP a; char *t; { INT erg = OK; sscan_partition_co(t,a); SYMCHECK (not partitionp(a),"sscan_reversepartition:no partition entered"); ENDR("sscan_partition"); } static INT sscan_partition_co(t,a) OP a; char *t; /* AK 050194 to read partition from string format [1,2,3,23,23,33] */ /* AK 230298 V2.0 */ { INT i,n,erg = OK; int SYM_isdigit(); char *v,*w; COP("sscan_partition(1)",t); COP("sscan_partition(2)",a); v = t; while (*v == ' ') v++; if (*v != '[') {erg = ERROR; goto spe;} w = v; n = (INT)1; /* now we count the number of parts */ w++; while (*w != ']') { if (*w == ',') n++; else if (not SYM_isdigit(*w)) {erg = ERROR; goto spe;} w++; } /* n is the number of parts */ b_ks_pa(VECTOR,callocobject(),a); m_il_v(n,S_PA_S(a)); C_O_K(S_PA_S(a),INTEGERVECTOR); w = v; w++; for (i=(INT)0; i= b equal parts */ /* AK 230298 V2.0 */ { INT erg = OK; INT i,j=0,k=0; CTO( PARTITION,"equal_parts",a); CTO( INTEGER,"equal_parts",b); if (S_I_I(b) <= (INT)0) { erg += error("equal_parts:integer object not bigger 0"); goto endr_ende; } if (S_PA_K(a) == EXPONENT) { for (i=0;i= S_I_I(b)) return TRUE; return FALSE; } if (S_PA_K(a) != VECTOR) { erg += error("equal_parts: partition object not VECTOR kind"); goto endr_ende; } for (i=0;i= S_PA_LI(a)) { if (a!= c) COPY(a,c); } else if (j >= S_PA_II(a,S_PA_LI(a)-1-i)) { if (a!= c) COPY(a,c); } else { d = CALLOCOBJECT(); COPY(S_PA_S(a),d); M_I_I(j,S_V_I(d,S_PA_LI(a)-i-1)); for (k=i+1; k= j) { DEC_INTEGER(S_V_I(d,S_PA_LI(a)-1-k)); COPY_INTEGER(S_V_I(d,S_PA_LI(a)-1-k),S_V_I(d,S_PA_LI(a)-k)); } else { m_i_i(j,S_V_I(d,S_PA_LI(a)-k)); break; } if (k == S_PA_LI(a)) M_I_I(j,S_V_I(d,0)); erg += m_v_pa(d,c); FREEALL(d); } ENDR("remove_hook"); } INT p_hook_diagramm(a,b,c) OP a,b,c; /* AK 010295 */ /* AK 230298 V2.0 */ /* input: PARTITION object a INTEGER object b output: hook diagramm with entry = hooklength mod b */ { INT erg=OK,i,j,k,l; CTO(INTEGER,"p_hook_diagramm(2)",b); PART_CHECK_KIND("p_hook_diagramm(1)",a,VECTOR); CE3(a,b,c,p_hook_diagramm); if (S_I_I(b) < (INT) 0) { erg += error("p_hook_diagramm: second parameter < 0"); goto endr_ende; } erg += hook_diagramm(a,c); if (S_I_I(b) == (INT)0) goto ee; if (S_I_I(b) == (INT)1) goto ee; for (i=0;i0;j--) { erg += m_i_i(k,S_V_I(c,l)); l++; } } } erg += m_v_pa(c,b); erg += freeall(c); ENDR("strict_to_odd_part"); } INT nachfolger_young(a,b) OP a,b; /* input: PARTITION object a output: VECTOR object of PARTITION objects, which are bigger neighbours in the Young poset */ /* AK V2.0 170298 */ /* a and b may be equal */ { INT erg = OK,k; OP c,z; CTO(PARTITION,"nachfolger_young",a); c = callocobject(); erg += first_partition(cons_eins,c); erg += outerproduct_schur(c,a,c); k=0; z = c; while (z != NULL) { k++; z = S_L_N(z); } erg += m_il_v(k,b); k=0; z = c; while (z != NULL) { erg += copy_partition(S_S_S(z), S_V_I(b,k)); k++; z = S_L_N(z); } erg += freeall(c); ENDR("nachfolger_young"); } INT vorgaenger_young(a,b) OP a,b; /* input: PARTITION object a output: VECTOR object of PARTITION objects, which are smaller neighbours in the Young poset */ /* AK V2.0 170298 */ /* a and b may be equal */ { INT erg = OK,k; OP c,z; CTTO(SKEWPARTITION,PARTITION,"vorgaenger_young(1)",a); if (S_O_K(a) == SKEWPARTITION) { CE2(a,b,vorgaenger_young_skewpartition); erg += vorgaenger_young_skewpartition(a,b); goto ende; } SYMCHECK (S_PA_LI(a) == 0, "vorgaenger_young: partition of weight 0 not allowed"); c = CALLOCOBJECT(); erg += first_partition(cons_eins,c); erg += part_part_skewschur(a,c,c); k=0; z = c; while (z != NULL) { k++; z = S_L_N(z); } erg += m_il_v(k,b); k=0; z = c; while (z != NULL) { erg += copy_partition(S_S_S(z), S_V_I(b,k)); k++; z = S_L_N(z); } FREEALL(c); ende: ENDR("vorgaenger_young"); } INT vorgaenger_young_skewpartition(a,b) OP a,b; /* input: SKEWPART object a EMPTY object b output: VECTOR object b of SKEWPART objects, which are smaller neighbours in the Young poset */ /* AK V2.0 280602 */ { INT erg = OK,i,kl; OP g,k; CTO(SKEWPARTITION,"vorgaenger_young_skewpartition(1)",a); CTO(EMPTY,"vorgaenger_young_skewpartition(2)",b); g = S_SPA_G(a); k = S_SPA_K(a); SYMCHECK( EQ(g,k), "vorgaenger_young_skewpartition: partition of weight 0 not allowed"); erg += init(BINTREE,b); if (S_PA_LI(g) == 1) { OP c; c = CALLOCOBJECT(); m_gk_spa(g,k,c); DEC_INTEGER(S_SPA_GI(c,0)); insert(c,b,NULL,NULL); goto ende; } /* in der ersten zeile kann evtl ein stein entfernt werden */ if (S_PA_LI(k) < S_PA_LI(g)) { OP c; c = CALLOCOBJECT(); m_gk_spa(g,k,c); if (S_PA_II(g,0) == 1) { FREESELF(S_SPA_G(c)); remove_part_integer(S_SPA_G(a),cons_eins,S_SPA_G(c)); } else DEC_INTEGER(S_SPA_GI(c,0)); insert(c,b,NULL,NULL); } else if (S_PA_II(g,0) > S_PA_II(k,0)) { OP c; c = CALLOCOBJECT(); m_gk_spa(g,k,c); DEC_INTEGER(S_SPA_GI(c,0)); insert(c,b,NULL,NULL); } for (i=1;i S_PA_II(g,i-1)) { kl = S_PA_LI(k) - (S_PA_LI(g)-i); if (kl < 0) { OP c; c = CALLOCOBJECT(); m_gk_spa(g,k,c);println(c); DEC_INTEGER(S_SPA_GI(c,i));println(c); insert(c,b,NULL,NULL); } else if (S_PA_II(g,i) > S_PA_II(k,i-(S_PA_LI(g)-S_PA_LI(k)) )) { OP c; c = CALLOCOBJECT(); m_gk_spa(g,k,c);println(c); DEC_INTEGER(S_SPA_GI(c,i));println(c); insert(c,b,NULL,NULL); } } ende: t_BINTREE_VECTOR(b,b); ENDR("vorgaenger_young_skewpartition"); } INT character_polynom(a,b) OP a,b; /* AK 040892 */ /* AK 161006 V3.1 */ { INT erg = OK; INT i,wi=0; OP l,lp,p,res,v; PART_CHECK_KIND("character_polynom(1)",a,VECTOR); if (S_PA_LI(a) == (INT)0) { erg += m_scalar_polynom(cons_eins,b); goto endr_ende; } CE2(a,b,character_polynom); C1R(a,"character_polynom",b); CALLOCOBJECT4(l,lp,p,v); COPY(S_PA_L(a),l); INC(l); COPY(a,lp); erg += first_permutation(l,p); erg += young_polynom(a,b); while (next_apply(p)) { CLEVER_COPY(S_PA_S(a),v); for (i=1;i(INT)0) { erg += m_i_i(k,d); erg += multinom(d,c,e); erg += m_iindex_monom(i,f); erg += binom(f,d,m); MULT_APPLY(e,m); MULT_APPLY(m,n); } } ADD_APPLY(n,l); j=(INT)0; if (S_V_LI(b) == 0) break; /* AK 060498 */ while (not next(S_V_I(b,j),S_V_I(b,j))) { j++; if (j==S_V_LI(b)) break; } if (j == S_V_LI(b)) break; /* links von der stelle wo erhoeht wurd muss auf null gesetzt werden */ for (j--;j>=(INT)0;j--) erg += first_part_EXPONENT(S_PA_I(a,j),S_V_I(b,j)); } while(1); /* alle partitionen durchlaufen */ FREEALL7(b,f,d,n,c,e,m); S1R(a,"young_polynom",l); ENDR("young_polynom"); } INT is_graphical(a) OP a; /* return TRUE if graphical partition */ /* i.e. a vertex degree sequence of a simple undirected graph, uses the criterion of haesselbarth see: barnes, savage: a reucrrence for counting graphical partitions */ /* AK 161006 V3.1 */ { INT erg = OK,r; CTO(PARTITION,"is_graphical(1)",a); SYMCHECK(S_PA_K(a) != VECTOR,"is_graphical no vector type"); { INT i,j=0; OP b; INT res = TRUE; for (i=0; i -j) { res = FALSE; goto ee; } } ee: FREEALL(b); ff: return res; } ENDR("is_graphical"); } INT multiplicity_part(part,i) OP part; INT i; /* AK 210503 */ /* return the multiplicty of part i in the partition part */ { INT erg = OK; CTO(PARTITION,"multiplicity_part",part); SYMCHECK(i<=0,"multiplicity_part: checked part must be > 0"); if (S_PA_K(part) == VECTOR) { OP z; INT j=S_PA_LI(part)-1; do { z = S_PA_I(part,j); if (S_I_I(z) < i) return 0; else if (S_I_I(z) == i) { erg = 1; j--; while (j>=0) { z = S_PA_I(part,j); if (S_I_I(z) != i) return erg; j--; erg ++; } return erg; } else j--; } while (j>=0); return 0; } else if (S_PA_K(part) == EXPONENT) { if (i > S_PA_LI(part)) return 0; return S_PA_II(part,i-1); } else { error("multiplicity_part: wrong kind of partition"); } ENDR("multiplicity_part"); } INT durfee_size_part(a,b) OP a,b; /* AK 260603 */ { INT erg =OK; CTO(PARTITION,"durfee_size_part(1)",a); if (S_PA_K(a)==VECTOR) { INT i,j; for (i=1; i<=S_PA_LI(a);i++) if (S_PA_II(a,S_PA_LI(a)-i) =S_PA_LI(a)) first_partition(cons_null,b); else if (j>=S_PA_II(a,S_PA_LI(a)-1-i)) first_partition(cons_null,b); else { INT armlength, footlength; OP c; armlength=S_PA_II(a,S_PA_LI(a)-1-i)-1-j; for (footlength = 0; footlength < S_PA_LI(a)-1-i; footlength++) if (S_PA_II(a,S_PA_LI(a)- i-1-footlength) <= j) {footlength--;break;} c=CALLOCOBJECT(); m_il_v(footlength+1,c); for (;footlength>=0;footlength--) M_I_I(1,S_V_I(c,footlength)); M_I_I(armlength+1,S_V_I(c,S_V_LI(c)-1)); C_O_K(c,INTEGERVECTOR); b_ks_pa(VECTOR,c,b); } } else { erg += error("hook_partition:wrong type of partition"); } ENDR("hook_partition"); } INT ribbon_partition(a,i,j,b) INT i,j; OP a,b; /* AK 270603 */ /* computes the ribbon = skew partition corresponding to the hook at position i,j */ { INT erg = OK; CTO(PARTITION,"ribbon_partition(1)",a); SYMCHECK(i<0,"ribbon_partition(2):<0"); SYMCHECK(j<0,"ribbon_partition(3):<0"); if (S_PA_K(a) == VECTOR) { OP d; SYMCHECK(i>=S_PA_LI(a),"ribbon_partition(2):> length of partition"); SYMCHECK(j>=S_PA_II(a,S_PA_LI(a)-1-i),"ribbon_partition(3):> size of part"); d = CALLOCOBJECT(); t_VECTOR_FROBENIUS(a,d); delete_entry_vector(S_V_I(S_PA_S(d),0),i,S_V_I(S_PA_S(d),0)); delete_entry_vector(S_V_I(S_PA_S(d),1),j,S_V_I(S_PA_S(d),1)); t_FROBENIUS_VECTOR(d,d); m_gk_spa(a,d,b); FREEALL(d); } else erg += error("ribbon_partition(1): wrong type of partition"); ENDR("ribbon_partition"); } INT young_ideal(a,b) OP a,b; /* input: PARTITION object output: VECTOR object, i-th entry = i-th level in young ideal */ /* AK 130803 */ { INT i,j,k; OP c,d,e,z,f; INT erg = OK; CTO(PARTITION,"young_ideal(1)",a); if (S_PA_K(a) == EXPONENT) { CALLOCOBJECT2(c,d); erg += t_EXPONENT_VECTOR(a,c); erg += young_ideal(c,d); m_il_v(S_V_LI(d), b); for (i=0;i= number equal parts. This routine is needed for modular representations of the symmetric group. BUG: works only for VECTOR type partitions NAME: q_core SYNOPSIS: INT q_core(OP part, d, res) DESCRIPTION: computes the q-core of a PARTITION object part. This is the remaining partition (=res) after removing of all hooks of length d (= INTEGER object). The result may be an empty object, if the whole partition disappears. BUG: works only for VECTOR type partitions COMMENT: Sometimes it is useful to sort an INTEGER vector, so that the result is a PARTITION object. This is done in the routine m_v_pa. NAME: m_v_pa SYNOPSIS: INT m_v_pa(OP vec, result) DESCRIPTION: The vec must be a VECTOR object with positve (>=0) INTEGER objects. This vector will be sorted and becomes the self part of the result which becomes a PARTITION object. As the name make_ .. says the vec will be copied. So you can still use the unsorted INTEGER vector vec. In the case b_v_pa the sorted vector becomes part of the PARTITION result. in the case of m_v_pa vec and result may be equal RETURN: ERROR if negative entries ERROR if not INTEGER entries OK COMMENT: If you want to build a PARTITION with only one part, you have m_i_pa. NAME: m_i_pa SYNOPSIS: INT m_i_pa(OP int, result) DESCRIPTION: build a PARTITION object with one part, namely the INTEGER object int. There is a copy of int inside the partition. COMMENT: Advanced routines ----------------- Generation of partitions: Very often you want to loop over all partitions, of a given weight. Look: #include "def.h" #include "macro.h" main() { OP a,b; anfang(); a = callocobject(); b = callocobject(); scan(INTEGER,a); first_partition(a,b); do { println(b); } while (next(b,b)); freeall(a); freeall(b); ende(); } which is a program which first asks the weight, and then prints a list of all partitions of that weight. Now the description: NAME: first_partition SYNOPSIS: INT first_partition(OP n, result) DESCRIPTION: n must be an INTEGER object, and result becomes the PARTITION object of VECTOR kind, which is the first one according to many orders of partitions, namely the partition [n]. EXAMPLE: to loop over all partitions #include "def.h" #include "macro.h" ANFANG scan(INTEGER,a); first_partition(a,b); do { println(b); } while (next(b,b)); ENDE COMMENT: analogous there is NAME: last_partition SYNOPSIS: INT last_partition(OP n, result) DESCRIPTION: n must be an INTEGER object, and result becomes the PARTITION object of VECTORkind, which is the last one according to many orders of partitions, namely the partition [1,1,1,....,1,1]. n and result may be equal objects. NAME: next_partition SYNOPSIS: next_partition(OP partone, OP partnext) DESCRIPTION: using the algorithm of Nijnhuis/Wilf the next partition with the same weight is computed. Better to use the general routine next(OP,OP) EXAMPLE: to loop over all partitions #include "def.h" #include "macro.h" ANFANG scan(INTEGER,a); first_partition(a,b); do { println(b); } while (next(b,b)); ENDE COMMENT: If you want to specify the kind of representation of the partition, there is also NAME: first_part_VECTOR SYNOPSIS: INT first_part_VECTOR(OP n, OP res) NAME: first_part_EXPONENT SYNOPSIS: INT first_part_EXPONENT(OP n, OP res) NAME: last_part_VECTOR SYNOPSIS: INT last_part_VECTOR(OP n, OP res) NAME: last_part_EXPONENT SYNOPSIS: INT last_part_EXPONENT(OP n, OP res) COMMENT: which have the same parameters and produce the specified PARTITION objects. To generate the next partition you should use the standardroutine next(), which allows you to use the same object for input and output, which is not allowed if you use the low level routine next_partition(). For the output of a PARTITION object using the standard routines print println or fprint and fprintln, you have to know the followiing convention. The parts of size 10 <= .. <=15 are printed as A,B,C,D,E,F and the parts bigger than 15 are printed with | between the parts. NAME: makevectorofpart gives a vector of partitions SYNOPSIS: INT makevectorofpart(OP n, result) DESCRIPTION: n must be an INTEGER object, and result becomes a VECTOR object of PARTITION objects. The order is according to the order of next(). [Nijenhuis/Wilf] EXAMPLE: #include "def.h" #include "macro.h" main() { OP a,b; anfang(); a = callocobject(); b = callocobject(); scan(INTEGER,a); makevectorofpart(a,b); println(b); println(s_v_i(b,s_v_li(b)-1L)); freeall(a); freeall(b); ende(); } NAME: numberofpart number of partitions SYNOPSIS: INT numberofpart(OP n, result) DESCRIPTION: numberofpart computes the number of partitions of the given weight n, which must be an INTEGER object. The result is an INTEGER object, or a LONGINTobject, according to the size of n. RETURN: OK or ERROR. EXAMPLE: This programm prints the number of partitions of weight up to 199. As you know this is big number, and the result for e.g. a=150 will be no longer an INTEGER object as for a=10, but a LONGINTobject. #include "def.h" #include "macro.h" main() { INT i; OP a,b; anfang(); a = callocobject(); b = callocobject(); for (i=1L;i<200L;i++) { freeself(a); freeself(b); /* a,b are now empty objects */ M_I_I(i,a); numberofpart(a,b); /* b is the number of partitions of weight a */ print (a) ; println(b); } freeall(a); freeall(b); ende(); } NAME: numberofpart_i SYNOPSIS: INT numberofpart_i(OP n) DESCRIPTION: numberofpart_i computes the number of partitions of the given weight n. the result will be the rturn value, so it works only for a small input. RETURN: numberofpart_i returns the number of partitions or ERROR COMMENT: This routine uses a method, which was described by Gupta, which is recursive one. So we have the following routine NAME: gupta_nm SYNOPSIS: INT gupta_nm(OP n,m,erg) DESCRIPTION: this routine computes the number of partitions of n with maximal part m. The result is erg. The input n,m must be INTEGER objects. The result is freed first to an empty object. The result must be a different from m and n. RETURN: OK COMMENT: There is also a routine, which computes a table of this values: NAME: gupta_tafel SYNOPSIS: INT gupta_tafel(OP max, result) DESCRIPTION: it computes the table of the above values. The entry n,m is the result of gupta_nm. mat is freed first. max must be an INTEGER object, it is the maximum weight for the partitions. max must be different from result. RETURN: OK COMMENT: Very often we have to work with vectors or matrices labeled by partitions. So we need the index of a partition: NAME: indexofpart SYNOPSIS: INT indexofpart(OP part) DESCRIPTION: computes the index of a partition. The algorithm used is the same as in next_partition. So the partition given by first_partition has the index 0. RETURN: The index of the partition, or ERROR NAME: random_partition SYNOPSIS: INT random_partition (OP w, p) DESCRIPTION: returns a random partition p of the entered weight w. w must be an INTEGER object, p becomes a PARTITION object. Type of partition is VECTOR . Its the algorithm of Nijnhuis Wilf p.76 COMMENT: COMPARISION ----------- There are several orders on the partitions. The standard routine comp() uses the colexikographic order, it is : you read the biggest part first, if it is equal you read the next part and so on. This is the same order, in which the partitions are generated using next. But there is another order the so called dominance order, it is checked by the routine NAME: dom_comp_part SYNOPSIS: INT dom_comp_part(OP parta, partb) DESCRIPTION: compares two partitions according to the dominance order. At the moment only for VECTOR representation. RETURN: 0 if equal, 1 if parta bigger then partb, -1 if parta is smaller then partb, the constant NONCOMPARABLE means that parta and partb are not comparable. EXAMPLE: #include "def.h" #include "macro.h" main() { OP a,b,c; INT i,j; anfang(); a=callocobject(); b=callocobject(); c=callocobject(); scan(INTEGER,a); makevectorofpart(a,b); println(b); m_ilih_m(S_V_LI(b),S_V_LI(b),c); for (i=0L;i= 0 */ /* AK 151104 V3.0 */ { INT erg = OK; CTO(PERMUTATION,"rank_permutation",a); CPT(VECTOR,"rank_permutation",a); { OP f,c,d; INT i,j; CALLOCOBJECT3(c,d,f); erg += lehmercode(a,f); erg += m_i_i(0L,b); for (i=0,j=S_P_LI(a);i=0 ; i--) { if (EMPTYP(S_M_IJ(e,i,j))) { M_I_I(k,S_M_IJ(e,i,j)) ; k++; } else if (S_M_IJI(e,i,j) == -1L) freeself(S_M_IJ(e,i,j)); else if (S_M_IJI(e,i,j) == 0L) { freeself(S_M_IJ(e,i,j)); for (m=j+1; m=0 ; m--) if (not EMPTYP(S_M_IJ(e,m,j))) if (S_M_IJI(e,m,j) == -1L) freeself(S_M_IJ(e,m,j)); break; } else return error("red_dia_perm:wrong content"); } } return(OK); } INT first_tab_perm(a,c) OP a,c; /* AK 010988 */ /* das erste tableau */ /* AK 151289 V1.1 */ /* AK 150891 V1.3 */ { OP b; INT erg = OK; CTO(PERMUTATION,"first_tab_perm(1)",a); b = callocobject(); erg += red_dia_perm(a,b); erg += fill_left_down_matrix(b); erg += m_matrix_tableaux(b,c); ENDR("first_tab_perm"); } #endif /* TABLEAUXTRUE */ INT fill_left_down_matrix(b) OP b; /* AK 060988 */ /* schiebt inhalt einer matrix nach links, dann nach unten, sofern dieser inhalt integer zahlen */ /* AK 051289 V1.1 */ /* AK 150891 V1.3 */ { INT i,j,k,l,m; for (i=S_M_HI(b)-1; i>=0L; i--) { k=0L; for (j=0L;j=0L; l--) if (EMPTYP(S_M_IJ(b,l,k))) break; /* l ist die zeile in der der eintrag hinkommt */ M_I_I(m,S_M_IJ(b,l,k)); k++; } } return(OK); } #ifdef POLYTRUE INT divideddiff_rz(rzt,poly,ergebnis) OP rzt, poly, ergebnis; /* 270887 zur berechnung des ergebnis des operators delta bei anwendung auf das polynom poly */ /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT i = 0 ; INT erg = OK; CTO(POLYNOM,"divideddiff_rz",poly); CE3(rzt,poly,ergebnis,divideddiff_rz); erg += copy_polynom(poly,ergebnis); if (EMPTYP(rzt)) goto endr_ende; while (i < S_V_LI(rzt)) { erg += divideddifference(S_V_I(rzt,i),ergebnis,ergebnis); i++; }; ENDR("divideddiff_rz"); } INT max_divideddiff(n,poly,e) OP n,poly,e; /* applies the maximal permutation */ /* AK 180291 V1.2 */ /* AK 150891 V1.3 */ { OP p = callocobject(); INT erg=OK; if ((erg=last_permutation(n,p)) != OK) goto md1; if ((erg=divideddiff_permutation(p,poly,e)) != OK) goto md1; md1: freeall(p); return erg; } INT divideddiff_permutation(perm,poly,c) OP perm,poly,c; /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150591 V1.2 */ /* AK 150891 V1.3 */ { OP rzt; INT erg = OK; CTO(PERMUTATION,"divideddiff_permutation",perm); rzt = callocobject(); erg += rz_perm(perm,rzt); erg += divideddiff_rz(rzt,poly,c); erg += freeall(rzt); ENDR("divideddiff_permutation"); } INT divideddiff_lc(lc,poly,c) OP lc,poly,c; /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT erg = OK; /* AK 020392 */ OP rzt; CTTO(INTEGERVECTOR,VECTOR,"divideddiff_lc(1)",lc); CTO(POLYNOM,"divideddiff_lc(2)",poly); rzt = callocobject(); erg += rz_lehmercode(lc,rzt); erg += divideddiff_rz(rzt,poly,c); erg += freeall(rzt); ENDR("divideddiff_lc"); } INT divdiff(a,b,c) OP a,b,c; /* AK 180393 */ { INT erg = OK; COP("divdiff(1)",a); COP("divdiff(2)",b); COP("divdiff(3)",c); CE3(a,b,c,divdiff); switch(S_O_K(a)) { case INTEGER: switch(S_O_K(b)) { case POLYNOM: erg += divideddifference(a,b,c); break; #ifdef SCHUBERTTRUE case SCHUBERT: erg += divdiff_schubert(a,b,c); break; #endif default: erg += WTT("divdiff",a,b); break; }; break; case PERMUTATION: if (S_P_K(a) == VECTOR) { switch(S_O_K(b)) { case POLYNOM: erg += divideddiff_permutation(a,b,c); break; #ifdef SCHUBERTTRUE case SCHUBERT: erg += divdiff_perm_schubert(a,b,c); break; #endif default: erg += WTT("divdiff",a,b); break; }; break; } if (S_P_K(a) == BAR) { switch(S_O_K(b)) { case POLYNOM: erg += divdiff_bar(a,b,c); break; }; break; } default: erg += WTT("divdiff",a,b); break; } ENDR("divdiff"); } INT divideddifference(i,poly,c) OP i,poly,c; /* AK 270887 zur berechnung des ergebnis des operators delta_i bei anwendung auf das polynom poly */ /* AK 110789 V1.0 */ /* AK 151289 V1.1 */ /* AK 150891 V1.3 */ { OP zeiger, zwischen; INT index,j,k, expo1, expo2 ,erg = OK; CTO(INTEGER,"divideddifference(1)",i); CTO(POLYNOM,"divideddifference(2)",poly); index = S_I_I(i) -1L; SYMCHECK(index < 0, "divideddifference:index < 1"); CE3(i,poly,c,divideddifference); init(POLYNOM,c); if (EMPTYP(poly)) goto rr; if (S_L_S(poly) == NULL) /* AK 040392 */ { erg += copy(poly,c); goto rr; } zwischen = callocobject(); zeiger = poly; while (zeiger != NULL) { if (S_L_S(zeiger) == NULL) { error("divideddifference:self == NULL"); erg += ERROR; goto rr; } if (not VECTORP(S_PO_S(zeiger))) { printobjectkind(S_PO_S(zeiger)); error("kind != VECTOR in divideddifference"); erg += ERROR; goto rr; }; if (S_I_I(i) == S_PO_SLI(zeiger)) /* operiert auf letzten exponenten */ { erg += inc(S_PO_S(zeiger)); M_I_I(0L,S_PO_SI(zeiger,S_I_I(i))); } else if (S_I_I(i) > S_PO_SLI(zeiger)) goto dividedend; expo1 = S_PO_SII(zeiger,index); expo2 = S_PO_SII(zeiger,index + 1L); if (expo1 > expo2) { for (j=expo1-1L,k=expo2 ;j>= expo2; j--,k++) { erg += b_skn_po(callocobject(),callocobject(),NULL,zwischen); erg += copy(S_PO_S(zeiger),S_PO_S(zwischen)); erg += copy(S_PO_K(zeiger),S_PO_K(zwischen)); M_I_I(j,S_PO_SI(zwischen,index)); M_I_I(k,S_PO_SI(zwischen,index+1L)); erg += add_apply(zwischen,c); erg += freeself(zwischen); }; } else if (expo1 < expo2) { for (j=expo2-1L,k=expo1 ;j>= expo1; j--,k++) { erg += b_skn_po(callocobject(),callocobject(),NULL,zwischen); COPY(S_PO_S(zeiger),S_PO_S(zwischen)); erg += addinvers(S_PO_K(zeiger),S_PO_K(zwischen)); M_I_I(j,S_PO_SI(zwischen,index)); M_I_I(k,S_PO_SI(zwischen,index+1)); erg += add_apply(zwischen,c); erg += freeself(zwischen); } }; dividedend: zeiger = S_PO_N(zeiger); }; FREEALL(zwischen); rr: ENDR("divideddifference"); } #endif /* POLYTRUE */ #endif /* PERMTRUE */ #ifdef KRANZTRUE OP s_kr_g(a) OP a; /* select_kranz_grobpermutation */ /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ /* AK 110804 V3.0 */ { INT erg = OK; CTO(KRANZ,"s_kr_g(1)",a); { return(s_v_i(a,0L)); } ENDO("s_kr_g"); } OP s_kr_v(a) OP a; /* select_kranz_vector */ /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ { return(s_v_i(a,1L)); } INT c_kr_g(a,b) OP a,b; /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ { return(c_v_i(a,0L,b)); } INT c_kr_v(a,b) OP a,b; /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ { return(c_v_i(a,1L,b)); } OP s_kr_i(a,i) OP a; INT i; /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ { return(s_v_i(s_kr_v(a),i)); } INT s_kr_gli(a) OP a; /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ { return(s_p_li(s_kr_g(a))); } OP s_kr_gi(a,i) OP a; INT i; /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ /* AK 200804 V3.0 */ { INT erg = OK; CTO(KRANZ,"s_kr_gi(1)",a); SYMCHECK(i<0,"s_kr_gi(2)<0"); { return s_p_i(s_kr_g(a),i); } ENDO("s_kr_gi"); } OP s_kr_gl(a) OP a; /* AK 170889 V1.1 */ /* AK 150891 V1.3 */ { return(s_p_l(s_kr_g(a))); } INT init_kranz(a) OP a; /* AK Fri Jan 27 12:29:38 MEZ 1989 */ /* AK 150891 V1.3 */ /* AK 110804 V3.0 */ { init(VECTOR,a); m_il_v(2L,a); C_O_K(a,KRANZ); return(OK); } INT b_perm_vector_kranz(p,v,a) OP p,v,a; /* dies initialisiert eine kranz product struktur */ /* ein vector aus 2 teilen wobei der erste eintrag ein eine permutation aus der s_n der zweite eintrag ein vector von n eintraegen */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT erg = OK; CTO(PERMUTATION,"b_perm_vector_kranz(1)",p); CTO(VECTOR,"b_perm_vector_kranz(2)",v); { erg += init(KRANZ,a); c_kr_g(a,p); c_kr_v(a,v); } ENDR("b_perm_vector_kranz"); } INT random_kranz(gn,vn,a) OP gn,vn,a; /* random element of kranz produkt */ /* AK 120804 V3.0 */ { INT erg = OK; CTO(INTEGER,"random_kranz(1)",gn); SYMCHECK(S_I_I(gn)<1,"random_kranz(1)<1"); CTO(INTEGER,"random_kranz(2)",vn); SYMCHECK(S_I_I(vn)<1,"random_kranz(2)<1"); CE3(gn,vn,a,random_kranz); { INT i; erg += init_kranz(a); erg += random_permutation(gn,S_KR_G(a)); erg += m_l_v(gn,S_KR_V(a)); for (i=0;i 0L) erg += first_partition(S_V_I(S_V_I(c,0L),i),a); } } ENDR("first_kranztypus"); } INT next_kranztypus(alt,c) OP alt,c; /* AK 310889 */ /* kranztypus ist ein vector mit zwei eintraegen. der erste eintrag eine komposition der zweite eintrag ist eine vector mit partitionen als komponenten. return TRUE falls ok FALSE falls letzter typus */ /* AK 181289 V1.1 */ /* AK 130691 V1.2 */ /* AK 150891 V1.3 */ { INT i,j,l ; OP a; OP b; if (alt != c) copy(alt,c); b = S_V_I(c,0L); /* die composition */ l = S_V_LI(b); /* anzahl teile der composition */ for (i=l-1;i>=0L;i--) { a = S_V_I(S_V_I(c,1L),i); /* partition */ if (not EMPTYP(a)) if (next(a,a)) goto nk310889; } if (i < 0L) if (next(b,b) == FALSE) return(FALSE); nk310889: for (j=i+1; j < l; j++) { a = S_V_I(S_V_I(c,1L),j); if (not EMPTYP(a)) freeself(a); if (S_V_II(b,j) > 0L) first_partition(S_V_I(b,j),a); } return(TRUE); } #endif /* KRANZTRUE */ INT makevectorof_kranztypus(w,parts,c) OP w,parts,c; /* AK 310889 */ /* AK 181289 V1.1 */ /* AK 120691 V1.2 */ /* AK 150891 V1.3 */ { INT erg = ERROR; #ifdef KRANZTRUE erg =OK; CTO(INTEGER,"makevectorof_kranztypus(1)",w); CTO(INTEGER,"makevectorof_kranztypus(2)",parts); CE3(w,parts,c,makevectorof_kranztypus); { OP a = callocobject(); INT i=0L; erg += m_il_v(1L,c); erg += first_kranztypus(w,parts,a); /* ergebnis ist vector */ COPY(a,S_V_I(c,0L)); while (next_kranztypus(a,a)) { INC(c); i++; COPY(a,S_V_I(c,i)); } FREEALL(a); } #endif ENDR("makevectorof_kranztypus"); } INT kranztypus_to_matrix(a,b) OP a,b; /* AK 010989 */ /* kranztypus als matrix */ /* b wird eine matrix */ /* kranztypus ist ein vector mit zwei eintraegen. der erste eintrag eine komposition der zweite eintrag ist eine vector mit partitionen als komponeten. */ /* AK 081289 V1.1 */ /* AK 120691 V1.2 */ /* AK 150891 V1.3 */ /* AK 050902 V2.0 */ { INT erg = OK; #ifdef KRANZTRUE CTO(VECTOR,"kranztypus_to_matrix(1)",a); SYMCHECK(S_V_LI(a)!=2,"kranztypus_to_matrix(1):wrong length of vector"); CTO(COMPOSITION,"kranztypus_to_matrix(1.0)",S_V_I(a,0)); CTO(VECTOR,"kranztypus_to_matrix(1.1)",S_V_I(a,1)); CE2(a,b,kranztypus_to_matrix); { INT z,s,i,j; OP summe = callocobject(); OP h1,h2; /* z = Anzahl der zeilen */ /* s = Anzahl der spalten */ s = S_V_LI(S_V_I(a,0L)); sum(S_V_I(a,0L),summe);/* composition ist vector */ z = S_I_I(summe); FREEALL(summe); m_ilih_nm(s,z,b); C_O_K(b,KRANZTYPUS); for (i=0L;i 0L) { h2 = S_V_I(S_V_I(a,1L),i) ; /* i-te partition */ for (j=0L;j 0L) { h = S_V_I(S_V_I(b,1L),j); /* h ist die partition */ b_ks_pa(EXPONENT,callocobject(),h); m_il_integervector(S_M_HI(a),S_PA_S(h)); for (i=0L;i 0L) { if (not EMPTYP(h1)) if (S_O_K(h1) != INTEGER) freeself(h1); charvalue(S_V_I(a2,i),S_V_I(b2,i),erg,NULL); mult(erg,S_PO_K(c),h1); ordcen(S_V_I(b2,i),erg); div(h1,erg,S_PO_K(c)); } } freeall(erg); freeall(h1); if (not nullp(S_PO_K(c))) kranztypus_to_matrix(b,S_PO_S(c)); else freeself(c); /* polynom == list */ return(OK); } INT kranztypus_charakteristik(a,b) OP a,b; /* AK 010989 */ /* aus einem kranztypus wird F_lambda berechnet */ /* AK 181289 V1.1 */ /* AK 120691 V1.2 */ /* AK 150891 V1.3 */ { OP c,d; INT i; if (S_O_K(a) == KRANZTYPUS) { c = callocobject(); matrix_to_kranztypus(a,c); kranztypus_charakteristik(c,b); freeall(c); return(OK); } /* a ist ein vektor */ c = callocobject(); copy(a,c); if (not EMPTYP(b)) freeself(b); for (i=0L; i 0L) first_partition(S_V_I(S_V_I(a,0L),i), S_V_I(S_V_I(c,1L),i)); do { d = callocobject(); kranztypus_kranztypus_monom(a,c,d); if (not EMPTYP(d)) insert(d,b,NULL,NULL); else freeall(d); } while ( next_kranztypus(c,c) && eq( S_V_I(c,0L),S_V_I(a,0L)) ); freeall(c); return(OK); } INT charakteristik_to_ypolynom(a,b,grad,ct) OP a,b,grad,ct; /* AK 040989 */ /* A ist charakteristik, b wird ypolynom */ /* grad ist der grad der symmetrischen gruppe G in GwrS_n*/ /* ct ist chartafel von S_n */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { OP z = a; OP c; OP partv = callocobject(); makevectorofpart(grad,partv); if (not EMPTYP(b)) freeself(b); while (z != NULL) { c = callocobject(); matrix_monom_ypolynom(z,c,grad,partv,ct); insert(c,b,NULL,NULL); z = S_PO_N(z); } freeall(partv); return(OK); } INT matrix_monom_ypolynom(a,b,grad,partv,ct) OP a,b,grad,partv,ct; /* AK 040989 */ /* eingabe a ist ein monom mit matrix kranztypus ausgabe b ist ein gleiches polynom in den y variablen */ /* grad ist der grad der symmetrischen gruppe G in GwrS_n*/ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT i,j; OP m=S_PO_S(a); /* matrix */ OP c = callocobject(); INT erg = OK; FREESELF(b); M_I_I(1L,b); for (i= 0L;i 0L) { s_x_nu_to_ypolynom(m,grad,i,j,c,partv,ct); MULT_APPLY(c,b); } } MULT_APPLY(S_PO_K(a),b); freeall(c); ENDR("matrix_monom_ypolynom"); } INT s_x_nu_to_ypolynom(m,grad,i,j,c,partv,ct) INT i,j; OP m,grad,c,partv,ct; /* AK 040989 */ /* ein einzelne transformation */ /* m ist die matrix */ /* c wird polynom */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT i1,j1,i2; OP h1,h2,h3,d,f; INT erg = OK; h1 = callocobject(); h2 = callocobject(); h3 = callocobject(); d = callocobject(); f = callocobject(); init(POLYNOM,c); erg += fakul(grad,f); for (i2=0L;i2= S_V_LI(c)) { fprintf(stderr,"m="); fprintln(stderr,m); fprintf(stderr,"a="); fprintln(stderr,a); fprintf(stderr,"c="); fprintln(stderr,c); error("co040989: not found"); } } /* i2 ist jetzt der index */ copy(S_PO_K(z),S_M_IJ(b,i,i2)); i2++; z = S_PO_N(z); } z = S_M_IJ(b,i,i2); while(i2 < S_M_LI(b)) { if(not EMPTYP(z)) if (S_O_K(z) != INTEGER) freeself(z); M_I_I(0L,z); i2++;z++; } return(OK); } INT typusorder(a,ggrad,ngrad,b,vec) OP b,a,ggrad,ngrad,vec; /* ordnung der konjugiertenklasse mit typus==MATRIX ggrad ist grad der symmetrischen gruppe G */ /* ngrad ist grad der symmetrischen gruppe S_n */ /* vec ist vector der partition von G */ /* result is b */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT i,j; OP f = callocobject(); OP h = callocobject(); OP p; OP k = callocobject(); OP h1 = callocobject(); OP h2 = callocobject(); OP gorder = callocobject(); INT erg = OK; /* AK 090692 */ erg += fakul(ggrad,gorder); erg += hoch(gorder,ngrad,h2); erg += fakul(ngrad,h); MULT(h2,h,f); p = S_V_I(vec,0L); if (not EMPTYP(b)) erg += freeself(b); M_I_I(1L,b); for (j=0L;j 44555 33344 --> 00444 */ /* AK 260789 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { #ifdef SHUFFLETRUE INT k,i; INT grenze = S_V_LI(a)-S_I_I(mx); copy(a,b); for (i=grenze-1L;i>=0L;i--) if (S_V_II(b,i) == 0L) { M_I_I(1L,S_V_I(b,i)); return(OK); }; for (i=1L;i S_V_II(b,i-1L)) break; k=i-1; if (eq(S_V_I(b,k),mx)) return(LASTSHUFFLE); inc(S_V_I(b,k)); for (i=k-1;i>=0L;i--) M_I_I(0L,S_V_I(b,i)); return OK; #else /* SHUFFLETRUE */ return error("next_shufflevector:SHUFFLE not defined"); #endif /* SHUFFLETRUE */ } INT next_shufflepermutation(mx,perm,erg) OP mx,perm,erg; /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { #ifdef SHUFFLETRUE INT e; OP a=callocobject(); OP b=callocobject(); lehmercode(perm,a); e = next_shufflevector(mx,a,b); if (e != LASTSHUFFLE) lehmercode(b,erg); freeall(a); freeall(b); return(e); #else /* SHUFFLETRUE */ return error("next_shufflepermutation:SHUFFLE not defined"); #endif /* SHUFFLETRUE */ } #ifdef PERMTRUE INT test_perm() /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { OP a = callocobject(); OP b = callocobject(); OP c = callocobject(); printf("test_perm:scan(a)"); scan(PERMUTATION,a); println(a); printf("test_perm:copy(a,b)"); copy(a,b); println(b); printf("test_perm:mult(a,b,b)"); mult(a,b,b); println(b); printf("test_perm:invers(b,a)"); invers(b,a); println(a); printf("test_perm:even(b)"); if (even(b)) printeingabe("is even"); else printeingabe("is not even"); printf("test_perm:inc(a)"); inc(a); println(a); printf("test_perm:UD_permutation(a,b)"); UD_permutation(a,b); println(b); printf("test_perm:random_permutation(134L,b)"); m_i_i(134L,a); random_permutation(a,b); println(b); printf("test_perm:makevectoroftranspositions(5L,c)"); m_i_i(5L,a); makevectoroftranspositions(a,c); println(c); freeall(a); freeall(b); freeall(c); return(OK); } INT tex_lc(perm) OP perm; /* AK 101187 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 150891 V1.3 */ { INT i; if (S_V_LI(perm)<10L) { fprintf(texout,"\\ $"); texposition += 2L; for (i=0L;i60L) { fprintf(texout,"\n"); texposition = 0L; } return(OK); } INT tex_permutation(perm) OP perm; /* AK 101187 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 150891 V1.3 */ { INT i; if (S_P_LI(perm)<10L) { fprintf(texout,"\\ $"); texposition += 3L; for (i=0L;i 60L) { fprintf(texout,"\n"); texposition = 0L; } return(OK); } INT tex_rz(obj) OP obj; /* AK 101187 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 150891 V1.3 */ { INT i; INT erg = OK; CTO(VECTOR,"tex_rz(1)",obj); fprintf(texout,"\\ $"); for (i=0L;inj) { e=ni; ni=nj; nj=e; }; /* ni < nj ist ergebnis der permutation */ /* nun nur noch den index bestimmen */ /* der ist e */ e = (nj-ni-1L)+((S_P_LI(a)+S_P_LI(a)-ni)*(ni-1L))/2L ; /* e ist der index des neuen paars speicher */ M_I_I(e+1L,S_P_I(b,z)); z++; }; ENDR("m_perm_paareperm"); } INT eq_permutation(a,b) OP a,b; /* AK 120104 */ { INT erg = OK; CTO(PERMUTATION,"eq_permutation(1)",a); CTO(PERMUTATION,"eq_permutation(2)",b); if (S_P_K(a) == S_P_K(b)) { switch (S_P_K(a)) { case ZYKEL: case VECTOR: return eq_integervector_integervector(S_P_S(a),S_P_S(b)); default: return EQ(S_P_S(a),S_P_S(b)); } } else { fprintf(stderr,"kind a = %ld\nkind b = %ld\n", S_P_K(a), S_P_K(b)); debugprint(b); return error("eq_permutation:different kinds of permutations"); } ENDR("eq_permutation"); } INT comp_permutation(a,b) OP a, b; /* AK 130587 als gr*/ /* AK 060488 als comp*/ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070891 V1.3 comp_vector */ /* AK 050898 V2.0 */ { INT erg = OK; CTO(PERMUTATION,"comp_permutation(1)",a); CTO(PERMUTATION,"comp_permutation(2)",b); if (S_P_K(a) == S_P_K(b)) return comp(S_P_S(a),S_P_S(b)); else { fprintf(stderr,"kind a = %ld\nkind b = %ld\n", S_P_K(a), S_P_K(b)); debugprint(b); return error("comp_permutation:different kinds of permutations"); } ENDR("comp_permutation"); } INT first_lehmercode(l,res) OP l, res; /* l beleibt erhalten */ /* AK 040487 */ /* firstlemercode = 0000...0000 */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT i; INT erg = OK; CTO(INTEGER,"first_lehmercode(1)",l); erg += m_il_v(S_I_I(l),res); for (i=0L;i=0;r--) if (S_P_II(next,r) < S_P_II(next,r+1L)) break; if (r == -1L) { erg = LASTPERMUTATION; goto fe; } for (s=0L; s S_P_II(next,r+s+1L) ) break; swap(S_P_I(next,r),S_P_I(next,r+s)); for (i=r+1,j=S_P_LI(next)-1;i=0;j--) { M_I_I(1,S_V_I(next_perm_v,S_P_II(a,j))); if (S_P_II(a,j) > i) i = S_P_II(a,j); else { /* schauen was hinkommt */ for (k=S_P_II(a,j)+1;k=0L;i--,j++) { if (S_V_II(n,i) < j) return(inc(S_V_I(n,i))); else C_I_I(S_V_I(n,i),0L); }; freeself(n); return(LASTLEHMERCODE); } #ifdef PARTTRUE INT vexillaryp_permutation(perm,part) OP perm,part; /* AK 290986 */ /* AK 031187 vergleiche hierzu kapitel 5.0 der diplomarbeit dort wird das kriterium fuer den test auf vexillary beschrieben */ /* in part der sortierte lehmercode von perm zurueck gegeben AK 110488 */ /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT erg; OP zwischen = callocobject(); OP zwei = callocobject(); OP a = callocobject(),b= callocobject(),c = callocobject(); OP d; if (part == NULL) d = callocobject(); else d = part; invers_permutation(perm,a); lehmercode_permutation(a,b); m_v_pa(b,zwischen);freeall(b); lehmercode_permutation(perm,c); m_v_pa(c,d);freeall(c); conjugate(d,zwei); erg = eq(zwischen,zwei); if (d != part) freeall(d); freeall(zwischen); freeall(zwei); freeall(a); return(erg); } #endif /* PARTTRUE */ INT lehmercode_permutation(perm,vec) OP perm, vec; /* AK 221087 diese procedure berechnet zur permutation perm = [p1,....,pn] den zugehoerigen lehmercode vec [v1,...,vn] */ /* AK 100789 V1.0 */ /* AK 111289 V1.1 */ /* AK 150891 V1.3 */ { INT i,j,k; INT erg = OK; CTO(PERMUTATION,"lehmercode_permutation(1)",perm); if (S_P_K(perm) == ZYKEL) /* AK 291091 */ erg += t_ZYKEL_VECTOR(perm,perm); else if (S_P_K(perm) == BAR) { erg += lehmercode_bar(perm,vec); goto aa; } erg += m_il_v(S_P_LI(perm),vec); /* erzeugt ein Vectorobject */ for(i=0L;i=(INT)0; j--,i++) { if (not INTEGERP(S_V_I(vec,j))) /* AK 131093 */ { erg = ERROR; goto lc_ende; } if (S_V_II(vec,j) < (INT)0) { erg = ERROR; goto lc_ende; } if (S_V_II(vec,j) > i) /* entry to big */ { if (S_V_II(vec,j)-i > k) k = S_V_II(vec,j)-i; } } if (k > (INT)0) /* to increase vector */ { self = callocobject(); liste = callocobject(); erg += m_il_nv(k,self); erg += append(vec,self,liste); erg += lehmercode_vector(liste,b); erg += freeall(self); erg += freeall(liste); goto lc_ende; } self = CALLOCOBJECT(); liste = CALLOCOBJECT(); erg += m_il_integervector(S_V_LI(vec),self); erg += m_il_integervector(S_V_LI(vec),liste); /* initialisierung zweier vektoren fuer eine Liste und fuer die zu berechnende Permutation */ for(i=(INT)0;ik) M_I_I(S_V_II(vec,j)-1L,S_V_I(vec,j)); }; return(OK); } INT invers_permutation(perm,b) OP perm,b; /* AK 100789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT i,erg = OK; OP self; CTO(PERMUTATION,"invers_permutation(1)",perm); CTO(EMPTY,"invers_permutation(2)",b); if (S_P_K(perm) == BAR) { erg += invers_bar(perm,b); goto ee; } if (S_P_K(perm) != VECTOR) /* AK 010692 */ return error("invers_perm: wrong perm type"); /* now the input is OK */ self = callocobject(); erg += m_il_integervector(S_P_LI(perm),self); for ( i=(INT)0;iS_P_LI(a) ) return FALSE; } h = callocobject(); m_il_v(S_P_LI(a),h); for (i=(INT)0;i S_P_LI(b)) /* AK 270493 */ { d = callocobject(); erg += m_il_p(S_P_LI(a),d); for (i=(INT)0;i S_{n+1} */ /* am anfang eine 1 dazu */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */ { INT i; INT erg = OK; CTO(PERMUTATION,"inc_permutation(1)",perm); if (S_P_K(perm) != VECTOR) return error("inc_permutation:wrong kind"); erg += inc(S_P_S(perm)); for(i=S_P_LI(perm)-1L;i>(INT)0;i--) M_I_I(S_P_II(perm,i-1L)+1L,S_P_I(perm,i)); M_I_I(1L,S_P_I(perm,(INT)0)); ENDR("inc_permutation"); } INT last_permutation(l,ree) OP l, ree; /* AK 101187 */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */ { OP zwerg; INT erg=OK; CTO(INTEGER,"last_permutation(1)",l); zwerg = callocobject(); erg += last_lehmercode(l,zwerg); erg += lehmercode(zwerg,ree); FREEALL(zwerg); ENDR("last_permutation"); } INT rz_perm(perm,c) OP perm,c; /* AK 050198 V2.0 */ /* computes a reduced decomposition of a permutation */ /* AK 270887 */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT erg=OK; /* 260292 */ OP lc; CTO(PERMUTATION,"rz_perm(1)",perm); lc = callocobject(); erg += lehmercode_permutation(perm,lc); erg += rz_lehmercode(lc,c); erg += freeall(lc); ENDR("rz_perm"); } INT rz_lehmercode(lc,b) OP lc,b; /* AK 241087 bildet die reduzierte zerlegung des lehmercodes lc bsp lc = 321200 dann ist ergebnis 32132354 vgl verfahren 1 in diplomarbeit */ /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { INT i = S_V_LI(lc), /* laufvariable durch l.c. */ k , /* laufvariable durch ergebnis */ j,erg = OK; OP zw; CTO(VECTOR,"rz_lehmercode(1)",lc); COP("rz_lehmercode(2)",b); zw = callocobject(); erg += sum(lc,zw); if (NULLP(zw)) { erg += m_il_integervector((INT)0,b); erg += freeall(zw); goto ende; } k = S_I_I(zw); erg += b_l_v(zw,b); /* die laenge der reduzierten zerlegung ist die summe des lehmercodes */ while (i-- > (INT)0) if (S_V_II(lc,i) > (INT)0) for (j=(INT)0;jp_self); } OBJECTKIND s_p_k(a) OP a; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_permutation->p_kind); } OP s_p_i(a,i) OP a; INT i; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { return(s_v_i(s_p_s(a),i)); } INT s_p_ii(a,i) OP a; INT i; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070891 V1.3 */ { if (a == NULL) return error("s_p_ii: a == NULL"); if (not permutationp(a)) return error("s_p_ii: a not permutation"); if (i >= s_p_li(a)) return error("s_p_ii: i to big"); return(s_v_ii(s_p_s(a),i)); } OP s_p_l(a) OP a; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070891 V1.3 */ { return(s_v_l(s_p_s(a))); } INT s_p_li(a) OP a; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { if (a == NULL) return error("s_p_li: a == NULL"); if (not permutationp(a)) return error("s_p_li: a not permutation"); return(s_v_li(s_p_s(a))); } INT c_p_k(a,b) OP a; OBJECTKIND b; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { OBJECTSELF c; if (a == NULL) /* AK 040292 */ return error("c_p_k:NULL object"); if (s_o_k(a) != PERMUTATION) /* AK 040292 */ return error("c_p_k:no PERMUTATION"); if ( /* AK 040292 */ (b != VECTOR)&& (b != ZYKEL) ) return error("c_p_k:wrong kind"); c = s_o_s(a); c.ob_permutation->p_kind = b; return(OK); } INT c_p_s(a,b) OP a,b; /* AK 060789 V1.0 */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_permutation->p_self = b; return(OK); } #ifdef PERMTRUE INT elementarp_permutation(a,b) OP a,b; /* AK 210889 */ /* AK 230889 */ /* true falls sich die beiden perm durch eine elementartransposition multipliziert von rechts unterscheiden */ /* AK 250889 V1.1 */ /* AK 150891 V1.3 */ { INT i; for (i=(INT)0;i 0) /* noch nicht im zykel */ { zykellength=1L; alt=i; while (S_P_II(a,alt) != (i+1)) { n = S_P_II(a,alt)-1; ADDINVERS_APPLY_INTEGER(S_P_I(a,alt)); alt = n; zykellength++; }; ADDINVERS_APPLY_INTEGER(S_P_I(a,alt)); M_I_I(zykellength,S_V_I(self,l)); l++; if (l >= S_V_LI(self)) inc_vector_co(self,10); }; for (i=(INT)0;i 1, dann zerfaellt dieser zykel naemlich */ for (i=(INT)0; i (INT)0) { k = ggt_i(S_I_I(b),i+1L); if (k>1L) { M_I_I( ( (S_PA_II(c,((i+1L)/k -1L))) + (k * S_PA_II(c,i) ) ), S_PA_I(c, (i+1L)/k -1L) ); M_I_I((INT)0,S_PA_I(c,i)); }; }; return(OK); } #endif /* PERMTRUE */ INT t_VECTOR_ZYKEL(a,b) OP a,b; /* AK 291091 */ { return t_vperm_zperm(a,b); } INT t_vperm_zperm(a,b) OP a,b; /* aus einer vector-permutation eine zykel-permutation */ /* folgende darstellung des zykel zuerst der zykel mit groessten kleinsten element usw als letztes der zykel mit der 1 */ /* bsp (1256)(387)(49) als [4,9,3,8,7,1,2,5,6] */ /* AK 050390 V1.1 */ /* AK 080891 V1.3 */ { INT i,erg =OK; INT schreibindex; INT leseindex,altleseindex; INT startindex=(INT)0,startwert; INT ergindex = S_P_LI(a)-1; /* der freie index am rechten ende */ OP c; CE2(a,b,t_vperm_zperm); c= callocobject(); erg += copy(a,c); erg += copy(a,b); C_P_K(b,ZYKEL); m_vperm_zperm_again: for (i=startindex;i (INT)0); goto m_vperm_zperm_again; }; goto m_vperm_zperm_next; ENDR("t_vperm_zperm"); } INT t_ZYKEL_VECTOR(a,b) OP a,b; /* AK 291091 */ { return t_zperm_vperm(a,b); } INT t_zperm_vperm(a,b) OP a,b; /* AK 050390 V1.1 */ /* AK 080891 V1.3 */ { INT index = (INT)0; INT startwert, schreibindex; INT erg = OK; /* AK 291091 */ CE2(a,b,t_zperm_vperm); copy(a,b); C_P_K(b,VECTOR); m_zperm_vperm_again: startwert = S_P_II(a,index); /* zykelanfang */ index++; schreibindex = startwert-1; if (index < S_P_LI(a)) /* AK 210597 */ while (S_P_II(a,index) > startwert) { M_I_I(S_P_II(a,index), S_P_I(b,schreibindex)); schreibindex = S_P_II(a,index) - 1; index++; if (index == S_P_LI(a)) break; }; /* wir sind am zykelende */ /* index ist anfang naechster zykel */ M_I_I(startwert, S_P_I(b,schreibindex)); if (index != S_P_LI(a)) goto m_zperm_vperm_again; /* ende der permutation */ ENDR("t_zperm_vperm"); } #ifdef MATRIXTRUE #ifdef PERMTRUE INT permutation_matrix(a,b) OP a,b; { return perm_matrix(a,b); } INT perm_matrix(a,b) OP a,b; /* AK 181289 permutationsmatrix (0,1) zu einer permutation */ /* AK 181289 V1.1 */ /* AK 150891 V1.3 */ /* FM 210296 */ /* AK 220498 V2.0 */ /* AK 261103 for barred permutations */ /* input: PERMUTATION output: 01 matrix b_ij = 1 if a(j) = i */ /* AK 060704 V3.0 */ { INT erg = OK; CPTT(BAR,VECTOR,"perm_matrix(1)",a); CE2(a,b,perm_matrix); { INT i,j; erg += m_ilih_m(S_P_LI(a),S_P_LI(a),b); for (i=0; i=0;i--) if (S_P_II(a,i) != (i+1L)) return(FALSE); return(TRUE); } else if (S_P_K(a) == ZYKEL) { for (j=1,i=S_P_LI(a) -1;i>=0;i--,j++) if (S_P_II(a,i) != j ) return(FALSE); return(TRUE); } else if (S_P_K(a) == BAR) { for (j=S_P_LI(a),i=S_P_LI(a) -1;i>=0;i--,j--) if (S_P_II(a,i) != j ) return(FALSE); return(TRUE); } else { WTO("einsp_permutation(1.typ)",a); } } ENDR("einsp_permutation"); } INT comp_lex_perm(a,b) OP a,b; /* AK 070390 V1.1 */ /* AK 150891 V1.3 */ /* AK 020902 V2.0 */ { return COMP(S_P_S(a),S_P_S(b)); } #ifdef POLYTRUE INT operate_gral_polynom(a,b,c) OP a,b,c; /* a is GRAL, b is POLYNOM, c becomes POLYNOM */ /* AK 200891 V1.3 */ { OP z,d; INT erg = OK; CTO(GRAL,"operate_gral_polynom(1)",a); CTO(POLYNOM,"operate_gral_polynom(2)",b); if (S_L_S(b) == NULL) /* AK 141092 */ return copy(b,c); erg += init(POLYNOM,c); z = a; d = callocobject(); while (z != NULL) { erg += operate_perm_polynom(S_PO_S(z),b,d); erg += mult_apply(S_PO_K(z),d); erg += add_apply(d,c); z = S_PO_N(z); } erg += freeall(d); ENDR("operate_gral_polynom"); } INT operate_perm_polynom(a,b,c) OP a,b,c; /* a is PERMUTATION, b is POLYNOM, c becomes POLYNOM */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(PERMUTATION,"operate_perm_polynom(1)",a); SYMCHECK((S_P_K(a) != VECTOR)&&(S_P_K(a) != BAR), "operate_perm_polynom(1) only for VECTOR or BAR permutations"); CTO(POLYNOM,"operate_perm_polynom(2)",b); CE3(a,b,c,operate_perm_polynom); { OP z,d,aa; INT j = 1; if (S_L_S(b) == NULL) /* AK 141092 */ { erg += copy(b,c); goto endr_ende; } erg += init(POLYNOM,c); if (S_P_K(a) == VECTOR) aa = a; else { /* Barred permutation */ INT i; aa = CALLOCOBJECT(); COPY (a,aa);C_P_K(aa,VECTOR); for (i=0;i S_MO_SLI(z)) /* AK 230192 */ { INC(S_MO_S(z)); ;M_I_I(0,S_MO_SI(z,S_MO_SLI(z)-1L)); } erg += operate_perm_vector(aa,S_MO_S(z),S_MO_S(d)); insert(d,c,add_koeff,NULL); }); if (a != aa) FREEALL(aa); } CTO(POLYNOM,"operate_perm_polynom(3-e)",c); ENDR("operate_perm_polynom"); } #endif /* POLYTRUE */ INT operate_perm_zeilenmatrix(perm,b,c) OP perm,b,c; { OP v; INT i,j; INT erg = OK; CTO(PERMUTATION,"operate_perm_zeilenmatrix(1)",perm); CTO(MATRIX,"operate_perm_zeilenmatrix(2)",b); v = callocobject(); erg += m_l_v(S_M_H(b), v); for (i=0;i S_V_LI(b),"operate_perm_vector:perm too big"); CE3( perm,b,c, operate_perm_vector); { INT i; if (S_P_LI(perm) < S_V_LI(b)) /* AK 230192 */ { OP d = callocobject(); erg += m_il_p(S_V_LI(b),d); for (i=0;i S_P_LI(as)) {c=bs;bs=as;as=c;erg= -1L;} /* as ist laenger als bs */ for (i=(INT)0; i S_P_II(bs,i)) return erg*1L; if (S_P_II(as,i) < S_P_II(bs,i)) return erg*-1L; } else { if (S_P_II(as,i) < i+1) return erg*-1L; if (S_P_II(as,i) > i+1) return erg*1L; } } return (INT)0; } INT gengroup(vec) OP vec; /* NiS 220191 V1.3 */ /* input: VECTOR of group elements output: VECTOR of all elements in the generated group */ { INT found=0,i,j,k,newfound=1,veclen; INT erg = OK; OP a,c,h,z,z1; CTO(VECTOR,"gengroup(1)",vec); CALLOCOBJECT3(a,c,h);init(HASHTABLE,h); for (i=0;i (INT)0) { erg += freeall(d); erg += error("first_perm_n_invers: number of invers too big"); goto endr_ende; } erg += lehmercode_vector(d,c); erg += freeall(d); ENDR("first_perm_n_invers"); } INT next_perm_invers(a,b) OP a,b; /* next perm with a given number of inversions */ /* a and b may be equal */ { INT erg = OK; CPT(VECTOR,"next_perm_invers(1)",a); { OP c = callocobject(); INT i,j,s,k; erg += lehmercode(a,c); s =(INT)0; for (j=(INT)0,i= S_V_LI(c)-1L; i>= (INT)0; i--,j++) { s += S_V_II(c,i); if ((S_V_II(c,i) < j)) break; } if (i < (INT)0) { freeall(c); return LAST_PERMUTATION; } for (j=i-1L;j>=(INT)0;j--) if (S_V_II(c,j) > (INT)0) break; if (j < (INT)0) { freeall(c); return LAST_PERMUTATION; } /* an j wird um eins erniedrigt */ /* rest wird aufgefuellt */ m_i_i(S_V_II(c,j) -1L, S_V_I(c,j)); s++; for (i=j+1L,k=S_V_LI(c)-1L-i; i= k) { m_i_i(k,S_V_I(c,i)); s -= k; } else { m_i_i(s,S_V_I(c,i)); s = (INT)0; } erg += lehmercode_vector(c,b); FREEALL(c); return erg; } ENDR("next_perm_invers"); } #ifdef PERMTRUE INT make_nzykel(n,r) OP n,r; /* AK 051198 V2.0 */ /* n and r may be equal */ { INT i,erg=OK; CTO(INTEGER,"make_nzykel",n); erg += m_il_p(S_I_I(n),r); for (i=(INT)0;i=S_I_I(n),"make_n_kelmtrans(2)>=n"); { INT i; erg += m_il_p(S_I_I(n),r); for (i=0;i S_P_II(a,i)) { erg += copy(a,c); erg += swap(S_P_I(c,i-1),S_P_I(c,i)); erg += co_120194(c,d,k-1,l); for (j=(INT)0;j S_P_II(a,i)) { erg += copy(a,c); erg += swap(S_P_I(c,i-1),S_P_I(c,i)); erg += co_120194_1(c,d,k-1,l); erg += add_apply(d,b); if (k==1) break; } } erg += freeall(c); erg += freeall(d); ENDR("internal routine: co_120194_1"); } INT cast_apply_perm(a) OP a; /* AK 280294 */ { INT erg = OK; EOP("cast_apply_perm(1)",a); switch(S_O_K(a)) { case VECTOR: erg += m_ks_p(VECTOR,a,a); break; default: printobjectkind(a); erg += WTO("cast_apply_perm",a); break; } ENDR("cast_apply_perm"); } INT sscan_permutation(t,a) OP a; char *t; /* AK 050194 to read permutation from string format [1,2,3,..] */ { INT erg = OK; COP("sscan_permutation(1)",t); CTO(EMPTY,"sscan_permutation(2)",a); erg += b_ks_p(VECTOR,callocobject(),a); erg += sscan(t,INTEGERVECTOR,S_P_S(a)); ENDR("sscan_permutation"); } INT makevectorofperm(a,b) OP a,b; /* input INTEGER object a output VECTOR object of length a! with permutations in order of next */ /* AK 220702 */ { INT i; INT erg = OK; OP c; CTO(INTEGER,"makevectorofperm(1)",a); CE2(a,b,makevectorofperm); c = CALLOCOBJECT(); erg += fakul(a,c); erg += m_l_v(c,b); erg += first_permutation(a,c); i=0; do { erg += copy_permutation(c,S_V_I(b,i)); i++; } while (next_apply(c)); FREEALL(c); ENDR("makevectorofperm"); } INT bruhat_comp_perm(a,b) OP a,b; /* compares according to the strong bruhat order*/ /* 1 if a>b 0 if a=b -1 if a=c in the Bruhat order ADD condition when c not long enough */ INT bru_comp(a,c) OP a,c; { INT i,j,k,x,y1,y2; k=S_P_LI(a); y1=S_P_II(a,(INT)0); y2=S_P_II(a,k-1); if( S_P_II(c,(INT)0) > y1 ) return (FALSE); if( k < S_P_LI(c) ) { for (j=k;ji ) x++; if ( S_P_II(c,j) >i ) x--; if (x<0) return (FALSE); } } return (TRUE); } INT t_VECTOR_BITREC(a,bitperm) OP a,bitperm; /* AK 200195 */ { OP c,d,b; INT i,erg=OK; CTO(PERMUTATION,"t_VECTOR_BITREC(1)",a); c = callocobject(); d = callocobject(); b = callocobject(); m_i_i(S_P_LI(a)+1,b); m_i_i(3,c); binom(b,c,d); freeall(c); m_il_nbv(S_I_I(d),b); fastrectr(a,d); for (i=0L;iS_P_II(a,i+1)) { z= S_P_II(a,i); x=S_P_II(a,i+1); for (k=z;k>=x;k--) { if ( S_P_II(b,k-1) >= i+2 && S_P_II(b,k) <=i+1) { y=0; for(i1=0;i1<=i;i1++) { if( S_P_II(a,i1) 0;j--) { if (S_V_II(S_V_I(b,j),S_I_I(a)-i) > 0) { erg += inc(b); erg += copy(S_V_I(b,j),S_V_I(b,S_V_LI(b)-1)); C_O_K(S_V_I(b,S_V_LI(b)-1),INTEGERVECTOR); erg += m_i_i(S_V_II(S_V_I(b,j),S_I_I(a)-i) ,S_V_I(S_V_I(b,S_V_LI(b)-1),S_I_I(a)-1-i)); } } for (j=1L;j<=i;j++) { erg += inc(b); erg += m_l_nv(a,S_V_I(b,S_V_LI(b)-1)); C_O_K(S_V_I(b,S_V_LI(b)-1),INTEGERVECTOR); erg += m_i_i(j,S_V_I(S_V_I(b,S_V_LI(b)-1),S_I_I(a)-i-1)); } } } ENDR("makevectorofrect"); } static INT co_co(n,bigr,vec) OP bigr,vec,n; /* input bigr and vector which is to be manipulated */ /* n the degree of s_n */ /* insert ones in one block */ { INT r2,r1,r0,og; INT x,k,i,j,length_of_cell; r2 = S_V_II(bigr,2); r1 = S_V_II(bigr,1); r0 = S_V_II(bigr,0); length_of_cell = S_I_I(n)-r1-r0; k=S_I_I(n); x=r0 + r1; og = x*(x-1)*(3*k-2*x+1)/6; /* start of block */ for (i=0;i=1;i--) { co_co(n,c,vec); dec(S_V_I(c,1)); } copy(bigr,c); for (i=S_V_II(c,2);i>1;i--) { inc(S_V_I(c,0)); dec(S_V_I(c,2)); co_co(n,c,vec); } freeall(c); ENDR("internal routine:co_co_2"); } INT order_permutation(a,b) OP a,b; /* AK 210802 */ /* order of permutation */ /* result is in b b is minimal integer with a^b = id */ /* AK V3.1 031106 */ /* a and b may be equal */ { INT erg = OK; CTO(PERMUTATION,"order_permutation(1)",a); { OP part; INT i; part = CALLOCOBJECT(); zykeltyp(a,part); copy(S_PA_I(part,0),b); for (i=1;i=0;ii--) { if (S_P_II(vc,ii) != i) if (S_P_II(vc,ii) != j) { M_I_I(S_P_II(vc,ii),S_P_I(vc,jj)); jj--; } } M_I_I(-i,S_P_I(vc,1)); M_I_I(-j,S_P_I(vc,0)); append(rn,r,r); for (i=0;i rightmin)) { OP perm_in_result; INC(b); perm_in_result = S_V_I(b,S_V_LI(b)-1); copy_permutation(a,perm_in_result); M_I_I(wj,S_P_I(perm_in_result,i)); M_I_I(wi,S_P_I(perm_in_result,j)); rightmin = wj; } } } } ENDR("vorgaenger_bruhat_strong"); } #define BRUHAT_IDEAL_CO(a,b,func)\ {\ INT i,j,k;\ OP c,d,e,z,f;\ c = CALLOCOBJECT();\ d = CALLOCOBJECT();\ e = CALLOCOBJECT();\ erg += numberof_inversionen(a,c); \ INC(c);\ erg += b_l_v(c,b);\ erg += m_o_v(a,S_V_I(b,0));\ for (i=0;i0;i--)\ for (j=0;j=(INT)0 ; i--) { if (EMPTYP(S_M_IJ(e,i,j))) { erg += m_i_i(1L,S_M_IJ(e,i,j)) ; k++; } else if (S_M_IJI(e,i,j) == -1L) erg += m_i_i((INT)0,S_M_IJ(e,i,j)); else if (S_M_IJI(e,i,j) == (INT)0){ erg += m_i_i((INT)0,S_M_IJ(e,i,j)); for (m=j+1L; m=(INT)0 ; m--) if (not EMPTYP(S_M_IJ(e,m,j))) { if (S_M_IJI(e,m,j) == -1L) erg += m_i_i((INT)0,S_M_IJ(e,m,j) ); } else m_i_i((INT)0,S_M_IJ(e,m,j)); break; } else error("inversion_matrix_perm:wrong content"); } } ENDR("inversion_matrix_perm"); } #endif /* PERMTRUE */ symmetrica-2.0/perm.doc0000600017361200001450000004041710726170300015031 0ustar tabbottcrontabCOMMENT: PERMUTATION ----------- Permutations are implemented as a structure of two components, the first component codes the special kind of the implementation, it is whether we have a list or a cycle structure. The second part are the datas, it is a VECTOR object of INTEGER object, the content depends on the kind information. At the moment there two kinds: VECTOR i.e. this is the list form, and ZYKEL. In both cases the numbering starts with 1, not with 0. The type VECTOR means, that we store the images of 1 to n as a list, so at the i-th position we have the image of i, if the type is ZYKEL, we store the permutation as a product of cycles, the cycles are written in a form, that the smallest entry is first, we store the cycle with the biggest first entry first. So the two following permutations are equal: VECTOR: [2,3,6,10,5,7,4,9,8,1] ZYKEL: (8,9)(5)(1,2,3,6,7,4,10) Internally both are a VECTOR object of INTEGER objects. So the ZYKEL-type would be the INTEGER VECTOR [8,9,5,1,2,3,6,7,4,10] The type VECTOR is the default type of PERMUTATION objects. There are the standard routines and macros NAME MACRO DESCRIPTION --------------------------------------------------------- c_p_k C_P_K change_perm_kind c_p_s C_P_S change_perm_self s_p_k S_P_K select_perm_kind s_p_i S_P_I select_perm_ith_element s_p_ii S_P_II select_perm_ith_element_as_INT s_p_l S_P_L select_perm_length s_p_li S_P_LI select_perm_length_as_INT s_p_s S_P_S select_perm_self b_ks_p m_ks_p m_il_p CONSTRUCTOR, SELECTOR, MACROS ----------------------------- NAME: c_p_k SYNOPSIS: c_p_k(OP p, OBJECTKIND k) DESCRIPTION: changes the value, which indicates the type of the PERMUTATION object p. Up to now there are only two kinds, which are allowed, i.e. VECTOR and ZYKEL. If you use the macro, there will be no checks, on valid input parameters. EXAMPLE: .... scan(PERMUTATION,a); println(a); c_p_k(a,ZYKEL); println(a); .... The data remains unchanged, but is interpreted as a permutation in cycle notation, if you enter for example the permutation (in list notation, which is the default) [3,5,4,1,2] the second println will output (3,5,4)(1,2) NAME: m_il_p SYNOPSIS: INT m_il_p(INT l; OP p) DESCRIPTION: builds a PERMUTATION object with empty entries of the specified length l. The kind of p becomes VECTOR. EXAMPLE: This example reads with the standard C-function scanf a INT variable from stdin, and generates a permutation of the entered length, the entries of the list, representing the permutation are empty objects ( = # ). #include "def.h" #include "macro.h" main() { OP a; INT l; anfang(); a = callocobject(); scanf("%ld",&l); m_il_p(l,a); println(a); freeall(a); ende(); } COMMENT: ROUTINES -------- The following part contains information on routines, which are handling PERMUTATION objects. NAME: bruhat_comp_perm SYNOPSIS: INT bruhat_comp_perm( OP a,b) DESCRIPTION: compares according to the Bruhat order. returns the constant INT NONCOMPARABLE if the two PERMUTATION objects a and b are not comparable. it return 0 if equal 1 if a>b and -1 if aSCHUR necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,ELMSYM,"plet_elmsym_schur(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"plet_elmsym_schur(2)",b); CTTTO(EMPTY,HASHTABLE,SCHUR,"plet_elmsym_schur(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } pes___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_SCHUR(c,c); #endif ENDR("plet_elmsym_schur"); } INT pes_ende() { return OK; } #ifdef PLETTRUE INT m_merge_partition_partition(); INT pes_integer_partition_(); INT pes_integer_hashtable_(); INT pes___(); INT pes_null__(b,c,f) OP b,c,f; { INT mxx_null__(); return mxx_null__(b,c,f); } INT pes_integer_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; CTO(INTEGER,"pes_integer_hashtable_(1)",a); CTTO(HASHTABLE,SCHUR,"pes_integer_hashtable_(2)",b); CTTO(SCHUR,HASHTABLE,"pes_integer_hashtable_(3)",c); NYI("pes_integer_hashtable_"); ENDR("pes_integer_hashtable_"); } INT pes_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"pes_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"pes_integer__(2)",b); CTTO(HASHTABLE,SCHUR,"pes_integer__(3)",c); if (S_O_K(b) == PARTITION) erg += pes_integer_partition_(a,b,c,f); else if (S_O_K(b) == SCHUR) { INT mss_hashtable_hashtable_(); INT p_schursum(); if (S_S_N(b) == NULL) erg += pes_integer_partition_(a,S_S_S(b),c,f); else erg += p_schursum(a,b,c,f,NULL,pes_integer__,mss_hashtable_hashtable_); } else { erg += pes_integer_hashtable_(a,b,c,f); } ENDR("pes_integer__"); } INT mpp_hashtable_hashtable_(); INT pes_null_partition_(); INT pes_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"pes_partition__(1)",a); CTTTO(HASHTABLE,SCHUR,PARTITION,"pes_partition__(2)",b); CTTO(HASHTABLE,SCHUR,"pes_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += pes_null_partition_(b,c,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += pes_integer__(S_PA_I(a,0),b,c,f); goto ende; } else{ INT mss_hashtable_hashtable_(); INT p_splitpart(); erg += p_splitpart(a,b,c,f,pes_partition__, mss_hashtable_hashtable_); goto ende; } ende: ENDR("pes_partition__"); } INT pes_elmsym__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(ELMSYM,"pes_elmsym__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"pes_elmsym__(2)",b); CTTO(HASHTABLE,SCHUR,"pes_elmsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,pes_partition__); ENDR("pes_elmsym__"); } INT pes_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"pes_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"pes_hashtable__(2)",b); CTTO(HASHTABLE,SCHUR,"pes_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,pes_partition__); ENDR("pes_hashtable__"); } INT pes_null_partition_(b,c,f) OP b,c,f; /* AK 061201 */ { INT erg = OK; CTO(PARTITION,"pes_null_partition(1)",b); CTTO(SCHUR,HASHTABLE,"pes_null_partition(2)",c); _NULL_PARTITION_(b,c,f); ENDR("pes_null_partition"); } INT pes_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; INT cc_plet_pes_integer_partition(); CTO(INTEGER,"pes_integer_partition_(1)",a); CTO(PARTITION,"pes_integer_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"pes_integer_partition_(3)",c); SYMCHECK ((S_I_I(a) < 0),"pes_integer_partition_:integer<0"); if (S_I_I(a) == 0) { erg += pes_null_partition_(b,c,f); goto ende; } erg += cc_plet_pes_integer_partition(a,b,c,f); ende: ENDR("pes_integer_partition_"); } INT pes___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,ELMSYM,"pes___(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"pes___(2)",b); CTTO(HASHTABLE,SCHUR,"pes___(3)",c); if (S_O_K(a) == INTEGER) { erg += pes_integer__(a,b,c,f); } else if (S_O_K(a) == PARTITION) { erg += pes_partition__(a,b,c,f); } else if (S_O_K(a) == ELMSYM) { erg += pes_elmsym__(a,b,c,f); } else /* if (S_O_K(a) == HASHTABLE) */ { erg += pes_hashtable__(a,b,c,f); } ENDR("pes___"); } #endif /* PLETTRUE */ symmetrica-2.0/phe.c0000400017361200001450000000134410726021634014316 0ustar tabbottcrontab #include "def.h" #include "macro.h" INT thp___faktor(); INT ppe___(); INT plet_homsym_elmsym(a,b,c) OP a,b,c; /* AK 061201 */ { INT t=0,erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"plet_homsym_elmsym(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,ELMSYM,"plet_homsym_elmsym(2)",b); CTTTO(EMPTY,HASHTABLE,ELMSYM,"plet_homsym_elmsym(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } /* pse___(a,b,c,cons_eins); */ { /* via ppe with change of basis */ OP f = CALLOCOBJECT(); erg += init_hashtable(f); erg += thp___faktor(a,f,cons_eins); erg += ppe___(f,b,c,cons_eins); FREEALL(f); } if (t==1) t_HASHTABLE_ELMSYM(c,c); ENDR("plet_homsym_elmsym"); } symmetrica-2.0/phh.c0000400017361200001450000000141710726021634014322 0ustar tabbottcrontab #include "def.h" #include "macro.h" INT thp___faktor(); INT pph___(); INT plet_homsym_homsym(a,b,c) OP a,b,c; /* AK 111201 */ { INT t=0,erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"plet_homsym_homsym(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,HOMSYM,"plet_homsym_homsym(2)",b); CTTTO(EMPTY,HASHTABLE,HOMSYM,"plet_homsym_homsym(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } else if (S_O_K(c) == HOMSYM) { t=1; t_HOMSYM_HASHTABLE(c,c); } { /* via pph with change of basis */ OP f = CALLOCOBJECT(); erg += init_hashtable(f); erg += thp___faktor(a,f,cons_eins); erg += pph___(f,b,c,cons_eins); FREEALL(f); } if (t==1) t_HASHTABLE_HOMSYM(c,c); ENDR("plet_homsym_homsym"); } symmetrica-2.0/phm.c0000400017361200001450000001627510726021635014340 0ustar tabbottcrontab #include "def.h" #include "macro.h" INT plet_homsym_monomial(a,b,c) OP a,b,c; /* AK 051201 */ { INT erg = OK; #ifdef PLETTRUE INT t=0; /* is 1 if transfer HASHTABLE->MONOMIAL necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"plet_homsym_monomial(1)",a); CTTTTO(HASHTABLE,PARTITION,MONOMIAL,INTEGER,"plet_homsym_monomial(2)",b); CTTTO(EMPTY,HASHTABLE,MONOMIAL,"plet_homsym_monomial(3)",c); if (S_O_K(c) == EMPTY) if (S_O_K(a) == INTEGER) init_monomial(c); else { t=1; init_hashtable(c); } phm___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_MONOMIAL(c,c); #endif ENDR("plet_homsym_monomial"); } INT phm_ende() { INT erg = OK; return erg; } #ifdef PLETTRUE INT phm_integer_partition_(); INT phm_integer_hashtable_(); INT phm_integer_integer_(); INT phm___(); INT phm_null__(b,c,f) OP b,c,f; { INT mxx_null__(); return mxx_null__(b,c,f); } INT phm_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"phm_integer__(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,MONOMIAL,"phm_integer__(2)",b); CTTO(HASHTABLE,MONOMIAL,"phm_integer__(3)",c); SYMCHECK((S_I_I(a) < 0),"phm_integer__:integer < 0"); if (S_I_I(a) == 0) erg += phm_null__(b,c,f); if (S_O_K(b) == PARTITION) erg += phm_integer_partition_(a,b,c,f); else if (S_O_K(b) == INTEGER) erg += phm_integer_integer_(a,b,c,f); else M_FORALL_MONOMIALS_IN_B(a,b,c,f,phm_integer_partition_); ENDR("phm_integer__"); } INT phm_null_partition_(); INT phm_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"phm_partition__(1)",a); CTTTO(HASHTABLE,MONOMIAL,PARTITION,"phm_partition__(2)",b); CTTO(HASHTABLE,MONOMIAL,"phm_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += phm_null__(b,c,f); } else if (S_PA_LI(a) == 1) { erg += phm_integer__(S_PA_I(a,0),b,c,f); } else{ INT mmm_hashtable_hashtable_(); INT p_splitpart(); erg += p_splitpart(a,b,c,f,phm_partition__, mmm_hashtable_hashtable_); } ENDR("phm_partition__"); } INT phm_homsym__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HOMSYM,"phm_homsym__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"phm_homsym__(2)",b); CTTO(HASHTABLE,MONOMIAL,"phm_homsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,phm_partition__); ENDR("phm_homsym__"); } INT phm_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"phm_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"phm_hashtable__(2)",b); CTTO(HASHTABLE,MONOMIAL,"phm_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,phm_partition__); ENDR("phm_hashtable__"); } INT phm_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"phm_hashtable_hashtable_(1)",a); CTO(HASHTABLE,"phm_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,MONOMIAL,"phm_hashtable_hashtable_(3)",c); NYI("phm_hashtable_hashtable_"); ENDR("phm_hashtable_hashtable_"); } INT phm_null_partition_(b,c,f) OP b,c,f; /* AK 061201 */ { INT erg = OK; CTO(PARTITION,"phm_null_partition(1)",b); CTTO(MONOMIAL,HASHTABLE,"phm_null_partition(2)",c); _NULL_PARTITION_(b,c,f); ENDR("phm_null_partition"); } INT phm_integer_integer_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"phm_integer_integer_(1)",a); CTO(INTEGER,"phm_integer_integer_(2)",b); CTTO(MONOMIAL,HASHTABLE,"phm_integer_integer_(3)",c); SYMCHECK ((S_I_I(a) < 0),"phm_integer_integer_:integer(1)<0"); SYMCHECK ((S_I_I(b) < 0),"phm_integer_integer_:integer(2)<0"); if (S_I_I(a) == 0) { erg += phm_null__(b,c,f); goto ende; } else { OP z,m = CALLOCOBJECT(); INT i; INT thm_integer__faktor(); init_hashtable(m); thm_integer__faktor(a,m,f); FORALL(z,m,{ OP mm; for (i=0;iSCHUR necessary */ if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } phs___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_SCHUR(c,c); } #endif ENDR("plet_homsym_schur"); } INT phs_ende() { INT erg = OK; return erg; } #ifdef PLETTRUE INT phs_integer_partition_(); INT phs_integer_hashtable_(); INT phs___(); INT phs_null__(b,c,f) OP b,c,f; { INT mxx_null__(); return mxx_null__(b,c,f); } INT phs_integer_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; CTO(INTEGER,"phs_integer_hashtable_(1)",a); CTTO(HASHTABLE,SCHUR,"phs_integer_hashtable_(2)",b); CTTO(SCHUR,HASHTABLE,"integer_hashtable_(3)",c); NYI("phs_integer_hashtable_"); ENDR("phs_integer_hashtable_"); } INT phs_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"phs_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"phs_integer__(2)",b); CTTO(HASHTABLE,SCHUR,"phs_integer__(3)",c); SYMCHECK((S_I_I(a) < 0) , "phs_integer__:integer<0"); if (S_I_I(a) == 0) { erg += phs_null__(b,c,f); } else if (S_O_K(b) == PARTITION) erg += phs_integer_partition_(a,b,c,f); else if (S_O_K(b) == SCHUR) { INT mss_hashtable_hashtable_(); INT p_schursum(); if (S_S_N(b) == NULL) erg += phs_integer_partition_(a,S_S_S(b),c,f); else erg += p_schursum(a,b,c,f,NULL,phs_integer__,mss_hashtable_hashtable_); } else { erg += phs_integer_hashtable_(a,b,c,f); } ENDR("phs_integer__"); } INT phs_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"phs_partition__(1)",a); CTTTO(HASHTABLE,SCHUR,PARTITION,"phs_partition__(2)",b); CTTO(HASHTABLE,SCHUR,"phs_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += phs_null__(b,c,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += phs_integer__(S_PA_I(a,0),b,c,f); goto ende; } else{ INT p_splitpart(); INT mss_hashtable_hashtable_(); erg += p_splitpart(a,b,c,f,phs_partition__, mss_hashtable_hashtable_); goto ende; } ende: CTTO(HASHTABLE,SCHUR,"phs_partition__(3)",c); ENDR("phs_partition__"); } INT phs_homsym__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HOMSYM,"phs_homsym__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"phs_homsym__(2)",b); CTTO(HASHTABLE,SCHUR,"phs_homsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,phs_partition__); ENDR("phs_homsym__"); } INT phs_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"phs_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"phs_hashtable__(2)",b); CTTO(HASHTABLE,SCHUR,"phs_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,phs_partition__); CTTO(HASHTABLE,SCHUR,"phs_hashtable__(3-end)",c); ENDR("phs_hashtable__"); } INT phs_null_partition_(b,c,f) OP b,c,f; /* AK 061201 */ { INT erg = OK; CTO(PARTITION,"phs_null_partition(1)",b); CTTO(SCHUR,HASHTABLE,"phs_null_partition(2)",c); _NULL_PARTITION_(b,c,f); ENDR("phs_null_partition"); } INT phs_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; INT cc_plet_phs_integer_partition(); CTO(INTEGER,"phs_integer_partition_(1)",a); CTO(PARTITION,"phs_integer_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"phs_integer_partition_(3)",c); SYMCHECK ((S_I_I(a) < 0),"phs_integer_partition_:integer<0"); if (S_I_I(a) == 0) { erg += phs_null_partition_(b,c,f); goto ende; } erg += cc_plet_phs_integer_partition(a,b,c,f); ende: ENDR("phs_integer_partition_"); } INT phs___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"phs___(1)",a); CTTTO(HASHTABLE,PARTITION,SCHUR,"phs___(2)",b); CTTO(HASHTABLE,SCHUR,"phs___(3)",c); if (S_O_K(a) == INTEGER) { erg += phs_integer__(a,b,c,f); goto ende; } else if (S_O_K(a) == PARTITION) { erg += phs_partition__(a,b,c,f); goto ende; } else if (S_O_K(a) == HOMSYM) { erg += phs_homsym__(a,b,c,f); goto ende; } else /* if (S_O_K(a) == HASHTABLE) */ { erg += phs_hashtable__(a,b,c,f); goto ende; } ende: CTTO(HASHTABLE,SCHUR,"phs___(3-end)",c); ENDR("phs___"); } #endif /* PLETTRUE */ symmetrica-2.0/plet.c0000400017361200001450000044146010726021636014517 0ustar tabbottcrontab/* SYMMETRICA file plet.c */ #include "def.h" #include "macro.h" /* CC 240197 */ #ifdef PLETTRUE #ifdef DGUX #define signed #endif /* DGUX */ #ifdef sun #define signed #endif /*sun */ #ifdef hpux #define signed #endif static INT cmp(); static INT ins_sch_lst(); static INT ins_sc_lst(); /* static INT ins_s_lst(); */ static INT cjg_rv(); static INT cjg_rv_lst(); static INT pl_schur_schur(); static struct liste * proprt(); static INT fct_sch_prt_srt(); static struct liste * pro_lg(); static INT fct_sch_lg_srt(); static INT poids(); static INT free_lst(); static INT free_newton(); static INT shuffle_sig(); /* static INT shuffle_sg(); */ static INT detr(); static INT plth1(); static INT plth2(); static INT plth3(); static INT plth4(); static INT plth5(); static INT cc_plethysm(); static INT calcul(); static INT calcula(); static INT calculi(); static INT operer(); static INT plet_conj(); static INT conjug(); static INT t_list_SYM(); static INT conjugate_apply_schur(); static INT t_list_coef_SYM(); struct liste { INT coef; signed char *tab; struct liste *suivant; }; struct monomial{ int degree; unsigned indice; struct liste *resultat; struct monomial *suivant; }; /* struct cel{ struct cel *prec; struct cel *suiv; signed char *tab; long coef; }; */ /* struct lst{ struct cel *deb; }; */ signed char gv,booo,gvr,lng; /**/ void voirbuf(bs) register char *bs; { while(*bs) { printf("%d ",*bs); bs++; } } /**/ /* prints the double linked list */ #ifdef UNDEF static void voirlst(plst) struct cel *plst; { while(plst!=NULL) { printf("%ld(",plst->coef); voirbuf(plst->tab); printf(")\n"); plst=plst->suiv; } } static void voirliste(plst) struct liste *plst; { while(plst!=NULL) { printf("%ld(",plst->coef); voirbuf(plst->tab); printf(")\n"); plst=plst->suivant; } } #endif static INT cmp(a,b) OP a,b; { OP as=S_MO_S(a); OP bs=S_MO_S(b); INT i=S_PA_LI(as)-1L; INT j=S_PA_LI(bs)-1L; for(;i>=0L && j>= 0L;i--,j--) { if(S_PA_II(as,i) > S_PA_II(bs,j)) return -1L; if(S_PA_II(as,i) < S_PA_II(bs,j)) return 1L; } return 0L; } INT plethysm(a,b,c) OP a,b,c; /* AK 180299 */ /* input object a may be SCHUR, MONOMIAL, ... input object b may be SCHUR, MONOMIAL, ... output object c the plethysm a[b] in the basis of b */ { INT erg = OK; CE3(a,b,c,plethysm); if ((S_O_K(a) == SCHUR) && (S_O_K(b) == MONOMIAL)) { erg += plethysm_schur_monomial(a,b,c); } else if ((S_O_K(a) == SCHUR) && (S_O_K(b) == SCHUR)) { erg += plethysm_schur_schur(a,b,c); } else { erg += WTT("plethysm",a,b); } ENDR("plethysm"); } /* takes a partition, its maximal indice and conjugates it 1 1 2, 2 gives 1 3, 1 */ static INT plet_conj(pt,pj) signed char **pt,*pj; { signed char *btab,*af,*baf,j; signed char mid,temp,high,i; j= *pj; btab = *pt+j; mid = *btab;*pj=mid; af=(signed char *)SYM_MALLOC(mid+1); *(af+mid)=0; baf=af; j++; temp = 0; while(j >= 0) { high = 0; while(*btab == mid) { j--; high++; if(j == 0) { j--; break; } btab--; } temp = temp+high; if(j == -1) { for(i=0;i= (signed char) 0) { high = 0; while(*btab == mid) { j--; high++; if(j == 0) { j--; break; } btab--; } temp = temp+high; if(j == -1) i = 0; else i = *btab; for(;i < mid;i++) { M_I_I( (INT)temp , S_V_I( ve,(INT)k ) ); k++; } mid = *btab; } return OK; } int SYM_strlen(); static INT operer(n,ttp,deg,baf,cof,liste,parite) signed char n,ttp,deg,*baf,parite; struct liste *liste; INT cof; { signed char np,cond=0,si,v,tv,k,tp,var,first; register signed char j,jn,temp; signed char *s,*init,*tabn,*st,*af,*bs,*binit,*btabn,*bab,*bobo; static struct liste *liste3p; struct liste *liste1,*liste2=NULL,*liste3; static signed char obo[128]; /* The succesive "buf" which come are ordered; The search in "liste" begins at its first pointed element if buf is the first pointed element of "bp" in calcul (gv = 0) or begins in at the element pointed by liste3p if not */ first = (signed char)0; if(gv == 0) { liste3 = liste; gv = 1; } else liste3 = liste3p; si = sizeof(struct liste); /*j is the length of baf; instead of this: strlen(baf)*/ j = 0; bab = baf; while(*baf != '\0') { baf++; j++; } /*The maximal length of the new terms will be less than or equal to np; tmp is a useful variable giving the difference of length*/ tp = ttp - j; np = j + (deg * n); /*Allocation of four different tableaux*/ s = (signed char *)SYM_MALLOC(np + 1); init = (signed char *)SYM_MALLOC(np + 1); af = (signed char *)SYM_MALLOC(np + 1); tabn = (signed char *)SYM_MALLOC(deg + 1); /*Init is the initial Schur function we want multiply by the monomial function indexed by n*/ binit = init; for(jn = 0;jn < np - j;jn++) *binit++ = jn + tp; baf = bab; for(jn = 0;jn < j;jn++) *binit++ = *baf++ + (deg * n); *binit = 0; /* s is the tableau result of the product; tab is the tableau giving the position of the parts which are incremented*/ temp = np - 1; if(booo == 1) { binit = init + temp; first = 1; for(jn = temp; jn >= 0; jn--) { if(((*binit) + n - tp - temp) <= lng) break; if(jn != 0) binit--; } binit = init; bs = s; for(temp = 0; temp <= jn - deg;temp++) *bs++ = *binit++; for(;temp < jn;temp++) *bs++ = *binit++ + n; for(; temp < np;temp++) *bs++ = *binit++; *(tabn + deg - 1) = jn + 1; if(j < deg) j = deg; tp = j; var = deg - 1; goto et1; } else { jn = np - deg; binit = init + jn; baf = tabn; bs = s + jn; for(;jn <= temp;jn++) { *baf++ = jn; *bs++ = *binit++ + n; } *baf = 0; *bs = 0; bs = s; binit = init; for(jn = 0;jn < np - deg;jn++) *bs++ = *binit++; if(j < deg) j = deg; tp = j; liste2 = liste3->suivant; if(liste2 != NULL) { /*The Schur function result of the product must be put in a structure liste which is not empty. The real result is st which is an offset of s*/ st = (signed char *)SYM_MALLOC(j + 1); baf = st; temp = np - j; bs = s + temp; for(jn = temp;jn < np;jn++) *baf++ = *bs++ ; *baf = 0; while(liste2 != NULL) { /*Is the Schur function in liste? As the cofactor is ordered, the result must not be very far in the liste*/ /* Position on the last part of the partition for the liste: bab for the result:bs*/ temp = -1; bab = liste2->tab; while(*bab != '\0') { bab++; temp++; } cond = 0; bab = (liste2->tab) + temp; bs = st + j - 1; /* The comparaison*/ for(jn = temp;jn >= 0;jn--) { if(*bs < *bab) { cond = -1; break; } else if(*bs > *bab) { cond = 1; break; } bs--; bab--; } /*The result of the comparaison*/ if(cond > 0) /*Stop of the comparaison for insertion*/ break; else if(cond == 0) { /*The Schur function is already in the liste*/ liste2->coef += (cof * parite); if(liste2->coef == 0L) { /*the coefficient of the Schur function is null: Supression*/ liste1 = liste2->suivant; SYM_free(liste2->tab); SYM_free((signed char *)liste2); liste3->suivant = liste1; liste2 = liste1; } else { liste3 = liste2; liste2 = liste2->suivant; } SYM_free(st); /*the comparaison is ended*/ break; } /*End of if cond == 0*/ else { /*In this case the comparaison go on*/ liste3 = liste2; liste2 = liste2->suivant; } } /*End of while liste2 != NULL*/ if (cond != 0) { /*Insertion*/ liste1 = (struct liste *)SYM_MALLOC(si); liste1->tab = st; liste1->suivant = liste2; liste1->coef = cof * parite; liste3->suivant = liste1; liste3 = liste1; } /*The first product from the next cofactor will be after the product st in the pointed liste*/ liste3p = liste3; /* Muir's algorithm starts trying to add n to the part indexed by tabn[0]-1*/ *tabn -= 1; s[np - deg] = s[np - deg] - n; for(;;) { while((v = tabn[0]) >= 0) { /*To try to add the leftest part n of the monomial function*/ if(((np - v) > lng) && (booo == 0)) /*If the result has its length bigger than lng, go out the loop*/ break; tv = s[v] + n; for(jn= v+1;jn< np;jn++) if(tv == s[jn]) /*If two parts are equal, try to put n to another place*/ break; if(jn == np) { /*Build the vector result in af; af is not ordered*/ baf = af; bs = s; for(jn= 0;jn< v;jn++) *baf++ = *bs++; *baf++ = tv; bs++; for(jn= v+1;jn< np;jn++) *baf++ = *bs++; *baf = '\0'; /*We reorder the vector into a partition*/ tv = parite; for(k = n /2;k > 0;k /= 2) for(jn = k;jn< np;jn++) for(j = jn-k;((j >= 0) && (af[j] > af[j+k]));j -= k) { tv = -tv; temp = af[j]; af[j] = af[j+k]; af[j+k] = temp; } /*j is the length of the partition less one; v is np-v i.e. the number of parts which are null*/ if(tp < np - v) j = np - v - 1; else { v = np - tp; j = tp - 1; } if(first == 1) { if(gvr == 0) { gvr = 1; liste3 = liste; } else { temp = SYM_strlen(obo); bobo = obo + (temp - 1); baf = af + np - 1; if(np < temp) temp = np; for(;temp > 1; temp--) { if(*bobo > *baf) { liste3 = liste3p; break; } else if(*bobo < *baf) { liste3 = liste; break; } bobo--; baf--; } if (temp == 1) { if(*bobo > *baf) liste3 = liste3p; else liste3 = liste; } /* CC 1/3/97 SYM_free(obo); */ } temp = j + 1; /* CC 1/3/97 obo = (signed char *)SYM_MALLOC(temp + 1); */ bobo = obo; baf = af + v; for(jn = 0;jn < temp;jn++) *bobo++ = *baf++; *bobo = 0; liste2 = liste3->suivant; } /*It is the same search than before: is the Schur function af in the liste*/ if (liste2 == NULL) cond = 1; while(liste2 != NULL) { temp = -1; bab = liste2->tab; while(*bab != '\0') { bab++; temp++; } bab = (liste2->tab) + temp; baf = af + np - 1; cond = 0; if(temp > j) temp = j; for(jn = temp;jn>= 0;jn--) { /*Comparaison*/ if(*baf < *bab) { cond = -1; break; } else if(*baf > *bab) { cond = 1; break; } baf--; bab--; } if(cond > 0) break; else if(cond == 0) { if(tv == -1) liste2->coef -= cof; else liste2->coef += cof; if(liste2->coef == 0L) { liste1 = liste2->suivant; SYM_free(liste2->tab); SYM_free((signed char *)liste2); liste3->suivant = liste1; liste2 = liste1; } else { liste3 = liste2; liste2 = liste2->suivant; } break; } /*End of if cond == 0*/ else { liste3 = liste2; liste2 = liste2->suivant; } } /*End of while liste2 == NULL*/ if (cond != 0) { /*Insertion*/ liste1 = (struct liste *)SYM_MALLOC(si); liste3->suivant = liste1; j++; /*The Schur function is put in the liste*/ bab = (signed char *)SYM_MALLOC(j+1); liste1->tab = bab; baf = af + v; for(jn= 0;jn< j;jn++) *bab++ = *baf++; *bab = '\0'; liste1->coef = tv * cof; liste1->suivant = liste2; liste3 = liste1; } /*End of cond != 0*/ if(first == 1) { first = 0; liste3p = liste3; } } /*End of jn == np*/ tabn[0]--; } /*End of the while tabn[0]>= 0*/ var = 1; et1: for(jn= var;jn< deg;jn++) { /*To put all the indexes of the monomial function except the leftest one*/ bab = tabn + jn; if((v = *bab ) != jn) { /*Shift left still the jn index of the monomial function which is at the position v*/ binit = init + v; baf = s + v; *baf = *binit; for(j = jn;j >= 0;j--) /*Try to put the index j of the monomial function*/ for(;;) { v--; binit--; baf--; if((j > v) || ((booo == 0) && ((np + j - v) > lng))) /*It is impossible to put the jn leftest indexes of the monomial function; try to put more than jn indexes*/ goto boucle1; else { /*Shift*/ tv = *binit + n; if(np <= v + n) temp = np; else temp = v + n + 1; bs = s + v; for(k = v+1;k < temp;k++) { bs++; if(tv == *bs) { /*Impossible to shift the index j at position v: try to put at v-1*/ *baf = *binit; break; } } if(k == temp) { /*Succeed in shifting*/ *bab-- = v; *baf = *binit + n; break; } } } /*After succeeding in shifting, build a new tableau s*/ bs = s; binit = init; for(k = 0;k <= v;k++) *bs++ = *binit++; break; } boucle1: ; } if(jn== deg) break; } /*End of the loop for(;;) corresponding to Muir's algorithm*/ } else { /*It seems to the preceeding loop except that there is not ordering*/ liste2 = (struct liste *)SYM_MALLOC(si); liste3->suivant = liste2; liste2->suivant = NULL; liste2->coef = cof * parite; bs = s + (np - j); bab = (signed char *)SYM_MALLOC(j + 1); liste2->tab = bab; for(jn = 0;jn < j;jn++) *bab++ = *bs++; *bab = 0; liste3 = liste2; liste2 = NULL; liste3p = liste3; tabn[0]--; s[np - deg] = s[np - deg] - n; for(;;) { while((v = tabn[0]) >= 0) { if(((np - v) > lng) && (booo == 0)) break; tv = s[v] + n; for(jn = v + 1;jn < np;jn++) if(tv == s[jn]) break; if(jn == np) { baf = af; bs = s; for(jn = 0;jn < v;jn++) *baf++ = *bs++; *baf++ = tv; bs++; for(jn = v+1;jn < np;jn++) *baf++ = *bs++; *baf = '\0'; tv = parite; for(k = n /2;k > 0;k /= 2) for(jn = k;jn < np;jn++) for(j = jn-k;((j >= 0) && (af[j] > af[j+k]));j -= k) { tv = -tv; temp = af[j]; af[j] = af[j+k]; af[j+k] = temp; } liste2 = (struct liste *)SYM_MALLOC(si); if(tp < np - v) j = np - v; else { v = np - tp; j = tp; } baf = af + v; btabn = (signed char *)SYM_MALLOC(j + 1); liste2->tab = btabn; while(*baf != '\0') *btabn++ = *baf++; *btabn = '\0'; if(first == 1) { first = 0; liste3p = liste3; } liste2->coef = tv * cof; liste2->suivant = NULL; liste3->suivant = liste2; liste3 = liste2; } tabn[0]--; } for(jn = 1;jn < deg;jn++) { /*It is the same loop that in the case liste2!= NULL*/ btabn = tabn + jn; if((v = *btabn) != jn) { binit = init + v; baf = s + v; *baf = *binit; for(j = jn;j >= 0;j--) for(;;) { v--; binit--; baf--; if((j > v) || ((booo == 0) && ((np + j - v) > lng))) goto boucle2; else { tv = *binit + n; if ( np <= v + n ) temp = np; else temp = v + n + 1; bs = s + v; for(k = v+1;k < temp;k++) { bs++; if(tv == *bs) { *baf = *binit; break; } } if(k == temp) { *btabn-- = v; *baf = *binit+n; break; } } } bs = s; binit = init; for(k = 0;k <= v;k++) *bs++ = *binit++; break; } boucle2: ; } if(jn == deg) break; } } } SYM_free(s); SYM_free(tabn); SYM_free(af); SYM_free(init); return OK; } static INT calcul(tab,n,ch,dep,cofe,parite,cond4) signed char *tab,*ch,parite,cond4; int n; INT cofe; struct liste *dep; /*calcul makes the product of the Schur function "ch" by the plethysm L"tab" J"n" ; the final determinant is in dep cond4==n && lg(tab)==1 => dep->suivant==NULL*/ { signed char mx,boo,boo1,boo2,*btab; register int i,j,k; INT cof; int deg,np; /* from signed int AK 210199 */ signed char in,jn,v,tv,ttp,tp,tp1=0,var,first; signed char si,sim,max; signed char *binit,*bs,*s,*init,*tabn,*btabn,*baf,*af; signed char lg; unsigned vr,av,bvr,tvr,ttvr,tttvr,atvr; struct liste *liste,*liste2=NULL,*liste3,*bp; struct monomial stmn,*mn,stmn1,*mn1,*bmn=NULL; /* lg is the length of the partition tab (strlen(tab))*/ btab = tab; first = 0; lg = 0; while(*btab != 0) { btab++; lg++; } /* max (resp. deg) is the weight (resp. length) of the partition ch*/ max = 0; deg = 0; btab = ch; while(*btab != 0) { deg++; max += *btab++; } btab = tab; mx = *btab; /* printf("n %d cond4 %d lg %d booo %d\n",n,cond4,lg,booo); */ if((n != cond4) && (lg == 1)) { gv = 0; btab = ch; i = max - deg; while(*btab != 0) { *btab += i; btab++; i++; } operer(n,max,mx,ch,cofe,dep,parite); } else { /*In the stucture monomial, there are the different determinants of order i, i between 1 and lg determinants taken on the i first columns*/ mn = &stmn; mn->suivant = NULL; si = sizeof(struct liste); sim = sizeof(struct monomial); vr = 1; if(lg != 1) boo = 1; else boo = parite; for(k = mx;((k > mx - lg) && (k > 0));k--) { /*The calculus of all the determinants of the first column, except may be the product of the plethysm L0Jn (=1) by ch.*/ if(lg != 1) /*The determinant is of order bigger than 1: the is put in a liste*/ liste = (struct liste *)SYM_MALLOC(si); else /*The determinant is of order 1: the result is returned in dep, argument of the function calcul*/ liste = dep; /*The program in the loop "for(k = mx;((k > mx - lg) && (k > 0));k--)" is the Muir's formula to compute the determinants in the first column: see this algorithm in operer*/ liste->suivant = NULL; np = (n * k) + deg; tp1 = max - deg; s = (signed char *)SYM_MALLOC(np + 1); init = (signed char *)SYM_MALLOC(np + 1); af = (signed char *)SYM_MALLOC(np + 1); tabn = (signed char *)SYM_MALLOC(k + 1); baf = ch; binit = init; for(in = 0;in < np - deg;in++) *binit++ = in + tp1; for(;in < np ;in++) *binit++ = *baf++ + in + tp1; *binit = 0; if(booo == 1) { first = 1; binit = init + np - 1; for(i = np - 1; i >= 0; i--) { if(((*binit) + n - tp1 - np ) < lng) break; if(i != 0) binit--; } bs = s; binit = init; for(jn = 0; jn <= i-k;jn++) *bs++ = *binit++; for(;jn < i;jn++) *bs++ = *binit++ + n; for(; jn < np;jn++) *bs++ = *binit++; *(tabn + k - 1) = i + 1; j = deg; if(j < k) j = k; var = k - 1; goto et3; } else { bs = s ; binit = init; btabn = tabn; for(in = 0;in < np - k; in ++) *bs++ = *binit++; for(; in < np; in++) { *bs++ = *binit++ + n; *btabn++ = in; } *btabn = 0; *bs = 0; j = deg; if(j < k) j = k; liste2 = (struct liste*)SYM_MALLOC(si); if(lg != 1) liste2->coef = 1L; else liste2->coef = boo * cofe; bs = s + (np - j); btabn = (signed char *)SYM_MALLOC(j + 1); liste2->tab = btabn; while(*bs != 0) *btabn++ = *bs++ ; *btabn = '\0'; liste2->suivant = NULL; liste->suivant = liste2; tabn[0]--; s[np - k] = s[np - k] - n; for(;;) { while((v = tabn[0]) >= 0) { if(((np - v) > lng) && (booo == 0)) break; tv = s[v] + n; for(in = v+1;in < np;in++) if(tv == s[in]) break; if(in == np) { baf = af; bs = s; for(in = 0;in < v;in++) *baf++ = *bs++; bs = s + v + 1; *baf++ = tv; for(in = v+1;in < np;in++) *baf++ = *bs++; *baf = '\0'; tv = boo; for(i = n /2;i > 0;i /= 2) for(in = i;in < np;in++) for(jn = in-i;((jn >= 0) && (af[jn] > af[jn+i]));jn -= i) { tv = -tv; ttp = af[jn]; af[jn] = af[jn+i]; af[jn+i] = ttp; } bp = (struct liste *)SYM_MALLOC(si); if(j < np - v) jn = np - v; else { v = np - j; jn = j; } btabn = (signed char *) SYM_MALLOC(jn + 1); bp->tab = btabn; baf = af + v; while(*baf != 0) *btabn++ = *baf++; *btabn = '\0'; if(lg != 1) bp->coef = tv; else bp->coef = tv * cofe; bp->suivant = NULL; if(first == 1) { first = 0; liste2 = liste; } liste2->suivant = bp; liste2 = bp; } tabn[0]--; } var = 1; et3: for(in = var;in < k;in++) { btabn = tabn + in; if((v = *btabn) != in) { binit = init + v; baf = s + v; *baf = *binit; for(jn = in;jn >= 0;jn--) for(;;) { v--; binit--; baf--; if((jn > v) || ((booo == 0) && ((np + jn - v) > lng))) goto boucle; else { tv = *binit+n; if ( np <= v + n ) ttp = np; else ttp = v + n + 1; bs = s + v; for(i = v+1;i < ttp;i++) { bs++; if(tv == *bs) { *baf = *binit; break; } } if(i == ttp) { *btabn-- = v; *baf = *binit+n; break; } } } bs = s; binit = init; for(i = 0;i <= v;i++) *bs++ = *binit++; break; } boucle: ; } if(in == k) break; } } SYM_free(s); SYM_free(tabn); SYM_free(af); SYM_free(init); if (lg != 1) { /*The option is bigger than 0: if the final determinant is not of order 1, write the different partial results in the pointed liste of type struct monomial: stmn*/ mn->suivant = (struct monomial *)SYM_MALLOC(sim); mn = mn->suivant; mn->resultat = liste; /*The record indice is used to recognize the different determinants*/ mn->indice = vr; vr = vr << 1; mn->degree = k; mn->suivant = NULL; } } /*End of the loop for(k = mx;((k > mx - lg) && (k > 0));k--)*/ if((k == 0) && (k != mx - lg)) { /*To put a determinant of value the partition ch*/ if(lg != 1) /*Not final liste*/ liste = (struct liste *)SYM_MALLOC(si); else /*Final liste*/ liste = dep; liste2 = (struct liste *)SYM_MALLOC(si); liste->suivant = liste2; /*Write the coefficient*/ if(lg != 1) liste2->coef = 1L; else liste2->coef = boo * cofe; /*write the partition*/ baf = (signed char *)SYM_MALLOC(deg + 1); liste2->tab = baf; bs = ch; for(i = max - deg;i < max ;i++) *baf++ = *bs++ + i ; *baf = 0; liste2->suivant = NULL; if(lg != 1) { mn->suivant = (struct monomial *)SYM_MALLOC(sim); mn = mn->suivant; mn->resultat = liste; mn->indice = vr; mn->degree = 0; mn->suivant = NULL; } } boo = 1; if(lg != 1) { /*The determinant is of order bigger than 0*/ vr = 1; av = (1 << (lg - 1)); for(i = 1;i < lg;i++) { /*The algorithm progresses with columns i+1*/ /*The option is bigger than i: we will write in the structure monomial*/ if(boo == 1) { /*The preceeding determinants (of order i ) are in stmn; put the determinants ( of order i+1) we are going to compute in stmn1*/ mn = stmn.suivant; mn1 = &stmn1; } else { /*The preceeding determinants (of order i ) are in stmn1; put the determinants ( of order i+1) we are going to compute in stmn*/ mn = stmn1.suivant; mn1 = &stmn; } mn1->suivant = NULL; /*All the variables of type unsigned is used to enumerate the determinants: for example the determinants of order 2 have for indices the characters 00000011, 00000101, 00001001, ... where the position of 1 are the rows of the cofactor*/ av = av | (1 << (lg - i - 1)); vr = (1 << i) | vr; /*vr will be the index of the first determinant of order i+1 we compute; for example for the determinants of order 3, vr is 111*/ tvr = vr; btab++; mx = *btab; for(;;) { /*CALCUL of the determinant of index tvr*/ tp = -1; if(i != lg - 1) { /*Not final liste*/ liste = (struct liste *)SYM_MALLOC(si); liste->suivant = NULL; } else /*Final liste*/ liste = dep; boo1 = 0; boo2 = 0; tv = -1; for(in = lg - 1;in >= 0;in--) { /*Consider the factor which is in the row in + 1, and on the columns i + 1*/ if(tp == i) /*The computation of the determinant indexed by tvr is finished*/ break; ttvr = tvr; if(((ttvr >> in) & 1) == 0) /*The factor is not used in the computation of the determinant indexed by tvr*/ continue; ttvr = (1 << in) ^ tvr; tp++; deg = mx + i - in; if(deg < 0) /*The factor is null*/ continue; if((deg > lng) && (booo == 0)) break; else { tv = -tv; if(deg == 0) { /*The factor is equal to 1*/ /*Read the cofactor from the monomial structure mn*/ bmn = mn; while(bmn != NULL) { /*Search of the cofactor*/ if(bmn->indice == ttvr) break; bmn = bmn->suivant; } if(bmn == NULL) /*The cofactor is null; it will be the same for the cofactor not yet considered: break */ break; boo1 = 1; if(boo2 == 0) { /*the product 'tp1*n' will be the weight of the Schur function indexed by tvr*/ boo2 = 1; tp1 = bmn->degree; } bp = (bmn->resultat)->suivant; liste3 = liste; liste2 = liste3->suivant; while( bp!= NULL) { /*Copy in liste the cofactor (the factor is equal to one); at the beginning liste2 is null; moreover the cofactor is already ordered: it is just a copy*/ liste2 = (struct liste *)SYM_MALLOC(si); baf = bp->tab; j = 0; while(*baf != 0) { baf++; j++; } bs = (signed char *)SYM_MALLOC(j+1); /*Write the partition*/ baf = bp->tab; liste2->tab = bs; while(*baf != 0) *bs++ = *baf++; *bs = 0; /*Write the coefficient*/ liste2->coef = bp->coef * tv; liste2->suivant = NULL; liste3->suivant = liste2; liste3 = liste2; bp = bp->suivant; } } /*End of the if deg == 0*/ else { gvr = 0; /*It is the product by the monomial function indexed by deg and its cofactor indexed by ttvr*/ /* The preceeding result is in the monomial structure bmn*/ if(boo1 == 1) { /* The calculus of a determinant has already begun*/ bmn = bmn->suivant; } else { bmn = mn; } while(bmn != NULL) { /* It is the search of the cofactor of the monomial indexed by deg*/ if(bmn->indice == ttvr) break; bmn = bmn->suivant; } if(bmn == NULL) /*The cofactor is null*/ break; /*The cofactor is not null; boo1 signals that for the next step in the calculus of the determinant a product factor by cofactor different from 0 has already been*/ boo1 = 1; if(boo2 == 0) { /* In the first product (boo2 == 0), '(tp1*n)+max', where max is the weight of the second partition entered, is the weight of the Schur function we are computing*/ boo2 = 1; tp1 = bmn->degree + deg; } /* bp is the cofactor*/ bp = (bmn->resultat)->suivant; /*ttp is the degree maxi of the cofactor np1 is the degree of the product*/ ttp = (bmn->degree * n) + max; /*gv is a global variable to indicate to operer that the product begins*/ gv = 0; while(bp != NULL) { /* operer which makes the product is called for each term of the cofactor*/ cof = bp->coef * tv; if(i == lg - 1) { cof = cof * cofe; j = parite; } else j = 1; operer(n,ttp,deg,bp->tab,cof,liste,j); bp = bp->suivant; } } /*End of deg > 0*/ } /*End of a product factor by cofactor*/ } /*End of the computation of the determinant indexed by tvr*/ if(liste->suivant == NULL) SYM_free((signed char *)liste); else { if( i != lg - 1) { /*i < opt: do not use the files; i!=lg-1: put the liste in the structure pointed by mn1*/ bmn = (struct monomial *)SYM_MALLOC(sim); mn1->suivant = bmn; mn1 = bmn; mn1->suivant = NULL; mn1->indice = tvr; mn1->degree = tp1; mn1->resultat = liste; } } if(av == tvr) /*The computation of the determinants of order i+1 is finished: break*/ break; /*tvr will be the index of the next determinant: for example for lg+1 = 4,and i+1 = 2, the order for the indexes is the following: 0011,0101,0110,1001,1010,1100*/ ttvr = tvr; atvr = 0xFFFF; tp = 0; tp1 = 0; bvr = 1; while((ttvr & 1) == 0) { ttvr = ttvr >> 1; bvr = (bvr << 1) | 1; tp++; } tttvr = 0; tp++; tp1++; bvr = (bvr << 1 ) | 1; ttvr = ttvr >> 1; while((ttvr & 1) == 1) { ttvr = ttvr >> 1; tttvr = (tttvr << 1) | 1; bvr = (bvr << 1) | 1; tp++; tp1++; } ttvr = (1 << tp) | tttvr; atvr = atvr << tp; tvr = atvr & tvr; tvr = tvr | ttvr; } /*Erase the structure having the last results (determinants of order i)*/ if(boo == 1) mn = stmn.suivant; else mn = stmn1.suivant; while(mn != NULL) { bp = (mn->resultat)->suivant; while(bp != NULL) { SYM_free(bp->tab); liste = bp; bp = bp->suivant; SYM_free((signed char *)liste); } mn1 = mn; mn = mn->suivant; SYM_free((signed char *)(mn1->resultat)); SYM_free((signed char *)mn1); } boo = -boo; } /* End of the loop for(i = 1 ;i < lg ; i++) */ } /* End of the condition lg != 1 */ } return OK; } /* is used by plth3 to compute product of \psi^outer(S_inner), in the basis of Schur functions, where outer and inner are partitions. */ static INT calculi(sch,inner,outer,dep) signed char *outer, *inner, *sch; struct liste *dep; { struct liste *bp, *entree; register signed char *bs, tp; signed char pas, tmp,we; pas=0; bs=inner; while(*bs) pas+= *bs++; tmp= -1; bs=sch; while(*bs) tmp+= *bs++; we=tmp; entree=(struct liste *) SYM_MALLOC(sizeof(struct liste)); entree->coef= 1L; entree->tab= sch; entree->suivant=NULL; while(*outer) { while(entree!=NULL) { if(tmp== we) { gvr=0; calcul(inner,(int) *outer,entree->tab,dep,entree->coef,1,*outer+1); } else { bs=entree->tab; while(*bs) bs++; bs--; tp=tmp; for(;;) { *bs -=tp; if(bs==entree->tab) break; bs--; tp--; } gvr=0; calcul(inner,(int) *outer,entree->tab,dep,entree->coef,1,*outer+1); } SYM_free(entree->tab); bp=entree; entree=entree->suivant; SYM_free((signed char *)bp); } tmp += ((*outer)*pas); entree=dep->suivant; dep->suivant=NULL; outer++; } dep->suivant=entree; return OK; } static INT calcula(inner,np,pa,res) signed char *inner,np; OP res; OP pa; { OP crc,pb,cb,cf,tr; register signed char *bs,tp; INT i; signed char pas,av,tmp,lb,lim,*outer,*bouter; struct liste str, *bp, *db,*entree; if (S_O_K(res) != SCHUR) error("calcula:res != SCHUR"); pas=0; bs=inner; while(*bs) pas+= *bs++; if(booo==0) lim= *(bs-1); else lim=bs-inner; db=(struct liste *)SYM_MALLOC(sizeof(struct liste)); db->coef= 1L; db->tab= (signed char *)SYM_calloc(1,1); db->suivant=NULL; str.suivant=NULL; cb=callocobject();cf=callocobject(); crc=callocobject(); m_part_sc(pa,crc); for(i=0L;itab==0) { gvr=0; calcul(inner,(int) *bouter,entree->tab,&str,1,1,*bouter); entree=entree->suivant; }/*End of if(*entree->tab==0)*/ else { bs=entree->tab; while(*bs) bs++; bs--; tp=tmp; for(;;) { *bs -=tp; if(bs==entree->tab) break; bs--; tp--; } gvr=0; calcul(inner,(int) *bouter,entree->tab,&str,entree->coef,1,*bouter+1); SYM_free(entree->tab); bp=entree; entree=entree->suivant; SYM_free((signed char *)bp); }/*End of else of if(*entree->tab==0)*/ }/*End of while(entree!=NULL)*/ if(*(bouter+1)!=0) { tmp += *bouter*pas; entree=str.suivant; } else { tr=callocobject(); bs=outer; /*Suppress cb=callocobject(); CC 24/01/97*/ M_I_I(1L,cb);av=0; while(*bs) { M_I_I(*bs,cf); mult_apply(cf,cb); if(*bs==av) { tp++; M_I_I(tp,cf); mult_apply(cf,cb); } else tp = 1; av= *bs; bs++; } div(S_SC_WI(crc,i),cb,cf); t_list_coef_SYM(&str,cf,np,tr); /*CC 24/01/97*/ freeself(cb); freeself(cf); if(nullp(res)) { copy(tr,res); freeall(tr); /* CC 24/07/97*/ } else { insert(tr,res,add_koeff,cmp); } } str.suivant=NULL; bouter++; }/*End of while(*bouter!=0)*/ SYM_free(outer); }/*End of if(S_I_I(S_SC_WI(...)*/ }/*End of for(i=0L;i<...*/ SYM_free(db->tab); SYM_free((char *) db); freeall(crc);/**/ freeall(cf); freeall(cb);/* suppress CC 24/01/97 */ return OK; } /* Input os,on,opsi. Output ores make the product of S_os by the plethysm \psi_on(S_psi) cond3==0=> limits upon length cond3==1=> limits upon the biggest part */ static INT plth1(os,on,opsi,cond3,ores) OP os,on,opsi,ores;char cond3; { register signed char *bs,i,j; register struct liste *bp; int tmp; /* AK 210199 */ signed char li,lj,inv,tp,n,*s,*psi; struct liste stdep,*dep; OP sc,ve,cf,pol,d; if(S_O_K(os)!=INTEGER && S_O_K(os)!=PARTITION) return error("plth1: wrong first type"); if(S_O_K(opsi)!=INTEGER && S_O_K(opsi)!=PARTITION) return error("plth1: wrong third type"); if(S_O_K(on)!=INTEGER) return error("plth1: wrong second type"); if(lng<0L) { init(SCHUR,ores); return OK; } n=S_I_I(on); if(n<0) { init(SCHUR,ores); return OK; } if(S_O_K(os)==INTEGER) { if(S_I_I(os)<0L) { init(SCHUR,ores); return OK; } sc=callocobject(); if(S_I_I(os)==0L) m_il_v(0L,sc); else { m_il_v(1L,sc); M_I_I(S_I_I(os),S_V_I(sc,0L)); } freeself(os); b_ks_pa(VECTOR,sc,os); } if(n==0) { if(not EMPTYP(ores)) freeself(ores); sc=callocobject(); weight(os,sc); /*CC 240596 to change with the upon the length of os*/ if(S_I_I(sc)==0L) { M_I_I(1L,ores);freeall(sc); return OK; } freeall(sc); m_skn_s(os,cons_eins,NULL,ores); return OK; } if(S_O_K(opsi)==INTEGER) { if(S_I_I(opsi)<0L) { init(SCHUR,ores); return OK; } sc=callocobject(); if(S_I_I(opsi)==0L) m_il_v(0L,sc); else { m_il_v(1L,sc); M_I_I(S_I_I(opsi),S_V_I(sc,0L)); } freeself(opsi); b_ks_pa(VECTOR,sc,opsi); } sc=callocobject(); weight(opsi,sc); /*CC 240596 to change with the upon the length of opsi*/ if(S_I_I(sc)==0L) { freeall(sc); if(not EMPTYP(ores)) freeself(ores); sc=callocobject(); weight(os,sc); /*CC 240596 to change with the upon the length of os*/ if(S_I_I(sc)!=0L) { m_skn_s(os,cons_eins,NULL,ores);freeall(sc); return OK; } else { M_I_I(1L,ores); freeall(sc); return OK; } } freeall(sc); dep= &stdep; dep->suivant=NULL; li=(signed char)S_PA_LI(os); lj=(signed char)S_PA_LI(opsi); if((cond3==1 && (S_PA_II(os,(INT)li-1L)>lng || S_PA_II(opsi,(INT)lj-1L)>lng))||(cond3==0 && (li>lng||lj>lng))) { init(SCHUR,ores); return OK; } if(not EMPTYP(ores)) freeself(ores); if(n==1) { sc=callocobject(); M_I_I(lng,sc); l_outerproduct_schur_lrs(sc,os,opsi,ores); freeall(sc); return OK; } bs=(signed char *)SYM_MALLOC(li+1); s=bs; tp=0; for(i=0;i127) { fprintf(stderr,"Plethysms too big\n"); SYM_free((signed char*)psi); SYM_free((signed char*)s); exit(0); } if(lj>= *bs) { lj--;inv=0; plet_conj(&psi,&lj); } else { inv=1; if(*s) { li--; plet_conj(&s,&li); } } gvr=0; if(cond3==0) booo=inv; else { if(inv==1) booo=0; else booo=1; } calcul(psi,(int) n,s,dep,1L,1,n); bp=dep->suivant; init(SCHUR,ores);d=ores; while(bp!=NULL) { bs=bp->tab; j= -1; while(*bs){ bs++;j++;} bs--; tp=tmp-1; for(i=j;i>=0;i--) { (*bs--) -=tp; tp--; } /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc. THE RESULT ores */ sc = callocobject(); ve = callocobject(); pol=callocobject(); init(VECTOR,ve); if(inv == 1) { conjug( bp->tab , j , ve); } else { bs = bp->tab; m_il_v( (INT)(j+1), ve ); for(i = 0; i<=j ;i++) { M_I_I( (INT)(*bs), S_V_I(ve, (INT) i)); bs++; } } SYM_free(bp->tab); b_ks_pa(VECTOR,ve,sc); cf=callocobject(); M_I_I(bp->coef,cf); b_skn_s(sc,cf,NULL,pol); c_l_n(d,pol);d=pol; dep = bp; bp = bp->suivant; SYM_free((signed char *)dep); } if(S_L_N(ores)!=NULL) { /*CC 24/01/97*/ d=S_L_N(ores); c_l_s(ores,S_L_S(S_L_N(ores))); c_l_n(ores,S_L_N(S_L_N(ores))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } SYM_free((signed char*)psi); SYM_free((signed char*)s); return OK; } /* computes S_m (cond1==0) or \Lambda_m (cond1==1) of S_{tab} (cond2==0) or \Lambda_tab(cond2==1) restricted upon length (cond3==0) or upon parts (cond3==1) */ static INT plth2(tab,cond1,cond2,cond3,m,newton) signed char *tab,cond1,cond2,cond3; int m; struct liste *newton; { signed char *s,*bs,*btab,*baf,*af,*bch,*tab1; char condition,parite,mx,np,npt,le,inv; INT cof; signed char n,in; signed char k; signed char cond,high,mid; register signed char i,j,temp; struct liste str,*bp,*liste,*liste1; le=0; mx=0; btab=tab; while(*btab!=0) { le++; mx += *btab; btab++; } inv=0; if(*(btab - 1) < le) { inv = 1; tab1 = (signed char *)SYM_MALLOC(*(btab - 1) + 1); bs = tab1; btab = tab; af = (signed char *)SYM_MALLOC(le + 1); baf = af; while(*btab != 0) *baf++ = *btab++; *baf = 0; cond = -1; j = le - 1; btab = af + j; mid = *btab; j++; temp = 0; while(j >= 0) { high = 0; while(*btab == mid) { j--; high++; if(j == 0) { *btab = 0; j--; break; } btab--; } temp = temp+high; for(i = *btab;i < mid;i++) { cond++; *bs++ = temp; } mid = *btab; } *bs = 0; SYM_free(af); } else { tab1 = (signed char *)SYM_MALLOC(le + 1); btab = tab; bch = tab1; while(*btab != 0) *bch++ = *btab++; *bch = 0; } booo = 0; if((( cond2 == 0) && (inv == 0)) || ((cond2 == 1) && (inv == 1))) booo = 1; if(cond2 == 0) { if(lng < le) { fprintf(stderr,"No elements of the length %d in this plethysm\n",m); return ERROR; } } else if(lng < *(tab + le - 1)) { fprintf(stderr,"No elements of the length %d in this plethysm\n",m); return ERROR; } liste1 = &str; if ( cond2 == 0) if(cond1 == 0) if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1))) condition = 0; else condition = 1; else if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1))) condition = 1; else condition = 0; else if(cond1 == 0) if((inv == 0) || ((inv == 1) && (mx%2 == 0))) condition = 0; else condition = 1; else if((inv == 0) || ((inv == 1) && (mx%2 == 0))) condition = 1; else condition = 0; liste = (struct liste *)SYM_MALLOC(sizeof(struct liste)); liste->coef = 1L; liste->suivant = NULL; liste1->suivant = liste; bs = (signed char *)SYM_MALLOC(1); liste->tab = bs; *bs = 0; (newton)->suivant = liste1->suivant; for(n = 1;n <= m;n++) { liste1->suivant = NULL; np = n * mx; npt = np; if( n == 1) { liste = (struct liste *)SYM_MALLOC(sizeof(struct liste)); liste->coef = 1L; liste->suivant = NULL; liste1->suivant = liste; if (inv == 0) { bs = (signed char *)SYM_MALLOC(tab[le - 1] + 1); liste->tab = bs; btab = tab; af = (signed char *)SYM_MALLOC(le + 1); baf = af; while(*btab != 0) *baf++ = *btab++; *baf = 0; cond = -1; j = le - 1; btab = af + j; mid = *btab; j++; temp = 0; while(j >= 0) { high = 0; while(*btab == mid) { j--; high++; if(j == 0) { *btab = 0; j--; break; } btab--; } temp = temp+high; for(i = *btab;i < mid;i++) { cond++; *bs++ = temp; } mid = *btab; } *bs = 0; temp = mx - 1; bs--; for(i = 0 ;i <= cond; i++) { (*bs) += temp; temp--; if(i != cond) bs--; } if(bs == NULL) return OK; SYM_free(af); } else { liste->tab = (signed char *)SYM_MALLOC(le + 1); bs = liste->tab + le; *bs-- = 0; btab = tab + le - 1; temp = mx - 1; for(i = 1 ;i <= le; i++) { *bs = *btab + temp; temp--; if(i != le) { btab--; bs--; } } } } else { for(in = 0;in < n;in++) { /* fprintf(stderr,"\nn = %d,in = %d ",n,in); */ if(condition == 1) { i = (n+1+in)%2; if(i == 0) parite = 1; else parite = -1; } else parite = 1; liste = (newton+in)->suivant; while(liste != NULL) { baf = liste->tab; temp = np - npt; s = (signed char *)SYM_MALLOC(temp + 1); if(temp != 0) { temp--; j = 0; while(*baf != '\0') { j++; baf++; } baf--; btab = s + j; *btab-- = 0; for(k = j-1;k >= 0;k--) { *btab = (*baf) - temp; if(k != 0) { btab--; baf--; temp--; } } } else *s = '\0'; cof = liste->coef; gvr = 0; if(cond3==1) { if(booo==1) booo=0; else booo=1; } calcul(tab1,(int) n - in,s,liste1,cof,parite,n); if(cond3==1) { if(booo==1) booo=0; else booo=1; } SYM_free(s); liste = liste->suivant; } npt = npt - mx; } /* End of the loop for (in = 0;in < n ;in++) */ } liste = liste1->suivant; while(liste != NULL) { liste->coef = liste->coef/n; liste = liste->suivant; } (newton+n)->suivant = liste1->suivant; } /* End of the loop with n*/ liste = newton + 1; for(in=1;in<=m;in++) { bp = liste->suivant; k = in * mx; /*We read the Schur functions which are expressions of Sin(Sp), to express them by their diagonal indices*/ while(bp != NULL) { btab = bp->tab; j = -1; while(*btab != '\0') { btab++; j++; } btab--; temp = k-1; for(i = j;i > 0;i--) { (*btab--) -= temp; temp--; } *btab -=temp; af=(signed char *)SYM_MALLOC(j+2); baf=af; btab=bp->tab+j; for(i=0;itab=af; bp = bp->suivant; } liste++; } SYM_free(tab1); return OK; } /* Puts in c the decomposition of the plethysm \psi^a(S_b) where a and b are partitions, in the basis of Schur functions cond3==0=> retriction upon length. cond3==1=> restriction upon parts. */ static INT plth3(a,b,cond3,c) OP a,b,c; signed char cond3; { OP sc,d,pol,ve,cf; signed char *inner,*outer,*sch; signed char tp,la,lb,inv,tmp,j; struct liste *dep,str,*bp; register signed char i,*bs; if(S_O_K(a)!=INTEGER && S_O_K(a)!=PARTITION) return error("plth3: wrong first type"); if(S_O_K(b)!=INTEGER && S_O_K(b)!=PARTITION) return error("plth3: wrong second type"); if(S_O_K(b)==INTEGER) { if(S_I_I(b)<0L) { init(SCHUR,c);return OK; } if(S_I_I(b)==0L) { freeself(c);M_I_I(1L,c);return OK; } sc=callocobject(); m_il_v(1L,sc); M_I_I(S_I_I(b),S_V_I(sc,0L)); freeself(b);b_ks_pa(VECTOR,sc,b); } if(S_O_K(a)==INTEGER) { if(S_I_I(a)<0L) { init(SCHUR,c);return OK; } if(S_I_I(a)==0L) { freeself(c);M_I_I(1L,c);return OK; } sc=callocobject(); M_I_I(0L,sc); plth1(sc,a,b,cond3,c); freeall(sc); return OK; } if(S_PA_LI(a)==0L || S_PA_LI(b)==0L) { freeself(c); M_I_I(1L,c); return OK; } if(S_PA_LI(a)==1L) { sc=callocobject(); M_I_I(0L,sc); plth1(sc,S_PA_I(a,0L),b,cond3,c); freeall(sc); return OK; } lb= (signed char)S_PA_LI(b); if((cond3==1 && S_PA_II(b,(INT)lb-1L)>lng )||(cond3==0 && lb>lng)) { init(SCHUR,c); return OK; } bs=(signed char *)SYM_MALLOC(lb+1); inner=bs; tp=0; for(i=0;i= *bs) { lb--;inv=0; plet_conj(&inner, &lb); } la=(signed char ) S_PA_LI(a); bs=(signed char *)SYM_MALLOC(la+1); outer=bs; tmp=0; for(i=0;i 127) return error("plth3: plethysm too big"); */ if(cond3==0) booo=inv; else if(inv==1) booo=0; else booo=1; dep= &str; str.suivant=NULL; sch=(signed char *)SYM_calloc(1,1); calculi(sch,inner,outer,dep); tmp--; bp=dep->suivant; init(SCHUR,c);d=c; while(bp!=NULL) { bs=bp->tab; j= -1; while(*bs){ bs++;j++;} bs--; tp=tmp; for(i=j;i>=0;i--) { (*bs--) -=tp; tp--; } /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc. THE RESULT c */ sc = callocobject(); ve = callocobject(); pol=callocobject(); init(VECTOR,ve); if(inv == 1) { conjug( bp->tab , j , ve); } else { bs = bp->tab; m_il_v( (INT)(j+1), ve ); for(i = 0; i<=j ;i++) { M_I_I( (INT)(*bs), S_V_I(ve, (INT) i)); bs++; } } SYM_free(bp->tab); b_ks_pa(VECTOR,ve,sc); cf=callocobject(); M_I_I(bp->coef,cf); b_skn_s(sc,cf,NULL,pol); c_l_n(d,pol);d=pol; dep = bp; bp = bp->suivant; SYM_free((signed char *)dep); } if(S_L_N(c)!=NULL) { /*CC 24/01/97*/ d=S_L_N(c); c_l_s(c,S_L_S(S_L_N(c))); c_l_n(c,S_L_N(S_L_N(c))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } SYM_free(outer); SYM_free(inner); return OK; } /* Puts in c the decomposition of the product S_os * \psi^a(S_b) where a and b are partitions, in the basis of Schur functions cond3==0=> retriction upon length. cond3==1=> restriction upon parts. */ static INT plth5(os,a,b,cond3,c) OP os,a,b,c; signed char cond3; { OP sc,d,pol,ve,cf; signed char *inner,*outer,*sch; signed char tp,la,lb,inv,tmp,j,los,pdos; struct liste *dep,str,*bp; register signed char i,*bs; if(S_O_K(a)!=INTEGER && S_O_K(a)!=PARTITION) return error("plth5: wrong second type"); if(S_O_K(b)!=INTEGER && S_O_K(b)!=PARTITION) return error("plth5: wrong third type"); if(S_O_K(os)!=INTEGER && S_O_K(os)!=PARTITION) return error("plth5: wrong first type"); if(lng<0){init(SCHUR,c); return OK;} if(S_O_K(os)==INTEGER) { if(S_I_I(os) <0L) { init(SCHUR,os); return OK; } else { sc=callocobject(); if(S_I_I(os) == 0L) m_il_v(0L,sc); else { m_il_v(1L,sc); M_I_I(S_I_I(os),S_V_I(sc,0L)); } freeself(os); b_ks_pa(VECTOR,sc,os); } } if(cond3==0 && S_PA_LI(os) > lng) { init(SCHUR,c);return OK; } if(S_PA_LI(os) > 0 && (cond3==1 && S_PA_II(os,S_PA_LI(os)-1L)>lng)) { init(SCHUR,c);return OK; } if(S_O_K(b)==INTEGER) { if(S_I_I(b)<0L) { init(SCHUR,c);return OK; } if(S_I_I(b)==0L) { freeself(c);m_skn_s(os,cons_eins,NULL,c);return OK; } sc=callocobject(); m_il_v(1L,sc); M_I_I(S_I_I(b),S_V_I(sc,0L)); freeself(b);b_ks_pa(VECTOR,sc,b); } if(S_O_K(a)==INTEGER) { if(S_I_I(a)<0L) { init(SCHUR,c);return OK; } if(S_I_I(a)==0L) { freeself(c);m_skn_s(os,cons_eins,NULL,c);return OK; } plth1(os,a,b,cond3,c); return OK; } if(S_PA_LI(a)==0L || S_PA_LI(b)==0L) { freeself(c);m_skn_s(os,cons_eins,NULL,c); return OK; } if(S_PA_LI(a)==1L) { plth1(os,S_PA_I(a,0L),b,cond3,c); return OK; } lb= (signed char)S_PA_LI(b); if((cond3==1 && S_PA_II(b,(INT)lb-1L)>lng )||(cond3==0 && lb>lng)) { init(SCHUR,c); return OK; } los=S_PA_LI(os); bs=(signed char *)SYM_MALLOC(los+1); sch=bs; pdos=0; for(i=0;i= *bs) { lb--;inv=0; plet_conj(&inner, &lb); } else { inv=1; if(*sch!=0) { los--; plet_conj(&sch,&los); } } la=(signed char ) S_PA_LI(a); bs=(signed char *)SYM_MALLOC(la+1); outer=bs; tmp=0; for(i=0;i 127) return error("plth3: plethysm too big"); */ if(cond3==0) booo=inv; else if(inv==1) booo=0; else booo=1; dep= &str; str.suivant=NULL; calculi(sch,inner,outer,dep); tmp--; bp=dep->suivant; init(SCHUR,c);d=c; while(bp!=NULL) { bs=bp->tab; j= -1; while(*bs){ bs++;j++;} bs--; tp=tmp; for(i=j;i>=0;i--) { (*bs--) -=tp; tp--; } /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc. THE RESULT c */ sc = callocobject(); ve = callocobject(); pol=callocobject(); init(VECTOR,ve); if(inv == 1) { conjug( bp->tab , j , ve); } else { bs = bp->tab; m_il_v( (INT)(j+1), ve ); for(i = 0; i<=j ;i++) { M_I_I( (INT)(*bs), S_V_I(ve, (INT) i)); bs++; } } SYM_free(bp->tab); b_ks_pa(VECTOR,ve,sc); cf=callocobject(); M_I_I(bp->coef,cf); b_skn_s(sc,cf,NULL,pol); c_l_n(d,pol);d=pol; dep = bp; bp = bp->suivant; SYM_free((signed char *)dep); } if(S_L_N(c)!=NULL) { /*CC 24/01/97*/ d=S_L_N(c); c_l_s(c,S_L_S(S_L_N(c))); c_l_n(c,S_L_N(S_L_N(c))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } SYM_free(outer); SYM_free(inner); /*Ne pas liberer sch: ca a ete fait dans calculi*/ return OK; } static INT conjugate_apply_schur(a) OP a; /* afterwards a is no longer ordered */ { OP tmp,z; if(S_O_K(a)==SCHUR) { if(not nullp(a)) { z=a; while(z!=NULL) { tmp=callocobject(); conjugate_partition(S_S_S(z),tmp); copy(tmp,S_S_S(z)); freeall(tmp); z=S_L_N(z); } } } return OK; } /* Puts in c the decomposition of the plethysm S_a(S_b) where a and b are partitions, in the basis of Schur functions cond3==0=> retriction upon length. cond3==1=> restriction upon parts. */ INT cc_plet_pss_integer_partition(a,b,c,f) OP a,b,c,f; /* to call from pss_integer_partition */ { INT erg = OK; OP d; CTO(INTEGER,"cc_plet_pss_integer_partition_(1)",a); CTO(PARTITION,"cc_plet_pss_integer_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"cc_plet_pss_integer_partition_(3)",c); if (S_PA_LI(b) == 0) { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(f,S_MO_K(m)); COPY(b,S_MO_S(m)); if (S_O_K(c) == SCHUR) insert_list(m,c,add_koeff,comp_monomschur); else insert_scalar_hashtable(m,c,add_koeff,eq_monomsymfunc,hash_monompartition); goto ende; } d = CALLOCOBJECT(); erg += schur_schur_plet(a,b,d); CTO(SCHUR,"cc_plet_pss_integer_partition(i1)",d); MULT_APPLY(f,d); if (S_O_K(c) == SCHUR) insert_list_list(d,c,add_koeff,comp_monomschur); else insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition); ende: ENDR("cc_plet_pss_integer_partition"); } INT cc_plet_phs_integer_partition(a,b,c,f) OP a,b,c,f; /* to call from phs_integer_partition */ /* AK 2002 */ /* AK 210704 V3.0 */ { INT erg = OK; CTO(INTEGER,"cc_plet_phs_integer_partition_(1)",a); CTO(PARTITION,"cc_plet_phs_integer_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"cc_plet_phs_integer_partition_(3)",c); { OP d; d = CALLOCOBJECT(); erg += complete_schur_plet(a,b,d); CTO(SCHUR,"cc_plet_phs_integer_partition(i1)",d); MULT_APPLY(f,d); if (S_O_K(c) == SCHUR) insert_list_list(d,c,add_koeff,comp_monomschur); else insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition); } ENDR("cc_plet_phs_integer_partition"); } INT cc_plet_pes_integer_partition(a,b,c,f) OP a,b,c,f; /* to call from pes_integer_partition */ { INT erg = OK; OP d; CTO(INTEGER,"cc_plet_pes_integer_partition_(1)",a); CTO(PARTITION,"cc_plet_pes_integer_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"cc_plet_pes_integer_partition_(3)",c); d = CALLOCOBJECT(); erg += elementary_schur_plet(a,b,d); CTO(SCHUR,"cc_plet_phs_integer_partition(i1)",d); MULT_APPLY(f,d); if (S_O_K(c) == SCHUR) insert_list_list(d,c,add_koeff,comp_monomschur); else insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition); ENDR("cc_plet_pes_integer_partition"); } INT cc_plet_pss_partition_partition(a,b,c,f) OP a,b,c,f; /* to call from pss_partition_partition */ { INT erg = OK; OP d; CTO(PARTITION,"cc_plet_pss_partition_partition_(1)",a); CTO(PARTITION,"cc_plet_pss_partition_partition_(2)",b); CTTO(SCHUR,HASHTABLE,"cc_plet_pss_partition_partition_(3)",c); d = CALLOCOBJECT(); erg += schur_schur_plet(a,b,d); CTO(SCHUR,"cc_plet_pss_integer_partition(i1)",d); MULT_APPLY(f,d); if (S_O_K(c) == SCHUR) insert_list_list(d,c,add_koeff,comp_monomschur); else insert_schur_hashtable(d,c,add_koeff,eq_monomsymfunc,hash_monompartition); ENDR("cc_plet_pss_partition_partition"); } /* Puts in c the decomposition of the plethysm S_a(S_b) where a and b are partitions, in the basis of Schur functions cond3==0=> retriction upon length. cond3==1=> restriction upon parts. */ static INT plth4(a,b,cond3,c) OP a,b,c; signed char cond3; { OP sc; signed char *inner; signed char tp,lb,inv,tmp; register signed char i,*bs; if(S_O_K(a)!=INTEGER && S_O_K(a)!=PARTITION) return error("plth4: wrong first type"); if(S_O_K(b)!=INTEGER && S_O_K(b)!=PARTITION) return error("plth4: wrong second type"); if(S_O_K(b)==INTEGER) { if(S_I_I(b)<0L) { init(SCHUR,c);return OK; } if(S_I_I(b)==0L) { freeself(c);M_I_I(1L,c);return OK; } sc=callocobject(); m_il_v(1L,sc); M_I_I(S_I_I(b),S_V_I(sc,0L)); freeself(b);b_ks_pa(VECTOR,sc,b); } if(S_O_K(a)==INTEGER) { if(S_I_I(a)<0L) { init(SCHUR,c);return OK; } if(S_I_I(a)==0L) { freeself(c);M_I_I(1L,c);return OK; } sc=callocobject(); m_il_v(1L,sc); M_I_I(S_I_I(a),S_V_I(sc,0L)); freeself(a);b_ks_pa(VECTOR,sc,a); } if(S_PA_LI(a)==0L || S_PA_LI(b)==0L) { freeself(c); M_I_I(1L,c); return OK; } lb= (signed char)S_PA_LI(b); if((cond3==1 && S_PA_II(b,(INT)lb-1L)>lng )||(cond3==0 && lb>lng)) { init(SCHUR,c); return OK; } bs=(signed char *)SYM_MALLOC(lb+1); inner=bs; tp=0; for(i=0;i= *bs) { lb--;inv=0; plet_conj(&inner, &lb); } sc=callocobject(); weight(a,sc); tmp = tp*(char)S_I_I(sc); freeall(sc); /* gcc: comparison is always 0 due to limited range of data type if(tmp > 127) return error("plth4: plethysm too big"); */ if(cond3==0) booo=inv; else if(inv==1) booo=0; else booo=1; init(SCHUR,c); calcula(inner,tmp-1,a,c); if(inv==1) conjugate_apply_schur(c); SYM_free(inner); return OK; } /* Insert a Schur function in a sorted list, the partition being read from the right. Partition begins at *af */ /* NOT TESTED */ #ifdef UNDEF static INT ins_s_lst(af,coef,plst) signed char *af; INT coef; struct liste **plst; { register struct liste *bp,*bpp; struct liste *bc; signed char *db; register signed char *baf,*btab; bpp= *plst; bp=bpp->suivant; baf=af; while(*baf) baf++; db = --baf; while(bp!=NULL) { baf=db; btab=bp->tab; while(*btab) btab++; btab--; for(;;) { if(*baf < *btab) goto out1; if(*baf > *btab) goto out2; if(baf==af) goto out3; baf--; btab--; } out1: bpp=bp; bp=bp->suivant; } /* On sort avec bp==NULL ou avant un plus grand element dans la liste */ out2: bc=(struct liste *)SYM_MALLOC(sizeof(struct liste)); bc->coef=coef; bc->suivant=bp; btab=(signed char *)SYM_MALLOC(db+2); baf=af; bc->tab=btab; while(*baf) *btab++ = *baf++; *btab=0; bpp->suivant=bc; *plst=bpp; return OK; /* l'element existe deja dans la liste */ out3: if(coef== -bp->coef) { bpp->suivant=bp->suivant; SYM_free(bp->tab); SYM_free((char *)bp); } else bp->coef +=coef; *plst=bpp; return OK; } #endif /* list2 est le shuffle des 2 listes triees a partir de la fin sig*lst1 et lst2 sig*lst1 signifie que le champ coef de toutes les cellules est multiplie par sig */ /* static INT shuffle_sg(lst1,sig,lst2) register struct liste *lst1; struct liste *lst2; signed char sig; { lst1=lst1->suivant; while(lst1!= NULL) { ins_s_lst(lst1->tab,lst1->coef*sig,&lst2); lst1=lst1->suivant; } return OK; } */ /* insert a Schur function in a sorted list Partition begins at *af */ static INT ins_sc_lst(af,coef,plst) signed char *af; INT coef; struct liste **plst; { register struct liste *bp,*bpp; struct liste *bc; register signed char *baf,*btab; bpp= *plst; bp=bpp->suivant; while(bp!=NULL) { baf=af; btab=bp->tab; while(*baf!=0) { if(*baf < *btab) goto out1; if(*baf > *btab) goto out2; baf++;btab++; } goto out3; out1: bpp=bp; bp=bp->suivant; } /* On sort avec bp==NULL ou avant un plus grand element dans la liste */ out2: bc=(struct liste *)SYM_MALLOC(sizeof(struct liste)); bc->coef=coef; bc->suivant=bp; baf=af; while(*baf++); btab=(signed char *)SYM_MALLOC(baf-af+1); baf=af; bc->tab=btab; while(*baf) *btab++ = *baf++; *btab=0; bpp->suivant=bc; *plst=bpp; return OK; /* l'element existe deja dans la liste */ out3: if(coef== -bp->coef) { bpp->suivant=bp->suivant; SYM_free(bp->tab); SYM_free((char *)bp); } else bp->coef +=coef; *plst=bpp; return OK; } /* list2 est le shuffle des 2 listes triees sig*lst1 et lst2 sig*lst1 signifie que le champ coef de toutes les cellules est multiplie par sig */ static INT shuffle_sig(lst1,sig,lst2) register struct liste *lst1; struct liste *lst2; signed char sig; { lst1=lst1->suivant; while(lst1!= NULL) { ins_sc_lst(lst1->tab,lst1->coef*sig,&lst2); lst1=lst1->suivant; } return OK; } /* frees a list */ static INT free_lst (lst) register struct liste *lst; { struct liste *lst1,*bp; lst1=lst; lst=lst->suivant; while(lst!=NULL) { SYM_free(lst->tab); bp=lst; lst=lst->suivant; SYM_free((signed char *)bp); } lst1->suivant=NULL; return OK; } /* frees a tableau of struct liste tiil the rank n */ /* CC 24/01/97 */ static INT free_newton(newton, n) struct liste *newton; int n; { for(; n>=0; n--) { free_lst(newton); newton++; } return OK; } /* returns the weight of partitions of a list */ static INT poids (lst) struct liste *lst; { register signed char *btab; register signed char tmp=0; lst=lst->suivant; if(lst!=NULL) { btab=lst->tab; while(*btab) { tmp+= *btab; btab++; } } return((INT)tmp); } /* insere une fonction de Schur dans une liste *af est la taille de la partition */ static INT ins_sch_lst(af,coef,plst) signed char *af; INT coef; struct liste **plst; { register struct liste *bp,*bpp; struct liste *bc; register signed char *baf,*btab; bpp= *plst; bp=bpp->suivant; while(bp!=NULL) { baf=af+1; btab=bp->tab; while(*baf!=0) { if(*baf < *btab) goto out1; if(*baf > *btab) goto out2; baf++;btab++; } goto out3; out1: bpp=bp; bp=bp->suivant; } /* On sort avec bp==NULL ou avant un plus grand element dans la liste */ out2: bc=(struct liste *)SYM_MALLOC(sizeof(struct liste)); bc->coef=coef; bc->suivant=bp; baf=af; btab=(signed char *)SYM_MALLOC(*baf+1); baf++; bc->tab=btab; while(*baf) *btab++ = *baf++; *btab=0; bpp->suivant=bc; *plst=bpp; return OK; /* l'element existe deja dans la liste */ out3: if(coef== -bp->coef) { bpp->suivant=bp->suivant; SYM_free(bp->tab); SYM_free((signed char *)bp); } else bp->coef +=coef; *plst=bpp; return OK; } /* met dans lst le produit de S_fi par S_ev produit restreint aux partitions dont les parts sont <= mx lst est une liste a entete et peut ne pas etre vide (lst->suivant!= NULL) retourne l'adresse de la cellule precedent la premiere cellule de la liste qui a ete modifie va plus vite si le poids de fi est superieur que le poids de ev Algo sophistique */ static struct liste * proprt(fi,ev,coef1,coef2,mx,lst) signed char *fi,*ev,mx; INT coef1,coef2; struct liste *lst; { INT cmt; INT coef; signed char etat,ssetat=0,bas=0,ev_niv,ym; signed char nb_lt,lg_fi,lg_tb,lg_tb_dct,lg_old; signed char i,j=0,k,tmp,tp,dsp,topc,topd,pds,av,fr=0; register signed char niv; signed char sz_pcar,sz_plst,sz_lst; signed char **tb,**nb_tb,**ctb,**dtb,**etb,**ftb,**gtb,**htb; register signed char **btb,**bnb_tb,**byam; signed char **yam; signed char *af,*bfi,*bev,*pos,*bpos; register signed char *baf; struct liste **pl,**bpl,*bpc,*lst1; cmt=1L; /* Faire un test si il y a des termes ou pas */ if((*fi > mx)|| (*ev > mx)) return lst; /* nb_lt nombre de lettres lg_fi longueur de la forme interieure */ baf=ev; nb_lt= 0; while(*baf++) nb_lt++; baf=fi; lg_fi= 0; while(*baf++) lg_fi++; /* lg_fi=*fi;nb_lt=*ev; */ sz_pcar= sizeof(signed char *); /* Dimension d'un pointeur sur caractere*/ sz_plst= sizeof(struct liste *); /*Dimension de pointeur sur structure liste*/ sz_lst= sizeof(struct liste); /* Dimension sur structure liste*/ lg_tb= lg_fi+nb_lt; /* Longueur maximum des tableaux resultat*/ /* Creation de 3 tableaux bidimensionnels avec pour nombre de lignes lg_tb */ tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar); nb_tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar); yam=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar); btb=tb; bnb_tb=nb_tb;byam=yam; for(i=0;i<=lg_tb+2;i++) { *btb++ =(signed char *)SYM_calloc(nb_lt+3,1); *bnb_tb++ =(signed char *)SYM_calloc(nb_lt+3,1); *byam++ =(signed char *)SYM_calloc(nb_lt+3,1); } *btb=NULL;*bnb_tb =NULL;*byam=NULL; /* Construction d'un tableau de taille lg_tb+3 */ af=(signed char *)SYM_calloc(lg_tb+3,1); /* Creation d'un tableau de dimension nb_lt + 2 ou on met les sommes cumulees du vecteur d'evaluation pds: poids de la partition composee des parts de la partition */ pos=(signed char *)SYM_MALLOC(nb_lt+2); bpos=pos; *bpos++ =0; bev=ev;av=0; for(i=1;i<=nb_lt;i++) { *bpos = av+ *bev; av= *bpos; bev++;bpos++; } pds= *--bpos; /* Creation d'un tableau de pointeurs sur struct liste de dimension pds pour l'insertion d'un tableau dans la liste des tableaux */ pl=(struct liste **)SYM_MALLOC((pds+2)*sz_plst); /* Initialisation de tb selon fi */ **tb=mx; btb=tb+1; bfi=fi; for(i=1;i<=lg_fi;i++) { tmp= *bfi; bpos= *btb; for(j=0;j<=nb_lt+1;j++) { *bpos++ = tmp; } bfi++;btb++; } /* Remplissage des tableaux */ btb=tb; bev=ev; bnb_tb=nb_tb+1; byam=yam+1; dsp = *bev; ctb=btb; dtb= btb+1; etb= bnb_tb; while(dsp!= 0) { topc= **ctb; topd= **dtb; tmp= topc-topd; if(tmp>=dsp) { /* dsp etant different de 0, tmp est > 0 */ *(*byam+1)=99; *(*etb+1)=dsp; tmp= **dtb+dsp; bpos = *dtb+1; for(j=1;j<=nb_lt+1;j++) *bpos++ = tmp; break; } *(*byam+1)=99; *(*etb+1)=tmp; dsp -= tmp; tmp= **dtb+tmp; bpos= *dtb+1; for(j=1;j<=nb_lt+1;j++) *bpos++ = tmp; ctb++;dtb++;etb++;byam++; }/* Fin du while(dsp !=0)*/ bev++;btb++; byam=yam+1; for(i=2;i<=nb_lt;i++) { dsp= *bev; ctb=btb; dtb=btb+1; etb= bnb_tb; ftb=bnb_tb+1; gtb=byam; htb=byam+1; k=i; while(dsp !=0) { topc= *(*ctb+i-1); topd= *(*dtb+i-1); tmp=topc-topd; ym= *(*gtb+i) + *(*etb+i-1); if(ym=dsp) { /* dsp etant different de 0, tmp est > 0 */ *(*ftb+i)=dsp; *(*htb+i)= ym - dsp; tmp= *(*dtb+i-1)+dsp; bpos= *dtb+i; for(j=i;j<=nb_lt+1;j++) *bpos++ = tmp; break; }/* if(tmp>=dsp) */ *(*ftb+i)=tmp; *(*htb+i)= ym - tmp; dsp -=tmp; tmp= *(*dtb+i-1)+tmp; bpos= *dtb+i; for(j=i;j<=nb_lt+1;j++) *bpos++ = tmp; ctb++;dtb++; etb++;ftb++; gtb++;htb++; k++; }/*while(dsp != 0)*/ k++; gtb++;htb++;etb++; for(;k<=lg_tb;k++) { *(*htb+i)= *(*gtb+i)+ *(*etb+i-1); htb++;gtb++;etb++; } bev++;btb++;bnb_tb++;byam++; }/*for(i=2;i<=nb_lt;i++)*/ baf=af+1; btb=tb+1; for(i=1;i<= lg_tb+1;i++) { tmp= *(*btb+nb_lt); *baf= tmp; if(tmp==0) break; baf++;btb++; } lg_tb_dct=i-1; **tb=0; coef=coef1*coef2; bpl=pl+1; for(i=1;i<=pds;i++) *bpl++ =lst; *af=lg_tb_dct; ins_sch_lst(af,coef,&lst); lst1=lst; /* Debut de l'algorithme */ niv=nb_lt; lg_old=lg_tb_dct; etat=0; while(niv>0) { switch(etat) { case 0: /* Depilage: Essai de placer les lettres plus haut dans le tableau */ ev_niv=ev[niv-1]; baf=af+lg_tb_dct; btb=tb+lg_tb_dct; bnb_tb=nb_tb+lg_tb_dct; i= ev_niv;j=lg_tb_dct; av=lg_tb_dct+1; while(i>0) { /* Chaque lettre i de valeur niv est testee. */ if(*(*bnb_tb+ niv)==0) { bnb_tb--;btb--; j--;baf--; } else { ctb=btb;dtb=btb+1; for(k=j+1;k<=av;k++) { /* On teste ou la mettre plus haut dans le tableau tb*/ topc= *(*ctb+niv-1); topd= *(*dtb+niv); if(topc>topd) { /*SUCCES: On enleve cette lettre niv de la ligne j pour la mettre plus haut dans le tableau*/ etat=1;fr=niv; (*(*btb+niv))--; (*baf)--;(*(*bnb_tb+niv))--; byam=yam+j; (*(*byam+niv))++;tp= *(*byam+niv); byam++;j++; for(;jtopd)*/ ctb++;dtb++; }/*for(k=j+1;k<=av;k++)*/ if(etat==1)break; tp= *(*bnb_tb+niv);av=j;i-=tp; bnb_tb--;btb--;j--;baf--; }/*else du if(*(*bnb_tb+niv)==0)*/ }/*while(i>0)*/ if(etat==1)break; if(*(*(tb+lg_tb_dct)+niv-1)==0) lg_tb_dct--; niv--; break;/*Sortie du case 0*/ case 1: if(ssetat==0) { /* On commence a placer la premiere lettre de valeur niv */ i=1;j=niv; /* premiere lettre niv*/ btb=tb+j;byam=yam+j;baf=af+j; bnb_tb=nb_tb+j; } /*j est forcement > 1*/ /*Essai de placer toutes les lettres niv de i a ev_niv*/ ev_niv=ev[niv-1]; while((j<=lg_tb_dct)||(i<=ev_niv)) { topc= *(*(btb-1)+niv-1); topd= *(*btb+niv-1); tmp=topc-topd; ym= *(*(byam-1)+niv)+ *(*(bnb_tb-1)+niv-1); if((tmp>0)&&(ym>0)) { if(tmp>ym)tmp=ym; dsp=ev_niv-i+1; if(tmp>dsp)tmp=dsp; *(*byam+niv) =ym-tmp; *(*bnb_tb+niv)=tmp; *(*btb+niv)=topd+tmp; *baf=topd+tmp; i+=tmp; if(j>lg_tb_dct) { lg_tb_dct++; } } else { *(*byam+niv)=ym; *(*btb+niv) =topd; *baf=topd; *(*bnb_tb+niv)=0; } btb++;bnb_tb++;byam++;baf++;j++; } topd= *(*btb+niv-1); for(;j<=lg_old;j++) { *(*btb+niv)=topd; btb++; } niv++;ssetat=0; break;/*Sortie de case 1*/ } if(niv >nb_lt) { etat=0; if(lg_tb_dctsuivant; bnv1=res; res->tab=(signed char *)SYM_calloc(2,1);*(res->tab)=99; while(lst1!=NULL) { bp=lst2->suivant; if(strcmp((char *) lst1->tab,(char *) bnv1->tab)>0) bnv1=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,bnv1); else bnv1=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,res); bnv2=bnv1; bp=bp->suivant; while(bp!=NULL) { if(strcmp((char *) lst1->tab,(char *) bnv2->tab)>0) bnv2=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,bnv2); else bnv2=proprt(lst1->tab,bp->tab,lst1->coef,bp->coef,mx,res); bp=bp->suivant; } lst1=lst1->suivant; } return OK; } /* met dans lst le produit de S_fi par S_ev produit restreint aux partitions de longueur <=lg lst est une liste a entete et peut ne pas etre vide (lst->suivant!= NULL) retourne l'adresse de la cellule precedent la premiere cellule de la liste qui a ete modifie va plus vite si le poids de fi est superieur que le poids de ev */ static struct liste * pro_lg(fi,ev,coef1,coef2,lg,lst) INT coef1,coef2; signed char lg; signed char *fi,*ev; struct liste *lst; { INT cmt; INT coef; signed char etat,ssetat,bas=0,ev_niv,ym; signed char nb_lt,lg_fi,lg_tb,lg_tb_dct,lg_tb_dct0=0,lg_old; signed char i,j=0,k,tmp,tp,dsp,topc,topd,pds,av,ttp=0,fr=0,niv0=0; register signed char niv; signed char sz_pcar,sz_plst,sz_lst; signed char **tb,**nb_tb,**ctb,**dtb; signed char **yam,**bbyam; register signed char **btb,**bnb_tb,**byam; signed char *af,*bfi,*bev,*baf,*pos,*bpos; struct liste **pl,**bpl,*bpc,*lst1; cmt=1L; nb_lt= 0; /* Nombre de lettres*/ baf=ev; while(*baf++) nb_lt++; lg_fi= 0; /* Longueur de la forme interieure*/ baf=fi; while(*baf++) lg_fi++; if((lg_fi >lg)||(nb_lt >lg)) { return lst; } sz_pcar= sizeof(signed char *); /* Dimension d'un pointeur sur caractere*/ sz_plst= sizeof(struct liste *); /*Dimension de pointeur sur structure liste*/ sz_lst= sizeof(struct liste); /* Dimension sur structure liste*/ lg_tb= lg_fi+nb_lt; /* Longueur maximum des tableaux resultat*/ /* Creation de 3 tableaux bidimensionnels avec pour nombre de lignes lg_tb */ tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar); nb_tb=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar); yam=(signed char **)SYM_MALLOC((lg_tb+4)*sz_pcar); btb=tb; bnb_tb=nb_tb;byam=yam; for(i=0;i<=lg_tb+2;i++) { *btb++ =(signed char *)SYM_calloc(nb_lt+3,1); *bnb_tb++ =(signed char *)SYM_calloc(nb_lt+3,1); *byam++ =(signed char *)SYM_calloc(nb_lt+3,1); } *btb=NULL;*bnb_tb =NULL;*byam=NULL; /* Construction d'un tableau de taille lg_tb+3 */ af=(signed char *)SYM_MALLOC(lg_tb+3); /* Creation d'un tableau de dimension nb_lt + 2 ou on met les sommes cumulees du vecteur d'evaluation pds: poids de la partition composee des parts de la partition */ pos=(signed char *)SYM_MALLOC(nb_lt+2); bpos=pos; *bpos++ =0; bev=ev;av=0; for(i=1;i<=nb_lt;i++) { *bpos = av+ *bev; av= *bpos; bev++;bpos++; } pds= *--bpos; /* Creation d'un tableau de pointeurs sur struct liste de dimension pds pour l'inserion d'un tableau dans la liste des tableaux */ pl=(struct liste **)SYM_MALLOC((pds+2)*sz_plst); /* Initialisation avant remplissage des tableaux */ bnb_tb=nb_tb+1; bev=ev; btb=tb+1; byam=yam+1; av= *bev; if(lg_fi0) { switch(etat) { case 0: /* Depilage: Essai de placer les lettres plus haut dans le tableau */ ev_niv=ev[niv-1]; if(ssetat==0) { baf=af+lg_tb_dct; btb=tb+lg_tb_dct; bnb_tb=nb_tb+lg_tb_dct; i= ev_niv;j=lg_tb_dct; av=lg_tb_dct+1; } else { ssetat=0; j=av-1; i=ttp; lg_tb_dct=lg_tb_dct0; baf=af+j; bnb_tb=nb_tb+j; btb=tb+j; } while(i>0) { /* Chaque lettre i de valeur niv est testee. */ if(*(*bnb_tb+ niv)==0) { bnb_tb--;btb--; j--;baf--; } else { ctb=btb;dtb=btb+1; for(k=j+1;k<=av;k++) { /* On teste ou la mettre plus haut dans le tableau tb*/ topc= *(*ctb+niv-1); topd= *(*dtb+niv); if(topc>topd) { if(k >lg) break; else { /*SUCCES: On enleve cette lettre niv de la ligne j pour la mettre plus haut dans le tableau*/ etat=1;fr=niv; av=j;ttp=i- *(*bnb_tb+niv); (*(*btb+niv))--; lg_tb_dct0=lg_tb_dct; niv0=niv; (*baf)--;(*(*bnb_tb+niv))--; byam=yam+j; (*(*byam+niv))++;tp= *(*byam+niv); byam++;j++; for(;jlg*/ break; }/*if(topc>topd)*/ ctb++;dtb++; }/*for(k=j+1;k<=av;k++)*/ if(etat==1)break; tp= *(*bnb_tb+niv);av=j;i-=tp; bnb_tb--;btb--;j--;baf--; }/*else du if(*(*bnb_tb+niv)==0)*/ }/*while(i>0)*/ if(etat==1)break; if(*(*(tb+lg_tb_dct)+niv-1)==0) lg_tb_dct--; niv--; break;/*Sortie du case 0*/ case 1: if(ssetat==0) { /* On commence a placer la premiere lettre de valeur niv */ i=1;j=niv; /* premiere lettre niv*/ btb=tb+j;byam=yam+j;baf=af+j; bnb_tb=nb_tb+j; } /*j est forcement > 1*/ /*Essai de placer toutes les lettres niv de i a ev_niv*/ ev_niv=ev[niv-1]; while((j<=lg_tb_dct)||(i<=ev_niv)) { if(j>lg) { if(ttp>0) { etat=0;ssetat=1;niv=niv0; } else { etat=0; ssetat=0; niv=niv0-1; if(*(*(tb+lg_tb_dct0)+niv)==0) lg_tb_dct=lg_tb_dct0-1; else lg_tb_dct=lg_tb_dct0; } break; } topc= *(*(btb-1)+niv-1); topd= *(*btb+niv-1); tmp=topc-topd; ym= *(*(byam-1)+niv)+ *(*(bnb_tb-1)+niv-1); if((tmp>0)&&(ym>0)) { if(tmp>ym)tmp=ym; dsp=ev_niv-i+1; if(tmp>dsp)tmp=dsp; *(*byam+niv) =ym-tmp; *(*bnb_tb+niv)=tmp; *(*btb+niv)=topd+tmp; *baf=topd+tmp; i+=tmp; if(j>lg_tb_dct) { lg_tb_dct++; } } else { *(*byam+niv)=ym; *(*btb+niv) =topd; *baf=topd; *(*bnb_tb+niv)=0; } btb++;bnb_tb++;byam++;baf++;j++; }/*while((j<=lg_tb_dct)||(i<=ev_niv))*/ if(etat==0) break; topd= *(*btb+niv-1); for(;j<=lg_old;j++) { *(*btb+niv)=topd; btb++; } niv++;ssetat=0; break;/*Sortie de case 1*/ } if(niv >nb_lt) { etat=0; if(lg_tb_dctsuivant; bnv1=res; while(lst1!=NULL) { bp=lst2->suivant; bnv1=pro_lg(lst1->tab,bp->tab,lst1->coef,bp->coef,lg,bnv1); bnv2=bnv1; bp=bp->suivant; while(bp!=NULL) { bnv2=pro_lg(lst1->tab,bp->tab,lst1->coef,bp->coef,lg,bnv2); bp=bp->suivant; } lst1=lst1->suivant; } return OK; } /* Product of Schur functions S_{pa}*S_{pb} pa and pb are partition objects. */ INT outerproduct_schur_lrs(pa,pb,c) OP pa,pb,c; { OP prt,tmp,cf,v,d; signed char *va,*vb,*baf,*bva,*bvb; INT i,na,nb,lg,k; struct liste str,*lst,*bp; if(S_O_K(pa)!= PARTITION) return error("outerproduct_schur_lrs: Wrong first type"); if(S_O_K(pb)!= PARTITION) return error("outerproduct_schur_lrs: Wrong second type"); if(S_PA_LI(pa)==0L && S_PA_LI(pb)==0L) { if(not EMPTYP(c)) freeself(c); M_I_I(1L,c); return OK; } if(S_PA_LI(pa)==0L) { if(not EMPTYP(c)) freeself(c); m_skn_s(pb,cons_eins,NULL,c); return OK; } if(S_PA_LI(pb)==0L) { if(not EMPTYP(c)) freeself(c); m_skn_s(pa,cons_eins,NULL,c); return OK; } init(SCHUR,c);d=c; va=(signed char *)SYM_MALLOC(S_PA_LI(pa)+1L); vb=(signed char *)SYM_MALLOC(S_PA_LI(pb)+1L); na=0L;nb=0L;bva=va;bvb=vb; for(i=S_PA_LI(pa)-1L;i>=0L;i--) { *bva++ =(signed char) S_PA_II(pa,i); na++; } *bva=0; for(i=S_PA_LI(pb)-1L;i>=0L;i--) { *bvb++ =(signed char) S_PA_II(pb,i); nb++; } *bvb=0; str.suivant=NULL; if(na>nb) proprt(va,vb,1L,1L,99L,&str); else proprt(vb,va,1L,1L,99L,&str); lst=str.suivant; SYM_free(va); SYM_free(vb); while(lst!=NULL) { cf=callocobject();tmp=callocobject(); M_I_I(lst->coef,cf); prt=callocobject();v=callocobject(); baf=lst->tab; while(*baf)baf++; lg=(INT)(baf-lst->tab); m_il_v(lg,v); baf--; for(k=0L;ktab); bp=lst; lst=lst->suivant; SYM_free((char *)bp); } if(S_L_N(c)!=NULL) { /*CC 24/01/97*/ d=S_L_N(c); c_l_s(c,S_L_S(S_L_N(c))); c_l_n(c,S_L_N(S_L_N(c))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } return OK; } /* Product of Schur functions S_{pa}*S_{pb} restricted with parts <= mx pa and pb are partition objects. */ INT mx_outerproduct_schur_lrs(mx,pa,pb,c) OP pa,pb,c,mx; { OP prt,tmp,cf,v,d; signed char *va,*vb,*baf,*bva,*bvb; INT i,na,nb,lg,k; struct liste str,*lst,*bp; if(S_O_K(pa)!= PARTITION) return error("outerproduct_schur_lrs: Wrong first type"); if(S_O_K(pb)!= PARTITION) return error("outerproduct_schur_lrs: Wrong second type"); if(S_I_I(mx)<0L) { init(SCHUR,c); return OK; } if(S_PA_LI(pa)==0L && S_PA_LI(pb)==0L) { if(not EMPTYP(c)) freeself(c); M_I_I(1L,c); return OK; } if(S_PA_LI(pa)==0L) { if(S_PA_II(pb,S_PA_LI(pb)-1L)<=S_I_I(mx)) { if(not EMPTYP(c)) freeself(c); m_skn_s(pb,cons_eins,NULL,c); } else init(SCHUR,c); return OK; } if(S_PA_LI(pb)==0L) { if(S_PA_II(pa,S_PA_LI(pa)-1L)<=S_I_I(mx)) { if(not EMPTYP(c)) freeself(c); m_skn_s(pa,cons_eins,NULL,c); } else init(SCHUR,c); return OK; } init(SCHUR,c);d=c; str.suivant=NULL; va=(signed char *)SYM_MALLOC(S_PA_LI(pa)+1L); vb=(signed char *)SYM_MALLOC(S_PA_LI(pb)+1L); na=0L;nb=0L;bva=va;bvb=vb; for(i=S_PA_LI(pa)-1L;i>=0L;i--) { *bva++ =(signed char) S_PA_II(pa,i); na++; } *bva=0; for(i=S_PA_LI(pb)-1L;i>=0L;i--) { *bvb++ =(signed char) S_PA_II(pb,i); nb++; } *bvb=0; if(na>nb) proprt(va,vb,1L,1L,(signed char)S_I_I(mx),&str); else proprt(vb,va,1L,1L,(signed char)S_I_I(mx),&str); lst=str.suivant; SYM_free(va); SYM_free(vb); while(lst!=NULL) { cf=callocobject();tmp=callocobject();v=callocobject(); M_I_I(lst->coef,cf); prt=callocobject(); baf=lst->tab; while(*baf)baf++; lg=(INT)(baf-lst->tab); m_il_v(lg,v); baf--; for(k=0L;ktab); bp=lst; lst=lst->suivant; SYM_free((char *)bp); } if(S_L_N(c)!=NULL) { /*CC 24/01/97*/ d=S_L_N(c); c_l_s(c,S_L_S(S_L_N(c))); c_l_n(c,S_L_N(S_L_N(c))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } return OK; } /* Product of Schur functions S_{pa}*S_{pb} restricted upon lengths <=le pa and pb are partition objects. */ INT l_outerproduct_schur_lrs(le,pa,pb,c) OP pa,pb,c,le; { OP prt,tmp,cf,v,d; signed char *va,*vb,*baf,*bva,*bvb; INT i,na,nb,lg,k; struct liste str,*lst,*bp; if(S_O_K(pa)!= PARTITION) return error("outerproduct_schur_lrs: Wrong first type"); if(S_O_K(pb)!= PARTITION) return error("outerproduct_schur_lrs: Wrong second type"); if(S_I_I(le)<0L) { init(SCHUR,c); return OK; } if(S_PA_LI(pa)==0L && S_PA_LI(pb)==0L) { if(not EMPTYP(c)) freeself(c); M_I_I(1L,c); return OK; } if(S_PA_LI(pa)==0L) { if(S_PA_LI(pb)<=S_I_I(le)) { if(not EMPTYP(c)) freeself(c); m_skn_s(pb,cons_eins,NULL,c); } else init(SCHUR,c); return OK; } if(S_PA_LI(pb)==0L) { if(S_PA_LI(pa)<=S_I_I(le)) { if(not EMPTYP(c)) freeself(c); m_skn_s(pa,cons_eins,NULL,c); } else init(SCHUR,c); return OK; } init(SCHUR,c); d=c; str.suivant=NULL; va=(signed char *)SYM_MALLOC(S_PA_LI(pa)+1L); vb=(signed char *)SYM_MALLOC(S_PA_LI(pb)+1L); na=0L;nb=0L;bva=va;bvb=vb; for(i=S_PA_LI(pa)-1L;i>=0L;i--) { *bva++ =(signed char) S_PA_II(pa,i); na++; } *bva=0; for(i=S_PA_LI(pb)-1L;i>=0L;i--) { *bvb++ =(signed char) S_PA_II(pb,i); nb++; } *bvb=0; if(na>nb) pro_lg(va,vb,1L,1L,(signed char)S_I_I(le),&str); else pro_lg(vb,va,1L,1L,(signed char)S_I_I(le),&str); lst=str.suivant; SYM_free(va); SYM_free(vb); while(lst!=NULL) { cf=callocobject();tmp=callocobject();v=callocobject(); M_I_I(lst->coef,cf); prt=callocobject(); baf=lst->tab; while(*baf)baf++; lg=(INT)(baf-lst->tab); m_il_v(lg,v); baf--; for(k=0L;ktab); bp=lst; lst=lst->suivant; SYM_free((char *)bp); } if(S_L_N(c)!=NULL) { /*CC 24/01/97*/ d=S_L_N(c); c_l_s(c,S_L_S(S_L_N(c))); c_l_n(c,S_L_N(S_L_N(c))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } return OK; } /* The plethysmes S_n(S_I) of the different components of the Schur functions being in newton, det computes the plethysm S_I(S_J) */ static INT detr(ext,m,le,newton,boo,lst) signed char m,le,*boo,*ext; struct liste *lst,*newton; { signed char i,j,sig,tmp,pds; struct liste lst1[1],lst2[1],*bp; lst1->suivant=NULL; lst2->suivant=NULL; i=1;j=1; while(i!= m+1) { if(boo[j]==0) { if(m==1) { tmp=le-j+ *(ext+le-1); lst->suivant=(newton+tmp)->suivant; return OK; } else { tmp=le-m+1-j+ *(ext+le-m); if(tmp < 0) return OK; if(i%2==1) sig=1; else sig= -1; boo[j]=1; detr(ext,m-1,le,newton,boo,lst1); boo[j]=0; if(tmp==0) { shuffle_sig(lst1,sig,lst); if(m!=2) free_lst(lst1); else lst1->suivant=NULL; return OK; } else { pds=poids(lst1); if(pds!=0) { if(booo==1) { if(poids(newton+tmp)< pds) fct_sch_prt_srt(lst1,newton+tmp,lng,lst2); else fct_sch_prt_srt(newton+tmp,lst1,lng,lst2); } else { if(poids(newton+tmp)tab); if(m!=2) free_lst(lst1); else lst1->suivant=NULL; if(lst->suivant!=NULL) { shuffle_sig(lst2,sig,lst); free_lst(lst2); } else { if (sig!=1) { bp=lst2->suivant; while(bp!=NULL) { bp->coef= -bp->coef; bp=bp->suivant; } } lst->suivant=lst2->suivant; lst2->suivant=NULL; } } i++; } }/*else du if(m==1)*/ }/*if(boo[j]==0)*/ j++; } return OK; } /* conjugates the partition being in decreasing order (4 3 1 for example gives 3 2 2 1) */ static INT cjg_rv(ttab) signed char **ttab; { signed char *tab,*btab,*af,*baf; signed char lg,av,k,tp,j,tmp; tab= *ttab; lg= *tab; af=(signed char *)SYM_MALLOC(lg+1); baf=af+lg; *baf-- =0; btab=tab; av = *btab++; k=1;tp= *btab; while(tp) { if(av != tp) { tmp=av-tp; for(j=0;jsuivant; while(lst!=NULL) { cjg_rv(&lst->tab); lst=lst->suivant; } return OK; } static INT pl_schur_schur(inn,ext,cond1,cond2,cond3,lst) signed char *inn,*ext,cond1,cond2,cond3; struct liste *lst; { signed char mx,*bx,le,*boo; struct liste *newton; le= -1; bx=ext; while(*bx) { le++;bx++; } mx= *(bx-1)+le; newton=(struct liste *)SYM_MALLOC((mx+1)*sizeof(struct liste)); plth2(inn,cond1,cond2,cond3,mx,newton); le++; boo=(signed char *)SYM_calloc(le+2,1); lst->suivant=NULL; if(cond3==1) { if(booo==1) booo=0; else booo=1; } detr(ext,le,le,newton,boo,lst); /* printf("booo %d le %d mx %d *(ext) %d\n",booo,le,mx,*ext); */ /* CC 24/01/97 */ if(le==1) free_newton(newton, mx-1); else /* CC 27/02/97 */ free_newton(newton, mx); SYM_free(newton); if(cond3==1) { if(booo==1) booo=0; else booo=1; } if(booo==1) cjg_rv_lst(lst); SYM_free(boo); return OK; } static INT cc_plethysm(m,otab,cond1,ores) signed char m,cond1; OP otab,ores; { OP sc,ve,pa,cf; signed char tab[20]; signed char *s,*bs,*btab,*baf,*af,*bch,*tab1; signed char condition,parite,mx,np,npt,le,inv; INT cof; INT c; signed char n,in; signed char k; signed char cond,cond2,high,mid; register signed char i,j,temp; struct liste str,*newton,*bp,*liste,*liste1; for (i=0;i<20;i++) tab[(int)i]=0; inv = 0; le = (signed char)S_PA_LI(otab); if(le > 19) { fprintf(stderr,"partition too long\n"); exit(inv); } btab = tab; mx = 0; for(c = 0L; c < le; c++) { *btab = (signed char)S_PA_II(otab,c); mx += *btab++; } if(( le * mx) > 127) { fprintf(stderr,"too big plethysm for my little structures\n"); exit(inv); } *btab = 0; cond2 = 0; newton = (struct liste *)SYM_MALLOC( (m+1) * sizeof(struct liste) ); if(*(btab - 1) < le) { inv = 1; tab1 = (signed char *)SYM_MALLOC(*(btab - 1) + 1); bs = tab1; btab = tab; af = (signed char *)SYM_MALLOC(le + 1); baf = af; while(*btab != 0) *baf++ = *btab++; *baf = 0; cond = -1; j = le - 1; btab = af + j; mid = *btab; j++; temp = 0; while(j >= 0) { high = 0; while(*btab == mid) { j--; high++; if(j == 0) { *btab = 0; j--; break; } btab--; } temp = temp+high; for(i = *btab;i < mid;i++) { cond++; *bs++ = temp; } mid = *btab; } *bs = 0; SYM_free(af); } else { tab1 = (signed char *)SYM_MALLOC(le + 1); btab = tab; bch = tab1; while(*btab != 0) *bch++ = *btab++; *bch = 0; } booo = 0; if((( cond2 == 0) && (inv == 0)) || ((cond2 == 1) && (inv == 1))) booo = 1; if(cond2 == 0) { if(lng < le) { fprintf(stderr,"No elements of the length %d in this plethysm\n",m); exit(inv); } } else if(lng < *(tab + le - 1)) { fprintf(stderr,"No elements of the length %d in this plethysm\n",m); exit(inv); } liste1 = &str; if ( cond2 == 0) if(cond1 == 0) if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1))) condition = 0; else condition = 1; else if((mx%2 == 0) || ((mx%2 == 1)&&(inv == 1))) condition = 1; else condition = 0; else if(cond1 == 0) if((inv == 0) || ((inv == 1) && (mx%2 == 0))) condition = 0; else condition = 1; else if((inv == 0) || ((inv == 1) && (mx%2 == 0))) condition = 1; else condition = 0; liste = (struct liste *)SYM_MALLOC(sizeof(struct liste)); liste->coef = 1L; liste->suivant = NULL; liste1->suivant = liste; bs = (signed char *)SYM_MALLOC(1); if (bs == NULL) return no_memory(); liste->tab = bs; *bs = (signed char) 0; (newton)->suivant = liste1->suivant; for(n = 1;n <= m;n++) { liste1->suivant = NULL; np = n * mx; npt = np; if( n == 1) { liste = (struct liste *)SYM_MALLOC(sizeof(struct liste)); liste->coef = 1L; liste->suivant = NULL; liste1->suivant = liste; if (inv == 0) { bs = (signed char *)SYM_calloc(tab[le - 1] + 1,sizeof(char)); liste->tab = bs; btab = tab; af = (signed char *)SYM_calloc(le + 1,sizeof(char)); baf = af; while(*btab != (signed char)0) *baf++ = *btab++; *baf = (signed char)0; cond = (signed char)-1; j = le - 1; btab = af + j; mid = *btab; j++; temp = (signed char)0; while(j >= (signed char)0) { high = (signed char)0; while(*btab == mid) { j--; high++; if(j == (signed char)0) { *btab = (signed char)0; j--; break; } btab--; } temp = temp+high; for(i = *btab;i < mid;i++,bs++) { cond++; *bs = temp; } mid = *btab; } *bs = 0; temp = mx - 1; bs--; for(i = 0 ;i <= cond; i++) { (*bs) += temp; temp--; if(i != cond) bs--; } if(bs == NULL) return OK; SYM_free(af); } else { liste->tab = (signed char *)SYM_MALLOC(le + 1); bs = liste->tab + le; *bs-- = 0; btab = tab + le - 1; temp = mx - 1; for(i = 1 ;i <= le; i++) { *bs = *btab + temp; temp--; if(i != le) { btab--; bs--; } } } } else { for(in = 0;in < n;in++) { if(condition == 1) { i = (n+1+in)%2; if(i == 0) parite = 1; else parite = -1; } else parite = 1; liste = (newton+in)->suivant; while(liste != NULL) { baf = liste->tab; temp = np - npt; s = (signed char *)SYM_MALLOC(temp + 1); if(temp != 0) { temp--; j = 0; while(*baf != '\0') { j++; baf++; } baf--; btab = s + j; *btab-- = 0; for(k = j-1;k >= 0;k--) { *btab = (*baf) - temp; if(k != 0) { btab--; baf--; temp--; } } } else *s = '\0'; cof = liste->coef; gvr = 0; calcul(tab1,(int) n - in,s,liste1,cof,parite,n); SYM_free(s); /* AK 181291 */ liste = liste->suivant; } npt = npt - mx; } /* End of the loop for (in = 0;in < n ;in++) */ } liste = liste1->suivant; while(liste != NULL) { liste->coef = liste->coef/n; liste = liste->suivant; } (newton + n)->suivant = liste1->suivant; } /* End of the loop with n*/ liste = newton + 1; /*START OF THE THIRD PART WRITING IN THE LIST ores*/ for(in = 1;in < m;in++) { bp = liste->suivant; while(bp != NULL) { SYM_free(bp->tab); liste1 = bp; bp = bp->suivant; SYM_free((signed char *)liste1); } /*liste1 = liste; Suppress */ liste++; /* SYM_free((signed char *)liste1); AK 140192 wg sun */ } bp = liste->suivant; k = in * mx; init(SCHUR,ores); /* d=ores; */ while(bp != NULL) { btab = bp->tab; j = -1; while(*btab != '\0') { btab++; j++; } btab--; temp = k-1; for(i = j;i >= 0;i--) { (*btab--) -= temp; temp--; } /*ALLOCATION OF A NEW MEMORY FOR THE VECTOR ve AND THE SCHUR FUNCTION sc. THE RESULT ores */ sc = callocobject(); ve = callocobject(); pa=callocobject(); cf=callocobject(); if(booo == 1) conjug( bp->tab , j , ve); else { btab = bp->tab; m_il_v( (INT)(j+1), ve ); for(i = 0; i<=j ;i++) { M_I_I( (INT)(*btab), S_V_I(ve, (INT) i)); btab++; } } b_ks_pa(VECTOR,ve,pa); M_I_I(bp->coef,cf); b_skn_s(pa,cf,NULL,sc); insert(sc,ores,NULL,NULL); /* AK 151298 */ SYM_free(bp->tab); liste1 = bp; bp = bp->suivant; SYM_free((signed char *)liste1); } SYM_free(tab1); /*CC 24/01/97*/ SYM_free(newton->suivant->tab); SYM_free(newton->suivant); SYM_free((signed char *)newton); return OK; } static INT t_list_coef_SYM(lst,cof,np,res) struct liste * lst; OP res,cof;signed char np; { signed char lg; register signed char *baf,i; struct liste *q; OP pol,pa,v,cf,d; lst=lst->suivant; init(SCHUR,res); d=res; while(lst!=NULL) { pol=callocobject(); v=callocobject(); pa=callocobject(); cf=callocobject(); baf=lst->tab; while(*baf) baf++; lg=(INT)(baf-lst->tab); m_il_v((INT)lg,v); i=np; baf--; for(;;) { *baf -=i; if(baf==lst->tab) break; i--;baf--; } for(i=0;icoef,cf);mult_apply(cof,cf); b_skn_s(pa,cf,NULL,pol); c_l_n(d,pol);d=pol; q=lst; lst=lst->suivant; SYM_free(q->tab); SYM_free((char *)q); } if(S_L_N(res)!=NULL) { /*CC 24/01/97*/ d=S_L_N(res); c_l_s(res,S_L_S(S_L_N(res))); c_l_n(res,S_L_N(S_L_N(res))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } return OK; } static INT t_list_SYM(lst,res)struct liste * lst; OP res; { signed char lg; register signed char *baf,i; struct liste *q; OP pol,pa,v,cf,d; lst=lst->suivant; init(SCHUR,res); d=res; while(lst!=NULL) { pol=callocobject(); v=callocobject(); pa=callocobject(); cf=callocobject(); baf=lst->tab; while(*baf) baf++; lg=baf-lst->tab; m_il_v((INT)lg,v); baf--; for(i=0;icoef,cf); b_skn_s(pa,cf,NULL,pol); c_l_n(d,pol);d=pol; q=lst; lst=lst->suivant; SYM_free(q->tab); SYM_free((char *)q); } if(S_L_N(res)!=NULL) { /*CC 24/01/97*/ d=S_L_N(res); c_l_s(res,S_L_S(S_L_N(res))); c_l_n(res,S_L_N(S_L_N(res))); c_l_n(d,NULL); c_l_s(d,NULL); freeall(d); } return OK; } /* a= \sum n_I*S_I => a= \sum n_I*S_I\tilde */ /* The partitions of the a=\sum n_I*S_I are put in its growing order */ INT growingorder_schur(a) OP a; { OP z,ap,b; b=callocobject();init(SCHUR,b); if(S_O_K(a) == SCHUR) { if(not nullp(a)) { z=S_L_N(a); c_l_s(b,S_L_S(a)); while(z!=NULL) { ap=S_L_N(z); C_L_N(z,NULL); insert(z,b,add_koeff,comp_monomvector_monomvector); z=ap; } c_l_s(a,s_l_s(b)); c_l_n(a,s_l_n(b)); } } return OK; } INT l_complete_schur_plet(olng,b,c,res) OP c,res,olng,b; /*l_complete_schur_plet COMPUTES THE TERMS OF S_n(S_I) LESS THAN lng.*/ /* result is of type SCHUR */ /* CC 1996 */ /* AK 210704 V3.0 */ { INT erg = OK; CTO(INTEGER,"l_complete_schur_plet(1)",olng); CTO(INTEGER,"l_complete_schur_plet(2)",b); CTTO(PARTITION,INTEGER,"l_complete_schur_plet(3)",c); { OP part_inn,tmp; if(S_I_I(olng)<0L) { init(SCHUR,res); } else if(S_I_I(b)==0L) { erg += m_scalar_schur(cons_eins,res); } else if(S_I_I(b)<0L) { init(SCHUR,res); } else if ( (S_O_K(c)==INTEGER)&&(S_I_I(c)<=0L)) { init(SCHUR,res); } else { part_inn=callocobject(); if(S_O_K(c)==INTEGER) { erg += m_i_pa(c,part_inn); } else { COPY(c,part_inn); } lng = (signed char)(S_I_I(olng)); FREESELF(res); if(lng1) m_il_v((INT)max-1,S_PA_S(S_S_S(gl))); else m_il_v(1L,S_PA_S(S_S_S(gl))); baf = af; if (max>1)baf++; if(max > 1) for (i=0;i1) m_il_v((INT)max-1,S_PA_S(b)); else m_il_v(1L,S_PA_S(b)); if(max>1) for(i=1;i (INT)(i+kk)*(n-1) ) break; m_il_v(S_PA_LI(z)-i,S_PA_S(a)); for (zz=0;zz=0");goto endr_ende; } if (S_PA_LI(I) == 0) { m_pa_mon(I,r); goto ende; } if (S_I_I(n) == 0) { m_pa_mon(I,r); first_partition(cons_null,S_S_S(r)); M_I_I(1,S_S_K(r)); goto ende;} if (S_I_I(n) == 1) { m_pa_mon(I,r); goto ende; } /* loop over all partitions with parts from I and length <= n */ j=1;for (i=1;i= maximalen teil */ j = 0; for (i=1;i<=S_V_LI(v);i++) { if ((i == S_V_LI(v)) || (S_V_II(v,i) != S_V_II(v,i-1))) { INT k; OP new_I = callocobject(); OP new_n = callocobject(); OP new_r = callocobject(); /* von j bis i ein block */ copy(S_PA_S(I),new_I); for (k=0;k0) /* AK 121201 */ if (S_V_II(new_I,k) == S_V_II(parts,S_V_II(v,i-1)-1)) { M_I_I(0,S_V_I(new_I,k)); break; } m_v_pa(new_I,new_I); /* check ob das gewicht stimmt */ M_I_I(i-j,new_n); recdeb++; if ((S_PA_LI(new_I) == 0) || (S_I_I(new_n) == 1) ) { /* AK 121201 */ m_pa_mon(new_I,new_r); } else plet_sn_mI(new_n,new_I,new_r); recdeb--; if (j==0) swap(new_r,level); else mult_apply_monomial_monomial(new_r,level); j = i; freeall(new_I); freeall(new_n); freeall(new_r); } } /* jetzt den level um das teil w erweitern */ inc_weight_monomial(w,level); erg += add_apply(level,r); { next: /* next */ for (i=0;i 0) { DEC_INTEGER(S_V_I(v,i)); j = S_V_II(v,i); i--; break; } for (;i>=0;i--) M_I_I(j,S_V_I(v,i)); } freeall(level); } while (not nullp(v)); erg += freeall(v); freeall(parts); ende: CTO(INTEGER,"plet_sn_mI(1)",n); CTO(PARTITION,"plet_sn_mI(2)",I); CTO(MONOMIAL,"plet_sn_mI(3-ende)",r); /* { OP z,d = callocobject(),w=callocobject(); weight(I,d); mult_apply(n,d); FORALL(z,r, { weight(S_MO_S(z),w); if (neq(w,d)) error(""); } ); freeall(w); freeall(d); } */ ENDR("plet_sn_mI"); } static INT inc_weight_monomial(INT w, OP s) { OP z; OP r = callocobject(); init(MONOMIAL,r); FORALL(z,s,{ if ((S_PA_LI(S_MO_S(z)) == 0) || (S_PA_II(S_MO_S(z), S_PA_LI(S_MO_S(z))-1) <= w)) { OP p = callocobject(); copy(S_MO_S(z),p); inc(p); M_I_I(w,S_PA_I(p,S_PA_LI(p)-1)); m_pa_mon(p,p); copy(S_MO_K(z),S_S_K(p)); insert(p,r,NULL,NULL); } }); swap(r,s); freeall(r); return OK; } INT p2_schursum(); INT p_schursum(a,b,c,f,schurf,partf,multf) OP a,b,c,f; INT (*schurf)(), (*partf)(), (*multf)(); /* AK 101201 for the expansion S_I[P+Q] */ { return p2_schursum(a,b,c,f,-1,schurf,partf,multf); #ifdef UNDEF INT erg = OK; /* loop over all partitions smaller then a */ /* S_a[b1+b2] = \sum_d= S_V_LI(vec)) goto evalpoly3; /* i ist < S_V_LI(vec) */ if (not EMPTYP(S_V_I(vec,i))) if (S_PO_SII(zeiger,i) != (INT)0) { if (S_PO_SII(zeiger,i) != 1L) { if (S_PO_SII(zeiger,i) >= S_V_LI(speicher)) { l = S_V_LI(speicher); inc_vector_co(speicher, S_PO_SII(zeiger,i)-S_V_LI(speicher)+1); for (;l row_length) { zeilenposition = (INT)0; fprintf(stdout,"\n"); } else zeilenposition++; } fprintf(f," "); erg += fprint(f,S_MO_S(monom)); if (f==stdout) { if (zeilenposition > row_length) { zeilenposition = (INT)0; fprintf(stdout,"\n"); } } ENDR("fprint_monom"); } INT tex_monom(monom) OP monom; /* AK 230688 */ /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 070291 V1.2 tex to texout */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(MONOM,"tex_monom(1)",monom); if (POLYNOMP(S_MO_K(monom))) fprintf(texout,"("); erg += tex(S_MO_K(monom)); fprintf(texout,"\\ "); texposition += (INT)2; if (POLYNOMP(S_MO_K(monom))) /* AK 240795 */ fprintf(texout,")"); erg += tex(S_MO_S(monom)); ENDR("tex_monom"); } #endif /* MONOMTRUE */ #ifdef POLYTRUE INT m_s_po(self,poly) OP self,poly; /* AK 120790 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; OP s; COP("m_s_po(2)",poly); s = CALLOCOBJECT(); COPY(self,s); erg += b_s_po(s,poly); ENDR("m_s_po"); } INT b_s_po(self,poly) OP self,poly; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ /* AK 210904 V3.0 */ { INT erg = OK; COP("b_s_po(2)",poly); SYMCHECK(self==poly,"b_s_po:two equal parameters"); { erg += b_sn_l(CALLOCOBJECT(),NULL,poly); C_O_K(poly,POLYNOM); B_SK_MO(self,CALLOCOBJECT(),S_L_S(poly)); M_I_I(1,S_PO_K(poly)); } ENDR("b_s_po"); } #endif /* POLYTRUE */ #ifdef MONOMTRUE INT freeself_monom(a) OP a; /* AK 100789 V1.0 */ /* AK 211189 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; CTO(MONOM,"freeself_monom(1)",a); FREEALL(S_MO_S(a)); FREEALL(S_MO_K(a)); FREEMONOM(S_O_S(a).ob_monom); C_O_K(a,EMPTY); ENDR("freeself_monom"); } INT comp_monom(a,b) OP a,b; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 080390 bei gleichheit von self wird koeff verglichen */ /* AK 200891 V1.3 */ { INT erg=OK; CTO(MONOM,"comp_monom(1)",a); CTO(MONOM,"comp_monom(2)",b); { INT res; res = COMP(S_MO_S(a), S_MO_S(b)); if (res != 0) return res; else return COMP(S_MO_K(a),S_MO_K(b)); } ENDR("comp_monom"); } INT copy_monom(a,b) OP a,b; /* AK 100789 V1.0 */ /* AK 071289 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; CTO(MONOM,"copy_monom(1)",a); CTO(EMPTY,"copy_monom(2)",b); B_SK_MO(CALLOCOBJECT(),CALLOCOBJECT(),b); COPY(S_MO_K(a), S_MO_K(b)); COPY(S_MO_S(a), S_MO_S(b)); ENDR("copy_monom"); } OP s_mo_s(a) OP a; /* select_monom_self */ /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; if (a == NULL) return error("s_mo_s:a == NULL"),(OP)NULL; if (S_O_K(a) != MONOM) return error("s_mo_s:a != MONOM"),(OP)NULL; c = s_o_s(a); return(c.ob_monom->mo_self); } OP s_mo_k(a) OP a; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; if (a == NULL) return error("s_mo_k:a == NULL"),(OP)NULL; if (S_O_K(a) != MONOM) return error("s_mo_k:a != MONOM"),(OP)NULL; c = s_o_s(a); return(c.ob_monom->mo_koeff); } /* the following routines only work with self part which are VECTORobjects */ OP s_mo_sl(a) OP a; /* AK 200891 V1.3 */ { return s_v_l(s_mo_s(a)); } INT s_mo_sli(a) OP a; /* AK 200891 V1.3 */ { return s_v_li(s_mo_s(a)); } OP s_mo_si(a,i) OP a;INT i; /* AK 200891 V1.3 */ { return s_v_i(s_mo_s(a),i); } INT s_mo_sii(a,i) OP a;INT i; /* AK 200891 V1.3 */ { return s_v_ii(s_mo_s(a),i); } INT s_mo_ki(a) OP a; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { return(s_i_i(s_mo_k(a))); } INT c_mo_s(a,b) OP a,b; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_monom->mo_self = b; return(OK); } INT c_mo_k(a,b) OP a,b; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_monom->mo_koeff = b; return(OK); } INT mult_scalar_monom(a,b,c) OP a,b,c; /* AK 111188 */ /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(MONOM,"mult_scalar_monom(2)",b); CTO(EMPTY,"mult_scalar_monom(3)",c); B_SK_MO(CALLOCOBJECT(),CALLOCOBJECT(),c); COPY(S_MO_S(b),S_MO_S(c)); MULT(S_MO_K(b),a,S_MO_K(c)); ENDR("mult_scalar_monom"); } INT mult_integer_monom(a,b,c) OP a,b,c; /* AK 111188 */ /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(INTEGER,"mult_integer_monom(1)",a); CTO(MONOM,"mult_integer_monom(2)",b); CTO(EMPTY,"mult_integer_monom(3)",c); B_SK_MO(CALLOCOBJECT(),CALLOCOBJECT(),c); COPY(S_MO_S(b),S_MO_S(c)); MULT_INTEGER(a,S_MO_K(b),S_MO_K(c)); ENDR("mult_integer_monom"); } #endif /* MONOMTRUE */ #ifdef POLYTRUE INT mult_polynom(a,b,d) OP a,b,d; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 150591 V1.2 */ /* AK 080891 V1.3 */ /* CC 210595 fuer die rationnellen Funktionen*/ { INT erg = OK; OP tp1, tp2; CTO(POLYNOM,"mult_polynom(1)",a); CTO(EMPTY,"mult_polynom(3)",d); if (NULLP(a)) { M_I_I(0,d); goto ende; } switch(S_O_K(b)) { case INTEGER: case FF: case LONGINT: erg+=mult_scalar_polynom(b,a,d); break; #ifdef BRUCHTRUE case BRUCH: if((!scalarp(S_B_O(b))) ||(!scalarp(S_B_U(b)))) { tp1=callocobject();tp2=callocobject(); M_I_I(1L,tp1);m_ou_b(a,tp1,tp2); copy(tp2,a); freeall(tp1);freeall(tp2); erg += mult_bruch_bruch(a,b,d); } else erg+=mult_scalar_polynom(b,a,d); break; #endif /* BRUCHTRUE */ case POLYNOM: erg+=mult_polynom_polynom(a,b,d); break; #ifdef SCHUBERTTRUE case SCHUBERT: erg+=mult_schubert_polynom(b,a,d); /* AK 190690 */ goto ende; #endif /* SCHUBERTTRUE */ #ifdef GRALTRUE case GRAL: erg += mult_scalar_gral(a,b,d); goto ende; #endif /* GRALTRUE */ #ifdef SCHURTRUE case HOM_SYM: erg += mult_homsym_scalar(b,a,d); goto ende; case MONOMIAL: erg += mult_monomial_scalar(b,a,d); goto ende; case POW_SYM: erg += mult_powsym_scalar(b,a,d); goto ende; case ELM_SYM: erg += mult_elmsym_scalar(b,a,d); goto ende; case SCHUR: erg += mult_schur_scalar(b,a,d); goto ende; #endif /* SCHURTRUE */ #ifdef MATRIXTRUE case MATRIX: erg+=mult_scalar_matrix(a,b,d); goto ende; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += mult_scalar_monom(a,b,d); goto ende; #endif /* MONOMTRUE */ case MONOPOLY: erg += mult_monopoly_polynom(b,a,d); goto ende; default: erg += WTO("mult_polynom(2)",b); } ende: ENDR("mult_polynom"); } INT mult_scalar_polynom(a,poly,res) OP a,poly,res; /* AK 100789 V1.0 */ /* AK 191289 V1.1 */ /* AK 150591 V1.2 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(POLYNOM,"mult_scalar_polynom(2)",poly); CTO(EMPTY,"mult_scalar_polynom(3)",res); MULT_SCALAR_MONOMLIST(a,poly,res); ENDR("mult_scalar_polynom"); } INT mult_polynom_polynom(eins,zwei,c) OP eins, zwei, c; /* AK 100789 V1.0 */ /* AK 081289 V1.1 */ /* AK 150591 V1.2 */ /* AK 140891 V1.3 */ { OP z, ez, zz; INT erg = OK; CTO(POLYNOM,"mult_polynom_polynom(1)",eins); CTO(POLYNOM,"mult_polynom_polynom(2)",zwei); CTO(EMPTY,"mult_polynom_polynom(3)",c); erg += init_polynom(c); if (NULLP(eins)) goto ende; if (NULLP(zwei)) goto ende; zz = zwei; while (zz != NULL) { z = CALLOCOBJECT(); erg += copy_list(eins,z); /* eins ist polynom */ ez = z; while (ez != NULL) { ADD_APPLY( S_PO_S(zz), S_PO_S(ez)); MULT_APPLY( S_PO_K(zz), S_PO_K(ez)); ez = S_PO_N(ez); }; INSERT(z,c,add_koeff,comp_monomvector_monomvector); zz = S_PO_N(zz); }; ende: CTO(POLYNOM,"mult_polynom_polynom(e3)",c); ENDR("mult_polynom_polynom"); } INT init_polynom(a) OP a; /* AK 250102 */ { INT erg = OK; CTO(EMPTY,"init_polynom(1)",a); erg += b_sn_l(NULL,NULL,a); C_O_K(a,POLYNOM); CTO(POLYNOM,"init_polynom(e1)",a); ENDR("init_polynom"); } INT numberofmonomials(a,n) OP a,n; /* AK 230999 */ /* only works for positive integer coefficients */ { INT erg = OK; OP z; CTO(POLYNOM,"numberofmonomials",a); CE2(a,n,numberofmonomials); erg += m_i_i((INT)0,n); /* frees the result automaticaly */ if (S_L_S(a) == NULL) goto ne; z = a; while (z != NULL) { if (S_O_K(S_PO_K(z)) == INTEGER) { if (negp(S_PO_K(z))) { m_i_i(-1L,n); goto ne; } else add_apply(S_PO_K(z),n); } else if (S_O_K(S_PO_K(z)) == LONGINT) { if (negp(S_PO_K(z))) { m_i_i(-1L,n); goto ne; } else add_apply(S_PO_K(z),n); } else { println(a); WTO("numberofmonomials",S_PO_K(z)); m_i_i(-1L,n); goto ne; } z = S_PO_N(z); } ne: ENDR("numberofmonomials"); } INT numberofvariables(a,n) OP a,n; /* AK 250692 */ /* n becomes the number of variables of the POLYNOM a */ { INT i,erg = OK; OP z; CTO(POLYNOM,"numberofvariables(1)",a); CE2(a,n,numberofvariables); M_I_I((INT)0,n); if (S_L_S(a) == NULL) goto ne; z = a; while (z != NULL) { i = S_PO_SLI(z)-1L; while (S_PO_SII(z,i) == (INT)0) i--; if (i+1L > S_I_I(n)) M_I_I(i+1L,n); z = S_PO_N(z); } ne: ENDR("numberofvariables"); } INT mult_disjunkt_polynom_polynom(a,b,c) OP a, b, c; /* AK 300889 */ /* die beiden polynome haben disjunkte alphabete */ /* beim c werden die alphabete hintereinandergehaengt */ /* AK 191289 V1.1 */ /* AK 200891 V1.3 */ { OP z, ap, bp; OP n,l; INT i; INT erg = OK; CTO(POLYNOM,"mult_disjunkt_polynom_polynom(1)",a); CTO(POLYNOM,"mult_disjunkt_polynom_polynom(2)",b); CE3(a,b,c,mult_disjunkt_polynom_polynom); /* first check the number of variables of a */ /* AK 250692 */ n = callocobject(); numberofvariables(a,n); bp = b; l = callocobject(); while (bp != NULL) { z = callocobject(); copy(a,z); ap = z; while (ap != NULL) { if (S_PO_SLI(ap) < S_I_I(n)) /* AK 250692 */ { m_il_nv(S_I_I(n),l); for (i=(INT)0;i 0 */ /* works also for other list objects */ /* false for empty list */ { OP z = a; if (S_L_S(a) == NULL) return FALSE; while (z != NULL) { if (not posp(S_PO_K(z))) return FALSE; z = S_PO_N(z); } return TRUE; } INT negp_polynom(a) OP a; /* AK V2.0 221298 */ /* TRUE if all coeffs < 0 */ /* works also for other list objects */ { OP z = a; if (S_L_S(a) == NULL) return TRUE; while (z != NULL) { if (not negp(S_PO_K(z))) return FALSE; z = S_PO_N(z); } return TRUE; } INT comp_polynom(a,b) OP a,b; { INT erg = OK; CTO(POLYNOM,"comp_polynom(1)",a); switch (S_O_K(b)) { case INTEGER: case LONGINT: case BRUCH: case FF: return comp_polynom_scalar(a,b); case POLYNOM: if ( (S_L_S(a) == NULL) && (S_L_S(b) == NULL) ) return 0; if (S_L_S(a) == NULL) return -1; if (S_L_S(b) == NULL) return 1; /* return comp_list_co(a,b,comp); AK061207 *//* comp but not comp_monomvector */ return comp_list_co(a,b,comp_monomvector_monomvector);/* comp but not comp_monomvector */ default: WTO("comp_polynom(2)",b); break; } ENDR("comp_polynom"); } INT comp_polynom_scalar(a,b) OP a,b; /* AK 030298 */ { if (not nullp(S_PO_S(a))) return -1; if (S_PO_N(a) != NULL) return 1; return comp(S_PO_K(a),b); } #define COMP_MONOMSF(a,b)\ if (S_PA_LI(S_MO_S(a)) == S_PA_LI(S_MO_S(b)))\ {\ INT i,l=S_PA_LI(S_MO_S(b)); OP ap,bp;\ if (S_PA_LI(S_MO_S(a)) == 0) return 0;\ ap = S_V_S (S_PA_S( S_MO_S(a) ));\ bp = S_V_S (S_PA_S( S_MO_S(b) ));\ for (i=0;i S_PA_LI(S_MO_S(b)) )\ {\ INT i,l=S_PA_LI(S_MO_S(b)); OP ap,bp;\ ap = S_V_S (S_PA_S( S_MO_S(a) ));\ bp = S_V_S (S_PA_S( S_MO_S(b) ));\ for (i=0;i S_P_LI(as)) { a=bs; bs=as; as=a; erg= -1L; } /* as ist laenger als bs */ for (i=(INT)0; i S_P_II(bs,i)) return erg*1L; if (S_P_II(as,i) < S_P_II(bs,i)) return erg*-1L; } else { if (S_P_II(as,i) < i+1L) return erg*-1L; if (S_P_II(as,i) > i+1L) return erg*1L; } } return (INT)0; } if ( (S_O_K(as) == MATRIX) && (S_O_K(bs)==MATRIX) ) { INT h,l; h = (S_M_HI(as) > S_M_HI(bs) ? S_M_HI(as) : S_M_HI(bs)); l = (S_M_LI(as) > S_M_LI(bs) ? S_M_LI(as) : S_M_LI(bs)); for (i=(INT)0; i=S_M_HI(as) ) && ( j=S_M_HI(bs) ) && ( j=S_M_LI(bs) ) ) if (not NULLP(S_M_IJ(as,i,j))) return 1L; if ( ( i=S_M_LI(as) ) ) if (not NULLP(S_M_IJ(bs,i,j))) return -1L; } return (INT)0; } if ( ((S_O_K(as) != VECTOR)&&(S_O_K(as) != INTEGERVECTOR)) || ((S_O_K(bs) != VECTOR)&&(S_O_K(bs) != INTEGERVECTOR)) ) return COMP(as,bs); for (i=(INT)0;i= S_V_LI(bs)) { if (S_V_II(as,i) != (INT)0) return 1L; } else if (S_O_K(S_V_I(bs,i)) != INTEGER) { if (S_O_K(S_V_I(bs,i)) == LONGINT) { C_O_K(bs,VECTOR); goto ccc; } fprintln(stderr,bs); error("comp_monomvector_monomvector:bs no INTEGERVECTOR"); } else if ( S_V_II(as,i) > S_V_II(bs,i) ) return 1L; else if ( S_V_II(as,i) < S_V_II(bs,i) ) return -1L; } for (j=i;j= S_V_LI(bs)) { if (not nullp(S_V_I(as,i))) return 1L; } else if ( gt(S_V_I(as,i),S_V_I(bs,i)) ) return 1L; else if ( lt(S_V_I(as,i),S_V_I(bs,i)) ) return -1L; } for (j=i;j(INT)0) { hbool=(INT)0; if (S_M_IJI(z,i,j) >1L) fprintf(texout," x_{%ld,%ld}^{%ld} ", i,j,S_M_IJI(z,i,j)); else fprintf(texout," x_{%ld,%ld} ", i,j); texposition += 15L; } } else { for (i= (INT)0 ;i < S_PO_SLI(zeiger); i++) if (S_PO_SII(zeiger,i) > (INT)0) { hbool=(INT)0; if (tex_poly_var == NUMERICAL) /* AK 090395 */ fprintf(texout,"x_{%ld}",i+tex_poly_first_var_index); else fprintf(texout,"%c",(char)( 'a'+i+tex_poly_first_var_index)); texposition ++; if (S_PO_SII(zeiger,i) != 1L) { fprintf(texout,"^{%ld}",S_PO_SII(zeiger,i)); texposition += 10L; }; }; } if (hbool == 1L) fprintf(texout,"1"); fprintf(texout,"\\ "); texposition += 3L; if (texposition > tex_row_length) { fprintf(texout,"\n"); texposition = (INT)0; } zeiger = S_PO_N(zeiger); if (zeiger != NULL) if (not negp(S_PO_K(zeiger))) /* AK 100892 */ { fprintf(texout," + "); texposition += 5L; } }; if (ts == (INT)0) { fprintf(texout,"$ \\ "); texmath_yn = (INT)0; } else fprintf(texout,"\\ "); texposition += 2L; return(OK); } INT copy_polynom(a,b) OP a,b; /* AK 091190 V1.1 */ /* AK 190291 V1.2 */ /* AK 200891 V1.3 */ { return(copy_list(a,b)); } INT add_apply_polynom_polynom(a,b) OP a,b; /* AK 091190 V1.1 */ /* AK 190291 V1.2 */ /* AK 200891 V1.3 */ { INT erg = OK; OP c; CTO(POLYNOM,"add_apply_polynom_polynom(1)",a); CTO(POLYNOM,"add_apply_polynom_polynom(2)",b); c = callocobject(); erg += copy_polynom(a,c); insert(c,b,add_koeff,comp_monomvector_monomvector); ENDR("add_apply_polynom_polynom"); } INT add_apply_polynom_scalar(a,b) OP a,b; /* AK 130891 V1.3 */ { OP c; INT erg = OK; CTO(POLYNOM,"add_apply_polynom_scalar(1)",a); #ifdef UNDEF /* 170304 removed */ c = callocobject(); erg += copy(a,c); erg += add(b,c,b); /* error AK 211194 */ erg += freeall(c); #endif c = callocobject(); erg += m_scalar_polynom(b,c); erg += add(a,c,b); erg += freeall(c); ENDR("add_apply_polynom_scalar"); } INT add_apply_polynom(a,b) OP a,b; /* AK 220390 V1.1 */ /* AK 190291 V1.2 */ /* AK 130891 V1.3 */ /* AK 030498 V2.0 */ { INT erg = OK; OP d; CTO(POLYNOM,"add_apply_polynom",a); if ((EMPTYP(b)) || nullp(b) ) { erg += copy_polynom(a,b); goto endr_ende; } switch(S_O_K(b)) { case BRUCH: case FF: case LONGINT: case CYCLOTOMIC: case SQ_RADICAL: case INTEGER: erg += add_apply_polynom_scalar(a,b);break; case MONOPOLY: d=callocobject(); erg += t_POLYNOM_MONOPOLY(a,d); erg += add_apply_monopoly(d,b); erg += freeall(d); break; case POLYNOM: erg += add_apply_polynom_polynom(a,b);break; #ifdef SCHUBERTTRUE case SCHUBERT: erg += add_apply_polynom_schubert(a,b);break; #endif /* SCHUBERTTRUE */ default: WTO("add_apply_polynom(2)",b); goto endr_ende; } ENDR("add_apply_polynom"); } #endif /* POLYTRUE */ #ifdef SCHUBERTTRUE INT add_apply_polynom_schubert(a,b) OP a,b; /* AK 190291 V1.2 */ /* AK 200891 V1.3 */ { OP c; INT erg = OK; CTO(POLYNOM,"add_apply_polynom_schubert(1)",a); CTO(SCHUBERT,"add_apply_polynom_schubert(2)",b); c = callocobject(); erg += t_POLYNOM_SCHUBERT(a,c); erg += add_apply(c,b); erg += freeall(c); ENDR("add_apply_polynom_schubert"); } INT gauss_schubert_polynom(a,b,c) OP a,b,c; /* AK 040190 gausspolynom [a+b \atop b] */ /* mittels schubertpolynome */ /* AK 040190 V1.1 */ /* AK 200891 V1.3 */ /* AK 280199 V2.0 */ /* a,b,c may be equal */ { INT i,m; OP vec,perm; INT erg = OK; CTO(INTEGER,"gauss_schubert_polynom",a); CTO(INTEGER,"gauss_schubert_polynom",b); vec = callocobject(); perm = callocobject(); erg += m_il_v(S_I_I(a)+S_I_I(b)+1L,vec); for (i=(INT)0,m=(INT)0;i 1 + q^i */ /* AK 080190 */ /* AK 091190 V1.1 */ /* AK 200891 V1.3 */ { OP d,e,f; OP z; INT i; INT erg = OK; CTO(POLYNOM,"polya_sub(1)",a); CTO(INTEGER,"polya_sub(2)",c); e=CALLOCOBJECT(); erg += b_skn_po(CALLOCOBJECT(),CALLOCOBJECT(),NULL,e); erg += m_il_nv(1L,S_PO_S(e)); M_I_I(1,S_PO_K(e)); f=CALLOCOBJECT(); COPY(e,f); M_I_I(1L,S_PO_SI(f,0L)); erg += insert(f,e,add_koeff,comp_monomvector_monomvector); d=CALLOCOBJECT(); erg += m_il_v(S_I_I(c),d); for (i=0L;i= S_V_LI(vec)) goto evalpoly3; /* i ist < S_V_LI(vec) */ if (not EMPTYP(S_V_I(vec,i))) /* if (not nullp (S_PO_SI(zeiger,i))) AK 040892 */ if (S_PO_SII(zeiger,i) != (INT)0) { if (S_PO_SII(zeiger,i) == 1L) mult_apply_integer(S_V_I(vec,i),monom); else if (S_PO_SII(zeiger,i) == 2L) { m_i_i(S_V_II(vec,i)*S_V_II(vec,i),c); mult_apply_integer(c,monom); } else if (S_PO_SII(zeiger,i) == 3L) { m_i_i(S_V_II(vec,i)*S_V_II(vec,i)*S_V_II(vec,i),c); erg += mult_apply_integer(c,monom); } else if (S_PO_SII(zeiger,i) == 4L) { m_i_i(S_V_II(vec,i)*S_V_II(vec,i)*S_V_II(vec,i)*S_V_II(vec,i),c); erg += mult_apply_integer(c,monom); } else /* AK 040892 */ { erg += hoch(S_V_I(vec,i),S_PO_SI(zeiger,i),c); erg += mult_apply(c,monom); } } }; evalpoly3: if ( (S_O_K(monom) == INTEGER) && (S_O_K(res) == INTEGER) ) erg += add_apply_integer_integer(monom,res); else if (S_O_K(monom) == BRUCH) erg += add_apply_bruch(monom,res); else erg += add_apply(monom,res); zeiger = S_PO_N(zeiger); } erg += freeall(c); erg += freeall(monom); return erg; } INT m_vec_poly(a,c) OP a,c; /* AK 090805 */ /* input vec a out polynom c = ... a_i x^i */ { INT erg = OK; CTO(VECTOR,"m_vec_poly(1)",a); CE2(a,c,m_vec_poly); { INT i;OP z,zz; if (i==0) init(POLYNOM,c); else if (NULLP(a)) init(POLYNOM,c); else { zz= z = c; for (i=0;i maxvar) maxvar = S_V_II(a,i); } /* now the input is OK */ erg += b_skn_po(callocobject(),callocobject(),NULL,c); erg += m_i_i(1L,S_PO_K(c)); erg += m_il_nv(maxvar+1L,S_PO_S(c)); for (i=(INT)0;i 0L) { fprintf(texout,"*x%ld",i+1); texposition ++; if (S_PO_SII(zeiger,i) != 1L) { fprintf(texout,"^%ld",S_PO_SII(zeiger,i)); texposition += 10L; }; }; texposition += 1L; if (texposition > 70L) { fprintf(texout,"\n"); texposition = 0L; } zeiger = S_PO_N(zeiger); if (zeiger != NULL) if (not negp(S_PO_K(zeiger))) { fprintf(texout,"+"); texposition +=3L; } }; return(OK); } INT cast_apply_polynom(a) OP a; /* tries to transform the object a into a POLYNOM object */ /* AK 170206 V3.0 */ { INT erg = OK; COP("cast_apply_polynom(1)",a); switch (S_O_K(a)) { case BRUCH: case LONGINT: case INTEGER: erg += m_scalar_polynom(a,a); break; case MONOPOLY: erg += t_MONOPOLY_POLYNOM(a,a); break; default: erg += WTO("cast_apply_polynom",a); break; } ENDR("cast_apply_polynom"); } OP s_lc_poly(OP pol) /* AK 181203 */ /* pointer auf leading coeff */ { INT erg = OK; OP z; CTO(POLYNOM,"s_lc_poly(1)",pol); SYMCHECK (S_L_S(pol)==NULL,"s_lc_poly:null polynom"); z = S_PO_S(pol); SYMCHECK (( S_O_K(z)!= VECTOR )&&(S_O_K(z)!= INTEGERVECTOR), "s_lc_poly:wrong type of list self part"); SYMCHECK (S_V_LI(z)!= 1, "s_lc_poly:not a univariate polynomial"); z=pol; while (S_L_N(z)!=NULL) z=S_L_N(z); return S_PO_K(z); ENDO("s_lc_poly"); } INT content_polynom(OP a, OP b) /* AK 171203 */ { OP z; INT erg =OK; CTO(POLYNOM,"content_polynom(1)",a); if (NULLP(a)) { m_i_i(0,b); } copy(S_PO_K(a),b); FORALL(z,a,{ ggt(b,S_MO_K(z),b); }); ENDR("content_polynom"); } INT ggt_field_polynom(OP a, OP b, OP c) /* AK 170206 */ /* Cohen p.113 */ { INT erg = OK; CTO(POLYNOM,"ggt_field_polynom(1)",a); CTO(POLYNOM,"ggt_field_polynom(2)",b); { if (NULLP(b)) erg+=copy(a,c); else { OP q=callocobject(); OP r=callocobject(); erg += quores(a,b,q,r); erg += ggt_field_polynom(b,r,c); freeall(q); freeall(r); } } ENDR("ggt_field_polynom"); } INT ggt_polynom(OP a, OP b, OP c) /* AK 171203 */ { INT erg = OK; CTO(POLYNOM,"ggt_polynom(1)",a); CTO(POLYNOM,"ggt_polynom(2)",b); { OP aa,bb;OP q,r; OP ac,bc; OP d,z; if (NULLP(b)) { erg += copy(a,c); goto endr_ende;} aa=CALLOCOBJECT();content_polynom(a,aa); bb=CALLOCOBJECT();content_polynom(b,bb); d = CALLOCOBJECT(); ggt(aa,bb,d); invers_apply(bb); invers_apply(aa); ac = CALLOCOBJECT();mult_scalar_polynom(aa,a,ac);FREESELF(aa); bc = CALLOCOBJECT();mult_scalar_polynom(bb,b,bc);FREESELF(bb); degree_polynom(ac,aa); degree_polynom(bc,bb); if (LT(aa,bb)) swap(ac,bc); CALLOCOBJECT2(q,r); bb: FREESELF(aa); FREESELF(bb); degree_polynom(ac,aa); degree_polynom(bc,bb); /* aa >= bb is known */ sub(aa,bb,aa); inc(aa); hoch (s_lc_poly(bc),aa,bb); mult_apply(bb,ac); /* no coeff division necessary in quores */ quores(ac,bc,q,r); if (NULLP(r)) goto aa; FREESELF(q); degree_polynom(r,q); if (NULLP(q)) { eins(S_PO_K(r),bc); goto aa; } content_polynom(r,q); copy(bc,ac); invers_apply(q); FREESELF(bc); mult_scalar_polynom(q,r,bc); goto bb; aa: MULT(d,bc,c); FREEALL3(d,aa,bb); FREEALL4(ac,bc,q,r); } ENDR("ggt_polynom"); } INT derivative(OP pol, OP pold) /* AK 171203 */ { INT erg = OK; OP z; CTO(POLYNOM,"derivative(1)",pol); CE2(pol,pold,derivative); if (S_L_S(pol)==NULL) { erg += copy(pol,pold); goto endr_ende; } z = S_PO_S(pol); SYMCHECK (S_O_K(z)!= VECTOR, "derivative:wrong type of list self part"); SYMCHECK (S_V_LI(z)!= 1, "derivative:not a univariate polynomial"); if (S_V_II(z,0) == 0) { if (S_PO_N(pol)==NULL) { init(POLYNOM,pold); goto endr_ende; } pol = S_PO_N(pol); } COPY(pol,pold); FORALL(z,pold,{ MULT_APPLY(S_MO_SI(z,0),S_MO_K(z)); DEC(S_MO_SI(z,0)); }); ENDR("derivative"); } INT horner( OP point, OP vec, OP res) /* eval polynomial at point */ /* vec[0] constant term */ /* res = vec[0]+point*vec[1]+point^2 *vec[2]+ .. */ /* AK 300607 */ { INT erg = OK; CTTO(VECTOR,INTEGERVECTOR,"horner(2)",vec); CE3(point,vec,res,horner); { INT i; COPY(S_V_I(vec,S_V_LI(vec)-1), res); for (i=S_V_LI(vec)-2;i>=0;i--) { MULT_APPLY(point,res); ADD_APPLY(S_V_I(vec,i),res); } } ENDR("horner"); } #endif /* POLYTRUE */ symmetrica-2.0/poly.doc0000600017361200001450000003010110726170300015036 0ustar tabbottcrontabCOMMENT: /* file: poly.doc SYMMETRICA documentation */ POLYNOM ------- Polynomials are implemented as a LIST object of MONOM objects. Look also at the specific documentations. This means, that you have a next part, which is the next part of the list, it must be NULL if we are at the end of the list, or it is again a POLYNOM object. You have a self part, which is the self part of the monom and you have a koeff part, which is the koeff part of the monom. For a POLYNOM object it is necessary, that the selfpart is a VECTOR object of INTEGER objects. There is a set of routines which allows you to work directly with a POLYNOM object. These are NAME MACRO DESCRIPTION ------------------------------------------------------------------ s_po_n S_PO_N select_polynom_next s_po_s S_PO_S select_polynom_self s_po_si S_PO_SI select_polynom_self_ith_element = s_v_i(s_po_s) s_po_sii S_PO_SII select_polynom_self_ith_element_as_INT = s_v_ii(s_po_s) s_po_sl S_PO_SL select_polynom_self_length = s_v_l(s_po_s) s_po_sli S_PO_SLI select_polynom_self_length_as_INT = s_v_li(s_po_s) s_po_k S_PO_K select_polynom_koeff s_po_ki S_PO_KI select_polynom_koeff_as_INT = s_i_i(s_po_k) m_skn_po make_self_koeff_next_polynom b_skn_po build_self_koeff_next_polynom b_s_po build_self_polynom m_s_po make_self_polynom EXAMPLE: main() { OP a,b,c; anfang(); a = callocobject(); b = callocobject(); c = callocobject(); m_il_v(2,a);m_i_i(1L,s_v_i(a,0L)); m_i_i(2L,s_v_i(a,1L)); m_i_i(7L,b); b_skn_po(a,b,NULL,c); println(c); /* output is the polynom 7ab^2 */ freeall(c); ende(); } As in the cases with other objects, if we use m_skn_po instead of b_skn_po, we will work with copies of the self part next part and koeff part. So we have to call freeall(b) and freeall(c) at the end of the routine main() { OP a,b,c; anfang(); a = callocobject(); b = callocobject(); c = callocobject(); m_il_v(2,a);m_i_i(1L,s_v_i(a,0L)); m_i_i(2L,s_v_i(a,1L)); m_i_i(7L,b); m_skn_po(a,b,NULL,c); println(c); /* output is the polynom 7ab^2 */ freeall(a); freeall(b); freeall(c); ende(); } The routines b_s_po and m_s_po help to generate a POLYNOM object, where the self-part is given by the self parameter and the coefficent is given by the INTEGER object 1. The next part is NULL, which means we have a POLYNOM object which consist only of one MONOM object. !!!!!!!!!!! WARNING this is new in V1.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! If we use the standard routine init, we get an empty POLYNOM, which means, that the self is the NULL pointer and the next part is also NULL. !!!!!!!!!!! WARNING this is new in V1.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NAME: init_polynom SYNOPSIS: INT init_polynom(OP result) DESCRIPTION: the result becomes a POLYNOM object, which is a LIST object, with NULL as next and NULL as self EXAMPLE: But note that the example main() { OP c; anfang(); c =callocobject(); init(POLYNOM,c); println(s_po_s(c)); freeall(c); ende(); } produces an error, because the self part is not yet initialised. NAME: symmetrip_i SYNOPSIS: INT symmetricp_i(OP a; INT i) DESCRIPTION: checks wether a POLYNOM object a is symmetric in i-th and (i+1)-th variable. The numbering of the variables starts with 0. The return value is TRUE or FALSE. An error occures if i<0 or a is no POLYNOM object. COMMENT: If you want to get a TEX-output of a polynom, the standard routine tex() calls the special routine tex_polynom() which numbers the variables of the POLYNOM object by a,b,c,... NAME: tex_polynom SYNOPSIS: INT tex_polynom(OP a) DESCRIPTION: Do a texoutput of the POLYNOM object, if the coefficient is not unity it calls tex() for the coefficient, then it prints the variables named a,b,c... In general you should use the standard routine tex, not the speial one tex_polynom. COMMENT: A special kind of a POLYNOM are the socalled character polynomials and the Young polynomials: NAME: character_polynom SYNOPSIS: INT character_polynom(OP part, res) DESCRIPTION: computes the character polynom labeled by the PARTITION object part. The definition and method of computation is decribed in Kerber: combinatorics via finite group actions p. 197 The result is a POLYNOM object res. If you enter the empty object the result will be unity. NAME: young_polynom SYNOPSIS: INT young_polynom(OP part,res) DESCRIPTION: computes the Young polynom labeled by the PARTITION object part. The definition and method of computation is decribed in Kerber: combinatorics via finite group actions p. 189 The result is a POLYNOM object res. COMMENT: These POLYNOM objects give value of characters of the symmetric group. To evaluate the polynomials, there is special kind of functions, which is faster then the standard routine eval_polynom: NAME: eval_char_polynom SYNOPSIS: INT eval_char_polynom(OP pol,vec,res) DESCRIPTION: you enter a POLYNOM object pol, which should be a Young polynomial or a character polynomial enter a VECTOR object vec, which should be a cycle type, and the result, which is a character will be in the object res. COMMENT: One useful value is the degree of a single-variable polynomial NAME: degree_polynom SYNOPSIS: INT degree_polynom(OP a,b) DESCRIPTION: COMMENT: The evaluation of a POLYNOM at a given value of the variables: NAME: eval_polynom SYNOPSIS: INT eval_polynom(OP a,b,c) DESCRIPTION: you enter a POLYNOM object a, and an VECTOR object b, where the ith entry of the VECTOR object b gives the value for the specialization of the i-th variable. If the i-th entry is an empty object, you don't specialize the i-th variable. The output will be in c. NAME: gauss_polynom SYNOPSIS: INT gauss_polynom(a,b,c) DESCRIPTION: computing Gauss polynomial using recursion. NAME: gauss_schubert_polynom SYNOPSIS: INT gauss_polynom(a,b,c) DESCRIPTION: computing Gauss polynomial as a specialisation of Schubert polynomials (slower) NAME: is_scalar_polynom SYNOPSIS: INT is_scalar_polynom(OP a) DESCRIPTION: returns TRUE if the object a is a POLYNOM object, with only a constant term. Else the return value is FALSE. COMMENT: It is a well known fact, that for n given values at n given points, there is exactly one polynomial in one variable of degree n-1 with these values at these points, it is the so called Lagrange polynomial. NAME: lagrange_polynom SYNOPSIS: INT lagrange_polynom(OP a,b,c) DESCRIPTION: This routine computes the Lagrange polynomial which interpolates at the points in the VECTOR object a (which must be pairwise different), with the values in the VECTOR object b, which must be as long as a, the result is a POLYNOM object c, in one variable. EXAMPLE: #include "def.h" #include "macro.h" main() { OP a,b,c; anfang(); a=callocobject(); b=callocobject(); c=callocobject(); m_il_v(2L,a); m_i_i(1L, s_v_i(a,0L)); m_i_i(7L, s_v_i(a,1L)); m_il_v(2L,b); m_i_i(5L, s_v_i(b,0L)); m_i_i(7L, s_v_i(b,1L)); lagrange_polynom(a,b,c);println(c); freeall(a); freeall(b); freeall(c); ende(); } COMMENT: To build monomials in an easy way we have the routine m_iindex_monom, which allows to build polynomials like a + b + c .. . NAME: m_iindex_monom SYNOPSIS: INT m_iindex_monom(INT i; OP erg) DESCRIPTION: builds a POLYNOM object consisting of a single monomial which is the i-th variable. At first it frees the result to an empty object. There is a check whether i is >= 0. RETURN: ERROR if an error occures, OK else. EXAMPLE: #include "def.h" #include "macro.h" main() { OP a,b; INT i; anfang(); a=callocobject(); b=callocobject(); for (i=0L; i<= 10L; i++) { m_iindex_monom(i,b); add(b,a,a); } mult(a,a,b); println(b); freeall(a); freeall(b); ende(); COMMENT: This routine is a special case of the following, which allows you to generate the polynomial a_i ^ex NAME: m_iindex_iexponent_monom SYNOPSIS: INT m_iindex_iexponent_monom(INT i,ex; OP erg) DESCRIPTION: builds a POLYNOM object consisting of a single monomial which is the i-th variable, and the exponent of this variable is given by ex. First it frees the result to an empty object. There is a check whether i is >= 0. RETURN: ERROR if an error occures, OK else. NAME: m_scalar_polynom SYNOPSIS: INT m_scalar_polynom(OP a,b) DESCRIPTION: a is a scalar object, b becomes the result, again a POLYNOM object. a becomes the coefficent of the POLYNOM object with one single monomial, namely the monomial [0], i.e. a single variable, whose exponent is zero. NAME: m_vec_vec_polynom SYNOPSIS: INT m_vec_vec_polynom(OP a,b,c) DESCRIPTION: a nd b are VECTOR objects of the same length, whose entries are positive INTEGER objects. The output is a POLYNOM object with coeff 1, consisting of the singe monom c = product over a_i ^ b_i RETURN: OK or ERROR NAME: mult_disjunkt_polynom_polynom SYNOPSIS: INT mult_disjunkt_polynom_polynom(OP a,b,c) DESCRIPTION: a and b are POLYNOM objects and c becomes the result of the multiplication of a and b, where the alphabets of the two POLYNOM objects are taken different EXAMPLE: Read a POLYNOM and multiply it with itself, assumming the two alphabets to be different #include "def.h" #include "macro.h" main() { OP b,d; anfang(); b=callocobject(); d=callocobject(); scan(POLYNOM,b); mult_disjunkt_polynom_polynom(b,b,d); println(d); freeall(b); freeall(d); ende(); } NAME: numberofvariables SYNOPSIS: INT numberofvariables(OP pol,res) DESCRIPTION: computes the number of variables of the POLYNOM object pol. The result is a positiv INTEGER object res. If the self-part of pol is NULL, the result is zero. BUG: if you have for example the POLYNOM x_0 x_3 the result will be four, because the routines looks on the index of the highest exponent not equal to zero. NAME: polya_sub SYNOPSIS: INT polya_sub(OP a,c,b) DESCRIPTION: a is a POLYNOM object, b becomes the result, again a POLYNOM object, c is a INTEGER object, which gives the number of different variables in a. There is the substitution x_i becomes 1 + q^i, so the result is a POLYNOM object in one variable. EXAMPLE: Computes the Polya substitution in a Schur polynomial. #include "def.h" #include "macro.h" main() { OP a,b,c,d; anfang(); a=callocobject(); b=callocobject(); c=callocobject(); d=callocobject(); scan(PARTITION,a);println(a); scan(INTEGER,b);println(b); compute_schur_with_alphabet(a,b,c);println(c); polya_sub(c,b,d); println(d); freeall(a); freeall(b); freeall(c); freeall(d); ende(); } NAME: select_coeff_polynom SYNOPSIS: INT select_coeff_polynom(OP a,b,c) DESCRIPTION: you enter a POLYNOM object a, and an VECTOR object b, which must have INTEGER entries, this integer vector is treated as an exponent vector, the output is the coefficent which is the object c. This is a copy of the coefficent in the polynom. COMMENT: t_POLYNOM_SCHUBERT see sb.doc t_POLYNOM_MONOMIAL see sr.doc NAME: test_poly SYNOPSIS: INT test_poly() DESCRIPTION: checks the installation of the POLYNOM routines. NAME: unimodalp SYNOPSIS: INT unimodalp(OP a) DESCRIPTION: tests unimodality of a POLYNOM object RETURN: TRUE or FALSE COMMENT: GENERAL ROUTINES ---------------- add() add_apply() addinvers() addinvers_apply() comp() copy() einsp() fprint() fprintln() freeall() freeself(); hoch() mult() mult_apply() nullp() objectread() objectwrite() print() println() scan() input as a sum of monomial tex() symmetrica-2.0/ppe.c0000400017361200001450000001376410726021641014335 0ustar tabbottcrontab #include "def.h" #include "macro.h" INT ppe_ende() { INT erg = OK; ENDR("ppe_ende"); } INT m_merge_partition_partition(); INT ppe_integer_partition_(); INT ppe_integer_hashtable_(); INT ppe___(); INT ppe_null__(b,c,f) OP b,c,f; { return mxx_null__(b,c,f); } INT ppe_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"ppe_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"ppe_integer__(2)",b); CTTO(HASHTABLE,ELMSYM,"ppe_integer__(3)",c); SYMCHECK((S_I_I(a) < 0),"ppe_integer__:integer < 0"); if (S_I_I(a) == 0) erg += ppe_null__(b,c,f); if (S_O_K(b) == PARTITION) erg += ppe_integer_partition_(a,b,c,f); else M_FORALL_MONOMIALS_IN_B(a,b,c,f,ppe_integer_partition_); ENDR("ppe_integer__"); } INT mee_hashtable_hashtable_(); INT ppe_null_partition_(); INT ppe_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"ppe_partition__(1)",a); CTTTO(HASHTABLE,ELMSYM,PARTITION,"ppe_partition__(2)",b); CTTO(HASHTABLE,ELMSYM,"ppe_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += ppe_null__(b,c,f); } else if (S_PA_LI(a) == 1) { erg += ppe_integer__(S_PA_I(a,0),b,c,f); } else{ erg += p_splitpart(a,b,c,f,ppe_partition__, mee_hashtable_hashtable_); } ENDR("ppe_partition__"); } INT ppe_powsym__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(POWSYM,"ppe_powsym__(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"ppe_powsym__(2)",b); CTTO(HASHTABLE,ELMSYM,"ppe_powsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,ppe_partition__); ENDR("ppe_powsym__"); } INT ppe_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"ppe_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,ELMSYM,"ppe_hashtable__(2)",b); CTTO(HASHTABLE,ELMSYM,"ppe_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,ppe_partition__); ENDR("ppe_hashtable__"); } INT ppe_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"ppe_hashtable_hashtable_(1)",a); CTO(HASHTABLE,"ppe_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,ELMSYM,"ppe_hashtable_hashtable_(3)",c); NYI("ppe_hashtable_hashtable_"); ENDR("ppe_hashtable_hashtable_"); } INT ppe_null_partition_(b,c,f) OP b,c,f; /* AK 061201 */ { INT erg = OK; CTO(PARTITION,"ppe_null_partition(1)",b); CTTO(ELMSYM,HASHTABLE,"ppe_null_partition(2)",c); _NULL_PARTITION_(b,c,f); ENDR("ppe_null_partition"); } INT ppe_integer_integer_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; OP m; INT i; CTO(INTEGER,"ppe_integer_integer_(1)",a); CTO(INTEGER,"ppe_integer_integer_(2)",b); CTTO(ELMSYM,HASHTABLE,"ppe_integer_integer_(3)",c); SYMCHECK ((S_I_I(a) < 0),"ppe_integer_integer_:integer(1)<0"); SYMCHECK ((S_I_I(b) < 0),"ppe_integer_integer_:integer(2)<0"); if (S_I_I(a) == 0) { erg += ppe_null__(b,c,f); goto ende; } m = CALLOCOBJECT(); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),m); erg += m_il_v(S_I_I(b),S_PA_S(m)); C_O_K(S_PA_S(m),INTEGERVECTOR); for (i=0;iELMSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"plet_powsym_elmsym(1)",a); CTTTTO(HASHTABLE,PARTITION,ELMSYM,INTEGER,"plet_powsym_elmsym(2)",b); CTTTO(EMPTY,HASHTABLE,ELMSYM,"plet_powsym_elmsym(3)",c); if (S_O_K(c) == EMPTY) if (S_O_K(a) == INTEGER) init_elmsym(c); else { t=1; init_hashtable(c); } ppe___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_ELMSYM(c,c); ENDR("plet_powsym_elmsym"); } INT ppe___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"ppe___(1)",a); CTTTTO(HASHTABLE,PARTITION,ELMSYM,INTEGER,"ppe___(2)",b); CTTO(HASHTABLE,ELMSYM,"ppe___(3)",c); if (S_O_K(b) == INTEGER) { OP d; d = CALLOCOBJECT(); erg += m_i_pa(b,d); erg += ppe___(a,d,c,f); FREEALL(d); } else if (S_O_K(a) == INTEGER) { erg += ppe_integer__(a,b,c,f); } else if (S_O_K(a) == PARTITION) { erg += ppe_partition__(a,b,c,f); } else if (S_O_K(a) == POWSYM) { erg += ppe_powsym__(a,b,c,f); } else /* if (S_O_K(a) == HASHTABLE) */ { erg += ppe_hashtable__(a,b,c,f); } ENDR("ppe___"); } symmetrica-2.0/pph.c0000400017361200001450000002510210726021641014325 0ustar tabbottcrontab #include "def.h" #include "macro.h" INT pph_ende() { return OK; } INT m_merge_partition_partition(); INT pph_integer_partition_(); INT pph_integer_hashtable_(); INT pph_integer_integer_(); INT pph___(); INT tsp___faktor(); INT ppp___(); INT tep___faktor(); INT thp___faktor(); INT tmp___faktor(); INT pph_null__(b,c,f) OP b,c,f; { INT mxx_null__(); return mxx_null__(b,c,f); } INT pph_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"pph_integer__(1)",a); CTTTTO(HASHTABLE,PARTITION,HOMSYM,INTEGER,"pph_integer__(2)",b); CTTO(HASHTABLE,HOMSYM,"pph_integer__(3)",c); if (S_O_K(b) == PARTITION) erg += pph_integer_partition_(a,b,c,f); else if (S_O_K(b) == INTEGER) erg += pph_integer_integer_(a,b,c,f); else M_FORALL_MONOMIALS_IN_B(a,b,c,f,pph_integer_partition_); ENDR("pph_integer__"); } INT mpp_hashtable_hashtable_(); INT pph_null_partition_(); INT pph_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"pph_partition__(1)",a); CTTTTO(HASHTABLE,HOMSYM,PARTITION,INTEGER,"pph_partition__(2)",b); CTTO(HASHTABLE,HOMSYM,"pph_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += pph_null__(b,c,f); } else if (S_PA_LI(a) == 1) { erg += pph_integer__(S_PA_I(a,0),b,c,f); } else{ INT mhh_hashtable_hashtable_(); INT p_splitpart(); erg += p_splitpart(a,b,c,f,pph_partition__, mhh_hashtable_hashtable_); } ENDR("pph_partition__"); } INT pph_powsym__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(POWSYM,"pph_powsym__(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,HOMSYM,"pph_powsym__(2)",b); CTTO(HASHTABLE,HOMSYM,"pph_powsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,pph_partition__); ENDR("pph_powsym__"); } INT pph_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"pph_hashtable__(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,HOMSYM,"pph_hashtable__(2)",b); CTTO(HASHTABLE,HOMSYM,"pph_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,pph_partition__); ENDR("pph_hashtable__"); } INT pph_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"pph_hashtable_hashtable_(1)",a); CTO(HASHTABLE,"pph_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,HOMSYM,"pph_hashtable_hashtable_(3)",c); M_FORALL_MONOMIALS_IN_AB(a,b,c,f,pph_partition__); ENDR("pph_hashtable_hashtable_"); } INT pph_null_partition_(b,c,f) OP b,c,f; /* AK 061201 */ { INT erg = OK; CTO(PARTITION,"pph_null_partition(1)",b); CTTO(HOMSYM,HASHTABLE,"pph_null_partition(2)",c); _NULL_PARTITION_(b,c,f); ENDR("pph_null_partition"); } INT pph_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"pph_integer_partition_(1)",a); CTO(PARTITION,"pph_integer_partition_(2)",b); CTO(HASHTABLE,"pph_integer_partition_(3)",c); SYMCHECK ((S_I_I(a) < 0),"pph_integer_partition_:integer<0"); if (S_I_I(a) == 0) { erg += pph_null_partition_(b,c,f); goto ende; } else if (S_PA_LI(b) == 0) { erg += pph_null__(b,c,f); goto ende; } else if (S_PA_LI(b) == 1) { erg += pph_integer_integer_(a,S_PA_I(b,0),c,f); goto ende; } else { INT mhh_hashtable_hashtable_(); INT p_splitpart2(); erg += p_splitpart2(a,b,c,f,pph_integer_partition_, mhh_hashtable_hashtable_); goto ende; } ende: ENDR("pph_integer_partition_"); } INT pph_integer_integer_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; INT ppe_integer_integer_(); CTO(INTEGER,"pph_integer_integer_(1)",a); CTO(INTEGER,"pph_integer_integer_(2)",b); CTO(HASHTABLE,"pph_integer_integer_(3)",c); SYMCHECK ((S_I_I(a) < 0),"pph_integer_integer_:integer<0"); if (S_I_I(a) == 0) { erg += pph_null__(b,c,f); goto ende; } if (S_I_I(a) % 2 == 1) { erg += ppe_integer_integer_(a,b,c,f); goto ende; } else if (S_I_I(b) % 2 == 0) { erg += ppe_integer_integer_(a,b,c,f); goto ende; } else { OP ff; ff = CALLOCOBJECT(); ADDINVERS(f,ff); erg += ppe_integer_integer_(a,b,c,ff); FREEALL(ff); goto ende; } ende: CTO(HASHTABLE,"pph_integer_integer_(3-ende)",c); ENDR("pph_integer_integer_"); } INT pph_integer_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 061101 */ { INT erg = OK; CTO(INTEGER,"pph_integer_hashtable_(1)",a); CTTO(HASHTABLE,HOMSYM,"pph_integer_hashtable_(2)",b); CTTO(POWSYM,HASHTABLE,"integer_hashtable_(3)",c); SYMCHECK ((S_I_I(a) < 0),"pph_integer_hashtable_:integer<0"); if (S_I_I(a) == 0) { erg += pph_null__(b,c,f); goto ende; } M_FORALL_MONOMIALS_IN_B(a,b,c,f,pph_integer_partition_); ende: ENDR("pph_integer_hashtable_"); } INT pph___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"pph___(1)",a); CTTTTO(HASHTABLE,PARTITION,HOMSYM,INTEGER,"pph___(2)",b); CTO(HASHTABLE,"pph___(3)",c); if (S_O_K(a) == INTEGER) { erg += pph_integer__(a,b,c,f); } else if (S_O_K(a) == PARTITION) { erg += pph_partition__(a,b,c,f); } else if (S_O_K(a) == POWSYM) { erg += pph_powsym__(a,b,c,f); } else /* if (S_O_K(a) == HASHTABLE) */ { erg += pph_hashtable__(a,b,c,f); } ENDR("pph___"); } INT plet_powsym_homsym(a,b,c) OP a,b,c; /* AK 061201 */ { INT erg = OK; INT t=0; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"plet_powsym_homsym(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,HOMSYM,"plet_powsym_homsym(2)",b); CTTTO(EMPTY,HASHTABLE,HOMSYM,"plet_powsym_homsym(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } else if (S_O_K(c) == HOMSYM) { t=1; t_HOMSYM_HASHTABLE(c,c); } pph___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_HOMSYM(c,c); ENDR("plet_powsym_homsym"); } INT plet_schur_powsym(a,b,c) OP a,b,c; /* AK 061201 */ { INT t=0,erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,SCHUR,"plet_schur_powsym(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,POWSYM,"plet_schur_powsym(2)",b); CTTTO(EMPTY,HASHTABLE,POWSYM,"plet_schur_powsym(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } /* pph___(a,b,c,cons_eins); */ { /* via ppp with change of basis */ OP f = CALLOCOBJECT(); erg += init_hashtable(f); erg += tsp___faktor(a,f,cons_eins); erg += ppp___(f,b,c,cons_eins); FREEALL(f); } if (t==1) t_HASHTABLE_POWSYM(c,c); ENDR("plet_schur_powsym"); } /* elmsym plethysm */ INT plet_elmsym_powsym(a,b,c) OP a,b,c; /* AK 061201 */ { INT t=0,erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,ELMSYM,"plet_elmsym_powsym(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,POWSYM,"plet_elmsym_powsym(2)",b); CTTTO(EMPTY,HASHTABLE,POWSYM,"plet_elmsym_powsym(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } /* pph___(a,b,c,cons_eins); */ { /* via ppp with change of basis */ OP f = CALLOCOBJECT(); erg += init_hashtable(f); erg += tep___faktor(a,f,cons_eins); erg += ppp___(f,b,c,cons_eins); FREEALL(f); } if (t==1) t_HASHTABLE_POWSYM(c,c); ENDR("plet_elmsym_powsym"); } /* homsym plethysm */ INT plet_homsym_powsym(a,b,c) OP a,b,c; /* AK 061201 */ { INT t=0,erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"plet_homsym_powsym(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,POWSYM,"plet_homsym_powsym(2)",b); CTTTO(EMPTY,HASHTABLE,POWSYM,"plet_homsym_powsym(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } /* pph___(a,b,c,cons_eins); */ { /* via ppp with change of basis */ OP f = CALLOCOBJECT(); erg += init_hashtable(f); erg += thp___faktor(a,f,cons_eins); erg += ppp___(f,b,c,cons_eins); FREEALL(f); } if (t==1) t_HASHTABLE_POWSYM(c,c); ENDR("plet_homsym_powsym"); } /* monomial plethysm */ INT plet_monomial_schur(a,b,c) OP a,b,c; /* AK 061201 */ { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,MONOMIAL,"plet_monomial_schur(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"plet_monomial_schur(2)",b); CTTTO(EMPTY,HASHTABLE,SCHUR,"plet_monomial_schur(3)",c); { /* via ppp with change of basis */ OP d,e,f; NEW_HASHTABLE(d); NEW_HASHTABLE(e); NEW_HASHTABLE(f); erg += tmp___faktor(a,f,cons_eins); erg += tsp___faktor(b,d,cons_eins); erg += ppp___(f,d,e,cons_eins); FREEALL(d); FREEALL(f); erg += t_POWSYM_SCHUR(e,c); CTO(HASHTABLE,"plet_monomial_schur(ie)",e); FREEALL(e); } CTTO(HASHTABLE,SCHUR,"plet_monomial_schur(e3)",c); ENDR("plet_monomial_schur"); } INT plet_monomial_monomial(a,b,c) OP a,b,c; /* AK 061201 */ { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,MONOMIAL,"plet_monomial_monomial(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,MONOMIAL,"plet_monomial_monomial(2)",b); CTTTO(EMPTY,HASHTABLE,MONOMIAL,"plet_monomial_monomial(3)",c); /* if (S_O_K(c) == EMPTY) t=1; init_hashtable(c); } pph___(a,b,c,cons_eins); */ { /* via ppp with change of basis */ OP d = CALLOCOBJECT(); OP e = CALLOCOBJECT(); OP f = CALLOCOBJECT(); erg += init_hashtable(e); erg += init_hashtable(d); erg += init_hashtable(f); erg += tmp___faktor(a,f,cons_eins); erg += tmp___faktor(b,d,cons_eins); erg += ppp___(f,d,e,cons_eins); FREEALL(d); FREEALL(f); erg += t_POWSYM_MONOMIAL(e,c); FREEALL(e); } /* if (t==1) t_HASHTABLE_MONOMIAL(c,c); */ ENDR("plet_monomial_monomial"); } INT plet_monomial_powsym(a,b,c) OP a,b,c; /* AK 061201 */ { INT t=0,erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,MONOMIAL,"plet_monomial_powsym(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,POWSYM,"plet_monomial_powsym(2)",b); CTTTO(EMPTY,HASHTABLE,POWSYM,"plet_monomial_powsym(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } /* pph___(a,b,c,cons_eins); */ { /* via ppp with change of basis */ OP f = CALLOCOBJECT(); erg += init_hashtable(f); erg += tmp___faktor(a,f,cons_eins); erg += ppp___(f,b,c,cons_eins); FREEALL(f); } if (t==1) t_HASHTABLE_POWSYM(c,c); ENDR("plet_monomial_powsym"); } symmetrica-2.0/ppm.c0000400017361200001450000001606310726021642014341 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT ppm_ende() { return OK; } INT ppm_integer_partition_(); INT ppm_integer_hashtable_(); INT ppm_integer_integer_(); INT ppm___(); INT ppm_null__(b,c,f) OP b,c,f; { INT mxx_null__(); return mxx_null__(b,c,f); } INT ppm_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"ppm_integer__(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,MONOMIAL,"ppm_integer__(2)",b); CTTO(HASHTABLE,MONOMIAL,"ppm_integer__(3)",c); SYMCHECK((S_I_I(a) < 0),"ppm_integer__:integer < 0"); if (S_I_I(a) == 0) { erg += ppm_null__(b,c,f); goto ende; } else if (S_O_K(b) == PARTITION) { erg += ppm_integer_partition_(a,b,c,f); goto ende; } else if (S_O_K(b) == INTEGER) { erg += ppm_integer_integer_(a,b,c,f); goto ende; } else { M_FORALL_MONOMIALS_IN_B(a,b,c,f,ppm_integer_partition_); goto ende; } ende: CTTO(HASHTABLE,MONOMIAL,"ppm_integer__(e3)",c); ENDR("ppm_integer__"); } INT ppm_null_partition_(); INT ppm_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"ppm_partition__(1)",a); CTTTO(HASHTABLE,MONOMIAL,PARTITION,"ppm_partition__(2)",b); CTTO(HASHTABLE,MONOMIAL,"ppm_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += ppm_null__(b,c,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += ppm_integer__(S_PA_I(a,0),b,c,f); goto ende; } else{ INT mmm_hashtable_hashtable_(); INT p_splitpart(); erg += p_splitpart(a,b,c,f,ppm_partition__, mmm_hashtable_hashtable_); goto ende; } ende: CTTO(HASHTABLE,MONOMIAL,"ppm_partition__(e3)",c); ENDR("ppm_partition__"); } INT ppm_powsym__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(POWSYM,"ppm_powsym__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"ppm_powsym__(2)",b); CTTO(HASHTABLE,MONOMIAL,"ppm_powsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,ppm_partition__); CTTO(HASHTABLE,MONOMIAL,"ppm_powsym__(e3)",c); ENDR("ppm_powsym__"); } INT ppm_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"ppm_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"ppm_hashtable__(2)",b); CTTO(HASHTABLE,MONOMIAL,"ppm_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,ppm_partition__); CTTO(HASHTABLE,MONOMIAL,"ppm_hashtable__(e3)",c); ENDR("ppm_hashtable__"); } INT ppm_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"ppm_hashtable_hashtable_(1)",a); CTO(HASHTABLE,"ppm_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,MONOMIAL,"ppm_hashtable_hashtable_(3)",c); NYI("ppm_hashtable_hashtable_"); ENDR("ppm_hashtable_hashtable_"); } INT ppm_null_partition_(b,c,f) OP b,c,f; /* AK 061201 */ { INT erg = OK; CTO(PARTITION,"ppm_null_partition(1)",b); CTTO(MONOMIAL,HASHTABLE,"ppm_null_partition(2)",c); _NULL_PARTITION_(b,c,f); ENDR("ppm_null_partition"); } INT ppm_integer_integer_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"ppm_integer_integer_(1)",a); CTO(INTEGER,"ppm_integer_integer_(2)",b); CTTO(MONOMIAL,HASHTABLE,"ppm_integer_integer_(3)",c); SYMCHECK ((S_I_I(a) < 0),"ppm_integer_integer_:integer(1)<0"); SYMCHECK ((S_I_I(b) < 0),"ppm_integer_integer_:integer(2)<0"); if (S_I_I(a) == 0) { erg += ppm_null__(b,c,f); goto ende; } else { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(f,S_MO_K(m)); b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); m_il_integervector(1,S_PA_S(S_MO_S(m))); M_I_I(S_I_I(b)*S_I_I(a), S_PA_I(S_MO_S(m),0)); if (S_O_K(c) == HASHTABLE) insert_scalar_hashtable(m,c,add_koeff,eq_monomsymfunc,hash_monompartition); else insert_list(m,c,add_koeff,comp_monommonomial); goto ende; } ende: CTTO(MONOMIAL,HASHTABLE,"ppm_integer_integer_(3-ende)",c); ENDR("ppm_integer_integer_"); } INT ppm_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"ppm_integer_partition_(1)",a); CTO(PARTITION,"ppm_integer_partition_(2)",b); CTTO(MONOMIAL,HASHTABLE,"ppm_integer_partition_(3)",c); SYMCHECK ((S_I_I(a) < 0),"ppm_integer_partition_:integer<0"); if (S_I_I(a) == 0) { erg += ppm_null__(b,c,f); goto ende; } else if (S_PA_LI(b) == 0) { erg += ppm_null__(b,c,f); goto ende; } else { OP m; INT i; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(f,S_MO_K(m)); b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); m_il_integervector(S_PA_LI(b),S_PA_S(S_MO_S(m))); for (i=0;iPOWSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"plet_powsym_monomial(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"plet_powsym_monomial(2)",b); CTTTO(EMPTY,HASHTABLE,MONOMIAL,"plet_powsym_monomial(3)",c); if (S_O_K(c) == EMPTY) if (S_O_K(a) == INTEGER) init_monomial(c); else { t=1; init_hashtable(c); } ppm___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_MONOMIAL(c,c); ENDR("plet_powsym_monomial"); } INT ppm___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"ppm___(1)",a); CTTTO(HASHTABLE,PARTITION,MONOMIAL,"ppm___(2)",b); CTTO(HASHTABLE,POWSYM,"ppm___(3)",c); if (S_O_K(a) == INTEGER) { erg += ppm_integer__(a,b,c,f); goto ende; } else if (S_O_K(a) == PARTITION) { erg += ppm_partition__(a,b,c,f); goto ende; } else if (S_O_K(a) == POWSYM) { erg += ppm_powsym__(a,b,c,f); goto ende; } else /* if (S_O_K(a) == HASHTABLE) */ { erg += ppm_hashtable__(a,b,c,f); goto ende; } ende: CTTO(HASHTABLE,POWSYM,"ppm___(e3)",c); ENDR("ppm___"); } symmetrica-2.0/ppp.c0000400017361200001450000001212710726021643014342 0ustar tabbottcrontab #include "def.h" #include "macro.h" INT ppp_ende() { return OK; } INT m_merge_partition_partition(); INT ppp_integer_partition_(); INT ppp_integer_hashtable_(); INT ppp___(); INT mpp_hashtable_hashtable_(); INT ppp_null_partition_(); INT p_splitpart(); INT mxx_null__(); INT ppp_null__(b,c,f) OP b,c,f; { return mxx_null__(b,c,f); } INT ppp_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; CTO(INTEGER,"ppp_integer__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"ppp_integer__(2)",b); CTTO(HASHTABLE,POWSYM,"ppp_integer__(3)",c); SYMCHECK((S_I_I(a) < 0),"ppp_integer__:integer < 0"); if (S_I_I(a) == 0) erg += ppp_null__(b,c,f); if (S_O_K(b) == PARTITION) erg += ppp_integer_partition_(a,b,c,f); else M_FORALL_MONOMIALS_IN_B(a,b,c,f,ppp_integer_partition_); ENDR("ppp_integer__"); } INT ppp_partition__(a,b,c,f) OP a,b,c; OP f; { INT erg = OK; CTO(PARTITION,"ppp_partition__(1)",a); CTTTO(HASHTABLE,POWSYM,PARTITION,"ppp_partition__(2)",b); CTTO(HASHTABLE,POWSYM,"ppp_partition__(3)",c); if (S_PA_LI(a) == 0) { erg += ppp_null__(b,c,f); } else if (S_PA_LI(a) == 1) { erg += ppp_integer__(S_PA_I(a,0),b,c,f); } else{ erg += p_splitpart(a,b,c,f,ppp_partition__, mpp_hashtable_hashtable_); } ENDR("ppp_partition__"); } INT ppp_powsym__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(POWSYM,"ppp_powsym__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"ppp_powsym__(2)",b); CTTO(HASHTABLE,POWSYM,"ppp_powsym__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,ppp_partition__); ENDR("ppp_powsym__"); } INT ppp_hashtable__(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"ppp_hashtable__(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"ppp_hashtable__(2)",b); CTTO(HASHTABLE,POWSYM,"ppp_hashtable__(3)",c); M_FORALL_MONOMIALS_IN_A(a,b,c,f,ppp_partition__); ENDR("ppp_hashtable__"); } INT ppp_hashtable_hashtable_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ /* c += p_a [p_b] \times f */ { INT erg = OK; CTO(HASHTABLE,"ppp_hashtable_hashtable_(1)",a); CTO(HASHTABLE,"ppp_hashtable_hashtable_(2)",b); CTTO(HASHTABLE,POWSYM,"ppp_hashtable_hashtable_(3)",c); NYI("ppp_hashtable_hashtable_"); ENDR("ppp_hashtable_hashtable_"); } INT ppp_null_partition_(b,c,f) OP b,c,f; /* AK 061201 */ { INT erg = OK; CTO(PARTITION,"ppp_null_partition(1)",b); CTTO(POWSYM,HASHTABLE,"ppp_null_partition(2)",c); _NULL_PARTITION_(b,c,f); ENDR("ppp_null_partition"); } INT ppp_integer_partition_(a,b,c,f) OP a,b,c,f; /* AK 051201 */ { INT erg = OK; OP m; INT i; CTO(INTEGER,"ppp_integer_partition_(1)",a); CTO(PARTITION,"ppp_integer_partition_(2)",b); CTTO(POWSYM,HASHTABLE,"ppp_integer_partition_(3)",c); SYMCHECK ((S_I_I(a) < 0),"ppp_integer_partition_:integer<0"); if (S_I_I(a) == 0) { erg += ppp_null__(b,c,f); goto ende; } m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); erg += m_il_v(S_PA_LI(b),S_PA_S(S_MO_S(m))); C_O_K(S_PA_S(S_MO_S(m)),INTEGERVECTOR); COPY(f, S_MO_K(m)); for (i=0;iPOWSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"plet_powsym_powsym(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"plet_powsym_powsym(2)",b); CTTTO(EMPTY,HASHTABLE,POWSYM,"plet_powsym_powsym(3)",c); if (S_O_K(c) == EMPTY) if (S_O_K(a) == INTEGER) init_powsym(c); else { t=1; init_hashtable(c); } ppp___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_POWSYM(c,c); ENDR("plet_powsym_powsym"); } INT ppp___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"ppp___(1)",a); CTTTO(HASHTABLE,PARTITION,POWSYM,"ppp___(2)",b); CTTO(HASHTABLE,POWSYM,"ppp___(3)",c); if (S_O_K(a) == INTEGER) { erg += ppp_integer__(a,b,c,f); } else if (S_O_K(a) == PARTITION) { erg += ppp_partition__(a,b,c,f); } else if (S_O_K(a) == POWSYM) { erg += ppp_powsym__(a,b,c,f); } else /* if (S_O_K(a) == HASHTABLE) */ { erg += ppp_hashtable__(a,b,c,f); } ENDR("ppp___"); } symmetrica-2.0/pps.c0000400017361200001450000001242610726021643014347 0ustar tabbottcrontab/* pps.c */ /* plethysm p_I[S_J] in the basis of schur function */ #include "def.h" #include "macro.h" INT pps_ende() { INT erg = OK; ENDR("pps_ende"); } extern INT pps_integer_partition_(); extern INT pps_integer_hashtable_(); extern INT pps_integer_integer_(); extern INT pps___(); extern INT tsm___faktor(); INT pps_null__(b,c,f) OP b,c,f; { INT mxx_null__(); return mxx_null__(b,c,f); } INT pps_integer__(a,b,c,f) OP a,b,c; OP f; /* AK 051201 */ { INT erg = OK; OP ff,p,z; INT i; INT mms_hashtable__(), tsm___faktor(); CTO(INTEGER,"pps_integer__(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"pps_integer__(2)",b); CTTO(HASHTABLE,SCHUR,"pps_integer__(3)",c); SYMCHECK((S_I_I(a) < 0),"pps_integer__:integer < 0"); if (S_I_I(a) == 0) { erg += pps_null__(b,c,f); goto ende; } ff = CALLOCOBJECT(); erg += init_hashtable(ff); tsm___faktor(b,ff,f); FORALL(z,ff,{ for (i=0;iPOWSYM necessary */ CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"plet_powsym_schur(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"plet_powsym_schur(2)",b); CTTTO(EMPTY,HASHTABLE,SCHUR,"plet_powsym_schur(3)",c); if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } pps___(a,b,c,cons_eins); if (t==1) t_HASHTABLE_SCHUR(c,c); ENDR("plet_powsym_schur"); } INT pps___(a,b,c,f) OP a,b,c,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"pps___(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"pps___(2)",b); CTTO(HASHTABLE,SCHUR,"pps___(3)",c); if (S_O_K(b) == INTEGER) /* AK 090703 */ { OP d = CALLOCOBJECT(); erg += m_i_pa(b,d); erg += pps___(a,d,c,f); FREEALL(d); } else if (S_O_K(a) == INTEGER) { erg += pps_integer__(a,b,c,f); } else if (S_O_K(a) == PARTITION) { erg += pps_partition__(a,b,c,f); } else if (S_O_K(a) == POWSYM) { erg += pps_powsym__(a,b,c,f); } else /* if (S_O_K(a) == HASHTABLE) */ { erg += pps_hashtable__(a,b,c,f); } ENDR("pps___"); } INT plet_powsym_schur_via_ppm(a,b,c) OP a,b,c; /* AK 061201 */ { INT t=0,erg = OK; CTTTTO(HASHTABLE,INTEGER,PARTITION,POWSYM,"plet_powsym_schur(1)",a); CTTTTO(INTEGER,HASHTABLE,PARTITION,SCHUR,"plet_powsym_schur(2)",b); CTTTO(EMPTY,HASHTABLE,SCHUR,"plet_powsym_schur(3)",c); /* if (S_O_K(c) == EMPTY) { t=1; init_hashtable(c); } pse___(a,b,c,cons_eins); */ { /* via ppm with change of basis */ OP f = CALLOCOBJECT(); OP d = CALLOCOBJECT(); erg += init_hashtable(f); erg += init_hashtable(d); erg += tsm___faktor(b,f,cons_eins); erg += ppm___(a,f,d,cons_eins); FREEALL(f); erg += t_MONOMIAL_SCHUR(d,c,cons_eins); FREEALL(d); } /* if (t==1) t_HASHTABLE_SCHUR(c,c); */ ENDR("plet_powsym_schur"); } symmetrica-2.0/pr.c0000400017361200001450000003255510726021644014174 0ustar tabbottcrontab /*****************************************************************************/ /* BERECHNUNG DER PROJEKTIVEN MATRIXDARSTELLUNG DER S_n */ /* NACH NAZAROV */ /*****************************************************************************/ /* Christine Barop Jan.93 */ /*****************************************************************************/ #include "def.h" #include "macro.h" #define PR_RH_MAX (INT)100 static OP S_lambda; /* Vektor mit allen standard shifted */ /* Tableaux mit Umriss lambda */ static OP phi, rho; /* Nazarov's phi- und rho-Funktion */ static OP zwei, vier, m_eins, compl, m_compl; /* Konstanten */ static OP e; /* Starteitrag von S_lambda */ static OP M; /* Vektor mit den Basismatr. der Cliff.alg */ static OP E, I, J, K; /* Pauli- Basis */ static OP A, B; /* Operation von t_k auf S_lambda */ static OP G; /* Indices der M-Matr. im Tensorprod.*/ static INT rh_ccsert(); static INT rh_ccstka(); static INT rh_cnsert(); static INT rh_celete(); static INT rh_cusgabemat(); static INT ccstka_tab_partition(); static INT phi_funkt(); static INT rho_funkt(); static INT ini_kons(); static INT ini_slam(); static INT pauli(); static INT m_matr(); static INT ab_matr(); static INT hoehe(); INT prsym(lambda, T_v) OP lambda, T_v; /*****************************************************************************/ /* BERECHNUNG DER PROJEKTIVEN MATRIXDARSTELLUNG DER TRANSPOSITION t_k */ /* NACH NAZAROV */ /*****************************************************************************/ /* Christine Barop Jan.93 */ /*****************************************************************************/ { INT i,j,l,ll, nr; /* Zaehlvariablen */ INT len; /* #(S_lambda) */ INT k; /* Index der Transposition */ INT m; /* 2*m +1 = Rang der Clifford--Alg. */ INT g; /* Nazarov's g--Funktion */ INT m_lambda, n_lambda; /* Laenge und max. Teil der Part.*/ INT dim, hi, lf; /* Hilfsvariablen */ OP eps; /* epsilon-Parameter */ OP n; /* Gewicht der Partition */ OP T_k; /* Darstellende Matrix von t_k */ OP M_eins, M_zwei; /* M_g und M_(g-1) */ OP kk; /* Nummer der Transposition */ OP p, q; /* Hoehe von k, k+1 im Tableau */ OP x, y/* , z*/; /* Hilfsvariablen fuer versch. Zwecke*/ OP gg; /* Nazarov's g-Funktion als INT */ OP D; /* Darstellende Matrix */ n=callocobject(); p=callocobject(); q=callocobject(); x=callocobject(); y=callocobject(); phi=callocobject(); rho=callocobject(); S_lambda=callocobject(); e=callocobject(); eps=callocobject(); zwei=callocobject(); vier=callocobject(); m_eins=callocobject(); compl=callocobject(); m_compl=callocobject(); A=callocobject(); M=callocobject(); E=callocobject(); I=callocobject(); J=callocobject(); K=callocobject(); B=callocobject(); T_k=callocobject(); G=callocobject(); D=callocobject(); M_eins=callocobject(); M_zwei=callocobject(); kk=callocobject(); gg=callocobject(); ini_kons(); pauli(); ini_slam(); weight(lambda,n); /* Berechnung von S_lambda */ ccstka_tab_partition(lambda,n); /* Dimensionen und Hilfsgroessen */ m_lambda = S_PA_LI(lambda); n_lambda = S_PA_II(lambda,m_lambda-1L); m_i_i(m_lambda,x); sub(n,x,y); ganzdiv(y,zwei,y); m=S_I_I(y); m_ilih_m(1L,1L,eps); copy(cons_eins,S_M_IJ(eps,0L,0L)); m_matr(m,eps); /* Anzahl der Tableaux */ len=0L; while(S_M_LI(S_V_I(S_lambda,len++))!=1L); len--; /* Berechnung der T_k */ add(n,cons_eins,x); m_l_v(x,T_v); for(i=0L;i0L) { copy(S_V_I(M,g),M_eins); copy(S_V_I(M,g-1L),M_zwei); for(l=0;l1L) mult(S_M_IJ(B,i,j),S_M_IJ(M_zwei,l,ll),y); else m_i_i(0L,y); hi = i*dim +l; lf=j*dim +ll; add(x,y,S_M_IJ(T_k,hi,lf)); } } } copy(T_k,S_V_I(T_v,k)); } hi = S_M_LI(S_V_I(T_v,1)); m_ilih_nm(hi,hi,T_k); for(l=0;l0L) { p=pa[l]-um[l]+l-1; if((l==1L)||(tab[l-1][p+1]!=0L)) { um[l]--; rh_ccsert(tab,st,l,p+1L); rh_ccstka(tab,st+1L,1L,um,m,pa,n); rh_celete(tab,st,l,p+1L); um[l]++; } } } } } static INT rh_cusgabemat(tab,z,s) INT tab[PR_RH_MAX][PR_RH_MAX],z,s; /* c ist liste, d ist umriss */ /* Ralf Hager 1989 */ /* AK 281289 V1.1 */ /* AK 210891 V1.3 */ { INT i; INT j; OP e = callocobject(); OP f = callocobject(); m_ilih_nm(s+1L,z+1L,f); for (i=0L;i <=z; i++) for (j=0L;j <=s; j++) if(tab[i][j] > 0L) m_i_i(tab[i][j],S_M_IJ(f,i,j)); for(i=0L;i<=PR_RH_MAX;i++) if(S_M_LI(S_V_I(S_lambda,i))==1L) { copy(f,S_V_I(S_lambda,i)); break; } freeall(e); /* AK 130392 */ freeall(f); /* AK 071093 */ return OK; } static INT rh_ccsert(v,zz,i,j) INT v[PR_RH_MAX][PR_RH_MAX]; INT zz,i,j; { v[i][j]=zz; return(OK); } static INT rh_celete(v,z,i,j) INT v[PR_RH_MAX][PR_RH_MAX]; INT z,i,j; { v[i][j]=0L; return(OK); } static INT m_matr(m,eps) OP eps; INT m; /* CB */ { OP EM = callocobject(); OP JM = callocobject(); OP x = callocobject(); OP y = callocobject(); INT i,i_eins; /* Berechnung der M-Matrizen */ i_eins = m; i_eins++; m_il_v(i_eins,EM); m_il_v(i_eins,JM); i_eins--; i_eins = 2L*i_eins+2L; m_il_v(i_eins,M); m_ilih_m(1L,1L,x); copy(cons_eins,S_M_IJ(x,0L,0L)); copy(x,S_V_I(EM,0L)); copy(x,S_V_I(JM,0L)); for(i=1; i<= m; i++) { kronecker_product(E,S_V_I(EM,i-1L),x); kronecker_product(J,S_V_I(JM,i-1L),y); copy(x,S_V_I(EM,i)); copy(y,S_V_I(JM,i)); } copy(S_V_I(JM,m),S_V_I(M,1L)); for(i=1;i<=m;i++) { kronecker_product(K,S_V_I(JM,m-i),x); kronecker_product(S_V_I(EM,i-1L),x,x); kronecker_product(eps,x,S_V_I(M,2*i),x); kronecker_product(I,S_V_I(JM,m-i),x); kronecker_product(S_V_I(EM,i-1L),x,x); kronecker_product(eps,x,S_V_I(M,2*i+1L)); } freeall(EM); freeall(JM); freeall(x); freeall(y); return(OK); } static INT ab_matr(m_lambda,n_lambda,len,k) INT len,k; INT m_lambda, n_lambda; { /* Berechnung der A- und ggf. B-Matrizen */ OP T =callocobject(); OP gg = callocobject(); OP p = callocobject(); OP q = callocobject(); OP Th = callocobject(); OP x = callocobject(); OP kk = callocobject(); INT j,l,g; INT pp, qq; /* Hoehe von k, k+1 im Tableau */ INT *ppp, *qqq; /* Hoehe von k, k+1 im Tableau */ INT *ip, *jp, *iq, *jq; /* Koordinaten von k, k+1 im Tableau */ INT *hilf; /* Schon betrachtete Tableaux */ hilf = (INT *) SYM_malloc(PR_RH_MAX * sizeof(INT)); ppp = (INT *) SYM_malloc(sizeof(INT)); qqq = (INT *) SYM_malloc(sizeof(INT)); jp = (INT *) SYM_malloc(sizeof(INT)); ip = (INT *) SYM_malloc(sizeof(INT)); iq = (INT *) SYM_malloc(sizeof(INT)); jq = (INT *) SYM_malloc(sizeof(INT)); m_ilih_nm(len,len,A); m_ilih_nm(len,len,B); m_ilih_nm(len,len,G); for(j=0L;j=0L;i--) /* AK 161091 */ { SYM_free(freeall_speicher[i]); /* AK 161091 */ } SYM_FREE(freeall_speicher); /* AK 161091 */ return OK; } INT freeall_magma(a) OP a; { if (not EMPTYP(a)) freeself(a); SYM_FREE(a); return OK; } INT freeall(a) OP a; /* AK 101286 */ /* AK 280689 V1.0 */ /* AK 071289 V1.1 */ /* AK 270291 V1.2 */ /* AK 050891 V1.3 */ { INT erg = OK; COP("freeall(1)",a); if (not EMPTYP(a)) erg += freeself(a); if (freeall_speicherposition+1 == freeall_speichersize) /* AK 231001 */ { freeall_speicher = (OP *) SYM_realloc(freeall_speicher, (freeall_speichersize+SPEICHERSIZE)*sizeof(OP)); SYMCHECK( (freeall_speicher == NULL) ,"freeall:no more memory"); freeall_speichersize = freeall_speichersize+SPEICHERSIZE; } freeall_speicher[++freeall_speicherposition] = a; ENDR("freeall"); } INT freeself(a) OP a; /* AK 061186 */ /* AK 280689 V1.0 */ /* AK 041289 V1.1 */ /* AK 050891 V1.3 */ /* AK 070498 V2.0 */ { INT erg=OK; COP("freeself(1)",a); switch(S_O_K(a)) { case EMPTY: break; #ifdef BINTREETRUE case BINTREE : erg += freeself_bintree(a); break; #endif /* BINTREETRUE */ #ifdef BRUCHTRUE case BRUCH : erg += freeself_bruch(a); break; #endif /* BRUCHTRUE */ #ifdef FFTRUE case FF : erg += freeself_ff(a); break; #endif /* FFTRUE */ case INTEGER : erg += FREESELF_INTEGER(a); break; #ifdef LISTTRUE case GRAL: case HOM_SYM: case POW_SYM: case MONOPOLY: case POLYNOM: case SCHUR: case SCHUBERT: case ELM_SYM: case LIST: case MONOMIAL: erg += freeself_list(a); break; #endif /* LISTTRUE */ #ifdef LONGINTTRUE case LONGINT : erg += freeself_longint(a); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS : erg += freeself_kranztypus(a); break; case KOSTKA : case MATRIX : erg += freeself_matrix(a); break; case INTEGERMATRIX: erg += freeself_integermatrix(a); break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM : erg += freeself_monom(a); break; #endif /* MONOMTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: case CYCLOTOMIC: erg += freeself_number(a); break; #endif /* NUMBERTRUE */ #ifdef PARTTRUE case AUG_PART : case CHARPARTITION: case PARTITION : erg += freeself_partition(a); break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION : erg += freeself_permutation(a); break; #endif /* PERMTRUE */ #ifdef REIHETRUE case REIHE : erg += freeself_reihe(a); break; #endif /* REIHETRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION : erg += freeself_skewpartition(a); break; #endif /* PERMTRUE */ #ifdef CHARTRUE case SYMCHAR : erg += freeself_symchar(a); break; #endif /* CHARTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX : erg += freeself_tableaux(a); break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case HASHTABLE: erg += freeself_hashtable(a); break; case LAURENT: erg += freeself_laurent(a); break; #ifdef KRANZTRUE case KRANZ: erg += freeself_kranz(a); break; #endif /* KRANZTRUE */ case WORD: case QUEUE: case VECTOR: erg += freeself_vector(a); break; case BITVECTOR: erg += freeself_bitvector(a); break; case SUBSET: case INTEGERVECTOR: case COMPOSITION: erg += freeself_integervector(a); break; case GALOISRING: erg += freeself_galois(a); break; #endif /* VECTORTRUE */ default: erg += WTO("freeself(1)",a); break; }; CTO(EMPTY,"freeself(e1)",a); ENDR("freeself"); } INT copy(a,b) OP a, b; /* AK 280689 V1.0 */ /* AK 201289 V1.1 */ /* AK 050891 V1.3 */ { INT erg = OK; if (sym_timelimit > 0L) check_time(); if (a == b) return(OK); COP("copy(1)",a); COP("copy(2)",b); FREESELF(b); switch(S_O_K(a)) { case EMPTY: break; #ifdef BINTREETRUE case BINTREE : erg += copy_bintree(a,b); break; #endif /* BINTREETRUE */ #ifdef BRUCHTRUE case BRUCH : erg += copy_bruch(a,b); break; #endif /* BRUCHTRUE */ #ifdef FFTRUE case FF: erg += copy_ff(a,b); break; #endif /* FFTRUE */ #ifdef INTEGERTRUE case INTEGER : COPY_INTEGER(a,b); break; #endif /* INTEGERTRUE */ #ifdef LISTTRUE case POLYNOM: case GRAL: case MONOPOLY: case SCHUBERT: case LIST : erg += copy_list(a,b); break; case SCHUR: erg += copy_schur(a,b); break; case HOMSYM: erg += copy_homsym(a,b); break; case MONOMIAL: erg += copy_monomial(a,b); break; case POWSYM: erg += copy_powsym(a,b); break; case ELMSYM: erg += copy_elmsym(a,b); break; #endif /* LISTTRUE */ #ifdef LONGINTTRUE case LONGINT : erg += copy_longint(a,b); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case INTEGERMATRIX: erg += copy_integermatrix(a,b); break; case KRANZTYPUS : erg += copy_kranztypus(a,b); break; case KOSTKA : case MATRIX : erg += copy_matrix(a,b); break; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM : erg += copy_monom(a,b); break; #endif /* MONOMTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: case CYCLOTOMIC: erg += copy_number(a,b);break; #endif /* NUMBERTRUE */ #ifdef PARTTRUE case AUG_PART : case PARTITION : erg += copy_partition(a,b);break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION : erg += copy_permutation(a,b);break; #endif /* PERMTRUE */ #ifdef REIHETRUE case REIHE : erg += copy_reihe(a,b);break; #endif /* REIHETRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION : erg += copy_skewpartition(a,b);break; #endif /* SKEWPARTTRUE */ #ifdef CHARTRUE case SYMCHAR : erg += copy_symchar(a,b);break; #endif /* CHARTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX : erg += copy_tableaux(a,b);break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case HASHTABLE: erg += copy_hashtable(a,b); break; case COMPOSITION: erg += copy_composition(a,b); break; case WORD: erg += copy_word(a,b); break; case KRANZ: erg += copy_kranz(a,b); break; case SUBSET: erg += copy_subset(a,b); break; case LAURENT: erg += copy_laurent(a,b); break; case QUEUE: erg += copy_queue(a,b); break; case VECTOR: erg += copy_vector(a,b); break; case INTEGERVECTOR: erg += copy_integervector(a,b); break; case GALOISRING: erg += copy_galois(a,b); break; case BITVECTOR: erg += copy_bitvector(a,b); break; #endif /* VECTORTRUE */ default: erg+= WTO("copy(1)",a); break; }; ENDR("copy"); } INT append_apply(a,b) OP a,b; /* AK 060901 */ /* a := [a1,...,ak,b1,...,bl] */ { INT erg = OK; COP("append_apply(1)",a); COP("append_apply(2)",b); /* a and b may be equal here */ switch(S_O_K(a)) { #ifdef PARTTRUE case PARTITION : erg += append_apply_part(a,b); break; #endif /* PARTTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case WORD: case QUEUE: case COMPOSITION: case SUBSET: case VECTOR : erg += append_apply_vector(a,b); break; #endif /* VECTORTRUE */ default: erg+= WTO("append_apply",a); break; }; ENDR("append_apply"); } INT append(a,b,e) OP a,b,e; /* AK 280689 V1.0 */ /* AK 221289 V1.1 */ /* AK 190291 V1.2 */ /* AK 090891 V1.3 */ /* e := [a1,...,ak,b1,...,bl] */ /* AK 241006 V3.1 */ { INT erg = OK; if (a == e) { erg += append_apply(a,b); goto endr_ende; } CE3(a,b,e,append); if (EMPTYP(b)) { erg += copy(a,e); goto endr_ende; } switch(S_O_K(a)) { case LIST: /* missing */ NYI("append with lists"); break; #ifdef PARTTRUE case PARTITION : erg += append_part_part(a,b,e); break; #endif /* PARTTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case WORD: case QUEUE: case COMPOSITION: case SUBSET: case VECTOR : erg += append_vector(a,b,e); break; #endif /* VECTORTRUE */ default: erg+= WTO("append",a); break; }; ENDR("append"); } INT scalarp(a) OP a; /* test ob scalarer datentyp Fri Mar 3 12:43:30 MEZ 1989 AK wahr falls INTEGER,LONGINT,BRUCH */ /* AK 280689 V1.0 */ /* AK 221289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("scalarp(1)",a); switch(S_O_K(a)) { case BRUCH: case INTEGER: case LONGINT: return(TRUE); default: return(FALSE); } ENDR("scalarp"); } INT dynamicp(a) OP a; /* test ob dynamische datenstruktur */ /* Tue Jan 10 07:16:33 MEZ 1989 */ /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 050891 V1.3 */ { INT erg = OK; COP("dynamicp",a); switch (S_O_K(a)) { case GRAL: case HOM_SYM: case POW_SYM: case BINTREE: case MONOPOLY: case SCHUR: case SCHUBERT: case LIST: case ELM_SYM: case MONOMIAL: case POLYNOM: return(TRUE); default: return(FALSE); } ENDR("dynamicp"); } INT nullp(a) OP a; /* 290388 aus macro */ /* AK 280689 V1.0 */ /* AK 081289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; EOP("nullp(1)",a); switch (S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH: return(NULLP_BRUCH(a)); #endif /* BRUCHTRUE */ case INTEGER: return (NULLP_INTEGER(a)); #ifdef FFTRUE case FF: return nullp_ff(a); #endif /* FFTRUE */ #ifdef GRTRUE case GALOISRING: return nullp_galois(a); #endif /* GRTRUE */ #ifdef LONGINTTRUE case LONGINT: return nullp_longint(a); #endif /* LONGINTTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: return nullp_cyclo(a); #endif /* CYCLOTRUE */ #ifdef MONOPOLYTRUE case MONOPOLY: return nullp_monopoly(a); /* AK 290395 */ #endif /* MONOPOLYTRUE */ #ifdef MATRIXTRUE case INTEGERMATRIX: return nullp_integermatrix(a); case MATRIX: return nullp_matrix(a); #endif /* MATRIXTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: return nullp_sqrad(a); #endif /* SQRADTRUE */ #ifdef SCHUBERTTRUE case SCHUBERT: return nullp_schubert(a); /* AL 180393 */ #endif /* SCHUBERTTRUE */ #ifdef SCHURTRUE case ELM_SYM: return nullp_elmsym(a); case POW_SYM: return nullp_powsym(a); case HOM_SYM: return nullp_homsym(a); case MONOMIAL: return nullp_monomial(a); case SCHUR: return nullp_schur(a); #endif /* SCHURTRUE */ #ifdef CHARTRUE case SYMCHAR: return nullp_symchar(a); /* AK 010692 */ #endif /* CHARTRUE */ #ifdef POLYTRUE case POLYNOM: return nullp_polynom(a); #endif /* POLYTRUE */ #ifdef REIHETRUE case REIHE: return nullp_reihe(a); #endif /* REIHETRUE */ #ifdef VECTORTRUE /* AK 311091 */ case INTEGERVECTOR: return nullp_integervector(a); case VECTOR: return nullp_vector(a); case BITVECTOR: return nullp_bitvector(a); case HASHTABLE: return nullp_integer(S_V_I(a,S_V_LI(a))); #endif /* VECTORTRUE */ case MONOM: return NULLP(S_MO_K(a)); default: WTO("nullp",a); }; ENDR("nullp"); } INT bit(a,i) OP a; INT i; /* returns the i-th bit of a */ /* in the case of longint with out sign */ /* AK 200902 V2.1 */ { INT erg = OK; CTTO(INTEGER,LONGINT,"bit(1)",a); SYMCHECK(i<0,"bit: neg index"); { if (S_O_K(a) == INTEGER) { INT l; if (i>=32) return 0; l = S_I_I(a); return (l>>i)&1; } else { return bit_longint(a,i); } } ENDR("bit"); } INT eins_default(a,b) OP a,b; /* AK 200902 V2.1 */ { INT erg = OK; erg += m_i_i(1,b); cast_apply(S_O_K(a),b); ENDR("eins_default"); } INT eins(a,b) OP a,b; /* a any object b becomes identity in the object class of a */ /* AK 200902 V2.1 */ /* AK 120804 V3.0 */ /* AK 231106 V3.1 */ { INT erg = OK; EOP("eins(1)",a); switch(S_O_K(a)) { case BRUCH: /* AK 120804 */ case INTEGER: case LONGINT: erg += m_i_i(1,b); break; case GALOISRING: erg += eins_galois(a,b); break; case FF: erg += eins_ff(a,b); break; case MATRIX: case INTEGERMATRIX: if (S_M_HI(a)==S_M_LI(a)) { INT i,j; erg += m_lh_m(S_M_L(a),S_M_H(a),b); C_O_K(b,S_O_K(a)); for (i=0;i 0 */ /* changed from >= 0 to >0 041001 AK */ /* AK 151204 V3.0 */ { INT erg = OK; COP("posp",a); switch(S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH : return posp_bruch(a) ; #endif /* BRUCHTRUE */ #ifdef INTEGERTRUE case INTEGER : return POSP_INTEGER(a) ; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT : return posp_longint(a) ; #endif /* LONGINTTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case VECTOR : return posp_vector(a) ; #endif /* VECTORTRUE */ #ifdef POLYTRUE /* AK V2.0 221298 */ /* true if all coeffs > 0 */ case SCHUBERT: case GRAL: case SCHUR: case ELM_SYM: case POW_SYM: case HOM_SYM: case MONOMIAL: case MONOPOLY: case POLYNOM: return posp_polynom(a); #endif /* POLYTRUE */ default: erg += WTO("posp",a); goto endr_ende; }; ENDR("posp"); } INT comp(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 281289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("comp(1)",a); COP("comp(2)",b); if (EMPTYP(a) && EMPTYP(b)) return(0L); else if (EMPTYP(a)) return(-1L); else if (EMPTYP(b)) return(1L); else switch(S_O_K(a)){ #ifdef BRUCHTRUE case BRUCH : return comp_bruch(a,b); #endif /* BRUCHTRUE */ #ifdef FFTRUE case FF : return comp_ff(a,b); #endif /* FFTRUE */ #ifdef INTEGERTRUE case INTEGER : if (S_O_K(b) == INTEGER) return ( S_I_I(a) > S_I_I(b) ? 1L : S_I_I(a) == S_I_I(b) ? 0L : -1L ); else return comp_integer(a,b); #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT : return comp_longint(a,b); #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS :return comp_kranztafel(a,b); case INTEGERMATRIX: return comp_integermatrix(a,b); case MATRIX : return comp_matrix(a,b); #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM : return comp_monom(a,b); #endif /* MONOMTRUE */ #ifdef LISTTRUE case SCHUBERT: case GRAL: case SCHUR: case ELM_SYM: case POW_SYM: case HOM_SYM: case MONOMIAL: case LIST : return comp_list(a,b); case POLYNOM: return comp_polynom(a,b); case MONOPOLY: return comp_monopoly(a,b); #endif /* LISTTRUE */ #ifdef PARTTRUE case PARTITION: return comp_partition(a,b); #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION: return comp_permutation(a,b); #endif /* PERMTRUE */ #ifdef REIHETRUE case REIHE: return comp_reihe(a,b); #endif /* REIHETRUE */ #ifdef SKEWPARTTRUE case SKEWPARTITION: return comp_skewpartition(a,b); #endif /* SKEWPARTTRUE */ #ifdef CHARTRUE case SYMCHAR: return comp_symchar(a,b); #endif /* CHARTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX : /* 060588 */ return comp_tableaux(a,b); #endif /* TABLEAUXTRUE */ #ifdef WORDTRUE case WORD: return comp_word(a,b); #endif /* WORDTRUE */ #ifdef VECTORTRUE case BITVECTOR: /* AK 200395 */ return comp_bv(a,b); case VECTOR: return comp_vector(a,b); case INTEGERVECTOR: case COMPOSITION: case SUBSET: return comp_integervector(a,b); case GALOISRING: return comp_galois(a,b); #endif /* VECTORTRUE */ default: return WTT("comp",a,b); } ENDR("comp"); } INT lt(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ /* AK 161204 V3.0 */ { INT erg = OK; COP("lt(1)",a); COP("lt(2)",b); if (comp(a,b) < 0L) return(TRUE); return(FALSE); ENDR("lt"); } INT eq(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ /* AK 161204 V3.0 */ { INT erg = OK; COP("eq(1)",a); COP("eq(2)",b); switch (S_O_K(a)) { case INTEGER: return eq_integer(a,b); case PARTITION: return eq_partition(a,b); case PERMUTATION: return eq_permutation(a,b); case VECTOR: return eq_vector(a,b); case CYCLOTOMIC: return eq_cyclotomic(a,b); case SQ_RADICAL: return eq_sqrad(a,b); case INTEGERMATRIX: case MATRIX: case KRANZTYPUS: return eq_matrix(a,b); /* AK 110703 */ case INTEGERVECTOR: /* AK 280804 */ if (S_O_K(b)==INTEGERVECTOR) return eq_integervector_integervector(a,b); else if (comp(a,b) == 0L) return(TRUE); else return FALSE; default: /* AK 051207 if (S_O_K(a) != S_O_K(b)) return FALSE; */ if (comp(a,b) == 0L) return(TRUE); } ENDR("eq"); } INT neq(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("neq(1)",a); COP("neq(2)",b); return not eq(a,b); ENDR("neq"); } INT gr(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { if (comp(a,b) > 0L) return(TRUE); return(FALSE); } INT ge(a,b) OP a,b; /* AK 260789 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { if (comp(a,b) >= 0L) return(TRUE); return(FALSE); } INT gt(a,b) OP a,b; /* AK 010889 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { if (S_O_K(a) == INTEGER) if (S_O_K(b) == INTEGER) return ((S_I_I(a) > S_I_I(b))? TRUE:FALSE); if (comp(a,b) > 0L) return(TRUE); return(FALSE); } INT le(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { if (comp(a,b) > 0L) return(FALSE); return(TRUE); } INT listp(a) OP a; /* AK 030789 V1.0 */ /* AK 160890 V1.1 */ /* AK 060891 V1.3 */ { OBJECTKIND kind = S_O_K(a); if ( kind == LIST || kind == POLYNOM || kind == MONOPOLY || kind == GRAL || kind == HOM_SYM || kind == POW_SYM || kind == ELM_SYM || kind == MONOMIAL || kind == SCHUR || kind == SCHUBERT ) return(TRUE); else return(FALSE); } INT factorize(a,b) OP a,b; /* AK 290304 */ /* decomposition into factors, i.e. a vector of factors */ /* the factors are ordered */ /* AK 281106 V3.1 */ { INT erg = OK; CE2(a,b,factorize); FREESELF(b); switch(S_O_K(a)) { case INTEGER: erg+=factorize_integer(a,b); goto endr_ende; case LONGINT: NYI("factorize for longint"); goto endr_ende; case POLYNOM: NYI("factorize for polynom"); goto endr_ende; default: WTO("factorize",a); } ENDR("factorize"); } #ifdef INTEGERTRUE INT factorize_integer(a,b) OP a,b; /* AK 060690 V1.1 */ /* AK 060891 V1.3 */ /* AK 220998 V2.0 */ /* input: INTEGER object a output:INTEGERVECTOR of prim factors in increasing order */ { INT erg = OK; CTO(INTEGER,"factorize_integer(1)",a); { INT ai = S_I_I(a); INT i=2L; m_il_v((INT)0,b); while (i <= ai) { if (ai % i == 0L) { INC(b); M_I_I(i,S_V_I(b,S_V_LI(b)-1L)); ai = ai / i; continue; } i++; } } ENDR("factorize_integer"); } #endif /* INTEGERTRUE */ #ifdef BRUCHTRUE INT invers_apply_integer(a) OP a; /* AK 140591 V1.2 */ /* AK 060891 V1.3 */ { INT erg = OK; CTO(INTEGER,"invers_apply_integer",a); SYMCHECK(S_I_I(a) == 0,"invers_apply_integer:zero"); if (S_I_I(a) == 1) goto endr_ende; if (S_I_I(a) == -1) { M_I_I(-S_I_I(a),a); goto endr_ende; } erg += m_ioiu_b(1L, S_I_I(a), a); ENDR("invers_apply_integer"); } #endif /* BRUCHTRUE */ INT addinvers_apply_integer(a) OP a; /* AK 201289 V1.1 */ /* AK 140591 V1.2 */ /* AK 060891 V1.3 */ { INT erg = OK; CTO(INTEGER,"addinvers_apply_integer",a); M_I_I(- S_I_I(a), a); ENDR("addinvers_apply_integer"); } INT addinvers_integer(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 060891 V1.3 */ { INT erg = OK; CTO(INTEGER,"addinvers_integer(1)",a); CTO(EMPTY,"addinvers_integer(2)",b); M_I_I(- S_I_I(a), b); ENDR("addinvers_integer"); } INT inc_integer(a) OP a; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { INT erg = OK; CTO(INTEGER,"inc_integer(1)",a); C_I_I(a,S_I_I(a)+1L); ENDR("inc_integer"); } INT dec_integer(a) OP a; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { INT erg = OK; CTO(INTEGER,"dec_integer(1)",a); C_I_I(a,S_I_I(a)-1L); ENDR("dec_integer"); } INT hoch_integer_integer(a,b,c) OP a,b,c; { INT erg = OK; INT i; OP d; CTTO(LONGINT,INTEGER,"hoch_integer_integer(1)",a); CTO(INTEGER,"hoch_integer_integer(2)",b); CTO(EMPTY,"hoch_integer_integer(3)",c); if (NULLP_INTEGER(b)) { M_I_I(1,c); goto ende; } if (NEGP_INTEGER(b)) { erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),c); M_I_I(1,S_B_O(c)); C_B_I(c,GEKUERZT); ADDINVERS_APPLY_INTEGER(b); erg += hoch_integer_integer(a,b,S_B_U(c)); ADDINVERS_APPLY_INTEGER(b); goto ende; } if (EINSP_INTEGER(b)) { COPY(a,c); goto ende; } SYMCHECK((S_I_I(b) <= 1), "hoch_integer_integer:(i1)"); i = S_I_I(b); d = CALLOCOBJECT(); COPY(a,d); M_I_I(1,c); while(i) { if ( i % 2 == 1) { MULT_APPLY(d,c); } erg += square_apply(d); i /= 2; } FREEALL(d); ende: CTTO(INTEGER,LONGINT,"hoch_integer_integer(e3)",c); ENDR("hoch_integer_integer"); } INT hoch_longint_integer(a,b,c) OP a,b,c; { INT erg = OK; CTO(LONGINT,"hoch_longint_integer(1)",a); CTO(INTEGER,"hoch_longint_integer(2)",b); CTO(EMPTY,"hoch_longint_integer(3)",c); erg += hoch_integer_integer(a,b,c); ENDR("hoch_longint_integer"); } INT hoch_longint_longint(a,b,c) OP a,b,c; { INT erg = OK; CTO(LONGINT,"hoch_longint_longint(1)",a); CTO(LONGINT,"hoch_longint_longint(2)",b); CTO(EMPTY,"hoch_longint_longint(3)",c); NYI("hoch_longint_longint"); ENDR("hoch_longint_longint"); } INT hoch_integer_longint(a,b,c) OP a,b,c; { INT erg = OK; CTO(INTEGER,"hoch_integer_longint(1)",a); CTO(LONGINT,"hoch_integer_longint(2)",b); CTO(EMPTY,"hoch_integer_longint(3)",c); NYI("hoch_integer_longint"); ENDR("hoch_integer_longint"); } INT hoch_default(); INT hoch_bruch_integer(a,b,c) OP a,b,c; { INT erg = OK; CTO(BRUCH,"hoch_bruch_integer(1)",a); CTO(INTEGER,"hoch_bruch_integer(2)",b); CTO(EMPTY,"hoch_bruch_integer(3)",c); erg += hoch_default(a,b,c); ENDR("hoch_bruch_integer"); } INT hoch_bruch_longint(a,b,c) OP a,b,c; { INT erg = OK; CTO(BRUCH,"hoch_bruch_longint(1)",a); CTO(LONGINT,"hoch_bruch_longint(2)",b); CTO(EMPTY,"hoch_bruch_longint(3)",c); erg += hoch_default(a,b,c); ENDR("hoch_bruch_longint"); } INT hoch_integer(a,b,c) OP a,b,c; { INT erg = OK; CTO(INTEGER,"hoch_integer(1)",a); CTO(EMPTY,"hoch_integer(3)",c); if (S_O_K(b) == INTEGER) erg += hoch_integer_integer(a,b,c); else if (S_O_K(b) == LONGINT) erg += hoch_integer_longint(a,b,c); else erg += hoch_default(a,b,c); ENDR("hoch_integer"); } INT hoch_longint(a,b,c) OP a,b,c; { INT erg = OK; CTO(LONGINT,"hoch_longint(1)",a); CTO(EMPTY,"hoch_longint(3)",c); if (S_O_K(b) == INTEGER) erg += hoch_longint_integer(a,b,c); else if (S_O_K(b) == LONGINT) erg += hoch_longint_longint(a,b,c); else erg += hoch_default(a,b,c); ENDR("hoch_longint"); } INT hoch_bruch(a,b,c) OP a,b,c; { INT erg = OK; CTO(BRUCH,"hoch_bruch(1)",a); CTO(EMPTY,"hoch_bruch(3)",c); if (S_O_K(b) == INTEGER) erg += hoch_bruch_integer(a,b,c); else if (S_O_K(b) == LONGINT) erg += hoch_bruch_longint(a,b,c); else erg += hoch_default(a,b,c); ENDR("hoch_bruch"); } INT mult_integer_integer(a,b,d) OP a,b,d; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { INT l,erg = OK; CTO(INTEGER,"mult_integer_integer(1)",a); CTO(INTEGER,"mult_integer_integer(2)",b); CTO(EMPTY,"mult_integer_integer(3)",d); l=INTLOG(a) + INTLOG(b); if ( l > 9) { #ifdef LONGINTTRUE OP c= CALLOCOBJECT(); erg += t_int_longint(a,c); erg += mult_longint_integer(c,b,d); FREEALL(c); #else /* LONGINTTRUE */ erg += error("mult_integer_integer:no LONGINT"); #endif /* LONGINTTRUE */ goto endr_ende; } M_I_I(S_I_I(a)*S_I_I(b),d); ENDR("mult_integer_integer"); } INT mult_integer_longint(a,b,c) OP a,b,c; { INT erg = OK; CTO(INTEGER,"mult_integer_longint",a); CTO(LONGINT,"mult_integer_longint",b); CTO(EMPTY,"mult_integer_longint",c); erg += mult_longint_integer(b,a,c); ENDR("mult_integer_longint"); } INT mult_integer_bruch(a,b,c) OP a,b,c; { INT erg = OK; CTO(INTEGER,"mult_integer_bruch",a); CTO(BRUCH,"mult_integer_bruch",b); CTO(EMPTY,"mult_integer_bruch",c); erg += mult_bruch_integer(b,a,c); ENDR("mult_integer_bruch"); } INT mult_integer(a,b,d) OP a,b,d; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { INT erg=OK; CTO(INTEGER,"mult_integer(1)",a); CTTO(EMPTY,INTEGER,"mult_integer(3)",d); EOP("mult_integer(2)",b); if (S_O_K(d)==INTEGER) C_O_K(d,EMPTY); switch(S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: erg += mult_bruch_integer(b,a,d); goto ende; #endif /* BRUCHTRUE */ case INTEGER: erg += mult_integer_integer(a,b,d); goto ende; #ifdef LONGINTTRUE case LONGINT: erg += mult_longint_integer(b,a,d); goto ende; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS : case MATRIX: erg += mult_scalar_matrix(a,b,d); goto ende; #endif /* MATRIXTRUE */ #ifdef MONOMTRUE case MONOM: erg += mult_integer_monom(a,b,d); goto ende; #endif /* MONOMTRUE */ #ifdef POLYTRUE case POW_SYM: erg += mult_powsym_scalar(b,a,d); goto ende; case ELM_SYM: erg += mult_elmsym_scalar(b,a,d); goto ende; case HOM_SYM: erg += mult_homsym_scalar(b,a,d); goto ende; case MONOMIAL: erg += mult_monomial_scalar(b,a,d); goto ende; case SCHUR: erg += mult_schur_scalar(b,a,d); goto ende; #ifdef SCHUBERTTRUE case SCHUBERT: erg += mult_scalar_schubert(a,b,d); goto ende; #endif case GRAL: erg += mult_scalar_gral(a,b,d); goto ende; case POLYNOM: erg += mult_scalar_polynom(a,b,d); goto ende; case MONOPOLY: erg += mult_scalar_monopoly(a,b,d); goto ende; #endif /* POLYTRUE */ #ifdef LAURENTTRUE case LAURENT: { OP c = callocobject(); erg += t_INTEGER_LAURENT(a,c); erg += mult_laurent(c,b,d); erg += freeall(c); } goto ende; #endif /* LAURENTTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += mult_scalar_sqrad(a,b,d); goto ende; #endif /* SQRADDTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += mult_scalar_cyclo(a,b,d); goto ende; #endif /* CYCLOTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += mult_scalar_symchar(a,b,d); goto ende; #endif /* CHARTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case VECTOR: erg += mult_scalar_vector(a,b,d); goto ende; #endif /* VECTORTRUE */ #ifdef FFTRUE case FF: erg += cast_apply_ff(a); erg += mult_ff(a,b,d); goto ende; #endif /* FFTRUE */ case HASHTABLE: erg += mult_integer_hashtable(a,b,d); goto ende; default: WTO("mult_integer(2)",b); goto ende; } ende: ENDR("mult_integer"); } INT even_integer(a) OP a; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { return(S_I_I(a) %2L == 0L); } INT posp_integer(a) OP a; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { return(S_I_I(a) >= (INT) 0); } INT negp_integer(a) OP a; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { return(S_I_I(a) < 0L); } INT mod_integer_integer(a,b,c) OP a,b,c; { INT erg = OK; CTO(INTEGER,"mod_integer_integer(1)",a); CTO(INTEGER,"mod_integer_integer(2)",b); CTO(EMPTY,"mod_integer_integer(3)",c); M_I_I(S_I_I(a) % S_I_I(b),c); ENDR("mod_integer"); } INT add_integer_integer(a,b,c) OP a,b,c; /* AK 251001 */ { INT erg = OK,i; CTO(INTEGER,"add_integer_integer(1)",a); CTO(INTEGER,"add_integer_integer(2)",b); CTO(EMPTY,"add_integer_integer(3)",c); i = S_I_I(a)+S_I_I(b); if ( ( (S_I_I(a) > 0) && (S_I_I(b) > 0) && (i <= 0) ) || ( (S_I_I(a) < 0) && (S_I_I(b) < 0) && (i >= 0) ) ) { #ifdef LONGINTTRUE OP d; d = callocobject(); erg += t_int_longint(b,d); erg += add_longint_integer(d,a,c); erg += freeall(d); #else /* LONGINTTRUE */ erg += error("add_apply_integer_integer:Overflow no LONGINT"); #endif /* LONGINTTRUE */ } else { M_I_I(i,c); } ENDR("add_integer_integer"); } INT add_integer_longint(a,b,c) OP a,b,c; /* AK 251001 */ { INT erg = OK; CTO(INTEGER,"add_integer_longint(1)",a); CTO(LONGINT,"add_integer_longint(2)",b); CTO(EMPTY,"add_integer_longint(3)",c); erg += add_longint_integer(b,a,c); ENDR("add_integer_longint"); } INT add_integer(a,b,c) OP a,b,c; /* das erste object ist vom typ INTEGER, das ergebnis ist ein leere object */ /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 280291 V1.2 */ /* AK 060891 V1.3 */ { INT erg = OK; CTO(INTEGER,"add_integer(1)",a); CTO(EMPTY,"add_integer(3)",c); EOP("add_integer(2)",b); switch(S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: erg += add_bruch_scalar(b,a,c); goto aiende; #endif /* BRUCHTRUE */ case INTEGER: erg += add_integer_integer(a,b,c); goto aiende; #ifdef LONGINTTRUE case LONGINT: erg += add_longint_integer(b,a,c); goto aiende; #endif /* LONGINTTRUE */ #ifdef POLYTRUE /* AK 060891 */ case POLYNOM: erg += add_scalar_polynom(a,b,c); goto aiende; #endif /* POLYTRUE */ case SQ_RADICAL: erg += add_scalar_sqrad(a,b,c); goto aiende; case CYCLOTOMIC: erg += add_scalar_cyclo(a,b,c); goto aiende; #ifdef SCHURTRUE /* AK 240102 */ case SCHUR: erg += add_schur(b,a,c); goto aiende; case HOMSYM: erg += add_homsym(b,a,c); goto aiende; case POWSYM: erg += add_powsym(b,a,c); goto aiende; case ELMSYM: erg += add_elmsym(b,a,c); goto aiende; case MONOMIAL: erg += add_monomial(b,a,c); goto aiende; #endif /* SCHURTRUE */ case MONOPOLY: erg += add_scalar_monopoly(a,b,c); goto aiende; default : if (NULLP_INTEGER(a)) COPY(b,c); else erg += WTO("add_integer(2)",b); goto aiende; } /* end switch */ aiende: ENDR("add_integer"); } INT eq_integer(a,b) OP a,b; /* AK 110202 */ { INT erg = OK; CTO(INTEGER,"eq_integer(1)",a); switch(S_O_K(b)) { case SQ_RADICAL: return FALSE; case CYCLOTOMIC: return FALSE; case EMPTY: return FALSE; default: return comp_integer(a,b) == 0; } ENDR("eq_integer"); } INT comp_integer_integer(a,b) OP a,b; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* AK 281098 V2.0 */ { INT ai = S_I_I(a); INT bi = S_I_I(b); if (ai == bi) return(0L); if (ai > bi) return(1L); return(-1L); } INT comp_integer(a,b) OP a,b; /* AK 280888 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* AK 040298 V2.0 */ /* a is of type INTEGER type of b is from BRUCH, INTEGER, LONGINT, POLYNOM */ { INT erg = OK; CTO(INTEGER,"comp_integer(1)",a); switch (S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: return -1 * comp_bruch_scalar(b,a); #endif /* BRUCHTRUE */ case INTEGER: return COMP_INTEGER_INTEGER(a,b); #ifdef LONGINTTRUE case LONGINT: return -1 * comp_longint_integer(b,a); #endif /* LONGINTTRUE */ #ifdef POLYTRUE case POLYNOM: return -1 * comp_polynom_scalar(b,a); #endif /* POLYTRUE */ default: WTO("comp_integer(2)",b);goto endr_ende; } ENDR("comp_integer"); } INT quores_integer(a,b,c,d) OP a,b,c,d; /* AK 280888 */ /* AK 270689 V1.0 */ /* AK 081289 V1.1 */ /* AK 210891 V1.3 */ /* d is always positive */ /* a is integer */ { INT erg = OK; CTO(INTEGER,"quores_integer(1)",a); CTO(EMPTY,"quores_integer(3)",c); CTO(EMPTY,"quores_integer(4)",d); switch(S_O_K(b)) { case INTEGER: { M_I_I(S_I_I(a) / S_I_I(b), c); M_I_I(S_I_I(a) % S_I_I(b), d); if ((S_I_I(d) < 0L) && (S_I_I(b) < 0L)) { M_I_I(S_I_I(d)-S_I_I(b),d); INC_INTEGER(c); } if ((S_I_I(d) < 0L) && (S_I_I(b) > 0L)) { M_I_I(S_I_I(d)+S_I_I(b),d); DEC_INTEGER(c); } goto endr_ende; } #ifdef LONGINTTRUE case LONGINT: { if (NULLP_INTEGER(a)) /* AK 020103 */ { M_I_I(0,c); M_I_I(0,d); } else { OP e = callocobject(); erg += m_i_longint(S_I_I(a),e); erg += quores_longint(e,b,c,d); erg += freeall(e); } goto endr_ende; }; #endif /* LONGINTTRUE */ default: WTT("quores_integer",a,b); goto endr_ende; } ENDR("quores_integer"); } INT nullp_integer(a) OP a; /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* a is integer */ { return( (S_I_I(a) == 0L) ? TRUE : FALSE ); } INT einsp_integer(a) OP a; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* a is integer */ { return ((S_I_I(a) == 1L)?TRUE:FALSE); } INT negeinsp_integer(a) OP a; /* AK 070789 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* a is integer */ { return ((S_I_I(a) == -1L)? TRUE : FALSE); } INT copy_integer(a,c) OP a,c; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { M_I_I( S_I_I(a),c); return OK; } #ifdef BRUCHTRUE INT invers_integer(a,b) OP a,b; /* AK 031286 */ /* AK 220888 gilt auch bei longint */ /* AK 270689 V1.0 */ /* AK 151289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(INTEGER,"invers_integer(1)",a); CTO(EMPTY,"invers_integer(2)",b); if (EINSP_INTEGER(a)) { M_I_I(1,b); goto endr_ende; } if (NEGEINSP_INTEGER(a)) { M_I_I(-1,b); goto endr_ende; } erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),b); M_I_I(1,S_B_O(b)); M_I_I(S_I_I(a),S_B_U(b)); C_B_I(b,GEKUERZT); ENDR("invers_integer"); } #endif /* BRUCHTRUE */ INT random_integer(res,para_eins,para_zwei) OP res,para_eins,para_zwei; /* AK 150587 */ /* AK 090688 changed */ /* para_eins = lower limit, para_zwei= upper limit */ /* res will be a pseudo random number between lower and upper limit. */ /* uses the system function rand() */ /* para_eins and para_zwei may be NULL in this case an integer between 0 and 10 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* AK 300802 V2.0 */ /* AK 080306 V3.0 */ { INT untergrenze,obergrenze,ires,zi; INT erg = OK; int rand(); if (para_eins==NULL) untergrenze=0; else if (S_O_K(para_eins) != INTEGER) WTO("random_integer(2)",para_eins); else untergrenze = S_I_I(para_eins); if (para_zwei==NULL) obergrenze=untergrenze + 10; else if (S_O_K(para_zwei) != INTEGER) #ifdef LONGINTTRUE { if (S_O_K(para_zwei)==LONGINT) /* AK 151092 */ { OP c = callocobject(); COPY(para_zwei,c); if (para_eins != NULL) erg += sub(c,para_eins,c); if (S_O_K(c) == LONGINT) erg += random_longint(res,c); else erg += random_integer(res,NULL,c); if (para_eins != NULL) erg += add_apply(para_eins,res); freeall(c); goto endr_ende; } else #endif /* LONGINTTRUE */ WTO("random_integer(3)",para_zwei); #ifdef LONGINTTRUE } #endif /* LONGINTTRUE */ else obergrenze = S_I_I(para_zwei); SYMCHECK(obergrenze < untergrenze,"random_integer: upper limit < lower limit"); if (obergrenze > untergrenze) { zi = rand() % (obergrenze - untergrenze); ires = untergrenze + zi; } else ires = untergrenze; erg += m_i_i(ires,res); ENDR("random_integer"); } INT tex_integer(a) OP a; /* AK 101187 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 070291 V1.2 prints to texout instead of stdout */ /* AK 210891 V1.3 */ { INT ts = texmath_yn; /* AK 190892 */ texposition += /* AK 210291 */ intlog(a); if (S_I_I(a) <0L) texposition++; if (ts == 0L) { fprintf(texout," $%ld$ ",S_I_I(a)); texposition += 4L; } else fprintf(texout," %ld ",S_I_I(a)); return OK; } INT scan_integer(ergebnis) OP ergebnis; /* liest ein integerobject ein AK 270787 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 080591 V1.2 */ /* AK 210891 V1.3 */ { char c; int eingabe; INT erg = OK; INT numberofmatches; CTO(EMPTY,"scan_integer(1)",ergebnis); sia: scan_printeingabe("integerobject "); skip_comment(); numberofmatches = (INT)scanf("%d",&eingabe); if (numberofmatches == EOF) /* AK 220807 */ { error("scan_integer:EOF"); goto endr_ende; } if (numberofmatches != (INT)1) { while ((c = getchar()) != '\n'); error("scan_integer:I did not recognize a number"); goto sia; } M_I_I((INT)eingabe,ergebnis); ENDR("scan_integer"); } INT skip_integer(t) char *t; /* AK 300998 */ { INT erg = OK; char *oldt = t; while (*t == ' ') t++; if (*t == '-') t++; if (not SYM_isdigit(*t)) { error("skip_integer:not a INTEGER"); erg = -10; goto endr_ende; } while (SYM_isdigit(*t)) t++; return (INT)(t-oldt); ENDR("skip_integer"); } INT sscan_integer(t,a) OP a; char *t; /* AK 301293 */ { long i; sscanf(t,"%ld",&i); m_i_i((INT)i,a); return OK; } INT objectread_integer(filename,obj) FILE *filename; OP obj; /* AK 131086 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 020591 V1.2 */ /* AK 210891 V1.3 */ { INT eingabe; INT erg = OK; COP("objectread_integer(1)",filename); fscanf(filename,"%ld",&eingabe); M_I_I(eingabe,obj); ENDR("objectread_integer"); } INT objectwrite_integer(filename,obj) FILE *filename; OP obj; /* AK 131086 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("objectwrite_integer(1)",filename); fprintf(filename," %ld %ld\n",(INT)INTEGER,S_I_I(obj)); ENDR("objectwrite_integer"); } INT sprint_integer(string,a) char *string; OP a; /* AK 020295 */ /* AK 240398 V2.0 */ { INT erg = OK; CTO(INTEGER,"sprint_integer(2)",a); sprintf(string,"%ld",S_I_I(a)); ENDR("sprint_integer"); } INT fprint_integer(f,a) FILE *f; OP a; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* AK 190298 V2.0 */ /* AK 201204 V3.0 */ { INT erg = OK; CTO(INTEGER,"fprint_integer",a); SYMCHECK(f == NULL,"fprint_integer:NULL file pointer"); { INT l; if (f == stdout) { l = intlog(a); zeilenposition += l; if (l < integer_format) { /* we need leading blanks */ l = integer_format-l; zeilenposition += l; while (l--) putchar(' '); } if (S_I_I(a) < 0) zeilenposition++; /* for the leading sign */ } fprintf(f,"%ld",S_I_I(a)); if (f == stdout) if (zeilenposition >= row_length) { fprintf(f,"\n"); zeilenposition = 0; } } ENDR("fprint_integer"); } INT s_i_i(a) OP a; /* to be faster, use the macro S_I_I */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ /* AK 201204 V3.0 */ { INT erg = OK; CTO(INTEGER,"s_i_i",a); return a->ob_self.ob_INT; ENDR("s_i_i"); } INT c_i_i(a,b) OP a;INT b; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(INTEGER,"c_i_i",a); a->ob_self.ob_INT=b; ENDR("c_i_i"); } INT m_i_i(a,b) INT a;OP b; /* AK 270689 V1.0 AK 181289 V1.1 AK 110291 V1.2 AK 060891 V1.3 */ { INT erg=OK; COP("m_i_i",b); FREESELF(b); C_O_K(b,INTEGER); C_I_I(b,a); ENDR("m_i_i"); } INT freeself_integer(a) OP a; /* AK 270689 V1.0 AK 181289 V1.1 AK 210891 V1.3 */ { C_O_K(a,EMPTY); return(OK); } INT test_integer() /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { OP a=callocobject(); OP b=callocobject(); OP c=callocobject(); INT erg; m_i_i(5L,a); printf("test_integer:m_i_i(5L,a)\n"); debugprint_object(a); C_I_I(a,7L); printf("test_integer:c_i_i(a,7L)\n"); debugprint_object(a); printf("test_integer:fprint_integer(stdout,a)\n"); fprint_integer(stdout,a); printf("\n"); printf("test_integer:tex_integer(a)\n"); tex_integer(a); printf("\n"); printf("test_integer:copy_integer(a,b)\n"); copy_integer(a,b); printf("b="); println(b); printf("test_integer:comp_integer_integer(a,b)\n"); erg=comp_integer_integer(a,b); printf("%ld\n",erg); printf("test_integer:binom(a=5L,b=4L,c)\n"); m_i_i(5L,a); m_i_i(4L,b); binom(a,b,c); println(c); freeall(a); freeall(b); freeall(c); return(OK); } #ifdef POLYTRUE INT add_apply_scalar_polynom(a,b) OP a,b; /* AK 110990 V1.1 */ /* AK 270291 V1.2 */ /* AK 080891 V1.3 */ /* AK 260298 V2.0 */ /* input: a = INTEGER or BRUCH or LONGINT */ { INT erg = OK; OP c; CE2A(a,b,add_apply_scalar_polynom); CTO(POLYNOM,"add_apply_scalar_polynom(2)",b); c = callocobject(); erg += m_scalar_polynom(a,c); erg += insert(c,b,add_koeff,comp_monomvector_monomvector); ENDR("add_apply_scalar_polynom"); } #endif /* POLYTRUE */ INT add_apply_integer(a,b) OP a,b; /* AK 120390 V1.1 */ /* AK 080891 V1.3 */ /* AK 260298 V2.0 */ { INT erg=OK; OP d; CTO(INTEGER,"add_apply_integer(1)",a); switch(S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: erg += add_apply_scalar_bruch(a,b); break; #endif /* BRUCHTRUE */ case INTEGER: erg += add_apply_integer_integer(a,b); break; #ifdef LONGINTTRUE case LONGINT: erg += add_apply_integer_longint(a,b); break; #endif /* LONGINTTRUE */ #ifdef SCHURTRUE case SCHUR: d = callocobject(); erg += m_scalar_schur(a,d); insert(d,b,add_koeff,comp_monomschur); break; #endif /* SCHURTRUE */ #ifdef POLYTRUE case SCHUBERT: case POLYNOM: erg += add_apply_scalar_polynom(a,b); break; #endif /* POLYTRUE */ default: { OP c; c = callocobject(); *c = *b; C_O_K(b,EMPTY); erg += add_integer(a,c,b); erg += freeall(c); } break; } ENDR("add_apply_integer"); } #ifdef MATRIXTRUE INT mult_apply_integer_matrix(a,b) OP a,b; /* b = b* a */ /* AK 220390 V1.1 */ /* AK 250291 V1.2 */ /* AK 080891 V1.3 */ /* AK 260298 V2.0 */ { OP z = S_M_S(b); INT i = S_M_HI(b)*S_M_LI(b); INT erg = OK; CTO(INTEGER,"mult_apply_integer_matrix(1)",a); CTO(MATRIX,"mult_apply_integer_matrix(2)",b); for(;i>0L;i--,z++) MULT_APPLY_INTEGER(a,z); ENDR("mult_apply_integer_matrix"); } #endif /* MATRIXTRUE */ INT mult_apply_integer(a,b) OP a,b; /* b = b* a */ /* AK 201289 V1.1 */ /* AK 250291 V1.2 */ /* AK 210891 V1.3 */ /* AK 260298 V2.0 */ { INT erg = OK; EOP("mult_apply_integer(2)",b); CTO(INTEGER,"mult_apply_integer(1)",a); switch(S_O_K(b)) { #ifdef BRUCHTRUE case BRUCH: erg += mult_apply_integer_bruch(a,b); break; #endif /* BRUCHTRUE */ case INTEGER: erg += mult_apply_integer_integer(a,b); break; #ifdef LONGINTTRUE case LONGINT: erg += mult_apply_integer_longint(a,b); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case KRANZTYPUS : case MATRIX: erg += mult_apply_integer_matrix(a,b); break; #endif /* MATRIXTRUE */ #ifdef CHARTRUE case SYMCHAR: erg += mult_apply_scalar_symchar(a,b); break; #endif /* CHARTRUE */ #ifdef POLYTRUE case MONOM: erg += mult_apply_integer_monom(a,b); break; case SCHUR: case POW_SYM: case ELM_SYM: case HOM_SYM: case MONOMIAL: case SCHUBERT: case GRAL: case POLYNOM: case MONOPOLY: erg += mult_apply_integer_polynom(a,b); break; #endif /* POLYTRUE */ #ifdef NUMBERTRUE case SQ_RADICAL: erg += mult_apply_scalar_sqrad(a,b); break; case CYCLOTOMIC: erg += mult_apply_scalar_cyclo(a,b); break; #endif /* NUMBERTRUE */ #ifdef VECTORTRUE case INTEGERVECTOR: case COMPOSITION: case WORD: case VECTOR: erg += mult_apply_scalar_vector(a,b); break; case HASHTABLE: erg += mult_apply_integer_hashtable(a,b); break; #endif /* VECTORTRUE */ default: if (S_I_I(a) == (INT)1) { } else if (S_I_I(a) == (INT)-1) erg += addinvers_apply(b); else erg += WTO("mult_apply_integer: wrong second type",b); } ENDR("mult_apply_integer"); } INT square_apply_integer(a) OP a; /* AK 271101 */ /* a = a * a */ { INT erg = OK; INT i; CTO(INTEGER,"square_apply_integer(1)",a); i = S_I_I(a); if (i<0) i = -i; if (i < 46340) /* sqrt(2^31 */ { M_I_I(S_I_I(a) * S_I_I(a),a); } else{ OP c; c = CALLOCOBJECT(); *c = *a; C_O_K(a,EMPTY); t_int_longint(c,a); erg += mult_apply_integer_longint(c,a); FREEALL(c); } ENDR("square_apply_integer"); } INT mult_apply_integer_integer(a,b) OP a,b; /* AK 201289 V1.1 */ /* AK 250291 V1.2 */ /* AK 210891 V1.3 */ /* AK 270298 V2.0 */ { INT erg = OK; CTO(INTEGER,"mult_apply_integer_integer(1)",a); CTO(INTEGER,"mult_apply_integer_integer(2)",b); if ( (S_I_I(a) < 46300) && (S_I_I(a) > -46300) && (S_I_I(b) < 46300) && (S_I_I(b) > -46300) ) M_I_I(S_I_I(a)*S_I_I(b),b); else { if ( (INTLOG(a) + INTLOG(b)) > 9L ) { if (S_I_I(a)==0) M_I_I(0,b); else if (S_I_I(b)!=0) { erg += t_int_longint(b,b); erg += mult_apply_integer_longint(a,b); } } else M_I_I(S_I_I(a)*S_I_I(b),b); } ENDR("mult_apply_integer_integer"); } INT add_apply_integer_integer(a,b) OP a,b; /* AK 120390 V1.1 */ /* AK 250291 V1.2 */ /* AK 210891 V1.3 */ /* AK 270298 V2.0 */ /* AK 050902 V2.1 */ { INT erg = OK; INT i; CTO(INTEGER,"add_apply_integer_integer(1)",a); CTO(INTEGER,"add_apply_integer_integer(2)",b); i = S_I_I(a)+S_I_I(b); if ( ( (S_I_I(a) > 0) && (S_I_I(b) > 0) && (i <= 0) ) || ( (S_I_I(a) < 0) && (S_I_I(b) < 0) && (i >= 0) ) ) /* we have to change to longint arithmetic */ { #ifdef LONGINTTRUE OP c; c = CALLOCOBJECT(); erg += t_int_longint(b,c); FREESELF(b); *b = *c; C_O_K(c,EMPTY); FREEALL(c); erg += add_apply_integer_longint(a,b); #else /* LONGINTTRUE */ erg += error("add_apply_integer_integer:Overflow no LONGINT"); #endif /* LONGINTTRUE */ } else C_I_I(b,i); ENDR("add_apply_integer_integer"); } INT intlog_int(ai) INT ai; /* number of digits of an int */ /* AK 201204 V3.0 */ { if (ai < 0L) ai = -ai; if (ai >= 1000000000L) return(10L); if (ai >= 100000000L) return(9L); if (ai >= 10000000L) return(8L); if (ai >= 1000000L) return(7L); if (ai >= 100000L) return(6L); if (ai >= 10000L) return(5L); if (ai >= 1000L) return(4L); if (ai >= 100L) return(3L); if (ai >= 10L) return(2L); return(1L); } INT intlog(a) OP a; /* number of digits of an integer object */ /* AK 150290 V1.1 */ /* AK 250291 V1.2 */ /* AK 210891 V1.3 */ /* AK 201204 V3.0 */ { INT erg = OK; CTTO(LONGINT,INTEGER,"intlog(1)",a); if (S_O_K(a) == INTEGER) { INT ai; ai = S_I_I(a); if (ai < 0L) ai = -ai; if (ai >= 1000000000L) return(10L); if (ai >= 100000000L) return(9L); if (ai >= 10000000L) return(8L); if (ai >= 1000000L) return(7L); if (ai >= 100000L) return(6L); if (ai >= 10000L) return(5L); if (ai >= 1000L) return(4L); if (ai >= 100L) return(3L); if (ai >= 10L) return(2L); return(1L); } else if (S_O_K(a) == LONGINT) { return intlog_longint(a); } ENDR("intlog"); } INT init(kind,a) OBJECTKIND kind; OP a; /* AK 300588 */ /* AK 030789 V1.0 */ /* AK 060390 V1.1 */ /* AK 250291 V1.2 */ /* AK 050891 V1.3 */ { INT erg=OK; COP("init(2)",a); FREESELF(a); switch (kind) { case EMPTY: break; #ifdef BINTREETRUE case BINTREE: erg += init_bintree(a); break; #endif /* BINTREETRUE */ #ifdef BRUCHTRUE case BRUCH: erg += b_ou_b(callocobject(),callocobject(),a); break; #endif /* BRUCHTRUE */ case INTEGER: M_I_I(0,a); /* AK 050902 */ break; #ifdef KRANZTRUE case KRANZ: erg+= init_kranz(a); break; #endif /* KRANZTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += init_longint(a); break; #endif /* LONGINTTRUE */ #ifdef MONOMTRUE case MONOM: erg += b_sk_mo(callocobject(),callocobject(),a); break; #endif /* MONOMMTRUE */ #ifdef NUMBERTRUE case CYCLOTOMIC: erg += init_cyclo(a); break; case SQ_RADICAL: /* MD */ erg += init_sqrad(a); break; #endif /* NUMBERTRUE */ #ifdef PARTTRUE case PARTITION: erg+= b_ks_pa(VECTOR,callocobject(),a);break; #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION: erg+=b_ks_p(VECTOR,callocobject(),a);break; #endif /* PERMTRUE */ #ifdef REIHETRUE case REIHE: erg+=init_reihe(a);break; #endif /* REIHETRUE */ #ifdef LISTTRUE case SCHUR: erg += init_schur(a); break; case HOMSYM: erg += init_homsym(a); break; case GRAL: case POW_SYM: case MONOPOLY: case POLYNOM: case ELM_SYM: case MONOMIAL: case SCHUBERT: case LIST: erg += b_sn_l(NULL,NULL,a); C_O_K(a,kind); break; #endif /* LISTTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX: erg+=b_us_t(callocobject(),callocobject(),a); break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case BITVECTOR: erg += m_il_bv((INT)0,a);break; case INTEGERVECTOR: case WORD: case VECTOR: case COMPOSITION: case SUBSET: erg += m_il_v((INT)0,a); C_O_K(a,kind); break; case QUEUE: erg += init_queue(a); break; case HASHTABLE: erg += init_hashtable(a); break; #endif /* VECTORTRUE */ default: fprintf(stderr,"kind = %ld\n",(INT) kind); return error("init:wrong kind"); } CTO(kind,"init(e2)",a); ENDR("init"); } INT next_apply(obj) OP obj; /* AK 300997 */ { INT erg = OK; EOP("next_apply(1)",obj); switch(S_O_K(obj)) { #ifdef FFTRUE case FF: /* AK 290304 */ erg = next_apply_ff(obj); if (erg == ERROR) goto endr_ende; return (erg == LAST_FF ? FALSE : TRUE ); #endif /* FFTRUE */ #ifdef PARTTRUE case SUBSET: /* AK 280901 */ return((next_apply_subset(obj) == LASTSUBSET)? FALSE : TRUE); case COMPOSITION: return((next_apply_composition(obj) == LASTCOMP)? FALSE : TRUE); case PARTITION: return((next_apply_partition(obj) == LASTPARTITION)? FALSE : TRUE); #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION: /* AK 280901 */ if (S_P_K(obj) == VECTOR) return (next_apply_permutation(obj) == LASTPERMUTATION)? FALSE : TRUE; else if (S_P_K(obj) == BAR) /* AK 120902 */ return (next_apply_bar(obj) == LASTPERMUTATION)? FALSE : TRUE; else { error("wrong kind of permutation in next_apply"); goto endr_ende; } #endif /* PERMTRUE */ default: erg+= WTO("next_apply(1)",obj); break; } ENDR("next_apply"); } INT next(von,nach) OP von, nach; /* AK 220488 */ /* AK 030789 V1.0 */ /* AK 081289 V1.1 */ /* AK 250291 V1.2 */ /* AK 050891 V1.3 */ { INT erg = OK; EOP("next",von); /* nicht CE2 wg. return value */ if (check_equal_2(von,nach,next,&erg) == EQUAL) return erg; switch(S_O_K(von)) { #ifdef FFTRUE case FF: /* AK 170194 */ erg = next_ff(von,nach); if (erg == ERROR) goto endr_ende; return (erg == LAST_FF ? FALSE : TRUE ); #endif /* FFTRUE */ #ifdef PARTTRUE case PARTITION: { return((next_partition(von,nach) == LASTPARTITION)? FALSE : TRUE); } case COMPOSITION: { return((next_composition(von,nach) == LASTCOMP)? FALSE : TRUE); } case SUBSET: { return((next_subset(von,nach) == LASTSUBSET)? FALSE : TRUE); } #endif /* PARTTRUE */ #ifdef PERMTRUE case PERMUTATION: { if (S_P_K(von) == BAR) return((next_bar(von,nach) == LASTPERMUTATION)? FALSE : TRUE); else if (S_P_K(von) == VECTOR) return((next_permutation(von,nach) == LASTPERMUTATION)? FALSE : TRUE); else return error("next: wrong kind of permutation"); } #endif /* PERMTRUE */ default: erg+= WTO("next(1)",von); break; } ENDR("next"); } OP find (a,b) OP a,b; /* return NULL if a not in b */ /* AK 251103 */ { INT erg =OK; if (VECTORP(b)) return find_vector(a,b); WTO("find(2)",b); ENDO("find"); } INT insert(a,c,eh,cf) OP a,c; INT (*eh)(),(*cf)(); /* AK 221286*/ /* AK 030789 V1.0 */ /* AK 221289 V1.1 */ /* AK 250291 V1.2 */ /* AK 060891 V1.3 */ /* inserts a into c */ /* AK 060498 V2.0 */ { INT erg = OK; if (a == NULL) { erg += error("insert:first == NULL"); goto endr_ende; } if (a == c) { erg += error("insert:first == ERGEBNIS"); goto endr_ende; } if (EMPTYP(a)) { erg += freeall(a); goto endr_ende; } switch(S_O_K(c)) { #ifdef VECTORTRUE case HASHTABLE: erg = insert_hashtable(a,c, eh,cf,hash); goto endr_ende; #endif #ifdef BINTREETRUE case BINTREE: erg = insert_bintree(a,c, eh,cf); switch (erg) { case INSERTOK: case INSERTEQ: return erg; } goto endr_ende; #endif /* BINTREETRUE */ #ifdef LISTTRUE case LIST: erg += insert_list(a,c,eh,cf); goto endr_ende; #endif /* LISTTRUE */ case MONOPOLY: case SCHUR: case SCHUBERT: case POW_SYM: case HOM_SYM: case GRAL: case POLYNOM: case ELM_SYM: case MONOMIAL: #ifdef LISTTRUE if (cf == NULL) cf= comp_monomvector_monomvector; if (eh == NULL) eh = add_koeff; erg += insert_list(a,c, eh,cf); goto endr_ende; #endif /* LISTTRUE */ default: ; }; switch(S_O_K(a)) { #ifdef POLYTRUE case GRAL: case HOM_SYM: case POW_SYM: case MONOPOLY: case SCHUBERT: case SCHUR: case POLYNOM: case ELM_SYM: case MONOMIAL: if (cf == NULL) cf= comp_monomvector_monomvector; if (eh == NULL) eh = add_koeff; erg += insert_list(a,c, eh,cf); goto endr_ende; #endif /* POLYTRUE */ default: erg += WTT("insert(1,2)",a,c); goto endr_ende; }; ENDR("insert"); } INT first(kind,res,para_eins) OBJECTKIND kind; OP res,para_eins; /* AK 270788 */ /* AK 030789 V1.0 */ /* AK 060390 V1.1 */ /* AK 200691 V1.2 */ /* AK 210891 V1.3 */ { INT erg = OK; CE2(res,para_eins,first); if (not EMPTYP(res)) erg += freeself(res); switch (kind) { #ifdef PERMTRUE case PERMUTATION: erg += first_permutation(para_eins,res); break; #endif /* PERMTRUE */ #ifdef PARTTRUE case PARTITION: erg += first_partition(para_eins,res); break; #endif /* PARTTRUE */ default: return error("first:wrong kind"); }; ENDR("first"); } INT b_ks_o(kind,self,object) OBJECTKIND kind; OBJECTSELF self; OP object; /* build_kind_self_object */ /* AK 061086 */ /* erzeugt ein object der art kind (z.B. VECTOR) und einen pointer auf self, das eigentliche object (z.B. struct vector) 270787/ */ /* AK 270689 V1.0 */ /* AK 060390 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("b_ks_o",object); FREESELF(object); C_O_K(object,kind); C_O_S(object,self); ENDR("b_ks_o"); } /* must be with offset */ INT (*check_time_co)(); INT check_time() { static INT l_callocobject; if (check_time_co != NULL) { (*check_time_co)(); } runtime(&l_callocobject); if (l_callocobject > sym_timelimit) { fprintf(stderr,"SYMMETRICA stopped due to timelimit\n"); exit(ERROR_TIMELIMIT); } return OK; } OP callocobject_magma() { OP res; res = (OP) SYM_MALLOC(sizeof(struct object)); C_O_K(res,EMPTY); return res; } OP callocobject() /* erzeugt den speicherplatz fuer ein object 270787 */ /* AK 270689 V1.0 */ /* AK 170190 V1.1 */ /* AK 060891 V1.3 */ { #ifdef SYMMAGMA return callocobject_magma(); #else OP c; if (sym_timelimit > 0L) check_time(); if (freeall_speicherposition >= 0L) /* AK 111091 */ { c = freeall_speicher[freeall_speicherposition--]; } else c = (OP) SYM_MALLOC(sizeof(struct object)); if (c == NULL) error("callocobject:NULL object"); C_O_K(c,EMPTY); return c; #endif } OP callocobject_fast() /* AK 141101 */ { OP c; c = (OP) SYM_MALLOC(sizeof(struct object)); C_O_K(c,EMPTY); return c; } OBJECTSELF s_o_s(a) OP a; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */ { if (a==NULL) { error("s_o_s:object == NULL"); } return(a->ob_self); } OBJECTKIND s_o_k(a) OP a; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { if (a==NULL) {return((OBJECTKIND) error("s_o_k:object == NULL"));} return(a->ob_kind); } INT c_o_k(a,b) OP a; OBJECTKIND b; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("c_o_k",a); a->ob_kind = b; ENDR("c_o_k"); } INT c_o_s(a,b) OP a; OBJECTSELF b; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("c_o_s",a); a->ob_self = b; ENDR("c_o_s"); } INT emptyp(a) OP a; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { return(s_o_k(a) == EMPTY); } INT test_callocobject() /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { OP a = callocobject(); printf("test_callocobject: sizeof(OP)=%d\n",sizeof(a)); printf("test_callocobject: sizeof(*OP)=%d\n",sizeof(*a)); printf("test_callocobject: sizeof(struct object)=%d\n",sizeof(struct object)); if (a==NULL) { printf("test_callocobject: NULL-object");return(OK); } printf("test_callocobject: a=%ld\n",(INT)a); printf("test_callocobject: a->ob_kind=%ld\n",(INT) (a->ob_kind)); printf("test_callocobject: a->ob_self.ob_INT=%ld\n", (a->ob_self).ob_INT); SYM_free(a); return(OK); } INT debugprint_object(a) OP a; /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { if (a==NULL) { fprintf(stderr,"debugprint_object: NULL-object");return(OK);} fprintf(stderr,"debugprint_object: a=%ld\n",(INT)a); fprintf(stderr,"debugprint_object: kind=%ld\n",(INT)a->ob_kind); fprintf(stderr,"debugprint_object: self.INT=%ld\n",a->ob_self.ob_INT); return(OK); } INT test_object() /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { OP a=callocobject(); OBJECTSELF d; printf("test von callocobject()\n"); test_callocobject(); printf("\nobject vor c_o_k()\n"); debugprint_object(a); c_o_k(a,(OBJECTKIND)5); printf("\nobject nach c_o_k(a,5)\n"); debugprint_object(a); d.ob_INT = 12345L; c_o_s(a,d); printf("\nobject nach c_o_s(a,12345L)\n"); debugprint_object(a); SYM_free(a); return(OK); } #ifdef SKEWPARTTRUE OP s_spa_g(a) OP a; /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF b; INT erg = OK; CTO(SKEWPARTITION,"s_spa_g",a); b = s_o_s(a); return b.ob_skewpartition->spa_gross; ENDO("s_spa_g"); } INT c_spa_g(a,b) OP a,b; /* AK 280789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF c; c=s_o_s(a); c.ob_skewpartition->spa_gross=b; return(OK); } OP s_spa_k(a) OP a; /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_skewpartition->spa_klein); } INT c_spa_k(a,b) OP a,b; /* AK 280789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { OBJECTSELF c; c=s_o_s(a); c.ob_skewpartition->spa_klein=b; return(OK); } OP s_spa_gi(a,i) OP a; INT i; /* AK 260789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { return(s_pa_i(s_spa_g(a),i)); } OP s_spa_ki(a,i) OP a; INT i; /* AK 260789 V1.1 */ /* AK 210891 V1.3 */ { return(s_pa_i(s_spa_k(a),i)); } INT s_spa_gii(a,i) OP a; INT i; /* AK 260789 V1.1 */ /* AK 210891 V1.3 */ { return(s_pa_ii(s_spa_g(a),i)); } INT s_spa_gli(a) OP a; /* AK 260789 V1.1 */ /* AK 210891 V1.3 */ { return(s_pa_li(s_spa_g(a))); } INT s_spa_kii(a,i) OP a; INT i; /* AK 260789 V1.1 */ /* AK 210891 V1.3 */ { return(s_pa_ii(s_spa_k(a),i)); } INT s_spa_kli(a) OP a; /* AK 260789 V1.1 */ /* AK 210891 V1.3 */ { return(s_pa_li(s_spa_k(a))); } #endif INT comp_skewpartition(a,b) OP a,b; { INT erg=OK; INT res=0; CTO(SKEWPARTITION,"comp_skewpartition(1)",a); CTO(ANYTYPE,"comp_skewpartition(2)",b); if (S_O_K(b) == SKEWPARTITION) res= comp_skewpartition_skewpartition(a,b); else WTO("comp_partition(2)",b); return res; ENDR("comp_skewpartition"); } INT comp_skewpartition_skewpartition(a,b) OP a,b; { INT erg=OK; CTO(SKEWPARTITION,"comp_skewpartition_skewpartition(1)",a); CTO(SKEWPARTITION,"comp_skewpartition_skewpartition(2)",b); erg = comp(S_SPA_G(a), S_SPA_G(b)); if (erg != 0) return erg; return comp(S_SPA_K(a), S_SPA_K(b)); ENDR("comp_skewpartition_skewpartition"); } INT lastof_skewpartition(a,b) OP a,b; /* AK 280789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { #ifdef SKEWPARTTRUE return(lastof(S_SPA_G(a),b)); #else return error("lastof_skewpartition:SKEWPARTITION not available"); #endif } #ifdef SKEWPARTTRUE INT length_skewpartition(a,b) OP a,b; /* AK 280789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { return length(S_SPA_G(a),b); } INT hash_skewpartition(a) OP a; /* AK 201201 */ { INT erg = OK; CTO(SKEWPARTITION,"hash_skewpartition(1)",a); return hash_partition(S_SPA_G(a)) + 11 * hash_partition(S_SPA_K(a)); ENDR("hash_skewpartition"); } INT freeself_skewpartition(a) OP a; /* AK 280789 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; CTO(SKEWPARTITION,"freeself_skewpartition(1)",a); FREEALL(S_SPA_G(a)); FREEALL(S_SPA_K(a)); SYM_free(S_O_S(a).ob_skewpartition); C_O_K(a,EMPTY); ENDR("freeself_skewpartition"); } INT copy_skewpartition(a,b) OP a,b; /* AK 280789 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; CTO(SKEWPARTITION,"copy_skewpartition(1)",a); CTO(EMPTY,"copy_skewpartition(2)",b); erg += b_gk_spa(callocobject(),callocobject(),b); copy_partition(S_SPA_G(a),S_SPA_G(b)); copy_partition(S_SPA_K(a),S_SPA_K(b)); ENDR("copy_skewpartition"); } INT weight_skewpartition(a,b) OP a,b; /* AK 020488 */ /* AK 060390 V1.1 */ /* AK 020591 V1.2 */ /* AK 210891 V1.3 */ { OP c=callocobject(), d=callocobject(); weight(S_SPA_G(a),c); weight(s_spa_k(a),d); sub(c,d,b); freeall(c); freeall(d); return(OK); } INT objectread_skewpartition(f,a) FILE *f; OP a; /* AK 210690 V1.1 */ /* AK 020591 V1.2 */ /* AK 210891 V1.3 */ { b_gk_spa(callocobject(),callocobject(),a); objectread(f,S_SPA_G(a)); objectread(f,s_spa_k(a)); return OK; } INT objectwrite_skewpartition(f,a) FILE *f; OP a; /* AK 210690 V1.1 */ /* AK 210891 V1.3 */ { INT erg = OK; COP("objectwrite_skewpartition(1)",f); fprintf(f, "%ld ", (INT)SKEWPARTITION); erg += objectwrite(f,S_SPA_G(a)); erg += objectwrite(f,s_spa_k(a)); ENDR("objectwrite_skewpartition"); } INT dimension_skewpartition(a,b) OP a,b; /* dimension der dartsellung */ /* AK 020890 V1.1 */ /* AK 210891 V1.3 */ { OP c = callocobject(); part_part_skewschur(S_SPA_G(a),S_SPA_K(a),c); dimension(c,b); freeall(c); return OK; } INT starpart(a,b,c) OP a,b,c; /* 020488 AK implementiert staroperation aus REWH */ /* bsp 123 * 222 -> 222345/222 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */ { INT i,letztes; OP glength = callocobject(); OP klength = callocobject(); b_gk_spa(callocobject(),callocobject(),c); add(S_PA_L(a),S_PA_L(b),glength); length(a,klength); b_kl_pa(VECTOR,glength,S_SPA_G(c)); b_kl_pa(VECTOR,klength,S_SPA_K(c)); letztes = S_PA_II(b,S_PA_LI(b)-1); for (i=0L;i=0;i--) /* number of subwords */ { r = 1; m_il_w(S_PA_II(d,i),e); /* the subword */ ccc: j=S_W_LI(c)-1; ddd: if (S_W_II(c,j) == r) { r++; M_I_I(-S_W_II(c,j),S_W_I(c,j)); } j--; if (r == S_W_LI(e) +1) goto bbb; /* one word finished */ if (j == -1) goto ccc; else goto ddd; bbb: for (j=0,r=0;j oj) r++; M_I_I(r,S_V_I(c,j)); oj = j; } } erg += sum(c,b); eee: erg += freeall(c); ENDR("charge_word"); } INT random_word(a,b) OP a,b; /* AK 030892 */ /* a random word of length a and entries between 1 and 2 * length */ { OP c; INT erg = OK, i; CTO(INTEGER,"random_word(1)",a); c = CALLOCOBJECT(); M_I_I(S_I_I(a)+S_I_I(a),c); erg += m_l_w(a,b); for (i=0L;i= r in S_a_rofword"); } copy(r,i); do { dec(i); S_rofword(w,i); } while( ge(i,a) ); freeall(i); return(OK); } INT S_rofword(w,r) OP w,r; /* 210488 */ /* AK 160890 V1.1 */ /* liefert TRUE solange ein r-index > 0 */ /* AK 210891 V1.3 */ { INT erg = OK; OP m=callocobject(); OP index=callocobject(); erg += maxrindexword(w,r,index,m); if (S_I_I(m) <= 0L) return(FALSE); M_I_I(S_I_I(r)-1L,S_W_I(w,S_I_I(index))); erg += freeall(m); erg += freeall(index); return(TRUE); } INT content_word(a,b) OP a,b; /* AK 300792 */ { INT erg=OK,m,i; CTTO(VECTOR,WORD,"content_word(1)",a); CTO(EMPTY,"content_word(2)",b); m=0L; for (i=0L;im) m=S_W_II(a,i); /* m is max */ erg += m_il_nv(m,b); for (i=0L;i=0L;i--,k++) for (j=s_v_ii(in,k)-1L;j>=0L;j--) M_I_I(k+1L,s_t_ij(s,i,j)); freeall(in); SYM_free(m); return OK; } INT rm_rindex(word,r) OP word,r; /* 250488 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { while(S_rofword(word,r)) { }; return(OK); } static INT coroutine250488(i,word,tableaux) INT i; OP word,tableaux; /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { OP rindex=callocobject(); OP umriss; INT erg=OK; M_I_I(i,rindex); while(S_rofword(word,rindex)) erg += R_roftableaux(tableaux,rindex); /* simultane operation auf tableaux */ if (i>2) erg += coroutine250488(i-1L,word,tableaux); umriss = callocobject(); /* AK 100688 den umriss ausrechnen */ erg+= m_matrix_umriss(S_T_S(tableaux), S_T_U(tableaux)); erg += freeall(rindex); return erg; } INT m_tableaux_tableauxpair(tab,ergtab_eins,s) OP tab,ergtab_eins,s; /* AK 160890 V1.1 */ /* AK 210891 V1.3 */ { OP w = callocobject(); INT i,j,l; INT index; wordoftableaux(tab,w); starttableaux(tab,s); l = s_t_hi(s); for(i=2L;i<=l;i++) coroutine250488(i,w,s); copy(tab,ergtab_eins); index=0L; for (i=s_t_hi(ergtab_eins)-1L;i>=0L;i--) for (j=s_t_li(ergtab_eins)-1L;j>=0L;j--) if (not EMPTYP(s_t_ij(ergtab_eins,i,j))) { M_I_I(S_W_II(w,index),s_t_ij(ergtab_eins,i,j)); index++; }; freeall(w); return OK; } INT maxrindexword(w,r,index,erg) OP w,r,erg,index; /*210488*/ /* AK 160890 V1.1 */ /* berechnet den maximalen wert der r-indices */ /* er wird an der stelle index erreicht */ /* AK 210891 V1.3 */ { INT i; OP zw_eins=callocobject(); OP stelle=callocobject(); M_I_I(-1000000L,erg); M_I_I(0L,index); for(i=0L;i=lg_vc1+delta) m_il_nla(lg_vc2,res); else m_il_nla(lg_vc1+delta,res); M_I_I(S_LA_II(vc2,0L),S_LA_I(res,0L)); for(i=1L;i=lg_vc) { erg += m_il_nla(2L,vc); goto endr_ende; } tmp=0L; for(i=lg_vc-1L;i>0L;i--) { if(S_LA_II(vc,i)!=0L) break; else tmp++; } w=callocobject(); lg_w=lg_vc-tmp-tp; erg += m_il_la(lg_w,w); M_I_I(S_LA_II(vc,0L)+tp,S_LA_I(w,0L)); for(i=1L;i=0L) { erg += init(MONOPOLY,mp); for(i=1L;i2L) { freeall(v); return error("t_BRUCH_LAURENT: don't succeed in converting into Laurent polynomial"); } t_OBJ_LAURENT(oo,vc); vc1=callocobject(); copy(vc,vc1); sub(S_LA_I(vc1,0L),S_LA_I(v,0L),S_LA_I(vc,0L)); for(i=1L;i=1;i--) { erg += m_i_i(i-1,p); erg += m_i_i(i,oi); do { erg += inc(p); erg += binom(p,oi,h); } while (ge(r,h)); erg += dec(p); erg += binom(p,oi,h); erg += sub(r,h,r); erg += m_i_i(S_I_I(p)+1,S_V_I(d,i-1)); } FREEALL4(p,oi,h,r); ENDR("unrank_subset"); } INT unrank_k_subset(OP number, OP n, OP k, OP set) /* die menge ist k-teilmenge von 1...n */ /* sortierung ist lexikographisch */ /* AK 241006 V3.1 */ { INT erg =OK; OP h,b; INT i; // printf("number= "); print(number); printf(" n = ");print(n); printf(" k= ");println(k); if (S_O_K(set)!= VECTOR) m_l_v(k,set); else if (S_V_LI(set)!= S_I_I(k)) m_l_v(k,set); if (S_I_I(k)==S_I_I(n)) { for(i=0;i orbit_max_size) ) goto end; } else { OP perm,inv; if (sv != NULL) { CALLOCOBJECT2(perm,inv); if (words_jn==0) { MULT(S_V_I(erz,i),S_V_I(z,1),perm); INVERS(S_V_I(z2,1),inv); MULT_APPLY(inv,perm); } else { INT ii,jj; m_il_v(S_V_LI(S_V_I(z,1))+1+S_V_LI(S_V_I(z2,1)),perm); for (ii=0;ii=0;ii++,jj--) M_I_I(-S_V_II(S_V_I(z2,1),jj),S_V_I(perm,ii)); } in = index_vector(perm,sv); if (in == -1) { INC(sv); COPY(perm, S_V_I(sv,S_V_LI(sv)-1)); /* add the new schreier generator */ } FREEALL2(inv,perm); } FREEALL(ares); } } FREEALL(z); z = pop(cand); } end: erg += m_il_v(WEIGHT_HASHTABLE(h),res); i=0; FORALL(z,h,{COPY(S_V_I(z,0),S_V_I(res,i)); i++; }); FREEALL2(h,cand); ENDR("orbit"); } static all_orbits_trace=0; static INT (*all_orbits_rankf)()=NULL; INT all_orbits_set_trace() { all_orbits_trace=1; } INT all_orbits_unset_trace() { all_orbits_trace=0; } INT all_orbits_set_rankf(f) INT (*f)(); { all_orbits_rankf=f; } INT all_orbits_unset_rankf() { all_orbits_rankf=NULL; } INT all_orbits(X,erz,bahnen,no,f) OP X,erz,bahnen,no; INT (*f)(); /* berechnet alle bahnen von erz auf der menge X die menge X wird sortiert in bahnen steht danach die bahnnr beginnend mit 1 die anzahl der bahnen ist in no */ { INT erg = OK; CTO(VECTOR,"all_orbits(1)",X); CTO(VECTOR,"all_orbits(2)",erz); { INT nextbahn=0; // naechste unverbrauchte element INT bahnnr=1; OP c; // ein test ob identität bei den erzeugern // das kostet zeit { INT i; for (i=0;i 0) // dies sind elemente zu anderen bahnen AK290607 || (NEQ(S_V_I(c,j),S_V_I(X,k))) ) { if (S_V_II(bahnen,k)==0) nextbahn=k; /* nextbahn next element from X not in known orbit */ k++; } M_I_I(bahnnr,S_V_I(bahnen,k)); } while (k0 if a bigger. it works for the following kind of objects BRUCH numerical INTEGER numerical LIST lexico LONGINT numerical MATRIX lexico PARTITION lexico PERMUTATION lexico POLYNOM lexico REIHE lexico SCHUBERT lexico SCHUR lexico VECTOR lexico NAME: copy SYNOPSIS: INT copy(OP a,b) DESCRIPTION: copies object a to b. First b is freed to an empty object. NAME: divdiff SYNOPSIS: INT divdiff(OP a,b,c) DESCRIPTION: computes the divided difference. The Operator is labeld by the object a (PERMUTATION or INTEGER) and is apllied on the object b (POLYNOM or SCHUBERT) the result is the object c. NAME: dynamicp SYNOPSIS: INT dynamicp(OP a) DESCRIPTION: tests whether a is a dynamic datatype. RETURN: TRUE or FALSE NAME: einsp SYNOPSIS: INT einsp(OP a) DESCRIPTION: tests whether a is unity. works for the following kinds of objects: BRUCH FINITEFIELD INTEGER LONGINT MATRIX PERMUTATION REIHE SCHUBERT SYMCHAR VECTOR RETURN: TRUE or FALSE NAME: even SYNOPSIS: INT even(OP a) DESCRIPTION: checks wether the input is even, this works for the following kind of objects INTEGER LONGINT PERMUTATION EXAMPLE: the following is an example for a PERMUTATION object as the input: #include "def.h" #include "macro.h" main() { OP a; anfang(); a=callocobject(); scan(PERMUTATION,a); print(a); if (even(a)) {printf(" is element of A");println(S_P_L(a));} else {printf(" is not element of A");println(S_P_L(a));} freeall(a); ende(); } NAME: first SYNOPSIS: INT first(OBJECTKIND k; OP a, erg) DESCRIPTION: k gives the kind of object, which we want to generate a is a parameter which is needed to generate erg becomes the result NAME: freeall SYNOPSIS: INT freeall(OP a) DESCRIPTION: frees all the memory of object a, before further use of a, you have to do a=callobject(); NAME: freeself SYNOPSIS: INT freeself(OP a) DESCRIPTION: frees the memory of the object a, the result is a empty object a NAME: init SYNOPSIS: INT init(OBJECTKIND a, OP b) DESCRIPTION: it generates an empty object of the special kind, specified by a. First it frees b to an empty object. Now follows the exact specification of the meaning empty object of the special kind: INTEGER: empty object VECTOR: vector of length 0 with self==NULL LIST: self and next == NULL MONOM: self and koeff are empty objects POLYNOM: SCHUR: SCHUBERT: next==NULL self == empty MONOM PERMUTATION: self is empty object PARTITION: self is empty object NAME: insert SYNOPSIS: INT insert(OP a,b; INT (*eq)(), (*comp)()) DESCRIPTION: inserts the object a into the object b, the funktion comp is for comparision of the list elements, these are for example MONOM objects in the case of POLYNOM objects, the function eq is for handling the case, that the element which should be inserted is already in the list. (comp the file list.doc) NAME: lastof SYNOPSIS: INT lastof(OP a,b) DESCRIPTION: b becomes the last element of a. It works for PARTITION SKEWPARTITION VECTOR it should be noticed, that b becomes a copy of the last element. NAME: lastp SYNOPSIS: INT lastp(OP a) DESCRIPTION: RETURN: TRUE or FALSE NAME: listp SYNOPSIS: INT listp(OP a) DESCRIPTION: RETURN: TRUE or FALSE NAME: negeinsp SYNOPSIS: INT negeinsp(OP a) DESCRIPTION: RETURN: TRUE or FALSE NAME: negp SYNOPSIS: INT negp(OP a) DESCRIPTION: RETURN: TRUE or FALSE NAME: next SYNOPSIS: INT next(OP a,b) DESCRIPTION: computes the next element, at the moment it works for: PARTITION PERMUTATION RETURN: TRUE or FALSE accord whether there was a next element or not NAME: nullp SYNOPSIS: INT nullp(OP a) DESCRIPTION: returns true if the object a is null, it works for INTEGER,FINITEFIELD, LONGINT,BRUCH,POLYNOM, VECTOR,SQRAD,CYCLOTOMIC,SYMCHAR, MATRIX, SCHUBERT, REIHE RETURN: TRUE or FALSE NAME: posp SYNOPSIS: INT posp(OP a) DESCRIPTION: RETURN: TRUE or FALSE NAME: rz SYNOPSIS: INT rz(OP a,b) DESCRIPTION: computes a reduced decomposition of a PERMUTATION object a, or of VECTOR object a, which needs to be a lehmercode (cf. perm.doc), the result is VECTOR object b of INTEGER objects. This works for permutations i.e. weyl group type A, and for barred permutations, i.e. weyl group type B. RETURN: OK or ERROR NAME: scalarp SYNOPSIS: INT scalarp(OP a) DESCRIPTION: BRUCH, INTEGER or LONGINT are socalled scalar types, in this case the return value is true. RETURN: TRUE or FALSE NAME: swap SYNOPSIS: INT swap(OP a,b) DESCRIPTION: the values of the objects a and b are exchanged RETURN: ERROR if a == b or OK symmetrica-2.0/rh.c0000400017361200001450000020044110726021650014150 0ustar tabbottcrontab/* SYMMETRICA rh.c */ #include "def.h" #include "macro.h" #ifdef REIHETRUE /* ++++++++++++ jetzt Variablendeklaration +++++++++++++++ */ static INT zuwachs=(INT)5; /* +++++++++++ Funktionsdeklaration +++++++++++++++++ */ #define new_var new_drei #define new_mon new_zwei static INT co_261093(); static INT reihevergleich (); static INT Eins_eingabe(); static INT co_eingabe(); static INT Random_eingabe(); static INT co_REIHE(); static int debugprint_rh(); static int debugprint_rh_var(); static int debugprint_rh_mon(); static int debugprint_rh_poly(); static struct REIHE_variablen *new_drei(); static struct REIHE_mon *new_zwei(); static struct REIHE_poly *new_eins(); static INT JH_add_reihe(); static INT JH_mult_reihe(); static int pot_reihe(); static int transform_reihe(); static int subst_reihe(); static int ableitung_reihe(); static INT initial_reihe(); static INT einfuegen_in_reihe(); static int del_reihe(); static int del_var(); static int del_mon(); static int del_poly(); static int normalisiere_reihe(); static int make_skalar_reihe(); static INT make_reihe(); static INT ergaenze_reihe(); static int card_typ_reihe(); static int card_reihe(); static int variablenvergleich(); static int monomvergleich (); static int monomgrad(); static INT monommult(); static INT monomausgabe(); static int trans_reihe_in_monom(); static int copyy_monom(); static JH_copy_reihe(); static JH_copy_reihe_co(); static INT reihe_zu_sympolynom(), monom_zu_symmonom(); static INT poly_zu_sympolynom(); static int ausgabe(), copy_var(), copy_mon(); static int free_drei(), free_zwei(), free_eins(); static int del_poly(p) struct REIHE_poly **p; /* AK 110393 */ { if (*p != NULL) { del_mon(& (*p) ->unten); del_poly(& (*p) ->rechts); free_eins((char*)*p); *p = NULL; } } static int del_mon(m) struct REIHE_mon **m; /* AK 110393 */ { if (*m != NULL) { del_var(& (*m)->zeiger); if ((*m)-> coeff != NULL) freeall((*m)->coeff); del_mon(& (*m)->ref); free_zwei((char*)(*m)); *m = NULL; } } static int del_var(v) struct REIHE_variablen **v; /* AK 110393 */ { if (*v != NULL) { del_var(&(*v)->weiter); free_drei((char*)*v); *v = NULL; } } static int copy_poly(a,b) struct REIHE_poly **b,*a; /* AK 150393 */ { if (a==NULL) return (int)(*b = NULL); *b = (struct REIHE_poly *) SYM_malloc(sizeof(struct REIHE_poly)); if (*b == NULL) return (int)no_memory; (*b)->grad = a->grad; copy_mon(a->unten, & (*b)->unten); copy_poly(a->rechts, & (*b)->rechts); } static int copy_mon(a,b) struct REIHE_mon **b,*a; /* AK 150393 */ { if (a==NULL) return (int)(*b = NULL); *b = (struct REIHE_mon *) SYM_malloc(sizeof(struct REIHE_mon)); if (*b == NULL) return (int)no_memory; (*b)->coeff=callocobject(); copy(a->coeff, (*b)->coeff); copy_mon(a->ref, & (*b)->ref); copy_var(a->zeiger, & (*b)->zeiger); } static int copy_var(a,b) struct REIHE_variablen **b,*a; /* AK 150393 */ { if (a == NULL) return (int)(*b = NULL); *b = (struct REIHE_variablen *) SYM_malloc(sizeof(struct REIHE_variablen)); if (*b == NULL) return (int)no_memory; (*b)->index = a->index; (*b)->potenz = a->potenz; copy_var(a->weiter, & (*b)->weiter); } static int copy_rh(a,b) REIHE_zeiger a,*b; { if (a == NULL) return (int)(*b = NULL); *b = (struct reihe *) SYM_malloc(sizeof(struct reihe)); if (*b == NULL) return (int)no_memory; (*b)->exist = a->exist; (*b)->reihenart = a->reihenart; (*b)->z = a->z; (*b)->ope = a->ope; (*b)->eingabefkt = a->eingabefkt; copy_rh(a->x, & (*b)->x); copy_rh(a->y, & (*b)->y); copy_rh(a->p, & (*b)->p); copy_poly(a->infozeig, & (*b)->infozeig); } INT max_degree_reihe(a,b) OP a,b; /* AK 100393 */ { OBJECTSELF d; INT i; INT erg = OK; CTO(REIHE,"max_degree_reihe",a); d = S_O_S(a); if (d.ob_reihe == NULL) { erg += m_i_i((INT)-1,b); goto endr_ende; } i = d.ob_reihe -> exist; erg += m_i_i(i,b); ENDR("max_degree_reihe"); } static struct REIHE_variablen *new_drei() { return (struct REIHE_variablen*) SYM_calloc(1,sizeof(struct REIHE_variablen)); } static int free_drei(a) char *a; { SYM_free(a); } static int free_zwei(a) char *a; { SYM_free(a); } static int free_eins(a) char *a; { SYM_free(a); } static int free_null_debug(a) char *a; { printf("free_null:%ld\n",a); SYM_free(a); } static int free_null(a) char *a; { SYM_free(a); } static struct REIHE_mon *new_zwei() { return (struct REIHE_mon*) SYM_calloc(1,sizeof(struct REIHE_mon)); } static struct REIHE_poly *new_eins() { return (struct REIHE_poly*) SYM_calloc(1,sizeof(struct REIHE_poly)); } static struct reihe *new_null() { struct reihe *a; a = (struct reihe*) SYM_calloc(1,sizeof(struct reihe)); return a; } static struct reihe *new_null_debug() { struct reihe *a; a = (struct reihe*) SYM_calloc(1,sizeof(struct reihe)); printf("new_null:%ld\n",a); return a; } static INT initial_reihe(adress) REIHE_zeiger* adress; /* JH 0293 */ { *adress=new_null(); if (*adress == NULL) return no_memory(); (*adress)->exist=0L; (*adress)->reihenart=1L; (*adress)->x=NULL; (*adress)->y=NULL; (*adress)->z=0L; (*adress)->p=NULL; (*adress)->eingabefkt=NULL; (*adress)->ope='#'; (*adress)->infozeig=new_eins(); (*adress)->infozeig->unten=NULL; (*adress)->infozeig->rechts=NULL; (*adress)->infozeig->grad=0L; return OK; } static struct reihe *callocreihe() /* AK 090393 */ { struct reihe *a; initial_reihe(&a); return a; } INT init_reihe(a) OP a; /* AK 090393 */ { OBJECTSELF c; c.ob_reihe = callocreihe(); B_KS_O(REIHE,c,a); return OK; } static int normalisiere_reihe(a) REIHE_zeiger a; { /* entfernen des absoluten Gliedes wegen pletist. Subst. */ a->infozeig->unten=NULL; } static int card_reihe(a) REIHE_zeiger a; { struct REIHE_poly *zeigpoly; struct REIHE_mon *zeigmon; if (a!=NULL) { zeigpoly=a->infozeig; do { if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; if (((zeigmon->zeiger)==NULL) || ((zeigmon->zeiger->potenz)==(zeigpoly->grad))) monomausgabe(zeigmon); } zeigpoly=zeigpoly->rechts; } while (zeigpoly!=NULL); } } static int card_typ_reihe(a) REIHE_zeiger a; { struct REIHE_poly *zeigpoly; struct REIHE_mon *zeigmon; OP e; if (a!=NULL) { zeigpoly=a->infozeig; do { if (zeigpoly->unten!=NULL) { e=callocobject(); m_i_i(0L,e); zeigmon=zeigpoly->unten; do { add_apply(zeigmon->coeff,e); zeigmon=zeigmon->ref; } while (zeigmon!=NULL); print(e); if (zeigpoly->grad!= (INT)0) printf("X^%i\n",zeigpoly->grad); else printf("\n"); freeall(e); } zeigpoly=zeigpoly->rechts; } while (zeigpoly!=NULL); } } static int variablenvergleich(p,q) struct REIHE_variablen* p, * q; { int hilf; if (q==NULL) hilf=2; else if (p == NULL) hilf = -1; /* AK 040893 */ else { /* referenzmonom ist ....... als einzufuegendes monom */ hilf=0; /* gleich */ if ((p->index)>(q->index)) hilf= -1; /* kleiner */ if ((p->index)<(q->index)) hilf=1; /* groesser */ } return hilf; } static int monomvergleich (p,q) struct REIHE_mon* p, * q; { /* p einzufuegendes Monom */ struct REIHE_variablen* p1; struct REIHE_variablen* q1; int hilf; if (q==NULL) hilf=2; /* q ist NULLREIHE_zeiger */ else { p1=p->zeiger; /* koennen NULL sein bei abs. Glied */ q1=q->zeiger; if ((p1==NULL) && (q1==NULL)) hilf=0; /* gleich */ else if (p1==NULL) hilf= -1; /* AK 030893 */ else if (q1==NULL) hilf=1; /* AK 030893 */ else { while (((p1->index)==(q1->index)) && ((p1->potenz)==(q1->potenz)) && ((p1->weiter)!=NULL)) /* nur wenn gleiche Monome, */ { /* sonst schon vorher Unterschied */ p1=p1->weiter; q1=q1->weiter; } if ((p1->weiter==NULL) && ((p1->index)==(q1->index)) && ((p1->potenz)==(q1->potenz))) hilf=0; /* gleiche Monome */ /* falls Unterschied erst beim letzten Monomteil und p->weiter ist also Null */ else { if ((p1->indexindex) || ((p1->index==q1->index) && (p1->potenz>q1->potenz))) hilf=1; /* Referenzmonom ist groeaer */ else hilf= -1;/* Referenzmonom ist kleiner */ } } } return hilf; } static int monomgrad(p) struct REIHE_mon* p; { struct REIHE_variablen* p1; int hilf; hilf=0; p1=p->zeiger; if (p1!=NULL) { do { /* hilf=hilf+((p1->index))*(p1->potenz); */ hilf=hilf+((p1->index)+1)*(p1->potenz); p1=p1->weiter; } while (p1!=NULL); } return hilf; } static INT einfuegen_in_reihe(m,in) struct REIHE_mon* m; REIHE_zeiger in; { /* ein neuer Grad ist immer groeaer als Null, es wurde mit Null initialisiert */ int g,v,gefunden; INT erg = OK; struct REIHE_poly *zeigpol,*p; struct REIHE_mon* zeigmon; struct REIHE_mon* hilfmon; struct REIHE_variablen* zeigvar,hilfvar; g=monomgrad(m); gefunden=0; p=in->infozeig; if (p==NULL) error("internal error:RH6"); while ((p->rechts!=NULL) && (gefunden==0)) { if ((p->rechts->grad)<=g) p=p->rechts; else gefunden=1; } /* Vergleiche von links nach rechts , Abbruch sobald etwas zutrifft */ /* also while ((p->rechts!=NULL) && (p->rechts->gradgrad==g) { switch(v=monomvergleich(m,p->unten)) /* falls ganz oben */ { /*eingesetzt werden mua */ case 2: p->unten=m; break; /* als erstes Monom bei Grad 0 */ case 1: hilfmon=p->unten; /* ganz oben einsetzen */ p->unten=m; m->ref=hilfmon; break; case 0: add_apply(m->coeff,p->unten->coeff); del_mon(& m); /* AK 110393 */ break; } if (v==-1) /* also noch nicht ganz vorne eingefuegt */ { zeigmon=p->unten; while ((v=monomvergleich(m,zeigmon->ref))<=0) zeigmon=zeigmon->ref; if (monomvergleich(m,zeigmon)==0) /* passendes Monom gefunden */ { erg += add_apply(m->coeff,zeigmon->coeff) ; del_mon(& m); /* AK 110393 */ } else switch(v) { case 2 : /* am Ende anfuegen */ zeigmon->ref=m; break; case 1 : /* naechstes Monom ist groeaer */ hilfmon=zeigmon->ref; zeigmon->ref=m; m->ref=hilfmon; break; } } } else if (p->rechts==NULL) /* am Ende neuen Grad erzeugen */ { p->rechts=new_eins(); p=p->rechts; p->grad=g; p->unten=m; p->rechts=NULL; } else /* neuen Grad dazwischenschieben */ { zeigpol=p->rechts; p->rechts=new_eins(); p=p->rechts; p->rechts=zeigpol; p->grad=g; p->unten=m; } if (erg != OK) error("internal error:RH7"); return erg; } INT Exp_eingabe(root, anzahl) REIHE_zeiger root; INT anzahl; /* JH 0293 */ { OP b,d,f; INT l; struct REIHE_mon *zeigmon; b=callocobject(); d=callocobject(); f=callocobject(); if (root->exist==0) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; m_i_i(1L,zeigmon->coeff); einfuegen_in_reihe(zeigmon,root); } for (l=root->exist+1L;l<=root->exist+anzahl;l++) { m_i_i(l,d); fakul(d,b); zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; m_i_i(1L,f); m_ou_b(f,b,zeigmon->coeff); kuerzen(zeigmon->coeff); zeigmon->zeiger=new_drei(); zeigmon->zeiger->weiter=NULL; zeigmon->zeiger->index=1; zeigmon->zeiger->potenz=l; einfuegen_in_reihe(zeigmon,root); } root->exist+=anzahl; /* erhoehen um anzahl */ freeall(b); freeall(d); freeall(f); } static INT co_261093(root,anzahl,func) REIHE_zeiger root; INT anzahl; INT (*func)(); /* bei benutzer definierten funktionen f ist vom typ (OP degree, OP koeff) */ { OP b,d,f; OP bb; INT i,j,l,k; INT erg=OK; struct REIHE_mon *zeigmon; struct REIHE_variablen *zeigvar,*help_drei; b=callocobject(); d=callocobject(); f=callocobject(); if (root->exist==0L) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; /* m_i_i(1L,zeigmon->coeff); */ (*func)(cons_null,b); if (S_O_K(b) != POLYNOM) EDC("RH11:internal error"); copy(S_PO_K(b),zeigmon->coeff); einfuegen_in_reihe(zeigmon,root); } for (l=root->exist+1L;l<=root->exist+anzahl;l++) { m_i_i(l,d); (*func)(d,b); if (S_O_K(b) != POLYNOM) EDC("RH12:internal error"); bb = b; while (bb!=NULL) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; /* m_i_i(1L,f); */ copy(S_PO_K(bb) ,zeigmon->coeff); /* for (j=1L;j<=l;j++) */ for (j=1L;j<=S_PO_SLI(bb);j++) { if ((k=S_PO_SII(bb,j-1))!=0L) { help_drei=new_drei(); help_drei->weiter=NULL; if (zeigmon->zeiger==NULL) zeigmon->zeiger=help_drei; else zeigvar->weiter=help_drei; zeigvar=help_drei; /* zeigvar->index=j; */ zeigvar->index=j-1; zeigvar->potenz=k; } } einfuegen_in_reihe(zeigmon,root); bb=S_PO_N(bb); } freeall(b); b=callocobject(); } root->exist+=anzahl; /* erhoehen um anzahl */ freeall(b); freeall(d); freeall(f); } INT Sinus_eingabe(root,anzahl) REIHE_zeiger root; INT anzahl; { OP a,b,c,d,e,f; INT l; struct REIHE_mon *zeigmon; b=callocobject(); d=callocobject(); f=callocobject(); e=callocobject(); m_i_i(2L,e); for (l=(root->exist)+1;l<=(root->exist)+anzahl;l++) { a=callocobject(); c=callocobject(); m_i_i(l,a); mod(a,e,c); if (einsp(c)) { m_i_i(l,d); fakul(d,b); zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; freeall(c); c=callocobject(); ganzdiv(a,e,c); freeall(a); a=callocobject(); mod(c,e,a); if (einsp(a)) m_i_i(-1L,f); else m_i_i(1L,f); m_ou_b(f,b,zeigmon->coeff); kuerzen(zeigmon->coeff); zeigmon->zeiger=new_drei(); zeigmon->zeiger->weiter=NULL; zeigmon->zeiger->index=0; zeigmon->zeiger->potenz=l; einfuegen_in_reihe(zeigmon,root); } freeall(a); freeall(c); } root->exist = (root->exist)+anzahl; /* erhoehen um anzahl */ freeall(b); freeall(d); freeall(f); freeall(e); return OK; } INT Cosinus_eingabe(root, anzahl) REIHE_zeiger root; INT anzahl; /* JH 0293 */ { OP a,b,c,d,e,f; INT l; struct REIHE_mon *zeigmon; b=callocobject(); d=callocobject(); f=callocobject(); e=callocobject(); m_i_i(2L,e); if (root->exist==0L) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; m_i_i(1L,zeigmon->coeff); einfuegen_in_reihe(zeigmon,root); } for (l=root->exist+1L;l<=root->exist+anzahl;l++) { a=callocobject(); c=callocobject(); m_i_i(l,a); mod(a,e,c); if (nullp(c)) { m_i_i(l,d); fakul(d,b); zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; freeall(c); c=callocobject(); ganzdiv(a,e,c); freeall(a); a=callocobject(); mod(c,e,a); if (einsp(a)) m_i_i(-1L,f); else m_i_i(1L,f); m_ou_b(f,b,zeigmon->coeff); kuerzen(zeigmon->coeff); zeigmon->zeiger=new_drei(); zeigmon->zeiger->weiter=NULL; zeigmon->zeiger->index=0; zeigmon->zeiger->potenz=l; einfuegen_in_reihe(zeigmon,root); } freeall(a); freeall(c); } root->exist+=anzahl; /* erhoehen um anzahl */ freeall(b); freeall(d); freeall(e); freeall(f); return OK; } #ifdef PARTTRUE INT Perm_eingabe(root, anzahl) REIHE_zeiger root; INT anzahl; { OP b,d,f; OP bb; INT i,j,l,k; struct REIHE_mon *zeigmon; struct REIHE_variablen *zeigvar,*help_drei; b=callocobject(); d=callocobject(); f=callocobject(); if (root->exist==0) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; m_i_i(1L,zeigmon->coeff); einfuegen_in_reihe(zeigmon,root); } for (l=root->exist+1L;l<=root->exist+anzahl;l++) { m_i_i(l,d); zykelind_Sn(d,b); bb = b; while (bb!=NULL) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; m_i_i(1L,f); copy(f,zeigmon->coeff); for (j=1L;j<=l;j++) { if ((k=S_PO_SII(bb,j-1))!=0) { help_drei=new_drei(); help_drei->weiter=NULL; if (zeigmon->zeiger==NULL) zeigmon->zeiger=help_drei; else zeigvar->weiter=help_drei; zeigvar=help_drei; zeigvar->index=j; zeigvar->potenz=k; } } einfuegen_in_reihe(zeigmon,root); bb=s_po_n(bb); } freeall(b); b=callocobject(); } root->exist+=anzahl; /* erhoehen um anzahl */ freeall(b); freeall(d); freeall(f); return OK; } INT E_eingabe(root, anzahl) REIHE_zeiger root; INT anzahl; /* JH 0293 */ { OP bb; OP b,d,f; INT i,j,l,k; struct REIHE_mon *zeigmon; struct REIHE_variablen *zeigvar,*help_drei; b=callocobject(); d=callocobject(); f=callocobject(); if (root->exist==0) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; m_i_i(1L,zeigmon->coeff); einfuegen_in_reihe(zeigmon,root); } for (l=root->exist+1L;l<=root->exist+anzahl;l++) { m_i_i(l,d); zykelind_Sn(d,b); bb = b; while (bb!=NULL) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; zeigmon->coeff=s_po_k(bb); for (j=1L;j<=l;j++) { if ((k=S_V_II(s_po_s(bb),j-1))!=0L) { help_drei=new_drei(); help_drei->weiter=NULL; if (zeigmon->zeiger==NULL) zeigmon->zeiger=help_drei; else zeigvar->weiter=help_drei; zeigvar=help_drei; zeigvar->index=j; zeigvar->potenz=k; } } einfuegen_in_reihe(zeigmon,root); bb=s_po_n(bb); } freeall(b); b=callocobject(); } root->exist+=anzahl; /* erhoehen um anzahl */ freeall(b); freeall(d); freeall(f); return OK; } #endif /* PARTTRUE */ static INT make_reihe(a,eingabe) REIHE_zeiger* a; INT (*eingabe)(); { initial_reihe(a); (*a)->reihenart=1L; (*a)->eingabefkt=eingabe; return OK; } INT m_function_reihe(f,a) OP a; INT (*f)(); /* AK 261093 */ { REIHE_zeiger *b; OBJECTSELF d; INT erg = OK; init(REIHE,a); d = S_O_S(a); b = & d.ob_reihe; ( S_O_S(a).ob_reihe)->reihenart=2L; ( S_O_S(a).ob_reihe)->eingabefkt=f; erg += ergaenze_reihe( & S_O_S(a).ob_reihe,5L); return erg; } INT m_scalar_reihe(c,b) OP c,b; /* AK 100393 */ { REIHE_zeiger *a; OBJECTSELF d; init(REIHE,b); d = S_O_S(b); a = & d.ob_reihe; (*a)->reihenart=1L; (*a)->infozeig->unten=new_zwei(); (*a)->infozeig->unten->coeff=callocobject(); copy(c,(*a)->infozeig->unten->coeff); (*a)->infozeig->unten->zeiger=NULL; (*a)->infozeig->unten->ref=NULL; return OK; } static int make_skalar_reihe(a) REIHE_zeiger* a; { initial_reihe(a); (*a)->reihenart=1; (*a)->infozeig->unten=new_zwei(); (*a)->infozeig->unten->coeff=callocobject(); scan(scanobjectkind(),(*a)->infozeig->unten->coeff); (*a)->infozeig->unten->zeiger=NULL; (*a)->infozeig->unten->ref=NULL; } INT inc_reihe(a) OP a; /* AK 100393 */ { INT erg = OK; erg += ergaenze_reihe( & S_O_S(a).ob_reihe,1L); ENDR("inc_reihe"); } static INT ergaenze_reihe(a,zunahme) REIHE_zeiger* a; INT zunahme; /* JH 0293 */ { INT erg = OK; if ((*a)->reihenart==1L) { if (((*a)->eingabefkt)!=NULL) (*((*a)->eingabefkt))((*a),zunahme); } else if ((*a)->reihenart==0L) { /* schon definierte Verknuepfung erweitern */ switch((*a)->ope) { case 'a': JH_add_reihe((*a)->x,(*a)->y,*a,zuwachs); break; case 'm': JH_mult_reihe((*a)->x,(*a)->y,*a,zuwachs); break; case 's': subst_reihe((*a)->x,(*a)->y,a,((*a)->exist)+zuwachs); break; /* immer neue Berechnung */ case 'p': pot_reihe((*a)->x,(*a)->z,*a,zuwachs); break; case 'l': ableitung_reihe((*a)->x,(*a)->z,*a,zuwachs); break; case 't': transform_reihe((*a)->x,(*a)->z,*a,zuwachs); break; default : erg += error("RH2:internal error"); } } else if ((*a)->reihenart == 2L) { co_261093((*a),zunahme,(*a)->eingabefkt); } else if ((*a)->reihenart == -1L) erg += error("RH1:internal error"); else erg += error("RH10:internal error"); return erg; } INT comp_reihe(a,b) OP a,b; /* AK 300793 */ { OBJECTSELF c,d; INT erg = OK; CTO(REIHE,"comp_reihe",a); CTO(REIHE,"comp_reihe",b); c = S_O_S(a); d = S_O_S(b); return reihevergleich(c.ob_reihe,d.ob_reihe); ENDR("comp_reihe"); } INT fprint_reihe(f,a) FILE *f; OP a; /* AK 090393 */ { OBJECTSELF c; c = S_O_S(a); ausgabe(f,c.ob_reihe); return OK; } static int ausgabe(f, r) REIHE_zeiger r; FILE *f; /* JH 0293 */ { struct REIHE_poly *zeigpoly; struct REIHE_mon *zeigmon; if (r!=NULL) { zeigpoly=r->infozeig; do { if (zeigpoly->unten!=NULL) /* weil p mit Grad 0 initial. wurde, */ { /* aber Konst. nicht unbedingt exist. */ zeigmon=zeigpoly->unten; do { monomausgabe(f, zeigmon); zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } while (zeigpoly!=NULL); } } static INT reihevergleich (s, r) REIHE_zeiger s,r; /* AK 300793 */ { struct REIHE_poly *zeigpoly_r; struct REIHE_poly *zeigpoly_s; struct REIHE_mon *zeigmon_r; struct REIHE_mon *zeigmon_s; int erg; if ((r == NULL) && (s==NULL)) return 0L; if ((r == NULL) && (s!=NULL)) return 1L; if ((r != NULL) && (s==NULL)) return -1L; zeigpoly_r=r->infozeig; zeigpoly_s=s->infozeig; do { if (zeigpoly_s == NULL) return -1L; if (zeigpoly_r == NULL) return 1L; if ((zeigpoly_s->unten!=NULL) && (zeigpoly_r->unten!=NULL) ) /* weil p mit Grad 0 initial. wurde, */ { /* aber Konst. nicht unbedingt exist. */ zeigmon_s=zeigpoly_s->unten; zeigmon_r=zeigpoly_r->unten; do { if (zeigmon_s == NULL) return -1L; if (zeigmon_r == NULL) return 1L; erg = monomvergleich(zeigmon_s, zeigmon_r); if (erg != 0) return (INT) erg; zeigmon_s=zeigmon_s->ref; zeigmon_r=zeigmon_r->ref; } while ((zeigmon_s!=NULL)||(zeigmon_r!=NULL)); } zeigpoly_s=zeigpoly_s->rechts; zeigpoly_r=zeigpoly_r->rechts; } while ( (zeigpoly_s!=NULL) || (zeigpoly_r!=NULL) ) ; return 0L; } static int ableitung_reihe(a,n,c,anzahl) REIHE_zeiger a,c; INT n,anzahl; { struct REIHE_poly *zeigpoly; struct REIHE_mon *zeigmon, *hmon; struct REIHE_variablen *zeigvar,*hvar1,*hvar2; OP e; int gefunden; if (c->ope=='#') c->ope='l'; c->reihenart=0L; if ((c->x==NULL) && (c->z==0)) { c->x=a; c->z=n; } else if ((c->x!=a) || (c->z!=n)) { printf("Falsche Operanden beim Transformieren!"); exit(3); } if (a->existexist+anzahl+1) ergaenze_reihe(&a,c->exist+anzahl+n-a->exist); /* Ableitung erniedrigt Grad des Monoms um n */ if (a!=NULL) { zeigpoly=a->infozeig; if (c->exist!=0) while ((zeigpoly->grad<=c->exist+n) && (zeigpoly->rechts!=NULL)) zeigpoly=zeigpoly->rechts; while ((zeigpoly!=NULL) && (zeigpoly->grad<=c->exist+anzahl+n)) { if (zeigpoly->unten!=NULL) /* weil p mit Grad 0 initial. wurde, */ { /* aber Konst. nicht unbedingt exist. */ zeigmon=zeigpoly->unten; do { gefunden=0; if (zeigmon->zeiger!=NULL) /* fuer Grad 0 ex. keine Monome */ { zeigvar=zeigmon->zeiger; do /* Pruefen, ob Variable im Monom enthalten ist */ { if ((zeigvar->index*1L==n) && (zeigvar->potenz>0)) gefunden=1; zeigvar=zeigvar->weiter; } while ((zeigvar!=NULL) && (gefunden==0)); if (gefunden==1) { hmon=new_zwei(); hmon->zeiger=NULL; hmon->ref=NULL; hmon->coeff=callocobject(); copy(zeigmon->coeff,hmon->coeff); zeigvar=zeigmon->zeiger; do { if (((zeigvar->index*1L==n) && (zeigvar->potenz>1)) || (zeigvar->index!=n)) { /* code folded from here */ hvar1=new_drei(); hvar1->weiter=NULL; if (zeigvar->index==n) { e=callocobject(); m_i_i(zeigvar->potenz*1L,e); mult(hmon->coeff,e,hmon->coeff); freeall(e); hvar1->potenz=zeigvar->potenz-1; hvar1->index=zeigvar->index; } else { hvar1->index=zeigvar->index; hvar1->potenz=zeigvar->potenz; } if (hmon->zeiger==NULL) hmon->zeiger=hvar1; else hvar2->weiter=hvar1; hvar2=hvar1; /* unfolding */ } zeigvar=zeigvar->weiter; } while (zeigvar!=NULL); einfuegen_in_reihe(hmon,c); } } zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } } c->exist+=anzahl; } static INT monomausgabe(f, m) struct REIHE_mon* m; FILE *f; { struct REIHE_variablen *zeigvar; INT erg = OK; if (not(nullp(m->coeff))) { fprintf(f, " "); if (f == stdout) zeilenposition++; /* AK 040893 */ erg += fprint(f, m->coeff); if (m->zeiger!=NULL) /* fuer Grad 0 ex. keine Monome */ { zeigvar=m->zeiger; do { if (zeigvar->potenz>0L) fprintf(f," X%ld^%ld",zeigvar->index,zeigvar->potenz); if (f == stdout) zeilenposition+=5L; /* AK 040893 */ zeigvar=zeigvar->weiter; if ((f == stdout) && (zeilenposition > 70L)) /* AK 040893 */ { zeilenposition = 0L; fprintf(f,"\n"); } } while (zeigvar!=NULL); } fprintf(f," +"); if (f == stdout) zeilenposition += 2L; } return erg; } static int copyy_monom(m1,m2) struct REIHE_mon* m1, **m2; { struct REIHE_variablen *zvar_eins,*zvar2,*help; *m2=new_zwei(); (*m2)->coeff=callocobject(); (*m2)->ref=NULL; (*m2)->zeiger=NULL; copy(m1->coeff,(*m2)->coeff); if (m1->zeiger!=NULL) { zvar_eins=m1->zeiger; do { help=new_drei(); help->weiter=NULL; help->index=zvar_eins->index; help->potenz=zvar_eins->potenz; if ((*m2)->zeiger==NULL) (*m2)->zeiger=help; else zvar2->weiter=help; zvar2=help; zvar_eins=zvar_eins->weiter; } while (zvar_eins!=NULL); } } static INT monommult(m1,m2,m3) struct REIHE_mon* m1,*m2, **m3; { int i,p,v; INT erg = OK; struct REIHE_variablen *help,*zeigvar1, *zeigvar2, *kopie; struct REIHE_mon *helpmon; if (monomgrad(m1)coeff,m2->coeff,(*m3)->coeff); zeigvar1=m2->zeiger; if (zeigvar1!=NULL) /* also nicht nur absolutes Glied */ { while (zeigvar1!=NULL) { i=zeigvar1->index; p=zeigvar1->potenz; if ((*m3)->zeiger == NULL) /* AK 040893 */ { zeigvar2=(*m3)->zeiger; kopie=new_drei(); kopie->index=i; kopie->potenz=p; kopie->weiter=NULL; (*m3)->zeiger=kopie; (*m3)->zeiger->weiter=zeigvar2; } else if (i<(*m3)->zeiger->index) /* ganz vorn als erstes */ { zeigvar2=(*m3)->zeiger; kopie=new_drei(); kopie->index=i; kopie->potenz=p; kopie->weiter=NULL; (*m3)->zeiger=kopie; (*m3)->zeiger->weiter=zeigvar2; } else { zeigvar2=(*m3)->zeiger; if (zeigvar2 == NULL) return error("internal error:RH9"); while ( (v=variablenvergleich(zeigvar1,zeigvar2->weiter)) <=0) zeigvar2=zeigvar2->weiter; if (variablenvergleich(zeigvar1,zeigvar2)==0) zeigvar2->potenz=zeigvar2->potenz+zeigvar1->potenz; else { kopie=new_drei(); kopie->index=i; kopie->potenz=p; kopie->weiter=NULL; switch(v) { case 1: help=zeigvar2->weiter; zeigvar2->weiter=kopie; kopie->weiter=help; break; case 2: zeigvar2->weiter=kopie; break; } } } zeigvar1=zeigvar1->weiter; } } #ifdef DEBUGRH7 printf("m1:");monomausgabe(stdout,m1);printf("\n"); printf("m2:");monomausgabe(stdout,m2);printf("\n"); printf("m3:");monomausgabe(stdout,*m3);printf("\n"); zeilenposition = 0L; #endif /* DEBUGRH7 */ #undef DEBUGRH7 return erg; } static INT monom_zu_symmonom(m,c) struct REIHE_mon* m; OP c; { struct REIHE_variablen *zeigvar; OP a,b,e,f; INT g; INT i; INT erg = OK; e=callocobject(); erg += m_iindex_iexponent_monom(0L,0L,e); if (m->zeiger!=NULL) /* fuer Grad 0 ex. keine Monome */ { zeigvar=m->zeiger; do { if (zeigvar->potenz>0) { a=callocobject(); erg += m_iindex_iexponent_monom( (zeigvar->index)*1L,(zeigvar->potenz)*1L,a); erg += mult_apply(a,e); erg += freeall(a); } zeigvar=zeigvar->weiter; } while (zeigvar!=NULL); } /* erg += mult(m->coeff,e,c); */ erg += mult_scalar_polynom(m->coeff,e,c); erg += freeall(e); return erg; } INT t_REIHE_POLYNOM(a,b) OP a,b; /* AK 150393 */ { INT erg = OK; if (check_equal_2(a,b,t_REIHE_POLYNOM,&erg) == EQUAL) goto tre; erg += reihe_zu_sympolynom(S_O_S(a).ob_reihe,b); tre: if (erg != OK) EDC("t_REIHE_POLYNOM"); return erg; } INT is_scalar_reihe(c) OP c; { return co_REIHE(c,is_scalar_polynom); } INT nullp_reihe(a) OP a; { return co_REIHE(a,nullp); } INT einsp_reihe(a) OP a; { return co_REIHE(a,einsp); } static INT co_REIHE(a,f) OP a; INT (*f)(); /* AK 280793 */ { OP b; INT erg; b = callocobject(); t_REIHE_POLYNOM(a,b); erg = (*f)(b); freeall(b); return erg; } static INT poly_zu_sympolynom(a,c) struct REIHE_poly *a; OP c; /* AK 040893 */ { struct REIHE_poly *zeigpoly; struct REIHE_mon *zeigmon; INT erg = OK; OP h; init(POLYNOM,c); h=callocobject(); zeigpoly=a; if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; do { if (not(nullp(zeigmon->coeff))) { erg += monom_zu_symmonom(zeigmon,h); erg += add_apply(h,c); } zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } erg += freeall(h); /* AK 131093 */ return erg; } static INT reihe_zu_sympolynom(a,c) REIHE_zeiger a; OP c; { INT erg = OK; struct REIHE_poly *zeigpoly; struct REIHE_mon *zeigmon; struct REIHE_variablen *zeigvar; OP h; if ((OP)a == c) return ERROR; h=callocobject(); erg += init(POLYNOM,c); if (a!=NULL) { zeigpoly=a->infozeig; do { erg += poly_zu_sympolynom(zeigpoly,h); erg += add_apply(h,c); zeigpoly=zeigpoly->rechts; } while (zeigpoly!=NULL); } erg += freeall(h); return erg; } INT add_apply_reihe(a,b) OP a,b; /* AK 020893 */ { OP c; INT erg = OK; if (S_O_K(a) != REIHE) return WTO("add_apply_reihe",a); c = callocobject(); *c = *b; C_O_K(b,EMPTY); erg += add(c,a,b); erg += freeall(c); aar_ende: if (erg != OK) EDC("add_apply_reihe"); return erg; } INT freeself_reihe(a) OP a; /* AK 100393 */ { INT erg = OK; CTO(REIHE,"freeself_reihe(1)",a); del_reihe(& (S_O_S(a).ob_reihe) ); C_O_K(a,EMPTY); ENDR("freeself_reihe"); } static int del_reihe(a) REIHE_zeiger *a; /* AK 110393 */ { if (*a != NULL) { del_reihe(& (*a)->x); del_reihe(& (*a)->y); del_reihe(& (*a)->p); del_poly( & (*a)->infozeig); free_null((char*)*a); *a = NULL; } } INT copy_reihe(a,b) OP a,b; /* AK 100393 */ { copy_rh( (S_O_S(a)).ob_reihe,& S_O_S(b).ob_reihe); C_O_K(b,REIHE); return OK; } static JH_copy_reihe(a,c) REIHE_zeiger a; REIHE_zeiger* c; { return JH_copy_reihe_co(a,c,1); } static AK_copy_reihe(a,c) REIHE_zeiger a; REIHE_zeiger* c; { return JH_copy_reihe_co(a,c,0); } static JH_copy_reihe_co(a,c,i) REIHE_zeiger a; REIHE_zeiger* c; int i; /* JH 0293 */ { struct REIHE_mon *zeigmon,*hmon; struct REIHE_poly *zeigpoly; del_reihe(c); initial_reihe(c); (*c)->exist=a->exist; if (i==1) (*c)->x=a->x; if (i==0) AK_copy_reihe(a->x, & ((*c)->x) ); if (i==1) (*c)->y=a->y; if (i==0) AK_copy_reihe(a->y, & ((*c)->y) ); (*c)->z=a->z; (*c)->ope=a->ope; (*c)->reihenart=a->reihenart; if (i==1) (*c)->p=a->p; if (i==0) AK_copy_reihe(a->p, & ((*c)->p) ); (*c)->eingabefkt=a->eingabefkt; if(i==1) { if (a!=NULL) /* dann ist auch a->infozeig!=NULL wegen initial */ { zeigpoly=a->infozeig; do { if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; do { copyy_monom(zeigmon,&hmon); einfuegen_in_reihe(hmon,*c); zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } while (zeigpoly!=NULL); } } if (i==0) { if (a == NULL) if(a->infozeig == NULL) error("JH_copy_reihe_co:(1)"); copy_poly(a->infozeig, & (*c)->infozeig); } } static int pot_reihe(a,n,c,anzahl) REIHE_zeiger a,c; INT n, anzahl; { struct reihe *help; struct REIHE_poly *zeigpoly; struct REIHE_mon *hmon,*zeigmon; int zaehler; if (c->ope=='#') c->ope='p'; c->reihenart=0L; if ((c->x==NULL) && (c->z==0)) { c->x=a; c->z=n; } /* fuer 1.Aufruf */ else if ((c->x!=a) || (c->z!=n)) { printf("Falsche Operanden beim Potenzieren!\n"); exit(3); } if (a->existexist+anzahl) ergaenze_reihe(&a,c->exist+anzahl-a->exist); help=a; /* help zeigt jetzt auch auf a */ zaehler=1; while ((help->p!=NULL) && (zaehler!=n)) { help=help->p; zaehler=zaehler+1; } if (zaehler==n) { if (help->existexist+anzahl) ergaenze_reihe(&help,c->exist+anzahl-help->exist); } else { do { initial_reihe(&(help->p)); zaehler=zaehler+1; help->p->reihenart=0L; help->p->ope='m'; help->p->x=a; help->p->y=help; JH_mult_reihe(a,help,help->p,c->exist+anzahl); help=help->p; } while (zaehlerinfozeig!=NULL wegen initial */ { zeigpoly=help->infozeig; if (c->exist!=0) while ((zeigpoly->grad<=c->exist) && (zeigpoly->rechts!=NULL)) zeigpoly=zeigpoly->rechts; while ((zeigpoly!=NULL) && (zeigpoly->grad<=c->exist+anzahl)) { if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; do { copyy_monom(zeigmon,&hmon); einfuegen_in_reihe(hmon,c); zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } } c->exist+=anzahl; } INT mult_reihe(a,b,c) OP a,b,c; /* AK 100393 */ { INT erg = OK; switch(S_O_K(b)) { case BRUCH: case INTEGER: case LONGINT: { OP d; d = callocobject(); erg += m_scalar_reihe(b,d); erg += mult_reihe(a,d,c); erg += freeall(d); break; } case REIHE: { OBJECTSELF as,bs,cs; OP d,e,f,g; d = callocobject(); e = callocobject(); g = callocobject(); f = callocobject(); erg += max_degree_reihe(a,d); erg += max_degree_reihe(b,e); if (lt(e,d)) copy(d,e); erg += copy(a,f); erg += copy(b,g); erg += init(REIHE,c); as = S_O_S(f); bs = S_O_S(g); cs = S_O_S(c); erg += JH_mult_reihe(as.ob_reihe,bs.ob_reihe,cs.ob_reihe,S_I_I(e)); erg += freeall(d); erg += freeall(e); C_O_K(f,EMPTY); C_O_K(g,EMPTY); erg += freeall(f); erg += freeall(g); break; } default: return WTT("mult_reihe",a,b); } if (erg != OK) EDC("mult_reihe"); return erg; } static INT JH_mult_reihe(a,b,c,anzahl) REIHE_zeiger a,b,c; INT anzahl; { struct REIHE_poly *zeigpoly1,*zeigpoly2; struct REIHE_mon *zeigmon1, *zeigmon2, *hmon; if (c->ope=='#') c->ope='m'; c->reihenart=0L; if ((c->x==NULL) && (c->y==NULL)) { c->x=a; c->y=b; } else if (((c->x!=a) || (c->y!=b)) && ((c->x!=b) || (c->y!=a))) { return error("RH-internal error"); } if (a->existexist+anzahl) ergaenze_reihe(&a,c->exist+anzahl-a->exist); if (b->existexist+anzahl) ergaenze_reihe(&b,c->exist+anzahl-b->exist); if (a!=NULL) /* dann ist auch a->infozeig!=NULL wegen initial */ { zeigpoly1=a->infozeig; while ((zeigpoly1!=NULL) && (zeigpoly1->grad<=c->exist+anzahl)) { if (zeigpoly1->unten!=NULL) { zeigmon1=zeigpoly1->unten; do { if (b!=NULL) /* dann ist auch b->infozeig!=NULL wegen initial */ { zeigpoly2=b->infozeig; if (c->exist!=0) while ((zeigpoly2->grad<=c->exist-zeigpoly1->grad) && (zeigpoly2->rechts!=NULL)) zeigpoly2=zeigpoly2->rechts; if (((zeigpoly2->grad+zeigpoly1->grad>c->exist) && (zeigpoly2->grad+zeigpoly1->grad<=c->exist+anzahl)) || (c->exist==0)) /* richtiger Grad ist erreicht */ do { if (zeigpoly2->unten!=NULL) { zeigmon2=zeigpoly2->unten; do { monommult(zeigmon1,zeigmon2,&hmon); einfuegen_in_reihe(hmon,c); zeigmon2=zeigmon2->ref; } while (zeigmon2!=NULL); } zeigpoly2=zeigpoly2->rechts; } /* do */ while ((zeigpoly2!=NULL) && (zeigpoly2->grad<=c->exist+anzahl-zeigpoly1->grad)); /* hier endet das if vor dem do */ } zeigmon1=zeigmon1->ref; } while (zeigmon1!=NULL); } zeigpoly1=zeigpoly1->rechts; } } c->exist+=anzahl; return OK; } static int trans_reihe_in_monom(a,m,b,anzahl) REIHE_zeiger a,*b; struct REIHE_mon *m; INT anzahl; { REIHE_zeiger help_eins,help_zwei,help_drei; struct REIHE_variablen *zeigvar; del_reihe(b); initial_reihe(&help_eins); help_eins->exist=1; help_eins->reihenart=1L; help_eins->infozeig->unten=new_zwei(); help_eins->infozeig->unten->ref=NULL; help_eins->infozeig->unten->zeiger=NULL; help_eins->infozeig->unten->coeff=callocobject(); m_i_i(1L,help_eins->infozeig->unten->coeff); if (m->zeiger!=NULL) /* wegen abs. Glied */ { zeigvar=m->zeiger; do { initial_reihe(&help_zwei); pot_reihe(a,zeigvar->potenz,help_zwei,anzahl); help_zwei->reihenart=1L; initial_reihe(&help_drei); transform_reihe(help_zwei,zeigvar->index,help_drei,anzahl); help_drei->reihenart=1L; del_reihe(&help_zwei); initial_reihe(&help_zwei); JH_mult_reihe(help_eins,help_drei,help_zwei,anzahl); help_zwei->reihenart=1L; del_reihe(&help_eins); del_reihe(&help_drei); help_eins=help_zwei; help_zwei=NULL; zeigvar=zeigvar->weiter; } while (zeigvar!=NULL); } initial_reihe(&help_zwei); /* Realisation der Skalarmult. mit coeff */ help_zwei->exist=1; help_zwei->reihenart=1L; help_zwei->infozeig->unten=new_zwei(); help_zwei->infozeig->unten->ref=NULL; help_zwei->infozeig->unten->zeiger=NULL; help_zwei->infozeig->unten->coeff=callocobject(); copy(m->coeff,help_zwei->infozeig->unten->coeff); initial_reihe(&help_drei); JH_mult_reihe(help_eins,help_zwei,help_drei,anzahl); help_drei->reihenart=1L; del_reihe(&help_eins); del_reihe(&help_zwei); *b=help_drei; } static int subst_reihe(a,b,c,anzahl) REIHE_zeiger a,b,* c; INT anzahl ; { struct REIHE_poly *zeigpoly; REIHE_zeiger help_eins,help_zwei,help_drei,help4; struct REIHE_mon *zeigmon; int m; /* a Basisreihe b einzusetzende Reihe c Ergebinsreihe */ if (((*c)->x==NULL) && ((*c)->y==NULL)) { (*c)->x=a; (*c)->y=b; } else if ((((*c)->x!=a) || ((*c)->y!=b)) && (((*c)->x!=b) || ((*c)->y!=a))) { printf("Falsche Operanden bei der Substitution!"); exit(3); } normalisiere_reihe(b); del_reihe(c); if (a->existexist); if (b->existexist); initial_reihe(&help4); /* help4 enthaelt immer das ergebnis */ help4->reihenart=1L; /* wird somit zum Skalar = 0 */ if (a!=NULL) { zeigpoly=a->infozeig; do { if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; do { initial_reihe(&help_eins); trans_reihe_in_monom(b,zeigmon,&help_eins,anzahl); help_eins->reihenart=1L; initial_reihe(&help_zwei); JH_add_reihe(help_eins,help4,help_zwei,anzahl); help_zwei->reihenart=1L; del_reihe(&help_eins); del_reihe(&help4); help4=help_zwei; help_zwei=NULL; zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } while (zeigpoly!=NULL); } /* initial_reihe(c); Zeiger nur umhaengen */ *c=help4; (*c)->x=a; (*c)->y=b; /* und noch die alten infos uebertragen */ (*c)->reihenart=0L; (*c)->exist=anzahl; (*c)->ope='s'; } INT add_reihe(a,b,c) OP a,b,c; /* AK 100393 */ { INT erg = OK; switch(S_O_K(b)) { case REIHE: { OBJECTSELF as,bs,cs; OP d,e,f,g; d = callocobject(); e = callocobject(); f = callocobject(); g = callocobject(); copy(a,f); copy(b,g); erg += max_degree_reihe(f,d); erg += max_degree_reihe(g,e); if (lt(e,d)) copy(d,e); erg += init(REIHE,c); as = S_O_S(f); bs = S_O_S(g); cs = S_O_S(c); erg += JH_add_reihe(as.ob_reihe,bs.ob_reihe,cs.ob_reihe,S_I_I(e)); erg += freeall(d); erg += freeall(e); C_O_K(f,EMPTY); C_O_K(g,EMPTY); erg += freeall(f); erg += freeall(g); break; } case INTEGER: case BRUCH: case LONGINT: /* AK 020893 */ { OP d; d = callocobject(); erg += m_scalar_reihe(b,d); erg += add_reihe(a,d,c); erg += freeall(d); break; } default: return WTT("add_reihe",a,b); } ENDR("add_reihe"); } static INT JH_add_reihe(a,b,c,anzahl) REIHE_zeiger a,b,c; INT anzahl; /* JH 0293 */ { struct REIHE_mon *zeigmon,*hmon; struct REIHE_poly *zeigpoly; if (c->ope=='#') c->ope='a'; c->reihenart=0L; if ((c->x==NULL) && (c->y==NULL)) { c->x=a; c->y=b; } else if (((c->x!=a) || (c->y!=b)) && ((c->x!=b) || (c->y!=a))) { printf("Falsche Operanden bei der Addition!"); exit(3); } if (a->existexist+anzahl) ergaenze_reihe(&a,c->exist+anzahl-a->exist); if (b->existexist+anzahl) ergaenze_reihe(&b,c->exist+anzahl-b->exist); if (a!=NULL) /* dann ist auch a->infozeig!=NULL wegen initial */ { zeigpoly=a->infozeig; if (c->exist!=0) while ((zeigpoly->grad<=c->exist) && (zeigpoly->rechts!=NULL)) zeigpoly=zeigpoly->rechts; while ((zeigpoly!=NULL) && (zeigpoly->grad<=c->exist+anzahl)) { if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; do { copyy_monom(zeigmon,&hmon); einfuegen_in_reihe(hmon,c); zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } } if (b!=NULL) { zeigpoly=b->infozeig; if (c->exist!=0) while ((zeigpoly->grad<=c->exist) && (zeigpoly->rechts!=NULL)) zeigpoly=zeigpoly->rechts; while ((zeigpoly!=NULL) && (zeigpoly->grad<=c->exist+anzahl)) { if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; do { copyy_monom(zeigmon,&hmon); einfuegen_in_reihe(hmon,c); zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } } c->exist+=anzahl; return OK; } static int transform_reihe(a,n,c,anzahl) REIHE_zeiger a,c; INT n,anzahl; { struct REIHE_poly *zeigpoly; struct REIHE_mon* zeigmon, *hmon; struct REIHE_variablen *zeigvar; if (c->ope=='#') c->ope='t'; c->reihenart=0L; if ((c->x==NULL) && (c->z==0)) { c->x=a; c->z=n; } else if ((c->x!=a) || (c->z!=n)) { return error("internal error:RH8"); } if (a->existexist+anzahl) ergaenze_reihe(&a,c->exist+anzahl-a->exist); if (a!=NULL) /* dann ist auch a->infozeig!=NULL wegen initial */ { zeigpoly=a->infozeig; if (c->exist!=0) while ((zeigpoly->grad<=c->exist) && (zeigpoly->rechts!=NULL)) zeigpoly=zeigpoly->rechts; while ((zeigpoly!=NULL) && (zeigpoly->grad<=c->exist+anzahl)) { if (zeigpoly->unten!=NULL) { zeigmon=zeigpoly->unten; do { copyy_monom(zeigmon,&hmon); if (hmon->zeiger!=NULL) { zeigvar=hmon->zeiger; do { zeigvar->index*=n; zeigvar=zeigvar->weiter; } while (zeigvar!=NULL); } einfuegen_in_reihe(hmon,c); zeigmon=zeigmon->ref; } while (zeigmon!=NULL); } zeigpoly=zeigpoly->rechts; } } c->exist+=anzahl; } INT m_perm_reihe(a) OP a; /* AK 100393 */ { INT erg = OK; erg += freeself(a); erg += make_reihe(& (S_O_S(a)).ob_reihe,Perm_eingabe); erg += ergaenze_reihe(& (S_O_S(a)).ob_reihe,5L); C_O_K(a,REIHE); ENDR("m_perm_reihe"); } INT m_cosinus_reihe(a) OP a; /* AK 100393 */ { INT erg = OK; erg += freeself(a); erg += make_reihe(& (S_O_S(a)).ob_reihe,Cosinus_eingabe); erg += ergaenze_reihe(& (S_O_S(a)).ob_reihe,5L); C_O_K(a,REIHE); ENDR("m_cosinus_reihe"); } INT random_reihe(a) OP a; /* AK 030893 */ { INT erg = OK; if (not EMPTYP(a)) erg += freeself(a); erg += make_reihe(& (S_O_S(a)).ob_reihe,Random_eingabe); erg += ergaenze_reihe(& (S_O_S(a)).ob_reihe,5L); C_O_K(a,REIHE); ENDR("random_reihe"); } INT m_eins_reihe(a) OP a; /* AK 100393 */ { if (not EMPTYP(a)) freeself(a); make_reihe(& (S_O_S(a)).ob_reihe,Eins_eingabe); ergaenze_reihe(& (S_O_S(a)).ob_reihe,5L); C_O_K(a,REIHE); return OK; } INT m_sinus_reihe(a) OP a; /* AK 100393 */ { INT erg = OK; if (not EMPTYP(a)) erg += freeself(a); erg += make_reihe(& (S_O_S(a)).ob_reihe,Sinus_eingabe); erg += ergaenze_reihe(& (S_O_S(a)).ob_reihe,5L); C_O_K(a,REIHE); ENDR("m_sinus_reihe"); } jh_ausgabe_vorbereiten(f, a, r) REIHE_zeiger* a; FILE *f; REIHE_zeiger r[]; /* JH 0293 */ { int art,x,y,z; char operat,was; if (*a==NULL) { printf("Es existiert noch keine Reihe.\n"); printf("Permutation.........1\n"); printf("EMenge..............2\n"); printf("Exponentialreihe....3\n"); printf("Skalar..............4\n"); printf("Sinus...............5\n"); printf("Cosinus.............6\n"); printf("Verknuepfungen......0\n"); printf("Uebergehen.........-1\n"); printf("\nAuswahl:"); do scanf("%i",&art); while ((art<-2) || (art>6)); if (art!=-1) { if (art>0) { switch(art) { case 1: make_reihe(a,Perm_eingabe); break; case 2: make_reihe(a,E_eingabe); break; case 3: make_reihe(a,Exp_eingabe); break; case 4: make_skalar_reihe(a); break; case 5: make_reihe(a,Sinus_eingabe); break; case 6: make_reihe(a,Cosinus_eingabe); break; } ergaenze_reihe(a,zuwachs); } else /* Verknuepfungen */ { initial_reihe(a); printf("\nAddition.............a\n"); printf("Multiplikation.......m\n"); printf("Potenzieren..........p\n"); printf("Ableitung............l\n"); printf("Transformieren.......t\n"); printf("Substitution.........s\n"); printf("\nOperation:"); do operat=getchar(); while(operat!='a' && operat!='m' && operat!='s' && operat!='p' && operat!='t' && operat!='l'); switch(operat) { case 'a': printf("\n1.Summand:"); scanf("%i",&x); printf("\n2.Summand:"); scanf("%i",&y); JH_add_reihe(r[x],r[y],*a,zuwachs); break; case 'm': printf("\n1.Faktor:"); scanf("%i",&x); printf("\n2.Faktor:"); scanf("%i",&y); JH_mult_reihe(r[x],r[y],*a,zuwachs); break; case 'p': printf("\nBasisreihe :"); scanf("%i",&x); printf("\nPotenz :"); scanf("%i",&z); pot_reihe(r[x],z,*a,zuwachs); break; case 'l': printf("\nBasisreihe :"); scanf("%i",&x); printf("\nAbleitung nach Variable:"); scanf("%i",&z); ableitung_reihe(r[x],z,*a,zuwachs); break; case 't': printf("\nReihe :"); scanf("%i",&x); printf("\nTransformation:"); scanf("%i",&z); transform_reihe(r[x],z,*a,zuwachs); break; case 's': printf("\n1.Reihe, in die eingesetzt wird:"); scanf("%i",&x); printf("\n2.Reihe, die eingesetzt wird :"); scanf("%i",&y); subst_reihe(r[x],r[y],a,zuwachs); break; } /* switch */ } /* else */ } /* if art.. */ ausgabe(f, *a); } /* if */ else /* Reihe ist schon definiert */ { if ((*a)->ope!='#') printf(" Operator:%c, \n",(*a)->ope); /* ursprung angeben */ else printf("\n"); printf("Ausgabe + Zuwachs...a "); printf("Loeschen............l "); printf("Ausgabe.............A\n"); printf("Normalisieren.......n "); printf("Symmetrica-Polynom..s "); printf("Cardinalitaet.......c\n"); printf("Typ-Cardinalitaet...t\n"); printf("\nAuswahl:"); do was=getchar(); while(was!='a' && was!='l' && was!='s' && was!='A' && was!='c' && was!='t' && was!='n'); if (was=='a') { ergaenze_reihe(a,zuwachs); ausgabe(f, *a); } if (was=='l') del_reihe(a); if (was=='c') card_reihe(*a); if (was=='t') card_typ_reihe(*a); if (was=='n') normalisiere_reihe(*a); if (was=='A') ausgabe(f, *a); if (was=='s'){ OP symd; symd = callocobject(); reihe_zu_sympolynom(*a,symd); fprintln(f, symd); freeall(symd); } } } INT debugprint_reihe(a) OP a; { debugprint_rh(S_O_S(a).ob_reihe); return OK; } static int debugprint_rh(a) REIHE_zeiger a; { INT i; for (i=0L;iexist); for (i=0L;ireihenart); for (i=0L;iz); for (i=0L;ix); doffset -= 2L; for (i=0L;iy); doffset -= 2L; for (i=0L;ip); doffset -= 2L; for (i=0L;iope); for (i=0L;iinfozeig); doffset -= 2L; } static int debugprint_rh_poly(a) struct REIHE_poly *a; { INT i; for (i=0L;igrad); for (i=0L;iunten); doffset -= 2L; for (i=0L;irechts); doffset -= 2L; } static int debugprint_rh_mon(a) struct REIHE_mon *a; { INT i; for (i=0L;icoeff); doffset -= 2L; for (i=0L;izeiger); doffset -= 2L; for (i=0L;iref); doffset -= 2L; } static int debugprint_rh_var(a) struct REIHE_variablen *a; { INT i; extern INT doffset; for (i=0L;iindex); for (i=0L;ipotenz); for (i=0L;iweiter); doffset -= 2L; } INT addinvers_reihe(a,b) OP a,b; /* AK 020893 */ { OP c; INT erg = OK; c = callocobject(); erg += m_scalar_reihe(cons_negeins,c); erg += mult(a,c,b); erg += freeall(c); if (erg != OK) EDC("addinvers_reihe"); return erg; } INT mult_apply_reihe(a,b) OP a,b; /* AK 150393 */ { OP c; INT erg = OK; c = callocobject(); erg += copy(b,c); erg += mult(a,c,b); erg += freeall(c); if (erg != OK) EDC("mult_apply_reihe"); return erg; } static INT Eins_eingabe(root, anzahl) REIHE_zeiger root; INT anzahl; { return co_eingabe (root, anzahl, 1L); } static INT Random_eingabe(root, anzahl) REIHE_zeiger root; INT anzahl; { return co_eingabe (root, anzahl, 2L); } static INT co_eingabe(root, anzahl, para ) REIHE_zeiger root; INT anzahl,para; /* AK 300793 */ { INT i,j,l,k; INT erg = OK; struct REIHE_mon *zeigmon; struct REIHE_variablen *zeigvar,*help_drei; /* b=callocobject(); d=callocobject(); f=callocobject(); */ if (root->exist==0) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->zeiger=NULL; zeigmon->ref=NULL; switch(para) { case 1: erg += M_I_I(1L,zeigmon->coeff); break; case 2: erg += random_integer(zeigmon->coeff,NULL,NULL); break; default: error("internal error:RH3"); } erg += einfuegen_in_reihe(zeigmon,root); } for (l=root->exist+1L;l<=root->exist+anzahl;l++) { zeigmon=new_zwei(); zeigmon->coeff=callocobject(); zeigmon->ref=NULL; switch(para) { case 1: erg += M_I_I(1L,zeigmon->coeff); break; case 2: erg += random_integer(zeigmon->coeff,NULL,NULL); break; default: error("internal error:RH4"); } help_drei=new_drei(); help_drei->weiter=NULL; zeigmon->zeiger=help_drei; zeigvar=help_drei; zeigvar->index=0; zeigvar->potenz=l; erg += einfuegen_in_reihe(zeigmon,root); } root->exist+=anzahl; /* erhoehen um anzahl */ /* erg += freeall(b); erg += freeall(d); erg += freeall(f); */ if (erg != OK) error("internal error:RH5"); return erg; } static INT t_MONOM_REIHE_mon(a,b) OP a;struct REIHE_mon *b; { INT i; struct REIHE_variablen *c; b->coeff = callocobject(); copy(S_MO_K(a),b->coeff); c = b->zeiger; /* fuer variablen */ for (i=0L;izeiger == NULL) { b->zeiger = new_var(); c = b->zeiger; } else { c->weiter = new_var(); c = c->weiter; } } c->index = i; c->potenz = s_i_i(S_MO_SI(a,i)); } return OK; } INT select_degree_reihe(a,b,c) OP a,b,c; /* AK 030893 */ { struct REIHE_poly *info; REIHE_zeiger z; OBJECTSELF d; INT erg = OK; if (S_O_K(a) != REIHE) { erg += WTT("select_degree_reihe",a,b); goto sdr_ende; } if (S_O_K(b) != INTEGER) { erg += WTT("select_degree_reihe",a,b); goto sdr_ende; } if (S_I_I(b) < 0L) { erg += ERROR; goto sdr_ende; } init(POLYNOM,c); d = S_O_S(a); z = d.ob_reihe; info = z->infozeig; while (info != NULL) { if (S_I_I(b) == info->grad) { erg += poly_zu_sympolynom(info,c); goto sdr_ende; } info = info->rechts; } sdr_ende: if (erg != OK) EDC("select_degree_reihe"); return erg; } INT select_coeff_reihe(a,b,d) OP a,b,d; /* AK 020893 */ { OP c; INT erg = OK; if (S_O_K(b) != VECTOR) return ERROR; if (S_O_K(a) != REIHE) return ERROR; c = callocobject(); erg += t_REIHE_POLYNOM(a,c); erg += select_coeff_polynom(c,b,d); erg += freeall(c); return erg; } INT length_reihe(a,b) OP a,b; /* AK 251093 */ { OP c; INT erg = OK; c = callocobject(); erg += t_REIHE_POLYNOM(a,c); erg += length(c,b); erg += freeall(c); if (erg != OK) EDC("length_reihe"); return erg; } INT rh_test() { OP a,b,c,d,e,f,g,h,h2,x; INT i,j,i1,j1,l; FILE *fp1,*fp2; a=callocobject(); b=callocobject(); c=callocobject(); d=callocobject(); e=callocobject(); f=callocobject(); g=callocobject(); h=callocobject(); h2=callocobject(); m_sinus_reihe(a); copy(a,b); println(a); println(b); printf("%d\n",comp(a,b)); inc(a);inc(a); println(a); printf("%d\n",comp(a,b)); inc(b);inc(b); println(b); printf("%d\n",comp(a,b)); inc(b);inc(b); println(b); printf("%d\n",comp(a,b)); inc(a);inc(a); println(a); printf("%d\n",comp(a,b)); m_iindex_iexponent_monom(0L,3L,c); println(c); select_coeff_reihe(b,S_PO_S(c),d); println(d); max_degree_reihe(b,c); println(c); m_perm_reihe(b); max_degree_reihe(b,c); println(c); inc(b); inc(b); println(b); max_degree_reihe(b,c); println(c); m_eins_reihe(a); println(a); add(a,cons_eins,b); println(b); m_cosinus_reihe(a); add_apply(a,b); println(b); addinvers(b,c); println(c); add(b,c,a); println(a); if (not nullp(a)) error("not null"); random_reihe(a); println(a); random_reihe(b); println(b); add(a,b,c); m_perm_reihe(b); select_degree_reihe(b,cons_null,d); println(d); debugprint(d); select_degree_reihe(b,cons_eins,d); println(d); m_i_i(5L,a); select_degree_reihe(b,a,d); println(d); freeall(a); freeall(b); freeall(c); freeall(d); freeall(e); freeall(f);freeall(g);freeall(h);freeall(h2); } #endif /* REIHETRUE */ #ifdef REIHETRUE INT scan_reihe(a) OP a; /* AK 221093 */ { int i; INT erg = OK; printeingabe("input of REIHE object"); printeingabe("sinus[1] cosinus[2] identity[3]"); printeingabe("perm [4] random [5] "); scanf("%d",&i); switch(i) { case 1: erg += m_sinus_reihe(a); break; case 2: erg += m_cosinus_reihe(a); break; case 3: erg += m_eins_reihe(a); break; case 4: erg += m_perm_reihe(a); break; case 5: erg += random_reihe(a); break; default: erg += ERROR; } if (erg != OK) EDC("scan_reihe"); return erg; } #endif /* REIHETRUE */ symmetrica-2.0/rh.doc0000600017361200001450000000552510726170301014501 0ustar tabbottcrontabCOMMENT: /* rh.doc SYMMETRICA */ NAME: is_scalar_reihe SYNOPSIS: INT is_scalar_reihe(OP a) DESCRIPTION: checks wether a is a object of the kind REIHE with only constant term. NAME: max_degree_reihe SYNOPSIS: INT max_degree_reihe(OP a,b) DESCRIPTION: you enter a REIHE object a, and the output is the degree of maximal coefficent, which is computed up to now. NAME: m_function_reihe SYNOPSIS: INT m_function_reihe(INT (*f)(); OP a); DESCRIPTION: you enter a function f, which computes an coefficent of the series, which is specified by an paramter of the function. The result is a object a of type REIHE. The syntax of the function f is described now in detail: INT f(OP a,b) a is a INTEGER object which gives the common degree of the coefficents, which should be computed. The result b must be of the type POLYNOM object. This POLYNOM object is homogenous of the entered degree. EXAMPLE: the following routine computes the series sum over all partitions, entered in exponent notation #include "def.h" #include "macro.h" INT co_part(a,b) OP a,b; { if (S_I_I(a) == 0L) m_iindex_iexponent_monom(0L,0L,b); else { OP c = callocobject(); OP d; INT i; makevectorofpart(a,c); init(POLYNOM,b); for (i=0;i=0L && k != i && S_V_II(besucht,k) == 0L) { m_i_i(1L,S_V_I(besucht,k)); for(j=0L;j=0L;--i) m_il_v(S_PA_II(tpart,i), S_V_I(Tt,S_PA_LI(tpart)-1L-i)); invers(perm,p_inv); invers(perm,perm); m_il_v(S_V_LI(t),D); if(var == -1L) /* Gesamte Matrix berechnen */ { for(i=0;i= 0L) { for(j=0L;j (S_V_II(um,l-1L)))&& (S_V_II(um,l) > S_V_II(ziel,l))) { m_i_i(S_V_II(um,l)-1L,S_V_I(um,l)); _ins(S_V_I(tab,l),st); _kt(n,t,tab,um,ziel,ou,tou,l,i+1L,st,ct, beta,nr); _del(S_V_I(tab,l)); m_i_i(S_V_II(um,l)+1L,S_V_I(um,l)); } } return OK; } /***********************************************************************/ /* */ /* Routine: _ins */ /* Hilfsroutine bei der Tableauberechnung */ /* */ /***********************************************************************/ /* RH 011091 */ static INT _ins(line,z) OP line; INT z; { INT i; for(i=1L;i=1L;--i) if(S_V_II(line,i)!=0L) { m_i_i(0L,S_V_I(line,i)); break; } return OK; } /***********************************************************************/ /* */ /* Routine: _zuweisen */ /* Hilfsroutine bei der Tableauberechnung */ /* */ /***********************************************************************/ /* RH 011091 */ static INT zuweisen(t,tab,ou,ind) OP t; OP tab; OP ou; INT ind; { INT i; INT j; for(i=0;i= 2L) { copy(S_V_I(t,anf),mitte); ind = -1L; i = anf + 1L; while((i<=end)&&(ind == -1L)) { if((*_vgl)(mitte,S_V_I(t,i)) == -1L) ind = i; else { if((*_vgl)(mitte,S_V_I(t,i)) == 1L) ind = anf; else ++i; } if(ind > -1L) { l = anf; r = end; copy(S_V_I(t,ind),mitte); do { swap(S_V_I(t,l),S_V_I(t,r)); while((*_vgl)(S_V_I(t,l),mitte) == -1L) ++l; while((*_vgl)(S_V_I(t,r),mitte) >= 0L) --r; } while(l <= r); sortieren(anf,l-1L,t,_vgl); sortieren(l,end,t,_vgl); } } } freeall(mitte); /* AK 010692 */ return OK; } /***********************************************************************/ /* */ /* Routine: lex_vgl */ /* lexikographisch aufsteigender Vergleich zweier Operanden */ /* */ /***********************************************************************/ /* RH 011091 */ static INT lex_vgl(a,b) OP a; OP b; { INT i; INT j; for(i=0L;i S_V_II(S_V_I(b,i),j)) { return(1L); } if(S_V_II(S_V_I(a,i),j) < S_V_II(S_V_I(b,i),j)) { return(-1L); } } } return(0L); } /***********************************************************************/ /* */ /* Routine: createP */ /* Erstellen der Stuktur P aus Horizontalpermutationen */ /* nach dem depth-first-search-Verfahren */ /* */ /***********************************************************************/ /* RH 011091 */ static INT createP(P,n,part,t) /* Die Struktur P, bestehend aus Horizontalpermutationen wird gebildet. */ OP P; OP n; OP part; OP t; { OP HP; OP neu; OP v = callocobject(); OP tpart = callocobject(); INT i; INT j; m_il_v(S_V_LI(t),P); m_il_v(20L,v); conjugate(part,tpart); for(i=0L;i= 2L) return(1L); } } else return(0L); } return(0L); } /***********************************************************************/ /* */ /* Routine: Pcut_col_row */ /* Bildet den Schnitt einer Zeile und einer Spalte zweier Tabelaux. */ /* */ /***********************************************************************/ /* RH 011091 */ static INT Pcut_col_row(col,l_col,row) OP col; INT l_col; OP row; { static INT erg; static INT i; static INT j; static OP zi,zj; erg = 0L; for(i=0L,zi = S_V_S(col);i1L) return(erg); } return(erg); } /***********************************************************************/ /* */ /* Routine: ziffern_existieren (Variante mit transponiertem Tabl.) */ /* Prueft, ob in zwei Tableaux zwei Ziffern gemeinsam in einer */ /* Zeile und Spalte vorkommen */ /* */ /***********************************************************************/ /* RH 011091 */ static INT ziffern_existieren(Tt,t_j) OP Tt; OP t_j; { static INT i; static INT j; for(i=0L;i0L) { if(cut_col_row( S_V_I(Tt,i), S_V_I(t_j,j)) >= 2L) return(1L); } else return(0L); return(0L); } /***********************************************************************/ /* */ /* Routine: cut_col_row (Variante mit transponiertem Tabl.) */ /* Bildet den Schnitt einer Zeile und einer Spalte zweier Tabelaux. */ /* */ /***********************************************************************/ /* RH 011091 */ static INT cut_col_row(col,row) OP col; OP row; { static INT erg; static INT i; static INT j; static OP zi,zj; erg = 0L; for(i=0L,zi = S_V_S(col);i1L) return(erg); } return(erg); } /***********************************************************************/ /* */ /* Routine: get_H_perm */ /* Gibt die Horizontalpermutation zwischen zwei Tableaux zurueck. */ /* */ /***********************************************************************/ /* RH 011091 */ static INT get_H_perm(t_i,t_j,perm) OP t_i; OP t_j; OP perm; { INT i; INT j; INT sp; for(i=0L;i k) { sgn*= -1; invers(p_inv,p1); mult(p1,perm,perm); invers(S_V_I(S_V_I(HP,l),1L),p1); mult(p1,perm,perm); mult(p_inv,perm,perm); get_T(T,S_V_I(t,zeile),perm); transponiere(T,Tt); D_row_calc(T,t,sgn,D,S_P_LI(p_inv),Tt); D_calc(t,D,P,perm,p_inv,sgn,zeile, S_V_II(S_V_I(HP,l),0L), S_V_II(S_V_I(HP,l),0L)+1L,Tt); invers(p_inv,p1); mult(p1,perm,perm); mult(S_V_I(S_V_I(HP,l),1L),perm,perm); mult(p_inv,perm,perm); sgn*= -1; } } } } DC_ende: freeall(T); freeall(p1); return OK; } #endif /* PERMTRUE */ /***********************************************************************/ /***********************************************************************/ /* */ /* Programme zur Berechnung der seminormalen und der orthogonalen */ /* Matrixdarstellungen von S_n */ /* */ /* Written by: Ralf Hager September 1991 */ /* */ /***********************************************************************/ /***********************************************************************/ /***********************************************************************/ /* */ /* Routine: sdg */ /* Gibt zu gegebener Partition part und Permutation perm die */ /* zugehoerige seminormale irreduzible Matrixdarstellung in D zurueck. */ /* */ /***********************************************************************/ /* RH 011091 */ #ifdef DGTRUE INT sdg(part,perm,D) OP part,perm,D; { INT i; INT j; INT erg = OK; INT lls_vgl(); OP n,lehmer,HD,dim,t,inh; CTO(PARTITION,"sdg(1)",part); CTO(PERMUTATION,"sdg(2)",perm); n = callocobject(); lehmer = callocobject(); HD = callocobject(); dim = callocobject(); t = callocobject(); inh = callocobject(); erg += dimension(part,dim); erg += m_lh_nm(dim,dim,D); erg += m_lh_nm(dim,dim,HD); erg += m_i_i(S_P_LI(perm),n); erg += m_l_v(n,inh); for(i=0;i=0L;--j) { erg += _xdg(S_V_II(lehmer,j),t,HD,0L); MULT_APPLY(HD,D); } } else { for(i=0L;i=1L;--k) { for(i=0L;i merk_b) return(1L); } return(0L); } /***********************************************************************/ /* */ /* Routine: odg */ /* Gibt zu gegebener Partition part und Permutation perm die */ /* zugehoerige orthogonale irreduzible Matrixdarstellung in D zurueck. */ /* */ /***********************************************************************/ /* RH 011091 */ INT cyclo_odg(a,b,c) OP a,b,c; /* AK 110202 */ { INT erg = OK; OP d; INT i,j; d = CALLOCOBJECT(); erg += odg(a,b,d); m_lh_m(S_M_L(d),S_M_H(d),c); for(i=0;i=0L;--j) { erg += _xdg(S_V_II(rz,j),t,HD,1L); MULT_APPLY(HD,D); } } else { for(i=0L;i= S_I_I(x)) /* copy(S_V_I(zeile,i),x); */ x = S_V_I(zeile,i); freeall(y); y = cons_null; for(i=0;i= S_I_I(y)) /* copy(S_V_I(spalte,i),y); */ y = S_V_I(spalte,i); erg += m_ilih_nm(S_I_I(y)+1L,S_I_I(x)+1L,polyself); for(i=0L;i> wird durchgefuehrt. */ /* Er hat den Aufwand O(m^2n f^2), ist also extrem aufwendig. */ /* Dabei ist f die Dimension derSymmetrisierung <>. */ /* */ /***********************************************************************/ /* RH 011091 */ #ifdef DGTRUE INT glm_B_W(m,n,B,D) OP m; OP n; OP B; OP D; { INT i,j,k,l; OP polyself = callocobject(); OP erg = callocobject(); OP x = callocobject(); OP mneu = callocobject(); m_lh_m(S_M_L(B),S_M_L(B),D); for(i=0L;i 0L) { expo = S_V_LI(tupel)-i-1L; expo = mhochexpo(S_I_I(m),expo); expo*= S_V_II(tupel,i); nr+= expo; } } return(nr); } static INT mhochexpo(x,y) INT x; INT y; { INT i; INT erg = 1L; if(y == 0L)return(1L); erg = x; for(i=2L;i<=y;++i) erg*=x; return(erg); } /***********************************************************************/ /* */ /* Routine: dimension_symmetrization */ /* Die Dimension der Symmetrisierung von part in GL_m(C) wird bestimmt.*/ /* Grundlange ist die in JK79 S. 188 angegebene Formel. */ /* */ /***********************************************************************/ /* RH 011091 */ /* = anzahl der tableaux vom umriss part und max eintrag m */ #ifdef PARTTRUE INT dimension_symmetrization(m,part,dim) OP m,part,dim; /* RH 011091 */ /* AK 010692 */ { INT i; INT j; INT erg = OK; OP nfak; OP f_part; OP hpart; OP _i; OP _j; OP h; CTO(INTEGER,"dimension_symmetrization(1)",m); CTO(PARTITION,"dimension_symmetrization(2)",part); nfak = callocobject(); f_part = callocobject(); hpart = callocobject(); _i = callocobject(); _j = callocobject(); h = callocobject(); m_i_i(1L,dim); for(i=0L;i> eingesetzt. Dann wird A*B gebildet, eingesetzt und auf */ /* Gleichheit getestet. */ /* */ /* written by: Ralf Hager (August 1991) */ /***********************************************************************/ /***********************************************************************/ /* RH 011091 */ /***********************************************************************/ /* */ /* Routine: glm_homtest */ /* Hauptroutine fuer den Homomorphietest. */ /* */ /***********************************************************************/ /* RH 011091 */ #ifdef DGTRUE INT glm_homtest(m,d) OP m,d; { OP a; OP b; OP anz; a = callocobject(); b = callocobject(); anz = callocobject(); m_lh_nm(m,m,a); m_lh_nm(m,m,b); bestimme_zufallsmatrizen(m,a,b); if(_homtest(a,b,d) == (INT)1) { printf("Homtest OK\n"); } else { printf("Fehler in Homtest\n"); } freeall(a); freeall(b); freeall(anz); return OK; } #endif /* DGTRUE */ /***********************************************************************/ /* */ /* Routine: bestimme_zufallsmatrizen */ /* Es werden zwei Matrizen A,B mit Zufallszahlen zwischen -5 und 5 */ /* besetzt. */ /* */ /***********************************************************************/ /* RH 011091 */ #ifdef MATRIXTRUE INT bestimme_zufallsmatrizen(m,a,b) OP m,a,b; { INT i; INT j; OP zahl = callocobject(); OP ober = callocobject(); OP unter = callocobject(); m_i_i((INT)-5,unter); m_i_i((INT)5,ober); for(i=0L;i 0L) { hoch(S_M_IJ(a,k,l),S_M_IJ(S_PO_S(z),k,l),y); mult_apply(y,x); /* AK 120692 statt mult */ } } } z = S_PO_N(z); add_apply(x,erg); /* AK 010692 statt add */ } freeall(x); /* AK 010692 */ freeall(y); /* AK 010692 */ return OK; } #endif /* MATRIXTRUE */ /***********************************************************************/ /***********************************************************************/ /* */ /* Programm zur Bestimmung von GLm(C) Matrixdarstellungen ohne */ /* Orthonormalisierungsschritt. */ /* Es kann durch var zwischen der orthogonalen (var = 0L) und der */ /* Boernerschen (var = 1L) Matrixdarstellung gewaehlt werden. */ /* Es wird eine m^n-dimensionale Matrix zerlegt. Sie muss im Fall */ /* von (S_n,GLm(C)) jedoch nicht explizit bekannt sein, sondern */ /* wird elementweise berechnet. */ /* Ansonsten ist das Verfahren identisch zu dem in sab beschriebenen. */ /* */ /* written by: Ralf Hager (August 1991) */ /***********************************************************************/ /***********************************************************************/ /***********************************************************************/ /* */ /* Routine: input_glmn */ /* Ein Erzeugendensystem fuer Sn wird bestimmt zusammen mit den */ /* darstellenden Matrizen der irreduziblen Matrixdarstellungen */ /* part mit part_1' <= m. */ /* */ /***********************************************************************/ /* RH 011091 */ #ifdef DGTRUE INT input_glmn(m,n,S,SMat,var) OP m; OP n; OP S; OP SMat; INT var; { INT i; OP part = callocobject(); OP anz_irr = callocobject(); OP perm1 = callocobject(); OP perm2 = callocobject(); OP m_hoch_n= callocobject(); OP tupel = callocobject(); m_i_i(0L,anz_irr); hoch(m,n,m_hoch_n); first_partition(n,part); do { if(S_PA_LI(part)<= S_I_I(m)) inc(anz_irr); } while(next(part,part)); if(S_I_I(n) > 2) { m_il_v(2L,S); m_il_p(S_I_I(m_hoch_n),S_V_I(S,0L)); m_il_p(S_I_I(m_hoch_n),S_V_I(S,1L)); m_il_p(S_I_I(n),perm1); m_il_p(S_I_I(n),perm2); for(i=2L;i<=S_I_I(n);++i) { m_i_i(i,S_P_I(perm2,i-2L)); } m_i_i(1L,S_P_I(perm2,S_I_I(n)-1L)); for(i=1L;i<=S_I_I(n);++i) { m_i_i(i,S_P_I(perm1,i-1L)); } m_i_i(2L,S_P_I(perm1,0L)); m_i_i(1L,S_P_I(perm1,1L)); m_l_v(anz_irr,SMat); for(i=0L;i> of GLm(C). NAME: glpdg SYNOPSIS: INT glpdg(m,part,M); OP m,part,M; DESCRIPTION: part has to be an PARTITION object with not more than m parts. For this partition, the program calculates the polynomial irreducible representation <> of GLm(C), which ist stored in the MATRIX-Object M. reference: J. Grabmeier/ A. Kerber: The evaluation of Irreducible Polynomial Representations of the General Linear Groups and of the Unitary Groups over Fields of Characteristic 0. Acta Applicandae Mathematicae 8 (1987). (Describes a method different from the one implemented here, but gives a lot of theoratical background.) COMMENT: 5. Checking Homomorphy of Representations of GLm(C): ------------------------------------------------ NAME: glm_homtest SYNOPSIS: INT glm_homtest(m,M); OP m,M; DESCRIPTION: The relation D(A)*D(B) = D(A*B) is verified with two random integer matrices. In case of M not being a representation, the procedure displays an error message to stdout. COMMENT: /* Documentation of routines, concerning the calculation of symmetry adapted bases for general finite permutation groups 1. Calculating of a general symmetry adapted Basis: -------------------------------------------------- SYNOPSIS: sab_input(S,SMat,M); OP S,SMat,M; group_gen(S,SMat,D,Di); OP S,SMat,D,Di; sab(Di,D,B,M,mpc); OP Di,D,B,M,mpc; The procedure sab_input reads the necessary input from the standard-input. The input-format is as follows: -------------------------------------------------------------- nr of generators of G | orderS (INTEGER ) | set S of generators of G | S (VECTOR of PERMUTATIONS of | length n, where G <= Sn) | nr. of irred. representations | anz_irr (INTEGER ) | matrices of irr.representations | for the elements s in S | SMat (VECTOR of VECTOR of MATRIX) | symmetric operator M | M (MATRIX) | -------------------------------------------------------------- With this input, group_gen calulates the whole symmetry group G. The group elements are stored in D the first line of their irreducible matrix representations are stored in Di in the order of the invers elements. D has the same type as S and Di is a threedimensional VECTOR structure. Finally sab can be called, which calculates the symmetry adapted basis in B and the decomposed Operator in M as a vector of matrices representing the blockdiagonal structure of M. Every block occures once, its multiplicity ist stored in the vector mpc. REFERENCE: E.Stiefel/A.Faessler: Gruppentheoretische Methoden und ihre Anwendung Teubner, 1979. */ symmetrica-2.0/sb.c0000400017361200001450000014056510726021652014157 0ustar tabbottcrontab /* SYMMETRICA sb.c */ #include "def.h" #include "macro.h" #ifdef SCHUBERTTRUE static INT algorithmus2(); static INT algorithmus3(); static INT algorithmus4(); static INT algorithmus5(); static INT algorithmus6(); static INT pol_sch_alg01(); static INT co_L9(); #endif /* SCHUBERTTRUE */ #ifdef SCHUBERTTRUE INT cast_apply_schubert(a) OP a; /* tries to transform the object a into a SCHUBERT object */ /* AK 170207 V3.0 */ { INT erg = OK; COP("cast_apply_schubert(1)",a); switch (S_O_K(a)) { case BRUCH: case LONGINT: case INTEGER: erg += m_scalar_schubert(a,a); break; default: erg += WTO("cast_apply_schubert",a); break; } ENDR("cast_apply_schubert"); } INT m_scalar_schubert(a,b) OP a,b; /* AK 141099 */ /* input scalar = INTGEER, BRUCH, LONGINT,... the type is not checked */ /* output schubert polynomial labeled by identy perm */ { INT erg = OK; CE2(a,b,m_scalar_schubert); erg += b_skn_sch(callocobject(),callocobject(),NULL,b); erg += first_permutation(cons_zwei,S_SCH_S(b)); COPY(a,S_SCH_K(b)); ENDR("m_scalar_schubert"); } INT maxdegree_schubert(a,b) OP a,b; /* AK 231194 */ /* AK 190598 V2.0 */ /* b: maximal degree of the permutations labelling the schubert polynomials (INTEGER object) */ { OP z; INT erg = OK; CTO(SCHUBERT,"maxdegree_schubert",a); CE2(a,b,maxdegree_schubert); erg += m_i_i((INT)0,b); z = a; while((z != NULL)&&(S_SCH_S(z) != NULL)) { if (S_SCH_SLI(z) > S_I_I(b)) M_I_I(S_SCH_SLI(z),b); z = S_SCH_N(z); } ENDR("maxdegree_schubert"); } INT einsp_schubert(a) OP a; /* AK 200691 V1.2 */ /* AK 200891 V1.3 */ { if (einsp(S_SCH_S(a))) if (einsp(S_SCH_K(a))) if (S_SCH_N(a) == NULL) return TRUE; return FALSE; } #endif /* SCHUBERTTRUE */ INT schubertp(a) OP a; /* AK 200891 V1.3 */ { if (s_o_k(a) == SCHUBERT) return TRUE; else return FALSE; } #ifdef SCHUBERTTRUE INT m_lehmer_schubert_qpolynom(a,b) OP a,b; /* AK 131097 */ { INT erg = OK; /* AK 191191 */ OP p; CTTO(INTEGERVECTOR,VECTOR,"m_lehmer_schubert_qpolynom(1)",a); p = CALLOCOBJECT(); erg += lehmercode(a,p); erg += m_perm_schubert_qpolynom(p,b); FREEALL(p); ENDR("m_lehmer_schubert_qpolynom"); } INT m_lehmer_schubert_monom_summe(a,b) OP a,b; /* AK 061288 */ /* AK 240789 V1.0 */ /* AK 190690 V1.1 */ /* AK 090891 V1.3 */ /* AK 190598 V2.0 */ /* a and b may be equal */ { INT erg = OK; /* AK 191191 */ OP p; CTTO(VECTOR,INTEGERVECTOR,"m_lehmer_schubert_monom_summe(1)",a); p = callocobject(); erg += lehmercode(a,p); erg += m_perm_schubert_monom_summe(p,b); erg += freeall(p); ENDR("m_lehmer_schubert_monom_summe"); } #endif /* SCHUBERTTRUE */ INT m_perm_schubert_monom_summe(perm,res) OP perm,res; /* Eingabe: PERMUTATION als label des Schubertpolynoms */ /* Ausgabe: POLYNOM */ /* 020588 */ /* AK 240789 V1.0 */ /* AK 120790 V1.1 */ /* AK 090891 V1.3 */ { OP vorfaktor; INT erg = ERROR; /* das monom, mit dem das ergebnis einer einzelnen rekursion multipliziert werden muss */ /* beim start = [0,0,0,0,....,0] */ #ifdef SCHUBERTTRUE erg = OK; CTO(PERMUTATION,"m_perm_schubert_monom_summe(1)",perm); CE2(perm,res,m_perm_schubert_monom_summe); if (einsp(perm)) /* AK 191191 */ { erg += m_scalar_polynom(cons_eins,res); goto endr_ende; } vorfaktor = CALLOCOBJECT(); erg += m_il_nv(S_P_LI(perm),vorfaktor); C_O_K(vorfaktor,INTEGERVECTOR); /* vorfaktor ist nun initialisiert */ erg += algorithmus2(vorfaktor,0L,S_P_LI(perm)-1L,perm,res); /* die rekursion wird aufgerufen */ FREEALL(vorfaktor); #endif /* SCHUBERTTRUE */ ENDR("m_perm_schubert_monom_summe"); } #ifdef SCHUBERTTRUE INT m_perm_schubert_qpolynom(perm,res) OP perm,res; /* 020588 */ /* AK 240789 V1.0 */ /* AK 040190 V1.1 */ /* AK 090891 V1.3 */ { INT erg = OK; INT w,i; OP c; CTO(PERMUTATION,"m_perm_schubert_qpolynom(1)",perm); c = callocobject(); erg += lehmercode(perm,c); w = 0; for (i=0;i j) { inc_vector(l); M_I_I(0L,S_V_I(l,S_V_LI(l)-1L)); goto pol_sch_alg01l1; } /* nun ist l ein lehmercode */ erg += b_skn_sch(callocobject(),callocobject(),NULL,schub); erg += copy(S_PO_K(p),S_SCH_K(schub)); erg += lehmercode(l,S_SCH_S(schub)); if (not EMPTYP(res)) erg += freeself(res); erg += m_lehmer_schubert_monom_summe(l,res); erg += mult_apply(S_PO_K(p),res); erg += sub(p,res,p); insert(schub,s,NULL,comp_monomvector_monomvector); erg += freeall(res); erg += freeall(l); if (not EMPTYP(p)) if (not empty_listp(p)) goto pol_sch_alg01l2; ENDR("internal:pol_sch_alg01"); } static INT algorithmus2(vorfaktor,alphabetindex,stufe,perm,res) OP vorfaktor; /* ist ein monom, d.h. vector */ /* bsp [0,1,0] == b^2 */ /* damit wird das ergebnis dieser rekursion multipliziert und in res eingefuegt */ INT alphabetindex; /* ist der start des alphabets a==0 */ /* d.h. wird nur noch im alphabet b,c,d, .. gerechnet so ist dies =1 */ INT stufe; /* der exponent des Vorfaktors */ OP perm; /* die permutation zu der berechnet wird */ OP res; /* das globale ergebnis */ /* AK 020588 */ /* AK 081188 */ /* AK 240789 V1.0 */ /* AK 201189 V1.1 */ /* AK 090891 V1.3 */ { INT i,erg=OK; CTO(PERMUTATION,"algorithmus2(1)",perm); CTTO(VECTOR,INTEGERVECTOR,"algorithmus2(2)",vorfaktor); if (S_V_LI(vorfaktor) == 0L) return error("algorithmus2:vorfaktor == 0"); if (S_P_LI(perm) == 2L) /* ende des algorithmus */ { OP monom = callocobject(); b_skn_po(callocobject(),callocobject(),NULL,monom); M_I_I(1L,S_PO_K(monom)); copy(vorfaktor,S_PO_S(monom)); /* das monom ist nun fertig initialisiert */ if (S_P_II(perm,0L) == 2L) INC(S_PO_SI(monom,alphabetindex)); /* der vorfaktor wird noch mit dem i-ten buchstaben multipliziert falls perm = [2,1] */ insert(monom,res,add_koeff,comp_monomvector_monomvector); /* einfuegen des ergebnis in das globale ergebnis */ return OK; } if (S_P_II(perm,0L) == S_P_LI(perm)) /* nun die rekursion */ { OP neuperm = callocobject(); OP neufaktor = callocobject(); b_ks_p(VECTOR,callocobject(),neuperm); m_il_v(S_P_LI(perm)-1L,S_P_S(neuperm)); for(i=0L;i S_P_II(perm,0L))) { copy(perm,neuperm); maximal = S_P_II(perm,i); M_I_I(S_P_II(perm,0L),S_P_I(neuperm,i)); M_I_I(S_P_II(perm,i),S_P_I(neuperm,0L)); algorithmus2(vorfaktor,alphabetindex, stufe-1L,neuperm,res); }; freeall(neuperm); return OK; } ENDR("algorithmus2"); } static INT algorithmus4(exponent,alphabetindex,stufe,perm,result) INT exponent; /* exponent zur q-specialisierung */ /* bsp [0,1,0] == b^2 */ INT alphabetindex; /* ist der startdes alphabets a==0 */ INT stufe; /* der exponent des Vorfaktors */ OP perm; /* die permutation zu der berechnet wird */ OP result; /* AK 020588 */ /* AK 240789 V1.0 */ /* AK 170190 V1.1 */ /* aendern monom nicht mehr integer sondern vector */ /* AK 090891 V1.3 */ { if (S_P_LI(perm) == 2L) /* ende des algorithmus */ { if (S_P_II(perm,0L) == 2L) inc(S_V_I(result,exponent+alphabetindex)); else inc(S_V_I(result,exponent)); return OK; } if (S_P_II(perm,0L) == S_P_LI(perm)) /* nun die rekursion */ { INT i; DEC_INTEGER(S_P_L(perm)); for(i=0L;i0;i--) M_I_I(S_P_II(perm,i-1),S_P_I(perm,i)); INC_INTEGER(S_P_L(perm)); M_I_I(S_P_LI(perm),S_P_I(perm,(INT)0)); return OK; } else { INT i; INT maximal = S_P_LI(perm)+1L; for (i=1L;i S_P_II(perm,0L))) { /* OP neuperm = callocobject(); copy_permutation(perm,neuperm); maximal = S_P_II(perm,i); M_I_I(S_P_II(perm,0L),S_P_I(neuperm,i)); M_I_I(S_P_II(perm,i),S_P_I(neuperm,0L)); algorithmus4(exponent,alphabetindex, stufe-1L,neuperm,result); freeall(neuperm); */ maximal = S_P_II(perm,i); M_I_I(S_P_II(perm,0L),S_P_I(perm,i)); M_I_I(maximal,S_P_I(perm,0L)); algorithmus4(exponent,alphabetindex, stufe-1L,perm,result); M_I_I(S_P_II(perm,i),S_P_I(perm,0L)); M_I_I(maximal,S_P_I(perm,i)); }; return(OK); } } static INT algorithmus3(alphabetindex,perm,result) INT alphabetindex; /* ist der startdes alphabets a==0 */ OP perm; /* di epermutation zu der berechnet wird */ OP result; /* AK 020588 */ /* AK 240789 V1.0 */ /* AK 191190 V1.1 */ /* AK 090891 V1.3 */ { if (S_P_LI(perm) == 2L) /* ende des algorithmus */ return inc(result); if (S_P_II(perm,0L) == S_P_LI(perm)) /* nun die rekursion */ { OP neuperm = callocobject(); INT i; b_ks_p(VECTOR,callocobject(),neuperm); m_il_v(S_P_LI(perm)-1L,S_P_S(neuperm)); for(i=0L;i S_P_II(perm,0L))) { OP neuperm = callocobject(); copy(perm,neuperm); maximal = S_P_II(perm,i); M_I_I(S_P_II(perm,0L),S_P_I(neuperm,i)); M_I_I(S_P_II(perm,i),S_P_I(neuperm,0L)); algorithmus3(alphabetindex,neuperm,result); freeall(neuperm); }; return(OK); } } INT all_ppoly(a,c,b) OP a,b,c; /* AK 201189 V1.1 */ /* AK 090891 V1.3 */ { /* a is PARTITION, c is INTEGER-limit , b becomes result */ INT i,j,k; OP w = callocobject(); for (i=0L;i<=S_I_I(c);i++) { OP d = callocobject(); OP e = callocobject(); /* becomes permutation with lehmercode d */ OP f = callocobject(); /* becomes q specialisation */ OP g = callocobject(); m_il_v(i+S_PA_LI(a)+s_pa_ii(a,S_PA_LI(a)-1L),d); for (j=0L;j70L) { fprintf(texout,"\n"); texposition = 0L; } }; fprintf(texout,"\\ "); texposition += 3L; return(OK); } INT add_schubert_schubert(a,b,c) OP a,b,c; /* AK 191190 V1.1 */ /* AK 090891 V1.3 */ { INT erg; OP d = callocobject(); if (not EMPTYP(c)) freeself(c); copy_list(a,d); copy_list(b,c); erg = insert(d,c,add_koeff,comp_monomvector_monomvector); return(erg); } INT add_schubert(a,b,c) OP a,b,c; /* AK 080102 */ { INT erg = OK; CTO(SCHUBERT,"add_schubert(1)",a); CTO(EMPTY,"add_schubert(3)",c); switch (S_O_K(b)) { case SCHUBERT: erg += add_schubert_schubert(a,b,c); goto ende; default: WTO("add_schubert(2)",b); goto ende; } ende: ENDR("add_schubert"); } INT m_skn_sch(self,koeff,n,ergebnis) OP self,koeff,n,ergebnis; /* AK 110789 V1.0 */ /* AK 191190 V1.1 */ /* AK 090891 V1.3 */ { INT erg = OK; COP("m_skn_sch(4)",ergebnis); erg += m_skn_po(self,koeff,n,ergebnis); C_O_K(ergebnis,SCHUBERT); ENDR("m_skn_sch"); } INT b_skn_sch(self,koeff,n,ergebnis) OP self,koeff,n,ergebnis; /* AK 110789 V1.0 */ /* AK 191190 V1.1 */ /* AK 090891 V1.3 */ { if (ergebnis == NULL) return(ERROR); b_skn_po(self,koeff,n,ergebnis); C_O_K(ergebnis,SCHUBERT); return(OK); } #endif /* SCHUBERTTRUE */ #ifdef SCHUBERTTRUE INT scan_schubert(ergebnis) OP ergebnis; /* AK 110789 V1.0 */ /* AK 191190 V1.1 */ /* AK 090891 V1.3 */ { char antwort[2]; OBJECTKIND kind; INT erg = OK; CTO(EMPTY,"scan_schubert(1)",ergebnis); erg += b_skn_sch( callocobject(), callocobject(), callocobject(), ergebnis); erg += printeingabe("input of Schubert-monom as permutation"); erg += scan(PERMUTATION,S_SCH_S(ergebnis)); erg += printeingabe("input kind of coeff"); kind = scanobjectkind(); erg += scan(kind,S_SCH_K(ergebnis)); erg += printeingabe("one more monom y/n"); scanf("%s",antwort); if (antwort[0] == 'y') erg += scan(SCHUBERT,S_SCH_N(ergebnis)); else { C_O_K(S_SCH_N(ergebnis),EMPTY); erg += freeall(S_SCH_N(ergebnis)); erg += c_sch_n(ergebnis,NULL); } ENDR("scan_schubert"); } INT m_perm_sch(a,b) OP a,b; /* AK 231194 */ { INT erg = OK; CTO(PERMUTATION,"m_perm_sch",a); erg += b_skn_sch(callocobject(),callocobject(),NULL,b); erg += copy(a,S_SCH_S(b)); M_I_I((INT)1,S_SCH_K(b)); ENDR("m_perm_sch"); } OP s_sch_s(a) OP a; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_s:a == NULL"), (OP) NULL; if (not schubertp(a)) return error("s_sch_s:a != SCHUBERT"), (OP) NULL; return(s_mo_s(s_l_s(a))); } OP s_sch_k(a) OP a; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_k:a == NULL"), (OP) NULL; if (not schubertp(a)) return error("s_sch_k:a != SCHUBERT"), (OP) NULL; return(s_mo_k(s_l_s(a))); } OP s_sch_n(a) OP a; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_n:a == NULL"), (OP) NULL; if (not schubertp(a)) return error("s_sch_n:a != SCHUBERT"), (OP) NULL; return(s_l_n(a)); } OP s_sch_si(a,i) OP a; INT i; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_si:a == NULL"), (OP) NULL; if (not schubertp(a)) return error("s_sch_si:a != SCHUBERT"), (OP) NULL; return s_p_i(s_sch_s(a),i); } OP s_sch_sl(a) OP a; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_sl:a == NULL"), (OP) NULL; if (not schubertp(a)) return error("s_sch_sl:a != SCHUBERT"), (OP) NULL; return s_p_l(s_sch_s(a)); } INT s_sch_ki(a) OP a; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_ki:a == NULL"); if (not schubertp(a)) return error("s_sch_ki:a != SCHUBERT"); return s_i_i(s_sch_k(a)); } INT s_sch_sii(a,i) OP a; INT i; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_sii:a == NULL"); if (not schubertp(a)) return error("s_sch_sii:a != SCHUBERT"); return s_p_ii(s_sch_s(a),i); } INT s_sch_sli(a) OP a; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { if (a == NULL) return error("s_sch_sli:a == NULL"); if (not schubertp(a)) return error("s_sch_sli:a != SCHUBERT"); return s_p_li(s_sch_s(a)); } INT c_sch_n(a,b) OP a,b; /* AK 110789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { OBJECTSELF c; if (a == NULL) return error("c_sch_n:a == NULL"); c = s_o_s(a); c.ob_list->l_next = b; return OK; } INT display_schubert(a) OP a; /* AK 240789 V1.0 */ /* AK 131290 V1.1 */ /* AK 090891 V1.3 */ { return(println(a)); } INT test_schubert() /* AK 200891 V1.3 */ { OP a = callocobject(); OP b = callocobject(); printf("test_schubert:scan(PERMUTATION)\n"); scan(PERMUTATION,a); println(a); printf("test_schubert:m_perm_schubert_monom_summe(a,b)\n"); m_perm_schubert_monom_summe(a,b); println(b); printf("test_schubert:scan(POLYNOM)\n"); scan(POLYNOM,a); println(a); printf("test_schubert:t_POLYNOM_SCHUBERT(a,b)\n"); t_POLYNOM_SCHUBERT(a,b); println(b); printf("test_schubert:tex(b)\n"); tex(b); printf("test_schubert:scan(SCHUBERT,a)\n"); scan(SCHUBERT,a); println(a); printf("test_schubert:hoch(a,2L,b)\n"); hoch(a,cons_zwei,b); println(b); printf("test_schubert:einsp(b)\n"); if (not einsp(b)) printeingabe("not eins"); else printeingabe("is eins"); freeall(a); freeall(b); return(OK); } INT print_schubert_difference(b,c) OP b,c; /* druckt in spezieller weise aus b ist ein einzelnes Schubertpolynom, c ist eine summe von Schubertpolynomen gedruckt werden nur die stellen die verschieden in den permutationen */ /* AK 200690 */ /* AK 200891 V1.3 */ { OP x; INT i; x = c; while ( x != NULL) { print(S_SCH_K(b)); printf(" ["); for (i=0L;(i < S_SCH_SLI(x))&& (i S_SCH_SLI(b)) { d=a; a=b; b=d; } d=callocobject(); erg += t_SCHUBERT_POLYNOM(a,d); erg += mult(d,b,c); erg += freeall(d); ENDR("mult_schubert_schubert"); } INT outerproduct_schubert(a,b,c) OP a,b,c; /* a PERM b PERM c wird SCHUBERT */ { INT erg = OK; OP d,e; CTO(PERMUTATION,"outerproduct_schubert(1)",a); CTO(PERMUTATION,"outerproduct_schubert(2)",b); d=callocobject(); e=callocobject(); erg += m_perm_sch(a,d); erg += m_perm_sch(b,e); erg += mult(d,e,c); erg += freeall(d); erg += freeall(e); ENDR("outerproduct_schubert"); } INT mult_schubert_variable (a,i,r) OP a,i,r; /* a ist schubert polynom i ist INTEGER, index der variable * r wird result */ /* AK 190690 V1.1 */ /* AK 090891 V1.3 */ { OP z,ss,c; INT erg = OK; INT ii = S_I_I(i); /* variablennumerierung beginnt mit 0 */ INT j; INT grenzelinks,grenzerechts; CE3(a,i,r,mult_schubert_variable); init(SCHUBERT,r); z = a; while (z != NULL) { ss = S_SCH_S(z); if (S_P_II(ss,S_P_LI(ss)-1L) != S_P_LI(ss) ) { inc(S_P_S(ss)); M_I_I(S_P_LI(ss), S_P_I(ss,S_P_LI(ss)-1L) ); } while (ii+1L >= S_P_LI(ss)) { inc(S_P_S(ss)); M_I_I(S_P_LI(ss), S_P_I(ss,S_P_LI(ss)-1L) ); } grenzelinks=0L; grenzerechts=S_P_LI(ss)+1L; for (j=ii-1L;j>=0L; j--) { if ( (S_P_II(ss,j) < S_P_II(ss,ii) ) && (S_P_II(ss,j) > grenzelinks ) ) { /* nach links tauschen */ c = callocobject(); b_skn_sch(callocobject(),callocobject(), NULL,c); addinvers(S_SCH_K(z),S_SCH_K(c)); copy(ss,S_SCH_S(c)); m_i_i(S_P_II(ss,j), S_SCH_SI(c,ii)); m_i_i(S_P_II(ss,ii), S_SCH_SI(c,j)); insert(c,r,add_koeff, comp_monomvector_monomvector); grenzelinks = S_P_II(ss,j); } } for (j=ii+1L; j S_P_II(ss,ii) ) && (S_P_II(ss,j) < grenzerechts ) ) { /* nach rechts tauschen */ c = callocobject(); b_skn_sch(callocobject(),callocobject(), NULL,c); copy(S_SCH_K(z),S_SCH_K(c)); copy_permutation(ss,S_SCH_S(c)); M_I_I(S_P_II(ss,j), S_SCH_SI(c,ii)); M_I_I(S_P_II(ss,ii), S_SCH_SI(c,j)); insert(c,r,add_koeff, comp_monomvector_monomvector); grenzerechts = S_P_II(ss,j); } } z = S_SCH_N(z); } ENDR("mult_schubert_variable"); } INT mult_schubert_monom(a,b,c) OP a,b,c; /* a ist SCHUBERT b ist MONOM eines POLYNOMS c wird ergebnis */ /* AK 190690 V1.1 */ /* AK 090891 V1.3 */ { OP e=callocobject(); INT i,j; copy(a,c); for (i=0L; iy){ M_I_I(x,S_P_I(e,S_I_I(a))); M_I_I(y,S_P_I(e,S_I_I(a)-1L)); erg += m_skn_sch(e,S_SCH_K(schub),NULL,f); erg += add_apply(f,res); } schub=S_SCH_N(schub); } ende: erg += freeall(f); erg += freeall(e); erg += freeall(a1); ENDR("divdiff_schubert"); } INT divdiff_perm_schubert(perm,sb,res) OP perm,sb,res; /* AL 180393 */ { OP red,f; INT i,erg = OK; CTO(PERMUTATION,"divdiff_perm_schubert(1)",perm); CTO(SCHUBERT,"divdiff_perm_schubert(2)",sb); red=callocobject(); f=callocobject(); erg += rz_perm(perm,red); erg += copy(sb,res); for(i=0L;i (INT)1) { fprintf(texout,"$ (x_%ld - y_%ld)^%ld $ ",j,k-j,S_PO_SII(z,i)); texposition += (INT)10; } if (k == j) { k++;j=(INT)0; } else j++; /* if (j == 0) { k++;j=k; } else j--; */ } z = S_PO_N(z); if (texposition >(INT)70) { fprintf(texout,"\n"); texposition = 0L; } if (z != NULL) fprintf(texout," $+$ "); } ENDR("tex_2schubert_monom_summe"); } INT m_perm_2schubert_monom_summe(perm,res) OP perm,res; /* Eingabe: PERMUTATION als label des Schubertpolynoms */ /* Ausgabe: POLYNOM */ /* 020588 */ /* AK 240789 V1.0 */ /* AK 120790 V1.1 */ /* AK 090891 V1.3 */ { OP vorfaktor; /* das monom, mit dem das ergebnis einer einzelnen rekursion multipliziert werden muss */ /* beim start = [0,0,0,0,....,0] */ INT i; INT erg = OK; CTO(PERMUTATION,"m_perm_2schubert_monom_summe",perm); if (einsp(perm)) /* AK 191191 */ return m_scalar_polynom(cons_eins,res); if (not EMPTYP(res)) erg += freeself(res); vorfaktor = callocobject(); erg += m_il_v((S_P_LI(perm)*(S_P_LI(perm)-1))/2,vorfaktor); for (i=0L;i S_P_II(perm,0L))) { copy(perm,neuperm); copy(vorfaktor,neufaktor); maximal = S_P_II(perm,i); M_I_I(S_P_II(perm,0L),S_P_I(neuperm,i)); M_I_I(S_P_II(perm,i),S_P_I(neuperm,0L)); /* M_I_I(1L,S_V_I(neufaktor,S_P_II(perm,0L)-1+alphabetindex)); */ k = alphabetindex + S_P_II(perm,0L) - 1L; j = ((1+k) * k) / 2; M_I_I(0L,S_V_I(neufaktor,j + alphabetindex)); /* print(S_P_I(perm,0L));print(neufaktor);println(neuperm); */ algorithmus5(neufaktor,alphabetindex, stufe-1L,neuperm,res); }; freeall(neuperm); freeall(neufaktor); return OK; } } INT exchange_alphabets(a,b) OP a,b; /* AK 101194 */ /* eingabe ein polynom mit matrix self teil in zwei zeilen = ergebnis von t_2SCHUBERT_POLYNOM */ /* ergbnis tausch der beiden zeilen der matrix */ { OP z,d; init(POLYNOM,b); z = a; while (z != NULL) { d = callocobject(); m_skn_po(S_PO_S(z),S_PO_K(z),NULL,d); change_row_ij(S_PO_S(d),0L,1L); insert(d,b,NULL,NULL); z = S_PO_N(z); } return OK; } INT eval_2schubert(a,vec,b) OP a,b,vec; /* AK 101194 */ /* eingabe ein double schubert polynom a (d.h. kodiert in einem vektor) und ein vektor vec mit den ersetzungen fuer y_i ergebnis ist b */ { OP z,c,d,e,f; INT i,j,k; z = a; init ( POLYNOM, b); if (nullp(a)) return OK; c = callocobject(); d = callocobject(); e = callocobject(); while (z != NULL) { f = callocobject(); m_i_i(1L,f); for (i=0L,j=0L,k=0L;i kein speicher bedarf */ if (nullp(res)) { FREEALL(res); goto ee; } vec = callocobject(); m_il_v(S_P_LI(perm2),vec); for (i=0;i S_P_II(perm,0L))) { copy(perm,neuperm); copy(vorfaktor,neufaktor); maximal = S_P_II(perm,i); M_I_I(S_P_II(perm,0L),S_P_I(neuperm,i)); M_I_I(S_P_II(perm,i),S_P_I(neuperm,0L)); k = alphabetindex + S_P_II(perm,0L) - 1L; j = ((1+k) * k) / 2; M_I_I(0L,S_V_I(neufaktor,j + alphabetindex)); algorithmus6(perm2,neufaktor,alphabetindex, stufe-1L,neuperm,res); }; freeall(neuperm); freeall(neufaktor); return OK; } } INT scalarproduct_schubert(a,b,c) OP a,b,c; /* AK 231194 */ { OP d,e; INT erg = OK; CTO(SCHUBERT,"scalarproduct_schubert",a); CTO(SCHUBERT,"scalarproduct_schubert",b); d = callocobject(); e = callocobject(); erg += maxdegree_schubert(a,d); erg += maxdegree_schubert(b,e); if (gt(e,d)) erg += copy(e,d); erg += mult(a,b,e); erg += last_permutation(d,d); erg += divdiff(d,e,c); erg += freeall(d); erg += freeall(e); ENDR("scalarproduct_schubert"); } #endif /* SCHUBERTTRUE */ symmetrica-2.0/sb.doc0000600017361200001450000001575410726170301014501 0ustar tabbottcrontabCOMMENT: SYMMETRICA: sb.doc ############################################################## SCHUBERT -------- This is a special kind of LISTobjects, the elements of the list are MONOM objects, where the self part are PERMUTATION objects, this is like POLYNOM or SCHUR objects. To access the parts of the object there are the macros and routines ROUTINE MACRO DESCRIPTION --------------------------------------------------- s_sch_s S_SCH_S select_schubert_self s_sch_si S_SCH_SI select_schubert_self_ith s_sch_sii S_SCH_SII select_schubert_self_ith_asINT s_sch_sl S_SCH_SL select_schubert_self_length s_sch_sli S_SCH_SLI select_schubert_self_length_asINT s_sch_n S_SCH_N select_schubert_next s_sch_k S_SCH_K select_schubert_koeff s_sch_ki S_SCH_KI select_schubert_koeff_asINT NAME: m_perm_sch SYNOPSIS: INT m_perm_sch(OP perm, res) DESCRIPTION: build out of a PERMUTATION object perm, a SCHUBERT object res, which is labeled by a copy of the permutation and which has coefficent 1. Compare this with the functions m_pa_s, which does the same for SCHUR objects. COMMENT: As the Schubertpolynomials form a basis of the ring of polynomials in several variables there are routines for the change of basis NAME: t_POLYNOM_SCHUBERT SYNOPSIS: INT t_POLYNOM_SCHUBERT(OP a,b) DESCRIPTION: you enter a POLYNOM object a and the result is the corresponding SCHUBERT object b. The variables a and b may be equal. NAME: t_SCHUBERT_POLYNOM SYNOPSIS: INT t_SCHUBERT_POLYNOM(OP a,b) DESCRIPTION: you enter a SCHUBERT object a and the result is the corresponding POLYNOM object b. NAME: divdiff_perm_schubert SYNOPSIS: INT divdiff_perm_schubert(OP perm,sb,res) DESCRIPTION: applys the divided difference operator labeled by the PERMUTATION object perm on the SCHUBERT object sb. The result is a new SCHUBERT object res. Better us the general routine divdiff. COMMENT: As Schubert polynomials are objects labeled by PERMUTATION objects it is natural to have the following routines NAME: m_lehmer_schubert_monom_summe SYNOPSIS: INT m_lehmer_schubert_monom_summe(OP a,b) DESCRIPTION: you enter a VECTOR object, which is a Lehmer code (cf. PERMUTATION) and the output is a POLYNOMobject b, which is the Schubert polynom, labeled by the permutation given by the Lehmer code. NAME: m_perm_schubert_monom_summe SYNOPSIS: INT m_perm_schubert_monom_summe(OP a,b) DESCRIPTION: you enter the PERMUTATION object a which labels the Schubert polynomial, the output is the POLYNOM object b. NAME: m_perm_2schubert_monom_summe SYNOPSIS: INT m_perm_schubert_monom_summe(OP a,b) DESCRIPTION: this routine computes the double schubert monomial coreesponding to the PERMUTATION object a which labeles the Schubert polynomial, the output is the POLYNOM object b. The self part of this POLYNOM object is to be interpreted as follows: position 0 is the exponent of the factor (x_1 - y_1) position 1 is the exponent of the factor (x_1 - y_2) position 2 is the exponent of the factor (x_2 - y_1) position 3 is the exponent of the factor (x_1 - y_3) position 4 is the exponent of the factor (x_2 - y_2) position 5 is the exponent of the factor (x_3 - y_1) ... as an example look at the output of the permutation 2 3 4 1 it is the polynomial 1 [1,0,1,0,0,1] this is the product (x_1 - y_1)(x_2 - y_1)(x_3 - y_1) NAME: m_perm_2schubert_operating_monom_summe SYNOPSIS: INT m_perm_2schubert_operating_monom_summe(OP a,b,c) DESCRIPTION: computes the double Schubert polynomial indexed by the PERMUTATION object a, and substitutes the second alphabet by the permuted first alphabet (the permutation is given by the PERMUTATION object b) The result is a POLYNOM object (the monomial expansion) NAME: m_perm_schubert_qpolynom SYNOPSIS: INT m_perm_schubert_qpolynom(OP a,b) DESCRIPTION: as the routine m_perm_schubert_monom_summe, but you specify the alphabet a,b,c,... of the result as follows a->q^0 b->q^1 c->q^2 ... So the result is a POLYNOM object b in the alphabet of one variable. NAME: m_perm_schubert_dimension SYNOPSIS: INT m_perm_schubert_dimension(OP a,b) DESCRIPTION: as the routine m_perm_schubert_monom_summe, but you specify the alphabet a,b,c,... of the result as follows a->1 b->1 c->1 ... So the result is a INTEGER object b. NAME: m_i_schubert SYNOPSIS: INT m_i_schubert(INT a; OP b) DESCRIPTION: transform the INTEGER object a to a SCHUBERT object b, where a is the koeffizent of the identity permutation. RETURN: OK; NAME: t_2SCHUBERT_POLYNOM SYNOPSIS: INT t_2SCHUBERT_POLYNOM(OP a,b) DESCRIPTION: to transfer the special POLYNOM object a, whose format was described in m_perm_2schubert_monom_summe, into an ordinary POLYNOM object, whose self part is a MATRIX object with two rows. (to code the 2 sets of variables) NAME: eval_2schubert SYNOPSIS: INT eval_2schubert(OP a,vec,b) DESCRIPTION: this routine specialices the second set of variables of double schubert polynomial a (this is a POLYNOM object in two sets of variables = result of the function t_2SCHUBERT_POLYNOM) so you have to enter a VECTOR object vec which contains the values which should replace the variables of the second set. See also the function eval_polynom which has a simliar syntax. EXAMPLE: NAME: exchange_alphabets SYNOPSIS: INT exchange_alphabets(OP a,b) DESCRIPTION: this routine exchanges the two sets of variables in a POLYNOM object a, which should be the result of a earlier call to t_2SCHUBERT_POLYNOM. The result is the POLYNOM object b NAME: test_schubert SYNOPSIS: INT test_schubert() DESCRIPTION: tests the installation NAME: tex_2schubert_monom_summe SYNOPSIS: INT tex_2schubert_monom_summe(OP a) DESCRIPTION: this is to provide a TeX output of the POLYNOM object which was described in m_perm_2schubert_monom_summe. NAME: println_schub_lehmer SYNOPSIS: INT println_schub_lehmer(OP schub) DESCRIPTION: prints a SCHUBERT object schub to stdout, but instead of the permutations it prints the Lehmer code of the permutations, which label one Schubert polynomial. NAME: outerproduct_schubert SYNOPSIS: INT outerproduct_schubert(OP perma,permb,result) DESCRIPTION: you enter two PERMUTATION objects, and the result is a SCHUBERT object, which is the expansion of the product of the two schubertpolynomials, labbeled by the two PERMUTATION objects perma and permb. COMMENT: GENERAL ROUTINES ---------------- add() add_apply() addinvers() comp() dimension() einsp() fprint() fprintln() freeall() freeself() hoch() mult() mult_apply() nullp() objectread() objectwrite() print() println() qdimension() tex() symmetrica-2.0/sc.c0000400017361200001450000016763110726021652014163 0ustar tabbottcrontab#include "def.h" #include "macro.h" /* AK 141086 */ /* symchar.c */ static struct symchar * callocsymchar(); static INT calculate(); static INT removestrip(); static INT addstrip(); static INT removestrip_char(); static INT addstrip_char(); static INT stripexistp(); static INT stripexistp_char(); static INT (*sef)() = NULL, (*asf)() = NULL, (*rsf)() = NULL; INT chartafel_symfunc(); #ifdef CHARTRUE INT augpart(part) OP part; /* bsp: 1113 --> 1236 */ /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */ { INT i; C_O_K(part,AUG_PART); for (i=(INT)0;i=(INT)0;i--,z--) if ( (*z + length) == h2) return(FALSE); return(TRUE); } static INT stripexistp(part,length,i) OP part; register INT length,i; /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */ { /* register INT j; */ OP z = S_PA_I(part,i); register INT h2; h2 = S_I_I(z); for (; i>=(INT)0;i--,z--) if ( (S_I_I(z) + length) == h2) return(FALSE); return(TRUE); } static INT addstrip_char(part,k,i,hi) OP part; register INT k,hi,i; /* part vom Typ CHARPARTITION */ { /* register INT l; */ i=i-hi; /* in l wird angesetzt */ while ((k--)>(INT)0) { if (i == S_PA_LI(part)-(INT)1) { S_PA_CII(part,i)=S_PA_CII(part,i) +(unsigned char)k+(unsigned char)1; goto addstripende; } else if (S_PA_CII(part,i) < S_PA_CII(part,(i+(INT)1))) S_PA_CII(part,i)++; else if (S_PA_CII(part,i) == S_PA_CII(part,(i+(INT)1))) S_PA_CII(part,++i)++; else error("addstrip_char:"); } addstripende: return OK; } static INT addstrip(part,k,i,hi) OP part; register INT k,hi,i; { /* register INT l; */ OP z; i -=hi; /* in l wird angesetzt */ z = S_PA_I(part,i); while ((k--)>(INT)0) { if (i == S_PA_LI(part)-(INT)1) { C_I_I(z,S_I_I(z)+k+1); goto addstripende; } /* else if (S_I_I(z) < S_I_I(z+1)) INC_INTEGER(z); else if (S_I_I(z) == S_I_I(z+1)) { i++; z++; INC_INTEGER(z); } else error("addstrip:"); */ if (S_I_I(z) == S_I_I(z+1)) { i++; z++; } INC_INTEGER(z); } addstripende: return OK; } static INT removestrip_char(part,k,i) OP part; register INT k; INT i; /* erzeugt neue partition part in der ab der zeile i ein streifen der laenge length entfernt wurde . ergebnis ist die hakenlaenge */ /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */ { register INT l; l=i; while ((k--)>(INT)0) { if (i == (INT)0) S_PA_CII(part,(INT)0)--; else if (S_PA_CII(part,i) > S_PA_CII(part,(i-(INT)1))) S_PA_CII(part,i)--; else S_PA_CII(part,--i)--; }; return(l-i); } static INT removestrip(part,k,i) OP part; register INT k; INT i; /* erzeugt neue partition part in der ab der zeile i ein streifen der laenge length entfernt wurde . ergebnis ist die hakenlaenge */ /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 200891 V1.3 */ { register INT l; OP z; l=i; z = S_PA_I(part,i); while ((k--)>0) { if (i == 0) { DEC_INTEGER(z); } else if (S_I_I(z) > S_I_I(z-1) ) { DEC_INTEGER(z); } else { z--; i--; DEC_INTEGER(z); } }; return(l-i); } #endif /* CHARTRUE */ #define REMOVESTRIP(part,length,j)\ k=length;l=j;m=j;\ while ((k--)>(INT)0)\ {\ if (m == (INT)0) \ DEC_INTEGER(S_PA_I((part),(INT)0));\ else if (S_PA_II((part),m) > S_PA_II((part),(m-(INT)1)))\ DEC_INTEGER(S_PA_I((part),m));\ else \ DEC_INTEGER(S_PA_I((part),--m));\ };\ hooklength=l-m; #ifdef CHARTRUE static INT calculate(sign,rep,part,res) INT sign; OP part, res, rep; /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 250291 V1.2 */ /* AK 200891 V1.3 */ { INT i,hooklength,l; OP newrep; INT erg=OK; INT (*lsef)() = sef, (*lasf)() = asf, (*lrsf)() = rsf; if (S_PA_LI(part) == (INT)0) { if (sign==(INT)1) INC(res); else if (sign == -1L) DEC(res); else erg += ERROR; goto ende; }; if (S_PA_LI(part) == 1L) /* Robinson Lemma 4.11 */ { if (S_PA_LI(rep) == 1L) { M_I_I(1L,res); goto ende; } if (S_PA_II(rep,S_PA_LI(rep)-2L) > S_PA_LI(rep)-1L ) goto ende; /* rep is haken */ for (i=(INT)0;i i) break; i = S_PA_LI(rep)-i; /* i is laenge der part */ if (sign==1L) if (i % 2L == (INT)0) DEC(res); else INC(res); else if (i % 2L == (INT)0) INC(res); else DEC(res); goto ende; } if (S_PA_II(part,S_PA_LI(part)-1) == 1L) /* AK 150988 */ /* dimension */ /* all parts are 1, so we compute the dimension */ { newrep = CALLOCOBJECT(); erg += dimension_augpart(rep,newrep); if (sign == -1L) ADDINVERS_APPLY(newrep); ADD_APPLY(newrep,res); FREEALL(newrep); goto ende; } l = S_PA_LI(part)-1L; /* AK 040293 */ for (i=S_PA_LI(rep)-1L;i>=(INT)0;i--) if (S_PA_II(part,l) <= S_PA_II(rep,i)) if ((*lsef)( rep, S_PA_II(part,l), i)) { hooklength = (*lrsf)( rep, S_PA_II(part,l), i); if (S_O_K(part) == PARTITION) DEC_INTEGER(S_PA_L(part)); else if (S_O_K(part) == CHARPARTITION) /* AK 130593 */ S_PA_C(part)[0]--; erg += calculate( ((hooklength % 2L == (INT)0) ? sign : - sign), rep, part, res); if (S_O_K(part) == PARTITION) /* AK 130593 */ INC_INTEGER(S_PA_L(part)); else if (S_O_K(part) == CHARPARTITION) S_PA_C(part)[0]++; erg += (*lasf)(rep, S_PA_II(part,l), i,hooklength); }; ende: ENDR("calculate"); } INT charvalue_tafel_part(rep,part,res,tafel,pv) OP part,rep,res,tafel,pv; /* AK 260690 V1.1 */ /* AK 250291 V1.2 */ /* tafel ist charactertafel, pv ist vector der partitionen */ /* AK 200891 V1.3 */ { INT i=0,j=0,k; INT erg = OK; CTO(PARTITION,"charvalue_tafel_part(1)",rep); CTO(PARTITION,"charvalue_tafel_part(2)",part); CTO(VECTOR,"charvalue_tafel_part(5)",pv); CTO(MATRIX,"charvalue_tafel_part(4)",tafel); for (k=(INT)0; k<= S_V_LI(pv); k++) if (EQ(rep,S_V_I(pv,k))) {i=k; break; } for (k=(INT)0; k<= S_V_LI(pv); k++) if (EQ(part,S_V_I(pv,k))) {j=k; break; } COPY(S_M_IJ(tafel,i,j),res); ENDR("charvalue_tafel_part"); } INT charvalue(rep,part,res,tafel) OP part, rep, res; OP tafel; /* tafel ist zeiger auf charactertafel mit werten, sonst NULL AK 130189 */ /* part ist der zykeltyp oder eine PERMUTATION */ /* rep ist irr. darstellung */ /* AK 140789 V1.0 */ /* AK 080290 V1.1 */ /* AK 050391 V1.2 */ /* AK 200891 V1.3 */ { OP newrep; INT erg=OK; CTTTO(CHARPARTITION,PARTITION,SKEWPARTITION, "charvalue(1)",rep); CTTTO(CHARPARTITION,PARTITION,PERMUTATION, "charvalue(2)",part); if (S_O_K(rep) == SKEWPARTITION) /* AK 170392 */ { erg += error("charvalue:rep == SKEWPARTITION not yet implemented"); goto endr_ende; } if (S_O_K(part) == PERMUTATION) { OP newpart; newpart = CALLOCOBJECT(); erg += zykeltyp(part,newpart); erg += charvalue(rep,newpart,res,tafel); FREEALL(newpart); goto endr_ende; } if (tafel != NULL) { INT i = indexofpart(rep), j = indexofpart(part); CTO(MATRIX,"charvalue(4)",tafel); erg += copy(S_M_IJ(tafel,i,j),res); goto endr_ende; } if (S_PA_II(part,S_PA_LI(part)-1L) == 1L) /* es wird die dimension berechnet */ { erg += dimension_partition(rep,res); goto endr_ende; }; if (rep == part) { newrep = callocobject(); erg += copy(rep,newrep); erg += charvalue(newrep,part,res,NULL); erg += freeall(newrep); return erg; } FREESELF(res); if (S_O_K(rep) == PARTITION) erg += c_PARTITION_AUGPART(rep); else if (S_O_K(rep) == CHARPARTITION) erg += c_CHARPARTITION_CHARAUGPART(rep); if (S_O_K(rep) == AUG_PART) { sef = stripexistp; asf = addstrip; rsf = removestrip; } if (S_O_K(rep) == CHAR_AUG_PART) { sef = stripexistp_char; asf = addstrip_char; rsf = removestrip_char; } M_I_I((INT)0,res); erg += calculate(1L,rep,part,res); if (S_O_K(rep) == AUG_PART) erg += c_AUGPART_PARTITION(rep); else if (S_O_K(rep) == CHAR_AUG_PART) erg += c_CHARAUGPART_CHARPARTITION(rep); ENDR("charvalue"); } INT chartafel_partvector(a,erg,pv) OP a; OP erg,pv; /* AK 260690 V1.1 */ /* AK 200891 V1.3 */ { return chartafel(a,erg); } #ifdef MATRIXTRUE INT chartafel(a,b) OP a,b; /* computes the table of irreducible characters of the symmetric group of degree a */ /* AK V2.0 300998 */ /* AK V3.0 280705 */ { INT erg=OK; CTO(INTEGER,"chartafel(1)",a); SYMCHECK(S_I_I(a)<0,"chartafel: input < 0"); CE2(a,b,chartafel); if (S_I_I(a) <= (INT) 1) { erg += m_ilih_m((INT)1,(INT)1,b); M_I_I(1,S_M_IJ(b,0,0)); goto ende; } C1R(a,"char_tafel",b); /* AK 171297 */ if (S_I_I(a) <= 16) erg += chartafel_nonbit(a,b); else erg += chartafel_symfunc(a,b); S1R(a,"char_tafel",b); ende: CTO(MATRIX,"chartafel(e2)",b); ENDR("chartafel"); } static INT newindexofpart(a,b) OP a,b; /* AK 030102 */ { INT h; if (S_PA_HASH(a) == -1) C_PA_HASH(a,hash_partition(a)); h = S_PA_HASH(a) % S_V_LI(b); if (h < 0) h += S_V_LI(b); return (S_V_II(b,h)); } static INT newchartafel(a,b) OP a,b; /* AK 030102 */ { INT erg = OK,i,j; INT f = 2; OP c,h1,h2; CTO(INTEGER,"chartafel(1)",a); c = CALLOCOBJECT(); h2 = CALLOCOBJECT(); erg += makevectorofpart(a,c); again: init_size_hashtable(h2,S_V_LI(c)*f); C_O_K(h2,INTEGERVECTOR); for (i=0;i= ( S_PA_II(S_V_I(vec,j),S_PA_LI(S_V_I(vec,j))-1L) ) ) erg += charvalue_bit(S_V_I(bitvec,i),S_V_I(vec,j), S_M_IJ(res,i,j),NULL); else M_I_I((INT)0,S_M_IJ(res,i,j)); j++; } while( j < dim); /* AK 290888 berechnung des assozierten characters */ conjugate(S_V_I(vec,i),conjpart); for (index = i+1L;index= ( S_PA_II(S_V_I(vec,j),S_PA_LI(S_V_I(vec,j))-1L) ) ) erg += charvalue(S_V_I(vec,i),S_V_I(vec,j), S_M_IJ(res,i,j),NULL); else M_I_I((INT)0,S_M_IJ(res,i,j)); j++; } while( j < dim); /* AK 290888 berechnung des assozierten characters */ conjugate(S_V_I(vec,i),conjpart); for (index = i+1L;index(INT)70) { zeilenposition = (INT)0; fprintf(fp,"\n"); } else zeilenposition += 2L; } return(OK); } INT scan_symchar(a) OP a; /* AK 140789 V1.0 */ /* AK 260790 V1.1 */ /* AK 200891 V1.3 */ { OP dim; INT i; extern INT zeilenposition; INT erg = OK; CTO(EMPTY,"scan_symchar(1)",a); erg += printeingabe(" enter the degree of the symmetric group"); dim = callocobject(); erg += scan(INTEGER,dim); erg += b_d_sc(dim,a); erg += printeingabe(" enter the character-value on the given class"); for (i=(INT)0;isy_werte); } OP s_sc_wi(a,i) OP a;INT i; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { return(s_v_i(s_sc_w(a),i)); } INT s_sc_wii(a,i) OP a;INT i; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { return(s_v_ii(s_sc_w(a),i)); } INT s_sc_wli(a) OP a; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { return(s_v_li(s_sc_w(a))); } OP s_sc_p(a) OP a; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_symchar->sy_parlist); } OP s_sc_pi(a,i) OP a;INT i; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { return(s_v_i(s_sc_p(a),i)); } INT s_sc_pli(a) OP a; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { return(s_v_li(s_sc_p(a))); } INT s_sc_di(a) OP a; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { return(s_i_i(s_sc_d(a))); } OP s_sc_d(a) OP a; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_symchar->sy_dimension); } INT c_sc_d(a,b) OP a,b; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_symchar->sy_dimension = b; return(OK); } INT c_sc_p(a,b) OP a,b; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_symchar->sy_parlist = b; return(OK); } INT c_sc_w(a,b) OP a,b; /* AK 140789 V1.0 */ /* AK 200891 V1.3 */ { OBJECTSELF c; c = s_o_s(a); c.ob_symchar->sy_werte = b; return(OK); } #endif /* CHARTRUE */ INT innermaxmofn(m,n,erg) OP m,n,erg; { /* AK 091189 */ /* geschrieben fuer regev, diese routine berechnet fuer eingebe INTEGER m INTEGER n die zerlegung der summe der inneren tensorquadrate der partitionen von n die hoechstens m teile haben ergebnis ist vom typ SCHUR */ /* AK 200891 V1.3 */ #ifdef CHARTRUE OP a = callocobject(); OP b = callocobject(); OP c = callocobject(); OP d = callocobject(); first_partition(n,a); do { if (le(s_pa_l(a),m)) { m_part_sc(a,b);mult(b,b,c); add(c,d,d); } } while(next(a,a)); reduce_symchar(d,erg); freeall(a); freeall(b); freeall(c); freeall(d); return(OK); #endif /* CHARTRUE */ } #ifdef CHARTRUE #ifdef KOSTKATRUE INT young_tafel(a,res,ct,kt) OP a, res, ct, kt; /* AK Mon Jan 23 09:59:22 MEZ 1989 */ /* a ist dimension res wird MATRIX ct ist wenn ungleich NULL die charatertafel kt ist wenn ungleich NULL die kostkatafel */ /* AK 200789 V1.0 */ /* AK 020290 V1.1 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ /* a and res may be equal */ { OP zw /* zwischenergebnis */, hct,hkt; INT i,j,k,dim; INT erg = OK; C1R(a,"young_tafel",res); if (a == res) { zw = callocobject(); erg += copy(a,zw); erg += young_tafel(zw,res,ct,kt); erg += freeall(zw); goto endr_ende; } dim = numberofpart_i(a); erg += m_ilih_nm(dim,dim,res); if (ct == NULL) { hct = callocobject(); erg += chartafel(a,hct); } else hct = ct; if (kt == NULL) { hkt = callocobject(); erg += kostka_tafel(a,hkt); } else hkt = kt; /* hct und hkt zeigen nun auf charactertafel und kostkatafel */ /* um den youngcharacter zu berechnen sind nur mehr multiplikation von zeilen und spalten noetig */ zw = callocobject(); for (i=(INT)0; i= (INT)100) return error("specht_powersum:a too big"); if (speicher == NULL) { speicher = callocobject();m_il_v((INT)100,speicher); } if (not EMPTYP(S_V_I(speicher, S_I_I(a)))) return copy(S_V_I(speicher, S_I_I(a)),b); /* not yet computed */ c = callocobject(); d = callocobject(); g=callocobject(); e = callocobject(); f = callocobject(); if (not EMPTYP(b)) freeself(b); first_part_EXPONENT(a,c); do { b_skn_po(callocobject(),callocobject(),NULL,d); m_il_v(S_PA_LI(c),S_PO_S(d)); for (j=(INT)0;j(INT)0) unten=mitte+(INT)1; else oben=mitte-(INT)1; if ( oben < unten ) { fprintln(stderr,d); fprintln(stderr,h); error("characteristik_to_symchar:part not found"); } goto aaa; aab: /* part gefunden */ /* i = indexofpart(c); */ copy(S_PO_K(z), S_SC_WI(b,i)); for (j=(INT)0;j= S_PA_LI(c) ) m_i_i((INT)0,S_PO_SI(d,j)); else m_i_i(S_PA_II(c,j), S_PO_SI(d,j) ); /* now the exponents of the monom are ok */ copy(S_SC_WI(a,i) , S_PO_K(d) ); for (j=(INT)0;j (INT)0) zeigerb=S_S_N(zeigerb); }; ENDR("schnitt_schur"); } INT einsp_symfunc(p) OP p; /* return TRUE if constant and coeff is eins */ /* AK 181103 */ { OP z; FORALL(z,p,{ if (S_PA_LI(S_MO_S(z)) != 0) { if (not NULLP(S_MO_K(z))) return FALSE; } else { if (not EINSP(S_MO_K(z))) return FALSE; } }); return TRUE; } INT tex_schur(poly) OP poly; /* AK 101187 */ /* zur ausgabe eines Schurpolynoms */ /* AK 110789 V1.0 */ /* AK 181289 V1.1 */ /* AK 070291 V1.2 prints to texout */ /* AK 200891 V1.3 */ /* AK 021199 works for SCHUR,MONOMIAL,HOMSYM,ELMSYM,POWSYM */ { OP zeiger = poly; fprintf(texout,"\\ "); if (EMPTYP(poly)) return(OK); while (zeiger != NULL) { if (not einsp (S_S_K(zeiger))) /* der koeffizient wird nur geschrieben wenn er ungleich 1 ist */ if (listp(S_S_K(zeiger))) { /* AK 130397 */ fprintf(texout,"("); tex(S_S_K(zeiger)); fprintf(texout,")"); } else { tex(S_S_K(zeiger)); } if (S_O_K(zeiger) == SCHUR) fprintf(texout,"\\ $S_{ "); else if (S_O_K(zeiger) == MONOMIAL) fprintf(texout,"\\ $m_{ "); else if (S_O_K(zeiger) == HOM_SYM) fprintf(texout,"\\ $h_{ "); else if (S_O_K(zeiger) == POW_SYM) fprintf(texout,"\\ $p_{ "); else if (S_O_K(zeiger) == ELM_SYM) fprintf(texout,"\\ $e_{ "); fprint(texout,S_S_S(zeiger)); fprintf(texout," } $\\ "); zeiger = S_S_N(zeiger); if (zeiger != NULL) fprintf(texout," $+$ "); texposition += 15; if (texposition >tex_row_length) { fprintf(texout,"\n"); texposition = 0; } }; fprintf(texout,"\\ "); texposition += 3; return(OK); } INT compute_skewschur_with_alphabet_det(a,b,c) OP a,b,c; /* skewschurpolyomial with det */ /* AK 090790 V1.1 */ /* AK 250291 V1.2 */ /* AK 200891 V1.3 */ { INT erg = OK,i,j,gli,kli; OP d,h; CTO(SKEWPARTITION,"compute_skewschur_with_alphabet_det",a); CTO(INTEGER,"compute_skewschur_with_alphabet_det",b); d = callocobject(); h = callocobject(); gli = S_SPA_GLI(a); kli = S_SPA_KLI(a); /* alt gli */ erg += m_ilih_m(gli,gli,d); for (i=(INT)0; i= (gli - kli) ) m_i_i(S_SPA_GII(a,j)+j-i- S_SPA_KII(a,i-gli+kli) ,h); else m_i_i(S_SPA_GII(a,j)+j-i,h); erg += compute_complete_with_alphabet(h,b,S_M_IJ(d,i,j)); } erg += det_mat_imm(d,c); erg += freeall(d); erg += freeall(h); /* AK 160893 */ ENDR("compute_skewschur_with_alphabet_det"); } INT compute_schur_with_alphabet_det(a,b,c) OP a,b,c; /* schurpolyomial with det */ /* AK 090790 V1.1 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(PARTITION,"compute_schur_with_alphabet_det(1)",a); CTO(INTEGER,"compute_schur_with_alphabet_det(2)",b); CE3(a,b,c,compute_schur_with_alphabet_det); { OP d,h; INT i,j; d = callocobject(); h = callocobject(); erg += m_ilih_m(S_PA_LI(a),S_PA_LI(a),d); for (i=(INT)0; i pain) { pain = i; pa = z; } z = S_PO_N(z); } /* pain ist index der lex kleinsten partition pa der zugehoerige POLYNOM zeiger */ erg += m_v_ps(S_PO_S(pa),d); erg += copy(S_PO_K(pa),S_S_K(d)); erg += compute_power_with_alphabet( S_S_S(d),S_V_L(S_PO_S(pa)),e); z = e; while (z != NULL) { if (EQ(S_PO_S(z),S_PO_S(pa))) /* find coeff of the leading monom */ { f = callocobject(); erg += copy(S_PO_K(z),f); erg += invers_apply(f); MULT_APPLY(f,e); break; } z = S_PO_N(z); } erg += mult_apply(S_PO_K(pa),e); erg += sub(c,e,c); erg += mult_apply(f,d); /* AK 020394 */ erg += freeall(f); insert(d,b,NULL,NULL); } FREEALL2(e,c); ENDR("t_POLYNOM_POWER"); } INT t_POLYNOM_SCHUR(a,b) OP a,b; /* assumes a is symmetric */ /* AK 020394 */ { OP c; INT erg = OK; CTO(POLYNOM,"t_POLYNOM_SCHUR(1)",a); CE2(a,b,t_POLYNOM_SCHUR); if (consp_polynom(a)) { erg += m_scalar_schur(S_PO_K(a),b); goto endr_ende; } init(SCHUR,b); /* AK 080502 */ c = callocobject(); erg += t_POLYNOM_POWER(a,c); erg += t_POWSYM_SCHUR(c,b); erg += freeall(c); ENDR("t_POLYNOM_SCHUR"); } INT t_POLYNOM_ELMSYM(a,b) OP a,b; /* assumes a is symmetric */ /* AK 120995 faster version */ /* AK 240603 a,b may be equal */ { OP c,d,e,f,g; INT erg = OK; CTO(POLYNOM,"t_POLYNOM_ELMSYM(1)",a); CE2(a,b,t_POLYNOM_ELMSYM); erg += init(ELMSYM,b); if (NULLP(a)) goto ee; d = callocobject(); e = callocobject(); f = callocobject(); erg += numberofvariables(a,d); erg += copy(a,f); while (not NULLP(f)) { c = callocobject(); g = callocobject(); erg += m_v_pa(S_PO_S(f),c); erg += conjugate(c,c); erg += compute_elmsym_with_alphabet(c,d,e); erg += b_skn_e(c,callocobject(),NULL,g); erg += copy(S_PO_K(f),S_S_K(g)); insert(g,b,NULL,NULL); erg += mult_apply(S_PO_K(f),e); erg += sub(f,e,f); } FREEALL(d); FREEALL(e); FREEALL(f); ee: ENDR("t_POLYNOM_ELMSYM"); } static INT c_m_w_a_vp(a,b,c) OP a,b,c; /* AK 200891 V1.3 */ { OP e,f,g; INT erg = OK,i; e = CALLOCOBJECT(); erg += first_permutation(b,e); f = CALLOCOBJECT(); m_l_v(b,f); for (i=(INT)0;i S_I_I(l)) { erg += init(POLYNOM,result); goto ende; } zw = CALLOCOBJECT(); erg += m_il_nv(S_I_I(l),zw); for (i=0;il_next = b; return(OK); } INT test_schur() /* AK 181289 V1.1 */ /* AK 020791 V1.2 */ /* AK 200891 V1.3 */ { OP a = callocobject(); OP b = callocobject(); OP c = callocobject(); printeingabe("test_schur:scan(a)"); scan(SCHUR,a); println(a); printeingabe("test_schur:copy(a,b)"); copy(a,b); println(b); printeingabe("test_schur:add(a,b,b)"); add(a,b,b); println(b); printeingabe("test_schur:mult(a,b,b)"); mult(a,b,b); println(b); printeingabe("test_schur:addinvers(b,a)"); addinvers(b,a); println(a); printeingabe("test_schur:mult_apply(b,a)"); mult_apply(b,a); println(a); freeall(a); freeall(b); freeall(c); return(OK); } INT comp_colex_schurmonom(a,b) OP a,b; /* AK 091189 */ /* AK V1.1 201189 */ /* AK 200891 V1.3 */ { INT erg = OK; CTO(MONOM,"comp_colex_schurmonom",a); CTO(MONOM,"comp_colex_schurmonom",b); return(comp_colex_part(S_MO_S(a),S_MO_S(b))); ENDR("comp_colex_schurmonom"); } INT comp_colex_part(a,b) OP a,b; /* a,b partitions colex order */ /* AK V1.1 151189 */ /* AK 200891 V1.3 */ { INT i = S_PA_LI(a)-(INT)1; INT j = S_PA_LI(b)-(INT)1; INT erg; if (S_O_K(a) != PARTITION) error("comp_colex_part:kind != PARTITION"); if (S_O_K(b) != PARTITION) error("comp_colex_part:kind != PARTITION"); for (;(i >= (INT)0) || (j>=(INT)0); i--,j--) { if (i<(INT)0) return((INT)1); if (j<(INT)0) return((INT)-1); erg = S_PA_II(a,i) - S_PA_II(b,j); if (erg <(INT)0) return((INT)1); if (erg >(INT)0) return((INT)-1); } return((INT)0); } INT hall_littlewood_tafel(a,b) OP a,b; /* AK 191289 a ist grad der sn b wird tafel */ /* AK 201289 V1.1 */ /* AK 200891 V1.3 */ { INT i,j; OP c = callocobject(); OP d = callocobject(); OP z,zz; INT erg = OK; CTO(INTEGER,"hall_littlewood_tafel",a); erg += makevectorofpart(a,c); erg += m_ilih_nm(S_V_LI(c),S_V_LI(c),b); for (i=(INT)0;i(INT)0) break; /* noch nach links schieben */ for (j=i;j= (k-i) ) { OP d = callocobject(); OP e = callocobject(); tt = (INT)1; copy(zz,d); M_I_I(S_PA_II(zzz,i)-k,S_PA_I(S_MO_S(d),i)); M_I_I(S_PA_II(zzz,j)+k,S_PA_I(S_MO_S(d),j)); b_skn_po(callocobject(),callocobject(),NULL,e); m_il_v((INT)1,S_PO_S(e)); M_I_I(k,S_PO_SI(e,(INT)0)); M_I_I((INT)1,S_PO_K(e)); /* e = t^k */ mult(e,S_MO_K(d),S_MO_K(d)); insert(d,b,add_koeff,comp_monomvector_monomvector); /* add(d,b,b);*/ freeall(e); } z = S_L_N(z); } if (tt == (INT)0) break; /* ende */ } freeall(sp); return(OK); } INT tex_hall_littlewood(a) OP a; /* AK 191289 tex ausgabe */ /* AK 200891 V1.3 */ { return tex(a); } INT hall_littlewood(a,b) OP a,b; /* AK 221289 V1.1 die zweite methode, siehe morris 1963 */ /* Math. Zeit 81 112-123 (1963) */ /* AK 200891 V1.3 */ { OP c,d,e,ff,g,z; INT erg = OK; /* AK 180893 */ INT i; CE2(a,b,hall_littlewood); CTO(PARTITION,"hall_littlewood(1)",a); if (S_PA_LI(a) == (INT)1) { erg += b_skn_s(callocobject(),callocobject(),NULL,b); erg += copy(a,S_S_S(b)); erg += b_skn_po(callocobject(),callocobject(),NULL,S_S_K(b)); M_I_I((INT)1,S_PO_K(S_S_K(b))); erg += m_il_v((INT)1,S_PO_S(S_S_K(b))); M_I_I((INT)0,S_PO_SI(S_S_K(b),(INT)0)); goto hl_ende; } /* wenn die laenge groesser 1 ist */ erg += init(SCHUR,b); c = callocobject(); d = callocobject(); e = callocobject(); g = callocobject(); erg += copy_partition(a,c); erg += dec_partition(c); erg += hall_littlewood(c,d); erg += weight_partition(c,e); erg += copy(d,c); z = c; while (z != NULL) { erg += inc_partition(S_S_S(z)); M_I_I( S_PA_II(a,S_PA_LI(a)-(INT)1), S_S_SI(z,S_S_SLI(z)-(INT)1)); z = S_S_N(z); } ff = callocobject(); erg += reorder_hall_littlewood(c,ff); insert(ff,b,NULL,NULL); erg += copy(d,c); for (i=(INT)1;i<=S_I_I(e); i++) { erg += m_i_pa(e,g); M_I_I(i,S_PA_I(g,(INT)0)); z = c; /* c ist das ergebnis der rekursion */ erg += init(SCHUR,d); while (z != NULL) { ff = callocobject(); erg += part_part_skewschur(S_S_S(z),g,ff); if (not NULLP(ff)) { MULT_APPLY(S_S_K(z),ff); INSERT_LIST(ff,d,add_koeff,comp_monomschur); } else erg += freeall(ff); z = S_S_N(z); } /* d ist nun die liste mit den expansion der skewpartition */ z = d; /* nun noch die multiplikation mit t^i */ erg += b_skn_po(callocobject(),callocobject(),NULL,g); M_I_I((INT)1,S_PO_K(g)); erg += m_il_v((INT)1,S_PO_S(g)); M_I_I(i,S_PO_SI(g,(INT)0)); while (z != NULL) { erg += inc_partition(S_S_S(z)); M_I_I(S_PA_II(a,S_PA_LI(a)-(INT)1)+i, S_S_SI(z,S_S_SLI(z)-(INT)1)); erg += mult_apply(g,S_S_K(z)); z = S_S_N(z); } ff = callocobject(); erg += reorder_hall_littlewood(d,ff); erg += insert(ff,b,NULL,NULL); } erg += freeall(e); erg += freeall(d); erg += freeall(c); erg += freeall(g); hl_ende: ENDR("hall_littlewood"); } INT copy_monomial(a,b) OP a,b; /* AK 270901 */ { INT erg = OK; CTO(MONOMIAL,"copy_monomial(1)",a); erg += transformlist(a,b,copy_monom); ENDR("copy_monomial"); } INT copy_schur(a,b) OP a,b; /* AK 270901 */ { INT erg = OK; CTO(SCHUR,"copy_schur(1)",a); erg += transformlist(a,b,copy_monom); ENDR("copy_schur"); } INT copy_homsym(a,b) OP a,b; /* AK 270901 */ { INT erg = OK; CTO(HOMSYM,"copy_homsym(1)",a); erg += transformlist(a,b,copy_monom); ENDR("copy_homsym"); } INT copy_elmsym(a,b) OP a,b; /* AK 270901 */ { INT erg = OK; CTO(ELMSYM,"copy_elmsym(1)",a); erg += transformlist(a,b,copy_monom); ENDR("copy_elmsym"); } INT copy_powsym(a,b) OP a,b; /* AK 270901 */ { INT erg = OK; CTO(POWSYM,"copy_powsym(1)",a); erg += transformlist(a,b,copy_monom); ENDR("copy_powsym"); } INT add_apply_symfunc_symfunc(a,b) OP a,b; /* AK 200891 V1.3 */ { OP c = callocobject(); copy_polynom(a,c); return(insert(c,b,add_koeff,comp_monomvector_monomvector)); } INT add_apply_symfunc(a,b) OP a,b; /* result ist von typ b, falls beides sym func */ { OP c; INT erg = OK; if (S_O_K(a) == S_O_K(b)) erg += add_apply_symfunc_symfunc(a,b); else { c = CALLOCOBJECT(); SWAP(b,c); add(c,a,b); FREEALL(c); } ENDR("add_apply_symfunc"); } INT dimension_schur(a,b) OP a,b; /* AK 020890 V1.1 */ /* AK 200891 V1.3 */ /* AK 260198 V2.0 */ /* input: schur ( may be SCHUR or HASHTABLE ) output: dimension of corresponding representation of sn */ { OP z,res; INT erg = OK; CTTO(HASHTABLE,SCHUR,"dimension_schur(1)",a); CE2(a,b,dimension_schur); /* b is freed */ res = CALLOCOBJECT(); M_I_I(0,b); FORALL(z,a, { erg += dimension(S_MO_S(z),res); MULT_APPLY(S_MO_K(z),res); ADD_APPLY(res,b); } ); FREEALL(res); ENDR("dimension_schur"); } INT add_staircase_part(a,n,b) OP a,n,b; /* adds the vector 0,1,...,n-1 to the partition a */ /* AK 050990 V1.1 */ /* AK 200891 V1.3 */ { OP c = callocobject(); INT i,j; m_l_v(n,c); for (i=S_V_LI(c)-(INT)1,j=S_PA_LI(a)-(INT)1;i>=(INT)0;i--,j--) if (j>=(INT)0) M_I_I(S_PA_II(a,j)+i,S_V_I(c,i)); else M_I_I(i,S_V_I(c,i)); b_ks_pa(VECTOR,c,b); return OK; } INT mod_part(a,b,c) OP a,b,c; /* the single parts of partition a mod b gives c */ /* AK 050990 V1.1 */ /* AK 200891 V1.3 */ { INT i; if (a != c) copy(a,c); for (i=0;ib) , "m_int_int_qelm: para1 > para2"); erg += b_ks_pa(VECTOR,callocobject(),c); erg += m_il_v(2L,S_PA_S(c)); C_O_K(S_PA_S(c),INTEGERVECTOR); erg += m_i_i(a,S_PA_I(c,0)); erg += m_i_i(b,S_PA_I(c,1)); erg += m_part_qelm(c,d); erg += freeall(c); ENDR("m_int_int_qelm"); } INT m_part_qelm(a,b) OP a,b; /* AK 060995 */ /* computes q polynomial as elmsym */ { INT i,j; OP c,d,e; INT erg = OK; CTO(PARTITION,"m_part_qelm",a); if (S_PA_LI(a) == 1) { erg += m_int_qelm(S_PA_II(a,0),b); } else if (S_PA_LI(a) == 2) { c = callocobject(); erg += m_int_qelm(S_PA_II(a,0),c); d = callocobject(); erg += m_int_qelm(S_PA_II(a,1),d); erg += mult(c,d,b); e = callocobject(); for (i=1;i<=S_PA_II(a,0);i++) { erg += m_int_qelm(S_PA_II(a,0)-i,c); erg += m_int_qelm(S_PA_II(a,1)+i,d); erg += mult(c,d,e); erg += mult_apply(cons_zwei,e); if (i%2 == 1) erg += mult_apply(cons_negeins,e); erg += add_apply(e,b); } erg += freeall(c); erg += freeall(d); erg += freeall(e); } else if (S_PA_LI(a) %2 == 0) { c = callocobject(); erg += m_ilih_m(S_PA_LI(a), S_PA_LI(a),c); for (i=0;i0;i--) { M_I_I(w,S_V_I(outer,i)); w = w - S_V_II(a,i); M_I_I(w,S_V_I(inner,i-1)); } M_I_I(w,S_V_I(outer,i)); erg += m_v_pa(inner,inner); erg += m_v_pa(outer,outer); spa = callocobject(); erg += m_gk_spa(outer,inner,spa); erg += freeall(inner); erg += freeall(outer); erg += kostka_number_skewpartition(b,spa,c); erg += freeall(spa); ENDR("number_nat_matrices"); } INT t_ELMSYM_MONOMIAL(a,b) OP a,b; /* AK 270901 */ /* using multiplication e_I * m_0 -> \sum m_J */ /* fastest up to now */ { INT erg = OK; OP m; CTTTTO(HASHTABLE,INTEGER,PARTITION,ELMSYM,"t_ELMSYM_MONOMIAL",a); TCE2(a,b,t_ELMSYM_MONOMIAL,MONOMIAL); m=CALLOCOBJECT(); erg += first_partition(cons_null,m); erg += m_pa_mon(m,m); erg += mult_elmsym_monomial(a,m,b); FREEALL(m); ENDR("t_ELMSYM_MONOMIAL"); } static INT all_01_matrices_rek_160802(a,c,d,i,b) OP a,b,c,d; INT i; /* AK 160802 */ { INT erg=OK; if (i>=S_V_LI(a)) { INC(b); COPY(d,S_V_I(b,S_V_LI(b)-1)); } else { OP e; INT j; erg = ERROR; e = callocobject(); first_subset(S_V_L(c),S_V_I(a,i), e); do { for (j=0;j0;i--) { M_I_I(w,S_V_I(outer,i)); w = w - S_V_II(a,i); M_I_I(w,S_V_I(inner,i-1)); } M_I_I(w,S_V_I(outer,i)); erg += m_v_pa(inner,inner); erg += m_v_pa(outer,outer); spa = callocobject(); erg += m_gk_spa(outer,inner,spa); FREEALL(inner); FREEALL(outer); erg += conjugate(spa,spa); erg += kostka_number(b,spa,c); FREEALL(spa); } ENDR("number_01_matrices"); } INT t_SCHUR_SCHUR(a,b) OP a,b; { return copy(a,b); } INT t_ELMSYM_ELMSYM(a,b) OP a,b; { return copy(a,b); } INT t_POWSYM_POWSYM(a,b) OP a,b; { return copy(a,b); } INT t_HOMSYM_HOMSYM(a,b) OP a,b; { return copy(a,b); } INT t_MONOMIAL_MONOMIAL(a,b) OP a,b; { return copy(a,b); } #define CAST_SF(a,b,scalarf,partf,schurf,homsymf,powsymf,monomialf,elmsymf,t,t2)\ COP(t,a);\ COP(t2,b);\ switch(S_O_K(a)) \ {\ case INTEGER:\ case LONGINT:\ case FF:\ case CYCLOTOMIC:\ case SQ_RADICAL:\ case POLYNOM:\ case BRUCH: erg += scalarf(a,b); goto ende;\ case PARTITION: erg += partf(a,b); goto ende;\ case SCHUR: erg += schurf(a,b); goto ende;\ case HOMSYM: erg += homsymf(a,b); goto ende;\ case MONOMIAL: erg += monomialf(a,b); goto ende;\ case ELMSYM: erg += elmsymf(a,b); goto ende;\ case POWSYM: erg += powsymf(a,b); goto ende;\ default: erg += WTO(t,a); goto ende;\ }\ ende: #define CAST_APPLY_SF(a,scalarf,partf,schurf,homsymf,powsymf,monomialf,elmsymf,t)\ CAST_SF(a,a,scalarf,partf,schurf,homsymf,powsymf,monomialf,elmsymf,t,t) INT cast_apply_schur(a) OP a; /* AK 080102 */ { INT erg = OK; CAST_APPLY_SF(a,m_scalar_schur,m_pa_s,t_SCHUR_SCHUR,t_HOMSYM_SCHUR, t_POWSYM_SCHUR,t_MONOMIAL_SCHUR, t_ELMSYM_SCHUR, "cast_apply_schur(1)"); CTO(SCHUR,"cast_apply_schur(e1)",a); ENDR("cast_apply_schur"); } INT cast_apply_elmsym(a) OP a; /* AK 080102 */ { INT erg = OK; CAST_APPLY_SF(a,m_scalar_elmsym,m_pa_e,t_SCHUR_ELMSYM,t_HOMSYM_ELMSYM, t_POWSYM_ELMSYM,t_MONOMIAL_ELMSYM, t_ELMSYM_ELMSYM, "cast_apply_elmsym(1)"); CTO(ELMSYM,"cast_apply_elmsym(e1)",a); ENDR("cast_apply_elmsym"); } INT cast_apply_homsym(a) OP a; /* AK 080102 */ { INT erg = OK; CAST_APPLY_SF(a,m_scalar_homsym,m_pa_h,t_SCHUR_HOMSYM,t_HOMSYM_HOMSYM, t_POWSYM_HOMSYM,t_MONOMIAL_HOMSYM, t_ELMSYM_HOMSYM, "cast_apply_homsym(1)"); CTO(HOMSYM,"cast_apply_homsym(e1)",a); ENDR("cast_apply_homsym"); } INT cast_apply_powsym(a) OP a; /* AK 080102 */ { INT erg = OK; CAST_APPLY_SF(a,m_scalar_powsym,m_pa_ps,t_SCHUR_POWSYM,t_HOMSYM_POWSYM, t_POWSYM_POWSYM,t_MONOMIAL_POWSYM, t_ELMSYM_POWSYM, "cast_apply_powsym(1)"); CTO(POWSYM,"cast_apply_powsym(e1)",a); ENDR("cast_apply_powsym"); } INT cast_apply_monomial(a) OP a; /* AK 080102 */ { INT erg = OK; CAST_APPLY_SF(a,m_scalar_monomial,m_pa_mon,t_SCHUR_MONOMIAL,t_HOMSYM_MONOMIAL, t_POWSYM_MONOMIAL,t_MONOMIAL_MONOMIAL, t_ELMSYM_MONOMIAL, "cast_apply_monomial(1)"); CTO(MONOMIAL,"cast_apply_monomial(e1)",a); ENDR("cast_apply_monomial"); } INT cast_schur(a,b) OP a,b; /* AK 080102 */ { INT erg = OK; CAST_SF(a,b,m_scalar_schur,m_pa_s,t_SCHUR_SCHUR,t_HOMSYM_SCHUR, t_POWSYM_SCHUR,t_MONOMIAL_SCHUR, t_ELMSYM_SCHUR, "cast_schur(1)","cast_schur(2)"); CTO(SCHUR,"cast_schur(e2)",b); ENDR("cast_schur"); } INT cast_elmsym(a,b) OP a,b; /* AK 080102 */ { INT erg = OK; CAST_SF(a,b,m_scalar_elmsym,m_pa_e,t_SCHUR_ELMSYM,t_HOMSYM_ELMSYM, t_POWSYM_ELMSYM,t_MONOMIAL_ELMSYM, t_ELMSYM_ELMSYM, "cast_elmsym(1)","cast_elmsym(2)"); CTO(ELMSYM,"cast_elmsym(e2)",b); ENDR("cast_elmsym"); } INT cast_homsym(a,b) OP a,b; /* AK 080102 */ { INT erg = OK; CAST_SF(a,b,m_scalar_homsym,m_pa_h,t_SCHUR_HOMSYM,t_HOMSYM_HOMSYM, t_POWSYM_HOMSYM,t_MONOMIAL_HOMSYM, t_ELMSYM_HOMSYM, "cast_homsym(1)","cast_homsym(2)"); CTO(HOMSYM,"cast_homsym(e2)",b); ENDR("cast_homsym"); } INT cast_powsym(a,b) OP a,b; /* AK 080102 */ { INT erg = OK; CAST_SF(a,b,m_scalar_powsym,m_pa_ps,t_SCHUR_POWSYM,t_HOMSYM_POWSYM, t_POWSYM_POWSYM,t_MONOMIAL_POWSYM, t_ELMSYM_POWSYM, "cast_powsym(1)", "cast_powsym(2)"); CTO(POWSYM,"cast_powsym(e2)",b); ENDR("cast_powsym"); } INT cast_monomial(a,b) OP a,b; /* AK 080102 */ { INT erg = OK; CAST_SF(a,b,m_scalar_monomial,m_pa_mon,t_SCHUR_MONOMIAL,t_HOMSYM_MONOMIAL, t_POWSYM_MONOMIAL,t_MONOMIAL_MONOMIAL, t_ELMSYM_MONOMIAL, "cast_monomial(1)","cast_monomial(2)"); CTO(MONOMIAL,"cast_monomial(e2)",b); ENDR("cast_monomial"); } INT frobenius_elmsym(a,b) OP a,b; /* result is n basis of elmsym */ { INT erg = OK; OP z; CTTTO(PARTITION,ELMSYM,HASHTABLE,"frobenius_elmsym(1)",a); CTTTO(EMPTY,ELMSYM,HASHTABLE,"frobenius_elmsym(2)",b); if (S_O_K(b) == EMPTY) erg += init(ELMSYM,b); if (S_O_K(a) == PARTITION) { erg += t_HOMSYM_ELMSYM(a,b); goto ende; } else if (S_O_K(a) == HASHTABLE) { erg += t_HOMSYM_ELMSYM(a,b); goto ende; } else { /* ELMSYM */ z = a; while (z != NULL) { C_O_K(z,HOMSYM); z = S_L_N(z); } erg += t_HOMSYM_ELMSYM(a,b); z = a; while (z != NULL) { C_O_K(z,HOMSYM); z = S_L_N(z); } goto ende; } ende: ENDR("frobenius_elmsym"); } INT frobenius_schur(a,b) OP a,b; /* result is n basis of schur */ { INT erg = OK; CTTTO(PARTITION,SCHUR,HASHTABLE,"frobenius_schur(1)",a); CTTTO(EMPTY,SCHUR,HASHTABLE,"frobenius_schur(2)",b); if (S_O_K(b) == EMPTY) erg += init(SCHUR,b); if (S_O_K(a) == PARTITION) { OP d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); M_I_I(1,S_MO_K(d)); erg += conjugate_partition(a,S_MO_S(d)); INSERT_SCHURMONOM_(d,b); goto ende; } else { /* SCHUR */ /* HASHTABLE */ erg += conjugate_schur(a,b); goto ende; } ende: ENDR("frobenius_schur"); } INT frobenius_powsym(a,b) OP a,b; /* result is n basis of powsym */ { INT erg = OK; INT sig,i; OP z,d; CTTTO(PARTITION,POWSYM,HASHTABLE,"frobenius_powsym(1)",a); CTTTO(EMPTY,POWSYM,HASHTABLE,"frobenius_powsym(2)",b); if (S_O_K(b) == EMPTY) erg += init(POWSYM,b); if (S_O_K(a) == PARTITION) { d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); for (sig=1,i=0;i = delta_I,J */ { OP za,zb; OP d; INT res; INT erg = OK; CTTO(PARTITION,SCHUR,"scalarproduct_schur_schur(1)",a); CTTO(PARTITION,SCHUR,"scalarproduct_schur_schur(2)",b); CTO(EMPTY,"scalarproduct_schur_schur(3)",c); if (S_O_K(a) == PARTITION) { d = CALLOCOBJECT(); erg += m_pa_s(a,d); erg += scalarproduct_schur_schur(d,b,c); FREEALL(d); goto ende; } if (S_O_K(b) == PARTITION) { d = CALLOCOBJECT(); erg += m_pa_s(b,d); erg += scalarproduct_schur_schur(a,d,c); FREEALL(d); goto ende; } d = CALLOCOBJECT(); za = a; zb = b; M_I_I((INT)0,c); do { if (za == NULL) goto preende; if (zb == NULL) goto preende; res = comp(S_S_S(za),S_S_S(zb)); if (res == (INT)0) { FREESELF(d); MULT(S_S_K(za),S_S_K(zb),d); ADD_APPLY(d,c); za = S_S_N(za); zb = S_S_N(zb); } else if (res < (INT)0) { za = S_S_N(za); } else { zb = S_S_N(zb); } } while(1); preende: FREEALL(d); ende: ENDR("scalarproduct_schur_schur"); } INT scalarproduct_powsym_powsym(a,b,c) OP a,b,c; /* = ordcen() delta_I,J */ { OP za,zb; OP d,e; INT res; INT erg = OK; CTTO(PARTITION,POWSYM,"scalarproduct_powsym_powsym(1)",a); CTTO(PARTITION,POWSYM,"scalarproduct_powsym_powsym(2)",b); CTO(EMPTY,"scalarproduct_powsym_powsym(3)",c); if (S_O_K(a) == PARTITION) { d = CALLOCOBJECT(); erg += m_pa_ps(a,d); erg += scalarproduct_powsym_powsym(d,b,c); FREEALL(d); goto ende; } if (S_O_K(b) == PARTITION) { d = CALLOCOBJECT(); erg += m_pa_ps(b,d); erg += scalarproduct_powsym_powsym(a,d,c); FREEALL(d); goto ende; } d = CALLOCOBJECT(); e = CALLOCOBJECT(); za = a; zb = b; M_I_I((INT)0,c); do { if (za == NULL) goto preende; if (zb == NULL) goto preende; res = comp(S_S_S(za),S_S_S(zb)); if (res == (INT)0) { FREESELF(d); MULT(S_S_K(za),S_S_K(zb),d); ordcen(S_S_S(za),e); MULT_APPLY(e,d); ADD_APPLY(d,c); za = S_S_N(za); zb = S_S_N(zb); } else if (res < (INT)0) { za = S_S_N(za); } else { zb = S_S_N(zb); } } while(1); preende: FREEALL(d); FREEALL(e); ende: ENDR("scalarproduct_powsym_powsym"); } INT scalarproduct_homsym_monomial(a,b,c) OP a,b,c; /* = delta_I,J */ { OP za,zb; OP d; INT res; INT erg = OK; CTTO(PARTITION,HOMSYM,"scalarproduct_homsym_monomial(1)",a); CTTO(PARTITION,MONOMIAL,"scalarproduct_homsym_monomial(2)",b); CTO(EMPTY,"scalarproduct_homsym_monomial(3)",c); if (S_O_K(a) == PARTITION) { d = CALLOCOBJECT(); erg += m_pa_h(a,d); erg += scalarproduct_homsym_monomial(d,b,c); FREEALL(d); goto ende; } if (S_O_K(b) == PARTITION) { d = CALLOCOBJECT(); erg += m_pa_mon(b,d); erg += scalarproduct_homsym_monomial(a,d,c); FREEALL(d); goto ende; } d = CALLOCOBJECT(); za = a; zb = b; M_I_I((INT)0,c); do { if (za == NULL) goto preende; if (zb == NULL) goto preende; res = comp(S_S_S(za),S_S_S(zb)); if (res == (INT)0) { FREESELF(d); MULT(S_S_K(za),S_S_K(zb),d); ADD_APPLY(d,c); za = S_S_N(za); zb = S_S_N(zb); } else if (res < (INT)0) { za = S_S_N(za); } else { zb = S_S_N(zb); } } while(1); preende: FREEALL(d); ende: ENDR("scalarproduct_homsym_monomial"); } INT scalarproduct_schur(a,b,c) OP a,b,c; { INT erg = OK; CTO(SCHUR,"scalarproduct_schur(1)",a); CTO(EMPTY,"scalarproduct_schur(3)",c); if (S_O_K(b) == SCHUR) { erg += scalarproduct_schur_schur(a,b,c); } else if (S_O_K(b) == HOMSYM) { OP d; d = CALLOCOBJECT(); t_HOMSYM_SCHUR(b,d); erg += scalarproduct_schur_schur(a,d,c); FREEALL(d); } else if (S_O_K(b) == ELMSYM) { OP d; d = CALLOCOBJECT(); t_ELMSYM_SCHUR(b,d); erg += scalarproduct_schur_schur(a,d,c); FREEALL(d); } else if (S_O_K(b) == POWSYM) { OP d; d = CALLOCOBJECT(); t_POWSYM_SCHUR(b,d); erg += scalarproduct_schur_schur(a,d,c); FREEALL(d); } else if (S_O_K(b) == MONOMIAL) { OP d; d = CALLOCOBJECT(); t_MONOMIAL_SCHUR(b,d); erg += scalarproduct_schur_schur(a,d,c); FREEALL(d); } else WTO("scalarproduct_schur(2)",b); ENDR("scalarproduct_schur"); } INT scalarproduct_powsym(a,b,c) OP a,b,c; { INT erg = OK; CTO(POWSYM,"scalarproduct_powsym(1)",a); CTO(EMPTY,"scalarproduct_powsym(3)",c); if (S_O_K(b) == POWSYM) { erg += scalarproduct_powsym_powsym(a,b,c); goto sppende; } else if (S_O_K(b) == HOMSYM) { OP d; d = CALLOCOBJECT(); t_HOMSYM_POWSYM(b,d); erg += scalarproduct_powsym_powsym(a,d,c); FREEALL(d); goto sppende; } else if (S_O_K(b) == ELMSYM) { OP d; d = CALLOCOBJECT(); t_ELMSYM_POWSYM(b,d); erg += scalarproduct_powsym_powsym(a,d,c); FREEALL(d); goto sppende; } else if (S_O_K(b) == SCHUR) { OP d; d = CALLOCOBJECT(); t_SCHUR_POWSYM(b,d); erg += scalarproduct_powsym_powsym(a,d,c); FREEALL(d); goto sppende; } else if (S_O_K(b) == MONOMIAL) { OP d; d = CALLOCOBJECT(); t_MONOMIAL_POWSYM(b,d); erg += scalarproduct_powsym_powsym(a,d,c); FREEALL(d); goto sppende; } else WTO("scalarproduct_powsym(2)",b); sppende: ENDR("scalarproduct_powsym"); } INT scalarproduct_homsym(a,b,c) OP a,b,c; { INT erg = OK; CTO(HOMSYM,"scalarproduct_homsym(1)",a); CTO(EMPTY,"scalarproduct_homsym(3)",c); if (S_O_K(b) == MONOMIAL) { erg += scalarproduct_homsym_monomial(a,b,c); } else if (S_O_K(b) == HOMSYM) { OP d; d = CALLOCOBJECT(); t_HOMSYM_MONOMIAL(b,d); erg += scalarproduct_homsym_monomial(a,d,c); FREEALL(d); } else if (S_O_K(b) == ELMSYM) { OP d; d = CALLOCOBJECT(); t_ELMSYM_MONOMIAL(b,d); erg += scalarproduct_homsym_monomial(a,d,c); FREEALL(d); } else if (S_O_K(b) == POWSYM) { OP d; d = CALLOCOBJECT(); t_POWSYM_MONOMIAL(b,d); erg += scalarproduct_homsym_monomial(a,d,c); FREEALL(d); } else if (S_O_K(b) == SCHUR) { OP d; d = CALLOCOBJECT(); t_SCHUR_MONOMIAL(b,d); erg += scalarproduct_homsym_monomial(a,d,c); FREEALL(d); } else WTO("scalarproduct_homsym(2)",b); ENDR("scalarproduct_homsym"); } INT scalarproduct_monomial(a,b,c) OP a,b,c; { INT erg = OK; CTO(MONOMIAL,"scalarproduct_monomial(1)",a); CTO(EMPTY,"scalarproduct_monomial(3)",c); if (S_O_K(b) == HOMSYM) { erg += scalarproduct_homsym_monomial(b,a,c); } else if (S_O_K(b) == MONOMIAL) { OP d; d = CALLOCOBJECT(); t_MONOMIAL_HOMSYM(b,d); erg += scalarproduct_homsym_monomial(d,a,c); FREEALL(d); } else if (S_O_K(b) == ELMSYM) { OP d; d = CALLOCOBJECT(); t_ELMSYM_HOMSYM(b,d); erg += scalarproduct_homsym_monomial(d,a,c); FREEALL(d); } else if (S_O_K(b) == POWSYM) { OP d; d = CALLOCOBJECT(); t_POWSYM_HOMSYM(b,d); erg += scalarproduct_homsym_monomial(d,a,c); FREEALL(d); } else if (S_O_K(b) == SCHUR) { OP d; d = CALLOCOBJECT(); t_SCHUR_HOMSYM(b,d); erg += scalarproduct_homsym_monomial(d,a,c); FREEALL(d); } else WTO("scalarproduct_monomial(2)",b); ENDR("scalarproduct_monomial"); } INT scalarproduct_elmsym(a,b,c) OP a,b,c; { INT erg = OK; OP e; CTO(ELMSYM,"scalarproduct_elmsym(1)",a); CTO(EMPTY,"scalarproduct_elmsym(3)",c); e = CALLOCOBJECT(); if (S_O_K(b) == HOMSYM) { OP d; t_ELMSYM_SCHUR(a,e); d = CALLOCOBJECT(); t_HOMSYM_SCHUR(b,d); erg += scalarproduct_schur_schur(d,e,c); FREEALL(d); } else if (S_O_K(b) == MONOMIAL) { OP d; t_ELMSYM_SCHUR(a,e); d = CALLOCOBJECT(); t_MONOMIAL_SCHUR(b,d); erg += scalarproduct_schur_schur(d,e,c); FREEALL(d); } else if (S_O_K(b) == ELMSYM) { OP d; t_ELMSYM_SCHUR(a,e); d = CALLOCOBJECT(); t_ELMSYM_SCHUR(b,d); erg += scalarproduct_schur_schur(d,e,c); FREEALL(d); } else if (S_O_K(b) == POWSYM) { OP d; t_ELMSYM_SCHUR(a,e); d = CALLOCOBJECT(); t_POWSYM_SCHUR(b,d); erg += scalarproduct_schur_schur(d,e,c); FREEALL(d); } else if (S_O_K(b) == SCHUR) { t_ELMSYM_SCHUR(a,e); erg += scalarproduct_schur_schur(b,e,c); } else WTO("scalarproduct_elmsym(2)",b); FREEALL(e); ENDR("scalarproduct_elmsym"); } static INT co_1611(a,b) OP a,b; /* transform polynom to vector of monoms */ { OP z; INT i=0,j; z = a; while (z != NULL) { i += S_PO_KI(z); z = S_PO_N(z); } m_il_v(i,b); z = a; for (i=0;ib) error("::"); erg += b_ks_pa(VECTOR,callocobject(),c); erg += m_il_v(2L,S_PA_S(c)); erg += m_i_i(a,S_PA_I(c,0)); erg += m_i_i(b,S_PA_I(c,1)); erg += m_part_Qschur(c,d); erg += freeall(c); ENDR("m_int_int_qelm"); } INT m_part_Qschur(a,b) OP a,b; /* AK 291295 */ /* computes Q schur polynomial as monomial sym */ { INT i,j; OP c,d,e; INT erg = OK; CTO(PARTITION,"m_part_Qschur",a); if (S_PA_LI(a) == 1) { erg += m_int_Qelm(S_PA_II(a,0),b); } else if (S_PA_LI(a) == 2) { c = callocobject(); erg += m_int_Qelm(S_PA_II(a,0),c); d = callocobject(); erg += m_int_Qelm(S_PA_II(a,1),d); erg += mult(c,d,b); e = callocobject(); for (i=1;i<=S_PA_II(a,0);i++) { erg += m_int_Qelm(S_PA_II(a,0)-i,c); erg += m_int_Qelm(S_PA_II(a,1)+i,d); erg += mult(c,d,e); erg += mult_apply(cons_zwei,e); if (i%2 == 1) erg += mult_apply(cons_negeins,e); erg += add_apply(e,b); } erg += freeall(c); erg += freeall(d); erg += freeall(e); } else if (S_PA_LI(a) %2 == 0) { c = callocobject(); erg += m_ilih_m(S_PA_LI(a), S_PA_LI(a),c); for (i=0;i bi) { M_I_I(ai,dd); MULT_APPLY_INTEGER(dd,c); ai--; M_I_I(j,dd); MULT_APPLY_INTEGER(dd,ee); j++; } ganzdiv_apply(ee,c); copy(c,z); } } static dec_step(a,b,c) OP a,b,c; { INT erg = OK; CE3(a,b,c,dec_step); if (S_O_K(b) == VECTOR || S_O_K(b) == INTEGERVECTOR) { INT i; dec_step_2(a,S_V_I(b,0),c); for (i=1;i0) j++; /* j ist die anzahl der teile != 0 */ anzahl = callocobject(); indexvec = callocobject(); M_I_I(j,anzahl); b_l_v(anzahl,indexvec); for (i=0,j=0;i0) { M_I_I(i,S_V_I(indexvec,j)); j++; } /* der j-te eintrag in indexvec ist der index des j-ten eintrag != 0 in a */ first_composition(b,S_V_L(indexvec),d); do { for (i=0;i 0) M_I_I(S_PA_II(S_MO_S(e),S_V_II(indexvec,i)-1)+S_V_II(d,i), S_PA_I(S_MO_S(e),S_V_II(indexvec,i)-1)); if (S_PA_II(a,S_V_II(indexvec,i)) != S_V_II(d,i) ) { my_binom(S_PA_I(a,S_V_II(indexvec,i)), S_V_I(d,i), g); mult_apply(g,S_MO_K(e)); } } insert(e,c,add_koeff,my_comp); next_step: ; } while(next_apply(d)); t_BINTREE_SCHUR(c,c); println(c); freeall(d); freeall(indexvec); freeall(g); } #endif #ifdef UNDEF INT class_mult_schurmonom(OP a, OP b, OP c) { INT erg = OK; OP e,d; CE3(a,b,c,class_mult_schurmonom); CTO(MONOM,"class_mult_schurmonom(1)",a); CTO(MONOM,"class_mult_schurmonom",b); CTO(PARTITION,"class_mult_schurmonom-selfpart",S_MO_S(a)); CTO(PARTITION,"class_mult_schurmonom-selfpart",S_MO_S(b)); e = callocobject(); d = callocobject(); erg += weight(S_MO_S(a),e); erg += weight(S_MO_S(b),d); if (neq(e,d)) { erg += error("class_mult_schurmonom:different weights of partitions"); goto ee; } C2R(S_MO_S(a),S_MO_S(b),"class_mult_part",c); erg += init(SCHUR,c); erg += first_partition(e,d); do { erg += c_ijk_sn(S_MO_S(a),S_MO_S(b),d,e); if (not NULLP(e)) { OP f,g; f = callocobject(); g = callocobject(); erg += copy_partition(d,g); erg += b_skn_s(g,callocobject(),NULL,f); erg += mult(S_MO_K(a),S_MO_K(b),S_S_K(f)); erg += mult_apply(e,S_S_K(f)); insert(f,c,NULL,NULL); } } while(next(d,d)); S2R(S_MO_S(a),S_MO_S(b),"class_mult_part",c); ee: erg += freeall(e); erg += freeall(d); ENDR("class_mult_schurmonom"); } #endif INT class_mult_schur(OP a, OP b, OP c) { #ifdef UNDEF INT erg = OK; OP z1,z2; CTO(SCHUR,"class_mult_schur",a); CTO(SCHUR,"class_mult_schur",b); CE3(a,b,c,class_mult_schur); erg += init(SCHUR,c); z1 = a; while (z1 != NULL) { z2 = b; while (z2 != NULL) { OP e; e = callocobject(); if (le(S_S_S(z1), S_S_S(z2))) erg += class_mult_schurmonom(S_L_S(z1),S_L_S(z2),e); else erg += class_mult_schurmonom(S_L_S(z2),S_L_S(z1),e); insert(e,c,NULL,NULL); z2 = S_S_N(z2); }; z1 = S_S_N(z1); } ENDR("class_mult_schur"); #endif return class_mult(a,b,c); } INT init_elmsym(a) OP a; { INT erg = OK; CTO(EMPTY,"init_elmsym",a); erg += b_sn_e(NULL,NULL,a); ENDR("init_elmsym"); } INT init_homsym(a) OP a; { INT erg = OK; CTO(EMPTY,"init_homsym",a); erg += b_sn_h(NULL,NULL,a); ENDR("init_homsym"); } INT init_powsym(a) OP a; { INT erg = OK; CTO(EMPTY,"init_powsym",a); erg += b_sn_ps(NULL,NULL,a); ENDR("init_powsym"); } INT init_schur(a) OP a; { INT erg = OK; CTO(EMPTY,"init_schur",a); erg += b_sn_s(NULL,NULL,a); ENDR("init_schur"); } INT init_monomial(a) OP a; { INT erg = OK; CTO(EMPTY,"init_monomial",a); erg += b_sn_mon(NULL,NULL,a); ENDR("init_monomial"); } INT conjugate_schur(a,b) OP a,b; /* AK 111001 */ { INT erg=OK,t=0; OP z; CTTO(HASHTABLE,SCHUR,"conjugate_schur(1)",a); CTTTO(EMPTY,SCHUR,HASHTABLE,"conjugate_schur(2)",b); if (S_O_K(b) == EMPTY) { init_hashtable(b); t=1; } FORALL(z,a,{ OP d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); COPY(S_MO_K(z),S_MO_K(d)); erg += conjugate_partition(S_MO_S(z),S_MO_S(d)); if (S_O_K(b) == SCHUR) insert_list(d,b,NULL,comp_monomschur); else insert_hashtable(d,b,NULL,NULL,hash_monompartition); } ); if (t==1) t_HASHTABLE_SCHUR(b,b); ENDR("conjugate_schur"); } INT conjugate_elmsym(a,b) OP a,b; /* AK 111001 */ { INT erg=OK,t=0; OP z; CTTO(HASHTABLE,ELMSYM,"conjugate_elmsym(1)",a); CTTTO(EMPTY,ELMSYM,HASHTABLE,"conjugate_elmsym(2)",b); if (S_O_K(b) == EMPTY) { init_hashtable(b); t=1; } FORALL(z,a,{ OP d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); COPY(S_MO_K(z),S_MO_K(d)); erg += conjugate_partition(S_MO_S(z),S_MO_S(d)); if (S_O_K(b) == ELMSYM) insert_list(d,b,NULL,comp_monomelmsym); else insert_hashtable(d,b,NULL,NULL,hash_monompartition); } ); if (t==1) t_HASHTABLE_ELMSYM(b,b); ENDR("conjugate_elmsym"); } INT conjugate_homsym(a,b) OP a,b; /* AK 111001 */ { INT erg=OK,t=0; OP z; CTTO(HASHTABLE,HOMSYM,"conjugate_homsym(1)",a); CTTTO(EMPTY,HOMSYM,HASHTABLE,"conjugate_homsym(2)",b); if (S_O_K(b) == EMPTY) { init_hashtable(b); t=1; } FORALL(z,a,{ OP d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); COPY(S_MO_K(z),S_MO_K(d)); erg += conjugate_partition(S_MO_S(z),S_MO_S(d)); if (S_O_K(b) == HOMSYM) insert_list(d,b,NULL,comp_monomhomsym); else insert_hashtable(d,b,NULL,NULL,hash_monompartition); } ); if (t==1) t_HASHTABLE_HOMSYM(b,b); ENDR("conjugate_homsym"); } INT conjugate_powsym(a,b) OP a,b; /* AK 111001 */ { INT erg=OK,t=0; OP z; CTTO(HASHTABLE,POWSYM,"conjugate_powsym(1)",a); CTTTO(EMPTY,POWSYM,HASHTABLE,"conjugate_powsym(2)",b); if (S_O_K(b) == EMPTY) { init_hashtable(b); t=1; } FORALL(z,a,{ OP d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); COPY(S_MO_K(z),S_MO_K(d)); erg += conjugate_partition(S_MO_S(z),S_MO_S(d)); if (S_O_K(b) == POWSYM) insert_list(d,b,NULL,comp_monompowsym); else insert_hashtable(d,b,NULL,NULL,hash_monompartition); } ); if (t==1) t_HASHTABLE_POWSYM(b,b); ENDR("conjugate_powsym"); } INT conjugate_monomial(a,b) OP a,b; /* AK 111001 */ { INT erg=OK,t=0; OP z; CTTO(HASHTABLE,MONOMIAL,"conjugate_monomial(1)",a); CTTTO(EMPTY,MONOMIAL,HASHTABLE,"conjugate_monomial(2)",b); if (S_O_K(b) == EMPTY) { init_hashtable(b); t=1; } FORALL(z,a,{ OP d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); COPY(S_MO_K(z),S_MO_K(d)); erg += conjugate_partition(S_MO_S(z),S_MO_S(d)); if (S_O_K(b) == MONOMIAL) insert_list(d,b,NULL,comp_monommonomial); else insert_hashtable(d,b,NULL,NULL,hash_monompartition); } ); if (t==1) t_HASHTABLE_MONOMIAL(b,b); ENDR("conjugate_monomial"); } OP find_schur(a,b) OP a,b; /* AK 161001 */ /* return OP pointer to SCHUR element with partition eq b, b is monom or partition */ { INT erg = OK; OP z,p; CTO(SCHUR,"find_schur(1)",a); CTTO(PARTITION,MONOM,"find_schur(2)",b); if (S_O_K(b) == MONOM) { CTO(PARTITION,"find_schur(2b)",S_MO_S(b)); p = S_MO_S(b); } else p = b; z = a; while (z != NULL) { if (EQ(p,S_S_S(z))) return S_L_S(z); z = S_S_N(z); } return NULL; ENDO("find_schur"); } OP find_monomial(a,b) OP a,b; /* AK 161001 */ /* return OP pointer to MONOMIAL element with partition eq b, b is monom or partition */ { INT erg = OK; OP z,p; CTO(MONOMIAL,"find_monomial(1)",a); CTTO(PARTITION,MONOM,"find_monomial(2)",b); if (S_O_K(b) == MONOM) { CTO(PARTITION,"find_monomial(2b)",S_MO_S(b)); p = S_MO_S(b); } else p = b; z = a; while (z != NULL) { if (EQ(p,S_S_S(z))) return S_L_S(z); z = S_S_N(z); } return NULL; ENDO("find_monomial"); } #define FINDMAX_SF(a,cf)\ {\ OP z,res=NULL;\ if (cf == NULL) cf = comp;\ FORALL(z,a, {\ if (res ==NULL) res = z;\ else if ( (*cf)(S_MO_S(z),S_MO_S(res)) > 0 ) res = z;\ } );\ return res;\ } OP findmax_schur(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns maximum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(SCHUR,HASHTABLE,"findmax_schur(1)",a); FINDMAX_SF(a,cf); ENDO("findmax_schur"); } OP findmax_monomial(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns maximum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,MONOMIAL,"find_monomial",a); FINDMAX_SF(a,cf); ENDO("findmax_monomial"); } OP findmax_powsym(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns maximum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,POWSYM,"find_powsym",a); FINDMAX_SF(a,cf); ENDO("findmax_powsym"); } OP findmax_elmsym(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns maximum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,ELMSYM,"find_elmsym",a); FINDMAX_SF(a,cf); ENDO("findmax_elmsym"); } OP findmax_homsym(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns maximum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,HOMSYM,"find_homsym",a); FINDMAX_SF(a,cf); ENDO("findmax_homsym"); } #define FINDMIN_SF(a,cf)\ {\ OP z,res=NULL;\ if (cf == NULL) cf = comp;\ FORALL(z,a,\ {\ if (res ==NULL) res = z;\ else if ( (*cf)(S_MO_S(z),S_MO_S(res)) < 0 ) res = z;\ });\ return res;\ } OP findmin_monomial(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns minimum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,MONOMIAL,"findmin_monomial(1)",a); FINDMIN_SF(a,cf); ENDO("findmin_monomial"); } OP findmin_schur(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns minimum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,SCHUR,"findmin_schur(1)",a); FINDMIN_SF(a,cf); ENDO("findmin_schur"); } OP findmin_elmsym(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns minimum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,ELMSYM,"findmin_elmsym(1)",a); FINDMIN_SF(a,cf); ENDO("findmin_elmsym"); } OP findmin_homsym(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns minimum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,HOMSYM,"findmin_homsym(1)",a); FINDMIN_SF(a,cf); ENDO("findmin_homsym"); } OP findmin_powsym(a,cf) OP a; INT (*cf)(); /* AK 161001 */ /* returns minimum according to comp function */ /* comp function operates on PARTITIONS */ /* if cf == NULL comp is used */ { INT erg = OK; CTTO(HASHTABLE,POWSYM,"findmin_powsym(1)",a); FINDMIN_SF(a,cf); ENDO("findmin_powsym"); } INT m_forall_monomials_in_a(a,b,c,f,partf) OP a,b,c,f; INT (*partf)(); /* basic routine for multiplication */ { INT erg = OK; OP ff,z; ff = CALLOCOBJECT(); FORALL (z,a, { if (EINSP(f)) erg += (*partf)(S_MO_S(z),b,c,S_MO_K(z)); else { FREESELF(ff); MULT(f,S_MO_K(z),ff); erg += (*partf)(S_MO_S(z),b,c,ff); } } ); FREEALL(ff); ENDR("m_forall_monomials_in_a"); } INT t_forall_monomials_in_a(a,b,f,partf) OP a,b,f; INT (*partf)(); /* basic routine for multiplication */ { INT erg = OK; OP ff,z; ff = CALLOCOBJECT(); FORALL (z,a, { if (EINSP(f)) erg += (*partf)(S_MO_S(z),b,S_MO_K(z)); else { FREESELF(ff); MULT(f,S_MO_K(z),ff); erg += (*partf)(S_MO_S(z),b,ff); } } ); FREEALL(ff); ENDR("t_forall_monomials_in_a"); } INT m_forall_monomials_in_b(a,b,c,f,partf) OP a,b,c,f; INT (*partf)(); /* basic routine for multiplication */ { INT erg = OK; OP ff,z; ff = CALLOCOBJECT(); FORALL (z,b, { CTO(ANYTYPE,"m_forall_monomials_in_b(i4)",f); CTO(MONOM,"m_forall_monomials_in_b(z)",z); if (EINSP(f)) { erg += (*partf)(a,S_MO_S(z),c,S_MO_K(z)); } else { FREESELF(ff); MULT(f,S_MO_K(z),ff); erg += (*partf)(a,S_MO_S(z),c,ff); } } ); FREEALL(ff); ENDR("m_forall_monomials_in_b"); } INT m_forall_monomials_in_ab(a,b,c,f,partf) OP a,b,c,f; INT (*partf)(); /* basic routine for multiplication */ { INT erg = OK; OP ff,z,y; ff = CALLOCOBJECT(); FORALL (y,a, { FORALL (z,b, { FREESELF(ff); MULT(S_MO_K(z),S_MO_K(y),ff); if (not EINSP(f)) { MULT_APPLY(f,ff); } erg += (*partf)(S_MO_S(y),S_MO_S(z),c,ff); } ); } ); FREEALL(ff); ENDR("m_forall_monomials_in_b"); } INT t_loop_partition(a,b,f,intf,multf,multapplyf) OP a,b,f; INT (*intf)(); INT (*multf)(); INT (*multapplyf)(); /* computes the decomposition of a partition by looping over all parts of the partition and multiplying */ { INT erg = OK; CTO(PARTITION,"t_loop_partition(1)",a); CTTTTTTO(HASHTABLE,POWSYM,SCHUR,HOMSYM,ELMSYM,MONOMIAL,"t_loop_partition(2)",b); if (S_PA_LI(a) == 0) { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += first_partition(cons_null,S_MO_S(m)); COPY(f,S_MO_K(m)); INSERT_HOMSYMMONOM_(m,b); /* also for other types working */ goto ende; } else if (S_PA_LI(a) == 1) { (*intf)(S_PA_I(a,0),b,f); goto ende; } else { OP l,d; INT i; l = CALLOCOBJECT(); d = CALLOCOBJECT(); init_hashtable(l); init_hashtable(d); erg += (*intf)(S_PA_I(a,0),d,f); for (i=1;i= 0) k = k - S_PA_II(kl,S_PA_LI(kl)-j-1); if (k<0) continue; m_int_pa(k,S_M_IJ(b,i,j)); m_pa_s(S_M_IJ(b,i,j),S_M_IJ(b,i,j)); } } ENDR("jacobitrudimatrix"); } symmetrica-2.0/t147.doc0000400017361200001450000001147210726170301014563 0ustar tabbottcrontabDie folgenden Funktionen stellen eine Arithmetik fuer endliche Koerper in Normalbasenrepraesentation dar. Sie wurde mit Hilfe trace-kompatibler Polynome implementiert, die Alfreed Scheerhorn vom IBM Scientific Center in Heidelberg bereitgestellt hat. Um mit diesen Funktionen arbeiten zu koennen werden die Dateien trace_02.pol trace_03.pol trace_05.pol trace_07.pol trace_11.pol trace_13.pol benoetigt die fuer die jeweilige Charakteristik die trace-kompatiblen Polynome vom Grad 1-100 enthalten. Die Funktion erzmulttafel berechnet die Multiplikationstafel fuer die Normalbasis. erzmulttafel wird automatisch durchgefuehrt, falls Addition oder Multiplikation zweier Koerperelemente dies erfordern. Sie muss also nur dann angesprochen werden, wenn explizit ein bestimmter Erweiterungsgrad gewuenscht wird, d.h. wenn z.B. Koerperelemente zufaellig erzeugt werden sollen, die einen bestimmten Erweiterungsgrad haben. erzmulttafel gibt 1 zurueck, falls die Erzeugung der Multiplikationstafel erfolgreich abgeschlossen wurde und 0 sonst. INT erzmulttafel(Erweiterungsgrad) INT Erweiterungsgrad; Die Funktion UE_Platz stellt ein undefiniertes Koerperelement bereit. UE_Platz(Koerperzeiger) INT **Koerperzeiger; Mit der Funktion UE_scan werden Koerperelemente eingelesen. UE_scan(Koerperzeiger) INT **Koerperzeiger; Die Funktion UE_Zeige gibt ein Koerperelement auf dem Bildschirm aus. INT UE_Zeige(Koerperzeiger) INT **Koerperzeiger; Die Funktion UE_fZeige gibt ein Koerperelement auf das File f aus. INT UE_fZeige(f,Koerperzeiger) FILE *f; INT **Koerperzeiger; Die Funktion minimalErw bettet ein gegebenes Element in den Koerper kleinsten Erweiterungsgrades ein, in dem es enthalten ist. minimalErw(Element) INT **Element; Die Funktion UE_add berechnet die Summe von Summ1zeig und Summ2zeig und gibt das Ergebnis dieser Summe auf Ergebniszeig aus. Der Zeiger Ergebzeig darf dabei nicht auf dasselbe Koerperelement zeigen, wie Summ1zeig oder Summ2zeig. UE_add(Summ1zeig,Summ2zeig,Ergebzeig) INT **Summ1zeig; INT **Summ2zeig; INT **Ergebzeig; Die Funktion UE_mult berechnet das Produkt von Fakt1zeig und Fakt2zeig und gibt das Ergebnis dieses Produktes auf Ergebniszeig aus. Der Zeiger Ergebnzeig darf dabei nicht auf dasselbe Koerperelement zeigen, wie Fakt1zeig oder Fakt2zeig. UE_mult(Fakt1zeig,Fakt2zeig,Ergebzeig) INT **Fakt1zeig; INT **Fakt2zeig; INT **Ergebzeig; Die Funktion negativ berechnet das additive Inverse von Element und gibt -Element auf Ergebnis aus. Der Zeiger Ergebnis darf dabei nicht auf dasselbe Koerperelement zeigen, wie Element. negativ(Element,Ergebnis) INT **Element,**Ergebnis; Die Funktion UE_hoch berechnet die m-te Potenz von Element und gibt Element^m auf Ergebnis. Der Zeiger Ergebnis darf dabei nicht auf dasselbe Koerperelement zeigen, wie Element. UE_hoch(Element,m,Ergebnis) INT **Element; INT m; INT **Ergebnis; Die Funktion invers berechnet das multiplikative Inverse zu Element und gibt 1/Element auf Ergebnis aus. Der Zeiger Ergebnis darf dabei nicht auf dasselbe Koerperelement zeigen, wie Element. UE_invers(Element,Ergebnis) INT **Element,**Ergebnis; Die Funktion ist_null ueberprueft, ob Element dem neutralem Element der additiven Gruppe des aktuellen Koerpers entspricht. ist_null gibt 1 zurueck, falls dies gilt und 0 sonst. INT ist_null(Element) INT **Element; Die Funktion ist_eins ueberprueft, ob Element dem neutralem Element der multiplikativen Gruppe des aktuellen Koerpers entspricht. ist_eins gibt 1 zurueck falls dies gilt und 0 sonst. INT ist_eins(Element) INT **Element; Die Funktion Int_Aequivalent berechnet die a-fache Summe des 1-Elementes im Grundkoerper und belegt das Koerperelement Ergebnis mit dieser Summe. Int_Aequivalent(a,Ergebnis) INT a; INT **Ergebnis; Die Funktion ist_gleich vergleicht die Koerperelemente Element1 und Element2. Dazu werden die Koeffizienten von Element1 und Element2 bezueglich der Normalbasis ihres gemeinsammen Erweiterungskoerpers von links nach rechts verglichen. Die erste Stelle in der sie sich unterscheiden ist ausschlaggebend. ist_gleich gibt 1 zurueck, falls Element1 > Element2, -1 , falls Element1 < Element2, und 0 , falls Element1 = Element2. INT ist_gleich(Element1,Element2) INT **Element1; INT **Element2; Die Funktion Order berechnet die kleinste Zahl m, fuer die Element^m = 1 gilt. Order gibt diese Zahl m zurueck. int Order(Element) int **Element; Die Funktion UE_Random erzeugt ein zufaelliges Koerperelement aus dem Koerper mit der aktuellen Koerpererweiterung. Das Ergebnis wird auf Element ausgegeben. UE_Random(Element) INT **Element; symmetrica-2.0/ta.c0000400017361200001450000017701510726021654014161 0ustar tabbottcrontab/* SYMMETRICA file:ta.c */ #include "def.h" #include "macro.h" static struct tableaux * calloctableaux(); static INT inhaltcoroutine(); static INT free_tableaux(); static INT mem_counter_tab; #ifdef TABLEAUXTRUE #define ZEILENENDE(tab,zn)/* AK 100902 */\ (\ S_O_K(S_T_U(tab)) == PARTITION ?\ (zn >= S_PA_LI(S_T_U(tab)) ? -1 :S_PA_II(S_T_U(tab),S_PA_LI(S_T_U(tab))-1-zn) -1 ):\ (zn >= S_T_UGLI(tab) ? -1 :S_PA_II(S_T_UG(tab),S_T_UGLI(tab)-zn-1)-1)\ ) INT tab_anfang() /* AK 100893 */ { mem_counter_tab=0L; return OK; } INT tab_ende() /* AK 100893 */ { INT erg = OK; if (mem_counter_tab != 0L) { fprintf(stderr,"mem_counter_tab = %ld\n",mem_counter_tab); erg += error("tab memory not freed"); } return erg; } INT cast_apply_tableaux(a) OP a; /* AK 270295 */ /* AK 260398 V2.0 */ /* tries to make the object a into a TABLEAUX object */ { INT erg = OK; EOP("cast_apply_tableaux(1)",a); if (MATRIXP(a)) { erg += m_matrix_tableaux(a,a); } else if (VECTORP(a)) { erg += cast_apply_matrix(a); erg += m_matrix_tableaux(a,a); } else { WTO("cast_apply_tableaux(1)",a); } SYMCHECK(a == S_T_S(a), "cast_apply_tableaux(i1)"); ENDR("cast_apply_tableaux"); } INT conjugate_tableaux(a,b) OP a,b; /* AK 040398 V2.0 */ { INT erg = OK; CTO(TABLEAUX,"conjugate_tableaux",a); CE2(a,b,conjugate_tableaux); erg += b_us_t(callocobject(),callocobject(),b); erg += conjugate(S_T_U(a), S_T_U(b)); erg += transpose(S_T_S(a), S_T_S(b)); ENDR("conjugate_tableaux"); } #endif /* TABLEAUXTRUE */ INT tableauxp(a) OP a; /* AK 040398 V2.0 */ { OP z; if (S_O_K(a) != TABLEAUX) return FALSE; if (not matrixp(S_T_S(a))) return FALSE; z = S_T_U(a); switch(S_O_K(z)) { case PARTITION: if (not partitionp(z)) return FALSE; return TRUE; case SKEWPARTITION: if (not skewpartitionp(z)) return FALSE; return TRUE; } return FALSE; } #ifdef TABLEAUXTRUE INT charge_tableaux(a,b) OP a,b; /* AK 141196 */ /* AK 040398 V2.0 */ /* a and b may be equal */ { INT erg = OK; OP c; CTO(TABLEAUX,"charge_tableaux(1)",a); c = CALLOCOBJECT(); erg += rowwordoftableaux(a,c); erg += charge_word(c,b); FREEALL(c); ENDR("charge_tableaux"); } static INT free_tableaux(a) char *a; { SYM_free(a); mem_counter_tab--; return OK; } INT freeself_tableaux(a) OP a; /* AK 260789 */ /* AK 281289 V1.1 */ /* AK 200891 V1.3 */ /* AK 260398 V2.0 */ { INT erg = OK; CTO(TABLEAUX,"freeself_tableaux(1)",a); FREEALL(S_T_S(a)); FREEALL(S_T_U(a)); free_tableaux((char *) S_O_S(a).ob_tableaux); C_O_K(a,EMPTY); ENDR("freeself_tableaux"); } INT copy_tableaux(a,b) OP a,b; /* AK 260789 */ /* AK 230790 V1.1 */ /* AK 200891 V1.3 */ /* AK 260398 V2.0 */ { INT erg = OK; CTO(TABLEAUX,"copy_tableaux(1)",a); CTO(EMPTY,"copy_tableaux(2)",b); erg += b_us_t(callocobject(),callocobject(),b); if (S_O_K(S_T_S(a)) == INTEGERMATRIX) erg += copy_integermatrix(S_T_S(a),S_T_S(b)); else erg += copy_matrix(S_T_S(a),S_T_S(b)); /* self ist immer matrix */ if (S_O_K(S_T_U(a)) == PARTITION) erg += copy_partition(S_T_U(a),S_T_U(b)); else erg += copy(S_T_U(a),S_T_U(b)); ENDR("copy_tableaux"); } static struct tableaux * calloctableaux() /* 020488 AK erste prozedur beim einfuehren eines neuen datentyps */ /* AK 010889 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { struct tableaux *erg = (struct tableaux *) SYM_calloc((int)1,sizeof(struct tableaux)); if (erg == NULL) error("calloctableaux:no memory"); mem_counter_tab++; return(erg); } /* CONSTRUCTORS */ INT m_us_t(); INT b_us_t(); INT b_u_t(); INT m_u_t(); INT b_matrix_tableaux(); INT m_matrix_tableaux(); INT b_matrix_tableaux(mat,tab) OP mat,tab; /* AK 010988 */ /* AK 010889 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OP u; INT erg = OK; if (not MATRIXP(mat)) WTO("b_matrix_tableaux",mat); CE2(mat,tab,b_matrix_tableaux); u = callocobject(); erg += m_matrix_umriss(mat,u); erg += b_us_t(u,mat,tab); ENDR("b_matrix_tableaux"); } INT m_matrix_tableaux(mat,tab) OP mat,tab; /* AK 010988 */ /* AK 010889 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OP u; INT erg = OK; if (not MATRIXP(mat)) WTO("m_matrix_tableaux",mat); CE2(mat,tab,m_matrix_tableaux); u = callocobject(); erg += m_matrix_umriss(mat,u); erg += m_us_t(u,mat,tab); erg += freeall(u); ENDR("m_matrix_tableaux"); } INT m_u_t(umriss,res) OP umriss,res; /* AK 020488 */ /* AK 281289 V1.1 */ /* AK 240791 V1.3 */ /* AK 020398 V2.0 */ /* umriss and res may be equal */ { OP l,h; INT erg = OK; CTTO(PARTITION,SKEWPARTITION,"m_u_t(1)",umriss); CE2(umriss,res,m_u_t); l= callocobject(); h= callocobject(); erg += b_us_t(CALLOCOBJECT(),CALLOCOBJECT(),res); COPY(umriss,S_T_U(res)); erg += length(umriss,h); erg += lastof(umriss,l); erg += b_lh_m(l,h,S_T_S(res)); CTO(TABLEAUX,"m_u_t(res)",res); ENDR("m_u_t"); } INT b_u_t(umriss,res) OP umriss,res; /* AK 020398 V2.0 */ { OP l,h; INT erg = OK; COP("b_u_t(2)",res); l= callocobject(); h= callocobject(); erg += length(umriss,h); /* bsp umriss = 1234 ==> height = 4 umriss = 23456789/3456 ==> height = 8 */ erg += lastof(umriss,l); erg += b_us_t(umriss,callocobject(),res); erg += b_lh_m(l,h,S_T_S(res)); ENDR("b_u_t"); } INT m_us_t(umriss,self,res) OP umriss,self,res; /* AK 230790 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { INT erg = OK; COP("m_us_t(3)",res); erg += b_us_t(callocobject(),callocobject(),res); erg += copy(umriss,S_T_U(res)); erg += copy_matrix(self,S_T_S(res)); ENDR("m_us_t"); } INT b_us_t(umriss,self,res) OP umriss,self,res; /* AK 010889 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OBJECTSELF d; INT erg = OK; COP("b_us_t(3)",res); d.ob_tableaux = calloctableaux(); erg += b_ks_o(TABLEAUX, d, res); erg += c_t_u(res,umriss); erg += c_t_s(res,self); ENDR("b_us_t"); } INT objectread_tableaux(f,a) FILE *f; OP a; /* AK 210690 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { INT erg = OK; CTO(EMPTY,"objectread_tableaux(2)",a); COP("objectread_tableaux(1)",f); erg += b_us_t(callocobject(),callocobject(),a); erg += objectread(f,S_T_U(a)); erg += objectread(f,S_T_S(a)); ENDR("objectread_tableaux"); } INT objectwrite_tableaux(f,a) FILE *f; OP a; /* AK 210690 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { INT erg = OK; CTO(TABLEAUX,"objectwrite_tableaux(2)",a); COP("objectwrite_tableaux(1)",f); fprintf(f,"%ld ",(INT)S_O_K(a)); erg += objectwrite(f,S_T_U(a)); erg += objectwrite(f,S_T_S(a)); ENDR("objectwrite_tableaux"); } INT m_matrix_umriss(mat,umr) OP mat,umr; /* AK 080688 */ /* AK 010989 V1.0 */ /* AK 110790 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ /* mat and umr may be equal */ { INT i,j,k,schalter; INT erg = OK; if (not MATRIXP(mat)) { WTO("m_matrix_umriss",mat); goto endr_ende; } CE2(mat,umr,m_matrix_umriss); /* zuerst die laenge der partition */ for (i=0L;i=0L; i--) { if (S_V_II(b,i) == S_M_LI(mat)) { M_I_I(0L,S_V_I(b,i)); M_I_I(0L,S_V_I(a,i)); } else break; } /* nun sind die nullen am ende */ /* das umdrehen */ erg += b_gk_spa(callocobject(),callocobject(),umr); erg += m_v_pa(a,S_SPA_G(umr)); erg += m_v_pa(b,S_SPA_K(umr)); erg += freeall(a); erg += freeall(b); if (EMPTYP(S_SPA_G(umr))) /* no real entry in the matrix */ { erg += freeself(umr); } goto endr_ende; } erg += b_ks_pa(VECTOR,CALLOCOBJECT(),umr); erg += m_il_integervector(i,S_PA_S(umr)); /* die laenge wurde berechnet */ k = S_M_LI(mat); for (i=0L;i k) { erg += error("m_matrix_umriss:no partition shape"); goto endr_ende; } M_I_I(j,S_PA_I(umr,S_PA_LI(umr)-1-i)); k = j; }; ENDR("m_matrix_umriss"); } INT tex_tableaux(a) OP a; /* AK 060588 */ /* AK 230790 V1.1 */ /* AK 070291 V1.2 prints to texout */ /* AK 200891 V1.3 */ /* AK 260398 V2.0 */ { INT i,j; INT erg = OK; CTO(TABLEAUX,"tex_tableaux(1)",a); if (S_O_K(S_T_U(a)) != PARTITION) /* AK 310892 */ { return error("tex_tableaux: only for PARTITION shape"); } fprintf(texout,"\\hbox { \\vbox {\n"); for (i=0L; i< S_PA_LI(S_T_U(a)); i++) { fprintf(texout,"\\hrule width %ldpt\n", S_PA_II(S_T_U(a),i)*13-1L); fprintf(texout,"\\vskip 0pt\n\\hbox {\n"); for (j=0L; j< S_PA_II(S_T_U(a),i); j++) { fprintf(texout, "\\kern -3.5pt\n\\hbox to 13pt{"); fprintf(texout,"\\vrule height10pt depth3pt$"); /* s_t_iji statt S_T_IJI */ if (s_t_iji(a,S_PA_LI(S_T_U(a))-1-i,j) < 10L) fprintf(texout,"\\ %ld", /* s_t_iji statt S_T_IJI */ s_t_iji(a,S_PA_LI(S_T_U(a))-1-i,j)); /* s_t_iji statt S_T_IJI */ else if (s_t_iji(a,S_PA_LI(S_T_U(a))-1-i,j) < 100L) fprintf(texout,"%ld", /* s_t_iji statt S_T_IJI */ s_t_iji(a,S_PA_LI(S_T_U(a))-1-i,j)); else return error("tex_tableaux:entry too big in tableaux"); fprintf(texout, "$ \\vrule height10pt depth3pt}\n"); } fprintf(texout,"}\n\\vskip 0pt\n"); if (i== S_PA_LI(S_T_U(a)) -1L) fprintf(texout, "\\hrule width %ldpt\n",S_PA_II(S_T_U(a),i)*13-1L); } fprintf(texout,"} } "); ENDR("tex_tableaux"); } INT comp_tableaux(a,b) OP a,b; /* AK 060588 */ /* AK 281289 V1.1 */ /* AK 200891 V1.3 */ /* AK 221097 */ /* AK 260398 V2.0 */ { INT erg=OK,i,j,k; CTO(TABLEAUX,"comp_tableaux",a); CTO(TABLEAUX,"comp_tableaux",b); erg = comp(S_T_U(a), S_T_U(b)); if (erg != (INT)0) return erg; for (i=0;i= S_T_ULI(a)) continue;}\ else if (S_O_K(S_T_U(a)) == SKEWPARTITION)\ {if (i >= S_T_UGLI(a)) continue;}\ /*empty matrix*/else if (S_O_K(S_T_U(a)) == EMPTY)\ continue;\ \ fprintf(fp,"\n");\ if (fp == stdout) zeilenposition = 0L;\ schalter=1L;\ for (j=0L; j= 0L; i--) { CO_CO_FPT }; } else { for (i=0L; i < S_T_HI(a);i++) { CO_CO_FPT }; } } fprintf(fp,"\n"); if (fp == stdout) { zeilenposition = (INT)0; } ENDR("fprint_tableaux"); } /* SELECTORS */ OP s_t_s(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OBJECTSELF c; c = s_o_s(a); return(c.ob_tableaux->t_self); } OP s_t_u(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OBJECTSELF c; c=s_o_s(a); return(c.ob_tableaux->t_umriss); } OP s_t_ug(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_spa_g(s_t_u(a))); } OP s_t_l(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_m_l(s_t_s(a))); } INT s_t_li(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_m_li(s_t_s(a))); } INT s_t_hi(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_m_hi(s_t_s(a))); } INT s_t_iji(a,i,j) OP a;INT i,j; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_i_i(s_t_ij(a,i,j))); } OP s_t_ij(a,i,j) OP a;INT i,j; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_m_ij(s_t_s(a),i,j)); } OP s_t_h(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_m_h(s_t_s(a))); } INT c_t_s(a,b) OP a,b; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OBJECTSELF c; c = s_o_s(a); c.ob_tableaux->t_self = b; return(OK); } INT c_t_u(a,b) OP a,b; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OBJECTSELF c; c = s_o_s(a); c.ob_tableaux->t_umriss = b; return(OK); } OP s_t_uk(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_spa_k(s_t_u(a))); } OP s_t_us(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_pa_s(s_t_u(a))); } INT s_t_uli(a) OP a; /* AK 040398 V2.0 */ { INT erg = OK; CTO(TABLEAUX,"s_t_uli",a); CTO(PARTITION,"s_t_uli:shape of the tableau",s_t_u(a)); return(s_pa_li(s_t_u(a))); ENDR("s_t_uli"); } OP s_t_ul(a) OP a; /* AK 040398 V2.0 */ { OP umriss = s_t_u(a); if (s_o_k(umriss) != PARTITION) { printobjectkind(umriss); error("s_t_ul: not a partition shape tableau"); return NULL; } return(s_pa_l(s_t_u(a))); } OP s_t_ui(a,i) OP a;INT i; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OP umriss = s_t_u(a); if (s_o_k(umriss) != PARTITION) { printobjectkind(umriss); error("s_t_ui: not a partition shape tableau"); return NULL; } return(s_pa_i(s_t_u(a),i)); } INT s_t_uii(a,i) OP a;INT i; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { OP umriss = s_t_u(a); if (s_o_k(umriss) != PARTITION) { printobjectkind(umriss); error("s_t_uii: not a partition shape tableau"); return ERROR; } return(s_pa_ii(s_t_u(a),i)); } INT s_t_ukii(a,i) OP a;INT i; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_spa_kii(s_t_u(a),i)); } INT s_t_ukli(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_spa_kli(s_t_u(a))); } INT s_t_ugii(a,i) OP a;INT i; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_spa_gii(s_t_u(a),i)); } INT s_t_ugli(a) OP a; /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { return(s_spa_gli(s_t_u(a))); } INT content_tableaux(a,content) OP a,content; /* AK 250488 */ /* AK 230790 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { INT i,j,an,en; INT erg = OK; CTO(TABLEAUX,"content_tableaux(1)",a); CE2(a,content,content_tableaux); erg += m_il_nv(1L,content); for (i=S_T_HI(a)-1L;i>=0L;i--) { an = zeilenanfang(a,i); en = ZEILENENDE(a,i); for (j=an;j<=en;j++) erg += inhaltcoroutine(S_T_IJI(a,i,j),content); } ENDR("content_tableaux"); } static INT inhaltcoroutine(zahl,content) INT zahl; OP content; /* AK 230790 V1.1 */ /* AK 200891 V1.3 */ /* AK 040398 V2.0 */ { INT erg = OK; CTO(VECTOR,"internal routine:inhaltcoroutine(2)",content); if (zahl <= S_V_LI(content)) INC_INTEGER(S_V_I(content,zahl-1L)); else { OP b=callocobject(); INT k,m=S_V_LI(content); erg += m_il_v(zahl,b); for (k=0L;k=k;j--) { M_I_I(S_T_IJI(a,i,j),S_W_I(b,index));index++; } } erg += freeall(l); ENDR("rowwordoftableaux"); } INT columnwordoftableaux(a,b) OP a,b; /* berechnet das zu einem Tableaux gehoerende word */ /* AK 020290 V1.1 */ /* AK 200891 V1.3 */ /* AK 230398 V2.0 */ { OP l; INT i,j,k,erg=OK; INT index=0L; /* der index im word */ CTO(TABLEAUX,"columnwordoftableaux(1)",a); l = callocobject(); erg += weight_tableaux(a,l); /* die laenge des wortes ist das gewicht des tableaus */ erg += m_il_w(S_I_I(l),b); for (j=0L;j=k;i--) { M_I_I(S_T_IJI(a,i,j),S_W_I(b,index));index++; } } erg += freeall(l); ENDR("columnwordoftableaux"); } INT spaltenanfang(a,b) OP a; INT b; /* AK 020290 V1.1 */ /* AK 180691 V1.2 */ /* Ak 200891 V1.3 */ /* AK 230398 V2.0 */ { OP z = S_T_U(a); INT j; if (b <0L) return error("spaltenanfang:index < 0"); if (S_O_K(z) == PARTITION) { if (b >= S_PA_II(z,S_PA_LI(z)-1L)) return(S_T_HI(a)); else return(0L); } else if (S_O_K(z) == SKEWPARTITION) { /* s_t_ugii statt S_T_UGII */ if (b >= s_t_ugii(a,S_T_UGLI(a)-1L)) return(S_T_HI(a)); /* s_t_ukii statt S_T_UKII */ else if (b>=s_t_ukii(a,S_T_UKLI(a)-1L)) return(0L); else { for (j=S_T_UKLI(a)-1L;j>=0L;j--) if (S_T_UKII(a,j) <= b) break; return(S_T_UKLI(a) - 1L - j); } } else error("spaltenanfang: wrong shape"); return OK; } INT spaltenende(a,b) OP a; INT b; /* AK 020290 V1.1 */ /* AK 180691 V1.2 */ /* Ak 200891 V1.3 */ /* AK 230398 V2.0 */ { OP z = S_T_U(a); INT j; if (b <0L) return error("spaltenende:index < 0"); if (S_O_K(z) == PARTITION) { if (b >= S_PA_II(z,S_PA_LI(z)-1L)) return(-1L); else { for (j=S_PA_LI(z)-1L;j>=0L;j--) if (S_PA_II(z,j) <= b) break; return(S_PA_LI(z) - 2L - j); } } else if (S_O_K(z) == SKEWPARTITION) { /* s_t_ugii statt S_T_UGII */ if (b >= s_t_ugii(a,S_T_UGLI(a)-1L)) return(-1L); else { for (j=S_T_UGLI(a)-1L;j>=0L;j--) if (S_T_UGII(a,j) <= b) break; return(S_T_UGLI(a) - 2L - j); } } else return error("spaltenende: wrong shape"); } INT zeilenanfang(tab,zn) OP tab; INT zn; /* AK 090688 */ /* gibt index ersten eintrag in zeile zn */ /* falls zn keine besetzte zeile ist, dann ist das ergebnis die breite der matrix */ /* AK 281289 V1.1 */ /* AK 180691 V1.2 */ /* Ak 200891 V1.3 */ /* AK 230398 V2.0 */ { INT erg = OK; CTO(TABLEAUX,"zeilenanfang",tab); if (zn <0L) { erg += error("zeilenanfang:index < 0"); goto endr_ende; } if (S_O_K(S_T_U(tab)) == PARTITION) { /* ein tableau */ if (zn < S_PA_LI(S_T_U(tab)) ) return(0L); else return(S_T_LI(tab)); } else if (S_O_K(S_T_U(tab)) == SKEWPARTITION) /* ein schieftableau */ { if (zn >= S_T_UGLI(tab)) return(S_T_LI(tab)); else if (zn >= S_T_UKLI(tab)) return(0L); else return( S_T_UKII(tab,S_T_UKLI(tab)-zn-1L)); } else { printobjectkind(S_T_U(tab)); erg += error("zeilenanfang: wrong umriss"); } ENDR("zeilenanfang"); } INT zeilenende(tab,zn) OP tab; INT zn; /* letzter erlaubter index */ /* AK 281289 V1.1 */ /* AK 180691 V1.2 */ /* Ak 200891 V1.3 */ /* AK 230398 V2.0 */ /* AK 100902 V2.1 */ { OP u = S_T_U(tab); INT erg = OK; CTO(TABLEAUX,"zeilenende(1)",tab); CTTO(PARTITION,SKEWPARTITION,"zeilenende(1.shape)",S_T_U(tab)); SYMCHECK(zn<0,"zeilenende:index < 0"); if (S_O_K(u) == PARTITION) { if (zn >= S_PA_LI(u)) return -1; else return(S_PA_II(u,S_PA_LI(u)-1L-zn) -1); } else { if (zn >= S_T_UGLI(tab)) return -1; else return(S_PA_II(S_T_UG(tab),S_T_UGLI(tab)-zn-1L)-1); } ENDR("zeilenende"); } INT skewplane_plane(a,b) OP a,b; /* AK 010889 */ /* Jeu de Taquin auf a wird b . a ist schiefplanepartition und wird eine planepartition b */ /* AK 010889 V1.1 */ /* Ak 200891 V1.3 */ /* AK 230398 V2.0 */ { OP self = callocobject(); OP umriss; OP unten,rechts; INT i,j; INT posi,posj; /* aktuelle position des jokers */ INT nexti,nextj; /* naechste position des jokers */ INT si=0,sj=0; /* start of joker */ copy (S_T_S(a),self); m0108893: /* ein neues spiel */ i = 0L; for (j=0L;j0L; j--,k++) m_i_i(j+i,S_T_IJ(zz,0L,za-k)); erg += m_matrix_umriss(S_T_S(zz),S_T_U(zz)); insert(zz,b,NULL,NULL); C_L_S(z,NULL); } else if ( S_T_IJI(zz,0L,zeilenanfang(zz,0L)) <= S_V_II(a,i) + i + 1L ) freeself(zz); else { za = zeilenanfang(zz,0L); for (j=S_V_II(a,i),k=1L;j>0L; j--,k++) m_i_i(j+i,S_T_IJ(zz,0L,za-k)); erg += m_matrix_umriss(S_T_S(zz),S_T_U(zz)); insert(zz,b,NULL,NULL); C_L_S(z,NULL); } z = S_L_N(z); } erg += freeall(e); ENDR("lehmercode_tableaux"); } INT umriss_tableaux(a,b) OP a,b; /* AK 300792 */ /* AK 040398 V2.0 */ { INT erg = OK; CTO(TABLEAUX,"umriss_tableaux",a); CE2(a,b,umriss_tableaux); erg += copy(S_T_U(a),b); ENDR("umriss_tableaux"); } INT standardp(a) OP a; /* AK 300792 */ /* true if weakly increasing in rows and strictly in columns */ /* AK 040398 V2.0 */ { INT i,j; INT erg = OK; CTO(TABLEAUX,"standardp",a); for (i=0L; i0L) if (not EMPTYP(S_T_IJ(a,i-1L,j))) if (S_T_IJI(a,i,j) <= S_T_IJI(a,i-1L,j)) return FALSE; if (j>0L) if (not EMPTYP(S_T_IJ(a,i,j-1L))) if (S_T_IJI(a,i,j) < S_T_IJI(a,i,j-1L)) return FALSE; } return TRUE; ENDR("standardp"); } INT planep(a) OP a; /* true if strictly decreasing in rows and columns */ /* AK 260398 V2.0 */ { INT i,j; INT erg = OK; CTO(TABLEAUX,"planep",a); for (i=0L; i0L) if (not EMPTYP(S_T_IJ(a,i-1L,j))) if (S_T_IJI(a,i,j) > S_T_IJI(a,i-1L,j)) return FALSE; if (j>0L) if (not EMPTYP(S_T_IJ(a,i,j-1L))) if (S_T_IJI(a,i,j) > S_T_IJI(a,i,j-1L)) return FALSE; } return TRUE; ENDR("planep"); } INT youngp(a) OP a; /* AK 160992 */ /* TRUE if entries 1,2,3,....n, each exactly one time */ /* AK 040398 V2.0 */ { OP c; INT res,erg = OK; CTO(TABLEAUX,"youngp",a); c = callocobject(); erg += inhalt_tableaux(a,c); if (not einsp_integervector(c)) res=FALSE; else res=TRUE; erg += freeall(c); if (erg != OK) goto endr_ende; return res; ENDR("youngp"); } INT sort_rows_tableaux_apply(b) OP b; /* AK 070295 */ { INT erg = OK; INT i,j,k; CTO(TABLEAUX,"sort_rows_tableaux_apply(1)",b); for (i=0;i=0;j--) { if (not EMPTYP(S_T_IJ(a,i,j))) { if (S_T_IJI(a,i,j) <= S_P_LI(b)) M_I_I(S_P_II(b,S_T_IJI(a,i,j)-1L), S_T_IJ(c,i,j)); } } } ENDR("operate_perm_tableaux"); } #endif /* PERMTRUE */ INT first_tableaux(a,b) OP a,b; /* AK 040693 */ /* a is umriss */ /* b first tableau according lex order on column word */ { INT erg = OK; INT i,j,k=1,sa,se; CTTO(PARTITION,SKEWPARTITION,"first_tableaux",a); erg += m_u_t(a,b); for (j=0L;j=0L;j--) { M_I_I(j,S_V_I(res,ind)); ind++; } } erg += freeall(wght); erg += freeall(form1); ENDR("ym_min"); } INT nxt_ym(ym1,ym2) OP ym1,ym2; { INT i,j,l,ind_max,av,pres=0,crt,tp; char *tab; ind_max=S_V_LI(ym1)-1L; av=S_V_II(ym1,ind_max); for(i=ind_max-1L;i>=0L;i--) { pres=S_V_II(ym1,i); if(presi)&&(l0L;j--) for(;i<*(tab+j);i++) for(l=0L;l<=j;l++,crt--) M_I_I(l,S_V_I(ym2,crt)); for(;crt>tp;crt--) M_I_I(0L,S_V_I(ym2,crt)); SYM_free(tab); return(TRUE); } INT find_tab_entry(tab,b,i,j) OP tab,b; INT *i, *j; /* place of b in tab */ /* FALSE if not */ { INT k,l; for (k=0;k *j) { *i = k; *j = l; } if (*i == -1) return FALSE; else return TRUE; } INT word_tableaux(a,b) OP a,b; { INT erg = OK; CE2(a,b,word_tableaux); erg += word_schen(a,b,NULL); ENDR("word_tableaux"); } INT word_schen(a,p_symbol,q_symbol) OP a,p_symbol,q_symbol; { INT i; INT erg = OK; CE3(a,p_symbol,q_symbol,word_schen); if (S_O_K(a) == PERMUTATION) erg += word_schen(S_P_S(a),p_symbol,q_symbol); else { erg += freeself(p_symbol); if (q_symbol != NULL) erg += freeself(q_symbol); for (i=0;i= 0 zu paar von integer vektoren */ { INT erg = OK,i,j,k,l; OP c; CE3(matrix, column_index, row_index,matrix_twoword); c = callocobject(); erg += zeilen_summe(matrix,c); erg += sum(c,c); erg += m_l_v(c,column_index); erg += m_l_v(c,row_index); for(i=0,l=0;i=0;i--) erg += knuth_row_delete_step(S_V_I(a,i),S_V_I(b,i),c,d); erg += freeall(d); erg += freeall(c); ENDR("knuth_twoword"); } INT schen_word(a,bb,cb) OP a,bb,cb; /* input are the two tableaux bb and cc a becomes the result a word */ { INT i; INT erg = OK; OP c,b; CTO(TABLEAUX,"schen_word(2)",bb); CTO(TABLEAUX,"schen_word(3)",cb); c = callocobject(); b = callocobject(); erg += copy(bb,b); erg += copy(cb,c); erg += weight(b,a); erg += m_il_w(S_I_I(a),a); for (i=S_V_LI(a)-1;i>=0;i--) { erg += schensted_row_delete_step(S_V_I(a,i),b,c); } erg += freeall(b); erg += freeall(c); CTO(WORD,"schen_word(e1)",a); ENDR("schen_word"); } INT knuth_row_insert_step(rein,qrein,P,Q) OP qrein,rein,P,Q; /* for 01 matrices */ { INT erg = OK,i,j,k; OP c,z; CTTO(EMPTY,TABLEAUX,"knuth_row_insert_step(3)",P); c = callocobject(); if (emptyp(P)) /* anfang */ { m_ilih_m(10L,10L,c); if (Q != NULL) { copy(qrein,S_M_IJ(c,0,0)); m_matrix_tableaux(c,Q); } copy(rein,S_M_IJ(c,0,0)); b_matrix_tableaux(c,P); goto sk; } z = callocobject(); i=0;copy(rein,z); aa: k = ZEILENENDE(P,i); for (j=0;j<=k;j++) if (le(z,S_T_IJ(P,i,j))) break; if (j <= k) /* d.h. im tableau */ { if ( (S_O_K(S_T_IJ(P,i,j)) == INTEGER) && (S_O_K(z) == INTEGER) ) { M_I_I(S_T_IJI(P,i,j),c); M_I_I(S_I_I(z),S_T_IJ(P,i,j)); M_I_I(S_I_I(c),z); } else { copy(S_T_IJ(P,i,j),c); copy(z,S_T_IJ(P,i,j)); copy(c,z); } i++; if (i == S_T_ULI(P)) { /* neue zeile */ j=0; goto kk; } else goto aa; } else /* anhaengen */ { kk: freeself(c); swap(S_T_S(P),c); if ((i >= S_M_HI(c)) || (j>= S_M_LI(c)) ) { inc(c); } if (i < S_T_ULI(P)) { if (S_O_K(z) == INTEGER) M_I_I(S_I_I(z),S_M_IJ(c,i,j)); else copy(z,S_M_IJ(c,i,j)); INC_INTEGER(S_T_UI(P,S_T_ULI(P)-1-i)); swap(S_T_S(P),c); freeall(c); /* AK 130297 */ } else { copy(z,S_M_IJ(c,i,j)); b_matrix_tableaux(c,P); } if (Q == NULL) { freeall(z); goto sk; /* nicht freigeben */ } freeself(z); swap(S_T_S(Q),z); if ((i >= S_M_HI(z)) || (j>= S_M_LI(z)) ) { inc(z); } if (i < S_T_ULI(Q)) { copy(qrein,S_M_IJ(z,i,j)); INC_INTEGER(S_T_UI(Q,S_T_ULI(Q)-1-i)); swap(S_T_S(Q),z); freeall(z); } else { copy(qrein,S_M_IJ(z,i,j)); b_matrix_tableaux(z,Q); } goto sk; } sk: ENDR("knuth_row_insert_step"); } INT schensted_row_insert_step(rein,P,Q) OP rein,P,Q; { INT erg = OK,i,j,k; OP c,z; CTTO(EMPTY,TABLEAUX,"schensted_row_insert_step(2)",P); c = callocobject(); if (emptyp(P)) /* anfang */ { m_ilih_m(10L,10L,c); if (Q != NULL) { m_i_i(1L,S_M_IJ(c,0,0)); m_matrix_tableaux(c,Q); } copy(rein,S_M_IJ(c,0,0)); b_matrix_tableaux(c,P); goto sk; } z = callocobject(); i=0;copy(rein,z); aa: k = ZEILENENDE(P,i); for (j=0;j<=k;j++) if (lt(z,S_T_IJ(P,i,j))) break; if (j <= k) /* d.h. im tableau */ { if ( (S_O_K(S_T_IJ(P,i,j)) == INTEGER) && (S_O_K(z) == INTEGER) ) { M_I_I(S_T_IJI(P,i,j),c); M_I_I(S_I_I(z),S_T_IJ(P,i,j)); M_I_I(S_I_I(c),z); } else { copy(S_T_IJ(P,i,j),c); copy(z,S_T_IJ(P,i,j)); copy(c,z); } i++; if (i == S_T_ULI(P)) { /* neue zeile */ j=0; goto kk; } else goto aa; } else /* anhaengen */ { kk: freeself(c); swap(S_T_S(P),c); if ((i >= S_M_HI(c)) || (j>= S_M_LI(c)) ) { inc(c); } if (i < S_T_ULI(P)) { if (S_O_K(z) == INTEGER) M_I_I(S_I_I(z),S_M_IJ(c,i,j)); else copy(z,S_M_IJ(c,i,j)); INC_INTEGER(S_T_UI(P,S_T_ULI(P)-1-i)); swap(S_T_S(P),c); freeall(c); /* AK 130297 */ } else { copy(z,S_M_IJ(c,i,j)); b_matrix_tableaux(c,P); } if (Q == NULL) { freeall(z); goto sk; /* nicht freigeben */ } weight(Q,z); k = S_I_I(z); /* gewicht */ freeself(z); swap(S_T_S(Q),z); if ((i >= S_M_HI(z)) || (j>= S_M_LI(z)) ) { inc(z); } if (i < S_T_ULI(Q)) { M_I_I(k+1,S_M_IJ(z,i,j)); INC_INTEGER(S_T_UI(Q,S_T_ULI(Q)-1-i)); swap(S_T_S(Q),z); freeall(z); } else { m_i_i(k+1,S_M_IJ(z,i,j)); b_matrix_tableaux(z,Q); } goto sk; } sk: ENDR("schensted_row_insert_step"); } INT knuth_row_delete_step(raus,qraus,P,Q) OP raus,qraus,P,Q; { INT i,j,l,k,erg = OK; OP c; CTO(TABLEAUX,"knuth_row_delete_step(3)",P); CTO(TABLEAUX,"knuth_row_delete_step(4)",Q); if (S_T_ULI(P) == 1) { i = ZEILENENDE(P,0); erg += copy_integer(S_T_IJ(P,0L,i),raus); erg += copy_integer(S_T_IJ(Q,0L,i),qraus); if (i==0) { erg += freeself(P); erg += freeself(Q); goto sre; } erg += dec_integer(S_T_UI(P,0)); erg += dec_integer(S_T_UI(Q,0)); erg += freeself_integer(S_T_IJ(P,0L,i)); erg += freeself_integer(S_T_IJ(Q,0L,i)); goto sre; } /* richtiges tableau */ c = callocobject(); max(Q,c); copy(c,qraus); /* jetzt suchen wo das max in Q vorkommt, davon aber dann den groessten wert in P*/ find_knuth_tab_entry(P,Q,c,&i,&j); if (i == -1) error("internal error:"); copy(S_T_IJ(P,i,j),c); freeself(S_T_IJ(P,i,j)); freeself(S_T_IJ(Q,i,j)); for (l=i-1;l>=0;l--) { i = ZEILENENDE(P,l); for (k=0;k<= i;k++) if (gt(S_T_IJ(P,l,k),c)) { break; } else if (eq(S_T_IJ(P,l,k),c)) { k++; break; } k--; /* nun an k setzen */ swap(S_T_IJ(P,l,k),c); } copy(c,raus); copy(S_T_S(P),c); m_matrix_tableaux(c,P); copy(S_T_S(Q),c); b_matrix_tableaux(c,Q); sre: ENDR("knuth_row_delete_step"); } INT schensted_row_delete_step(raus,P,Q) OP raus,P,Q; { INT i,j,l,k,erg = OK; OP c; CTO(TABLEAUX,"schensted_row_delete_step(2)",P); CTO(TABLEAUX,"schensted_row_delete_step(3)",Q); if (S_T_ULI(P) == 1) { i = ZEILENENDE(P,0); erg += copy(S_T_IJ(P,0L,i),raus); if (i==0) { erg += freeself(P); erg += freeself(Q); goto sre; } erg += dec(S_T_UI(P,0)); erg += dec(S_T_UI(Q,0)); erg += freeself(S_T_IJ(P,0L,i)); erg += freeself(S_T_IJ(Q,0L,i)); goto sre; } /* richtiges tableau */ c = callocobject(); weight(Q,c); find_tab_entry(Q,c,&i,&j); if (i == -1) error("internal error:"); copy(S_T_IJ(P,i,j),c); freeself(S_T_IJ(P,i,j)); freeself(S_T_IJ(Q,i,j)); for (l=i-1;l>=0;l--) { i = ZEILENENDE(P,l); for (k=0;k<= i;k++) if (ge(S_T_IJ(P,l,k),c)) break; k--; /* nun an k setzen */ swap(S_T_IJ(P,l,k),c); } copy(c,raus); copy(S_T_S(P),c); m_matrix_tableaux(c,P); copy(S_T_S(Q),c); b_matrix_tableaux(c,Q); sre: ENDR("schensted_row_delete_step"); } INT all_plactic_word(w,c) OP w,c; /* AK 211195 */ /* enter a word return all plactic equivalent words */ /* using Schensted */ /* AK 240398 V2.0 */ { OP a,b,d; INT i, erg = OK; CTO(WORD,"all_plactic_word(1)",w); a = callocobject(); b = callocobject(); d = callocobject(); erg += word_schen(w,a,b); erg += last_partition(S_V_L(w),b); erg += kostka_tab(S_T_U(a),b,d); erg += t_LIST_VECTOR(d,b); erg += m_il_v(S_V_LI(b),c); for (i=0;i S_T_ULI(a)) return error("INV_NILJDT: illegel index"); if (S_O_K(S_T_U(a)) == SKEWPARTITION) if (si > S_T_UGLI(a)) return error("INV_NILJDT: illegel index"); self = callocobject(); copy(S_T_S(a),self); if (sj == S_M_LI(self)) inc(self); if (si == S_M_HI(self)) inc(self); posi = si; posj = sj; m120790again: unten = NULL; links = NULL; if (posj > 0L) { links = S_M_IJ(self, posi, posj-1L); if (EMPTYP(links)) links = NULL;} if (posi > 0L) { unten = S_M_IJ(self, posi-1L, posj); if (EMPTYP(unten)) unten = NULL;} if ((links == NULL) && (unten == NULL)) { /* Abbruchbedingung */ C_O_K(S_M_IJ(self,posi,posj),EMPTY); umriss = callocobject(); m_matrix_umriss(self,umriss); return b_us_t(umriss,self,b); } if (links == NULL) { M_I_I(S_I_I(unten), S_M_IJ(self,posi,posj)); posi--; goto m120790again; } if (unten == NULL) { M_I_I(S_I_I(links), S_M_IJ(self,posi,posj)); posj--; goto m120790again; } if (S_I_I(unten) == S_I_I(links)) { if ( not emptyp(S_M_IJ(self,posi-1L,posj-1L))) if ( S_M_IJI(self,posi-1L,posj-1L) == S_I_I(links)-1L ) { /* jetzt anwenden der nilplactic relationen */ INT i; M_I_I(S_M_IJI(self,posi,posj-1L), S_M_IJ(self,posi,posj)); for (i=1L; i <= posi ; i++) { if ( (S_M_IJI(self,posi-i,posj-1L) != S_I_I(links)-i) || (S_M_IJI(self,posi-i,posj) != S_I_I(links)-i+1L) ) break; M_I_I(S_M_IJI(self,posi-i,posj-1L), S_M_IJ(self,posi-i,posj)); } posj--; goto m120790again; } } if (S_I_I(unten) >= S_I_I(links)) { M_I_I(S_I_I(unten), S_M_IJ(self,posi,posj)); posi--; goto m120790again; } else { M_I_I(S_I_I(links), S_M_IJ(self,posi,posj)); posj--; goto m120790again; } } INT inverse_jeudetaquin_tableaux(a,si,sj,b) OP a,b;INT si,sj; /* AK 100790 V1.1 */ /* AK 200891 V1.3 */ { OP self,umriss; INT posi,posj; /* aktuelle position des jokers */ OP unten, links; if (not EMPTYP(b) ) freeself(b); if (sj != ZEILENENDE(a,si)+1L) return error("inverse_jeudetaquin_tableaux: illegel index"); self = callocobject(); copy(S_T_S(a),self); if (sj == S_M_LI(self)) inc(self); if (si == S_M_HI(self)) inc(self); posi = si; posj = sj; m100790again: unten = NULL; links = NULL; if (posj > 0L) { links = S_M_IJ(self, posi, posj-1L); if (EMPTYP(links)) links = NULL;} if (posi > 0L) { unten = S_M_IJ(self, posi-1L, posj); if (EMPTYP(unten)) unten = NULL;} if ((links == NULL) && (unten == NULL)) { /* Abbruchbedingung */ C_O_K(S_M_IJ(self,posi,posj),EMPTY); umriss = callocobject(); m_matrix_umriss(self,umriss); b_us_t(umriss,self,b); return(OK); } if (links == NULL) { M_I_I(S_I_I(unten), S_M_IJ(self,posi,posj)); posi--; goto m100790again; } if (unten == NULL) { M_I_I(S_I_I(links), S_M_IJ(self,posi,posj)); posj--; goto m100790again; } if (S_I_I(unten) >= S_I_I(links)) { M_I_I(S_I_I(unten), S_M_IJ(self,posi,posj)); posi--; goto m100790again; } else { M_I_I(S_I_I(links), S_M_IJ(self,posi,posj)); posj--; goto m100790again; } } INT jeudetaquin_tableaux(a,b) OP a,b; /* AK 080688 */ /* Jeu de Taquin auf a wird b . a ist schieftableau und wird ein tableau b */ /* AK 010889 V1.1 */ /* AK 200891 V1.3 */ { OP self,umriss,unten,rechts; INT i,j; INT posi,posj; /* aktuelle position des jokers */ INT nexti,nextj; /* naechste position des jokers */ INT si= -1,sj= -1; /* start of joker */ if (S_O_K(S_T_U(a)) == PARTITION) return copy(a,b); self = callocobject(); copy (S_T_S(a),self); m0806883: /* ein neues spiel */ i = 0L; for (j=0L;j=0;i--) { res = next_lex_vector(S_V_I(v,i),S_V_I(v,i)); if (res != FALSE) break; } if (i==-1) res = FALSE; else res=TRUE; if (res ==TRUE) { for (i++;i=0;i--) erg+= qsort_vector(S_V_I(v,i)); if (a !=b) erg += copy(a,b); for (i=0;i S_V_LI(teh_speicher)) { inc_vector_co(teh_speicher, S_I_I(a)-S_V_LI(teh_speicher)+5); } if (not EMPTYP(S_V_I(teh_speicher, S_I_I(a)))) { return S_V_I(teh_speicher, S_I_I(a)); } else { ek_to_h(a,S_V_I(teh_speicher, S_I_I(a))); return S_V_I(teh_speicher, S_I_I(a)); } ENDO("find_teh_integer"); } INT teh_integer__faktor(a,b,f) OP a,b,f; /* also called from tsh_partition__faktor */ /* also called from the_integer__faktor */ { INT erg = OK; OP m; CTO(INTEGER,"teh_integer__faktor(1)",a); CTTTO(HASHTABLE,HOMSYM,ELMSYM,"teh_integer__faktor(2)",b); SYMCHECK((S_I_I(a) < 0),"teh_integer__faktor:parameter < 0"); if (teh_speicher == NULL) { teh_speicher = CALLOCOBJECT(); erg += m_il_v(100,teh_speicher); } if (S_I_I(a) > S_V_LI(teh_speicher)) { inc_vector_co(teh_speicher, S_I_I(a)-S_V_LI(teh_speicher)+5); } if (not EMPTYP(S_V_I(teh_speicher, S_I_I(a)))) { m = CALLOCOBJECT(); COPY(S_V_I(teh_speicher, S_I_I(a)),m); MULT_APPLY(f,m); if (S_O_K(b) == HASHTABLE) INSERT_HASHTABLE(m,b,add_koeff,eq_monomsymfunc,hash_monompartition); else INSERT_LIST(m,b,add_koeff,comp_monomhomsym); goto eee; } m = CALLOCOBJECT(); ek_to_h(a,m); COPY(m,S_V_I(teh_speicher, S_I_I(a))); MULT_APPLY(f,m); if (S_O_K(b) == HASHTABLE) INSERT_HASHTABLE(m,b,add_koeff,eq_monomsymfunc,hash_monompartition); else INSERT_LIST(m,b,add_koeff,comp_monomhomsym); eee: ENDR("teh_integer__faktor"); } INT teh_partition__faktor_pre290102(a,b,f) OP a,b,f; { INT erg = OK; CTO(PARTITION,"teh_partition__faktor(1)",a); CTTO(HASHTABLE,HOMSYM,"teh_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += first_partition(cons_null,S_MO_S(m)); COPY(f,S_MO_K(m)); INSERT_HOMSYMMONOM_(m,b); } else if ( S_PA_LI(a) == 1 ){ erg += teh_integer__faktor(S_PA_I(a,0),b,f); } else { INT t_loop_partition(); erg += t_loop_partition(a,b,f,teh_integer__faktor,mult_homsym_homsym,mult_apply_homsym_homsym); /* slower one INT t_splitpart();; erg += t_splitpart(a,b,f,teh_partition__faktor,mult_homsym_homsym); */ } ENDR("teh_partition__faktor"); } static INT special_teh_integer(a,b,w,ff) OP a,b; INT w; OP (*ff)(); { INT erg = OK,i; OP h,z,m; CTO(HASHTABLE,"special_teh_integer(2)",b); h = (*ff)(a); FORALL(z,h, { m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(S_MO_K(z),S_MO_K(m)); b_ks_pa(EXPONENT,CALLOCOBJECT(),S_MO_S(m)); m_il_nv(w,S_PA_S(S_MO_S(m))); C_O_K(S_PA_S(S_MO_S(m)), INTEGERVECTOR); for (i=0;i=0;l--,av++,bv++) if (S_I_I(av) != S_I_I(bv)) return FALSE; return TRUE; } INT special_mult_apply_homsym_homsym(a,b,mpm) OP a,b,mpm; /* both are hashtable */ /* both labelling partitions are are of expnent type */ /* both labelling partitions are of the same length */ /* the external variable mpm is initialised */ { OP c,z1,z2,p1,p2,p3; INT erg = OK,i,j; CTO(HASHTABLE,"special_mult_apply_homsym_homsym(1)",a); CTO(HASHTABLE,"special_mult_apply_homsym_homsym(2)",b); CTO(MONOM,"special_mult_apply_homsym_homsym(3)",mpm); NEW_VECTOR(c,WEIGHT_HASHTABLE(b)); i=0; FORALL_HASHTABLE(z2,b, { SWAP(S_V_I(c,i),z2); i++; }); /* entries in c */ /* b is empty */ for (i=S_V_LI(b)-1,z1=S_V_S(b);i>=0; i--,z1++) { if (not EMPTYP(z1) ) FREESELF_INTEGERVECTOR(z1); C_I_I(z1,-1); } M_I_I(0,S_V_I(b,S_V_LI(b))); /* b is a empty */ FORALL_HASHTABLE(z1,a, { for (j=0,z2 = S_V_S(c);j 12) ) erg += binom(oben,unten,S_MO_K(res)); else erg += binom_small(oben,unten,S_MO_K(res)); } else { M_I_I(1,S_MO_K(res)); } /* faktor bestimmen */ M_I_I(so,oben); m_il_v(ml,unten); for (ml=0,i=1;i 12) { erg += multinom(oben,unten,d); MULT_APPLY(d,S_MO_K(res)); } else { FREESELF(d); erg += multinom_small(oben,unten,d); MULT_APPLY_INTEGER(d,S_MO_K(res)); } if ((w+l)%2 == 1) /* negativ */ ADDINVERS_APPLY(S_MO_K(res)); INSERT_HOMSYMMONOM_(res,b); } } while (next_apply(c)); FREEALL(c); FREEALL(d); FREEALL(oben); FREEALL(unten); ende: ENDR("ek_to_h"); } INT t_ELMSYM_HOMSYM(a,b) OP a,b; /* AK 050901 */ { INT erg = OK; INT t=0; CTTTTO(HASHTABLE,ELMSYM,PARTITION,INTEGER,"t_ELMSYM_HOMSYM",a); TCE2(a,b,t_ELMSYM_HOMSYM,HOMSYM); if (S_O_K(b) == EMPTY) { erg += init_hashtable(b); t=1; } teh___faktor(a,b,cons_eins); if (t==1) t_HASHTABLE_HOMSYM(b,b); ENDR("t_ELMSYM_HOMSYM"); } symmetrica-2.0/tem.c0000400017361200001450000000445010726021655014333 0ustar tabbottcrontab #include "def.h" #include "macro.h" static OP tem_sp = NULL; INT tem_ende() { INT erg = OK; if (tem_sp!= NULL) { FREEALL(tem_sp); tem_sp=NULL; } ENDR("tem_ende"); } static INT tsp2_co(a,b,c,f) OP a,b,c,f; { OP m; INT erg = OK; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(a,S_MO_S(m)); COPY(f,S_MO_K(m)); if (S_O_K(c) == HASHTABLE) insert_scalar_hashtable(m,c,add_koeff,eq_monomsymfunc,hash_monompartition); else insert_list(m,c,add_koeff,comp_monommonomial); ENDR("tsp2_co"); } OP find_tem_integer(a) OP a; { INT erg = OK; CTO(INTEGER,"find_tem_integer(1)",a); SYMCHECK( (S_I_I(a) < 0) ,"find_tem_integer:parameter <0"); if (tem_sp==NULL){ tem_sp=CALLOCOBJECT();m_il_v(100,tem_sp);} if (S_I_I(a)>S_V_LI(tem_sp)) { erg += inc_vector_co(S_I_I(a)-S_V_LI(tem_sp)+30);} if (EMPTYP(S_V_I(tem_sp,S_I_I(a)))) { OP c; c = CALLOCOBJECT(); first_partition(cons_null,c); init_hashtable(S_V_I(tem_sp,S_I_I(a))); mem_integer__(a,c,S_V_I(tem_sp,S_I_I(a)),cons_eins); FREEALL(c); } return S_V_I(tem_sp,S_I_I(a)); ENDO("find_tem_integer"); } INT tem_integer__faktor(a,b,f) OP a,b,f; { OP c; INT erg = OK; CTTO(HASHTABLE,MONOMIAL,"tem_integer__faktor(2)",b); CTO(INTEGER,"tem_integer__faktor(1)",a); SYMCHECK( (S_I_I(a) < 0) ,"tem_integer__faktor:parameter <0"); if (tem_sp==NULL){ tem_sp=CALLOCOBJECT();m_il_v(100,tem_sp);} if (S_I_I(a)>S_V_LI(tem_sp)) { erg += inc_vector_co(S_I_I(a)-S_V_LI(tem_sp)+30);} if (EMPTYP(S_V_I(tem_sp,S_I_I(a)))) { c = CALLOCOBJECT(); first_partition(cons_null,c); init_hashtable(S_V_I(tem_sp,S_I_I(a))); mem_integer__(a,c,S_V_I(tem_sp,S_I_I(a)),cons_eins); FREEALL(c); } M_FORALL_MONOMIALS_IN_A(S_V_I(tem_sp,S_I_I(a)),cons_eins,b,f,tsp2_co); ENDR("tem_integer__factor"); } INT tem_partition__faktor(a,b,f) OP a,b,f; { OP c; INT erg = OK; CTTO(HASHTABLE,MONOMIAL,"tem_partition__faktor(2)",b); CTO(PARTITION,"tem_partition__faktor(1)",a); c = CALLOCOBJECT(); erg += first_partition(cons_null,c); erg += mem_partition__(a,c,b,f); FREEALL(c); ENDR("tem_partition__factor"); } symmetrica-2.0/tep.c0000400017361200001450000001525210726021656014341 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT tep_integer__faktor(); INT mpp_hashtable_hashtable_(); INT t_loop_partition(); OP find_tep_integer(); INT t_productexponent(); INT tep_partition__faktor_pre040202(a,b,f) OP a,b,f; { INT erg = OK; CTO(PARTITION,"tep_partition__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"tep_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { erg += tep_integer__faktor(cons_null,b,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += tep_integer__faktor(S_PA_I(a,0),b,f); goto ende; } else { /* erg += t_splitpart(a,b,f,tep_partition__faktor,mpp_hashtable_hashtable_); */ erg += t_loop_partition(a,b,f,tep_integer__faktor,mult_powsym_powsym, mult_apply_powsym_powsym); goto ende; } ende: ENDR("tpe_partition__faktor"); } INT tep_partition__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(PARTITION,"tep_partition__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"tep_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { erg += tep_integer__faktor(cons_null,b,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += tep_integer__faktor(S_PA_I(a,0),b,f); goto ende; } else { erg += t_productexponent(a,b,f,tep_integer__faktor,find_tep_integer); goto ende; } ende: ENDR("tpe_partition__faktor"); } INT tep_elmsym__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTTO(HASHTABLE,ELMSYM,"tep_elmsym__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"tep_elmsym__faktor(2)",b); T_FORALL_MONOMIALS_IN_A(a,b,f,tep_partition__faktor); ENDR("tep_elmsym__faktor"); } INT tep_hashtable__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(HASHTABLE,"tep_hashtable__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"tep_hashtable__faktor(2)",b); T_FORALL_MONOMIALS_IN_A(a,b,f,tep_partition__faktor); ENDR("tep_hashtable__faktor"); } INT tep___faktor(a,b,f) OP a,b,f; { INT erg = OK; CTTTTO(INTEGER,HASHTABLE,PARTITION,ELMSYM,"tep___faktor(1)",a); CTTO(HASHTABLE,POWSYM,"tep___faktor(2)",b); if (S_O_K(a) == INTEGER) { tep_integer__faktor(a,b,f); goto ende; } else if (S_O_K(a) == PARTITION) { tep_partition__faktor(a,b,f); goto ende; } else if (S_O_K(a) == HASHTABLE) { tep_hashtable__faktor(a,b,f); goto ende; } else if (S_O_K(a) == ELMSYM) { tep_elmsym__faktor(a,b,f); goto ende; } ende: ENDR("tep___faktor"); } static OP tep_sp=NULL; INT tep_ende() { INT erg = OK; if (tep_sp != NULL) { FREEALL(tep_sp); } tep_sp = NULL; ENDR("tep_ende"); } OP find_tep_integer(a) OP a; /* AK 040202 */ { INT erg = OK; CTO(INTEGER,"find_tep_integer(1)",a); SYMCHECK((S_I_I(a) < 0), "find_tep_integer:parameter < 0"); if ( (tep_sp == NULL) || (S_I_I(a) >= S_V_LI(tep_sp)) || (EMPTYP(S_V_I(tep_sp,S_I_I(a)))) ) { OP c; NEW_HASHTABLE(c); erg += tep_integer__faktor(a,c,cons_eins); FREEALL(c); } return S_V_I(tep_sp,S_I_I(a)); ENDO("find_tep_integer"); } INT tep_integer__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(INTEGER,"tep_integer__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"tep_integer__faktor(2)",b); SYMCHECK((S_I_I(a) < 0), "tep_integer__faktor:parameter < 0"); /* first check on the stored result */ if (tep_sp == NULL) NEW_VECTOR(tep_sp,100); if (S_I_I(a) >= S_V_LI(tep_sp)) erg += inc_vector_co(tep_sp, S_I_I(a) - S_V_LI(tep_sp)+5); if (not EMPTYP(S_V_I(tep_sp, S_I_I(a) ) ) ) { OP m,c; FORALL(c,S_V_I(tep_sp, S_I_I(a)), { m = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); MULT(S_MO_K(c), f, S_MO_K(m)); erg += copy_partition(S_MO_S(c),S_MO_S(m)); INSERT_POWSYMMONOM_(m,b); }); goto ende; } /* now we know */ /* the result is not stored */ if (S_I_I(a) == 0) { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(f,S_MO_K(m)); erg += first_partition(cons_null,S_MO_S(m)); INSERT_POWSYMMONOM_(m,b); init_size_hashtable(S_V_I(tep_sp,0),3); m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); M_I_I(1,S_MO_K(m)); erg += first_partition(cons_null,S_MO_S(m)); INSERT_POWSYMMONOM_(m,S_V_I(tep_sp,0)); goto ende; } else { OP c,coeff,ergebnis,sp; OP bb; c=CALLOCOBJECT(); coeff=CALLOCOBJECT(); ergebnis=CALLOCOBJECT(); sp=CALLOCOBJECT(); bb=CALLOCOBJECT(); erg += init(HASHTABLE,bb); erg += first_partition(a,c); do { OP d; INT i; m_i_i(1,sp); m_i_i(1,ergebnis); d = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); COPY(c,S_MO_S(d)); /* compute coeff */ for (i=(INT)0; i(INT)0) { if (S_PA_II(c,i) == S_PA_II(c,(i-1L))) { INC_INTEGER(sp); MULT_APPLY_INTEGER(sp,ergebnis); } else M_I_I(1L,sp); }; MULT_APPLY_INTEGER(S_PA_I(c,i),ergebnis); }; /* in ergebnis ist der coeff, es muss durch ihn geteilt werden */ erg += m_ou_b(cons_eins,ergebnis,S_MO_K(d)); C_B_I(S_MO_K(d),GEKUERZT); if ( (S_I_I(a) - S_PA_LI(c)) %2 == 1 ) M_I_I(-1,S_B_O(S_MO_K(d))); insert_scalar_hashtable(d,bb,NULL,eq_monomsymfunc,hash_monompartition); } while(next_apply(c)); FREEALL(c); FREEALL(coeff); FREEALL(ergebnis); FREEALL(sp); COPY(bb,S_V_I(tep_sp, S_I_I(a) ) ); MULT_APPLY(f,bb); if (S_O_K(b) == POWSYM) INSERT_LIST(bb,b,add_koeff,comp_monompowsym); else INSERT_HASHTABLE(bb,b,add_koeff,eq_monomsymfunc,hash_monompartition); } ende: ENDR("tep_integer__faktor"); } INT t_ELMSYM_POWSYM(a,b) OP a,b; /* AK 190901 */ { INT erg = OK; INT t=0; CTTTTO(INTEGER,HASHTABLE,PARTITION,ELMSYM,"t_ELMSYM_POWSYM(1)",a); TCE2(a,b,t_ELMSYM_POWSYM,POWSYM); if (S_O_K(b) == EMPTY) { init_hashtable(b); t=1; } tep___faktor(a,b,cons_eins); if (t==1) t_HASHTABLE_POWSYM(b,b); ENDR("t_ELMSYM_POWSYM"); } symmetrica-2.0/tes.c0000400017361200001450000000673210726021656014347 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT t_ELMSYM_SCHUR_pre041201(a,b) OP a,b; /* AK 121001 */ /* conjugate to t_HOMSYM_SCHUR */ { INT erg = OK; OP c; CTTO(PARTITION,ELMSYM,"t_ELMSYM_SCHUR_pre041201",a); if (S_O_K(a) == PARTITION) { c = callocobject(); erg += t_HOMSYM_SCHUR(a,c); erg += freeself(b); erg += conjugate_schur(c,b); erg += freeall(c); } else { OP z; z=a; while (z != NULL) { C_O_K(z,HOMSYM); z = S_L_N(z); } c = callocobject(); erg += t_HOMSYM_SCHUR(a,c); erg += freeself(b); erg += conjugate_schur(c,b); erg += freeall(c); z=a; while (z != NULL) { C_O_K(z,ELMSYM); z = S_L_N(z); } } ENDR("t_ELMSYM_SCHUR_pre041201"); } INT tes_integer__faktor(); INT mes_partition__(); INT tes_partition__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(PARTITION,"tes_partition__faktor(1)",a); CTTO(HASHTABLE,SCHUR,"tes_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { erg += tes_integer__faktor(cons_null,b,f); } else if (S_PA_LI(a) == 1) { erg += tes_integer__faktor(S_PA_I(a,0),b,f); } else { OP c; c = CALLOCOBJECT(); first_partition(cons_null,c); mes_partition__(a,c,b,f); FREEALL(c); } ENDR("tpe_partition__faktor"); } INT tes_elmsym__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTTO(HASHTABLE,ELMSYM,"tes_elmsym__faktor(1)",a); CTTO(HASHTABLE,SCHUR,"tes_elmsym__faktor(2)",b); T_FORALL_MONOMIALS_IN_A(a,b,f,tes_partition__faktor); ENDR("tes_elmsym__faktor"); } INT tes_hashtable__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(HASHTABLE,"tes_hashtable__faktor(1)",a); CTTO(HASHTABLE,SCHUR,"tes_hashtable__faktor(2)",b); T_FORALL_MONOMIALS_IN_A(a,b,f,tes_partition__faktor); ENDR("tes_hashtable__faktor"); } INT tes___faktor(a,b,f) OP a,b,f; { INT erg = OK; CTTTTO(INTEGER,HASHTABLE,PARTITION,ELMSYM,"tes___faktor(1)",a); CTTO(HASHTABLE,SCHUR,"tes___faktor(2)",b); if (S_O_K(a) == INTEGER) { tes_integer__faktor(a,b,f); goto ende; } else if (S_O_K(a) == PARTITION) { tes_partition__faktor(a,b,f); goto ende; } else if (S_O_K(a) == HASHTABLE) { tes_hashtable__faktor(a,b,f); goto ende; } else if (S_O_K(a) == ELMSYM) { tes_elmsym__faktor(a,b,f); goto ende; } ende: ENDR("tes___faktor"); } INT tes_integer__faktor(a,b,f) OP a,b,f; { INT erg = OK; OP m; CTO(INTEGER,"tes_integer__faktor(1)",a); CTTO(HASHTABLE,SCHUR,"tes_integer__faktor(2)",b); SYMCHECK((S_I_I(a) < 0), "tes_integer__faktor:parameter < 0"); m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(f,S_MO_K(m)); erg += last_partition(a,S_MO_S(m)); if (S_O_K(b) == SCHUR) INSERT_LIST(m,b,add_koeff,comp_monomschur); else insert_scalar_hashtable(m,b,add_koeff,eq_monomsymfunc,hash_monompartition); ENDR("tes_integer__faktor"); } INT t_ELMSYM_SCHUR(a,b) OP a,b; /* AK 190901 */ { INT erg = OK; INT t=0; CTTTTO(INTEGER,HASHTABLE,PARTITION,ELMSYM,"t_ELMSYM_SCHUR(1)",a); TCE2(a,b,t_ELMSYM_SCHUR,SCHUR); if (S_O_K(b) == EMPTY) { init_hashtable(b); t=1; } tes___faktor(a,b,cons_eins); if (t==1) t_HASHTABLE_SCHUR(b,b); ENDR("t_ELMSYM_SCHUR"); } symmetrica-2.0/test.c0000600017361200001450000000013210726167164014526 0ustar tabbottcrontab#include "def.h" #include "macro.h" ANFANG scan(INTEGER,a); fakul(a,b); println(b); ENDE symmetrica-2.0/tfiles.doc0000600017361200001450000005017110726170302015354 0ustar tabbottcrontabt1.c : zerlegung aller inneren produkte von schurfunktionen zu gegebenen grad. eingabe: INTEGER t2.c : einlesen eines beliebigen objects, abspeichern, wieder vom file lesen, dann ausgeben t3.c : wie t1.c aber unter verwendung von m_part_sc_tafel statt m_part_sc und mit vorheriger berechnung der charactertafel t4.c : innere product zweier schurfunktionen, und dann q -spezialisierung nach der zerlegung des products muss die laenge des alphabets angegeben werden t5.c : eingabe einer permutation w dann des grades n ,berechnet alle produkte des schubertprolynoms X_w mit allen schubertpolynomen zu permutationen vom grad n t6.c : kranztafel, eingabe zwei INTEGER t7.c : Eingabe zwei lehmercodes, ausgabe produkt der schubertpolynome mit lehmercode t8.c : eingabe lehmercode, ausgabe ergebnis von newtrans t9.c : eingabe integer, berechnung chartafel, inverse chartafel, multiplikation der ergebnise. t10.c : ein fehlerhaftes programm von tpd. eingabefiles sind data1.tpd und data2.tpd t11.c : Eingabe Skewpartition und laenge des Alphabets, berechnung der Schiefschurfunktion t12.c : Eingabe Permutation es werden alle red.dec. die tableaux sind berechnet, dann werden die umrisse mit dem ergebnis von newtrans verglichen. t13.c : eingabe grad einer s_n, und ein lehmerode einer permutation, berechnung des produkts von 100 zufaelligen schubertpolynomen des eingegebenen grades und des schubertpolynoms zum eingegeben lehmercode, ausgabe als lehmercode liste. t14.c : Eingabe schiefpartition s und Partition p , ausgabe der tableaux mit umriss s und inhalt p t15.c : Eingabe integer, ausgabe alle permutation, die nicht vexillary und die zugehoerigen tableaux, die reduced dec. sind. t16.c : inneres tensorproduct von zwei rechtecken, vielfachheit der rechtecke in der zerlegung (clausen) t17.c : innere tensorprodukte von beliebigen rechtecken, darin die vielfachheiten von rechtecken t18.c : kostkatafel berechnen und abspeichern t19.c : eingabe zwei vectoren ( stuetzpunkte und werte ) ausgabe das lagrange polynom t20.c : determinante von schubertpolynomen, eingabe der codes t21.c : chern_falg: totale chernklasse t22.c : determinant of schurpolynomial input: t22.in t23.c : determinant of schurpolynomial input multiply by diagonal matrix input t23.in t24.c : pletysm von 2 complete symm func und nur die rechtecke ausgeben t25.c : chern klass with polynomials (former schubert) t26.c : determinant of complete sym functions with binomial koeff t27.c : produkts of (1 + x_j - x_i) as schubertpolynomials: eingabe t27.in t28.c : produkt (1+a) (1+a+b) (1+a+b+c) ... as schubertpolynomial t29.c : projektive degree of schubert (Y_1 + Y_01 ... + Y_0..01)^k t30.c : change monomial - elementary and inverse t31.c : start permutation and all tableaux for the following non vex one t32.c : jeu de taquin enter skew tableau t33.c : inverses polynom labeld by permutation as schubert poly t34.c : enter degree schubertpolynomials in tex t35.c : produkts of (x_i - x_j) t36.c : produkte (1 + (x_i - x_j) + ... +(x_i -x_j)^k) output in lehmercode restricted to given degree of s_n t37.c : change of basis invers pol -- schubert pol t38.c : group generated by permutations t39.c : CYCLOTOMIC, produkt welches die fakultatet ergibt t40.c : inverse matrix mit radikalen t41.c : search for null-charakter t42.c : enter schurpolynom and length of alphabet compute q-spec t43.c : computation of representing matrix in natural representation t44.c : computation of representing matrix in modular representation moddg t45.c : enter sym character output sum of irred characters t46.c : input two schur polynomials, multiply them t47.c : input two partitions output charvale t48.c : input partition output induced character in s_(n over 2) t49.c : expansion of powersum t50.c : zerlegung von reutenauer charakteren, input rectangle shape t51.c : eingabe startpartition, liste alle nachfolgenden reutenauer charaktere t52.c : testfile fuer ndg, enter a PARTITION, runs forever t53.c : t_POLYNOM_MONOMIALS enter length of alphbet, decompose square of vandermonde t54.c : speichern von leeren listen t55.c : matrix of dominance relation eingabe: t55.in t56.c : frobenius trafo fuer eine Spalte der Charaktertafel: eingabe spalten index=PARTITION, integer fuer laenge der laengsten Partition eingabe: t56.in t57.c : permutationen with given number of inversions t58.c : word --> weintraube --> word t59.c : eingabe perm, ausgabe alle wt mit zugehoerigen tableau und q-gewicht t60.c : eingabe part, length of alphabet, output zonal polynom t61.c : enter VECTOR, compute T_I as sum of wt,sum of tab, polynom, transform polynom back to T_I t62.c : enter WORD compute tableaux, which P-symbol in robinson/schensted t63.c : enter INTEGER n, reduce the character 0,1,2,3, .. in S_n t64.c : enter PARTITION n, build matrix of that degree, compute and print immanente t65.c : hilbert matrix invertieren t66.c : enter max degree of S_n, product of Schubert polynomials t67.c : enter TABLEAUX for idempotent, apply to SCHUBERT t68.c : det of characters t69.c : computation of pi stops after 100 iterations t70.c : alle spechtpolynome zu gegebenen Umriss t71.c : berechnung der nat dg von Specht t72.c : tableau und kontertableau zu weintraube t74.c : berechnugn von schiefdarstellungen t75.c : psoitiv definit fuer ein problem von Merris Lin and Multilin Algebra 29 1991 315-317 t76.c : testfile nr 1 for new nb.c t77.c : testfile nr 2 for new nb.c t78.c : structure constants t79.c : list of structure constants t82.c : character of GL(n,q) nach Morris Math Zeitschr 1963 X^{label}_{class}(t) t85.c : pleint.c Lascoux Thurnau Sommerschule 1991 t86.c : test von odg t87.c : test von inner und outer plethysm durch vergleich gegen quadrat t88.c : 0-1 Matrizen zu vorgegebener Zeilen und spalten summe t89.c : schubert polynomial in shifted alphabet t90.c : codes die unterhalb eines lehmercodes liegen. t91.c : rank /unrank 2-elementig t92.c : lasoux example t93.c : lascoux second example shifted alphabet t94.c : lascoux tagnme statistics t95.c : hager beispiel polynomiale darstellung t96.c : rank /unrank 2-tupel mit neuer Polyasubstitution t97.c : beispiel zu idmpotent und zentralprim t98.c : naiver algorithmus gruppe zu erzeugen t99.c : algorithmus gruppe zu erzeugen aus Produkten der Erzeuger t100.c : dimino didaktisch t101.c : stabilisator/ commutator / remove_equals t102.c : orbit t103.c : schreier-vek t104.c : complete_schur_plet FEHLER bei 345 mit Opitimzer t105.c : mult MATRIX x VECTOR t106.c : operate_perm_polynom / operate_perm_vector t107.c : Vergleich der Berechnung des Zykelindex mit Dimino und der Routine zykelind_arb t108.c: routinen mit strong generator t109.c: Pragacz file t110.c: 1. Bsp barred permutation t111.c: 2. Bsp barred permutation t112.c: change of basis monomial --> schubert t113.c: beispiel of alain t114.c: geaendertes beispiel t115.c: beispiel new character t116.c: entwurf a_charvalue t117.c: test for all zykind t118.c: abgabe entwurf weber t119.c: P-Q Schur functions t120.c: remmelmult t121.c: P-Q table t122.c: P-Q table lascoux version t123.c: Euler Phi mit factorization t124.c: test auf strict bei partitionen t125.c: berechnung der young polynome und test auf richtige werte t126.c: berechnung der character polynome und test auf richtige werte t127.c: charakterpolynome als schubert polynome t128.c: automatischer texausdruck von charakterpolynomen t129.c: basiswechsel charpol --> monom t130.c: basiswechsel charpol --> monom ganze tafel fuer alle gewichte t131.c: bigchar, bigyoung t132.c: example lascoux ALain kann nich kuerzen !! t133.c: hecke Algebra Beispiel t134.c: Alain example t135.c: test of t_vec_vec_poly t136.c: test fuer alternierende gruppe mit nc-interface t137.c: multiplikation von monomial symmetric functions t138.c: berechnung eines tableau zu inhalt umriss (alg) t139.c: test fuer sym functionen t140.c: stembridge : Eulerian numbers ...Disc Math 99 p. 314 t141.c: zykelind_arb Fripertinger t141.org t142.c: test-environment t143.c: fehler von petra_mueller eingabe oh.dat t144.c: dimino fuer ueberlagerungsgruppe input t144.1 t144.2 ... t145.c: ralf dixonwilf eingabe oktaeder t146.c: t_POWSYM_ELMSYM t147.c: uli eidt version der endlichen koerper: doco t147.doc t148.c: Pragacz t149.c: lascoux 24.4.92 t150.c: lascoux 24.4.92 t151.c: lascoux 250892 t152.c: lascoux 6-92 t153.c: lascoux 11-92 t153.doc improved Axel 251192 t154.c: bad shape t155.c: bad shape still not working t156.c: first version badshape , stil problems t157.c: version bad shape 180193 still problems t158.c: problem alain geloest t159.c: christine t160.c: power series t161.c: beispiel reihen t162.c: test fuer reihen t163.c: ff bsp Dirk Lattermann t165.c: al 100393 2. Teil t166.c: al 190393 idempotente schubert t167.c: tafel und basiswechsel charpol-monomial t168.c: automatische lagrange t169.c: projektive Darstellung 1 t170.c: projektive Darstellung 2 t171.c: operate_perm_tableaux t172.c: charvalue mit charpartition, zeitvergleich t173.c: fehler bei kostka_tab_skew, geloest t174.c: beispiel von alain t175.c: first_tableaux t176.c: vminus_hecke t177.c: vertikal_sum t178.c: numberof_shufflepermutation t179.c: garnir t180.c: wybourne hecke t181.c: betten untergruppen (erste version) t182.c: zykelindex test mit s8 t183.c square of vandermond t184.c: special variables in elmsym t185.c: test routinen t186.c: eval_cons_polynom t187.c: first version of Muzychuk t188.c: second version of Muzychuk t189.c: reihe routine t190.c: zweites Beispiel Reihe t191.c: test fuer weintrauben welche symmetric sind t192.c: outerproductschur mit limit t193.c: beispiel square vandermonde von thomas noetig einf2, einf3, .. t194.c: beispiel fuer sscan t195.c: beispiel fuer brauer character t196.c: alain example t197.c: test prsym von Barop t198.c: test for finite field order / next t199.c: test for finite filed / mult t200.c: zerlegungsmatrix decp_mat t201.c: vergleich von reduzierten zerlegungen von permutationen und inversen permutationen. Verglichen werden die laengen der ansteigenden teilfolgen t202.c: berechnung modularer dimension t203.c: berechnung determinante von HOMSYM t204.c: schnittmatrix nach FF, dann rank, vergleich mit dimension_mod t205.c: weintraube / kontertableau zu permutation t206.c: alain permutations unterhalb in der bruhat ordnung t207.c: brenti kshdan lustig t208.c: problem von dirk lattermann t209.c: problem christine barop t210.c: fripertinger t211.c: best case quicksort wahrscheinlichkeit und anzahl best cases t212.c: check for t_POLYNOM_ELMSYM t213.c: double schubert t214.c: double schubert sepcialisieren in perm of 2 alpabet t215.c: rectrice t216.c: bruhat comp t217.c: gauss polynom t218.c: colex sorting with insert into lists t220.c: yamanouchi t221.c: schubert box t222.c: test fuer eval polynom t223.c: scalarproduct schubert t224.c: new invers matrix t225.c: chartafel ohne ausgabe t226.c: binary gcd t227.c: extended ggt t228.c: binaermodell chartafel t229.c: rectrice t230.c: test t_LIST_POLYNO M t231.c: alain problem t232.c: dimensionvergleich mod/gewoehnlich t233.c: beispiel langzahl in polynom t234.c: beispiel zur p-hook-diagramm t235.c: problem langzahl polynom t236.c: lascoux max/min B_n t237.c: eigene schnitt matrix berechnung wg. fehler in dim_mod t238.c: beispiel mit p_hook_diagramm t239.c: eigene modulare dimension nur mit alpha t240.c: random_bv t241.c: fastspin t242.c: bespiel lascoux fuer spin charaktere t243.c: test objectread/write bv t244.c: test m_vector_ff / m_ff_vector t246.c: test composiotn t247.c: test next bar t248.c: test cyclic chartafel t249.c: bespiel fuer symmetric move down bei wt t250.c: aufwand heap sort - heap erstellen t251.c: double schubert beispiele t253.c: barred perm schubert pragacz t254.c: test LAURENT t255.c: test BRUCH of polynomials, invers matrix of polynom matriox using adjonit and determinant t256.c: test sup/inf bitvector t257.c: test rectrice t258.c: rectrice bar t259.c: bsp carre t260.c: richtiges rectr t261.c: reverse rectrice t262.c: test english tableau t263.c: differential operator fuer sym fkt t264.c: Schensted t265.c: test pletysm t266.c: test strict_to_odd_part t267.c: test schnitt_schur t268.c: quine mc cluskey t269.c: test hecke trevor ex1.c t270.c: rz polynom t271.c: dimension_mod t272.c: loop over all permutations t273.c: random_bar t274.c: random_permutation t275.c: schnittmatrix Anzahl Nullen t276.c: t277.c t278.c t279.c: new alg wt t280.c: new alg wt t281.c: t282.c: new alg wt t283.c: vergleich schnittmat und grammat t284.c: rank mit john methode t285.c: noch was zu john t286.c: bit rank t287.c: bit rank von own schnitt t288.c: alain odg t289.c: rank von schnitt t290.c: tabloide der schnittmatrix t291.c: dim mod und immaneneten t292.c: dim mod mot bit ohne zwischenmatrix t293.c: test von zyk.c t294.c: test von vc.c t295.c: dim mod mot bit ohne zwischenmatrix anzahl nullen t296.c test fehler in m_i_pa t297.c: version bit rank t298.c: t299.c: test aenderung christoph carre gcd t300.c: test aenderung christoph carre gcd t301.c: test aenderung christoph carre gcd t302.c: test aenderung christoph carre gcd t303.c: test aenderung christoph carre gcd t304.c: test aenderung christoph carre laurent t305.c: test aenderung christoph carre laurent t306.c: neues dimmod mit einfuegen in vektorraum t307.c: test aenderung christoph carre laurent t308.c: test aenderung christoph carre laurent /* problems */ t309.c: test christoph plet 1 t310.c: double schubert eingabe lehmercode t311.c: dimmod mit packed und einfuegen t312.c: unrank subset t313.c: dimmod mit neuem rankfunktion ==> 32 bit bei 1347 t314.c: dimmod mit neuem rankfunktion ==> 32 bit bei 1347 noch schneller t315.c: result speichern testen bei makevectoroftableaux t316.c: dimmod mit mehreren files fuer tabloids t317.c: double wt ausgabe als tex-matrix falsch! t318.c: double wt mit rahmen t319.c: haegar bsp t320.c: bsp specht_dg t321.c: doppel wt funktioniert! t322.c: vergleich der tableaux bei wt-diss und double-wt t323.c: test.c vom 14.11.96 t324.c: sscan SCHUR t325.c: ex1.c hiccup t326.c: ex2.c hiccup t327.c: hecke_dg t328.c: plethysm t329.c: invers_bar, sscan_bar t330.c: reorder_hall t331.c: euler_phi t332.c: elementary_schur_plet t333.c: schur_schur_plet / length limit t334.c: schubert polynome mittels compatibler folgen t335.c: vergleich compatible gegen schubert t336.c: zu einer weintraube wird eine reduzierte zerlegung berechnet, dann wird getestet ob alle wt unterhalb zur gleichen permutation gehoeren. t337.c: malen von verband der wt/2wt t338.c: verschiedene wt - versionen t339.c: testen von INTEGER/LONGINT t340.c: test von mult power x schur t341.c: zeitvergleich chartafel_bit / chartafel_nonbit t342.c: abbildung list->zykel als bahn in sn t343.c: verschiedene ordnungen bruhat stark/schwach/ lehmer containment t344.c: whitney zahlen fuer young verband zu partitionen t345.c: whitney zahlen fuer young verband zu partitionen und skewpartitions t346.c: berechnung unimodaler folgen t347.c: berechnung unimodaler folgen t348.c: forgotten symmetric function t349.c: anzahl 0-1 matrizen t350.c: subset loop t351.c: anzahl 0-1 matrizen gute version t352.c: anzahl 0-1 matrizen gute version t353.c: anzahl 0-1 matrizen noch besser 2x bintree t354.c: anzahl 0-1 matrizen besser mit speicher fuer my_binom t355.c: 0-1 mittels newtrans, basiswechsel t356.c: erzeugen der 0-1 matrizen t356.c: erzeugen der 0-1 matrizen + bijectives tablueax paar t357.c: erzeugen der 0-1 matrizen automorphismen gruppe thomas Gruener t358.c: anzahl 0-1 matrizen mit number_01_matrices t359.c: erzeugen, automorphismengruppe, aufhoeren wenn all t360.c: knuth 0-1 bijection vor und zureuck t361.c: 0-1 isomorphe matrizen mittels knuth aus tableaux paaren t362.c: 0-1 isomorphe mittels operation auf wt, nicht so gut t363.c: 0-1 mittels speicher und teilen in der mitte t364.c: anzahl matrizen natuerliche zahlen t365.c: 0-1 mittels speicher und spaltenweise t366.c: test der hashtabelle t367.c: 0-1 mittels speicher spaltenweise, hash t368.c: 0-1 mittels hash, globaler file t369.c: erzeugende funktion fuer young verband, meine und ueno t370.c: m_lehmer_schubert_qpolynom t371.c: 0-1 hash globaler file 9.12.97 t372.c: q_gauss t373.c: chartafel t375.c: pp --> parts t376.c: basis wechsel sym func t377.c: vergleich zweier basiswechsel sym func t378.c: berechnungen zu stanley: number of reduced decompositions F und Q polynom t379.c: moebius t380.c: stanley F Q t381.c: beispiel fuer joellenbeck = gral element = summe ueber all STY t382.c: rank generating young poset, for factoring with maple t383.c: summe ueber dimension_schubert t384.c: mif format fuer polynom t385.c: test ob vex schubert = determinante t386.c: unimodal gauss/arb partition t387.c: T_I als q_polynom fuer unimodal t388.c: unimodalitaets untersuchungen an gauss polynom t389.c: ordnung beliebiger gruppe bsp: s8 als drehen auf dem wuerfel t390.c: unimodalitaetstest mit 0-1 matrix eintrag 1 falls differenz unimodal t391.c: row column matrices t392.c: testpart t393.c: test fuer mod dim mit duenner matrix t394.c: schnellere version von t393.c t395.c: perm matrix t396.c: zerlegungszahlen, schneller mit duenn, rank duenn ohne symmetrica, speichern der schnittmatrix t397.c: datenbank mit unimod sequences, nur mit gdbm nicht mit ndbm laeuft auf der btm2xm in /scratch/axel/ t398.c: versuch zum bruhat ideal. idee war mittels speziellen weintrauben operation die rank generating function zu bekommen geht nicht z.B. Y_02010 operation war o oo -- o o -o o o -o o oo - o oo - o oo um die coxeter relationen zu simulieren t399.c: statistik nach anzahl der ebenen bei den weintrauben, eingabe der grad der permutation, ausgab die Anzahl der perm, deren schubert polynom die entsprechende anzahl der ebenen hat. t400.c: statistik nach ebenen, aufgeschluesselt nach partitions paaren t403.c: t404.c: t405.c: t406.c: anzahl 01 matrizen t407.c: anzahl grassmannian permutations t408.c: anzahl grassmannian,vexillary permutations t409.c: anzahl grassman nach position decrease t410.c: newtrans mit breath first t411.c: newtrans t412.c: ranked essential set t413.c: klassen multiplikation t414.c: klassen multiplikation mit c_ijk t415.c: covering number sn t416.c: newtrans mit gegebener zahl von inversionen und geg grad t417.c: classmult c_lambda^k bis volle gruppe, ausgabe der neuen klassen t418.c: anzahl der fixpunkte als charakter zerlegen t419.c: group reduction function testen t420.c: sscan testen t421.c: determinant von chartafel, an_tafel t422.c: rank of a mtrix t423.c: sdg t424.c: bad shape darstellung brechnung der dimension t425.c: charakteristik Specht paper t426.c: neue variante fuer dimmod t427.c: neue weniger platz dimmod nur fuer mod 2 t428.c: zum berechnen des p-defects t429.c: dimmod t430.c: test von order eines group elements und order einer bdg t431.c: bdg erzeugen des invarianten unterraums t432.c: dimmod versuch 1347 auf x4 t433.c: invariante unterraueme suchen t434.c: dimmmod t435.c: dimmod andere rank_bit - not working t436.c: test m_umriss_tableaux t437.c: fuer foulkes conjecture, differenz t438.c: dnk fuer laue mittels cap t439.c: eigne berechnung plethsym t440.c: eigner algorithmus plethysm t441.c: eigner algorithmus plethysm t442.c: PSL2_23 t443.c: test von tdelete mittels multiplication von monomial symmetric functions t444.c: html output von kostka tafel t445.c: foulkes vergleich t446.c: foulkes vergleich einzelne partition t448.c: foulkes monomial symmetric leading terms zu gegebenen rechteck t449.c: foulkes monomial symmetric leading terms zu gegebener partitionsumriss t450.c: foulkes monomial symmetric leading terms zu gegebener partitionsumriss und gegebenen inhalt (abfallend) t451.c: dimmod mit threads t452.c: dominance for news t453.c: test auf fehler in james/kerber aber stembridge verwechselt die reihenfolge t454.c: square free part symmetrica-2.0/the.c0000400017361200001450000000165710726021657014336 0ustar tabbottcrontab#include "def.h" #include "macro.h" OP find_teh_integer(); INT the_integer__faktor( a,b,f) OP a,b,f; { return teh_integer__faktor(a,b,f); } OP find_the_integer(a) OP a; { return find_teh_integer(a); } INT t_HOMSYM_ELMSYM(a,b) OP a,b; /* AK 231192 */ { INT erg = OK; INT s=0; OP z; CTTTTO(HASHTABLE,HOMSYM,INTEGER,PARTITION,"t_HOMSYM_ELMSYM(1)",a); TCE2(a,b,t_HOMSYM_ELMSYM,ELMSYM); if (S_O_K(a) == HOMSYM) { z = a; while(z!=NULL) { C_O_K(z,ELMSYM); z = S_S_N(z); } s = 1; } if (S_O_K(b) == ELMSYM) { z = b; while(z!=NULL) { C_O_K(z,HOMSYM); z = S_S_N(z); } } erg += t_ELMSYM_HOMSYM(a,b); if (S_O_K(b) == HOMSYM) { z = b; while(z!=NULL) { C_O_K(z,ELMSYM); z = S_S_N(z); } } if (s == 1) { z = a; while(z!=NULL) { C_O_K(z,HOMSYM); z = S_S_N(z); } } ENDR("t_HOMSYM_ELMSYM"); } symmetrica-2.0/thm.c0000400017361200001450000000631310726021657014340 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT t_HOMSYM_MONOMIAL(a,b) OP a,b; /* AK 260901 */ /* faster using newmultiplication h_n \times m_I = \sum c_n,I,J m_J */ { INT erg = OK; OP m; CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"t_HOMSYM_MONOMIAL",a); TCE2(a,b,t_HOMSYM_MONOMIAL,MONOMIAL); m=CALLOCOBJECT(); erg += first_partition(cons_null,m); erg += mult_homsym_monomial(a,m,b); FREEALL(m); ENDR("t_HOMSYM_MONOMIAL"); } static OP thm_sp = NULL; INT thm_ende() { INT erg = OK; if (thm_sp!= NULL) { FREEALL(thm_sp); thm_sp=NULL; } ENDR("thm_ende"); } static INT thm2_co(a,b,c,f) OP a,b,c,f; { OP m; INT erg = OK; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(a,S_MO_S(m)); COPY(f,S_MO_K(m)); if (S_O_K(c) == HASHTABLE) insert_scalar_hashtable(m,c,add_koeff,eq_monomsymfunc,hash_monompartition); else insert_list(m,c,add_koeff,comp_monommonomial); ENDR("thm2_co"); } OP find_thm_integer(a) OP a; { INT erg = OK; CTO(INTEGER,"find_thm_integer(1)",a); SYMCHECK( (S_I_I(a) < 0) ,"find_thm_integer:parameter <0"); if (thm_sp==NULL){ thm_sp=CALLOCOBJECT();m_il_v(100,thm_sp);} if (S_I_I(a)>S_V_LI(thm_sp)) { erg += inc_vector_co(S_I_I(a)-S_V_LI(thm_sp)+30);} if (EMPTYP(S_V_I(thm_sp,S_I_I(a)))) { OP c; c = CALLOCOBJECT(); first_partition(a,c); init_hashtable(S_V_I(thm_sp,S_I_I(a))); do { OP m; m= CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); M_I_I(1,S_MO_K(m)); COPY(c,S_MO_S(m)); insert_scalar_hashtable(m,S_V_I(thm_sp,S_I_I(a)),NULL,eq_monomsymfunc,hash_monompartition); } while (next_apply(c)); FREEALL(c); } return S_V_I(thm_sp,S_I_I(a)); ENDO("find_thm_integer"); } INT thm_integer__faktor(a,b,f) OP a,b,f; { OP c; INT erg = OK; CTTO(HASHTABLE,MONOMIAL,"thm_integer__faktor(2)",b); CTO(INTEGER,"thm_integer__faktor(1)",a); SYMCHECK( (S_I_I(a) < 0) ,"thm_integer__faktor:parameter <0"); if (thm_sp==NULL){ thm_sp=CALLOCOBJECT();m_il_v(100,thm_sp);} if (S_I_I(a)>S_V_LI(thm_sp)) { erg += inc_vector_co(S_I_I(a)-S_V_LI(thm_sp)+30);} if (EMPTYP(S_V_I(thm_sp,S_I_I(a)))) { c = CALLOCOBJECT(); first_partition(a,c); init_hashtable(S_V_I(thm_sp,S_I_I(a))); do { OP m; m= CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); M_I_I(1,S_MO_K(m)); COPY(c,S_MO_S(m)); insert_scalar_hashtable(m,S_V_I(thm_sp,S_I_I(a)),NULL,eq_monomsymfunc,hash_monompartition); } while (next_apply(c)); FREEALL(c); } erg += m_forall_monomials_in_a(S_V_I(thm_sp,S_I_I(a)),cons_eins,b,f,thm2_co); ENDR("thm_integer__factor"); } INT thm_partition__faktor(a,b,f) OP a,b,f; { OP c; INT erg = OK; CTTO(HASHTABLE,MONOMIAL,"thm_partition__faktor(2)",b); CTO(PARTITION,"thm_partition__faktor(1)",a); c = CALLOCOBJECT(); erg += first_partition(cons_null,c); erg += mhm_partition__(a,c,b,f); FREEALL(c); ENDR("thm_partition__factor"); } symmetrica-2.0/thp.c0000400017361200001450000002102510726021660014332 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT thp___faktor(); INT thp_integer__faktor(); INT mhp_integer_hashtable_(); INT t_splitpart(); INT mpp___(); INT t_HOMSYM_POWSYM(a,b) OP a,b; /* AK 190901 */ { INT erg = OK; INT t=0; CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"t_HOMSYM_POWSYM(1)",a); TCE2(a,b,t_HOMSYM_POWSYM,POWSYM); if (S_O_K(b) == EMPTY) { init_hashtable(b);t=1; } CTTO(HASHTABLE,POWSYM,"t_HOMSYM_POWSYM(2)",b); thp___faktor(a,b,cons_eins); if (t==1) t_HASHTABLE_POWSYM(b,b); ENDR("t_HOMSYM_POWSYM"); } static OP htop_sp=NULL; INT thp_ende() { INT erg = OK; if (htop_sp != NULL) { FREEALL(htop_sp); } htop_sp = NULL; ENDR("thp_ende"); } OP find_thp_integer(a) OP a; /* AK 221101 */ /* zeiger auf gespeicherten wert */ { INT erg = OK; CTO(INTEGER,"find_thp_integer(1)",a); SYMCHECK((S_I_I(a) <= 0) , "find_thp_integer:parameter <=0"); if (htop_sp == NULL) NEW_VECTOR(htop_sp,20); if (S_V_LI(htop_sp) <= S_I_I(a)) erg += inc_vector_co(htop_sp , S_I_I(a)-S_V_LI(htop_sp)+2); if (not EMPTYP(S_V_I(htop_sp, S_I_I(a)))) return S_V_I(htop_sp, S_I_I(a)); else { OP c; NEW_HASHTABLE(c); thp_integer__faktor(a,c,cons_eins); FREEALL(c); return S_V_I(htop_sp, S_I_I(a)); } ENDO("find_thp_integer"); } INT thp_integer__faktor(a,b,faktor) OP a,b; OP faktor; /* AK 311001 */ /* b = b + h_a * f */ { INT erg = OK; OP c,ergebnis,sp; OP bb; CTO(INTEGER,"thp_integer__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"thp_integer__faktor(2)",b); CTO(ANYTYPE,"thp_integer__faktor(3)",faktor); SYMCHECK((S_I_I(a) < 0), "thp_integer__faktor:parameter < 0"); if (S_I_I(a) == 0) { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); COPY(faktor,S_MO_K(m)); erg += first_partition(cons_null,S_MO_S(m)); if (S_O_K(b) == POWSYM) INSERT_LIST(m,b,add_koeff,comp_monompowsym); else INSERT_HASHTABLE(m,b,add_koeff,eq_monomsymfunc,hash_monompartition); goto ende; } SYMCHECK((S_I_I(a) <= 0), "thp_integer__faktor:(i1)"); if (htop_sp == NULL) { htop_sp = CALLOCOBJECT(); erg += m_il_v(100,htop_sp); } if (S_V_LI(htop_sp) <= S_I_I(a)) erg += inc_vector_co(htop_sp , S_I_I(a)-S_V_LI(htop_sp)+2); if (not EMPTYP(S_V_I(htop_sp, S_I_I(a)))) { OP m; FORALL(c,S_V_I(htop_sp, S_I_I(a)), { m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); MULT(S_MO_K(c), faktor, S_MO_K(m)); copy_partition(S_MO_S(c),S_MO_S(m)); if (S_O_K(b) == POWSYM) INSERT_LIST(m,b,add_koeff,comp_monompowsym); else INSERT_HASHTABLE(m,b,add_koeff,eq_monomsymfunc,hash_monompartition); }); goto ende; } c=CALLOCOBJECT(); sp=CALLOCOBJECT(); bb=CALLOCOBJECT(); /* erg += init(POWSYM,bb); */ erg += init(HASHTABLE,bb); erg += first_partition(a,c); do { OP d; INT i; CTO(PARTITION,"thp_integer__faktor(i1)",c); M_I_I(1,sp); ergebnis=CALLOCOBJECT(); M_I_I(1,ergebnis); d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); erg += copy_partition(c,S_MO_S(d)); /* compute coeff */ for (i=(INT)0; i(INT)0) { if (S_PA_II(c,i) == S_PA_II(c,(i-1L))) { INC_INTEGER(sp); MULT_APPLY_INTEGER(sp,ergebnis); } else M_I_I(1L,sp); }; MULT_APPLY_INTEGER(S_PA_I(c,i),ergebnis); }; /* in ergebnis ist der coeff, es muss durch ihn geteilt werden */ erg += b_ou_b(CALLOCOBJECT(),ergebnis,S_MO_K(d)); M_I_I(1,S_B_O(S_MO_K(d))); C_B_I(S_MO_K(d), GEKUERZT); /* INSERT_LIST(d,bb,NULL,comp_monompowsym); */ insert_scalar_hashtable(d,bb,NULL,eq_monomsymfunc,hash_monompartition); } while(next_apply(c)); FREEALL(c); FREEALL(sp); COPY(bb,S_V_I(htop_sp, S_I_I(a))); MULT_APPLY(faktor,bb); if (S_O_K(b) == POWSYM) INSERT_LIST(bb,b,add_koeff,comp_monompowsym); else INSERT_HASHTABLE(bb,b,add_koeff,eq_monomsymfunc,hash_monompartition); ende: CTTO(HASHTABLE,POWSYM,"thp_integer__faktor(e2)",b); ENDR("thp_integer__faktor"); } INT mpp_hashtable_hashtable_(); INT t_productexponent(); INT thp_partition__faktor(a,b,f) OP a,b; OP f; /* AK 300102 */ { INT erg = OK; CTO(PARTITION,"thp_partition__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"thp_partition__faktor(2)",b); erg += t_productexponent(a,b,f,thp_integer__faktor,find_thp_integer); ENDR("thp_partition__faktor"); } INT thp_partition__faktor_pre300102(a,b,faktor) OP a,b; OP faktor; { INT erg = OK; CTO(PARTITION,"thp_partition__faktor(1)",a); CTTO(HASHTABLE,POWSYM,"thp_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { erg += thp_integer__faktor(cons_null,b,faktor); goto endr_ende; } else if (S_PA_LI(a) == 1) { erg += thp_integer__faktor(S_PA_I(a,0),b,faktor); goto endr_ende; } else if (S_PA_LI(a) == 2) { OP p1,p2; p1 = find_thp_integer(S_PA_I(a,0)); p2 = find_thp_integer(S_PA_I(a,1)); erg += mpp___(p1,p2,b,faktor); } else if (S_PA_LI(a) == 3) { OP p1,p2; p1 = find_thp_integer(S_PA_I(a,2)); M_I_I(2,S_PA_L(a)); p2 = CALLOCOBJECT();init_hashtable(p2); thp_partition__faktor(a,p2,cons_eins); erg += mpp___(p1,p2,b,faktor); M_I_I(3,S_PA_L(a)); FREEALL(p2); } else { erg += t_splitpart(a,b,faktor,thp_partition__faktor,mpp_hashtable_hashtable_); goto endr_ende; } ENDR("thp_partition__faktor"); } INT thp_homsym__faktor(a,b,f) OP a,b,f; { INT erg = OK; static int level=0; level += 2; CTO(HOMSYM,"thp_homsym__faktor(1)",a); CTTO(POWSYM,HASHTABLE,"thp_homsym__faktor(2)",b); if (S_L_S(a) == NULL) goto eee; if (S_S_N(a) == NULL) { OP ff; ff = CALLOCOBJECT(); MULT(S_S_K(a),f,ff); erg += thp_partition__faktor(S_S_S(a),b,ff); FREEALL(ff); goto eee;} if (S_S_SLI(a) == 0) { if (EINSP(f)) erg += thp_partition__faktor(S_S_S(a),b,S_S_K(a)); else { OP ff = CALLOCOBJECT(); MULT(f,S_S_K(a),ff); erg += thp_partition__faktor(S_S_S(a),b,ff); FREEALL(ff); } erg += thp_homsym__faktor(S_S_N(a),b,f); goto eee; } else { OP z,zv,hi,ff; INT i,j; i = S_S_SII(a,0); z = a;zv = NULL; again: if (S_S_SII(z,0) == i) { for (j=0;ji */ /* zv ist der letzte teil mit kleinsten teil = i */ /* berechne : h_i * h_a + h_z */ C_S_N(zv,NULL); ff = CALLOCOBJECT(); init_hashtable(ff); hi = CALLOCOBJECT(); M_I_I(i,hi); erg += thp_homsym__faktor(a,ff,cons_eins); erg += mhp_integer_hashtable_(hi,ff,b,f); if (z != NULL) erg += thp_homsym__faktor(z,b,f); FREEALL(hi); FREEALL(ff); /* a wieder richtig zusammen bauen */ zv = a; aa: for (j=S_S_SLI(zv);j>0;j--) M_I_I(S_S_SII(zv,j-1),S_S_SI(zv,j)); M_I_I(i,S_S_SI(zv,0)); M_I_I(S_S_SLI(zv)+1,S_S_SL(zv)); if (S_S_N(zv) != NULL) { zv = S_S_N(zv); goto aa; } C_S_N(zv,z); } eee: level -= 2; ENDR("thp_homsym__faktor"); } INT thp___faktor(a,b,f) OP a,b; OP f; /* AK 190901 */ { INT erg = OK; CTTTTO(INTEGER,PARTITION,HASHTABLE,HOMSYM,"thp___faktor(1)",a); CTTO(POWSYM,HASHTABLE,"thp___faktor(2)",b); if (S_O_K(a) == INTEGER) erg += thp_integer__faktor(a,b,f); else if (S_O_K(a) == PARTITION) erg += thp_partition__faktor(a,b,f); else if (S_O_K(a) == HOMSYM) erg += thp_homsym__faktor(a,b,f); else /* HASHTABLE */ { T_FORALL_MONOMIALS_IN_A(a,b,f,thp_partition__faktor); } ENDR("thp___faktor"); } symmetrica-2.0/ths.c0000400017361200001450000000100510726021660014331 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT t_HOMSYM_SCHUR(a,b) OP a,b; /* AK 121001 */ /* faster using newmultiplication h_n \times S_I = \sum c_n,I,J S_J */ { INT erg = OK; OP m; CTTTTO(HASHTABLE,INTEGER,PARTITION,HOMSYM,"t_HOMSYM_SCHUR",a); TCE2(a,b,t_HOMSYM_SCHUR,SCHUR); m=CALLOCOBJECT(); erg += first_partition(cons_null,m); erg += m_pa_s(m,m); erg += mult_homsym_schur(a,m,b); FREEALL(m); CTTO(HASHTABLE,SCHUR,"t_HOMSYM_SCHUR(e2)",b); ENDR("t_HOMSYM_SCHUR"); } symmetrica-2.0/tme.c0000400017361200001450000002500410726021661014326 0ustar tabbottcrontab/* SYMMETRICA sr.c */ #include "def.h" #include "macro.h" OP me_speicher = NULL; INT tme___faktor(); INT tme_monomial__faktor(); INT tmh_integer__faktor(); INT mee_integer_hashtable_(); INT mem_integer_hashtable_(); INT txx_null__faktor(); INT t_splitpart(); INT tme_ende() { INT erg = OK; if (me_speicher != NULL) { FREEALL(me_speicher); } me_speicher=NULL; ENDR("tme_ende"); } INT t_MONOMIAL_ELMSYM(a,b) OP a,b; /* AK 121101 */ { INT erg = OK; INT t = 0; CTTTTO(INTEGER,PARTITION,MONOMIAL,HASHTABLE,"t_MONOMIAL_ELMSYM(1)",a); if (a == b) { OP c; c = CALLOCOBJECT(); *c = *a; C_O_K(a,EMPTY); erg += init_hashtable(b); t = 1; erg += tme___faktor(c,b,cons_eins); FREEALL(c); } else if (S_O_K(b) == ELMSYM) { OP c; c = CALLOCOBJECT(); erg += init_hashtable(c); erg += tme___faktor(a,c,cons_eins); insert(c,b,add_koeff,comp_monomelmsym); } else { if (S_O_K(b) == EMPTY) { erg += init_hashtable(b); t = 1; } if (S_O_K(b) != HASHTABLE) { FREESELF(b); erg += init_hashtable(b); t = 1; } erg += tme___faktor(a,b,cons_eins); } if (t == 1) erg += t_HASHTABLE_ELMSYM(b,b); ENDR("t_MONOMIAL_ELMSYM"); } OP find_tmh_integer(); OP find_tme_integer(a) OP a; /* AK 300102 */ { INT erg = OK; CTO(INTEGER,"find_tme_integer(1)",a); SYMCHECK(S_I_I(a) < 0, "find_tme_integer:integer <0"); if (S_I_I(a) % 2 == 1) return find_tmh_integer(a); if (me_speicher == NULL) { me_speicher=CALLOCOBJECT(); erg += m_il_v(40,me_speicher); } if (S_I_I(a) >= S_V_LI(me_speicher)) { erg += inc_vector_co(me_speicher,S_I_I(a)-S_V_LI(me_speicher)+5); } if (EMPTYP(S_V_I(me_speicher,S_I_I(a))) ) { OP c; c = find_tmh_integer(a); MULT_INTEGER(cons_negeins,c,S_V_I(me_speicher,S_I_I(a) ) ) ; } return S_V_I(me_speicher,S_I_I(a)); ENDO("find_tme_integer"); } INT tme_integer__faktor(a,b,f) OP a,b; OP f; { INT erg = OK; CTO(INTEGER,"tme_integer__faktor(1)",a); CTO(HASHTABLE,"tme_integer__faktor(2)",b); SYMCHECK(S_I_I(a) < 0, "tme_integer__faktor:integer <0"); if (S_I_I(a) == 0) { txx_null__faktor(b,f); goto ende; } else if (S_I_I(a) %2 == 0) { OP c; c = CALLOCOBJECT(); ADDINVERS(f,c); erg += tmh_integer__faktor(a,b,c); FREEALL(c); goto ende; } else { erg += tmh_integer__faktor(a,b,f); goto ende; } ende: ENDR("tme_integer__faktor"); } INT tme_partition__faktor(a,b,f) OP a,b; OP f; { INT erg = OK; CTO(PARTITION,"tme_partition__faktor(1)",a); CTO(HASHTABLE,"tme_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { txx_null__faktor(b,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += tme_integer__faktor(S_PA_I(a,0),b,f); goto ende; } else{ OP e; e = CALLOCOBJECT(); erg += m_pa_mon(a,e); erg += tme_monomial__faktor(e,b,f); FREEALL(e); goto ende; } ende: ENDR("tme_partition__faktor"); } INT tme_hashtable__faktor(a,b,f) OP a,b; OP f; { INT erg = OK; CTO(HASHTABLE,"tme_hashtable__faktor(1)",a); CTO(HASHTABLE,"tme_hashtable__faktor(2)",b); erg += tme_monomial__faktor(a,b,f); ENDR("tme_hashtable__faktor"); } INT tme_monomial__faktor(a,b,f) OP a,b; OP f; { INT erg = OK; OP z=NULL,ha,e_i,ohne_i,e_ohne_i; INT i; CTTO(HASHTABLE,MONOMIAL,"tme_monomial__faktor(1)",a); CTO(HASHTABLE,"tme_monomial__faktor(2)",b); CTO(ANYTYPE,"tme_monomial__faktor(3)",f); if (S_O_K(a) == MONOMIAL) { if (S_L_S(a) == NULL) { goto endr_ende; } if (S_L_N(a) == NULL) { if (S_PA_LI(S_S_S(a)) == 0) { OP e; e = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),e); erg += first_partition(cons_null,S_MO_S(e)); COPY(S_S_K(a),S_MO_K(e)); MULT_APPLY(f,S_MO_K(e)); INSERT_HASHTABLE(e,b,add_koeff,eq_monomsymfunc,hash_monompartition); goto ende; } else if (S_PA_LI(S_S_S(a)) == 1) { OP w; w = CALLOCOBJECT(); MULT(f,S_S_K(a),w); erg += tme_integer__faktor(S_PA_I(S_S_S(a),0),b,w); FREEALL(w); goto ende; } } } else if (S_O_K(a) == HASHTABLE) { if (S_V_II(a,S_V_LI(a)) == 0) { goto ende; } if (S_V_II(a,S_V_LI(a)) == 1) { FORALL(z,a, { goto fff; } ); fff: if (S_PA_LI(S_MO_S(z)) == 0) { OP e; e = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),e); erg += first_partition(cons_null,S_MO_S(e)); COPY(S_MO_K(z),S_MO_K(e)); MULT_APPLY(f,S_MO_K(e)); INSERT_HASHTABLE(e,b,add_koeff,eq_monomsymfunc,hash_monompartition); goto ende; } else if (S_PA_LI(S_MO_S(z)) == 1) { OP w; w = CALLOCOBJECT(); MULT(f,S_MO_K(z),w); erg += tme_integer__faktor(S_PA_I(S_MO_S(z),0),b,w); FREEALL(w); goto ende; } } } /* die eigentliche rekursion */ /* step one: find the minimum length of the partitions in a */ z = findmin_monomial(a,length_comp_part); i = S_PA_LI(S_MO_S(z)); ha = CALLOCOBJECT(); COPY(a,ha); NEW_HASHTABLE(ohne_i); NEW_HASHTABLE(e_ohne_i); e_i = CALLOCOBJECT(); while (i>=0) { /* hole alle partitionen der laenge i aus dem MONOMIAL ha */ OP v,m,p; INT j,k; CTTO(MONOMIAL,HASHTABLE,"tme_monomial__faktor(i-ha)",ha); if (S_O_K(ha) == MONOMIAL) { /* abbruch bedingung */ if (S_L_S(ha) == NULL) break; /* zweite abbruch bedingung */ if (S_L_N(ha) == NULL) if ((S_PA_LI(S_S_S(ha)) == 0) || (S_PA_II(S_S_S(ha), S_PA_LI(S_S_S(ha))-1 ) == 1) ) { OP h=CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),h); erg +=first_partition(S_PA_L(S_S_S(ha)),S_MO_S(h)); COPY(S_S_K(ha),S_MO_K(h)); if (not EINSP(f)) MULT_APPLY(f,S_MO_K(h)); INSERT_HASHTABLE(h,b,add_koeff,eq_monomsymfunc, hash_monompartition); break; } } else if (S_O_K(ha) == HASHTABLE) { /* abbruch bedingung */ if (S_V_II(ha,S_V_LI(ha)) == 0) break; /* zweite abbruch bedingung */ if (S_V_II(ha,S_V_LI(ha)) == 1) { FORALL(z,ha,{goto eee;}); eee: if ((S_PA_LI(S_MO_S(z)) == 0) || (S_PA_II(S_MO_S(z), S_PA_LI(S_MO_S(z))-1 ) == 1) ) { OP h=CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),h); erg +=first_partition(S_PA_L(S_MO_S(z)),S_MO_S(h)); COPY(S_MO_K(z),S_MO_K(h)); if (not EINSP(f)) MULT_APPLY(f,S_MO_K(h)); INSERT_HASHTABLE(h,b,add_koeff,eq_monomsymfunc, hash_monompartition); break; } } } FORALL(z,ha, { if (S_PA_LI(S_MO_S(z)) == i) /* kommt nach ohne_i */ { for (j=0;j 1) break; /* an der stelle j geht die eigentliche partition los */ v = CALLOCOBJECT(); erg +=m_il_v(i-j,v); for (k=0;k= S_V_LI(mh_speicher) ) || (EMPTYP(S_V_I(mh_speicher,S_I_I(a))) ) ) { OP c; NEW_HASHTABLE(c); tmh_integer__faktor(a,c,cons_eins); FREEALL(c); } return S_V_I(mh_speicher,S_I_I(a)); ENDO("find_tmh_integer"); } INT tmh_integer__faktor(a,b,faktor) OP a,b;OP faktor; /* called from tme_integer__faktor */ { INT erg = OK; OP p,c; CTO(INTEGER,"tmh_integer__faktor(1)",a); CTO(HASHTABLE,"tmh_integer__faktor(2)",b); SYMCHECK( (S_I_I(a) < 0) ,"tmh_integer__faktor:integer < 0"); if (mh_speicher == NULL) { mh_speicher=CALLOCOBJECT(); m_il_v(20,mh_speicher); } if (S_I_I(a) >= S_V_LI(mh_speicher) ) { erg += inc_vector_co(mh_speicher, S_I_I(a)+5- S_V_LI(mh_speicher)); } again: if (not EMPTYP(S_V_I(mh_speicher,S_I_I(a)) ) ) { OP d,m; FORALL(d,S_V_I(mh_speicher,S_I_I(a)), { m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); copy_partition(S_MO_S(d),S_MO_S(m)); MULT(faktor,S_MO_K(d),S_MO_K(m)); insert_scalar_hashtable(m,b,add_koeff,eq_monomsymfunc,hash_monompartition); }); goto eee; } SYMCHECK(not EMPTYP(S_V_I(mh_speicher,S_I_I(a))),"tmh_integer__faktor:i1"); init_size_hashtable(S_V_I(mh_speicher,S_I_I(a)), 2 * numberofpart_i(a)+1); /* erg += init(HASHTABLE,S_V_I(mh_speicher,S_I_I(a))); */ if (S_I_I(a) == 0) { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); first_partition(cons_null,S_MO_S(m)); M_I_I(1,S_MO_K(m)); insert_scalar_hashtable(m, S_V_I(mh_speicher,0), add_koeff, eq_monomsymfunc, hash_monompartition); goto again; } p = CALLOCOBJECT(); erg += first_partition(a,p); c = CALLOCOBJECT(); do { OP m; m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); erg += copy_partition(p,S_MO_S(m)); erg += m_k_to_h_lambda(a,p,S_MO_K(m)); if (EINSP(faktor)) { add_apply_hashtable(m,b,add_koeff,eq_monomsymfunc, hash_monompartition); insert_scalar_hashtable(m,S_V_I(mh_speicher,S_I_I(a)),add_koeff, eq_monomsymfunc,hash_monompartition); } else{ OP k1,k2; k1 = CALLOCOBJECT(); k2 = S_MO_K(m); MULT(faktor,k2,k1); C_MO_K(m,k1); add_apply_hashtable(m,b,add_koeff,eq_monomsymfunc, hash_monompartition); C_MO_K(m,k2); FREEALL(k1); insert_scalar_hashtable(m,S_V_I(mh_speicher,S_I_I(a)),add_koeff, eq_monomsymfunc,hash_monompartition); } } while(next_apply(p)); FREEALL(c); FREEALL(p); eee: ENDR("tmh_integer__faktor"); } INT mhh_hashtable_hashtable_(); INT tmh_partition__faktor(a,b,faktor) OP a,b;OP faktor; { INT erg = OK; CTO(PARTITION,"tmh_partition__faktor(1)",a); CTO(HASHTABLE,"tmh_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { OP d; d = CALLOCOBJECT(); erg += b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),d); COPY(faktor,S_MO_K(d)); erg += first_partition(cons_null,S_MO_S(d)); insert_scalar_hashtable(d,b,add_koeff,eq_monomsymfunc, hash_monompartition); goto eee; } else if (S_PA_LI(a) == 1) { erg += tmh_integer__faktor(S_PA_I(a,0),b,faktor); goto eee; } else if (S_PA_II(a,S_PA_LI(a)-1) == 1) { /* AK 191001 */ erg += teh_integer__faktor(S_PA_L(a),b,faktor); goto eee; } else { erg += monomial_recursion(a,b,faktor, tmh_partition__faktor, tmh___faktor, mhh_hashtable_hashtable_); goto eee; } eee: ENDR("tmh_partition__faktor"); } INT monomial_recursion2(a,b,faktor,partf,integerf,elmsymf,multf) OP a,b;OP faktor; INT (*partf)(); INT (*multf)(); INT (*integerf)(); INT (*elmsymf)(); /* implementiert die zweite rekursion fuer monomial symmetric functions */ { INT erg = OK; OP z,ha,h2,h3; /* static INT level=0; */ CTTO(HASHTABLE,MONOMIAL,"monomial_recursion2(1)",a); CTO(HASHTABLE,"monomial_recursion2(2)",b); ha = CALLOCOBJECT(); if (S_O_K(a) == HASHTABLE) COPY(a,ha); else t_MONOMIAL_HASHTABLE(a,ha); /* die partitionen in ha werden immer kuerzer */ NEW_HASHTABLE(h2); NEW_HASHTABLE(h3); while (not NULLP_HASHTABLE(ha)) { OP c,p1,p2,m1,m2,coeff; /* step one */ /* find a partition of maximal length */ z = findmax_monomial(ha,length_comp_part); if (S_PA_LI(S_MO_S(z)) == 0) { /* constant term only */ OP f; f = CALLOCOBJECT(); MULT(S_MO_K(z),faktor,f); (*integerf)(cons_null,b,f); FREESELF(z); DEC_INTEGER(S_V_I(ha,S_V_LI(ha))); FREEALL(f); continue; } if (S_PA_LI(S_MO_S(z)) == 1) { /* powsym */ OP f; f = CALLOCOBJECT(); MULT(S_MO_K(z),faktor,f); (*integerf)(S_PA_I(S_MO_S(z),0),b,f); FREESELF(z); DEC_INTEGER(S_V_I(ha,S_V_LI(ha))); FREEALL(f); continue; } if (S_PA_II(S_MO_S(z), S_PA_LI(S_MO_S(z))-1) == 1) { /* elmsym */ OP f; f = CALLOCOBJECT(); MULT(S_MO_K(z),faktor,f); (*elmsymf)(S_PA_L(S_MO_S(z)),b,f); FREESELF(z); DEC_INTEGER(S_V_I(ha,S_V_LI(ha))); FREEALL(f); continue; } p1 = CALLOCOBJECT(); p2 = CALLOCOBJECT(); splitpart(S_MO_S(z),p1,p2); NEW_HASHTABLE(m1); erg += mmm_partition_partition_(p1,p2,m1,cons_eins); m2 = CALLOCOBJECT(); erg += b_sk_mo(NULL,NULL,m2); C_MO_S(m2,S_MO_S(z)); c = find_hashtable(m2,m1,eq_monomsymfunc,hash_monompartition); SYMCHECK( (c == NULL) ,"monomial_recursion2:wrong leading monomial"); coeff = CALLOCOBJECT(); erg += div(S_MO_K(z),S_MO_K(c),coeff); /* leitkoeff */ MULT_APPLY(coeff,m1); /* es gilt jetzt m_a = (m_p1 * m_p2 )*coeff - m1 */ /* m1 von ha abziehen */ addinvers_apply_hashtable(m1); INSERT_HASHTABLE(m1,ha,add_koeff,eq_monomsymfunc,hash_monompartition); /* ha ist jetzt ohne maximale monom und m1 wurde abgezogen */ erg += (*partf)(p1,h2,coeff); C_MO_S(m2,p1); C_MO_K(m2,coeff); FREEALL(m2); /* wg NULL in b_sk_mo *//* p1, coeff freed */ erg += (*partf)(p2,h3,faktor); FREEALL(p2); erg += (*multf)(h3,h2,b); CLEAR_HASHTABLE(h2); CLEAR_HASHTABLE(h3); } FREEALL(ha); FREEALL(h2); FREEALL(h3); /* level--; */ ENDR("monomial_recursion2"); } INT tmh_monomial__faktor(a,b,faktor) OP a,b;OP faktor; { INT erg = OK; CTTO(HASHTABLE,MONOMIAL,"tmh_monomial__faktor(1)",a); CTO(HASHTABLE,"tmh_monomial__faktor(2)",b); monomial_recursion2(a,b,faktor, tmh_partition__faktor,tmh_integer__faktor,teh_integer__faktor, mult_homsym_homsym); ENDR("tmh_monomial__faktor"); } INT tmh___faktor(a,b,faktor) OP a,b;OP faktor; /* AK 180901 */ /* after multiplication by the faktor the result will be inserted in the hashtable b */ /* not static used from tme.c */ { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,MONOMIAL,PARTITION,"tmh___faktor(1)",a); CTO(HASHTABLE,"tmh___faktor(2)",b); CTO(ANYTYPE,"tmh___faktor(3)",faktor); if (mh_speicher == NULL) { mh_speicher=CALLOCOBJECT(); m_il_v(20,mh_speicher); } if (S_O_K(a) == INTEGER) { erg += tmh_integer__faktor(a,b,faktor); goto eee; } else if (S_O_K(a) == PARTITION) { erg += tmh_partition__faktor(a,b,faktor); goto eee; } else /* HASHTABLE MONOMIAL */ { erg += tmh_monomial__faktor(a,b,faktor); goto eee; } eee: ENDR("tmh___faktor"); } static INT m_k_to_h_lambda(a,b,c) OP a,b,c; /* AK 180901 */ /* computes the single coefficient */ /* of h_b in the expansion of m_k */ { INT erg = OK,w,i,l; OP exp,oben,mn,bn,unten; CTO(INTEGER,"m_k_to_h_lambda",a); CTO(PARTITION,"m_k_to_h_lambda",b); for (w=0,i=0;i 12) erg += multinom(oben,S_PA_S(exp),mn); else erg += multinom_small(oben,S_PA_S(exp),mn); FREEALL(exp); M_I_I(w,c); MULT_APPLY(mn,c); GANZDIV_APPLY(c,oben); /* erg += div(c,oben,c); */ if ((S_I_I(a)-w-1+l) > 0) { M_I_I(S_I_I(a)-w-1+l,oben); unten = CALLOCOBJECT(); M_I_I(l-1,unten); bn = CALLOCOBJECT(); if (S_I_I(oben) <= 12) { erg += binom_small(oben,unten,bn); MULT_APPLY_INTEGER(bn,c); M_I_I(l,unten); C_O_K(bn,EMPTY); erg += binom_small(oben,unten,bn); MULT_APPLY_INTEGER(mn,bn); } else { erg += binom(oben,unten,bn); MULT_APPLY(bn,c); M_I_I(l,unten); erg += binom(oben,unten,bn); MULT_APPLY(mn,bn); } ADD_APPLY(bn,c); FREEALL(unten); FREEALL(bn); } FREEALL(oben); FREEALL(mn); faktor: if ((S_PA_LI(b)%2)==0) { ADDINVERS_APPLY(c); } ENDR("internal to tmh___faktor"); } INT mult_hashtable_hashtable_faktor(a,b,d,faktor) OP a,b,d; OP faktor; /* AK 171001 */ /* a und b sind hashtable */ /* sind beides homogene homsym functions sind beide sehr voll besetzt d.h. fast alle partitionenmit coeff != 0 das ergebnis wird mit faktor in d eingefuegt */ { OP x=NULL,y=NULL,c; OP wx,wy,p; INT erg = OK,i,j,k; CTTTTO(HOMSYM,POWSYM,ELMSYM,HASHTABLE,"mult_hashtable_hashtable(1)",a); CTTTTO(HOMSYM,POWSYM,ELMSYM,HASHTABLE,"mult_hashtable_hashtable(2)",b); CTO(HASHTABLE,"mult_hashtable_hashtable(3)",d); FORALL(x,a, { goto ee; }); ee: FORALL(y,b, { goto ff; }); ff: /* x und y sind jetzt monome, das gemeinsame gewicht bestimmen */ wx=CALLOCOBJECT(); weight(S_MO_S(x),wx); wy=CALLOCOBJECT(); weight(S_MO_S(y),wy); ADD_APPLY(wx,wy); p = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),p); M_I_I(0,S_MO_K(p)); b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(p)); m_il_integervector(S_I_I(wy),S_PA_S(S_MO_S(p))); /* wy ist das gewicht der ergebnispartition p ist ein monom mit platz fuer die maximale partition */ FORALL(x,a, { FORALL(y,b, { i=j=k=0; while ( (i= 2 */ /* b and c becomes half of it */ { OP v1,v2; INT erg = OK; INT i,j; CTO(PARTITION,"splitpart(1)",a); v1 = CALLOCOBJECT(); v2 = CALLOCOBJECT(); erg += m_il_v(S_PA_LI(a)/2 ,v1); erg += m_il_v(S_PA_LI(a)-S_V_LI(v1) ,v2); for (i=0;i ... */ OP a,b,f; INT (*intf)(), (*multf)(); { OP ff; INT i,j; OP p,h2; OP h1; INT erg = OK; CTO(PARTITION,"t_schur_jacobi_trudi(1)",a); CTTTTTO(HASHTABLE,HOMSYM,MONOMIAL,ELMSYM,POWSYM,"t_schur_jacobi_trudi(2)",b); if (S_PA_LI(a) == 0) { (*intf)(cons_null,b,f); goto eee; } if (S_PA_LI(a) == 1) { (*intf)(S_PA_I(a,0),b,f); goto eee; } p = CALLOCOBJECT(); b_ks_pa(VECTOR,CALLOCOBJECT(),p); m_il_integervector(S_PA_LI(a)-1,S_PA_S(p)); h2 = CALLOCOBJECT(); b_ks_pa(VECTOR,CALLOCOBJECT(),h2); m_il_integervector(1,S_PA_S(h2)); NEW_HASHTABLE(h1); ff = CALLOCOBJECT(); for (j=0,i=S_PA_LI(a)-1;i>= 0; i--,j++) { if (( S_PA_II(a,i) - j ) >= 0 ) { INT k; FREESELF(ff); for (k=0;ki) M_I_I(S_PA_II(a,k)+1, S_PA_I(p,k-1)); } if (( S_PA_II(a,i) - j ) == 0) { if (j%2 == 1) { ADDINVERS(f,ff); } else { COPY(f,ff); } erg += t_schur_jacobi_trudi(p,b,ff,intf,multf); } else { if (j%2 == 1) { ADDINVERS(f,ff); } else { COPY(f,ff); } erg += t_schur_jacobi_trudi(p,h1,ff,intf,multf); M_I_I(S_PA_II(a,i) - j,S_PA_I(h2,0)); erg += (*multf)(h2,h1,b,cons_eins); /* erster parameter homsym */ CLEAR_HASHTABLE(h1); } } else break; } FREEALL(p); FREEALL(h2); FREEALL(h1); FREEALL(ff); eee: ENDR("t_schur_jacobi_trudi"); } INT t_schur_naegelsbach(a,b,f,intf,multf) /* implementiert die naegelsbach determinante fuer basis wechsel schur -> ... */ OP a,b,f; INT (*intf)(), (*multf)(); { OP z,ac; INT i,j; OP p,h2; OP h1; INT erg = OK; CTO(PARTITION,"t_schur_naegelsbach(1)",a); CTTTTTO(HASHTABLE,HOMSYM,MONOMIAL,ELMSYM,POWSYM,"t_schur_naegelsbach(2)",b); if (S_PA_LI(a) == 0) { (*intf)(cons_null,b,f); goto eee; } ac = CALLOCOBJECT(); conjugate_partition(a,ac); a = ac; if (S_PA_LI(a) == 1) { (*intf)(S_PA_I(a,0),b,f); goto bbb; } p = CALLOCOBJECT(); b_ks_pa(VECTOR,CALLOCOBJECT(),p); m_il_integervector(S_PA_LI(a)-1,S_PA_S(p)); h2 = CALLOCOBJECT(); b_ks_pa(VECTOR,CALLOCOBJECT(),h2); m_il_integervector(1,S_PA_S(h2)); h1 = CALLOCOBJECT();init_hashtable(h1); for (j=0,i=S_PA_LI(a)-1;i>= 0; i--,j++) { if (( S_PA_II(a,i) - j ) >= 0 ) { INT k; OP ff; ff = CALLOCOBJECT(); for (k=0;ki) M_I_I(S_PA_II(a,k)+1, S_PA_I(p,k-1)); } if (( S_PA_II(a,i) - j ) == 0) { if (j%2 == 1) ADDINVERS(f,ff); else COPY(f,ff); erg += t_schur_jacobi_trudi(p,b,ff,intf,multf); } else { if (j%2 == 1) ADDINVERS(f,ff); else COPY(f,ff); erg += t_schur_jacobi_trudi(p,h1,ff,intf,multf); M_I_I(S_PA_II(a,i) - j,S_PA_I(h2,0)); erg += (*multf)(h2,h1,b,cons_eins); /* erster parameter elmsym */ FORALL(z,h1, { FREESELF(z); }); M_I_I(0,S_V_I(h1,S_V_LI(h1))); } FREEALL(ff); } else break; } FREEALL(p); FREEALL(h2); FREEALL(h1); bbb: FREEALL(a); /* die conjugierte partition */ eee: CTTTTTO(HASHTABLE,HOMSYM,MONOMIAL,ELMSYM,POWSYM,"t_schur_naegelsbach(2-ende)",b); ENDR("t_schur_naegelsbach"); } INT mhh_partition__(); INT mhh_partition_hashtable_(); INT tsh_jt(a,m) OP a,m; /* jacobi trudi matrix with integer entries */ /* -1 = zero contribution */ { INT erg = OK,i,j; CTTO(PARTITION,SKEWPARTITION,"jt(1)",a); CTO(EMPTY,"jt(2)",m); if (S_O_K(a) == PARTITION) { m_ilih_nm(S_PA_LI(a),S_PA_LI(a),m); for (j=0;j=0;kl--,j--) for (i=0;i 0) { M_I_I(S_M_IJI(m,i,S_P_II(p,i)-1),S_V_I(v,j)); j++; } qsort(S_V_S(v), S_V_LI(v), sizeof(struct object), comp_integer_integer); b_ks_pa(VECTOR,v,S_MO_S(c)); MULT_APPLY(f,S_MO_K(c)); INSERT_HOMSYMMONOM_(c,b); continue; next: /* we can increase the permutation */ if (i==0) goto jj; i--; for (j=S_P_LI(p)-1;j>=i;j--) ADDINVERS_APPLY_INTEGER(S_P_I(pv,S_P_II(p,j)-1)); /* now all used entries are marked */ /* check where you can increase */ aa: k = S_P_II(p,i); for (j=k; j 0) { M_I_I(S_M_IJI(m,i,S_P_II(p,i)-1),S_V_I(v,j)); j++; } qsort(S_V_S(v), S_V_LI(v), sizeof(struct object), comp_integer_integer); b_ks_pa(VECTOR,v,S_MO_S(c)); INSERT_HOMSYMMONOM_(c,b); next: ; } while(next_apply(p)); FREEALL(m); FREEALL(p); goto eee; } eee: ENDR("tsh_partition__faktor"); } INT tsh_partition__faktor_pre240102(a,b,f) OP a,b,f; { INT erg = OK; CTO(PARTITION,"tsh_partition__faktor(1)",a); CTTO(HASHTABLE,HOMSYM,"tsh_partition__faktor(2)",b); /* nach der ersten spalte entwickeln bei jacobi trudi det */ if (S_PA_LI(a) == 0) { tsh_integer__faktor(cons_null,b,f); goto eee; } if (S_PA_LI(a) == 1) { tsh_integer__faktor(S_PA_I(a,0),b,f); goto eee; } if (S_PA_LI(a) == 2) { OP m; /* s_a,b = h_a,b - h_a--,b++ */ m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); b_ks_pa(VECTOR,CALLOCOBJECT(),S_MO_S(m)); if (S_PA_II(a,0) > 1) { m_il_integervector(2,S_PA_S(S_MO_S(m))); M_I_I(S_PA_II(a,0)-1, S_PA_I(S_MO_S(m),0)); M_I_I(S_PA_II(a,1)+1, S_PA_I(S_MO_S(m),1)); } else { m_il_integervector(1,S_PA_S(S_MO_S(m))); M_I_I(S_PA_II(a,1)+1, S_PA_I(S_MO_S(m),0)); } ADDINVERS(f,S_MO_K(m)); if (S_O_K(b) == HOMSYM) INSERT_LIST(m,b,add_koeff,comp_monomhomsym); else INSERT_HASHTABLE(m,b,add_koeff,eq_monomsymfunc, hash_monompartition); m = CALLOCOBJECT(); b_sk_mo(CALLOCOBJECT(),CALLOCOBJECT(),m); copy_partition(a,S_MO_S(m)); COPY(f,S_MO_K(m)); if (S_O_K(b) == HOMSYM) INSERT_LIST(m,b,add_koeff,comp_monomhomsym); else INSERT_HASHTABLE(m,b,add_koeff,eq_monomsymfunc, hash_monompartition); goto eee; } if (S_PA_II(a,S_PA_LI(a)-1) == 1) /* elmsym */ { INT teh_integer__faktor(); erg += teh_integer__faktor(S_PA_L(a),b,f); goto eee; } t_schur_jacobi_trudi(a,b,f,tsh_integer__faktor,mhh_partition_hashtable_); eee: ENDR("tsh_partition__faktor"); } #endif INT tsh_schur__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTTO(HASHTABLE,SCHUR,"tsh_schur__faktor(1)",a); CTTO(HASHTABLE,HOMSYM,"tsh_schur__faktor(2)",b); T_FORALL_MONOMIALS_IN_A(a,b,f,tsh_partition__faktor); ENDR("tsh_schur__faktor"); } INT tsh_hashtable__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(HASHTABLE,"tsh_hashtable__faktor(1)",a); CTTO(HASHTABLE,HOMSYM,"tsh_hashtable__faktor(2)",b); T_FORALL_MONOMIALS_IN_A(a,b,f,tsh_partition__faktor); ENDR("tsh_hashtable__faktor"); } INT tsh___faktor(a,b,f) OP a,b,f; { INT erg = OK; CTTTTO(HASHTABLE,INTEGER,SCHUR,PARTITION,"tsh___faktor(1)",a); CTTO(HASHTABLE,HOMSYM,"tsh___faktor(2)",b); if (S_O_K(a) == INTEGER) { erg += tsh_integer__faktor(a,b,f); goto eee; } else if (S_O_K(a) == PARTITION) { erg += tsh_partition__faktor(a,b,f); goto eee; } else if (S_O_K(a) == SCHUR) { erg += tsh_schur__faktor(a,b,f); goto eee; } else /* HASHTABLE */ { erg += tsh_hashtable__faktor(a,b,f); goto eee; } eee: ENDR("tsh___faktor"); } INT t_SCHUR_HOMSYM(a,b) OP a,b; { INT erg = OK; INT t = 0; CTTTTO(INTEGER,HASHTABLE,SCHUR,PARTITION,"t_SCHUR_HOMSYM",a); TCE2(a,b,t_SCHUR_HOMSYM,HOMSYM); if (S_O_K(b) == EMPTY) { erg += init_hashtable(b); t=1; } tsh___faktor(a,b,cons_eins); if (t==1) t_HASHTABLE_HOMSYM(b,b); ENDR("t_SCHUR_HOMSYM"); } symmetrica-2.0/tsm.c0000400017361200001450000001710110726021667014351 0ustar tabbottcrontab#include "def.h" #include "macro.h" INT thm_integer__faktor(); INT mem_integer_hashtable_(); INT mes_integer_hashtable_(); INT t_SCHUR_MONOMIAL_pre211101(a,b) OP a,b; /* AK 190901 */ /* fastest up to now */ /* with kostka number */ { INT erg = OK; CTTO(SCHUR,PARTITION,"t_SCHUR_MONOMIAL(1)",a); CE2(a,b,t_SCHUR_MONOMIAL_pre211101); if (S_O_K(a) == PARTITION) { /* definition mittels kostkanumber */ OP c; if (S_PA_LI(a) == 0) { erg += b_skn_mon(callocobject(),callocobject(),NULL,b); M_I_I(1,S_S_K(b)); erg += first_partition(cons_null,S_S_S(b)); goto endr_ende; } else if (S_PA_LI(a) == 1) { erg += t_HOMSYM_MONOMIAL(S_PA_I(a,0),b); goto endr_ende; } c = callocobject(); erg += copy_partition(a,c); erg += init(MONOMIAL,b); do { OP m; m = callocobject(); erg += m_pa_mon(c,m); erg += kostka_number(c,a,S_S_K(m)); if (not NULLP(S_S_K(m))) INSERT_LIST(m,b,NULL,comp_monommonomial); else erg += freeall(m); } while (next_apply(c)); erg += freeall(c); goto endr_ende; } else if (S_O_K(a) == SCHUR) { OP z,res; erg += init(MONOMIAL,b); FORALL(z,a, { res=callocobject(); erg += t_SCHUR_MONOMIAL_pre211101(S_MO_S(z),res); MULT_APPLY(S_MO_K(z),res); INSERT_LIST(res,b,add_koeff,comp_monommonomial); } ); } ENDR("t_SCHUR_MONOMIAL_pre211101"); } INT tsm_schur__faktor(); INT tsm_integer__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(INTEGER,"tsm_integer__faktor(1)",a); CTTO(HASHTABLE,MONOMIAL,"tsm_integer__faktor(2)",b); SYMCHECK((S_I_I(a) < 0), "tsm_integer__faktor:parameter <0"); erg += thm_integer__faktor(a,b,f); ENDR("tsm_integer__faktor"); } INT tsm_partition__faktor(a,b,f) OP a,b,f; { INT erg = OK; CTO(PARTITION,"tsm_partition__faktor(1)",a); CTTO(HASHTABLE,MONOMIAL,"tsm_partition__faktor(2)",b); if (S_PA_LI(a) == 0) { erg += thm_integer__faktor(cons_null,b,f); goto ende; } else if (S_PA_LI(a) == 1) { erg += thm_integer__faktor(S_PA_I(a,0),b,f); goto ende; } #ifdef UNDEF /* ist langsamer */ else if (S_PA_LI(a) == 2) { /* determinanten formel */ OP h1,h2; OP m; OP find_thm_integer(); h1 = find_thm_integer(S_PA_I(a,0)); h2 = find_thm_integer(S_PA_I(a,1)); mmm___(h1,h2,b,f); DEC_INTEGER(S_PA_I(a,0)); INC_INTEGER(S_PA_I(a,1)); h1 = find_thm_integer(S_PA_I(a,0)); h2 = find_thm_integer(S_PA_I(a,1)); m = CALLOCOBJECT(); ADDINVERS(f,m); mmm___(h1,h2,b,m); FREEALL(m); INC_INTEGER(S_PA_I(a,0)); DEC_INTEGER(S_PA_I(a,1)); /* erg += thm_integer__faktor(S_PA_I(a,0),b,f); */ goto ende; } #endif else { OP m; m = CALLOCOBJECT(); erg += m_pa_s(a,m); erg += tsm_schur__faktor(m,b,f); FREEALL(m); goto ende; } ende: ENDR("tsm_partition__faktor"); } INT tsm___faktor(a,b,f) OP a,b,f; { INT erg = OK; CTTTTO(HASHTABLE,SCHUR,PARTITION,INTEGER,"tsm___faktor(1)",a); CTTO(HASHTABLE,MONOMIAL,"tsm___faktor(2)",b); if (S_O_K(a) == INTEGER) { erg += tsm_integer__faktor(a,b,f); goto ende; } else if (S_O_K(a) == PARTITION) { erg += tsm_partition__faktor(a,b,f); goto ende; } else { erg += tsm_schur__faktor(a,b,f); goto ende; } ende: CTTO(HASHTABLE,MONOMIAL,"tsm___faktor(e2)",b); ENDR("tsm___faktor"); } INT tsm_schur__faktor(a,b,f) OP a,b,f; /* AK 260503: changed error in computation of factor in the trival cases at the beginning */ { INT erg = OK; OP z,ha,ohne_i,h_ohne_i; INT i; OP h_i; CTTO(HASHTABLE,SCHUR,"tsm_schur__faktor(1)",a); CTTO(HASHTABLE,MONOMIAL,"tsm_schur__faktor(2)",b); CTO(ANYTYPE,"tsm_schur__faktor(3)",f); if (NULLP(a)) { goto endr_ende; } if (S_O_K(a) == SCHUR) { if (S_L_N(a) == NULL) { if (S_PA_LI(S_S_S(a)) == 0) { z=CALLOCOBJECT(); MULT(f,S_S_K(a),z); erg += thm_integer__faktor(cons_null,b,S_S_K(a)); FREEALL(z); goto ende; } if (S_PA_LI(S_S_S(a)) == 1) { z=CALLOCOBJECT(); MULT(f,S_S_K(a),z); erg += thm_integer__faktor(S_S_SI(a,0),b,z); FREEALL(z); goto ende; } } } else /* HASHTABLE */ { if (S_V_II(a,S_V_LI(a)) == 1) { OP z=NULL; FORALL(z,a, { goto eee; } ); eee: if (S_PA_LI(S_MO_S(z)) == 0) { ha = CALLOCOBJECT(); MULT(f,S_MO_K(z),ha); erg += thm_integer__faktor(cons_null,b,ha); FREEALL(ha); goto ende; } if (S_PA_LI(S_MO_S(z)) == 1) { ha = CALLOCOBJECT(); MULT(f,S_MO_K(z),ha); erg += thm_integer__faktor(S_PA_I(S_MO_S(z),0),b,ha); FREEALL(ha); goto ende; } } } /* such die partition mit den wenigsten teilen */ z = findmin_schur(a,length_comp_part); i = S_PA_LI(S_MO_S(z)); ha = CALLOCOBJECT(); COPY(a,ha); NEW_HASHTABLE(ohne_i); NEW_HASHTABLE(h_ohne_i); h_i = CALLOCOBJECT(); while (i>=0) { OP v,p,m; INT k,j; if (NULLP(ha)) break; FORALL(z,ha, { if (S_PA_LI(S_MO_S(z)) == i) /* kommt nach ohne_i */ { v = CALLOCOBJECT(); for (j=0;j 1) break; erg +=m_il_v(S_PA_LI(S_MO_S(z))-j,v); for (k=0;k0) { OP v,p,m; INT k; if (NULLP(ha)) break; FORALL(z,ha, { if (S_PA_II(S_MO_S(z),S_PA_LI(S_MO_S(z))-1) == i) /* kommt nach ohne_i */ { v = CALLOCOBJECT(); erg +=m_il_v(S_PA_LI(S_MO_S(z))-1,v); for (k=0;kob_self.ob_vector = callocvectorstruct();\ C_V_S(r,s);\ C_V_L(r,l); } while(0) #ifdef VECTORTRUE INT vec_anfang() /* AK 100893 */ { INT erg = OK; #ifdef UNDEF mem_counter_vec=0; return OK; #endif ANFANG_MEMMANAGER(vector_speicher, vector_speicherindex, vector_speichersize, mem_counter_vec); ENDR("vec_anfang"); } INT vec_ende() /* AK 100893 */ { INT erg = OK; if (no_banner != TRUE) if (mem_counter_vec != (INT)0) { fprintf(stderr,"mem_counter_vec = %ld\n",mem_counter_vec); erg += error("vec memory not freed"); } #ifdef UNDEF erg += vec_speicher_ende(); return erg; #endif ENDE_MEMMANAGER(vector_speicher, vector_speicherindex, vector_speichersize, mem_counter_vec,"vec speicher not freed"); ENDR("vec_ende"); } INT einsp_vector(a) OP a; /* AK 010692 */ /* AK 040398 V2.0 */ { INT i; for (i=(INT)0;i=0;i--) if (LT(S_V_I(a,i),S_V_I(a,i+1))) return FALSE; return TRUE; } #endif /* VECTORTRUE */ INT vectorp(a) OP a; /* AK 210192 */ /* AK 011098 V2.0 */ /* AK 110902 V2.1 */ { #ifdef VECTORTRUE if ( (s_o_k(a) == VECTOR) || (s_o_k(a) == WORD) || (s_o_k(a) == KRANZ) || (s_o_k(a) == LAURENT) || (s_o_k(a) == COMPOSITION) || (s_o_k(a) == INTEGERVECTOR) || (s_o_k(a) == SUBSET) || (s_o_k(a) == HASHTABLE) || (s_o_k(a) == FF) ) return TRUE; #endif /* VECTORTRUE */ return FALSE; } #ifdef VECTORTRUE INT m_o_v(ob,vec) OP ob,vec; /* make_object_vector */ /* AK 260488 */ /* AK 270689 V1.0 */ /* AK 211289 V1.1 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ /* input: arbitrary object output: VECTOR object with one component = copy of first parameter */ /* ob and vec may be equal */ { INT erg = OK; CE2(ob,vec,m_o_v); erg += m_il_v((INT)1,vec); COPY(ob,S_V_I(vec,(INT)0)); ENDR("m_o_v"); } INT b_o_v(ob,vec) OP ob,vec; /* build_object_vector */ /* AK 170590 V1.1 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT erg = OK; OP l; SYMCHECK( ob == vec, "b_o_v: the two parameters are equal"); NEW_INTEGER(l,1); B_LS_V(l,ob,vec); ENDR("b_o_v"); } INT m_l_nv(il,vec) OP il,vec; /* AK 160791 V1.3 */ /* AK 011098 V2.0 */ /* il and vec may be equal */ { INT erg = OK; CTO(INTEGER,"m_l_nv",il); SYMCHECK(S_I_I(il) < 0,"m_l_nv:length < 0"); erg += m_il_nv(S_I_I(il),vec); ENDR("m_l_nv"); } INT m_il_nv(il,vec) INT il; OP vec; /* AK 160791 V1.3 */ /* AK 011098 V2.0 */ { INT i; INT erg = OK; SYMCHECK(il < 0,"m_il_nv:length < 0"); erg += m_il_v(il,vec); for (i=(INT)0;i>3) : (l>>3) +1); ENDR("s_bv_li"); } INT m_il_bv(il,bitvec) INT il; OP bitvec; /* AK 161294 */ /* AK 190298 V2.0 */ /* il is length in bit */ { INT erg = OK; SYMCHECK(il < 0,"m_il_bv: negativ length"); B_LS_V(callocobject(),NULL,bitvec); M_I_I(il,S_V_L(bitvec)); if (il > 0) C_V_S(bitvec,SYM_calloc(S_BV_LI(bitvec)/8+1,8)); C_O_K(bitvec,BITVECTOR); ENDR("m_il_bv"); } INT m_il_nbv(il,bitvec) INT il; OP bitvec; /* AK 161294 */ /* AK 011098 V2.0 */ { INT erg = OK; COP("m_il_nbv(2)",bitvec); SYMCHECK(il < 0,"m_il_nbv: negativ length"); B_LS_V(callocobject(),NULL,bitvec); M_I_I(il,S_V_L(bitvec)); if (il > (INT)0) C_V_S(bitvec,SYM_calloc(S_BV_LI(bitvec)/8+1,8)); C_O_K(bitvec,BITVECTOR); ENDR("m_il_nbv"); } INT m_il_v(il,vec) INT il; OP vec; /* make_integerlength_vector */ /* AK 250587 */ /* AK 270689 V1.0 */ /* AK 211289 V1.1 */ /* AK 080291 V1.2 test on negativ test on zero length */ /* AK 200891 V1.3 */ /* AK 020398 V2.0 */ { INT erg = OK,i; OP l; COP("m_il_v(2)",vec); SYMCHECK(il < 0,"m_il_v: negativ length"); if (S_O_K(vec) == VECTOR) /* AK 261006 */ { if (S_V_LI(vec)==il) { for (i=0,l=S_V_S(vec);i S_V_LI(b)) { c = CALLOCOBJECT(); COPY(a,c); for (i=(INT)0;i S_V_LI(b)) { erg += copy_vector(a,c); for (i=(INT)0;i S_V_LI(b)) { erg += copy_integervector(a,c); for (i=0;ij;k--) *S_V_I(vec,k) = *S_V_I(vec,k-1); C_O_S(S_V_I(vec,j),zeiger); C_O_K(S_V_I(vec,j),art); }; return(OK); } CTTO(INTEGERVECTOR,VECTOR,"sort_vector(1e)",vec); ENDR("sort_vector"); } INT random_bv(a,b) OP a,b; /* AK 250194 */ /* AK 011098 V2.0 */ { INT erg = OK,i; int rand(); CTO(INTEGER,"random_bv",a); erg += m_il_bv(S_I_I(a),b); C_O_K(b,BITVECTOR); for (i=(INT)0;i 0) SYM_free(S_V_S(a)); FREEALL(S_V_L(a)); freevectorstruct(S_O_S(a).ob_vector); C_O_K(a,EMPTY); } CTO(EMPTY,"freeself_integervector(1e)",a); ENDR("freeself_integervector"); } INT freeself_hashtable(vec) OP vec; /* AK 231001 AK 100307*/ /* length > 1 */ { INT i,erg=OK,j; OP z,zj; CTO(HASHTABLE,"freeself_hashtable(1)",vec); if (S_V_II(vec,S_V_LI(vec)) > 0) { for (i=(INT)0,z=S_V_S(vec);i 0)\ {\ OP z;INT i;\ for (z = S_V_S(vec),i=0;i bi) && (erg == -1)) return NONCOMPARABLE; if ((ai > bi) && (erg == 0)) { erg = 1; continue; } } return erg; ENDR("sub_comp_bv"); } INT comp_bv(a,b) OP a,b; /* AK 200395 */ /* AK 011098 V2.0 */ { INT erg = OK; CTO(BITVECTOR,"comp_bv",a); CTO(BITVECTOR,"comp_bv",b); if (S_V_LI(a) != S_V_LI(b)) error("comp_bv:different lengths"); /* for (i=0;i GET_BV_I(b,i)) return (INT)1; return (INT) 0; */ /* println(a); println(b); */ erg = (INT) memcmp((void *)S_V_S(a), (void *)S_V_S(b), (size_t)S_BV_LI(a)); /* printf("comp=%ld\n",erg); */ return erg; ENDR("comp_bv"); } INT eq_vector(a,b) OP a,b; /* AK 201201 */ /* AK 291104 V3.0 */ { INT erg = OK; CTO(VECTOR,"eq_vector(1)",a); if (S_O_K(b) != VECTOR) return FALSE; CTO(VECTOR,"eq_vector(2)",b); if (S_V_LI(b) != S_V_LI(a)) return FALSE; { INT i,l=S_V_LI(a); for (i=0;i= S_V_LI(b)) return(1);\ res = comp(az,bz);\ if (res != 0) return(res);\ };\ if (S_V_LI(a) < S_V_LI(b)) return -1;\ return(0);\ } INT comp_integervector(a,b) OP a,b; /* AK 011098 V2.0 *//* AK 270804 V3.0 */ { INT erg = OK; CTTTO(INTEGERVECTOR,COMPOSITION,SUBSET,"comp_integervector(1)",a); if (S_O_K(b) == VECTOR) { /* AK 080502 */ COMP_VC(a,b); } CTTTO(INTEGERVECTOR,COMPOSITION,SUBSET,"comp_integervector(2)",b); { OP za,zb; INT i; za = S_V_S(a);zb=S_V_S(b); for ( i=0; i= S_V_LI(b)) return 1; if (S_I_I(za) > S_I_I(zb)) return 1; if (S_I_I(za) == S_I_I(zb)) continue; return -1; }; if (i < S_V_LI(b)) return -1; return 0; } ENDR("comp_integervector"); } INT comp_galois(a,b) OP a,b; { INT erg = OK; CTO(GALOISRING,"comp_galois(1)",a); CTO(GALOISRING,"comp_galois(2)",b); { OP za,zb; INT i; za = S_V_S(a);zb=S_V_S(b); for ( i=0; i= S_V_LI(b)) return 1; if (S_I_I(za) > S_I_I(zb)) return 1; if (S_I_I(za) == S_I_I(zb)) continue; return -1; }; if (i < S_V_LI(b)) return -1; return 0; } ENDR("comp_galois"); } INT comp_vector(a,b) OP a,b; /* AK 060488 */ /* AK 280689 V1.0 */ /* AK 201289 V1.1 */ /* AK 200891 V1.3 */ /* AK 260298 V2.0 */ { INT erg = OK; CTO(VECTOR,"comp_vector(1)",a); CTTTO(VECTOR,INTEGERVECTOR,WORD,"comp_vector(2)",b); COMP_VC(a,b); ENDR("comp_vector"); } INT comp_word(a,b) OP a,b; /* AK 060502 from comp_vector */ { INT erg = OK; CTO(WORD,"comp_word(1)",a); CTTTO(VECTOR,INTEGERVECTOR,WORD,"comp_word(2)",b); COMP_VC(a,b); ENDR("comp_word"); } INT scan_bitvector(res) OP res; /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 080591 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT i,erg =OK; OP d,e; COP("scan_bitvector(1)",res); d = callocobject(); e = callocobject(); erg += printeingabe("input of a bitvector (0-1 vector)"); erg += printeingabe("length of bit vector "); erg += scan(INTEGER,d); erg += b_l_v(d,e); for (i=(INT)0;i= 0) /* AK 231001 */ { res=vector_speicher[vector_speicherindex--]; goto ende; } res = (struct vector *) SYM_MALLOC(sizeof(struct vector)); if (res == NULL) no_memory(); ende: mem_counter_vec++; #endif CALLOC_MEMMANAGER(struct vector, vector_speicher, vector_speicherindex, mem_counter_vec, res); return res; ENDTYP("callocvectorstruct", struct vector * ); } INT freevectorstruct(v) struct vector *v; /* AK 231001 */ { INT erg = OK; #ifdef UNDEF if (vector_speicherindex+1 == vector_speichersize) { if (vector_speichersize == 0) { vector_speicher = (struct vector **) SYM_MALLOC(100 * sizeof(struct vector *)); if (vector_speicher == NULL) { erg += error("no memory"); goto endr_ende; } vector_speichersize = 100; } else { vector_speicher = (struct vector **) SYM_realloc (vector_speicher, 2 * vector_speichersize * sizeof(struct vector *)); if (vector_speicher == NULL) { erg += error("no memory"); goto endr_ende; } vector_speichersize = 2 * vector_speichersize; } } vector_speicher[++vector_speicherindex] = v; mem_counter_vec--; #endif FREE_MEMMANAGER(struct vector *, vector_speicher, vector_speicherindex, vector_speichersize, mem_counter_vec, v); ENDR("freevectorstruct"); } #ifdef UNDEF static INT vec_speicher_ende() /* AK 230101 */ { INT erg = OK,i; for (i=0;i<=vector_speicherindex;i++) SYM_free(vector_speicher[i]); if (vector_speicher!= NULL) { COP("vec_speicher_ende:vector_speicher",vector_speicher); SYM_free(vector_speicher); } vector_speicher=NULL; vector_speicherindex=-1; vector_speichersize=0; ENDR("vec_speicher_ende"); } #endif INT b_ls_v(length,self,res) OP length, self,res; /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ /* self will be freed */ { OBJECTSELF d; INT erg = OK; COP("b_ls_v(3)",res); d.ob_vector = callocvectorstruct(); erg += b_ks_o(VECTOR, d,res); /* res will be freed */ C_V_S(res,self); C_V_L(res,length); ENDR("b_ls_v"); } OP s_v_s(a) OP a; /* AK 270689 V1.0 */ /* AK 211289 V1.1 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { OBJECTSELF c; c = s_o_s(a); if (a==NULL) { error("s_v_s:object == NULL"); return(NULL); } if (c.ob_vector==NULL) { error( "s_v_s:vector pointer == NULL"); return(NULL); } if (not vectorp(a)) { /* AK 210192 */ error("s_v_s: not VECTOR"); return NULL; } return(c.ob_vector->v_self); } OP s_v_l(a) OP a; /* AK 270689 V1.0 */ /* AK 201289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { OBJECTSELF c; OP erg=NULL; c = s_o_s(a); if (a==NULL) { error("s_v_l:object == NULL"); return(NULL); } if (c.ob_vector==NULL) { error( "s_v_l:vector pointer == NULL"); return(NULL); } if (not vectorp(a)) { /* AK 210192 */ WTO("s_v_l",a); return NULL; } erg = c.ob_vector->v_length; if (s_o_k(erg) != INTEGER) { printobjectkind(erg); error( "s_v_l:length != INTEGER"); return(NULL); } if (s_i_i(erg) < (INT)0) { error( "s_v_l:length <0"); return(NULL); } return erg; } INT s_v_li(a) OP a; /* AK 270689 V1.0 */ /* AK 201289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT erg = s_i_i(s_v_l(a)); return erg; } OP s_v_i(a,i) OP a; INT i; /* AK 270689 V1.0 */ /* AK 201289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT j; if (i<(INT)0) { fprintf(stderr,"index = %ld\n",i); error("s_v_i:negative index"); return(NULL); } if (s_o_k(a) == HASHTABLE) { if (i > (j=s_v_li(a)) ) { fprintf(stderr,"index = %ld dimension = %ld\n",i,j); error("s_v_i hashtable:index too big"); return(NULL); } } else if (i >= (j=s_v_li(a)) ) { fprintf(stderr,"index = %ld dimension = %ld\n",i,j); error("s_v_i:index too big"); return(NULL); } return(s_v_s(a) + (i)); } INT c_v_i(a,i,b) OP a,b; INT i; /* AK 170889 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { c_o_k(s_v_i(a,i),s_o_k(b)); c_o_s(s_v_i(a,i),s_o_s(b)); return(OK); } INT s_v_ii(a,i) OP a; INT i; /* AK 270689 V1.0 */ /* AK 201289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { return(s_i_i(s_v_i(a,i))); } INT c_v_s(a,b) OP a,b; /* AK 270689 V1.0 */ /* AK 201289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { OBJECTSELF c; c = s_o_s(a); (c.ob_vector->v_self)=b; return(OK); } INT c_v_l(a,b) OP a,b; /* AK 270689 V1.0 */ /* AK 201289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { OBJECTSELF c; c = s_o_s(a); (c.ob_vector->v_length)=b; return(OK); } #define LASTOF_V(a,b)\ SYMCHECK(S_V_LI(a) == 0,"LASTOF_V:length of vector == 0");\ if (S_V_LI(a)>0) COPY(S_V_I(a,S_V_LI(a)-(INT)1),b); INT lastof_vector(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 020398 V2.0 */ { INT erg = OK; CTO(VECTOR,"lastof_vector(1)",a); CTO(EMPTY,"lastof_vector(2)",b); LASTOF_V(a,b); ENDR("lastof_vector"); } INT lastof_integervector(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 020398 V2.0 */ { INT erg = OK; CTO(INTEGERVECTOR,"lastof_integervector(1)",a); CTO(EMPTY,"lastof_integervector(2)",b); LASTOF_V(a,b); ENDR("lastof_integervector"); } INT length_vector(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 180691 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { return(copy(S_V_L(a),b)); } INT tex_vector(vecobj) OP vecobj; /* AK 101187 */ /* mit tex werden alle elemente ausgegeben */ /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 070291 V1.2 prints to texout */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT i,ot=texmath_yn; if (texmath_yn==0) { fprintf(texout,"\\ $["); texmath_yn = 1; } else fprintf(texout,"\\ ["); for( i = (INT)0; i0) { sprintf(t,","); t++; } erg += sprint(t,S_V_I(a,i)); if (erg != OK) { WTO("sprint_vector: wrong type of vector-entry",S_V_I(a,i)); goto endr_ende; } t += strlen(t); } sprintf(t,"]"); ENDR("sprint_vector"); } INT sprint_integervector(t,a) char *t; OP a; /* AK 240398 V2.0 */ { INT erg = OK; INT i; CTO(INTEGERVECTOR,"sprint_integervector",a); sprintf(t,"["); t++; for (i=0;i0) { sprintf(t,","); t++; } sprintf(t,"%ld",S_V_II(a,i)); t += intlog(S_V_I(a,i)); if (S_V_II(a,i) < 0) t++; } sprintf(t,"]"); ENDR("sprint_integervector"); } INT fprint_vector(f,vecobj) FILE *f; OP vecobj; /* AK 171186 */ /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 200891 V1.3 */ /* AK 190298 V2.0 */ /* AK 201204 V3.0 */ { INT i, erg = OK; COP("fprint_vector(1)",f); putc('[',f); if (f == stdout) zeilenposition++; for( i = 0; i zm) zm = S_V_II(vec,i); erg += m_i_i(zm,m); ENDR("max_integervector"); } INT min_integervector(vec,m) OP vec,m; /* return copy of the minimal element */ /* AK 140703 */ { INT i; INT erg = OK; INT zm; CE2(vec,m,min_integervector); zm = S_V_II(vec,(INT)0); for(i=(INT)1;i=0;i--,za++,zb++) { if ( (not NULLP(za)) && (not NULLP(zb))) { /* AK 230904 */ CLEVER_MULT(za,zb,c); ADD_APPLY(c,d); } } FREEALL(c); } CTO(ANYTYPE,"scalarproduct_vector(e)",d); ENDR("scalarproduct_vector"); } INT dec_vector(a) OP a; /* AK 120187 kuerzt den vector um 1 */ /* das letzte element wird gestrichen */ /* AK 280689 V1.0 */ /* AK 211289 V1.1 */ /* AK 070891 V1.3 */ /* AK 011098 V2.0 */ { INT erg = OK; /* AK 100893 */ OP zz; CTO(VECTOR,"dec_vector(1)",a); SYMCHECK(S_V_LI(a) == 0, "dec_vector:initial length == 0"); FREESELF(S_V_I(a,S_V_LI(a)-1)); /* freigeben des speicherplatzes des letzten vectorelements */ DEC_INTEGER(S_V_L(a)); /* verkuerzen der laenge um eins */ if (S_V_LI(a) == (INT)1) /* AK 111093 */ { zz = S_V_S(a); C_V_S(a,CALLOCOBJECT()); *(S_V_S(a)) = *zz; SYM_free(zz); } else if (S_V_LI(a) == (INT)0) /* AK 100893 */ { FREEALL(S_V_S(a)); C_V_S(a,NULL); } ENDR("dec_vector"); } INT dec_integervector(a) OP a; /* AK 230402 */ /* AK 230904 V3.0 */ { INT erg = OK; /* AK 100893 */ CTO(INTEGERVECTOR,"dec_integervector(1)",a); SYMCHECK(S_V_LI(a) == 0, "dec_integervector:initial length == 0"); { OP zz; DEC_INTEGER(S_V_L(a)); /* verkuerzen der laenge um eins */ if (S_V_LI(a) == (INT)1) /* AK 111093 */ { zz = S_V_S(a); C_V_S(a,CALLOCOBJECT()); *(S_V_S(a)) = *zz; SYM_free(zz); } else if (S_V_LI(a) == (INT)0) /* AK 100893 */ { FREEALL(S_V_S(a)); C_V_S(a,NULL); } } ENDR("dec_integervector"); } INT reverse_vector(a,b) OP a, b; /* AK 160802 */ /* AK 230904 V3.0 */ { INT erg = OK; CTTTO(WORD,INTEGERVECTOR,VECTOR,"reverse_vector(1)",a); CE2(a,b,reverse_vector); { INT i,j; erg += m_il_v(S_V_LI(a),b); C_O_K(b,S_O_K(a)); for (i=0,j=S_V_LI(b)-1;i right) return -1; mitte = (left+right)/2; res = COMP(a,S_V_I(b,mitte)); if (res == 0) return mitte; if (res < 0) return index_vector_binary_co(a,b,left,mitte-1); else return index_vector_binary_co(a,b,mitte+1,right); ENDR("local:index_vector_binary_co"); } INT index_vector_binary(a,b) OP a,b; /* AK 211100 */ /* assumes sorted according to comp */ { return index_vector_binary_co(a,b,0,S_V_LI(b)-1); } INT insert_entry_vector(a,index,b) OP a,b; INT index; /* AK 280607 */ /* new empty object add position index */ { INT erg = OK; SYMCHECK(not VECTORP(a),"insert_entry_vector(1): not VECTORP"); { INT i,j; if (a == b) { OP c; c = CALLOCOBJECT(); *c = *b; C_O_K(b,EMPTY); erg += insert_entry_vector(c,index,b); FREEALL(c); goto endr_ende; } if (index<0) erg += copy(a,b); else if (index>=S_V_LI(a)) erg += copy(a,b); else { erg += m_il_v(S_V_LI(a)+1,b); C_O_K(b,S_O_K(a)); for (i=0;i= S_V_LI(a)) goto endr_ende; FREESELF(S_V_I(a,index)); DEC_INTEGER(S_V_L(a)); if (index == S_V_LI(a)) goto endr_ende; for (i=index;i S_V_LI(b)) /* error wrong: < corrected AK 130199 */ { c = a; a = b; b = c; m = (INT)-1; } else m = (INT)1; /* the vector a is the shorter one */ for (i=(INT)0;i S_V_II(b,i)) return m ; for (;i (INT)0) return m * (INT)-1; return (INT)0; ENDR("comp_numeric_vector"); } INT add_apply_integervector(a,b) OP a, b; /* b = b+a */ /* AK 211289 V1.1 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT i,erg = OK; CTO(INTEGERVECTOR,"add_apply_integervector(1)",a); CTTO(INTEGERVECTOR,VECTOR,"add_apply_integervector(2)",b); if (S_V_LI(a) > S_V_LI(b)) { i = S_V_LI(b); inc_vector_co(b,S_V_LI(a) - S_V_LI(b)); for (; i=0;i--,j++) if (GET_BV_I(vec,i)==1) SET_BV_I(res,j); else UNSET_BV_I(res,j); ENDR("reverse_bitvector"); } INT einsp_bitvector(vec) OP vec; /* AK 200606 all one vector ? */ { INT erg = OK,i; CTO(BITVECTOR,"einsp_bitvector(1)",vec); for (i=S_V_LI(vec)-1;i>=0;i--) if (GET_BV_I(vec,i)==0) return FALSE; return TRUE; ENDR("einsp_bitvector"); } INT invers_bitvector(vec,res) OP vec,res; /* AK 090703 */ /* the complement */ { INT erg = OK,i; CTO(BITVECTOR,"invers_bitvector(1)",vec); CE2(vec,res,invers_bitvector); erg += m_il_bv( S_V_LI(vec), res); /* length in bit */ C_O_K(res,S_O_K(vec)); for (i=S_V_LI(vec)-1;i>=0;i--) if (GET_BV_I(vec,i)==1) UNSET_BV_I(res,i); else SET_BV_I(res,i); ENDR("invers_bitvector"); } INT inc_bitvector(v) OP v; /* AK 020698 V2.0 */ { INT erg = OK; CTO(BITVECTOR,"inc_bitvector(1)",v); if ((S_V_LI(v) % 8) == 0) { C_V_S(v, SYM_realloc(S_V_S(v), S_V_LI(v)/8 + 1)); } INC_INTEGER(S_V_L(v)); ENDR("inc_bitvector"); } INT copy_integervector(vec,res) OP vec, res; /* AK 021286 */ /* AK 280689 V1.0 */ /* AK 081289 V1.1 */ /* AK 120391 V1.2 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT erg = OK; CTO(INTEGERVECTOR,"copy_integervector(1)",vec); CTO(EMPTY,"copy_integervector(2)",res); erg += m_il_v( S_V_LI(vec), res); memcpy(S_V_S(res),S_V_S(vec), S_V_LI(vec) * sizeof(struct object)); C_O_K(res,S_O_K(vec)); ENDR("copy_integervector"); } INT copy_galois(vec,res) OP vec, res; /* AK 211106 V3.1 */ { INT erg = OK; CTO(GALOISRING,"copy_galois(1)",vec); CTO(EMPTY,"copy_galois(2)",res); erg += m_il_v( S_V_LI(vec), res); memcpy(S_V_S(res),S_V_S(vec), S_V_LI(vec) * sizeof(struct object)); C_O_K(res,S_O_K(vec)); ENDR("copy_integervector"); } INT copy_composition(vec,res) OP vec, res; /* AK 070102 */ /* identic to copy_integervector */ { INT erg = OK; CTO(COMPOSITION,"copy_composition(1)",vec); CTO(EMPTY,"copy_composition(2)",res); erg += m_il_v( S_V_LI(vec), res); memcpy(S_V_S(res),S_V_S(vec), S_V_LI(vec) * sizeof(struct object)); C_O_K(res,S_O_K(vec)); ENDR("copy_composition"); } INT comp_colex_vector(a,b) OP a,b; /* a,b vectors colex order */ /* AK V1.1 151189 */ /* AK 200891 V1.3 */ /* AK 011098 V2.0 */ { INT i = S_V_LI(a)-1; INT j = S_V_LI(b)-1; INT erg; if (not VECTORP(a)) error("comp_colex_vector:kind != VECTOR"); if (not VECTORP(b)) error("comp_colex_vector:kind != VECTOR"); for (;(i >= (INT)0) || (j>=(INT)0); i--,j--) { if (i<(INT)0) return((INT)1); if (j<(INT)0) return((INT)-1); erg = comp(S_V_I(a,i),S_V_I(b,j)); if (erg <(INT)0) return((INT)1); if (erg >(INT)0) return((INT)-1); } return((INT)0); } /* laenge in byte */ INT unset_bv_i(a,i) OP a; INT i; /* ite bit auf 0 setzen */ /* AK 011098 V2.0 */ { INT erg = OK; CTO(BITVECTOR,"unset_bv_i",a); if (S_V_LI(a) < i) return error("unset_bv_i: index to big"); if (i< 0) return error("unset_bv_i: index negativ"); *((unsigned char *)S_V_S(a) + (i/8)) &= (~(1 << (i%8))); ENDR("unset_bv_i"); } INT set_bv_i(a,i) OP a; INT i; /* ite bit setzen */ /* AK 011098 V2.0 */ { INT erg = OK; CTO(BITVECTOR,"set_bv_i",a); if (S_V_LI(a) < i) return error("set_bv_i: index to big"); if (i< 0) return error("set_bv_i: index negativ"); *((unsigned char *)S_V_S(a) + (i/8)) |= (1 << (i%8)); ENDR("set_bv_i"); } INT get_bv_i(a,i) OP a; INT i; /* AK 011098 V2.0 */ { INT erg = OK; CTO(BITVECTOR,"set_bv_i",a); if (S_V_LI(a) < i) return error("set_bv_i: index to big"); if (i< 0) return error("set_bv_i: index negativ"); return (*(((unsigned char *)S_V_S(a) ) + i/8) >> (i%8))%2; ENDR("get_bv_i"); } INT fprint_bitvector(fp,a) OP a; FILE *fp; /* AK 011098 V2.0 */ { INT i,erg = OK; CTO(BITVECTOR,"fprint_bitvector",a); for (i=0;i 70) { printf("\n"); zeilenposition = 0; } } } ENDR("fprint_bitvector"); } INT t_INTVECTOR_BITVECTOR(a,b) OP a,b; /* AK 011098 V2.0 */ /* a and b may be equal */ { INT erg = OK; INT i,l; if (not VECTORP(a)) { WTO("t_INTVECTOR_BITVECTOR",a); goto endr_ende; } CE2(a,b,t_INTVECTOR_BITVECTOR); /* a is INTVECTOR object */ l = S_V_LI(a); erg += m_il_bv(l,b); for (i=0;i=0;i--) bs2[i] ^= bs1[i] ; ENDR("exor_bitvector_apply"); } INT inf_bitvector_apply(bit1, res) OP bit1,res; /* AK 011098 V2.0 */ { unsigned char *bs1, *bs2; INT erg = OK; INT i,l; CTO(BITVECTOR,"inf_bitvector_apply(1)",bit1); CTO(BITVECTOR,"inf_bitvector_apply(2)",res); if (S_V_LI(bit1) != S_V_LI(res)) error("inf_bitvector_apply:diff lengths"); l = S_V_LI(bit1); bs1 = (unsigned char *) S_V_S(bit1); bs2 = (unsigned char *) S_V_S(res); for (i=0;i<= (l/8);i++) bs2[i] &= bs1[i] ; ENDR("inf_bitvector_apply"); } INT sup_bitvector_apply(bit1, res) OP bit1,res; /* AK 200606 V2.0 */ { unsigned char *bs1, *bs2; INT erg = OK; INT i,l; CTO(BITVECTOR,"sup_bitvector_apply(1)",bit1); CTO(BITVECTOR,"sup_bitvector_apply(2)",res); if (S_V_LI(bit1) != S_V_LI(res)) error("sup_bitvector_apply:diff lengths"); l = S_V_LI(bit1); bs1 = (unsigned char *) S_V_S(bit1); bs2 = (unsigned char *) S_V_S(res); for (i=0;i<= (l/8);i++) bs2[i] |= bs1[i] ; ENDR("sup_bitvector_apply"); } INT t_BITVECTOR_INTVECTOR(a,b) OP a,b; /* AK 011098 V2.0 */ { unsigned char *self; INT i,j,k; if (a == b) return ERROR; /* a is INTVECTOR object */ self = (unsigned char *) S_V_S(a); m_il_v(S_V_LI(a),b); for (i=0,j=0,k=1;i 0) il = S_PA_LI(a) + S_PA_II(a,S_PA_LI(a)-(INT)1); /* laenge des bit vectors i n bit */ erg += b_ks_pa(BITVECTOR,callocobject(),b); B_LS_V(callocobject(),NULL,S_PA_S(b)); M_I_I(il,S_PA_L(b)); C_O_K(S_PA_S(b),BITVECTOR); if (il == 0) goto endr_ende; self = (unsigned char *) SYM_calloc(il/64+1,8); C_V_S(S_PA_S(b),self); for (i=(INT)0,j=S_PA_LI(a)-1,k=S_PA_II(a,S_PA_LI(a)-1);i S_PA_II(a,j)) { SET_BV_I(S_PA_S(b),i); k--; } else { j--; } } C_PA_K(b,BITVECTOR); if (k != 0) return error("t_VECTOR_BIT: internal error tVB-0"); if (j != -1) return error("t_VECTOR_BIT: internal error tVB-1"); ENDR("t_VECTOR_BIT"); } static INT maxpart_bitvector_part_i(a) OP a; /* AK 011098 V2.0 */ { INT i,j=0; for (i=0;i<=S_V_LI(a);i++) { if (GET_BV_I(a,i) != (INT)1) break; } /* d.h. i ist die 0 */ for (;i<=S_V_LI(a);i++) if (GET_BV_I(a,i) == (INT)1) j++; return j; /* maximaler teil */ } static INT length_bitvector_part_i(a) OP a; /* AK 011098 V2.0 */ { INT i,j=0,k; for (i=S_V_LI(a)-1;i>=0;i--) { if ((k=GET_BV_I(a,i)) != (INT)0) break; } /* d.h. i ist die letzte 1 */ for (k=(INT)0;k=0;i--) { if(GET_BV_I(S_PA_S(a),i) == 1) break; } for (;k=0;i--) { if(GET_BV_I(a,i) == 1) break; } /* hier geht die partition los */ nu = 0; for (;k= 6) ) { dimension_bit_co(a,c,sig); return OK; } i=S_V_LI(a)-1; uc = ((unsigned char *) S_V_S(a)) + (i/8); l = i%8; for (;i>=0;i--,l--) { if (l < 0) {l+=8;uc--;} if (GET_BV_I(a,i) != 0) break; /* if (GET_BIT_I(uc,l) != 0) break; */ } ol = S_V_LI(a); M_I_I(i+1,S_V_L(a)); /* i index erster wagrechter eintrag */ hakenlaenge = S_V_II(b,index); uch = ((unsigned char *) S_V_S(a)) + ((i-hakenlaenge)/8); lh = (i-hakenlaenge)%8; for (;i>=hakenlaenge;i--,l--,lh--) { if (l < 0) {l+=8;uc--;} if (lh < 0) {lh+=8;uch--;} if (GET_BV_I(a,i) != 1) continue; /* if (GET_BIT_I(uc,l) != 1) continue; */ if (GET_BV_I(a,i-hakenlaenge) != 0) continue; /* if (GET_BIT_I(uch,lh) != 0) continue; */ k = 0; for (j=i-1;j>i-hakenlaenge;j--) if (GET_BV_I(a,j) == 0) k++; /* k is leglength */ if (index == (INT)0) { if (k%2 == 1) sig *= -1; if (sig==1) inc(c); else dec(c); goto ende; } UNSET_BV_I(a,i); /* UNSET_BIT_I(uc,l);*/ SET_BV_I(a,i-hakenlaenge); /*SET_BIT_I(uch,lh);*/ if (k%2 == 0) charvalue_bit_co(a,b,c,index-1,sig); else charvalue_bit_co(a,b,c,index-1,sig* ((INT)-1)); SET_BV_I(a,i); /*SET_BIT_I(uc,l);*/ UNSET_BV_I(a,i-hakenlaenge); /*UNSET_BIT_I(uch,lh);*/ } ende: M_I_I(ol,S_V_L(a)); return OK; } INT next_lex_vector(a,b) OP a,b; /* AK 060802 */ /* computes the next vector */ /* a and b may be equal */ /* return TRUE if there was a lexicoigraphic next vector FALSE if it is already the biggest one */ { INT erg = OK; INT i,j,k; OP m; CTTO(INTEGERVECTOR,VECTOR,"next_lex_vector(1)",a); if (a != b) erg += copy(a,b); if (S_V_LI(b) <= 1) return FALSE; /* vector has length >= 1 */ /* to left till decrease */ for (i=S_V_LI(b)-2;i>=0;i--) if (LT(S_V_I(b,i),S_V_I(b,i+1))) break; if (i==-1) return FALSE; k = i+1; for (j=i+1;j100) { INT j; /* AK 210104 */ for (j=0;i+j0 if a>b BUG: there is no check on typs, because this is a special routine, normally you should use comp instead. NAME: copy_vector SYNOPSIS: INT copy_vector(OP a,b) DESCRIPTION: a should be a VECTOR object, b the empty object. b becomes a copy of a. a and b must be different. This routine is called by other copy routines, which copy objects with VECTOR type components. RETURN: OK, or ERROR BUG: there is no check on typs, and there is no check whether a nd b are different. Because this is a special routine, normaly you should use copy instead. NAME: find_vector SYNOPSIS: OP find_vector(OP a,b) returns NULL if there is no object in the VECTOR object b, which is equal to the object a. If such a object exists, the result is the object in the vector, not a copy of it, so you should not remove the result of this routine. NAME: index_vector SYNOPSIS: INT index_vector(OP a,b) returns -1L if there is no object in the VECTOR object b, which is equal to the object a. If such a object exists, the result is the index in the vector. So the result is always smaller then the length of the VECTOR object b. COMMENT: INTEGERVECTOR this is a special type of VECTOR object, where we now for sure, that all the parts are INTEGER objects, so all the routines for VECTOR objects can be applied, but the general routines like add etc., can call special functions which may be faster. BITVECTOR this is a type which is simliar to VECTOR objects, but not compatibel. symmetrica-2.0/word.doc0000600017361200001450000000110010726170302015025 0ustar tabbottcrontabCOMMENT: WORD this is a special type of VECTOR objects. So we have the routines for VECTOR objects. The entries are INTEGER objects bigger then 0. the name is s_w_... instead of s_v_... NAME: random_word SYNOPSIS: INT random_word(OP a,b) DESCRIPTION: builds a random WORD object of the length given by the INTEGER object a. The entries are INTEGER objects with the maximum value 2 times the length = a. RETURN: OK or not OK. NAME: test_word SYNOPSIS: INT test_word() DESCRIPTION: checks the installation COMMENT: general routines: copy() inhalt() symmetrica-2.0/zo.c0000400017361200001450000003532410726021672014201 0ustar tabbottcrontab/* IK: 150591 */ #include "def.h" #include "macro.h" static INT berechne_Dominanz(); static INT berechne_sprod_kk(); static INT berechne_sumvec(); static INT berechne_M_Pk(); static INT mult_udrmatrix_matrix(); #ifdef MATRIXTRUE #ifdef CHARTRUE INT compute_zonal_with_alphabet(part,l,res) OP part,l,res; /* AK 210891 V1.3 */ { OP c,d,e,f,g,h,i; INT ind,z; INT erg = OK; C2R(part,l,"compute_zonal_with_alphabet",res); CTO(PARTITION,"compute_zonal_with_alphabet",part); CTO(INTEGER,"compute_zonal_with_alphabet",l); if (S_PA_LI(part) > S_I_I(l)) { erg += init(POLYNOM,res); goto s2r_ende; } c = callocobject(); d = callocobject(); e = callocobject(); f = callocobject(); g = callocobject(); h = callocobject(); i = callocobject(); erg += weight(part,c); erg += makevectorofpart(c,e); erg += young_tafel(c,h,NULL,NULL); erg += invers(h,h); erg += transpose(h,i); erg += m_ilih_m(S_V_LI(e),S_V_LI(e),f); erg += berechne_Dominanz(S_V_LI(e),e,f); erg += m_ilih_m(S_V_LI(e),S_V_LI(e),g); erg += berechne_sprod_kk(S_V_LI(e),c,e,h,i, f, g); erg += m_ilih_m(S_V_LI(e),S_V_LI(e),d); erg += berechne_M_Pk(S_V_LI(e),g,e,f,d); ind = indexofpart(part); erg += init(POLYNOM,res); for (z=0L;z S_V_II(laenge,j) ) m_i_i(0L,S_M_IJ(Dominanz,i,j)); else { m_i_i(1L,S_M_IJ(Dominanz,i,j)); for (k=0L;k=0L;j--) for (k=0L;k<=dim-i-3L;k++) copy(S_M_IJ(Ainvers,j,k),S_M_IJ(Ainvers_alt,j,k)); m_ilih_m(dim-i-1L,dim-i-1L,Ainvers); /* Speicher fuer neues Ainvers */ for (j=dim-i-3L;j>=0L;j--) for (k=0L;k<=dim-i-3L;k++) copy(S_M_IJ(Ainvers_alt,j,k),S_M_IJ(Ainvers,j+1L,k+1L)); freeall(Ainvers_alt); /* Ainvers_alt freigeben, Werte auf neues Ainvers kopiert */ m_i_i(0L,S_M_IJ(Ainvers,0L,0L)); for (j=0L;j=0L;i--) /* Berechnung des zonalen Polynoms zur Partition mit Index i */ { C=callocobject(); Adachinv=callocobject(); bdach=callocobject(); domdim=0L; for (j=i+1L;j a) { c=b;b=a;a=c; } /* Euklidischer Algorithmus */ while(c != 0L) { c=a%b; /* c ist der Rest bei der Division */ a=b; b=c; } return(a); } static INT eulerfunc(n) INT n; /* NS 060891 V1.3 */ { INT i,h=0L; if(n == 1L) return(1L); for(i=1L; i < n; i++) { if(gcd(n,i) == 1L) { h++; } } return(h); } /* Berechnet das Zykelindikatorpolynom der Cn */ #ifdef BRUCHTRUE INT zykelind_Cn(l,pol) OP l; OP pol; /* NS 060891 V1.3 */ { INT d,li; INT erg = OK; OP b; CTO(INTEGER,"zykelind_Cn",l); if (S_I_I(l) < 1L) /* AK 060792 */ { error("zykelind_Cn: input < 1"); goto endr_ende; } init(POLYNOM,pol); if (einsp(l)) /* AK 060792 */ { erg += m_iindex_monom(0L,pol); goto endr_ende; } b=callocobject(); li=S_I_I(l); for(d=1L; (d <= li) ; d++) if(li%d == 0L) { /* stopf den Koeffizienten in den Typ BRUCH von symchar */ /* stopf das Ergebnis in den Typ POLYNOM von symchar */ erg += b_skn_po(callocobject(),callocobject(),NULL,b); erg += m_ioiu_b(eulerfunc(d),li,S_PO_K(b)); erg += kuerzen(S_PO_K(b)); erg += m_il_nv(li,S_PO_S (b)); erg += m_i_i(li/d,S_PO_SI(b,d-1L)); erg += add_apply(b,pol); } erg += freeall(b); ENDR("zykelind_Cn"); } #endif /* BRUCHTRUE */ /* Berechnet das Zykelindikatorpolynom der Dn */ /* Beruht auf dem Programm fuer den Zykelindex der Cn, da fuer * den Zykelindex der Diedergruppe Dn nur ein Summand dazukommt * , ruft zykelind_Cn auf. */ INT zykelind_Dn(l,pol) OP l; OP pol; /* NS 060891 V1.3 */ { #ifdef BRUCHTRUE INT len,erg=OK; OP b,halb,hilf; CTO(INTEGER,"zykelind_Dn(1)",l); SYMCHECK( S_I_I(l) < 1L,"zykelind_Dn: input < 1"); len=S_I_I(l); init(POLYNOM,pol); if (einsp(l)) /* AK 060792 */ return m_iindex_monom(0L,pol); /* Berechne den Zykelindiktor der Cn */ zykelind_Cn(l,pol); b=callocobject(); halb=callocobject(); hilf=callocobject(); /* Vorfaktor 1/2 */ div(pol,cons_zwei,pol); /* Anhaengen der zusaetzlichen Summanden */ b_skn_po(callocobject(),callocobject(),NULL,b); m_l_nv(l,S_PO_S (b)); /* Wenn m gerade ist ..*/ if((long)len%2L == 0L) { erg += m_ioiu_b(1L,4L,S_PO_K(b)); erg += kuerzen(S_PO_K(b)); m_i_i(len/2L,S_PO_SI(b,1L)); add_apply(b,pol); /* addiere die zusaetzlichen Summanden */ erg += m_ioiu_b(1L,4L,S_PO_K(b)); erg += kuerzen(S_PO_K(b)); m_i_i(2L,S_PO_SI(b,0L)); m_i_i((len-2L)/2L,S_PO_SI(b,1L)); erg += add_apply(b,pol); /* addiere die zusaetzlichen Summanden */ } /* Wenn m ungerade ist .. */ if(len%2L == 1L) { m_ioiu_b(1L,2L,S_PO_K(b)); kuerzen(S_PO_K(b)); /* y1 in das Polynom eintragen */ m_i_i(1L,S_PO_SI(b,0L)); /* y2 hoch (n-1L)/2 in das Polynom eintragen */ m_i_i(((long)len-1L)/2L,S_PO_SI(b,1L)); add_apply(b,pol); /* addiere die zusaetzlichen Summanden */ } freeall(b); freeall(halb); freeall(hilf); ENDR("zykelind_Dn"); #endif /*BRUCHTRUE*/ } /* Berechnet das Zykelindikatorpolynom der An */ INT zykelind_An(l,pol) OP l; OP pol; /* NS 060891 V1.3 */ { #ifdef BRUCHTRUE INT i,j,veklen,veklen2; OP a; OP hilf; OP k; OP n; OP v; OP party; OP zahl; OP zwisch; if (S_O_K(l) != INTEGER) /* AK 060792 */ return error("zykelind_An: input not INTEGER"); if (S_I_I(l) < 1L) /* AK 060792 */ return error("zykelind_An: input < 1"); if (einsp(l)) /* AK 040692 */ { return m_iindex_monom(0L,pol); } init(POLYNOM,pol); a = callocobject(); hilf=callocobject(); k=callocobject(); n = callocobject(); v = callocobject(); party = callocobject(); zahl = callocobject(); zwisch = callocobject(); b_skn_po(callocobject(),callocobject(),NULL,a); /* lasse alle partitionen berechnen */ makevectorofpart(l,v); veklen=S_V_LI(v); m_l_nv(l,S_PO_S (a)); /* AK 040692 Macro */ for(i=0L; i < veklen ; i++) { /* umwandeln in Exponentenschreibweise */ t_VECTOR_EXPONENT(S_V_I(v,i),party); /* und umwandeln in ein Monom */ copy(S_PA_S(party),S_PO_S (a)); /* AK 040692 Macro */ veklen2=S_V_LI(S_PO_S (a)); /* AK 040692 Macro */ m_i_i(0L,zwisch); /* Variable entleeren */ for(j=1L; j < veklen2; j+=2L) { /* addiere a[2], a[4], ... auf */ add_apply(S_PO_SI(a,j),zwisch); /* AK 040692 statt add */ } /* Nur wenn a[2]+a[4]+... ungerade ist, dann gibts einen Koeff- * izienten */ if(even(zwisch)) { /* Berechnen der Koeffizienten */ m_i_i(1L,k); for(j=0L; j < veklen2; j++) { fakul(S_PO_SI(a,j),zwisch); mult(k,zwisch,k); m_i_i(j+1L,zahl); hoch(zahl,S_PO_SI(a,j),zwisch); mult(k,zwisch,k); } m_i_i(2L,zwisch); m_ou_b(zwisch,k,S_PO_K(a)); kuerzen(S_PO_K(a)); add_apply(a,pol); /* AK 040692 statt add */ } } freeall(a); freeall(hilf); freeall(k); freeall(n); freeall(party); freeall(v); freeall(zahl); freeall(zwisch); return OK; #else /* BRUCHTRUE */ return error("zykelind_An: BRUCH not available"); #endif /* BRUCHTRUE */ } /* * Berechnet das Zykelindikatorpolynom der Sn */ INT zykelind_Sn(l,pol) OP l; OP pol; /* NS 060891 V1.3 */ /* AK 300998 V2.0 */ /* l and pol may be equal */ { INT erg = OK; CTO(INTEGER,"zykelind_Sn(1)",l); SYMCHECK(S_I_I(l)<1,"zykelind_Sn(1): input < 1"); { INT i,j,veklen,veklen2; OP a,hilf,k,v,party,zahl,zwisch; CALLOCOBJECT4(a,k,hilf,party); CALLOCOBJECT3(v,zahl,zwisch); erg += b_skn_po(CALLOCOBJECT(),CALLOCOBJECT(),NULL,a); erg += makevectorofpart(l,v); veklen=S_V_LI(v); erg += m_l_nv(l,S_PO_S (a)); erg += init(POLYNOM,pol); for(i=0L; i < veklen ; i++) { /* umwandeln in Exponentenschreibweise */ erg += t_VECTOR_EXPONENT(S_V_I(v,i),party); /* und umwandeln in ein Monom */ CLEVER_COPY(S_PA_S(party),S_PO_S(a)); /* Berechnen der Koeffizienten */ m_i_i(1,k); veklen2=S_V_LI(S_PO_S (a)); for(j=0L; j < veklen2; j++) { erg += fakul(S_V_I(S_PO_S(a),j),zwisch); MULT_APPLY(zwisch,k); M_I_I(j+1,zahl); erg += hoch(zahl,S_V_I(S_PO_S(a),j),zwisch); MULT_APPLY(zwisch,k); } erg += invers(k,S_PO_K(a)); ADD_APPLY(a,pol); } FREEALL4(a,k,hilf,party); FREEALL3(v,zahl,zwisch); } ENDR("zykelind_Sn"); } /* Hier folgen die Routinen fuer die Berechnung der Zykel- * indizes von beliebigen Permutationsgruppen, die durch * erzeugende Permutationen gegeben sind */ /* routinen zur berechnung eines starken Erzeugers nach Hoffmann */ struct treecomp { unsigned short atr; /* 0=FALSE, 1=TRUE */ INT gen; INT point; }; static INT stabilizer(i,vec,stabi) INT i; OP vec; OP stabi; /* NS 060891 V1.3 */ /* AK 101291 vec ist VECTOR of PERMUTATION stabi wird VECTOR of PERMUTATION */ { unsigned short is_stab; INT j,k; /* Schleifenzaehler */ INT veclen; m_il_v(0L,stabi); /* stabi is freed first */ veclen=S_V_LI(vec); for(j=0L; j < veclen; j++) { is_stab=N_TRUE; for(k=0 ; k < i-1L; k++) { if(S_P_II(S_V_I(vec,j),k) != k+1L) { is_stab=N_FALSE; break; } } if(is_stab) { inc(stabi); copy(S_V_I(vec,j),S_V_I(stabi,S_V_LI(stabi)-1L)); } } return OK; } static INT updatemat(degree,i,tree,stabi,repma) INT degree,i; struct treecomp *tree; OP stabi,repma; /* NS 060891 V1.3 */ { INT l,next; OP id=callocobject(); OP ob_degree=callocobject(); OP operm=callocobject(); m_i_i(degree,ob_degree); first_permutation(ob_degree,id); /* Untersuche die Bahn von i, fuer jedes k aus der Bahn von * von i mache einen Eintrag i,k in der Repraesentations * matrix und zwar das Produkt aller Erzeuger, die i * sukzessive nach k bewegt haben, dazu benutzte alle * Eintrage in tree.gen auf dem Weg zurueck von k nach i (=wort) * und multipliziere die entsprechenden Erzeuger */ for(l=i; l < degree; l++) { if(tree[l].atr == N_TRUE) { /* suche rueckwaerts */ next=l; copy(id,operm); while(tree[next].point) { mult(operm,S_V_I(stabi,tree[next].gen),operm); next=(tree[next].point)-1L; } copy(operm,S_M_IJ(repma,i-1L,l)); } } freeall(id); freeall(ob_degree); freeall(operm); return OK; } /* sift() sieht nach, ob perm in der Repraesentationsmatrix * repma enthalten ist. sift() wird von strongen benoetigt. */ static INT sift(degree,insrow,perm,repma) INT degree, *insrow; OP perm,repma; /* NS 060891 V1.3 */ { register unsigned short ismember=N_TRUE; INT i=0L,j; OP invperm=callocobject(); while((i < degree) && ismember) { i++; j=S_P_II(perm,i-1L); if(not EMPTYP (S_M_IJ(repma,i-1L,j-1L))) { invers(S_M_IJ(repma,i-1L,j-1L),invperm); mult(invperm,perm,perm); } else { ismember=N_FALSE; copy(perm,S_M_IJ(repma,i-1L,j-1L)); /* In diese Zeile wurde die Permutation eingefuegt */ (*insrow)=i-1L; break; } } freeall(invperm); return(ismember); } /* porbit(degree,i,stabi,tree) berechnet die Bahn eines Punktes * i und gibt * folgenden Baum (tree) zurueck: * * * tree[r].atr: TRUE, wenn r in der Bahn von i liegt, sonst FALSE * tree[r].gen: Nummer k des Generators g[k], der s-> r abb. * tree[r].point: Bahnpunkt s, der von dem generator g[k] nach * r abbgebildet wird, tree[i].point = 0L, um * anzuzeigen, dass i die Wurzel des Baumes ist. * * porbit() wird von strongen() benoetigt. */ static INT porbit(degree,i,stabi,tree) INT degree,i; OP stabi; /* Stabilisator von 1L,...,i-1 */ struct treecomp tree[]; /* NS 060891 V1.3 */ { INT pos=0L; INT stablen; INT g,j, /* Schleifenzaehler */ r,s; /* Bahnpunkte */ INT *points; stablen=S_V_LI(stabi); points=(INT *) SYM_malloc(sizeof(INT)*degree+OFFSET); points[pos] = i; /* initialisiere points mit dem Punkt, * dessen Bahn gesucht wird */ for(j=0L; j < degree; j++) { tree[j].atr=N_FALSE; tree[i-1].atr=N_TRUE; tree[i-1].point=0L; /* i ist Wurzel des Baumes */ } while(pos >= 0L) { s=points[pos]; points[pos--]=0L; for(g=0L; g < stablen; g++) { /* Bestimme das Bild r von s unter dem g-ten Stabilisator */ r=S_P_II(S_V_I(stabi,g),s-1L); if(not tree[r-1].atr) { points[++pos]=r; tree[r-1].atr=N_TRUE; tree[r-1].gen=g; tree[r-1].point=s; } } } SYM_free(points); return OK; } /* Eigentliche Prozedur zur Berechnung eines starken Erzeugers * beziehungsweise einer Repraesentationsmatrix repma */ #ifdef MATRIXTRUE INT strong_generators(a,b) OP a,b; /* AK 290192 */ /* a VECTOR of generators b becomes MATRIX of stronggenerators */ { INT degree, numgen; INT erg = OK; degree=S_P_LI (S_V_I(a,0L)); numgen=S_V_LI(a); erg += m_ilih_m(degree+1L,degree+1L,b); erg += strongen(degree,numgen,a,b); ENDR("strong_generators"); } static INT strongen(degree,numgen,genvec,repma) INT degree; /* numgen= Anzahl der Erzeuger wird von strongen an sift() * weitergereicht. */ INT numgen; OP genvec; /* Vektor der die Erzeuger einer Gruppe enthaelt */ OP repma; /* Repraesentationsmatrix fuer die Gruppe */ /* NS 060891 V1.3 */ { INT i,j,k,l; /* Schleifenzaehler */ INT row; INT stablen; INT erg = OK; /* AK 290192 */ struct treecomp *tree; OP id=callocobject(); OP queue=callocobject(); OP ob_degree=callocobject(); OP perm_eins=callocobject(); /* stabi ist Vektor von Permutationen. */ OP stabi=callocobject(); OP strgset=callocobject(); tree=(struct treecomp*) SYM_malloc(degree*sizeof(struct treecomp)+OFFSET); m_i_i(degree,ob_degree); erg +=first_permutation(ob_degree,id); /* Stabilisator ist am Anfang der ganze Erzeuger */ erg +=m_il_v(numgen,strgset); erg +=m_il_v(0L,stabi); for(k=0L; k < numgen; k++) { erg +=copy(S_V_I(genvec,k),S_V_I(strgset,k)); } /* Diagonale der Repraesentationsmatrix mit id besetzen */ for(k=0L; k < degree; k++) erg +=copy(id,S_M_IJ(repma,k,k)); for(i=1L; i <= degree; i++) { erg +=stabilizer(i,strgset,stabi); erg +=porbit(degree,i,stabi,tree); erg +=updatemat(degree,i,tree,stabi,repma); } m_il_v(0L,queue); for(i=1L; i <= degree; i++) { erg +=stabilizer(i,strgset,stabi); stablen=S_V_LI(stabi); for(l=0L; l < stablen; l++) { /* for(k=i-1L; k <= degree; k++) */ for(k=i-1L; k < degree; k++) /* statt <= degree < degree */ if(not EMPTYP(S_M_IJ(repma,i-1L,k))) { erg +=mult(S_V_I(stabi,l),S_M_IJ(repma,i-1L,k),perm_eins); erg +=inc(queue); erg +=copy(perm_eins,S_V_I(queue,S_V_LI(queue)-1L)); } } while(S_V_LI(queue)) { erg +=copy(S_V_I(queue,S_V_LI(queue)-1L),perm_eins); erg +=dec(queue); if(not sift(degree,&row,perm_eins,repma)) /* ismember == 0 */ { erg +=inc(strgset); erg +=copy(perm_eins,S_V_I(strgset,S_V_LI(strgset)-1L)); for(j=1L; j <= row; j++) { erg +=stabilizer(j,strgset,stabi); erg +=porbit(degree,j,stabi,tree); erg +=updatemat(degree,j,tree,stabi,repma); /*for(l=j-1L; l <= degree; l++)*/ for(l=j-1L; l < degree; l++) /* < degree statt <= degree */ { if(not EMPTYP(S_M_IJ(repma,j-1L,l))) { erg +=mult(perm_eins,S_M_IJ(repma,j-1L,l),perm_eins); erg +=inc(queue); erg +=copy(perm_eins,S_V_I(queue,S_V_LI(queue)-1L)); } } } } /* end if */ } /* end while */ } /* AK end for 110292 */ erg +=freeall(id); erg +=freeall(queue); erg +=freeall(ob_degree); erg +=freeall(perm_eins); erg +=freeall(stabi); erg +=freeall(strgset); SYM_free(tree); return erg; } /* end all :-) */ #endif /* MATRIXTRUE */ static INT recu(degree,start,numnontriv,ztvec,numztvec,perm,repma) INT degree; INT start; INT numnontriv; OP ztvec; OP numztvec; OP perm; OP repma; /* NS 060891 V1.3 */ { INT i,j; OP saveperm=callocobject(); if(start == numnontriv-1L) { for(i=start; i< degree; i++) { if(not EMPTYP(S_M_IJ(repma,start,i))) { mult(perm,S_M_IJ(repma,start,i),saveperm); colltypes(saveperm,ztvec,numztvec); } } } else for(j=start; j < degree; j++) { if(not EMPTYP(S_M_IJ(repma,start,j))) { mult(perm,S_M_IJ(repma,start,j),saveperm); recu(degree,start+1L,numnontriv,ztvec,numztvec,saveperm,repma); } } freeall(saveperm); return OK; } static INT callrecu(grad,ztvec,numztvec,repma) INT grad; OP ztvec,numztvec,repma; /* NS 060891 V1.3 */ { unsigned short trivrow; INT i,j; INT numnontriv=1L; /* AK 021291 */ OP id=callocobject(); OP ob_grad=callocobject(); OP perm=callocobject(); /* Weil die unteren Zeilen der Matrix meistens bis auf * die Identitaet in der Diagonalen leer sind, wird * hier erstmal festgestellt, ab wo die Matrix leer * ist */ for(i=grad-1L; i > 0L; i--) { trivrow=N_TRUE; for(j=i+1L; j < grad; j++) { if(not EMPTYP(S_M_IJ(repma,i,j))) { trivrow=N_FALSE; break; } } if(trivrow == N_FALSE) { numnontriv=i+1L; break; } } m_i_i(grad,ob_grad); first_permutation(ob_grad,id); copy(id,perm); recu(grad,0L,numnontriv,ztvec,numztvec,perm,repma); freeall(id); freeall(ob_grad); freeall(perm); return OK; } /* end all */ static INT colltypes(perm,ztvec,numztvec) OP perm, ztvec, numztvec; /* NS 060891 V1.3 */ { INT i; INT ztveclen; OP ztperm=callocobject(); OP expztperm=callocobject(); ztveclen=S_V_LI(ztvec); zykeltyp(perm,ztperm); t_VECTOR_EXPONENT(ztperm,expztperm); for(i=0L; i < ztveclen; i++) { if(comp(expztperm,S_V_I(ztvec,i)) == 0L) { inc(S_V_I(numztvec,i)); goto ende; } } inc(ztvec); copy(expztperm,S_V_I(ztvec,S_V_LI(ztvec)-1L)); inc(numztvec); m_i_i(1L,S_V_I(numztvec,S_V_LI(numztvec)-1L)); ende: freeall(ztperm); freeall(expztperm); return OK; } /* berechnet das Zykelindikatorpolynom einer beliebigen Permutations- * gruppe, benutzt dazu die uebergebenen Vektoren, die die * Zykeltypen (expztvec), bzw deren Anzahlen (numztvec) * enthalten. */ #ifdef BRUCHTRUE static INT zykelind_arb_co(expztvec,numztvec,pol) OP expztvec; OP numztvec; OP pol; /* enhaelt nach Ablauf der Routine das Zykelindikator- * polynom (noch nicht Polyasubstituiert) */ /* NS 060891 V1.3 */ { INT i,order,veklen; INT erg = OK; OP a,hilf,k,party,zahl,zwisch,zykeltypvec; OP ak_order; a = CALLOCOBJECT(); hilf=CALLOCOBJECT(); k=CALLOCOBJECT(); party = CALLOCOBJECT(); zahl = CALLOCOBJECT(); zwisch = CALLOCOBJECT(); zykeltypvec = CALLOCOBJECT(); ak_order = CALLOCOBJECT(); sum(numztvec,ak_order); /* AK 060295 */ b_skn_po(CALLOCOBJECT(),CALLOCOBJECT(),NULL,a); veklen=S_V_LI(expztvec); m_il_nv(5,S_PO_S(a)); init(POLYNOM,pol); for(i=0L; i < veklen ; i++) { COPY(S_PA_S(S_V_I(expztvec,i)),S_PO_S (a)); /* m_i_i(order,k); */ m_ou_b(S_V_I(numztvec,i),ak_order,S_PO_K(a)); /* m_ou_b(S_V_I(numztvec,i),k,S_PO_K(a)); */ kuerzen(S_PO_K(a)); add_apply(a,pol); } FREEALL3(a,hilf,k); FREEALL5(ak_order,party,zahl,zwisch,zykeltypvec); ENDR("zykelind_arb_co:internal routine"); } #endif /* BRUCHTRUE */ /* * Die Funktion zykelind_arb fasst die Funktionen strongen, * callrecu und zykelind_arb_co zusammen. Eingabeparameter * der Vektor von Permutationen genvec, er enthaelt die Erzeuger * der Gruppe, in pol wird dann das Zykelindikator polynom * geliefert. */ INT zykelind_arb(genvec,pol) OP genvec; OP pol; /* NS 060891 V1.3 */ /* AK 180998: now the generating permutations may have different degree */ { #ifdef BRUCHTRUE INT degree,i,j; INT numgen; INT erg = OK; OP mat=callocobject(); OP numztvec=callocobject(); OP ztvec=callocobject(); OP axl = callocobject(); OP mygenvec = callocobject(); erg += m_l_v(cons_null,numztvec); erg += m_l_v(cons_null,ztvec); /* degree und numgen bestimmen */ degree=S_P_LI (S_V_I(genvec,0L)); for (i=1;i degree) degree=S_P_LI (S_V_I(genvec,i)); numgen=S_V_LI(genvec); erg += m_il_v(numgen,mygenvec); /* AK 180998 */ for (i=0;i [11...1][22...2]...[nn...n] * wobei die Laenge von [xx...x] gleich der Anzahl der * Farben ist und n die Maechtigkeit der Menge X, * auf der die Gruppe operiert. */ erg += numberofvariables(pol,exp); /* AK 211194 */ degree=S_I_I(exp); erg += m_il_v(degree,colvec); erg += b_skn_po(callocobject(),callocobject(),NULL,compcolpol); erg += b_skn_po(callocobject(),callocobject(),NULL,hpol); FREESELF(pattpol); for(i=0L; i < degree; i++) { erg += init(POLYNOM,compcolpol); for(j=0L; j < numcol; j++) { if (not EMPTYP(hpol)) erg += freeself(hpol); erg += m_iindex_iexponent_monom(j,i+1L,hpol); erg += add_apply(hpol,compcolpol); } erg += copy(compcolpol,S_V_I(colvec,i)); } erg += eval_polynom(pol,colvec,pattpol); FREEALL4(colvec,compcolpol,hpol,exp); ENDR("zyk:internal function polyasub"); } /* Algorithmus von dimino, berechnet eine Liste mit allen * Elementen einer Gruppe aus den erzeugenden Permutationen. */ INT dimino(elm) OP elm; /* enthaelt am Anfang die Erzeuger der Gruppe, nach * Ablauf der Routine dann alle Gruppenelemente */ /* NS 060891 V1.3 */ { INT i,j,k, cosetlen, elt_not_elm, numgen, order=0L, rep_pos, s_count, si_not_elm; INT erg = OK; OP elt,g,genvec,id; CTO(VECTOR,"dimino(1)",elm); elt=callocobject(); /* Hilfsvariable fuer Test auf Enhaltensein * in elm */ g=callocobject(); /* eine Permutation */ genvec=callocobject(); /* enhaelt die Erzeuger */ id=callocobject(); /* die identische Permutation */ numgen=S_V_LI(elm); erg += m_il_v(numgen,genvec); /* Kopiere die Erzeuger in einen eigenen Vektor genvec */ for(i=0L; i < numgen; i++) COPY(S_V_I(elm,i),S_V_I(genvec,i)); eins(S_V_I(genvec,0),id); /* Liste der Elemente anlegen, laenge ist erstmal = 1 */ erg += m_il_v(1L,elm); /* Spezialfall G= */ COPY(id,S_V_I(elm,order)); /* 1. Element ist id */ COPY(S_V_I(genvec,0L),g); /* g:=s1 */ // while(comp(g,id)) /* Solange g ungleich id */ while(not einsp(g)) /* Solange g ungleich id */ { /* Elementevektor muss jedesmal erst um 1 verlaengert werden */ INC(elm); ++order; /* AK 060891 */ COPY(g,S_V_I(elm,order)); /* elm[order]=g */ CLEVER_MULT(S_V_I(elm,order),S_V_I(genvec,0L),g); /* g:=g*s1 */ } /* Laenge der Nebenklassen feststellen, muss man nur einmal machen, * da alle Nebenklassen gleiche Laenge haben */ cosetlen=S_V_LI(elm); /* Falls es mehr als einen Erzeuger gibt */ for(i=1L; i < numgen; i++) { si_not_elm=1L; for(k=0L; k <= order; k++) /* s(i) in elm ? */ if((si_not_elm=comp(S_V_I(genvec,i),S_V_I(elm,k))) == 0L) break; /* Wenn s[i] nicht in elm: * s[i] und seine Nebenklasse g*s[i] * zu elm hinzufuegen */ if(si_not_elm) /* Wenn s(i) nicht in elm */ { /* s[i] hinzufuegen */ /* Elementevektor muss jedesmal erst um 1 verlaengert werden */ inc(elm); ++order; COPY(S_V_I(genvec,i),S_V_I(elm,order)); /* Nebenklasse zu elm hinzufuegen */ for(j=1L; j < cosetlen; j++) { /* ++order,elm[order]:=elm[j]*s[i] */ /* Elementevektor muss jedesmal erst um 1 verlaengert werden */ inc(elm); ++order; MULT(S_V_I(elm,j),S_V_I(genvec,i),S_V_I(elm,order)); } /* end for */ rep_pos=cosetlen; do { for(s_count=0L; s_count <= i; s_count++) { /* elt=elm[rep_pos]*s[s_count] */ MULT(S_V_I(elm,rep_pos), S_V_I(genvec,s_count),elt); elt_not_elm=1L; for(k=0L; k <= order; k++) /* elt in elm ? */ if((elt_not_elm=comp(elt,S_V_I(elm,k))) == 0L) break; /* Wenn elt nicht in elm: * elt und seine Nebenklasse g*elt * zu elm hinzufuegen */ if(elt_not_elm) { /* elt hinzufuegen */ /* Elementevektor muss jedesmal erst * um 1 verlaengert werden */ INC(elm); ++order; COPY(elt,S_V_I(elm,order)); /* Nebenklasse zu elm hinzufuegen */ for(j=1L; j < cosetlen; j++) { /* ++order,elm[order]:=elm[j]*s[i] */ /* Elementevektor muss jedesmal erst * um 1 verlaengert werden */ INC(elm); ++order; MULT(S_V_I(elm,j),elt,S_V_I(elm,order)); } /* end for */ } /* end if */ } /* end for */ rep_pos+=cosetlen; } while(rep_pos <= order); } /* end if */ cosetlen=order+1L; } /* end for */ FREEALL4(elt,g,genvec,id); CTO(VECTOR,"dimino(1e)",elm); ENDR("dimino"); } INT grf_arb(gr,n,res) OP gr,n,res; /* AK 220998 V2.0 */ /* AK 091204 V3.0 */ { INT erg = OK; CTO(INTEGER,"grf_arb(2)",n); CTO(VECTOR,"grf_arb(1)",gr); CE3(gr,n,res,grf_arb); { OP zw; zw = CALLOCOBJECT(); erg += zykelind_arb(gr,zw); erg += polya_n_sub(zw,n,res); FREEALL(zw); } ENDR("grf_arb"); } INT grf_Sn(gr,n,res) OP gr,n,res; /* AK 220998 V2.0 */ { INT erg = OK; CTO(INTEGER,"grf_Sn",n); CTO(INTEGER,"grf_Sn",gr); CE3(gr,n,res,grf_Sn); { OP zw; zw = callocobject(); erg += zykelind_Sn(gr,zw); erg += polya_n_sub(zw,n,res); erg += freeall(zw); } ENDR("grf_Sn"); } INT grf_An(gr,n,res) OP gr,n,res; /* AK 220998 V2.0 */ { OP zw; INT erg = OK; CTO(INTEGER,"grf_An",n); CTO(INTEGER,"grf_An",gr); CE3(gr,n,res,grf_An); zw = callocobject(); erg += zykelind_An(gr,zw); erg += polya_n_sub(zw,n,res); erg += freeall(zw); ENDR("grf_An"); } INT grf_Cn(gr,n,res) OP gr,n,res; /* AK 220998 V2.0 */ { OP zw; INT erg = OK; CTO(INTEGER,"grf_Cn",n); CTO(INTEGER,"grf_Cn",gr); CE3(gr,n,res,grf_Cn); zw = callocobject(); erg += zykelind_Cn(gr,zw); erg += polya_n_sub(zw,n,res); erg += freeall(zw); ENDR("grf_Cn"); } INT grf_Dn(gr,n,res) OP gr,n,res; /* AK 220998 V2.0 */ { OP zw; INT erg = OK; CTO(INTEGER,"grf_Dn",n); CTO(INTEGER,"grf_Dn",gr); CE3(gr,n,res,grf_Dn); zw = callocobject(); erg += zykelind_Dn(gr,zw); erg += polya_n_sub(zw,n,res); erg += freeall(zw); ENDR("grf_Dn"); } INT no_orbits_arb(a,b,c) OP a,b,c; /* AK 071098 V2.0 */ { OP d,e; OP z; INT erg = OK; CE3(a,b,c,no_orbits_arb); d = callocobject(); e = callocobject(); erg += zykelind_arb(a,d); z = d; erg += m_i_i(0,c); while (z!=NULL) { erg += sum(S_PO_S(z),e); erg += hoch(b,e,e); erg += mult_apply(S_PO_K(z),e); erg += add_apply(e,c); z = S_PO_N(z); } erg += freeall(d); erg += freeall(e); ENDR("no_orbits_arb"); } #endif /* ZYKTRUE */ symmetrica-2.0/zyk.doc0000600017361200001450000001131210726170302014675 0ustar tabbottcrontabCOMMENT: ZYK ___ We are describing the routines of the file zyk.c. These are routines for the computation of cycle index polynomials, and for the computation with general permutation groups. NAME: zykelind_Sn SYNOPSIS: INT zykelind_Sn(OP n,pol) DESCRIPTION: computes the cycleindex polynomial of the symmetric group of the degree n. n is a INTEGER object, pol becomes a POLYNOM object. BUG: n and pol must be different NAME: zykelind_Dn SYNOPSIS: INT zykelind_Dn(OP n,pol) DESCRIPTION: computes the cycleindex polynomial of the dihedral group of the degree n. n is a INTEGER object, pol becomes a POLYNOM object. BUG: n and pol must be different NAME: zykelind_Cn SYNOPSIS: INT zykelind_Cn(OP n,pol) DESCRIPTION: computes the cycleindex polynomial of the cyclic group of the degree n. n is a INTEGER object, pol becomes a POLYNOM object. BUG: n and pol must be different NAME: zykelind_An SYNOPSIS: INT zykelind_An(OP n,pol) DESCRIPTION: computes the cycleindex polynomial of the alternating group of the degree n. n is a INTEGER object, pol becomes a POLYNOM object. BUG: n and pol must be different NAME: zykelind_arb SYNOPSIS: INT zykelind_arb(OP vec,pol) DESCRIPTION: computes the cycle index polynomial of a arbitrary permutation group . vec is a VECTOR object, whose entries are PERMUTATION objects whose degrees are equal. These permutations are the generators of the group. pol becomes a POLYNOM object. BUG: vec and pol must be different NAME: dimino SYNOPSIS: INT dimino(OP vec) DESCRIPTION: computes the elements of a arbitrary permutation group. vec is a VECTOR object, whose elements are PERMUTATION objects, which generates the group. At the end of dimino, this vector contains all elements of the group. BUG: the permutations in the vector must be of the same degree, and they must be of VECTOR type. NAME: polya_n_sub SYNOPSIS: INT polya_n_sub(OP p,n,e) DESCRIPTION: you enter a POLYNOM object p, and a INTEGER object n, and the output is the POLYNOM object which you get using the substitution x_i --> a_1^i + ... + a_n^i NAME: grf_Sn SYNOPSIS: INT grf_Sn(OP degree, OP n, OP result) DESCRIPTION: you enter the degree of the symmetric group, and the number of variables for the polya substitution. The routine computes the group reduction function. The first step is the computation of cycle index and the second step is the polya substitution with n variables. EXAMPLE: #include "def.h" #include "macro.h" ANFANG sscan("9",INTEGER,a); sscan("4",INTEGER,b); grf_Sn(a,b,c); println(c); ENDE NAME: grf_Cn SYNOPSIS: INT grf_Cn(OP degree, OP n, OP result) DESCRIPTION: you enter the degree of the cyclic group, and the number of variables for the polya substitution. The routine computes the group reduction function. The first step is the computation of cycle index and the second step is the polya substitution with n variables. EXAMPLE: #include "def.h" #include "macro.h" ANFANG sscan("9",INTEGER,a); sscan("4",INTEGER,b); grf_Cn(a,b,c); println(c); ENDE NAME: grf_An SYNOPSIS: INT grf_An(OP degree, OP n, OP result) DESCRIPTION: you enter the degree of the alternating group, and the number of variables for the polya substitution. The routine computes the group reduction function. The first step is the computation of cycle index and the second step is the polya substitution with n variables. EXAMPLE: #include "def.h" #include "macro.h" ANFANG sscan("9",INTEGER,a); sscan("4",INTEGER,b); grf_An(a,b,c); println(c); ENDE NAME: grf_Dn SYNOPSIS: INT grf_Dn(OP degree, OP n, OP result) DESCRIPTION: you enter the degree of the dihedral group, and the number of variables for the polya substitution. The routine computes the group reduction function. The first step is the computation of cycle index and the second step is the polya substitution with n variables. EXAMPLE: #include "def.h" #include "macro.h" ANFANG sscan("9",INTEGER,a); sscan("4",INTEGER,b); grf_Dn(a,b,c); println(c); ENDE NAME: grf_arb SYNOPSIS: INT grf_arb(OP generators, OP n, OP result) DESCRIPTION: you enter the generators (VECTOR of PERMUTATION objects) of a permutaion group, and the number of variables for the polya substitution. The routine computes the group reduction function. The first step is the computation of cycle index and the second step is the polya substitution with n variables. EXAMPLE: #include "def.h" #include "macro.h" ANFANG sscan("[[6,5,4,3,2,1,8,7],[2,1,8,7,6,5,4,3],[5,6,7,8,1,2,3,4]]", PERMUTATIONVECTOR,a); sscan("4",INTEGER,b); grf_arb(a,b,c); println(c); ENDE symmetrica-2.0/zykelind.c0000400017361200001450000052654010726021674015411 0ustar tabbottcrontab/* SYMMETRICA zykelind.c */ #include "def.h" #include "macro.h" static INT zykeltyp_on_pairs_reduced(); static INT zykeltyp_on_2sets(); static INT zykeltyp_on_ksubsets(); static INT zykeltyp_on_ktuples(); static INT zykelind_index_verschieben(); static INT zykelind_operation_for_exp(); static INT zykeltyp_operation_for_exp(); static INT zykeltyp_poly_part(); static INT zykeltyp_hyperbegleitmatrix_poly(); static INT exponenten_bestimmen(); static INT charakteristik_bestimmen(); static INT zykeltyp_poly_part_aff(); static INT zykeltyp_hyperbegleitmatrix_poly_afferg(); static INT zykelind_aff1Zp(); static INT zykelind_aff1Z2(); static INT min_pot(); static INT zykelind_dir_prod_pglkq(); static INT zykelind_dir_prod_pglkq_apply(); static INT zykelind_hoch_dir_prod_pglkq(); static INT mod_mult(); static INT subexponenten_bestimmen(); static INT zyklische_gruppe(); static INT zykeltyp_poly_part_pglkq(); static INT zykeltyp_hyperbegleitmatrix_poly_pglkq(); static INT zykelind_aus_subzykelind(); static INT monom_to_vek(); static INT vek_to_monom(); static INT sum_vector11(); static INT sum_vector1(); static INT zykelind_red(); static INT zykelind_red_apply(); static INT debruijn_formel(); static INT eval_polynom_maxgrad(); static INT mult_po_po_maxgrad(); static INT hoch_po_maxgrad(); static INT zykelind_test1(); static INT comp_vector1(); static INT ordnung(); static INT mu(); static INT vektor_mult_apply(); static INT vektor_prod(); static INT vektor_kgv_prod_durch_kgv(); static INT fmultinom(); static INT fmultinom_ext(); static INT erster_kandidat(); static INT next_kandidat(); static INT next_kandidat2(); static INT first_unordered_part_into_atmost_k_parts(); static INT next_unordered_part_into_atmost_k_parts(); static INT first_part_into_atmost_k_parts(); static INT next_part_into_atmost_k_parts(); static INT redf_f1(); static INT redf_f2(); static INT redf_f3(); static INT redf_f1h(); static INT redf_f2h(); static INT redf_f3h(); static INT redf_formel(); #ifdef POLYTRUE INT zykelind_dir_prod(a,b,c) /* Berechnet aus den Zykelindizes a und b einen weiteren Zykelindex c. Es operiere G auf X und H auf Y dann operiert G\times H auf X\times Y. Der Zykelindex c ist der Zykelindex der Operation von G\times H in obiger Situation, falls a der Zykelindex von der Aktion von G auf X und b der Zykelindex der Aktion von H auf Y ist. */ OP a,b,c; { OP hilfk,hilfmonom,monom1,monom2,monom3; INT i1,i2,ex1,ex2; INT erg=OK; CTO(POLYNOM,"zykelind_dir_prod(1)",a); CTO(POLYNOM,"zykelind_dir_prod(2)",b); hilfk=callocobject(); hilfmonom=callocobject(); monom3=callocobject(); M_I_I(0L,hilfk); erg+=m_scalar_polynom(hilfk,c); monom1=a; while (monom1!=NULL) { monom2=b; while (monom2!=NULL) { erg+=mult(S_PO_K(monom1),S_PO_K(monom2),hilfk); erg+=m_scalar_polynom(hilfk,monom3); for (i1=0L; i1=2L) { M_I_I(ex1,hilf); erg+=binom(hilf,cons_zwei,hilf1); erg+=m_iindex_iexponent_monom(i1,(i1+1L),hilfmonom); erg+=hoch(hilfmonom,hilf1,hilfmonom); erg+=mult_apply(hilfmonom,b); } if (i1 % 2L == 0L) erg+=m_iindex_iexponent_monom(i1,ex1*i1/2L,hilfmonom); else { erg+=m_iindex_iexponent_monom(i1,ex1*((i1+1L)/2L-1L),hilfmonom); erg+=m_iindex_iexponent_monom((i1+1L)/2L-1L,ex1,hilf1); erg+=mult_apply(hilf1,hilfmonom); } erg+=mult_apply(hilfmonom,b); } } i1=S_V_LI(S_PO_S(a))-1L; ex1=S_V_II(S_PO_S(a),i1); if (ex1 != 0L) { if (ex1>=2L) { M_I_I(ex1,hilf); erg+=binom(hilf,cons_zwei,hilf1); erg+=m_iindex_iexponent_monom(i1,(i1+1L),hilfmonom); erg+=hoch(hilfmonom,hilf1,hilfmonom); erg+=mult_apply(hilfmonom,b); } if (i1 % 2L == 0L) erg+=m_iindex_iexponent_monom(i1,ex1*i1/2L,hilfmonom); else { erg+=m_iindex_iexponent_monom(i1,ex1*((i1+1L)/2L-1L),hilfmonom); erg+=m_iindex_iexponent_monom((i1+1L)/2L-1L,ex1,hilf1); erg+=mult_apply(hilf1,hilfmonom); } erg+=mult_apply(hilfmonom,b); } erg+=freeall(hilf); erg+=freeall(hilf1); erg+=freeall(hilfmonom); if (erg != OK) error(" in computation of zykeltyp_on_2sets(a,b) "); return(erg); } INT zykelind_on_2sets(a,b) OP a,b; /* Berechnet aus dem Zykelindex a den Zykelindex b der auf der Menge aller 2-elementigen Teilmengen induzierten Gruppenaktion, die durch die zu a gehoerende Gruppenaktion definiert wird. */ { OP hilfk,monom1,monom3; INT erg=OK; if (S_O_K(a)!=POLYNOM) return error("zykelind_on_2sets(a,b) a not POLYNOM"); if (not EMPTYP(b)) erg+=freeself(b); hilfk=callocobject(); monom3=callocobject(); M_I_I(0L,hilfk); erg+=m_scalar_polynom(hilfk,b); monom1=a; while (monom1!=NULL) { erg+=zykeltyp_on_2sets(monom1,monom3); erg+=add_apply(monom3,b); monom1=S_PO_N(monom1); } erg+=freeall(hilfk); erg+=freeall(monom3); if (erg != OK) error(" in computation of zykelind_on_2sets(a,b) "); return(erg); } INT zykelind_superp_lin_dir_graphs(a,bb) OP a,bb; /* Berechnet den Zyklenzeiger der Gruppenaktion von S_n auf der Menge aller Paare (i,j) mit i ungleich j (Kanten eines gerichteten Graphen) und auf der Menge aller 2-elementigen Teilmengen von {1,2,...,n} (Kanten eines linearen Graphen). Die entsprechenden Zykelverzeichnisse werden dabei mit verschiedenen Familien von Unbestimmten versehen. a ist ein Integer Objekt, das den Wert von n (Anzahl der Knoten der Graphen) angibt. bb ist der errechnete Zyklenzeiger, also ein 2-dimensionaler Zykelindex. c=s_mz_v(bb) ist ein Vektor Objekt. Die (zwei) Eintragungen von c definieren die Stellen in dem Polynomobjekt an denen eine neue Familie von Unbestimmten beginnt. (Somit ist der erste Wert von c gleich 0. Den zweiten Wert kann man in diesem Fall stets gleich (a ueber 2) setzen.) */ { OP b,c,d,cc,hilfmonom,monom1,monom2,monom3,monom4,vekt; INT i1,i2,ex1,ex2; INT erg=OK; if (S_O_K(a)!=INTEGER) return error("zykelind_superp_lin_dir_graphs(a,b) a not INTEGER"); if (not EMPTYP(bb)) erg+=freeself(bb); d=callocobject(); cc=callocobject(); b=callocobject(); c=callocobject(); hilfmonom=callocobject(); monom2=callocobject(); monom3=callocobject(); monom4=callocobject(); vekt=callocobject(); erg+=zykelind_Sn(a,d); erg+=m_scalar_polynom(cons_null,b); erg+=m_il_v(2L,c); M_I_I(0L,S_V_I(c,0L)); erg+=binom(a,cons_zwei,cc); erg+=copy(cc,S_V_I(c,1L)); monom1=d; while (monom1!=NULL) { erg+=zykeltyp_on_pairs_reduced(monom1,monom3); erg+=zykeltyp_on_2sets(monom1,monom2); erg+=copy(S_PO_S(monom2),vekt); while (S_V_LI(vekt)0L) erg+=add_apply(hilf5,S_V_I(c,i)); else erg+=sub(S_V_I(c,i),hilf5,S_V_I(c,i)); } } erg+=ganzdiv(S_V_I(c,i),hilf,S_V_I(c,i)); erg+=inc(hilf); } erg+=freeall(hilf); erg+=freeall(hilf1); erg+=freeall(hilf2); erg+=freeall(hilf3); erg+=freeall(hilf4); erg+=freeall(hilf5); erg+=freeall(pow); erg+=freeall(teiler); erg+=freeall(teiler1); if (erg!=OK) EDC("zykeltyp_operation_for_exp"); return erg; } /* ************************************************************** The cycle indices of centralizers of permutations and stabilizers of partitions. ****************************************************************** */ INT zykelind_centralizer(typ,res) OP typ,res; /* Berechnet den Zyklenzeiger des Stabilisators einer Permutation, vom Zykeltyp typ.*/ { INT erg=OK; OP typv,typvv; OP a=callocobject(); OP b=callocobject(); OP c=callocobject(); OP d=callocobject(); INT i; INT j=0L; erg+=m_scalar_polynom(cons_eins,res); if (S_O_K(typ)==PERMUTATION) { typv=callocobject(); erg+=zykeltyp(typ,typv); t_VECTOR_EXPONENT(typv,typv); typvv=S_PA_S(typv); j=1L; } else if (S_O_K(typ)==PARTITION) { if (S_PA_K(typ)==VECTOR) { typv=callocobject(); t_VECTOR_EXPONENT(typ,typv); typvv=S_PA_S(typv); j=1L; } else typvv=S_PA_S(typ); } else if ((S_O_K(typ)==VECTOR) || (S_O_K(typ)==INTEGERVECTOR)) typvv=typ; else if (S_O_K(typ)==POLYNOM) typvv=S_PO_S(typ); else error("zykelind_centralizer(a,b) a wrong objectkind"); for (i=0,M_I_I(1L,d);i0L) erg+=add_apply(hilf1,ergeb); else if (j<0L) erg+=sub(ergeb,hilf1,ergeb); } erg+=ganzdiv(ergeb,d,ergeb); erg+=freeall(hilf); erg+=freeall(hilf1); if (erg!=OK) error("in computation of number_of_irred_poly_of_degree(d,q,ergeb) "); return(erg); } static INT exponenten_bestimmen(d,q,a,b) OP d,q,a,b; { INT i,j,k,l; OP hilf,hilfv,dd,c,e,f,g,h,speicher; OP ax_e; INT erg=OK; hilf=callocobject(); hilfv=callocobject(); dd=callocobject(); c=callocobject(); e=callocobject(); f=callocobject(); g=callocobject(); h=callocobject(); speicher=callocobject(); erg+=init(BINTREE,speicher); erg+=m_l_v(d,a); erg+=m_l_v(d,b); for (i=0L;i0L) { /*4*/ M_I_I(i+1L,d); erg+=m_scalar_polynom(null,zs2); first_unordered_part_into_atmost_k_parts(S_PA_II(c,i),S_V_LI(S_V_I(v1,i)),c1); do { /*5*/ erg+=m_iindex_monom(0L,zs3); for (j=0L;j0L) { /*4*/ M_I_I(i+1L,d); erg+=m_scalar_polynom(null,zs2); first_unordered_part_into_atmost_k_parts(S_PA_II(c,i),S_V_LI(S_V_I(v1,i)),c1); do { /*5*/ erg+=m_iindex_monom(0L,zs3); for (j=0L;j=1 INTEGER objekt den Zyklenzeiger der Gruppe aller regulaeren $k\times k$ Matrizen (k ein INTEGER objekt) ueber Z_n=(Z modulo n) als Permutationsgruppe von Z_n^k */ { INT erg=OK; OP hilf=callocobject(); OP hilfpoly=callocobject(); OP q=callocobject(); if (S_O_K(k)!=INTEGER) return error("zykelind_glkzn(k,n,cy_ind) k not INTEGER"); if (S_I_I(k)<1L) return error("zykelind_glkzn(k,n,cy_ind) k<1"); if (S_O_K(n)!=INTEGER) return error("zykelind_glkzn(k,n,cy_ind) n not INTEGER"); if (S_I_I(n)<1L) return error("zykelind_glkzn(k,n,cy_ind) n<1"); if (!emptyp(cy_ind)) erg+=freeself(cy_ind); erg+=m_iindex_monom(0L,cy_ind); erg+=integer_factor(n,hilf);/* monopoly Faktorisierung von q */ erg+=copy(hilf,q); while(hilf!=NULL) { if (!einsp(S_PO_K(hilf))) return error(" zykelind_glkzn(k,n,cy_ind) n not square free"); hilf=s_l_n(hilf); } hilf=callocobject(); erg+=copy(q,hilf); while(hilf!=NULL) { erg+=copy(S_PO_S(hilf),q); erg+=zykelind_glkq(k,q,hilfpoly); erg+=zykelind_dir_prod_apply(hilfpoly,cy_ind); hilf=s_l_n(hilf); } /*erg+=freeall(hilf);*/ erg+=freeall(hilfpoly); erg+=freeall(q); if (erg!=OK) error("in computation of zykelind_glkzn(k,n,cy_ind)"); return(erg); } INT zykelind_affkzn(k,n,cy_ind) OP k,n,cy_ind; /* Berechnet fuer quadratfreies n>=1 INTEGER objekt den Zyklenzeiger der Gruppe aller affinen Abbildungen Z_n^k -> Z_n^k mit Z_n=(Z modulo n) als Permutationsgruppe von Z_n^k */ { INT erg=OK; OP hilf=callocobject(); OP hilfpoly=callocobject(); OP q=callocobject(); if (S_O_K(k)!=INTEGER) return error("zykelind_affkzn(k,n,cy_ind) k not INTEGER"); if (S_I_I(k)<1L) return error("zykelind_affkzn(k,n,cy_ind) k<1"); if (S_O_K(n)!=INTEGER) return error("zykelind_affkzn(k,n,cy_ind) n not INTEGER"); if (S_I_I(n)<1L) return error("zykelind_affkzn(k,n,cy_ind) n<1"); if (!emptyp(cy_ind)) erg+=freeself(cy_ind); if (einsp(k)) return zykelind_aff1Zn(n,cy_ind); erg+=m_iindex_monom(0L,cy_ind); erg+=integer_factor(n,hilf);/* monopoly Faktorisierung von q */ erg+=copy(hilf,q); while(hilf!=NULL) { if (!einsp(S_PO_K(hilf))) return error(" zykelind_affkzn(k,n,cy_ind) n not square free"); hilf=s_l_n(hilf); } hilf=callocobject(); erg+=copy(q,hilf); while(hilf!=NULL) { erg+=copy(S_PO_S(hilf),q); erg+=zykelind_affkq(k,q,hilfpoly); erg+=zykelind_dir_prod_apply(hilfpoly,cy_ind); hilf=s_l_n(hilf); } /*erg+=freeall(hilf);*/ erg+=freeall(hilfpoly); erg+=freeall(q); ENDR("internal function zykelind_affkzn"); } static INT zykelind_aff1Zp(p,a,r) OP p,a,r; /* p sei eine Primzahl ungleich 2 r ist der Zyklenzeiger von der Gruppe aller affinen Abbildungen von Z_{p^a}. */ { if (eq(p,cons_zwei)) return zykelind_aff1Z2(a,r); else { INT erg=OK; INT i,j,k; OP hilf1=callocobject(); OP hilf2=callocobject(); OP hilf3=callocobject(); OP hilf4=callocobject(); OP hilf5=callocobject(); OP hmonom=callocobject(); OP hmonom1=callocobject(); OP teiler=callocobject(); OP pp=callocobject(); erg+=m_i_i(0L,r); erg+=copy(p,pp); erg+=dec(pp); erg+=alle_teiler(pp,teiler); erg+=m_i_i(0L,hilf1); for (i=0L;i0L) { /*4*/ M_I_I(i+1L,d); erg+=m_scalar_polynom(null,zs2); first_unordered_part_into_atmost_k_parts(S_PA_II(c,i),S_V_LI(S_V_I(v1,i)),c1); do { /*5*/ erg+=m_scalar_polynom(eins,zs3); for (j=0L;j0L) { /*4*/ M_I_I(i+1L,d); erg+=m_scalar_polynom(null,zs2); first_unordered_part_into_atmost_k_parts(S_PA_II(c,i),S_V_LI(S_V_I(v1,i)),c1); do { /*5*/ erg+=m_scalar_polynom(eins,zs3); for (j=0L;j1L) { erg+=fakul(S_V_I(a,i),hilf); erg+=mult_apply(hilf,c); } erg+=mult_apply(S_PO_K(hilfm),c); erg+=freeall(hilf); if (erg!=OK) error("in computation of debruijn_formel(a,b,c)"); return(erg); } hilfm=S_PO_N(hilfm); } M_I_I(0L,c); freeall(hilf); if (erg!=OK) error("in computation of debruijn_formel(a,b,c)"); return(erg); } static INT sum_vector11(vecobj,ergebnis,gr) OP vecobj,ergebnis,gr; /* berechnet die Summe $\sum_{i=0L}^{s_v_li(vecobj)-1L} (i+1)*s_v_i(vecobj,i)$ falls diese kleiner als gr bleibt, ansonsten gibt sie die erste Teilsumme groesser als gr aus. */ { INT i; INT erg = OK; OP hilf=callocobject(); if ((S_O_K(vecobj)!=VECTOR)&&(S_O_K(vecobj)!=INTEGERVECTOR)) return error("sum_vector11(vecobj,ergebnis) vecobj not VECTOR"); if (!emptyp(ergebnis)) erg+=freeself(ergebnis); M_I_I(0L,ergebnis); for ( i=0L; i < S_V_LI(vecobj);i++) { erg+=m_i_i(i+1L,hilf); erg+=mult_apply(S_V_I(vecobj,i),hilf); erg += add_apply(hilf , ergebnis); if (gt(ergebnis,gr)) { erg+=freeall(hilf); if (erg!=OK) error(" in computation of sum_vector11(vecobj,ergebnis) "); return(erg); } } erg+=freeall(hilf); if (erg!=OK) error(" in computation of sum_vector11(vecobj,ergebnis) "); return erg; } static INT sum_vector1(vecobj,ergebnis) OP vecobj,ergebnis; /* berechnet die Summe $\sum_{i=0L}^{s_v_li(vecobj)-1L} (i+1)*s_v_i(vecobj,i)$ */ { INT i; INT erg = OK; OP hilf=callocobject(); if ((S_O_K(vecobj)!=VECTOR)&&(S_O_K(vecobj)!=INTEGERVECTOR)) return error("sum_vector1(vecobj,ergebnis) vecobj not VECTOR"); if (!emptyp(ergebnis)) erg+=freeself(ergebnis); M_I_I(0L,ergebnis); for ( i=0L; i < S_V_LI(vecobj);i++) { erg+=m_i_i(i+1L,hilf); erg+=mult_apply(S_V_I(vecobj,i),hilf); erg += add_apply(hilf , ergebnis); } if (erg!=OK) error(" in computation of sum_vector1(vecobj,ergebnis) "); return erg; } INT stirling_numbers_second_kind_vector(a,b) OP a,b; /* a INTEGER object , the result b is a VECTOR object of length a+1 with entry s_v_i(i,b) = 2. Stirl. number S(a,i) */ /* HF 1994 */ /* AK 200704 V3.0 */ { INT erg=OK; CTO(INTEGER,"stirling_numbers_second_kind_vector(1)",a); SYMCHECK(S_I_I(a)<0,"stirling_numbers_second_kind_vector:parameter <0"); { if (NULLP_INTEGER(a)) { erg += m_o_v(cons_null,b); } else { OP bb,c,d,e,f; INT i,j; CALLOCOBJECT5(bb,c,d,e,f); M_I_I(0L,f); erg+=m_il_v(S_I_I(a)+1L,b); M_I_I(0L,S_V_I(b,0L)); i=0L; erg+=m_iindex_iexponent_monom(0L,s_i_i(a),d); for (j=1;j<=S_I_I(a);j++) { M_I_I(j,c); erg+=zykelind_Sn(c,bb); erg+=debruijn_all_functions(d,bb,e); erg+=sub(e,f,S_V_I(b,j)); CLEVER_COPY(e,f); } FREEALL5(bb,c,d,e,f); } } ENDR("stirling_numbers_second_kind_vector"); } INT polya1_sub(a,c,b) OP a,b,c; /* einsetzung */ /* a ist polynom */ /* c ist length of alphabet */ /* b wird ergebnis x_i ----> 1 + 2 q^i */ /* AK 080190 */ /* AK 091190 V1.1 */ /* AK 200891 V1.3 */ /*FRIP 15.3.94 */ { OP d,e,f,g; INT i; INT erg=OK; if (S_O_K(a)!=POLYNOM) return error("polya1_sub(a,c,b) a not POLYNOM"); if (S_O_K(c)!=INTEGER) return error("polya1_sub(a,c,b) c not INTEGER"); if (not EMPTYP(b)) erg+=freeself(b); d=callocobject(); e=callocobject(); f=callocobject(); g=callocobject(); M_I_I(1L,d); erg += m_scalar_polynom(d,e); M_I_I(2L,d); erg += m_il_v(1L,f); M_I_I(1L,s_v_i(f,0L)); erg+=m_skn_po(f,d,NULL,g); erg += m_il_v(S_I_I(c),d); for (i=0L;i 1 + i q^i */ /* AK 080190 */ /* AK 091190 V1.1 */ /* AK 200891 V1.3 */ /*FRIP 15.3.94 */ { OP d,e,f,g; INT i; INT erg=OK; if (S_O_K(a)!=POLYNOM) return error("polya2_sub(a,c,b) a not POLYNOM"); if (S_O_K(c)!=INTEGER) return error("polya2_sub(a,c,b) c not INTEGER"); if (not EMPTYP(b)) erg+=freeself(b); d=callocobject(); e=callocobject(); f=callocobject(); g=callocobject(); M_I_I(1L,d); erg += m_scalar_polynom(d,e); /*M_I_I(2L,d);*/ erg += m_il_v(1L,f); M_I_I(1L,s_v_i(f,0L)); erg+=m_skn_po(f,d,NULL,g); erg += m_il_v(S_I_I(c),d); for (i=0L;i 1 + q^i + q^2i + q^3i + ... */ /* dd ist die hoechste Potenz von q die eingesetzt werden kann */ /* das Ergebnis stimmt nur bis zu der Potenz q^dd */ /* AK 080190 */ /* AK 091190 V1.1 */ /* AK 200891 V1.3 */ /*FRIP 7.6.94 */ { OP d,e,f,g,h; INT i; INT erg=OK; if (S_O_K(a)!=POLYNOM) return error("polya3_sub(a,c,b) a not POLYNOM"); if (S_O_K(c)!=INTEGER) return error("polya3_sub(a,c,b) c not INTEGER"); if (not EMPTYP(b)) erg+=freeself(b); d=callocobject(); e=callocobject(); f=callocobject(); g=callocobject(); h=callocobject(); M_I_I(1L,d); erg += m_scalar_polynom(d,e); erg += m_il_v(1L,f); M_I_I(1L,s_v_i(f,0L)); erg+=m_skn_po(f,d,NULL,g); erg += m_il_v(S_I_I(c),d); for (i=0L;i 1 + q^i */ /* maxgrad ist der maximale Grad der berechnet werden soll */ /* AK 080190 */ /* AK 091190 V1.1 */ /* AK 200891 V1.3 */ /*FRIP 15.3.94 */ { OP d,e,f,g; INT i; INT erg=OK; if (S_O_K(a)!=POLYNOM) return error("co_polya_sub(a,c,maxgrad,b) a not POLYNOM"); if (S_O_K(c)!=INTEGER) return error("co_polya_sub(a,c,maxgrad,b) c not INTEGER"); if (not EMPTYP(b)) erg+=freeself(b); d=callocobject(); e=callocobject(); f=callocobject(); g=callocobject(); M_I_I(1L,d); erg += m_scalar_polynom(d,e); /*M_I_I(1L,d);*/ erg += m_il_v(1L,f); M_I_I(1L,s_v_i(f,0L)); erg+=m_skn_po(f,d,NULL,g); erg += m_il_v(S_I_I(c),d); for (i=0L;i 1 + q^i + q^2i + q^3i + ... */ /* dd ist die hoechste Potenz von q die eingesetzt werden kann */ /* das Ergebnis stimmt nur bis zu der Potenz q^dd */ /* AK 080190 */ /* AK 091190 V1.1 */ /* AK 200891 V1.3 */ /*FRIP 7.6.94 */ { OP d,e,f,g,h; INT i; INT erg=OK; if (S_O_K(a)!=POLYNOM) return error("co_polya3_sub(a,c,dd,b) a not POLYNOM"); if (S_O_K(c)!=INTEGER) return error("co_polya3_sub(a,c,dd,b) c not INTEGER"); if (not EMPTYP(b)) erg+=freeself(b); d=callocobject(); e=callocobject(); f=callocobject(); g=callocobject(); h=callocobject(); M_I_I(1L,d); erg += m_scalar_polynom(d,e); erg += m_il_v(1L,f); M_I_I(1L,s_v_i(f,0L)); erg+=m_skn_po(f,d,NULL,g); erg += m_il_v(S_I_I(c),d); for (i=0L;i0 falls a>b <0 falls a0 */ if (erg != 0L) return(erg); ++i; } } else { for ( i=0L; i= 0L) { M_I_I(S_V_II(v,i)+1L,S_V_I(v,i)); if (S_V_II(v,i) > m) { M_I_I(0L,S_V_I(v,i)); i=i-1L; } else fertig=1L; } if (i<0L) return(2L); /* alle Kandidaten aufgelistet */ else return(1L); /* kein Fehler aufgetreten */ } static INT next_kandidat2(vfh,v) OP v,vfh; { int i,fertig; if (S_O_K(vfh)!=VECTOR) return error("next_kandidat2(vfh,v) vfh not VECTOR"); /* for (i=0;i= 0L) { M_I_I(S_V_II(v,i)+1L,S_V_I(v,i)); if (S_V_II(v,i) > S_V_II(vfh,i)) { M_I_I(0L,S_V_I(v,i)); i=i-1L; } else fertig=1L; } if (i<0L) return(2L); /* alle Kandidaten aufgelistet */ else return(1L); /* kein Fehler aufgetreten */ } static INT mu(a) OP a; /* Berechnet Moebiusfunktion(a) */ { OP aa,tei; INT j; INT erg=OK; if (S_O_K(a)!=INTEGER) return error("mu(a) a not INTEGER"); if (S_I_I(a)<1L) return error("mu(a) a<1"); if (S_I_I(a)==1L) { if (erg != OK) error(" in computation of mu(a) "); return(1L); } aa=callocobject(); erg+=integer_factor(a,aa);/* monopoly Faktorisierung von a */ j=0L; tei=aa; while (tei != NULL) { ++j; if(S_PO_KI(tei)>1L) { erg+=freeall(aa); if (erg != OK) error(" in computation of mu(a) "); return(0L); } tei=S_L_N(tei); } if (j%2L==0L) { erg+=freeall(aa); if (erg != OK) error(" in computation of mu(a) "); return(1L); } else { erg+=freeall(aa); if (erg != OK) error(" in computation of mu(a) "); return(-1L); } } INT coeff_of_in(a,b,c) OP a,b,c; /* Bestimmt c, den Koeffizienten von x^a in dem Polynom b ( b ist ein Polynom in einer Unbestimmten). */ { OP poly; INT erg=OK; if (S_O_K(a)!=INTEGER) return error("coeff_of_in(a,b,c) a not INTEGER"); if (S_I_I(a)<0L) return error("coeff_of_in(a,b,c) a<0"); if (S_O_K(b)!=POLYNOM) return error("coeff_of_in(a,b,c) b not POLYNOM"); if (not EMPTYP(c)) erg+=freeself(c); poly=b; while (poly!=NULL) { if (eq(a,S_PO_SI(poly,0L))) { erg+=copy(S_PO_K(poly),c); if (erg != OK) error(" in computation of coeff_of_in(a,b,c) "); return(erg); } poly=S_PO_N(poly); } M_I_I(0L,c); if (erg != OK) error(" in computation of coeff_of_in(a,b,c) "); return(erg); } static INT vektor_mult_apply(a,b) OP a,b; /* Sei a[i] das i-te Element von a, dann wird a[i] als a[i]*b berechnet. */ { INT i; INT erg=OK; /*if (S_O_K(a)==INTEGERVECTOR) C_O_K(a,VECTOR);*/ if ((S_O_K(a)!=VECTOR)&&(S_O_K(a)!=INTEGERVECTOR)) return error("vektor_mult_apply(a,b) a not VECTOR"); if (S_O_K(b)!=INTEGER) return error("vektor_mult_apply(a,b) b not INTEGER"); for (i=0L;i=0. Diese Darstellung wird als VECTOR a weitergegeben. */ { int i; INT erg=OK; m_il_nv(k,a); if (k>0) M_I_I(s,S_V_I(a,k-1L)); ENDR("internal func first_unordered_part_into_atmost_k_parts"); } static INT next_unordered_part_into_atmost_k_parts(a) OP a; /*next_pa_into_atmost_k_parts(a)*/ /* Berechnet den Nachfolger der Darstellung einer natuerlichen Zahl als Summe von hoechstens k Summanden >=0. Die natuerliche Zahl ist dabei die Summe ueber alle Elemente von a, k ist die Laenge von a. */ { int i; INT erg = OK; CTO(VECTOR,"next_unordered_part_into_atmost_k_parts",a); i=S_V_LI(a)-1L; while( (i>=0L) && nullp(S_V_I(a,i)) ) --i; if (i<=0L) return(2L); /* alle aufglistet */ copy(S_V_I(a,i),S_V_I(a,S_V_LI(a)-1L)); dec(S_V_I(a,S_V_LI(a)-1L)); inc(S_V_I(a,i-1L)); if (i=1L) && (le(S_V_I(v,i),hilf1))); if ((i==0L) && (eq(S_V_I(v,i),hilf1))) { res=2L; goto ende; } copy(S_V_I(v,i),hilf1); dec(hilf1); quores(hilf,hilf1,hilf2,hilf3); if (nullp(hilf3)) l=0L; else l=1L; if (S_I_I(hilf2)+i+l<=S_V_LI(v)) { for (j=0L;j0L) nn = S_L_N(nn); else { redf_f3(S_L_S(von),S_L_S(nn),har); nn = S_L_N(nn); } } return(OK); } static INT redf_f3(a,b,c) OP a,b,c; /* a,b sin MONOMe mit gleichem S_MO_S VECTOR ihre Koeffizienten werden zusammenmultipliziert und als neuer Term zu c (POLYNOM) mit S_MO_S VECTOR dazuaddiert */ { INT erg=OK; OP hilf=callocobject(); OP monom=callocobject(); erg+=mult(S_MO_K(a),S_MO_K(b),hilf); erg+=m_skn_po(S_MO_S(a),hilf,NULL,monom); erg+=add_apply(monom,c); erg+=freeall(hilf); erg+=freeall(monom); if (erg!=OK) EDC("redf_f3"); return erg; } static INT redf_f1h(a,b,na,nb,c) OP a,b,na,nb,c; /* a,b sin POLYNOME, c wird ein neues POLYNOM, dessen MONOMe sowohl in a als auch in b vorkommen. Die entsprechenden Koeffizienten werden zusammenmultipliziert. Dazu werden a und b in Listen umgewandelt. Diese Listen werden in redf_f2h auf gleiche MONOM-VECTOREN untersucht, und c wird dann in redf_f3h aufgebaut. na und nb sind die Vielfachheiten, mit denen a bzw b auftritt */ { INT erg=OK; OP al=callocobject(); OP bl=callocobject(); erg+=copy_list(a,al); erg+=copy_list(b,bl); erg+=m_i_i(0L,c); erg+=redf_f2h(al,bl,na,nb,c); erg+=freeall(al);erg+=freeall(bl); if (erg!=OK) return error(" in computation of redf_f1h"); return erg; } static INT redf_f2h(von,nach,na,nb,har) OP von,nach,na,nb,har; /* untersucht die Listen von und nach auf gleiche MONOM-VECTORen Falls solche auftreten wird redf_f3h aufgerufen. */ { INT erg; OP nn = callocobject(); *nn = *nach; while((von != NULL) && (nn != NULL)) { erg=comp_monomvector_monomvector(S_L_S(von),S_L_S(nn)); if (erg < 0L) von = S_L_N(von); else if (erg >0L) nn = S_L_N(nn); else { redf_f3h(S_L_S(von),S_L_S(nn),na,nb,har); nn = S_L_N(nn); } } return(OK); } static INT redf_f3h(a,b,na,nb,c) OP a,b,na,nb,c; /* a,b sin MONOMe mit gleichem S_MO_S VECTOR ihre Koeffizienten werden zusammenmultipliziert und als neuer Term zu c (POLYNOM) mit S_MO_S VECTOR dazuaddiert */ { INT erg=OK; OP hilf=callocobject(); OP monom=callocobject(); erg+=hoch(S_MO_K(a),na,hilf); erg+=hoch(S_MO_K(b),nb,monom); erg+=mult_apply(monom,hilf); erg+=freeself(monom); erg+=m_skn_po(S_MO_S(a),hilf,NULL,monom); erg+=add_apply(monom,c); erg+=freeall(hilf); erg+=freeall(monom); if (erg!=OK) EDC("redf_f3h"); return erg; } static INT redf_formel(a,n,b) OP a,b; INT n; /* Berechnet den Koeffizienten fuer die Errechnung des cup bzw. cap Produktes von n+1 gleichen Monomen mit der Gestalt a (ist ein Vektor Objekt). Das Ergebnis ist b. */ { OP hilf; INT i,erg; erg=OK; if (a==NULL) return m_i_i(0L,b); if ((S_O_K(a)!=VECTOR) && (S_O_K(a)!=INTEGERVECTOR)) return error("redf_formel(a,n,b) a not VECTOR"); if (not EMPTYP(b)) erg+=freeself(b); if (n<1L) return error("redf_formel(a,n,b) n<1"); hilf=callocobject(); erg+=m_i_i(1L,b); for (i=0L; i1L) { erg+=m_il_v(2L,z); erg+=copy(v,S_V_I(z,0L)); erg+=copy(p,S_V_I(z,1L)); } else erg+=copy(p,z); ENDR("m_v_po_mz"); } INT zykelind_tetraeder(aa) OP aa; /* Berechnet den Zyklenzeiger der Drehgruppe des Tetraeders. Es treten 3 Familien von Unbestimmten auf. Die erste Familie bezieht sich auf Gruppenaktion auf der Menge der Knoten, die zweite auf der Menge der Kanten und die dritte auf der Menge der Flaechen des Tetraeders. */ { OP a,b,koef,vektor,hilf; INT i; INT erg=OK; koef=callocobject(); vektor=callocobject(); hilf=callocobject(); a=callocobject(); b=callocobject(); erg+=m_ioiu_b(1L,12L,koef); erg+=m_il_v(11L,vektor); for (i=0L;i