======
#! /usr/bin/env wish
if false {
======
[wdb] This is a minimalistic Sudoku without bells & whistles
[http://wolf-dieter-busch.de/html/Software/Kleinigkeiten/Sudoku.htm].
No Menu. No Help. No Game restart after finishing.

[http://wolf-dieter-busch.de/html/res/Heimatseite/img/sw/sudoku-mini.png]
======
}

package require Tcl 8.5
package require Tk

pack\
  [canvas .ch -width 270 -height 30 -bg white]\
  [canvas .c -width 270 -height 270 -bg white]\
  -side bottom
wm title . Sudoku

proc aloud args {
  # debugging purposes
  puts $args
  uplevel 1 $args
}

apply {{c ch} {
  set font {Helvetica -25}
  set cursorColor grey
  $c delete all
  $ch delete all
  for {set i 0} {$i < 9} {incr i} {
    for {set j 0} {$j < 9} {incr j} {
      $c create text [+ [* $i 30] 15] [+ [* $j 30] 15]\
        -tags [list nr $i/$j col$i row$j]\
        -font $font -text "" -fill grey
    }
  }
  $c create text 0 0 -font $font -fill $cursorColor -tags cursor
  $c bind cursor <1> [list tryCoords $c %x %y]
  $c bind cursor <ButtonRelease> [subst {
    $c itemconfigure nr -fill grey
    $c itemconfigure cursor -fill $cursorColor
    $c itemconfigure fixed -fill black
  }]
  for {set i 1} {$i < 9} {incr i} {
    set w [expr {$i % 3 ? 1 : 2}]
    $c create line [* $i 30] 0 [* $i 30] 270 -width $w -fill grey
    $c create line 0 [* $i 30] 270 [* $i 30] -width $w -fill grey
  }
  for {set i 1} {$i <= 9} {incr i} {
    $ch create text [- [* $i 30] 15] 15\
      -text $i -font $font -tags try$i -fill grey
    $ch bind try$i <1> [list setNrCursor $c $i]
  }
  bind $ch <Shift-1> [list setNrCursor $c ""]
  bind $ch <Control-1> [list setNrCursor $c ""]
} ::tcl::mathop} .c .ch

proc setNr {canvas x y nr} {
  $canvas itemconfigure $x/$y -text $nr
}

proc setNrCursor {canvas nr} {
  if {$nr eq ""} then {
    $canvas configure -cursor ""
    $canvas itemconfigure cursor -text ""
    $canvas bind cursor <Motion> ""
    bind $canvas <Leave> ""
    bind $canvas <Enter> ""
  } else {
    $canvas configure -cursor none
    bind $canvas <Motion> [list $canvas coords cursor %x %y]
    bind $canvas <Enter> [list $canvas itemconfigure cursor -text $nr]
    bind $canvas <Leave> [list $canvas itemconfigure cursor -text ""]
  }
}

proc tryCoords {canvas xCoord yCoord} {
  set x [expr {$xCoord / 30}]
  set y [expr {$yCoord / 30}]
  if {"fixed" in [$canvas gettags $x/$y]} then {
    setNrCursor $canvas [$canvas itemcget $x/$y -text]
    after idle [list event generate $canvas <Enter>]
    return
  }
  set nr [$canvas itemcget cursor -text]
  if {[$canvas itemcget $x/$y -text] eq $nr} then {
    $canvas itemconfigure nr&&$x/$y&&!fixed -text ""
    return
  }
  set occurrences [concat\
                     [colOccurrence $canvas $x $nr]\
                     [rowOccurrence $canvas $y $nr]\
                     [squareOccurrence $canvas $x $y $nr]]
  if {$occurrences eq ""} then {
    $canvas itemconfigure nr&&$x/$y&&!fixed\
      -text [$canvas itemcget cursor -text]
    return $nr
  }
  # error
  foreach {x y} $occurrences {
    $canvas itemconfigure $x/$y -fill red
  }
  $canvas itemconfigure cursor -fill red
}

proc colOccurrence {canvas x nr} {
  set result {}
  foreach item [$canvas find withtag col$x] {
    set text [$canvas itemcget $item -text]
    if {$text eq $nr} then {
      set tags [$canvas gettags $item]
      set index [lsearch $tags row*]
      set tag [lindex $tags $index]
      lappend result $x [string index $tag end]
    }
  }
  set result
}

proc rowOccurrence {canvas y nr} {
  set result {}
  foreach item [$canvas find withtag row$y] {
    set text [$canvas itemcget $item -text]
    if {$text eq $nr} then {
      set tags [$canvas gettags $item]
      set index [lsearch $tags col*]
      set tag [lindex $tags $index]
      lappend result [string index $tag end] $y
    }
  }
  set result
}

proc squareOccurrence {canvas x y nr} {
  if {$x < 3} then {
    set xRange {0 1 2}
  } elseif {$x < 6} then {
    set xRange {3 4 5}
  } else {
    set xRange {6 7 8}
  }
  if {$y < 3} then {
    set yRange {0 1 2}
  } elseif {$y < 6} then {
    set yRange {3 4 5}
  } else {
    set yRange {6 7 8}
  }
  #
  set result {}
  foreach i $xRange {
    foreach j $yRange {
      set text [$canvas itemcget $i/$j -text]
      if {$text eq $nr} then {
        lappend result $i $j
      }
    }
  }
  set result
}

proc collides? {canvas x y nr} {
  expr {[llength\
           [concat\
              [colOccurrence $canvas $x $nr]\
              [rowOccurrence $canvas $y $nr]\
              [squareOccurrence $canvas $x $y $nr]]]
        ? yes
        : no}
}

proc inc9 _nr {
  upvar $_nr nr
  set nr [expr {int($nr) % 9 + 1}]
}

proc startRand9 {} {
  expr {1 + int(rand() * 9)}
}

proc nextField {x y} {
  incr x        
  if {$x > 8} then {
    set x 0
    incr y
  }
  list $x $y
}

proc checkField {canvas {x 0} {y 0}} {
  if {$y > 8} then {
    return yes
  }
  lassign [nextField $x $y] x1 y1
  set nr [startRand9]
  foreach i {1 2 3 4 5 6 7 8 9} {
    inc9 nr
    if {[collides? $canvas $x $y $nr]} then continue
    setNr $canvas $x $y $nr
    if {[checkField $canvas $x1 $y1]} then {
      return yes
    } else {
      setNr $canvas $x $y ""
    }
  }
  setNr $canvas $x $y ""
  return no
}

proc randomly? {} {
  expr {rand() > 0.5 ? yes : no}
}

apply {canvas {
  foreach i {0 1 2 3 4 5 6 7 8} {
    foreach j {0 1 2 3 4 5 6 7 8} {
      $canvas itemconfigure $i/$j -text ""
    }
  }
  checkField $canvas
  foreach i {0 1 2 3 4 5 6 7 8} {
    foreach j {0 1 2 3 4 5 6 7 8} {
      if {[randomly?]} then {
        aloud $canvas addtag fixed withtag $i/$j
      } else {
        aloud $canvas dtag $i/$j fixed
        $canvas itemconfigure $i/$j -text ""
      }
    }
  }
  $canvas itemconfigure fixed -fill black
}} .c

if false {
======
I've hacked it yesterday afternoon (GUI) and this morning (logics).

Have fun.
======
}
======
----
[LV] 2009 Aug 12
So, is this program's intent only to display the sudoku board itself? I was trying to figure out how to enter in the numbers to solve the puzzle but I haven't figured it out yet.
----
<<categories>>Category Games