summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/tk8.6/demos/knightstour.tcl
blob: 3c2972067566d393b964f39c7465dbd84051d55c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
# 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} {
                # to remove the enhancement to Warnsdorff's rule
                # remove the next line:
                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 moveto 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.tf.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.tf.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 coords [lrange [$dlg.f.c coords knight] 0 1]
        set square [expr {[$dlg.f.c find closest {*}$coords 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 moveto 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 \
        -yscrollcommand [list $f.vs set] -font {Arial 8}
    ttk::scrollbar $f.vs -command [list $f.txt yview]

    variable delay 600
    variable continuous 0
    ttk::frame $dlg.tf
    ttk::label $dlg.tf.ls -text Speed
    ttk::scale $dlg.tf.sc  -from 8 -to 2000 -command [list SetDelay] \
        -variable [namespace which -variable delay]
    ttk::checkbutton $dlg.tf.cc -text Repeat \
        -variable [namespace which -variable continuous]
    ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg]
    ttk::button $dlg.tf.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 + 4}] [expr {$row * 30 + 4}] \
                            [expr {$col * 30 + 30}] [expr {$row * 30 + 30}]]
            $c create rectangle $coords -fill $fill -disabledfill $dfill \
                -width 2 -state disabled -outline black
        }
    }
    if {[tk windowingsystem] ne "x11"} {
        catch {eval font create KnightFont -size -24}
        $c create text 0 0 -font KnightFont -text "\u265e" \
            -anchor nw -tags knight -fill black -activefill "#600000"
    } else {
        # On X11 we cannot reliably tell if the \u265e glyph is available
        # so just use a polygon
        set pts {
            2 25   24 25  21 19   20 8   14 0   10 0   0 13   0 16
            2 17    4 14   5 15    3 17   5 17   9 14  10 15  5 21
        }
        $c create polygon $pts -tag knight -offset 8 \
            -fill black -activefill "#600000"
    }
    $c moveto 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.tf.ls $dlg.tf.sc $dlg.tf.cc $dlg.tf.b1]
    if {![info exists ::widgetDemo]} {
	lappend things $dlg.tf.b2
	if {[tk windowingsystem] ne "aqua"} {
	    set things [linsert $things 0 [ttk::sizegrip $dlg.tf.sg]]
	}
    }
    pack {*}$things -side right
    if {[tk windowingsystem] eq "aqua"} {
	pack configure {*}$things -padx {4 4} -pady {12 12}
	pack configure [lindex $things 0] -padx {4 24}
	pack configure [lindex $things end] -padx {16 4}
    }
    grid $dlg.tf  - - - - - -sticky ew
    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.tf.b1 invoke]
    bind $dlg <Escape> [list $dlg.tf.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 {![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 }
}