## sudoku.tcl - adapted to iPaq by Richard Suchenwirth, Konstanz 2005

namespace eval sudoku {    
    variable S
    set S(preDone) 0
    set S(afterIds) [list]
}
package require Tk

proc main {} {
    set win .
    wm protocol $win WM_DELETE_WINDOW [list sudoku::closeDown $win]
    sudoku::buildWindow $win
    sudoku::buildMenus  $win
    wm geometry $win +0+0
    bind . <Up> {exec wish $argv0 &; exit}
    bind . <F1> {console show}
}
################################################################################
# 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
                        }
                    }
                }
                set sq [choose $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]     
            # 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
                        }
                    }
                }
                set sq [choose $sqList]                                
                set m [sudoku-mask::easier $sq]                
                if { [sudoku-mask::numvis] > $max } {
                    set p [sudoku-create::start]
                    set m [sudoku-mask::generate $p $min]
                }                
                incr count
            }
        }
    }
    fromList $l
    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 darkgrey
            } 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 black
            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 white
    } else {
        $S(w:c) itemconfigure $S(idr:$col,$row) -fill red
    }
    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       
        }      
    }
}

################################################################################
# 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 {[lsearch $S(fixedList) "$col,$row"] != -1} {
        setNum [getVal $col $row]
    } else {
        setVal $col $row [getNum]
        clearPen $col $row
    }
}
proc sudoku::clickRight {col row} {    
    variable S    
    if {[lsearch $S(fixedList) "$col,$row"] != -1} {
        setNum [getVal $col $row]
    } else {
        togPen $col $row [getNum]
    }
}
proc sudoku::setNum {n} {    
    variable S 
    # Work, with or without tile package
    if {[catch {$S(w:b$S(num)) state !pressed}]} {
        $S(w:b$S(num)) configure -relief raised
    }
    if {[catch {$S(w:b$n) state pressed}]} {
        $S(w:b$n) configure -relief sunken
    }
    set S(num) $n
}
proc sudoku::getNum {} {
    variable S
    if { $S(num) == 0 } {
        return " "
    } else {
        return $S(num)
    }
}
################################################################################
# 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} {    
    variable S    
    set offx 5
    set offy 5
    set w 25
    set h 25
    set hw [expr {$w / 2}]
    set hh [expr {$h / 2}]
    
    # 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 black -fill white -width 1]
            set idp1 [$c create text [expr {$x1+3}] $y1 -anchor nw -text "" -font penfont -fill grey]
            set idp2 [$c create text [expr {$x1+3}] $y2 -anchor sw -text "" -font penfont -fill grey]
            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 <Double-1> [list sudoku::clickLeft $col $row]
                $c bind $id <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 black -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 bf [frame $win.bf]
    foreach i [list 1 2 3 4 5 6 7 8 9] {
        set S(w:b$i) [button $bf.b$i -text "$i" -width 1 -command "sudoku::setNum $i"]
        pack $S(w:b$i) -side left -fill x -expand true
    }
    set S(w:b0) [button $bf.b0 -text " " -command [list sudoku::setNum 0]]
    pack $S(w:b0) -side left -fill x -expand true
    $S(w:b1) invoke
    grid $bf -sticky news -padx 0
 
    set c [canvas $win.c]
    foreach {x y} [drawBoard $c] {break}    
    $c configure -width $x -height $y
    grid $c -sticky {} -padx 1 -pady 1
    
    set S(level) "Easy"
    set S(w:top) $win
    set S(w:c) $c
    clear   
    wm resizable $win 0 0
}

###################################################
# aboutBox
#
# Display an about box
###################################################
proc sudoku::aboutBox { w } {    
    set message "Sudoku v0.7i\n"
    append message "(c) David Easton, 2005\n\n"
    append message "Written in Tcl/Tk"    
    tk_messageBox -icon info \
            -title "About" \
            -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 23 \
            -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 config -state disabled
}
    
###################################################
# buildMenus
#
# Build menus for toplevel w
###################################################
proc sudoku::buildMenus { w } {   
    variable S
    if {$w eq "."} {set w ""; interp alias {} "" {} .}
    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 "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]
    
    $w configure -menu $w.menu
}
#-----------------------------------------------------------------------
################################################################################
# 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]
    }
}

#-----------------------------------------------------------------------
################################################################################
# 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
        }
    }    
    return [toList]
}
proc lsearch-all-glob {list pattern} {
   set res {}
   set i 0
   foreach element $list {
       if [string match $pattern $element] {lappend res $i}
       incr i
   }
   set res
}

# 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
    }
    return [toList]
}
#-----------------------------------------------------------------------
################################################################################
# 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 {} {
    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]
        }
    }
}
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
}
#-----------------------------------------------------------------------
main