Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

SuDoTKu - version 2

by polettix (Vicar)
on Aug 09, 2005 at 00:00 UTC ( #482071=sourcecode: print w/replies, xml ) Need Help??
Category: Fun Stuff
Author/Contact Info Flavio Poletti - frodo72
Description: If you liked SuDoTKu, you'll enjoy this! It's a substantial rewrite of the game interface, which is pretty good and usable now IMHO (you can see a snapshot here). The biggest defect is that it has quite a slow initialisation, due to the fact that there are many widgets.

There's a bare-bones help about the controls. Anyway, no more keyboard, but only mouse interaction; moreover, I eliminated right-buttons for Mac users (fixing a cell is now done with double-click on the choice).

If anyone knows how I can speed-up the initialisation process... please let me know!!!

#!/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;
Here comes a sample puzzle (#1898120598 from http://www.websudoku.com):
: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
Replies are listed 'Best First'.
Re: SuDoTKu - version 2
by zentara (Archbishop) on Aug 09, 2005 at 11:51 UTC
    If anyone knows how I can speed-up the initialisation process... please let me know!!!

    It would involve a total redesign, but you could switch to using a single canvas, and it would most likely speed things up. Instead of buttons, you could create little rectangles on the Canvas, and use bind on them to get the mouse action. If you planned it out right, you could make each "rectangle" an independent object to simplify their creation and keeping track of them.

    The single canvas could be popped up quickly on initialization, with a "loading game" message, while you create the cells.


    I'm not really a human, but I play one on earth. flash japh
      As you can see from the differences between the two versions... redesigning the whole thing does not scare me :)

      I have never used a Canvas (like most of the other Tk widgets, as a matter of fact) but from the few things I've read of it a doubt remains: how can I display a number in each single "little rectangle"? I'll have to dig...

      Flavio
      perl -ple'$_=reverse' <<<ti.xittelop@oivalf

      Don't fool yourself.
        The thing that is powerful, and a bit tricky to master, is the concept of tags. You can devise very intricate schemes with tags and hashes of objects. Here is the basic idea. The number is centered here, but I tagged it upper-left-corner, to show you that you can create multiple text objects in the rectangles and refer to them differently with tags, and raise. lower, configure to be hidden, etc.

        Your problem will be to find a way to reference the text creation points with respect to the location of the various rectangles on the canvas. It can all be done, maybe using 'groups' or make them independent objects, and do something like "my $cell{1}{'obj} = new Cell(-x=>$x,-y=>$y) in some sort of double loop to make your grid. Then all your need to do is make text points in the object, (or even a plain hash will do), and you can get them with syntax like $cell{2}{upper_left}, etc. Or if OO, $cell{2}->upper_left

        #!/usr/bin/perl use Tk; use strict; my $w=20; my $x=0; my $y=0; my %nums = ( 0 => ['black','yellow'], 1 => ['yellow','black'], 2 => ['white','green'], 3 => ['green','white'], 4 => ['grey','red'], 5 => ['red','grey'], 6 => ['blue','white'], 7 => ['white','blue'], 8 => ['orange','grey45'], 9 => ['grey45','orange'], ); my $mw=tkinit; my $c = $mw->Canvas->pack; for (0..9) { my $item=$c->createRectangle($x,$y,$x+20,$y+20, -fill=> ${$nums{$_}}[0], -tags => ['rect'] ); my $text = $c->createText($x+10,$y+10, -anchor=>'center', -fill => ${$nums{$_}}[1], -text => $_, -tags => ['num','upper-left-corner'] ); $x+=20; } $mw->Button( -text => "Hide Text", -command => sub { $c->lower('num','rect'); })->pack; $mw->Button( -text => "Show Text", -command => sub { $c->raise('num','rect'); })->pack; MainLoop;

        I'm not really a human, but I play one on earth. flash japh

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://482071]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others about the Monastery: (4)
As of 2020-09-30 00:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    If at first I donít succeed, I Ö










    Results (155 votes). Check out past polls.

    Notices?