/****************************************************************************
**
*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);
}
