Click on a cell with MB1 to display a menu. Then select the value to put into the cell from the menu.

The panel below the puzzle displays the counts for each digit. You can select a value by pressing it's count button. Then selected value can be painted onto the puzzle using MB3.

Notes can be added by changing the paint mode using the Game/Paint Mode menu or by selecting the mode in the toolbar. When paint mode is set to value then painting sets the value in the cell. Paint Mode can be set to Corner Note or Bottom Note to affect one of the notes instead. If the cell value is set then it will be displayed. Otherwise, any active note will be displayed. If both notes are set then the bottom note will be displayed.

Alternately use the arrow keys to move around the board and enter values by pressing the desired number on the keyboard.

To see what cells are blocked by a given value select the value from the Game/Shade menu or press Ctrl and the number. Press Ctrl-0 to clear the shading.

#!/usr/bin/env perl

# Sudoku Program written by Thomas Pfau -- https://perlmonks.org/?node
+_id=217641
# Puzzle generator adapted from https://perlmonks.org/?node_id=538853

use strict;
use warnings;
use Tk;
use Tk::Button;
use Tk::Radiobutton;
use Tk::Checkbutton;
use Tk::FileSelect;
use Data::Dumper;

# constants
our $COLCNT = 4 * 9 ** 2; # number of columns in cover
our $ROWCNT = 9 ** 3;     # number of rows in cover

# bitvecs for full and empty rows and cols
our $ZEROCOL = pack( 'b*', "0" x $COLCNT );
our $ZEROROW = pack( 'b*', "0" x $ROWCNT );
our $FULLCOL = pack( 'b*', "1" x $COLCNT );
our $FULLROW = pack( 'b*', "1" x $ROWCNT );

our $BG = '#cccccc';    # button background color
our $PAINTBG = '#00ccff'; # paint button background
our $SHADE = '#999999';  # shaded button background color
our $GIVEN = 'black';   # foreground for a given number
our $GUESS = 'blue';    # foreground for a guessed number
our $HILITE = 'orange'; # shaded number foreground
our $BAD = 'red';       # check not ok
our $fontsize = 24;     # current font size
our $autocheck = 0;     # run check after each move
our @moves;             # move list for undo
our $move = 0;          # current position in undo list

our ( $curx, $cury ) = ( 0, 0 ); # current position
our @counts = ( 0 ) x 9;         # digit counts

my ( @rows, @columns, @squares ); # label widgets
my $cur_label;          # active label

my @soln;               # solution (if known)
my @puzzle;             # original puzzle

my $paintMode = 0;      # entry mode ( 0 = value, 1 = bottom note, 2 =
+ corner note )

my $menu =
    [
        [ Cascade => "~File", -menuitems =>
          [
              [ Button => "~Open", -command => \&openGame, -accelerato
+r => '^O' ],
              [ Button => "~Save", -command => \&saveGame, -accelerato
+r => '^S' ],
              [ Separator => '' ],
              [ Button => "~Quit", -command => \&endIt, -accelerator =
+> '^Q' ],
          ]
        ],
        [ Cascade => "~Game", -menuitems =>
          [
              [ Button => "~New", -command => \&newGame, -accelerator 
+=> '^N' ],
              [ Button => "~Define", -command => \&define, -accelerato
+r => '^D' ],
              [ Button => "C~lear", -command => \&clear, -accelerator 
+=> '^L' ],
              [ Separator => '' ],
              [ Cascade => "~Paint Mode", -menuitems =>
                [
                    [ Radiobutton => "~Number", -accelerator => '^V', 
+-variable => \$paintMode, -value => 0 ],
                    [ Radiobutton => "~Corner Note", -accelerator => '
+^T', -variable => \$paintMode, -value => 2 ],
                    [ Radiobutton => "~Bottom Note", -accelerator => '
+^B', -variable => \$paintMode, -value => 1 ]
                ],
              ],
              [ Button => "~Check", -command => \&check, -accelerator 
+=> '^C' ],
              [ Button => "Find ~Errors", -command => \&findErrors, -a
+ccelerator => '^E' ],
              [ Checkbutton => "~Autocheck", -accelerator => '^A', -va
+riable => \$autocheck ],
              [ Cascade => "~Shade", -menuitems =>
                [
                    map { [ Button => $_ ? "~$_" : "~None",
                            -command => [ \&shade, $_ ],
                            -accelerator => "^$_" ] } ( 0..9 )
                ],
              ],
              [ Separator => '' ],
              [ Cascade => "~Font Size", -menuitems =>
                [
                    map { [ Radiobutton => $_, -variable => \$fontsize
+, -value => $_,
                            -command => [ \&setFontSize, $_ ] ] } ( 10
+, 12, 14, 16, 18, 20, 24, 28, 32, 36 )
                ],
              ],
          ],
        ],
        [ Cascade => "~Edit", -menuitems =>
          [
              [ Button => "~Undo", -command => \&undo, -accelerator =>
+ '^U' ],
              [ Button => "~Redo", -command => \&redo, -accelerator =>
+ '^R' ],
          ]
        ]
    ];

my $ui = MainWindow->new();

# load toolbar icon images
my %images;
while ( my $name = <DATA> ) {
    chomp $name;
    my $data = <DATA>;
    chomp $data;
    $images{$name}{bits} = pack("H*",$data);
    $images{$name}{bitmap} = $ui->DefineBitmap( $name, 24, 24, $images
+{$name}{bits} );
    $images{$name}{image} = $ui->Bitmap( -data => $images{$name}{bitma
+p} );
}

$ui->resizable(0,0);
# font for game digits
my $digitFont = $ui->fontCreate( -size => $fontsize, -family => "helve
+tica",
                            -weight => "bold" );
# font for counts
my $countFont = $ui->fontCreate( -size => int( $fontsize * 3 / 4 ),
                             -family => "helvetica" );
# font for notes
my $noteFont = $ui->fontCreate( -size => int( $fontsize / 2 ),
                             -family => "helvetica");

my $me = $ui->Menu( -tearoff => 0,
                    -menuitems => $menu );

$ui->configure( -menu => $me );

my $popup = $ui->Menu( -tearoff => 0,
                       -menuitems => [ map { [ Button => $_,
                                               -command => [ \&setLabe
+l, $_ ],
                       ] } ( '', 1..9 ) ] );
$ui->bind( $_->[0], $_->[1] )
    for ( [ '<Control-a>', sub { $autocheck ^= 1; } ],
          [ '<Control-b>', sub { $paintMode = 1; } ],
          [ '<Control-c>', \&check ],
          [ '<Control-d>', \&define ],
          [ '<Control-e>', \&findErrors ],
          [ '<Control-l>', \&clear ],
          [ '<Control-n>', \&newGame ],
          [ '<Control-o>', \&openGame ],
          [ '<Control-q>', \&endIt ],
          [ '<Control-r>', \&redo ],
          [ '<Control-s>', \&saveGame ],
          [ '<Control-t>', sub { $paintMode = 2; } ],
          [ '<Control-u>', \&undo ],
          [ '<Control-v>', sub { $paintMode = 0; } ],
        map( { [ "<Control-Key-$_>", [ \&shade, $_ ] ] } ( 0..9 ) ),
        map( { [ "<Key-$_>", [ \&currentAssign, $_ ] ] } ( 0..9 ) ),
          [ '<Key-Left>', \&currentLeft ],
          [ '<Key-Right>', \&currentRight ],
          [ '<Key-Up>', \&currentUp ],
          [ '<Key-Down>', \&currentDown ],
          [ '<Key-Tab>', \&currentTab ],
          [ '<Shift-Key-Tab>', \&currentBackTab ],
    );

my $toolbar = $ui->Frame()->pack( -side => 'top', -expand => 1, -fill 
+=> 'x' );
$toolbar->Radiobutton( -bitmap => 'value', -variable => \$paintMode, -
+value => 0, -padx => 0, -pady => 0,
                       -relief=>'raised', -indicatoron=>0 )
        ->pack( -side => 'left' );
$toolbar->Radiobutton( -bitmap => 'corner', -variable => \$paintMode, 
+-value => 2, -padx => 0, -pady => 0,
                       -relief=>'raised', -indicatoron=>0 )
        ->pack( -side => 'left' );
$toolbar->Radiobutton( -bitmap => 'bottom', -variable => \$paintMode, 
+-value => 1, -padx => 0, -pady => 0,
                       -relief=>'raised', -indicatoron=>0 )
        ->pack( -side => 'left' );
$toolbar->Button( -bitmap => 'undo', -command => \&undo, -padx => 0, -
+pady => 0, )
        ->pack( -side => 'left' );
$toolbar->Button( -bitmap => 'redo', -command => \&redo, -padx => 0, -
+pady => 0, )
        ->pack( -side => 'left' );

my $frame = $ui->{frame} = $ui->Frame()->pack();

for my $x ( 0..2 ) {
    for my $y ( 0..2 ) {
        my $sq = $ui->{square}[$x][$y] =
            $frame->Frame()->grid( -column => $x,
                                   -row => $y,
                                   -padx => 4,
                                   -pady => 4 );
        for my $i ( 0..2 ) {
            for my $j ( 0..2 ) {
                my $row = $y * 3 + $j;
                my $col = $x * 3 + $i;
                my $cel = $row * 9 + $col;
                my $l = $sq->Label( -width => 2,
                                    -relief => 'groove',
                                    -background => $BG,
                                    -font => $digitFont,
                                    -relief => 'raised',
                )          ->grid( -column => $i,
                                   -row => $j );
                $l->{cell} = $cel;
                $l->{values} = [ ('') x 3 ];
                push @{ $rows[$row] }, $l;
                push @{ $columns[$col] }, $l;
                push @{ $squares[$x * 3 + $y] }, $l;
            }
        }
    }
}

my $paint = 1;
my $counts = $frame->Frame()
                   ->grid( -column => 0, -row => 3, -padx => 4, -pady 
+=> 4, -columnspan => 3 );
my @paintRadio;
$paintRadio[$_] = $counts->Radiobutton(-text=>$_,-value=>$_,-variable=
+>\$paint,-font=>$countFont,
                                       -selectcolor=>$PAINTBG,-relief=
+>'raised',-indicatoron=>0)
                         ->grid(-column=>$_-1,-row=>0) for (1..9);

$ui->bind( 'Tk::Label',
           '<ButtonPress-1>' => \&poke );
$ui->bind( 'Tk::Label',
           '<ButtonPress-2>' => \&poke2 );
$ui->bind( 'Tk::Label',
           '<ButtonPress-3>' => \&poke3 );
currentHilite('sunken');

MainLoop;

# leave the game
sub endIt {
    exit;
}

# display popup menu on cell
# argument is label widget that was clicked on
sub poke {
    $cur_label = shift;
    return if $cur_label->{fixed};
    $popup->Popup( -popover => $cur_label,
                   -popanchor => 'nw',
                   -overanchor => 'c' );
}

# swap notes
sub poke2 {
    $cur_label = shift;
    my $values = $cur_label->{values};
    return if $values->[0];
    @$values[1,2] = @$values[2,1];
    paintCell($cur_label);
}

# assign current paint value to cell
# argument is label widget that was clicked on
sub poke3 {
    $cur_label = shift;
    return if $cur_label->{fixed};
    setLabel($paint);
}

# set label on cell
# value is number to assign to cell
sub setLabel {
    my $value = $_[0];
    return unless $value =~ /^[1-9]?$/;
#    my $event = $cur_label->XEvent;
#    my $mod = 0;
#    if ( $event ) {
#        $mod = 1 if $event->s =~ /Shift-/;
#        $mod = 2 if $event->s =~ /Control-/;
#    }
    my $cur = $cur_label->{values}[$paintMode];
    if ( $paintMode == 0 ) {
        return if $cur && $cur == $value;
        $#moves = $move;
        $moves[$move++] = { Button => $cur_label, Cell => $cur_label->
+{cell},
                            Old => $cur, New => $value };
        $cur_label->{values}[$paintMode] = $value;
        decCount( $cur );
        incCount( $value );
        $cur = $value;
    } else {
        my $i = index( $cur, $value );
        if ( $i == -1 ) {
            $cur = join('',sort split(//,$cur.$value) );
        } else {
            $cur = substr($cur,0,$i) . substr($cur,$i+1);
        }
        $cur_label->{values}[$paintMode] = $cur;
    }
    paintCell($cur_label);
}

# repaint the contents of a cell
sub paintCell {
    $cur_label = shift;
    my $values = $cur_label->{values};
    if ( $values->[0] ) {
        $cur_label->configure( -text => $values->[0], -foreground => $
+GUESS, -font => $digitFont, -anchor => 'c', -width => 2,
                               -height => 1, -border => 2 );
        findErrors() if $autocheck;
    } else {
        if ( $values->[1] ) {
            $cur_label->configure( -text => $values->[1], -foreground 
+=> $GUESS, -font => $noteFont, -anchor =>
                                   's', -width => 4, -height => 2 );
        } else {
            $cur_label->configure( -text => $values->[2], -foreground 
+=> $GUESS, -font => $noteFont, -anchor =>
                                   'nw', -width => 4, -height => 2 );
        }
    }
}

# start a new puzzle
sub newGame {
    my $oc = $ui->cget( '-cursor' );
    $ui->configure( -cursor => 'watch' );

    @moves = ();
    $move = 0;
    @soln = ();
    @puzzle = ();
    my ( $p1, $p2 ) = generate();
    $soln[int( $_ / 9 )] = 1 + $_ % 9 for @$p1;
    $puzzle[int( $_ / 9 )] = 1 + $_ % 9 for @$p2;
    @counts = ( 0 ) x 9;
    $counts[$_ % 9]++ for @$p2;
    $#puzzle = 80;

    for my $r ( 0..8 ) {
        for my $c ( 0..8 ) {
            my $v = $puzzle[$r * 9 + $c];
            if ( $v ) {
                $rows[$r][$c]->configure( -text => $v,
                                          -foreground => $GIVEN,
                                          -background => $BG,
                                          -width => 2, -height => 1 );
                $rows[$r][$c]{fixed} = 1;
                $rows[$r][$c]{values} = [ $v, '', '' ];
            }
            else {
                $rows[$r][$c]->configure( -text => '',
                                          -foreground => $GUESS,
                                          -background => $BG );
                $rows[$r][$c]{fixed} = 0;
                $rows[$r][$c]{values} = [ ('') x 3 ];
            }
        }
    }
    $ui->configure( -cursor => $oc );
    showCount();
}

# clear the current puzzle
sub clear {
    @moves = ();
    $move = 0;
    @soln = ();
    @puzzle = ();
    @counts = ( 0 ) x 9;
    for my $r ( @rows ) {
        for my $c ( @$r ) {
            $c->{fixed} = 0;
            $c->configure( -text => '',
                           -foreground => $GUESS,
                           -background => $BG );
            $$c->{values} = [ ( '' ) x 3 ];
        }
    }
}

# use the current cell values as a new puzzle
sub define {
    @moves = ();
    $move = 0;
    @puzzle = ();
    for my $r ( (0..9) ) {
        for my $c ( (0..9) ) {
            my $cell = $rows[$r][$c];
            my $v = $cell->{values}[0];
            if ( $v ) {
                $cell->{fixed} = 1;
                $cell->configure( -foreground => $GIVEN );
                $puzzle[$r * 9 + $c] = $v;
            }
        }
    }
}

# highlight cells based on correctness and completeness
sub check {
    my ( @good, @bad );
    shade( 'none' );
    for my $r ( @rows, @columns, @squares ) {
        my @l;
        for my $c ( @{ $r } ) {
            push @l, $c->{values}[0];
        }
        my $set = join( '', sort( @l ));
        if ( length( $set ) == 9 ) {
            if ( $set eq "123456789" ) {
                push @good, $r;
            }
            else {
                push @bad, $r;
            }
        }
    }
    for my $s ( [ \@good, 'green' ], [ \@bad, 'red' ] ) {
        for my $r ( @{ $s->[0] } ) {
            for my $c ( @{ $r } ) {
                $c->configure( -background => $s->[1] );
            }
        }
    }
}

# highlight cells based on correctness
sub findErrors {
    return unless @soln;
    for my $i ( 0..80 ) {
        my ( $r, $c ) = ( int( $i / 9 ), $i % 9 );
        my $g = $rows[$r][$c];
        my $t = $g->{values}[0];
        my $fg = $g->{fixed} ? $GIVEN :
            ( $t && ( $t ne $soln[$i] ) ) ? $BAD : $GUESS;
        $rows[$r][$c]->configure( -foreground => $fg );
    }
}

# set current cell border style
# argument is style ('sunken' or 'raised')
sub currentHilite {
    $rows[$curx][$cury]->configure( -relief => shift );
}

# set current cell
# arguments are x and y coordinates
sub currentSet {
    currentHilite( 'raised' );
    $rows[$curx][$cury]->configure( -relief => 'raised' );
    ( $curx, $cury ) = @_;
    $curx += 9 if $curx < 0;
    $curx -= 9 if $curx >= 9;
    $cury += 9 if $cury < 0;
    $cury -= 9 if $cury >= 9;
    currentHilite( 'sunken' );
}

# set value in current cell
# argument is new value
sub currentAssign {
    $cur_label = $rows[$curx][$cury];
    return if $cur_label->{fixed};
    setLabel( $_[1] );
}

# move up from current cell
sub currentUp {
    currentSet( $curx - 1, $cury );
}

# move down from current cell
sub currentDown {
    currentSet( $curx + 1, $cury );
}

# move left from current cell
sub currentLeft {
    currentSet( $curx, $cury - 1 );
}

# move right from current cell
sub currentRight {
    currentSet( $curx, $cury + 1 );
}

# move forward to next empty cell
sub currentTab {
    my ( $x, $y ) = ( $curx, $cury );
    while ( 1 ) {
        $y++;
        if ( $y > 8 ) {
            $y = 0;
            $x++;
            $x = 0 if $x > 8;
        }
        last if ( $x == $curx ) && ( $y == $cury );
        my $bg = $rows[$x][$y]->cget( -background );
        next if ( $bg eq $SHADE );
        my $c = $rows[$x][$y]->{values}[0];
        if ( $c eq '' ) {
            currentSet( $x, $y );
            return;
        }
    }
}

# move backwards to previous empty cell
sub currentBackTab {
    my ( $x, $y ) = ( $curx, $cury );
    while ( 1 ) {
        $y--;
        if ( $y < 0 ) {
            $y = 8;
            $x--;
            $x = 8 if $x < 0;
        }
        last if ( $x == $curx ) && ( $y == $cury );
        my $c = $rows[$x][$y]->{values}[0];
        if ( $c eq '' ) {
            currentSet( $x, $y );
            return;
        }
    }
}

# shade cells affected by a value
sub shade {
    my $want = shift;
    $want = shift if ref $want;
    my @r;
    my @c;
    my @b;
    for my $r ( 0..8 ) {
        for my $c ( 0..8 ) {
            my $g = $rows[$r][$c];
            if ( $g->{values}[0] eq $want ) {
                $g->configure( -foreground => $HILITE,
                               -background => $BG );
                $r[$r]++;
                $c[$c]++;
                $b[int( $c / 3 ) * 3 + int( $r / 3 )]++;
            }
            else {
                $g->configure( -foreground => $g->{fixed} ? $GIVEN : $
+GUESS,
                               -background => $BG );
            }
        }
    }
    for my $i ( 0..8 ) {
        if ( $r[$i] ) {
            $_->configure( -background => $SHADE ) for ( @{ $rows[$i] 
+} );
        }
        if ( $c[$i] ) {
            $_->configure( -background => $SHADE ) for ( @{ $columns[$
+i] } );
        }
        if ( $b[$i] ) {
            $_->configure( -background => $SHADE ) for ( @{ $squares[$
+i] } );
        }
    }
}

# change font size
sub setFontSize {
    my $fontsize = shift;
    $fontsize = shift if ref $fontsize;
    $digitFont = $ui->fontCreate( -size => $fontsize, -family => "helv
+etica", -weight => "bold" );
    $noteFont = $ui->fontCreate( -size => int( $fontsize / 2 ), -famil
+y => "helvetica");
    $countFont = $ui->fontCreate( -size => int( $fontsize * 3 / 4 ), -
+family => "helvetica" );
    for my $r ( @rows ) {
        for my $c ( @$r ) {
            my $values = $c->{values};
            if ( $values->[0] ) {
                $c->configure( -font => $digitFont, -width => 2, -heig
+ht => 1 );
            } else {
                $c->configure( -font => $noteFont, -width => 4, -heigh
+t => 2 );
            }
        }
    }
    $paintRadio[$_]->configure( -font => $countFont ) for (1..9);
}

# undo last move
sub undo {
    return unless $move;
    my $m = $moves[--$move];
    $m->{Button}->{values}[0] = $m->{Old};
    decCount( $m->{New} );
    incCount( $m->{Old} );
    paintCell($m->{Button});
    findErrors() if $autocheck;
}

# redo last undo
sub redo {
    return unless $move <= $#moves;
    my $m = $moves[$move++];
    $m->{Button}->{values}[0] = $m->{New};
    decCount( $m->{Old} );
    incCount( $m->{New} );
    paintCell($m->{Button});
    findErrors() if $autocheck;
}

# load a saved game from a file
sub openGame {
    my $file = $ui->getOpenFile;
    return unless defined $file;

    open my $fh, "<", $file;
    if ( !$fh ) {
        $ui->Dialog( -title => 'File Open Error',
                     -text => "Can't open $file\n$!",
                     -buttons => [ 'Ok' ] )->Show();
        return;
    }

    my $rec0 = <$fh>;
    my $rec1 = <$fh>;
    my $rec2 = <$fh>;
    if ( $rec0 !~ /^Perl-Tk Sudoku/ || $rec1 !~ /^\d{81}$/ || $rec2 !~
+ /^\d{81}$/ ) {
        $ui->Dialog( -title => 'File Format Error',
                     -text => "File is not a valid saved game",
                     -buttons => [ 'Ok' ] )->Show();
        return;
    }
    $rec1 =~ tr/\r\n//d;
    $rec2 =~ tr/\r\n//d;

    my $oc = $ui->cget( '-cursor' );
    $ui->configure( -cursor => 'watch' );

    @moves = ();
    $move = 0;
    @soln = ();
    @soln = split( //, $rec2 );
    @puzzle = ();
    @puzzle = split( //, $rec1 );
    @counts = ( 0 ) x 9;

    for my $r ( 0..8 ) {
        for my $c ( 0..8 ) {
            my $v = $puzzle[$r * 9 + $c];
            if ( $v ) {
                $rows[$r][$c]->configure( -text => $v,
                                          -foreground => $GIVEN,
                                          -background => $BG );
                $rows[$r][$c]{fixed} = 1;
                $rows[$r][$c]{values}[0] = $v;
                $counts[$v - 1]++;
            }
            else {
                $rows[$r][$c]->configure( -text => '',
                                          -foreground => $GUESS,
                                          -background => $BG );
                $rows[$r][$c]{fixed} = 0;
                $rows[$r][$c]{values}[0] = '';
            }
        }
    }

    while ( my $rec = <$fh> ) {
        $rec =~ tr/\r\n//d;
        my ( $bn, $v ) = split( /,/, $rec );
        my $c = $rows[int( $bn / 9 )][$bn % 9];
        push @moves, { Button => $c, Cell => $bn,
                       Old => $c->{values}[0], New => $v };
        $move++;
        $c->configure( -text => $v, -foreground => $GUESS );
        $c->{values}[0] = $v;
        $counts[$v - 1]++;
    }

    showCount();
    $ui->configure( -cursor => $oc );
}

# save game to a file
sub saveGame {
    my $file = $ui->getSaveFile;
    return unless defined $file;

    open my $fh, ">", $file;
    if ( !$fh ) {
        $ui->Dialog( -title => 'File Open Error',
                     -text => "Can't open $file\n$!",
                     -buttons => [ 'Ok' ] )->Show();
        return;
    }

    print $fh "Perl-Tk Sudoku\n";
    print $fh join( '', map { $_ ? $_ : '0' } @puzzle ), $/;
    print $fh join( '', @soln ), $/;

    for my $mv ( @moves ) {
        print $fh join( ',', $mv->{Cell}, $mv->{New} ), $/;
    }
}

# increment count for a value
sub incCount {
    my $s = shift;
    if ( $s =~ /[1-9]/ ) {
        $counts[$s - 1]++;
        showCount();
        my $c = 0;
        while ( $c < 9 ) {
            last if $counts[$c] != 9;
            ++$c;
        }
        check() if $c == 9;
    }
}

# decrement count for a value
sub decCount {
    my $s = shift;
    if ( $s =~ /[1-9]/ ) {
        $counts[$s - 1]--;
        showCount();
    }
}

# update value counts
sub showCount {
    for my $i ( 1..9 ) {
        my $label = join(':',$i,$counts[$i-1]);
        $paintRadio[$i]->configure( -text => $label );
    }
}

#
# sudoku generator adapted from https://perlmonks.org/?node_id=538853
#

use List::Util qw{shuffle};

sub generate {
    # use STDERR because STDOUT is used to pass the puzzle text
    #  to sudoku2pdf.pl
    #    print STDERR "Generating Sudoku puzzle...\n";

    # create the cover puzzle, and an initial path stash
    my $puzzle = make_puzzle();
    my $pstash = make_path_stash( $puzzle );

    # find a completed Sudoku puzzle
    my @solutions = solve_cover( $puzzle, $pstash, 1 );
    my $solset = pop @solutions;

    # find -a- minimal puzzle with that set
    my @sol = find_minimal( @$solset );

    return ( $solset, \@sol );
}

############################################################
##   FUNCTIONS                                            ##
############################################################

############################################################
# solve_cover() - given an initial path stash, solve puzzle

sub solve_cover {
    my ( $puzref, $iloc, $tofind ) = @_;
    $tofind ||= 1;

    # initialize as much as possible here,
    # to avoid allocing during tightloop
    my @stack = ( $iloc ); # 'recurse' agenda
    my @liverows = ();     # don't allocated any arrays in
    my @pivrows = ();      # loop - expensive.
    my @solutions = ();    # solutions found
    my $curpaths = 0;      # counter for paths (stats only)
    my @puz = @$puzref;

    RECURSE:
    while ( 1 ) {
        # basecase 1:
        my $rloc = pop @stack or last RECURSE;

        if ( $rloc->{livecol} eq $ZEROCOL ) {
            my @setlist = grep { vec $rloc->{solset}, $_, 1 } 0..( $RO
+WCNT - 1 );
            push @solutions, \@setlist;

            # basecase 2 - we satisfy our solution agenda
            last RECURSE if ( scalar( @solutions ) >= $tofind );
            next RECURSE;
        }

        # enumerate active rows
        my $cand = ( ~$rloc->{removed} );
        @liverows = ();
        vec( $cand, $_, 1 ) && push( @liverows, $_ )
            for 0..( $ROWCNT - 1 );

        # basecase 3:
        my $colcheck = $ZEROCOL;
        $colcheck |= $puz[$_] for @liverows;
        next RECURSE unless $colcheck eq $rloc->{livecol};

        # select a pivot column
        my $pivcol;
        my $pivmask;

        COLPICK:
        for my $col ( 0..$COLCNT - 1 ) {
            next COLPICK unless vec( $rloc->{livecol}, $col, 1 );

            $pivcol = $col;
            $pivmask = $ZEROCOL;
            vec( $pivmask, $pivcol, 1 ) = 1;

            my $cnt = 0;
            ( ( $pivmask & $puz[$_] ) ne $ZEROCOL ) and $cnt++
                for @liverows;

            # shortcurcuit select if any singletons found
            last COLPICK if $cnt == 1;
        }

        # enumerate pivot rows:
        @pivrows = ();
        for ( @liverows ) {
            push @pivrows, $_
                if ( ( $pivmask & $puz[$_] ) ne $ZEROCOL );
        }

        # DESCEND - each pivot row is a path to descend into
        for my $prow ( shuffle @pivrows ) {
            my %crloc = %$rloc;

            # prune out covered rows
            for my $r ( @liverows ) {
                vec( $crloc{removed}, $r, 1 ) = 1
                    if ( $puz[$r] & $puz[$prow] ) ne $ZEROCOL;
            }

            # mask out consumed columns
            $crloc{livecol} &= ~$puz[$prow];

            # add row to solutionset
            vec( $crloc{solset}, $prow, 1 ) = 1;

            $curpaths++;
            push @stack, \%crloc;
        }

    }
    return @solutions;
}

############################################################

sub find_minimal {
    my ( @solset ) = @_;

    # This is cheap and dirty, but at least it's cheap and dirty.
    my @sol;
    do
    {
        @sol = shuffle @solset;
        pop @sol for 0..30;
    }
        until ( is_unambiguous( @sol ) );

    TRIM:
    while ( 1 ) {
        for ( 0..$#sol ) {
            my $front = shift @sol;
            next TRIM if is_unambiguous( @sol );
            push @sol, $front;
        }
        last TRIM; # none can be removed
    }

    return @sol;
}

############################################################

sub is_unambiguous {
    my @set = @_;
    my $puzzle = make_puzzle();
    my $pstash = make_path_stash( $puzzle, @set );

    my @solutions = solve_cover( $puzzle, $pstash, 2 );

    return ( scalar( @solutions ) == 1 );
}

############################################################

sub make_path_stash {
    my ( $puz, @set ) = @_;
    my $mask = $ZEROCOL;
    my $solset = $ZEROROW;
    my $remset = $ZEROROW;

    if ( @set ) {
        $mask |= $puz->[$_] for @set;

        for my $row ( 0..( $ROWCNT - 1 ) ) {
            vec( $remset, $row, 1 ) = 1
                if ( ( $puz->[$row] & $mask ) ne $ZEROCOL );
        }

        vec( $solset, $_, 1 ) = 1 for @set;
    }

    return {
        livecol => ( ~$mask ) & $FULLCOL,
        removed => $remset,
        solset => $solset,
        colptr => 0,
    };
}

############################################################
# return puzzle array

sub make_puzzle {
    my @puz;
    for my $sqr ( 0..80 ) {
        for my $val ( 1..9 ) {
            push @puz, map_to_covervec( $val, $sqr );
        }
    }

    return \@puz;
}

############################################################
# given a square and a value, return bitvec

sub map_to_covervec {
    my ( $num, $sqr ) = @_;
    my $bitmap = $ZEROCOL; # blank row
    my $seg = 9 ** 2;      # constraint segment offset

    my $row = int( $sqr / 9 );  # row
    my $col = $sqr % 9;         # col
    my $blk = int( $col / 3 ) + # block
              int( $row / 3 ) * 3;

    # map to contraint offsets
    my @offsets = (
        $sqr,
        $seg + $row * 9 + $num - 1,
        $seg * 2 + $col * 9 + $num - 1,
        $seg * 3 + $blk * 9 + $num - 1,
    );

    # poke out offsets
    vec( $bitmap, $_, 1 ) = 1 for @offsets;

    return $bitmap;
}

__DATA__
value
000000000000000000000000001800001c00001e00001f00001f00001c00001c00001c
+00001c00001c00001c00001c00001c0080ff0080ff0080ff000000000000000000000
+00000
corner
000000000000980300240400200400100200080400040400bc03000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+00000
bottom
0000000000000000000000000000000000000000000000000000000000000000000000
+0000000000000080f4008014008014008077000084000084000074000000000000000
+00000
undo
000000000000000000007c00088301c80006280008280008180010f800100000200000
+20000020000020000020000010100010200008200008c00006008301007c000000000
+00000
redo
000000000000000000003e0080c11060001310001410001408001808001f0400000400
+0004000004000004000008000008000810000410000460000380c100003e000000000
+00000
[download]