Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
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


In reply to Re^3: One for the weekend: challenge by Limbic~Region
in thread One for the weekend: challenge by BrowserUk

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others about the Monastery: (9)
    As of 2014-07-28 06:14 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      My favorite superfluous repetitious redundant duplicative phrase is:









      Results (189 votes), past polls