static void AddObjSetNew(Obj set, Obj obj)
{
UInt size = CONST_ADDR_WORD(set)[OBJSET_SIZE];
UInt hash = ObjHash(set, obj);
GAP_ASSERT(TNUM_OBJ(set) == T_OBJSET);
GAP_ASSERT(hash < size);
for (;;) {
Obj current;
current = CONST_ADDR_OBJ(set)[OBJSET_HDRSIZE+hash];
if (!current) {
ADDR_OBJ(set)[OBJSET_HDRSIZE+hash] = obj;
ADDR_WORD(set)[OBJSET_USED]++;
CHANGED_BAG(set);
return;
}
if (current == Undefined) {
ADDR_OBJ(set)[OBJSET_HDRSIZE+hash] = obj;
ADDR_WORD(set)[OBJSET_USED]++;
GAP_ASSERT(ADDR_WORD(set)[OBJSET_DIRTY] >= 1);
ADDR_WORD(set)[OBJSET_DIRTY]--;
CHANGED_BAG(set);
return;
}
hash++;
if (hash >= size)
hash = 0;
}
}
/****************************************************************************
**
*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 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);
}
/****************************************************************************
**
*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;
}
Obj NewPolymakeExternalObject(enum polymake_object_type t) {
Obj o;
o = NewBag(T_POLYMAKE, 2*sizeof(Obj));
switch(t) {
case T_POLYMAKE_EXTERNAL_CONE:
ADDR_OBJ(o)[0] = TheTypeExternalPolymakeCone;
break;
case T_POLYMAKE_EXTERNAL_FAN:
ADDR_OBJ(o)[0] = TheTypeExternalPolymakeFan;
break;
case T_POLYMAKE_EXTERNAL_POLYTOPE:
ADDR_OBJ(o)[0] = TheTypeExternalPolymakePolytope;
break;
case T_POLYMAKE_EXTERNAL_TROPICAL_HYPERSURFACE:
ADDR_OBJ(o)[0] = TheTypeExternalPolymakeTropicalHypersurface;
break;
case T_POLYMAKE_EXTERNAL_TROPICAL_POLYTOPE:
ADDR_OBJ(o)[0] = TheTypeExternalPolymakeTropicalPolytope;
break;
case T_POLYMAKE_EXTERNAL_MATROID:
ADDR_OBJ(o)[0] = TheTypeExternalPolymakeMatroid;
break;
}
ADDR_OBJ(o)[1] = NULL;
return o;
}
void RemoveObjSet(Obj set, Obj obj) {
Int pos = FindObjSet(set, obj);
if (pos >= 0) {
ADDR_OBJ(set)[OBJSET_HDRSIZE+pos] = Undefined;
ADDR_WORD(set)[OBJSET_USED]--;
ADDR_WORD(set)[OBJSET_DIRTY]++;
CHANGED_BAG(set);
CheckObjSetForCleanUp(set, 0);
}
}
/****************************************************************************
**
*F CleanObjWPObjCopy( <obj> ) . . . . . . . . . . . . . . clean WPobj copy
*/
void CleanObjWPObjCopy (
Obj obj )
{
UInt i; /* loop variable */
Obj elm; /* subobject */
/* remove the forwarding pointer */
ADDR_OBJ(obj)[0] = ELM_PLIST( ADDR_OBJ(obj)[0], 1 );
CHANGED_BAG(obj);
/* now it is cleaned */
RetypeBag( obj, TNUM_OBJ(obj) - COPYING );
/* clean the subvalues */
for ( i = 1; i < SIZE_OBJ(obj)/sizeof(Obj); i++ ) {
elm = ADDR_OBJ(obj)[i];
if ( elm != 0 && !IS_WEAK_DEAD_BAG(elm))
CLEAN_OBJ( elm );
}
}
void LoadWPObj( Obj wpobj )
{
UInt len, i;
Obj *ptr;
ptr = ADDR_OBJ(wpobj)+1;
len = LoadUInt();
STORE_LEN_WPOBJ(wpobj, len);
for (i = 1; i <= len; i++)
{
*ptr++ = LoadSubObj();
}
}
Region * NewRegion(void)
{
Region * result;
pthread_rwlock_t * lock;
Obj region_obj;
#ifndef DISABLE_GC
result = GC_malloc(sizeof(Region) + (MAX_THREADS + 1));
lock = GC_malloc_atomic(sizeof(*lock));
GC_register_finalizer(lock, LockFinalizer, NULL, NULL, NULL);
#else
result = calloc(1, sizeof(Region) + (MAX_THREADS + 1));
lock = malloc(sizeof(*lock));
#endif
pthread_rwlock_init(lock, NULL);
region_obj = NewBag(T_REGION, sizeof(Region *));
MakeBagPublic(region_obj);
*(Region **)(ADDR_OBJ(region_obj)) = result;
result->obj = region_obj;
result->lock = lock;
return result;
}
void SaveWPObj( Obj wpobj )
{
UInt len, i;
Obj *ptr;
Obj x;
ptr = ADDR_OBJ(wpobj)+1;
len = STORED_LEN_WPOBJ(wpobj);
SaveUInt(len);
for (i = 1; i <= len; i++)
{
x = *ptr;
if (IS_WEAK_DEAD_BAG(x))
{
SaveSubObj(0);
*ptr = 0;
}
else
SaveSubObj(x);
ptr++;
}
}
Obj CopyObjWPObj (
Obj obj,
Int mut )
{
Obj copy; /* copy, result */
Obj tmp; /* temporary variable */
Obj elm;
UInt i; /* loop variable */
/* make a copy */
if ( mut ) {
copy = NewBag( T_WPOBJ, SIZE_OBJ(obj) );
ADDR_OBJ(copy)[0] = ADDR_OBJ(obj)[0];
}
else {
copy = NewBag( T_PLIST+IMMUTABLE, SIZE_OBJ(obj) );
SET_LEN_PLIST(copy,LengthWPObj(obj));
}
/* leave a forwarding pointer */
tmp = NEW_PLIST( T_PLIST, 2 );
SET_LEN_PLIST( tmp, 2 );
SET_ELM_PLIST( tmp, 1, ADDR_OBJ(obj)[0] );
SET_ELM_PLIST( tmp, 2, copy );
ADDR_OBJ(obj)[0] = tmp;
CHANGED_BAG(obj);
/* now it is copied */
RetypeBag( obj, T_WPOBJ + COPYING );
/* copy the subvalues */
for ( i = SIZE_OBJ(obj)/sizeof(Obj)-1; i > 0; i-- ) {
elm = ADDR_OBJ(obj)[i];
if ( elm != 0 && !IS_WEAK_DEAD_BAG(elm)) {
tmp = COPY_OBJ( elm, mut );
ADDR_OBJ(copy)[i] = tmp;
CHANGED_BAG( copy );
}
}
/* return the copy */
return copy;
}
/****************************************************************************
**
*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;
}
/****************************************************************************
**
*F CopyObjWPObjCopy( <obj>, <mut> ) . . . . . . . . . . . copy a WPobj copy
*/
Obj CopyObjWPObjCopy (
Obj obj,
Int mut )
{
return ELM_PLIST( ADDR_OBJ(obj)[0], 2 );
}
static void MarkObjMap(Obj obj)
{
UInt size = CONST_ADDR_WORD(obj)[OBJSET_SIZE];
MarkArrayOfBags( ADDR_OBJ(obj) + OBJSET_HDRSIZE, 2 * size );
}
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;
}
/* Type object function for the polymake object */
Obj ExternalPolymakeObjectTypeFunc(Obj o) {
return ADDR_OBJ(o)[0];
}
/****************************************************************************
**
*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 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;
}
