Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

SuDoTKu

by polettix (Vicar)
on Jul 25, 2005 at 02:30 UTC ( #477660=sourcecode: print w/replies, xml ) Need Help??
Category: Fun Stuff
Author/Contact Info Flavio Poletti frodo72
Description: Enhanced version SuDoTKu - version 2

A small Tk application that will help you playing SuDoKu.

You can display up to 5 characters in any cell, to register possible values, and you can freeze a cell by right-clicking. Of course, you can only fix cells containing one digit.

During the game, you can check the board status with the "Check" button. This will check only fixed cells, so your guesses will not interphere.

If you're going to make guesses, you can "Push" the current status over a stack, and you can undo to that status with the "Pop" button. Yes, this is a macro undo.

If you provide a filename on the command line, the application will try to load it upon startup. You can click "Save" to save the current status, of course.

Exit will not ask you for confirmation, so "Save" before :)

How I use it: put the initial setup and freeze the cells, "Push" and start putting elements. When an element fits directly, I freeze it immediately, otherwise I put the different choiches inside the entry. From time to time I hit "Check" just to be sure I'm on the correct track.

The file format is simple. Cells are saved one element per file line, by row. Each element has two parts: the value inside the cell, and the status, which can be "starter", for fixed cells that form the starter grid, "fixed" and "normal", with obvious meaning (ok, the first is for fixed cells, the second for those cells you can edit).

Update: modified the readonly into disabled as per jbrugger's suggestion. The look-and-feel should be the same anyway - a fixed entry is blue and bold.

Update: removed silly bug, changed relief for fixed cells, translated check messages into english.

Update: removed bug with push/pop. Added support for "starter". Added file format.

#!/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. Added version thanks to dree

use strict;
use warnings;

use Tk;
use Tk::Dialog;

######## GLOBAL VARIABLES ###########################################
# Version
my $VERSION = 0.03;

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

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

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

# Different options for fixed cells (disabled) and normal ones
# These are the different visualisations for the two states of a
# cell: normal (editable) and disabled (i.e. "fixed").
my %opts = (
   'normal' => {
      -font    => 'normal',    # Will create this font later
      -justify => 'left',
      -relief => 'sunken',
      -state  => 'normal',
   },
   'fixed' => {
      -font    => 'fixed',    # Will create this font later
      -justify => 'center',
      -relief => 'groove',
      -state  => 'disabled',
   },
   'starter' => {
      -font    => 'starter',    # Will create this font later
      -justify => 'center',
      -relief => 'groove',
      -state  => 'disabled',
   },
);

# Map of game info
my @map;

# Commands for undo support
my @commands;

# Frames for different 3x3 subframes
my @chunks;

# Signal if we're inside an undo sequence, just to avoid having
# the undo commands be re-pushed inside the command stack.
my $undoing;

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

# 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 => 4);
      $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) {

      # Each element is compound of three items: the contents of the
      # Entry widget, the state (normal = editable, disabled = fixed),
      # and a reference to the cell itself for later modifications.
      $map[$i][$j] = ['', 'normal', undef];
      my $cell = $chunks[$i / 3][$j / 3][$i % 3]->Entry(
         -width              => 4,
         -textvariable       => \$map[$i][$j][0],
         -validate           => 'key',
         -validatecommand    => [\&validate, $i, $j],
         -font               => 'normal',
         -disabledforeground => 'blue',
      );
      $map[$i][$j][2] = $cell;

      # Clicking with the right mouse button toggles state if applicab
+le
      # You cannot fix cells that are empty or contain more than one
      # character, of course.
      $cell->bind(
         "<Button-3>",
         sub {
            my $cstate = $map[$i][$j][1];
            return if $cstate eq 'starter';

            # Invert the state only if cell contains a single digit
            $cstate = ($cstate eq 'normal' ? 'fixed' : 'normal')
              if (defined $map[$i][$j][0] && $map[$i][$j][0] =~ /^\d$/
+);

            # Call ad-hoc function, refactored code
            set_state($i, $j, $cstate);
         }
      );
      $cell->pack(-side => 'left');
   } ## end for my $j (0 .. 8)
} ## end for my $i (0 .. 8)

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

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

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

# Undo handling. Push pushes a marker into the command stack, which
# will be the stopping point for a canned sequence of later pops.
$bottom->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.
$bottom->Button(
   -text    => 'Pop',
   -command => sub {
      $undoing = 1;
      while (my $aref = pop @commands) {
         my ($i, $j, $type, $v) = @$aref;
         if ($type eq 'value') {
            $map[$i][$j][0] = $v;
         }
         else {
            set_state($i, $j, $v);
         }
      }
      $undoing = 0;
   }
)->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 {
      $checkLabel = (check() ? "All ok!" : "Check out errors!");
      $checkDialog->Show();
   }
)->pack(-side => 'left');

# If a filename was provided, saves the board into that file.
$bottom->Button(-text => 'Save', -command => sub { save($filename) })
  ->pack(-side => 'left');

# Exit from the game. No "are you sure" messages are shown :)
$bottom->Button(-text => 'Exit', -command => sub { exit 0 })
  ->pack(-side => 'left');

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

# Fire!
MainLoop();

# Set the state of a cell. It is expected to receive the coordinates
# of the element, and the state to set, which can be 'disabled' or
# 'normal'.
sub set_state {
   my ($i, $j, $cstate) = @_;
   my $cell = $map[$i][$j][2];
   $cell->configure($_ => $opts{$cstate}{$_}) for keys %{$opts{$cstate
+}};
   $cell->configure( -disabledforeground => 'darkred') if $cstate eq '
+starter';
   push @commands, [$i, $j, state => $map[$i][$j][1]] unless $undoing;
   $map[$i][$j][1] = $cstate;
} ## end sub set_state

# Validate input. Accept only digits between 1 and 9. If ok, push a
# command inside the queue.
sub validate {
   my ($i, $j, $current, $key, $old) = @_;
   return 1 unless defined $key;        # No key is good enough
   return 0 unless $key =~ /^[1-9]$/;

   # Accept the command, and push it into the undo queue
   push @commands, [$i, $j, value => $old] unless $undoing;
   return 1;
} ## end sub validate

# 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 ($v, $aref) = @_;
   return 1 if $v->[1] eq 'normal';
   $v = $v->[0];
   return 1 unless defined $v;
   return 1 unless $v =~ /^(\d)(\D)?/;
   return 0 if $aref->[$1];
   $aref->[$1] = 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) {
            print $fh @{$map[$i][$j]};
         }
      }
   } ## 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 /:/, $_;
         $map[$i / 9][$i % 9][0] = $f;
         set_state($i / 9, $i % 9, $s);
      } ## end while (<$fh>)
   } ## end if (open my $fh, "<", ...
   else {
      warn "open($filename): $!";
   }
} ## end sub load
Replies are listed 'Best First'.
Re: SuDoTKu
by jbrugger (Parson) on Jul 25, 2005 at 04:33 UTC
    Nice!
    Only that i did not know the game, it gives a better idea on how to use Tk and Perl.
    One issue: i got a Tk::Error: bad state value "readonly": must be normal or disabled at test.pl line 177. when pressing the right button to 'lock' a cell, so i had to %s/readonly/disabled/g to make it work on my debian machine.

    "We all agree on the necessity of compromise. We just can't agree on when it's necessary to compromise." - Larry Wall.
      I used Tk version 804.026, which should be the latest according to CPAN.

      Anyway, I updated the code above using disabled instead of readonly. I also set the -disabledforeground to blue, to preserve the original look for the fixed entries (light gray is too difficult to read IMHO).

      Thanks for the feedback!

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

      Don't fool yourself.
        The latest version of Tk is 804.027

        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://477660]
help
Chatterbox?
and the web crawler heard nothing...

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










    Results (142 votes). Check out past polls.

    Notices?