Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Yet Another Sudoku Solver

by SubStack (Monk)
on Aug 26, 2006 at 18:31 UTC ( #569825=sourcecode: print w/replies, xml ) Need Help??
Category: Fun Stuff
Author/Contact Info SubStack
Description: This script solves any sudoku puzzle that can be solved (as far as I can tell). I started out with a simpler version that only solved easy puzzles and then retro-fitted it to solve the harder ones where the player must follow out potentially useless trails.
#!/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 blank
+s.
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 sol
+utions.
my $threshold = 1;
close $fh;
# Iternate through each spot and see how many choices for numbers ther
+e 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], @{$sq
+uares[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 s
+quare.
          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 parti
+cular
      # 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 iteratio
+n.
  $threshold++;
}
show(0);
sub show { # useful for debugging the squares while running
  print join("", @$_), "\n" for @{$squares[$_[0]]};
}
Spaces are used for blanks. Here's an example to try out:
    9  4 
 7  6    
89    21 
     36 8
  42 67  
9 68     
 61    54
    8  7 
 4  1
Replies are listed 'Best First'.
Re: Yet Another Sudoku Solver
by strat (Canon) on Jun 18, 2007 at 23:38 UTC
    9 6 7 4 3 4 2 7 23 1 5 1 4 2 8 6 3 5 3 7 5 7 5 4 5 1 7 8
    only shows one solution (the sudoku has two):
    926571483 351486279 874923516 582367194 149258367 763194825 238749651 617835942 495612738
    and
    926571483 351486279 874923516 582367194 149258367 763149825 238794651 617835942 495612738

    Best regards,
    perl -e "s>>*F>e=>y)\*martinF)stronat)=>print,print v8.8.8.32.11.32"

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://569825]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (5)
As of 2020-09-28 09:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    If at first I donít succeed, I Ö










    Results (143 votes). Check out past polls.

    Notices?