DLX sudoku solver

1.pl

#!/usr/bin/perl
use strict;
use warnings;

# constants for the exact cover matrix
my $width = 9*9*4;
my $height = 9*9*9;

# globals used in recursive functions
my @solution;
my $root = Node::new(N=>"root");

{
    package Node;

    # (Left, Right, Up, Down, Column)
    sub new {
        my @node;
        my %args = ( L=>\@node,
                     R=>\@node,
                     U=>\@node,
                     D=>\@node,
                     C=>\@node,
                     S=>0,
                     N=>"none",
                     @_ );
        @node = map { $args{$_} } (qw(L R U D C S N));
        
        return bless \@node;
    }

    sub L { $_[1] ? $_[0][0]=$_[1] : $_[0][0] }
    sub R { $_[1] ? $_[0][1]=$_[1] : $_[0][1] }
    sub U { $_[1] ? $_[0][2]=$_[1] : $_[0][2] }
    sub D { $_[1] ? $_[0][3]=$_[1] : $_[0][3] }
    sub C { $_[1] ? $_[0][4]=$_[1] : $_[0][4] }
    sub S { $_[1] ? $_[0][5]=$_[1] : $_[0][5] }
    sub N { $_[1] ? $_[0][6]=$_[1] : $_[0][6] }
}

# (node)
sub cover {
    my $col = shift;
    my ($row, $node, $up, $down);
    my $l = $col->L;
    my $r = $col->R;
    $l->R($r);
    $r->L($l);
    for ($row=$col->D; $row!=$col; $row=$row->D) {
        for ($node=$row->R; $node!=$row; $node=$node->R) {
            $up = $node->U;
            $down = $node->D;
            $up->D($down);
            $down->U($up);
            $node->C->S($node->C->S - 1);
        }
    }
}

# (node)
sub uncover {
    my $col = shift;
    my ($row, $node, $up, $down);
    for ($row=$col->U; $row!=$col; $row=$row->U) {
        for ($node=$row->L; $node!=$row; $node=$node->L) {
            $up = $node->U;
            $down = $node->D;
            $up->D($node);
            $down->U($node);
            $node->C->S($node->C->S + 1);
        }
    }
    my $l = $col->L;
    my $r = $col->R;
    $l->R($col);
    $r->L($col);
}

# (number, #column, #row)
sub set {
    my ($n, $c, $r) = @_;
    my $current = $root->R;
    $current = $current->R while ($current->N!=$r*9+$c);
    cover($current);
    do {
        $current = $current->D;
    } while ($current->N!=$n);
    push @solution, $current;
    for (my $j=$current->R; $j!=$current; $j=$j->R) {
        cover($j->C);
    }
}

sub search {
    # print solution when found
    if ($root==$root->R) {
        my @s;
        my $i;
        foreach (@solution) {
            my $current = $_;
            my $j = $current;
            $j = $j->R until ($j->C->N < 81); # go to the cell constraints
            $i = $j->C->N;
            $s[$i/9][$i%9] = $j->R->C->N%9;
        }
        for (my $i = 0; $i < 9; $i++) {
            for (my $j = 0; $j < 9; $j++) {
                print defined $s[$i][$j]?$s[$i][$j]+1:'.', $j==2||$j==5?'|':' ';
            }
            print $/;
            print "-----+-----+-----\n" if $i==2||$i==5; 
        }
        print $/;
        exit;
    }

    # find best column (i.e. lowest list size)
    my $c;
    my $minS = $height;
    for (my $current=$root->R; $current!=$root; $current=$current->R) {
        if ($current->S < $minS) {
            $c = $current;
            $minS = $current->S;
        }
    }

    # backtracking
    cover($c);
    for (my $current=$c->D; $current!=$c; $current=$current->D) {
        push @solution, $current;
        for (my $j=$current->R; $j!=$current; $j=$j->R) {
            cover($j->C);
        }
        search();
        $current = pop @solution;
        $c = $current->C;
        for (my $j=$current->L; $j!=$current; $j=$j->L) {
            uncover($j->C);
        }
    }
    uncover($c);
}

###############
# Build matrix
my @sudoku = [];
# way less mispredictions, this is much faster :)
for my $i (0..728) {
    $sudoku[$i][81*0+$i/9] = 1;
    $sudoku[$i][81*1+int($i/81)*9+$i%9] = 1;
    $sudoku[$i][81*2+$i%81] = 1;
    $sudoku[$i][81*3+$i%9+(int($i/27)%3)*9+int($i/243)*27] = 1;
}

my $current = $root;

################
# Build headers
for (1..$width) {
    $current->R(Node::new(L=>$current, N=>$_-1));
    $current = $current->R;
}
$current->R($root);
$root->L($current);

#####################
# Build data objects
my $n; # new node
my $column; # current column
my $firstinrow;
my $lastinrow;
for (my $i=0; $i<$height; $i++) {
    $column = $root->R;
    $firstinrow = undef;
    $lastinrow = undef;
    for (my $j=0; $j<$width; $j++, $column=$column->R) {
        if ($sudoku[$i][$j]) {
            $column->S($column->S+1);
            if ($lastinrow) {
                $n = Node::new(L=>$lastinrow, U=>$column->U, D=>$column, C=>$column, N=>$i%9+1);
                $lastinrow->R($n);
            } else {
                $n = Node::new(U=>$column->U, D=>$column, C=>$column, N=>$i%9+1);
            }
            $firstinrow //= $n;
            $column->U->D($n);
            $column->U($n);
            $lastinrow = $n;
        }
    }
    $lastinrow->R($firstinrow);
    $firstinrow->L($lastinrow);
}

###############
# Load problem
if ($ARGV[0]) {
    open FILE, $ARGV[0];
} else {
    print "Usage: perl $0 FILE\n";
    exit -1;
}
my @problem = <FILE>;
my $r=0;
foreach (@problem) {
    chomp;
    my $c=0;
    foreach my $n (split //, $_) {
        set($n, $c, $r) if ($n);
        $c++;
    }
    $r++;
}

############################
# Search and print solution
search();