mingw/lib/tk8.5/demos/knightstour.tcl

   1 # Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
   2 #
   3 #       Calculate a Knight's tour of a chessboard.
   4 #
   5 #       This uses Warnsdorff's rule to calculate the next square each
   6 #       time. This specifies that the next square should be the one that
   7 #       has the least number of available moves.
   8 #
   9 #       Using this rule it is possible to get to a position where
  10 #       there are no squares available to move into. In this implementation
  11 #       this occurs when the starting square is d6.
  12 #
  13 #       To solve this fault an enhancement to the rule is that if we
  14 #       have a choice of squares with an equal score, we should choose
  15 #       the one nearest the edge of the board.
  16 #
  17 #       If the call to the Edgemost function is commented out you can see
  18 #       this occur.
  19 #
  20 #       You can drag the knight to a specific square to start if you wish.
  21 #       If you let it repeat then it will choose random start positions
  22 #       for each new tour.
  23
  24 package require Tk 8.5
  25
  26 # Return a list of accessible squares from a given square
  27 proc ValidMoves {square} {
  28     set moves {}
  29     foreach pair {{-1 -2} {-2 -1} {-2 1} {-1 2} {1 2} {2 1} {2 -1} {1 -2}} {
  30         set col [expr {($square % 8) + [lindex $pair 0]}]
  31         set row [expr {($square / 8) + [lindex $pair 1]}]
  32         if {$row > -1 && $row < 8 && $col > -1 && $col < 8} {
  33             lappend moves [expr {$row * 8 + $col}]
  34         }
  35     }
  36     return $moves
  37 }
  38
  39 # Return the number of available moves for this square
  40 proc CheckSquare {square} {
  41     variable visited
  42     set moves 0
  43     foreach test [ValidMoves $square] {
  44         if {[lsearch -exact -integer $visited $test] == -1} {
  45             incr moves
  46         }
  47     }
  48     return $moves
  49 }
  50
  51 # Select the next square to move to. Returns -1 if there are no available
  52 # squares remaining that we can move to.
  53 proc Next {square} {
  54     variable visited
  55     set minimum 9
  56     set nextSquare -1
  57     foreach testSquare [ValidMoves $square] {
  58         if {[lsearch -exact -integer $visited $testSquare] == -1} {
  59             set count [CheckSquare $testSquare]
  60             if {$count < $minimum} {
  61                 set minimum $count
  62                 set nextSquare $testSquare
  63             } elseif {$count == $minimum} {
  64                 set nextSquare [Edgemost $nextSquare $testSquare]
  65             }
  66         }
  67     }
  68     return $nextSquare
  69 }
  70
  71 # Select the square nearest the edge of the board
  72 proc Edgemost {a b} {
  73     set colA [expr {3-int(abs(3.5-($a%8)))}]
  74     set colB [expr {3-int(abs(3.5-($b%8)))}]
  75     set rowA [expr {3-int(abs(3.5-($a/8)))}]
  76     set rowB [expr {3-int(abs(3.5-($b/8)))}]
  77     return [expr {($colA * $rowA) < ($colB * $rowB) ? $a : $b}]
  78 }
  79
  80 # Display a square number as a standard chess square notation.
  81 proc N {square} {
  82     return [format %c%d [expr {97 + $square % 8}] \
  83                 [expr {$square / 8 + 1}]]
  84 }
  85
  86 # Perform a Knight's move and schedule the next move.
  87 proc MovePiece {dlg last square} {
  88     variable visited
  89     variable delay
  90     variable continuous
  91     $dlg.f.txt insert end "[llength $visited]. [N $last] .. [N $square]\n" {}
  92     $dlg.f.txt see end
  93     $dlg.f.c itemconfigure [expr {1+$last}] -state normal -outline black
  94     $dlg.f.c itemconfigure [expr {1+$square}] -state normal -outline red
  95     $dlg.f.c coords knight [lrange [$dlg.f.c coords [expr {1+$square}]] 0 1]
  96     lappend visited $square
  97     set next [Next $square]
  98     if {$next ne -1} {
  99         variable aid [after $delay [list MovePiece $dlg $square $next]]
 100     } else {
 101         $dlg.tf.b1 configure -state normal
 102         if {[llength $visited] == 64} {
 103             variable initial
 104             if {$initial == $square} {
 105                 $dlg.f.txt insert end "Closed tour!"
 106             } else {
 107                 $dlg.f.txt insert end "Success\n" {}
 108                 if {$continuous} {
 109                     after [expr {$delay * 2}] [namespace code \
 110                         [list Tour $dlg [expr {int(rand() * 64)}]]]
 111                 }
 112             }
 113         } else {
 114             $dlg.f.txt insert end "FAILED!\n" {}
 115         }
 116     }
 117 }
 118
 119 # Begin a new tour of the board given a random start position
 120 proc Tour {dlg {square {}}} {
 121     variable visited {}
 122     $dlg.f.txt delete 1.0 end
 123     $dlg.tf.b1 configure -state disabled
 124     for {set n 0} {$n < 64} {incr n} {
 125         $dlg.f.c itemconfigure $n -state disabled -outline black
 126     }
 127     if {$square eq {}} {
 128         set square [expr {[$dlg.f.c find closest \
 129                                {*}[$dlg.f.c coords knight] 0 65]-1}]
 130     }
 131     variable initial $square
 132     after idle [list MovePiece $dlg $initial $initial]
 133 }
 134
 135 proc Stop {} {
 136     variable aid
 137     catch {after cancel $aid}
 138 }
 139
 140 proc Exit {dlg} {
 141     Stop
 142     destroy $dlg
 143 }
 144
 145 proc SetDelay {new} {
 146     variable delay [expr {int($new)}]
 147 }
 148
 149 proc DragStart {w x y} {
 150     $w dtag selected
 151     $w addtag selected withtag current
 152     variable dragging [list $x $y]
 153 }
 154 proc DragMotion {w x y} {
 155     variable dragging
 156     if {[info exists dragging]} {
 157         $w move selected [expr {$x - [lindex $dragging 0]}] \
 158             [expr {$y - [lindex $dragging 1]}]
 159         variable dragging [list $x $y]
 160     }
 161 }
 162 proc DragEnd {w x y} {
 163     set square [$w find closest $x $y 0 65]
 164     $w coords selected [lrange [$w coords $square] 0 1]
 165     $w dtag selected
 166     variable dragging ; unset dragging
 167 }
 168
 169 proc CreateGUI {} {
 170     catch {destroy .knightstour}
 171     set dlg [toplevel .knightstour]
 172     wm title $dlg "Knights tour"
 173     wm withdraw $dlg
 174     set f [ttk::frame $dlg.f]
 175     set c [canvas $f.c -width 240 -height 240]
 176     text $f.txt -width 10 -height 1 -background white \
 177         -yscrollcommand [list $f.vs set] -font {Arial 8}
 178     ttk::scrollbar $f.vs -command [list $f.txt yview]
 179
 180     variable delay 600
 181     variable continuous 0
 182     ttk::frame $dlg.tf
 183     ttk::label $dlg.tf.ls -text Speed
 184     ttk::scale $dlg.tf.sc  -from 8 -to 2000 -command [list SetDelay] \
 185         -variable [namespace which -variable delay]
 186     ttk::checkbutton $dlg.tf.cc -text Repeat \
 187         -variable [namespace which -variable continuous]
 188     ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg]
 189     ttk::button $dlg.tf.b2 -text Exit -command [list Exit $dlg]
 190     set square 0
 191     for {set row 7} {$row != -1} {incr row -1} {
 192         for {set col 0} {$col < 8} {incr col} {
 193             if {(($col & 1) ^ ($row & 1))} {
 194                 set fill tan3 ; set dfill tan4
 195             } else {
 196                 set fill bisque ; set dfill bisque3
 197             }
 198             set coords [list [expr {$col * 30 + 4}] [expr {$row * 30 + 4}] \
 199                             [expr {$col * 30 + 30}] [expr {$row * 30 + 30}]]
 200             $c create rectangle $coords -fill $fill -disabledfill $dfill \
 201                 -width 2 -state disabled
 202         }
 203     }
 204     catch {eval font create KnightFont -size -24}
 205     $c create text 0 0 -font KnightFont -text "\u265e" \
 206         -anchor nw -tags knight -fill black -activefill "#600000"
 207     $c coords knight [lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1]
 208     $c bind knight <ButtonPress-1> [namespace code [list DragStart %W %x %y]]
 209     $c bind knight <Motion> [namespace code [list DragMotion %W %x %y]]
 210     $c bind knight <ButtonRelease-1> [namespace code [list DragEnd %W %x %y]]
 211
 212     grid $c $f.txt $f.vs  -sticky news
 213     grid rowconfigure    $f 0 -weight 1
 214     grid columnconfigure $f 1 -weight 1
 215
 216     grid $f - - - - - -sticky news
 217     set things [list $dlg.tf.ls $dlg.tf.sc $dlg.tf.cc $dlg.tf.b1]
 218     if {![info exists ::widgetDemo]} {
 219         lappend things $dlg.tf.b2
 220         if {[tk windowingsystem] ne "aqua"} {
 221             set things [linsert $things 0 [ttk::sizegrip $dlg.tf.sg]]
 222         }
 223     }
 224     pack {*}$things -side right
 225     if {[tk windowingsystem] eq "aqua"} {
 226         pack configure {*}$things -padx {4 4} -pady {12 12}
 227         pack configure [lindex $things 0] -padx {4 24}
 228         pack configure [lindex $things end] -padx {16 4}
 229     }
 230     grid $dlg.tf  - - - - - -sticky ew
 231     if {[info exists ::widgetDemo]} {
 232         grid [addSeeDismiss $dlg.buttons $dlg] - - - - - -sticky ew
 233     }
 234
 235     grid rowconfigure $dlg 0 -weight 1
 236     grid columnconfigure $dlg 0 -weight 1
 237
 238     bind $dlg <Control-F2> {console show}
 239     bind $dlg <Return> [list $dlg.tf.b1 invoke]
 240     bind $dlg <Escape> [list $dlg.tf.b2 invoke]
 241     bind $dlg <Destroy> [namespace code [list Stop]]
 242     wm protocol $dlg WM_DELETE_WINDOW [namespace code [list Exit $dlg]]
 243
 244     wm deiconify $dlg
 245     tkwait window $dlg
 246 }
 247
 248 if {!$tcl_interactive} {
 249     if {![winfo exists .knightstour]} {
 250         if {![info exists widgetDemo]} { wm withdraw . }
 251         set r [catch [linsert $argv 0 CreateGUI] err]
 252         if {$r} {
 253             tk_messageBox -icon error -title "Error" -message $err
 254         }
 255         if {![info exists widgetDemo]} { exit $r }
 256     }
 257 }