Acht Königinnen

Auf dem Schachbrett darf die Dame längs und schräg schlagen.

Ziel des Spiels: verteile acht Damen, so dass sich keine bedroht fühlt. Sonst schmollt sie nämlich.


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

bind [winfo class .] <Destroy> exit
wm resizable . no no
wm title . "Set 8 Queens, splendid safe, please!"

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
          }
        }
      }
    }
  }
}

apply {canvas {
  destroy $canvas
  pack [canvas $canvas -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 #cccccc\
    -outline ""
  $canvas itemconfigure even\
    -fill #ffffcc\
    -outline ""
  $canvas itemconfigure q\
    -fill navy\
    -font {Times 32}
  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
  }
  set missing [missingOfQueens]
  switch -exact -- $missing {
    0 {
      wm title . Congratulations!
    }
    1 {
      wm title . "Set 1 Queen, splendid safe!"
    }
    default {
      wm title .\
        "Set $missing Queens, splendid safe!"
    }
  }
}

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 \u2655
  } else {
    # .c itemconfigure $pat -fill red
    blink .c -tag $pat -color0 white -color1 navy -interval 10
  }
}

bind .c <ButtonRelease> {
  blink stop
  .c itemconfigure q -fill navy
}

proc missingOfQueens {} {
  set result 8
  foreach item [.c find all] {
    if {[.c type $item] eq "text" &&
        [.c itemcget $item -text] ne ""} then {
      incr result -1
    }
  }
  set result
}

11.3.2022