#!/usr/bin/perl

# Copyright (C) 2005 by Flavio Poletti
# Same licensing terms as Perl itself, v. 5.8.6
# NO WARRANTY AT ALL, USE IT AT YOUR RISK

# ChangeLog:
#
# Changed from 'readonly' to 'disabled' to support older versions of
# Tk. Also changed -disableforeground to give the same look-and-feel.
#
# Removed dumb error left from a previos test. Turned check messages
# into english. Changed relief for fixed cells.
#
# Added support for "starter" status, i.e. elements that are there
# from the start. Fixed residual bug in push/pop mechanism.

use strict;
use warnings;

use Tk;
use Tk::Dialog;
use Tk::Menu;

######## GLOBAL VARIABLES ###########################################
# Version
my $VERSION = '2.0';

# File name used for load and save
my $filename = shift;

# Main Window
my $mw = MainWindow->new();

# Font size
my $size = int(-32 * 32 / 33);

# Map of game info
my @map;

# Commands for undo support
my @commands;

# Reset value
#my $resetter = [ 1 .. 9 ];
my $resetter = [];

#####################################################################
# Define fonts for normal and disabled view
$mw->fontCreate(
   'big',
   -family => 'courier',
   -weight => 'bold',
   -size   => $size
);
$mw->fontCreate(
   'tiny',
   -family => 'courier',
   -weight => 'normal',
   -size   => ($size / 3)
);

{    # A bit of scope reduction for some variables
       # Frames for different 3x3 subframes
   my @chunks;

   # Initialise frames, isolating 3x3 subwindows. This allows to
   # separate 3x3 subwindows for a clearer view of the game table.
   for my $i (0 .. 2) {
      my $outer = $mw->Frame();
      $outer->pack(-side => 'top');
      for my $j (0 .. 2) {
         my $inner = $outer->Frame(-borderwidth => 2);
         $inner->pack(-side => 'left');
         for my $k (0 .. 2) {
            $chunks[$i][$j][$k] = $inner->Frame();
            $chunks[$i][$j][$k]->pack(-side => 'top');
         }
      } ## end for my $j (0 .. 2)
   } ## end for my $i (0 .. 2)

   # Initialise the 81 cells in the game
   for my $i (0 .. 8) {
      for my $j (0 .. 8) {
         $map[$i][$j] =
           SuDoKu::BigButton->new($chunks[$i / 3][$j / 3][$i % 3],
            [\&autoclean, $i, $j]);
      }
   } ## end for my $i (0 .. 8)

   # Dialog window to show when the check button is pressed.
   my $check_label;
   my $check_dialog = $mw->Dialog(
      -title        => 'Check result',
      -buttons      => ['OK'],
      -bitmap       => 'warning',
      -textvariable => \$check_label
   );

   # Top frame, containing the menu
   my $menu = $mw->Menu();
   $mw->configure(-menu => $menu);

   my $file_menu = $menu->cascade(-label => 'File');
   $file_menu->command(
      -label   => 'Load...',
      -command => \&ask_load_file
   );
   $file_menu->command(
      -label   => 'Save',
      -command => sub { save($filename) if $filename }
   );
   $file_menu->command(
      -label   => 'Save As...',
      -command => \&ask_save_file
   );
   $file_menu->separator();
   $file_menu->command(-label => 'Reset', -command => \&reset);
   $file_menu->command(-label => 'Exit',  -command => sub { exit(0) })
+;

   # Help system, pretty auto-explanatory
   my $about_dialog = $mw->Dialog(
      -title   => 'About SuDoTKu',
      -buttons => ['OK'],
      -bitmap  => 'info',
      -text    => "SuDoTKu - Su DoKu Perl/Tk Interface

Copyright 2005 by Flavio Poletti

Many thanks to the perl.it guys for the patience :)"
   );
   my $help_dialog = $mw->Dialog(
      -title   => 'SuDoTKu Help',
      -buttons => ['OK'],
      -bitmap  => 'info',
      -text    => "Su DoKu rules can be found on the net

This program tries to make it easy to play Su DoKu. Each cell can
be in 'multiple' mode, meaning you can keep all your guesses, or in
single fixed mode, for cells that you think that have only that
value. You can enable/disable a guess from multiple mode simply
clicking on it. When you double-click an enabled guess, you fix it;
double clicking a fixed cell returns to multiple mode. Cells that
are in the original scheme are frozen and do not interact.

File Menu: do you really need help?!?

Push: push a marker on the undo stack
Pop : pop until you find a marker or you exhaust the undo stack
MiniPop: pop a single action from the undo stack

Fill: turn all empty cells into completely full cells, or vice-versa
Cleanup: auto-cleanup impossible options
Check: check if the current board complies to the Su DoKu rules


Copyright 2005 by Flavio Poletti

Many thanks to the perl.it guys for the patience :)"
   );
   my $help_menu = $menu->cascade(-label => 'Help');
   $help_menu->command(
      -label   => 'Help on SuDoTKu',
      -command => sub {
         $help_dialog->Show();
      }
   );
   $help_menu->separator();
   $help_menu->command(
      -label   => 'About...',
      -command => sub {
         $about_dialog->Show();
      }
   );

   # Bottom frame, containing all the action buttons.
   my $undofr = $mw->Frame();
   $undofr->pack();

   # Undo handling. Push pushes a marker into the command stack, which
   # will be the stopping point for a canned sequence of later pops.
   $undofr->Button(-text => 'Push', -command => sub { push @commands, 
+0 })
     ->pack(-side => 'left');

   # Pop inhibits the re-push of the commands signaling via the
   # $undoing variable. It pops commands and undoes them until
   # the queue is empty or it finds a marker pushed by the user.
   $undofr->Button(
      -text    => 'Pop',
      -command => sub {
         while (my $aref = pop @commands) {
            undo($aref);
         }
      }
   )->pack(-side => 'left');

   # Pop inhibits the re-push of the commands signaling via the
   # $undoing variable. It pops commands and undoes them until
   # the queue is empty or it finds a marker pushed by the user.
   $undofr->Button(
      -text    => 'MiniPop',
      -command => sub {
         return unless @commands;
         if (my $aref = pop @commands) {
            undo($aref);
         }
         else {    # Don't remove markers
            push @commands, $aref;
         }
      }
   )->pack(-side => 'left');

   # Bottom frame, containing all the action buttons.
   my $bottom = $mw->Frame();
   $bottom->pack();

   # Filler helps you fill (or empty) cells that still have no
   # "information"
   my $filler;
   $filler = $bottom->Button(
      -text    => 'Fill',
      -command => sub {
         my $target = @$resetter;
         if ($target) {
            $resetter = [];
            $filler->configure(-text => 'Fill');
         }
         else {
            $resetter = [1 .. 9];
            $filler->configure(-text => 'Empty');
         }
         for my $i (0 .. 8) {
            for my $j (0 .. 8) {
               $map[$i][$j]->reset($resetter)
                 if $map[$i][$j]->get_state() eq 'normal'
                 && @{$map[$i][$j]->get_value()} == $target;
            }
         } ## end for my $i (0 .. 8)
      }
   );
   $filler->pack(-side => 'left');

   # Autoclean all impossible positions in multiple choices
   $bottom->Button(
      -text    => 'Cleanup',
      -command => sub {
         for my $i (0 .. 8) {
            for my $j (0 .. 8) {
               autoclean($i, $j);
            }
         }
      }
   )->pack(-side => 'left');

   # Check calls the check method to see if the fixed elements collide
+.
   # It displays the $checkDialog dialog window with an appropriate
   # message.
   $bottom->Button(
      -text    => 'Check',
      -command => sub {
         $check_label = (check() ? "All ok!" : "Check out errors!");
         $check_dialog->Show();
      }
   )->pack(-side => 'left');

   # Avoid resizing of the window - it would have no meaning.
   $mw->resizable(0, 0);
   $mw->update();

   # Load filename, if it can be done, and initialise cells
   if ($filename) {
      load($filename);
      set_title($filename);
   }
}

# Fire!
MainLoop();

# Undo one command. The input is an array whose first element is
# a sub reference, others elements are parameters.
sub undo {
   my $aref = shift;
   my ($sub, @params) = @$aref;
   $sub->(@params);
}

# Check an element. Receives two array references: the first pointing
# to the data of the cell to check, the other to an array that keeps
# track of seen positions. If a position is seen twice, an error is
# returned. Only fixed cells are analysed, of course.
sub check_it {
   my ($bb, $aref) = @_;

   my $v = $bb->get_value();

   # Non fixed cells are ok
   return 1 if ref $v;

   # Check if already in array
   return 0 if $aref->[$v];

   $aref->[$v] = 1;
   return 1;
} ## end sub check_it

# Check the game board.
sub check {
   for my $i (0 .. 8) {
      my (@pv, @ph, @pc);
      for my $j (0 .. 8) {

         # Horizontal check
         return 0 unless check_it($map[$i][$j], \@ph);

         # Vertical check
         return 0 unless check_it($map[$j][$i], \@pv);

         # 3x3 subtable check
         return 0
           unless check_it(
            $map[(int($i / 3) * 3 + ($j % 3))]
              [(3 * ($i % 3) + int($j / 3))],
            \@pc
           );
      } ## end for my $j (0 .. 8)
   } ## end for my $i (0 .. 8)
   1;
} ## end sub check

# Save board to file, input is filename
sub save {
   my $filename = shift;
   local $, = ":";
   local $\ = "\n";
   if (open my $fh, ">", $filename) {
      for my $i (0 .. 8) {
         for my $j (0 .. 8) {
            my $value = $map[$i][$j]->get_value();
            $value = join '', @$value if ref $value;
            print $fh $value, $map[$i][$j]->get_state();
         }
      } ## end for my $i (0 .. 8)
   } ## end if (open my $fh, ">", ...
   else {
      warn("open($filename): $!");
   }
} ## end sub save

# Load board from file, input is filename.
sub load {
   my $filename = shift;
   -e $filename or return;
   if (open my $fh, "<", $filename) {
      while (<$fh>) {
         chomp;
         my $i = $. - 1;

         # Split into two parts, the value and the state
         my ($f, $s) = split /:/, $_;
         if ($s eq 'starter') {
            $map[int($i / 9)][$i % 9]->freeze($f);
         }
         elsif ($s eq 'fixed') {
            $map[int($i / 9)][$i % 9]->reset($resetter);
            $map[int($i / 9)][$i % 9]->set_value($f);
         }
         else {
            $map[int($i / 9)][$i % 9]->reset([split //, $f]);
         }
      } ## end while (<$fh>)
   } ## end if (open my $fh, "<", ...
   else {
      warn "open($filename): $!";
   }
} ## end sub load

sub reset {
   foreach my $i (0 .. 80) {
      unless ($map[$i / 9][$i % 9]->get_state() eq 'starter') {
         $map[$i / 9][$i % 9]->reset($resetter);
      }
   }
   @commands = ();
} ## end sub reset

# Convenience wrapper to call the file open dialog and load the file
sub ask_load_file {
   my $selected =
     $mw->getOpenFile(
      -filetypes => [['SuDoTKu file', '*.sdk', 'TEXT'], ['All files', 
+'*']]
     );
   if ($selected) {
      $filename = $selected;
      load($filename);
      set_title($filename);
   }
} ## end sub ask_load_file

# Convenience wrapper to call the save file dialog
sub ask_save_file {
   my $selected =
     $mw->getSaveFile(
      -filetypes => [['SuDoTKu file', '*.sdk', 'TEXT'], ['All files', 
+'*']]
     );
   if ($selected) {
      $filename = $selected;
      save($filename);
      set_title($filename);
   }
} ## end sub ask_save_file

# Convenience function to set the title of the main window
sub set_title {
   $mw->configure(-title => "SuDoTKu ($_[0])");
}

# Perform autocleaning of all guesses that conflict with a given
# *fixed* position.
sub autoclean {
   my ($r, $c) = @_;
   my $value = $map[$r][$c]->get_value();
   return if ref $value;
   return unless defined $value;
   for my $idx (0 .. 8) {
      $map[$idx][$c]->remove_option($value);
      $map[$r][$idx]->remove_option($value);
      $map[3 * int($r / 3) + int($idx / 3)][3 * int($c / 3) + $idx % 3
+]
        ->remove_option($value);
   } ## end for my $idx (0 .. 8)

} ## end sub autoclean

# This accessory package (tries to) encapsulates the behaviour of a
# single entry in the Su DoKu table, providing a view for the guesses
# (tiny font, 9 guesses arranged in a 3x3 fashion) and for the fixed
# values. Interaction is done all via Mouse.
package SuDoKu::BigButton;
use Tk;

# Pass to the multiple, guessing view
sub _go_multiple {
   my ($self, $value) = @_;

   # Remove single
   $self->{single}{frame}->packForget() if $self->{single};

   # Enable multiple
   $self->{multiple}{frame}->pack();

   $self->{state} = 'normal';
} ## end sub _go_multiple

# Change the value of a label in multiple view, toggling between
# a simple (empty) space to the value associated to the position
sub toggle_label {
   my ($label, $value) = @_;
   my $current = $label->cget('-text');
   $label->configure(-text => (($current eq $value) ? ' ' : $value));
}

# Call toggle_label but registers the undo function in @commands
# This breaks encapsulation a bit :)
sub registered_toggle_label {
   my ($label, $value) = @_;
   toggle_label($label, $value);
   push @commands, [\&toggle_label, $label, $value];
}

# Makes a label interactive, in particular respondent to simple and
# double clicks (Labels have no binding by default, they're not
# supposed to interact).
sub _interactive_Label {
   my ($self, $frame, $iframe, $label) = @_;
   my $value = $label->cget('-text');

   $label->bind(
      '<Double-1>',
      sub {    # Request to pass in fixed view
         my $current = $label->cget('-text');
         if ($current ne $value) {
            $label->configure(-text => $value);
            $self->_go_single($value);
            pop @commands;
            push @commands, [\&_go_multiple, $self];
         } ## end if ($current ne $value)
         Tk->break();
      }
   );
   $label->bind(
      '<1>',
      sub {    # Toggle character, save in undo stack
         registered_toggle_label($label, $value);
      }
   );
} ## end sub _interactive_Label

# Create a new 'multiple' view, compound of 3x3 elements from 1 to 9,
# all labels made interactive
sub _new_multiple {
   my $self       = shift;
   my $upperframe = $self->{frame};
   my $href       = {};
   my $frame      = $href->{frame} = $upperframe->Frame();
   for my $i (0 .. 2) {
      my $iframe = $frame->Frame();
      $iframe->pack(-side => 'top');
      for my $j (0 .. 2) {
         my $idx = $i * 3 + $j + 1;
         my $label = $iframe->Label(-text => $idx, -font => 'tiny');
         $self->_interactive_Label($frame, $iframe, $label);
         $label->pack(-side => 'left');

         # Add to the list of labels
         $href->{labels}[$idx] = $label;
      } ## end for my $j (0 .. 2)
   } ## end for my $i (0 .. 2)
   $frame->pack();

   return $href;
} ## end sub _new_multiple

# Pass to single, fixed view.
sub _go_single {
   my ($self, $value) = @_;

   # Remove multiple
   $self->{multiple}{frame}->packForget();

   # Enable single. The single view initialisation is lazy in contrast
   # to that of the multiple view - this saves some time.
   $self->{single} = $self->_new_single()
     unless $self->{single};
   $self->{single}{label}->configure(
      -text       => $value,
      -foreground => 'darkblue'
   );
   $self->{single}{frame}->pack();

   $self->{state} = 'fixed';
} ## end sub _go_single

# Creates a new single-view element
sub _new_single {
   my $self = shift;
   my $href = {};

   # Freeze frame dimensions, in order to keep the same size of the
   # multiple view. In this way there will be no mess passing from
   # one view to the other
   $self->{frame}->packPropagate(0);

   my $frame = $href->{frame} = $self->{frame}->Frame();
   $frame->pack();
   my $label = $href->{label} = $frame->Label(-text => '', -font => 'b
+ig');
   $label->bind(
      '<Double-1>',
      sub {
         unless ($self->{state} eq 'starter') {
            my $value = $self->get_value();
            $self->_go_multiple();
            push @commands, [\&_go_single, $self, $value];
         }
      }
   );
   $label->bind(
      '<Control-1>',
      sub {    # This sequence calls the action associated during new(
+)
         if (my $ref = $self->{Control1}) {
            my ($sub, @params) = $ref;
            ($sub, @params) = @$ref if ((ref $ref) eq 'ARRAY');
            $sub->(@params);
         }
      }
   );
   $label->pack();

   return $href;
} ## end sub _new_single

# Create a new object. Parameters:
# $class: passed implicitly with call to SuDoKu::BigButton->new(...);
# $parent: the parent widget (mainwindow or frame)
# The callback to be called when CTRL-Button1 is pressed on a fixed
# cell
#
sub new {
   my ($class, $parent, $Control1) = @_;
   my $frame = $parent->Frame(-relief => 'groove', -borderwidth => 1);
   $frame->pack(-side => 'left');
   my $self =
     bless {parent => $parent, frame => $frame, Control1 => $Control1}
+,
     $class;
   $self->{multiple} = $self->_new_multiple();
   $self->reset($resetter);

   return $self;
} ## end sub new

# Get the value of the cell. If the cell is fixed (or even frozen)
# returns a single scalar containing the desired value, otherwise
# returns a reference to an array containing current guesses.
sub get_value {
   my $self = shift;
   if ($self->{state} eq 'normal') {
      return [
         map {
            if ((my $v = $_->cget(-text)) =~ /\d/)
            {
               $v;
            } ## end if ((my $v = $_->cget(...
            else {
               ();
            }
           } @{$self->{multiple}{labels}}[1 .. 9]
      ];
   } ## end if ($self->{state} eq ...
   else {
      return $self->{single}{label}->cget('-text');
   }
} ## end sub get_value

# Set the value of the cell. This means fixing the value and passing
# on the single view
sub set_value {
   my ($self, $value) = @_;
   $self->{multiple}{labels}[$value]->configure(-text => $value);
   $self->_go_single($value);
}

# Set the value of a cell and make it unmodifiable by the normal
# game course. This is useful to mark starting hints.
sub freeze {
   my ($self, $value) = @_;
   $self->set_value($value);
   $self->{single}{label}->configure(-foreground => 'darkred');
   $self->{state} = 'starter';
} ## end sub freeze

# Reset the button using the $init parameter as a reference to
# an array containing the guesses to evidentiate
sub reset {
   my $self = shift;
   my $init = shift;

   $self->_go_multiple();
   $self->{single} = undef;
   $self->{multiple}{labels}[$_]->configure(-text => ($init ? ' ' : $_
+))
     foreach 1 .. 9;
   if (ref $init) {
      $self->{multiple}{labels}[$_]->configure(-text => $_) foreach @$
+init;
   }
   $self->{state} = 'normal';
} ## end sub reset

# Get the current state of the button, i.e. 'normal' (multiple choice
# status), 'fixed' (cells fixed by the user), 'starter' (cells contain
+ing
# starting hint).
sub get_state {
   return shift->{state};
}

# Remove a possible choice in the multiple view.
sub remove_option {
   my ($self, $value) = @_;
   return unless $self->get_state() eq 'normal';
   my $label = $self->{multiple}{labels}[$value];
   registered_toggle_label($label, $value)
     if $label->cget('-text') eq $value;
} ## end sub remove_option

1;
[download]

:normal
:normal
9:starter
:normal
:normal
8:starter
:normal
:normal
7:starter
3:starter
:normal
:normal
:normal
6:starter
:normal
:normal
:normal
:normal
:normal
:normal
:normal
3:starter
:normal
5:starter
1:starter
:normal
9:starter
1:starter
:normal
:normal
:normal
8:starter
:normal
9:starter
:normal
:normal
4:starter
:normal
:normal
:normal
2:starter
:normal
:normal
:normal
5:starter
:normal
:normal
6:starter
:normal
4:starter
:normal
:normal
:normal
2:starter
9:starter
:normal
4:starter
8:starter
:normal
1:starter
:normal
:normal
:normal
:normal
:normal
:normal
:normal
9:starter
:normal
:normal
:normal
4:starter
8:starter
:normal
:normal
7:starter
:normal
:normal
3:starter
:normal
:normal
[download]