Perl solution for week 86, challenge 2.

1 files changed, 165 insertions, 0 deletions

diff --git a/challenge-086/abigail/perl/ch-2.pl b/challenge-086/abigail/perl/ch-2.pl
new file mode 100644
index 0000000000..7763d1ea76
--- /dev/null
+++ b/challenge-086/abigail/perl/ch-2.pl
@@ -0,0 +1,165 @@
+#!/opt/perl/bin/perl
+
+use 5.032;
+
+use strict;
+use warnings;
+no  warnings 'syntax';
+
+use experimental 'signatures';
+use experimental 'lexical_subs';
+
+
+#
+# Read the puzzle; set unsolved squares to 0.
+#
+my @sudoku   = map {[map {/_/ ? 0 : $_} /[_1-9]/g]} <>;
+my $SIZE     = @sudoku;
+my @INDICES  = (0 .. $SIZE - 1);
+my @ELEMENTS = (1 .. $SIZE);
+my $sqrtSIZE =  sqrt $SIZE;
+
+#
+# Sanity check
+#
+die "Sudoku width not a square\n"
+     unless int (sqrt $SIZE) ** 2 == $SIZE;
+die "All rows should be the same length as the columns"
+     if grep {@$_ != $SIZE} @sudoku;
+
+#
+# Given a square with coordinates ($x, $y), return all the
+# squares which can "see" this square -- that is, all the
+# squares in the same row, same column, or same block.
+# These are the squares which cannot have the same number
+# as the square with coordinates ($x, $y) has.
+#
+sub sees ($x, $y) {
+    state $cache;
+    $$cache {$x, $y} //= do {
+        my $out;
+        foreach my $i (@INDICES) {
+            foreach my $j (@INDICES) {
+                next if $i == $x && $j == $y;
+                push @$out => [$i, $j] if
+                      $i == $x ||                       # Same column
+                      $j == $y ||                       # Same row
+                                                        # Same box
+                      int ($i / $sqrtSIZE) == int ($x / $sqrtSIZE) &&
+                      int ($j / $sqrtSIZE) == int ($y / $sqrtSIZE);
+            }
+        }
+        $out;
+    };
+    @{$$cache {$x, $y}};
+}
+
+#
+# Iterate over the given puzzle. Create a set of solved
+# squares, and a set of unsolved ones. For the latter ones,
+# calculate the options it can take.
+#
+my $solved;
+my $unsolved;
+foreach my $x (@INDICES) {
+    foreach my $y (@INDICES) {
+        if ($sudoku [$x] [$y]) {  # Clue, hence solved
+            $$solved {$x, $y} = $sudoku [$x] [$y];
+            next;
+        }
+        #
+        # Not solved. Out of the elements, record the numbers
+        # which cannot be seen from this square.
+        #
+        my %set = map {$_ => 1} @ELEMENTS;
+        foreach my $can_see (sees ($x, $y)) {
+            delete $set {$sudoku [$$can_see [0]] [$$can_see [1]]};
+        }
+
+        $$unsolved {$x, $y} = [keys %set];
+    }
+}
+
+
+
+sub solve ($solved, $unsolved) {
+    #
+    # If there are no unsolved squares, we return $solved.
+    #
+    return $solved unless keys %$unsolved;
+
+    #
+    # Find the (a) square which the least possibilities
+    #
+    my ($key) = sort {@{$$unsolved {$a}} <=> @{$$unsolved {$b}} ||
+                                    $a   cmp               $b} keys %$unsolved;
+    my ($x, $y) = split $; => $key;
+
+    #
+    # Try each possibility
+    #
+    foreach my $guess (@{$$unsolved {$key}}) {
+        #
+        # Create new solved and unsolved structures
+        #
+        my $new_solved = {%$solved};
+        $$new_solved {$x, $y} = $guess;
+
+        #
+        # Copy unsolved
+        #
+        my $new_unsolved;
+        foreach my $key (keys %$unsolved) {
+            $$new_unsolved {$key} = [@{$$unsolved {$key}}];
+        }
+
+        #
+        # Delete our guess
+        #
+        delete $$new_unsolved {$key};
+
+        #
+        # Delete our guess as possibility for each square
+        # which can be seen
+        #
+        foreach my $can_see (sees ($x, $y)) {
+            my ($x, $y) = @$can_see;
+            $$new_unsolved {$x, $y} = [grep {$_ != $guess}
+                                           @{$$new_unsolved {$x, $y}}] 
+                      if $$new_unsolved {$x, $y};
+        }
+
+        #
+        # Recurse. Return on success.
+        #
+        if (my $solution = solve ($new_solved, $new_unsolved)) {
+            return $solution;
+        }
+    }
+
+    #
+    # No guess worked. Return false.
+    #
+    return;
+}
+
+
+#
+# Print the solution, if any.
+#
+if (my $r = solve ($solved, $unsolved)) {
+    foreach my $x (@INDICES) {
+        print "[ ";
+        foreach my $y (@INDICES) {
+            printf "%d ", $$r {$x, $y};
+        }
+        print "]\n";
+    }
+}
+else {
+    say "No solution found\n";
+}
+
+
+
+__END__