Scid  4.6.5
board.tcl
Go to the documentation of this file.
1 # board.tcl: part of Scid
2 # Copyright (C) 2001-2003 Shane Hudson. All rights reserved.
3 # Copyright (C) 2014 Fulvio Benini
4 
5 # letterToPiece
6 # Array that maps piece letters to their two-character value.
7 #
8 array set ::board::letterToPiece [list \
9  "R" wr "r" br "N" wn "n" bn "B" wb "b" bb \
10  "Q" wq "q" bq "K" wk "k" bk "P" wp "p" bp "." e]
11 
12 # List of color schemes: each sublist contains a reference name (not used),
13 # then lite, dark, highcolor, bestcolor, white, black, w border, b border.
14 #
15 set colorSchemes {
16  { "Blue-white" "#f3f3f3" "#7389b6" "#f3f484" "#b8cbf8" "#ffffff" "#000000" "#000000" "#ffffff" }
17  { "Green-Yellow" "#e0d070" "#70a070" "#b0d0e0" "#bebebe" }
18  { "Brown" "#d0c0a0" "#a08050" "#b0d0e0" "#bebebe" }
19  { "Blue-ish" "#d0e0d0" "#80a0a0" "#b0d0e0" "#f0f0a0" }
20  { "M. Thomas" "#e0d8b8" "#047c24" "#1c80e0" "#fe0000" }
21  { "KM. Skontorp" "#ffdb86" "#ffa200" "#b0d0e0" "#bebebe" }
22 }
23 array set newColors {}
24 
25 proc SetBoardTextures {} {
26  global boardfile_dark boardfile_lite
27  # handle cases of old configuration files
28  image create photo bgl20 -height 20 -width 20
29  image create photo bgd20 -height 20 -width 20
30  if { [ catch { bgl20 copy $boardfile_lite -from 0 0 20 20 ; bgd20 copy $boardfile_dark -from 0 0 20 20}] } {
31  set boardfile_dark emptySquare
32  set boardfile_lite emptySquare
33  bgl20 copy $boardfile_lite -from 0 0 20 20
34  bgd20 copy $boardfile_dark -from 0 0 20 20
35  }
36 
37  set textureSize "[image height $boardfile_lite].0"
38  foreach size $::boardSizes {
39  # create lite and dark squares
40  image create photo bgl$size -width $size -height $size
41  image create photo bgd$size -width $size -height $size
42  set z [expr int (ceil ($size / $textureSize))]
43  bgl$size copy $boardfile_lite -zoom $z
44  bgd$size copy $boardfile_dark -zoom $z
45  }
46 }
47 
48 # setPieceFont:
49 # Given a piece font name, resets all piece images in all
50 # available board sizes to that font.
51 #
52 proc setPieceFont {font} {
53  set ::boardSizes {}
54  set dname [file join $::scidImgDir pieces $font]
55  set fnames [glob -nocomplain -directory $dname *.png]
56  append fnames " " [glob -nocomplain -directory $dname *.gif]
57  foreach {fname} $fnames {
58  if {! [catch {image create photo tmpPieces -file "$fname"}]} {
59  set size [image height tmpPieces]
60  if {[lsearch -exact $::boardSizes $size] == -1} {
61  image create photo e$size -height $size -width $size
62  set x 0
63  foreach p {wp wn wb wr wq wk bp bn bb br bq bk} {
64  image create photo $p$size -width $size -height $size
65  $p$size copy tmpPieces -from $x 0 [expr {$x + $size}] $size
66  incr x $size
67  }
68  lappend ::boardSizes $size
69  }
70  image delete tmpPieces
71  }
72  }
73  if {[llength $::boardSizes] == 0 && $::boardStyle != "Merida"} {
74  set ::boardStyle "Merida"
75  setPieceFont "$::boardStyle"
76  return
77  }
78  set ::boardSizes [lsort -integer $::boardSizes]
79  foreach size $::boardSizes {
80  if {$size >= $::boardSize} { break}
81  }
82  set ::boardSize $size
85 }
86 
87 # chooseBoardTextures:
88 # Dialog for selecting board textures.
89 #
90 proc chooseBoardTextures {i} {
91  global boardfile_dark boardfile_lite
92 
93  set prefix [lindex $::textureSquare $i]
94  set boardfile_dark ${prefix}-d
95  set boardfile_lite ${prefix}-l
97 
98 }
99 
100 # chooseBoardColors:
101 # Dialog for selecting board colors.
102 #
103 proc chooseBoardColors {{choice -1}} {
104  global lite dark highcolor bestcolor
105  global colorSchemes newColors
106 
107  set colors {lite dark highcolor bestcolor}
108 
109  set w .boardColorDialog
110 
111  if {[winfo exists $w]} {
112  # Just update the dialog box colors and return:
113  if {$choice >= 0} {
114  set list [lindex $colorSchemes $choice]
115  set newColors(lite) [lindex $list 1]
116  set newColors(dark) [lindex $list 2]
117  set newColors(highcolor) [lindex $list 3]
118  set newColors(bestcolor) [lindex $list 4]
119  }
120  set nlite $newColors(lite)
121  set ndark $newColors(dark)
122 
123  foreach i {wr bn wb bq wk bp} {
124  $w.bd.$i configure -background $ndark
125  }
126  foreach i {br wn bb wq bk wp} {
127  $w.bd.$i configure -background $nlite
128  }
129  $w.bd.bb configure -background $newColors(highcolor)
130  $w.bd.wk configure -background $newColors(bestcolor)
131  foreach i $colors {
132  $w.select.b$i configure -background $newColors($i)
133  }
134 
135  foreach i {0 1 2 3} {
136  set c $w.border.c$i
137  $c itemconfigure dark -fill $dark -outline $dark
138  $c itemconfigure lite -fill $lite -outline $lite
139  }
140 
141  return
142  }
143 
144  toplevel $w
145  wm title $w "Scid: [tr OptionsBoardColors]"
146 
147  foreach i $colors { set newColors($i) [set $i]}
148  set bd $w.bd
149  pack [ttk::frame $bd] -side top -expand 1
151  pack [ttk::frame $w.select] -side top -fill x
153  pack [ttk::frame $w.preset] -side top -fill x
154  pack [ttk::frame $w.texture] -side top -fill x
156  pack [ttk::frame $w.border] -side top
158  pack [ttk::frame $w.buttons] -side top -fill x
159 
160  foreach psize $::boardSizes {
161  if {$psize >= 40} { break}
162  }
163  set column 0
164  foreach j {r n b q k p} {
165  ttk::label $bd.w$j -image w${j}$psize
166  ttk::label $bd.b$j -image b${j}$psize
167  grid $bd.b$j -row 0 -column $column
168  grid $bd.w$j -row 1 -column $column
169  incr column
170  }
171 
172  set f $w.select
173  foreach row {0 1 0 1} column {0 0 2 2} c {
174  lite dark highcolor bestcolor
175  } n {
176  LightSquares DarkSquares SelectedSquares SuggestedSquares
177  } {
178  button $f.b$c -image e20 -background [set $c] -command "
179  set x \[ tk_chooseColor -initialcolor \$newColors($c) -title Scid \]
180  if {\$x != \"\"} { set newColors($c) \$x; chooseBoardColors }
181  "
182  ttk::label $f.l$c -text "$::tr($n) "
183  grid $f.b$c -row $row -column $column
184  grid $f.l$c -row $row -column [expr {$column + 1}] -sticky w
185  }
186 
187  # Border width option:
188  set f $w.border
189  foreach i {0 1 2 3} {
190  if {$i != 0} { pack [ttk::frame $f.gap$i -width 20] -side left -padx 1}
191  set b $f.b$i
192  ttk::radiobutton $b -text "$i:" -variable newborderwidth -value $i
193  set c $f.c$i
194  canvas $c -height $psize -width $psize -background black
195  $c create rectangle 0 0 [expr {20 - $i}] [expr {20 - $i}] -tag dark
196  $c create rectangle [expr {20 + $i}] [expr {20 + $i}] $psize $psize -tag dark
197  $c create rectangle 0 [expr {20 + $i}] [expr 20 - $i] $psize -tag lite
198  $c create rectangle [expr {20 + $i}] 0 $psize [expr {20 - $i}] -tag lite
199  pack $b $c -side left -padx 1
200  bind $c <Button-1> "set newborderwidth $i"
201  }
202  set ::newborderwidth $::borderwidth
203 
204  set count 0
205  foreach list $colorSchemes {
206  set f $w.preset.p$count
207  pack [ttk::frame $f] -side left -padx 5
208  ttk::label $f.blite -image bp$psize -background [lindex $list 1]
209  ttk::label $f.bdark -image bp$psize -background [lindex $list 2]
210  ttk::label $f.wlite -image wp$psize -background [lindex $list 1]
211  ttk::label $f.wdark -image wp$psize -background [lindex $list 2]
212  ttk::button $f.select -text [expr {$count + 1}] -command "chooseBoardColors $count ; \
213  set ::boardfile_dark emptySquare ; \
214  set ::boardfile_lite emptySquare ; \
215  ::SetBoardTextures "
216  foreach i {blite bdark wlite wdark} {
217  bind $f.$i <1> "chooseBoardColors $count ; \
218  set ::boardfile_dark emptySquare ; \
219  set ::boardfile_lite emptySquare ; \
220  ::SetBoardTextures "
221  }
222  grid $f.blite -row 0 -column 0 -sticky e
223  grid $f.bdark -row 0 -column 1 -sticky w
224  grid $f.wlite -row 1 -column 1 -sticky w
225  grid $f.wdark -row 1 -column 0 -sticky e
226  grid $f.select -row 2 -column 0 -columnspan 2 ; # -sticky we
227  incr count
228  }
229 
230  #########################################################
231  set f $w.texture
232  set count 0
233  set row 0
234  set col 0
235  foreach tex $::textureSquare {
236  set f $w.texture.p$count
237  grid [ ttk::frame $f] -row $row -column $col -padx 5
238  canvas $f.c -width [expr $psize*2] -height [expr $psize*2] -background red
239  $f.c create image 0 0 -image ${tex}-l -anchor nw
240  $f.c create image $psize 0 -image ${tex}-d -anchor nw
241  $f.c create image 0 $psize -image ${tex}-d -anchor nw
242  $f.c create image $psize $psize -image ${tex}-l -anchor nw
243 
244  $f.c create image 0 0 -image bp$psize -anchor nw
245  $f.c create image $psize 0 -image wp$psize -anchor nw
246  $f.c create image 0 $psize -image wp$psize -anchor nw
247  $f.c create image $psize $psize -image bp$psize -anchor nw
248  ttk::button $f.select -text [expr {$count + 1}] -command "chooseBoardTextures $count"
249  bind $f.c <1> "chooseBoardTextures $count"
250  pack $f.c $f.select -side top
251 
252  incr count
253  incr col
254  if {$col > 4} { set col 0 ; incr row}
255  }
256 
257  dialogbutton $w.buttons.ok -text "OK" -command "
258  foreach i {lite dark highcolor bestcolor} {
259  set \$i \$newColors(\$i)
260  }
261  set borderwidth \$newborderwidth
262  ::board::border .main.board \$borderwidth
263  grab release $w
264  destroy $w
265  "
266  dialogbutton $w.buttons.cancel -text $::tr(Cancel) \
267  -command "catch {grab release $w}; destroy $w"
268  bind $w <Escape> "catch {grab release $w}; destroy $w"
269  packbuttons right $w.buttons.cancel $w.buttons.ok
271  wm resizable $w 0 0
272  catch {grab $w}
273 }
274 
275 namespace eval ::board {
276 
277  namespace export sq
278 
279  # List of square names in order; used by sq procedure.
280  variable squareIndex [list a1 b1 c1 d1 e1 f1 g1 h1 a2 b2 c2 d2 e2 f2 g2 h2 \
281  a3 b3 c3 d3 e3 f3 g3 h3 a4 b4 c4 d4 e4 f4 g4 h4 \
282  a5 b5 c5 d5 e5 f5 g5 h5 a6 b6 c6 d6 e6 f6 g6 h6 \
283  a7 b7 c7 d7 e7 f7 g7 h7 a8 b8 c8 d8 e8 f8 g8 h8]
284 }
285 
286 # ::board::sq:
287 # Given a square name, returns its index as used in board
288 # representations, or -1 if the square name is invalid.
289 # Examples: [sq h8] == 63; [sq a1] = 0; [sq notASquare] = -1.
290 #
291 proc ::board::sq {sqname} {
292  variable squareIndex
293  return [lsearch -exact $squareIndex $sqname]
294 }
295 
296 # ::board::san --
297 #
298 # Convert a square number (0-63) used in board representations
299 # to the SAN square name (a1, a2, ..., h8).
300 #
301 # Arguments:
302 # sqno square number 0-63.
303 # Results:
304 # Returns square name "a1"-"h8".
305 #
306 proc ::board::san {sqno} {
307  if {($sqno < 0) || ($sqno > 63)} { return}
308  return [format %c%c \
309  [expr {($sqno % 8) + [scan a %c]}] \
310  [expr {($sqno / 8) + [scan 1 %c]}]]
311 
312 }
313 
314 # ::board::new
315 # Creates a new board in the specified frame.
316 #
317 proc ::board::new {w {psize 40} } {
318  if {[winfo exists $w]} { return}
319 
320  foreach size $::boardSizes {
321  if {$size >= $psize} { break}
322  }
323  set psize $size
324 
325  set ::board::_size($w) $psize
326  set ::board::_border($w) $::borderwidth
327  set ::board::_coords($w) 2
328  set ::board::_flip($w) 0
329  set ::board::_data($w) [sc_pos board]
330  set ::board::_showMarks($w) 0
331  set ::board::_mark($w) {}
332  set ::board::_drag($w) -1
333  set ::board::_showmat($w) 0
334 
335  set border $::board::_border($w)
336  set bsize [expr {$psize * 8 + $border * 9}]
337  set bgcolor [ttk::style lookup Button.label -background]
338 
339  ttk::frame $w -class Board
340  canvas $w.bd -width $bsize -height $bsize -cursor crosshair -background $bgcolor -borderwidth 0 -highlightthickness 0
341  catch { grid anchor $w center}
342 
343  set startrow 5
344  grid $w.bd -row [expr $startrow +1] -column 3 -rowspan 8 -columnspan 8
345  set bd $w.bd
346 
347  # Create empty board:
348  for {set i 0} {$i < 64} {incr i} {
349  set xi [expr {$i % 8}]
350  set yi [expr {int($i/8)}]
351  set x1 [expr {$xi * ($psize + $border) + $border }]
352  set y1 [expr {(7 - $yi) * ($psize + $border) + $border }]
353  set x2 [expr {$x1 + $psize }]
354  set y2 [expr {$y1 + $psize }]
355 
356  $bd create rectangle $x1 $y1 $x2 $y2 -tag sq$i -outline ""
357  }
358 
359  # Set up coordinate labels:
360  for {set i 1} {$i <= 8} {incr i} {
361  ttk::label $w.lrank$i -text [expr {9 - $i}]
362  grid $w.lrank$i -row [expr $startrow + $i] -column 2 -sticky e -padx 5
363  ttk::label $w.rrank$i -text [expr {9 - $i}]
364  grid $w.rrank$i -row [expr $startrow + $i] -column 11 -sticky w -padx 5
365  }
366  foreach i {1 2 3 4 5 6 7 8} file {a b c d e f g h} {
367  ttk::label $w.tfile$file -text $file
368  grid $w.tfile$file -row $startrow -column [expr $i + 2] -sticky s
369  ttk::label $w.bfile$file -text $file
370  grid $w.bfile$file -row [expr $startrow + 9] -column [expr $i + 2] -sticky n
371  }
372 
373  canvas $w.mat -width 20 -height $bsize -highlightthickness 0 -background $bgcolor
374  grid $w.mat -row 6 -column 12 -rowspan 8 -pady 5 -padx 5
375  grid remove $w.mat
376 
377  ::board::coords $w
378  ::board::update $w
379  return $w
380 }
381 
382 proc ::board::addNamesBar {w {varname}} {
383  set bgcolor #fbfbfb
384  frame $w.playerW -background $bgcolor
385  frame $w.playerW.color -background #EAE0C8 -width 6 -height 6
386  canvas $w.playerW.tomove -borderwidth 0 -background $bgcolor -highlightthickness 0 -width 9 -height 9
387  label $w.playerW.name -textvariable ${varname}(nameW) -background $bgcolor -font font_SmallBold
388  label $w.playerW.elo -textvariable ${varname}(eloW) -background $bgcolor -font font_Small
389  label $w.playerW.clock -textvariable ${varname}(clockW) -background $bgcolor -font font_Small
390  grid $w.playerW.color -row 0 -column 0 -sticky news -padx 2 -pady 2
391  grid $w.playerW.name -row 0 -column 1 -sticky w
392  grid $w.playerW.elo -row 0 -column 2 -sticky w
393  grid $w.playerW.clock -row 0 -column 3 -sticky e
394  grid $w.playerW.tomove -row 0 -column 4 -sticky w -padx 4
395  grid columnconfigure $w.playerW 3 -weight 1
396  grid $w.playerW -row 16 -column 3 -columnspan 8 -sticky news -pady 4
397 
398  frame $w.playerB -background $bgcolor
399  frame $w.playerB.color -background black -width 6 -height 6
400  canvas $w.playerB.tomove -borderwidth 0 -background $bgcolor -highlightthickness 0 -width 9 -height 9
401  label $w.playerB.name -textvariable ${varname}(nameB) -background $bgcolor -font font_SmallBold
402  label $w.playerB.elo -textvariable ${varname}(eloB) -background $bgcolor -font font_Small
403  label $w.playerB.clock -textvariable ${varname}(clockB) -background $bgcolor -font font_Small
404  grid $w.playerB.color -row 0 -column 0 -sticky news -padx 2 -pady 2
405  grid $w.playerB.name -row 0 -column 1 -sticky w
406  grid $w.playerB.elo -row 0 -column 2 -sticky w
407  grid $w.playerB.clock -row 0 -column 3 -sticky e
408  grid $w.playerB.tomove -row 0 -column 4 -sticky w -padx 4
409  grid columnconfigure $w.playerB 3 -weight 1
410  grid $w.playerB -row 3 -column 3 -columnspan 8 -sticky news -pady 4
411 }
412 
413 proc ::board::addInfoBar {w varname} {
414  ttk::frame $w.bar
415  set $w.bar.info [ttk::frame $w.bar.info]
416  autoscrollframe $w.bar.info text $w.bar.info.t -relief flat -bg [ttk::style lookup Button.label -background] \
417  -font font_Regular -cursor arrow -state disabled
418  $w.bar.info.t tag configure header -font font_Bold
419  $w.bar.info.t tag bind click <Any-Enter> "$w.bar.info.t configure -cursor hand2"
420  $w.bar.info.t tag bind click <Any-Leave> "$w.bar.info.t configure -cursor {}"
421  grid propagate $w.bar.info 0
422  grid $w.bar.info.t -sticky news
423  ttk::button $w.bar.back -image tb_BD_Back -style Toolbutton
424  ttk::button $w.bar.cmd -image tb_BD_ShowToolbar -style Toolbutton -command "::board::toggleInfoBar_ $w"
425  ttk::button $w.bar.forward -image tb_BD_Forward -style Toolbutton
426  set bar_tb [::board::newToolBar_ $w $varname]
427  grid $w.bar.back -row 0 -column 0 -sticky news
428  grid $w.bar.cmd -in $w.bar -row 0 -column 1 -sticky news -padx 8
429  grid $bar_tb -in $w.bar -row 0 -column 2 -sticky ew
430  grid remove $bar_tb
431  grid $w.bar.info -in $w.bar -row 0 -column 2 -sticky news
432  grid $w.bar.forward -row 0 -column 4 -sticky news
433  grid columnconfigure $w.bar 2 -weight 1
434  grid $w.bar -row 20 -column 3 -columnspan 8 -sticky news -pady 4
435 }
436 
437 proc ::board::setInfo {{w} {msg}} {
438  toggleInfoBar_ $w "tmpRestore"
439  $w.bar.info.t configure -state normal
440  $w.bar.info.t delete 1.0 end
441  $w.bar.info.t insert end "$msg"
442  $w.bar.info.t configure -state disabled
443 }
444 
445 
446 proc ::board::setInfoAlert {{w} {header} {msg} {msgcolor} {cmd}} {
447  $w.bar.info.t configure -state normal
448  $w.bar.info.t delete 1.0 end
449  $w.bar.info.t insert end "$header " {header click}
450  $w.bar.info.t insert end "$msg" {color click}
451  $w.bar.info.t configure -state disabled
452  $w.bar.info.t tag configure color -foreground $msgcolor
453  $w.bar.info.t tag bind click <ButtonRelease-1> "
454  if {[winfo exists $cmd]} {
455  after idle \"tk_popup $cmd %X \[expr -10 + %Y - \[winfo reqheight $cmd\] \]\"
456  } else {
457  after idle $cmd
458  }
459  "
460  toggleInfoBar_ $w "tmpInfo"
461 }
462 
463 set ::board::repeatCmd 400
464 proc ::board::setButtonCmd {{w} {button} {cmd}} {
465  if {$cmd == ""} {
466  $w.bar.$button configure -state disabled
467  } else {
468  $w.bar.$button configure -state normal
469  ::bind $w.bar.$button <ButtonPress-1> "
470  $cmd
471  set ::board::repeatCmd \[expr int(\$::board::repeatCmd *0.8)\]
472  after \$::board::repeatCmd \"event generate $w.bar.$button <ButtonPress-1>\"
473  "
474  ::bind $w.bar.$button <Any-Leave> "
475  after cancel \"event generate $w.bar.$button <ButtonPress-1>\"
476  set ::board::repeatCmd 400
477  "
478  ::bind $w.bar.$button <ButtonRelease-1> "
479  after cancel \"event generate $w.bar.$button <ButtonPress-1>\"
480  set ::board::repeatCmd 400
481  "
482  }
483 }
484 
485 proc ::board::toggleInfoBar_ {{w} {action "click"}} {
486  set bstate [$w.bar.cmd state]
487  if {$action == "tmpInfo" && $bstate == "pressed"} {
488  grid remove $w.buttons;
489  grid $w.bar.info
490  } elseif {($action == "tmpRestore" && $bstate == "pressed") || \
491  ($action == "click" && "$w.bar.info" == [grid slaves $w.bar -column 2])} {
492  grid remove $w.bar.info;
493  grid $w.buttons
494  $w.bar.cmd state pressed
495  } else {
496  grid remove $w.buttons;
497  grid $w.bar.info
498  $w.bar.cmd state !pressed
499  }
500 }
501 
502 proc ::board::updateToolBar_ {{menu} {varname} {mb ""} } {
503  global "$varname"
504  set i [$menu index end]
505  while {$i >= 0} {
506  set idx -1
507  catch { set idx [lindex [$menu entryconfigure $i -image] 4]}
508  if {[info exists "${varname}($idx)"] } {
509  $menu entryconfigure $i -foreground black -command "eval \$::${varname}($idx)"
510  } else {
511  catch { $menu entryconfigure $i -foreground gray -command ""}
512  }
513  incr i -1
514  }
515  if {$mb != ""} {
516  set x [winfo rootx $mb]
517  set y [winfo rooty $mb]
518  set bh [winfo height $mb]
519  set mh [winfo reqheight $menu]
520  if {$y >= $mh} { incr y -$mh} { incr y $bh}
521  tk_popup $menu $x $y
522  }
523 }
524 
525 proc ::board::newToolBar_ {{w} {varname}} {
526  global "$varname"
527  ttk::frame $w.buttons
528 
529  set m [menu $w.buttons.menu_back -bg white -font font_Regular]
530  $m add command -label " Go back to mainline" -image tb_BD_BackToMainline -compound left
531  $m add command -label " Leave variant" -image tb_BD_VarLeave -compound left
532  $m add command -label " Go to start" -image tb_BD_Start -compound left -accelerator "<home>"
533  ::bind $w.bar.back <ButtonRelease-$::MB3> "::board::updateToolBar_ $m $varname %W"
534 
535  set m [menu $w.buttons.menu_forw -bg white -font font_Regular]
536  $m add command -label " Autoplay" -image tb_BD_Autoplay -compound left
537  $m add command -label " Go to end" -image tb_BD_End -compound left -accelerator "<end>"
538  ::bind $w.bar.forward <ButtonRelease-$::MB3> "::board::updateToolBar_ $m $varname %W"
539 
540  set menus { tb_BD_Changes tb_BD_Comment tb_BD_Variations tb_BD_Layout }
541  set i 0
542  foreach b $menus {
543  menu $w.buttons.menu_$b -bg white -font font_Regular -postcommand "::board::updateToolBar_ $w.buttons.menu_$b $varname"
544  ttk::menubutton $w.buttons.$b -style Toolbutton -image $b -menu "$w.buttons.menu_$b" -direction above
545  grid $w.buttons.$b -row 0 -column $i -padx 4
546  incr i
547  }
548 
549  set m "$w.buttons.menu_[lindex $menus 0]"
550  $m add command -label " [tr GameAdd]" -image tb_BD_SaveAs -compound left
551  $m add command -label " [tr GameReplace]" -image tb_BD_Save -compound left
552  $m add separator
553  $m add command -label " Undo all" -image tb_BD_Revert -compound left
554  $m add command -label " Redo" -image tb_BD_Redo -compound left
555  $m add command -label " Undo" -image tb_BD_Undo -compound left
556 
557  set m "$w.buttons.menu_[lindex $menus 1]"
558  $m add command -label " [tr EditSetup]" -image tb_BD_SetupBoard -compound left
559 
560  set m "$w.buttons.menu_[lindex $menus 2]"
561  $m add command -label " Delete variant" -image tb_BD_VarDelete -compound left
562  $m add command -label " Promote variant" -image tb_BD_VarPromote -compound left
563  $m add command -label " Leave variant" -image tb_BD_VarLeave -compound left
564  $m add command -label " Go back to mainline" -image tb_BD_BackToMainline -compound left
565  $m add separator
566  $m add command -label " Go to start" -image tb_BD_Start -compound left
567  $m add command -label " Go to end" -image tb_BD_End -compound left
568  $m add command -label " Autoplay" -image tb_BD_Autoplay -compound left
569 
570  set m "$w.buttons.menu_[lindex $menus 3]"
571  $m add command -label " Rotate" -image tb_BD_Flip -compound left
572  $m add command -label " Show/hide coord" -image tb_BD_Coords -compound left
573  $m add command -label " Show/hide material" -image tb_BD_Material -compound left
574  $m add command -label " Full Screen" -image tb_BD_Fullscreen -compound left
575  set ${varname}(tb_BD_Flip) "::board::flip $w"
576  set ${varname}(tb_BD_Coords) "::board::coords $w"
577  set ${varname}(tb_BD_Material) "::board::toggleMaterial $w"
578  set ${varname}(tb_BD_Fullscreen) { wm attributes . -fullscreen [expr ![wm attributes . -fullscreen] ] }
579 
580  return $w.buttons
581 }
582 
583 proc ::board::flipNames_ { {w} {white_on_top} } {
584  if {![winfo exist $w.playerW] } { return}
585  if {$white_on_top} {
586  grid $w.playerW -row 3
587  grid $w.playerB -row 16
588  } else {
589  grid configure $w.playerW -row 16
590  grid configure $w.playerB -row 3
591  }
592 }
593 
594 proc ::board::sideToMove_ { {w} {side} } {
595  if {![winfo exist $w.playerW] } { return}
596  if {$side == "w"} {
597  $w.playerB.tomove delete -tag tomove
598  $w.playerW.tomove create rectangle 0 0 100 100 -fill blue -tag tomove
599  } elseif {$side == "b"} {
600  $w.playerW.tomove delete -tag tomove
601  $w.playerB.tomove create rectangle 0 0 100 100 -fill blue -tag tomove
602  }
603 }
604 
605 # ::board::defaultColor
606 # Returns the color (the value of the global
607 # variable "lite" or "dark") depending on whether the
608 # specified square number (0=a1, 1=b1, ..., 63=h8) is
609 # a light or dark square.
610 #
611 proc ::board::defaultColor {sq} {
612  return [expr {($sq + ($sq / 8)) % 2 ? "$::lite" : "$::dark"}]
613 }
614 
615 # ::board::size
616 # Returns the current board size.
617 #
618 proc ::board::size {w} {
619  return $::board::_size($w)
620 }
621 
622 proc ::board::resizeAuto {w bbox} {
623  set availw [lindex $bbox 2]
624  set availh [lindex $bbox 3]
625  set extraw [expr [winfo reqwidth $w] - $::board::_size($w) * 8]
626  set extrah [expr [winfo reqheight $w] - $::board::_size($w) * 8]
627  set availw [expr $availw - $extraw]
628  set availh [expr $availh - $extrah]
629  set maxSize [expr {$availh < $availw ? $availh : $availw}]
630  set maxSize [expr $maxSize / 8]
631 
632  set newSize 0
633  foreach size $::boardSizes {
634  if {$size <= $maxSize && $size > $newSize} { set newSize $size}
635  }
636 
637  return [::board::resize $w $newSize]
638 }
639 
640 # ::board::resize
641 # Resizes the board. Takes a numeric piece size (which should
642 # be in the global boardSizes list variable), or "-1" or "+1".
643 # If the size argument is "redraw", the board is redrawn.
644 # Returns the new size of the board.
645 #
646 proc ::board::resize {w psize} {
647  global boardSizes
648 
649  set oldsize $::board::_size($w)
650  if {$psize == $oldsize} { return $oldsize}
651  if {$psize == "redraw"} { set psize $oldsize}
652  if {$psize == "-1"} {
653  set index [lsearch -exact $boardSizes $oldsize]
654  if {$index == 0} { return $oldsize}
655  incr index -1
656  set psize [lindex $boardSizes $index]
657  } elseif {$psize == "+1"} {
658  set index [lsearch -exact $boardSizes $oldsize]
659  incr index
660  if {$index == [llength $boardSizes]} { return $oldsize}
661  set psize [lindex $boardSizes $index]
662  }
663 
664  # Verify that we have a valid size:
665  if {[lsearch -exact $boardSizes $psize] < 0} { return $oldsize}
666 
667  set border $::board::_border($w)
668  set bsize [expr {$psize * 8 + $border * 9}]
669 
670  $w.bd configure -width $bsize -height $bsize
671  set ::board::_size($w) $psize
672 
673  # Resize each square:
674  for {set i 0} {$i < 64} {incr i} {
675  set xi [expr {$i % 8}]
676  set yi [expr {int($i/8)}]
677  set x1 [expr {$xi * ($psize + $border) + $border }]
678  set y1 [expr {(7 - $yi) * ($psize + $border) + $border }]
679  set x2 [expr {$x1 + $psize }]
680  set y2 [expr {$y1 + $psize }]
681  set pos $i
682  if {$::board::_flip($w)} { set pos [expr {63 - $i}]}
683  $w.bd coords sq$pos $x1 $y1 $x2 $y2
684  }
685 
686  # resize the material canvas
687  $w.mat configure -height $bsize
688 
689  ::board::update $w
690 
691  return $psize
692 }
693 
694 # ::board::border
695 # Get or set the border width.
696 # If the optional argument is missing or the empty string, returns
697 # the width of the board.
698 # Otherwise, the board sqyare borders are set to the specified width.
699 #
700 proc ::board::border {w {border ""}} {
701  if {$border == ""} {
702  return $::board::_border($w)
703  } else {
704  set ::board::_border($w) $border
705  ::board::resize $w redraw
706  }
707 }
708 
709 # ::board::getSquare
710 # Given a board frame and root-window X and Y screen coordinates,
711 # returns the square number (0-63) containing that screen location,
712 # or -1 if the location is outside the board.
713 #
714 proc ::board::getSquare {w x y} {
715  if {[winfo containing $x $y] != "$w.bd"} {
716  return -1
717  }
718  set x [expr {$x - [winfo rootx $w.bd]}]
719  set y [expr {$y - [winfo rooty $w.bd]}]
720  set psize $::board::_size($w)
721  set border $::board::_border($w)
722  set x [expr {int($x / ($psize+$border))}]
723  set y [expr {int($y / ($psize+$border))}]
724 
725  if {$x < 0 || $y < 0 || $x > 7 || $y > 7} {
726  set sq -1
727  } else {
728  set sq [expr {(7-$y)*8 + $x}]
729  if {$::board::_flip($w)} { set sq [expr {63 - $sq}]}
730  }
731  return $sq
732 }
733 
734 # ::board::showMarks
735 # Turns on/off the showing of marks (colored squares).
736 #
737 proc ::board::showMarks {w value} {
738  set ::board::_showMarks($w) $value
739 }
740 
741 # ::board::colorSquare
742 # Colors the specified square (0-63) of the board.
743 # If the color is the empty string, the appropriate
744 # color for the square (light or dark) is used.
745 #
746 proc ::board::colorSquare {w i {color ""}} {
747  if {$i < 0 || $i > 63} { return}
748  if {$color != ""} {
749  $w.bd itemconfigure br$i -state hidden
750  } else {
751  set color [::board::defaultColor $i]
752  set brstate "normal"
753  if { $::glossOfDanger } {
754  array set attacks [sc_pos attacks]
755  if {[info exists attacks($i)]} {
756  set color $attacks($i)
757  }
758  }
759  foreach mark $::board::_mark($w) {
760  if {[lindex $mark 1] == $i && [lindex $mark 0] == "full"} {
761  set color [lindex $mark 3]
762  set brstate "hidden"
763  }
764  }
765  $w.bd itemconfigure br$i -state $brstate
766  }
767  $w.bd itemconfigure sq$i -fill $color -outline ""
768 }
769 
770 # ::board::midSquare
771 # Given a board and square number, returns the canvas X/Y
772 # coordinates of the midpoint of that square.
773 #
774 proc ::board::midSquare {w sq} {
775  set c [$w.bd coords sq$sq]
776  #Klimmek: calculation change, because some sizes are odd and then some squares are shifted by 1 pixel
777  # set x [expr {([lindex $c 0] + [lindex $c 2]) / 2} ]
778  # set y [expr {([lindex $c 1] + [lindex $c 3]) / 2} ]
779  set psize $::board::_size($w)
780  if { $psize % 2 } { set psize [expr {$psize - 1}]}
781  set x [expr {[lindex $c 0] + $psize/2}]
782  set y [expr {[lindex $c 1] + $psize/2}]
783  return [list $x $y]
784 }
785 
786 
787 # ::board::setmarks --
788 #
789 # Set the marks for the board:
790 # colored squares, arrows, circles, etc.
791 #
792 # Arguments:
793 # w A frame containing a board '$win.bd'.
794 # cmds Commands to draw the marks
795 # Results:
796 # Sets ::board::_mark($w) with all the right formatted commands.
797 # Marks will be drawn by ::board::update
798 # Returns nothing.
799 #
800 proc ::board::setmarks {w cmds} {
801  set ::board::_mark($w) {}
802  foreach {cmd discard} [mark::getEmbeddedCmds $cmds] {
803  lset cmd 1 [::board::sq [lindex $cmd 1]]
804  set dest [::board::sq [lindex $cmd 2]]
805  if {$dest != -1} {lset cmd 2 $dest}
806  lappend ::board::_mark($w) $cmd
807  }
808 }
809 
810 ### Namespace ::board::mark
811 
812 namespace eval ::board::mark {
813  namespace import [namespace parent]::sq
814 
815  # Regular expression constants for
816  # matching Scid's embedded commands in PGN files.
817 
818  variable StartTag {\[%}
819  variable ScidKey {mark|arrow}
820  variable Command {draw}
821  variable Type {full|square|arrow|circle|disk|tux}
822  variable Text {[-+=?!A-Za-z0-9]}
823  variable Square {[a-h][1-8]\M}
824  variable Color {[\w#][^]]*\M} ;# FIXME: too lax for #nnnnnn!
825  variable EndTag {\]}
826 
827  # Current (non-standard) version:
828  variable ScidCmdRegex \
829  "$StartTag # leading tag
830  ($ScidKey)\\\ + # (old) command name + space chars
831  ($Square) # mandatory square (e.g. 'a4')
832  (?:\\ +($Square))? # optional: another (destination) square
833  (?:\\ *($Color))? # optional: color name
834  $EndTag # closing tag
835  "
836  # Proposed new version, according to the
837  # PGN Specification and Implementation Guide (Supplement):
838  variable StdCmdRegex \
839  "${StartTag} # leading tag
840  ${Command} # command name
841  \\ # a space character
842  (?:(${Type}|$Text),)? # keyword, e.g. 'arrow' (may be omitted)
843  # or single char (indicating type 'text')
844  ($Square) # mandatory square (e.g. 'a4')
845  (?:,($Square))? # optional: (destination) square
846  (?:,($Color))? # optional: color name
847  $EndTag # closing tag
848  "
849 
850  # ChessBase' syntax for markers and arrows
851  variable CBSquare {csl}
852  variable CBarrow {cal}
853  variable CBColor {[GRY]}
854  variable Square {[a-h][1-8]\M}
855  variable sqintern {[a-h][1-8]}
856 
857  variable CBSquareRegex \
858  "$StartTag
859  ($CBSquare)\\\ +
860  ($CBColor)
861  ($Square)
862  (?:,($CBColor)($Square))?
863  $EndTag
864  "
865 
866  variable CBArrowRegex \
867  "$StartTag
868  ($CBarrow)\\\ +
869  ($CBColor)
870  ($sqintern)
871  ($sqintern)
872  $EndTag
873  "
874 }
875 
876 # ::board::mark::getEmbeddedCmds --
877 #
878 # Scans a game comment string and extracts embedded commands
879 # used by Scid to mark squares or draw arrows.
880 #
881 # Arguments:
882 # comment The game comment string, containing
883 # embedded commands, e.g.:
884 # [%mark e4 green],
885 # [%arrow c4 f7],
886 # [%draw e4],
887 # [%draw circle,f7,blue].
888 # Results:
889 # Returns a list of embedded Scid commands,
890 # {command indices ?command indices...?},
891 # where 'command' is a list representing the embedded command:
892 # '{type square ?arg? color}',
893 # e.g. '{circle f7 red}' or '{arrow c4 f7 green}',
894 # and 'indices' is a list containing start and end position
895 # of the command string within the comment.
896 #
897 proc ::board::mark::getEmbeddedCmds {comment} {
898  if {$comment == ""} {return}
899  variable ScidCmdRegex
900  variable StdCmdRegex
901  variable CBSquareRegex
902  variable CBArrowRegex
903  set result {}
904 
905  # Build regex and search script for embedded commands:
906  set regex ""
907  foreach r [list $ScidCmdRegex $StdCmdRegex $CBSquareRegex $CBArrowRegex] {
908  if {[string equal $regex ""]} {set regex $r} else {append regex "|$r"}
909  }
910  set locateScript {regexp -expanded -indices -start $start \
911  $regex $comment indices}
912 
913  # Loop over all embedded commands contained in comment string:
914 
915  for {set start 0} {[eval $locateScript]} {incr start} {
916  foreach {first last} $indices {} ;# just a multi-assign
917  foreach re [list $ScidCmdRegex $StdCmdRegex $CBSquareRegex $CBArrowRegex] {
918  # Passing matching subexpressions to variables:
919  if {![regexp -expanded $re [string range $comment $first $last] \
920  match type arg1 arg2 color]} {
921  continue
922  }
923  # CB uses rotated arguments. Bring them in order
924  if {[string equal $type "csl"] || [string equal $type "cal"]} {
925  set dummy1 $arg1
926  set dummy2 $arg2
927  set dummy3 $color
928  set color $dummy1
929  set arg1 $dummy2
930  set arg2 $dummy3
931  if {[string equal $type "csl"]} {set type "full"}
932  if {[string equal $type "cal"]} {set type "arrow"}
933  if {[string equal $color "R"]} {set color "red"}
934  if {[string equal $color "G"]} {set color "green"}
935  if {[string equal $color "Y"]} {set color "yellow"}
936  }
937  # Settings of (default) type and arguments:
938  if {[string equal $color ""]} { set color "red"}
939  switch -glob -- $type {
940  "" {set type [expr {[string length $arg2] ? "arrow" : "full"}]}
941  mark {set type "fu" ;# new syntax}
942  ? {if {[string length $arg2]} break else {
943  set arg2 $type; set type "text"}
944  }
945  }
946  # Construct result list:
947  lappend result [list $type $arg1 $arg2 $color]
948  lappend result $indices
949  set start $last ;# +1 by for-loop
950  }
951  }
952  return $result
953 }
954 
955 # ::board::mark::remove --
956 #
957 # Removes a specified mark.
958 #
959 # Arguments:
960 # win A frame containing a board '$win.bd'.
961 # args List of one or two squares.
962 # Results:
963 # Appends a dummy mark to the bord's list of marks
964 # which causes the add routine to delete all marks for
965 # the specified square(s).
966 #
967 proc ::board::mark::remove {win args} {
968  if {[llength $args] == 2} {
969  eval add $win arrow $args nocolor 1
970  } else {
971  add $win DEL [lindex $args 0] "" nocolor 1
972  }
973 }
974 
975 # ::board::mark::add --
976 #
977 # Draws arrow or mark on the specified square(s).
978 #
979 # Arguments:
980 # win A frame containing a board 'win.bd'.
981 # args What kind of mark:
982 # type Either type id (e.g., square, circle) or
983 # a single character, which is of type 'text'.
984 # square Square number 0-63 (0=a1, 1=a2, ...).
985 # ?arg2? Optional: additional type-specific parameter.
986 # color Color to use for marking the square (mandatory).
987 # ?new? Optional: whether or not this mark should be
988 # added to the list of marks; defaults to 'true'.
989 # Results:
990 # For a given square, mark type, color, and optional (type-specific)
991 # destination arguments, creates the proper canvas object.
992 #
993 proc ::board::mark::add {win args} {
994  # Rearrange list if "type" is simple character:
995  if {[string length [lindex $args 0]] == 1} {
996  # ... e.g., {c e4 red} --> {text e4 c red}
997  set args [linsert $args 1 "text"]
998  set args [linsert [lrange $args 1 end] 2 [lindex $args 0]]
999  }
1000  # Add default arguments:
1001  if {![regexp true|false|1|0 [lindex $args end]]} {
1002  lappend args "true"
1003  }
1004  if {[llength $args] == 4} { set args [linsert $args 2 ""]}
1005 
1006  # Here we (should) have: args == <type> <square> ?<arg>? <color> <new>
1007  foreach {type square dest color new} $args {break} ;# assign
1008  if {[llength $args] != 5 } { return}
1009 
1010  set board $win.bd
1011  set type [lindex $args 0]
1012 
1013  # Remove existing marks:
1014  if {$type == "arrow"} {
1015  $board delete "mark${square}:${dest}" "mark${dest}:${square}"
1016  if {[string equal $color "nocolor"]} { set type DEL}
1017  } else {
1018  $board delete "mark${square}"
1019  #not needed anymore
1020  # ::board::colorSquare $win $square [::board::defaultColor $square]
1021  }
1022 
1023  switch -- $type {
1024  full { ::board::colorSquare $win $square $color}
1025  DEL { set new 1}
1026  default {
1027  # Find a subroutine to draw the canvas object:
1028  set drawingScript "Draw[string totitle $type]"
1029  if {![llength [info procs $drawingScript]]} { return}
1030 
1031  # ... and try it:
1032  if {[catch {eval $drawingScript $board $square $dest $color}]} {
1033  return
1034  }
1035  }
1036  }
1037  if {$new} { lappend ::board::_mark($win) [lrange $args 0 end-1]}
1038 }
1039 
1040 # ::board::mark::DrawXxxxx --
1041 #
1042 # Draws specified canvas object,
1043 # where "Xxxxx" is some required type, e.g. "Circle".
1044 #
1045 # Arguments:
1046 # pathName Name of the canvas widget.
1047 # args Type-specific arguments, e.g.
1048 # <square> <color>,
1049 # <square> <square> <color>,
1050 # <square> <char> <color>.
1051 # Results:
1052 # Constructs and evaluates the proper canvas command
1053 # "pathName create type coordinates options"
1054 # for the specified object.
1055 #
1056 
1057 # ::board::mark::DrawCircle --
1058 #
1059 proc ::board::mark::DrawCircle {pathName square color} {
1060  # Some "constants":
1061  set size 0.6 ;# inner (enclosing) box size, 0.0 < $size < 1.0
1062  set width 0.1 ;# outline around circle, 0.0 < $width < 1.0
1063 
1064  set box [GetBox $pathName $square $size]
1065  lappend pathName create oval [lrange $box 0 3] \
1066  -tag [list mark circle mark$square p$square]
1067  if {$width > 0.5} {
1068  ;# too thick, draw a disk instead
1069  lappend pathName -fill $color
1070  } else {
1071  set width [expr {[lindex $box 4] * $width}]
1072  if {$width <= 0.0} {set width 1.0}
1073  lappend pathName -fill "" -outline $color -width $width
1074  }
1075  eval $pathName
1076 }
1077 
1078 # ::board::mark::DrawDisk --
1079 #
1080 proc ::board::mark::DrawDisk {pathName square color} {
1081  # Size of the inner (enclosing) box within the square:
1082  set size 0.6 ;# 0.0 < $size < 1.0 = size of rectangle
1083 
1084  set box [GetBox $pathName $square $size]
1085  eval $pathName \
1086  {create oval [lrange $box 0 3]} \
1087  -fill $color \
1088  {-tag [list mark disk mark$square p$square]}
1089 }
1090 
1091 # ::board::mark::DrawText --
1092 # Pascal Georges : if shadow!="", try to make the text visible even if fg and bg colors are close
1093 proc ::board::mark::DrawText {pathName square char color {size 0} {shadowColor ""}} {
1094  set box [GetBox $pathName $square 0.8]
1095  set len [expr {($size > 0) ? $size : int([lindex $box 4])}]
1096  set x [lindex $box 5]
1097  set y [lindex $box 6]
1098  $pathName delete text$square mark$square
1099  if {$shadowColor!=""} {
1100  eval $pathName \
1101  create text [expr $x+1] [expr $y+1] -fill $shadowColor \
1102  {-font [list helvetica $len bold]} \
1103  {-text [string index $char 0]} \
1104  {-anchor c} \
1105  {-tag [list mark text text$square mark$square p$square]}
1106 
1107  }
1108  eval $pathName \
1109  create text $x $y -fill $color \
1110  {-font [list helvetica $len bold]} \
1111  {-text [string index $char 0]} \
1112  {-anchor c} \
1113  {-tag [list mark text text$square mark$square p$square]}
1114 }
1115 
1116 # ::board::mark::DrawArrow --
1117 #
1118 proc ::board::mark::DrawArrow {pathName from to color} {
1119  if {$from < 0 || $from > 63} { return}
1120  if {$to < 0 || $to > 63} { return}
1121  set coord [GetArrowCoords $pathName $from $to]
1122  eval $pathName \
1123  {create line $coord} \
1124  -fill $color -arrow last -width 2 \
1125  {-tag [list mark arrows "mark${from}:${to}"]}
1126 }
1127 
1128 # ::board::mark::DrawRectangle --
1129 # Draws a rectangle surrounding the square
1130 proc ::board::mark::DrawRectangle { pathName square color pattern } {
1131  if {$square < 0 || $square > 63} { return}
1132  set box [::board::mark::GetBox $pathName $square]
1133  $pathName create rectangle [lindex $box 0] [lindex $box 1] [lindex $box 2] [lindex $box 3] \
1134  -outline $color -width $::highlightLastMoveWidth -dash $pattern -tag highlightLastMove
1135 }
1136 
1137 # ::board::mark::DrawTux --
1138 #
1139 image create photo tux16x16 -data \
1140  {R0lGODlhEAAQAPUyAAAAABQVFiIcBi0tLTc0Kj4+PkQ3CU9ADVVFD1hJFV1X
1141  P2pXFWJUKHttLnttOERERVVWWWRjYWlqcYNsGJR5GrSUIK6fXsKdGMCdI8er
1142  ItCuNtm2KuS6KebAKufBOvjJIfnNM/3TLP/aMP/lM+/We//lQ//jfoGAgJaU
1143  jpiYmqKipczBmv/wk97e3v//3Ojo6f/96P7+/v///wAAAAAAAAAAAAAAAAAA
1144  AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEBADIALAAAAAAQABAAAAbm
1145  QJlMJpMBAAAAQCaTyWQymUwmAwQAAQAAIJPJZDKZTCYDQCInCQAgk8lkMplM
1146  JgMwOBoHACCTyYAymUwmkwEao5IFAADIZDKZTCaTAVQu2GsAAMhkMplMJgMU
1147  YrFY7AQAAGQymUwmA6RisVjsFQAAATKZTCYDBF6xWCwWewAAAJlMJjMoYrFY
1148  LBaDAAAAmUwW+oBWsVgsxlokFgCZTBYChS6oWCxmAn5CHYNMJhOJQiFS7JXS
1149  iEQjCkAmw3BCow0hAMiMNggAQCYDAAyTAwAASEwEAABAJpPJAAAAAACUAQAA
1150  gEwmCwIAOw==}
1151 set ::board::mark::tux16x16 tux16x16
1152 
1153 image create photo tux32x32 -data \
1154  {R0lGODlhIAAgAPU0AAAAABANAxERESAaBiwkCDAnCSQkJEM2DEA3GVBBDllJ
1155  EFNKLG5aFHBbFHpkFnZoMkBAQFBQUGBgYHBwcIBpF4xyGZ+DHZ+GKqmKHq+T
1156  Lb+hNsynJNSuJtu0J9+6NeW8Kc+wQPnMLPTJMP7QLv/UO//aVf/dYv/ifIiI
1157  hp+fn6+vr7+/v//lif/ol//rpM/Pz9/f3//22O/u6v/55f///////wAAAAAA
1158  AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEBADUALAAAAAAgACAAAAb+
1159  wFqtVqvVarVarQYAAAAAAABQq9VqtVqtVqvVarVarVar1Wq1Wg0AAAAAAAAA
1160  AKjVarVarVar1YC1Wq1Wq9VqtVqtBgAAAAAAAAAAAGq1Wq1Wq9VqtVqtVqvV
1161  arVaDQAAAAAAAAAAAABqtVqtVqsBa7VarVar1Wq1Wq0GMMgighdtAgAAALVa
1162  rVar1Wq1Wq1Wq9VqtVqtBphEUpCUQQUAAAC1Wq1WA9ZqtVqtVqvVarVarVYD
1163  RBYejwahAgAAgFqtVqvVarVarVar1Wq1Wq1WAxRIIdFolAEAAABArQas1Wq1
1164  Wq1Wq9VqtVqtVqvVGqPRaDTSAAAAAKBWq9VqtVr+rVar1Wq1Wq1Wq9UMp9Fo
1165  xJIJAAAAAFir1Wq1Wq1Wq9VqtVqtVqvVABGaqzWj0SYAAAAAqNVqtVqtVqvV
1166  arVarVarAQQyGo1Go9FgAAAQAAAAarVarVar1Wq1Wq1WqwEAExqNRqPRaDSD
1167  AAAAAGq1Wq1Wq9VqtVqtVqsBAC8ajUaj0Wg0oAoAAAAAgFqtVqvVarVarVar
1168  AQACGo1Go9FoNBpNAAAAAIBarVar1Wq1Wq1WqwEAKhqNRqPRaEAajYYCAAAA
1169  AKBWq9VqtVqtVqvVAAIajUaj0Wg0Go22AgAAAACgVqvVarVarVarAQARGo1G
1170  o9GANBqNRpMBAAAAAAD+qNVqtVqtVqvVAAAUjUaj0Wg0Go1GowkAAAAAAKjV
1171  arVarVar1QgUFI1GowFpNBqNRqPRDAZDAAAA1Gq1Wq1Wq9VGo1HpRaPRaDQa
1172  jUY7iQAAwUMBANRqtVqtVhuFRqPR6LIC0mg0Go1Go5lGiYBlVAEAarVarVar
1173  jUaj0Wg0KqRoNBqNRqOZRqPRaPQBAGq1Wq1Wq41Go9FoBBxtADIajUaj0Uyj
1174  0Wg0Gn0YgFqtVqvVRqPRaDQajVw0Go1Go6VGo9FoNBqNOABArVar1Uaj0Qg4
1175  Go1GoxiNRntFBqPRaDQajT4KAKBWq9Vqo9FoNBqNRiOHASIAAAqj0Wg0CmGW
1176  AAAAoFar1WoYDlAUGo1Go1FFAAAAAInRaDT6EAAAAABQq9VqNQAAAHB0QqNO
1177  AQAAAACA0Gi0AQAAAECtVqvVajUgAAAAAAAAAAAAAAAAAAAAAAAAAIBarVar
1178  1Wq1Wq1WqwEAAAAAAKjVarUaAAAAAAC1Wq1Wq9VqwFqtVqvVarVarVar1Wq1
1179  Wq1Wq9VqtVqtVqvVarUgADs=
1180  }
1181 set ::board::mark::tux32x32 tux32x32
1182 
1183 proc ::board::mark::DrawTux {pathName square discard} {
1184  variable tux16x16
1185  variable tux32x32
1186  set box [::board::mark::GetBox $pathName $square]
1187  for {set len [expr {int([lindex $box 4])}]} {$len > 0} {incr len -1} {
1188  if {[info exists tux${len}x${len}]} break
1189  }
1190  if {!$len} return
1191  $pathName create image [lrange $box 5 6] \
1192  -image tux${len}x${len} \
1193  -tag [list mark "mark$square" tux]
1194 }
1195 
1196 # ::board::mark::GetArrowCoords --
1197 #
1198 # Auxiliary function:
1199 # Similar to '::board::midSquare', but this function returns
1200 # coordinates of two (optional adjusted) squares.
1201 #
1202 # Arguments:
1203 # board A board canvas ('win.bd' for a frame 'win').
1204 # from Source square number (0-63).
1205 # to Destination square number (0-63).
1206 # shrink Optional shrink factor (0.0 - 1.0):
1207 # 0.0 = no shrink, i.e. just return midpoint coordinates,
1208 # 1.0 = start and end at edge (unless adjacent squares).
1209 # Results:
1210 # Returns a list of coordinates {x1 y1 x2 y2} for drawing
1211 # an arrow "from" --> "to".
1212 #
1213 proc ::board::mark::GetArrowCoords {board from to {shrink 0.6}} {
1214  if {$shrink < 0.0} {set shrink 0.0}
1215  if {$shrink > 1.0} {set shrink 1.0}
1216 
1217  # Get left, top, right, bottom, length, midpoint_x, midpoint_y:
1218  set fromXY [GetBox $board $from]
1219  set toXY [GetBox $board $to]
1220  # Get vector (dX,dY) = to(x,y) - from(x,y)
1221  # (yes, misusing the foreach multiple features)
1222  foreach {x0 y0} [lrange $fromXY 5 6] {x1 y1} [lrange $toXY 5 6] {break}
1223  set dX [expr {$x1 - $x0}]
1224  set dY [expr {$y1 - $y0}]
1225 
1226  # Check if we have good coordinates and shrink factor:
1227  if {($shrink == 0.0) || ($dX == 0.0 && $dY == 0.0)} {
1228  return [list $x0 $y0 $x1 $y1]
1229  }
1230 
1231  # Solve equation: "midpoint + (lambda * vector) = edge point":
1232  if {abs($dX) > abs($dY)} {
1233  set edge [expr {($dX > 0) ? [lindex $fromXY 2] : [lindex $fromXY 0]}]
1234  set lambda [expr {($edge - $x0) / $dX}]
1235  } else {
1236  set edge [expr {($dY > 0) ? [lindex $fromXY 3] : [lindex $fromXY 1]}]
1237  set lambda [expr {($edge - $y0) / $dY}]
1238  }
1239 
1240  # Check and adjust shrink factor for adjacent squares
1241  # (i.e. don't make arrows too short):
1242  set maxShrinkForAdjacent 0.667
1243  if {$shrink > $maxShrinkForAdjacent} {
1244  set dFile [expr {($to % 8) - ($from % 8)}]
1245  set dRank [expr {($from / 8) - ($to / 8)}]
1246  if {(abs($dFile) <= 1) && (abs($dRank) <= 1)} {
1247  set shrink $maxShrinkForAdjacent
1248  }
1249  }
1250 
1251  # Return shrinked line coordinates {x0', y0', x1', y1'}:
1252  set shrink [expr {$shrink * $lambda}]
1253  return [list [expr {$x0 + $shrink * $dX}] [expr {$y0 + $shrink * $dY}]\
1254  [expr {$x1 - $shrink * $dX}] [expr {$y1 - $shrink * $dY}]]
1255 }
1256 
1257 # ::board::mark::GetBox --
1258 #
1259 # Auxiliary function:
1260 # Get coordinates of an inner box for a specified square.
1261 #
1262 # Arguments:
1263 # pathName Name of a canvas widget containing squares.
1264 # square Square number (0..63).
1265 # portion Portion (length inner box) / (length square)
1266 # (1.0 means: box == square).
1267 # Results:
1268 # Returns a list whose elements are upper left and lower right
1269 # corners, length, and midpoint (x,y) of the inner box.
1270 #
1271 proc ::board::mark::GetBox {pathName square {portion 1.0}} {
1272  set coord [$pathName coords sq$square]
1273  set len [expr {[lindex $coord 2] - [lindex $coord 0]}]
1274  if {$portion < 1.0} {
1275  set dif [expr {$len * (1.0 -$portion) * 0.5}]
1276  foreach i {0 1} { lappend box [expr {[lindex $coord $i] + $dif}]}
1277  foreach i {2 3} { lappend box [expr {[lindex $coord $i] - $dif}]}
1278  } else {
1279  set box $coord
1280  }
1281  lappend box [expr { [lindex $box 2] - [lindex $box 0] }]
1282  lappend box [expr {([lindex $box 0] + [lindex $box 2]) / 2}]
1283  lappend box [expr {([lindex $box 1] + [lindex $box 3]) / 2}]
1284  return $box
1285 }
1286 
1287 ### End of namespace ::board::mark
1288 
1289 # ::board::piece {w sq}
1290 # Given a board and square number, returns the piece type
1291 # (e for empty, wp for White Pawn, etc) of the square.
1292 proc ::board::piece {w sq} {
1293  set p [string index $::board::_data($w) $sq]
1294  return $::board::letterToPiece($p)
1295 }
1296 
1297 # ::board::setDragSquare
1298 # Sets the square from whose piece should be dragged.
1299 # To drag nothing, the square value should be -1.
1300 # If the previous value is a valid square (0-63), the
1301 # piece being dragged is returned to its home square first.
1302 #
1303 proc ::board::setDragSquare {w sq} {
1304  set oldSq $::board::_drag($w)
1305  if {$oldSq >= 0 && $oldSq <= 63} {
1306  ::board::drawPiece $w $oldSq [string index $::board::_data($w) $oldSq]
1307  $w.bd raise arrows
1308  }
1309  set ::board::_drag($w) $sq
1310  return $oldSq
1311 }
1312 
1313 proc ::board::getDragSquare {w} {
1314  return $::board::_drag($w)
1315 }
1316 
1317 
1318 # ::board::dragPiece
1319 # Drags the piece of the drag-square (as set above) to
1320 # the specified global (root-window) screen coordinates.
1321 #
1322 proc ::board::dragPiece {w x y} {
1323  set sq $::board::_drag($w)
1324  if {$sq < 0} { return}
1325  set x [expr {$x - [winfo rootx $w.bd]}]
1326  set y [expr {$y - [winfo rooty $w.bd]}]
1327  $w.bd coords p$sq $x $y
1328  $w.bd raise p$sq
1329 }
1330 
1331 # ::board::bind
1332 # Binds the given event on the given square number to
1333 # the specified action.
1334 #
1335 proc ::board::bind {w sq event action} {
1336  if {$sq == "all"} {
1337  for {set i 0} {$i < 64} {incr i} {
1338  $w.bd bind p$i $event $action
1339  }
1340  } else {
1341  $w.bd bind p$sq $event $action
1342  }
1343 }
1344 
1345 # ::board::drawPiece
1346 # Draws a piece on a specified square.
1347 #
1348 proc ::board::drawPiece {w sq piece} {
1349  set psize $::board::_size($w)
1350  set flip $::board::_flip($w)
1351  # Compute the XY coordinates for the centre of the square:
1352  set midpoint [::board::midSquare $w $sq]
1353  set xc [lindex $midpoint 0]
1354  set yc [lindex $midpoint 1]
1355  # Delete any old image for this square, and add the new one:
1356  $w.bd delete p$sq
1357  $w.bd create image $xc $yc -image $::board::letterToPiece($piece)$psize -tag p$sq
1358 }
1359 
1360 # ::board::clearText
1361 # Remove all text annotations from the board.
1362 #
1363 proc ::board::clearText {w} {
1364  $w.bd delete texts
1365 }
1366 
1367 # ::board::drawText
1368 # Draws the specified text on the specified square.
1369 # Additional arguments are treated as canvas text parameters.
1370 #
1371 proc ::board::drawText {w sq text color args {shadow ""} } {
1372  mark::DrawText ${w}.bd $sq $text $color \
1373  [expr {[catch {font actual font_Bold -size} size] ? 11 : $size}] \
1374  $shadow
1375  #if {[llength $args] > 0} {
1376  # catch {eval $w.bd itemconfigure text$sq $args}
1377  #}
1378 }
1379 
1380 # Highlight last move played by drawing a red rectangle around the two squares
1381 proc ::board::lastMoveHighlight {w} {
1382  $w.bd delete highlightLastMove
1383  if { ! $::highlightLastMove } {return}
1384  set moveuci [ sc_game info previousMoveUCI]
1385  if {[string length $moveuci] >= 4} {
1386  set moveuci [ string range $moveuci 0 3]
1387  set square1 [ ::board::sq [string range $moveuci 0 1]]
1388  set square2 [ ::board::sq [string range $moveuci 2 3]]
1389  ::board::mark::DrawRectangle $w.bd $square1 $::highlightLastMoveColor $::highlightLastMovePattern
1390  ::board::mark::DrawRectangle $w.bd $square2 $::highlightLastMoveColor $::highlightLastMovePattern
1391  if { ! $::arrowLastMove } {return}
1392  ::board::mark::DrawArrow $w.bd $square1 $square2 $::highlightLastMoveColor
1393  }
1394 }
1395 
1396 # ::board::update
1397 # Update the board given a 64-character board string as returned
1398 # by the "sc_pos board" command. If the board string is empty, it
1399 # defaults to the previous value for this board.
1400 # If the optional parameter "animate" is 1 and the changes from
1401 # the previous board state appear to be a valid chess move, the
1402 # move is animated.
1403 #
1404 proc ::board::update {w {board ""} {animate 0}} {
1405  set oldboard $::board::_data($w)
1406  if {$board == ""} {
1407  set board $::board::_data($w)
1408  } else {
1409  set ::board::_data($w) $board
1410  }
1411  set psize $::board::_size($w)
1412 
1413  # Cancel any current animation:
1414  after cancel "::board::_animate $w"
1415 
1416  # Remove all marks (incl. arrows) from the board:
1417  $w.bd delete mark
1418 
1419  # Draw each square:
1420  for {set sq 0} { $sq < 64 } { incr sq} {
1421  set piece [string index $board $sq]
1422  # Compute the XY coordinates for the centre of the square:
1423  set midpoint [::board::midSquare $w $sq]
1424  set xc [lindex $midpoint 0]
1425  set yc [lindex $midpoint 1]
1426  #update every square with color and texture
1427  set color [::board::defaultColor $sq]
1428  $w.bd itemconfigure sq$sq -fill $color -outline "" ; #-outline $color
1429 
1430  set boc bgd$psize
1431  if { ($sq + ($sq / 8)) % 2 } { set boc bgl$psize}
1432  $w.bd delete br$sq
1433  $w.bd create image $xc $yc -image $boc -tag br$sq
1434 
1435  # Delete any old image for this square, and add the new one:
1436  $w.bd delete p$sq
1437  $w.bd create image $xc $yc -image $::board::letterToPiece($piece)$psize -tag p$sq
1438  }
1439 
1440  # Update side-to-move icon:
1441  ::board::sideToMove_ $w [string index $::board::_data($w) 65]
1442 
1443  # Gloss Of Danger:
1444  if { $::glossOfDanger } {
1445  foreach {sq col} [sc_pos attacks] {
1446  ::board::colorSquare $w $sq $col
1447  }
1448  }
1449 
1450  # Redraw marks and arrows if required:
1451  if {$::board::_showMarks($w)} {
1452  foreach mark $::board::_mark($w) {
1453  set type [lindex $mark 0]
1454  if {$type == "full"} {
1455  ::board::colorSquare $w [lindex $mark 1] [lindex $mark 3]
1456  } else {
1457  # Find a subroutine to draw the canvas object:
1458  set drawingScript "mark::Draw[string totitle $type]"
1459  if {[llength [info procs $drawingScript]]} {
1460  catch {eval $drawingScript $w.bd [join [lrange $mark 1 3]]}
1461  }
1462  }
1463  }
1464  }
1465 
1466  # Redraw last move highlight if mainboard
1467  if { $w == ".main.board"} {
1469  }
1470 
1471  # Redraw material values
1472  if {$::board::_showmat($w)} {
1474  }
1475 
1476  # Animate board changes if requested:
1477  if {$animate && $board != $oldboard} {
1478  ::board::animate $w $oldboard $board
1479  }
1480 }
1481 
1482 proc ::board::isFlipped {w} {
1483  return $::board::_flip($w)
1484 }
1485 
1486 # ::board::flipAuto
1487 # Sometimes SCID wants to automatically rotate the board,
1488 # i.e. when playing a game or loading a game with the "FlipB" flag set.
1489 # This function flip the board, but allow to restore the last state
1490 # (rotated, not rotated) selected by the user
1491 # @newstate: 0 ->white bottom
1492 # 1 ->black bottom
1493 # -1 ->restore previous state
1494 #
1495 proc ::board::flipAuto {w {newstate -1}} {
1496  if {$newstate == -1} {
1497  if {[info exists ::board::flipAuto_($w)]} {::board::flip $w $::board::flipAuto_($w)}
1498  return
1499  }
1500  set tmp $::board::_flip($w)
1501  if {[info exists ::board::flipAuto_($w)]} { set tmp $::board::flipAuto_($w)}
1502  ::board::flip $w $newstate
1503  set ::board::flipAuto_($w) $tmp
1504 }
1505 
1506 # ::board::flip
1507 # Rotate the board 180 degrees.
1508 #
1509 proc ::board::flip {w {newstate -1}} {
1510  if {! [info exists ::board::_flip($w)]} { return}
1511  catch {unset ::board::flipAuto_($w)}
1512  if {$newstate == $::board::_flip($w)} { return}
1513  set flip [expr {1 - $::board::_flip($w)}]
1514  set ::board::_flip($w) $flip
1515 
1516  # Swap squares:
1517  for {set i 0} {$i < 32} {incr i} {
1518  set swap [expr {63 - $i}]
1519  set coords(South) [$w.bd coords sq$i]
1520  set coords(North) [$w.bd coords sq$swap]
1521  $w.bd coords sq$i $coords(North)
1522  $w.bd coords sq$swap $coords(South)
1523  }
1524 
1525  # Change coordinate labels:
1526  for {set i 1} {$i <= 8} {incr i} {
1527  set value [expr {9 - [$w.lrank$i cget -text]}]
1528  $w.lrank$i configure -text $value
1529  $w.rrank$i configure -text $value
1530  }
1531  if {$flip} {
1532  foreach file {a b c d e f g h} newvalue {h g f e d c b a} {
1533  $w.tfile$file configure -text $newvalue
1534  $w.bfile$file configure -text $newvalue
1535  }
1536  } else {
1537  foreach file {a b c d e f g h} {
1538  $w.tfile$file configure -text $file
1539  $w.bfile$file configure -text $file
1540  }
1541  }
1542  ::board::flipNames_ $w $flip
1543  ::board::update $w
1544  return $w
1545 }
1546 ################################################################################
1547 # ::board::material
1548 # displays material balance
1549 ################################################################################
1550 proc ::board::material {w} {
1551  set f $w.mat
1552 
1553  $f delete material
1554 
1555  set fen [lindex [sc_pos fen] 0]
1556  set p 0
1557  set n 0
1558  set b 0
1559  set r 0
1560  set q 0
1561  for {set i 0} {$i < [string length $fen]} {incr i} {
1562  set ch [string index $fen $i]
1563  switch -- $ch {
1564  p {incr p -1}
1565  P {incr p}
1566  n {incr n -1}
1567  N {incr n}
1568  b {incr b -1}
1569  B {incr b}
1570  r {incr r -1}
1571  R {incr r}
1572  q {incr q -1}
1573  Q {incr q}
1574  }
1575  }
1576  set sum [expr abs($p) + abs($n) +abs($b) +abs($r) +abs($q)]
1577  set rank 0
1578 
1579  foreach pType {q r b n p} {
1580  set count [expr "\$$pType"]
1581  if {$count < 0} {
1582  addMaterial $count $pType $f $rank $sum
1583  incr rank [expr abs($count)]
1584  }
1585  }
1586  foreach pType {q r b n p} {
1587  set count [expr "\$$pType"]
1588  if {$count > 0} {
1589  addMaterial $count $pType $f $rank $sum
1590  incr rank [expr abs($count)]
1591  }
1592  }
1593 }
1594 proc ::board::addMaterial {count piece parent rank sum} {
1595  if {$count == 0} {return}
1596  if {$count <0} {
1597  set col "b"
1598  set count [expr 0 - $count]
1599  } else {
1600  set col "w"
1601  }
1602  set w [$parent cget -width]
1603  set h [$parent cget -height]
1604  set offset [expr ($h - ($sum * 20)) / 2]
1605  if {$offset <0} { set offset 0}
1606  set x [expr $w / 2]
1607  for {set i 0} {$i<$count} {incr i} {
1608  set y [expr $rank * 20 +10 + $offset + $i * 20]
1609  $parent create image $x $y -image $col${piece}20 -tag material
1610  }
1611 }
1612 proc ::board::toggleMaterial {w} {
1613  set ::board::_showmat($w) [expr {1 - $::board::_showmat($w)}]
1614  if {$::board::_showmat($w)} {
1615  grid $w.mat
1616  } else {
1617  grid remove $w.mat
1618  }
1619  ::board::update $w
1620  return $::board::_showmat($w)
1621 }
1622 
1623 ################################################################################
1624 #
1625 ################################################################################
1626 
1627 # ::board::coords
1628 # Add or remove coordinates around the edge of the board.
1629 # Toggle between 0,1,2.
1630 proc ::board::coords {w} {
1631  set coords [expr {1 + $::board::_coords($w)}]
1632  if { $coords > 2 } { set coords 0}
1633  set ::board::_coords($w) $coords
1634 
1635  if {$coords == 0 } {
1636  for {set i 1} {$i <= 8} {incr i} {
1637  grid remove $w.lrank$i
1638  grid remove $w.rrank$i
1639  }
1640  foreach i {a b c d e f g h} {
1641  grid remove $w.tfile$i
1642  grid remove $w.bfile$i
1643  }
1644  } elseif {$coords == 1 } {
1645  for {set i 1} {$i <= 8} {incr i} {
1646  grid configure $w.lrank$i
1647  grid remove $w.rrank$i
1648  }
1649  foreach i {a b c d e f g h} {
1650  grid remove $w.tfile$i
1651  grid configure $w.bfile$i
1652  }
1653  } else { #Klimmek: coords == 2 then show left and bottom
1654  for {set i 1} {$i <= 8} {incr i} {
1655  grid configure $w.lrank$i
1656  grid configure $w.rrank$i
1657  }
1658  foreach i {a b c d e f g h} {
1659  grid configure $w.tfile$i
1660  grid configure $w.bfile$i
1661  }
1662  }
1663 
1664  return $coords
1665 }
1666 
1667 # ::board::animate
1668 # Check for board changes that appear to be a valid chess move,
1669 # and start animating the move if applicable.
1670 #
1671 proc ::board::animate {w oldboard newboard} {
1672  global animateDelay
1673  if {$animateDelay <= 0} { return}
1674 
1675  # Find which squares differ between the old and new boards:
1676  set diffcount 0
1677  set difflist [list]
1678  for {set i 0} {$i < 64} {incr i} {
1679  if {[string index $oldboard $i] != [string index $newboard $i]} {
1680  incr diffcount
1681  lappend difflist $i
1682  }
1683  }
1684 
1685  # Check the number of differences could mean a valid move:
1686  if {$diffcount < 2 || $diffcount > 4} { return}
1687 
1688  for {set i 0} {$i < $diffcount} {incr i} {
1689  set sq($i) [lindex $difflist $i]
1690  set old($i) [string index $oldboard $sq($i)]
1691  set new($i) [string index $newboard $sq($i)]
1692  }
1693 
1694  set from -1
1695  set to -1
1696  set captured -1
1697  set capturedPiece "."
1698 
1699  if {$diffcount == 4} {
1700  # Check for making/unmaking a castling move:
1701  set castlingList [list [sq e1] [sq g1] [sq h1] [sq f1] \
1702  [sq e8] [sq g8] [sq h8] [sq f8] \
1703  [sq e1] [sq c1] [sq a1] [sq d1] \
1704  [sq e8] [sq c8] [sq a8] [sq d8]]
1705 
1706  foreach {kfrom kto rfrom rto} $castlingList {
1707  if {[lsort $difflist] == [lsort [list $kfrom $kto $rfrom $rto]]} {
1708  if {[string tolower [string index $oldboard $kfrom]] == "k" &&
1709  [string tolower [string index $oldboard $rfrom]] == "r" &&
1710  [string tolower [string index $newboard $kto]] == "k" &&
1711  [string tolower [string index $newboard $rto]] == "r"} {
1712  # A castling move animation.
1713  # Move the rook back to initial square until animation is complete:
1714  # TODO: It may look nicer if the rook was animated as well...
1715  eval $w.bd coords p$rto [::board::midSquare $w $rfrom]
1716  set from $kfrom
1717  set to $kto
1718  } elseif {[string tolower [string index $newboard $kfrom]] == "k" &&
1719  [string tolower [string index $newboard $rfrom]] == "r" &&
1720  [string tolower [string index $oldboard $kto]] == "k" &&
1721  [string tolower [string index $oldboard $rto]] == "r"} {
1722  # An undo-castling animation. No need to move the rook.
1723  set from $kto
1724  set to $kfrom
1725  }
1726  }
1727  }
1728  }
1729 
1730  if {$diffcount == 3} {
1731  # Three squares are different, so check for an En Passant capture:
1732  foreach i {0 1 2} {
1733  foreach j {0 1 2} {
1734  foreach k {0 1 2} {
1735  if {$i == $j || $i == $k || $j == $k} { continue}
1736  # Check for an en passant capture from i to j with the enemy
1737  # pawn on k:
1738  if {$old($i) == $new($j) && $old($j) == "." && $new($k) == "." &&
1739  (($old($i) == "p" && $old($k) == "P") ||
1740  ($old($i) == "P" && $old($k) == "p"))} {
1741  set from $sq($i)
1742  set to $sq($j)
1743  }
1744  # Check for undoing an en-passant capture from j to i with
1745  # the enemy pawn on k:
1746  if {$old($i) == $new($j) && $old($k) == "." && $new($i) == "." &&
1747  (($old($i) == "p" && $new($k) == "P") ||
1748  ($old($i) == "P" && $new($k) == "p"))} {
1749  set from $sq($i)
1750  set to $sq($j)
1751  set captured $sq($k)
1752  set capturedPiece $new($k)
1753  }
1754  }
1755  }
1756  }
1757  }
1758 
1759  if {$diffcount == 2} {
1760  # Check for a regular move or capture: one old square should have the
1761  # same (non-empty) piece as the other new square, and at least one
1762  # of the old or new squares should be empty.
1763 
1764  if {$old(0) != "." && $old(1) != "." && $new(0) != "." && $new(1) != "."} {
1765  return
1766  }
1767 
1768  foreach i {0 1} {
1769  foreach j {0 1} {
1770  if {$i == $j} { continue}
1771  if {$old($i) == $new($j) && $old($i) != "."} {
1772  set from $sq($i)
1773  set to $sq($j)
1774  set captured $sq($j)
1775  set capturedPiece $old($j)
1776  }
1777 
1778  # Check for a (white or black) pawn promotion from i to j:
1779  if {($old($i) == "P" && [string is upper $new($j)] &&
1780  $sq($j) >= [sq a8] && $sq($j) <= [sq h8]) ||
1781  ($old($i) == "p" && [string is lower $new($j)] &&
1782  $sq($j) >= [sq a1] && $sq($j) <= [sq h1])} {
1783  set from $sq($i)
1784  set to $sq($j)
1785  }
1786 
1787  # Check for undoing a pawn promotion from j to i:
1788  if {($new($j) == "P" && [string is upper $old($i)] &&
1789  $sq($i) >= [sq a8] && $sq($i) <= [sq h8]) ||
1790  ($new($j) == "p" && [string is lower $old($i)] &&
1791  $sq($i) >= [sq a1] && $sq($i) <= [sq h1])} {
1792  set from $sq($i)
1793  set to $sq($j)
1794  set captured $sq($j)
1795  set capturedPiece $old($j)
1796  }
1797  }
1798  }
1799  }
1800 
1801  # Check that we found a valid-looking move to animate:
1802  if {$from < 0 || $to < 0} { return}
1803 
1804  # Redraw the captured piece during the animation if necessary:
1805  if {$capturedPiece != "." && $captured >= 0} {
1806  ::board::drawPiece $w $from $capturedPiece
1807  eval $w.bd coords p$from [::board::midSquare $w $captured]
1808  }
1809 
1810  # Move the animated piece back to its starting point:
1811  eval $w.bd coords p$to [::board::midSquare $w $from]
1812  $w.bd raise p$to
1813 
1814  # Start the animation:
1815  set start [clock clicks -milli]
1816  set ::board::_animate($w,start) $start
1817  set ::board::_animate($w,end) [expr {$start + $::animateDelay}]
1818  set ::board::_animate($w,from) $from
1819  set ::board::_animate($w,to) $to
1821 }
1822 
1823 # ::board::_animate
1824 # Internal procedure for updating a board move animation.
1825 #
1826 proc ::board::_animate {w} {
1827  if {! [winfo exists $w]} { return}
1828  set from $::board::_animate($w,from)
1829  set to $::board::_animate($w,to)
1830  set start $::board::_animate($w,start)
1831  set end $::board::_animate($w,end)
1832  set now [clock clicks -milli]
1833  if {$now > $end} {
1834  ::board::update $w
1835  return
1836  }
1837 
1838  # Compute where the moving piece should be displayed and move it:
1839  set ratio [expr {double($now - $start) / double($end - $start)}]
1840  set fromMid [::board::midSquare $w $from]
1841  set toMid [::board::midSquare $w $to]
1842  set fromX [lindex $fromMid 0]
1843  set fromY [lindex $fromMid 1]
1844  set toX [lindex $toMid 0]
1845  set toY [lindex $toMid 1]
1846  set x [expr {$fromX + round(($toX - $fromX) * $ratio)}]
1847  set y [expr {$fromY + round(($toY - $fromY) * $ratio)}]
1848  $w.bd coords p$to $x $y
1849  $w.bd raise p$to
1850 
1851  # Schedule another animation update in a few milliseconds:
1852  after 5 "::board::_animate $w"
1853 }
1854 
1855 proc InitBoard {} {
1856  # Ensure that the current board style is valid:
1857  if {[lsearch -exact "$::boardStyles" "$::boardStyle"] == -1} {
1858  set ::boardStyle [lindex $::boardStyles 0]
1859  }
1860 
1861  setPieceFont "$::boardStyle"
1863 }
1864 InitBoard
1865 
1866 
1867 ###
1868 ### End of file: board.tcl
1869 ###