Sudoku

Ein minimales Sudoku:

sudoku-mini

Kein Feuerwerk, wenn Spiel gewonnen ist ...


Sämtliche Software steht beim One-Click-Hoster zum Download zur Verfügung. Bei Fragen bitte kurze Email an mich.


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

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}

apply {
  c {
    destroy $c
    pack [canvas $c -width 270 -height 305 -bg white]
    wm title . Sudoku
    wm resizable . no no
    set font {Helvetica -25}
    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 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
    }
    $c create line 0 270 270 270 -width 1 -fill grey
    for {set i 1} {$i <= 9} {incr i} {
      $c create line [- [* $i 30] 5] 280 [- [* $i 30] 25] 300\
        -fill white -width 2 -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
  } ::tcl::mathop} .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 100 success
  }
}

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

proc setNrCursor {canvas nr} {
  $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 black
  }
}

proc tryCoords {canvas xCoord yCoord {byHand no}} {
  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 4 -color0 white -color1 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 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 {
    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 black
    # $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

Vergnügen!

(Ursprung – 09.08.2009)

<< Home | Sitemap | A-Z | Impressum | Suche >>