Perl: the Markov chain saw PerlMonks

### Re^3: One for the weekend: challenge

by Limbic~Region (Chancellor)
 on Jun 03, 2008 at 18:22 UTC ( #689971=note: print w/replies, xml ) Need Help??

in reply to Re^2: One for the weekend: challenge
in thread One for the weekend: challenge

BrowserUk,
Here is the same code re-written to be more clear and maintainable. I still think the handful of special case scenarios could be reduced to a more general case. Unfortunately, I don't have time to try.
```#!/usr/bin/perl
use constant PIECES   => 0;
use constant POSITION => 1;
use constant USED_DIG => 2;
use strict;
use warnings;

my %l = (
E => 0, e => 0, J => 1, j => 1, N => 1, n => 1, Q => 1, q => 1, R
+=> 2, r => 2,
W => 2, w => 2, X => 2, x => 2, D => 3, d => 3, S => 3, s => 3, Y
+=> 3, y => 3,
F => 4, f => 4, T => 4, t => 4, A => 5, a => 5, M => 5, m => 5, C
+=> 6, c => 6,
I => 6, i => 6, V => 6, v => 6, B => 7, b => 7, K => 7, k => 7, U
+=> 7, u => 7,
L => 8, l => 8, O => 8, o => 8, P => 8, p => 8, G => 9, g => 9, H
+=> 9, h => 9,
Z => 9, z => 9
);

my (\$fh, %data);

open(\$fh, '<', 'dictionary.txt') or die "Unable to open 'dictionary.tx
while (<\$fh>) {
chomp;

# 123-4/56 -> 123456 -> push @{data{1}{2}{3}{4}{5}{6}{nodes}}, '12
+3-4/56'
eval join '', 'push @{\$data', (map {defined \$l{\$_} ? "{\$l{\$_}}" :
+()} split //, \$_), "{nodes}}, '\$_';";
}

open(\$fh, '<', 'input.txt') or die "Unable to open 'input.txt' for rea
+ding: \$!";
while (<\$fh>) {
chomp;

# Make a copy of original phone number for readability (not \$_)
my \$orig_num = \$_;

# Make a copy of phone number using just digits
my \$num = join '', /(\d+)/g;

# Determine the position of last digit in phone number for substr
my \$end = length(\$num) - 1;

# Special case - if single digit, print it and move on
if (! \$end) {
print "\$orig_num: \$num\n";
next;
}

# Initialize potential solution queue
my @solution = ([
["\$orig_num:"], # pieces of solution
0,              # position in \$num to look for next piece
0               # boolean to indicate last piece was not digit
]);

while (@solution) {

# Get a reference to our data tree
my \$tree = \%data;

# Get a potential solution off the queue
my \$work = pop @solution;

# Boolean indicating we have not yet found the next piece of a
+ solution
my \$found = 0;

# Record the first digit in the next solution piece.  Needed i
+n case no words found
my \$first = substr(\$num, \$work->[POSITION], 1);

# Find all possible words from the current position to the end
+ of \$num
for my \$pos (\$work->[POSITION] .. \$end) {

# Get the digit associated with the current position
my \$dig = substr(\$num, \$pos, 1);

# There are no possible solutions beyond this point in the
+ \$num
if (! exists \$tree->{\$dig}) {

# If we have not yet found a solution and didn't use a
+ digit in last piece
if (! \$work->[USED_DIG] && ! \$found) {

# Indicate we found the next piece of solution
\$found = 1;

# Use a digit as the next piece and put the soluti
+on back on the work queue
push @solution, [
[@{\$work->[PIECES]}, \$first],  # Add digit to
+possible solution set
\$work->[POSITION] + 1,         # Increment the
+ position by 1
1                              # Indicate we u
+sed a digit for last piece
];

# No more possible solutions can exist, so move on
last;
}
}

# Move one step down in our data tree
\$tree = \$tree->{\$dig};

# If any words can be found at this depth
if (exists \$tree->{nodes}) {

# Indicate we found the next piece of solution
\$found = 1;

# If we are at the end of the phone number
if (\$pos == \$end) {

# For each word found
for my \$word (@{\$tree->{nodes}}) {

# Print all the pieces of the solution
print join ' ', @{\$work->[PIECES]}, \$word;
print "\n";
}

# No more possible solutions can exist (end of num
+), so move on
last;
}

# If only one digit remains in the phone number
if (\$end - \$pos == 1) {

# Grab that last digit
my \$last_dig = substr(\$num, \$end, 1);

# For each word found at current position
for my \$word (@{\$tree->{nodes}}) {

# Print all the pieces of the solution using l
+ast dig as last piece
print join ' ', @{\$work->[PIECES]}, \$word, \$la
+st_dig;
print "\n";
}

# If the data tree doesn't have a branch for the n
+ext digit
# Or if the branch for the next digit has no word
+nodes
# Then no more possible solutions, so move on
last if ! exists \$tree->{\$last_dig} || ! exists \$t
+ree->{\$last_dig}{nodes};
}

# We are not yet at the end, so push each word on to t
+he possible solution queue
for my \$word (@{\$tree->{nodes}}) {
push @solution, [
[@{\$work->[PIECES]}, \$word],  # Add word to po
+ssible solution set
\$pos + 1,                     # Increment posi
+tion by 1
0                             # Indicate last
+piece was not a digit
];
}
}
}

# If we made it all the way to the end
# And we did not find a possible solution
# And the last piece found was not a digit
# Use the first digit seen as a possible piece
if (! \$found && ! \$work->[USED_DIG]) {
push @solution, [
[@{\$work->[PIECES]}, \$first],  # Add digit to possible
+ solution set
\$work->[POSITION] + 1,         # Increment position by
+ 1
1                              # Indicate last piece w
+as a digit
];
}
}
}

Cheers - L~R

Replies are listed 'Best First'.
Re^4: One for the weekend: challenge
by BrowserUk (Pope) on Jun 03, 2008 at 18:35 UTC

Create A New User
Node Status?
node history
Node Type: note [id://689971]
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (5)
As of 2018-03-20 21:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
When I think of a mole I think of:

Results (259 votes). Check out past polls.

Notices?