laurent_r

These are some answers to the Week 76 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on Aug. 16, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task #1: Prime Sum

I’ve written a Raku program to solve this task, but it is unfortunately a bit buggy: it works in most cases, but there are a few rare cases where it doesn’t find the minimum number of prime numbers whose summation gives you the target number. I certainly don’t want to publish here a program which I know to be faulty in some cases, and I no longer have time before the deadline to fix it. So, I’ll skip this task for now.

Task #2: Word Search

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.

Search Grid:

B I D E M I A T S U C C O R S T
L D E G G I W Q H O D E E H D P
U S E I R U B U T E A S L A G U
N G N I Z I L A I C O S C N U D
T G M I D S T S A R A R E I F G
S R E N M D C H A S I V E E L I
S C S H A E U E B R O A D M T E
H W O V L P E D D L A I U L S S
R Y O N L A S F C S T A O G O T
I G U S S R R U G O V A R Y O C
N R G P A T N A N G I L A M O O
E I H A C E I V I R U S E S E D
S E T S U D T T G A R L I C N H
H V R M X L W I U M S N S O T B
A E A O F I L C H T O D C A E U
Z S C D F E C A A I I R L N R F
A R I I A N Y U T O O O U T P F
R S E C I S N A B O S C N E R A
D R S M P C U U N E L T E S I L

Output:

Found 54 words of length 5 or more when checked against the local dictionary. You may or may not get the same result but that is fine.

aimed, align, antes, argos, arose, ashed, blunt, blunts, broad, buries, clove, cloven, constitution, constitutions, croon, depart, departed, enter, filch, garlic, goats, grieve, grieves, hazard, liens, malign, malignant, malls, margo, midst, ought, ovary, parted, patna, pudgiest, quash, quashed, raped, ruses, shrine, shrines, social, socializing, spasm, spasmodic, succor, succors, theorem, theorems, traci, tracie, virus, viruses, wigged

My first reaction was to hate this task because it requires a lot of code lines (so many different cases) for a coding challenge. So, I tried to make a relatively concise solution avoiding code repetition.

Word Search in Raku

I have in my default directory a words.txt file containing about 114,000 English words. They are all lower-case words, so I’ll have to change case for the input grid. The authorized words will be stored in a Set.

The grid will be read from a file ans stored in an array or arrays.

The program reads arrays from the grid in all directions (horizontal, vertical, from top left to bottom right and from top right to bottom left and calls the find_words subroutine. This subroutine takes an array of letters as input, and looks for words, both forward and backward, in the input array.

use v6;

my ($dict, $grid-file) = @*ARGS;
my $min-length = @*ARGS[2]:exists ?? @*ARGS[2] !! 5;
my $words = $dict.IO.lines.grep({.chars >= $min-length}).Set;
my @grid;
for  $grid-file.IO.lines -> $line {
    my @letters = $line.lc.split(' ');
    push @grid, @letters;
}
my $max_row = @grid.end;
my $max_col = @grid[0].end;
my $result = SetHash.new;

sub find_words (@row) {
    for 0 .. @row.end -> $i {
        for $i+$min-length-1 .. @row.end -> $j {
            my $word = join '', @row[$i..$j];
            $result{$word}++ if $words{$word};
            my $flipped = $word.flip;
            $result{$flipped}++ if $words{$flipped};
        }
    }
}
# Horizontal
for @grid -> @row {
    find_words @row;
}
# Vertical
for 0..$max_col -> $i {
    my @col = map { @grid[$_][$i] }, 0..$max_row;
    find_words @col;
}
# Oblique, NW to SE
for 0..$max_col - $min-length + 1 -> $i {
    my @vals = grep {defined $_}, map { @grid[$_][$_+$i] }, 0..$max_row;
    find_words @vals;
}
for 1..$max_row-$min-length+1 -> $j {
    my @vals = grep {defined $_}, map { @grid[$_+$j][$_]}, 0..$max_row;
    find_words @vals;
}
# Oblique, NE to Sw
for $min-length - 1 .. $max_col -> $j {
    my @vals = grep {defined $_}, map { @grid[$j-$_][$_] }, 0..$max_col;
    find_words @vals;
}
for 1 ..$max_row - $min-length + 1 -> $i {
    my @vals = grep {defined $_}, map { @grid[$i+$_][$max_col-$_] },  0..$max_col;
    find_words @vals;
}  
say join " ", sort keys $result;

This program produces the following output with 57 words:

$ raku letter-grid.raku words.txt grid.txt
aimed align antes arose ashed blunt blunts broad buries clove cloven constitution croon depart departed duddie enter filch garlic goats grieve grieves grith hazard ileac liens lunts malign malignant malls midst midsts ought ovary parted pudgiest quash quashed raias raped roser ruses shrine shrines sices social socializing soyas spasm spasmodic succor succors theorem theorems virus viruses wigged

Word Search in Perl

Compared too the Raku program, Sets and SetHashes are replaced with hashes. There are a few other things done differently, but it is essentially the same idea. Also, I was too lazy to use a separate file for the grid, which I included in a __DATA__ section of the program. For the same reason, I also hard-coded the name of the file containing the list of authorized words.

use strict;
use warnings;
use feature "say";

my $dict = "words.txt";
my $min_length = shift // 5;
open my $IN, "<", $dict or die unable to open $dict;
my %words = map { $_ => 1 } grep { length $_ >= $min_length }
    map { chomp; $_ } <$IN>;
close $IN;

my @grid = map { s/[\r\n]+//; [split / /, lc $_]} <DATA>;
my $max_row = $#grid;
my $max_col = $#{$grid[0]}; # scalar @{$grid}[0]} - 1;
my %result;

sub find_words {
    my @row = @{$_[0]};
    for my $i (0..$#row) {
        for my $j ($i+$min_length-1..$#row) {
            my $word = join '', @row[$i..$j];
            $result{$word} = 1 if exists $words{$word};
        }
    }
}

# Horizontal
for my $row (@grid) {
    find_words $_ for $row, [reverse @$row];
}
# Vertical
for my $i (0..$max_col) {
    my @vals = map { $grid[$_][$i] } 0..$max_row;
    find_words $_ for [@vals], [reverse @vals];
}
# Oblique, NW to SE
for my $i (0..$max_col - $min_length + 1) {
    my @vals = grep defined $_, map { $grid[$_][$_+$i] } 0..$max_row;
    find_words $_ for [@vals], [reverse @vals];
}
for my $j (1..$max_row-$min_length+1) {
    my @vals = grep defined $_, map { $grid[$_+$j][$_]} 0..$max_row;
    find_words $_ for [@vals], [reverse @vals];
}
# Oblique, NE to Sw
for my $j ($min_length - 1 .. $max_col) {
    my @vals = grep defined $_, map { $grid[$j-$_][$_] } 0..$max_col;
    find_words $_ for [@vals], [reverse @vals];;
}
for my $i (1 ..$max_row - $min_length + 1) {
    my @vals = grep defined $_, map { $grid[$i+$_][$max_col-$_] }  0..$max_col;
    find_words $_ for [@vals], [reverse @vals];
}  
say join " ", sort keys %result;


__DATA__
B I D E M I A T S U C C O R S T
L D E G G I W Q H O D E E H D P
U S E I R U B U T E A S L A G U
N G N I Z I L A I C O S C N U D
T G M I D S T S A R A R E I F G
S R E N M D C H A S I V E E L I
S C S H A E U E B R O A D M T E
H W O V L P E D D L A I U L S S
R Y O N L A S F C S T A O G O T
I G U S S R R U G O V A R Y O C
N R G P A T N A N G I L A M O O
E I H A C E I V I R U S E S E D
S E T S U D T T G A R L I C N H
H V R M X L W I U M S N S O T B
A E A O F I L C H T O D C A E U
Z S C D F E C A A I I R L N R F
A R I I A N Y U T O O O U T P F
R S E C I S N A B O S C N E R A
D R S M P C U U N E L T E S I L

This program produces the same output as the Raku program:

$ perl letter-grid.pl
aimed align antes arose ashed blunt blunts broad buries clove cloven constitution croon depart departed duddie enter filch garlic goats grieve grieves grith hazard ileac liens lunts malign malignant malls midst midsts ought ovary parted pudgiest quash quashed raias raped roser ruses shrine shrines sices social socializing soyas spasm spasmodic succor succors theorem theorems virus viruses wigged

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on Sunday, September 13, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.