3x3 sudoku solves

solve-3x3sudoku.pl

#!/usr/bin/perl
# solve-3x3sudoku.pl - solve 3x3 sudoku.
# at 2013/02/12 by @xtetsuji

use strict;
use warnings;

use Pod::Usage 'pod2usage';

use constant DEBUG => $ENV{DEBUG};
use constant MAX_STEP => 1_000;

my @board;
while (<>) {
    chomp;
    push @board, [ map { $_ =~ /\D/ ? +{} : $_ }  split //, $_ ];
}

if ( @board != 9 || grep { @$_ != 9 } @board ) {
    pod2usage(1);
}

my $step = 0; # guard infinite loop
while ( !solved(\@board) ) {
    DEBUG and print "=== step=$step ===\n";
    # row
    for my $row (@board) {
        guess_process( row => $row );
    }
    # column
    for my $column (transpose(@board)) {
        guess_process( column => $column );
    }
    # square
    for my $square (square_group_3x3(@board)) {
        guess_process( square => $square );
    }

    # guess check
    DEBUG and print "guess check\n";
    for my $row (@board) {
        for my $cell (@$row) { # $cell is alias. it's written affects origin.
            next if determined($cell);
            DEBUG and  print "  cell->{$_}=" . (join ",", @{$cell->{$_}}) . "\n" for qw/row column square/;
            my @guesses = intersection(@$cell{qw/row column square/});
            DEBUG and print "guesses=" . (join ",", @guesses) . "\n";
            if ( @guesses == 1 ) {
                die if ref $guesses[0]; # not string is strange;
                $cell = $guesses[0];
            }
        }
    }

    # giveup
    if ( $step++ > MAX_STEP ) {
        if ( DEBUG ) {
            require Data::Dumper;
            print Data::Dumper::Dumper(\@board);
        }
        die "giveup\n";
    }
}

DEBUG and print "finally step=$step\n";

# print
for my $row (@board) {
    print join q(), @$row;
    print "\n";
}

exit;

sub guess_process {
    my $domain = shift; # row, column, square
    my $cells = shift; # array ref which has 9 elements
    my @determined_numbers = grep { determined($_) } @$cells;
    if ( DEBUG ) {
        print "guess_process\n";
        print "  domain=$domain\n";
        print "  cells=" . (join ",", map { ref $_ ? '_' : $_ } @$cells) . "\n";
    }
    my @maybe_numbers = maybe_numbers(@determined_numbers);
    if ( DEBUG ) { print "  maybe_numbers=" . (join ",", @maybe_numbers) . "\n"; }
    for my $cell (@$cells) {
        next if determined($cell);
        $cell->{$domain} = [ @maybe_numbers ];
    }
}

sub determined {
    my $cell = shift;
    return defined $cell && !ref $cell && $cell =~ /^[0-9]$/;
}

sub maybe_numbers {
    my @determined_numbers = @_;
    my %determined_numbers_of = map { $_ => 'determined' } @determined_numbers;
    return map { $determined_numbers_of{$_} ? () : $_ } (1..9);
}

sub solved {
    my @board = @_;
    return !grep { !determined($_) } listify(@board);
}

sub listify {
    return map { ref $_ eq 'ARRAY' ? listify(@$_) : $_ } @_;
}

sub uniq {
    my %seen;
    return map { $seen{$_}++ == 0 ? $_ : () } @_;
}

sub intersection {
    my @lists = @_;
    my %seen;
    return grep { ++$seen{$_} == @lists ? $_ : () } map { uniq @$_ } @lists;
}

sub transpose {
    my @matrix = @_;
    my $row_length = scalar @matrix;
    my $col_length = scalar @{$matrix[0]};
    die "transpose gives not rectangle" if grep { @$_ != $col_length } @matrix;
    return map {
        my $x = $_;
        [ map {
            my $y = $_;
            $matrix[$y]->[$x] } 0..($col_length-1) ] ;
    } 0..($row_length-1);
}

sub square_group_3x3 {
    my @matrix = @_;
    my @addr = ([0,1,2],[3,4,5],[6,7,8]);
    my @group;
    for my $x_addrs (@addr) {
        for my $y_addrs (@addr) {
            push @group, [ map {
                my $x = $_;
                map {
                    my $y = $_;
                    $matrix[$x]->[$y];
                } @$y_addrs;
            } @$x_addrs ];
        }
    }
    return @group;
}

__END__

=pod

=encoding utf-8

=head1 NAME

solve-3x3sudoku.pl - 3x3 sudoku solves

=head1 SYNOPSIS

 cat | solve-3x3sudoku.pl
 7..6.5..8
 .6.271.9.
 ..2.4.8..
 59.127.46
 .1..3..7.
 .84...76.
 .57.1.93.
 1..762..4
 ^D

=head1 DESCRIPTION

This program is one of concept of solving sudoku.

If you solve sudoku with correctly and fastly and more functional something,
then search cpan by keyword "Sudoku":

http://search.cpan.org/search?q=Sudoku;s=1

I write this program without any reference for 106 minutes.
This program writing is a test of my strength.

=head1 AUTHOR

OGATA Tetsuji E<lt>tetsuji.ogata {at} gmail.comE<gt>

First release at Feb 12, 2013.

=head1 LICENSES

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut

First release at Feb 12, 2013 version's this program, sudoku that it can not solve is exist.
This program is alpha quality. If you want to solve sudoku, then search CPAN by "Sudoku" keyword and use a steady CPAN module.