script for unrestricted permutation

W

weberh

Hi !

All scripts for permutation I found yet, were restricted by depth
(loops have to be hardcoded) or memory (recursive approach).

Here I wrote a handy script that gives the user unrestricted
choice of number of elements and depth of permutation.

The script is a bit special, because it dynamically generates code.
This code delivers the permutation and is evaluated within the script.

So, "perm 4 red green blue" gives

redredredred
redredredgreen
..
..
blueblueblueblue

It's still an ad hoc script and has to be refined, of course.

Would you like to see it as part of a module ?
Maybe together with other flavors of permutation and combination ?

Here we go ...

#!/usr/bin/perl
#perm: permutation with user defined depth and number of elements
#usage: perm depth element1 element2 ...

use strict;

my ($code,$i);
my ($depth,@element) = @ARGV;


for ($i = 1; $i <= $depth; $i++) #Code generation starts here
{$code .= "for (my \$i$i = 0; \$i$i <= $#element; \$i$i++)\n{"}

$code .= 'print "';

for (my $c=1; $c <= $depth; $c++)
{$code .= "\$element[\$i$c]"}

$code .= '\n"';

for (my $c=1; $c <= $i-1; $c++)
{$code .= '}'}

$code .= "\n"; #Code generation is finished here

eval($code); #Code evaluation gives the permutation




Regards, Harald
 
W

weberh

Alright, but it is slow, no?

[Abacus3]~/perltest: time ./bdperm 10 a b c d > /dev/null

real 1m11.719s
user 1m11.583s
sys 0m0.053s

[Abacus3]~/perltest: time ./perm 10 a b c d > /dev/null

real 0m12.659s
user 0m12.600s
sys 0m0.029s
 
J

Jay Tilton

(e-mail address removed)-berlin.de (weberh) wrote:

: Alright, but it is slow, no?

It is customary to provide some context by quoting relevant material
from the article you are replying to.

recap of bd's code:

while($indices[0] < @elements){
foreach my $index (@indices) {
print "$elements[$index] ";
}
print "\n";
$indices[-1]++;
for($_ = $#indices; $_ > 0; $_--){
if($indices[$_] >= @elements){
$indices[$_] = 0;
$indices[$_ - 1]++;
}
}
}

Sure it's slower. But the idea is readily adapted to give it much
more flexibility.

It's essentially a base-n counter, where n is the number of permutable
items. By changing it from a counter to a decimal-to-base-n
converter, it can be used to obtain any arbitrary permutation without
having to generate the entire set.

my($count, @elements) = @ARGV;
my $permutation = sub {
use integer;
my($i) = @_;
my @indices = ($elements[0]) x $count;
my $c = $count;
while($c && $i) {
$indices[--$c] = $elements[ $i % @elements ];
$i /= @elements;
}
@indices;
};
print $permutation->($_), "\n"
for 0 .. @elements ** $count -1;
 
W

weberh

Thanks for the hint.
I have to admit, that I haven't understood bd's code yet.
I'll make a hardcopy and study it at home with a cup of tea.

(e-mail address removed) (Jay Tilton) wrote in message
 
C

Chris Charley

Thanks for the hint.
I have to admit, that I haven't understood bd's code yet.
I'll make a hardcopy and study it at home with a cup of tea.

I solved this permutation by modeling it on an odometer. The number of
wheels to the odometer is the number of groupings (4, for example). A
car odometer wheel is marked from 0 to 9 - base ten. For the odometer
this code creates, the wheels are from 0 to the number of elements in
the array minus 1. (Total numbers on the wheel = number of array
elements to be permuted). Then, to generate the permutations, you
cycle the odometer (like a car) adding 1, getting that permutation,
and continuing until the odometer 'rolls over' and exits at the last
permutation. This 'perm' function does not handle incorrect parameter
lists or error checking and will be unpredictable in that case. Scalar
@elements is the 'base' of the number system of the odometer.

The line of code:
push @perms, [ @elements[@odometer] ];
Uses array slices to assign elements to the permutation.

#!/usr/bin/perl
use strict;
use warnings;

my $group = 4;

my @perms = perm($group, "red", "green", "blue");

for my $i (0..$#perms) {
for my $j (0..$group-1) {
print "$perms[$i][$j] ";
}
print "\n";
}


# function perm($groupings, @elements)

sub perm {
my $groupings = shift @_;
my @elements = @_;
my @odometer = (0) x $groupings;
my @perms;
while ( 1 ) {
push @perms, [ @elements[@odometer] ];
my $wheel= 0;
$odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;

while ($odometer[$wheel] == 0 && ++$wheel< @odometer) {
$odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;
}
return @perms if $wheel == @odometer;
}
}
 
J

Jay Tilton

(e-mail address removed) (Chris Charley) wrote:

: I solved this permutation by modeling it on an odometer.

Nice analogy.

: #!/usr/bin/perl
: use strict;
: use warnings;
:
: my $group = 4;
: my @perms = perm($group, "red", "green", "blue");
:
: for my $i (0..$#perms) {
: for my $j (0..$group-1) {
: print "$perms[$i][$j] ";
: }
: print "\n";
: }
: sub perm {
: my $groupings = shift @_;
: my @elements = @_;
: my @odometer = (0) x $groupings;
: my @perms;
: while ( 1 ) {
: push @perms, [ @elements[@odometer] ];
: my $wheel= 0;
: $odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;
:
: while ($odometer[$wheel] == 0 && ++$wheel< @odometer) {
: $odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;
: }
: return @perms if $wheel == @odometer;
: }
: }

I like the principle, but the implementation feels a little too
fiddly.

How about instead of monitoring $wheel and bailing out when it indexes
a nonexistent @odometer element, just add another element to
@odometer. Ignore its value in the permutation, but bail out when it
increments. Program flow simplifies itself a lot.

print "@$_\n" for perm(4, "red", "green", "blue");
sub perm {
my($groupings, @elems) = @_;
my @odometer = (0) x ($groupings+1);
my @perms;
until( $odometer[-1] ) {
push @perms, [ @elems[ @odometer[0..$groupings-1] ] ];
for( @odometer ) {
$_++;
last if $_ %= @elems;
}
}
return @perms;
}
 
J

John W. Krahn

Jay said:
(e-mail address removed) (Chris Charley) wrote:

: I solved this permutation by modeling it on an odometer.

Nice analogy.

: #!/usr/bin/perl
: use strict;
: use warnings;
:
: my $group = 4;
: my @perms = perm($group, "red", "green", "blue");
:
: for my $i (0..$#perms) {
: for my $j (0..$group-1) {
: print "$perms[$i][$j] ";
: }
: print "\n";
: }
: sub perm {
: my $groupings = shift @_;
: my @elements = @_;
: my @odometer = (0) x $groupings;
: my @perms;
: while ( 1 ) {
: push @perms, [ @elements[@odometer] ];
: my $wheel= 0;
: $odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;
:
: while ($odometer[$wheel] == 0 && ++$wheel< @odometer) {
: $odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;
: }
: return @perms if $wheel == @odometer;
: }
: }

I like the principle, but the implementation feels a little too
fiddly.

How about instead of monitoring $wheel and bailing out when it indexes
a nonexistent @odometer element, just add another element to
@odometer. Ignore its value in the permutation, but bail out when it
increments. Program flow simplifies itself a lot.

print "@$_\n" for perm(4, "red", "green", "blue");
sub perm {
my($groupings, @elems) = @_;
my @odometer = (0) x ($groupings+1);
my @perms;
until( $odometer[-1] ) {
push @perms, [ @elems[ @odometer[0..$groupings-1] ] ];
for( @odometer ) {
$_++;
last if $_ %= @elems;
}
}
return @perms;
}


This looks a bit simpler. :)

my $group = 4;
my @elements = qw/ red green blue /;

for ( 0 .. ( @elements ** $group ) - 1 ) {
my @odometer;
do { unshift @odometer, $_ % @elements } while $_ = int( $_ / @elements );
@odometer = ( (0) x $group, @odometer )[ map -$_, reverse 1 .. $group ];
print "@{[ map $elements[$_], @odometer ]}\n";
}



John
 
C

Chris Charley

John W. Krahn said:
John W. Krahn said:
This looks a bit simpler. :)

my $group = 4;
my @elements = qw/ red green blue /;

for ( 0 .. ( @elements ** $group ) - 1 ) {
my @odometer;
do { unshift @odometer, $_ % @elements } while $_ = int( $_ / @elements );
@odometer = ( (0) x $group, @odometer )[ map -$_, reverse 1 .. $group ];
print "@{[ map $elements[$_], @odometer ]}\n";
}


Or a bit simpler. :)

my $group = 4;
my @elements = qw/ red green blue /;

for ( 0 .. ( @elements ** $group ) - 1 ) {
my @odometer;
do { unshift @odometer, $_ % @elements } while $_ = int( $_ / @elements );
print "@{[ map $elements[$_], (0) x ($group - @odometer), @odometer ]}\n";
}



John

Well, I didn't mean to offend many of the fine Perl programmers.
Should have kept in mind all the folks that would be viewing my post -
guess I carried the simplified explanation a bit too far? :)

John, I will look over your code to understand its brevity.
 
B

Benjamin Goldberg

weberh said:
Hi !

All scripts for permutation I found yet, were restricted by depth
(loops have to be hardcoded) or memory (recursive approach).

Here I wrote a handy script that gives the user unrestricted
choice of number of elements and depth of permutation.

The script is a bit special, because it dynamically generates code.
This code delivers the permutation and is evaluated within the script.

So, "perm 4 red green blue" gives

redredredred
redredredgreen
.
.
blueblueblueblue

How about the following:

#!/usr/bin/perl -w
use strict;
sub perm {
if( my $x = pop ) {
--$x;
perm( @_, $_, $x ) for @ARGV;
} else {
print "@_\n";
}
}
perm(shift);
__END__
[untested]

Or, if one truly *wants* to use eval(), consider:

#!/usr/bin/perl -w
use strict;
my $count = shift;
my $code = "";
$code .= qq{
for my \$e$_ (\@ARGV) {
} for 1 .. $count;
$code .= q{
print "} . join(" ",
(map "\$e$_", 1 .. $count)
) . q{";
};
$code .= "}" x $count;
eval $code;
__END__
[untested]
 
J

Jay Tilton

(e-mail address removed) (Chris Charley) wrote:

: Well, I didn't mean to offend many of the fine Perl programmers.

What gave you the idea anybody was offended?

Exploring different ways to perform a given task can be an enjoyable
recreation. It's interesting to see how different people look at the
same problem. It's even interesting to see what refinements different
people apply to fundamentally identical approaches.

It wouldn't be Perl without TIMTOWTDI.
 
W

weberh

All scripts for permutation I found yet, were restricted by depth
(loops have to be hardcoded) or memory (recursive approach).

So there are many nice ideas not depending on eval().
Here's a (some kind of primitive) benchmark
(if necessary, scripts were slightly modified, so
command line arguments are accepted).


[Abacus3]~/perltest/bench: for x in `/bin/ls`; do echo $x; time ./$x
10 a b c d > /dev/null; echo xxx; done
bdperm

real 1m12.404s
user 1m11.622s
sys 0m0.061s
xxx
benperm

real 0m15.092s
user 0m14.805s
sys 0m0.049s
xxx
chrisperm

real 1m26.948s
user 1m23.068s
sys 0m3.254s
xxx
haraldperm

real 0m15.749s
user 0m15.656s
sys 0m0.048s
xxx
jayperm

real 1m32.635s
user 1m32.105s
sys 0m0.182s
xxx
johnperm

real 1m49.748s
user 1m48.612s
sys 0m0.362s
xxx

equal output ?

[Abacus3]~/perltest/bench: for x in `/bin/ls`; do echo $x; ./$x 10 a b
c d | wc; echo xxx; done
bdperm
1048576 10485760 22020096
xxx
benperm
1048576 10485760 20971520
xxx
chrisperm
1048576 10485760 22020096
xxx
haraldperm
1048576 10485760 22020096
xxx
jayperm
1048576 1048576 11534336
xxx
johnperm
1048576 10485760 20971520



bdperm
#!/usr/bin/perl -w
use strict;

my $count = shift @ARGV;
my @elements = @ARGV;

my @indices;
unshift @indices, 0 for (0..$count - 1);

while($indices[0] < @elements){
foreach my $index (@indices) {
print "$elements[$index] ";
}
print "\n";
$indices[-1]++;
for($_ = $#indices; $_ > 0; $_--){
if($indices[$_] >= @elements){
$indices[$_] = 0;
$indices[$_ - 1]++;
}
}
}
xxx
benperm
#!/usr/bin/perl -w
use strict;
sub perm {
if( my $x = pop ) {
--$x;
perm( @_, $_, $x ) for @ARGV;
} else {
print "@_\n";
}
}
perm(shift);
xxx
chrisperm
#!/usr/bin/perl -w

use strict;

my $group = shift;

my @perms = perm($group,@ARGV);

for my $i (0..$#perms) {
for my $j (0..$group-1) {
print "$perms[$i][$j] ";
} print "\n";
}


# function perm($groupings, @elements)

sub perm {
my $groupings = shift @_;
my @elements = @_;
my @odometer = (0) x $groupings;
my @perms;
while ( 1 ) {
push @perms, [ @elements[@odometer] ];
my $wheel= 0;
$odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;

while ($odometer[$wheel] == 0 && ++$wheel< @odometer) {
$odometer[$wheel] = ($odometer[$wheel] + 1) % @elements;
}
return @perms if $wheel == @odometer;
}
}
xxx
haraldperm
#!/usr/bin/perl -w
#perm: permutation with user defined depth and number of elements
#usage: perm depth element1 element2 ...
#version 0.02

use strict;

my ($code,$i);
my ($depth,@element) = @ARGV;

for ($i = 1; $i <= $depth; $i++) #Code generation starts here
{$code .= "for (my \$i$i = 0; \$i$i <= $#element; \$i$i++)\n{"}

$code .= 'print "';

for (my $c=1; $c <= $depth; $c++)
{$code .= "\$element[\$i$c] "}

$code .= '\n"' . '}' x$depth . "\n"; #End of Code generation

eval($code); #Code evaluation gives the
permutation

xxx
jayperm
#!/usr/bin/perl -w

my($count, @elements) = @ARGV;
my $permutation = sub {
use integer;
my($i) = @_;
my @indices = ($elements[0]) x $count;
my $c = $count;
while($c && $i) {
$indices[--$c] = $elements[ $i % @elements ];
$i /= @elements;
}
@indices;
};
print $permutation->($_), "\n"
for 0 .. @elements ** $count -1;

xxx
johnperm
#!/usr/bin/perl -w

my $group = shift;
my @elements = @ARGV;

for ( 0 .. ( @elements ** $group ) - 1 ) {
my @odometer;
do { unshift @odometer, $_ % @elements } while $_ = int( $_ /
@elements );
print "@{[ map $elements[$_], (0) x ($group - @odometer),
@odometer ]}\n";
}
xxx
 
C

Chris Charley

John W. Krahn said:
:

[snip]

Or a bit simpler. :)

my $group = 4;
my @elements = qw/ red green blue /;

for ( 0 .. ( @elements ** $group ) - 1 ) {
my @odometer;
do { unshift @odometer, $_ % @elements } while $_ = int( $_ / @elements );
print "@{[ map $elements[$_], (0) x ($group - @odometer), @odometer ]}\n";
}



John
[snip]>
John, I will look over your code to understand its brevity.

Hi John

I know this is not srictly about Perl and probably an algorithmic
topic.

(After running your code through the debugger!), I finally got what
was happening. The do while loop is a base 10 to base 3 (in this
problem) converter. Can be used to convert between base 10 and any
other base.
Sure is clean once you see it. 3 lines in the for loop. Also found
this same algorithm in my old Discreet Math book (by Kenneth Rosen).
Was in a cs program at college but only completed half the program.
With this algorithm you can also selectively perform
any of 0 .. (@elements ** $group - 1) permutations - not nesessary to
generate all the perms if you know which ones you may be concerned
with. :)
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Members online

Forum statistics

Threads
473,744
Messages
2,569,483
Members
44,901
Latest member
Noble71S45

Latest Threads

Top