No such thing as a small change PerlMonks

### Re: One for the weekend: challenge

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

in reply to One for the weekend: challenge

BrowserUk,
Now that I understand the problem, here is a correct working solution that is relatively fast (8 seconds locally). Running it through perl -MO=Deparse solution.pl | wc -l indicates it is 42 lines. It isn't very clean as I didn't have very much time to implement. If I have time, I will see about clarity and optimizations. If nothing else, I will add comments tomorrow so at least the algorithm is clear even if the code is not.
```#!/usr/bin/perl
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;
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;
my \$num = join '', /(\d+)/g;
my \$end = length(\$num) - 1;
print "\$_: \$num\n" and next if ! \$end;
my @solution = [["\$_:"], 0, 0];
while (@solution) {
my (\$tree, \$work) = (\%data, pop @solution);
my (\$found, \$first) = (0, substr(\$num, \$work->[1], 1));
for my \$pos (\$work->[1] .. \$end) {
my \$dig = substr(\$num, \$pos, 1);
if (! exists \$tree->{\$dig}) {
push @solution, [[@{\$work->[0]}, \$first], \$work->[1] +
+ 1, 1] if ! \$work->[2] && ! \$found++;
last;
}
\$tree = \$tree->{\$dig};
if (exists \$tree->{nodes} && ++\$found) {
if (\$pos == \$end) {
print join(' ', @{\$work->[0]}, \$_), "\n" for @{\$tr
+ee->{nodes}};
last;
}
if (\$end - \$pos == 1) {
my \$last_dig = substr(\$num, \$end, 1);
print join(' ', @{\$work->[0]}, \$_, \$last_dig), "\n
+" for @{\$tree->{nodes}};
last if ! exists \$tree->{\$last_dig} || ! exists \$t
+ree->{\$last_dig}{nodes};
}
push @solution, [[@{\$work->[0]}, \$_], \$pos + 1, 0] for
+ @{\$tree->{nodes}};
}
}
push @solution, [[@{\$work->[0]}, \$first], \$work->[1] + 1, 1] i
+f ! \$work->[2] && ! \$found;
}
}

Cheers - L~R

Replies are listed 'Best First'.
Re^2: One for the weekend: challenge
by BrowserUk (Pope) on Jun 03, 2008 at 04:14 UTC
So which solution matched up to your expectations the best? I haven't tried all of them yet... waiting for my next break.
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.

Cheers - L~R

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

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (5)
As of 2017-11-20 01:50 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
In order to be able to say "I know Perl", you must have:

Results (282 votes). Check out past polls.

Notices?