Updated 2016-04-22 22:17:15 by gold

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 <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::myInit

HJG Added grey background for every other block, moved help-line directly above output-label.

See also: Sudoku - Playing sudoku - sudokut - sudoku minimalistic.