How can I generate all ordered combinations of length k in Perl?

Question

I need a routine that, given the character set, will generate all possible combinations of these characters of length k. Ordering and reuse issues are permitted, so if k = 2, then AB != BAit AAis an option. I found some working examples on PerlMonks , but, unfortunately, they are code golf, and it is not easy for me to wrap my mind around it. Can someone do one or more of the following?

• Give a breakdown and explanation of how the first algorithm works.
• De-obfuscate code to make the point clearer.
• Point me to another example, which is clearer.

Thank!

Answer 1

You can use variations_with_repetition from Algorithm :: Combinatorics (which also provides an iterator-based interface), but if you just need a list, this is a pretty simple recursive algorithm:

sub ordered_combinations
{
  my ($data, $k) = @_;

  return @$data if $k == 1;

  my @previous = ordered_combinations($data, $k-1);

  my @results;
  for my $letter (@$data) {
    push @results, map { $letter . $_ } @previous;
  }

  return @results;
} # end ordered_combinations

print "$_\n" for ordered_combinations([qw(a b c)], 3);

This is basically the same algorithm that golfers use the code, but I use a loop forinstead of nesting map. In addition, I recurs only once per level (code golf is the minimization of the source code, not the runtime).

Any recursive function can be converted to iterative, which usually reduces its overhead. It is pretty simple:

sub ordered_combinations
{
  my ($data, $k) = @_;

  return if $k < 1;

  my $results = $data;

  while (--$k) {
    my @new;
    for my $letter (@$data) {
      push @new, map { $letter . $_ } @$results;
    } # end for $letter in @$data

    $results = \@new;
  } # end while --$k is not 0

  return @$results;
} # end ordered_combinations

This version handles a case $k == 0that the original did not.

Answer 2

, :

sub c{my$n=-1+shift;$n?map{my$c=$_;map$c.$_,c($n,@_)}@_:@_}

, ; , (. combinations):

#!/usr/bin/perl

use strict;
use warnings;

sub c {
   my $n=-1+shift;
   $n ? map{
             my $c = $_;
             map $c . $_ , c($n ,@_)
           } @_
   : @_;
}

sub combinations {
   my $number = shift; # remove the first item from @_
   my @chars  = @_;    # the remainder of @_

   $number --; # decrement $number, so that you will eventually exit
               # from this recursive subroutine (once $number == 0)

   if ($number) { # true as long as $number != 0 and $number not undef

      my @result;

      foreach my $char (@chars) {
         my @intermediate_list = map { $char . $_ } combinations($number, @chars);
         push @result, @intermediate_list;
      }

      return @result; # the current concatenation result will be used for creation of
                      # @intermediate_list in the 'subroutine instance' that called 'combinations'
   }
   else {
      return @chars;
   }
}

print join " ", combinations(2, "A", "B");
print "\n";
print join " ", c(2, "A", "B");
print "\n\n";
print join " ", combinations(3, "A", "B");
print "\n";
print join " ", c(3, "A", "B");
print "\n";

, :

AA AB BA BB
AA AB BA BB

AAA AAB ABA ABB BAA BAB BBA BBB
AAA AAB ABA ABB BAA BAB BBA BBB

, , , !? , , , : , : "" "", . $number 2 ( ), @chars ('A', 'B').

combinations $number 1, if, foreach. $char 'A'. combinations(1, ('A', 'B')). $number , $number 0 " ", ( "A" , "B" ). :

@intermediate_list = map { $char . $_ } ('A', 'B'); # $char eq 'A'

map "A" "B" "A" ($ char), @intermediate_list ('AA', 'AB'). foreach $char = B, @intermediate_list ( "BA", "BB" ).

@intermediate_list , @result .

, , , $number = 3, combinations . , , @result, , . .

, , . , , - .

EDIT: . ysth .