Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
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
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            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 studying the Monastery: (20)
    As of 2015-07-06 18:16 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (80 votes), past polls