Beefy Boxes and Bandwidth Generously Provided by pair Networks Frank
Perl Monk, Perl Meditation
 
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 +t' for reading: $!"; 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


Comment on Re^3: One for the weekend: challenge
Download Code
Re^4: One for the weekend: challenge
by BrowserUk (Pope) on Jun 03, 2008 at 18:35 UTC

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://689971]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (18)
As of 2014-04-17 13:38 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (447 votes), past polls