Minimally changing combinations

[Yary]

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.

[Eily]

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 ;-)

[haukex]

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]

[Laurent_R]

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.

[tybalt89]

What do you need a module for?

#!/usr/bin/perl -l

# http://perlmonks.org/?node_id=1193761

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;

[Anonymous Monk]

Good point. The OP says "combination", but it appears that what he actually wants is the Cartesian product.

[Yary]

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!

[Yary]

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.

[thanos1983]

Hello Yary

I think you are looking for Algorithm::Permute or perlfaq4/How do I permute N elements of a list? or Permutations and combinations.

Hope this helps, BR.