#!/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]]};
}