Merge pull request #2771 from ccntrq/challenge-086

Challenge 086

2 files changed, 247 insertions, 0 deletions

diff --git a/challenge-086/alexander-pankoff/perl/ch-1.pl b/challenge-086/alexander-pankoff/perl/ch-1.pl
new file mode 100755
index 0000000000..adf19222a7
--- /dev/null
+++ b/challenge-086/alexander-pankoff/perl/ch-1.pl
@@ -0,0 +1,92 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+use List::Util qw(any first pairfirst);
+use Scalar::Util qw(looks_like_number);
+
+use Getopt::Long qw(:config auto_help);
+use Pod::Usage;
+
+use FindBin;
+use lib File::Spec->join( $FindBin::RealBin, '..', '..', '..', 'challenge-083', 'alexander-pankoff', 'perl', 'lib' );
+
+use Combinations qw(combinations);
+
+{
+    my $NUMBERS;
+    my $TARGET;
+    GetOptions(
+        'numbers=s' => \$NUMBERS,
+        "target=i"  => \$TARGET,
+      )
+      && defined $TARGET
+      or pod2usage( -exitval => 1 );
+
+    $NUMBERS = slurp( *STDIN ) if !$NUMBERS;
+
+    my @NUMBERS = split( /,?\s+/, $NUMBERS );
+
+    my $invalid = first( sub { !looks_like_number( $_ ) || $_ <= 0 || int( $_ ) != $_ }, @NUMBERS );
+    pod2usage(
+        -exitval => 1,
+        message  => "unexpected value in input list: $invalid"
+    ) if $invalid;
+
+    my @pair = pair_difference( $TARGET, @NUMBERS );
+    my $out  = ( @pair ? 1 : 0 );
+
+    print $out;
+
+    if ( $ENV{DEBUG} && @pair ) {
+        printf( ' as %d - %d  = %d', ( sort { $b <=> $a } @pair ), $TARGET );
+    }
+
+    print "\n";
+
+    exit 0;
+}
+
+sub pair_difference ( $target, @numbers ) {
+
+    # reusing `combinations` from ch-083 again to build our pairs.
+    # we will calculate the absolute difference between the pair members so
+    # that order of the memebers doesn't matter
+    my @pairs = combinations( 2, @numbers );
+
+    # find the first pair whose difference is $target
+    # this returns the pair in list context or a boolean `found` value in
+    # scalar context
+    return pairfirst { abs( $a - $b ) == $target } ( map { @$_ } @pairs );
+}
+
+sub slurp($fh) {
+    local $/ = undef;
+    my $out = <$fh>;
+    return $out;
+}
+
+=pod
+
+=head1 NAME
+
+wk-086 ch-1 - Pair Difference
+
+=head1 SYNOPSIS
+
+ch-1.pl [options]
+
+  This programm will print '1' if there is a pair in `numbers` whose difference is `target`
+
+  Options:
+    --numbers    a list of integer numbers (e.g. "10, 8, 12, 15, 5")
+    --target     the target value
+    --help       print this help text
+
+    If --numbers is omitted input will be read from stdin instead
+
+=cut
diff --git a/challenge-086/alexander-pankoff/perl/ch-2.pl b/challenge-086/alexander-pankoff/perl/ch-2.pl
new file mode 100755
index 0000000000..1314a2c1b1
--- /dev/null
+++ b/challenge-086/alexander-pankoff/perl/ch-2.pl
@@ -0,0 +1,155 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+use List::Util qw(all any);
+use Storable qw(dclone);
+
+use Getopt::Long qw(:config auto_help);
+use Pod::Usage;
+
+{
+
+    my $INPUT = slurp(*STDIN);
+
+    my @SUDOKU = map {
+        [ map { $_ eq '_' ? undef : $_ } grep { /[0-9_]/ } split( /\s*/, $_ ) ]
+    } split( /\n/, $INPUT );
+
+    pod2usage( -message => "Invalid input", -exitval => 1 )
+      unless all { @$_ == 9 } @SUDOKU;
+
+    my $solved = solve( \@SUDOKU );
+
+    die "no solution found\n" unless $solved;
+    say render_sudoku($solved);
+}
+
+sub render_sudoku($sudoku) {
+    join(
+        "\n",
+        map {
+            join( ' ', '[', map { $_ // '_' } @$_, ']' )
+        } @$sudoku
+    );
+}
+
+sub solve($sudoku) {
+    return $sudoku if solved($sudoku);
+
+    my %cache;
+    while ( my %next = next_free_position( $sudoku, \%cache ) ) {
+        my $row = $next{row};
+        my $col = $next{col};
+        $cache{ $row . $col } = 1;
+
+        for my $candidate ( @{ $next{domain} } ) {
+            my $test = [@$sudoku];
+            $test->[$row] = [ @{ $test->[$row] } ];
+            $test->[$row][$col] = $candidate;
+            my $solved = solve($test);
+            return $solved if $solved;
+        }
+    }
+}
+
+sub next_free_position ( $sudoku, $cache ) {
+    my %min;
+    for my $row ( 0 .. 8 ) {
+        for my $col ( 0 .. 8 ) {
+            next if defined $sudoku->[$row][$col] || $cache->{ $row . $col };
+            my @domain = get_candidates( $row, $col, $sudoku );
+            return if !@domain;
+
+            if ( !%min || @domain < @{ $min{domain} } ) {
+                %min = (
+                    row    => $row,
+                    col    => $col,
+                    domain => \@domain,
+                );
+            }
+        }
+    }
+
+    return %min;
+}
+
+sub get_candidates ( $row, $col, $sudoku ) {
+    intersection(
+        [ col_candidates( $col, $sudoku ) ],
+        [ row_candidates( $row, $sudoku ) ],
+        [ box_candidates( $row, $col, $sudoku ) ]
+    );
+}
+
+sub solved($sudoku) {
+    all { !row_candidates( $_, $sudoku ) } 0 ... 8;
+}
+
+sub row_candidates ( $row, $sudoku ) {
+    _missing( @{ $sudoku->[$row] } );
+}
+
+sub col_candidates ( $col, $sudoku ) {
+    _missing( map { $_->[$col] } @{$sudoku} );
+}
+
+sub box_candidates ( $row, $col, $sudoku ) {
+
+    my $box_start_row = int( $row / 3 ) * 3;
+    my $box_start_col = int( $col / 3 ) * 3;
+
+    my @elems =
+      map { @{$_}[ $box_start_col .. $box_start_col + 2 ] }
+      ( @{$sudoku}[ $box_start_row .. $box_start_row + 2 ] );
+    return _missing(@elems);
+}
+
+sub _missing(@elems) {
+    state $domain = [ 1 .. 9 ];
+    difference( $domain, \@elems );
+}
+
+sub difference ( $a, $b ) {
+    my %b_lookup = map { $_ ? ( $_ => 1 ) : () } @$b;
+    grep { !$b_lookup{$_} } @$a;
+}
+
+sub intersection ( $a, $b, @more ) {
+    my %a_lookup = map { $_ => 1 } @$a;
+    my @res =
+      grep {
+        my $b_elem = $_;
+        $a_lookup{$b_elem};
+      } @$b;
+
+    return @res if !@more;
+    return intersection( \@res, @more );
+}
+
+sub slurp($fh) {
+    local $/ = undef;
+    my $out = <$fh>;
+    return $out;
+}
+
+=pod
+
+=head1 NAME
+
+wk-086 ch-2 - Sudoku Puzzle
+
+=head1 SYNOPSIS
+
+ch-2.pl [options]
+
+  This programm will complete the given Sudoku Puzzle
+
+  Options:
+    --help       print this help text
+
+=cut