#!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.

# Fisher-Yates
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
[download]