add perl solution for wk-086 ch-2

1 files changed, 155 insertions, 0 deletions

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