Algorithm-Permute-0.12/0000755000076400007640000000000011003634320013777 5ustar edwinedwinAlgorithm-Permute-0.12/Changes0000644000076400007640000000334711003633631015305 0ustar edwinedwinRevision history for Perl extension Algorithm::Permute. 0.12 Apr 23 2008 - Maintenance release. Bugfix #35288. 0.11 Jan 4 2008 - Added alternative implementation of the algorithm (enable it using -DUSE_LINKEDLIST) - Added comprehensive benchmarks script, thus replacing the old stuffs inside bench directory 0.10 Jan 2 2008 - Fixed memory error when cleaning up combination struct on Win32 - Fixed compile error when using MSVC6 0.09 Jan 2 2008 - Added test for die() inside permutation block - Added memory leak tests for A::P destructor - New feature: permutation r of n objects. Combination is implemented using coolex algorithm - Updated docs to reflect this feature - Fixed memory leak in A::P destructor 0.08 Dec 27 2007 - Make it pass test #23 (srezic reported crashes on amd64-freebsd-6.2). Thanks to Yoga Eko P for free login to freebsd machine. 0.07 Dec 26 2007 - Make it work with perl-5.10.0 (RT ticket #27022) 0.06 May 28 2003 - Fixed a memory leak in permute() - Fixed bug #2596 : Perl context stack manip done in safer way in permute() - array passed to permute() not marked as R/O. see test #23 for reason - test.pl extended with eval and mem leak tests 0.05 May 16 2003 - Added -DPERL_EXT to legalise use of perl-5.9.0's cxinc - Uses PAD_SET_CUR macro when defined, this fixes problem with invalid pad in 5.9.0 0.04 Mar 6 2002 - Fixed cross-compiler compatibility problem in the callback hack, by Robin 0.03 Sep 5 2001 - Added callback interface by Robin Houston - Fixed bogus benchmark 0.02 Sep 2 2000 - Major interface changes. Now object-oriented 0.01 Fri Sep 1 18:05:17 2000 - original version; created by h2xs 1.19 Algorithm-Permute-0.12/bench/0000755000076400007640000000000011003634320015056 5ustar edwinedwinAlgorithm-Permute-0.12/bench/benchmark.pl0000755000076400007640000001104010737367311017364 0ustar edwinedwin#!/usr/bin/perl -w # for your own pleasure and curiosity use strict; use blib; use Algorithm::Permute 'permute'; use Benchmark ':all'; use Getopt::Std; # process options my %opts; getopts('yrhl:n:', \%opts) or usage(); $opts{h} and usage(); $opts{n} ||= 9; $opts{l} ||= 5; my @arr = (1..$opts{n}); # runners my %runners = ( 'Combinatorial::Permutations' => sub { my @res = Combinatorial::Permutations::permutate(@arr); }, 'Memoization' => sub { my $num_permutations = PMemoization::factorial(scalar @arr); for (my $i=0; $i < $num_permutations; $i++) { my @permutation = @arr[PMemoization::n2perm($i, $#arr)]; # print "@permutation\n"; } }, 'LISPy' => sub { LISPy::faq_permute([@arr], []) }, 'List::Permutor' => sub { my $l = new List::Permutor(@arr); while (my @res = $l->next) {} }, 'Algorithm::Permute' => sub { my $p = new Algorithm::Permute([@arr]); while (my @res = $p->next) {} }, 'Algorithm::Permute qw(permute)' => sub { permute { my @res = @arr } @arr; }, 'Algorithm::Combinatorics' => sub { my $i = Algorithm::Combinatorics::permutations(\@arr); while (my $p = $i->next) {} }, 'Math::Combinatorics' => sub { my $combinat = Math::Combinatorics->new(count => $opts{n}, data => \@arr); while (my @res = $combinat->next_permutation) {} }, ); my @modules; # load optional modules my @optionals = qw/Algorithm::Combinatorics Math::Combinatorics List::Permutor/; foreach my $m (@optionals) { eval "require $m"; if ($@) { print "Unable to load $m. Not yet installed?\n"; } else { print "Module $m loaded.\n"; push @modules, $m; } } # give user a chance to select modules to his/her interest print "\nRun benchmark against:\n"; my @selected = grep { print "$_ [Y/n]? "; if ($opts{'y'}) { print "Y\n"; 1 } else { my $ans = <>; $ans !~ /^N/i } } @modules, qw/Combinatorial::Permutations Memoization LISPy/; print "\n"; my $i = 0; my %modules = map { sprintf("%02d_", $i++) . $_ => $runners{$_} } 'Algorithm::Permute qw(permute)', 'Algorithm::Permute', @selected; # run benchmark my $b = timethese($opts{l}, \%modules); $opts{r} and do { print "\n"; cmpthese($b); }; sub usage { print <<"USAGE"; $0 [options] -h this help -l number of loop (default: 5) -n size of array (default: 9) -r print benchmark comparison chart (default: no) -y yes to all confirmation question (default: no) Example: Run permutation of 8 objects in 10 loop, and print comparison chart: perl benchmark.pl -l 10 -n 8 -r USAGE exit; } package LISPy; no strict; no warnings; sub faq_permute{ my @items = @{ $_[0] }; my @perms = @{ $_[1] }; unless (@items) { # print "@perms\n"; @res = @perms; } else { my(@newitems,@newperms,$i); foreach $i (0 .. $#items) { @newitems = @items; @newperms = @perms; unshift(@newperms, splice(@newitems, $i, 1)); faq_permute([@newitems], [@newperms]); } } } package PMemoization; # permutation utilizing memoization use strict; # Utility function: factorial with memorizing BEGIN { no warnings; my @fact = (1); sub factorial($) { my $n = shift; return $fact[$n] if defined $fact[$n]; $fact[$n] = $n * factorial($n - 1); } } # n2pat($N, $len) : produce the $N-th pattern of length $len sub n2pat { my $i = 1; my $N = shift; my $len = shift; my @pat; while ($i <= $len + 1) { # Should really be just while ($N) { ... push @pat, $N % $i; $N = int($N/$i); $i++; } return @pat; } # pat2perm(@pat) : turn pattern returned by n2pat() into # permutation of integers. XXX: splice is already O(N) sub pat2perm { my @pat = @_; my @source = (0 .. $#pat); my @perm; push @perm, splice(@source, (pop @pat), 1) while @pat; return @perm; } # n2perm($N, $len) : generate the Nth permutation of S objects sub n2perm { pat2perm(n2pat(@_)); } package Combinatorial::Permutations; # from abigail use strict; use Exporter; use vars qw /@EXPORT @EXPORT_OK @ISA/; @ISA = qw /Exporter/; @EXPORT = (); @EXPORT_OK = qw /permutate/; sub permutate (@); # Return a list of permutations of the given list. sub permutate (@) { return () unless @_; my $first = shift; return ([$first]) unless @_; map {my $row = $_; map {my $tmp = [@$row]; splice @$tmp, $_, 0, $first; $tmp;} (0 .. @$row);} permutate @_; } Algorithm-Permute-0.12/MANIFEST0000644000076400007640000000026210737363234015150 0ustar edwinedwinREADME Changes Makefile.PL MANIFEST Permute.pm Permute.xs test.pl typemap coollex.c coollex.h bench/benchmark.pl META.yml Module meta-data in YAML Algorithm-Permute-0.12/Permute.pm0000644000076400007640000001375411003633142015771 0ustar edwinedwin# Permute.pm # # Copyright (c) 1999 - 2008 Edwin Pratomo # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the Perl README file, # with the exception that it cannot be placed on a CD-ROM or similar media # for commercial distribution without the prior approval of the author. package Algorithm::Permute; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); require Exporter; require DynaLoader; require AutoLoader; @ISA = qw(Exporter DynaLoader); @EXPORT_OK = qw(permute); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. $VERSION = '0.12'; bootstrap Algorithm::Permute $VERSION; # Preloaded methods go here. # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__ =head1 NAME Algorithm::Permute - Handy and fast permutation with object oriented interface =head1 SYNOPSIS use Algorithm::Permute; # default is to create n of n objects permutation generator my $p = new Algorithm::Permute(['a'..'d']); # but also you can create r of n objects permutation generator, where r <= n my $p = new Algorithm::Permute([1..4], 3); while (@res = $p->next) { print join(", ", @res), "\n"; } # and this one is the speed demon: my @array = (1..9); Algorithm::Permute::permute { print "@array\n" } @array; =head1 DESCRIPTION This handy module makes performing permutation in Perl easy and fast, although perhaps its algorithm is not the fastest on the earth. It supports permutation r of n objects where 0 < r <= n. =head1 METHODS =over 4 =item new [@list] Returns a permutor object for the given items. =item next Returns a list of the items in the next permutation. The order of the resulting permutation is the same as of the previous version of C. =item peek Returns the list of items which B by next(), but B. Could be useful if you wished to skip over just a few unwanted permutations. =item reset Resets the iterator to the start. May be used at any time, whether the entire set has been produced or not. Has no useful return value. =back =head1 CALLBACK STYLE INTERFACE Starting with version 0.03, there is a function - not exported by default - which supports a callback style interface: =over 4 =item permute BLOCK ARRAY A block of code is passed, which will be executed for each permutation. The array will be changed in place, and then changed back again before C returns. During the execution of the callback, the array is read-only and you'll get an error if you try to change its length. (You I change its elements, but the consequences are liable to confuse you and may change in future versions.) You have to pass an array, it can't just be a list. It B work with special arrays and tied arrays, though unless you're doing something particularly abstruse you'd be better off copying the elements into a normal array first. Example: my @array = (1..9); permute { print "@array\n" } @array; The code is run inside a pseudo block, rather than as a normal subroutine. That means you can't use C, and you can't jump out of it using C and so on. Also, C won't tell you anything helpful from inside the callback. Such is the price of speed. The order in which the permutations are generated is not guaranteed, so don't rely on it. The low-level hack behind this function makes it currently the fastest way of doing permutation among others. =back =head1 COMPARISON I've collected some Perl routines and modules which implement permutation, and do some simple benchmark. The whole result is the following. Permutation of B scalars: Abigail's : 9 wallclock secs ( 8.07 usr + 0.30 sys = 8.37 CPU) Algorithm::Permute : 5 wallclock secs ( 5.72 usr + 0.00 sys = 5.72 CPU) Algorithm::Permute qw(permute): 2 wallclock secs ( 1.65 usr + 0.00 sys = 1.65 CPU) List::Permutor : 27 wallclock secs (26.73 usr + 0.01 sys = 26.74 CPU) Memoization : 32 wallclock secs (32.55 usr + 0.02 sys = 32.57 CPU) perlfaq4 : 36 wallclock secs (35.27 usr + 0.02 sys = 35.29 CPU) Permutation of B scalars (the Abigail's routine is commented out, because it stores all of the result in memory, swallows all of my machine's memory): Algorithm::Permute : 43 wallclock secs ( 42.93 usr + 0.04 sys = 42.97 CPU) Algorithm::Permute qw(permute): 15 wallclock secs ( 14.82 usr + 0.00 sys = 14.82 CPU) List::Permutor : 227 wallclock secs (226.46 usr + 0.22 sys = 226.68 CPU) Memoization : 307 wallclock secs (306.69 usr + 0.43 sys = 307.12 CPU) perlfaq4 : 272 wallclock secs (271.93 usr + 0.33 sys = 272.26 CPU) The benchmark script is included in the bench directory. I understand that speed is not everything. So here is the list of URLs of the alternatives, in case you hate this module. =over 4 =item * Memoization is discussed in chapter 4 Perl Cookbook, so you can get it from O'Reilly: ftp://ftp.oreilly.com/published/oreilly/perl/cookbook =item * Abigail's: http://www.foad.org/~abigail/Perl =item * List::Permutor: http://www.cpan.org/modules/by-module/List =item * The classic way, usually used by Lisp hackers: perldoc perlfaq4 =back =head1 AUTHOR Edwin Pratomo, I. The object oriented interface is taken from Tom Phoenix's C. Robin Houston invented and contributed the callback style interface. =head1 ACKNOWLEDGEMENT Yustina Sri Suharini - my ex-fiance-now-wife, for providing the permutation problem to me. =head1 SEE ALSO =over 2 =item * B - Korsh and Garrett =item * B - Moret and Shapiro =back =cut Algorithm-Permute-0.12/Makefile.PL0000644000076400007640000000116611003634231015756 0ustar edwinedwinuse ExtUtils::MakeMaker; use Config; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. $optionals{LICENSE} = 'perl' if $Config{api_version} > 8; WriteMakefile( 'NAME' => 'Algorithm::Permute', 'VERSION_FROM' => 'Permute.pm', # finds $VERSION 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '-DPERL_EXT', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' 'OBJECT' => 'coollex.o Permute.o', 'CCFLAGS' => $Config{ccflags}, # '-Wall -fno-strict-aliasing', %optionals, ); Algorithm-Permute-0.12/typemap0000644000076400007640000000116607345516444015431 0ustar edwinedwinTYPEMAP Permute* O_OBJECT UINT T_IV AV * T_AvRV OUTPUT O_OBJECT sv_setref_pv( $arg, CLASS, (void*)$var ); T_AvRV $arg = newRV((SV*)$var); INPUT O_OBJECT if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) ) $var = ($type)SvIV((SV*)SvRV( $arg )); else{ warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" ); XSRETURN_UNDEF; } T_AvRV if( SvROK($arg) && (SvTYPE(SvRV($arg)) == SVt_PVAV) ) $var = (AV*)SvRV( $arg ); else { warn( \"${Package}::$func_name() -- $var is not an AV reference\" ); XSRETURN_UNDEF; } Algorithm-Permute-0.12/Permute.xs0000644000076400007640000003301410737255437016022 0ustar edwinedwin/* Permute.xs Copyright (c) 1999 - 2008 Edwin Pratomo You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file, with the exception that it cannot be placed on a CD-ROM or similar media for commercial distribution without the prior approval of the author. */ #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #include "coollex.h" #ifdef __cplusplus } #endif #ifdef TRUE #undef TRUE #endif #ifdef FALSE #undef FALSE #endif #define TRUE 1 #define FALSE 0 /* For 5.005 compatibility */ #ifndef aTHX_ # define aTHX_ #endif #ifndef aTHX # define aTHX #endif #ifdef ppaddr # define PL_ppaddr ppaddr #endif /* (Robin) This hack is stolen from Graham Barr's Scalar-List-Utils package. The comment therein runs: Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc) was not exported. Therefore platforms like win32, VMS etc have problems so we redefine it here -- GMB With any luck, it will enable us to build under ActiveState Perl. */ #if PERL_VERSION < 7/* Not in 5.6.1. */ # define SvUOK(sv) SvIOK_UV(sv) # ifdef cxinc # undef cxinc # endif # define cxinc() my_cxinc(aTHX) static I32 my_cxinc(pTHX) { cxstack_max = cxstack_max * 3 / 2; Renew(cxstack, cxstack_max + 1, struct context); /* XXX should fix CXINC macro */ return cxstack_ix + 1; } #endif /* (Robin) Assigning to AvARRAY(array) expands to an assignment which has a typecast on the left-hand side. * So it was technically illegal, but GCC is decent enough to accept it * anyway. Unfortunately other compilers are not usually so forgiving... */ #if PERL_VERSION >= 9 # define AvARRAY_set(av, val) ((av)->sv_u.svu_array) = val #else # define AvARRAY_set(av, val) ((XPVAV*) SvANY(av))->xav_array = (char*) val #endif typedef unsigned int UINT; typedef unsigned long ULONG; #ifdef USE_LINKEDLIST typedef struct record { int info; struct record *link; } listrecord; #endif typedef struct { bool is_done; SV **items; UV num; #ifdef USE_LINKEDLIST listrecord *ptr_head, **ptr, **pred; #else UINT *loc; /* location of n in p[] */ UINT *p; #endif COMBINATION *c; } Permute; /* private _next */ #ifdef USE_LINKEDLIST static bool _next(UV n, listrecord *ptr_head, listrecord **ptr, listrecord **pred) #else static bool _next(UV n, UINT *p, UINT *loc) #endif { #ifndef USE_LINKEDLIST int i; #endif bool is_done = FALSE; if (n <= 1) /* termination condition */ return TRUE; #ifdef USE_LINKEDLIST /* less arithmetic */ if (ptr[n]->link != NULL) { pred[n]->link = ptr[n]->link; pred[n] = pred[n]->link; ptr[n]->link = pred[n]->link; pred[n]->link = ptr[n]; } else { pred[n]->link = NULL; is_done = _next(n - 1, ptr_head, ptr, pred); ptr[n]->link = ptr_head->link; ptr_head->link = ptr[n]; /* change head of list */ 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 * */ 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); } MODULE = Algorithm::Permute PACKAGE = Algorithm::Permute PROTOTYPES: DISABLE Permute* new(CLASS, av, ...) char *CLASS AV *av PREINIT: UV i, num; COMBINATION *c; UV r, n; #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 */ 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; } if (r < n) { c = init_combination(n, r, av); /* PerlIO_stdoutf("passed init_combination()\n"); */ if (c == NULL) { warn("Unable to initialize combination"); XSRETURN_UNDEF; } RETVAL->c = c; num = r; } else { RETVAL->c = NULL; num = n; } } else { RETVAL->c = NULL; num = n; } RETVAL->num = num; if ((RETVAL->items = (SV**) safemalloc(sizeof(SV*) * (num + 1))) == NULL) XSRETURN_UNDEF; #ifdef USE_LINKEDLIST RETVAL->ptr_head = safemalloc(sizeof(listrecord)); if (RETVAL->ptr_head == NULL) XSRETURN_UNDEF; q = RETVAL->ptr_head; RETVAL->ptr = safemalloc(sizeof(listrecord*) * (num + 1)); if (RETVAL->ptr == NULL) XSRETURN_UNDEF; RETVAL->pred = safemalloc(sizeof(listrecord*) * (num + 1)); if (RETVAL->pred == NULL) XSRETURN_UNDEF; #else RETVAL->p = (UINT*) safemalloc(sizeof(UINT) * (num + 1)); if (RETVAL->p == NULL) XSRETURN_UNDEF; RETVAL->loc = (UINT*) safemalloc(sizeof(UINT) * (num + 1)); if (RETVAL->loc == NULL) XSRETURN_UNDEF; #endif /* initialize items, p, and loc */ for (i = 1; i <= num; i++) { if (RETVAL->c) { *(RETVAL->items + i) = &PL_sv_undef; } else { *(RETVAL->items + i) = av_shift(av); } #ifdef USE_LINKEDLIST q->link = safemalloc(sizeof(listrecord)); if (q->link == NULL) XSRETURN_UNDEF; q = q->link; q->info = num - i + 1; RETVAL->ptr[q->info] = q; RETVAL->pred[i] = RETVAL->ptr_head; /* all predecessors point to ptr_head */ #else *(RETVAL->p + i) = num - i + 1; *(RETVAL->loc + i) = 1; #endif } #ifdef USE_LINKEDLIST q->link = NULL; /* the tail of list points to NULL */ #endif if (RETVAL->c) { coollex(RETVAL->c); coollex_visit(RETVAL->c, RETVAL->items + 1); /* base of items is 1 */ } OUTPUT: RETVAL void next(self) Permute *self PREINIT: int i; #ifdef USE_LINKEDLIST listrecord *q; /* temporary holder */ #endif PPCODE: if (self->is_done && self->c) { /* permutation done */ self->is_done = coollex(self->c); /* generate next combination */ #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; } /* q->link = NULL; */ assert(q->link == NULL); /* should point to NULL */ #else /* reset self->p and self->loc */ for (i = 1; i <= self->num; i++) { *(self->p + i) = self->num - i + 1; *(self->loc + i) = 1; } #endif /* and update self->items */ coollex_visit(self->c, self->items + 1); } if (self->is_done) { /* done permutation for all combination */ if (self->c) { free_combination(self->c); self->c = NULL; } XSRETURN_EMPTY; } else { EXTEND(sp, self->num); #ifdef USE_LINKEDLIST q = self->ptr_head->link; while (q) { PUSHs(sv_2mortal(newSVsv(*(self->items + q->info)))); /* PerlIO_stdoutf("%d\n", q->info); */ q = q->link; } self->is_done = _next(self->num, self->ptr_head, self->ptr, self->pred); #else for (i = 1; i <= self->num; i++) { PUSHs(sv_2mortal(newSVsv(*(self->items + *(self->p + i))))); } self->is_done = _next(self->num, self->p, self->loc); #endif } void DESTROY(self) Permute *self PREINIT: int i; #ifdef USE_LINKEDLIST listrecord *q; #endif CODE: #ifdef USE_LINKEDLIST q = self->ptr_head; for (i = 1; i <= self->num; i++) { safefree(self->ptr[i]); /* No need to deallocate this, in fact, it would be disaster */ /* safefree(self->pred[i]); */ SvREFCNT_dec(*(self->items + i)); } safefree(self->ptr); safefree(self->pred); safefree(self->ptr_head); #else safefree(self->p); /* must free elements first? */ safefree(self->loc); for (i = 1; i <= self->num; i++) { /* leakproof! */ SvREFCNT_dec(*(self->items + i)); } #endif safefree(self->items); safefree(self); void peek(self) Permute *self PREINIT: #ifdef USE_LINKEDLIST listrecord *q; #else int i; #endif PPCODE: if (self->is_done) XSRETURN_EMPTY; EXTEND(sp, self->num); #ifdef USE_LINKEDLIST q = self->ptr_head->link; while (q) { PUSHs(sv_2mortal(newSVsv(*(self->items + q->info)))); q = q->link; } #else for (i = 1; i <= self->num; i++) PUSHs(sv_2mortal(newSVsv(*(self->items + *(self->p + i))))); #endif void reset(self) Permute *self PREINIT: int i; #ifdef USE_LINKEDLIST listrecord *q; #endif CODE: self->is_done = FALSE; #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)); /* Set up the context for the callback */ SAVESPTR(CvROOT(callback)->op_ppaddr); CvROOT(callback)->op_ppaddr = PL_ppaddr[OP_NULL]; /* Zap the OP_LEAVESUB */ #ifdef PAD_SET_CUR PAD_SET_CUR(CvPADLIST(callback),1); #else SAVESPTR(PL_curpad); PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(callback))[1]); #endif SAVETMPS; SAVESPTR(PL_op); PUSHBLOCK(cx, CXt_NULL, SP); /* make a pseudo block */ PUSHSUB(cx); old_catch = CATCH_GET; CATCH_SET(TRUE); save_destructor(afp_destructor, c); permute_engine(c->array, AvARRAY(c->array), 0, c->len, c->tmparea, CvSTART(callback)); POPBLOCK(cx,PL_curpm); CATCH_SET(old_catch); } Algorithm-Permute-0.12/README0000644000076400007640000000100310737340635014671 0ustar edwinedwin Algorithm::Permute - Handy and fast permutation with object oriented interface As of version 0.11, a different implementation of the same permutation generator algorithm can be chosen at compile time. This one uses linked list instead of array, and hopefully a little bit faster. To enable this, run Makefile.PL with a custom DEFINE argument: perl Makefile.PL DEFINE="-DPERL_EXT -DUSE_LINKEDLIST" This option only affects the iterative style (OO) interface. The callback interface remains unaffected. Algorithm-Permute-0.12/META.yml0000664000076400007640000000046011003634320015252 0ustar edwinedwin# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Algorithm-Permute version: 0.12 version_from: Permute.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30 Algorithm-Permute-0.12/test.pl0000644000076400007640000001323210737166262015336 0ustar edwinedwin# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..32\n"; } END {print "not ok 1\n" unless $loaded;} @correct = ("3 2 1", "2 3 1", "2 1 3", "3 1 2", "1 3 2", "1 2 3"); use Algorithm::Permute qw(permute); $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): $perm = Algorithm::Permute->new([1..3]); print ( $perm ? "ok 2\n" : "not ok 2\n"); # peek.. @peek = $perm->peek; print "# @peek.\nnot " unless "@peek" eq $correct[0]; print "ok 3\n"; # next.. while (@res = $perm->next) { print "# @res.\nnot " unless "@res" eq $correct[$cnt++]; print ("ok ". ($cnt + 3) . "\n"); } # reset.. $cnt = 0; $perm->reset; while (@res = $perm->next) { print "# @res.\nnot " unless "@res" eq $correct[$cnt++]; print "ok ". ($cnt + 9) . "\n"; } print $cnt == 6 ? "ok 16\n" : "not ok 16\n"; # Tests for the callback interface by Robin Houston my @array = (1..9); my $i = 0; permute { ++$i } @array; print ($i == 9*8*7*6*5*4*3*2*1 ? "ok 17\n" : "not ok 17\n"); print ($array[0] == 1 ? "ok 18\n" : "not ok 18\n"); @array = (); $i = 0; permute { ++$i } @array; print ($i == 0 ? "ok 19\n" : "not ok 19\n"); @array = ('A'..'E'); my @foo; permute { @foo = @array; } @array; my $ok = ( join("", @foo) eq join("", reverse @array) ); print ($ok ? "ok 20\n" : "not ok 20\n"); tie @array, 'TieTest'; permute { $_ = "@array" } @array; print (TieTest->c() == 600 ? "ok 21\n" : "not ok 21\t# ".TieTest->c()."\n"); untie @array; ########################################## # test eval block outside of permute block { my @array = (1..2); $i = 0; eval { permute { die if (++$i > 1 ) } @array; }; print "ok 22\n"; eval { @array = (1..2); }; # try to change the array after die() print $@ ? 'not ' : '', "ok 23\n"; } ###################################### # test eval block inside permute block @array = (qw/a r s e/); $i = 0; permute {eval {goto foo}; ++$i } @array; if ($@ =~ /^Can't "goto" out/) { print "ok 24\n"; } else { foo: print "not ok 24\t# $@\n"; } print ($i == 24 ? "ok 25\n" : "not ok 25\n"); { # test r of n permutation my %expected = map { $_ => 1 } qw/2_1 1_2 3_2 2_3 3_1 1_3/; my $p = Algorithm::Permute->new([1..3], 2); print ($p ? "ok 26\n" : "not ok 26\n"); my $found; while (my @r = $p->next) { my $key = join('_', @r); # print "key: $key\n"; $found = delete $expected{$key}; break unless $found; } if (not $found or keys(%expected)) { print "not ok 27\n"; } else { print "ok 27\n"; } } ###################### # test for memory leak $^O !~ /linux/ || !$ENV{MEMORY_TEST} and do { for (28..32) { print "skipping $_: memory leak test\n" } exit 0; }; # OO interface memory leak test for ($i = 0; $i < 10000; $i++) { $perm->reset; while (@res = $perm->next) { } if ($i == 0) { $ok = check_mem(1); # initialize } elsif ($i % 100 == 99) { !$ok or $ok = check_mem(); } } print $ok ? '' : 'not ', "ok 28\n"; for ($i = 0; $i < 10000; $i++) { @array = ('A'..'E'); permute { } @array; if ($i == 0) { $ok = check_mem(1); # initialize } elsif ($i % 100 == 99) { !$ok or $ok = check_mem(); } } print $ok ? '' : 'not ', "ok 29\n"; for ($i = 0; $i < 10000; $i++) { @array = ('A'..'E'); eval { permute { die } @array }; if ($i == 0) { $ok = check_mem(1); # initialize } elsif ($i % 100 == 99) { !$ok or $ok = check_mem(); } } print $ok ? '' : 'not ', "ok 30\n"; { # test A::P destructor for ($i = 0; $i < 10000; $i++) { my $p = Algorithm::Permute->new([1..4]); while (@res = $p->next) { } if ($i == 0) { $ok = check_mem(1); # initialize } elsif ($i % 100 == 99) { !$ok or $ok = check_mem(); } } print $ok ? '' : 'not ', "ok 31\n"; } { # test A::P destructor, r of n permutation for ($i = 0; $i < 10000; $i++) { my $p = Algorithm::Permute->new([1..4], 3); while (@res = $p->next) { } if ($i == 0) { $ok = check_mem(1); # initialize } elsif ($i % 100 == 99) { !$ok or $ok = check_mem(); } } print $ok ? '' : 'not ', "ok 32\n"; } my $c; package TieTest; sub TIEARRAY {bless []} sub FETCHSIZE {5} sub FETCH { ++$c; $_[1]} sub c {$c} package main; sub check_mem { my $initialise = shift; # Log Memory Usage local $^W; my %mem; if (open(FH, "/proc/self/status")) { my $units; while () { if (/^VmSize.*?(\d+)\W*(\w+)$/) { $mem{Total} = $1; $units = $2; } if (/^VmRSS:.*?(\d+)/) { $mem{Resident} = $1; } } close FH; print("# Mem Total: $mem{Total} $units, Resident: $mem{Resident} $units\n") if $ENV{MEMORY_TEST} > 1; if ($TOTALMEM != $mem{Total}) { warn("LEAK! : ", $mem{Total} - $TOTALMEM, " $units\n") unless $initialise; $TOTALMEM = $mem{Total}; return $initialise ? 1 : 0; } return 1; } } Algorithm-Permute-0.12/coollex.h0000644000076400007640000000163011003632760015623 0ustar edwinedwin/* Copyright (c) 2008 Edwin Pratomo You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file, with the exception that it cannot be placed on a CD-ROM or similar media for commercial distribution without the prior approval of the author. */ #ifndef COOLEX_H #define COOLEX_H #include "EXTERN.h" #include "perl.h" #include "XSUB.h" typedef struct { IV n; IV r; SV *aryref; unsigned char *b; /* bitstring: array of bytes */ int state; /* state 0 / 1 / 2 */ int x; int y; } COMBINATION; COMBINATION* init_combination(IV n, IV r, AV *av); void free_combination(COMBINATION *c); /* coollex pseudo-coroutine */ bool coollex(COMBINATION *c); void coollex_visit(COMBINATION *c, SV **p_items); #endif Algorithm-Permute-0.12/coollex.c0000644000076400007640000000451311003633171015616 0ustar edwinedwin/* Copyright (c) 2008 Edwin Pratomo You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file, with the exception that it cannot be placed on a CD-ROM or similar media for commercial distribution without the prior approval of the author. */ #include "coollex.h" COMBINATION* init_combination(IV n, IV r, AV *av) { COMBINATION *c = NULL; int i; unsigned char *b = NULL; SV *aryref = newRV_inc((SV*) av); /* init bitstring */ b = (unsigned char*)safecalloc(n, sizeof(unsigned char)); if (b == NULL) return NULL; for (i = 0; i < r; i++) b[i] = 1; c = (COMBINATION*)safemalloc(sizeof(COMBINATION)); if (c == NULL) { safefree(b); return NULL; } c->n = n; c->r = r; c->aryref = aryref; c->b = b; c->state = 0; c->x = 1; c->y = 0; return c; } void free_combination(COMBINATION *c) { safefree(c->b); SvREFCNT_dec(c->aryref); safefree(c); } /* coollex algorithm */ bool coollex(COMBINATION *c) { bool is_done = FALSE; switch (c->state) { case 0: /* state 0: initialized */ c->state = 1; break; case 1: /* state 1: first shift */ c->b[c->r] =1; c->b[0] = 0; c->state = 2; break; default: /* subsequent shifts */ { while (c->x < c->n - 1) { c->b[c->x++] = 0; c->b[c->y++] = 1; if (c->b[c->x] == 0) { c->b[c->x] = 1, c->b[0] = 0; if (c->y > 1) c->x = 1; c->y = 0; } return is_done; } is_done = TRUE; } } return is_done; } void coollex_visit(COMBINATION *c, SV **p_items) { int i, r = 0; SV **p, **svp; AV *av = (AV*)SvRV(c->aryref); for (i = 0, p = p_items; i < c->n; i++) { if (c->b[i]) { /* the bitstring matters */ r++; /* tell GC to take care of this */ if (SvOK(*p)) { SvREFCNT_dec(*p); } svp = av_fetch(av, i, FALSE); *p = (svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef; p++; } } assert(r == c->r); }