Obj FuncKURATOWSKI_OUTER_PLANAR_SUBGRAPH(Obj self, Obj digraph) { Obj res = boyers_planarity_check(digraph, EMBEDFLAGS_OUTERPLANAR, true); return (ELM_PLIST(res, 1) == False ? ELM_PLIST(res, 2) : Fail); }
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); }
Obj FuncPLANAR_EMBEDDING(Obj self, Obj digraph) { Obj res = boyers_planarity_check(digraph, EMBEDFLAGS_PLANAR, true); return (ELM_PLIST(res, 1) == True ? ELM_PLIST(res, 2) : Fail); }
/**************************************************************************** ** *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; }
extern inline Obj NAME_RNAM(UInt rnam) { return ELM_PLIST(NamesRNam, rnam); }
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 RNamName ( const Char * name ) { Obj rnam; /* record name (as imm intobj) */ UInt pos; /* hash position */ UInt len; /* length of name */ 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> */ const Char * p; /* loop variable */ UInt i; /* loop variable */ /* start looking in the table at the following hash position */ pos = 0; len = 0; for ( p = name; *p != '\0'; p++ ) { pos = 65599 * pos + *p; len++; } pos = (pos % SizeRNam) + 1; if(len >= 1023) { // Note: We can't pass 'name' here, as it might get moved by garbage collection ErrorQuit("Record names must consist of less than 1023 characters", 0, 0); } /* look through the table until we find a free slot or the global */ while ( (rnam = ELM_PLIST( HashRNam, pos )) != 0 && strncmp( NAME_RNAM( INT_INTOBJ(rnam) ), name, 1023 ) ) { pos = (pos % SizeRNam) + 1; } /* 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) */ if ( rnam == 0 ) { CountRNam++; rnam = INTOBJ_INT(CountRNam); SET_ELM_PLIST( HashRNam, pos, rnam ); strlcpy( namx, name, sizeof(namx) ); C_NEW_STRING_DYN(string, namx); GROW_PLIST( NamesRNam, CountRNam ); SET_LEN_PLIST( NamesRNam, CountRNam ); SET_ELM_PLIST( NamesRNam, CountRNam, string ); CHANGED_BAG( NamesRNam ); } /* if the table is too crowed, 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 ); for ( i = 1; i <= (SizeRNam-1)/2; i++ ) { rnam2 = ELM_PLIST( table, i ); if ( rnam2 == 0 ) continue; pos = 0; for ( p = NAME_RNAM( INT_INTOBJ(rnam2) ); *p != '\0'; p++ ) { pos = 65599 * pos + *p; } pos = (pos % SizeRNam) + 1; while ( ELM_PLIST( HashRNam, pos ) != 0 ) { pos = (pos % SizeRNam) + 1; } SET_ELM_PLIST( HashRNam, pos, rnam2 ); } } /* return the record name */ return INT_INTOBJ(rnam); }
/**************************************************************************** ** *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; }
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; }
static Obj NFFUNCTION(Obj self, Obj rel, Obj dir, Obj word) { /* word is an integer lists. dir is true/false. rel is a list of lists: square of positive relator+square of negative relator; positions in 1st of letter i; position in 1st of letter -i * if dir=true, replace all (>=1/2)-cyclic occurrences of rel in word by the shorter half * if dir=false, replace all occurrences of the last generator in word by the corresponding bit of rel */ Obj posind = ELM_PLIST(rel,2), negind = ELM_PLIST(rel,3); rel = ELM_PLIST(rel,1); Int n = LEN_PLIST(posind), allocn = n, i = 0, resulti = 0, match = 0, matchlen = 0, j; Obj result = ALLOC_PLIST(allocn); while (i < LEN_PLIST(word)) { /* we produced result[1..resulti] as the compressed version of word[1..i]. additionally, matchlen is maximal such that rel[match..match+matchlen-1] = result[resulti-matchlen+1..resulti] */ i++; Obj wi = ELM_PLIST(word,i); Int vi = INT_INTOBJ(wi); if (dir == False) { if (vi == n) { match = INT_INTOBJ(ELM_PLIST(negind,n)); for (j = 1; j < n; j++) PUSH_LETTER(INT_INTOBJ(ELM_PLIST(rel,j+match))); } else if (vi == -n) { match = INT_INTOBJ(ELM_PLIST(posind,n)); for (j = 1; j < n; j++) PUSH_LETTER(INT_INTOBJ(ELM_PLIST(rel,j+match))); } else PUSH_LETTER(vi); } else { if (resulti && vi == -INT_INTOBJ(ELM_PLIST(result,resulti))) { /* pop letter, and update match */ resulti--; matchlen--; if (matchlen == 0 && resulti) { MATCH_POS(match,INT_INTOBJ(ELM_PLIST(result,resulti))); matchlen = 1; while (resulti > matchlen && ELM_PLIST(result,resulti-matchlen) == ELM_PLIST(rel,match+n-1)) { matchlen++; if (!--match) match = n; } } else match = 0; } else { PUSH_LETTER(vi); if (match && wi == ELM_PLIST(rel,match+matchlen)) { matchlen++; if (matchlen >= (n+1+(match < 2*n))/2) { /* more than half, or exactly half and negatives */ resulti -= matchlen; for (j = n-1; j >= matchlen; j--) PUSH_LETTER(-INT_INTOBJ(ELM_PLIST(rel,j+match))); matchlen = n-matchlen; match = 4*n+1 - (match+n-1); } } else { matchlen = 1; MATCH_POS(match,vi); } } } } SET_LEN_PLIST(result,resulti); return result; }
Obj CollectPolycyc ( Obj pcp, Obj list, Obj word ) { Int ngens = INT_INTOBJ( ADDR_OBJ(pcp)[ PC_NUMBER_OF_GENERATORS ] ); Obj commute = ADDR_OBJ(pcp)[ PC_COMMUTE ]; Obj gens = ADDR_OBJ(pcp)[ PC_GENERATORS ]; Obj igens = ADDR_OBJ(pcp)[ PC_INVERSES ]; Obj pow = ADDR_OBJ(pcp)[ PC_POWERS ]; Obj ipow = ADDR_OBJ(pcp)[ PC_INVERSEPOWERS ]; Obj exp = ADDR_OBJ(pcp)[ PC_EXPONENTS ]; Obj wst = ADDR_OBJ(pcp)[ PC_WORD_STACK ]; Obj west = ADDR_OBJ(pcp)[ PC_WORD_EXPONENT_STACK ]; Obj sst = ADDR_OBJ(pcp)[ PC_SYLLABLE_STACK ]; Obj est = ADDR_OBJ(pcp)[ PC_EXPONENT_STACK ]; Obj conj=0, iconj=0; /*QQ initialize to please compiler */ Int st, bottom = INT_INTOBJ( ADDR_OBJ(pcp)[ PC_STACK_POINTER ] ); 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 = bottom; PUSH_STACK( word, INTOBJ_INT(1) ); while( st > bottom ) { w = ELM_PLIST( wst, st ); syl = INT_INTOBJ( ELM_PLIST( sst, st ) ); g = INT_INTOBJ( ELM_PLIST( w, syl ) ); if( st > bottom+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 ); conj = ADDR_OBJ(pcp)[PC_CONJUGATES]; iconj = 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 ); conj = ADDR_OBJ(pcp)[PC_CONJUGATESINVERSE]; iconj = 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 > bottom && 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 ); } } } ADDR_OBJ(pcp)[ PC_STACK_POINTER ] = INTOBJ_INT( bottom ); return (Obj)0; }
/**************************************************************************** ** *F FuncADD_SET( <self>, <set>, <obj> ) . . . . . . . add an element to a set ** ** 'FuncADD_SET' implements the internal function 'AddSet'. ** ** 'AddSet( <set>, <obj> )' ** ** 'AddSet' adds <obj>, which may be an object of an arbitrary type, to the ** set <set>, which must be a proper set. If <obj> is already an element of ** the set <set>, then <set> is not changed. Otherwise <obj> is inserted at ** the correct position such that <set> is again a set afterwards. ** ** 'AddSet' does not return anything, it is only called for the side effect ** of changing <set>. */ Obj FuncADD_SET ( Obj self, Obj set, Obj obj ) { UInt len; /* logical length of the list */ UInt pos; /* position */ UInt isCyc; /* True if the set being added to consists of kernel cyclotomics */ UInt notpos; /* position of an original element (not the new one) */ UInt wasHom; UInt wasNHom; UInt wasTab; /* check the arguments */ while ( ! IsSet(set) || ! IS_MUTABLE_OBJ(set) ) { set = ErrorReturnObj( "AddSet: <set> must be a mutable proper set (not a %s)", (Int)TNAM_OBJ(set), 0L, "you can replace <set> via 'return <set>;'" ); } len = LEN_LIST(set); /* perform the binary search to find the position */ pos = PositionSortedDensePlist( set, obj ); /* add the element to the set if it is not already there */ if ( len < pos || ! EQ( ELM_PLIST(set,pos), obj ) ) { GROW_PLIST( set, len+1 ); SET_LEN_PLIST( set, len+1 ); { Obj *ptr; ptr = PTR_BAG(set); memmove((void *)(ptr + pos+1),(void*)(ptr+pos),(size_t)(sizeof(Obj)*(len+1-pos))); #if 0 for ( i = len+1; pos < i; i-- ) { *ptr = *(ptr-1); ptr--; */ /* SET_ELM_PLIST( set, i, ELM_PLIST(set,i-1) ); */ } #endif } SET_ELM_PLIST( set, pos, obj ); CHANGED_BAG( set ); /* fix up the type of the result */ if ( HAS_FILT_LIST( set, FN_IS_SSORT ) ) { isCyc = (TNUM_OBJ(set) == T_PLIST_CYC_SSORT); wasHom = HAS_FILT_LIST(set, FN_IS_HOMOG); wasTab = HAS_FILT_LIST(set, FN_IS_TABLE); wasNHom = HAS_FILT_LIST(set, FN_IS_NHOMOG); CLEAR_FILTS_LIST(set); /* the result of addset is always dense */ SET_FILT_LIST( set, FN_IS_DENSE ); /* if the object we added was not mutable then we might be able to conclude more */ if ( ! IS_MUTABLE_OBJ(obj) ) { /* a one element list is automatically homogenous and ssorted */ if (len == 0 ) { if (TNUM_OBJ(obj) <= T_CYC) RetypeBagIfWritable( set, T_PLIST_CYC_SSORT); else { SET_FILT_LIST( set, FN_IS_HOMOG ); SET_FILT_LIST( set, FN_IS_SSORT ); if (IS_HOMOG_LIST(obj)) /* it might be a table */ SET_FILT_LIST( set, FN_IS_TABLE ); } } else { /* Now determine homogeneity */ if (isCyc) if (TNUM_OBJ(obj) <= T_CYC) RetypeBagIfWritable( set, T_PLIST_CYC_SSORT); else { RESET_FILT_LIST(set, FN_IS_HOMOG); SET_FILT_LIST(set, FN_IS_NHOMOG); } else if (wasHom) { if (!SyInitializing) { notpos = (pos == 1) ? 2 : 1; if (FAMILY_OBJ(ELM_PLIST(set,notpos)) == FAMILY_OBJ(obj)) { SET_FILT_LIST(set, FN_IS_HOMOG); if (wasTab) { if (IS_HOMOG_LIST( obj )) SET_FILT_LIST(set, FN_IS_TABLE); } } else SET_FILT_LIST(set, FN_IS_NHOMOG); } } else if (wasNHom) SET_FILT_LIST(set, FN_IS_NHOMOG); } } SET_FILT_LIST( set, FN_IS_SSORT ); } else { CLEAR_FILTS_LIST(set); SET_FILT_LIST( set, FN_IS_DENSE ); } }
/**************************************************************************** ** *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); }