summaryrefslogtreecommitdiffstats
path: root/library/demos/knightstour.tcl
diff options
context:
space:
mode:
authorpatthoyts <patthoyts@users.sourceforge.net>2008-02-29 22:48:06 (GMT)
committerpatthoyts <patthoyts@users.sourceforge.net>2008-02-29 22:48:06 (GMT)
commiteff9e7b132d60874582d94af7e9d765c26ebeb5d (patch)
treefc686054e73653bad1467adaf11909882d3574d8 /library/demos/knightstour.tcl
parentf63a0d96d95727c2c8f50da3ec71c615f3e367d6 (diff)
downloadtk-eff9e7b132d60874582d94af7e9d765c26ebeb5d.zip
tk-eff9e7b132d60874582d94af7e9d765c26ebeb5d.tar.gz
tk-eff9e7b132d60874582d94af7e9d765c26ebeb5d.tar.bz2
Added a Knights tour canvas demo.
Diffstat (limited to 'library/demos/knightstour.tcl')
-rw-r--r--library/demos/knightstour.tcl247
1 files changed, 247 insertions, 0 deletions
diff --git a/library/demos/knightstour.tcl b/library/demos/knightstour.tcl
new file mode 100644
index 0000000..93f8b47
--- /dev/null
+++ b/library/demos/knightstour.tcl
@@ -0,0 +1,247 @@
+# Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Calculate a Knight's tour of a chessboard.
+#
+# This uses Warnsdorff's rule to calculate the next square each
+# time. This specifies that the next square should be the one that
+# has the least number of available moves.
+#
+# Using this rule it is possible to get to a position where
+# there are no squares available to move into. In this implementation
+# this occurs when the starting square is d6.
+#
+# To solve this fault an enhancement to the rule is that if we
+# have a choice of squares with an equal score, we should choose
+# the one nearest the edge of the board.
+#
+# If the call to the Edgemost function is commented out you can see
+# this occur.
+#
+# You can drag the knight to a specific square to start if you wish.
+# If you let it repeat then it will choose random start positions
+# for each new tour.
+
+package require Tk 8.5
+
+# Return a list of accessible squares from a given square
+proc ValidMoves {square} {
+ set moves {}
+ foreach pair {{-1 -2} {-2 -1} {-2 1} {-1 2} {1 2} {2 1} {2 -1} {1 -2}} {
+ set col [expr {($square % 8) + [lindex $pair 0]}]
+ set row [expr {($square / 8) + [lindex $pair 1]}]
+ if {$row > -1 && $row < 8 && $col > -1 && $col < 8} {
+ lappend moves [expr {$row * 8 + $col}]
+ }
+ }
+ return $moves
+}
+
+# Return the number of available moves for this square
+proc CheckSquare {square} {
+ variable visited
+ set moves 0
+ foreach test [ValidMoves $square] {
+ if {[lsearch -exact -integer $visited $test] == -1} {
+ incr moves
+ }
+ }
+ return $moves
+}
+
+# Select the next square to move to. Returns -1 if there are no available
+# squares remaining that we can move to.
+proc Next {square} {
+ variable visited
+ set minimum 9
+ set nextSquare -1
+ foreach testSquare [ValidMoves $square] {
+ if {[lsearch -exact -integer $visited $testSquare] == -1} {
+ set count [CheckSquare $testSquare]
+ if {$count < $minimum} {
+ set minimum $count
+ set nextSquare $testSquare
+ } elseif {$count == $minimum} {
+ set nextSquare [Edgemost $nextSquare $testSquare]
+ }
+ }
+ }
+ return $nextSquare
+}
+
+# Select the square nearest the edge of the board
+proc Edgemost {a b} {
+ set colA [expr {3-int(abs(3.5-($a%8)))}]
+ set colB [expr {3-int(abs(3.5-($b%8)))}]
+ set rowA [expr {3-int(abs(3.5-($a/8)))}]
+ set rowB [expr {3-int(abs(3.5-($b/8)))}]
+ return [expr {($colA * $rowA) < ($colB * $rowB) ? $a : $b}]
+}
+
+# Display a square number as a standard chess square notation.
+proc N {square} {
+ return [format %c%d [expr {97 + $square % 8}] \
+ [expr {$square / 8 + 1}]]
+}
+
+# Perform a Knight's move and schedule the next move.
+proc MovePiece {dlg last square} {
+ variable visited
+ variable delay
+ variable continuous
+ $dlg.f.txt insert end "[llength $visited]. [N $last] .. [N $square]\n" {}
+ $dlg.f.txt see end
+ $dlg.f.c itemconfigure [expr {1+$last}] -state normal -outline black
+ $dlg.f.c itemconfigure [expr {1+$square}] -state normal -outline red
+ $dlg.f.c coords knight [lrange [$dlg.f.c coords [expr {1+$square}]] 0 1]
+ lappend visited $square
+ set next [Next $square]
+ if {$next ne -1} {
+ variable aid [after $delay [list MovePiece $dlg $square $next]]
+ } else {
+ $dlg.b1 configure -state normal
+ if {[llength $visited] == 64} {
+ variable initial
+ if {$initial == $square} {
+ $dlg.f.txt insert end "Closed tour!"
+ } else {
+ $dlg.f.txt insert end "Success\n" {}
+ if {$continuous} {
+ after [expr {$delay * 2}] [namespace code \
+ [list Tour $dlg [expr {int(rand() * 64)}]]]
+ }
+ }
+ } else {
+ $dlg.f.txt insert end "FAILED!\n" {}
+ }
+ }
+}
+
+# Begin a new tour of the board given a random start position
+proc Tour {dlg {square {}}} {
+ variable visited {}
+ $dlg.f.txt delete 1.0 end
+ $dlg.b1 configure -state disabled
+ for {set n 0} {$n < 64} {incr n} {
+ $dlg.f.c itemconfigure $n -state disabled -outline black
+ }
+ if {$square eq {}} {
+ set square [expr {[$dlg.f.c find closest \
+ {*}[$dlg.f.c coords knight] 0 65]-1}]
+ }
+ variable initial $square
+ after idle [list MovePiece $dlg $initial $initial]
+}
+
+proc Stop {} {
+ variable aid
+ catch {after cancel $aid}
+}
+
+proc Exit {dlg} {
+ Stop
+ destroy $dlg
+}
+
+proc SetDelay {new} {
+ variable delay [expr {int($new)}]
+}
+
+proc DragStart {w x y} {
+ $w dtag selected
+ $w addtag selected withtag current
+ variable dragging [list $x $y]
+}
+proc DragMotion {w x y} {
+ variable dragging
+ if {[info exists dragging]} {
+ $w move selected [expr {$x - [lindex $dragging 0]}] \
+ [expr {$y - [lindex $dragging 1]}]
+ variable dragging [list $x $y]
+ }
+}
+proc DragEnd {w x y} {
+ set square [$w find closest $x $y 0 65]
+ $w coords selected [lrange [$w coords $square] 0 1]
+ $w dtag selected
+ variable dragging ; unset dragging
+}
+
+proc CreateGUI {} {
+ catch {destroy .knightstour}
+ set dlg [toplevel .knightstour]
+ wm title $dlg "Knights tour"
+ wm withdraw $dlg
+ set f [ttk::frame $dlg.f]
+ set c [canvas $f.c -width 240 -height 240]
+ text $f.txt -width 10 -height 1 -background white \
+ -yscrollcommand [list $f.vs set] -font {Arial 8}
+ ttk::scrollbar $f.vs -command [list $f.txt yview]
+
+ variable delay 600
+ variable continuous 0
+ ttk::label $dlg.ls -text Speed
+ ttk::scale $dlg.sc -from 8 -to 2000 -command [list SetDelay] \
+ -variable [namespace which -variable delay]
+ ttk::checkbutton $dlg.cc -text Repeat \
+ -variable [namespace which -variable continuous]
+ ttk::button $dlg.b1 -text Start -command [list Tour $dlg]
+ ttk::button $dlg.b2 -text Exit -command [list Exit $dlg]
+ set square 0
+ for {set row 7} {$row != -1} {incr row -1} {
+ for {set col 0} {$col < 8} {incr col} {
+ if {(($col & 1) ^ ($row & 1))} {
+ set fill tan3 ; set dfill tan4
+ } else {
+ set fill bisque ; set dfill bisque3
+ }
+ set coords [list [expr {$col * 30 + 3}] [expr {$row * 30 + 3}] \
+ [expr {$col * 30 + 29}] [expr {$row * 30 + 29}]]
+ $c create rectangle $coords -fill $fill -disabledfill $dfill \
+ -width 2 -state disabled
+ }
+ }
+ catch {eval font create KnightFont -size -24}
+ $c create text 0 0 -font KnightFont -text "\u265e" \
+ -anchor nw -tags knight -fill black -activefill "#600000"
+ $c coords knight [lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1]
+ $c bind knight <ButtonPress-1> [namespace code [list DragStart %W %x %y]]
+ $c bind knight <Motion> [namespace code [list DragMotion %W %x %y]]
+ $c bind knight <ButtonRelease-1> [namespace code [list DragEnd %W %x %y]]
+
+ grid $c $f.txt $f.vs -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 1 -weight 1
+
+ grid $f - - - - - -sticky news
+ set things [list $dlg.ls $dlg.sc $dlg.cc $dlg.b1]
+ if {![info exists ::widgetDemo]} {
+ lappend things $dlg.b2 [ttk::sizegrip $dlg.sg]
+ }
+ grid {*}$things -sticky e
+ if {[info exists ::widgetDemo]} {
+ grid [addSeeDismiss $dlg.buttons $dlg] - - - - - -sticky ew
+ }
+
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+
+ bind $dlg <Control-F2> {console show}
+ bind $dlg <Return> [list $dlg.b1 invoke]
+ bind $dlg <Escape> [list $dlg.b2 invoke]
+ bind $dlg <Destroy> [namespace code [list Stop]]
+ wm protocol $dlg WM_DELETE_WINDOW [namespace code [list Exit $dlg]]
+
+ wm deiconify $dlg
+ tkwait window $dlg
+}
+
+if {!$tcl_interactive} {
+ if {![winfo exists .knightstour]} {
+ if {![info exists widgetDemo]} { wm withdraw . }
+ set r [catch [linsert $argv 0 CreateGUI] err]
+ if {$r} {
+ tk_messageBox -icon error -title "Error" -message $err
+ }
+ if {![info exists widgetDemo]} { exit $r }
+ }
+}