Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW

Minimally changing combinations

by Yary (Pilgrim)
on Jun 28, 2017 at 07:08 UTC ( #1193761=perlquestion: print w/replies, xml ) Need Help??

Yary has asked for the wisdom of the Perl Monks concerning the following question:

There are a few modules on CPAN for generating combinations. For example given the lists
[ 'a','b','c' ] , [ 1, 2 ]
they produce

a 1
a 2
b 1 # two changes this iteration
b 2
c 1 # two changes this iteration
c 2

There's another ordering, where only one position at a time changes. And there's a name for that ordering which I've forgotten, so I haven't been able to search CPAN for it. It would produce the tuples in an order like so:

a 1
a 2
b 2
b 1
c 1
c 2

Can anyone refresh my memory as to what that ordering is called, and as a bonus, find me a module on CPAN that already produces combinations that way?

... I have tried the the obvious keywords "permute" and "combination" on metacpan but suspect I'm missing the right word... yes I could implement it from scratch, or take the output of one of the CPAN modules and reverse some records to get the desired ordering. But why re-invent a wheel, if it's already been invented.

Replies are listed 'Best First'.
Re: Minimally changing combinations
by Eily (Monsignor) on Jun 28, 2017 at 09:06 UTC

    That sounds Gray-ish. Except this article deals pretty well with cases where all subsets have the same number of elements, which does not seem to be your case according to your example.

    If I'm not wrong, when you have @right, a list where your ordering is respected, and @left, a list of elements you can use the following algorithm:

    Take the first element of @left, combine it with all elements of @righ +t Take the second element of @left, combine it with all elements of reve +rse @right Take the third element of @left, combine it with all elements of @righ +t ...
    Because you reverse the right part each time you change the left element, you are sure that only one element changes (the left part), because you'll either be using the last or first element of @right twice in a row. This lets you scale up your N-uples recursively. Which in perl gives:
    use v5.20; use strict; use warnings; use Data::Dump qw( pp ); sub combine { my ($left, $right) = @_; my @out; my $reverse = 0; for my $el (@$left) { push @out, map { [ $el, ref $_ ? @$_ : $_ ] } ($reverse ? reverse +@$right : @$right); $reverse = !$reverse; } return \@out; } pp combine ['A' .. 'F'], combine ['a'..'d'], [1..8]; pp combine [1..3], combine [1..4], [1..3];

    I've just tested those sets and looked if I could find somewhere where the rule was not respected, my advice would be to test it properly though. And haukex's proposed solution might be better, the python page does mention gray coding so that's promising.

    Edit: and actually implementing that as a recursive sub is left as an exercise to the reader ;-)

Re: Minimally changing combinations (updated!)
by haukex (Bishop) on Jun 28, 2017 at 07:40 UTC

    I think you're looking for Heap's algorithm, although a quick search on CPAN and a look on Rosettacode doesn't yet show me an existing Perl implementation. Update: Sorry, that was permutations, you're looking for combinations.

    Update 2019-10-05: I've just released this as Algorithm::Odometer::Gray!

    Update 2: Knuth's "The Art of Computer Programming", "Generating all n-tuples", Algorithm H, "Loopless reflected mixed-radix Gray generation". Best I can do at the moment is an implementation in Python from the Sage project, here. Update 3: The exact same algorithm appears to be described in this freely available paper: Loopless Functional Algorithms as "Algorithm C" in the section "9.5. Non-binary Gray codes".

    Final Update: I think I've implemented the algorithm as described:

    sub mixedgray_it { my @w = @_; my @m = map { 0+@$_ } @w; die "all items must have at least two positions" if grep {$_<2} @m; my @a = (0) x @m; my @f = 0 .. @m; my @o = (1) x @m; my $done; return sub { return undef if $done; my $rv = [map {$w[$_][$a[$_]]} 0..$#w]; if ($f[0]==@w) { $done=1; return $rv } my $j = $f[0]; $f[0] = 0; $a[$j] += $o[$j]; if ($a[$j]==0 || $a[$j]==$m[$j]-1) { $o[$j] = -$o[$j]; $f[$j] = $f[$j+1]; $f[$j+1] = $j+1; } return $rv; } } use Data::Dump; my $it = mixedgray_it(['a','b','c'],[1,2]); while (defined( my $c = $it->() )) { dd $c } __END__ ["a", 1] ["b", 1] ["c", 1] ["c", 2] ["b", 2] ["a", 2]
      This is slightly off-topic, but just for your information, there is a description of the heap algorithm in the book Mastering Algorithms with Perl (O'Reilly, by Jon Orwant, Jarkko Hietaniemi, and John Macdonald). I think that the authors wrote a module (probably aimed at pedagogical purposes more than production) going with the book; but I'm not at home and can't check the book's content today, and I don't know if that particular algorithm is in this module.

      My book on Perl 6 also has something on heaps, but this is getting even more OT.

Re: Minimally changing combinations
by tybalt89 (Prior) on Jun 28, 2017 at 13:54 UTC

    What do you need a module for?

    #!/usr/bin/perl -l # use strict; use warnings; my @list1 = qw( a b c ); my @list2 = qw( 1 2 ); my $reverse = 0; my @combinations = map { my $left = $_; map "$left $_", $reverse++ % 2 ? reverse @list2 : @list2 } @list1; print for @combinations;
      Good point. The OP says "combination", but it appears that what he actually wants is the Cartesian product.
Re: Minimally changing combinations
by Yary (Pilgrim) on Jun 28, 2017 at 16:15 UTC
    Thanks haukex for your code that generates an iterator, and it's efficient. It keeps track of the direction (1 or -1) for each position in the array @o and runs without needing a stack. I renamed the variables to help me understand it better-
    sub mixedgray_iterator { my @domains = @_; my @sizes = map { scalar @$_ } @domains; die "all items must have at least two positions" if grep {$_<2} @sizes; my @cur_indices = (0) x @domains; my @pos_to_loop_next = 0 .. @domains; my @dir = (1) x @domains; my $done; return sub { return undef if $done; my $rv = [map {$domains[$_][$cur_indices[$_]]} 0..$#domains]; if ($pos_to_loop_next[0]==@domains) { $done=1; return $rv } (my $domain,$pos_to_loop_next[0]) = ($pos_to_loop_next[0], 0); $cur_indices[$domain] += $dir[$domain]; if ($cur_indices[$domain]==0 || $cur_indices[$domain]==$sizes[ +$domain]-1) { $dir[$domain] = -$dir[$domain]; $pos_to_loop_next[$domain] = $pos_to_loop_next[$domain+1]; $pos_to_loop_next[$domain+1] = $domain+1; } return $rv; } }

    thanos1983's references include Algorithm::Loops, its NestedLoots could be wrangled into producing what I'm looking for.

    Thanks Eily "Gray code" was the term I'd forgotten (and "Hamming Distance" too) and nice compact code there!

    Turns out my post was an "XY" problem. Like the authors of some combination modules, I'm running tests with all combinations of options. In these tests, each time an option changes, there's expensive setup to run first. My thought was to take the Gray-code-like sequence, and then compare each iteration with the values from the previous to see which setup code to run.

    Or in other words, I want a sequence of "change option K to value V". Working on it!

      It was easy once I figured out that it's just like counting... hope to have time this weekend to make it more feature-ful and put it on CPAN!
      #!/usr/bin/env perl use strict; use warnings; use Data::Dump; sub single_change_iterator { my @domains = @_; my $it = 0; my @dir = (1) x @domains; my @pos = (0) x @domains; $it = sub { # Initializion. Next call, use the real iterator. $it = sub { my $cur_dom; for ($cur_dom = 0; $cur_dom < @domains or return; # No more changes! ++$cur_dom) { # Are we at end position of this domain? my $upward = $dir[$cur_dom]==1; if ($pos[$cur_dom] == ($upward ? $#{$domains[$cur_dom] +} : 0)) { # flip domain's direction, let loop continue $dir[$cur_dom] *= -1; } else { # Move current domain to next position $pos[$cur_dom] += $dir[$cur_dom]; last; } } return [$cur_dom, $domains[$cur_dom][$pos[$cur_dom]]]; }; # End first call by initializing all domains return map [$_, $domains[$_][0]], 0 .. $#domains }; return \$it; } my $combo_it = single_change_iterator(['X','Y'], [qw(a b c)], [44,55]) +; my @changes; dd @changes while @changes = &$$combo_it; =head1 NAME single_change_itertor - Help build Cartesian product, by changing one +value at a time =head1 SYNOPSIS use Data::Dump; my $it = single_change_itertor(['X','Y'], [qw(a b c)], [1,2]); dd $_ while $_ = &$$it; prints ([0, "X"], [1, "a"], [2, 44]) [0, "Y"] [1, "b"] [0, "X"] [1, "c"] [0, "Y"] [2, 55] [0, "X"] [1, "b"] [0, "Y"] [1, "a"] [0, "X"] =head1 DESCRIPTION This finds a way to cycle through all possible combinations of the given sets- their Cartesian Product- by changing a single element at a time. Given a set of domains, returns a handle to an iterator showing which position changes, and what to. Similar to a Gray code, which cycles through a set of numbers while only changing one digit. Each call returns a list of array references. The inner array reference is a pair, [ index of domain that has a change , new value ] The first iteration returns a pair for each domain so as to initialize all the domains. Each subsequent call returns a single pair.
Re: Minimally changing combinations
by thanos1983 (Parson) on Jun 28, 2017 at 08:14 UTC

Log In?

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

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (8)
As of 2021-01-22 14:21 GMT
Find Nodes?
    Voting Booth?