/* FILE:nu.c */ #include "def.h" #include "macro.h" static INT mult_apply_co (); #ifdef SQRADTRUE INT squareroot(a,b) OP a,b; /* AK 040291 V1.2 */ /* AK 140891 V1.3 */ /* b becomes the squareroot of a */ { INT erg=OK; if (check_equal_2(a,b,squareroot,&erg) == EQUAL) return erg; switch (S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH: erg += squareroot_bruch(a,b); break; #endif /* BRUCHTRUE */ #ifdef INTEGERTRUE case INTEGER: erg += squareroot_integer(a,b); break; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += squareroot_longint(a,b); break; #endif /* LONGINTTRUE */ default: erg += WTO("squareroot",a); break; } sqende: ENDR("squareroot"); } #endif /* SQRADTRUE */ #ifdef SQRADTRUE INT ganzsquareroot(a,b) OP a,b; /* AK 040291 V1.2 */ /* b becomes the integer squareroot of a */ /* AK 140891 V1.3 */ { INT erg = OK; if (check_equal_2(a,b,ganzsquareroot,&erg) == EQUAL) return erg; switch (S_O_K(a)) { #ifdef INTEGERTRUE case INTEGER: erg+= ganzsquareroot_integer(a,b); break; #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += ganzsquareroot_longint(a,b); break; #endif /* LONGINTTRUE */ default: erg+= WTO("ganzsquareroot",a); break; } gsqende: ENDR("ganzsquareroot"); } #endif /* SQRADTRUE */ INT max(a,b) OP a,b; /* AK 280689 V1.0 */ /* AK 010290 V1.1 */ /* b is a copy of the maximum element */ /* AK 140891 V1.3 */ { INT erg = OK; CE2(a,b,max); switch (S_O_K(a)) { #ifdef MATRIXTRUE case MATRIX: erg += max_matrix(a,b); break; #endif /* MATRIXTRUE */ #ifdef TABLEAUXTRUE case TABLEAUX: erg += max_tableaux(a,b); break; #endif /* TABLEAUXTRUE */ #ifdef VECTORTRUE case WORD: case INTEGERVECTOR: erg += max_integervector(a,b); break; case VECTOR: erg += max_vector(a,b); break; #endif /* VECTORTRUE */ default: erg += WTO("max",a); break; }; ENDR("max"); } INT absolute(a,c) OP a,c; /* AK 100888 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140891 V1.3 */ { INT erg=OK; CE2(a,c,absolute); switch(S_O_K(a)) { #ifdef BRUCHTRUE case BRUCH: erg += absolute_bruch(a,c); break; #endif /* BRUCHTRUE */ #ifdef INTEGERTRUE case INTEGER: return m_i_i((S_I_I(a) > 0 ? S_I_I(a): - S_I_I(a)),c); #endif /* INTEGERTRUE */ #ifdef LONGINTTRUE case LONGINT: erg += absolute_longint(a,c); break; #endif /* LONGINTTRUE */ #ifdef MATRIXTRUE case MATRIX: erg += absolute_matrix(a,c); break; #endif /* MATRIXTRUE */ #ifdef VECTORTRUE case WORD: case COMP: case VECTOR: case INTEGERVECTOR: erg += absolute_vector(a,c); break; #endif /* VECTORTRUE */ default: erg += WTO("absolute",a); break; } 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; if (check_equal_2(a,b,transpose,&erg) == EQUAL) return erg; switch (S_O_K(a)) { #ifdef MATRIXTRUE case KOSTKA: case KRANZTYPUS: case MATRIX: return transpose_matrix(a,b); #endif /* MATRIXTRUE */ default: { printobjectkind(a); return error("transpose: wrong type"); } }; } 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; OP d; d=callocobject(); erg += addinvers(b,d); erg += add(a,d,c); erg += freeall(d); ENDR("sub"); } INT kgv(first,second,d) OP first, second, d; /* 031186 */ /* d = kgv(first,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; a=callocobject(); b=callocobject(); erg += mult(first,second,a); erg += ggt(first,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; 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 */ { INT erg=OK; if ((a == d)&&(b == d)) { OP c=callocobject(); *c = *a; C_O_K(d, EMPTY); erg += add(c,c,d); erg += freeall(c); goto add_ende; } else if (a == d) { OP c=callocobject(); *c = *a; C_O_K(d, EMPTY); erg += add(c,b,d); erg += freeall(c); goto add_ende; } else if (b == d) { OP c=callocobject(); *c = *b; C_O_K(d, EMPTY); erg += add(a,c,d); erg += freeall(c); goto add_ende; } else if (EMPTYP(a)) { erg += copy(b,d); goto add_ende; } else if (EMPTYP(b)) { erg += copy(a,d); goto add_ende; } if (not EMPTYP(d)) if (S_O_K(d) != INTEGER) erg += freeself(d); switch(S_O_K(b)) { #ifdef MONOPOLYTRUE case MONOPOLY: erg += add_monopoly (b,a,d); goto add_ende; #endif /* MONOPOLYTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += add_cyclo (b,a,d); goto add_ende; #endif /* CYCLOTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += add_sqrad (b,a,d); goto add_ende; #endif /* SQRADTRUE */ #ifdef REIHETRUE case REIHE: /* AK 020893 */ erg += add_reihe(b,a,d); goto add_ende; #endif /* REIHETRUE */ } 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 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: if (S_O_K(b) == INTEGERVECTOR) erg += add_integervector(a,b,d); else erg += add_vector(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 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: { 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 /* 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: if (erg != OK) { printobjectkind(a); printobjectkind(b); return error("add: error during computation"); } return erg; } 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; COP("sort",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; 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 COMP: 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; CE2(a,res,sum); switch(S_O_K(a)) { #ifdef VECTORTRUE case INTEGERVECTOR: case SUBSET: case COMP : erg += sum_integervector(a,res); 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; CE2(a,res,conjugate); switch(S_O_K(a)) { case EMPTY: break; #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: case MONOMIAL: case HOM_SYM: case ELM_SYM: case POW_SYM: erg += transformlist(a,res,conjugate); 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; CE2(a,res,addinvers); if (EMPTYP(a)) return(OK); 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",a); break; }; ENDR("addinvers"); } 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 */ { OP a,b,c; INT i; INT erg = OK; if (S_O_K(oben) == POLYNOM) /* AK 030892 */ { if (S_O_K(unten) != INTEGER) return(error("binom:unten not INTEGER")); if (S_I_I(unten) < 0 ) return(error("binom:unten < 0")); c = callocobject(); b = callocobject(); erg += copy(oben,c); erg += m_i_i(-1L,b); erg += copy(oben,d); for (i=1L;i= 0L) { binom(a,b,c); (schalter++ % 2L == 0L ? add(c,d,d): sub(d,c,d)); dec(b); }; goto binomende; } if (S_I_I(oben)==S_I_I(unten)) return(M_I_I(1L,d)); if (S_I_I(oben)S_I_I(unten);i--) { M_I_I(i,a); erg +=mult_apply(a,c); } ganzdiv(c,b,d); binomende: erg += freeall(a); erg += freeall(b); erg += freeall(c); ENDR("binom"); } INT inc(a) OP a; /* AK 280689 V1.0 */ /* AK 081289 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; COP("inc",a); switch(S_O_K(a)) { #ifdef INTEGERTRUE case INTEGER : erg += 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 : erg += 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 COMP: case VECTOR : erg += inc_vector(a);break; case BITVECTOR: erg += inc_bitvector(a); break; #endif /* VECTORTRUE */ default: erg += WTO("inc",a);break; }; ENDR("inc"); } INT dec(a) OP a; /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 140891 V1.3 */ { INT erg = OK; 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: case VECTOR : erg += dec_vector(a); break; #endif /* VECTORTRUE */ default: erg += WTO("dec",a); break; }; ENDR("dec"); } INT qdimension(n,d) OP n, d; /* AL 180393 */ { INT erg = OK; if (check_equal_2(n,d,qdimension,&erg) == EQUAL) return erg; switch (S_O_K(n)) { #ifdef SCHUBERTTRUE /* AL 180393 */ case SCHUBERT: erg += dimension_schubert(n,d); break; #endif /* SCHUBERTTRUE */ default: erg += WTO("qdimension",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; 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,d) OP a,b,d; /* AK 280689 V1.0 */ /* AK 071289 V1.1 */ /* AK 250391 V1.2 */ /* AK 140891 V1.3 */ { /* AK 031286 als invers*mult */ INT erg = OK; OP c = callocobject(); erg += invers(b,c); erg += mult(a,c,d); erg += freeall(c); ENDR("div"); } 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; if (c == d) return error("quores: two result in one variable"); if (a == c) { e =callocobject(); *e = *a; C_O_K(c,EMPTY); erg +=quores(e,b,c,d); erg += freeall(e); goto quoresende; } if (a == d) { e =callocobject(); *e = *a; C_O_K(d,EMPTY); erg +=quores(e,b,c,d); erg += freeall(e); goto quoresende; } if (b == c) { e =callocobject(); *e = *b; C_O_K(c,EMPTY); erg +=quores(a,e,c,d); erg += freeall(e); goto quoresende; } if (b == d) { e =callocobject(); *e = *b; C_O_K(d,EMPTY); erg +=quores(a,e,c,d); erg += 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 += m_i_i(0L,d); 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; #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 */ { OP d; INT erg = OK; CE3(a,b,c,mod); if (nullp(b)) { erg += error("mod: second parameter = null"); goto endr_ende; } 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; } } d = callocobject(); erg += quores(a,b,d,c); erg += freeall(d); ENDR("mod"); } INT ganzdiv(a,b,c) OP a,b,c; /*AK 040393 */ { OP d = callocobject(); INT erg = OK; erg += quores(a,b,c,d); erg += freeall(d); ENDR("ganzdiv"); } INT ganzdiv_apply(a,b) OP a,b; /* AK 151294 */ { INT erg = OK; if (a == b) { erg += m_i_i((INT)1,b); goto endr_ende; } switch(S_O_K(b)) { case INTEGER: if (S_O_K(a) == INTEGER) { M_I_I(S_I_I(b)/S_I_I(a),b); goto endr_ende; } break; default: break; } erg += ganzdiv(b,a,b); ENDR("ganzdiv_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 */ { INT i = 2,res = 1; INT erg = OK; CTO(INTEGER,"fakul",n); CE2(n,d,fakul); if (S_I_I(n) < 0L) { debugprint(n); error("fakul:negativ INTEGER"); return ERROR; } if (S_I_I(n) > (INT)12) { #ifdef LONGINTTRUE erg+=fakul_longint(n,d);goto ende; #else /* LONGINTTRUE */ return error("fakul:overflow no LONGINT available"); #endif /* LONGINTTRUE */ } 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; } ende: ENDR("fakul"); } #ifdef LONGINTTRUE INT fakul_longint(n,res) OP n,res; /* AK 180888 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140591 V1.2 */ /* AK 140891 V1.3 */ { OP i = callocobject(); INT erg = OK; erg += m_i_longint(479001600L,res); /* 12! */ erg += M_I_I(13L,i); while (S_I_I(i) <= S_I_I(n)) { erg += mult_apply(i,res); erg += INC_INTEGER(i); } erg += freeall(i); ENDR("fakul_longint"); } #endif /* LONGINTTRUE */ INT ggt_integer(a,b,c) OP a, b, c; /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140591 V1.2 */ /* AK 140891 V1.3 */ { return(M_I_I(ggt_i(S_I_I(a),S_I_I(b)),c)); } INT ggt_i(i,j) INT i, j; /* AK 031186 */ /* c = ggt(a,b) */ /* ok 5/12/86 */ /* AK 280689 V1.0 */ /* AK 061289 V1.1 */ /* AK 140591 V1.2 */ /* AK 140891 V1.3 */ { INT neg=1L; INT m=i; if (i<0L) i *= (-1L); if (j<0L) { j *= (-1L); if (m < 0L) neg=(-1L); }; while ((i != 0L) && (j != 0L)) if (i > j) i=i%j; else j=j%i; if (i > 0L) { i *=neg; return(i); } if (j > 0L) { j *=neg; return(j); } return(error("ggt_i: both zero")); } 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 */ { OP d; OP i,j; INT erg=OK,comperg; CE3(a,b,c,ggt); if ( (S_O_K(a) == INTEGER) && (S_O_K(b) == INTEGER) ) { erg+=ggt_integer(a,b,c); goto ggtende; } i = callocobject(); j = callocobject(); erg += absolute(a,i); erg += absolute(b,j); while (gt(i,cons_null) && gt(j,cons_null)) { comperg = comp(i,j); if (comperg > 0L) erg += mod(i,j,i); else erg += mod(j,i,j); }; if (gt(i,cons_null)) { if (negp(a) && negp(b)) erg += addinvers(i,c); else erg += copy(i,c); } else if (gt(j,cons_null)) { if (negp(a) && negp(b)) erg += addinvers(j,c); else erg += copy(j,c); } else erg += error("ggt:two 0"); erg += freeall(i); erg += freeall(j); ggtende: ENDR("ggt"); } INT hoch(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; EOP("hoch",basis); /* test on empty */ EOP("hoch",expon); CE3(basis,expon,ergeb,hoch); #ifdef UNDEF if ((expon == ergeb)&&(expon == basis)) /* AK 061191 */ { OP c=callocobject(); *c = *expon; C_O_K(ergeb,EMPTY); erg += hoch(c,c,ergeb); erg += freeall(c); goto he; }; if (expon == ergeb) { OP c=callocobject(); *c = *expon; C_O_K(ergeb,EMPTY); /* AK 071091 ohne copy */ erg += hoch(basis,c,ergeb); erg += freeall(c); goto he; }; if (basis == ergeb) { OP c=callocobject(); *c = *basis; C_O_K(ergeb,EMPTY); erg += hoch(c,expon,ergeb); erg += freeall(c); goto he; }; if (not EMPTYP(ergeb)) freeself(ergeb); #endif CTTO(INTEGER,LONGINT,"hoch",expon); if (negp(expon)) { OP c=callocobject(), d=callocobject(); erg += invers(basis,c); erg += addinvers(expon,d); erg += hoch(c,d,ergeb); erg += freeall(c); erg += freeall(d); goto he; } else if (nullp(expon)) M_I_I(1L,ergeb); else if (einsp(expon)) erg += copy(basis,ergeb); else { OP n = callocobject(); OP a = callocobject(); erg += copy(expon,n); erg += copy(basis,a); erg += copy(basis,ergeb); /* AK 290692 */ erg += dec(n); /* AK 290692 */ while (not nullp(n)) { erg += mult_apply(a,ergeb); erg += dec(n); } erg += freeall(a); erg += freeall(n); }; he: ENDR("hoch"); } 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 */ { OP c; INT erg = OK; if (nullp(a)) /* AK 070789 */ { debugprint(a); return error("invers:first is null"); } if (check_equal_2(a,b,invers,&erg) == EQUAL) return erg; if (einsp(a)) /* AK 070789 */ return copy(a,b); 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 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 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",a); break; }; ENDR("invers"); } 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 */ { OP c; INT erg = OK; EOP("mult: first parameter",a); EOP("mult: second parameter",b); COP("mult: result",d); CE3(a,b,d,mult); switch(S_O_K(b)) { #ifdef MONOPOLYTRUE case MONOPOLY: erg += mult_monopoly (b,a,d); goto endr_ende; #endif /* MONOPOLYTRUE */ #ifdef CYCLOTRUE case CYCLOTOMIC: erg += mult_cyclo (b,a,d); goto endr_ende; #endif /* CYCLOTRUE */ #ifdef SQRADTRUE case SQ_RADICAL: erg += mult_sqrad (b,a,d); goto endr_ende; #endif /* SQRADTRUE */ #ifdef SCHURTRUE case SCHUR: erg+=mult_schur(b,a,d); goto endr_ende; case MONOMIAL: erg+=mult_monomial(b,a,d); goto endr_ende; case POW_SYM : case ELM_SYM : case HOM_SYM : erg+=mult_symfunc(b,a,d); goto endr_ende; #endif /* SCHURTRUE */ } 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 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: case POW_SYM : case ELM_SYM : case HOM_SYM : erg+=mult_symfunc(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; }; break; #endif /* CHARTRUE */ case GRAL: switch(S_O_K(b)) { case GRAL: erg += mult_gral_gral(a,b,d); break; } break; default: return 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; if (a == c) { OP d =callocobject(); erg += copy(a,d); erg += scalarproduct(d,b,c); erg += freeall(d); goto se; } if (b == c) { OP d =callocobject(); erg += copy(b,d); erg += scalarproduct(a,d,c); erg += freeall(d); goto se; } if (not EMPTYP(c)) erg += freeself(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 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; }; se: 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 */ { INT i,j,erg = OK; OP a,b,c; if (check_equal_2(n,res,vander,&erg) == EQUAL) goto endr_ende; CTO(INTEGER,"vander",n); m_i_i(1L,res); a = callocobject(); b = callocobject(); c = callocobject(); for (i=2L;i<=S_I_I(n);i++) for (j=1L;j -10000000L) if (S_I_I(a) < 10000000L) return M_I_I(S_I_I(a)+S_I_I(a),a); break; case BRUCH: return double_apply(S_B_O(a)); } c = callocobject(); erg += copy(a,c); erg += add_apply(c,a); erg += freeall(c); return erg; } 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; OP c; if (a == b) return double_apply(a); 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 */ case KRANZTYPUS: #ifdef MATRIXTRUE 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: c = callocobject(); erg += copy(b,c); erg += add(a,c,b); erg += freeall(c); break; } ENDR("add_apply"); } INT multinom(a,b,c) OP a,b,c; /* AK 040892 */ { OP d; INT i,erg = OK; if ( (S_O_K(a) != INTEGER) || (S_O_K(b) != VECTOR) ) return WTT(a,b,"multinom"); for (i=0L;i