#! /usr/local/bin/perl
our $VERSION = '2.0.0';
use strict;
use warnings;
use Quantum::Superpositions;
use Getopt::Compact;
use Pod::Usage;
my $opt = new Getopt::Compact
(struct => [[[qw(v verbose)], qq(verbose mode, print grid after each i
+teration)],
[[qw(q quiet)], qq(quiet mode, just print result)],
[[qw(s summary)], qq(print summary at end)],
[[qw(m man)], qq(Print Pod doc as man page)],
])->opts;
pod2usage(-verbose => 3) if $opt->{man};
my $init = any(1..9);
my $grid = # Setup - we know nothing !
[
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
[$init,$init,$init, $init,$init,$init, $init,$init,$init],
];
my $known = 0; # How many cells do we know the value of ?
readpuzzle();
my $start = $known;
my $timer = time();
my $loops = 0;
#Keep looping round till there's no changes.
printgrid() while (elimrows() + elimcols() + elimsquares() and $known
+< 81);
$known == 81 ? finalgrid() : printgrid(1);
if ($opt->{summary})
{
my $elapsed = time() - $timer;
print "Solved in $elapsed secs. with $loops iterations over the gri
+d.\n";
print "Initial grid $start, finished $known\n";
}
exit;
# That's the end of the main code, rest are supporting subroutines.
# For each row, collect the known values and eliminate those values fr
+om the
# states of the other cells
sub elimrows
{
my $changed = 0;
$loops++;
for my $row (0..8)
{
my ($known,$seen) = gather($row,0,'row');
for my $col (0..8)
{
my $cell = $grid->[$row][$col];
# Eliminate all known values from this cell's state
my $to = $cell != all(@$known);
next if eigenstates($cell) == 1;
if (eigenstates($cell) > 1 and eigenstates($cell) > eigenstat
+es($to))
{
# We have reduced the eigenstates of a cell, so record thi
+s.
$changed++;
record($row,$col,$to,'Row elimination');
# If there's now only one possible state for this cell, we
+ have a new known value.
}
elsif (eigenstates($cell) > 1)
{
for (eigenstates($cell))
{
record($row,$col,$_,'Row only option') if ($seen->{$_}
+== 1);
# This is the only cell that can have this value, so se
+t it.
}
}
}
}
return $changed;
}
# For each column, collect the known values and eliminate those values
+ from the
# states of the other cells
sub elimcols
{
my $changed = 0;
for my $col (0..8)
{
my ($known,$seen) = gather(0,$col,'column');
for my $row (0..8)
{
my $cell = $grid->[$row][$col];
next if eigenstates($cell) == 1;
my $to = $cell != all(@$known);
if (eigenstates($cell) > 1 and eigenstates($cell) > eigenstat
+es($to))
{
$changed++;
record($row,$col,$to,'Column elimination');
}
elsif (eigenstates($cell) > 1)
{
for (eigenstates($cell))
{
record($row,$col,$_,'Column only option') if ($seen->{$
+_} == 1);
# This is the only cell that can have this value, so se
+t it.
}
}
}
}
return $changed;
}
# As above but for 3*3 square
sub elimsquares
{
my $changed = 0;
for my $row (0..8)
{
for my $col (0..8)
{
my ($known,$seen) = gather($row,$col,'square');
my $cell = $grid->[$row][$col];
next if eigenstates($cell) == 1;
my $to = $cell != all(@$known);
if (eigenstates($cell) > 1 and eigenstates($cell) > eigenstat
+es($to))
{
$changed++;
record($row,$col,$to,'Square elimination');
}
elsif (eigenstates($cell) > 1)
{
for (eigenstates($cell))
{
record($row,$col,$_,'Square only option') if ($seen->{
+$_} == 1);
}
}
}
}
return $changed;
}
sub readpuzzle
{
for my $row (0..8)
{
my $line = <>;
chomp($line);
my @row = split //, $line;
for my $col (0..8)
{
my $cell = shift(@row);
next if $cell eq '.';
$grid->[$row][$col] = $cell;
$known++;
}
}
}
sub printgrid
{
return unless shift or $opt->{verbose};
print "\n ";
printf "%-9s " ,$_ for (qw(A B C D E F G H I));
print"\n";
my $rc = 1;
foreach my $row (@$grid)
{
print $rc++, ") ";
map {printf "%-9s " , join('',sort(eigenstates($_)))} @$row;
print "\n";
}
print "\n";
}
sub finalgrid
{
print "\nCompleted : \n\n";
print join('',@$_), "\n" for (@$grid);
print "\n";
}
sub record
{
my ($row,$col,$to,$type) = @_;
my $state = state($row,$col);
$grid->[$row][$col] = $to;
# We have recorded the reduced eigenstates, but only report if new
+known value.
return unless eigenstates($to) == 1;
printf("%-14s => %d by %s\n",$state,$to,$type) unless $opt->{quiet}
+;
$known++;
}
# User friendly Column/Row indication.
sub loc
{
my ($row,$col) = @_;
return sprintf('%s%d',chr(ord('A')+$col),$row+1);
}
# User friendly Column/Row indication and state
sub state
{
my ($row,$col) = @_;
return sprintf('%s=any(%s)',loc($row,$col),join('',sort(eigenstates
+($grid->[$row][$col]))));
}
# Returns (\@known,\%seen)
# @known is an array of the known values in the row/column/square (cel
+ls with only one possible state)
# %seen is a hash of times that each number occurs in the states of ot
+her cells in the row/column/square,
# but NOT counting the known states.
sub gather
{
my ($row,$col,$type) = @_;
my @known = ();
my %seen = ();
$seen{$_} = 0 for (1..9);
if ($type eq 'square')
{
#print "Gather Square " . loc($row,$col) . " => ...";
for my $r (0..2)
{
for my $c (0..2)
{
#printf '%s, ',state(3*int($row / 3)+$r,3*int($col / 3)+$c
+);
my $cell = $grid->[3*int($row / 3)+$r][3*int($col / 3)+$c]
+;
eigenstates($cell) == 1 ? push (@known,$cell) : $seen{$_}
+++ for (eigenstates($cell));
}
}
#print "\n";
}
elsif ($type eq 'row')
{
for my $col (0..8)
{
my $cell = $grid->[$row][$col];
eigenstates($cell) == 1 ? push (@known,$cell) : $seen{$_}++
+for (eigenstates($cell));
}
}
elsif ($type eq 'column')
{
for my $row (0..8)
{
my $cell = $grid->[$row][$col];
eigenstates($cell) == 1 ? push (@known,$cell) : $seen{$_}++
+for (eigenstates($cell));
}
}
# Don't count states where we already have a known value (These mul
+tiple occurances are about to
# be eliminated in the calling function)
$seen{$_} = 0 for @known;
return (\@known,\%seen);
}
__END__
=head1 NAME
SuDoKu Solver
=head1 VERSION
This document describes the version released 28-Dec-04
=head1 SYNOPSIS
sudoku h3.sud
-h, --help This help message
-v, --verbose Verbose mode, print grid after each iteration
-q, --quiet Quiet mode, just print result
-s, --summary Print summary at end
-m, --man Print Pod doc as man page
=head1 BACKGROUND
This is a solver for SuDoKu puzzles. SuDoKu puzzles
are a 9*9 grid of numbers. At the start, some are provided
for you. Your challenge is to find the initially unknown
values.
=head2 Puzzle File input format
..21.64..
..93875..
7...2...8
..1...7..
.9..3..6.
..5...8..
8...6...5
..34786..
..49.13..
=head2 Rules
Each column, row and 3*3 square contains the numbers 1..9
once each.
=head1 How to solve a SuDoKu puzzle
Iterate over each cell in the grid
=head2 Elimination
=over
=item Pick a cell.
=item Check the same Column, Row and 3*3 Square (CRS). None
of the known values in the same CRW can be in this cell.
=item If that only leaves us one possible value, we have a new known v
+alue.
=back
=head2 the "Only" option
=over
=item For a given CRS, look at the possible values for each cell witho
+ut
a known state.
=item If one of the possibilities occurs only once in the CRS (and is
not an existing known value, ) then the cell where it is a possibilit
+y
must have that value, giving us a new known value.
=back
Finding a new known cell value will reduce the possbilities for
other unknown states in the same CRS as the newly discovered cell.
Iterate, checking each cell until solved.
=head1 AUTHOR
Richard Nuttall (richard-code@nuttall.uk.net)
=head1 COPYRIGHT
Copyright (c) 2004, Richard Nuttall
ll Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the stame terms as Perl-5.8.0 (or later)
(see http://www.perl.com/perl/misc/Artistic.html).
=head1 BUGS
This solver only works for puzzles that can be determined by logic alo
+ne.
If it is given a puzzle with insufficient, or inconsistent clues, or o
+ne
that requires backtracking, it will fail.
=cut
|
