# Challenge 76: Word Search and Sum Primes

Another week, another Perl Weekly Challenge, and I had fun with this one.

### TASK #1 › Prime Sum

Submitted by: Mohammad S Anwar

Reviewed by: Ryan ThompsonYou are given a number $N. Write a script to find the minimum number of prime numbers required, whose summation gives you $N.

For the sake of this task, please assume 1 is not a prime number.

Given the example problem, **N == 9**, you can do it several ways — `[2,7]`

, `[2,2,5]`

, `[3,3,3]`

, `[2,2,2,3]`

— and you *could* get every one and sort by length later, or, you can use the largest primes first and exit when done.

We of course need primes, and I grabbed my own `is_prime`

from Challenge #12. `is_prime`

, range and `grep`

give us a list of primes from 2 (as indicated) to `$n`

.

```
my @primes = reverse grep { is_prime($_) } 2 .. $n;
sub is_prime ( $n ) {
my @factors = factor($n);
return scalar @factors == 1 ? 1 : 0;
}
sub factor ( $n ) {
my @factors;
for my $i ( 1 .. $n - 1 ) {
push @factors, $i if $n % $i == 0;
}
return @factors;
}
```

There is a common line I use:

This Looks Like A Job For RECURSION!

And I tried it first. Theres a problem. If we want to get a list of all primes that add up to `10`

, and start with lowest primes, going with recursion would give us `[2,2,2,2,2]`

before it would give us `[7,3]`

, and if we reverse and take the largest primes first, we might *think* that we’d get to `[7,3]`

first, but we can’t prove it, so we must get *everything* and then sort it, and that’s not fast.

So, honestly, this looks like a job for Iteration.

I often forget Iteration, preferring the smaller code blocks (if you don’t mess it up) with Recursion, *but*, if you don’t be careful, Recursion can mess you up and take up all your memory. A pure recursive implementation of Fibonacci will take up all available computing resources if you go above … is it `fib(32)`

? Meanwhile, you can keep on chugging with an iterative implementation.

We use a `while`

loop, and this is about the only kind of code I use while. Specifically, we start with `push @array, []`

and then go to `while ( @array ) {...}`

. do a `for`

loop on the possible primes, copy the array, add the prime to it, and then sum for testing. If **sum < N**, we append a ref to the new array to `@array`

and go to next. If **sum == N**, we add it to the output array and `last`

out of the `while`

loop.

#### The Code

```
#!/usr/bin/env perl
use strict;
use warnings;
use feature qw{ say signatures state };
no warnings qw{ experimental };
use List::Util qw{ sum sum0 max };
use Getopt::Long;
my $n = 9;
GetOptions( 'n=i' => \$n, );
use JSON;
my $json = JSON->new->space_after->canonical;
my @primes = reverse grep { is_prime($_) } 2 .. $n;
my @output = prime_sum( $n, \@primes );
map { say $json->encode($_) } @output;
say '';
say $json->encode( $output[0] );
sub prime_sum ( $n, $primes, $list = [], $depth = 1 ) {
my @output;
my %join;
my @list = ( [] );
OUTER: while (@list) {
my $e = shift @list;
for my $p ( $primes->@* ) {
my $new->@* = reverse sort $e->@*, $p;
my $sum = sum $new->@*;
my $join = join ' ', $new->@*;
next if $join{$join}++;
push @list, $new if $sum < $n;
push @output, $new if $sum == $n;
last OUTER if $sum == $n;
}
}
return @output;
}
sub is_prime ( $n ) {
my @factors = factor($n);
return scalar @factors == 1 ? 1 : 0;
}
sub factor ( $n ) {
my @factors;
for my $i ( 1 .. $n - 1 ) {
push @factors, $i if $n % $i == 0;
}
return @factors;
}
```

### TASK #2 › Word Search

Submitted by: Neil Bowers Reviewed by: Ryan Thompson

Write a script that takes two file names. The first file would contain word search grid as shown below. The second file contains list of words, one word per line. You could even use local dictionary file.

Print out a list of all words seen on the grid, looking both orthogonally and diagonally, backwards as well as forwards.

This takes me back. Years ago, I heard a puzzle on NPR where you were to take the string **PRECHRISTMASSALE**, map it to a 4x4 grid like —

```
P R E C
H R I S
T M A S
S A L E
```

— and snake through it and find the longest word, which, as it turns out, is *matrices* and a few others of the same length. The game is **Boggle**, a game I never played, but because the only rules are next or diagonal and no reusing a square, we have to keep the list of squares as we go along. Here, We’re just going in straight lines, so we just have to handle four cases — horizontal, vertical, diagonal (/) and diagonal (\) — we iterate through all possible starting points, only looking forward but checking the reverse of the string.

For example, consider just the first line of the example word search:

B I D E M I A T S U C C O R S T

Starting at position 0, we get *BIDE* in four letters:

B I D EM I A T S U C C O R S T

If we start at position 4, we get *MIA*, which is a name but not a word, but if we reverse it, we get *AIM*.

B I D E

M I AT S U C C O R S T

I suppose I could’ve made this point with *DIB* and *BID*, the first three letters, but eh. This, *again*, looks like a job for Recursion! I may need a t-shirt.

I used the standard word list on my Ubuntu WSL, `/usr/share/dict/words`

, but you can clearly use whatever word list you choose, and I do checking with a hash, because it’s just simple. If I was doing it over, I might have a `is_word()`

function rather than passing around a hashref all over, but eh, I’m done.

```
There were 541 unique words in this word search
AB
AC
ACE
ACRE
ACT
AD
ADA
AG
AH
AI
AID
AIM
AIMED
...
WIG
WIGGED
WO
WU
XI
XU
YA
YAH
YE
YO
YOD
YON
YUP
ZING
ZR
ZS
```

#### The Code

```
#!/usr/bin/env perl
use strict;
use warnings;
use feature qw{ say signatures state };
no warnings qw{ experimental };
use Getopt::Long;
use List::Util qw{ first };
my $word_grid = 'word_grid.txt';
my $dictionary = '/usr/share/dict/words';
my $output = {};
GetOptions(
'dictionary=s' => \$dictionary,
'wordsearch=s' => \$word_grid,
);
my $words = get_words($dictionary);
my $word_search = get_word_search($word_grid);
do_word_search( $word_search, $words );
my $wc = scalar keys $output->%*;
say join "\n\t", "There were $wc unique words in this word search",
sort keys $output->%*;
sub do_word_search ( $graph, $dictionary ) {
my $xp = scalar $graph->@* - 1;
my $yp = scalar $graph->[0]->@* - 1;
for my $x ( 0 .. $xp ) {
for my $y ( 0 .. $yp ) {
my $l = $graph->[$x][$y];
find_word_vertical( $x + 1, $y, [$l], $graph, $dictionary );
find_word_horizontal( $x, $y + 1, [$l], $graph, $dictionary );
find_word_diagonal( $x + 1, $y + 1, [$l], $graph, $dictionary );
find_word_diagonal2( $x + 1, $y - 1, [$l], $graph, $dictionary );
}
}
}
sub find_word_vertical ( $x, $y, $strp, $graph, $dictionary ) {
my $l = $graph->[$x][$y];
return unless defined $l;
push $strp->@*, $l;
my $w1 = join '', $strp->@*;
my $w2 = join '', reverse $strp->@*;
$output->{$w1}++ if $dictionary->{$w1};
$output->{$w2}++ if $dictionary->{$w2};
find_word_vertical( $x + 1, $y, $strp, $graph, $dictionary );
}
sub find_word_horizontal ( $x, $y, $strp, $graph, $dictionary ) {
my $l = $graph->[$x][$y];
return unless defined $l;
push $strp->@*, $l;
my $w1 = join '', $strp->@*;
my $w2 = join '', reverse $strp->@*;
$output->{$w1}++ if $dictionary->{$w1};
$output->{$w2}++ if $dictionary->{$w2};
find_word_horizontal( $x, $y + 1, $strp, $graph, $dictionary );
}
sub find_word_diagonal ( $x, $y, $strp, $graph, $dictionary ) {
my $l = $graph->[$x][$y];
return unless defined $l;
push $strp->@*, $l;
my $w1 = join '', $strp->@*;
my $w2 = join '', reverse $strp->@*;
$output->{$w1}++ if $dictionary->{$w1};
$output->{$w2}++ if $dictionary->{$w2};
find_word_diagonal( $x + 1, $y + 1, $strp, $graph, $dictionary );
}
sub find_word_diagonal2 ( $x, $y, $strp, $graph, $dictionary ) {
my $l = $graph->[$x][$y];
return unless defined $l;
push $strp->@*, $l;
my $w1 = join '', $strp->@*;
my $w2 = join '', reverse $strp->@*;
$output->{$w1}++ if $dictionary->{$w1};
$output->{$w2}++ if $dictionary->{$w2};
find_word_diagonal( $x + 1, $y - 1, $strp, $graph, $dictionary );
}
sub get_word_search( $file ) {
my $ws = [];
if ( -f $file && open my $fh, '<', $file ) {
while ( my $line = <$fh> ) {
my @line = map { uc $_ } split /\W/, $line;
push $ws->@*, [@line];
}
}
return wantarray ? $ws->@* : $ws;
}
sub get_words ($file) {
my %words;
if ( -f $file && open my $fh, '<', $file ) {
while ( my $word = <$fh> ) {
chomp $word;
$word = uc $word;
next if $word =~ /\W/;
$words{$word} = 1;
}
}
return wantarray ? %words : \%words;
}
```