#!/usr/bin/perl
use strict;
use warnings;
use Tk;
use Tk::Button;
use Tk::Radiobutton;
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 $MARK      = '#999999';   # marked button background color
our $GIVEN     = 'black';     # foreground for a given number
our $GUESS     = 'blue';      # foreground for a guessed number
our $HILITE    = 'orange';    # marked number foreground
our $GOOD      = 'green';     # check ok
our $BAD       = 'red';       # check not ok
our $fontsize  = 14;

our @moves;
our $move = 0;

our ($curx,$cury) = (0,0);    # current position

my $menu =
    [
     [ Cascade => "~Game", -menuitems =>
       [
	[ Button => "~New", -command => \&new_game, -accelerator => '^N' ],
	[ Button => "~Define", -command => \&define, -accelerator => '^D' ],
	[ Button => "C~lear", -command => \&clear, -accelerator => '^L' ],
	[ Separator => '' ],
	[ Button => "~Check", -command => \&check, -accelerator => '^C' ],
	[ Button => "Find ~Errors", -command => \&find_errors,
	  -accelerator => '^E' ],
	[ Cascade => "~Mark", -menuitems =>
	  [
	   map { [ Button => $_ ? "~$_" : "~None",
		   -command => [ \&mark, $_ ],
		   -accelerator => "^$_" ] } (0..9)
	  ]
	],
	[ Separator => '' ],
        [ Cascade => "~Font Size", -menuitems =>
          [
            map { [ Radiobutton => $_, -variable => \$fontsize, -value => $_,
                     -command => [ \&setfontsize, $_ ] ] } (8, 10, 12, 14, 16)
          ]
        ],
	[ Button => "~Quit", -command => \&endit, -accelerator => '^Q' ],
       ]
     ],
     [
       Cascade => "~Edit", -menuitems =>
       [
        [ Button => "~Undo", -command => \&undo, -accelerator => '^U' ],
        [ Button => "~Redo", -command => \&redo, -accelerator => '^R' ],
       ]
     ]
    ];

my $ui = MainWindow->new( );
my $font = $ui->fontCreate( -size => $fontsize, -family => "helvetica" );

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

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

my $popup = $ui->Menu( -tearoff => 0,
		       -menuitems => [ map { [ Button => $_,
					       -command => [ \&set_label, $_ ],
					     ] } ( '', 1..9 ) ] );
$ui->bind($_->[0],$_->[1])
    for ( [ '<Control-n>', \&new_game ],
	  [ '<Control-q>', \&endit ],
	  [ '<Control-l>', \&clear ],
	  [ '<Control-d>', \&define ],
	  [ '<Control-c>', \&check ],
	  [ '<Control-e>', \&find_errors ],
	  [ '<Control-u>', \&undo ],
	  [ '<Control-r>', \&redo ],
	  map({ [ "<Control-Key-$_>", [ \&mark, $_ ] ] } (0..9)),
	  map({ [ "<Key-$_>", [ \&current_assign, $_ ] ] } (0..9)),
	  [ '<Key-Left>', \&current_left ],
	  [ '<Key-Right>', \&current_right ],
	  [ '<Key-Up>', \&current_up ],
	  [ '<Key-Down>', \&current_down ]
    );

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

my (@rows, @columns, @squares);
my @orig;

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 $a (0..2) {
	    for my $b (0..2) {
		my $l = $sq->Label( -width => 2,
				    -border => 2,
				    -relief => 'groove',
                                    -background => $BG,
				    -font => $font,
				    -relief => 'raised',
				    )->grid( -column => $a,
					     -row => $b );
		push @{$rows[$y*3+$b]}, $l;
		push @{$columns[$x*3+$a]}, $l;
		push @{$squares[$x*3+$y]}, $l;
	    }
	}
    }
}

$ui->bind( 'Tk::Label',
	   '<ButtonPress-1>' => \&poke );
current_hilite();

MainLoop;


sub endit {
    exit;
}

my $cur_label;

sub poke {
    $cur_label = $_[0];
    return if $_[0]{fixed};
    $popup->Popup( -popover => $_[0],
		   -popanchor => 'nw',
		   -overanchor => 'c' );
}

sub set_label {
    $moves[$move++] = { Button=>$cur_label,
			Old=>$cur_label->cget( -text ), New=>$_[0] };
    $#moves = $move;
    $cur_label->configure( -text => $_[0], -foreground => $GUESS );
}

my @soln;
my @puzzle;

sub new_game {
    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;

    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;
	    } else {
		$rows[$r][$c]->configure( -text => '',
					  -foreground => $GUESS,
					  -background => $BG );
		$rows[$r][$c]{fixed} = 0;
	    }
	}
    }
    $ui->configure( -cursor => $oc );
}

sub clear {
    @moves = ();
    $move = 0;
    @soln = ();
    @puzzle = ();
    for my $r (@rows) {
	for my $c (@$r) {
	    $c->{fixed} = 0;
	    $c->configure( -text => '',
			   -foreground => $GUESS,
			   -background => $BG );
	}
    }
}

sub define {
    @moves = ();
    $move = 0;
    @puzzle = ();
    for my $r (@rows) {
	for my $c (@$r) {
	    my $v = $c->cget( '-text' );
	    if ($v) {
		$c->{fixed} = 1;
		$c->configure( -foreground => $GIVEN );
	    }
	}
    }
}

sub check {
    my (@good,@bad);
    for my $r (@rows, @columns, @squares) {
	my @l;
	for my $c (@{$r}) {
	    push @l, $c->cget( "-text" );
	}
	my $bg = $BG;
	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] );
	    }
	}
    }
}

sub find_errors {
    return unless @soln;
    for my $i (0..80) {
	my ($r, $c) = ( int($i/9), $i % 9 );
	my $g = $rows[$r][$c]->cget( '-text' );
	if ( $g && ( $g ne $soln[$i] ) ) {
	    $rows[$r][$c]->configure( -foreground => $BAD );
	}
    }
}

sub current_hilite {
    $rows[$curx][$cury]->configure( -relief => 'sunken' );
}
sub current_set {
    $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;
    current_hilite();
}
sub current_assign {
    $cur_label = $rows[$curx][$cury];
    return if $cur_label->{fixed};
    set_label($_[1]);
}
sub current_up {
    current_set($curx-1,$cury);
}
sub current_down {
    current_set($curx+1,$cury);
}
sub current_left {
    current_set($curx,$cury-1);
}
sub current_right {
    current_set($curx,$cury+1);
}

sub mark {
    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->cget( '-text' ) 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 $a (0..8) {
        if ($r[$a]) {
            $_->configure( -background => $MARK ) for (@{$rows[$a]});
        }
        if ($c[$a]) {
            $_->configure( -background => $MARK ) for (@{$columns[$a]});
        }
        if ($b[$a]) {
            $_->configure( -background => $MARK ) for (@{$squares[$a]});
        }
    }
}

sub setfontsize {
    my $sz = shift;
    $sz = shift if ref $sz;
    $font = $ui->fontCreate( -size => $fontsize, -family => "helvetica" );
    for my $r (@rows) {
	for my $c (@$r) {
            $c->configure( -font => $font );
        }
    }
}

sub undo {
    return unless $move;
    my $m = $moves[--$move];
    $m->{Button}->configure( -text=>$m->{Old}, -foreground=>$GUESS );
}

sub redo {
    return unless $move < $#moves;
    my $m = $moves[$move++];
    $m->{Button}->configure( -text=>$m->{New}, -foreground=>$GUESS );
}

use List::Util qw{ shuffle };

############################################################
##   MAIN                                                 ##
############################################################

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;
}