[Artur Trzewik]: Programming a sudoku solver is a good brain training for an evening. Perhaps it will in time replace [Eight Queens Problem] as a popular student homework assignment. Here is a short implementation. It has some extra functionality to observe the solution progress. It will not solve problems which need several tries. ---- ====== namespace eval sudoku { variable win } proc sudoku::lremoveAll {list_ref listr} { upvar $list_ref list foreach elem $listr { lremove list $elem } } proc sudoku::lremove {list_ref elem} { upvar $list_ref list if {[set index [lsearch -exact $list $elem]]>=0} { set list [lreplace $list $index $index] return 1 } return 0 } proc sudoku::clear {} { set f [list] for {set i 0} {$i<9*9} {incr i} { lappend f [list] } setWin $f } proc sudoku::complexReduction {ref_f t} { variable win upvar $ref_f f set fields {1 2 3 4 5 6 7 8 9} set found 0 for {set y 0} {$y<9} {incr y} { for {set x 0} {$x<9} {incr x} { if {[llength [set pos [lindex $t [expr {$x+$y*9}]]]]>1} { set i 0 set allposibles [list] foreach p [getColumn $t $x] { if {$i==$y} { incr i continue } set allposibles [concat $allposibles $p] incr i } lremoveAll pos $allposibles if {[llength $pos]==1} { lset f [expr {$x+$y*9}] [lindex $pos 0] lset t [expr {$x+$y*9}] [lindex $pos 0] set found 1 return $found } set pos [lindex $t [expr {$x+$y*9}]] set i 0 set allposibles [list] foreach p [getRow $t $y] { if {$i==$x} { incr i continue } set allposibles [concat $allposibles $p] incr i } lremoveAll pos $allposibles if {[llength $pos]==1} { lset f [expr {$x+$y*9}] [lindex $pos 0] lset t [expr {$x+$y*9}] [lindex $pos 0] set found 1 return $found } } } } return $found } proc sudoku::compute {} { set f [getNumbers] while 1 { set r1 [simpleReduction f] set r2 [complexReduction f [simpleReduction f 0]] if {$r1==0 && $r2==0} { break } } setWin $f } proc sudoku::getColumn {f column} { set l [list] for {set i 0} {$i<9} {incr i} { lappend l [lindex $f [expr {$i*9+$column}]] } return $l } proc sudoku::getNumbers {} { variable win set f [list] for {set i 0} {$i<9*9} {incr i} { lappend f [list] } for {set x 0} {$x<9} {incr x} { for {set y 0} {$y<9} {incr y} { lset f [expr {$x+$y*9}] [$win.e${x}_$y get] } } return $f } proc sudoku::getQuad {f quad} { set diff [expr {($quad%3)*3+($quad/3)*27}] list [lindex $f $diff] [lindex $f [expr {$diff+1}]] [lindex $f [expr {$diff+2}]] [lindex $f [expr {$diff+9}]] [lindex $f [expr {$diff+10}]] [lindex $f [expr {$diff+11}]] [lindex $f [expr {$diff+18}]] [lindex $f [expr {$diff+19}]] [lindex $f [expr {$diff+20}]] } proc sudoku::getRow {f row} { lrange $f [expr {$row*9}] [expr {$row*9+8}] } proc sudoku::load {} { set f [tk_getOpenFile -filetypes {{{SuDoKu Files} *.sdk}}] if {$f eq ""} { return } set file [open $f r] set num [read $file] close $file setWin $num } proc sudoku::lstep {} { set f [getNumbers] set t [simpleReduction f 0] complexReduction f $t setWin $f } proc sudoku::myInit {} { setWin { {} {} {} {} 6 {} {} 3 {} {} {} 5 3 {} {} {} {} {} 8 {} {} {} {} 5 {} 4 7 {} {} {} 1 5 {} {} {} {} {} 1 {} {} {} {} {} 9 {} {} 5 {} {} {} 4 3 {} {} {} {} 4 6 8 {} {} 2 3 2 {} 1 {} 4 {} {} {} 8 {} 9 {} {} 7 2 1 6 {} } } proc sudoku::setMessage mes { variable win $win.lab configure -text $mes } proc sudoku::setWin f { variable win for {set x 0} {$x<9} {incr x} { for {set y 0} {$y<9} {incr y} { $win.e${x}_$y delete 0 end $win.e${x}_$y insert 0 [lindex $f [expr {$x+$y*9}]] } } } proc sudoku::simpleReduction {ref_f {reduction 1}} { upvar $ref_f f set fields {1 2 3 4 5 6 7 8 9} set t [list] for {set y 0} {$y<9} {incr y} { for {set x 0} {$x<9} {incr x} { if {[lindex $f [expr {$x+$y*9}]] eq ""} { set pos $fields lremoveAll pos [getRow $f $y] lremoveAll pos [getColumn $f $x] lremoveAll pos [getQuad $f [expr {$x/3+($y/3)*3}]] lappend t $pos if {[llength $pos]==1 && $reduction} { lset f [expr {$x+$y*9}] [lindex $pos 0] return 1 } elseif {[llength $pos]==0} { setMessage "Keine LĀ½sung ${x}:$y" } } else { lappend t [lindex $f [expr {$x+$y*9}]] } } } if {$reduction==1} { return 0 } return $t } proc sudoku::initWindow {window} { variable win set win $window frame $win.f frame $win.b label $win.help -text "Use double click to show possible numbers" -bg green if {[lsearch [font names] espfont]<0} { font create sdkfont -family Courier -size 25 } for {set y 0} {$y<9} {incr y} { for {set x 0} {$x<9} {incr x} { set qq [expr {($x / 3) + ($y / 3)}] entry $win.e${x}_$y -width 2 -font sdkfont if {[expr {$qq % 2}]==1} { $win.e${x}_$y config -bg grey } bind $win.e${x}_$y [list sudoku::testPos $x $y] grid $win.e${x}_$y -in $win.f -column $x -row $y -padx 2 -pady 2 } } button $win.compute -text "Solve" -command sudoku::compute button $win.step -text "Strategy 1" -command sudoku::step button $win.lstep -text "Strategy 2" -command sudoku::lstep #label $win.lab -relief raised -border 3 label $win.lab -relief sunken -border 3 #pack $win.help -fill x pack $win.f -fill both -expand yes -padx 10 -pady 10 pack $win.compute $win.step $win.lstep -side left -in $win.b #pack $win.b $win.lab -fill x pack $win.b -fill x pack $win.help -fill x pack $win.lab -fill x menu $win.m $win.m add command -label "Clean" -command sudoku::clear $win.m add command -label "Set example" -command sudoku::myInit $win.m add separator $win.m add command -label "Load" -command sudoku::load $win.m add command -label "Save" -command sudoku::save if {$win eq ""} { . configure -menu $win.m } else { $win configure -menu $win.m } } proc sudoku::save {} { set f [tk_getSaveFile -initialfile my.sdk -filetypes {{{SuDoKu Files} *.sdk}}] if {$f eq ""} { return } set file [open $f w] puts $file [getNumbers] close $file } proc sudoku::step {} { set f [getNumbers] set t [simpleReduction f] setWin $f } proc sudoku::testPos {x y} { set f [getNumbers] set t [simpleReduction f 0] set pos [lindex $t [expr {$y*9+$x}]] setMessage "${x}:$y = $pos" } proc sudoku::try f { for {set i 0} {$i<9} {incr i} { if {[llength [lsort -unique [getColumn $f $i]]]!=9} { return 0 } if {[llength [lsort -unique [getRow $f $i]]]!=9} { return 0 } if {[llength [lsort -unique [getQuad $f $i]]]!=9} { return 0 } } return 1 } sudoku::initWindow {} sudoku::myInit ====== ---- [HJG] Added grey background for every other block, moved help-line directly above output-label. ---- [http://img706.imageshack.us/img706/6231/minisudokutclwiki.gif] [gold ]added pix ---- See also: [Sudoku] - [Playing sudoku] - [sudokut]. ---- [Arts and crafts of Tcl-Tk programming] - [Category Games]