Exemple #1
0
Obj FuncKURATOWSKI_OUTER_PLANAR_SUBGRAPH(Obj self, Obj digraph) {
  Obj res = boyers_planarity_check(digraph, EMBEDFLAGS_OUTERPLANAR, true);
  return (ELM_PLIST(res, 1) == False ? ELM_PLIST(res, 2) : Fail);
}
Exemple #2
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);
}
Exemple #3
0
Obj FuncPLANAR_EMBEDDING(Obj self, Obj digraph) {
  Obj res = boyers_planarity_check(digraph, EMBEDFLAGS_PLANAR, true);
  return (ELM_PLIST(res, 1) == True ? ELM_PLIST(res, 2) : Fail);
}
Exemple #4
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;
}
Exemple #5
0
extern inline Obj NAME_RNAM(UInt rnam)
{
    return ELM_PLIST(NamesRNam, rnam);
}
Exemple #6
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;
}
Exemple #7
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;
}
Exemple #8
0
UInt            RNamName (
    const Char *        name )
{
    Obj                 rnam;           /* record name (as imm intobj)     */
    UInt                pos;            /* hash position                   */
    UInt                len;            /* length of name                  */
    Char                namx [1024];    /* temporary copy of <name>        */
    Obj                 string;         /* temporary string object <name>  */
    Obj                 table;          /* temporary copy of <HashRNam>    */
    Obj                 rnam2;          /* one element of <table>          */
    const Char *        p;              /* loop variable                   */
    UInt                i;              /* loop variable                   */

    /* start looking in the table at the following hash position           */
    pos = 0;
    len = 0;
    for ( p = name; *p != '\0'; p++ ) {
        pos = 65599 * pos + *p;
        len++;
    }
    pos = (pos % SizeRNam) + 1;

    if(len >= 1023) {
        // Note: We can't pass 'name' here, as it might get moved by garbage collection
        ErrorQuit("Record names must consist of less than 1023 characters", 0, 0);
    }
    /* look through the table until we find a free slot or the global      */
    while ( (rnam = ELM_PLIST( HashRNam, pos )) != 0
         && strncmp( NAME_RNAM( INT_INTOBJ(rnam) ), name, 1023 ) ) {
        pos = (pos % SizeRNam) + 1;
    }

    /* if we did not find the global variable, make a new one and enter it */
    /* (copy the name first, to avoid a stale pointer in case of a GC)     */
    if ( rnam == 0 ) {
        CountRNam++;
        rnam = INTOBJ_INT(CountRNam);
        SET_ELM_PLIST( HashRNam, pos, rnam );
        strlcpy( namx, name, sizeof(namx) );
        C_NEW_STRING_DYN(string, namx);
        GROW_PLIST(    NamesRNam,   CountRNam );
        SET_LEN_PLIST( NamesRNam,   CountRNam );
        SET_ELM_PLIST( NamesRNam,   CountRNam, string );
        CHANGED_BAG(   NamesRNam );
    }

    /* if the table is too crowed, make a larger one, rehash the names     */
    if ( SizeRNam < 3 * CountRNam / 2 ) {
        table = HashRNam;
        SizeRNam = 2 * SizeRNam + 1;
        HashRNam = NEW_PLIST( T_PLIST, SizeRNam );
        SET_LEN_PLIST( HashRNam, SizeRNam );
        for ( i = 1; i <= (SizeRNam-1)/2; i++ ) {
            rnam2 = ELM_PLIST( table, i );
            if ( rnam2 == 0 )  continue;
            pos = 0;
            for ( p = NAME_RNAM( INT_INTOBJ(rnam2) ); *p != '\0'; p++ ) {
                pos = 65599 * pos + *p;
            }
            pos = (pos % SizeRNam) + 1;
            while ( ELM_PLIST( HashRNam, pos ) != 0 ) {
                pos = (pos % SizeRNam) + 1;
            }
            SET_ELM_PLIST( HashRNam, pos, rnam2 );
        }
    }

    /* return the record name                                              */
    return INT_INTOBJ(rnam);
}
Exemple #9
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;
}
Exemple #10
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;
}
Exemple #11
0
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;
}
Exemple #12
0
Obj CollectPolycyc (
    Obj pcp,
    Obj list,
    Obj word )
{
    Int    ngens   = INT_INTOBJ( ADDR_OBJ(pcp)[ PC_NUMBER_OF_GENERATORS ] );
    Obj    commute = ADDR_OBJ(pcp)[ PC_COMMUTE ];

    Obj    gens    = ADDR_OBJ(pcp)[ PC_GENERATORS ];
    Obj    igens   = ADDR_OBJ(pcp)[ PC_INVERSES ];

    Obj    pow     = ADDR_OBJ(pcp)[ PC_POWERS ];
    Obj    ipow    = ADDR_OBJ(pcp)[ PC_INVERSEPOWERS ];
    Obj    exp     = ADDR_OBJ(pcp)[ PC_EXPONENTS ];

    Obj    wst  = ADDR_OBJ(pcp)[ PC_WORD_STACK ];
    Obj    west = ADDR_OBJ(pcp)[ PC_WORD_EXPONENT_STACK ];
    Obj    sst  = ADDR_OBJ(pcp)[ PC_SYLLABLE_STACK ];
    Obj    est  = ADDR_OBJ(pcp)[ PC_EXPONENT_STACK ];

    Obj    conj=0, iconj=0;   /*QQ initialize to please compiler */

    Int    st, bottom = INT_INTOBJ( ADDR_OBJ(pcp)[ PC_STACK_POINTER ] );

    Int    g, syl, h, hh;

    Obj    e, ee, ge, mge, we, s, t;
    Obj    w, x = (Obj)0, y = (Obj)0;


    if( LEN_PLIST(word) == 0 ) return (Obj)0;

    if( LEN_PLIST(list) < ngens ) {
        ErrorQuit( "vector too short", 0L, 0L );
        return (Obj)0;
    }
    if( LEN_PLIST(word) % 2 != 0 ) {
        ErrorQuit( "Length of word odd", 0L, 0L );
        return (Obj)0;
    }

    st = bottom;
    PUSH_STACK( word, INTOBJ_INT(1) );

    while( st > bottom ) {

      w   = ELM_PLIST( wst, st );
      syl = INT_INTOBJ( ELM_PLIST( sst, st ) );
      g   = INT_INTOBJ( ELM_PLIST( w, syl )  );

      if( st > bottom+1 && syl==1 && g == GET_COMMUTE(g) ) {
        /* Collect word^exponent in one go. */

        e = ELM_PLIST( west, st );

        /* Add in. */
        AddIn( list, w, e );

        /* Reduce. */
        for( h = g; h <= ngens; h++ ) {
          s = ELM_PLIST( list, h );
          if( IS_INT_ZERO( s ) ) continue;

          y = (Obj)0;
          if( (e = GET_EXPONENT( h )) != (Obj)0 ) {
              if( !LtInt( s, e ) ) {
                  t = ModInt( s, e );
                  SET_ELM_PLIST( list, h, t ); CHANGED_BAG( list );
                  if( (y = GET_POWER( h )) ) e = QuoInt( s, e );
              }
              else if( LtInt( s, INTOBJ_INT(0) ) ) {
                  t = ModInt( s, e );
                  SET_ELM_PLIST( list, h, t ); CHANGED_BAG( list );
              
                  if( (y = GET_IPOWER( h )) ) {
                      e = QuoInt( s, e );
                      if( !IS_INT_ZERO( t ) ) e = DiffInt( e, INTOBJ_INT(1) );
                      e = AInvInt(e);
                  }
              }
          }
          if( y != (Obj)0 ) AddIn( list, y, e );

        }

        st--;

      }
      else {
        if( g == GET_COMMUTE( g ) ) {
          s = ELM_PLIST( list, g ); 
          t = ELM_PLIST( est, st ); 
          C_SUM_FIA( ge, s, t );
          SET_ELM_PLIST( est, st, INTOBJ_INT(0) );
        }
        else {
          /* Assume that the top of the exponent stack is non-zero. */
          e = ELM_PLIST( est, st );
          
          if( LtInt( INTOBJ_INT(0), e ) ) {
            C_DIFF_FIA( ee, e, INTOBJ_INT(1) );  e = ee;
            SET_ELM_PLIST( est, st, e );
            conj  = ADDR_OBJ(pcp)[PC_CONJUGATES];
            iconj = ADDR_OBJ(pcp)[PC_INVERSECONJUGATES];
            
            C_SUM_FIA( ge, ELM_PLIST( list, g ), INTOBJ_INT(1) );
          }
          else {
            C_SUM_FIA( ee, e, INTOBJ_INT(1) );  e = ee;
            SET_ELM_PLIST( est, st, e );
            conj  = ADDR_OBJ(pcp)[PC_CONJUGATESINVERSE];
            iconj = ADDR_OBJ(pcp)[PC_INVERSECONJUGATESINVERSE];
            
            C_DIFF_FIA( ge, ELM_PLIST( list, g ), INTOBJ_INT(1) );
          }
        }
        SET_ELM_PLIST( list, g, ge );  CHANGED_BAG( list );


        /* Reduce the exponent.  We delay putting the power onto the 
           stack until all the conjugates are on the stack.  The power is
           stored in  y, its exponent in ge.  */
        y = (Obj)0;
        if( (e = GET_EXPONENT( g )) ) {
            if( !LtInt( ge, e ) ) {
                mge = ModInt( ge, e );
                SET_ELM_PLIST( list, g, mge ); CHANGED_BAG( list );
            
                if( (y = GET_POWER( g )) ) ge = QuoInt( ge, e );
            }
            else if( LtInt( ge, INTOBJ_INT(0) ) ) {
                mge = ModInt( ge, e );
                SET_ELM_PLIST( list, g, mge ); CHANGED_BAG( list );
            
                if( (y = GET_IPOWER( g )) ) {
                    ge = QuoInt( ge, e );
                    if( !IS_INT_ZERO( mge ) ) 
                        ge = DiffInt( ge, INTOBJ_INT(1) );
                    ge = AInvInt(ge);
                }
            }
        }
        
        hh = h = GET_COMMUTE( g );
        
        /* Find the place where we start to collect. */
        for( ; h > g; h-- ) {
            e = ELM_PLIST( list, h );
            if( !IS_INT_ZERO(e) ) {
            
                if( LtInt( INTOBJ_INT(0), e ) ) {
                    if( GET_CONJ( h, g ) ) break;
                }
                else {
                    if( GET_ICONJ( h, g ) ) break;
                }
            }
        }

        /* Put those onto the stack, if necessary. */
        if( h > g || y != (Obj)0 ) 
          for( ; hh > h; hh-- ) {
            e = ELM_PLIST( list, hh );
            if( !IS_INT_ZERO(e) ) {
              SET_ELM_PLIST( list, hh, INTOBJ_INT(0) );
              
              if( LtInt( INTOBJ_INT(0), e ) ) {
                  x = ELM_PLIST(  gens, hh );
              }
              else {
                  x = ELM_PLIST( igens, hh );
                  C_PROD_FIA( ee, e, INTOBJ_INT(-1) );  e = ee;
              }
              
              PUSH_STACK( x, e );
            }
          }
        
        
        for( ; h > g; h-- ) {
          e = ELM_PLIST( list, h );
          if( !IS_INT_ZERO(e) ) {
            SET_ELM_PLIST( list, h, INTOBJ_INT(0) );
            
            x = (Obj)0;
            if( LtInt( INTOBJ_INT(0), e ) ) x = GET_CONJ( h, g );
            else                            x = GET_ICONJ( h, g );
            
            if( x == (Obj)0 )  {
              if( LtInt( INTOBJ_INT(0), e ) ) x = ELM_PLIST(  gens, h );
              else                            x = ELM_PLIST( igens, h );
            
            }
            if( LtInt( e, INTOBJ_INT(0) ) ) {
              C_PROD_FIA( ee, e, INTOBJ_INT(-1) );  e = ee;
            }
            PUSH_STACK( x, e );
          }
        }
        
        if( y != (Obj)0 ) PUSH_STACK( y, ge );
      }

      while( st > bottom && IS_INT_ZERO( ELM_PLIST( est, st ) ) ) {
        w   = ELM_PLIST( wst, st );
        syl = INT_INTOBJ( ELM_PLIST( sst, st ) ) + 2;
        if( syl > LEN_PLIST( w ) ) {
          we = DiffInt( ELM_PLIST( west, st ), INTOBJ_INT(1) );
          if( EqInt( we, INTOBJ_INT(0) ) ) { st--; }
          else {
            SET_ELM_PLIST( west, st, we );
            SET_ELM_PLIST( sst,  st, INTOBJ_INT(1) );
            SET_ELM_PLIST( est,  st, ELM_PLIST( w, 2 ) );
            CHANGED_BAG( west ); CHANGED_BAG( est );
          }
        }
        else {
          SET_ELM_PLIST( sst, st, INTOBJ_INT(syl) );
          SET_ELM_PLIST( est, st, ELM_PLIST( w, syl+1 ));
          CHANGED_BAG( est );
        }
      }
    }

    ADDR_OBJ(pcp)[ PC_STACK_POINTER ] = INTOBJ_INT( bottom );
    return (Obj)0;
}
Exemple #13
0
Fichier : set.c Projet : vbraun/gap
/****************************************************************************
**


*F  FuncADD_SET( <self>, <set>, <obj> ) . . . . . . . add an element to a set
**
**  'FuncADD_SET' implements the internal function 'AddSet'.
**
**  'AddSet( <set>, <obj> )'
**
**  'AddSet' adds <obj>, which may be an object  of an arbitrary type, to the
**  set <set>, which must be a proper set.  If <obj> is already an element of
**  the set <set>, then <set> is not changed.  Otherwise <obj> is inserted at
**  the correct position such that <set> is again a set afterwards.
**
**  'AddSet' does not return  anything, it is only  called for the side effect
**  of changing <set>.
*/
Obj FuncADD_SET (
		 Obj                 self,
		 Obj                 set,
		 Obj                 obj )
{
  UInt                len;            /* logical length of the list      */
  UInt                pos;            /* position                        */
  UInt                isCyc;          /* True if the set being added to consists
					 of kernel cyclotomics           */
  UInt                notpos;         /* position of an original element
					 (not the new one)               */
  UInt                wasHom;
  UInt                wasNHom;
  UInt                wasTab;
    
  /* check the arguments                                                 */
  while ( ! IsSet(set) || ! IS_MUTABLE_OBJ(set) ) {
    set = ErrorReturnObj(
			 "AddSet: <set> must be a mutable proper set (not a %s)",
			 (Int)TNAM_OBJ(set), 0L,
			 "you can replace <set> via 'return <set>;'" );
  }
  len = LEN_LIST(set);

  /* perform the binary search to find the position                      */
  pos = PositionSortedDensePlist( set, obj );

  /* add the element to the set if it is not already there               */
  if ( len < pos || ! EQ( ELM_PLIST(set,pos), obj ) ) {
    GROW_PLIST( set, len+1 );
    SET_LEN_PLIST( set, len+1 );
    {
      Obj *ptr;
      ptr = PTR_BAG(set);
      memmove((void *)(ptr + pos+1),(void*)(ptr+pos),(size_t)(sizeof(Obj)*(len+1-pos)));
#if 0
      for ( i = len+1; pos < i; i-- ) {
	*ptr = *(ptr-1);
	ptr--;   */
	/* SET_ELM_PLIST( set, i, ELM_PLIST(set,i-1) ); */
      }
#endif
    }
    SET_ELM_PLIST( set, pos, obj );
    CHANGED_BAG( set );

    /* fix up the type of the result                                   */
    if ( HAS_FILT_LIST( set, FN_IS_SSORT ) ) {
      isCyc = (TNUM_OBJ(set) == T_PLIST_CYC_SSORT);
      wasHom = HAS_FILT_LIST(set, FN_IS_HOMOG);
      wasTab = HAS_FILT_LIST(set, FN_IS_TABLE);
      wasNHom = HAS_FILT_LIST(set, FN_IS_NHOMOG);
      CLEAR_FILTS_LIST(set);
      /* the result of addset is always dense */
      SET_FILT_LIST( set, FN_IS_DENSE );

				/* if the object we added was not
                                   mutable then we might be able to
                                   conclude more */
      if ( ! IS_MUTABLE_OBJ(obj) ) {
				/* a one element list is automatically
                                   homogenous  and ssorted */
	if (len == 0 )
	  {
	    if (TNUM_OBJ(obj) <= T_CYC)
	      RetypeBagIfWritable( set, T_PLIST_CYC_SSORT);
	    else
	      {
		SET_FILT_LIST( set, FN_IS_HOMOG );
		SET_FILT_LIST( set, FN_IS_SSORT );
		if (IS_HOMOG_LIST(obj))	/* it might be a table */
		  SET_FILT_LIST( set, FN_IS_TABLE );
	      }
	  }
	else
	  {
	    /* Now determine homogeneity */
	    if (isCyc)
	      if (TNUM_OBJ(obj) <= T_CYC)
		RetypeBagIfWritable( set, T_PLIST_CYC_SSORT);
	      else
		{
		  RESET_FILT_LIST(set, FN_IS_HOMOG);
		  SET_FILT_LIST(set, FN_IS_NHOMOG);
		}
	    else if (wasHom)
	      {
		if (!SyInitializing) {
		  notpos = (pos == 1) ? 2 : 1;
		  if (FAMILY_OBJ(ELM_PLIST(set,notpos)) == FAMILY_OBJ(obj))
		    {
		      SET_FILT_LIST(set, FN_IS_HOMOG);
		      if (wasTab) {
			if (IS_HOMOG_LIST( obj ))
			  SET_FILT_LIST(set, FN_IS_TABLE);
		      }
		    }

		  else
		    SET_FILT_LIST(set, FN_IS_NHOMOG);
		}
	      }
	    else if (wasNHom)
	      SET_FILT_LIST(set, FN_IS_NHOMOG);
	  }
      }
      SET_FILT_LIST( set, FN_IS_SSORT );
    }
    else {
      CLEAR_FILTS_LIST(set);
      SET_FILT_LIST( set, FN_IS_DENSE );
    }
  }
Exemple #14
0
Fichier : set.c Projet : vbraun/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);
}