/**************************************************************************** ** *F FuncIS_EQUAL_SET(<self>,<l1>,<l2>) test if a two lists are equal as sets ** ** 'FuncIS_EQUAL_SET' implements the internal function 'IsEqualSet'. ** ** 'IsEqualSet( <list1>, <list2> )' ** ** 'IsEqualSet' returns 'true' if the two lists <list1> and <list2> are ** equal *when viewed as sets*, and 'false' otherwise. <list1> and <list2> ** are equal if every element of <list1> is also an element of <list2> and ** if every element of <list2> is also an element of <list1>. */ Int EqSet ( Obj listL, Obj listR ) { Int lenL; /* length of the left operand */ Int lenR; /* length of the right operand */ Obj elmL; /* element of the left operand */ Obj elmR; /* element of the right operand */ UInt i; /* loop variable */ /* get the lengths of the lists and compare them */ lenL = LEN_PLIST( listL ); lenR = LEN_PLIST( listR ); if ( lenL != lenR ) { return 0L; } /* loop over the elements and compare them */ for ( i = 1; i <= lenL; i++ ) { elmL = ELM_PLIST( listL, i ); elmR = ELM_PLIST( listR, i ); if ( ! EQ( elmL, elmR ) ) { return 0L; } } /* no differences found, the lists are equal */ return 1L; }
/**************************************************************************** * FIND_RATIONALFUNCTION solves the Hurwitz problem ****************************************************************************/ static Obj FIND_RATIONALFUNCTION (Obj self, Obj gap_degrees, Obj gap_values, Obj gap_c, Obj gap_num, Obj gap_den, Obj params) { size_t degree = 2, s; s = LEN_PLIST(gap_degrees); if (s != LEN_PLIST(gap_values)+3 || s != LEN_PLIST(gap_c)+3) return Fail; size_t d[s], i; gsl_complex c[s-3], v[s]; for (i = 0; i < s; i++) { d[i] = INT_INTOBJ(ELM_PLIST(gap_degrees,i+1)); degree += d[i]-1; if (i < s-3) { v[i] = VAL_GSL_COMPLEX(ELM_PLIST(gap_values,i+1)); c[i] = VAL_GSL_COMPLEX(ELM_PLIST(gap_c,i+1)); } else if (i == s-3) GSL_SET_COMPLEX(v+i, 1.0, 0.0); else if (i == s-2) GSL_SET_COMPLEX(v+i, 0.0, 0.0); else if (i == s-1) GSL_SET_COMPLEX(v+i, HUGE_VAL, HUGE_VAL); } degree /= 2; gsl_complex num_data[degree+1], den_data[degree+1]; polynomial num = { LEN_PLIST(gap_num)-1, num_data }, den = { LEN_PLIST(gap_den)-1, den_data }; for (i = 0; i <= num.degree; i++) num.data[i] = VAL_GSL_COMPLEX(ELM_PLIST(gap_num,i+1)); for (i = 0; i <= den.degree; i++) den.data[i] = VAL_GSL_COMPLEX(ELM_PLIST(gap_den,i+1)); int status = solve_hurwitz (degree, s, d, v, c, &num, &den, INT_INTOBJ(ELM_PLIST(params,1)), VAL_FLOAT(ELM_PLIST(params,2)), VAL_FLOAT(ELM_PLIST(params,3))); if (status != GSL_SUCCESS) return INTOBJ_INT(status); for (i = 0; i < s-3; i++) set_elm_plist(gap_c,i+1, NEW_COMPLEX_GSL(c+i)); GROW_PLIST(gap_num, num.degree+1); SET_LEN_PLIST(gap_num, num.degree+1); for (i = 0; i <= num.degree; i++) set_elm_plist(gap_num,i+1, NEW_COMPLEX_GSL(num.data+i)); GROW_PLIST(gap_den, den.degree+1); SET_LEN_PLIST(gap_den, den.degree+1); for (i = 0; i <= den.degree; i++) set_elm_plist(gap_den,i+1, NEW_COMPLEX_GSL(den.data+i)); return INTOBJ_INT(status); }
/**************************************************************************** ** *F FuncAddRowVectorVecFFEs( <self>, <vecL>, <vecR> ) ** */ Obj FuncAddRowVectorVecFFEs( Obj self, Obj vecL, Obj vecR ) { Obj *ptrL; Obj *ptrR; FFV valS; FFV valL; FFV valR; FF fld; FFV *succ; UInt len; UInt xtype; UInt i; xtype = KTNumPlist(vecL, (Obj *) 0); if (xtype != T_PLIST_FFE && xtype != T_PLIST_FFE + IMMUTABLE) return TRY_NEXT_METHOD; xtype = KTNumPlist(vecR, (Obj *) 0); if (xtype != T_PLIST_FFE && xtype != T_PLIST_FFE + IMMUTABLE) return TRY_NEXT_METHOD; /* check the lengths */ len = LEN_PLIST(vecL); if (len != LEN_PLIST(vecR)) { vecR = ErrorReturnObj( "Vector *: vector lengths differ <left> %d, <right> %d", (Int)len, (Int)LEN_PLIST(vecR), "you can replace vector <right> via 'return <right>;'"); return CALL_2ARGS(AddRowVectorOp, vecL, vecR); } /* check the fields */ fld = FLD_FFE(ELM_PLIST(vecL, 1)); if (FLD_FFE(ELM_PLIST(vecR, 1)) != fld) { /* check the characteristic */ if (CHAR_FF(fld) == CHAR_FF(FLD_FFE(ELM_PLIST(vecR, 1)))) return TRY_NEXT_METHOD; vecR = ErrorReturnObj( "AddRowVector: vectors have different fields", 0L, 0L, "you can replace vector <right> via 'return <right>;'"); return CALL_2ARGS(AddRowVectorOp, vecL, vecR); } succ = SUCC_FF(fld); ptrL = ADDR_OBJ(vecL); ptrR = ADDR_OBJ(vecR); for (i = 1; i <= len; i++) { valL = VAL_FFE(ptrL[i]); valR = VAL_FFE(ptrR[i]); valS = SUM_FFV(valL, valR, succ); ptrL[i] = NEW_FFE(fld, valS); } return (Obj) 0; }
/**************************************************************************** ** *F PostRestore( <module> ) . . . . . . . . . . . . . after restore workspace */ static Int PostRestore ( StructInitInfo * module ) { /* make the list of names of record names */ CountRNam = LEN_PLIST(NamesRNam); /* make the hash list of record names */ SizeRNam = LEN_PLIST(HashRNam); /* return success */ return 0; }
/**************************************************************************** ** *F ProdVecFFEVecFFE(<vecL>,<vecR>) . . . . . . . . . product of two vectors ** ** 'ProdVecFFEVecFFE' returns the product of the two vectors <vecL> and ** <vecR>. The product is the sum of the products of the corresponding ** elements of the two lists. ** ** 'ProdVecFFEVecFFE' is an improved version of 'ProdListList', which does ** not call 'PROD'. */ Obj ProdVecFFEVecFFE ( Obj vecL, Obj vecR ) { FFV valP; /* one product */ FFV valS; /* sum of the products */ Obj * ptrL; /* pointer into the left operand */ FFV valL; /* one element of left operand */ Obj * ptrR; /* pointer into the right operand */ FFV valR; /* one element of right operand */ UInt lenL, lenR, len; /* length */ UInt i; /* loop variable */ FF fld; /* finite field */ FF * succ; /* successor table */ /* check the lengths */ lenL = LEN_PLIST(vecL); lenR = LEN_PLIST(vecR); len = (lenL < lenR) ? lenL : lenR; /* check the fields */ fld = FLD_FFE(ELM_PLIST(vecL, 1)); if (FLD_FFE(ELM_PLIST(vecR, 1)) != fld) { /* check the characteristic */ if (CHAR_FF(fld) == CHAR_FF(FLD_FFE(ELM_PLIST(vecR, 1)))) return ProdListList(vecL, vecR); vecR = ErrorReturnObj( "Vector *: vectors have different fields", 0L, 0L, "you can replace vector <right> via 'return <right>;'"); return PROD(vecL, vecR); } /* to add we need the successor table */ succ = SUCC_FF(fld); /* loop over the elements and add */ valS = (FFV)0; ptrL = ADDR_OBJ(vecL); ptrR = ADDR_OBJ(vecR); for (i = 1; i <= len; i++) { valL = VAL_FFE(ptrL[i]); valR = VAL_FFE(ptrR[i]); valP = PROD_FFV(valL, valR, succ); valS = SUM_FFV(valS, valP, succ); } /* return the result */ return NEW_FFE(fld, valS); }
UInt completion_rnam ( Char * name, UInt len ) { const Char * curr; const Char * next; UInt i, k; const UInt countRNam = LEN_PLIST(NamesRNam); next = 0; for ( i = 1; i <= countRNam; i++ ) { curr = CONST_CSTR_STRING( NAME_RNAM( i ) ); for ( k = 0; name[k] != 0 && curr[k] == name[k]; k++ ) ; if ( k < len || curr[k] <= name[k] ) continue; if ( next != 0 ) { for ( k = 0; curr[k] != '\0' && curr[k] == next[k]; k++ ) ; if ( k < len || next[k] < curr[k] ) continue; } next = curr; } if ( next != 0 ) { for ( k = 0; next[k] != '\0'; k++ ) name[k] = next[k]; name[k] = '\0'; } return next != 0; }
/**************************************************************************** * real_roots of polynomial (in increasing degree) ****************************************************************************/ static Obj REAL_ROOTS (Obj self, Obj coeffs) { Obj result; Int i, numroots; int degree = LEN_PLIST(coeffs)-1; Cdouble opr[degree+1], zeror[degree], zeroi[degree]; if (degree < 1) return Fail; for (i = 0; i <= degree; i++) { opr[degree-i] = VAL_FLOAT(ELM_PLIST(coeffs,i+1)); if (isnan(opr[degree-i])) return Fail; } rpoly (opr, °ree, zeror, zeroi); numroots = degree; if (numroots < 0) return Fail; result = ALLOC_PLIST(numroots); for (i = 1; i <= numroots; i++) { if (zeroi[i-1] == 0.0) set_elm_plist(result,i, NEW_FLOAT(zeror[i-1])); else { Obj t = ALLOC_PLIST(2); set_elm_plist(t,1, NEW_FLOAT(zeror[i-1])); set_elm_plist(t,2, NEW_FLOAT(zeroi[i-1])); set_elm_plist(result,i, t); } } return result; }
/* handler for function 5 */ static Obj HdlrFunc5 ( Obj self, Obj args ) { Obj a_a; Obj a_b; Obj t_1 = 0; Obj t_2 = 0; Obj t_3 = 0; Obj t_4 = 0; Bag oldFrame; CHECK_NR_AT_LEAST_ARGS( 2, args ) a_a = ELM_PLIST( args, 1 ); Obj x_temp_range = Range2Check(INTOBJ_INT(2), INTOBJ_INT(LEN_PLIST(args))); a_b = ELMS_LIST(args , x_temp_range); /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); /* Print( "f4:", a, ":", b, "\n" ); */ t_1 = GF_Print; t_2 = MakeString( "f4:" ); t_3 = MakeString( ":" ); t_4 = MakeString( "\n" ); CALL_5ARGS( t_1, t_2, a_a, t_3, a_b, t_4 ); /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
Obj FuncSMALLEST_FIELD_VECFFE( Obj self, Obj vec) { Obj elm; UInt deg, deg1, deg2, i, len, p, q; UInt isVecFFE = IsVecFFE(vec); len = LEN_PLIST(vec); if (len == 0) return Fail; elm = ELM_PLIST(vec, 1); if (!isVecFFE && !IS_FFE(elm)) return Fail; deg = DegreeFFE(elm); p = CharFFE(elm); for (i = 2; i <= len; i++) { elm = ELM_PLIST(vec, i); if (!isVecFFE && (!IS_FFE(elm) || CharFFE(elm) != p)) return Fail; deg2 = DegreeFFE(elm); deg1 = deg; while (deg % deg2 != 0) deg += deg1; } q = p; for (i = 2; i <= deg; i++) q *= p; return INTOBJ_INT(q); }
Int IsSet ( Obj list ) { Int isSet; /* result */ /* if <list> is a plain list */ if ( IS_PLIST( list ) ) { /* if <list> is the empty list, its a set (:-) */ if ( LEN_PLIST(list) == 0 ) { SET_FILT_LIST( list, FN_IS_EMPTY ); isSet = 1; } /* if <list> strictly sorted, its a set */ else if ( IS_SSORT_LIST(list) ) { isSet = 1; } /* otherwise it is not a set */ else { isSet = 0; } } /* if it is another small list */ else if ( IS_SMALL_LIST(list) ) { /* if <list> is the empty list, its a set (:-) */ if ( LEN_LIST(list) == 0 ) { PLAIN_LIST( list ); SET_FILT_LIST( list, FN_IS_EMPTY ); isSet = 1; } /* if <list> strictly sorted, its a set */ else if ( IS_SSORT_LIST(list) ) { PLAIN_LIST( list ); /* SET_FILT_LIST( list, FN_IS_HOMOG ); */ SET_FILT_LIST( list, FN_IS_SSORT ); isSet = 1; } /* otherwise it is not a set */ else { isSet = 0; } } /* otherwise it is certainly not a set */ else { isSet = 0; } /* return the result */ return isSet; }
static inline void PushObj(Obj obj) { Obj stack = TLS(SerializationStack); UInt len = LEN_PLIST(stack); len++; GROW_PLIST(stack, len); SET_LEN_PLIST(stack, len); SET_ELM_PLIST(stack, len, obj); }
static inline Obj PopObj(void) { Obj stack = TLS(SerializationStack); UInt len = LEN_PLIST(stack); Obj result = ELM_PLIST(stack, len); SET_ELM_PLIST(stack, len, (Obj) 0); len--; SET_LEN_PLIST(stack, len); return result; }
static inline Obj PopObj(void) { Obj stack = MODULE_STATE(Serialize).stack; UInt len = LEN_PLIST(stack); Obj result = ELM_PLIST(stack, len); SET_ELM_PLIST(stack, len, (Obj)0); len--; SET_LEN_PLIST(stack, len); return result; }
/**************************************************************************** ** *F DiffVecFFEFFE(<vecL>,<elmR>) difference of a vector and a fin field elm ** ** 'DiffVecFFEFFE' returns the difference of the vector <vecL> and the ** finite field element <elmR>. The difference is a list, where each ** element is the difference of <elmR> and the corresponding element of ** <vecL>. ** ** 'DiffVecFFEFFE' is an improved version of 'DiffListScl', which does not ** call 'DIFF'. */ Obj DiffVecFFEFFE ( Obj vecL, Obj elmR ) { Obj vecD; /* handle of the difference */ Obj * ptrD; /* pointer into the difference */ FFV valD; /* the value of a difference */ Obj * ptrL; /* pointer into the left operand */ FFV valL; /* the value of an element in vecL */ UInt len; /* length */ UInt i; /* loop variable */ FF fld; /* finite field */ FF * succ; /* successor table */ FFV valR; /* the value of elmR */ /* get the field and check that vecL and elmR have the same field */ fld = FLD_FFE(ELM_PLIST(vecL, 1)); if (FLD_FFE(elmR) != fld) { /* check the characteristic */ if (CHAR_FF(fld) == CHAR_FF(FLD_FFE(elmR))) return DiffListScl(vecL, elmR); elmR = ErrorReturnObj( "<vec>-<elm>: <elm> and <vec> must belong to the same finite field", 0L, 0L, "you can replace <elm> via 'return <elm>;'"); return DIFF(vecL, elmR); } /* make the result list */ len = LEN_PLIST(vecL); vecD = NEW_PLIST(IS_MUTABLE_OBJ(vecL) ? T_PLIST_FFE : T_PLIST_FFE + IMMUTABLE, len); SET_LEN_PLIST(vecD, len); /* to subtract we need the successor table */ succ = SUCC_FF(fld); /* loop over the elements and subtract */ valR = VAL_FFE(elmR); valR = NEG_FFV(valR, succ); ptrL = ADDR_OBJ(vecL); ptrD = ADDR_OBJ(vecD); for (i = 1; i <= len; i++) { valL = VAL_FFE(ptrL[i]); valD = SUM_FFV(valL, valR, succ); ptrD[i] = NEW_FFE(fld, valD); } /* return the result */ return vecD; }
/**************************************************************************** ** *F SumFFEVecFFE(<elmL>,<vecR>) . . . . sum of an fin field elm and a vector ** ** 'SumFFEVecFFE' returns the sum of the fin field elm <elmL> and the vector ** <vecR>. The sum is a list, where each element is the sum of <elmL> and ** the corresponding element of <vecR>. ** ** 'SumFFEVecFFE' is an improved version of 'SumSclList', which does not ** call 'SUM'. */ Obj SumFFEVecFFE ( Obj elmL, Obj vecR ) { Obj vecS; /* handle of the sum */ Obj * ptrS; /* pointer into the sum */ FFV valS; /* the value of a sum */ Obj * ptrR; /* pointer into the right operand */ FFV valR; /* the value of an element in vecR */ UInt len; /* length */ UInt i; /* loop variable */ FF fld; /* finite field */ FF * succ; /* successor table */ FFV valL; /* the value of elmL */ /* get the field and check that elmL and vecR have the same field */ fld = FLD_FFE(ELM_PLIST(vecR, 1)); if (FLD_FFE(elmL) != fld) { /* check the characteristic */ if (CHAR_FF(fld) == CHAR_FF(FLD_FFE(elmL))) return SumSclList(elmL, vecR); elmL = ErrorReturnObj( "<elm>+<vec>: <elm> and <vec> must belong to the same finite field", 0L, 0L, "you can replace <elm> via 'return <elm>;'"); return SUM(elmL, vecR); } /* make the result list */ len = LEN_PLIST(vecR); vecS = NEW_PLIST(IS_MUTABLE_OBJ(vecR) ? T_PLIST_FFE : T_PLIST_FFE + IMMUTABLE, len); SET_LEN_PLIST(vecS, len); /* to add we need the successor table */ succ = SUCC_FF(fld); /* loop over the elements and add */ valL = VAL_FFE(elmL); ptrR = ADDR_OBJ(vecR); ptrS = ADDR_OBJ(vecS); for (i = 1; i <= len; i++) { valR = VAL_FFE(ptrR[i]); valS = SUM_FFV(valL, valR, succ); ptrS[i] = NEW_FFE(fld, valS); } /* return the result */ return vecS; }
/**************************************************************************** ** *F iscomplete( <name>, <len> ) . . . . . . . . find the completions of name *F completion( <name>, <len> ) . . . . . . . . find the completions of name */ UInt iscomplete_rnam ( Char * name, UInt len ) { const Char * curr; UInt i, k; const UInt countRNam = LEN_PLIST(NamesRNam); for ( i = 1; i <= countRNam; i++ ) { curr = CONST_CSTR_STRING( NAME_RNAM( i ) ); for ( k = 0; name[k] != 0 && curr[k] == name[k]; k++ ) ; if ( k == len && curr[k] == '\0' ) return 1; } return 0; }
static Obj FuncALL_RNAMES(Obj self) { Obj copy, s; UInt i; Obj name; const UInt countRNam = LEN_PLIST(NamesRNam); copy = NEW_PLIST_IMM( T_PLIST, countRNam ); for ( i = 1; i <= countRNam; i++ ) { name = NAME_RNAM( i ); s = CopyToStringRep(name); SET_ELM_PLIST( copy, i, s ); } SET_LEN_PLIST( copy, countRNam ); return copy; }
Obj ZeroVecFFE( Obj vec ) { UInt i, len; Obj res; Obj z; assert(TNUM_OBJ(vec) >= T_PLIST_FFE && \ TNUM_OBJ(vec) <= T_PLIST_FFE + IMMUTABLE); len = LEN_PLIST(vec); assert(len); res = NEW_PLIST(TNUM_OBJ(vec), len); SET_LEN_PLIST(res, len); z = ZERO(ELM_PLIST(vec, 1)); for (i = 1; i <= len; i++) SET_ELM_PLIST(res, i, z); return res; }
/**************************************************************************** ** *F FuncNameRNam(<self>,<rnam>) . . . . convert a record name to a string ** ** 'FuncNameRNam' implements the internal function 'NameRName'. ** ** 'NameRName( <rnam> )' ** ** 'NameRName' returns the string corresponding to the record name <rnam>. */ static Obj FuncNameRNam(Obj self, Obj rnam) { Obj name; Obj oname; const UInt countRNam = LEN_PLIST(NamesRNam); while ( ! IS_INTOBJ(rnam) || INT_INTOBJ(rnam) <= 0 || countRNam < INT_INTOBJ(rnam) ) { rnam = ErrorReturnObj( "NameRName: <rnam> must be a record name (not a %s)", (Int)TNAM_OBJ(rnam), 0L, "you can replace <rnam> via 'return <rnam>;'" ); } oname = NAME_RNAM( INT_INTOBJ(rnam) ); name = CopyToStringRep(oname); return name; }
static Obj COMPLEX_ROOTS (Obj self, Obj coeffs) { Obj result; Int i, numroots, degree = LEN_PLIST(coeffs)-1; xcomplex op[degree+1], zero[degree]; if (degree < 1) return Fail; for (i = 0; i <= degree; i++) { __real__(op)[degree-i] = VAL_FLOAT(ELM_PLIST(ELM_PLIST(coeffs,i+1),1)); __imag__(op)[degree-i] = VAL_FLOAT(ELM_PLIST(ELM_PLIST(coeffs,i+1),2)); if (isnan(__real__(op)[degree-i]) || isnan(__imag__(op)[degree-i])) return Fail; } #ifdef DEBUG_COMPLEX_ROOTS fprintf(stderr,"coeffs"); for (i = 0; i <= degree; i++) fprintf(stderr," %g+I*%g",(double)opr[i],(double)opi[i]); /* __asm__ __volatile__ ("int3"); */ fprintf(stderr,"\n"); #endif numroots = cpoly (degree, op, zero); if (numroots == -1) return Fail; #ifdef DEBUG_COMPLEX_ROOTS fprintf(stderr,"roots"); for (i = 0; i < numroots; i++) fprintf(stderr," %g+I*%g",__real__(zero)[i],__imag__(zero)[i]); fprintf(stderr,"\n"); #endif result = ALLOC_PLIST(numroots); for (i = 1; i <= numroots; i++) { Obj t = ALLOC_PLIST(2); set_elm_plist(t,1, NEW_FLOAT(__real__(zero)[i-1])); set_elm_plist(t,2, NEW_FLOAT(__imag__(zero)[i-1])); set_elm_plist(result,i, t); } return result; }
void AddIn( Obj list, Obj w, Obj e ) { Int g, i; Obj r, s, t; for( i = 1; i < LEN_PLIST(w); i += 2 ) { g = INT_INTOBJ( ELM_PLIST( w, i ) ); s = ELM_PLIST( w, i+1 ); C_PROD_FIA( t, s, e ); /* t = s * e */ r = ELM_PLIST( list, g ); C_SUM_FIA( s, t, r ); /* s = r + s * e */ SET_ELM_PLIST( list, g, s ); CHANGED_BAG( list ); } }
static Obj FIND_BARYCENTER (Obj self, Obj gap_points, Obj gap_init, Obj gap_iter, Obj gap_tol) { #ifdef MALLOC_HACK old_malloc_hook = __malloc_hook; old_free_hook = __free_hook; __malloc_hook = my_malloc_hook; __free_hook = my_free_hook; #endif UInt i, j, n = LEN_PLIST(gap_points); Double __points[n][3]; bparams bparam = { n, __points }; for (i = 0; i < n; i++) for (j = 0; j < 3; j++) bparam.points[i][j] = VAL_FLOAT(ELM_PLIST(ELM_PLIST(gap_points,i+1),j+1)); const gsl_multiroot_fsolver_type *T; gsl_multiroot_fsolver *s; int status; size_t iter = 0, max_iter = INT_INTOBJ(gap_iter); double precision = VAL_FLOAT(gap_tol); gsl_multiroot_function f = {&barycenter, 3, &bparam}; gsl_vector *x = gsl_vector_alloc (3); for (i = 0; i < 3; i++) gsl_vector_set (x, i, VAL_FLOAT(ELM_PLIST(gap_init,i+1))); T = gsl_multiroot_fsolver_hybrids; s = gsl_multiroot_fsolver_alloc (T, 3); gsl_multiroot_fsolver_set (s, &f, x); do { iter++; status = gsl_multiroot_fsolver_iterate (s); if (status) /* check if solver is stuck */ break; status = gsl_multiroot_test_residual (s->f, precision); } while (status == GSL_CONTINUE && iter < max_iter); Obj result = ALLOC_PLIST(2); Obj list = ALLOC_PLIST(3); set_elm_plist(result, 1, list); for (i = 0; i < 3; i++) set_elm_plist(list, i+1, NEW_FLOAT(gsl_vector_get (s->x, i))); list = ALLOC_PLIST(3); set_elm_plist(result, 2, list); for (i = 0; i < 3; i++) set_elm_plist(list, i+1, NEW_FLOAT(gsl_vector_get (s->f, i))); gsl_multiroot_fsolver_free (s); gsl_vector_free (x); if (status != 0) { const char *s = gsl_strerror (status); C_NEW_STRING(result, strlen(s), s); } #ifdef MALLOC_HACK __malloc_hook = old_malloc_hook; __free_hook = old_free_hook; #endif return result; }
/**************************************************************************** ** *F ProdVectorMatrix(<vecL>,<vecR>) . . . . product of a vector and a matrix ** ** 'ProdVectorMatrix' returns the product of the vector <vecL> and the matrix ** <vecR>. The product is the sum of the rows of <vecR>, each multiplied by ** the corresponding entry of <vecL>. ** ** 'ProdVectorMatrix' is an improved version of 'ProdListList', which does ** not call 'PROD' and also accumulates the sum into one fixed vector ** instead of allocating a new for each product and sum. */ Obj ProdVecFFEMatFFE ( Obj vecL, Obj matR ) { Obj vecP; /* handle of the product */ Obj * ptrP; /* pointer into the product */ FFV * ptrV; /* value pointer into the product */ FFV valP; /* one value of the product */ FFV valL; /* one value of the left operand */ Obj vecR; /* one vector of the right operand */ Obj * ptrR; /* pointer into the right vector */ FFV valR; /* one value from the right vector */ UInt len; /* length */ UInt col; /* length of the rows in matR */ UInt i, k; /* loop variables */ FF fld; /* the common finite field */ FF * succ; /* the successor table */ /* check the lengths */ len = LEN_PLIST(vecL); col = LEN_PLIST(ELM_PLIST(matR, 1)); if (len != LEN_PLIST(matR)) { matR = ErrorReturnObj( "<vec>*<mat>: <vec> (%d) must have the same length as <mat> (%d)", (Int)len, (Int)col, "you can replace matrix <mat> via 'return <mat>;'"); return PROD(vecL, matR); } /* check the fields */ vecR = ELM_PLIST(matR, 1); fld = FLD_FFE(ELM_PLIST(vecL, 1)); if (FLD_FFE(ELM_PLIST(vecR, 1)) != fld) { /* check the characteristic */ if (CHAR_FF(fld) == CHAR_FF(FLD_FFE(ELM_PLIST(vecR, 1)))) return ProdListList(vecL, matR); matR = ErrorReturnObj( "<vec>*<mat>: <vec> and <mat> have different fields", 0L, 0L, "you can replace matrix <mat> via 'return <mat>;'"); return PROD(vecL, matR); } /* make the result list by multiplying the first entries */ vecP = ProdFFEVecFFE(ELM_PLIST(vecL, 1), vecR); /* to add we need the successor table */ succ = SUCC_FF(fld); /* convert vecP into a list of values */ /*N 5Jul1998 werner: This only works if sizeof(FFV) <= sizeof(Obj) */ /*N We have to be careful not to overwrite the length info */ ptrP = ADDR_OBJ(vecP); ptrV = ((FFV*)(ptrP + 1)) - 1; for (k = 1; k <= col; k++) ptrV[k] = VAL_FFE(ptrP[k]); /* loop over the other entries and multiply */ for (i = 2; i <= len; i++) { valL = VAL_FFE(ELM_PLIST(vecL, i)); vecR = ELM_PLIST(matR, i); ptrR = ADDR_OBJ(vecR); if (valL == (FFV)1) { for (k = 1; k <= col; k++) { valR = VAL_FFE(ptrR[k]); valP = ptrV[k]; ptrV[k] = SUM_FFV(valP, valR, succ); } } else if (valL != (FFV)0) { for (k = 1; k <= col; k++) { valR = VAL_FFE(ptrR[k]); valR = PROD_FFV(valL, valR, succ); valP = ptrV[k]; ptrV[k] = SUM_FFV(valP, valR, succ); } } } /* convert vecP back into a list of finite field elements */ /*N 5Jul1998 werner: This only works if sizeof(FFV) <= sizeof(Obj) */ /*N We have to be careful not to overwrite the length info */ for (k = col; k >= 1; k--) ptrP[k] = NEW_FFE(fld, ptrV[k]); /* return the result */ return vecP; }
Obj FuncAddRowVectorVecFFEsMult( Obj self, Obj vecL, Obj vecR, Obj mult ) { Obj *ptrL; Obj *ptrR; FFV valM; FFV valS; FFV valL; FFV valR; FF fld; FFV *succ; UInt len; UInt xtype; UInt i; if (TNUM_OBJ(mult) != T_FFE) return TRY_NEXT_METHOD; if (VAL_FFE(mult) == 0) return (Obj) 0; xtype = KTNumPlist(vecL, (Obj *) 0); if (xtype != T_PLIST_FFE && xtype != T_PLIST_FFE + IMMUTABLE) return TRY_NEXT_METHOD; xtype = KTNumPlist(vecR, (Obj *) 0); if (xtype != T_PLIST_FFE && xtype != T_PLIST_FFE + IMMUTABLE) return TRY_NEXT_METHOD; /* check the lengths */ len = LEN_PLIST(vecL); if (len != LEN_PLIST(vecR)) { vecR = ErrorReturnObj( "AddRowVector: vector lengths differ <left> %d, <right> %d", (Int)len, (Int)LEN_PLIST(vecR), "you can replace vector <right> via 'return <right>;'"); return CALL_3ARGS(AddRowVectorOp, vecL, vecR, mult); } /* check the fields */ fld = FLD_FFE(ELM_PLIST(vecL, 1)); if (FLD_FFE(ELM_PLIST(vecR, 1)) != fld) { /* check the characteristic */ if (CHAR_FF(fld) == CHAR_FF(FLD_FFE(ELM_PLIST(vecR, 1)))) return TRY_NEXT_METHOD; vecR = ErrorReturnObj( "AddRowVector: vectors have different fields", 0L, 0L, "you can replace vector <right> via 'return <right>;'"); return CALL_3ARGS(AddRowVectorOp, vecL, vecR, mult); } /* Now check the multiplier field */ if (FLD_FFE(mult) != fld) { /* check the characteristic */ if (CHAR_FF(fld) != CHAR_FF(FLD_FFE(mult))) { mult = ErrorReturnObj( "AddRowVector: <multiplier> has different field", 0L, 0L, "you can replace <multiplier> via 'return <multiplier>;'"); return CALL_3ARGS(AddRowVectorOp, vecL, vecR, mult); } /* if the multiplier is over a non subfield then redispatch */ if ((DEGR_FF(fld) % DegreeFFE(mult)) != 0) return TRY_NEXT_METHOD; /* otherwise it's a subfield, so promote it */ valM = VAL_FFE(mult); if (valM != 0) valM = 1 + (valM - 1) * (SIZE_FF(fld) - 1) / (SIZE_FF(FLD_FFE(mult)) - 1); } else valM = VAL_FFE(mult); succ = SUCC_FF(fld); ptrL = ADDR_OBJ(vecL); ptrR = ADDR_OBJ(vecR); /* two versions of the loop to avoid multipling by 1 */ if (valM == 1) for (i = 1; i <= len; i++) { valL = VAL_FFE(ptrL[i]); valR = VAL_FFE(ptrR[i]); valS = SUM_FFV(valL, valR, succ); ptrL[i] = NEW_FFE(fld, valS); } else for (i = 1; i <= len; i++) { valL = VAL_FFE(ptrL[i]); valR = VAL_FFE(ptrR[i]); valS = PROD_FFV(valR, valM, succ); valS = SUM_FFV(valL, valS, succ); ptrL[i] = NEW_FFE(fld, valS); } return (Obj) 0; }
Obj FuncMultRowVectorVecFFEs( Obj self, Obj vec, Obj mult ) { Obj *ptr; FFV valM; FFV valS; FFV val; FF fld; FFV *succ; UInt len; UInt xtype; UInt i; if (TNUM_OBJ(mult) != T_FFE) return TRY_NEXT_METHOD; if (VAL_FFE(mult) == 1) return (Obj) 0; xtype = KTNumPlist(vec, (Obj *) 0); if (xtype != T_PLIST_FFE && xtype != T_PLIST_FFE + IMMUTABLE) return TRY_NEXT_METHOD; /* check the lengths */ len = LEN_PLIST(vec); fld = FLD_FFE(ELM_PLIST(vec, 1)); /* Now check the multiplier field */ if (FLD_FFE(mult) != fld) { /* check the characteristic */ if (CHAR_FF(fld) != CHAR_FF(FLD_FFE(mult))) { mult = ErrorReturnObj( "MultRowVector: <multiplier> has different field", 0L, 0L, "you can replace <multiplier> via 'return <multiplier>;'"); return CALL_2ARGS(MultRowVectorOp, vec, mult); } /* if the multiplier is over a non subfield then redispatch */ if ((DEGR_FF(fld) % DegreeFFE(mult)) != 0) return TRY_NEXT_METHOD; /* otherwise it's a subfield, so promote it */ valM = VAL_FFE(mult); if (valM != 0) valM = 1 + (valM - 1) * (SIZE_FF(fld) - 1) / (SIZE_FF(FLD_FFE(mult)) - 1); } else valM = VAL_FFE(mult); succ = SUCC_FF(fld); ptr = ADDR_OBJ(vec); /* two versions of the loop to avoid multipling by 0 */ if (valM == 0) { Obj z; z = NEW_FFE(fld, 0); for (i = 1; i <= len; i++) { ptr[i] = z; } } else for (i = 1; i <= len; i++) { val = VAL_FFE(ptr[i]); valS = PROD_FFV(val, valM, succ); ptr[i] = NEW_FFE(fld, valS); } return (Obj) 0; }
UInt RNamNameWithLen(const Char * name, UInt len) { Obj rnam; /* record name (as imm intobj) */ UInt pos; /* hash position */ Char namx [1024]; /* temporary copy of <name> */ Obj string; /* temporary string object <name> */ Obj table; /* temporary copy of <HashRNam> */ Obj rnam2; /* one element of <table> */ UInt i; /* loop variable */ UInt sizeRNam; if (len > 1023) { // Note: We can't pass 'name' here, as it might get moved by garbage collection ErrorQuit("Record names must consist of at most 1023 characters", 0, 0); } /* start looking in the table at the following hash position */ const UInt hash = HashString( name, len ); #ifdef HPCGAP HPC_LockNames(0); /* try a read lock first */ #endif /* look through the table until we find a free slot or the global */ sizeRNam = LEN_PLIST(HashRNam); pos = (hash % sizeRNam) + 1; while ( (rnam = ELM_PLIST( HashRNam, pos )) != 0 && !EqString( NAME_RNAM( INT_INTOBJ(rnam) ), name, len ) ) { pos = (pos % sizeRNam) + 1; } if (rnam != 0) { #ifdef HPCGAP HPC_UnlockNames(); #endif return INT_INTOBJ(rnam); } #ifdef HPCGAP if (!PreThreadCreation) { HPC_UnlockNames(); /* switch to a write lock */ HPC_LockNames(1); /* look through the table until we find a free slot or the global */ sizeRNam = LEN_PLIST(HashRNam); pos = (hash % sizeRNam) + 1; while ( (rnam = ELM_PLIST( HashRNam, pos )) != 0 && !EqString( NAME_RNAM( INT_INTOBJ(rnam) ), name, len ) ) { pos = (pos % sizeRNam) + 1; } } if (rnam != 0) { HPC_UnlockNames(); return INT_INTOBJ(rnam); } #endif /* if we did not find the global variable, make a new one and enter it */ /* (copy the name first, to avoid a stale pointer in case of a GC) */ memcpy( namx, name, len ); namx[len] = 0; string = MakeImmString(namx); const UInt countRNam = PushPlist(NamesRNam, string); rnam = INTOBJ_INT(countRNam); SET_ELM_PLIST( HashRNam, pos, rnam ); /* if the table is too crowded, make a larger one, rehash the names */ if ( sizeRNam < 3 * countRNam / 2 ) { table = HashRNam; sizeRNam = 2 * sizeRNam + 1; HashRNam = NEW_PLIST( T_PLIST, sizeRNam ); SET_LEN_PLIST( HashRNam, sizeRNam ); #ifdef HPCGAP /* The list is briefly non-public, but this is safe, because * the mutex protects it from being accessed by other threads. */ MakeBagPublic(HashRNam); #endif for ( i = 1; i <= (sizeRNam-1)/2; i++ ) { rnam2 = ELM_PLIST( table, i ); if ( rnam2 == 0 ) continue; string = NAME_RNAM( INT_INTOBJ(rnam2) ); pos = HashString( CONST_CSTR_STRING( string ), GET_LEN_STRING( string) ); pos = (pos % sizeRNam) + 1; while ( ELM_PLIST( HashRNam, pos ) != 0 ) { pos = (pos % sizeRNam) + 1; } SET_ELM_PLIST( HashRNam, pos, rnam2 ); } } #ifdef HPCGAP HPC_UnlockNames(); #endif /* return the record name */ return INT_INTOBJ(rnam); }
template<class Z> Obj dofplll(Obj gapmat, Obj lllargs, Obj svpargs) { if (!IS_PLIST(gapmat)) return INTOBJ_INT(-1); Int numrows = LEN_PLIST(gapmat), numcols = -1; for (int i = 1; i <= numrows; i++) { Obj row = ELM_PLIST(gapmat,i); if (numcols == -1) numcols = LEN_PLIST(row); if (numcols != LEN_PLIST(row)) return INTOBJ_INT(-1); } if (numcols <= 0) return INTOBJ_INT(-1); ZZ_mat<Z> mat(numrows, numcols); for (int i = 1; i <= numrows; i++) for (int j = 1; j <= numcols; j++) SET_INTOBJ(mat[i-1][j-1], ELM_PLIST(ELM_PLIST(gapmat,i),j)); if (lllargs != Fail) { double delta = 0.99; double eta = 0.51; LLLMethod method = LM_WRAPPER; FloatType floatType = FT_DEFAULT; int precision = 0; int flags = LLL_DEFAULT; if (lllargs != True) { if (!IS_PLIST(lllargs) || LEN_PLIST(lllargs) != 6) return INTOBJ_INT(-20); Obj v = ELM_PLIST(lllargs,1); if (IS_MACFLOAT(v)) delta = VAL_MACFLOAT(v); else if (v != Fail) return INTOBJ_INT(-21); v = ELM_PLIST(lllargs,2); if (IS_MACFLOAT(v)) eta = VAL_MACFLOAT(v); else if (v != Fail) return INTOBJ_INT(-22); v = ELM_PLIST(lllargs,3); if (v == INTOBJ_INT(0)) method = LM_WRAPPER; else if (v == INTOBJ_INT(1)) method = LM_PROVED; else if (v == INTOBJ_INT(2)) method = LM_HEURISTIC; else if (v == INTOBJ_INT(3)) method = LM_FAST; else if (v != Fail) return INTOBJ_INT(-23); v = ELM_PLIST(lllargs,4); if (v == INTOBJ_INT(0)) floatType = FT_DEFAULT; else if (v == INTOBJ_INT(1)) floatType = FT_DOUBLE; else if (v == INTOBJ_INT(2)) floatType = FT_DPE; else if (v == INTOBJ_INT(3)) floatType = FT_MPFR; else if (v != Fail) return INTOBJ_INT(-24); v = ELM_PLIST(lllargs,5); if (IS_INTOBJ(v)) precision = INT_INTOBJ(v); else if (v != Fail) return INTOBJ_INT(-25); v = ELM_PLIST(lllargs,6); if (IS_INTOBJ(v)) flags = INT_INTOBJ(v); else if (v != Fail) return INTOBJ_INT(-26); } int result = lllReduction(mat, delta, eta, method, floatType, precision, flags); if (result != RED_SUCCESS) return INTOBJ_INT(10*result+1); } if (svpargs != Fail) { SVPMethod method = SVPM_PROVED; int flags = SVP_DEFAULT; // __asm__ ("int3"); if (svpargs != True) { if (!IS_PLIST(svpargs) || LEN_PLIST(svpargs) != 2) return INTOBJ_INT(-30); Obj v = ELM_PLIST(svpargs,1); if (v == INTOBJ_INT(0)) method = SVPM_PROVED; else if (v == INTOBJ_INT(1)) method = SVPM_FAST; else if (v != Fail) return INTOBJ_INT(-31); v = ELM_PLIST(svpargs,2); if (IS_INTOBJ(v)) flags = INT_INTOBJ(v); else if (v != Fail) return INTOBJ_INT(-32); } vector<Integer> sol(numrows); IntMatrix svpmat(numrows,numcols); for (int i = 0; i < numrows; i++) for (int j = 0; j < numcols; j++) SET_Z(svpmat[i][j],mat[i][j]); int result = shortestVector(svpmat, sol, method, flags); if (result != RED_SUCCESS) return INTOBJ_INT(10*result+2); Obj gapvec; if (lllargs == Fail) { // return coordinates of shortest vector in mat gapvec = NEW_PLIST(T_PLIST,numrows); SET_LEN_PLIST(gapvec,numrows); for (int i = 1; i <= numrows; i++) { Obj v = GET_INTOBJ(sol[i-1]); SET_ELM_PLIST(gapvec,i,v); } } else { // return shortest vector gapvec = NEW_PLIST(T_PLIST,numcols); SET_LEN_PLIST(gapvec,numcols); for (int i = 1; i <= numcols; i++) { Integer s; s = 0; for (int j = 0; j < numrows; j++) s.addmul(sol[j],svpmat[j][i-1]); Obj v = GET_INTOBJ(s); SET_ELM_PLIST(gapvec,i,v); } } return gapvec; } gapmat = NEW_PLIST(T_PLIST,numrows); SET_LEN_PLIST(gapmat,numrows); for (int i = 1; i <= numrows; i++) { Obj gaprow = NEW_PLIST(T_PLIST,numcols); SET_LEN_PLIST(gaprow,numcols); SET_ELM_PLIST(gapmat,i,gaprow); for (int j = 1; j <= numcols; j++) { Obj v = GET_INTOBJ(mat[i-1][j-1]); SET_ELM_PLIST(gaprow,j,v); } } return gapmat; }
/**************************************************************************** ** *F DiffVecFFEVecFFE(<vecL>,<vecR>) . . . . . . . . difference of two vectors ** ** 'DiffVecFFEVecFFE' returns the difference of the two vectors <vecL> and ** <vecR>. The difference is a new list, where each element is the ** difference of the corresponding elements of <vecL> and <vecR>. ** ** 'DiffVecFFEVecFFE' is an improved version of 'DiffListList', which does ** not call 'DIFF'. */ Obj DiffVecFFEVecFFE ( Obj vecL, Obj vecR ) { Obj vecD; /* handle of the difference */ Obj * ptrD; /* pointer into the difference */ FFV valD; /* one element of difference list */ Obj * ptrL; /* pointer into the left operand */ FFV valL; /* one element of left operand */ Obj * ptrR; /* pointer into the right operand */ FFV valR; /* one element of right operand */ UInt len, lenL, lenR; /* length */ UInt lenmin; UInt i; /* loop variable */ FF fld; /* finite field */ FF * succ; /* successor table */ /* check the lengths */ lenL = LEN_PLIST(vecL); lenR = LEN_PLIST(vecR); if (lenR > lenL) { len = lenR; lenmin = lenL; } else { len = lenL; lenmin = lenR; } /* check the fields */ fld = FLD_FFE(ELM_PLIST(vecL, 1)); if (FLD_FFE(ELM_PLIST(vecR, 1)) != fld) { /* check the characteristic */ if (CHAR_FF(fld) == CHAR_FF(FLD_FFE(ELM_PLIST(vecR, 1)))) return DiffListList(vecL, vecR); vecR = ErrorReturnObj( "Vector -: vectors have different fields", 0L, 0L, "you can replace vector <right> via 'return <right>;'"); return DIFF(vecL, vecR); } /* make the result list */ vecD = NEW_PLIST((IS_MUTABLE_OBJ(vecL) || IS_MUTABLE_OBJ(vecR)) ? T_PLIST_FFE : T_PLIST_FFE + IMMUTABLE, len); SET_LEN_PLIST(vecD, len); /* to subtract we need the successor table */ succ = SUCC_FF(fld); /* loop over the elements and subtract */ ptrL = ADDR_OBJ(vecL); ptrR = ADDR_OBJ(vecR); ptrD = ADDR_OBJ(vecD); for (i = 1; i <= lenmin; i++) { valL = VAL_FFE(ptrL[i]); valR = VAL_FFE(ptrR[i]); valR = NEG_FFV(valR, succ); valD = SUM_FFV(valL, valR, succ); ptrD[i] = NEW_FFE(fld, valD); } if (lenL < lenR) for (; i <= len; i++) { valR = VAL_FFE(ptrR[i]); valD = NEG_FFV(valR, succ); ptrD[i] = NEW_FFE(fld, valD); } else for (; i <= len; i++) ptrD[i] = ptrL[i]; /* return the result */ return vecD; }
Obj CollectPolycyc ( Obj pcp, Obj list, Obj word ) { Int ngens = INT_INTOBJ( CONST_ADDR_OBJ(pcp)[ PC_NUMBER_OF_GENERATORS ] ); Obj commute = CONST_ADDR_OBJ(pcp)[ PC_COMMUTE ]; Obj gens = CONST_ADDR_OBJ(pcp)[ PC_GENERATORS ]; Obj igens = CONST_ADDR_OBJ(pcp)[ PC_INVERSES ]; Obj pow = CONST_ADDR_OBJ(pcp)[ PC_POWERS ]; Obj ipow = CONST_ADDR_OBJ(pcp)[ PC_INVERSEPOWERS ]; Obj exp = CONST_ADDR_OBJ(pcp)[ PC_EXPONENTS ]; Obj wst = CFTLState()->WORD_STACK; Obj west = CFTLState()->WORD_EXPONENT_STACK; Obj sst = CFTLState()->SYLLABLE_STACK; Obj est = CFTLState()->EXPONENT_STACK; Obj conj=0, iconj=0; /*QQ initialize to please compiler */ Int st; Int g, syl, h, hh; Obj e, ee, ge, mge, we, s, t; Obj w, x = (Obj)0, y = (Obj)0; if( LEN_PLIST(word) == 0 ) return (Obj)0; if( LEN_PLIST(list) < ngens ) { ErrorQuit( "vector too short", 0L, 0L ); return (Obj)0; } if( LEN_PLIST(word) % 2 != 0 ) { ErrorQuit( "Length of word odd", 0L, 0L ); return (Obj)0; } st = 0; PUSH_STACK( word, INTOBJ_INT(1) ); while( st > 0 ) { w = ELM_PLIST( wst, st ); syl = INT_INTOBJ( ELM_PLIST( sst, st ) ); g = INT_INTOBJ( ELM_PLIST( w, syl ) ); if( st > 1 && syl==1 && g == GET_COMMUTE(g) ) { /* Collect word^exponent in one go. */ e = ELM_PLIST( west, st ); /* Add in. */ AddIn( list, w, e ); /* Reduce. */ for( h = g; h <= ngens; h++ ) { s = ELM_PLIST( list, h ); if( IS_INT_ZERO( s ) ) continue; y = (Obj)0; if( (e = GET_EXPONENT( h )) != (Obj)0 ) { if( !LtInt( s, e ) ) { t = ModInt( s, e ); SET_ELM_PLIST( list, h, t ); CHANGED_BAG( list ); if( (y = GET_POWER( h )) ) e = QuoInt( s, e ); } else if( LtInt( s, INTOBJ_INT(0) ) ) { t = ModInt( s, e ); SET_ELM_PLIST( list, h, t ); CHANGED_BAG( list ); if( (y = GET_IPOWER( h )) ) { e = QuoInt( s, e ); if( !IS_INT_ZERO( t ) ) e = DiffInt( e, INTOBJ_INT(1) ); e = AInvInt(e); } } } if( y != (Obj)0 ) AddIn( list, y, e ); } st--; } else { if( g == GET_COMMUTE( g ) ) { s = ELM_PLIST( list, g ); t = ELM_PLIST( est, st ); C_SUM_FIA( ge, s, t ); SET_ELM_PLIST( est, st, INTOBJ_INT(0) ); } else { /* Assume that the top of the exponent stack is non-zero. */ e = ELM_PLIST( est, st ); if( LtInt( INTOBJ_INT(0), e ) ) { C_DIFF_FIA( ee, e, INTOBJ_INT(1) ); e = ee; SET_ELM_PLIST( est, st, e ); CHANGED_BAG( est ); conj = CONST_ADDR_OBJ(pcp)[PC_CONJUGATES]; iconj = CONST_ADDR_OBJ(pcp)[PC_INVERSECONJUGATES]; C_SUM_FIA( ge, ELM_PLIST( list, g ), INTOBJ_INT(1) ); } else { C_SUM_FIA( ee, e, INTOBJ_INT(1) ); e = ee; SET_ELM_PLIST( est, st, e ); CHANGED_BAG( est ); conj = CONST_ADDR_OBJ(pcp)[PC_CONJUGATESINVERSE]; iconj = CONST_ADDR_OBJ(pcp)[PC_INVERSECONJUGATESINVERSE]; C_DIFF_FIA( ge, ELM_PLIST( list, g ), INTOBJ_INT(1) ); } } SET_ELM_PLIST( list, g, ge ); CHANGED_BAG( list ); /* Reduce the exponent. We delay putting the power onto the stack until all the conjugates are on the stack. The power is stored in y, its exponent in ge. */ y = (Obj)0; if( (e = GET_EXPONENT( g )) ) { if( !LtInt( ge, e ) ) { mge = ModInt( ge, e ); SET_ELM_PLIST( list, g, mge ); CHANGED_BAG( list ); if( (y = GET_POWER( g )) ) ge = QuoInt( ge, e ); } else if( LtInt( ge, INTOBJ_INT(0) ) ) { mge = ModInt( ge, e ); SET_ELM_PLIST( list, g, mge ); CHANGED_BAG( list ); if( (y = GET_IPOWER( g )) ) { ge = QuoInt( ge, e ); if( !IS_INT_ZERO( mge ) ) ge = DiffInt( ge, INTOBJ_INT(1) ); ge = AInvInt(ge); } } } hh = h = GET_COMMUTE( g ); /* Find the place where we start to collect. */ for( ; h > g; h-- ) { e = ELM_PLIST( list, h ); if( !IS_INT_ZERO(e) ) { if( LtInt( INTOBJ_INT(0), e ) ) { if( GET_CONJ( h, g ) ) break; } else { if( GET_ICONJ( h, g ) ) break; } } } /* Put those onto the stack, if necessary. */ if( h > g || y != (Obj)0 ) for( ; hh > h; hh-- ) { e = ELM_PLIST( list, hh ); if( !IS_INT_ZERO(e) ) { SET_ELM_PLIST( list, hh, INTOBJ_INT(0) ); if( LtInt( INTOBJ_INT(0), e ) ) { x = ELM_PLIST( gens, hh ); } else { x = ELM_PLIST( igens, hh ); C_PROD_FIA( ee, e, INTOBJ_INT(-1) ); e = ee; } PUSH_STACK( x, e ); } } for( ; h > g; h-- ) { e = ELM_PLIST( list, h ); if( !IS_INT_ZERO(e) ) { SET_ELM_PLIST( list, h, INTOBJ_INT(0) ); x = (Obj)0; if( LtInt( INTOBJ_INT(0), e ) ) x = GET_CONJ( h, g ); else x = GET_ICONJ( h, g ); if( x == (Obj)0 ) { if( LtInt( INTOBJ_INT(0), e ) ) x = ELM_PLIST( gens, h ); else x = ELM_PLIST( igens, h ); } if( LtInt( e, INTOBJ_INT(0) ) ) { C_PROD_FIA( ee, e, INTOBJ_INT(-1) ); e = ee; } PUSH_STACK( x, e ); } } if( y != (Obj)0 ) PUSH_STACK( y, ge ); } while( st > 0 && IS_INT_ZERO( ELM_PLIST( est, st ) ) ) { w = ELM_PLIST( wst, st ); syl = INT_INTOBJ( ELM_PLIST( sst, st ) ) + 2; if( syl > LEN_PLIST( w ) ) { we = DiffInt( ELM_PLIST( west, st ), INTOBJ_INT(1) ); if( EqInt( we, INTOBJ_INT(0) ) ) { st--; } else { SET_ELM_PLIST( west, st, we ); SET_ELM_PLIST( sst, st, INTOBJ_INT(1) ); SET_ELM_PLIST( est, st, ELM_PLIST( w, 2 ) ); CHANGED_BAG( west ); CHANGED_BAG( est ); } } else { SET_ELM_PLIST( sst, st, INTOBJ_INT(syl) ); SET_ELM_PLIST( est, st, ELM_PLIST( w, syl+1 )); CHANGED_BAG( est ); } } } return (Obj)0; }
/**************************************************************************** ** *F FuncIS_SUBSET_SET(<self>,<s1>,<s2>) test if a set is a subset of another ** ** 'FuncIS_SUBSET_SET' implements the internal function 'IsSubsetSet'. ** ** 'IsSubsetSet( <set1>, <set2> )' ** ** 'IsSubsetSet' returns 'true' if the set <set2> is a subset of the set ** <set1>, that is if every element of <set2> is also an element of <set1>. ** Either argument may also be a list that is not a proper set, in which ** case 'IsSubsetSet' silently applies 'Set' (see "Set") to it first. */ Obj FuncIS_SUBSET_SET ( Obj self, Obj set1, Obj set2 ) { UInt len1; /* length of the left set */ UInt len2; /* length of the right set */ UInt i1; /* index into the left set */ UInt i2; /* index into the right set */ Obj e1; /* element of left set */ Obj e2; /* element of right set */ UInt pos; /* position */ /* check the arguments, convert to sets if necessary */ while ( ! IS_SMALL_LIST(set1) ) { set1 = ErrorReturnObj( "IsSubsetSet: <set1> must be a small list (not a %s)", (Int)TNAM_OBJ(set1), 0L, "you can replace <set1> via 'return <set1>;'" ); } while ( ! IS_SMALL_LIST(set2) ) { set2 = ErrorReturnObj( "IsSubsetSet: <set2> must be a small list (not a %s)", (Int)TNAM_OBJ(set2), 0L, "you can replace <set2> via 'return <set2>;'" ); } if ( ! IsSet( set1 ) ) set1 = SetList( set1 ); if ( ! IsSet( set2 ) ) set2 = SetList( set2 ); /* special case if the second argument is a set */ if ( IsSet( set2 ) ) { /* get the logical lengths and get the pointer */ len1 = LEN_PLIST( set1 ); len2 = LEN_PLIST( set2 ); i1 = 1; i2 = 1; /* now compare the two sets */ while ( i1 <= len1 && i2 <= len2 && len2 - i2 <= len1 - i1 ) { e1 = ELM_PLIST( set1, i1 ); e2 = ELM_PLIST( set2, i2 ); if ( EQ( e1, e2 ) ) { i1++; i2++; } else if ( LT( e1, e2 ) ) { i1++; } else { break; } } } /* general case */ else { /* first convert the other argument into a proper list */ PLAIN_LIST( set2 ); /* get the logical lengths */ len1 = LEN_PLIST( set1 ); len2 = LEN_PLIST( set2 ); /* loop over the second list and look for every element */ for ( i2 = 1; i2 <= len2; i2++ ) { /* ignore holes */ if ( ELM_PLIST(set2,i2) == 0 ) continue; /* perform the binary search to find the position */ pos = PositionSortedDensePlist( set1, ELM_PLIST(set2,i2) ); /* test if the element was found at position k */ if ( len1<pos || ! EQ(ELM_PLIST(set1,pos),ELM_PLIST(set2,i2)) ) { break; } } } /* return 'true' if every element of <set2> appeared in <set1> */ return ((i2 == len2 + 1) ? True : False); }