/Singular/iparith.cc
C++ | 8472 lines | 7854 code | 158 blank | 460 comment | 1284 complexity | dfe4cc164433101cb4db6645b28a00b4 MD5 | raw file
Possible License(s): AGPL-1.0, GPL-3.0, Unlicense
Large files files are truncated, but you can click here to view the full file
- /****************************************
- * Computer Algebra System SINGULAR *
- ****************************************/
- /* $Id$ */
- /*
- * ABSTRACT: table driven kernel interface, used by interpreter
- */
- #include <stdlib.h>
- #include <string.h>
- #include <ctype.h>
- #include <stdio.h>
- #include <time.h>
- #include <unistd.h>
- #include <kernel/mod2.h>
- #include <Singular/tok.h>
- #include <kernel/options.h>
- #include <Singular/ipid.h>
- #include <kernel/intvec.h>
- #include <omalloc/omalloc.h>
- #include <kernel/polys.h>
- #include <kernel/febase.h>
- #include <Singular/sdb.h>
- #include <kernel/longalg.h>
- #include <kernel/longtrans.h>
- #include <kernel/ideals.h>
- #include <kernel/prCopy.h>
- #include <kernel/matpol.h>
- #include <kernel/kstd1.h>
- #include <kernel/timer.h>
- #include <kernel/ring.h>
- #include <Singular/subexpr.h>
- #include <Singular/lists.h>
- #include <kernel/modulop.h>
- #ifdef HAVE_RINGS
- #include <kernel/rmodulon.h>
- #include <kernel/rmodulo2m.h>
- #include <kernel/rintegers.h>
- #endif
- #include <kernel/numbers.h>
- #include <kernel/stairc.h>
- #include <kernel/maps.h>
- #include <Singular/maps_ip.h>
- #include <kernel/syz.h>
- #include <kernel/weight.h>
- #include <Singular/ipconv.h>
- #include <Singular/ipprint.h>
- #include <Singular/attrib.h>
- #include <Singular/silink.h>
- #include <kernel/sparsmat.h>
- #include <kernel/units.h>
- #include <Singular/janet.h>
- #include <kernel/GMPrat.h>
- #include <kernel/tgb.h>
- #include <kernel/walkProc.h>
- #include <kernel/mod_raw.h>
- #include <Singular/MinorInterface.h>
- #include <kernel/linearAlgebra.h>
- #include <Singular/misc_ip.h>
- #ifdef HAVE_FACTORY
- # include <kernel/clapsing.h>
- # include <kernel/kstdfac.h>
- #endif /* HAVE_FACTORY */
- #ifdef HAVE_FACTORY
- # include <kernel/fglm.h>
- #endif /* HAVE_FACTORY */
- #include <Singular/interpolation.h>
- #include <Singular/blackbox.h>
- #include <Singular/newstruct.h>
- #include <Singular/ipshell.h>
- #include <kernel/mpr_inout.h>
- #include <kernel/timer.h>
- // defaults for all commands: NO_PLURAL | NO_RING | ALLOW_ZERODIVISOR
- #ifdef HAVE_PLURAL
- #include <kernel/gring.h>
- #include <kernel/sca.h>
- #define ALLOW_PLURAL 1
- #define NO_PLURAL 0
- #define COMM_PLURAL 2
- #define PLURAL_MASK 3
- #else /* HAVE_PLURAL */
- #define ALLOW_PLURAL 0
- #define NO_PLURAL 0
- #define COMM_PLURAL 0
- #define PLURAL_MASK 0
- #endif /* HAVE_PLURAL */
- #ifdef HAVE_RINGS
- #define RING_MASK 4
- #define ZERODIVISOR_MASK 8
- #else
- #define RING_MASK 0
- #define ZERODIVISOR_MASK 0
- #endif
- #define ALLOW_RING 4
- #define NO_RING 0
- #define NO_ZERODIVISOR 8
- #define ALLOW_ZERODIVISOR 0
- static BOOLEAN check_valid(const int p, const int op);
- /*=============== types =====================*/
- struct sValCmdTab
- {
- short cmd;
- short start;
- };
- typedef sValCmdTab jjValCmdTab[];
- struct _scmdnames
- {
- char *name;
- short alias;
- short tokval;
- short toktype;
- };
- typedef struct _scmdnames cmdnames;
- typedef char * (*Proc1)(char *);
- struct sValCmd1
- {
- proc1 p;
- short cmd;
- short res;
- short arg;
- short valid_for;
- };
- typedef BOOLEAN (*proc2)(leftv,leftv,leftv);
- struct sValCmd2
- {
- proc2 p;
- short cmd;
- short res;
- short arg1;
- short arg2;
- short valid_for;
- };
- typedef BOOLEAN (*proc3)(leftv,leftv,leftv,leftv);
- struct sValCmd3
- {
- proc3 p;
- short cmd;
- short res;
- short arg1;
- short arg2;
- short arg3;
- short valid_for;
- };
- struct sValCmdM
- {
- proc1 p;
- short cmd;
- short res;
- short number_of_args; /* -1: any, -2: any >0, .. */
- short valid_for;
- };
- typedef struct
- {
- cmdnames *sCmds; /**< array of existing commands */
- struct sValCmd1 *psValCmd1;
- struct sValCmd2 *psValCmd2;
- struct sValCmd3 *psValCmd3;
- struct sValCmdM *psValCmdM;
- int nCmdUsed; /**< number of commands used */
- int nCmdAllocated; /**< number of commands-slots allocated */
- int nLastIdentifier; /**< valid indentifieres are slot 1..nLastIdentifier */
- } SArithBase;
- /*---------------------------------------------------------------------*
- * File scope Variables (Variables share by several functions in
- * the same file )
- *
- *---------------------------------------------------------------------*/
- static SArithBase sArithBase; /**< Base entry for arithmetic */
- /*---------------------------------------------------------------------*
- * Extern Functions declarations
- *
- *---------------------------------------------------------------------*/
- static int _gentable_sort_cmds(const void *a, const void *b);
- extern int iiArithRemoveCmd(char *szName);
- extern int iiArithAddCmd(const char *szName, short nAlias, short nTokval,
- short nToktype, short nPos=-1);
- /*============= proc =======================*/
- static BOOLEAN jjLOAD(leftv res, leftv v, BOOLEAN autoexport = FALSE);
- static int iiTabIndex(const jjValCmdTab dArithTab, const int len, const int op);
- #ifdef MDEBUG
- #define jjMakeSub(A) jjDBMakeSub(A,__FILE__,__LINE__)
- static Subexpr jjDBMakeSub(leftv e,const char *f,const int l);
- #else
- static Subexpr jjMakeSub(leftv e);
- #endif
- /*============= vars ======================*/
- extern int cmdtok;
- extern BOOLEAN expected_parms;
- #define ii_div_by_0 "div. by 0"
- int iiOp; /* the current operation*/
- /*=================== operations with 2 args.: static proc =================*/
- /* must be ordered: first operations for chars (infix ops),
- * then alphabetically */
- static BOOLEAN jjOP_IV_I(leftv res, leftv u, leftv v)
- {
- intvec* aa= (intvec *)u->CopyD(INTVEC_CMD);
- int bb = (int)(long)(v->Data());
- if (errorreported) return TRUE;
- switch (iiOp)
- {
- case '+': (*aa) += bb; break;
- case '-': (*aa) -= bb; break;
- case '*': (*aa) *= bb; break;
- case '/':
- case INTDIV_CMD: (*aa) /= bb; break;
- case '%':
- case INTMOD_CMD: (*aa) %= bb; break;
- }
- res->data=(char *)aa;
- return FALSE;
- }
- static BOOLEAN jjOP_I_IV(leftv res, leftv u, leftv v)
- {
- return jjOP_IV_I(res,v,u);
- }
- static BOOLEAN jjOP_IM_I(leftv res, leftv u, leftv v)
- {
- intvec* aa= (intvec *)u->CopyD(INTVEC_CMD);
- int bb = (int)(long)(v->Data());
- int i=si_min(aa->rows(),aa->cols());
- switch (iiOp)
- {
- case '+': for (;i>0;i--) IMATELEM(*aa,i,i) += bb;
- break;
- case '-': for (;i>0;i--) IMATELEM(*aa,i,i) -= bb;
- break;
- }
- res->data=(char *)aa;
- return FALSE;
- }
- static BOOLEAN jjOP_I_IM(leftv res, leftv u, leftv v)
- {
- return jjOP_IM_I(res,v,u);
- }
- static BOOLEAN jjCOLON(leftv res, leftv u, leftv v)
- {
- int l=(int)(long)v->Data();
- if (l>0)
- {
- int d=(int)(long)u->Data();
- intvec *vv=new intvec(l);
- int i;
- for(i=l-1;i>=0;i--) { (*vv)[i]=d; }
- res->data=(char *)vv;
- }
- return (l<=0);
- }
- static BOOLEAN jjDOTDOT(leftv res, leftv u, leftv v)
- {
- res->data=(char *)new intvec((int)(long)u->Data(),(int)(long)v->Data());
- return FALSE;
- }
- static void jjEQUAL_REST(leftv res,leftv u,leftv v);
- static BOOLEAN jjCOMPARE_IV(leftv res, leftv u, leftv v)
- {
- intvec* a = (intvec * )(u->Data());
- intvec* b = (intvec * )(v->Data());
- int r=a->compare(b);
- switch (iiOp)
- {
- case '<':
- res->data = (char *) (r<0);
- break;
- case '>':
- res->data = (char *) (r>0);
- break;
- case LE:
- res->data = (char *) (r<=0);
- break;
- case GE:
- res->data = (char *) (r>=0);
- break;
- case EQUAL_EQUAL:
- case NOTEQUAL: /* negation handled by jjEQUAL_REST */
- res->data = (char *) (r==0);
- break;
- }
- jjEQUAL_REST(res,u,v);
- if(r==-2) { WerrorS("size incompatible"); return TRUE; }
- return FALSE;
- }
- static BOOLEAN jjCOMPARE_IV_I(leftv res, leftv u, leftv v)
- {
- intvec* a = (intvec * )(u->Data());
- int b = (int)(long)(v->Data());
- int r=a->compare(b);
- switch (iiOp)
- {
- case '<':
- res->data = (char *) (r<0);
- break;
- case '>':
- res->data = (char *) (r>0);
- break;
- case LE:
- res->data = (char *) (r<=0);
- break;
- case GE:
- res->data = (char *) (r>=0);
- break;
- case EQUAL_EQUAL:
- case NOTEQUAL: /* negation handled by jjEQUAL_REST */
- res->data = (char *) (r==0);
- break;
- }
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjCOMPARE_P(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->Data();
- poly q=(poly)v->Data();
- int r=pCmp(p,q);
- if (r==0)
- {
- number h=nSub(pGetCoeff(p),pGetCoeff(q));
- /* compare lead coeffs */
- r = -1+nIsZero(h)+2*nGreaterZero(h); /* -1: <, 0:==, 1: > */
- nDelete(&h);
- }
- else if (p==NULL)
- {
- if (q==NULL)
- {
- /* compare 0, 0 */
- r=0;
- }
- else if(pIsConstant(q))
- {
- /* compare 0, const */
- r = 1-2*nGreaterZero(pGetCoeff(q)); /* -1: <, 1: > */
- }
- }
- else if (q==NULL)
- {
- if (pIsConstant(p))
- {
- /* compare const, 0 */
- r = -1+2*nGreaterZero(pGetCoeff(p)); /* -1: <, 1: > */
- }
- }
- switch (iiOp)
- {
- case '<':
- res->data = (char *) (r < 0);
- break;
- case '>':
- res->data = (char *) (r > 0);
- break;
- case LE:
- res->data = (char *) (r <= 0);
- break;
- case GE:
- res->data = (char *) (r >= 0);
- break;
- //case EQUAL_EQUAL:
- //case NOTEQUAL: /* negation handled by jjEQUAL_REST */
- // res->data = (char *) (r == 0);
- // break;
- }
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjCOMPARE_S(leftv res, leftv u, leftv v)
- {
- char* a = (char * )(u->Data());
- char* b = (char * )(v->Data());
- int result = strcmp(a,b);
- switch (iiOp)
- {
- case '<':
- res->data = (char *) (result < 0);
- break;
- case '>':
- res->data = (char *) (result > 0);
- break;
- case LE:
- res->data = (char *) (result <= 0);
- break;
- case GE:
- res->data = (char *) (result >= 0);
- break;
- case EQUAL_EQUAL:
- case NOTEQUAL: /* negation handled by jjEQUAL_REST */
- res->data = (char *) (result == 0);
- break;
- }
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjOP_REST(leftv res, leftv u, leftv v)
- {
- if (u->Next()!=NULL)
- {
- u=u->next;
- res->next = (leftv)omAllocBin(sleftv_bin);
- return iiExprArith2(res->next,u,iiOp,v);
- }
- else if (v->Next()!=NULL)
- {
- v=v->next;
- res->next = (leftv)omAllocBin(sleftv_bin);
- return iiExprArith2(res->next,u,iiOp,v);
- }
- return FALSE;
- }
- static BOOLEAN jjPOWER_I(leftv res, leftv u, leftv v)
- {
- int b=(int)(long)u->Data();
- int e=(int)(long)v->Data();
- int rc = 1;
- BOOLEAN overflow=FALSE;
- if (e >= 0)
- {
- if (b==0)
- {
- rc=(e==0);
- }
- else
- {
- int oldrc;
- while ((e--)!=0)
- {
- oldrc=rc;
- rc *= b;
- if (!overflow)
- {
- if(rc/b!=oldrc) overflow=TRUE;
- }
- }
- if (overflow)
- WarnS("int overflow(^), result may be wrong");
- }
- res->data = (char *)((long)rc);
- if (u!=NULL) return jjOP_REST(res,u,v);
- return FALSE;
- }
- else
- {
- WerrorS("exponent must be non-negative");
- return TRUE;
- }
- }
- static BOOLEAN jjPOWER_BI(leftv res, leftv u, leftv v)
- {
- int e=(int)(long)v->Data();
- number n=(number)u->Data();
- if (e>=0)
- {
- nlPower(n,e,(number*)&res->data);
- }
- else
- {
- WerrorS("exponent must be non-negative");
- return TRUE;
- }
- if (u!=NULL) return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjPOWER_N(leftv res, leftv u, leftv v)
- {
- int e=(int)(long)v->Data();
- number n=(number)u->Data();
- int d=0;
- if (e<0)
- {
- n=nInvers(n);
- e=-e;
- d=1;
- }
- nPower(n,e,(number*)&res->data);
- if (d) nDelete(&n);
- if (u!=NULL) return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjPOWER_P(leftv res, leftv u, leftv v)
- {
- int v_i=(int)(long)v->Data();
- if (v_i<0)
- {
- WerrorS("exponent must be non-negative");
- return TRUE;
- }
- poly u_p=(poly)u->CopyD(POLY_CMD);
- int dummy;
- if ((u_p!=NULL)
- && (pTotaldegree(u_p)*(signed long)v_i > (signed long)currRing->bitmask))
- {
- Werror("OVERFLOW in power(d=%ld, e=%d, max=%ld)",
- pTotaldegree(u_p),v_i,currRing->bitmask);
- pDelete(&u_p);
- return TRUE;
- }
- res->data = (char *)pPower(u_p,v_i);
- if (u!=NULL) return jjOP_REST(res,u,v);
- return errorreported; /* pPower may set errorreported via Werror */
- }
- static BOOLEAN jjPOWER_ID(leftv res, leftv u, leftv v)
- {
- res->data = (char *)idPower((ideal)(u->Data()),(int)(long)(v->Data()));
- if (u!=NULL) return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjPLUSMINUS_Gen(leftv res, leftv u, leftv v)
- {
- u=u->next;
- v=v->next;
- if (u==NULL)
- {
- if (v==NULL) return FALSE; /* u==NULL, v==NULL */
- if (iiOp=='-') /* u==NULL, v<>NULL, iiOp=='-'*/
- {
- do
- {
- if (res->next==NULL)
- res->next = (leftv)omAlloc0Bin(sleftv_bin);
- leftv tmp_v=v->next;
- v->next=NULL;
- BOOLEAN b=iiExprArith1(res->next,v,'-');
- v->next=tmp_v;
- if (b)
- return TRUE;
- v=tmp_v;
- res=res->next;
- } while (v!=NULL);
- return FALSE;
- }
- loop /* u==NULL, v<>NULL, iiOp=='+' */
- {
- res->next = (leftv)omAlloc0Bin(sleftv_bin);
- res=res->next;
- res->data = v->CopyD();
- res->rtyp = v->Typ();
- v=v->next;
- if (v==NULL) return FALSE;
- }
- }
- if (v!=NULL) /* u<>NULL, v<>NULL */
- {
- do
- {
- res->next = (leftv)omAlloc0Bin(sleftv_bin);
- leftv tmp_u=u->next; u->next=NULL;
- leftv tmp_v=v->next; v->next=NULL;
- BOOLEAN b=iiExprArith2(res->next,u,iiOp,v);
- u->next=tmp_u;
- v->next=tmp_v;
- if (b)
- return TRUE;
- u=tmp_u;
- v=tmp_v;
- res=res->next;
- } while ((u!=NULL) && (v!=NULL));
- return FALSE;
- }
- loop /* u<>NULL, v==NULL */
- {
- res->next = (leftv)omAlloc0Bin(sleftv_bin);
- res=res->next;
- res->data = u->CopyD();
- res->rtyp = u->Typ();
- u=u->next;
- if (u==NULL) return FALSE;
- }
- }
- static BOOLEAN jjCOLCOL(leftv res, leftv u, leftv v)
- {
- idhdl packhdl;
- switch(u->Typ())
- {
- case 0:
- Print("%s of type 'ANY'. Trying load.\n", v->name);
- if(iiTryLoadLib(u, u->name))
- {
- Werror("'%s' no such package", u->name);
- return TRUE;
- }
- syMake(u,u->name,NULL);
- // else: use next case !!! no break !!!
- case PACKAGE_CMD:
- packhdl = (idhdl)u->data;
- if((!IDPACKAGE(packhdl)->loaded)
- && (IDPACKAGE(packhdl)->language > LANG_TOP))
- {
- Werror("'%s' not loaded", u->name);
- return TRUE;
- }
- if(v->rtyp == IDHDL)
- {
- v->name = omStrDup(v->name);
- }
- v->req_packhdl=IDPACKAGE(packhdl);
- syMake(v, v->name, packhdl);
- memcpy(res, v, sizeof(sleftv));
- memset(v, 0, sizeof(sleftv));
- break;
- case DEF_CMD:
- break;
- default:
- WerrorS("<package>::<id> expected");
- return TRUE;
- }
- return FALSE;
- }
- static BOOLEAN jjPLUS_I(leftv res, leftv u, leftv v)
- {
- unsigned int a=(unsigned int)(unsigned long)u->Data();
- unsigned int b=(unsigned int)(unsigned long)v->Data();
- unsigned int c=a+b;
- res->data = (char *)((long)c);
- if (((Sy_bit(31)&a)==(Sy_bit(31)&b))&&((Sy_bit(31)&a)!=(Sy_bit(31)&c)))
- {
- WarnS("int overflow(+), result may be wrong");
- }
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjPLUS_BI(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(nlAdd((number)u->Data(), (number)v->Data()));
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjPLUS_N(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(nAdd((number)u->Data(), (number)v->Data()));
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjPLUS_P(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(pAdd((poly)u->CopyD(POLY_CMD) , (poly)v->CopyD(POLY_CMD)));
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjPLUS_IV(leftv res, leftv u, leftv v)
- {
- res->data = (char *)ivAdd((intvec*)(u->Data()), (intvec*)(v->Data()));
- if (res->data==NULL)
- {
- WerrorS("intmat size not compatible");
- return TRUE;
- }
- return jjPLUSMINUS_Gen(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjPLUS_MA(leftv res, leftv u, leftv v)
- {
- matrix A=(matrix)u->Data(); matrix B=(matrix)v->Data();
- res->data = (char *)(mpAdd(A , B));
- if (res->data==NULL)
- {
- Werror("matrix size not compatible(%dx%d, %dx%d)",
- MATROWS(A),MATCOLS(A),MATROWS(B),MATCOLS(B));
- return TRUE;
- }
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjPLUS_MA_P(leftv res, leftv u, leftv v)
- {
- matrix m=(matrix)u->Data();
- matrix p= mpInitP(m->nrows,m->ncols,(poly)(v->CopyD(POLY_CMD)));
- if (iiOp=='+')
- res->data = (char *)mpAdd(m , p);
- else
- res->data = (char *)mpSub(m , p);
- idDelete((ideal *)&p);
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjPLUS_P_MA(leftv res, leftv u, leftv v)
- {
- return jjPLUS_MA_P(res,v,u);
- }
- static BOOLEAN jjPLUS_S(leftv res, leftv u, leftv v)
- {
- char* a = (char * )(u->Data());
- char* b = (char * )(v->Data());
- char* r = (char * )omAlloc(strlen(a) + strlen(b) + 1);
- strcpy(r,a);
- strcat(r,b);
- res->data=r;
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjPLUS_ID(leftv res, leftv u, leftv v)
- {
- res->data = (char *)idAdd((ideal)u->Data(),(ideal)v->Data());
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjMINUS_I(leftv res, leftv u, leftv v)
- {
- void *ap=u->Data(); void *bp=v->Data();
- int aa=(int)(long)ap;
- int bb=(int)(long)bp;
- int cc=aa-bb;
- unsigned int a=(unsigned int)(unsigned long)ap;
- unsigned int b=(unsigned int)(unsigned long)bp;
- unsigned int c=a-b;
- if (((Sy_bit(31)&a)!=(Sy_bit(31)&b))&&((Sy_bit(31)&a)!=(Sy_bit(31)&c)))
- {
- WarnS("int overflow(-), result may be wrong");
- }
- res->data = (char *)((long)cc);
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjMINUS_BI(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(nlSub((number)u->Data(), (number)v->Data()));
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjMINUS_N(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(nSub((number)u->Data(), (number)v->Data()));
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjMINUS_P(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(pSub((poly)u->CopyD(POLY_CMD) , (poly)v->CopyD(POLY_CMD)));
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjMINUS_IV(leftv res, leftv u, leftv v)
- {
- res->data = (char *)ivSub((intvec*)(u->Data()), (intvec*)(v->Data()));
- if (res->data==NULL)
- {
- WerrorS("intmat size not compatible");
- return TRUE;
- }
- return jjPLUSMINUS_Gen(res,u,v);
- }
- static BOOLEAN jjMINUS_MA(leftv res, leftv u, leftv v)
- {
- matrix A=(matrix)u->Data(); matrix B=(matrix)v->Data();
- res->data = (char *)(mpSub(A , B));
- if (res->data==NULL)
- {
- Werror("matrix size not compatible(%dx%d, %dx%d)",
- MATROWS(A),MATCOLS(A),MATROWS(B),MATCOLS(B));
- return TRUE;
- }
- return jjPLUSMINUS_Gen(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjTIMES_I(leftv res, leftv u, leftv v)
- {
- int a=(int)(long)u->Data();
- int b=(int)(long)v->Data();
- int c=a * b;
- if ((b!=0) && (c/b !=a))
- WarnS("int overflow(*), result may be wrong");
- res->data = (char *)((long)c);
- if ((u->Next()!=NULL) || (v->Next()!=NULL))
- return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjTIMES_BI(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(nlMult( (number)u->Data(), (number)v->Data()));
- if ((v->next!=NULL) || (u->next!=NULL))
- return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjTIMES_N(leftv res, leftv u, leftv v)
- {
- res->data = (char *)(nMult( (number)u->Data(), (number)v->Data()));
- number n=(number)res->data;
- nNormalize(n);
- res->data=(char *)n;
- if ((v->next!=NULL) || (u->next!=NULL))
- return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjTIMES_P(leftv res, leftv u, leftv v)
- {
- poly a;
- poly b;
- int dummy;
- if (v->next==NULL)
- {
- a=(poly)u->CopyD(POLY_CMD); // works also for VECTOR_CMD
- if (u->next==NULL)
- {
- b=(poly)v->CopyD(POLY_CMD); // works also for VECTOR_CMD
- if ((a!=NULL) && (b!=NULL)
- && (pTotaldegree(a)+pTotaldegree(b)>si_max((long)rVar(currRing),(long)currRing->bitmask)))
- {
- Werror("OVERFLOW in mult(d=%ld, d=%ld, max=%ld)",
- pTotaldegree(a),pTotaldegree(b),currRing->bitmask);
- pDelete(&a);
- pDelete(&b);
- return TRUE;
- }
- res->data = (char *)(pMult( a, b));
- pNormalize((poly)res->data);
- return FALSE;
- }
- // u->next exists: copy v
- b=pCopy((poly)v->Data());
- if ((a!=NULL) && (b!=NULL)
- && (pTotaldegree(a)+pTotaldegree(b)>si_max((long)rVar(currRing),(long)currRing->bitmask)))
- {
- Werror("OVERFLOW in mult(d=%ld, d=%ld, max=%ld)",
- pTotaldegree(a),pTotaldegree(b),currRing->bitmask);
- pDelete(&a);
- pDelete(&b);
- return TRUE;
- }
- res->data = (char *)(pMult( a, b));
- pNormalize((poly)res->data);
- return jjOP_REST(res,u,v);
- }
- // v->next exists: copy u
- a=pCopy((poly)u->Data());
- b=(poly)v->CopyD(POLY_CMD); // works also for VECTOR_CMD
- if ((a!=NULL) && (b!=NULL)
- && ((unsigned long)(pTotaldegree(a)+pTotaldegree(b))>=currRing->bitmask))
- {
- pDelete(&a);
- pDelete(&b);
- WerrorS("OVERFLOW");
- return TRUE;
- }
- res->data = (char *)(pMult( a, b));
- pNormalize((poly)res->data);
- return jjOP_REST(res,u,v);
- }
- static BOOLEAN jjTIMES_ID(leftv res, leftv u, leftv v)
- {
- res->data = (char *)idMult((ideal)u->Data(),(ideal)v->Data());
- idNormalize((ideal)res->data);
- if ((v->next!=NULL) || (u->next!=NULL))
- return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjTIMES_IV(leftv res, leftv u, leftv v)
- {
- res->data = (char *)ivMult((intvec*)(u->Data()), (intvec*)(v->Data()));
- if (res->data==NULL)
- {
- WerrorS("intmat size not compatible");
- return TRUE;
- }
- if ((v->next!=NULL) || (u->next!=NULL))
- return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjTIMES_MA_BI1(leftv res, leftv u, leftv v)
- {
- number n=nInit_bigint((number)v->Data());
- poly p=pNSet(n);
- ideal I= (ideal)mpMultP((matrix)u->CopyD(MATRIX_CMD),p);
- res->data = (char *)I;
- return FALSE;
- }
- static BOOLEAN jjTIMES_MA_BI2(leftv res, leftv u, leftv v)
- {
- return jjTIMES_MA_BI1(res,v,u);
- }
- static BOOLEAN jjTIMES_MA_P1(leftv res, leftv u, leftv v)
- {
- poly p=(poly)v->CopyD(POLY_CMD);
- int r=pMaxComp(p);/* recompute the rank for the case ideal*vector*/
- ideal I= (ideal)mpMultP((matrix)u->CopyD(MATRIX_CMD),p);
- if (r>0) I->rank=r;
- idNormalize(I);
- res->data = (char *)I;
- return FALSE;
- }
- static BOOLEAN jjTIMES_MA_P2(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->CopyD(POLY_CMD);
- int r=pMaxComp(p);/* recompute the rank for the case ideal*vector*/
- ideal I= (ideal)pMultMp(p,(matrix)v->CopyD(MATRIX_CMD));
- if (r>0) I->rank=r;
- idNormalize(I);
- res->data = (char *)I;
- return FALSE;
- }
- static BOOLEAN jjTIMES_MA_N1(leftv res, leftv u, leftv v)
- {
- number n=(number)v->CopyD(NUMBER_CMD);
- poly p=pNSet(n);
- res->data = (char *)mpMultP((matrix)u->CopyD(MATRIX_CMD),p);
- idNormalize((ideal)res->data);
- return FALSE;
- }
- static BOOLEAN jjTIMES_MA_N2(leftv res, leftv u, leftv v)
- {
- return jjTIMES_MA_N1(res,v,u);
- }
- static BOOLEAN jjTIMES_MA_I1(leftv res, leftv u, leftv v)
- {
- res->data = (char *)mpMultI((matrix)u->CopyD(MATRIX_CMD),(int)(long)v->Data());
- idNormalize((ideal)res->data);
- return FALSE;
- }
- static BOOLEAN jjTIMES_MA_I2(leftv res, leftv u, leftv v)
- {
- return jjTIMES_MA_I1(res,v,u);
- }
- static BOOLEAN jjTIMES_MA(leftv res, leftv u, leftv v)
- {
- matrix A=(matrix)u->Data(); matrix B=(matrix)v->Data();
- res->data = (char *)mpMult(A,B);
- if (res->data==NULL)
- {
- Werror("matrix size not compatible(%dx%d, %dx%d)",
- MATROWS(A),MATCOLS(A),MATROWS(B),MATCOLS(B));
- return TRUE;
- }
- idNormalize((ideal)res->data);
- if ((v->next!=NULL) || (u->next!=NULL))
- return jjOP_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjGE_BI(leftv res, leftv u, leftv v)
- {
- number h=nlSub((number)u->Data(),(number)v->Data());
- res->data = (char *) (nlGreaterZero(h)||(nlIsZero(h)));
- nlDelete(&h,NULL);
- return FALSE;
- }
- static BOOLEAN jjGE_I(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((int)((long)u->Data()) >= (int)((long)v->Data()));
- return FALSE;
- }
- static BOOLEAN jjGE_N(leftv res, leftv u, leftv v)
- {
- res->data = (char *) (nGreater((number)u->Data(),(number)v->Data())
- || nEqual((number)u->Data(),(number)v->Data()));
- return FALSE;
- }
- static BOOLEAN jjGT_BI(leftv res, leftv u, leftv v)
- {
- number h=nlSub((number)u->Data(),(number)v->Data());
- res->data = (char *) (nlGreaterZero(h)&&(!nlIsZero(h)));
- nlDelete(&h,NULL);
- return FALSE;
- }
- static BOOLEAN jjGT_I(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((int)((long)u->Data()) > (int)((long)v->Data()));
- return FALSE;
- }
- static BOOLEAN jjGT_N(leftv res, leftv u, leftv v)
- {
- res->data = (char *) (nGreater((number)u->Data(),(number)v->Data()));
- return FALSE;
- }
- static BOOLEAN jjLE_BI(leftv res, leftv u, leftv v)
- {
- return jjGE_BI(res,v,u);
- }
- static BOOLEAN jjLE_I(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((int)((long)u->Data()) <= (int)((long)v->Data()));
- return FALSE;
- }
- static BOOLEAN jjLE_N(leftv res, leftv u, leftv v)
- {
- return jjGE_N(res,v,u);
- }
- static BOOLEAN jjLT_BI(leftv res, leftv u, leftv v)
- {
- return jjGT_BI(res,v,u);
- }
- static BOOLEAN jjLT_I(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((int)((long)u->Data()) < (int)((long)v->Data()));
- return FALSE;
- }
- static BOOLEAN jjLT_N(leftv res, leftv u, leftv v)
- {
- return jjGT_N(res,v,u);
- }
- static BOOLEAN jjDIVMOD_I(leftv res, leftv u, leftv v)
- {
- if (iiOp=='/') Warn("int division with `/`: use `div` instead in line >>%s<<",my_yylinebuf);
- int a= (int)(long)u->Data();
- int b= (int)(long)v->Data();
- if (b==0)
- {
- WerrorS(ii_div_by_0);
- return TRUE;
- }
- int bb=ABS(b);
- int c=a%bb;
- if(c<0) c+=bb;
- int r=0;
- switch (iiOp)
- {
- case INTMOD_CMD:
- r=c; break;
- case '%':
- r= (a % b); break;
- case INTDIV_CMD:
- r=((a-c) /b); break;
- case '/':
- r= (a / b); break;
- }
- res->data=(void *)((long)r);
- return FALSE;
- }
- static BOOLEAN jjDIV_BI(leftv res, leftv u, leftv v)
- {
- number q=(number)v->Data();
- if (nlIsZero(q))
- {
- WerrorS(ii_div_by_0);
- return TRUE;
- }
- q = nlIntDiv((number)u->Data(),q);
- nlNormalize(q);
- res->data = (char *)q;
- return FALSE;
- }
- static BOOLEAN jjDIV_N(leftv res, leftv u, leftv v)
- {
- number q=(number)v->Data();
- if (nIsZero(q))
- {
- WerrorS(ii_div_by_0);
- return TRUE;
- }
- q = nDiv((number)u->Data(),q);
- nNormalize(q);
- res->data = (char *)q;
- return FALSE;
- }
- static BOOLEAN jjDIV_P(leftv res, leftv u, leftv v)
- {
- poly q=(poly)v->Data();
- if (q==NULL)
- {
- WerrorS(ii_div_by_0);
- return TRUE;
- }
- poly p=(poly)(u->Data());
- if (p==NULL)
- {
- res->data=NULL;
- return FALSE;
- }
- if ((pNext(q)!=NULL) && (!rField_is_Ring()))
- { /* This means that q != 0 consists of at least two terms.
- Moreover, currRing is over a field. */
- #ifdef HAVE_FACTORY
- if(pGetComp(p)==0)
- {
- res->data=(void*)(singclap_pdivide(p /*(poly)(u->Data())*/ ,
- q /*(poly)(v->Data())*/ ));
- }
- else
- {
- int comps=pMaxComp(p);
- ideal I=idInit(comps,1);
- p=pCopy(p);
- poly h;
- int i;
- // conversion to a list of polys:
- while (p!=NULL)
- {
- i=pGetComp(p)-1;
- h=pNext(p);
- pNext(p)=NULL;
- pSetComp(p,0);
- I->m[i]=pAdd(I->m[i],p);
- p=h;
- }
- // division and conversion to vector:
- h=NULL;
- p=NULL;
- for(i=comps-1;i>=0;i--)
- {
- if (I->m[i]!=NULL)
- {
- h=singclap_pdivide(I->m[i],q);
- pSetCompP(h,i+1);
- p=pAdd(p,h);
- }
- }
- idDelete(&I);
- res->data=(void *)p;
- }
- #else /* HAVE_FACTORY */
- WerrorS("division only by a monomial");
- return TRUE;
- #endif /* HAVE_FACTORY */
- }
- else
- { /* This means that q != 0 consists of just one term,
- or that currRing is over a coefficient ring. */
- #ifdef HAVE_RINGS
- if (!rField_is_Domain())
- {
- WerrorS("division only defined over coefficient domains");
- return TRUE;
- }
- if (pNext(q)!=NULL)
- {
- WerrorS("division over a coefficient domain only implemented for terms");
- return TRUE;
- }
- #endif
- res->data = (char *)pDivideM(pCopy(p),pHead(q));
- }
- pNormalize((poly)res->data);
- return FALSE;
- }
- static BOOLEAN jjDIV_Ma(leftv res, leftv u, leftv v)
- {
- poly q=(poly)v->Data();
- if (q==NULL)
- {
- WerrorS(ii_div_by_0);
- return TRUE;
- }
- matrix m=(matrix)(u->Data());
- int r=m->rows();
- int c=m->cols();
- matrix mm=mpNew(r,c);
- int i,j;
- for(i=r;i>0;i--)
- {
- for(j=c;j>0;j--)
- {
- if (pNext(q)!=NULL)
- {
- #ifdef HAVE_FACTORY
- MATELEM(mm,i,j) = singclap_pdivide( MATELEM(m,i,j) ,
- q /*(poly)(v->Data())*/ );
- #else /* HAVE_FACTORY */
- WerrorS("division only by a monomial");
- return TRUE;
- #endif /* HAVE_FACTORY */
- }
- else
- MATELEM(mm,i,j) = pDivideM(pCopy(MATELEM(m,i,j)),pHead(q));
- }
- }
- idNormalize((ideal)mm);
- res->data=(char *)mm;
- return FALSE;
- }
- static BOOLEAN jjEQUAL_BI(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((long)nlEqual((number)u->Data(),(number)v->Data()));
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjEQUAL_I(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((int)((long)u->Data()) == (int)((long)v->Data()));
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjEQUAL_Ma(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((long)mpEqual((matrix)u->Data(),(matrix)v->Data()));
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjEQUAL_N(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((long)nEqual((number)u->Data(),(number)v->Data()));
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static BOOLEAN jjEQUAL_P(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->Data();
- poly q=(poly)v->Data();
- res->data = (char *) ((long)pEqualPolys(p,q));
- jjEQUAL_REST(res,u,v);
- return FALSE;
- }
- static void jjEQUAL_REST(leftv res,leftv u,leftv v)
- {
- if ((res->data) && (u->next!=NULL) && (v->next!=NULL))
- {
- int save_iiOp=iiOp;
- if (iiOp==NOTEQUAL)
- iiExprArith2(res,u->next,EQUAL_EQUAL,v->next);
- else
- iiExprArith2(res,u->next,iiOp,v->next);
- iiOp=save_iiOp;
- }
- if (iiOp==NOTEQUAL) res->data=(char *)(!(long)res->data);
- }
- static BOOLEAN jjAND_I(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((long)u->Data() && (long)v->Data());
- return FALSE;
- }
- static BOOLEAN jjOR_I(leftv res, leftv u, leftv v)
- {
- res->data = (char *)((long)u->Data() || (long)v->Data());
- return FALSE;
- }
- static BOOLEAN jjINDEX_I(leftv res, leftv u, leftv v)
- {
- res->rtyp=u->rtyp; u->rtyp=0;
- res->data=u->data; u->data=NULL;
- res->name=u->name; u->name=NULL;
- res->e=u->e; u->e=NULL;
- if (res->e==NULL) res->e=jjMakeSub(v);
- else
- {
- Subexpr sh=res->e;
- while (sh->next != NULL) sh=sh->next;
- sh->next=jjMakeSub(v);
- }
- return FALSE;
- }
- static BOOLEAN jjINDEX_IV(leftv res, leftv u, leftv v)
- {
- if ((u->rtyp!=IDHDL)||(u->e!=NULL))
- {
- WerrorS("indexed object must have a name");
- return TRUE;
- }
- intvec * iv=(intvec *)v->Data();
- leftv p=NULL;
- int i;
- sleftv t;
- memset(&t,0,sizeof(t));
- t.rtyp=INT_CMD;
- for (i=0;i<iv->length(); i++)
- {
- t.data=(char *)((long)(*iv)[i]);
- if (p==NULL)
- {
- p=res;
- }
- else
- {
- p->next=(leftv)omAlloc0Bin(sleftv_bin);
- p=p->next;
- }
- p->rtyp=IDHDL;
- p->data=u->data;
- p->name=u->name;
- p->flag=u->flag;
- p->e=jjMakeSub(&t);
- }
- u->rtyp=0;
- u->data=NULL;
- u->name=NULL;
- return FALSE;
- }
- static BOOLEAN jjINDEX_P(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->Data();
- int i=(int)(long)v->Data();
- int j=0;
- while (p!=NULL)
- {
- j++;
- if (j==i)
- {
- res->data=(char *)pHead(p);
- return FALSE;
- }
- pIter(p);
- }
- return FALSE;
- }
- static BOOLEAN jjINDEX_P_IV(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->Data();
- poly r=NULL;
- intvec *iv=(intvec *)v->CopyD(INTVEC_CMD);
- int i;
- int sum=0;
- for(i=iv->length()-1;i>=0;i--)
- sum+=(*iv)[i];
- int j=0;
- while ((p!=NULL) && (sum>0))
- {
- j++;
- for(i=iv->length()-1;i>=0;i--)
- {
- if (j==(*iv)[i])
- {
- r=pAdd(r,pHead(p));
- sum-=j;
- (*iv)[i]=0;
- break;
- }
- }
- pIter(p);
- }
- delete iv;
- res->data=(char *)r;
- return FALSE;
- }
- static BOOLEAN jjINDEX_V(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->CopyD(VECTOR_CMD);
- poly r=p; // pointer to the beginning of component i
- poly o=NULL;
- int i=(int)(long)v->Data();
- while (p!=NULL)
- {
- if (pGetComp(p)!=i)
- {
- if (r==p) r=pNext(p);
- if (o!=NULL)
- {
- if (pNext(o)!=NULL) pLmDelete(&pNext(o));
- p=pNext(o);
- }
- else
- pLmDelete(&p);
- }
- else
- {
- pSetComp(p, 0);
- p_SetmComp(p, currRing);
- o=p;
- p=pNext(o);
- }
- }
- res->data=(char *)r;
- return FALSE;
- }
- static BOOLEAN jjINDEX_V_IV(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->CopyD(VECTOR_CMD);
- if (p!=NULL)
- {
- poly r=pOne();
- poly hp=r;
- intvec *iv=(intvec *)v->Data();
- int i;
- loop
- {
- for(i=0;i<iv->length();i++)
- {
- if (pGetComp(p)==(*iv)[i])
- {
- poly h;
- pSplit(p,&h);
- pNext(hp)=p;
- p=h;
- pIter(hp);
- break;
- }
- }
- if (p==NULL) break;
- if (i==iv->length())
- {
- pLmDelete(&p);
- if (p==NULL) break;
- }
- }
- pLmDelete(&r);
- res->data=(char *)r;
- }
- return FALSE;
- }
- static BOOLEAN jjKLAMMER_rest(leftv res, leftv u, leftv v);
- static BOOLEAN jjKLAMMER(leftv res, leftv u, leftv v)
- {
- if(u->name==NULL) return TRUE;
- char * nn = (char *)omAlloc(strlen(u->name) + 14);
- sprintf(nn,"%s(%d)",u->name,(int)(long)v->Data());
- omFree((ADDRESS)u->name);
- u->name=NULL;
- char *n=omStrDup(nn);
- omFree((ADDRESS)nn);
- syMake(res,n);
- if (u->next!=NULL) return jjKLAMMER_rest(res,u->next,v);
- return FALSE;
- }
- static BOOLEAN jjKLAMMER_IV(leftv res, leftv u, leftv v)
- {
- intvec * iv=(intvec *)v->Data();
- leftv p=NULL;
- int i;
- long slen = strlen(u->name) + 14;
- char *n = (char*) omAlloc(slen);
- for (i=0;i<iv->length(); i++)
- {
- if (p==NULL)
- {
- p=res;
- }
- else
- {
- p->next=(leftv)omAlloc0Bin(sleftv_bin);
- p=p->next;
- }
- sprintf(n,"%s(%d)",u->name,(*iv)[i]);
- syMake(p,omStrDup(n));
- }
- omFree((ADDRESS)u->name);
- u->name = NULL;
- omFreeSize(n, slen);
- if (u->next!=NULL) return jjKLAMMER_rest(res,u->next,v);
- return FALSE;
- }
- static BOOLEAN jjKLAMMER_rest(leftv res, leftv u, leftv v)
- {
- leftv tmp=(leftv)omAllocBin(sleftv_bin);
- memset(tmp,0,sizeof(sleftv));
- BOOLEAN b;
- if (v->Typ()==INTVEC_CMD)
- b=jjKLAMMER_IV(tmp,u,v);
- else
- b=jjKLAMMER(tmp,u,v);
- if (b)
- {
- omFreeBin(tmp,sleftv_bin);
- return TRUE;
- }
- leftv h=res;
- while (h->next!=NULL) h=h->next;
- h->next=tmp;
- return FALSE;
- }
- BOOLEAN jjPROC(leftv res, leftv u, leftv v)
- {
- void *d;
- Subexpr e;
- int typ;
- BOOLEAN t=FALSE;
- if ((u->rtyp!=IDHDL)||(u->e!=NULL))
- {
- idrec tmp_proc;
- tmp_proc.id="_auto";
- tmp_proc.typ=PROC_CMD;
- tmp_proc.data.pinf=(procinfo *)u->Data();
- tmp_proc.ref=1;
- d=u->data; u->data=(void *)&tmp_proc;
- e=u->e; u->e=NULL;
- t=TRUE;
- typ=u->rtyp; u->rtyp=IDHDL;
- }
- leftv sl;
- if (u->req_packhdl==currPack)
- sl = iiMake_proc((idhdl)u->data,NULL,v);
- else
- sl = iiMake_proc((idhdl)u->data,u->req_packhdl,v);
- if (t)
- {
- u->rtyp=typ;
- u->data=d;
- u->e=e;
- }
- if (sl==NULL)
- {
- return TRUE;
- }
- else
- {
- memcpy(res,sl,sizeof(sleftv));
- }
- return FALSE;
- }
- static BOOLEAN jjMAP(leftv res, leftv u, leftv v)
- {
- //Print("try to map %s with %s\n",$3.Name(),$1.Name());
- leftv sl=NULL;
- if ((v->e==NULL)&&(v->name!=NULL))
- {
- map m=(map)u->Data();
- sl=iiMap(m,v->name);
- }
- else
- {
- Werror("%s(<name>) expected",u->Name());
- }
- if (sl==NULL) return TRUE;
- memcpy(res,sl,sizeof(sleftv));
- omFreeBin((ADDRESS)sl, sleftv_bin);
- return FALSE;
- }
- static BOOLEAN jjCALL2MANY(leftv res, leftv u, leftv v)
- {
- u->next=(leftv)omAllocBin(sleftv_bin);
- memcpy(u->next,v,sizeof(sleftv));
- BOOLEAN r=iiExprArithM(res,u,iiOp);
- v->Init();
- // iiExprArithM did the CleanUp
- return r;
- }
- #ifdef HAVE_FACTORY
- static BOOLEAN jjCHINREM_BI(leftv res, leftv u, leftv v)
- {
- intvec *c=(intvec*)u->Data();
- intvec* p=(intvec*)v->Data();
- int rl=p->length();
- number *x=(number *)omAlloc(rl*sizeof(number));
- number *q=(number *)omAlloc(rl*sizeof(number));
- int i;
- for(i=rl-1;i>=0;i--)
- {
- q[i]=nlInit((*p)[i], NULL);
- x[i]=nlInit((*c)[i], NULL);
- }
- number n=nlChineseRemainder(x,q,rl);
- for(i=rl-1;i>=0;i--)
- {
- nlDelete(&(q[i]),NULL);
- nlDelete(&(x[i]),NULL);
- }
- omFree(x); omFree(q);
- res->data=(char *)n;
- return FALSE;
- }
- #endif
- #if 0
- static BOOLEAN jjCHINREM_P(leftv res, leftv u, leftv v)
- {
- lists c=(lists)u->CopyD(); // list of poly
- intvec* p=(intvec*)v->Data();
- int rl=p->length();
- poly r=NULL,h, result=NULL;
- number *x=(number *)omAlloc(rl*sizeof(number));
- number *q=(number *)omAlloc(rl*sizeof(number));
- int i;
- for(i=rl-1;i>=0;i--)
- {
- q[i]=nlInit((*p)[i]);
- }
- loop
- {
- for(i=rl-1;i>=0;i--)
- {
- if (c->m[i].Typ()!=POLY_CMD)
- {
- Werror("poly expected at pos %d",i+1);
- for(i=rl-1;i>=0;i--)
- {
- nlDelete(&(q[i]),currRing);
- }
- omFree(x); omFree(q); // delete c
- return TRUE;
- }
- h=((poly)c->m[i].Data());
- if (r==NULL) r=h;
- else if (pLmCmp(r,h)==-1) r=h;
- }
- if (r==NULL) break;
- for(i=rl-1;i>=0;i--)
- {
- h=((poly)c->m[i].Data());
- if (pLmCmp(r,h)==0)
- {
- x[i]=pGetCoeff(h);
- h=pLmFreeAndNext(h);
- c->m[i].data=(char*)h;
- }
- else
- x[i]=nlInit(0);
- }
- number n=nlChineseRemainder(x,q,rl);
- for(i=rl-1;i>=0;i--)
- {
- nlDelete(&(x[i]),currRing);
- }
- h=pHead(r);
- pSetCoeff(h,n);
- result=pAdd(result,h);
- }
- for(i=rl-1;i>=0;i--)
- {
- nlDelete(&(q[i]),currRing);
- }
- omFree(x); omFree(q);
- res->data=(char *)result;
- return FALSE;
- }
- #endif
- #ifdef HAVE_FACTORY
- static BOOLEAN jjCHINREM_ID(leftv res, leftv u, leftv v)
- {
- if ((currRing==NULL) || rField_is_Q())
- {
- lists c=(lists)u->CopyD(); // list of ideal
- lists pl=NULL;
- intvec *p=NULL;
- if (v->Typ()==LIST_CMD) pl=(lists)v->Data();
- else p=(intvec*)v->Data();
- int rl=c->nr+1;
- poly r=NULL,h;
- ideal result;
- ideal *x=(ideal *)omAlloc(rl*sizeof(ideal));
- int i;
- int return_type=c->m[0].Typ();
- if ((return_type!=IDEAL_CMD)
- && (return_type!=MODUL_CMD)
- && (return_type!=MATRIX_CMD))
- {
- WerrorS("ideal/module/matrix expected");
- omFree(x); // delete c
- return TRUE;
- }
- for(i=rl-1;i>=0;i--)
- {
- if (c->m[i].Typ()!=return_type)
- {
- Werror("%s expected at pos %d",Tok2Cmdname(return_type),i+1);
- omFree(x); // delete c
- return TRUE;
- }
- x[i]=((ideal)c->m[i].Data());
- }
- number *q=(number *)omAlloc(rl*sizeof(number));
- if (p!=NULL)
- {
- for(i=rl-1;i>=0;i--)
- {
- q[i]=nlInit((*p)[i], currRing);
- }
- }
- else
- {
- for(i=rl-1;i>=0;i--)
- {
- if (pl->m[i].Typ()==INT_CMD)
- {
- q[i]=nlInit((int)(long)pl->m[i].Data(),currRing);
- }
- else if (pl->m[i].Typ()==BIGINT_CMD)
- {
- q[i]=nlCopy((number)(pl->m[i].Data()));
- }
- else
- {
- Werror("bigint expected at pos %d",i+1);
- for(i++;i<rl;i++)
- {
- nlDelete(&(q[i]),currRing);
- }
- omFree(x); // delete c
- omFree(q); // delete pl
- return TRUE;
- }
- }
- }
- result=idChineseRemainder(x,q,rl);
- for(i=rl-1;i>=0;i--)
- {
- nlDelete(&(q[i]),currRing);
- }
- omFree(q);
- res->data=(char *)result;
- res->rtyp=return_type;
- return FALSE;
- }
- else return TRUE;
- }
- #endif
- static BOOLEAN jjCOEF(leftv res, leftv u, leftv v)
- {
- poly p=(poly)v->Data();
- if ((p==NULL)||(pNext(p)!=NULL)) return TRUE;
- res->data=(char *)mpCoeffProc((poly)u->Data(),p /*(poly)v->Data()*/);
- return FALSE;
- }
- static BOOLEAN jjCOEFFS_Id(leftv res, leftv u, leftv v)
- {
- int i=pVar((poly)v->Data());
- if (i==0)
- {
- WerrorS("ringvar expected");
- return TRUE;
- }
- res->data=(char *)mpCoeffs((ideal)u->CopyD(),i);
- return FALSE;
- }
- static BOOLEAN jjCOEFFS2_KB(leftv res, leftv u, leftv v)
- {
- poly p = pInit();
- int i;
- for (i=1; i<=pVariables; i++)
- {
- pSetExp(p, i, 1);
- }
- pSetm(p);
- res->data = (void*)idCoeffOfKBase((ideal)(u->Data()),
- (ideal)(v->Data()), p);
- pDelete(&p);
- return FALSE;
- }
- static BOOLEAN jjCONTRACT(leftv res, leftv u, leftv v)
- {
- res->data=(char *)idDiffOp((ideal)u->Data(),(ideal)v->Data(),FALSE);
- return FALSE;
- }
- static BOOLEAN jjDEG_M_IV(leftv res, leftv u, leftv v)
- {
- short *iv=iv2array((intvec *)v->Data());
- ideal I=(ideal)u->Data();
- int d=-1;
- int i;
- for(i=IDELEMS(I);i>=0;i--) d=si_max(d,(int)pDegW(I->m[i],iv));
- omFreeSize((ADDRESS)iv,(pVariables+1)*sizeof(short));
- res->data = (char *)((long)d);
- return FALSE;
- }
- static BOOLEAN jjDEG_IV(leftv res, leftv u, leftv v)
- {
- poly p=(poly)u->Data();
- if (p!=NULL)
- {
- short *iv=iv2array((intvec *)v->Data());
- int d=(int)pDegW(p,iv);
- omFreeSize((ADDRESS)iv,(pVariables+1)*sizeof(short));
- res->data = (char *)(long(d));
- }
- else
- res->data=(char *)(long)(-1);
- return FALSE;
- }
- static BOOLEAN jjDIFF_P(leftv res, leftv u, leftv v)
- {
- int i=pVar((poly)v->Data());
- if (i==0)
- {
- WerrorS("ringvar expected");
- return TRUE;
- }
- res->data=(char *)pDiff((poly)(u->Data()),i);
- return FALSE;
- }
- static BOOLEAN jjDIFF_ID(leftv res, leftv u, leftv v)
- {
- int i=pVar((poly)v->Data());
- if (i==0)
- {
- WerrorS("ringvar expected");
- return TRUE;
- }
- res->data=(char *)idDiff((matrix)(u->Data()),i);
- return FALSE;
- }
- static BOOLEAN jjDIFF_ID_ID(leftv res, leftv u, leftv v)
- {
- res->data=(char *)idDiffOp((ideal)u->Data(),(ideal)v->Data());
- return FALSE;
- }
- static BOOLEAN jjDIM2(leftv res, leftv v, leftv w)
- {
- assumeStdFlag(v);
- #ifdef HAVE_RINGS
- if (rField_is_Ring(currRing))
- {
- ring origR = currRing;
- ring tempR = rCopy(origR);
- tempR->ringtype = 0; tempR->ch = 0;
- rComplete(tempR);
- ideal vid = (ideal)v->Data();
- int i = idPosConstant(vid);
- if ((i != -1) && (nIsUnit(pGetCoeff(vid->m[i]))))
- { /* ideal v contains unit; dim = -1 */
- res->data = (char *)-1;
- return FALSE;
- }
- rChangeCurrRing(tempR);
- ideal vv = idrCopyR(vid, origR, currRing);
- ideal ww = idrCopyR((ideal)w->Data(), origR, currRing);
- /* drop degree zero generator from vv (if any) */
- if (i != -1) pDelete(&vv->m[i]);
- long d = (long)scDimInt(vv, ww);
- if (rField_is_Ring_Z(origR) && (i == -1)) d++;
- res->data = (char *)d;
- idDelete(&vv); idDelete(&ww);
- rChangeCurrRing(origR);
- rDelete(tempR);
- return FALSE;
- }
- #endif
- if(currQuotient==NULL)
- res->data = (char *)((long)scDimInt((ideal)(v->Data()),(ideal)w->Data()));
- else
- {
- ideal q=idSimpleAdd(currQuotient,(ideal)w->Data());
- res->data = (char *)((long)scDimInt((ideal)(v->Data()),q));
- idDelete(&q);
- }
- return FALSE;
- }
- static BOOLEAN jjDIVISION(leftv res, leftv u, leftv v)
- {
- ideal vi=(ideal)v->Data();
- int vl= IDELEMS(vi);
- ideal ui=(ideal)u->Data();
- int ul= IDELEMS(ui);
- ideal R; matrix U;
- ideal m = idLift(vi,ui,&R, FALSE,hasFlag(v,FLAG_STD),TRUE,&U);
- // now make sure that all matices have the corect size:
- matrix T = idModule2formatedMatrix(m,vl,ul);
- int i;
- if (MATCOLS(U) != ul)
- {
- int mul=si_min(ul,MATCOLS(U));
- matrix UU=mpNew(ul,ul);
- int j;
- for(i=mul;i>0;i--)
- {
- for(j=mul;j>0;j--)
- {
- MATELEM(UU,i,j)=MATELEM(U,i,j);
- MATELEM(U,i,j)=NULL;
- }
- }
- idDelete((ideal *)&U);
- U=UU;
- }
- // make sure that U is a diagonal matrix of units
- for(i=ul;i>0;i--)
- {
- if(MATELEM(U,i,i)==NULL) MATELEM(U,i,i)=pOne();
- }
- lists L=(lists)omAllocBin(slists_bin);
- L->Init(3);
- L->m[0].rtyp=MATRIX_CMD; L->m[0].data=(void *)T;
- L->m[1].rtyp=u->Typ(); L->m[1].data=(void *)R;
- L->m[2].rtyp=MATRIX_CMD; L->m[2].data=(void *)U;
- res->data=(char *)L;
- return FALSE;
- }
- static BOOLEAN jjELIMIN(leftv res, leftv u, leftv v)
- {
- res->data=(char *)idElimination((ideal)u->Data(),(poly)v->Data());
- //setFlag(res,FLAG_STD);
- return FALSE;
- }
- static BOOLEAN jjELIMIN_IV(leftv res, leftv u, leftv v)
- {
- poly p=pOne();
- intvec *iv=(intvec*)v->Data();
- for(int i=iv->length()-1; i>=0; i--)
- {
- pSetExp(p,(*iv)[i],1);
- }
- pSetm(p);
- res->data=(char *)idElimination((ideal)u->Data(),p);
- pLmDelete(&p);
- //setFlag(res,FLAG_STD);
- return FALSE;
- }
- static BOOLEAN jjEXPORTTO(leftv res, leftv u, leftv v)
- {
- //Print("exportto %s -> %s\n",v->Name(),u->Name() );
- return iiExport(v,0,(idhdl)u->data);
- }
- static BOOLEAN jjERROR(leftv res, leftv u)
- {
- WerrorS((char *)u->Data());
- extern int inerror;
- inerror=3;
- return TRUE;
- }
- static BOOLEAN jjEXTGCD_I(leftv res, leftv u, leftv v)
- {
- int uu=(int)(long)u->Data();int vv=(int)(long)v->Data();
- int p0=ABS(uu),p1=ABS(vv);
- int f0 = 1, f1 = 0, g0 = 0, g1 = 1, q, r;
- while ( p1!=0 )
- {
- q=p0 / p1;
- r=p0 % p1;
- p0 = p1; p1 = r;
- r = g0 - g1 * q;
- g0 = g1; g1 = r;
- r = f0 - f1 * q;
- f0 = f1; f1 = r;
- }
- int a = f0;
- int b = g0;
- if ( uu /*(int)(long)u->Data()*/ < 0 ) a=-a;
- if ( vv /*(int)(long)v->Data()*/ < 0 ) b=-b;
- lists L=(lists)omAllocBin(slists_bin);
- L->Init(3);
- L->m[0].rtyp=INT_CMD; L->m[0].data=(void *)(long)p0;
- L->m[1].rtyp=INT_CMD; L->m[1].data=(void *)(long)a;
- L->m[2].rtyp=INT_CMD; L->m[2].data=(void *)(long)b;
- res->rtyp=LIST_CMD;
- res->data=(char *)L;
- return FALSE;
- }
- #ifdef HAVE_FACTORY
- static BOOLEAN jjEXTGCD_P(leftv res, leftv u, leftv v)
- {
- poly r,pa,pb;
- BOOLEAN ret=singclap_extgcd((poly)u->Data(),(poly)v->Data(),r,pa,pb);
- if (ret) return TRUE;
- lists L=(lists)omAllocBin(slists_bin);
- L->Init(3);
- res->data=(char *)L;
- L->m[0].data=(void *)r;
- L->m[0].rtyp=POLY_CMD;
- L->m[1].data=(void *)pa;
- L->m[1].rtyp=POLY_CMD;
- L->m[2].data=(void *)pb;
- L->m[2].rtyp=POLY_CMD;
- return FALSE;
- }
- extern int singclap_factorize_retry;
- static BOOLEAN jjFAC_P2(leftv res, leftv u,leftv dummy)
- {
- intvec *v=NULL;
- int sw=(int)(long)dummy->Data();
- int fac_sw=sw;
- if ((sw<0)||(sw>2)) fac_sw=1;
- singclap_factorize_retry=0;
- ideal f=singclap_factorize((poly)(u->CopyD()), &v, fac_sw);
- if (f==NULL)
- return TRUE;
- switch(sw)
- {
- case 0:
- case 2:
- {
- lists l=(lists)omAllocBin(slists_bin);
- l->Init(2);
- l->m[0].rtyp=IDEAL_CMD;
- l->m[0].data=(void *)f;
- l->m[1].rtyp=INTVEC_CMD;
- l->m[1].data=(void *)v;
- res->data=(void *)l;
- res->rtyp=LIST_CMD;
- return FALSE;
- }
- case 1:
- res->data=(void *)f;
- return FALSE;
- case 3:
- {
- poly p=f->m[0];
- int i=IDELEMS(f);
- f->m[0]=NULL;
- while(i>1)
- {
- i--;
- p=pMult(p,f->m[i]);
- f->m[i]=NULL;
- }
- res->data=(void *)p;
- res->rtyp=POLY_CMD;
- }
- return FALSE;
- }
- WerrorS("invalid switch");
- return TRUE;
- }
- static BOOLEAN jjFACSTD2(leftv res, leftv v, leftv w)
- {
- ideal_list p,h;
- h=kStdfac((ideal)v->Data(),NULL,testHomog,NULL,(ideal)w->Data());
- p=h;
- int l=0;
- while (p!=NULL) { p=p->next;l++; }
- lists L=(lists)omAllocBin(slists_bin);
- L->Init(l);
- l=0;
- while(h!=NULL)
- {
- L->m[l].data=(char *)h->d;
- L->m[l].rtyp=IDEAL_CMD;
- p=h->next;
- omFreeSize(h,sizeof(*h));
- h=p;
- l++;
- }
- res->data=(void *)L;
- return FALSE;
- }
- #endif /* HAVE_FACTORY */
- static BOOLEAN jjFAREY_BI(leftv res, leftv u, leftv v)
- {
- if (rField_is_Q())
- {
- number uu=(number)u->Data();
- number vv=(number)v->Data();
- res->data=(char *)nlFarey(uu,vv);
- return FALSE;
- }
- else return TRUE;
- }
- static BOOLEAN jjFAREY_ID(leftv res, leftv u, leftv v)
- {
- if (rField_is_Q())
- {
- ideal uu=(ideal)u->Data();
- number vv=(number)v->Data();
- res->data=(void*)idFarey(uu,vv);
- res->rtyp=u->Typ();
- return FALSE;
- }
- else return TRUE;
- }
- static BOOLEAN jjFETCH(leftv res, leftv u, leftv v)
- {
- ring r=(ring)u->Data();
- idhdl w;
- int op=iiOp;
- nMapFunc nMap;
- if ((w=r->idroot->get(v->Name(),myynest))!=NULL)
- {
- int *perm=NULL;
- int *par_perm=NULL;
- int par_perm_size=0;
- BOOLEAN bo;
- //if (!nSetMap(rInternalChar(r),r->parameter,rPar(r),r->minpoly))
- if ((nMap=nSetMap(r))==NULL)
- {
- if (rEqual(r,currRing))
- {
- nMap=nCopy;
- }
- else
- // Allow imap/fetch to be make an exception only for:
- if ( (rField_is_Q_a(r) && // Q(a..) -> Q(a..) || Q || Zp || Zp(a)
- (rField_is_Q() || rField_is_Q_a() ||
- (rField_is_Zp() || rField_is_Zp_a())))
- ||
- (rField_is_Zp_a(r) && // Zp(a..) -> Zp(a..) || Zp
- (rField_is_Zp(currRing, rInternalChar(r)) ||
- rField_is_Zp_a(currRing, rInternalChar(r)))) )
- {
- par_perm_size=rPar(r);
- BITSET save_test=test;
- if ((r->minpoly != NULL) || (r->minideal != NULL))
- naSetChar(rInternalChar(r),r);
- else ntSetChar(rInternalChar(r),r);
- nSetChar(currRing);
- test=save_test;
- }
- else
- {
- goto err_fetch;
- }
- }
- if ((iiOp!=FETCH_CMD) || (r->N!=pVariables) || (rPar(r)!=rPar(currRing)))
- {
- perm=(int *)omAlloc0((r->N+1)*sizeof(int));
- if (par_perm_size!=0)
- …
Large files files are truncated, but you can click here to view the full file