Solve 076 by E. Choroba: Prime Sum + Word Search

2 files changed, 157 insertions, 0 deletions

diff --git a/challenge-076/e-choroba/perl/ch-1.pl b/challenge-076/e-choroba/perl/ch-1.pl
new file mode 100755
index 0000000000..6a4a8d2e2d
--- /dev/null
+++ b/challenge-076/e-choroba/perl/ch-1.pl
@@ -0,0 +1,59 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+
+my %prime = (1 => 0, 2 => 1, 3 => 1);
+sub is_prime {
+    my ($n) = @_;
+    return $prime{$n} if exists $prime{$n};
+
+    for my $d (2 .. sqrt $n) {
+        next unless is_prime($d);
+
+        return $prime{$n} = 0 if 0 == $n % $d;
+    }
+    return $prime{$n} = 1
+}
+
+my %prime_sum;
+sub prime_sum {
+    my ($n) = @_;
+    return $prime_sum{$n} if exists $prime_sum{$n};
+
+    return $prime_sum{$n} = 1 if is_prime($n);
+
+    # Euler-Goldbach
+    return $prime_sum{$n} = 2 if 0 == $n % 2;
+
+    # Goldbach says we can only return 2 or 3.
+    my $min = $n;
+    for my $m (2 .. 1 + $n / 2) {
+        no warnings 'recursion';
+        my $sum = prime_sum($n - $m) + prime_sum($m);
+        $min = $sum if $sum < $min;
+
+        # We can't get less than 2.
+        last if 2 == $min;
+    }
+    return $prime_sum{$n} = $min
+}
+
+use Test::More;
+
+is prime_sum(2),  1, '2 = 2';
+is prime_sum(3),  1, '3 = 3';
+is prime_sum(4),  2, '4 = 2 + 2';
+is prime_sum(5),  1, '5 = 5';
+is prime_sum(6),  2, '6 = 3 + 3';
+is prime_sum(7),  1, '7 = 7';
+is prime_sum(8),  2, '8 = 3 + 5';
+is prime_sum(9),  2, '9 = 2 + 7';
+is prime_sum(10), 2, '10 = 3 + 7';
+is prime_sum(11), 1, '11 = 11';
+is prime_sum(27), 3, '27 = 2 + 2 + 23';
+is prime_sum(51), 3, '51 = 2 + 2 + 47';
+is prime_sum(1023), 2, '1023 = 2 + 1021';
+is prime_sum(2047), 3, '2047 = 2039 + 3 + 5';
+
+done_testing();
diff --git a/challenge-076/e-choroba/perl/ch-2.pl b/challenge-076/e-choroba/perl/ch-2.pl
new file mode 100755
index 0000000000..d7ceab3c53
--- /dev/null
+++ b/challenge-076/e-choroba/perl/ch-2.pl
@@ -0,0 +1,98 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+
+my %dict;
+
+sub put {
+    my ($dict, @chars) = @_;
+    if (@chars) {
+        my $ch = shift @chars;
+        $dict->{$ch} = {} unless exists $dict->{$ch};
+        put($dict->{$ch}, @chars);
+    } else {
+        undef $dict->{""};
+    }
+}
+
+sub get {
+    my ($dict, $chars, $path) = @_;
+    $path //= "";
+    my $ch = $chars->[0] // "";
+    my @r;
+    @r = ($path . $ch)
+        if exists $dict->{$ch} && exists $dict->{$ch}{""};
+    push @r, get($dict->{$ch}, [ @$chars[1 .. $#$chars] ], $path . $ch)
+        if @$chars;
+    return @r
+}
+
+my %found;
+sub examine {
+    my ($s) = @_;
+    my $length = length $s;
+    for my $string (map lc, $s, scalar reverse $s) {
+        for my $pos (0 .. $length - 1) {
+            if (
+                my @matches = get(\%dict, [split //, substr $string, $pos])
+            ) {
+                @found{@matches} = ();
+            }
+        }
+    }
+}
+
+my ($grid, $words) = @ARGV;
+
+open my $w, '<', $words or die $!;
+while (<$w>) {
+    chomp;
+    put(\%dict, split //, lc);
+}
+
+open my $g, '<', $grid or die $!;
+chomp( my @grid = <$g> );
+s/ //g for @grid;
+
+my $length = length $grid[0];
+
+for my $pos (1 .. $length) {
+    my $column;
+    for my $line (@grid) {
+        examine($line) if 1 == $pos;
+        $column .= substr $line, $pos - 1, 1;
+    }
+    examine($column);
+}
+
+my ($X, $Y) = (0, 0);
+for (1 .. @grid + $length - 1) {
+    my ($x, $y) = ($X, $Y);
+    my %diag;
+    while ($y >= 0 && $x <= $length - 1) {
+        $diag{NW} .= substr $grid[$y], $x, 1;
+        $diag{NE} .= substr $grid[$y], -$x - 1, 1;
+        ++$x, --$y;
+    }
+    examine($diag{$_}) for qw( NW NE );
+    if ($Y < $#grid) {
+        ++$Y;
+    } else {
+        ++$X;
+    }
+}
+
+say for sort keys %found;
+
+__END__
+
+time ch-2.pl pwc076-2.grid <(grep -E '^.{5,}' /usr/share/dict/british) | wc -l
+
+58
+
+real	0m3.629s
+user	0m3.567s
+sys	0m0.065s
+
+American English dictionary gives two more: socializing and succor.