Dogg has asked for the
wisdom of the Perl Monks concerning the following question:
I have a working algorithm, but it needs work.
I want a program to take five arrays (@a  @e, each array
runs at least 02) and a produce every permutation. This is easy for
me with a for loop. But, to complicate things, I want to produce
these permutations in a specific sequence  namely I want all
the numbers to stay nonzero as long as possible (except the middle
one, c  this one can be whatever).
For example, I want 01010 to come before 02000 (two nonzeros vs.
one nonzero), but a simple nested for loop gets it wrong.
I was able to solve this problem and get it right, but I had to
use 15 for loops like this one...
$b = 0;
$d =0;
for ($a=scalar(@minus2)1; $a>=1; $a){
for ($e=scalar(@plus2)1; $e>=1; $e){
for ($c=scalar(@mut)1; $c>=0; $c){
push(@possible, $minus2[$a].$minus[$b].$mut[$c].$plus[$d].$plus2[$e]);
}}}
where in each loop I hold an increasing number of variables at
at zero.
This just seems really inefficient and ugly to use 15 loops.
Assuming this is clear, any ideas on how to improve this algroithm?
Thanks,
Greg
Re: How can I improve this? by lhoward (Vicar) on Jul 25, 2000 at 07:12 UTC 
One solution that comes to mind is to generate the
list outoforder then sort it into order.
@bar=sort {zc($a) <=> zc($b)}
permute([0..2],[0..2],[0..2],[0..2],[0..2]);
sub zc{
my $arg=shift;
my @a=split //,$arg;
return (grep /0/,@a[0..1])+(grep /0/,@a[3..4]);
}
This is shorter (linesofcode wise) than the 16 loops you describe, but will
run slower. You could build the same sort of idea
into the algorithm by using a heap w/ the same sort rule,
but the end result would be algorithmically equivalent
performance wise.
Another approach (it is too late tonight for me
to work this out completely):
Assume that permute($a,$b,$c,$d,$e) takes array references
as its arguments and returns a list of all the permutations of the elements
of those lists.
Also assume that the function nz takes a list reference and
returns all nonzero elements of that list.
Then what you want to do is call permute like this:
push @list,permute(nz($a),nz($b),$c,nz($d),nz($e));
push @list,permute([0],nz($b),$c,nz($d),nz($e));
push @list,permute(nz($a),[0],$c,nz($d),nz($e));
push @list,permute(nz($a),nz($b),$c,[0],nz($e));
push @list,permute(nz($a),nz($b),$c,nz($d),[0]);
push @list,permute([0],[0],$c,nz($d),nz($e));
etc...
Basically the "16 loops" you describe above. There is a
very definite pattern to how the arguments of permute
are set up for each call.
Now all that is left is to figure out how
to generate that pattern.
 [reply] [d/l] [select] 
Re: How can I improve this? by young perlhopper (Scribe) on Jul 25, 2000 at 07:14 UTC 
One thing you could do is simply generate all permutations,
and then sort them. i.e.
@array = magical_permutation_generating_sub;
@sorted_array = sort srtsub @array;
sub srtsub {
#strip out everything that's not a zero, making it easy
#to compare the number of zeros
($A = $a) =~ s/[^0]//;
($B = $b) =~ s/[^0]//;
return ($A gt $B);
}
This presumes that your only sorting criteria is the number
of zeros. But if you have more, just add them to srtsub.
Good luck,
Mark
p.s. goshdarnit lhoward beat me to it and posted better
code. I'm gonna leave mine up though cause i think its a
little easier for somebody who (i gather) has a C background
to grok.  [reply] [d/l] 
RE: How can I improve this? by ferrency (Deacon) on Jul 25, 2000 at 07:31 UTC 
for my $a (0..@a) {
for my $b (0..@b) {
for my $c (0..@c) {
for my $d (0..@d) {
for my $e (0..@e) {
# Build a hash with the permutation as the key, and the
# number of zeros as the value
$permutation{$a[$a].$b[$b].$c[$c].$d[$d].$e[$e]} =
!$a + !$b + !$c + !$d + !$e;
}}}}}
# Now sort according to the number of zeros
return sort {$permutation{$a} <=> $permutation{$b}} keys %permutation;
If you want more order than just "least number of zeros
first," then you can create a more complex sorting routine
using an  operator to break the tie between equal numbers of
zeros. For example, to sort first according to number of
zeros, and then asciibetical on the permutation created,
use this:
return sort {$permutation{$a} <=> $permutation{$b} 
$a cmp $b} keys %permutation;
This code doesn't treat @c any differently than the rest of the arrays. If you don't care about @c, you could simply leave it out
of the "number of zeros" calculation when assigning things into %permutation.
I hope this helps.
Goshdarnit they both beat me to it, and with nearly the same answer... :)
Alan
 [reply] [d/l] [select] 
Re: How can I improve this? by steveAZ98 (Monk) on Jul 25, 2000 at 07:34 UTC 
Not sure that this is much of an improvement, but it only uses 5 for loops and one sort.
#!/usr/bin/perl w
my $m = [];
$m>[0] = [1,2,3,4,0];
$m>[1] = [1,2,3,5,6];
$m>[2] = [1,2,3];
$m>[3] = [3,1,2];
$m>[4] = [3,2,1,0];
my $a = perms($m);
foreach my $i (@{ $a }) {
print "Item: $i\n";
}
print "Total: ", $#{ $a }, "\n";
exit;
sub perms {
my ($m) = shift;
my @a = ();
my $n = 0;
for my $a (0..$#{ $m>[0]}) {
for my $b (0..$#{ $m>[1] }) {
for my $c (0..$#{ $m>[2] }) {
for my $d (0..$#{ $m>[3] }) {
for my $e (0..$#{ $m>[4] }) {
push @a, $m>[0]>[$a].$m>[1]>[$b].$m>[2]>
+[$c].$m>[3]>[$d].$m>[4]>[$
e];
}
}
}
}
}
@a = sort @a;
return \@a;
}
but I agree with the idea of using the sort.
And you all beat me!  [reply] [d/l] 
Re: How can I improve this? by athomason (Curate) on Jul 25, 2000 at 07:42 UTC 
Definitely TIMTOWTDI, but so far everyone agrees it's better (at least easier) to generate the permutations first and then sort the list, rather than trying to do both at once. Take a look at the Perl Cookbook section 4.15 (if you have it) for info on sorting lists based on a comparison function; it also has some effiency hints. I didn't do it by strings like the other Monks (which I realize differs from the form of your question), but this might be more efficient, and you can always regenerate the strings at the end. Here's what I came up: #!/usr/bin/perl w
use strict;
my (@a, @b, @c, @d, @e, $i1, $i2, $i3, $i4, $i5);
@a = @b = @c = @d = @e = (0, 1, 2); # or whatever
my (@unsorted, @sorted);
for ($i1 = 0; $i1 <= $#a; $i1++) {
for ($i2 = 0; $i2 <= $#b; $i2++) {
for ($i3 = 0; $i3 <= $#c; $i3++) {
for ($i4 = 0; $i4 <= $#d; $i4++) {
for ($i5 = 0; $i5 <= $#e; $i5++) {
push @unsorted, [$i1, $i2, $i3, $i4, $i5];
}
}
}
}
}
@sorted = sort { non_zeros($b) <=> non_zeros($a) 
${$b}[0] <=> ${$a}[0] 
${$b}[1] <=> ${$a}[1] 
${$b}[2] <=> ${$a}[2] 
${$b}[3] <=> ${$a}[3] 
${$b}[4] <=> ${$a}[4] } @unsorted;
print map "@$_\n", @sorted;
sub non_zeros {
my @arr = @{$_[0]};
scalar grep { $_ != 0 } @arr;
}
I'm not a big fan of any of the permutation generators (including mine) listed so far; I'll try to think of something cleaner and more general.  [reply] [d/l] 

Since you seemed interested.. here is my permutation generator.
It takes a base string (should be empty) as its first
argument, then refrences to as many lists as you want
as the other arguments and returns a refrence to a list
containg all the listelement concatination permutations:
my $foo=permute('',[0..2],[0..2],[0..3],[0..2]);
sub permute{
my $prefix=shift;
my @arrays=@_;
my $c=shift @arrays;
my @ret=();
foreach(@$c){
my $f=$prefix.$_;
if(scalar(@arrays)==0){
push @ret,$f;
}else{
my $t=permute($f,@arrays);
push @ret,@$t;
}
}
return \@ret;
}
I'm not really happy with the implementation of it, but
I like it in spirit (of course, I'm a big fan of recursive
algorithms to begin with).  [reply] [d/l] 

Well, since everyone is posting their permutors, here's mine:
sub permute {
my $last = pop @_;
unless (@_) {
return @$last;
}
return map { my $left = $_; map "$left$_", @$last } permute(@_);
}
 Randal L. Schwartz, Perl hacker  [reply] [d/l] 
Drool by gryng (Hermit) on Jul 25, 2000 at 17:01 UTC


Re: How can I improve this? by lhoward (Vicar) on Jul 25, 2000 at 21:34 UTC 
After a solid night's sleep I managed to come up with the
following implementation that generates the permutations
in the desired order without a separate sort step:
#!/usr/bin/perl w
use strict;
# set up the initial 5 arrays into @a
my @a=([0..2],[0..2],[0..2],[0..2],[0..2]);
# build nonzero versions of those arrays
my @nz=map {[grep {$_ != 0} @$_]} @a;
# permute in order....
my @foo;
foreach (15,14,13,11,7,12,10,6,9,5,3,8,4,2,1,0){
push @foo,@{permute('',
($_ & 0x01)?$nz[0]:[0],
($_ & 0x02)?$nz[1]:[0],
$a[2],
($_ & 0x04)?$nz[3]:[0],
($_ & 0x08)?$nz[4]:[0]);}
}
# print out results
print "$_\n" for (@foo);
# permute lists recursively
sub permute{
my ($prefix,$c,@arrays)=@_;
my @ret=();
foreach(@$c){
my $f=$prefix.$_;
if(scalar(@arrays)==0){
push @ret,$f;
}else{
push @ret,@{permute($f,@arrays)};
}
}
return \@ret;
}
 [reply] [d/l] 
Re: How can I improve this? by tye (Cardinal) on Jul 26, 2000 at 02:21 UTC 
Okay, this and merlyn's permuations code has been ticking in the back of my mind. Finally out popped a neat way to find all of the unique permutations of a set of (possibly) nonunique elements. For example, all of the unique permutations of the letters "h e l l o". Which is what I needed for solving this problem.
So here is a script that, when given no arguments, solves the noted problem. When given arguments, it outputs all of the unique permutations of those arguments, in sorted order, without using extra memory to accumulate values or track context (not even recursing).
#!/usr/bin/perl w
use strict;
exit main();
sub nextpermute(\@)
{
my( $vals )= @_;
my $last= $#{$vals};
return "" if $last < 1;
my $i= $last1; # Find last item not in reversesorted
+ order:
$i while 0 <= $i && $vals>[$i] ge $vals>[$i+1];
return "" if 1 == $i; # Complete reverse sort, done!
@{$vals}[$i+1..$last]= sort @{$vals}[$i+1..$last]
if $vals>[$i+1] gt $vals>[$last];
my $j= $i+1; # Find next item that will make us big
+ger:
$j++ while $vals>[$i] ge $vals>[$j];
@{$vals}[$i,$j]= @{$vals}[$j,$i];
return 1;
}
sub main
{
if( @ARGV ) {
my @vals= sort @ARGV;
do {
print "@vals\n";
} until( ! nextpermute(@vals) );
return 0;
}
#OR# my @map= (2,1,0);
for my $zero ( 0..5 ) {
for my $one ( 0..5$zero ) {
my $two= 5$one$zero;
my @val= ( (0)x$zero, (1)x$one, (2)x$two );
#OR# @val= ( (0)x$two, (1)x$one, (2)x$zero );
do {
print "@val\n";
#OR# print "@map[@val]\n";
} while( nextpermute(@val) );
}
}
return 0;
}
Remove the #OR# bits to have the solution provided sorted in an order I like better.  [reply] [d/l] [select] 

