Sudoku

Ein minimales Sudoku:

sudoku-mini

Kein Feuerwerk, wenn Spiel gewonnen ist ...



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

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]
  $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
    }
  $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 "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} {
  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 ""
    } else {
      $canvas itemconfigure stroke&&$nr -fill white
    }
  }
}

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} {
  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 ""
    return
  }
  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
    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 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
}

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
        if {[]}
      } else {
        $canvas itemconfigure stroke&&$nr -fill white
      }
    }
}} .c

Vergnügen!

(Ursprung – 09.08.2009)

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