Version 6 of Eight Queens, minimalistic

Updated 2009-10-21 00:19:40 by AMG
package require Tcl 8.5
package require Tk

bind Tk <Destroy> exit
wm resizable . no no

apply {canvas {
  destroy $canvas
  pack [canvas .c -width 320 -height 320] 
  foreach i {0 1 2 3 4 5 6 7} {
      foreach j {0 1 2 3 4 5 6 7} {
        set o [expr {($i+$j)%2 ? "odd" : "even"}]
        set coords [list [* $i 40] [* $j 40]\
                      [* [+ $i 1] 40] [* [+ $j 1] 40]]]
        $canvas create rectangle $coords\
          -tags [list f $o r$j c$i]
        $canvas create text\
          [+ [* $i 40] 20] [+ [* $j 40] 20]\
          -tags [list q r$j c$i]
        $canvas bind r$j&&c$i <1> "check $j $i"
      }
    }
  foreach c {-8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7} {
      set col $c
      foreach row {0 1 2 3 4 5 6 7} {
        $canvas addtag d[+ $c 7] withtag r$row&&c$col
        incr col
      }
    }
  foreach c {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
      set col $c
      foreach row {0 1 2 3 4 5 6 7} {
        $canvas addtag e$c withtag r$row&&c$col
        incr col -1
      }
    }
  $canvas itemconfigure odd\
    -fill grey\
    -outline ""
  $canvas itemconfigure even\
    -fill #ffffcc\
    -outline ""
  $canvas itemconfigure q\
    -fill navy\
    -font {Times 20 bold italic}
  bind $canvas <ButtonRelease>\
    "$canvas itemconfigure q -fill navy"
} ::tcl::mathop} .c

proc check {row col} {
  set txt [.c itemcget q&&r$row&&c$col -text]
  if {$txt ne ""} then {
    .c itemconfigure q&&r$row&&c$col -text ""
  } else {
    setQueen $row $col
  }
}

proc setQueen {row col} {
  foreach tag [.c gettags q&&r$row&&c$col] {
    regexp d(.+) $tag - d
    regexp e(.+) $tag - e
  }
  set pat q&&(r$row||c$col||d$d||e$e)
  set success true
  set els [.c find withtag $pat]
  foreach el $els {
    if {[.c itemcget $el -text] ne ""} then {
      set success false
    }
  }
  if {$success} then {
    .c itemconfigure q&&r$row&&c$col -text Q
  } else {
    .c itemconfigure $pat -fill white
  }
}

See also: Eight Queens Problem