/****************************************************************************
* 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);
}
/* handler for function 2 */
static Obj HdlrFunc2 (
Obj self )
{
Obj t_1 = 0;
Bag oldFrame;
OLD_BRK_CURR_STAT
/* allocate new stack frame */
SWITCH_TO_NEW_FRAME(self,0,0,oldFrame);
REM_BRK_CURR_STAT();
SET_BRK_CURR_STAT(0);
/* WITH_IMPS_FLAGS_CACHE := [ ]; */
t_1 = NEW_PLIST( T_PLIST, 0 );
SET_LEN_PLIST( t_1, 0 );
AssGVar( G_WITH__IMPS__FLAGS__CACHE, t_1 );
/* return; */
RES_BRK_CURR_STAT();
SWITCH_TO_OLD_FRAME(oldFrame);
return 0;
/* return; */
RES_BRK_CURR_STAT();
SWITCH_TO_OLD_FRAME(oldFrame);
return 0;
}
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;
}
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;
}
Obj FuncFREXP_MACFLOAT( Obj self, Obj f)
{
int i;
Obj d = NEW_MACFLOAT(frexp (VAL_MACFLOAT(f), &i));
Obj l = NEW_PLIST(T_PLIST,2);
SET_ELM_PLIST(l,1,d);
SET_ELM_PLIST(l,2,INTOBJ_INT(i));
SET_LEN_PLIST(l,2);
return l;
}
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 InitLibrary( <module> ) . . . . . . . initialise library data structures
*/
static Int InitLibrary (
StructInitInfo * module )
{
/* make the list of names of record names */
CountRNam = 0;
NamesRNam = NEW_PLIST( T_PLIST, 0 );
SET_LEN_PLIST( NamesRNam, 0 );
/* make the hash list of record names */
SizeRNam = 997;
HashRNam = NEW_PLIST( T_PLIST, SizeRNam );
SET_LEN_PLIST( HashRNam, SizeRNam );
/* init filters and functions */
InitGVarFiltsFromTable( GVarFilts );
InitGVarOpersFromTable( GVarOpers );
InitGVarFuncsFromTable( GVarFuncs );
/* return success */
return 0;
}
/****************************************************************************
**
*F SetList( <list> ) . . . . . . . . . . . . . . . . make a set from a list
**
** 'SetList' returns a new set that contains the elements of <list>. Note
** that 'SetList' returns a new plain list even if <list> was already a set.
**
** 'SetList' makes a copy of the list <list>, removes the holes, sorts the
** copy and finally removes duplicates, which must appear next to each other
** now that the copy is sorted.
*/
Obj SetList (
Obj list )
{
Obj set; /* result set */
Int lenSet; /* length of <set> */
Int lenList; /* length of <list> */
Obj elm; /* one element of the list */
UInt status; /* the elements are mutable */
UInt i; /* loop variable */
/* make a dense copy */
lenList = LEN_LIST( list );
set = NEW_PLIST( T_PLIST, lenList );
lenSet = 0;
for ( i = 1; i <= lenList; i++ ) {
elm = ELMV0_LIST( list, i );
if ( elm != 0 ) {
lenSet += 1;
SET_ELM_PLIST( set, lenSet, elm );
CHANGED_BAG(set); /* in case elm had to be made, not just extracted */
}
}
SET_LEN_PLIST( set, lenSet );
SET_FILT_LIST( set, FN_IS_DENSE );
/* sort the set (which is a dense plain list) */
SortDensePlist( set );
/* remove duplicates */
status = RemoveDupsDensePlist( set );
/* adjust flags where possible */
switch(status)
{
case 0:
break;
case 1:
SET_FILT_LIST(set, FN_IS_NHOMOG);
SET_FILT_LIST(set, FN_IS_SSORT);
break;
case 2:
SET_FILT_LIST( set, FN_IS_HOMOG );
SET_FILT_LIST( set, FN_IS_SSORT );
break;
}
/* return set */
return set;
}
/****************************************************************************
**
*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 CopyContainerToGap(const T& v)
{
size_t s = v.size();
if(s == 0)
{
Obj l = NEW_PLIST(T_PLIST_EMPTY, 0);
SET_LEN_PLIST(l, 0);
CHANGED_BAG(l);
return l;
}
Obj list = NEW_PLIST(T_PLIST_DENSE, s);
SET_LEN_PLIST(list, s);
CHANGED_BAG(list);
GAP_maker<typename T::value_type> m;
int pos = 1;
for(typename T::const_iterator it = v.begin(); it != v.end(); ++it, ++pos)
{
SET_ELM_PLIST(list, pos, m(*it));
CHANGED_BAG(list);
}
return list;
}
Obj operator()(const std::pair<T,U>& v) const
{
Obj list = NEW_PLIST(T_PLIST_DENSE, 2);
SET_LEN_PLIST(list, 2);
GAP_maker<T> m_t;
SET_ELM_PLIST(list, 1, m_t(v.first));
CHANGED_BAG(list);
GAP_maker<U> m_u;
SET_ELM_PLIST(list, 2, m_u(v.second));
CHANGED_BAG(list);
return list;
}
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;
}
Obj FuncALL_RNAMES (
Obj self )
{
Obj copy, s;
UInt i;
Char* name;
copy = NEW_PLIST( T_PLIST+IMMUTABLE, CountRNam );
for ( i = 1; i <= CountRNam; i++ ) {
name = NAME_RNAM( i );
C_NEW_STRING_DYN(s, name);
SET_ELM_PLIST( copy, i, s );
}
SET_LEN_PLIST( copy, CountRNam );
return copy;
}
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;
}
/****************************************************************************
**
*F InitLibrary( <module> ) . . . . . . . initialise library data structures
*/
static Int InitLibrary (
StructInitInfo * module )
{
/* make the list of names of record names */
NamesRNam = NEW_PLIST( T_PLIST, 0 );
#ifdef HPCGAP
MakeBagPublic(NamesRNam);
#endif
/* make the hash list of record names */
HashRNam = NEW_PLIST( T_PLIST, 14033 );
SET_LEN_PLIST( HashRNam, 14033 );
#ifdef HPCGAP
MakeBagPublic(HashRNam);
#endif
/* init filters and functions */
InitGVarFiltsFromTable( GVarFilts );
InitGVarOpersFromTable( GVarOpers );
InitGVarFuncsFromTable( GVarFuncs );
/* return success */
return 0;
}
/* handler for function 4 */
static Obj HdlrFunc4 (
Obj self )
{
Obj t_1 = 0;
Obj t_2 = 0;
Obj t_3 = 0;
Obj t_4 = 0;
Obj t_5 = 0;
Bag oldFrame;
/* allocate new stack frame */
SWITCH_TO_NEW_FRAME(self,0,0,oldFrame);
/* BreakOnError := false; */
t_1 = False;
AssGVar( G_BreakOnError, t_1 );
/* CALL_WITH_CATCH( range2, [ 1, 2 ^ 80 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range2;
CHECK_BOUND( t_2, "range2" )
t_3 = NEW_PLIST( T_PLIST, 2 );
SET_LEN_PLIST( t_3, 2 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(1) );
t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(80) );
SET_ELM_PLIST( t_3, 2, t_4 );
CHANGED_BAG( t_3 );
CALL_2ARGS( t_1, t_2, t_3 );
/* CALL_WITH_CATCH( range2, [ - 2 ^ 80, 0 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range2;
CHECK_BOUND( t_2, "range2" )
t_3 = NEW_PLIST( T_PLIST, 2 );
SET_LEN_PLIST( t_3, 2 );
t_5 = POW( INTOBJ_INT(2), INTOBJ_INT(80) );
C_AINV_FIA( t_4, t_5 )
SET_ELM_PLIST( t_3, 1, t_4 );
CHANGED_BAG( t_3 );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(0) );
CALL_2ARGS( t_1, t_2, t_3 );
/* CALL_WITH_CATCH( range3, [ 1, 2, 2 ^ 80 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range3;
CHECK_BOUND( t_2, "range3" )
t_3 = NEW_PLIST( T_PLIST, 3 );
SET_LEN_PLIST( t_3, 3 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(1) );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) );
t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(80) );
SET_ELM_PLIST( t_3, 3, t_4 );
CHANGED_BAG( t_3 );
CALL_2ARGS( t_1, t_2, t_3 );
/* CALL_WITH_CATCH( range3, [ - 2 ^ 80, 0, 1 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range3;
CHECK_BOUND( t_2, "range3" )
t_3 = NEW_PLIST( T_PLIST, 3 );
SET_LEN_PLIST( t_3, 3 );
t_5 = POW( INTOBJ_INT(2), INTOBJ_INT(80) );
C_AINV_FIA( t_4, t_5 )
SET_ELM_PLIST( t_3, 1, t_4 );
CHANGED_BAG( t_3 );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(0) );
SET_ELM_PLIST( t_3, 3, INTOBJ_INT(1) );
CALL_2ARGS( t_1, t_2, t_3 );
/* CALL_WITH_CATCH( range3, [ 0, 2 ^ 80, 2 ^ 81 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range3;
CHECK_BOUND( t_2, "range3" )
t_3 = NEW_PLIST( T_PLIST, 3 );
SET_LEN_PLIST( t_3, 3 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(0) );
t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(80) );
SET_ELM_PLIST( t_3, 2, t_4 );
CHANGED_BAG( t_3 );
t_4 = POW( INTOBJ_INT(2), INTOBJ_INT(81) );
SET_ELM_PLIST( t_3, 3, t_4 );
CHANGED_BAG( t_3 );
CALL_2ARGS( t_1, t_2, t_3 );
/* Display( [ 1, 2 .. 2 ] ); */
t_1 = GF_Display;
t_2 = Range3Check( INTOBJ_INT(1), INTOBJ_INT(2), INTOBJ_INT(2) );
CALL_1ARGS( t_1, t_2 );
/* CALL_WITH_CATCH( range3, [ 2, 2, 2 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range3;
CHECK_BOUND( t_2, "range3" )
t_3 = NEW_PLIST( T_PLIST, 3 );
SET_LEN_PLIST( t_3, 3 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(2) );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) );
SET_ELM_PLIST( t_3, 3, INTOBJ_INT(2) );
CALL_2ARGS( t_1, t_2, t_3 );
/* Display( [ 2, 4 .. 6 ] ); */
t_1 = GF_Display;
t_2 = Range3Check( INTOBJ_INT(2), INTOBJ_INT(4), INTOBJ_INT(6) );
CALL_1ARGS( t_1, t_2 );
/* CALL_WITH_CATCH( range3, [ 2, 4, 7 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range3;
CHECK_BOUND( t_2, "range3" )
t_3 = NEW_PLIST( T_PLIST, 3 );
SET_LEN_PLIST( t_3, 3 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(2) );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(4) );
SET_ELM_PLIST( t_3, 3, INTOBJ_INT(7) );
CALL_2ARGS( t_1, t_2, t_3 );
/* Display( [ 2, 4 .. 2 ] ); */
t_1 = GF_Display;
t_2 = Range3Check( INTOBJ_INT(2), INTOBJ_INT(4), INTOBJ_INT(2) );
CALL_1ARGS( t_1, t_2 );
/* Display( [ 2, 4 .. 0 ] ); */
t_1 = GF_Display;
t_2 = Range3Check( INTOBJ_INT(2), INTOBJ_INT(4), INTOBJ_INT(0) );
CALL_1ARGS( t_1, t_2 );
/* CALL_WITH_CATCH( range3, [ 4, 2, 1 ] ); */
t_1 = GF_CALL__WITH__CATCH;
t_2 = GC_range3;
CHECK_BOUND( t_2, "range3" )
t_3 = NEW_PLIST( T_PLIST, 3 );
SET_LEN_PLIST( t_3, 3 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(4) );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) );
SET_ELM_PLIST( t_3, 3, INTOBJ_INT(1) );
CALL_2ARGS( t_1, t_2, t_3 );
/* Display( [ 4, 2 .. 0 ] ); */
t_1 = GF_Display;
t_2 = Range3Check( INTOBJ_INT(4), INTOBJ_INT(2), INTOBJ_INT(0) );
CALL_1ARGS( t_1, t_2 );
/* Display( [ 4, 2 .. 8 ] ); */
t_1 = GF_Display;
t_2 = Range3Check( INTOBJ_INT(4), INTOBJ_INT(2), INTOBJ_INT(8) );
CALL_1ARGS( t_1, t_2 );
/* return; */
SWITCH_TO_OLD_FRAME(oldFrame);
return 0;
/* return; */
SWITCH_TO_OLD_FRAME(oldFrame);
return 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)
RetypeBag( 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)
RetypeBag( 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 );
}
}
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 SCTableProductHandler (
Obj self,
Obj table,
Obj list1,
Obj list2 )
{
Obj res; /* result list */
Obj row; /* one row of sc table */
Obj zero; /* zero from sc table */
Obj ai, aj; /* elements from list1 */
Obj bi, bj; /* elements from list2 */
Obj c, c1, c2; /* products of above */
Int dim; /* dimension of vectorspace */
Int i, j; /* loop variables */
/* check the arguments a bit */
if ( ! IS_SMALL_LIST(table) ) {
table = ErrorReturnObj(
"SCTableProduct: <table> must be a list (not a %s)",
(Int)TNAM_OBJ(table), 0L,
"you can replace <table> via 'return <table>;'" );
return SCTableProductHandler( self, table, list1, list2 );
}
dim = LEN_LIST(table) - 2;
if ( dim <= 0 ) {
table = ErrorReturnObj(
"SCTableProduct: <table> must be a list with at least 3 elements",
0L, 0L,
"you can replace <table> via 'return <table>;'" );
return SCTableProductHandler( self, table, list1, list2 );
}
zero = ELM_LIST( table, dim+2 );
if ( ! IS_SMALL_LIST(list1) || LEN_LIST(list1) != dim ) {
list1 = ErrorReturnObj(
"SCTableProduct: <list1> must be a list with %d elements",
dim, 0L,
"you can replace <list1> via 'return <list1>;'" );
return SCTableProductHandler( self, table, list1, list2 );
}
if ( ! IS_SMALL_LIST(list2) || LEN_LIST(list2) != dim ) {
list2 = ErrorReturnObj(
"SCTableProduct: <list2> must be a list with %d elements",
dim, 0L,
"you can replace <list2> via 'return <list2>;'" );
return SCTableProductHandler( self, table, list1, list2 );
}
/* make the result list */
res = NEW_PLIST( T_PLIST, dim );
SET_LEN_PLIST( res, dim );
for ( i = 1; i <= dim; i++ ) {
SET_ELM_PLIST( res, i, zero );
}
CHANGED_BAG( res );
/* general case */
if ( EQ( ELM_LIST( table, dim+1 ), INTOBJ_INT(0) ) ) {
for ( i = 1; i <= dim; i++ ) {
ai = ELM_LIST( list1, i );
if ( EQ( ai, zero ) ) continue;
row = ELM_LIST( table, i );
for ( j = 1; j <= dim; j++ ) {
bj = ELM_LIST( list2, j );
if ( EQ( bj, zero ) ) continue;
c = PROD( ai, bj );
if ( ! EQ( c, zero ) ) {
SCTableProdAdd( res, c, ELM_LIST( row, j ), dim );
}
}
}
}
/* commutative case */
else if ( EQ( ELM_LIST( table, dim+1 ), INTOBJ_INT(1) ) ) {
for ( i = 1; i <= dim; i++ ) {
ai = ELM_LIST( list1, i );
bi = ELM_LIST( list2, i );
if ( EQ( ai, zero ) && EQ( bi, zero ) ) continue;
row = ELM_LIST( table, i );
c = PROD( ai, bi );
if ( ! EQ( c, zero ) ) {
SCTableProdAdd( res, c, ELM_LIST( row, i ), dim );
}
for ( j = i+1; j <= dim; j++ ) {
bj = ELM_LIST( list2, j );
aj = ELM_LIST( list1, j );
if ( EQ( aj, zero ) && EQ( bj, zero ) ) continue;
c1 = PROD( ai, bj );
c2 = PROD( aj, bi );
c = SUM( c1, c2 );
if ( ! EQ( c, zero ) ) {
SCTableProdAdd( res, c, ELM_LIST( row, j ), dim );
}
}
}
}
/* anticommutative case */
else if ( EQ( ELM_LIST( table, dim+1 ), INTOBJ_INT(-1) ) ) {
for ( i = 1; i <= dim; i++ ) {
ai = ELM_LIST( list1, i );
bi = ELM_LIST( list2, i );
if ( EQ( ai, zero ) && EQ( bi, zero ) ) continue;
row = ELM_LIST( table, i );
for ( j = i+1; j <= dim; j++ ) {
bj = ELM_LIST( list2, j );
aj = ELM_LIST( list1, j );
if ( EQ( aj, zero ) && EQ( bj, zero ) ) continue;
c1 = PROD( ai, bj );
c2 = PROD( aj, bi );
c = DIFF( c1, c2 );
if ( ! EQ( c, zero ) ) {
SCTableProdAdd( res, c, ELM_LIST( row, j ), dim );
}
}
}
}
/* return the result */
return res;
}
Obj boyers_planarity_check(Obj digraph, int flags, bool krtwsk) {
DIGRAPHS_ASSERT(flags == EMBEDFLAGS_PLANAR || flags == EMBEDFLAGS_OUTERPLANAR
|| flags == EMBEDFLAGS_SEARCHFORK23
|| flags == EMBEDFLAGS_SEARCHFORK4
|| flags == EMBEDFLAGS_SEARCHFORK33);
if (CALL_1ARGS(IsDigraph, digraph) != True) {
ErrorQuit("Digraphs: boyers_planarity_check (C): the 1st argument must be "
"a digraph, not %s",
(Int) TNAM_OBJ(digraph),
0L);
}
Obj const out = FuncOutNeighbours(0L, digraph);
if (FuncIS_ANTISYMMETRIC_DIGRAPH(0L, out) != True) {
ErrorQuit("Digraphs: boyers_planarity_check (C): the 1st argument must be "
"an antisymmetric digraph",
0L,
0L);
}
Int V = DigraphNrVertices(digraph);
Int E = DigraphNrEdges(digraph);
if (V > INT_MAX) {
// Cannot currently test this, it might always be true, depending on the
// definition of Int.
ErrorQuit("Digraphs: boyers_planarity_check (C): the maximum number of "
"nodes is %d, found %d",
INT_MAX,
V);
return 0L;
} else if (2 * E > INT_MAX) {
// Cannot currently test this
ErrorQuit("Digraphs: boyers_planarity_check (C): the maximum number of "
"edges is %d, found %d",
INT_MAX / 2,
E);
return 0L;
}
graphP theGraph = gp_New();
switch (flags) {
case EMBEDFLAGS_SEARCHFORK33:
gp_AttachK33Search(theGraph);
break;
case EMBEDFLAGS_SEARCHFORK23:
gp_AttachK23Search(theGraph);
break;
case EMBEDFLAGS_SEARCHFORK4:
gp_AttachK4Search(theGraph);
break;
}
if (gp_InitGraph(theGraph, V) != OK) {
gp_Free(&theGraph);
ErrorQuit("Digraphs: boyers_planarity_check (C): invalid number of nodes!",
0L,
0L);
return 0L;
} else if (gp_EnsureArcCapacity(theGraph, 2 * E) != OK) {
gp_Free(&theGraph);
ErrorQuit("Digraphs: boyers_planarity_check (C): invalid number of edges!",
0L,
0L);
return 0L;
}
int status;
for (Int v = 1; v <= LEN_LIST(out); ++v) {
DIGRAPHS_ASSERT(gp_VertexInRange(theGraph, v));
gp_SetVertexIndex(theGraph, v, v);
Obj const out_v = ELM_LIST(out, v);
for (Int w = 1; w <= LEN_LIST(out_v); ++w) {
DIGRAPHS_ASSERT(gp_VertexInRange(theGraph, w));
int u = INT_INTOBJ(ELM_LIST(out_v, w));
if (v != u) {
status = gp_AddEdge(theGraph, v, 0, u, 0);
if (status != OK) {
// Cannot currently test this, i.e. it shouldn't happen (and
// currently there is no example where it does happen)
gp_Free(&theGraph);
ErrorQuit("Digraphs: boyers_planarity_check (C): internal error, "
"can't add edge from %d to %d",
(Int) v,
(Int) u);
return 0L;
}
}
}
}
status = gp_Embed(theGraph, flags);
if (status == NOTOK) {
// Cannot currently test this, i.e. it shouldn't happen (and
// currently there is no example where it does happen)
gp_Free(&theGraph);
ErrorQuit("Digraphs: boyers_planarity_check (C): status is not ok", 0L, 0L);
}
Obj res;
if (krtwsk) {
// Kuratowski subgraph isolator
gp_SortVertices(theGraph);
Obj subgraph = NEW_PLIST_IMM(T_PLIST, theGraph->N);
SET_LEN_PLIST(subgraph, theGraph->N);
for (int i = 1; i <= theGraph->N; ++i) {
int nr = 0;
Obj list = NEW_PLIST_IMM(T_PLIST, 0);
int j = theGraph->V[i].link[1];
while (j) {
if (CALL_3ARGS(IsDigraphEdge,
digraph,
INTOBJ_INT((Int) i),
INTOBJ_INT((Int) theGraph->E[j].neighbor))
== True) {
AssPlist(list, ++nr, INTOBJ_INT(theGraph->E[j].neighbor));
}
j = theGraph->E[j].link[1];
}
if (nr == 0) {
RetypeBag(list, T_PLIST_EMPTY);
}
SET_ELM_PLIST(subgraph, i, list);
CHANGED_BAG(subgraph);
}
res = NEW_PLIST_IMM(T_PLIST, 2);
SET_LEN_PLIST(res, 2);
SET_ELM_PLIST(res, 1, (status == NONEMBEDDABLE ? False : True));
SET_ELM_PLIST(res, 2, subgraph);
CHANGED_BAG(res);
} else if (status == NONEMBEDDABLE) {
res = False;
} else {
res = True;
}
gp_Free(&theGraph);
return res;
}
/* handler for function 2 */
static Obj HdlrFunc2 (
Obj self )
{
Obj t_1 = 0;
Obj t_2 = 0;
Obj t_3 = 0;
Obj t_4 = 0;
Obj t_5 = 0;
Obj t_6 = 0;
Bag oldFrame;
/* allocate new stack frame */
SWITCH_TO_NEW_FRAME(self,0,0,oldFrame);
/* Print( 1, "\n" ); */
t_1 = GF_Print;
t_2 = MakeString( "\n" );
CALL_2ARGS( t_1, INTOBJ_INT(1), t_2 );
/* Print( "abc", "\n" ); */
t_1 = GF_Print;
t_2 = MakeString( "abc" );
t_3 = MakeString( "\n" );
CALL_2ARGS( t_1, t_2, t_3 );
/* Print( (1,2)(5,6), "\n" ); */
t_1 = GF_Print;
t_2 = IdentityPerm;
t_4 = NEW_PLIST( T_PLIST, 2 );
SET_LEN_PLIST( t_4, 2 );
t_3 = NEW_PLIST( T_PLIST, 2 );
SET_LEN_PLIST( t_3, 2 );
SET_ELM_PLIST( t_4, 1, t_3 );
CHANGED_BAG( t_4 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(1) );
CHANGED_BAG( t_3 );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(2) );
CHANGED_BAG( t_3 );
t_3 = NEW_PLIST( T_PLIST, 2 );
SET_LEN_PLIST( t_3, 2 );
SET_ELM_PLIST( t_4, 2, t_3 );
CHANGED_BAG( t_4 );
SET_ELM_PLIST( t_3, 1, INTOBJ_INT(5) );
CHANGED_BAG( t_3 );
SET_ELM_PLIST( t_3, 2, INTOBJ_INT(6) );
CHANGED_BAG( t_3 );
t_2 = Array2Perm( t_4 );
t_3 = MakeString( "\n" );
CALL_2ARGS( t_1, t_2, t_3 );
/* Print( [ 1, "abc" ], "\n" ); */
t_1 = GF_Print;
t_2 = NEW_PLIST( T_PLIST, 2 );
SET_LEN_PLIST( t_2, 2 );
SET_ELM_PLIST( t_2, 1, INTOBJ_INT(1) );
t_3 = MakeString( "abc" );
SET_ELM_PLIST( t_2, 2, t_3 );
CHANGED_BAG( t_2 );
t_3 = MakeString( "\n" );
CALL_2ARGS( t_1, t_2, t_3 );
/* Print( Group( (1,2,3) ), "\n" ); */
t_1 = GF_Print;
t_3 = GF_Group;
t_4 = IdentityPerm;
t_6 = NEW_PLIST( T_PLIST, 1 );
SET_LEN_PLIST( t_6, 1 );
t_5 = NEW_PLIST( T_PLIST, 3 );
SET_LEN_PLIST( t_5, 3 );
SET_ELM_PLIST( t_6, 1, t_5 );
CHANGED_BAG( t_6 );
SET_ELM_PLIST( t_5, 1, INTOBJ_INT(1) );
CHANGED_BAG( t_5 );
SET_ELM_PLIST( t_5, 2, INTOBJ_INT(2) );
CHANGED_BAG( t_5 );
SET_ELM_PLIST( t_5, 3, INTOBJ_INT(3) );
CHANGED_BAG( t_5 );
t_4 = Array2Perm( t_6 );
t_2 = CALL_1ARGS( t_3, t_4 );
CHECK_FUNC_RESULT( t_2 )
t_3 = MakeString( "\n" );
CALL_2ARGS( t_1, t_2, t_3 );
/* return; */
SWITCH_TO_OLD_FRAME(oldFrame);
return 0;
/* return; */
SWITCH_TO_OLD_FRAME(oldFrame);
return 0;
}
/* handler for function 1 */
static Obj HdlrFunc1 (
Obj self )
{
Obj t_1 = 0;
Obj t_2 = 0;
Obj t_3 = 0;
Obj t_4 = 0;
Bag oldFrame;
OLD_BRK_CURR_STAT
/* allocate new stack frame */
SWITCH_TO_NEW_FRAME(self,0,0,oldFrame);
REM_BRK_CURR_STAT();
SET_BRK_CURR_STAT(0);
/* WITH_HIDDEN_IMPS_FLAGS_COUNT := 0; */
AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__COUNT, INTOBJ_INT(0) );
/* WITH_HIDDEN_IMPS_FLAGS_CACHE_MISS := 0; */
AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__CACHE__MISS, INTOBJ_INT(0) );
/* WITH_HIDDEN_IMPS_FLAGS_CACHE_HIT := 0; */
AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__CACHE__HIT, INTOBJ_INT(0) );
/* IMPLICATIONS := [ ]; */
t_1 = NEW_PLIST( T_PLIST, 0 );
SET_LEN_PLIST( t_1, 0 );
AssGVar( G_IMPLICATIONS, t_1 );
/* WITH_IMPS_FLAGS_CACHE := [ ]; */
t_1 = NEW_PLIST( T_PLIST, 0 );
SET_LEN_PLIST( t_1, 0 );
AssGVar( G_WITH__IMPS__FLAGS__CACHE, t_1 );
/* WITH_IMPS_FLAGS_COUNT := 0; */
AssGVar( G_WITH__IMPS__FLAGS__COUNT, INTOBJ_INT(0) );
/* WITH_IMPS_FLAGS_CACHE_HIT := 0; */
AssGVar( G_WITH__IMPS__FLAGS__CACHE__HIT, INTOBJ_INT(0) );
/* WITH_IMPS_FLAGS_CACHE_MISS := 0; */
AssGVar( G_WITH__IMPS__FLAGS__CACHE__MISS, INTOBJ_INT(0) );
/* Unbind( CLEAR_IMP_CACHE ); */
AssGVar( G_CLEAR__IMP__CACHE, 0 );
/* BIND_GLOBAL( "CLEAR_IMP_CACHE", function ( )
WITH_IMPS_FLAGS_CACHE := [ ];
return;
end ); */
t_1 = GF_BIND__GLOBAL;
C_NEW_STRING( t_2, 15, "CLEAR_IMP_CACHE" );
t_3 = NewFunction( NameFunc[2], NargFunc[2], NamsFunc[2], HdlrFunc2 );
ENVI_FUNC( t_3 ) = TLS(CurrLVars);
t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) );
STARTLINE_BODY(t_4) = INTOBJ_INT(39);
ENDLINE_BODY(t_4) = INTOBJ_INT(41);
FILENAME_BODY(t_4) = FileName;
BODY_FUNC(t_3) = t_4;
CHANGED_BAG( TLS(CurrLVars) );
CALL_2ARGS( t_1, t_2, t_3 );
/* BIND_GLOBAL( "WITH_IMPS_FLAGS", function ( flags )
local with, changed, imp, hash, hash2, i;
hash := HASH_FLAGS( flags ) mod 11001;
for i in [ 0 .. 3 ] do
hash2 := 2 * ((hash + 31 * i) mod 11001) + 1;
if IsBound( WITH_IMPS_FLAGS_CACHE[hash2] ) then
if IS_IDENTICAL_OBJ( WITH_IMPS_FLAGS_CACHE[hash2], flags ) then
WITH_IMPS_FLAGS_CACHE_HIT := WITH_IMPS_FLAGS_CACHE_HIT + 1;
return WITH_IMPS_FLAGS_CACHE[hash2 + 1];
fi;
else
break;
fi;
od;
if i = 3 then
WITH_IMPS_FLAGS_COUNT := (WITH_IMPS_FLAGS_COUNT + 1) mod 4;
i := WITH_IMPS_FLAGS_COUNT;
hash2 := 2 * ((hash + 31 * i) mod 11001) + 1;
fi;
WITH_IMPS_FLAGS_CACHE_MISS := WITH_IMPS_FLAGS_CACHE_MISS + 1;
with := flags;
changed := true;
while changed do
changed := false;
for imp in IMPLICATIONS do
if IS_SUBSET_FLAGS( with, imp[2] ) and not IS_SUBSET_FLAGS( with, imp[1] ) then
with := AND_FLAGS( with, imp[1] );
changed := true;
fi;
od;
od;
WITH_IMPS_FLAGS_CACHE[hash2] := flags;
WITH_IMPS_FLAGS_CACHE[hash2 + 1] := with;
return with;
end ); */
t_1 = GF_BIND__GLOBAL;
C_NEW_STRING( t_2, 15, "WITH_IMPS_FLAGS" );
t_3 = NewFunction( NameFunc[3], NargFunc[3], NamsFunc[3], HdlrFunc3 );
ENVI_FUNC( t_3 ) = TLS(CurrLVars);
t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) );
STARTLINE_BODY(t_4) = INTOBJ_INT(44);
ENDLINE_BODY(t_4) = INTOBJ_INT(83);
FILENAME_BODY(t_4) = FileName;
BODY_FUNC(t_3) = t_4;
CHANGED_BAG( TLS(CurrLVars) );
CALL_2ARGS( t_1, t_2, t_3 );
/* UNBIND_GLOBAL( "RANK_FILTER" ); */
t_1 = GF_UNBIND__GLOBAL;
C_NEW_STRING( t_2, 11, "RANK_FILTER" );
CALL_1ARGS( t_1, t_2 );
/* BIND_GLOBAL( "RANK_FILTER", function ( filter )
local rank, flags, i;
rank := 0;
if IS_FUNCTION( filter ) then
flags := FLAGS_FILTER( filter );
else
flags := filter;
fi;
for i in TRUES_FLAGS( WITH_HIDDEN_IMPS_FLAGS( flags ) ) do
if IsBound( RANK_FILTERS[i] ) then
rank := rank + RANK_FILTERS[i];
else
rank := rank + 1;
fi;
od;
return rank;
end ); */
t_1 = GF_BIND__GLOBAL;
C_NEW_STRING( t_2, 11, "RANK_FILTER" );
t_3 = NewFunction( NameFunc[4], NargFunc[4], NamsFunc[4], HdlrFunc4 );
ENVI_FUNC( t_3 ) = TLS(CurrLVars);
t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) );
STARTLINE_BODY(t_4) = INTOBJ_INT(97);
ENDLINE_BODY(t_4) = INTOBJ_INT(114);
FILENAME_BODY(t_4) = FileName;
BODY_FUNC(t_3) = t_4;
CHANGED_BAG( TLS(CurrLVars) );
CALL_2ARGS( t_1, t_2, t_3 );
/* RankFilter := RANK_FILTER; */
t_1 = GC_RANK__FILTER;
CHECK_BOUND( t_1, "RANK_FILTER" )
AssGVar( G_RankFilter, t_1 );
/* UNBIND_GLOBAL( "RANK_FILTER_STORE" ); */
t_1 = GF_UNBIND__GLOBAL;
C_NEW_STRING( t_2, 17, "RANK_FILTER_STORE" );
CALL_1ARGS( t_1, t_2 );
/* BIND_GLOBAL( "RANK_FILTER_STORE", function ( filter )
local hash, rank, flags;
if IS_FUNCTION( filter ) then
flags := FLAGS_FILTER( filter );
else
flags := filter;
fi;
hash := HASH_FLAGS( flags );
rank := RANK_FILTER( flags );
ADD_LIST( RANK_FILTER_LIST_CURRENT, hash );
ADD_LIST( RANK_FILTER_LIST_CURRENT, rank );
return rank;
end ); */
t_1 = GF_BIND__GLOBAL;
C_NEW_STRING( t_2, 17, "RANK_FILTER_STORE" );
t_3 = NewFunction( NameFunc[5], NargFunc[5], NamsFunc[5], HdlrFunc5 );
ENVI_FUNC( t_3 ) = TLS(CurrLVars);
t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) );
STARTLINE_BODY(t_4) = INTOBJ_INT(119);
ENDLINE_BODY(t_4) = INTOBJ_INT(133);
FILENAME_BODY(t_4) = FileName;
BODY_FUNC(t_3) = t_4;
CHANGED_BAG( TLS(CurrLVars) );
CALL_2ARGS( t_1, t_2, t_3 );
/* UNBIND_GLOBAL( "RANK_FILTER_COMPLETION" ); */
t_1 = GF_UNBIND__GLOBAL;
C_NEW_STRING( t_2, 22, "RANK_FILTER_COMPLETION" );
CALL_1ARGS( t_1, t_2 );
/* BIND_GLOBAL( "RANK_FILTER_COMPLETION", function ( filter )
local hash, flags;
if IS_FUNCTION( filter ) then
flags := FLAGS_FILTER( filter );
else
flags := filter;
fi;
hash := HASH_FLAGS( flags );
if hash <> RANK_FILTER_LIST[RANK_FILTER_COUNT] then
Error( "corrupted completion file" );
fi;
RANK_FILTER_COUNT := RANK_FILTER_COUNT + 2;
return RANK_FILTER_LIST[RANK_FILTER_COUNT - 1];
end ); */
t_1 = GF_BIND__GLOBAL;
C_NEW_STRING( t_2, 22, "RANK_FILTER_COMPLETION" );
t_3 = NewFunction( NameFunc[6], NargFunc[6], NamsFunc[6], HdlrFunc6 );
ENVI_FUNC( t_3 ) = TLS(CurrLVars);
t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) );
STARTLINE_BODY(t_4) = INTOBJ_INT(136);
ENDLINE_BODY(t_4) = INTOBJ_INT(151);
FILENAME_BODY(t_4) = FileName;
BODY_FUNC(t_3) = t_4;
CHANGED_BAG( TLS(CurrLVars) );
CALL_2ARGS( t_1, t_2, t_3 );
/* return; */
RES_BRK_CURR_STAT();
SWITCH_TO_OLD_FRAME(oldFrame);
return 0;
/* return; */
RES_BRK_CURR_STAT();
SWITCH_TO_OLD_FRAME(oldFrame);
return 0;
}
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;
}
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);
}
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);
}
