Perl solution for week 76/part 2

5 files changed, 196 insertions, 0 deletions

diff --git a/challenge-076/abigail/README.md b/challenge-076/abigail/README.md
index d40e979e24..c10f721c4d 100644
--- a/challenge-076/abigail/README.md
+++ b/challenge-076/abigail/README.md
@@ -19,3 +19,51 @@ Ouput:
 
 ### Solutions
 * [Perl](perl/ch-1.c)
+
+## [Word Search](https://perlweeklychallenge.org/blog/perl-weekly-challenge-076/#TASK2)
+
+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.
+
+### Example
+~~~~
+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
+
+### Solutions
+* [Perl](perl/ch-2.c)
diff --git a/challenge-076/abigail/perl/ch-2.pl b/challenge-076/abigail/perl/ch-2.pl
new file mode 100644
index 0000000000..59636a7852
--- /dev/null
+++ b/challenge-076/abigail/perl/ch-2.pl
@@ -0,0 +1,85 @@
+#!/opt/perl/bin/perl
+
+use 5.032;
+
+use strict;
+use warnings;
+no  warnings 'syntax';
+
+use experimental 'signatures';
+use experimental 'lexical_subs';
+
+use List::Util qw [min];
+
+#
+# Read in the list of words. Grep all the words longer than 4 characters.
+#
+my $dictionary = "/Users/abigail/Words/enable.lst";
+open my $fh, "<", $dictionary or die "open: $!";
+chomp (my @words = grep {/.{5}/} <$fh>);
+
+#
+# Turn the word list into a pattern. Longest word first.
+# This means if there are words 'foo' and 'foobar', and a
+# row contains 'foobar', we grep the 'foobar', not the 'foo'.
+#
+my $pat = join '|' => sort {length ($b) <=> length ($a)} @words;
+   $pat = qr /$pat/;
+
+
+#
+# Read in the grid; lowercase the letters.
+#
+my @grid = map {[split ' ' => lc]} <>;
+my $nr_of_rows = @grid;
+my $nr_of_cols = @{$grid [0]};
+
+{
+    my %words;
+    #
+    # Given a list of letters, find any words in them, either
+    # in the give direction, or reversed.
+    #
+    sub collect_words (@letters) {
+        my $line = join "" => @letters;
+        $words {$_} ++ for          $line  =~ /(?=($pat))/g;
+        $words {$_} ++ for reverse ($line) =~ /(?=($pat))/g;
+    }
+    #
+    # Return the list of found words, sorted.
+    #
+    sub words () {
+        sort keys %words;
+    }
+}
+
+#
+# Collect words
+#
+
+# Rows:
+map {collect_words @$_} @grid;
+
+# Columns:
+map {my $i = $_; collect_words map {$$_ [$i]} @grid} 0 .. $nr_of_cols - 1;
+
+# Diagonals in NE & SE quadrants:
+for my $i (0 .. $nr_of_cols - 1) {
+    my $max = min $nr_of_cols - $i - 1, $nr_of_rows - 1;
+    collect_words map {$grid [$_]                        [$_ + $i]} 0 .. $max;
+    collect_words map {$grid [$nr_of_rows - 1 - $_]      [$_ + $i]} 0 .. $max;
+}
+
+# Diagonals in SW & NW quadrants:
+for my $j (0 .. $nr_of_rows - 1) {
+    my $max = min $nr_of_rows - $j - 1, $nr_of_cols - 1;
+    collect_words map {$grid [$_ + $j]                   [$_]}      0 .. $max;
+    collect_words map {$grid [$nr_of_rows - 1 - $_ - $j] [$_]}      0 .. $max;
+}
+
+#
+# Print the results
+#
+say for words;
+
+__END__
diff --git a/challenge-076/abigail/t/ctest.ini b/challenge-076/abigail/t/ctest.ini
index c926397ef7..4f40aed80e 100644
--- a/challenge-076/abigail/t/ctest.ini
+++ b/challenge-076/abigail/t/ctest.ini
@@ -2,3 +2,4 @@
 1-1 = Given example

 1-2 = Some 2 digit cases

 1-3 = Some 12 digit cases

+2-1 = Given search grid

diff --git a/challenge-076/abigail/t/input-2-1 b/challenge-076/abigail/t/input-2-1
new file mode 100644
index 0000000000..31cf2e0fd8
--- /dev/null
+++ b/challenge-076/abigail/t/input-2-1
@@ -0,0 +1,19 @@
+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
diff --git a/challenge-076/abigail/t/output-2-1.exp b/challenge-076/abigail/t/output-2-1.exp
new file mode 100644
index 0000000000..ec1e35c623
--- /dev/null
+++ b/challenge-076/abigail/t/output-2-1.exp
@@ -0,0 +1,43 @@
+aimed
+align
+antes
+arose
+ashed
+blunts
+broad
+buries
+cloven
+constitutions
+croon
+departed
+duddie
+enter
+filch
+garlic
+goats
+grieves
+grith
+hazard
+ileac
+liens
+lunts
+malignant
+malls
+midsts
+ought
+ovary
+parted
+pudgiest
+quashed
+raias
+raped
+ruses
+shrines
+sices
+socializing
+soyas
+spasmodic
+succors
+theorems
+viruses
+wigged