#!perl w
use strict;
# Sudoku
#
# This set of functions allows generation of various dimensioned Sudok
+u puzzles
# The ResolveGrid() function can also be used to resolve partially con
+structed grids,
# which is to say that it can be used to solve puzzles you find elsewh
+ere.
# Also, due to the computational complexity (NP) of prooving that an i
+ncomplete grid
# leads to only one possible solution, not all generated puzzles will
+have a unique
# solution. This also means that it may take awhile to generate a lar
+ge puzzle.
#
use constant Symetry => 1; # 1 => Symetrical Puzzle
use constant Dim => 4; # 3 = Traditional
use constant Side => Dim * Dim; # One side of the grid
use constant Squared => Side * Side; # Total spaces in grid
use constant MinDots => int( Squared / 2 ); # Specifying the max giv
+ens.
use constant Options => (1..9,0,'A'..'Z','a'..'z')[0..Side()1];
use constant Form => " ". join('  ',(join(' ',('@')x Dim))x Dim)
+ ." \n";
use constant Line => "+". join('+',(join('',('')x Dim))x Dim)
+ ."+\n";
# For convenience, functions which return an array of results
# return a reference to that array in scalar context.
# FisherYates
sub Shuffle
{
my @array = @_;
if ( not defined $_[1] and UNIVERSAL::isa( $_[0], 'ARRAY' ) )
{
@array = @{$_[0]};
}
my $i=@array;
while($i)
{
my $j=int rand(1+$i);
@array[$i, $j]=@array[$j, $i]
}
return wantarray ? @array : \@array;
}
# Coordinates are zero based.
# Index = Crd2Index( Row, Col )
sub Crd2Index($$) { $_[0] * Side + $_[1] }
sub Index2Crd($)
{
my $i = $_[0];
my $r = int( $i / Side );
my $c = $i % Side;
return wantarray ? ( $r, $c ) : [ $r, $c ];
}
# I know, I know... still, it is easier to read this way.
sub DotCount($) { return $_[0] =~ s/\./\./g }
# Put the grid into a ... grid.
sub Format($)
{
die "ASSERT" unless $_[0] and length $_[0] == Squared;
$^A = "";
for ( 0 .. Side  1 )
{
$^A .= Line if $_ % Dim == 0;
formline Form, split //, substr( $_[0], Side * $_, Side );
}
return $^A ? $^A . Line : undef;
}
# Determine available options for a given spot in a given grid
# Avail( Grid, Index )
# Avail( Grid, Row, Col )
sub Avail($$;$)
{
my ( $grid, $row, $col ) = @_;
( $row, $col ) = Index2Crd( $row ) if not defined $col;
my %used = map { $_ => 0 } Options;
# A little error checking
die "ASSERT( $row, $col )" unless Crd2Index( $row, $col ) < Square
+d;
die "ASSERT( '$grid' )" unless length( $grid ) == Squared;
# Row and Col  Could also do Row via a split, but whatever.
for ( 0 .. Side  1 )
{
++$used{substr( $grid, Crd2Index( $_, $col ), 1 )};
++$used{substr( $grid, Crd2Index( $row, $_ ), 1 )};
}
# Now determine which square we are in
my ( $x, $y ) = map { int( $_ / Dim ) * Dim } ( $col, $row );
for my $r ( $y .. $y + Dim  1 )
{
for my $c ( $x .. $x + Dim  1 )
{
++$used{substr( $grid, Crd2Index( $r, $c ), 1 )};
}
}
my @result = grep { not $used{$_} } Options;
return wantarray ? @result : \@result;
}
# Making and Solving a grid are basically the exact same thing
# You don't need to shuffle the available array if you are just
# solving, but it doesn't hurt anything  and it allows you to
# find multiple solutions, if they exist.
sub ResolveGrid(;$)
{
my $grid = $_[0];
$grid = '.' x Squared if not defined $grid;
my @stack = ( );
my $next = 0;
while ( 0 <= $next and $next < Squared )
{
if ( substr( $grid, $next, 1 ) ne '.' )
{
++$next;
next;
}
my $avail = Shuffle Avail( $grid, $next );
if ( not @{$avail} )
{
die "INVALID GRID\n" if not @stack;
my $prev = pop @stack;
$grid = $prev>[0];
$avail = $prev>[1];
$next = $prev>[2];
}
my $choice = shift @{$avail};
push @stack, [ $grid, $avail, $next ] if @{$avail};
substr( $grid, $next, 1 ) = $choice;
++$next;
}
return $grid;
}
# Could also resolve a grid recursivly, but you hit Perl's limit with
# grids larger then (3x3)^2  that is, Dim => 3.
sub ResolveGridRecursive
{
my $grid = $_[0];
my $next = $_[1]  0;
die "ASSERT!\nGRID = '$grid'\nNEXT='$next'\n\t" if $next < 0;
$grid = '.' x Squared if not defined $grid;
return $grid if $next >= length $grid;
substr( $grid, $next, 1 ) = '.';
for ( Shuffle Avail( $grid, $next ) )
{
substr( $grid, $next, 1 ) = $_;
my $testgrid = ResolveGridRecursive( $grid, $next + 1 );
return $testgrid if defined $testgrid;
}
substr( $grid, $next, 1 ) = '.';
return undef;
}
# Generate a puzzle
#
sub MakePuzzle(;$)
{
my $soln = ResolveGrid( $_[0] ); # Resolving empty grid creates a
+random solution.
my $puz = $soln;
my @location = Shuffle( 0 .. Squared  1 );
my $i;
while ( @location )
{
$i = pop @location;
substr( $puz, $i, 1 ) = '.';
last if ResolveGrid( $puz ) ne $soln;
}
substr( $puz, $i, 1 ) = substr( $soln, $i, 1 ) if defined $i;
return $puz;
}
# Some people prefer symetrical puzzles.
sub MakePuzzleSym(;$)
{
my $soln = $_[0]  ResolveGrid; # Resolving empty grid creates a
+random solution.
my $puz = $soln;
my @location;
for ( 0 .. Side  1 ) { push @location, $_ * Side .. $_ * Side + S
+ide  ( Side  $_ ) }
@location = Shuffle( @location );
my ( $i, $j );
while ( @location )
{
$i = pop @location;
$j = Crd2Index( Index2Crd( $i )>[1], Index2Crd( $i )>[0] );
die "ASSERT( $i, $j )" if $j > Squared;
substr( $puz, $i, 1 ) = '.';
substr( $puz, $j, 1 ) = '.';
last if ResolveGrid( $puz ) ne $soln;
}
substr( $puz, $i, 1 ) = substr( $soln, $i, 1 ) if defined $i;
substr( $puz, $j, 1 ) = substr( $soln, $j, 1 ) if defined $j;
return $puz;
}
########
# Main #
########
# Resolving and empty grid gives you a legitimate Sudoku square
# The MakePuzzle functions will do this for you, if you don't want the
+ solution handy.
my $solution = ResolveGrid;
# Now find a sufficiently 'hard' set of givens, where 'hard' is merely
+ a function
# of how many givens you have. MakePuzzle attempts to verify that the
+puzzle you
# get has only the desired solution, but of course you can't really ve
+rify that
# without checking every possible solution.
my $puzzle = $solution;
while ( DotCount( $puzzle ) < MinDots )
{ print "Attempt\n";
$puzzle = Symetry ? MakePuzzleSym( $solution ) : MakePuzzle( $solu
+tion );
}
# Now you can display the puzzle in a lovely grid
print Format( $puzzle ), "\n";
# Or just dump out a simple string form, suitable for testing other so
+lvers
print "Puzzle : $puzzle\n";
# And, of course, the solution... just in case you want it.
print "Solution: $solution\n";
__END__
Example Output for a (4x4)^2 symetrical puzzle:
+++++
 . . C 7  4 . . 9  . . E 3  1 . . . 
 . . 5 2  F . . .  A 6 . 1  9 B . . 
 9 D 8 .  . 5 B .  . 2 0 .  . . . . 
 1 0 . .  E 3 . A  . . C 8  . 2 . . 
+++++
 C B . A  8 . E 2  1 . . 0  . D 7 5 
 . . 7 1  . . 3 4  5 9 B .  C . 2 A 
 . . F .  1 C D 6  . . 4 .  . 9 B . 
 2 . . 3  7 B A 5  8 C D .  . 1 4 . 
+++++
 . 4 . .  2 1 . C  E . . .  . . . 7 
 . 9 2 .  . A . B  . . F 5  . 4 . 1 
 3 . 1 F  . D 4 E  . B . A  . C . . 
 5 A . C  9 . . .  . 1 2 .  3 . . . 
+++++
 7 C . .  . E . .  . . . 2  . . 9 . 
 . E . 9  D . C 3  . 0 5 .  . . . . 
 . . . .  A 7 1 F  . . . .  5 . 3 C 
 . . . .  5 2 . .  3 4 . .  . . E 0 
+++++
Puzzle : ..C74..9..E31.....52F...A6.19B..9D8..5B..20.....10..E3.A..C8
+.2..CB.A8.
E21..0.D75..71..3459B.C.2A..F.1CD6..4..9B.2..37BA58CD..14..4..21.CE...
+...7.92..A
.B..F5.4.13.1F.D4E.B.A.C..5A.C9....12.3...7C...E.....2..9..E.9D.C3.05.
+........A7
1F....5.3C....52..34....E0
Solution: AFC74629BDE31508E352F08DA6719BC49D86C5B1420F73AE10B4E37A95C8
+D2F6CB4A89
E21F306D75D8710F3459B6CE2A05FE1CD62A4789B326937BA58CDE014FB4D0215CE369
+AF8769283A
0BC7F5E4D1371F6D4E0B8A2C595AEC98F7D124306B7C35BE60F8124A9D8EA9D4C3705B
+F612420BA7
1F6E9D583CF16D529834ACB7E0
