<> **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://irrational-numbers.googlecode.com/files/sudoku-0.7.1.zip%|%sudoku.zip%|%] - pure tcl-code (for any TclTk platform) - unzip and run sudoku.vfs/main.tcl * [https://irrational-numbers.googlecode.com/files/sudoku-0.7.1.kit%|%sudoku.kit%|%] - Starkit archive (TclKit required) * [https://irrational-numbers.googlecode.com/files/sudoku-0.7.1.exe%|%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