Simple OO backtracking Sudoku solver

solver.pl

package Sudoku;

1;

package Sudoku::Grid {

    use strict;
    use warnings;

    use Cell;

    sub new {
        my ( $class, $definition ) = @_;
        $definition =~ s/\D+//g;

        my @grid = split( //, $definition );

        my $location = 0;
        my @cells = map { Sudoku::Cell->new( \@grid, $location++ ) } @grid;

        my $self = bless \@cells, $class;

        return $self;
    }

    sub solve {
        my ($self) = @_;
        my $solution = $self->_solve( [], 0 );
        die "No solution found" unless $solution;
        return join '', @$solution;
    }

    sub _solve {
        my ( $self, $grid, $cell ) = @_;

        # Success!!!
        return $grid if $cell == 81;

        # Get anything it could be, given the current grid
        my @candidates = (
            ref $self->[$cell]
            ? $self->[$cell]->candidates($grid)
            : ( $self->[$cell] )
        );

        return unless @candidates;

        # Otherwise, for each candidate
        for my $candidate (@candidates) {
            $grid->[$cell] = $candidate;

            my $result = $self->_solve( $grid, $cell + 1 );
            return $result if $result;
        }

        return undef;
    }

    1;
};

package Sudoku::Cell {
    use strict;
    use warnings;

    sub new {
        my ( $class, $grid, $location ) = @_;

        # If we're fixed, it's nice and easy
        if ( my $fixed = $grid->[$location] ) {
            return $fixed;
        }

        # Turn location in to coordinates
        my $y = int( $location / 9 );
        my $x = $location % 9;

        my %upstream;
        my %exclude;

        # Look in the columns and rows for upstreams and exclusions
        for my $c ( 0 .. 8 ) {
            my $col = ( $c * 9 ) + $x;
            my $row = ( $y * 9 ) + $c;

            # Column
            if ( my $preset = $grid->[$col] ) {
                $exclude{$preset} = 1;
            }
            elsif ( $y > $c ) {
                $upstream{$col} = 1;
            }

            # Row
            if ( my $preset = $grid->[$row] ) {
                $exclude{$preset} = 1;
            }
            elsif ( $x > $c ) {
                $upstream{$row} = 1;
            }
        }

        # Look in the surrounding box
        my $top_x = $x - ( $x % 3 );
        my $top_y = $y - ( $y % 3 );
        for my $c ( 0 .. 8 ) {
            my $plus_x = $c % 3;
            my $plus_y = int( $c / 3 );

            my $cell_location
                = ( 9 * ( $top_y + $plus_y ) ) + $top_x + $plus_x;

            if ( my $preset = $grid->[$cell_location] ) {
                $exclude{$preset} = 1;
            }
            elsif ( $cell_location < $location ) {
                $upstream{$cell_location} = 1;
            }
        }

        my %candidates = map { $_ => 1 } grep { !$exclude{$_} } 1 .. 9;
        my @upstream = sort keys %upstream;

        my $self = bless {
            candidates => \%candidates,
            upstream   => \@upstream,
        }, $class;

        return $self;
    }

    sub candidates {
        my ( $self, $grid ) = @_;

        my %candidates = %{ $self->{'candidates'} };
        for my $c ( @{ $self->{'upstream'} } ) {
            my $value = $grid->[$c] || die "WTF? Upstream: $c";
            delete $candidates{$value};
        }

        return keys %candidates;
    }

    1;
}

__DATA__
#!perl

use strict;
use warnings;

use Test::More;

use Sudoku;

for (
    [   '2564891733746159829817234565932748617128.6549468591327635147298127958634849362715',
        '256489173374615982981723456593274861712836549468591327635147298127958634849362715'
    ],
    [   '3.542.81.4879.15.6.29.5637485.793.416132.8957.74.6528.2413.9.655.867.192.965124.8',
        '365427819487931526129856374852793641613248957974165283241389765538674192796512438'
    ],
    [   '..2.3...8.....8....31.2.....6..5.27..1.....5.2.4.6..31....8.6.5.......13..531.4..',
        '672435198549178362831629547368951274917243856254867931193784625486592713725316489'
    ],

    # Allegedly the world's hardest Sudoku problem for a back-tracking solver
    [   '.61..7..3.92..3..............853..........5.45....8....4......1...16.8..6........',
        '461987253792453168385216479128534796936721584574698312849375621253169847617842935'
    ]
    )
{
    my ( $in, $expected ) = @$_;
    $in =~ s/\./0/g;
    my $grid = Sudoku::Grid->new($in);

    my $actual = $grid->solve;
    is( $actual, $expected );
}

done_testing();