Re^3: One for the weekend: challenge

[Limbic~Region]

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
            ];
        }
    }
}