File Coverage

blib/lib/Games/Sudoku/DLX.pm

Criterion	Covered	Total	%
statement	65	65	100.0
branch	7	8	87.5
condition	3	5	60.0
subroutine	6	6	100.0
pod	1	2	50.0
total	82	86	95.3

package Games::Sudoku::DLX;

use strict;
use warnings;

our $VERSION = 0.02;

use Algorithm::DLX;

use Exporter        qw( import );
our @EXPORT_OK  =   qw( solve_sudoku );  # symbols to export on request

sub sudoku_to_dlx {
    my %params = @_;
    my $puzzle  = $params{puzzle};
    my $regions = $params{regions};
    my $dlx = Algorithm::DLX->new();

    my $order = @$puzzle;
    my $number_of_regions = @$regions;

    my @cols;
    # Each cell can only have one symbol
    for my $r (0..$order - 1) {
        for my $c (0..$order - 1) {
            push @cols, $dlx->add_column("cell_$r$c");
        }
    }

    # Each symbol can only appear once in each row, column, and region
    for my $r (1..$order) {
        for my $c (0..$order - 1) {
            for my $region (@$regions) {
                my ($a, $b) = @$region;
                my $block = (int($r/$a) * $a) + int($c/$b);
                push @cols, $dlx->add_column("r#$r c#$c R#$a,$b B#$block");
            }
        }
    }

    for my $r (0..$order - 1) {
        for my $c (0..$order - 1) {
            if ($puzzle->[$r][$c]) {
                my $n = $puzzle->[$r][$c];
                my @columns;
                for my $region (0..@$regions - 1) {
                    my ($a, $b) = @{$regions->[$region]};
                    my $block = (int($r/$a) * $a) + int($c/$b);

                    push @columns, $cols[(($region+1) * $order**2) + ($block*$order)+($n-1)];
                }

                # Add the cell column
                push @columns, $cols[$r*$order+$c];
                $dlx->add_row("$r $c $n", @columns);
            } else {
                for my $n (1..$order) {
                    my @columns;
                    for my $region (0..scalar @$regions - 1) {
                        my ($a, $b) = @{$regions->[$region]};
                        my $block = (int($r/$a) * $a) + int($c/$b);

                        push @columns, $cols[(($region+1) * $order**2) + ($block*$order)+($n-1)];
                    }

                    # Add the cell column
                    push @columns, $cols[$r*$order+$c];
                    $dlx->add_row("$r $c $n",  @columns);
                }
            }
        }
    }

    return $dlx;
}

# When we me this a module, this is what we will export
sub solve_sudoku {
    my %params              = @_;

    my $puzzle              = $params{puzzle};
    my $regions             = $params{regions};
    my $number_of_solutions = $params{number_of_solutions} || 0;

    # validate the regions
    my $puzzle_size = scalar @$puzzle;
    for my $region (@$regions) {
        my ($a, $b) = @$region;
        die "Invalid region size: $a x $b for puzzle of size $puzzle_size\n" if $a * $b != @$puzzle;
    }

    # validate the puzzle size
    for my $row (@$puzzle) {
        die "Invalid row size: @$row should have size $puzzle_size\n" if @$row != $puzzle_size;

        # validate the cell values
        for my $cell (@$row) {
            die "Invalid cell value: $cell should be between 0 and $puzzle_size\n" if $cell < 0 || $cell > $puzzle_size;
        }
    }

    my $dlx = sudoku_to_dlx(
        regions => $regions,
        puzzle  => $puzzle,
    );
    my $solutions = $dlx->solve(
        number_of_solutions => $number_of_solutions
    );

    return $solutions;
}

1

__END__