character generator

[semio]

fellow monks,

As a personal exercise, I am interested in building a script that will generate all possible combinations of a defined set of characters. The string length is a user provided option. I put together a solution to this problem; although it works, I believe there is a better way to accomplish the desired result. As an example, here's what I've come up with.

#!perlenv -w

use strict;

if($#ARGV <1) { 
print <<EOF;
usage: char-gen <charSetNum> <stringLength>
charSetNum 1 = 
a b c 

charSetNum 2 = 
a b c
1 2 3 

charSetNum 3 = 
a b c 
1 2 3
! @ #

EOF
die();
} 


my @charsSetOne = qw/ a b c /;
my @charsSetTwo = qw/ a b c 1 2 3 /;
my @charsSetThree = split // , q'abc123!@#';

my @chars;

if ( $ARGV[0] == 1) {
    @chars = @charsSetOne;
    }
elsif ( $ARGV[0] == 2) {
    @chars = @charsSetTwo;
    }
elsif ( $ARGV[0] == 3) {
    @chars = @charsSetThree;
    }


my @charsOne = @chars;
my @charsTwo = @chars;
my @charsThree = @chars;

my $charsOne;
my $charsTwo;
my $charsThree;


my @charSetNum = $ARGV[0];
my $stringLength = $ARGV[1];



if ( $stringLength >= 1) {

for $charsOne (@charsOne) {
    print $charsOne . "\n";
}
}



if ( $stringLength >= 2) {

foreach $charsOne (@charsOne) {
        foreach $charsTwo (@charsTwo) {
            print $charsOne;
            print $charsTwo . "\n";
        }            
}
}



if ($stringLength >= 3) {
foreach $charsOne (@charsOne) {
        foreach $charsTwo (@charsTwo) {
            foreach $charsThree (@charsThree) {
                print $charsOne;
                print $charsTwo;
                print $charsThree . "\n";
            }            
        }
}
}

My concern is with how I'm handling the user provided option for stringLength. In this example, I'm building nested foreach loops to handle the stringLength option. My question is: how would others approach this? As always, comments, critiques and suggestions for improvement are always welcome.

cheers, semio

[ikegami]

NextPermute of Algorithm::Loops will do the trick, and it even has code that considers duplicate letters to be the same so you won't get "tool" twice while asking for permutations of "loot" (for example).

[gaal]

I'd use Algorithm::Permute.

[pg]

As an exercise, this is actually a good candidate for recursion (we have a recursion fever here these days): (I simplified the question a little bit, and assume we only want full length strings, strings that are formed by all characters in the set, so we can focus on recursion)

use Data::Dumper;

use strict;
use warnings;

my @set = ('1', '2', '3');
my @strings = generate(@set);
print Dumper(\@strings);

sub generate {
    my @set = @_;
    my @strings;
    if ($#set == 0) {
        return ($set[0]);
    } else {
        for (0 .. $#set) {
            my @temp = @set;
            my $t = splice(@temp, $_, 1);
            push @strings, "$t$_" foreach (generate(@temp));
        }
        return @strings;
    }
}

[pg]

Actually can be easily modified to generate strings with a specified length (not just the full length):

use Data::Dumper;

use strict;
use warnings;

my @set = ('1', '2', '3', '4');
my $len = 3; #test shows that it is safe to specify len greater than s
+et size, or equal to set size, or less than
my @strings = generate($len, @set);
print Dumper(\@strings);

sub generate {
    my $len = shift;
    my @set = @_;
    my @strings;
    if ($#set == 0) {
        return ($set[0]);
    } else {
    if ($len == 1) {
        push @strings, "$_" foreach (@set);    
    } else {
            for (0 .. $#set) {
                my @temp = @set;
                my $t = splice(@temp, $_, 1);
            push @strings, "$t$_" foreach (generate($len - 1, @temp));
        }
    }
        return @strings;
    }
}

[tmoertel]

Here's one way to compute the combinations that can be created by drawing a single element from each of a list of given sets:

    #!/usr/bin/perl -l

    use warnings;
    use strict;

    use List::Util qw( reduce );

    sub combinations {
        no warnings qw( once );
        reduce { outer_r($a,$b) } [[]], reverse @_;
    }

    sub outer_r {
        my ($ys, $xs) = @_;
        my @product;
        foreach my $x (@$xs) {
            foreach my $y (@$ys) {
                push @product, [$x, @$y];
            }
        }
        return \@product;
    }

The combinations function takes a list of sets (each represented as an arrayref) and returns the combinations that can be created from them:

    use Data::Dumper;
    $Data::Dumper::Terse = 1;
    $Data::Dumper::Indent = 0;

    print Dumper( combinations( [1..3], ["a","b"] ) ), "\n";
    # [[1,'a'],[1,'b'],[2,'a'],[2,'b'],[3,'a'],[3,'b']]

With this function, we can turn to your question of how best to represent your character sets. I would just use strings to keep things simple. A helper function will convert strings into the form needed by combinations and then convert the results back into strings:

    sub charset_combinations {
        my @charsets = map [split//], @_;
        map join("", @$_), @{ combinations( @charsets ) };
    }

Let's use our new helper to find all of the 3-character combinations that can be made from the charset "abc":

my @abcees3 = charset_combinations( ("abc") x 3 );
print "@abcees3\n";
# aaa aab aac aba abb abc aca acb acc\
# baa bab bac bba bbb bbc bca bcb bcc\
# caa cab cac cba cbb cbc cca ccb ccc

We can even draw successive characters from different character sets:

    my @charsets = qw( abc 123 !@$ );

    foreach my $string_length (0 .. @charsets) {
        my @genstrings =
            charset_combinations( @charsets[0..$string_length-1] );
        print "$string_length: @genstrings\n";
    }

    # 0:
    # 1: a b c
    # 2: a1 a2 a3 b1 b2 b3 c1 c2 c3
    # 3: a1! a1@ a1$ a2! a2@ a2$ a3! a3@ a3$\
    #    b1! b1@ b1$ b2! b2@ b2$ b3! b3@ b3$\
    #    c1! c1@ c1$ c2! c2@ c2$ c3! c3@ c3$

I hope this gives you some helpful ideas.

Cheers,
Tom

[TedPride]

use strict;

print "Enter characters to permutate : ";
$_ = <STDIN>; s/\s+//g; split(//);

my ($last, $chars);
foreach (sort @_) {
    if ($_ ne $last) { $chars .= $_; $last = $_; }
}

for ($_ = length($chars); $_; $_--) {
    permutate($_, $chars);
}

sub permutate {
    my ($depth, $chars, $pre) = @_;
    if ($depth == 1) {
        print $pre.substr($chars,$_,1)."\n" for (0..(length($chars)-1)
+);
    }
    else {
        for (0..(length($chars)-$depth)) {
            permutate($depth-1, substr($chars,$_+1), $pre.substr($char
+s,$_,1));
        }
    }
}

This takes input from STDIN rather than ARGV, but does print all the permutations correctly. It's a recursive solution using strings to track permutations.