Sudoku

Für die, die die Regeln noch nicht kennen: die Ziffern Eins bis Neun werden so verteilt, dass in jedem drei-mal-drei-Feld, in jeder Spalte und in jeder Zeile jede Ziffer exakt einmal vorkommt.

Anmerkung, im Unterschied zu kommerziellen Sudokus ist die Lösung nicht immer eindeutig. Wenn beispielsweise nur zwo Zahlen „frei“ sind bei vier „freien“ Feldern, dürften schätzungweise zwei Lösungen vorliegen. Dann führt „Raten“ nahezu zwangsläufig zur Lösung.

---

#! /usr/bin/env wish
package require Tcl 8.5
package require Tk

namespace import ::tcl::mathfunc::* ::tcl::mathop::*

proc blink {widget args} {
  lassign [info level 0] blink
  if {$widget eq "info"} then {
    #
    # info
    #
    set result {}
    foreach event [after info] {
      set info [after info $event]
      if {[lindex $info end] eq "timer" &&
          [lindex $info 0 0] eq $blink} then {
        lassign $info cmd
        lassign $cmd blink widget
        if {[winfo exists $widget]} then {
          set line [list $blink $widget]
          set opts [lrange $cmd 2 end]
          if {[winfo class $widget] in {Text Canvas}} then {
            lappend line -tag [dict get $opts -tag]
          } 
          lappend line -att [dict get $opts -att]
          lappend result $line
        }
      }
    }
    lsort $result
  } elseif {$widget eq "stop"} then {
    #
    # stop all after-events
    #
    foreach event [after info] {
      set info [after info $event]
      if {[lindex $info end] eq "timer" &&
          [lindex $info 0 0] eq $blink} then {
        after cancel $event
      }
    }
  } elseif {[winfo exists $widget]} then {
    if {$args eq "stop"} then {
      $blink $widget -action stop
    } else {
      set class [winfo class $widget]
      #
      # prepare
      #
      set item {
        -step 0
        -red0 0
        -green0 0
        -blue0 0
        -tag blink
        -red1 65535
        -green1 65535
        -blue1 65535
        -interval 25
        -action continue
      }
      #
      # set default target attributes
      #
      switch -exact -- $class {
        Text {
          dict set item -att -foreground
        }
        Canvas {
          dict set item -att -fill
        }
        default {
          dict set item -att -fg
        }
      }
      #
      # customize by command line
      #
      dict for {key val} $args {
        dict set item $key $val
      }
      #
      # translate named colors if given
      #
      if {[dict exists $item -color0]} then {
        lassign [winfo rgb . [dict get $item -color0]] r g b
        dict set item -red0 $r
        dict set item -green0 $g
        dict set item -blue0 $b
        dict unset item -color0
      }
      if {[dict exists $item -color1]} then {
        lassign [winfo rgb . [dict get $item -color1]] r g b
        dict set item -red1 $r
        dict set item -green1 $g
        dict set item -blue1 $b
        dict unset item -color1
      }
      #
      if {[dict get $item -action] eq "continue"} then {
        #
        # calculate increasement of color
        #
        dict incr item -step
        if {[dict get $item -step] >= 100} then {
          dict set item -step 0
        }
        set pi [expr {
          atan2(0,-1)
        }]
        set factor [expr {
          (cos($pi * 2 * [dict get $item -step] / 100) + 1) / 2
        }]
        #
        # generate hexadecimal color string
        #
        set rrrrggggbbbb #
        #
        set red0 [dict get $item -red0]
        set red1 [dict get $item -red1]
        set red [expr {$red0+int(($red1-$red0)*$factor)}]
        append rrrrggggbbbb [format %04x $red]
        #
        set green0 [dict get $item -green0]
        set green1 [dict get $item -green1]
        set green [expr {$green0+int(($green1-$green0)*$factor)}]
        append rrrrggggbbbb [format %04x $green]
        #
        set blue0 [dict get $item -blue0]
        set blue1 [dict get $item -blue1]
        set blue [expr {$blue0+int(($blue1-$blue0)*$factor)}]
        append rrrrggggbbbb [format %04x $blue]
        #
        set tag [dict get $item -tag]
        set att [dict get $item -att]
        switch -exact -- $class {
          Canvas {
            $widget itemconfigure $tag $att $rrrrggggbbbb
          }
          Text {
            $widget tag configure $tag $att $rrrrggggbbbb
          }
          default {
            $widget configure $att $rrrrggggbbbb
          }
        }
        #
        # repeat
        #
        set interval [dict get $item -interval]
        after $interval [list blink $widget {*}$item]
        #
      } else {
        #
        # stop blinking of $widget
        #
        foreach event [after info] {
          set info [after info $event]
          set line [lindex $info 0]
          lassign $line proc arg 
          if {$proc eq $blink && $arg eq $widget} then {
            after cancel $event
          }
        }
      }
    }
  }
}

bind Tk <Destroy> exit

proc aloud args {puts $args; uplevel 1 $args}

set lineColor goldenrod4
set warnColor {light blue}

apply {
  c {
    variable lineColor
    destroy $c
    pack [canvas $c -width 270 -height 305 -bg white]
    wm title . Sudoku
    wm resizable . no no
    set font {Helvetica -25 bold}
    set cursorColor grey
    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 yes]
    $c bind cursor <ButtonRelease> [subst {
      blink stop
      $c itemconfigure nr -fill grey
      $c itemconfigure cursor -fill $cursorColor
      $c itemconfigure fixed -fill $lineColor
    }]
    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 $lineColor
      $c create line 0 [* $i 30] 270 [* $i 30] -width $w -fill $lineColor
    }
    $c create line 0 270 270 270 -width 1 -fill $lineColor
    for {set i 1} {$i <= 9} {incr i} {
      $c create line [- [* $i 30] 5] 280 [- [* $i 30] 25] 300\
        -fill white -width 4 -tags "blink stroke $i"
      $c create text [- [* $i 30] 15] 290\
        -text $i -font $font -tags "try$i try" -fill grey
      $c bind try$i <1> [list setNrCursor $c $i]
    }
    $c raise cursor
  }
} .c

proc occurrences-of {nr canvas} {
  set result 0
  foreach item [$canvas find withtag nr] {
    if {[$canvas itemcget $item -text] eq $nr} then {
      incr result
    }
  }
  set result
}

proc echo args {puts $args}

proc setNr {canvas x y nr {byHand no}} {
  set before [$canvas itemcget $x/$y -text]
  if {$before ne ""} then {
    $canvas itemconfigure stroke&&$before -fill white
  }
  $canvas itemconfigure $x/$y -text $nr
  if {[string is integer -strict $nr]} then {
    if {[occurrences-of $nr $canvas] > 8} then {
      $canvas itemconfigure stroke&&$nr -fill grey
      setNrCursor $canvas ""
      $canvas addtag done withtag stroke&&$nr
    } else {
      $canvas itemconfigure stroke&&$nr -fill white
      $canvas dtag stroke&&$nr done
    }
  }
  if {$byHand && [llength [$canvas find withtag done]] > 8} then {
    update
    after 250 success
  }
}

proc success {} {
  tk busy hold .c -cursor ""
  .c raise blink
  # .c itemconfigure blink -width 4
  blink .c -color0 yellow -color1 grey
}

proc setNrCursor {canvas nr} {
  variable lineColor
  $canvas itemconfigure try -fill grey
  if {$nr eq ""} then {
    $canvas configure -cursor ""
    $canvas itemconfigure cursor -text ""
    $canvas bind cursor <Motion> ""
    bind $canvas <Leave> ""
    bind $canvas <Enter> ""
  } elseif {[$canvas itemcget cursor -text] eq $nr} then {
    setNrCursor $canvas ""
  } 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 ""]
    after idle [list event generate $canvas <Enter>]
    $canvas itemconfigure try$nr -fill $lineColor
  }
}

proc tryCoords {canvas xCoord yCoord {byHand no}} {
  variable lineColor
  variable warnColor
  set x [expr {$xCoord / 30}]
  set y [expr {$yCoord / 30}]
  if {$y > 8} then {
    setNrCursor $canvas [expr {$x+1}]
    return
  }
  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 {
    setNr $canvas $x $y "" $byHand
    return
  } else {
    set occurrences [concat\
      [colOccurrence $canvas $x $nr]\
      [rowOccurrence $canvas $y $nr]\
      [squareOccurrence $canvas $x $y $nr]]
    if {$occurrences eq ""} then {
      setNr $canvas $x $y $nr $byHand
      return $nr
    }
    # error
    foreach {x y} $occurrences {
      # $canvas itemconfigure $x/$y -fill red
      lappend erraneous  $x/$y
    }
    $canvas itemconfigure cursor -fill red
    lappend erraneous cursor
    blink $canvas -tag [join $erraneous ||]\
      -interval 10 -color0 $lineColor -color1 white
  }
}

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 take1from _l {
  upvar $_l l
  set i [expr {int(rand() * [llength $l])}]
  set result [lindex $l $i]
  set l [lreplace $l $i $i]
  set result
}

proc checkField {canvas {x 0} {y 0}} {
  if {$y > 8} then {
    return yes
  }
  lassign [nextField $x $y] x1 y1
  set l {1 2 3 4 5 6 7 8 9}
  while {[llength $l]} {
    set nr [take1from l]
    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
}

# debug

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

apply {
  canvas {
    variable lineColor
    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 {
          $canvas addtag fixed withtag $i/$j
        } else {
          $canvas dtag $i/$j fixed
          $canvas itemconfigure $i/$j -text ""
        }
      }
    }
    $canvas itemconfigure fixed -fill $lineColor
    # $canvas itemconfigure stroke -fill white
    foreach nr {1 2 3 4 5 6 7 8 9} {
      if {[occurrences-of $nr $canvas] > 8} then {
        $canvas itemconfigure stroke&&$nr -fill grey
        $canvas addtag done withtag stroke&&$nr
      } else {
        $canvas itemconfigure stroke&&$nr -fill white
        $canvas dtag stroke&&$nr done
      }
    }
}} .c

---

11.3.2022

<< | Heimatseite | Verzeichnis | Stichworte | Autor | >>