Ejemplo n.º 1
0
Archivo: set.c Proyecto: YurieCo/gap
/****************************************************************************
**
*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;
}
Ejemplo n.º 2
0
/****************************************************************************
 * 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);
}
Ejemplo n.º 3
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;
}
Ejemplo n.º 4
0
Archivo: records.c Proyecto: vbraun/gap
/****************************************************************************
**
*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;
}
Ejemplo n.º 5
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);
}
Ejemplo n.º 6
0
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;
}
Ejemplo n.º 7
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, &degree, 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;
}
Ejemplo n.º 8
0
/* 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;
}
Ejemplo n.º 9
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);
}
Ejemplo n.º 10
0
Archivo: set.c Proyecto: YurieCo/gap
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;
}
Ejemplo n.º 11
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);
}
Ejemplo n.º 12
0
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;
}
Ejemplo n.º 13
0
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;
}
Ejemplo n.º 14
0
/****************************************************************************
**
*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;
}
Ejemplo n.º 15
0
/****************************************************************************
**
*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;
}
Ejemplo n.º 16
0
/****************************************************************************
**
*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;
}
Ejemplo n.º 17
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;
}
Ejemplo n.º 18
0
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;
}
Ejemplo n.º 19
0
/****************************************************************************
**
*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;
}
Ejemplo n.º 20
0
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;
}
Ejemplo n.º 21
0
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 );
  }

}
Ejemplo n.º 22
0
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;
}
Ejemplo n.º 23
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;
}
Ejemplo n.º 24
0
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;
}
Ejemplo n.º 25
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;
}
Ejemplo n.º 26
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);
}
Ejemplo n.º 27
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;
}
Ejemplo n.º 28
0
/****************************************************************************
**
*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;
}
Ejemplo n.º 29
0
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;
}
Ejemplo n.º 30
0
Archivo: set.c Proyecto: YurieCo/gap
/****************************************************************************
**
*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);
}