#!/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, -accelerator => '^O' ],
              [ Button => "~Save", -command => \&saveGame, -accelerator => '^S' ],
              [ Separator => '' ],
              [ Button => "~Quit", -command => \&endIt, -accelerator => '^Q' ],
          ]
        ],
        [ Cascade => "~Game", -menuitems =>
          [
              [ Button => "~New", -command => \&newGame, -accelerator => '^N' ],
              [ Button => "~Define", -command => \&define, -accelerator => '^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, -accelerator => '^E' ],
              [ Checkbutton => "~Autocheck", -accelerator => '^A', -variable => \$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}{bitmap} );
}

$ui->resizable(0,0);
# font for game digits
my $digitFont = $ui->fontCreate( -size => $fontsize, -family => "helvetica",
                            -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 => [ \&setLabel, $_ ],
                       ] } ( '', 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 => "helvetica", -weight => "bold" );
    $noteFont = $ui->fontCreate( -size => int( $fontsize / 2 ), -family => "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, -height => 1 );
            } else {
                $c->configure( -font => $noteFont, -width => 4, -height => 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..( $ROWCNT - 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
000000000000000000000000001800001c00001e00001f00001f00001c00001c00001c00001c00001c00001c00001c00001c0080ff0080ff0080ff00000000000000000000000000
corner
000000000000980300240400200400100200080400040400bc0300000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
bottom
00000000000000000000000000000000000000000000000000000000000000000000000000000000000080f400801400801400807700008400008400007400000000000000000000
undo
000000000000000000007c00088301c80006280008280008180010f80010000020000020000020000020000020000010100010200008200008c00006008301007c00000000000000
redo
000000000000000000003e0080c11060001310001410001408001808001f04000004000004000004000004000008000008000810000410000460000380c100003e00000000000000