>
**Introduction**
[David Easton] ''05 Jan 2005''
'''Sudoku''' is a puzzle included in '''The Times''' newspaper in the UK since November 2004. <
>
The rules are extremely simple: In a 3x3 grid of boxes, each with 3x3 cells,
fill in the digits 1..9 so that each digit occurs exactly once in each row, column, and box.
I have written a tool in Tcl that allows:
* Sudoku puzzles to be generated
* Sudoku puzzles to be played
* Sudoku puzzles to be solved
[DPE] ''20 Nov 2007'' Version 1.9b is available as a [Starpack] for Windows.
[http://www.easton.me.uk/sudoku/images/screen2.gif]
[http://www.easton.me.uk/sudoku/images/screen4.gif]
[DPE] ''12 May 2006'' Version 1.6a is available as a [Starpack] for Windows, Mac OS X and Linux.
It allows 9x9 sudoku puzzles to be created, played and solved. Register the software if you want additional puzzle sizes and puzzle types. There have been numerous enhancements since the 0.7 version.
[DPE] ''25 Feb 2005'' Version 0.7 has been released as a Tcl/Tk starkit with no compiled extensions -
this may be freely examined and extended as long as it isn't for commercial use.
[WikiDbImage sudoku.jpg]
It is freely available from: http://www.easton.me.uk/sudoku/index.html
----
[LV] http://en.wikipedia.org/wiki/Sudoku is an interesting resource, and talks about more of the history of the puzzle genre. I hadn't realized that these types of puzzles had been popular for so many years.
----
'''Sp!''' ''8th March 2005'' Thank you!!! I have been addicted to these puzzles for a while now and
this is just brilliant. I generate half a dozen gifs and paste them into word to take to work with me.
Took a little searching to find this wiki (found your home page first) but very glad I did.
[AvL] ''March 21th 2005'': I join in to this praising. Anyway, I've also made some changes to
my copy: changed gray and darkgrey both to blue (grey was too little contrast on my monitor),
and I made bind'ings for digit-keys to invoke the respective button. Also, I've made the cells
larger (from 25 to 35) and changed the buttons from image to penfont-text (-width 2).
I've got some more "feature"-requests:
* undo (at least one level: I often write a number to wrong cell, then have to erase it and try to restore what was in the cell before. ([DPE] This is now available)
* shading complete lines/rows/boxes (optionally)
* right-click on buttons should toggle a disabled-state, so I can visually mark the digits that have already been placed 9 times. Upon new game or clear board, all shall be enabled. ([DPE] Buttons are now automatically coloured when all digits have been placed)
* reset to current game: just remove all gray (blue) numbers, but leave the black ones. ([DPE] This is now available)
These features do not give more extra help, than what one could do on paper.
Plus another feature that *does* exceed the possibilities on paper:
* optionally do auto-check after each big digit. ([DPE] This is now available)
I've not yet understood the prog well enough to implement these goodies myself.
[DPE] ''21 April 2005'' I've only just noticed the above posts. Thanks for the positive feedback. Now that you've set me a challenge, I'll see if I can find some time to do some more improvements!
----
David,
I am intending to port this to Mac OS X as a self-contained file, such that it can be simply double-clicked by the most ignorant of users. I couldn't find your email anywhere to obtain your permission to do so.
If you have any qualms about this, please post them to this site.
Thanks,
Dan Schellenberg
[DPE] ''21 April 2005'' Dan, feel free to use this as you wish - just reference this page or my web site somewhere. I can put a MAC executable on my web site if you think it would be of interest.
[RAF] "21 August 2005" It would be nice for the MAC executable to be hosted here -
meanwhile, it is on Dan's site here [http://www.educationaltechnology.ca/dan/archives/2005/04/22/sudoku-aka-su-doku-generator-and-solver-for-mac-os-x/]
[PT] 19-May-2005: Very cool!!
[RJ] 19-May-2005: VC indeed. David, I suggest that this starkit be included under Games at [sdarchive]. Very nice work.
[DPE] ''27 May 2005'' Thanks. I'll soon release version 0.8 that allows a page of puzzles
to be created as a PDF document - I'll try to get around to adding it to [sdarchive] at that time.
----
See also [Playing sudoku] for some mathematical musings. [http://wiki.tcl.tk/_repo/wiki_images/sudoku.tcl]
is a compaction of v 0.7 (single Tcl file, no image loading or saving) tweaked to run on the [iPaq].
[http://wiki.tcl.tk/_repo/wiki_images/sudoku-ce.jpg]
----
[ABU] 10-sep-2005
Based on the original work of Dave (v 0.7), this my variant (v. 0.7.1) comes with a different,
and I believe more comfortable, user interface. ...
!!!!!!
[Image sudoku071]
!!!!!!
Sudoku 0.7.1 is provided in 3 different distributions:
* [https://sourceforge.net/projects/irrational-numbers/files/sudoku-0.7.1.zip/download%|%sudoku.zip%|%] - pure tcl-code (for any TclTk platform) - unzip and run sudoku.vfs/main.tcl
* [https://sourceforge.net/projects/irrational-numbers/files/sudoku-0.7.1.kit/download%|%sudoku.kit%|%] - Starkit archive (TclKit required)
* [https://sourceforge.net/projects/irrational-numbers/files/sudoku-0.7.1.exe/download%|%sudoku.exe%|%] - .exe Windows executable (no installation is required)
----
28-Nov-2005, on [comp.lang.tcl%|%clt] Bernard Desgraupes announced a sudoku solver.
(bernard-01-12-2005) It is a command line sudoku solver written in Tcl and named [sudokut].
There is no GUI: just pass the sudoku 81 chars string as an argument to the ''sudokut'' command.
Alternatively you can pass a sudoku file (one sudoku string per line) with the -f option to have all the sudokus in this file solved. There are several options.
Internally it implements an exact cover algorithm based on D. [Knuth]'s dancing links strategy.
This guarantees to find all the solutions.
I have also put the code on SourceForge [http://sourceforge.net/projects/sudokut/].
For instance:
shell> sudokut ...3..8..64.8...5.875.....15...7.2.6....9....2.9.8...54.....769.2...8.13..7..5...
Found 1 solution
Solution 1:
-----------------------
| 1 9 2 | 3 5 6 | 8 4 7 |
| 6 4 3 | 8 1 7 | 9 5 2 |
| 8 7 5 | 4 2 9 | 6 3 1 |
|-------|-------|-------|
| 5 8 4 | 1 7 3 | 2 9 6 |
| 7 6 1 | 5 9 2 | 3 8 4 |
| 2 3 9 | 6 8 4 | 1 7 5 |
|-------|-------|-------|
| 4 5 8 | 2 3 1 | 7 6 9 |
| 9 2 6 | 7 4 8 | 5 1 3 |
| 3 1 7 | 9 6 5 | 4 2 8 |
-----------------------
(GWM) NB the main tool described on this page solves in a WYSIWIG manner a sudoku set to it.
I also pondered how many games of Sudoku there could be.
For example, suppose there is a Sudoku puzzle that is solvable;
the following operations make the original puzzle look different
but actually leave the puzzle the same:
* swap any 2 rows in the top 3 rows (the columns have all 9 numbers, the rows are unchanged)
* swap any 2 rows in the middle 3 rows
* and of course swap 2 rows in the bottom 3 rows.
Each of these 3 operations can be done in 6 different ways (choice of 3 first rows, 2 second = 3*2).
So the 3 operations can be done in 216 (6^3) ways.
The 3 big rows of 3 can also be placed in any order (top/mid/bottom; top/bottom/mid; mid/top/bottom; .... another 6 ways).
Thus there are 6*216=1296 different puzzles just by swapping the rows of numbers.
You can do the same operations with columns (swap any 2 columns in each group of 3),
and sort left/right/middle column groups.
Giving 1296 permutations of the columns times 1296 permutations of the rows -
over 1 million topologically identical puzzles.
I haven't included the option of changing all the 1s to 2s and 2s to 1s
(9! further operations, possibly 362880 million puzzles)
since I suspect we will be double counting some of the puzzles.
So the compilers of puzzles only need 1 original puzzle and can spend the rest
of their days (4600 years including leap days) regurgitating the same puzzle
just passing it through a random swapping sieve.
----
[LV] May 11, 2006 - I've been seeing alphabetic sudoku around (TV Guide, for instance)
and wondered whether numerics were so intrinsic to these applications
that one would have to start over from scratch to build a version for other "sets" of entities.
[DPE] May 11, 2006 - The registered version of Sudoku Puzzle Generator does Alphadoku and
Alphadoku X which is alphabetic sudoku.
There is nothing special about alphabetic sudoku as 1-9 can just be translated
to A-I on the user interface.
It also does Sudoku X, Irregular Sudoku, Killer Sudoku and Killer Sudoku X in various sizes.
----
For comparison: Christian Neukirchen's solver in Prolog:
[http://chneukirchen.org/blog/#x-20051117-160643] and
[http://chneukirchen.org/repos/blogcode/sudoku.pl].
----
[uniquename] 2013aug02
Thanks to Buratti for providing the download links above. I work on Linux without the starkit components at my disposal, so I found the zip file most useful (rather than the Windows executable or the starkit).
Here are several images that come from that 'unrestricted' 0.7.1 version.
[easton-buratti_sudoku0-7-1_aboutWindow_screenshot_423x188.jpg]
[easton-buratti_sudoku0-7-1_grid_screenshot_453x503.jpg]
This image was created by running the 'Generate' and 'Solve' options of the 'Game' drop-down menu.
[easton_sudoku071_helpWindow_screenshot_532x517.jpg]
I know I would have appreciated having the Sudoku 0.7.1 code merged into one file for easy download. So here is a single merged file of source --- with the 10 small GIF files that are needed shown below this source. Right-click and SaveAs to download those GIF's.
**Discussion**
<>
[RLE] (2013-08-02): If you really want a single source file, you can pack the tiny images directly into the source. The "-data" parameter for Tk images accepts a base64 string and will internally decode the string into an image. For the 10 tiny Gif's, they could all be included directly in the source instead of in 10 tiny external files.
[uniquename] 2013aug03: I am well aware of the base64 technique.
Vetter used it over-and-over in his various Solitaire games, for the card images.
But he generated some concern from certain people about those same 52-plus data groups appearing over-and-over on about 10 different pages on this wiki.
Although the GIF files actually take about as much space on this wiki as the base64 data lines, at least the code looks more compact without all the base64 data in it --- and hence I am less likely to draw heat from people who do not like to see all that base64 data in code on this wiki --- especially if it is repeated on various Sudoku pages on this wiki.
<>
------
**Program sudoku.tk**
<>Code for Tk script 'sudoku.tk' :
======
#!/usr/bin/wish
##
## SCRIPT: sudoku.tk
##
## Sudoku 0.7.1 by David Easton, 2005
## with user interaction changes by Aldo Buratti
##
## This Buratti-version was downloaded in 2013 August from
## https://irrational-numbers.googlecode.com/files/sudoku-0.7.1.zip
## which is the link that Buratti placed on the wiki page
## http://wiki.tcl.tk/13272 - 'Sudoku'.
##
## Four '.tcl' files were merged into one script by B. Montandon 2013aug02.
## The 10 GIF files that are referenced below can be found on the
## wiki.tcl.tk/13272 page. Download them into an 'images' subdirectory
## of the directory where this script was downloaded.
####################################################################
namespace eval sudoku {
variable S
set S(preDone) 0
set S(afterIds) [list]
# some constants
set S(fixedNumberColor) black
set S(userNumberColor) darkgrey
set S(smallNumberColor) grey
set S(wheelFgColor) darkblue
set S(wheelBgColor) white
set S(normalCellBg) white
set S(errorCellBg) red
set S(selectedCellBg) grey90
set S(gridLinesColor) black
}
################################################################################
# Generating an image of the puzzle
################################################################################
proc sudoku::generatePuzzleImage {} {
variable S
set puzImg [image create photo]
# Copy the blank grid
$puzImg copy $S(img,grid) -shrink
# Add numbers as appropriate
foreach col [list 1 2 3 4 5 6 7 8 9] {
foreach row [list 1 2 3 4 5 6 7 8 9] {
set val [getVal $col $row]
if {$val >= 1 && $val <= 9} {
set x [expr {$col * 25 - 18}]
set y [expr {$row * 25 - 19}]
$puzImg copy $S(img,$val) -to $x $y
}
}
}
return $puzImg
}
proc sudoku::saveImage {} {
variable S
set types {{"Image Files" {.gif}}}
set filename [tk_getSaveFile -filetypes $types \
-initialfile sudoku.gif \
-defaultextension .gif \
-parent $S(w:top)]
if { $filename != {} } {
set image [generatePuzzleImage]
$image write -format gif $filename
image delete $image
}
}
################################################################################
# Pencil marks
################################################################################
proc sudoku::clearPen {row col} {
variable S
$S(w:c) itemconfigure $S(idp1:$row,$col) -text ""
$S(w:c) itemconfigure $S(idp2:$row,$col) -text ""
}
proc sudoku::getPen {row col} {
variable S
set p1 [$S(w:c) itemcget $S(idp1:$row,$col) -text]
set p2 [$S(w:c) itemcget $S(idp2:$row,$col) -text]
return [split "$p1$p2" ""]
}
proc sudoku::setPen {row col penList} {
variable S
set penList [lsort $penList]
$S(w:c) itemconfigure $S(idp1:$row,$col) -text [join [lrange $penList 0 2] ""]
$S(w:c) itemconfigure $S(idp2:$row,$col) -text [join [lrange $penList 3 5] ""]
}
proc sudoku::togPen {row col num} {
variable S
if { $num < 1 || $num > 9 } {
return
}
set penList [getPen $row $col]
if {[set i [lsearch $penList $num]] == -1} {
lappend penList $num
} else {
set penList [lreplace $penList $i $i]
}
setPen $row $col $penList
}
################################################################################
# Sudoku Generation
################################################################################
proc sudoku::choose {list} {
return [lindex $list [expr {int(rand() * [llength $list])}]]
}
# Merge puzzle and mask
proc sudoku::merge {p m} {
set l [list]
foreach yp $p ym $m {
set yl [list]
foreach ep $yp em $ym {
if {$em} {
lappend yl $ep
} else {
lappend yl " "
}
}
lappend l $yl
}
return $l
}
# Used to generate a puzzle in advance for faster
# response when generate button is clicked
proc sudoku::bgGen {args} {
variable S
foreach afterId $S(afterIds) {
catch {after cancel $afterId}
}
set S(afterIds) [list]
if {$S(preDone) == 0} {
# First make a finished puzzle
set p [sudoku-create::start]
# Now make a mask (use value of 30 for hard, 36 for easy)
switch $S(level) {
"Easy" {
set min 34
set max 36
}
"Medium" {
set min 30
set max 34
}
"Hard" {
set min 26
set max 32
}
default {
set min 24
set max 36
}
}
set m [sudoku-mask::generate $p $min]
set solvable 0
while {$solvable == 0} {
# Apply the mask
set l [merge $p $m]
# See if it is solveable
foreach {res solveList} [sudoku-solve::solve $l] {break}
if { $res } {
set solvable 1
} else {
set maxlen 1
set sqList [list]
foreach row $solveList x [list 1 2 3 4 5 6 7 8 9] {
foreach entry $row y [list 1 2 3 4 5 6 7 8 9] {
set len [llength $entry]
if {$len > $maxlen} {
set maxlen $len
set sqList [list $y,$x]
} elseif {$len == $maxlen} {
lappend sqList $y,$x
}
}
}
#puts $sqList
set sq [choose $sqList]
#puts "Chose $sq from $sqList"
set m [sudoku-mask::easier $sq]
if { [sudoku-mask::numvis] > $max } {
break
}
}
}
if {$solvable == 1} {
set S(preDone) 1
set S(prePuz) $l
} else {
lappend S(afterIds) [after 200 sudoku::bgGen]
update
}
}
}
proc sudoku::generate {} {
variable S
set count 1
clear
$S(w:top) configure -cursor watch
update
# Use prebuilt puzzle if one is ready
if {$S(preDone) == 1} {
set l $S(prePuz)
} else {
# First make a finished puzzle
set p [sudoku-create::start]
# Now make a mask (use value of 30 for hard, 36 for easy)
switch $S(level) {
"Easy" {
set min 34
set max 36
}
"Medium" {
set min 30
set max 34
}
"Hard" {
set min 26
set max 32
}
default {
set min 24
set max 36
}
}
set m [sudoku-mask::generate $p $min]
set solvable 0
while {$solvable == 0} {
# Apply the mask
set l [merge $p $m]
#fromList $l
# See if it is solveable
foreach {res solveList} [sudoku-solve::solve $l] {break}
if { $res } {
set solvable 1
} else {
set maxlen 1
set sqList [list]
foreach row $solveList x [list 1 2 3 4 5 6 7 8 9] {
foreach entry $row y [list 1 2 3 4 5 6 7 8 9] {
set len [llength $entry]
if {$len > $maxlen} {
set maxlen $len
set sqList [list $y,$x]
} elseif {$len == $maxlen} {
lappend sqList $y,$x
}
}
}
#puts $sqList
set sq [choose $sqList]
#puts "Chose $sq from $sqList"
set m [sudoku-mask::easier $sq]
if { [sudoku-mask::numvis] > $max } {
set p [sudoku-create::start]
set m [sudoku-mask::generate $p $min]
}
#puts "NUMBER VISIBLE = [sudoku-mask::numvis]"
incr count
}
#update
}
}
fromList $l
#puts "$count attempts"
#puts "NUMBER VISIBLE = [sudoku-mask::numvis]"
colour
# Now make a new one in the background
set S(preDone) 0
$S(w:top) configure -cursor arrow
lappend S(afterIds) [after 500 sudoku::bgGen]
}
proc sudoku::colour {} {
variable S
set S(fixedList) [list]
foreach col [list 1 2 3 4 5 6 7 8 9] {
foreach row [list 1 2 3 4 5 6 7 8 9] {
set val [getVal $col $row]
if {$val == " "} {
$S(w:c) itemconfigure $S(idt:$col,$row) -fill $S(userNumberColor)
} else {
lappend S(fixedList) "$col,$row"
}
}
}
}
proc sudoku::solve {} {
variable S
set l [toList]
colour
foreach {res solution} [sudoku-solve::solve $l] {break}
fromList $solution
}
################################################################################
# Clearing
################################################################################
proc sudoku::clear {} {
variable S
set S(fixedList) [list]
foreach col [list 1 2 3 4 5 6 7 8 9] {
foreach row [list 1 2 3 4 5 6 7 8 9] {
setVal $col $row " "
$S(w:c) itemconfigure $S(idt:$col,$row) -fill $S(fixedNumberColor)
clearPen $col $row
}
}
check
}
proc sudoku::checkSquare {col row} {
variable S
set val [getVal $col $row]
set ok true
if { $val >= 1 && $val <= 9 } {
# Check row
foreach nc [list 1 2 3 4 5 6 7 8 9] {
if {$nc == $col} {continue}
if {$val == [getVal $nc $row]} {
set ok false
}
}
# Check column
foreach nr [list 1 2 3 4 5 6 7 8 9] {
if {$nr == $row} {continue}
if {$val == [getVal $col $nr]} {
set ok false
}
}
# Check box
foreach rowList {{1 2 3} {4 5 6} {7 8 9}} {
if {[lsearch $rowList $row] != -1} {break}
}
foreach colList {{1 2 3} {4 5 6} {7 8 9}} {
if {[lsearch $colList $col] != -1} {break}
}
foreach nc $colList {
foreach nr $rowList {
if {$nc == $col && $nr == $row} {continue}
if {$val == [getVal $nc $nr]} {
set ok false
}
}
}
}
if {$ok} {
$S(w:c) itemconfigure $S(idr:$col,$row) -fill $S(normalCellBg)
} else {
$S(w:c) itemconfigure $S(idr:$col,$row) -fill $S(errorCellBg)
}
return $ok
}
proc sudoku::check {} {
variable S
# Check each row
foreach row [list 1 2 3 4 5 6 7 8 9] {
foreach col [list 1 2 3 4 5 6 7 8 9] {
checkSquare $col $row
}
}
#after checking, the current cell is cleared
set S(currR) -1
set S(currC) -1
}
################################################################################
# Clicking etc.
################################################################################
proc sudoku::getVal {col row} {
variable S
return $S(v:$col,$row)
}
proc sudoku::setVal {col row val} {
variable S
set S(v:$col,$row) $val
$S(w:c) itemconfigure $S(idt:$col,$row) -text $S(v:$col,$row)
}
proc sudoku::clickLeft {col row} {
variable S
## if it is not a fixed cell
if {[lsearch $S(fixedList) "$col,$row"] == -1} {
if { $S(currR) != -1 } {
$S(w:c) itemconfigure $S(idr:$S(currC),$S(currR)) -fill $S(normalCellBg)
checkSquare $S(currC) $S(currR)
}
set S(currR) $row
set S(currC) $col
wheel-moveto $col $row
wheel-open 5 38
after 1
$S(w:c) itemconfigure $S(idr:$S(currC),$S(currR)) -fill $S(selectedCellBg)
}
}
################################################################################
# Utility functions
################################################################################
proc sudoku::toList {} {
set l [list]
foreach col [list 1 2 3 4 5 6 7 8 9] {
set lc [list]
foreach row [list 1 2 3 4 5 6 7 8 9] {
lappend lc [getVal $col $row]
}
lappend l $lc
}
return $l
}
proc sudoku::fromList {l} {
set col 0
foreach column $l {
incr col
set row 0
foreach entry $column {
incr row
if {[llength $entry] == 1} {
setVal $col $row $entry
} else {
setVal $col $row " "
}
}
}
}
proc sudoku::closeDown { win } {
destroy $win
exit
}
################################################################################
# Draw the board
################################################################################
proc sudoku::drawBoard {c cellsize} {
variable S
set w $cellsize
set h $cellsize
set hw [expr {$w / 2}]
set hh [expr {$h / 2}]
# offset (border) should be enough to display the numeric-input wheel;
# Set offset equal to a cellsize (or greater than)
set offx $cellsize
set offy $cellsize
# Each square
foreach col [list 1 2 3 4 5 6 7 8 9] {
foreach row [list 1 2 3 4 5 6 7 8 9] {
set x2 [expr {$col * $w + $offx}]
set x1 [expr {$x2 - $w}]
set y2 [expr {$row * $h + $offy}]
set y1 [expr {$y2 - $h}]
set xm [expr {$x1 + $hw}]
set ym [expr {$y1 + $hh}]
set idr [$c create rectangle $x1 $y1 $x2 $y2 -outline $S(gridLinesColor) -fill $S(normalCellBg) -width 1]
set idp1 [$c create text [expr {$x1+3}] $y1 -anchor nw -text "" -font penfont -fill $S(smallNumberColor)]
set idp2 [$c create text [expr {$x1+3}] $y2 -anchor sw -text "" -font penfont -fill $S(smallNumberColor)]
set idt [$c create text $xm $ym -anchor c -text " " -font numfont]
set S(idr:$col,$row) $idr
set S(idt:$col,$row) $idt
set S(idp1:$col,$row) $idp1
set S(idp2:$col,$row) $idp2
foreach id [list $idr $idt $idp1 $idp2] {
$c bind $id [list sudoku::clickLeft $col $row]
# ??? $c bind $id [list sudoku::clickRight $col $row]
}
}
}
set maxx [expr {$x2 + $offx}]
set maxy [expr {$y2 + $offy}]
# Each box
foreach bx [list 0 1 2] {
foreach by [list 0 1 2] {
set x1 [expr {$bx * 3 * $w + $offx}]
set x2 [expr {$x1 + 3 * $w}]
set y1 [expr {$by * 3 * $h + $offy}]
set y2 [expr {$y1 + 3 * $h}]
$c create rectangle $x1 $y1 $x2 $y2 -outline $S(gridLinesColor) -width 3
}
}
return [list $maxx $maxy]
}
################################################################################
# Building the UI
################################################################################
proc sudoku::buildWindow {win} {
variable S
font create penfont -family {Comic Sans MS} -size 8
font create numfont -family {Comic Sans MS} -size 16 -weight bold
set S(num) 1
set c [canvas $win.c]
set cellsize 40
foreach {x y} [drawBoard $c $cellsize] {break}
$c configure -width $x -height $y
grid $c -sticky {} -padx 5 -pady 5
set S(level) "Easy"
set S(w:top) $win
set S(w:c) $c
clear
wm resizable $win 0 0
focus $c
bind $c [list sudoku::checkKeyPress %K]
bind $c [list sudoku::checkControlKeyPress %K]
# expr is the radius of the circle surroundind the cell
sudoku::wheel-create $c [expr $cellsize/2*sqrt(2)]
}
###################################################
# aboutBox
#
# Display an about box
###################################################
proc sudoku::aboutBox { w } {
set message "Sudoku v0.7.1\n"
append message "(c) David Easton, 2005\n\n"
append message "User Interaction redesigned by Aldo Buratti\n\n"
append message "Written in Tcl/Tk"
tk_messageBox -icon info \
-title "About" \
-type ok \
-parent $w \
-message $message
}
###################################################
# Function: help
#
# Description: Shows help text for sudoku
###################################################
proc sudoku::help {} {
catch {destroy .help}
toplevel .help
wm title .help "Sudoku Help"
set t [text .help.t -relief raised -wrap word -width 70 -height 28 \
-padx 10 -pady 10 -cursor {} -yscrollcommand {.help.sb set}]
set sb [scrollbar .help.sb -orient vertical -command [list $t yview]]
set btnOK [button .help.btnOK -text OK -width 8 -command {destroy .help}]
pack $btnOK -side bottom -pady 10
pack $sb -side right -fill y
pack $t -side top -expand 1 -fill both
set bold "[font actual [$t cget -font]] -weight bold"
set italic "[font actual [$t cget -font]] -slant italic"
$t tag config title -justify center -foregr red -font "Arial 20 bold"
$t tag configure title2 -justify center -font "Arial 12 bold"
$t tag configure bullet -font $bold
$t tag configure n -lmargin1 15 -lmargin2 15
$t tag configure nc -justify center
$t tag configure ital -font $italic
$t insert end "Sudoku\n" title
$t insert end "by David Easton\n\n" title2
set m "To solve a Sudoku puzzle, every digit from 1 to 9 must appear in:\n
* Each of the nine vertical columns\n
* Each of the nine horizontal rows\n
* Each of the nine boxes\n\n"
$t insert end "Rules\n" bullet $m n
set m "Start a new game using Game->Generate\n\n"
$t insert end "Starting a new game\n" bullet $m n
set m "The level can be changed under the Options menu.\n\n"
$t insert end "Changing the level\n" bullet $m n
$t insert end "Inserting a number\n" bullet \
"Select a cell and then enter a digit (or space to delete).\n
You can use the numeric wheel or the keyboard.\n
If key is pressed, the selected number will be drawn as an annotation" \
n
$t config -state disabled
}
###################################################
# buildMenus
#
# Build menus for toplevel w
###################################################
proc sudoku::buildMenus { w } {
variable S
menu $w.menu -tearoff 0
set Menu(main) $w.menu
set m $w.menu.game
set Menu(game) $m
menu $m -tearoff 0
$w.menu add cascade -label "Game" -menu $m -underline 0
$m add command -label "Generate" -command [list sudoku::generate]
$m add command -label "Solve" -command [list sudoku::solve]
$m add command -label "Check" -command [list sudoku::check]
$m add separator
$m add command -label "Save Image" -command [list sudoku::saveImage]
$m add command -label "Clear" -command [list sudoku::clear]
$m add separator
$m add command -label "Exit" -command [list sudoku::closeDown $w]
set m $w.menu.opts
set Menu(opts) $m
$w.menu add cascade -label "Options" -menu $m
menu $m -tearoff 0
set m $w.menu.opts.level
$w.menu.opts add cascade -label "Level" -menu $m
menu $m -tearoff 0
set levList [list "Easy" "Medium" "Hard"]
foreach lev $levList {
$m add radio -label "$lev" \
-variable sudoku::S(level) \
-value $lev \
-command "set sudoku::S(preDone) 0;sudoku::bgGen"
}
set m $w.menu.help
set Menu(help) $m
$w.menu add cascade -label "Help" -menu $m
menu $m -tearoff 0
$m add command -label "Help" -command [list sudoku::help]
$m add command -label "About" -command [list sudoku::aboutBox $w]
#$m add separator
#$m add command -label "Show Console" -command "console show"
$w configure -menu $w.menu
}
###################################################
# readImages
#
# Read the images
###################################################
proc sudoku::readImages { } {
variable S
set S(img,grid) [image create photo -file ./images/sudoku_grid.gif]
foreach num [list 1 2 3 4 5 6 7 8 9] {
set S(img,$num) [image create photo -file ./images/sudoku_$num.gif]
}
set S(img,blank) [image create photo -width 15 -height 17]
}
#--- Numeric Wheel for input ------------------------
proc sudoku::checkKeyPress {val} {
variable S
if { $S(currC) == -1 } return
if { $val == "space" } { set val " " }
if { [string first $val "123456789 "] != -1 } {
wheel-close
setVal $S(currC) $S(currR) $val
clearPen $S(currC) $S(currR)
checkSquare $S(currC) $S(currR)
}
}
proc sudoku::checkControlKeyPress {val} {
variable S
if { $S(currC) == -1 } return
if { $val == "space" } { set val " " }
if { [string first $val "123456789 "] != -1 } {
togPen $S(currC) $S(currR) $val
}
}
# R is the 'inner' radius of the wheel
proc sudoku::wheel-create {cvs R} {
variable S
set S(wheelXc) 0
set S(wheelYc) 0
set pi [expr acos(0)*2]
# degree-to-radiant conversion factor
set d2r [expr $pi/180.0]
set halfAlfa [expr (360/10)/2*$d2r]
set r [expr $R*sin($halfAlfa)/(1-sin($halfAlfa))]
set keys [list space 1 2 3 4 5 6 7 8 9]
for { set alfa -90; set idx 0 } { $idx <= 9 } { incr alfa 36; incr idx } {
set x [expr ($R+$r) * cos($alfa*$d2r)]
set y [expr ($R+$r) * sin($alfa*$d2r)]
set key [lindex $keys $idx]
# pseudo-shadow
$cvs create oval [expr $x-$r] [expr $y-$r] [expr $x+$r] [expr $y+$r] \
-fill grey80 -outline {} -tag [list numctrl shadow]
$cvs create oval [expr $x-$r] [expr $y-$r] [expr $x+$r] [expr $y+$r] \
-fill $S(wheelBgColor) -outline $S(wheelFgColor) \
-tag [list numctrl oval val_$key]
# NOTE: set disabled state, so that state "numbers" cannot be selected.
$cvs create text $x $y -text $key -tag [list numctrl text val_$key] \
-state disabled -fill $S(wheelFgColor)
$cvs bind val_$key <1> \
[list event generate $cvs -keysym $key]
$cvs bind val_$key \
[list event generate $cvs -keysym $key]
}
# shift shadow and put them under the ovals
$cvs move numctrl&&shadow 2 2
$cvs lower shadow&&numctrl numctrl&&oval
# touch 0th oval display
$cvs itemconfigure numctrl&&text&&val_space -text "X"
$cvs bind oval [list $cvs itemconfigure current -fill $S(selectedCellBg)]
$cvs bind oval [list $cvs itemconfigure current -fill $S(normalCellBg)]
# hide it
$cvs itemconfigure numctrl -state hidden
set S(outerRadius) [expr $R+2*$r]
}
proc sudoku::wheel-destroy {} {
variable S
$S(w:c) delete numctrl
}
proc sudoku::wheel-movetoXY {x y} {
variable S
$S(w:c) move numctrl [expr $x - $S(wheelXc)] [expr $y - $S(wheelYc)]
set S(wheelXc) $x
set S(wheelYc) $y
}
proc sudoku::wheel-moveto { col row } {
variable S
# the xy should be the center of the cell ($row $col)
foreach {x0 y0 x1 y1} [$S(w:c) bbox $S(idr:$col,$row)] { break }
set xc [expr ($x0+$x1)/2]
set yc [expr ($y0+$y1)/2]
wheel-movetoXY $xc $yc
}
# r0 is the initial radius
# r1 is the final radius (close to the wheel radius)
# (r1/r0 = 6 --> smooth
# <5 --> too fast
# > 8 --> slow
proc sudoku::wheel-open {r0 r1} {
variable S
set cvs $S(w:c)
set circleID [$cvs create oval [expr $S(wheelXc)-$r0] [expr $S(wheelYc)-$r0] \
[expr $S(wheelXc)+$r0] [expr $S(wheelYc)+$r0] \
-outline $S(userNumberColor)
]
for {set i 2} { $i <$r1/$r0 } {incr i} {
set sFactor [expr $i.0/($i-1)]
$cvs scale $circleID $S(wheelXc) $S(wheelYc) $sFactor $sFactor
update idletasks
after 30
}
$cvs delete $circleID
# show wheel
$cvs itemconfigure numctrl -state normal
$cvs itemconfigure numctrl&&text -state disabled
bind $cvs [list sudoku::checkOutOfWheel %x %y]
}
proc sudoku::checkOutOfWheel {x y} {
variable S
set dist [expr sqrt( ($x-$S(wheelXc))*($x-$S(wheelXc)) + \
($y-$S(wheelYc))*($y-$S(wheelYc)) )]
if { $dist > $S(outerRadius) } {
wheel-close
}
}
proc sudoku::wheel-close {} {
variable S
bind $S(w:c) {}
$S(w:c) itemconfigure numctrl -state hidden
}
###################################################
# MAIN
###################################################
package require Tk
## source sudoku-create.tcl
###############################################################################
# sudoku-create.tcl
#
# Package to create sudoku puzzles
#
# Author: David Easton
################################################################################
package provide sudoku-create 1.0
namespace eval sudoku-create {
variable v
}
proc sudoku-create::shuffle { list } {
set n 1
set slist {}
foreach item $list {
set index [expr {int(rand()*$n)}]
set slist [linsert $slist $index $item]
incr n
}
return $slist
}
proc sudoku-create::toList {} {
variable v
set l [list]
foreach y [list 0 1 2 3 4 5 6 7 8 ] {
set lx [list]
foreach x [list 0 1 2 3 4 5 6 7 8] {
set n [expr {9*$y + $x}]
lappend lx $v($n)
}
lappend l $lx
}
return $l
}
proc sudoku-create::start {} {
variable v
set v(stop) 0
makeRowLists
makeColLists
makeBoxLists
nextSquare 0 [shuffle [list 1 2 3 4 5 6 7 8 9]]
return $v(list)
}
proc sudoku-create::printStatus {{max 81}} {
variable v
foreach y [list 0 1 2 3 4 5 6 7 8] {
foreach x [list 0 1 2 3 4 5 6 7 8] {
set n [expr {9*$y + $x}]
if {$n >= $max} {puts "";return}
puts -nonewline $v($n)
}
puts ""
}
}
# Note: The last column of each row does not
# need to be in this list, as this is the
# square itself.
proc sudoku-create::makeRowLists {} {
foreach r [list 0 1 2 3 4 5 6 7 8] {
set v(rowList,$r) [list]
foreach c [list 0 1 2 3 4 5 6 7] {
lappend v(rowList,$r) [expr {9 * $r + $c}]
}
}
}
# Note: The last row of each column does not
# need to be in this list, as this is the
# square itself.
proc sudoku-create::makeColLists {} {
variable v
foreach c [list 0 1 2 3 4 5 6 7 8] {
set v(colList,$c) [list]
foreach r [list 0 1 2 3 4 5 6 7] {
lappend v(colList,$c) [expr {9 * $r + $c}]
}
}
}
# Note: The last row of each box does not
# need to be in this list, as the row checking
# will always cover those squares.
proc sudoku-create::makeBoxLists {} {
variable v
foreach bc [list 0 1 2] {
foreach br [list 0 1 2] {
set offset [expr {27 * $br + 3 * $bc}]
set i "$br$bc"
set v(boxList,$i) [list]
foreach y [list 0 1] {
foreach x [list 0 1 2] {
lappend v(boxList,$i) [expr {$offset + (9 * $y) + $x}]
}
}
}
}
}
proc sudoku-create::nextSquare {n possList} {
variable v
if { $v(stop) } {return}
if {$n == 81} {
#printStatus $n
set v(list) [toList]
set v(stop) 1
return
}
set r [expr {$n / 9}]
set c [expr {$n % 9}]
set b [expr {$r/3}][expr {$c/3}]
if {$c == 0} {set possList [shuffle [list 1 2 3 4 5 6 7 8 9]]}
set clist [list]
foreach e [lrange $v(colList,$c) 0 [expr {$r -1}]] {
lappend clist $v($e)
}
set blist [list]
if {$r % 3} {
foreach e $v(boxList,$b) {
if { $e >= $n } {break}
lappend blist $v($e)
}
}
foreach i $possList {
# Test for uniqueness in col, box
if {[lsearch $clist $i] != -1} {
continue
}
if {[lsearch $blist $i] != -1} {
continue
}
set v($n) $i
set ind [lsearch $possList $i]
nextSquare [expr {$n+1}] [lreplace $possList $ind $ind]
}
}
## source sudoku-mask.tcl
################################################################################
# sudoku-mask.tcl
#
# Package to create masks for sudoku puzzles
#
# Author: David Easton
################################################################################
package provide sudoku-mask 1.0
namespace eval sudoku-mask {
variable M
}
proc sudoku-mask::choose {list} {
return [lindex $list [expr {int(rand() * [llength $list])}]]
}
proc sudoku-mask::addSquare {sq} {
variable M
if {[lsearch $M(vis) $sq] == -1} {
lappend M(vis) $sq
set M($sq) 1
}
}
proc sudoku-mask::removeSquare {sq} {
variable M
if {[set i [lsearch $M(vis) $sq]] != -1} {
set M(vis) [lreplace $M(vis) $i $i]
set M($sq) 0
}
}
proc sudoku-mask::init {} {
variable M
set M(vis) [list]
foreach x [list 1 2 3 4 5 6 7 8 9] {
foreach y [list 1 2 3 4 5 6 7 8 9] {
set M($x,$y) 1
lappend M(vis) "$x,$y"
}
}
}
proc sudoku-mask::chooseSym {} {
# Full list is miry mirx mirxy miryx mirb rot180 rot90
return [choose [list mirb rot180 rot90]]
}
proc sudoku-mask::symmetry {type sq} {
set res [list $sq]
foreach {x y} [split $sq ,] {break}
set xi [expr {10-$x}]
set yi [expr {10-$y}]
switch $type {
miry {
if {$x != 5} {
lappend res "$xi,$y"
}
}
mirx {
if {$y != 5} {
lappend res "$x,$yi"
}
}
mirxy {
if {$x != $y} {
lappend res "$y,$x"
}
}
miryx {
if {$x != $yi} {
lappend res "$yi,$xi"
}
}
mirb {
if {$x != 5 || $y != 5} {
lappend res "$x,$yi"
lappend res "$xi,$yi"
lappend res "$xi,$y"
}
}
rot180 {
if {$x != 5 || $y != 5} {
lappend res "$xi,$yi"
}
}
rot90 {
if {$x != 5 || $y != 5} {
lappend res "$yi,$x"
lappend res "$xi,$yi"
lappend res "$y,$xi"
}
}
}
return $res
}
proc sudoku-mask::show {} {
variable M
foreach y [list 1 2 3 4 5 6 7 8 9] {
foreach x [list 1 2 3 4 5 6 7 8 9] {
puts -nonewline $M($x,$y)
}
puts ""
}
puts ""
}
proc sudoku-mask::toList {} {
variable M
set l [list]
foreach x [list 1 2 3 4 5 6 7 8 9] {
set lx [list]
foreach y [list 1 2 3 4 5 6 7 8 9] {
lappend lx $M($x,$y)
}
lappend l $lx
}
return $l
}
################################################################################
# Searches for instances of 4 squares containing 2 different values
# where the values are interchangeable. These must always be specified
# at start of the puzzle if the puzzle is to have a unique solution
################################################################################
proc sudoku-mask::analysePuzzle {p} {
set matchedList [list]
set col 0
foreach column $p {
incr col
set row 0
foreach val $column {
incr row
set block [expr {(($row -1)/3)*3 + (($col -1)/3)} + 1]
set colRowFromBlockVal($block,$val) $col,$row
set valFromColRow($col,$row) $val
}
}
set blockAssociations(1) [list 2 3 4 7]
set blockAssociations(2) [list 3 5 8]
set blockAssociations(3) [list 6 9]
set blockAssociations(4) [list 5 6 7]
set blockAssociations(5) [list 6 8]
set blockAssociations(6) [list 9]
set blockAssociations(7) [list 8 9]
set blockAssociations(8) [list 9]
set blockAssociations(9) [list]
foreach block [list 1 2 3 4 5 6 7 8 9] {
foreach num [list 1 2 3 4 5 6 7 8 9] {
set sq1 $colRowFromBlockVal($block,$num)
foreach assocBlock $blockAssociations($block) {
set sq2 $colRowFromBlockVal($assocBlock,$num)
foreach {c1 r1} [split $sq1 ,] {break}
foreach {c2 r2} [split $sq2 ,] {break}
if { $valFromColRow($c1,$r2) == $valFromColRow($c2,$r1) } {
set matched [lsort [list $sq1 $c1,$r2 $c2,$r1 $sq2]]
if {[lsearch $matchedList $matched] == -1} {
lappend matchedList $matched
}
}
}
}
}
return $matchedList
}
proc sudoku-mask::generate {p num} {
variable M
init
set M(sym) [chooseSym]
set matchedList [analysePuzzle $p]
# Only show $num visible entries
while {[llength $M(vis)] > $num} {
if {[llength $matchedList]} {
set useMatchedList true
set sq [choose [choose $matchedList]]
} else {
set useMatchedList false
set sq [choose $M(vis)]
}
set sqList [symmetry $M(sym) $sq]
foreach sq $sqList {
if {$useMatchedList} {
# Remove any matching entries from matchedList
foreach index [lsort -integer -decreasing [lsearch -all -glob $matchedList *${sq}*]] {
set matchedList [lreplace $matchedList $index $index]
}
}
removeSquare $sq
}
}
#show
return [toList]
}
# Change
proc sudoku-mask::change {} {
sudoku-mask::less
sudoku-mask::more
}
# Number visible
proc sudoku-mask::numvis {} {
variable M
return [llength $M(vis)]
}
# Harder
proc sudoku-mask::harder { {sq 0} } {
variable M
if { $sq == 0 || [lsearch $M(vis) $sq] == -1} {
set sq [choose $M(vis)]
}
set sqList [symmetry $M(sym) $sq]
foreach sq $sqList {
removeSquare $sq
}
#show
return [toList]
}
# Easier
proc sudoku-mask::easier { {sq 0} } {
variable M
# Protect against infinite loop
if { [llength $M(vis)] == 81} {return}
if { $sq == 0 } {
set x [choose [list 1 2 3 4 5 6 7 8 9]]
set y [choose [list 1 2 3 4 5 6 7 8 9]]
} else {
foreach {x y} [split $sq ,] {break}
}
while {[lsearch $M(vis) $x,$y] != -1} {
set x [choose [list 1 2 3 4 5 6 7 8 9]]
set y [choose [list 1 2 3 4 5 6 7 8 9]]
}
set sq $x,$y
set sqList [symmetry $M(sym) $sq]
foreach sq $sqList {
addSquare $sq
}
#show
return [toList]
}
## source sudoku-solve.tcl
################################################################################
# sudoku-solve.tcl
#
# Package to solve sudoku puzzles
#
# Author: David Easton
################################################################################
package provide sudoku-solve 1.0
namespace eval sudoku-solve {
variable S
variable V
}
proc sudoku-solve::toList {} {
variable V
set l [list]
foreach col [list 1 2 3 4 5 6 7 8 9] {
set lc [list]
foreach row [list 1 2 3 4 5 6 7 8 9] {
set box [getBoxFromRowCol $col $row]
lappend lc $V($col,$row,$box)
}
lappend l $lc
}
return $l
}
proc sudoku-solve::getBoxFromRowCol {col row} {
set box [expr {3 * (($row - 1)/3) + ($col - 1)/3 + 1}]
}
proc sudoku-solve::solve {l} {
variable S
init
set S(numDone) 0
set S(progress) 0
# 0 for unsolvable, 1 for single answer
set S(answer) 0
set S(known) [list]
foreach num [list 1 2 3 4 5 6 7 8 9] {
set S(rem,col,$num) [list 1 2 3 4 5 6 7 8 9]
set S(rem,row,$num) [list 1 2 3 4 5 6 7 8 9]
set S(rem,box,$num) [list 1 2 3 4 5 6 7 8 9]
}
set col 0
foreach column $l {
incr col
set row 0
foreach entry $column {
incr row
if {[regexp {[0-9]} $entry]} {
setKnown $col $row $entry
}
}
}
# Ensure that we always use the easiest method when possible
while {$S(progress)} {
while {$S(progress)} {
while {$S(progress)} {
set S(progress) 0
if {$S(numDone) == 81} {
break
}
rule2
}
rule3
}
rule4
}
if {$S(numDone) == 81} {
set S(answer) 1
}
showAll
return [list $S(answer) [sudoku-solve::toList]]
}
proc sudoku-solve::listSquares {type num} {
variable V
switch $type {
"col" { set eList [array names V "$num,*,*"]}
"row" { set eList [array names V "*,$num,*"]}
"box" { set eList [array names V "*,*,$num"]}
default {set elList [list]}
}
return [lsort $eList]
}
proc sudoku-solve::rule2 {} {
# For each row, column and box
# see if only 1 square can be any particular number
variable S
variable V
foreach i [list 1 2 3 4 5 6 7 8 9] {
foreach type [list col row box] {
foreach num $S(rem,$type,$i) {
set matchList [list]
foreach entry [listSquares $type $i] {
if {[lsearch $V($entry) $num] != -1} {
lappend matchList $entry
}
}
if {[llength $matchList] == 1} {
set entry [lindex $matchList 0]
#puts "Solved $entry = $num *rule 2*"
foreach {co ro bo} [split $entry ,] {break}
setKnown $co $ro $num
}
}
}
}
}
proc sudoku-solve::rule3 {} {
# For each col/row/box. If a number can only exist in
# 1 col/row/box, then can remove the number from others
# This is an extension of the testing performed in rule2
variable S
variable V
foreach i [list 1 2 3 4 5 6 7 8 9] {
foreach type [list col row box] {
foreach num $S(rem,$type,$i) {
set matchList [list]
foreach entry [listSquares $type $i] {
if {[lsearch $V($entry) $num] != -1} {
lappend matchList $entry
}
}
# Test whether matchList has another col/row/box in common
if {[llength $matchList] == 1} {
set entry [lindex $matchList 0]
#puts "Solved $entry = $num *rule 2*"
foreach {co ro bo} [split $entry ,] {break}
setKnown $co $ro $num
} elseif {[llength $matchList] < 4} {
set coList [list]
set roList [list]
set boList [list]
foreach entry $matchList {
foreach {co ro bo} [split $entry ,] {break}
if {[lsearch $coList $co] == -1} {lappend coList $co}
if {[lsearch $roList $ro] == -1} {lappend roList $ro}
if {[lsearch $boList $bo] == -1} {lappend boList $bo}
}
switch $type {
col -
row {
# For col/row, check if in same box
if {[llength $boList] == 1} {
# Remove $num from other cols/rows in this box
set bo [lindex $boList 0]
foreach ent [listSquares box $bo] {
if {[lsearch $matchList $ent] != -1} {continue}
if {[set ind [lsearch $V($ent) $num]] != -1} {
set V($ent) [lreplace $V($ent) $ind $ind]
set S(progress) 1
#puts "Removed $num from $ent *rule 3* (type $type)"
if {[llength $V($ent)] == 1} {
foreach {co ro bo} [split $ent ,] {break}
#puts "Solved $ent = $V($ent) *rule 3*"
setKnown $co $ro $V($ent)
}
}
}
}
}
box {
# For box, check if in same row or col
if {[llength $coList] == 1} {
# Remove $num from other boxes in this col
set co [lindex $coList 0]
foreach ent [listSquares col $co] {
if {[lsearch $matchList $ent] != -1} {continue}
if {[set ind [lsearch $V($ent) $num]] != -1} {
set V($ent) [lreplace $V($ent) $ind $ind]
set S(progress) 1
#puts "Removed $num from $ent *rule 3* (type $type)"
if {[llength $V($ent)] == 1} {
foreach {co ro bo} [split $ent ,] {break}
#puts "Solved $ent = $V($ent) *rule 3*"
setKnown $co $ro $V($ent)
}
}
}
}
if {[llength $roList] == 1} {
# Remove $num from other boxes in this row
set ro [lindex $roList 0]
foreach ent [listSquares row $ro] {
if {[lsearch $matchList $ent] != -1} {continue}
if {[set ind [lsearch $V($ent) $num]] != -1} {
set V($ent) [lreplace $V($ent) $ind $ind]
set S(progress) 1
#puts "Removed $num from $ent *rule 3* (type $type)"
if {[llength $V($ent)] == 1} {
foreach {co ro bo} [split $ent ,] {break}
#puts "Solved $ent = $V($ent) *rule 3*"
setKnown $co $ro $V($ent)
}
}
}
}
}
}
}
}
}
}
}
proc sudoku-solve::rule4 {} {
# For each row, column and box
# if 2 squares can only be 1,3 for example, remove 1,3 from other
# squares in the row/col/box.
# Also this needs to cover 3 squares with 1,2 2,3 1,3 etc.
variable S
variable V
foreach type [list col row box] {
foreach i [list 1 2 3 4 5 6 7 8 9] {
catch {array unset match}
foreach num $S(rem,$type,$i) {
set match($num) [list]
foreach entry [listSquares $type $i] {
if {[lsearch $V($entry) $num] != -1} {
lappend match($num) $entry
}
}
}
# Search for pairs
if {[set retCode [testMatch match 2]]} {return $retCode}
if {[set retCode [testMatch match 3]]} {return $retCode}
if {[set retCode [testMatch match 4]]} {return $retCode}
if {[set retCode [testMatch match 5]]} {return $retCode}
}
}
}
# Returns 1 if it did something useful, 0 otherwise
proc sudoku-solve::solveRule4 {squares numbers} {
variable V
set retCode 0
# For each square, remove entries which are not
# the numbers provided.
foreach entry $squares {
foreach num $V($entry) {
if {[lsearch $numbers $num] == -1} {
set S(progress) 1
#puts "Removed $num from $entry *rule 4a*"
set V($entry) [lremove $V($entry) $num]
set retCode 1
}
}
}
# For each row/col/box in common, remove the numbers
# provided.
# See what they have in common
set coList [list]
set roList [list]
set boList [list]
foreach entry $squares {
foreach {co ro bo} [split $entry ,] {break}
if {[lsearch $coList $co] == -1} {lappend coList $co}
if {[lsearch $roList $ro] == -1} {lappend roList $ro}
if {[lsearch $boList $bo] == -1} {lappend boList $bo}
}
if {[llength $coList] == 1} {
foreach entry [listSquares col $coList] {
if {[lsearch $squares $entry] != -1} {
continue
}
foreach num $numbers {
if {[set ind [lsearch $V($entry) $num]] != -1} {
set S(progress) 1
#puts "Removed $num from $entry *rule 4b*"
set retCode 1
set V($entry) [lreplace $V($entry) $ind $ind]
if {[llength $V($entry)] == 1} {
foreach {co ro bo} [split $entry ,] {break}
#puts "Solved $entry = $V($entry) *rule 4*"
setKnown $co $ro $V($entry)
}
}
}
}
}
if {[llength $roList] == 1} {
foreach entry [listSquares row $roList] {
if {[lsearch $squares $entry] != -1} {
continue
}
foreach num $numbers {
if {[set ind [lsearch $V($entry) $num]] != -1} {
set S(progress) 1
#puts "Removed $num from $entry *rule 4b*"
set retCode 1
set V($entry) [lreplace $V($entry) $ind $ind]
if {[llength $V($entry)] == 1} {
foreach {co ro bo} [split $entry ,] {break}
#puts "Solved $entry = $V($entry) *rule 4*"
setKnown $co $ro $V($entry)
}
}
}
}
}
if {[llength $boList] == 1} {
foreach entry [listSquares box $boList] {
if {[lsearch $squares $entry] != -1} {
continue
}
foreach num $numbers {
if {[set ind [lsearch $V($entry) $num]] != -1} {
set S(progress) 1
#puts "Removed $num from $entry *rule 4b*"
set retCode 1
set V($entry) [lreplace $V($entry) $ind $ind]
if {[llength $V($entry)] == 1} {
foreach {co ro bo} [split $entry ,] {break}
#puts "Solved $entry = $V($entry) *rule 4*"
setKnown $co $ro $V($entry)
}
}
}
}
}
return $retCode
}
proc sudoku-solve::testMatch {matchName num} {
upvar $matchName match
set unknown [array names match]
# No point in doing all this if we cannot rule
# anything out anyway
if {[llength $unknown] <= $num} {return 0}
set numList [list]
foreach entry [array names match] {
if {[llength $match($entry)] <= $num} {
lappend numList $entry
}
}
# If at least $num numbers have only $num squares represented, continue
if {[llength $numList] >= $num} {
set cmd comb$num
foreach combo [$cmd $numList] {
set sqs [list]
foreach c $combo {
foreach entry $match($c) {
if {[lsearch $sqs $entry] == -1} {
lappend sqs $entry
}
}
}
if {[llength $sqs] == $num} {
set retCode [solveRule4 $sqs $combo]
return $retCode
}
}
}
return 0
}
proc sudoku-solve::showAll {} {
variable V
foreach row [list 1 2 3 4 5 6 7 8 9] {
foreach col [list 1 2 3 4 5 6 7 8 9] {
set box [getBoxFromRowCol $col $row]
if {[llength $V($col,$row,$box)] > 1} {
#puts -nonewline "."
} else {
#puts -nonewline $V($col,$row,$box)
}
}
#puts ""
}
#puts ""
}
proc sudoku-solve::show {} {
variable V
parray V
}
# Make unsolved grid
proc sudoku-solve::init {} {
variable V
foreach row [list 1 2 3 4 5 6 7 8 9] {
foreach col [list 1 2 3 4 5 6 7 8 9] {
set box [getBoxFromRowCol $col $row]
set V($col,$row,$box) [list 1 2 3 4 5 6 7 8 9]
}
}
}
proc sudoku-solve::lremove {list entry} {
if {[set i [lsearch $list $entry]] != -1} {
return [lreplace $list $i $i]
} else {
return $list
}
}
# Known values
proc sudoku-solve::setKnown {col row to} {
variable S
variable V
# Check if this has already been set
if {[lsearch $S(known) $col,$row] != -1} {
return
}
set box [getBoxFromRowCol $col $row]
# Check that it is possible
if {[lsearch $V($col,$row,$box) $to] != -1} {
set S(progress) 1
set V($col,$row,$box) $to
set S(rem,col,$col) [lremove $S(rem,col,$col) $to]
set S(rem,row,$row) [lremove $S(rem,row,$row) $to]
set S(rem,box,$box) [lremove $S(rem,box,$box) $to]
lappend S(known) $col,$row
incr S(numDone)
# Clear this value from all others in this row, col & box
set colList [listSquares col $col]
set rowList [listSquares row $row]
set boxList [listSquares box $box]
set remList [list]
foreach entry [concat $colList $rowList $boxList] {
if {[lsearch $remList $entry] == -1 && $entry != "$col,$row,$box"} {
lappend remList $entry
}
}
foreach entry $remList {
if {[set i [lsearch $V($entry) $to]] != -1} {
set V($entry) [lreplace $V($entry) $i $i]
if {[llength $V($entry)] == 1} {
foreach {co ro bo} [split $entry ,] {break}
#puts "Solved $entry = $V($entry) *rule 1*"
setKnown $co $ro $V($entry)
}
}
}
return $to
} else {
return 0
}
}
################################################################################
# Pre-built comb functions designed for speed
################################################################################
proc sudoku-solve::comb5 {list} {
set rl [list]
set i1 0
foreach e1 $list {
incr i1
set i2 0
foreach e2 [lrange $list $i1 end] {
incr i2
set i3 0
foreach e3 [lrange $list [expr {$i1+$i2}] end] {
incr i3
set i4 0
foreach e4 [lrange $list [expr {$i1+$i2+$i3}] end] {
incr i4
foreach e5 [lrange $list [expr {$i1+$i2+$i3+$i4}] end] {
lappend rl [list $e1 $e2 $e3 $e4 $e5]
}
}
}
}
}
return $rl
}
proc sudoku-solve::comb4 {list} {
set rl [list]
set i1 0
foreach e1 $list {
incr i1
set i2 0
foreach e2 [lrange $list $i1 end] {
incr i2
set i3 0
foreach e3 [lrange $list [expr {$i1+$i2}] end] {
incr i3
foreach e4 [lrange $list [expr {$i1+$i2+$i3}] end] {
lappend rl [list $e1 $e2 $e3 $e4]
}
}
}
}
return $rl
}
proc sudoku-solve::comb3 {list} {
set rl [list]
set i1 0
foreach e1 $list {
incr i1
set i2 0
foreach e2 [lrange $list $i1 end] {
incr i2
foreach e3 [lrange $list [expr {$i1 + $i2}] end] {
lappend rl [list $e1 $e2 $e3]
}
}
}
return $rl
}
proc sudoku-solve::comb2 {list} {
set rl [list]
set i 0
foreach e1 $list {
incr i
foreach e2 [lrange $list $i end] {
lappend rl [list $e1 $e2]
}
}
return $rl
}
wm withdraw .
set win .sudoku
toplevel $win
wm title $win "Sudoku"
wm protocol $win WM_DELETE_WINDOW [list sudoku::closeDown $win]
sudoku::readImages
sudoku::buildWindow $win
sudoku::buildMenus $win
update
#sudoku::bgGen
======
<>
----
**..**
You can right-click on these images and use 'Save Link As...' (or some similar option)
of your web browser, to save these 10 files for use with the code above:
[sudoku_1.gif] [sudoku_2.gif] [sudoku_3.gif] [sudoku_4.gif] [sudoku_5.gif]
[sudoku_6.gif] [sudoku_7.gif] [sudoku_8.gif] [sudoku_9.gif]
[sudoku_grid.gif]
<> Games | Toys | Puzzles