Merge pull request #2741 from jacoby/master

86!

4 files changed, 224 insertions, 0 deletions

diff --git a/challenge-085/dave-jacoby/perl/ch-1.pl b/challenge-085/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..81b3d47945
--- /dev/null
+++ b/challenge-085/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,51 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use List::Util qw{ sum };
+
+my @list;
+push @list, [ 1.2, 0.4, 0.1, 2.5 ];
+push @list, [ 0.2, 1.5, 0.9, 1.1 ];
+push @list, [ 0.5, 1.1, 0.3, 0.7 ];
+
+for my $r (@list) {
+    triplet_sum( $r->@* );
+    say '';
+}
+
+sub triplet_sum ( @array ) {
+    say join ', ', @array;
+    my $arr->@* = @array;
+
+    for ( 0 .. scalar $arr->@* ) {
+        my $x   = shift $arr->@*;
+        my $out = _triplet_sum( [$x], $arr );
+        say 1 and return if $out;
+        push $arr->@*, $x;
+    }
+    say 0;
+}
+
+sub _triplet_sum ( $trip, $stash ) {
+    if ( 3 == scalar $trip->@* ) {
+        my $sum = sum $trip->@*;
+        if ( 1 < $sum && $sum < 2 ) {
+            say join ' + ', $trip->@*;
+            return 1;
+        }
+        return 0;
+    }
+    my $trip2->@*  = $trip->@*;
+    my $stash2->@* = $stash->@*;
+    for ( 0 .. scalar $stash2->@* ) {
+        my $x = shift $stash2->@*;
+        push $trip2->@*, $x;
+        my $out = _triplet_sum( $trip2, $stash2 );
+        return 1 if $out;
+        push $stash2->@*, pop $trip2->@*;
+    }
+}
diff --git a/challenge-085/dave-jacoby/perl/ch-2.pl b/challenge-085/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..7442e8b066
--- /dev/null
+++ b/challenge-085/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,25 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+for my $n ( 8, 15, 125 ) {
+    say join "\t", $n, two_ints($n),"\n";
+}
+
+sub two_ints( $n ) {
+    for my $i ( 1 .. $n ) {
+        for my $j ( 2 .. $n ) {
+            my $exp = $i**$j;
+            next if $exp > $n;
+            if ( $exp == $n ) {
+                say qq{$i ** $j == $exp == $n};
+                return 1;
+            }
+        }
+    }
+    return 0;
+}
+
diff --git a/challenge-086/dave-jacoby/perl/ch-1.pl b/challenge-086/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..29c2e42e98
--- /dev/null
+++ b/challenge-086/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,23 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+say pair_difference( 7,  ( 10, 8,  12, 15, 5 ) );
+say pair_difference( 6,  ( 1,  5,  2,  9,  7 ) );
+say pair_difference( 15, ( 10, 30, 20, 50, 40 ) );
+
+sub pair_difference ( $A, @N ) {
+    say join ' ', '     ', $A, '--', @N;
+    while (@N) {
+        my $n = shift @N;
+        for my $o (@N) {
+            return 1 if $A == $n - $o;
+            return 1 if $A == $o - $n;
+        }
+    }
+
+    return 0;
+}
diff --git a/challenge-086/dave-jacoby/perl/ch-2.pl b/challenge-086/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..020a20e6b5
--- /dev/null
+++ b/challenge-086/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,125 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use List::Util qw{ uniq };
+
+use JSON;
+my $json = JSON->new;
+
+my $puzzle = '
+ _ _ _ 2 6 _ 7 _ 1 
+ 6 8 _ _ 7 _ _ 9 _ 
+ 1 9 _ _ _ 4 5 _ _ 
+ 8 2 _ 1 _ _ _ 4 _ 
+ _ _ 4 6 _ 2 9 _ _ 
+ _ 5 _ _ _ 3 _ 2 8 
+ _ _ 9 3 _ _ _ 7 4 
+ _ 4 _ _ 5 _ _ 3 6 
+ 7 _ 3 _ 1 8 _ _ _ 
+';
+
+my @puzzle;
+for my $row ( grep { /\S/ } split /\s?\n\s?/, $puzzle ) {
+    my @row = split /\s/mx, $row;
+    push @puzzle, \@row;
+}
+
+say 'BEFORE';
+display_puzzle(@puzzle);
+solve_puzzle( 0, 0, \@puzzle );
+
+sub solve_puzzle ( $x, $y, $puzzle ) {
+    return unless $puzzle->[$x][$y];
+    my $n = $puzzle->[$x][$y];
+
+    my $nx = $x;
+    my $ny = $y;
+    $nx++;
+    if ( $nx > 8 ) {
+        $ny++;
+        $nx = 0;
+    }
+
+    if ( $n eq '_' ) {
+        for my $i ( 1 .. 9 ) {
+            $puzzle->[$x][$y] = $i;
+            next unless test_puzzle($puzzle);
+            if ( $x == 8 && $y == 8 ) {
+                say 'SOLVED';
+                display_puzzle($puzzle->@*);
+            }
+            else {
+                solve_puzzle( $nx, $ny, $puzzle );
+            }
+        }
+        $puzzle->[$x][$y] = '_';
+    }
+    else {
+        solve_puzzle( $nx, $ny, $puzzle );
+    }
+}
+
+sub test_puzzle( $puzzle) {
+    my @puzzle    = $puzzle->@*;
+    my $yardstick = join ' ', 1 .. 9;
+
+    # rows
+    for my $x ( 0 .. 8 ) {
+        my @row = $puzzle[$x]->@*;
+        for my $k ( 1 .. 9 ) {
+            my @c = grep { /$k/ } @row;
+            my $c = scalar @c;
+            return 0 if $c > 1;
+        }
+    }
+
+    # columns
+    for my $x ( 0 .. 8 ) {
+        my @col = map { $puzzle->[$_][$x] } 0 .. 8;
+        for my $k ( 1 .. 9 ) {
+            my @c = grep { /$k/ } @col;
+            my $c = scalar @c;
+            return 0 if $c > 1;
+        }
+    }
+
+    # blocks
+    for my $xa ( 0 .. 2 ) {
+        for my $ya ( 0 .. 2 ) {
+            my @block;
+            for my $xb ( 0 .. 2 ) {
+                for my $yb ( 0 .. 2 ) {
+                    my $x = $xa * 3 + $xb;
+                    my $y = $ya * 3 + $yb;
+                    push @block, $puzzle[$x][$y];
+                }
+            }
+            for my $k ( 1 .. 9 ) {
+                my @c = grep { /$k/ } @block;
+                my $c = scalar @c;
+                return 0 if $c > 1;
+            }
+        }
+    }
+    return 1;
+}
+
+sub display_puzzle ( @puzzle ) {
+    say '-' x 27;
+    for my $x ( 0 .. 8 ) {
+        if ( $x % 3 == 0 && $x ne 0 ) { say ''; }
+        for my $y ( 0 .. 8 ) {
+            print ' ' if $y % 3 == 0;
+            print $puzzle[$x][$y] || '=';
+            print ' ';
+        }
+        say '';
+    }
+    say '-' x 27;
+    say '';
+}
+