Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
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 imbibing at the Monastery: (3)
As of 2020-10-20 03:31 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My favourite web site is:












    Results (208 votes). Check out past polls.

    Notices?