view release on metacpan or  search on metacpan

Permute.xs  view on Meta::CPAN

        pred[n] = ptr_head;
    }
#else
    if (loc[n] < n) {
        /* swap adjacent */
        p[loc[n]] = p[loc[n] + 1];
        p[++loc[n]] = n;
    } else {
        is_done = _next(n - 1, p, loc);
        /* then shift right */
        for (i = n - 1; i >= 1; i--)
            p[i + 1] = p[i];
        /* adjust both extremes */
        p[1] = n;
        loc[n] = 1;
    }
#endif
    return is_done;
}


/* permute_engine() and afp_destructor() are from Robin Houston
 * <robin@kitsite.com> */
void permute_engine(
AV* av, 
SV** array, 
I32 level, 
I32 len, SV*** tmparea, OP* callback)
{
    SV** copy    = tmparea[level];
    int  index   = level;
    bool calling = (index + 1 == len);
    SV*  tmp;
    
    Copy(array, copy, len, SV*);
    
    if (calling)
        AvARRAY_set(av, copy);

    do {
        if (calling) {
            PL_op = callback;
            CALLRUNOPS(aTHX);
        }
        else {
            permute_engine(av, copy, level + 1, len, tmparea, callback);
        }
        if (index != 0) {
            tmp = copy[index];
            copy[index] = copy[index - 1];
            copy[index - 1] = tmp;
        }
    } while (index-- > 0);
}

struct afp_cache {
    SV***         tmparea;
    AV*           array;
    I32           len;
    SV**          array_array;
    U32           array_flags;
    SSize_t       array_fill;
    SV**          copy;          /* Non-magical SV list for magical array */
};

static
void afp_destructor(void *cache)
{
    struct afp_cache *c = cache;
    I32               x;
    
    /* PerlIO_stdoutf("DESTROY!\n"); */

    for (x = c->len; x >= 0; x--) free(c->tmparea[x]);
    free(c->tmparea);
    if (c->copy) {
        for (x = 0; x < c->len; x++) SvREFCNT_dec(c->copy[x]);
        free(c->copy);
    }
    
    AvARRAY_set(c->array, c->array_array);
    SvFLAGS(c->array) = c->array_flags;
    AvFILLp(c->array) = c->array_fill;
    free(c);
}

static
bool reset_combination(Permute *self, AV *av, UV r) {
    UV n;
    COMBINATION *c = NULL;
    if ((n = av_len(av) + 1) == 0) 
        return 0;

    c = init_combination(n, r, av);
    /* PerlIO_stdoutf("passed init_combination()\n"); */
    if (c == NULL) {
        warn("Unable to initialize combination");
        return 0;
    }
    self->c = c;

    coollex(self->c);
    coollex_visit(self->c, self->items + 1); /* base of items is 1 */
    return 1;
}

MODULE = Algorithm::Permute     PACKAGE = Algorithm::Permute        
PROTOTYPES: DISABLE

Permute* 
new(CLASS, av, ...)
    char *CLASS
    AV *av
    PREINIT:
    UV i, num;
    UV r, n;
    UV has_combination;
#ifdef USE_LINKEDLIST
    listrecord *q; /* temporary holder */
#endif
    
    CODE:
    RETVAL = (Permute*) safemalloc(sizeof(Permute));
    if (RETVAL == NULL) {
        warn("Unable to create an instance of Algorithm::Permute");
        XSRETURN_UNDEF;
    }

    RETVAL->is_done = FALSE;
    if ((n = av_len(av) + 1) == 0) 
        XSRETURN_UNDEF;

    /* init combination if necessary */
    has_combination = 0;
    RETVAL->c = NULL;
    num = n;
    if (items > 2) {
        r = SvUV(ST(2));
        if (r > n) {
            warn("Number of combination must be less or equal the number of elements");
            XSRETURN_UNDEF;
        }

Permute.xs  view on Meta::CPAN

    CODE:
    self->is_done = FALSE;

    reset_combination(self, (AV*)(SvRV(self->aryref)), self->num);
#ifdef USE_LINKEDLIST
    q = self->ptr_head;
    for (i = 1; i <= self->num; i++) {
        q = q->link;
        q->info = self->num - i + 1;
        self->pred[i] = self->ptr_head;
    }
    assert(q->link == NULL);
#else
    for (i = 1; i <= self->num; i++) {
        *(self->p + i) = self->num - i + 1;
        *(self->loc + i) = 1;     
    }
#endif

void
permute(callback_sv, array_sv)
SV* callback_sv;
SV* array_sv;
  PROTOTYPE: &\@
  PREINIT:
    CV*           callback;
    GV*           agv;
    I32           x;
    PERL_CONTEXT* cx;
    I32           gimme = G_VOID;  /* We call our callback in VOID context */

    bool          old_catch;
    struct afp_cache *c;
    I32 hasargs = 0;
    SV** newsp;
  PPCODE:
{
    if (!SvROK(callback_sv) || SvTYPE(SvRV(callback_sv)) != SVt_PVCV)
        Perl_croak(aTHX_ "Callback is not a CODE reference");
    if (!SvROK(array_sv)    || SvTYPE(SvRV(array_sv))    != SVt_PVAV)
        Perl_croak(aTHX_ "Array is not an ARRAY reference");
    
    c = malloc(sizeof(struct afp_cache));
    callback = (CV*)SvRV(callback_sv);
    c->array    = (AV*)SvRV(array_sv);
    c->len      = 1 + av_len(c->array);
    
    agv = gv_fetchpv("A", TRUE, SVt_PVAV);
    SAVESPTR(GvSV(agv));

    if (SvREADONLY(c->array))
        Perl_croak(aTHX_ "Can't permute a read-only array");

    if (c->len == 0) {
        /* Should we warn here? */
        free(c);
        return;
    }
    
    c->array_array = AvARRAY(c->array);
    c->array_flags = SvFLAGS(c->array);
    c->array_fill  = AvFILLp(c->array);

    /* Magical array. Realise it temporarily. */
    if (SvRMAGICAL(c->array)) {
        c->copy = (SV**) malloc (c->len * sizeof *(c->copy));
        for (x = 0; x < c->len; x++) {
            SV **svp = av_fetch(c->array, x, FALSE);
            c->copy[x] = (svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef;
        }
        SvRMAGICAL_off(c->array);
        AvARRAY_set(c->array, c->copy);
        AvFILLp(c->array) = c->len - 1;
    } else {
        c->copy = 0;
    }
    
    SvREADONLY_on(c->array); /* Can't change the array during permute */ 
    
    /* Allocate memory for the engine to scribble on */   
    c->tmparea = (SV***) malloc((c->len + 1) * sizeof *(c->tmparea));
    for (x = c->len; x >= 0; x--)
        c->tmparea[x]  = malloc(c->len * sizeof **(c->tmparea));
    
    {
        dMULTICALL;
        PUSH_MULTICALL(callback);
        SAVEDESTRUCTOR(afp_destructor, c);
        permute_engine(c->array, AvARRAY(c->array), 0, c->len, 
            c->tmparea, multicall_cop);
        POP_MULTICALL;
    }
}