Version 53 of Sudoku

Updated 2015-05-04 20:02:37 by AMG

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 [L1 ]

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. [L2 ] 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:

  • sudoku.zip - pure tcl-code (for any TclTk platform) - unzip and run sudoku.vfs/main.tcl
  • sudoku.kit - Starkit archive (TclKit required)
  • sudoku.exe - .exe Windows executable (no installation is required)

28-Nov-2005, on 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 [L3 ].

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: [L4 ] and [L5 ].


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 <Button-1> [list sudoku::clickLeft $col $row]
                # ??? $c bind $id <Control-Button-1> [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 <KeyPress> [list sudoku::checkKeyPress %K]

    bind $c <Control-KeyPress> [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 <Control> 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 <KeyPress> -keysym $key]
      $cvs bind val_$key <Control-1> \
           [list event generate $cvs <Control-KeyPress> -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 <Enter> [list $cvs itemconfigure current -fill $S(selectedCellBg)]
  $cvs bind oval <Leave> [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 <Motion> [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) <Motion> {}
    $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