#!/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 ```