aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--challenge-076/dave-jacoby/perl/ch-1.pl56
-rw-r--r--challenge-076/dave-jacoby/perl/ch-2.pl109
-rw-r--r--challenge-076/dave-jacoby/perl/word_grid.txt19
-rwxr-xr-xchallenge-077/dave-jacoby/perl/ch-1.pl63
-rwxr-xr-xchallenge-077/dave-jacoby/perl/ch-2.pl71
5 files changed, 318 insertions, 0 deletions
diff --git a/challenge-076/dave-jacoby/perl/ch-1.pl b/challenge-076/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..9b2e4cef89
--- /dev/null
+++ b/challenge-076/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,56 @@
+#!/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;
+}
diff --git a/challenge-076/dave-jacoby/perl/ch-2.pl b/challenge-076/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..7a36c770da
--- /dev/null
+++ b/challenge-076/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,109 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use Getopt::Long;
+
+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;
+}
diff --git a/challenge-076/dave-jacoby/perl/word_grid.txt b/challenge-076/dave-jacoby/perl/word_grid.txt
new file mode 100644
index 0000000000..c5766eae93
--- /dev/null
+++ b/challenge-076/dave-jacoby/perl/word_grid.txt
@@ -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 \ No newline at end of file
diff --git a/challenge-077/dave-jacoby/perl/ch-1.pl b/challenge-077/dave-jacoby/perl/ch-1.pl
new file mode 100755
index 0000000000..6dc2865d99
--- /dev/null
+++ b/challenge-077/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,63 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use Carp;
+use Getopt::Long;
+use List::Util qw{ max sum0 uniq };
+
+my $n = 9;
+GetOptions( 'n=i' => \$n );
+croak "n < 1" if $n < 1;
+
+fib_sum($n);
+
+#
+sub fib_sum ( $n ) {
+ my @fib = reverse fib_list($n);
+ my @list = ( [] );
+ my @sums;
+ my %no;
+
+ while (@list) {
+ my $entry = shift @list;
+ for my $fib (@fib) {
+ next if grep { $_ == $fib } $entry->@*;
+ my $new->@* = sort { $b <=> $a } $fib, $entry->@*;
+ my $sum = sum0 $new->@*;
+ my $join = join ',', $new->@*;
+ next if $no{$join}++;
+ push @list, $new if $sum < $n;
+ push @sums, $new if $sum == $n;
+ }
+ }
+
+ if ( scalar @sums ) {
+ for my $sum (@sums) {
+ my $s = scalar $sum->@*;
+ my $p = join ' + ', $sum->@*;
+ say qq{$s as ($n = $p)};
+ }
+ }
+ else { print 0 }
+}
+
+# creates a list of fibonacci values where each value is
+# less than n and greater than zero, because zero is useless
+# in summation
+sub fib_list( $n ) {
+ my @output = ( 0, 1 );
+ my $i = 2;
+
+ while ( max(@output) < $n ) {
+ $output[$i] = $output[ $i - 1 ] + $output[ $i - 2 ];
+ my $max = max(@output);
+ $i++;
+ }
+
+ @output = uniq grep { $_ } grep { $_ <= $n } @output;
+ return @output;
+}
diff --git a/challenge-077/dave-jacoby/perl/ch-2.pl b/challenge-077/dave-jacoby/perl/ch-2.pl
new file mode 100755
index 0000000000..f35435cb75
--- /dev/null
+++ b/challenge-077/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,71 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use List::Util qw{ first };
+
+my @input = (
+ [ [qw[ O O X ]], [qw[ X O O ]], [qw[ X O O ]], ],
+ [ [qw( O O X O)], [qw( X O O O)], [qw( X O O X)], [qw( O X O O)], ]
+);
+
+for my $input (@input) {
+ say join "\n ", '', map { join ' ', $_->@* } $input->@*;
+ say '';
+
+ my $c = lonely_x($input);
+ if ( $c == 0 ) { say "No lonely Xs were found" }
+ elsif ( $c == 1 ) { say "One lonely X was found" }
+ else { say "$c lonely Xs were found" }
+}
+
+# lonely_x takes an arrayref containing a two-dimensional array
+# representing an m x n matrix containing only X and O, and
+# returns a count of "lonely Xs", which are Xs without an
+# X in a bordering position. If none are found, it returns
+# zero
+
+sub lonely_x ( $input ) {
+
+ my $c = 0;
+ my $x = scalar $input->@*;
+ my $y = scalar $input->[0]->@*;
+
+ # X and y are the outer bounds of the matrix.
+ # i and j are the location within the matrix.
+ # p is the value in the current "center".
+ # ii and jj are the bordering locations to i and j
+ # pp is the value in the current border location
+
+ # if pp is X, we know that i,j is not lonely,
+ # and thus we used he named next to get to the
+ # next. If, instead, we get to the end of the ii,jj
+ # loops, it must be lonely and we increment our
+ # "lonely X" count.
+
+ for my $i ( 0 .. $x ) {
+ OUT: for my $j ( 0 .. $y ) {
+ my $p = $input->[$i][$j];
+ next unless defined $p;
+ my $ok = 'X' eq $p ? 1 : 0;
+ next unless $ok;
+
+ for my $ii ( $i - 1 .. $i + 1 ) {
+ next if $ii < 0;
+ for my $jj ( $j - 1 .. $j + 1 ) {
+ next if $jj < 0;
+ next if $i == $ii && $j == $jj;
+ my $pp = $input->[$ii][$jj];
+ next unless defined $pp;
+ next OUT if $pp eq 'X';
+ }
+ }
+ $c++;
+ }
+ }
+
+ return $c;
+}
generated by cgit (git 2.34.1) at 2026-07-03 10:59:22 +0000