http://www.perlmonks.org?node_id=481022

I just discovered Sudoku last weekend, and I thought... I can generate these; but when I looked around online for code, I didn't find any. I found plenty of solvers, and I recognized that solving a blank grid would result in a puzzle if you had a random element in your solution method. So I set out to write my own solver/generator that did just that. This code can create and solve Sudoku puzzles of varying sizes, although not very quickly. One problem I'd like to solve is that the puzzles generated are either too easy or too hard. A puzzle tends to be too hard when there are more than one solution, and too easy when there are too many givens. This code tries to find a middle ground by testing to see if randomly solving the puzzle gets the expected solution, and requiring a minimum number of open spots. Enjoy. And yes, I know that Brovnik already posted some code (SuDoKu solver) to solve these, but my method is different (that is, more brutish). Optimizations and corrections are welcome and encouraged.
#!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]

Back to Cool Uses for Perl