#!/usr/bin/perl
# solve.pl - Solves all sudoku puzzles, even really hard ones
# Just feed it a file with each row on a line and spaces for the blanks.
use strict;
use warnings;
use Storable qw(dclone);
my $DEBUG = 0;
die "usage: $0 file\n" unless @ARGV;
open my $fh, "<", $ARGV[0] or die "failed to open '$ARGV[0]': $!\n";
# Store all potential squares (by which I mean the board-type thing).
# This grows as new potentials solutions manifest and shrinks as they fail.
my @squares = [ map [ m/([\d ])/g ], <$fh> ];
# Number of potential solutions that will be acceptable for the given search.
# This is automatically adjusted based on the availability of good solutions.
my $threshold = 1;
close $fh;
# Iternate through each spot and see how many choices for numbers there are.
# If the number of choices meets the threshold, fill the coordinate in, on
# multiple instances of the square if needed.
scan: while (grep $_ eq " ", map @$_, @{$squares[0]}) {
# keep track of y coordinate on the square
my $y = -1;
for my $row (@{$squares[0]}) {
$y++;
# keep track of x coordinate on the square
my $x = -1;
for my $number (@$row) {
$x++;
next unless $number eq " "; # only bother solving blank squares
# Load all the numbers in the coordinate's 3x3 magic square.
# They aren't really magic squares of course, but it makes them easier to
# refer to.
my @magic = grep $_ ne " ",
map @{$_}[int($x / 3) * 3 .. int($x / 3) * 3 + 2 ],
@{$squares[0]}[int($y / 3) * 3 .. int($y / 3) * 3 + 2];
# Load all the numbers in the coordinate's row.
my @row_nums = grep $_ ne " ", @$row;
# Load all the numbers in the coordinate's column.
my @col_nums = grep $_ ne " ", grep defined, map $_->[$x], @{$squares[0]};
# Count up the occurances of the numbers the coordinate can't be.
my %count = map { $_ => 0 } 1 .. 9;
$count{$_}++ for @magic, @row_nums, @col_nums;
# All the possible values for the coordinate
my @possible = grep $count{$_} == 0, keys %count;
print "($x, $y): ",
" possible = @{[ sort @possible ]}\n",
" magic = @{[ sort @magic ]}\n",
" cols = @{[ sort @col_nums ]}\n",
" rows = @{[ sort @row_nums ]}\n"
if $DEBUG;
if (@possible == $threshold) {
# Number of possibilities meets the threshold
print "Solved coordinate ($x, $y) == (@possible)\n" if $DEBUG;
# Throw the first possibility onto the current square.
$squares[0][$y][$x] = shift @possible;
for (@possible) {
# Throw the other possibilities into copies of the current square.
push @squares, dclone($squares[0]);
$squares[$#squares][$y][$x] = $_;
}
# Set the threshold back to 1 for a successful match.
$threshold = 1;
next scan;
}
# Scrap squares that don't have any possible choices for a particular
# coordinate.
if (@possible == 0) {
print "Scrapping guess due to ($x, $y)\n" if $DEBUG;
shift @squares;
die "No more guesses! Unsolvable!\n" unless @squares;
$threshold = 1;
next scan;
}
}
}
# The possibilities weren't good enough. Be less picky next iteration.
$threshold++;
}
show(0);
sub show { # useful for debugging the squares while running
print join("", @$_), "\n" for @{$squares[$_[0]]};
}
##```
##
9 4
7 6
89 21
36 8
42 67
9 68
61 54
8 7
4 1
```