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 <Double-1> [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::myInitHJG Added grey background for every other block, moved help-line directly above output-label.
See also: Sudoku - Playing sudoku - sudokut - sudoku minimalistic.
