# Fresh attempt at sudoku solver in pure tcl/tk.
# This spin will do manual entry validation instead of automatic
# which gives us place to convert to kanji

# some of this talk about arrays is left over from the c version
# in this code, they may be lists or collections of widgets

# 2010.01.17
# eliminate zero as legit arabic input
# remove tcl/tk version requirements

# 2010.01.07-1
# fixed typo in unicode for kanji "9"

# 2010.01.07
# correct a couple of non-fatal bugs pointed out in tcl ng

# Board is a 9x9 matrix represented by a single-subscript
# array and associated widgets - starts w/zero at the upper left.

#  0  1  2  3  4  5  6  7  8
#  9 10 11 12 13 14 15 16 17
# 18 19 20 21 22 23 24 25 26
# 27 28 29 30 31 32 33 34 35
# 36 37 38 39 40 41 42 43 44
# 45 46 47 48 49 50 51 52 53
# 54 55 56 57 58 59 60 61 62
# 63 64 65 66 67 68 69 70 71
# 72 73 74 75 76 77 78 79 80

# Possible board is a similar array but each element is a list
# containing digits 1-9 that will be pruned as the puzzle is
# solved.

# package require Tcl 8.5
# package require Tk 8.5


# set row, column, and square associations
# each row, column, and square has 9 associated entries
# use nested lists like 2 dimensional arrays

proc buildAssociations {} {

    global rows cols squares

    set rows [ list \
        {0 1 2 3 4 5 6 7 8} \
        {9 10 11 12 13 14 15 16 17} \
        {18 19 20 21 22 23 24 25 26} \
        {27 28 29 30 31 32 33 34 35} \
        {36 37 38 39 40 41 42 43 44} \
        {45 46 47 48 49 50 51 52 53} \
        {54 55 56 57 58 59 60 61 62} \
        {63 64 65 66 67 68 69 70 71} \
        {72 73 74 75 76 77 78 79 80} ]

    set cols [ list \
        {0 9 18 27 36 45 54 63 72} \
        {1 10 19 28 37 46 55 64 73} \
        {2 11 20 29 38 47 56 65 74} \
        {3 12 21 30 39 48 57 66 75} \
        {4 13 22 31 40 49 58 67 76} \
        {5 14 23 32 41 50 59 68 77} \
        {6 15 24 33 42 51 60 69 78} \
        {7 16 25 34 43 52 61 70 79} \
        {8 17 26 35 44 53 62 71 80} ]

    set squares [ list \
        {0 1 2 9 10 11 18 19 20} \
        {3 4 5 12 13 14 21 22 23} \
        {6 7 8 15 16 17 24 25 26} \
        {27 28 29 36 37 38 45 46 47} \
        {30 31 32 39 40 41 48 49 50} \
        {33 34 35 42 43 44 51 52 53} \
        {54 55 56 63 64 65 72 73 74} \
        {57 58 59 66 67 68 75 76 77} \
        {60 61 62 69 70 71 78 79 80} ]
}


# set up up arabic to/from kanji translations
# and the list of 9 kanji digits equivalent to 1-9

proc buildTranslations {} {

    global kanjiarray arabicarray global kanji1to9

    array set kanjiarray {1 \u4e00 2 \u4e8c 3 \u4e09 4 \u56db \
        5 \u4e94 6 \u516d 7 \u4e03 8 \u516b 9 \u4e5d}

    array set arabicarray {\u4e00 1 \u4e8c 2 \u4e09 3 \u56db 4 \
        \u4e94 5 \u516d 6 \u4e03 7 \u516b 8 \u4e5d 9}

    set kanji1to9 [list \u4e00 \u4e8c \u4e09 \u56db \u4e94 \
        \u516d \u4e03 \u516b \u4e5d]

}


# pop up a warning message inside the main window

proc popMessage {message color} {

    # don't allow multiple window creations if called more than once

    if {[winfo exists .sudoku.messpop]} {
        return
    }

    labelframe .sudoku.messpop -width 10c -height 4c -bg $color
    grab .sudoku.messpop
    message .sudoku.messpop.msg -text $message -bg $color -aspect 600 -font {courrier 12 bold}
    button .sudoku.messpop.okb -text OK -command {destroy .sudoku.messpop ; return 0}
    place .sudoku.messpop -in .sudoku -relx 0.5 -rely 0.5 -anchor center
    pack .sudoku.messpop.msg .sudoku.messpop.okb -side top 
}


# set the color of the CHECK button

proc setCheckButtonColor {color} {

    .sudoku.buttons.checkButton configure -bg $color
}


# build the board

proc buildGrid {} {

    global cellarray

    for {set rowind 0} {$rowind < 9} {incr rowind} {

        set gridlist ""
        for {set colind 0} {$colind < 9} {incr colind} {
            set cellind [expr {$rowind * 9 + $colind}]
            entry .sudoku.board.cellentry$cellind -textvariable cellarray($cellind) \
                -width 2 -font {courrier 20} -justify center
            bind .sudoku.board.cellentry$cellind <KeyPress> \
                [list validEntryKey %W $cellind]
            lappend gridlist .sudoku.board.cellentry$cellind
        }
        eval grid $gridlist
    }
}


# set the board's background colors and the array that
# holds the default colors for future reference

proc setBackgroundColors {} {

    global cellbgcolorarray
    global cellbgcolorA cellbgcolorB

    for {set rowind 0} {$rowind < 9} {incr rowind} {
        set gridlist ""
        for {set colind 0} {$colind < 9} {incr colind} {
            set cellind [expr {$rowind * 9 + $colind}]
            # set cell color (row = 3 or 4 or 5) exor (col = 3 or 4 or 5)
            # THE PATTERN MUST COME BEFORE THE STRING OR WISH GETS CONFUSED!!!!
            if {[string match {[3-5]} $colind] ^ [string match {[345]} $rowind]} {
                set cellbg $cellbgcolorA
            } else {
                set cellbg $cellbgcolorB
            }
            .sudoku.board.cellentry$cellind configure -bg $cellbg
            set cellbgcolorarray($cellind) $cellbg
        }
    }
}


# build the "possible" array
# each element is a list of 1-9 that gets pruned as the possibles
# get reduced until only one remains (hopefully) in a given element

proc buildPossible {} {

    global possarray

    set possibles [list 1 2 3 4 5 6 7 8 9]

    for {set index 0} {$index < 81} {incr index} {
        set possarray($index) $possibles
    }
}


# clear all 9 possible values from a single
# possible array element - this may boil down to a single
# statement so just fold it into calling code???

proc clearPossibleElementAll {index} {

    global possarray

    # make sure it remains a list - but empty

    set possarray($index) [list]
}


# clear one possible values from a single
# possible array element - this may boil down to a single
# statement so just fold it into calling code???

proc clearPossibleElementValue {index value} {

    global possarray

    set possarray($index) \
        [lsearch -all -inline -not -exact $possarray($index) $value]
}


# clears all possible values from a possible array element
# array if the actual board already has a value in that location
# not redundant since prune proc only eliminates a single value, not
# the entire list (as must happen if cell already occupied)

proc clearPossiblesPerEntry {} {

    global cellarray

    for {set index 0} {$index < 81} {incr index} {
        if {[nineCheck $cellarray($index)]} {
            clearPossibleElementAll $index
        }
    }
}


# determine if a given possible array element has
# exactly ONE possible value
# returns found value if == 1, else returns 0

proc checkPossibleForOne {index} {

    global possarray

    if {[llength $possarray($index)] == 1} {
        return $possarray($index)
    }
    return 0
}


# that checks possible board for single possibles and
# sets the actual board to that value if it finds any
# set bg color to ?something? if new entry

proc updateBoard {} {

    global cellarray possarray
    global cellchangedcolor
    global arabicmode

    for {set index 0} {$index < 81} {incr index} {
        set singlevalue [checkPossibleForOne $index]
        if {$singlevalue != 0} {
            if {!$arabicmode} {
                # convert to kanji first
                set singlevalue [toKanji $singlevalue]
            }
            set cellarray($index) $singlevalue
            .sudoku.board.cellentry$index configure \
                -bg $cellchangedcolor
        }
    }
}


# check an entire entity for a single instance
# of a value - if only one found, plug that into the
# actual board in that location and set bg to ?something?
# this is different than finding a single possible value
# in a possible element, which is done elsewhere

proc scanEntityForOne { entitytype } {

    global rows cols squares
    global cellarray possarray
    global cellchangedcolor
    global arabicmode

    foreach entity [subst $$entitytype] {
        for {set numeral 1} {$numeral < 10} {incr numeral} {
            # for each entity, count number of each numeral
            # if count == 1 set the board cell that matches
            # the index where the numeral was found
            set count 0
            set indexmaybe 0
            foreach index $entity {
                if {[lsearch $possarray($index) $numeral] != -1} {
                    incr count
                    set indexmaybe $index
                }
            }
            if {$count == 1} {

                set newmeral $numeral
                if {!$arabicmode} {
                    # convert to kanji first
                    set newmeral [toKanji $numeral]
                }

                # sanity check
                if {[nineCheck $cellarray($indexmaybe)] \
                    && ($cellarray($indexmaybe) != $newmeral)} {
                    popMessage "Code failure! trying to change existing entry!" red
                }

                set cellarray($indexmaybe) $newmeral
                .sudoku.board.cellentry$indexmaybe configure -bg $cellchangedcolor
            }
        }
    }
}


# check all entities for single occurance of a
# given numeral and if found updates board in that location

proc scanAllEntitiesForOne {} {

    global rows cols squares

    scanEntityForOne rows
    scanEntityForOne cols
    scanEntityForOne squares
}


# clear all the matching possibles in an entity
# if the board has an entry, clear that value from all possibles
# in the associated entity type - row, column, or square
 
proc prunePossiblesPerEntity {entitytype} {

    global cellarray possarray
    global rows cols squares
    global arabicmode

    # each entity is a sub-list of 9 board cell index values
    # grab each index value and see if there is a board entry
    # in that cell - if so delete that value from all the
    # possibles at the other indices in the entity (delete from
    # possible array, not the board array

    foreach entity [subst $$entitytype] {
        for {set index 0} {$index < 9} {incr index} {
            # cellindex points to board entry to test
            set cellindex [lindex $entity $index]
            set cellvalue $cellarray($cellindex)
            if {[nineCheck $cellvalue]} {
                # delete that value from each element of entity
                for {set undex 0} {$undex < 9} {incr undex} {
                    set possindex [lindex $entity $undex]
                    set smellvalue $cellvalue
                    if {!$arabicmode} {
                        # convert back to arabic for pruning
                        set smellvalue [toArabic $cellvalue]
                    }
                    clearPossibleElementValue $possindex $smellvalue
                }
            }
        }
    }
}


# prune all possibles in all entities based on existing board
# first eliminate all possible numerals at any location that
# already has an entry in board then clean out all copies of
# an existing board numeral in it's subsuming entities

proc pruneAllPossibles {} {

    global rows cols squares

    clearPossiblesPerEntry
    prunePossiblesPerEntity rows
    prunePossiblesPerEntity cols
    prunePossiblesPerEntity squares
}


# ckeck for space or null

proc checkSpaceOrNull {x} {

    return [expr {[string equal $x " "] || [string equal $x {}]}]
}


# to check for legit kanji cell contents
# kanji 1-9, space, null all OK

proc kanjiAllCheck {x} {

    global kanji1to9

    return [expr {([lsearch -exact -inline $kanji1to9 $x] != {}) \
        || [checkSpaceOrNull $x]}]
}


# to check for legit arabic cell contents
# 1-9, space, null all OK

proc arabicAllCheck {x} {

    return [expr {(([string is int -strict $x] && ($x >= 1) && ($x <= 9)) \
        || [checkSpaceOrNull $x])}]
}


# check for legal numeral, space, or null entry
# kanji or arabic numeral based on flag

proc allCheck {x} {

    global arabicmode

    if {$arabicmode} {
        return [arabicAllCheck $x]
    } else {
        return [kanjiAllCheck $x]
    }
}


# check for arabic 1-9

proc arabicNineCheck {x} {

    return [expr {[string is int -strict $x] && ($x >= 1) && ($x <= 9)}]
}


# check for kanji 1-9

proc kanjiNineCheck {x} {

    global kanji1to9

    return [expr {[lsearch -exact -inline $kanji1to9 $x] != {}}]
}


# check for a numeral - arabic or kanji depending on flag

proc nineCheck {x} {

    global arabicmode

    if {$arabicmode} {
        return [arabicNineCheck $x]
    } else {
        return [kanjiNineCheck $x]
    }
}


# do translations arabic/kanji
# return question mark if invalid input

proc toKanji {arabic} {

    global kanjiarray

    if {[arabicNineCheck $arabic]} {
        return $kanjiarray($arabic)
    }

    if {[checkSpaceOrNull $arabic]} {
        return $arabic
    }

    return "?"
}


proc toArabic {kanji} {

    global arabicarray

    if {[kanjiNineCheck $kanji]} {
        return $arabicarray($kanji)
    }

    if {[checkSpaceOrNull $kanji]} {
        return $kanji
    }

    return "?"
}


# switch board between arabic and kanji display
# switch existing display and set appropriate flags

# what to return if not a legit input? "?" or ???
# and maybe don't change the original if "?"

proc allKanji {} {

    global cellarray
    global arabicmode

    if {!$arabicmode} {
        return
    }

    set arabicmode FALSE
    .sudoku.buttons.arabicButton configure -relief raised
    .sudoku.buttons.kanjiButton configure -relief sunken

    for {set index 0} {$index < 81} {incr index} {
        set cellarray($index) [toKanji $cellarray($index)]
    }
}

proc allArabic {} {

    global cellarray
    global arabicmode

    if {$arabicmode} {
        return
    }

    set arabicmode TRUE
    .sudoku.buttons.arabicButton configure -relief sunken
    .sudoku.buttons.kanjiButton configure -relief raised

    for {set index 0} {$index < 81} {incr index} {
        set cellarray($index) [toArabic $cellarray($index)]
    }
}


# count the number of non-zero board entries UNUSED SO FAR

proc countEntries {} {

    global cellarray

    set count 0
    for {set index 0} {$index < 81} {incr index} {
        if {[nineCheck $cellarray($index)]} {
            incr count
        }
    }
    return $count
}


# catch keystrokes in a cell entry and
# calls home-made validation routine AFTER all keystrokes
# are processed
# validation routine checks textvariable contents, not key

proc validEntryKey {win index} {

    global checkcolor

    # set CHECK button color to *something* since entry
    # touched by key stroke

    setCheckButtonColor $checkcolor

    # call validate but only after keystrokes have updated
    # "key" means we are calling validEntry due to keystroke(s)

    after 0 validEntry "key" $win $index
}


# validate an entry called by explicit validation
# or indirectly (delayed until other key processing done)
# when any keystroke in entry via a wrapper proc
# it checks an entry's textvariable for valid contents
# (later versions kanji digits as well)

# convert the cell to kanji if the kanji flag is set

# this version checks the textvariable NOT the keystroke

# flag bogus cells with error color and
# set error flag

# win is widget, key is key code, index is textvariable
# array index (some of this could be calculated) 
# why is "key" for keystroke(s) or ""

# if we are here due to keystroke, in kanji mode, and
# the cell contains a valid arabic numberal, do the
# conversion FIRST

proc validEntry {why win index} {

    global cellbgcolorarray cellerrorcolor checkcolor
    global invalidfound
    global cellarray
    global arabicmode

    if {[string equal $why "key"] && !$arabicmode && \
        [arabicNineCheck $cellarray($index)]} {

        set cellarray($index) [toKanji $cellarray($index)]
    }

    if {[allCheck $cellarray($index)]} {
        $win configure -bg $cellbgcolorarray($index)
    } else {
        $win configure -bg $cellerrorcolor
        bell
        set invalidfound TRUE
    }
}


# validate all cells manually
# empty arg to validEntry means not due to keystroke(s)

proc validateAll {} {

    for {set index 0} {$index < 81} {incr index} {
        validEntry "" .sudoku.board.cellentry$index $index
    }
}


# test a single type of entity for duplicate entries
# rows, cols, or squares
# if duplicates, flag both with the dup error color

# use lindex at lowest level to avoid redundant checking

proc checkEntityType {entitytype} {

    global celldupcolor
    global cellarray
    global rows cols squares
    global duplicatesfound

    # don't test non- 1-9 digit elements
    # start index at one past the element we are testing against
    # and stop test w/penultimate element

    # entity is a list of the cell numbers associated with entity
    # element and other contain cell numbers under test

    foreach entity [subst $$entitytype] {
        for {set index 0} {$index < 8} {incr index} {
            set element [lindex $entity $index]
            for {set undex [expr {$index + 1}]} {$undex < 9} {incr undex} {
                set other [lindex $entity $undex]
                if {[nineCheck $cellarray($element)] && [nineCheck $cellarray($other)]} {
                   if {[string equal $cellarray($element) $cellarray($other)] } {
                       .sudoku.board.cellentry$element configure -bg $celldupcolor
                       .sudoku.board.cellentry$other configure -bg $celldupcolor
                       bell
                       set duplicatesfound TRUE
                    }
                }
            }
        }
    }
}


# test all entities for duplicate entries
# if dupes found global duplicatesfound will be set TRUE


proc checkAllEntityTypes {} {

    checkEntityType rows
    checkEntityType cols
    checkEntityType squares
}


# check everything for legit entries
# no invalid entries, no duplicates
# error flags set by called routines

proc checkAll {} {

    global duplicatesfound invalidfound

    set duplicatesfound FALSE
    set invalidfound FALSE

    validateAll
    checkAllEntityTypes

    if {$duplicatesfound || $invalidfound} {
        popMessage "Invalid or Duplicate Entry" red
        setCheckButtonColor red
        return
    }
    setCheckButtonColor green
}


# make sure we are in arabic mode at start

proc initArabicMode {} {

    global arabicmode

    set arabicmode TRUE
    .sudoku.buttons.arabicButton configure -relief sunken
    .sudoku.buttons.kanjiButton configure -relief raised
}


# initialize board

proc initBoard {} {

    global cellarray
    global cellbgcolorarray

    for {set cellind 0} {$cellind < 81} {incr cellind} {
        set cellarray($cellind) ""
        set cellbgcolorarray($cellind) ""
    }

    setBackgroundColors
    setCheckButtonColor white
    initArabicMode
}


# create board
# build display grid and initialize background color array
# build global textvariable and background color arrays here

proc createBoard {} {

    global cellarray cellbgcolorarray
    global cellbgcolorA cellbgcolorB cellerrorcolor celldupcolor \
        cellchangedcolor checkcolor

    # background alternating colors, error colors

    set cellbgcolorA gray
    set cellbgcolorB lightgray
    set cellerrorcolor red
    set celldupcolor orange
    set cellchangedcolor white
    set checkcolor yellow

    buildGrid
}


# add buttons to main window

proc createButtons {} {

    button .sudoku.buttons.resetButton -text RESET -font {courrier 12} \
        -bg white -command initBoard
    button .sudoku.buttons.checkButton -text CHECK -font {courrier 12} \
        -bg white -command checkAll
    button .sudoku.buttons.stepButton -text SOLVE -font {courrier 12} \
        -bg white -command solveStep
    button .sudoku.buttons.arabicButton -text 123 -font {courrier 12} \
        -bg white -command allArabic
    button .sudoku.buttons.kanjiButton -text \u56db\u4e94\u516d -font {courrier 12} \
        -bg white -command allKanji

    set buttons [list .sudoku.buttons.resetButton .sudoku.buttons.checkButton \
    .sudoku.buttons.stepButton .sudoku.buttons.arabicButton .sudoku.buttons.kanjiButton]
    eval grid $buttons
}


# do one iteration of solving
# retore background colors since there may be some
# that flag previous solve step results

# this version reloads possibles every time to allow
# for erasing and modifying existing board
# also runs check

proc solveStep {} {

    setBackgroundColors

    # make sure board is valid
    checkAll

    # rebuild possibles to allow modifying existing board
    buildPossible

    # prune possibilities based on existing board
    pruneAllPossibles

    # add to current board where there is only one
    # possibility in a cell entry
    updateBoard

    # if a given numeral occurs only once in an
    # entity, update board in that location
    scanAllEntitiesForOne
}


# #### get after it ####


labelframe .sudoku -text SUDOKU
frame .sudoku.board
frame .sudoku.buttons

# build the row column and square associations with the actual
# board array, set up the arabic <-> kanji translations

buildAssociations
buildTranslations

# set up and initialize display grid and colors

createBoard
createButtons
initBoard

pack .sudoku.board .sudoku.buttons
pack .sudoku