Words for phone number - perl

Question

I would like to write an simple perl script to generate all possible words for given phone number.
I started with definition of an array:
my #nums = (
['0'],
['1'],
['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'],
['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'],
['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'],
['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']
);
The final script should generate following output:
$ num2word 12
12
1a
1b
1c
$ num2word 213
213
21d
21e
21f
a13
a1d
a1e
a1f
b13
b1d
b1e
b1f
c13
c1d
c1e
c1f
I am looking for any module which can do most part of the job (something like List::Permutor which does not seem to qualify for this task).
Any hints?
Thanks!

Answer 1

Our very own #brian d foy has solved this problem with his Set::CrossProduct module.
use Set::CrossProduct;
my $iterator = Set::CrossProduct->new(
[ [ qw(8 t u v) ], [ qw(0) ], [ qw(7 p q r s) ] ] );
print "#$_\n" for $iterator->combinations;
Output:
8 0 7
8 0 p
8 0 q
8 0 r
8 0 s
t 0 7
t 0 p
t 0 q
t 0 r
t 0 s
u 0 7
u 0 p
u 0 q
u 0 r
u 0 s
v 0 7
v 0 p
v 0 q
v 0 r
v 0 s

Answer 2

This does what you ask.
use strict;
use warnings;
my #nums = (
[ qw/ 0 / ],
[ qw/ 1 / ],
[ qw /2 a b c / ],
[ qw /3 d e f / ],
[ qw /4 g h i / ],
[ qw /5 j k l / ],
[ qw /6 m n o / ],
[ qw /7 p q r s / ],
[ qw /8 t u v / ],
[ qw /9 w x y z / ],
);
list_matching('12');
list_matching('213');
sub list_matching {
my ($num) = #_;
my #num = $num =~ /\d/g;
my #map = (0) x #num;
do {
print join('', map { $nums[$num[$_]][$map[$_]] } 0 .. $#num), "\n";
my $i = $#map;
while ($i >= 0) {
last if ++$map[$i] < #{ $nums[$num[$i]] };
$map[$i--] = 0;
}
} while grep $_, #map;
}
output
12
1a
1b
1c
213
21d
21e
21f
a13
a1d
a1e
a1f
b13
b1d
b1e
b1f
c13
c1d
c1e
c1f

Answer 3

See the functions in Algorithm::Combinatorics.

Answer 4

Actually, does work, too early for me...
use autodie;
use strict;
use warnings;
my #nums = (
['0'],
['1'],
['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'],
['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'],
['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'],
['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']
);
my $input = shift || die "Need a number!\n";
die "Input not numeric!\n" unless $input =~ m/^\d+$/;
my #digits = split //, $input;
my #rows;
push #rows, $nums[$_] for #digits;
print_row(0,'');
exit;
sub print_row {
my $i = shift;
my $word = shift;
my $row = $rows[$i];
for my $j (0..$#{$row}) {
my $word2 = $word . $row->[$j];
if ($i < $#rows) {
print_row($i+1, $word2);
}
else {
print "$word2\n";
}
}
}

Answer 5

No modules required:
my #nums = (
['0'],
['1'],
['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'],
['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'],
['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'],
['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']
);
print "$_\n" while glob join '', map sprintf('{%s}', join ',', #{$nums[$_]}), split //, $ARGV[0]

Answer 6

use strict;
use warnings;
my #nums = (
['0'], ['1'], ['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'], ['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'], ['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'], ['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']);
num2word(12);
num2word(213);
sub num2word {
my ($i, $n, $t) = ($_[0]=~/(.)(.*)/, $_[1]);
for (#{$nums[$i]}) {
print "$t$_\n" and next if !length($n);
num2word($n, defined $t ? $t.$_ : $_);
}
}

Answer 7

A basic recursive solution:
#!/usr/bin/perl
use strict;
use warnings;
my $phone_number = $ARGV[0] or die "No phone number";
my #nums = (
['0'],
['1'],
[ '2', 'a', 'b', 'c' ],
[ '3', 'd', 'e', 'f' ],
[ '4', 'g', 'h', 'i' ],
[ '5', 'j', 'k', 'l' ],
[ '6', 'm', 'n', 'o' ],
[ '7', 'p', 'q', 'r', 's' ],
[ '8', 't', 'u', 'v' ],
[ '9', 'w', 'x', 'y', 'z' ]
);
my %letters = map { shift #{$_} => $_ } #nums;
my #permutations;
sub recurse {
my $str = shift;
my $done = shift || '';
unless ($str) {
push #permutations, $done;
return;
}
my $next = substr( $str, 0, 1 );
$str = substr( $str, 1 );
recurse( $str, $done . $next );
if ( my #chars = #{ $letters{$next} } ) {
recurse( $str, $done . $_ ) foreach #chars;
}
}
recurse($phone_number);
print "$_\n" foreach #permutations;
and:
perl num2word 12
12
1a
1b
1c
perl num2word 213
213
21d
21e
21f
a13
a1d
a1e
a1f
b13
b1d
b1e
b1f
c13
c1d
c1e
c1f