Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

How can I improve this?

by Dogg (Scribe)
on Jul 25, 2000 at 06:15 UTC ( #24230=perlquestion: print w/ replies, xml ) Need Help??
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 0-2) 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 non-zero as long as possible (except the middle one, c - this one can be whatever). For example, I want 01010 to come before 02000 (two non-zeros vs. one non-zero), 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

Comment on How can I improve this?
Download Code
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 out-of-order 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 (lines-of-code 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 non-zero 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.
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.

RE: How can I improve this?
by ferrency (Deacon) on Jul 25, 2000 at 07:31 UTC
    If the only thing about the order of your permutations that matters, is keeping the number of 0's as low as possible for as long as possible, then another way to accomplish your goal would be to create a complete set of permutations in any order, and then sort the set of permutations according to the number of 0's in each.

    For example (using @a...@e):

    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

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!
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.

      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 list-element 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).
        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

        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 non-zero 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; }
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) non-unique 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= $last-1; # Find last item not in reverse-sorted + 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.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://24230]
Approved by root
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (5)
As of 2014-07-26 05:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (175 votes), past polls