Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Variant permutation

by gmax (Abbot)
on Aug 30, 2003 at 11:00 UTC ( #287900=perlquestion: print w/ replies, xml ) Need Help??
gmax has asked for the wisdom of the Perl Monks concerning the following question:

The problem

For an algorithm related to code generation I need to permute the values of an array, but in addition to a regular permutation, I need also to report the partial permutation of the values.

VALUES a b c 1 2 3 x y z PERMUTATIONS a1x a1y a1z a1 a2x a2y a2z a2 a3x a3y a3z a3 a b1x b1y b1z b1 b2x b2y b2z b2 b3x b3y b3z b3 b c1x c1y c1z c1 c2x c2y c2z c2 c3x c3y c3z c3 c

In the example above, the first three columns are the result of a standard permutation, in addition to that, I need to generate "a1" when it is no longer part of the permuted value. Therefore, before "a2x", I need to create "a1", before "b1x" I must create "a3". The same goes for "a", which is generated immediately before the permuted value starts showing "b".

I hope the example is clearer than my explanation. :)

More detail about the problem

  • The array is mostly small. The total permutation values shouldn't be more than a few thousand.
  • The values are generated dynamically, and the number of rows and column in the array is variable.
  • Showing the values by a simple string is just a simplification of what I need. In the real case, I generate an array of permuted values, and I perform the algorithm's steps on them.
  • Order is important. The permutations must be generated exactly in the order shown.

Research

I found several permutation examples, and I tried out merlyn's Permutations and combinations. It works as advertised, but it doesn't do what I need.

Other variants of permutation algorithms don't offer any handle to do what I need, and some don't even guarantee a given order.

#!/usr/bin/perl -w use strict; my @array = ( [ 'a', 'b', 'c' ], [ 1, 2 ], ['x', 'y', 'z'], [7, 8, 9] ); sub permute { # merlyn's my $last = pop @_; unless (@_) { return map [$_], @$last; } return map { my $left = $_; map [@$left, $_], @$last } permute(@_); } print join("", @$_), " " for permute(@array); print "\n"; __END__ a1x7 a1x8 a1x9 a1y7 a1y8 a1y9 a1z7 a1z8 a1z9 a2x7 a2x8 a2x9 a2y7 a2y8 a2y9 a2z7 a2z8 a2z9 b1x7 b1x8 b1x9 b1y7 b1y8 b1y9 b1z7 b1z8 b1z9 b2x7 b2x8 b2x9 b2y7 b2y8 b2y9 b2z7 b2z8 b2z9 c1x7 c1x8 c1x9 c1y7 c1y8 c1y9 c1z7 c1z8 c1z9 c2x7 c2x8 c2x9 c2y7 c2y8 c2y9 c2z7 c2z8 c2z9

my solution

The problem is recursive, not only that, but it has also some reminiscence of tree traversal, so I tried with a Tree.

#!/usr/bin/perl -w use strict; use Tree::DAG_Node; my @array = ( [ 'a', 'b', 'c' ], [ 1, 2 ], ['x', 'y', 'z'], [7, 8, 9] ); my $tree = Tree::DAG_Node->new; $tree->name('cols'); sub add_values { my $top = shift; my $matrix = shift; my $level = shift; return if $level > $#$matrix; my $values = $array[$level]; $top->new_daughter->name($_) for @$values; add_values($_, $matrix, $level+1) for $top->daughters; } add_values($tree, \@array, 0); $tree->walk_down ({ callbackback => sub { my $node = shift; print join ( "", reverse map {$_->name} grep {$_->address ne '0'} $node, $node->ancestors)," "; } }); print "\n"; __END__ a1x7 a1x8 a1x9 a1x a1y7 a1y8 a1y9 a1y a1z7 a1z8 a1z9 a1z a1 a2x7 a2x8 a2x9 a2x a2y7 a2y8 a2y9 a2y a2z7 a2z8 a2z9 a2z a2 +a b1x7 b1x8 b1x9 b1x b1y7 b1y8 b1y9 b1y b1z7 b1z8 b1z9 b1z b1 b2x7 b2x8 b2x9 b2x b2y7 b2y8 b2y9 b2y b2z7 b2z8 b2z9 b2z b2 +b c1x7 c1x8 c1x9 c1x c1y7 c1y8 c1y9 c1y c1z7 c1z8 c1z9 c1z c1 c2x7 c2x8 c2x9 c2x c2y7 c2y8 c2y9 c2y c2z7 c2z8 c2z9 c2z c2 +c

This does exactly what I need, even though I have a gut feeling that it could be better.

I can live with this solution, if there is nothing else available.

Any paths for improvement?

Can anyone suggest a more linear course of action?

TIA

 _  _ _  _  
(_|| | |(_|><
 _|   

Comment on Variant permutation
Select or Download Code
Re: Variant permutation
by Abigail-II (Bishop) on Aug 30, 2003 at 11:15 UTC
    #!/usr/bin/perl use strict; use warnings; sub perm; sub perm { my $array = shift; if (@$array > 1) { my $first = shift @$array; my @results = perm $array; my @all; foreach my $f (@$first) { foreach my $r (@results) { push @all => "$f$r"; } push @all => $f; } return @all; } return @{$array -> [0]} if @$array == 1; } my @results = perm [['a', 'b', 'c'], [ 1, 2], ['x', 'y', 'z'], [ 7, 8, 9]]; print "@results\n"; __END__ a1x7 a1x8 a1x9 a1x a1y7 a1y8 a1y9 a1y a1z7 a1z8 a1z9 a1z a1 a2x7 a2x8 a2x9 a2x a2y7 a2y8 a2y9 a2y a2z7 a2z8 a2z9 a2z a2 a b1x7 b1x8 b1x9 b1x b1y7 b1y8 b1y9 b1y b1z7 b1z8 b1z9 b1z b1 b2x7 b2x8 b2x9 b2x b2y7 b2y8 b2y9 b2y b2z7 b2z8 b2z9 b2z b2 b c1x7 c1x8 c1x9 c1x c1y7 c1y8 c1y9 c1y c1z7 c1z8 c1z9 c1z c1 c2x7 c2x8 c2x9 c2x c2y7 c2y8 c2y9 c2y c2z7 c2z8 c2z9 c2z c2 c
Re: Variant permutation
by bsb (Priest) on Aug 30, 2003 at 14:07 UTC
    Can anyone suggest a more linear course of action?
    Not me. I can suggest something stupid though.

    My pet toy at the moment, genexes.

    (Generating regex strings with a regex)

    #!/usr/bin/perl -wl use strict; use re "eval"; my @array = ( [ 'a', 'b', 'c' ], [ 1, 2 ], ['x', 'y', 'z'], [7, 8, 9] ); my $re; map { $re .= "(\n". '((?{$^R."' . join('"})|(?{$^R."', @$_) . qq'"}))\n'; } @array; $re .= ")?" x @array; $re .= '(?{ push @_, $^R })(?!)'; print $re; ''=~/$re/x; print for(grep defined($_), @_); __END__
Re: Variant permutation
by runrig (Abbot) on Aug 30, 2003 at 17:28 UTC
    Here is a version of Re (tilly) 1 (perl): What Happened...(perils of porting from c):
    #!/usr/bin/perl use strict; use warnings; my @array = ( [1..3],['a'..'b'],['A'..'C'] ); my @prev_value; nested_for( sub { if (@prev_value) { my $diff; for (0..$#prev_value) { if ($prev_value[$_] ne $_[$_]) { $diff = $_; last; } } if (defined $diff) { for (reverse $diff..$#prev_value) { print " ", @prev_value[0..$_]; } print "\n"; } else { print " "; } } print @_; @prev_value = @_[0..$#_-1]; }, reverse @array); sub nested_for { ret_iter(@_)->(); } sub ret_iter { my $fn = shift; my $range = shift; my $sub = sub { $fn->(@_, $_) for @$range }; return @_ ? ret_iter($sub, @_) : $sub; }
Re: Variant permutation
by hossman (Prior) on Aug 31, 2003 at 07:29 UTC

    I'm curious...

    1. Why do you need these "Variant permutations" ? ... is there a practicle use for this, or are you just interested from a theoreticaly standpoint?
    2. Why are you limiting yourself to (what i would call) "permutation prefixes" ?

    If you asked me to "to report the partial permutation of the values...

    a b c
    1 2 3
    x y z
    
    ...my list would include "ax", "1x", "1", "x", etc.

      An example would be better than any explanation.

      my $headers = { locations => ['USA', 'UK'], departments => ['pers', 'dev','sales'], gender => ['m', 'f'] }; __END__ The ultimate goal will be USA UK + ---------------------------------- --------------------------------- pers dev sales USA pers dev sales UK -------- ------- --------- ------- -------- ------- --------- ------ m f pers m f dev m f sales m f USA m f pers m f dev m f sales m f UK - - --- - - --- - - ----- - - --- - - ---- - - --- - - ----- - - -- a b c d e f g h i j k l m n o p q r s t u v w x

      Take this schema, and see why I said that order is important and I take the variation only when the last one is changing.

      For every location I list the departments; for each department a breakdown by gender (columns a b d e n o p q s t), followed by a department total (columns c f i o r u). Then there is a breakdown by location (columns g h v w) with its grand total (columns l x).

      If I permute 'USA'-'m' before 'USA'-'pers'-'m' I am breaking the schema.

      The algorithm I am dealing with is a little more complex than this, since it is taking information about where to find each item, and generating code to retrieve the relevant data from a database.

      The permutations are needed to create the appropriate conditions for retrieving each column of data. All the conditions are merged together into a giant SQL statement that will fetch the data according to my instructions (SUM, COUNT, AVG).

      More on this subject when I adjust nicely all the above into a module. :)

       _  _ _  _  
      (_|| | |(_|><
       _|   
      
Re: Variant permutation
by BrowserUk (Pope) on Aug 31, 2003 at 11:47 UTC

    How's this?

    #! perl -slw use strict; my @array = ( [ 'a', 'b', 'c' ], [ 1, 2 ], ['x', 'y', 'z' ], [ 7, 8, 9 ] ); sub p { my( $stem, @a ) = @_; return @{ shift @a } if @a == 1; map { my $pre = $_; map( { $pre . $_ } p( $stem . $_, @a ) ), $pre; } @{ shift @a }; } print for p( '', @array ); __END__ P:\test>287900-2 a1x7 a1x8 a1x9 a1x a1y7 a1y8 a1y9 a1y a1z7 a1z8 a1z9 a1z a1 a2x7 a2x8 a2x9 a2x a2y7 a2y8 a2y9 a2y a2z7 a2z8 a2z9 a2z a2 a b1x7 b1x8 b1x9 b1x b1y7 b1y8 b1y9 b1y b1z7 b1z8 b1z9 b1z b1 b2x7 b2x8 b2x9 b2x b2y7 b2y8 b2y9 b2y b2z7 b2z8 b2z9 b2z b2 b c1x7 c1x8 c1x9 c1x c1y7 c1y8 c1y9 c1y c1z7 c1z8 c1z9 c1z c1 c2x7 c2x8 c2x9 c2x c2y7 c2y8 c2y9 c2y c2z7 c2z8 c2z9 c2z c2 c

    Examine what is said, not who speaks.
    "Efficiency is intelligent laziness." -David Dunham
    "When I'm working on a problem, I never think about beauty. I think only how to solve the problem. But when I have finished, if the solution is not beautiful, I know it is wrong." -Richard Buckminster Fuller
    If I understand your problem, I can solve it! Of course, the same can be said for you.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (9)
As of 2014-08-20 08:01 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (107 votes), past polls