util/X86LINUX64/lib/tk8.6/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                 # to remove the enhancement to Warnsdorff's rule
  65                 # remove the next line:
  66                 set nextSquare [Edgemost $nextSquare $testSquare]
  67             }
  68         }
  69     }
  70     return $nextSquare
  71 }
  72
  73 # Select the square nearest the edge of the board
  74 proc Edgemost {a b} {
  75     set colA [expr {3-int(abs(3.5-($a%8)))}]
  76     set colB [expr {3-int(abs(3.5-($b%8)))}]
  77     set rowA [expr {3-int(abs(3.5-($a/8)))}]
  78     set rowB [expr {3-int(abs(3.5-($b/8)))}]
  79     return [expr {($colA * $rowA) < ($colB * $rowB) ? $a : $b}]
  80 }
  81
  82 # Display a square number as a standard chess square notation.
  83 proc N {square} {
  84     return [format %c%d [expr {97 + $square % 8}] \
  85                 [expr {$square / 8 + 1}]]
  86 }
  87
  88 # Perform a Knight's move and schedule the next move.
  89 proc MovePiece {dlg last square} {
  90     variable visited
  91     variable delay
  92     variable continuous
  93     $dlg.f.txt insert end "[llength $visited]. [N $last] .. [N $square]\n" {}
  94     $dlg.f.txt see end
  95     $dlg.f.c itemconfigure [expr {1+$last}] -state normal -outline black
  96     $dlg.f.c itemconfigure [expr {1+$square}] -state normal -outline red
  97     $dlg.f.c moveto knight {*}[lrange [$dlg.f.c coords [expr {1+$square}]] 0 1]
  98     lappend visited $square
  99     set next [Next $square]
 100     if {$next ne -1} {
 101         variable aid [after $delay [list MovePiece $dlg $square $next]]
 102     } else {
 103         $dlg.tf.b1 configure -state normal
 104         if {[llength $visited] == 64} {
 105             variable initial
 106             if {$initial == $square} {
 107                 $dlg.f.txt insert end "Closed tour!"
 108             } else {
 109                 $dlg.f.txt insert end "Success\n" {}
 110                 if {$continuous} {
 111                     after [expr {$delay * 2}] [namespace code \
 112                         [list Tour $dlg [expr {int(rand() * 64)}]]]
 113                 }
 114             }
 115         } else {
 116             $dlg.f.txt insert end "FAILED!\n" {}
 117         }
 118     }
 119 }
 120
 121 # Begin a new tour of the board given a random start position
 122 proc Tour {dlg {square {}}} {
 123     variable visited {}
 124     $dlg.f.txt delete 1.0 end
 125     $dlg.tf.b1 configure -state disabled
 126     for {set n 0} {$n < 64} {incr n} {
 127         $dlg.f.c itemconfigure $n -state disabled -outline black
 128     }
 129     if {$square eq {}} {
 130         set coords [lrange [$dlg.f.c coords knight] 0 1]
 131         set square [expr {[$dlg.f.c find closest {*}$coords 0 65]-1}]
 132     }
 133     variable initial $square
 134     after idle [list MovePiece $dlg $initial $initial]
 135 }
 136
 137 proc Stop {} {
 138     variable aid
 139     catch {after cancel $aid}
 140 }
 141
 142 proc Exit {dlg} {
 143     Stop
 144     destroy $dlg
 145 }
 146
 147 proc SetDelay {new} {
 148     variable delay [expr {int($new)}]
 149 }
 150
 151 proc DragStart {w x y} {
 152     $w dtag selected
 153     $w addtag selected withtag current
 154     variable dragging [list $x $y]
 155 }
 156 proc DragMotion {w x y} {
 157     variable dragging
 158     if {[info exists dragging]} {
 159         $w move selected [expr {$x - [lindex $dragging 0]}] \
 160             [expr {$y - [lindex $dragging 1]}]
 161         variable dragging [list $x $y]
 162     }
 163 }
 164 proc DragEnd {w x y} {
 165     set square [$w find closest $x $y 0 65]
 166     $w moveto selected {*}[lrange [$w coords $square] 0 1]
 167     $w dtag selected
 168     variable dragging ; unset dragging
 169 }
 170
 171 proc CreateGUI {} {
 172     catch {destroy .knightstour}
 173     set dlg [toplevel .knightstour]
 174     wm title $dlg "Knights tour"
 175     wm withdraw $dlg
 176     set f [ttk::frame $dlg.f]
 177     set c [canvas $f.c -width 240 -height 240]
 178     text $f.txt -width 10 -height 1 -background white \
 179         -yscrollcommand [list $f.vs set] -font {Arial 8}
 180     ttk::scrollbar $f.vs -command [list $f.txt yview]
 181
 182     variable delay 600
 183     variable continuous 0
 184     ttk::frame $dlg.tf
 185     ttk::label $dlg.tf.ls -text Speed
 186     ttk::scale $dlg.tf.sc  -from 8 -to 2000 -command [list SetDelay] \
 187         -variable [namespace which -variable delay]
 188     ttk::checkbutton $dlg.tf.cc -text Repeat \
 189         -variable [namespace which -variable continuous]
 190     ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg]
 191     ttk::button $dlg.tf.b2 -text Exit -command [list Exit $dlg]
 192     set square 0
 193     for {set row 7} {$row != -1} {incr row -1} {
 194         for {set col 0} {$col < 8} {incr col} {
 195             if {(($col & 1) ^ ($row & 1))} {
 196                 set fill tan3 ; set dfill tan4
 197             } else {
 198                 set fill bisque ; set dfill bisque3
 199             }
 200             set coords [list [expr {$col * 30 + 4}] [expr {$row * 30 + 4}] \
 201                             [expr {$col * 30 + 30}] [expr {$row * 30 + 30}]]
 202             $c create rectangle $coords -fill $fill -disabledfill $dfill \
 203                 -width 2 -state disabled
 204         }
 205     }
 206     if {[tk windowingsystem] ne "x11"} {
 207         catch {eval font create KnightFont -size -24}
 208         $c create text 0 0 -font KnightFont -text "\u265e" \
 209             -anchor nw -tags knight -fill black -activefill "#600000"
 210     } else {
 211         # On X11 we cannot reliably tell if the \u265e glyph is available
 212         # so just use a polygon
 213         set pts {
 214             2 25   24 25  21 19   20 8   14 0   10 0   0 13   0 16
 215             2 17    4 14   5 15    3 17   5 17   9 14  10 15  5 21
 216         }
 217         $c create polygon $pts -tag knight -offset 8 \
 218             -fill black -activefill "#600000"
 219     }
 220     $c moveto knight {*}[lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1]
 221     $c bind knight <ButtonPress-1> [namespace code [list DragStart %W %x %y]]
 222     $c bind knight <Motion> [namespace code [list DragMotion %W %x %y]]
 223     $c bind knight <ButtonRelease-1> [namespace code [list DragEnd %W %x %y]]
 224
 225     grid $c $f.txt $f.vs  -sticky news
 226     grid rowconfigure    $f 0 -weight 1
 227     grid columnconfigure $f 1 -weight 1
 228
 229     grid $f - - - - - -sticky news
 230     set things [list $dlg.tf.ls $dlg.tf.sc $dlg.tf.cc $dlg.tf.b1]
 231     if {![info exists ::widgetDemo]} {
 232         lappend things $dlg.tf.b2
 233         if {[tk windowingsystem] ne "aqua"} {
 234             set things [linsert $things 0 [ttk::sizegrip $dlg.tf.sg]]
 235         }
 236     }
 237     pack {*}$things -side right
 238     if {[tk windowingsystem] eq "aqua"} {
 239         pack configure {*}$things -padx {4 4} -pady {12 12}
 240         pack configure [lindex $things 0] -padx {4 24}
 241         pack configure [lindex $things end] -padx {16 4}
 242     }
 243     grid $dlg.tf  - - - - - -sticky ew
 244     if {[info exists ::widgetDemo]} {
 245         grid [addSeeDismiss $dlg.buttons $dlg] - - - - - -sticky ew
 246     }
 247
 248     grid rowconfigure $dlg 0 -weight 1
 249     grid columnconfigure $dlg 0 -weight 1
 250
 251     bind $dlg <Control-F2> {console show}
 252     bind $dlg <Return> [list $dlg.tf.b1 invoke]
 253     bind $dlg <Escape> [list $dlg.tf.b2 invoke]
 254     bind $dlg <Destroy> [namespace code [list Stop]]
 255     wm protocol $dlg WM_DELETE_WINDOW [namespace code [list Exit $dlg]]
 256
 257     wm deiconify $dlg
 258     tkwait window $dlg
 259 }
 260
 261 if {![winfo exists .knightstour]} {
 262     if {![info exists widgetDemo]} { wm withdraw . }
 263     set r [catch [linsert $argv 0 CreateGUI] err]
 264     if {$r} {
 265         tk_messageBox -icon error -title "Error" -message $err
 266     }
 267     if {![info exists widgetDemo]} { exit $r }
 268 }