Scid  4.7.0
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
83  menuUpdateBoardSizes
84  SetBoardTextures
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
96  SetBoardTextures
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  ::win::createDialog $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
150  addHorizontalRule $w
151  pack [ttk::frame $w.select] -side top -fill x -padx 5
152  addHorizontalRule $w
153  pack [ttk::frame $w.preset] -side top -fill x
154  pack [ttk::frame $w.texture] -side top -fill x
155  addHorizontalRule $w
156  pack [ttk::frame $w.border] -side top
157  addHorizontalRule $w
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
270  chooseBoardColors
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 
338  ttk::frame $w -class Board
339  canvas $w.bd -width $bsize -height $bsize -cursor crosshair -borderwidth 0 -highlightthickness 0
340  ::applyThemeColor_background $w.bd
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
374  ::applyThemeColor_background $w.mat
375  grid $w.mat -row 6 -column 12 -rowspan 8 -pady 5 -padx 5
376  grid remove $w.mat
377 
378  ::board::coords $w
379  ::board::update $w
380  return $w
381 }
382 
383 proc ::board::addNamesBar {w {varname}} {
384  set bgcolor #fbfbfb
385  frame $w.playerW -background $bgcolor
386  frame $w.playerW.color -background #EAE0C8 -width 6 -height 6
387  canvas $w.playerW.tomove -borderwidth 0 -background $bgcolor -highlightthickness 0 -width 9 -height 9
388  label $w.playerW.name -textvariable ${varname}(nameW) -background $bgcolor -font font_SmallBold
389  label $w.playerW.elo -textvariable ${varname}(eloW) -background $bgcolor -font font_Small
390  label $w.playerW.clock -textvariable ${varname}(clockW) -background $bgcolor -font font_Small
391  grid $w.playerW.color -row 0 -column 0 -sticky news -padx 2 -pady 2
392  grid $w.playerW.name -row 0 -column 1 -sticky w
393  grid $w.playerW.elo -row 0 -column 2 -sticky w
394  grid $w.playerW.clock -row 0 -column 3 -sticky e
395  grid $w.playerW.tomove -row 0 -column 4 -sticky w -padx 4
396  grid columnconfigure $w.playerW 3 -weight 1
397  grid $w.playerW -row 16 -column 3 -columnspan 8 -sticky news -pady 4
398 
399  frame $w.playerB -background $bgcolor
400  frame $w.playerB.color -background black -width 6 -height 6
401  canvas $w.playerB.tomove -borderwidth 0 -background $bgcolor -highlightthickness 0 -width 9 -height 9
402  label $w.playerB.name -textvariable ${varname}(nameB) -background $bgcolor -font font_SmallBold
403  label $w.playerB.elo -textvariable ${varname}(eloB) -background $bgcolor -font font_Small
404  label $w.playerB.clock -textvariable ${varname}(clockB) -background $bgcolor -font font_Small
405  grid $w.playerB.color -row 0 -column 0 -sticky news -padx 2 -pady 2
406  grid $w.playerB.name -row 0 -column 1 -sticky w
407  grid $w.playerB.elo -row 0 -column 2 -sticky w
408  grid $w.playerB.clock -row 0 -column 3 -sticky e
409  grid $w.playerB.tomove -row 0 -column 4 -sticky w -padx 4
410  grid columnconfigure $w.playerB 3 -weight 1
411  grid $w.playerB -row 3 -column 3 -columnspan 8 -sticky news -pady 4
412 }
413 
414 proc ::board::addInfoBar {w varname} {
415  ttk::frame $w.bar
416  autoscrollText y $w.bar.info $w.bar.info.t TLabel
417  $w.bar.info.t tag configure header -font font_Bold
418  $w.bar.info.t tag bind click <Any-Enter> "$w.bar.info.t configure -cursor hand2"
419  $w.bar.info.t tag bind click <Any-Leave> "$w.bar.info.t configure -cursor {}"
420  grid propagate $w.bar.info 0
421  ttk::button $w.bar.back -image tb_BD_Back -style Toolbutton
422  ttk::button $w.bar.forward -image tb_BD_Forward -style Toolbutton
423  set menu [::board::newToolBar_ $w $varname]
424  ttk::button $w.bar.cmd -image tb_BD_ShowToolbar -style Toolbutton \
425  -command "::board::updateToolBar_ $menu $varname $w.bar.cmd"
426  grid $w.bar.back -row 0 -column 0 -sticky news
427  grid $w.bar.cmd -in $w.bar -row 0 -column 1 -sticky news -padx 8
428  grid $w.bar.info -in $w.bar -row 0 -column 2 -sticky news
429  grid $w.bar.forward -row 0 -column 4 -sticky news
430  grid columnconfigure $w.bar 2 -weight 1
431  grid $w.bar -row 20 -column 3 -columnspan 8 -sticky news -pady 4
432 }
433 
434 proc ::board::addInfo {{w} {msg}} {
435  if {$msg eq ""} { return}
436  $w.bar.info.t configure -state normal
437  $w.bar.info.t insert end "\n$msg"
438  $w.bar.info.t configure -state disabled
439 }
440 
441 proc ::board::setInfo {{w} {msg}} {
442  $w.bar.info.t configure -state normal
443  $w.bar.info.t delete 1.0 end
444  $w.bar.info.t insert end "$msg"
445  $w.bar.info.t configure -state disabled
446 }
447 
448 proc ::board::setInfoAlert {{w} {header} {msg} {msgcolor} {cmd}} {
449  $w.bar.info.t configure -state normal
450  $w.bar.info.t delete 1.0 end
451  $w.bar.info.t insert end "$header " {header click}
452  $w.bar.info.t insert end "$msg" {color click}
453  $w.bar.info.t configure -state disabled
454  $w.bar.info.t tag configure color -foreground $msgcolor
455  $w.bar.info.t tag bind click <ButtonRelease-1> "
456  if {[winfo exists $cmd]} {
457  after idle \"tk_popup $cmd %X \[expr -10 + %Y - \[winfo reqheight $cmd\] \]\"
458  } else {
459  after idle $cmd
460  }
461  "
462 }
463 
464 set ::board::repeatCmd 400
465 proc ::board::setButtonCmd {{w} {button} {cmd}} {
466  if {$cmd == ""} {
467  $w.bar.$button configure -state disabled
468  } else {
469  $w.bar.$button configure -state normal
470  ::bind $w.bar.$button <ButtonPress-1> "
471  $cmd
472  set ::board::repeatCmd \[expr int(\$::board::repeatCmd *0.8)\]
473  after \$::board::repeatCmd \"event generate $w.bar.$button <ButtonPress-1>\"
474  "
475  ::bind $w.bar.$button <Any-Leave> "
476  after cancel \"event generate $w.bar.$button <ButtonPress-1>\"
477  set ::board::repeatCmd 400
478  "
479  ::bind $w.bar.$button <ButtonRelease-1> "
480  after cancel \"event generate $w.bar.$button <ButtonPress-1>\"
481  set ::board::repeatCmd 400
482  "
483  }
484 }
485 
486 proc ::board::updateToolBar_ {{menu} {varname} {mb ""} } {
487  global "$varname"
488  set i [$menu index end]
489  while {$i >= 0} {
490  set idx -1
491  catch { set idx [lindex [$menu entryconfigure $i -image] 4]}
492  if {[info exists "${varname}($idx)"] } {
493  $menu entryconfigure $i -foreground black -command "eval \$::${varname}($idx)"
494  } else {
495  catch { $menu entryconfigure $i -foreground gray -command ""}
496  }
497  incr i -1
498  }
499  if {$mb != ""} {
500  set x [winfo rootx $mb]
501  set y [winfo rooty $mb]
502  set bh [winfo height $mb]
503  set mh [winfo reqheight $menu]
504  if {$y >= $mh} { incr y -$mh} { incr y $bh}
505  tk_popup $menu $x $y
506  }
507 }
508 
509 proc ::board::newToolBar_ {{w} {varname}} {
510  global "$varname"
511 
512  set m [menu $w.menu_back -bg white -font font_Regular]
513  $m add command -label " [tr BackToMainline]" -image tb_BD_BackToMainline -compound left
514  $m add command -label " [tr EditDelete]" -image tb_BD_VarDelete -compound left
515  $m add command -label " [tr LeaveVariant]" -image tb_BD_VarLeave -compound left
516  $m add command -label " [tr GameStart]" -image tb_BD_Start -compound left -accelerator "<home>"
517  ::bind $w.bar.back <ButtonRelease-$::MB3> "::board::updateToolBar_ $m $varname %W"
518 
519  set m [menu $w.menu_forw -bg white -font font_Regular]
520  $m add command -label " [tr Autoplay]" -image tb_BD_Autoplay -compound left
521  $m add command -label " [tr GameEnd]" -image tb_BD_End -compound left -accelerator "<end>"
522  ::bind $w.bar.forward <ButtonRelease-$::MB3> "::board::updateToolBar_ $m $varname %W"
523 
524  set m [menu $w.menu -bg white -font font_Regular]
525  $m add command -label " [tr EditSetup]" -image tb_BD_SetupBoard -compound left
526  $m add command -label " [tr IERotate]" -image tb_BD_Flip -compound left
527  $m add command -label " [tr ShowHideCoords]" -image tb_BD_Coords -compound left
528  $m add command -label " [tr ShowHideMaterial]" -image tb_BD_Material -compound left
529  $m add command -label " [tr FullScreen]" -image tb_BD_Fullscreen -compound left
530  set ${varname}(tb_BD_Flip) "::board::flip $w"
531  set ${varname}(tb_BD_Coords) "::board::coords $w"
532  set ${varname}(tb_BD_Material) "::board::toggleMaterial $w"
533  set ${varname}(tb_BD_Fullscreen) { wm attributes . -fullscreen [expr ![wm attributes . -fullscreen] ] }
534 
535  return $m
536 }
537 
538 proc ::board::flipNames_ { {w} {white_on_top} } {
539  if {![winfo exist $w.playerW] } { return}
540  if {$white_on_top} {
541  grid $w.playerW -row 3
542  grid $w.playerB -row 16
543  } else {
544  grid configure $w.playerW -row 16
545  grid configure $w.playerB -row 3
546  }
547 }
548 
549 proc ::board::sideToMove_ { {w} {side} } {
550  if {![winfo exist $w.playerW] } { return}
551  if {$side == "w"} {
552  $w.playerB.tomove delete -tag tomove
553  $w.playerW.tomove create rectangle 0 0 100 100 -fill blue -tag tomove
554  } elseif {$side == "b"} {
555  $w.playerW.tomove delete -tag tomove
556  $w.playerB.tomove create rectangle 0 0 100 100 -fill blue -tag tomove
557  }
558 }
559 
560 # ::board::defaultColor
561 # Returns the color (the value of the global
562 # variable "lite" or "dark") depending on whether the
563 # specified square number (0=a1, 1=b1, ..., 63=h8) is
564 # a light or dark square.
565 #
566 proc ::board::defaultColor {sq} {
567  return [expr {($sq + ($sq / 8)) % 2 ? "$::lite" : "$::dark"}]
568 }
569 
570 # ::board::size
571 # Returns the current board size.
572 #
573 proc ::board::size {w} {
574  return $::board::_size($w)
575 }
576 
577 proc ::board::resizeAuto {w bbox} {
578  set availw [lindex $bbox 2]
579  set availh [lindex $bbox 3]
580  set extraw [expr [winfo reqwidth $w] - $::board::_size($w) * 8]
581  set extrah [expr [winfo reqheight $w] - $::board::_size($w) * 8]
582  set availw [expr $availw - $extraw]
583  set availh [expr $availh - $extrah]
584  set maxSize [expr {$availh < $availw ? $availh : $availw}]
585  set maxSize [expr $maxSize / 8]
586 
587  set newSize 0
588  foreach size $::boardSizes {
589  if {$size <= $maxSize && $size > $newSize} { set newSize $size}
590  }
591 
592  return [::board::resize $w $newSize]
593 }
594 
595 # ::board::resize
596 # Resizes the board. Takes a numeric piece size (which should
597 # be in the global boardSizes list variable), or "-1" or "+1".
598 # If the size argument is "redraw", the board is redrawn.
599 # Returns the new size of the board.
600 #
601 proc ::board::resize {w psize} {
602  global boardSizes
603 
604  set oldsize $::board::_size($w)
605  if {$psize == $oldsize} { return $oldsize}
606  if {$psize == "redraw"} { set psize $oldsize}
607  if {$psize == "-1"} {
608  set index [lsearch -exact $boardSizes $oldsize]
609  if {$index == 0} { return $oldsize}
610  incr index -1
611  set psize [lindex $boardSizes $index]
612  } elseif {$psize == "+1"} {
613  set index [lsearch -exact $boardSizes $oldsize]
614  incr index
615  if {$index == [llength $boardSizes]} { return $oldsize}
616  set psize [lindex $boardSizes $index]
617  }
618 
619  # Verify that we have a valid size:
620  if {[lsearch -exact $boardSizes $psize] < 0} { return $oldsize}
621 
622  set border $::board::_border($w)
623  set bsize [expr {$psize * 8 + $border * 9}]
624 
625  $w.bd configure -width $bsize -height $bsize
626  set ::board::_size($w) $psize
627 
628  # Resize each square:
629  for {set i 0} {$i < 64} {incr i} {
630  set xi [expr {$i % 8}]
631  set yi [expr {int($i/8)}]
632  set x1 [expr {$xi * ($psize + $border) + $border }]
633  set y1 [expr {(7 - $yi) * ($psize + $border) + $border }]
634  set x2 [expr {$x1 + $psize }]
635  set y2 [expr {$y1 + $psize }]
636  set pos $i
637  if {$::board::_flip($w)} { set pos [expr {63 - $i}]}
638  $w.bd coords sq$pos $x1 $y1 $x2 $y2
639  }
640 
641  # resize the material canvas
642  $w.mat configure -height $bsize
643 
644  ::board::update $w
645 
646  return $psize
647 }
648 
649 # ::board::border
650 # Get or set the border width.
651 # If the optional argument is missing or the empty string, returns
652 # the width of the board.
653 # Otherwise, the board sqyare borders are set to the specified width.
654 #
655 proc ::board::border {w {border ""}} {
656  if {$border == ""} {
657  return $::board::_border($w)
658  } else {
659  set ::board::_border($w) $border
660  ::board::resize $w redraw
661  }
662 }
663 
664 # ::board::getSquare
665 # Given a board frame and root-window X and Y screen coordinates,
666 # returns the square number (0-63) containing that screen location,
667 # or -1 if the location is outside the board.
668 #
669 proc ::board::getSquare {w x y} {
670  if {[winfo containing $x $y] != "$w.bd"} {
671  return -1
672  }
673  set x [expr {$x - [winfo rootx $w.bd]}]
674  set y [expr {$y - [winfo rooty $w.bd]}]
675  set psize $::board::_size($w)
676  set border $::board::_border($w)
677  set x [expr {int($x / ($psize+$border))}]
678  set y [expr {int($y / ($psize+$border))}]
679 
680  if {$x < 0 || $y < 0 || $x > 7 || $y > 7} {
681  set sq -1
682  } else {
683  set sq [expr {(7-$y)*8 + $x}]
684  if {$::board::_flip($w)} { set sq [expr {63 - $sq}]}
685  }
686  return $sq
687 }
688 
689 # ::board::showMarks
690 # Turns on/off the showing of marks (colored squares).
691 #
692 proc ::board::showMarks {w value} {
693  set ::board::_showMarks($w) $value
694 }
695 
696 # ::board::colorSquare
697 # Colors the specified square (0-63) of the board.
698 # If the color is the empty string, the appropriate
699 # color for the square (light or dark) is used.
700 #
701 proc ::board::colorSquare {w i {color ""}} {
702  if {$i < 0 || $i > 63} { return}
703  if {$color != ""} {
704  $w.bd itemconfigure br$i -state hidden
705  } else {
706  set color [::board::defaultColor $i]
707  set brstate "normal"
708  if { $::glossOfDanger } {
709  array set attacks [sc_pos attacks]
710  if {[info exists attacks($i)]} {
711  set color $attacks($i)
712  }
713  }
714  foreach mark $::board::_mark($w) {
715  if {[lindex $mark 1] == $i && [lindex $mark 0] == "full"} {
716  set color [lindex $mark 3]
717  set brstate "hidden"
718  }
719  }
720  $w.bd itemconfigure br$i -state $brstate
721  }
722  $w.bd itemconfigure sq$i -fill $color -outline ""
723 }
724 
725 # ::board::midSquare
726 # Given a board and square number, returns the canvas X/Y
727 # coordinates of the midpoint of that square.
728 #
729 proc ::board::midSquare {w sq} {
730  set c [$w.bd coords sq$sq]
731  #Klimmek: calculation change, because some sizes are odd and then some squares are shifted by 1 pixel
732  # set x [expr {([lindex $c 0] + [lindex $c 2]) / 2} ]
733  # set y [expr {([lindex $c 1] + [lindex $c 3]) / 2} ]
734  set psize $::board::_size($w)
735  if { $psize % 2 } { set psize [expr {$psize - 1}]}
736  set x [expr {[lindex $c 0] + $psize/2}]
737  set y [expr {[lindex $c 1] + $psize/2}]
738  return [list $x $y]
739 }
740 
741 
742 # ::board::setmarks --
743 #
744 # Set the marks for the board:
745 # colored squares, arrows, circles, etc.
746 #
747 # Arguments:
748 # w A frame containing a board '$win.bd'.
749 # cmds Commands to draw the marks
750 # Results:
751 # Sets ::board::_mark($w) with all the right formatted commands.
752 # Marks will be drawn by ::board::update
753 # Returns nothing.
754 #
755 proc ::board::setmarks {w cmds} {
756  set ::board::_mark($w) {}
757  foreach {cmd discard} [mark::getEmbeddedCmds $cmds] {
758  lset cmd 1 [::board::sq [lindex $cmd 1]]
759  set dest [::board::sq [lindex $cmd 2]]
760  if {$dest != -1} {lset cmd 2 $dest}
761  lappend ::board::_mark($w) $cmd
762  }
763 }
764 
765 ### Namespace ::board::mark
766 
767 namespace eval ::board::mark {
768  namespace import [namespace parent]::sq
769 
770  # Regular expression constants for
771  # matching Scid's embedded commands in PGN files.
772 
773  variable StartTag {\[%}
774  variable ScidKey {mark|arrow}
775  variable Command {draw}
776  variable Type {full|square|arrow|circle|disk|tux}
777  variable Text {[-+=?!A-Za-z0-9]}
778  variable Square {[a-h][1-8]\M}
779  variable Color {[\w#][^]]*\M} ;# FIXME: too lax for #nnnnnn!
780  variable EndTag {\]}
781 
782  # Current (non-standard) version:
783  variable ScidCmdRegex \
784  "$StartTag # leading tag
785  ($ScidKey)\\\ + # (old) command name + space chars
786  ($Square) # mandatory square (e.g. 'a4')
787  (?:\\ +($Square))? # optional: another (destination) square
788  (?:\\ *($Color))? # optional: color name
789  $EndTag # closing tag
790  "
791  # Proposed new version, according to the
792  # PGN Specification and Implementation Guide (Supplement):
793  variable StdCmdRegex \
794  "${StartTag} # leading tag
795  ${Command} # command name
796  \\ # a space character
797  (?:(${Type}|$Text),)? # keyword, e.g. 'arrow' (may be omitted)
798  # or single char (indicating type 'text')
799  ($Square) # mandatory square (e.g. 'a4')
800  (?:,($Square))? # optional: (destination) square
801  (?:,($Color))? # optional: color name
802  $EndTag # closing tag
803  "
804 
805  # ChessBase' syntax for markers and arrows
806  variable CBSquare {csl}
807  variable CBarrow {cal}
808  variable CBColor {[GRY]}
809  variable Square {[a-h][1-8]\M}
810  variable sqintern {[a-h][1-8]}
811 
812  variable CBSquareRegex \
813  "$StartTag
814  ($CBSquare)\\\ +
815  ($CBColor)
816  ($Square)
817  (?:,($CBColor)($Square))?
818  $EndTag
819  "
820 
821  variable CBArrowRegex \
822  "$StartTag
823  ($CBarrow)\\\ +
824  ($CBColor)
825  ($sqintern)
826  ($sqintern)
827  $EndTag
828  "
829 }
830 
831 # ::board::mark::getEmbeddedCmds --
832 #
833 # Scans a game comment string and extracts embedded commands
834 # used by Scid to mark squares or draw arrows.
835 #
836 # Arguments:
837 # comment The game comment string, containing
838 # embedded commands, e.g.:
839 # [%mark e4 green],
840 # [%arrow c4 f7],
841 # [%draw e4],
842 # [%draw circle,f7,blue].
843 # Results:
844 # Returns a list of embedded Scid commands,
845 # {command indices ?command indices...?},
846 # where 'command' is a list representing the embedded command:
847 # '{type square ?arg? color}',
848 # e.g. '{circle f7 red}' or '{arrow c4 f7 green}',
849 # and 'indices' is a list containing start and end position
850 # of the command string within the comment.
851 #
852 proc ::board::mark::getEmbeddedCmds {comment} {
853  if {$comment == ""} {return}
854  variable ScidCmdRegex
855  variable StdCmdRegex
856  variable CBSquareRegex
857  variable CBArrowRegex
858  set result {}
859 
860  # Build regex and search script for embedded commands:
861  set regex ""
862  foreach r [list $ScidCmdRegex $StdCmdRegex $CBSquareRegex $CBArrowRegex] {
863  if {[string equal $regex ""]} {set regex $r} else {append regex "|$r"}
864  }
865  set locateScript {regexp -expanded -indices -start $start \
866  $regex $comment indices}
867 
868  # Loop over all embedded commands contained in comment string:
869 
870  for {set start 0} {[eval $locateScript]} {incr start} {
871  foreach {first last} $indices {} ;# just a multi-assign
872  foreach re [list $ScidCmdRegex $StdCmdRegex $CBSquareRegex $CBArrowRegex] {
873  # Passing matching subexpressions to variables:
874  if {![regexp -expanded $re [string range $comment $first $last] \
875  match type arg1 arg2 color]} {
876  continue
877  }
878  # CB uses rotated arguments. Bring them in order
879  if {[string equal $type "csl"] || [string equal $type "cal"]} {
880  set dummy1 $arg1
881  set dummy2 $arg2
882  set dummy3 $color
883  set color $dummy1
884  set arg1 $dummy2
885  set arg2 $dummy3
886  if {[string equal $type "csl"]} {set type "full"}
887  if {[string equal $type "cal"]} {set type "arrow"}
888  if {[string equal $color "R"]} {set color "red"}
889  if {[string equal $color "G"]} {set color "green"}
890  if {[string equal $color "Y"]} {set color "yellow"}
891  }
892  # Settings of (default) type and arguments:
893  if {[string equal $color ""]} { set color "red"}
894  switch -glob -- $type {
895  "" {set type [expr {[string length $arg2] ? "arrow" : "full"}]}
896  mark {set type "fu" ;# new syntax}
897  ? {if {[string length $arg2]} break else {
898  set arg2 $type; set type "text"}
899  }
900  }
901  # Construct result list:
902  lappend result [list $type $arg1 $arg2 $color]
903  lappend result $indices
904  set start $last ;# +1 by for-loop
905  }
906  }
907  return $result
908 }
909 
910 # ::board::mark::remove --
911 #
912 # Removes a specified mark.
913 #
914 # Arguments:
915 # win A frame containing a board '$win.bd'.
916 # args List of one or two squares.
917 # Results:
918 # Appends a dummy mark to the bord's list of marks
919 # which causes the add routine to delete all marks for
920 # the specified square(s).
921 #
922 proc ::board::mark::remove {win args} {
923  if {[llength $args] == 2} {
924  eval add $win arrow $args nocolor 1
925  } else {
926  add $win DEL [lindex $args 0] "" nocolor 1
927  }
928 }
929 
930 # ::board::mark::add --
931 #
932 # Draws arrow or mark on the specified square(s).
933 #
934 # Arguments:
935 # win A frame containing a board 'win.bd'.
936 # args What kind of mark:
937 # type Either type id (e.g., square, circle) or
938 # a single character, which is of type 'text'.
939 # square Square number 0-63 (0=a1, 1=a2, ...).
940 # ?arg2? Optional: additional type-specific parameter.
941 # color Color to use for marking the square (mandatory).
942 # ?new? Optional: whether or not this mark should be
943 # added to the list of marks; defaults to 'true'.
944 # Results:
945 # For a given square, mark type, color, and optional (type-specific)
946 # destination arguments, creates the proper canvas object.
947 #
948 proc ::board::mark::add {win args} {
949  # Rearrange list if "type" is simple character:
950  if {[string length [lindex $args 0]] == 1} {
951  # ... e.g., {c e4 red} --> {text e4 c red}
952  set args [linsert $args 1 "text"]
953  set args [linsert [lrange $args 1 end] 2 [lindex $args 0]]
954  }
955  # Add default arguments:
956  if {![regexp true|false|1|0 [lindex $args end]]} {
957  lappend args "true"
958  }
959  if {[llength $args] == 4} { set args [linsert $args 2 ""]}
960 
961  # Here we (should) have: args == <type> <square> ?<arg>? <color> <new>
962  foreach {type square dest color new} $args {break} ;# assign
963  if {[llength $args] != 5 } { return}
964 
965  set board $win.bd
966  set type [lindex $args 0]
967 
968  # Remove existing marks:
969  if {$type == "arrow"} {
970  $board delete "mark${square}:${dest}" "mark${dest}:${square}"
971  if {[string equal $color "nocolor"]} { set type DEL}
972  } else {
973  $board delete "mark${square}"
974  #not needed anymore
975  # ::board::colorSquare $win $square [::board::defaultColor $square]
976  }
977 
978  switch -- $type {
979  full { ::board::colorSquare $win $square $color}
980  DEL { set new 1}
981  default {
982  # Find a subroutine to draw the canvas object:
983  set drawingScript "Draw[string totitle $type]"
984  if {![llength [info procs $drawingScript]]} { return}
985 
986  # ... and try it:
987  if {[catch {eval $drawingScript $board $square $dest $color}]} {
988  return
989  }
990  }
991  }
992  if {$new} { lappend ::board::_mark($win) [lrange $args 0 end-1]}
993 }
994 
995 # ::board::mark::DrawXxxxx --
996 #
997 # Draws specified canvas object,
998 # where "Xxxxx" is some required type, e.g. "Circle".
999 #
1000 # Arguments:
1001 # pathName Name of the canvas widget.
1002 # args Type-specific arguments, e.g.
1003 # <square> <color>,
1004 # <square> <square> <color>,
1005 # <square> <char> <color>.
1006 # Results:
1007 # Constructs and evaluates the proper canvas command
1008 # "pathName create type coordinates options"
1009 # for the specified object.
1010 #
1011 
1012 # ::board::mark::DrawCircle --
1013 #
1014 proc ::board::mark::DrawCircle {pathName square color} {
1015  # Some "constants":
1016  set size 0.6 ;# inner (enclosing) box size, 0.0 < $size < 1.0
1017  set width 0.1 ;# outline around circle, 0.0 < $width < 1.0
1018 
1019  set box [GetBox $pathName $square $size]
1020  lappend pathName create oval [lrange $box 0 3] \
1021  -tag [list mark circle mark$square p$square]
1022  if {$width > 0.5} {
1023  ;# too thick, draw a disk instead
1024  lappend pathName -fill $color
1025  } else {
1026  set width [expr {[lindex $box 4] * $width}]
1027  if {$width <= 0.0} {set width 1.0}
1028  lappend pathName -fill "" -outline $color -width $width
1029  }
1030  eval $pathName
1031 }
1032 
1033 # ::board::mark::DrawDisk --
1034 #
1035 proc ::board::mark::DrawDisk {pathName square color} {
1036  # Size of the inner (enclosing) box within the square:
1037  set size 0.6 ;# 0.0 < $size < 1.0 = size of rectangle
1038 
1039  set box [GetBox $pathName $square $size]
1040  eval $pathName \
1041  {create oval [lrange $box 0 3]} \
1042  -fill $color \
1043  {-tag [list mark disk mark$square p$square]}
1044 }
1045 
1046 # ::board::mark::DrawText --
1047 # Pascal Georges : if shadow!="", try to make the text visible even if fg and bg colors are close
1048 proc ::board::mark::DrawText {pathName square char color {size 0} {shadowColor ""}} {
1049  set box [GetBox $pathName $square 0.8]
1050  set len [expr {($size > 0) ? $size : int([lindex $box 4])}]
1051  set x [lindex $box 5]
1052  set y [lindex $box 6]
1053  $pathName delete text$square mark$square
1054  if {$shadowColor!=""} {
1055  eval $pathName \
1056  create text [expr $x+1] [expr $y+1] -fill $shadowColor \
1057  {-font [list helvetica $len bold]} \
1058  {-text [string index $char 0]} \
1059  {-anchor c} \
1060  {-tag [list mark text text$square mark$square p$square]}
1061 
1062  }
1063  eval $pathName \
1064  create text $x $y -fill $color \
1065  {-font [list helvetica $len bold]} \
1066  {-text [string index $char 0]} \
1067  {-anchor c} \
1068  {-tag [list mark text text$square mark$square p$square]}
1069 }
1070 
1071 # ::board::mark::DrawArrow --
1072 #
1073 proc ::board::mark::DrawArrow {pathName from to color} {
1074  if {$from < 0 || $from > 63} { return}
1075  if {$to < 0 || $to > 63} { return}
1076  set coord [GetArrowCoords $pathName $from $to]
1077  eval $pathName \
1078  {create line $coord} \
1079  -fill $color -arrow last -width 2 \
1080  {-tag [list mark arrows "mark${from}:${to}"]}
1081 }
1082 
1083 # ::board::mark::DrawRectangle --
1084 # Draws a rectangle surrounding the square
1085 proc ::board::mark::DrawRectangle { pathName square color pattern } {
1086  if {$square < 0 || $square > 63} { return}
1087  set box [::board::mark::GetBox $pathName $square]
1088  $pathName create rectangle [lindex $box 0] [lindex $box 1] [lindex $box 2] [lindex $box 3] \
1089  -outline $color -width $::highlightLastMoveWidth -dash $pattern -tag highlightLastMove
1090 }
1091 
1092 # ::board::mark::DrawTux --
1093 #
1094 image create photo tux16x16 -data \
1095  {R0lGODlhEAAQAPUyAAAAABQVFiIcBi0tLTc0Kj4+PkQ3CU9ADVVFD1hJFV1X
1096  P2pXFWJUKHttLnttOERERVVWWWRjYWlqcYNsGJR5GrSUIK6fXsKdGMCdI8er
1097  ItCuNtm2KuS6KebAKufBOvjJIfnNM/3TLP/aMP/lM+/We//lQ//jfoGAgJaU
1098  jpiYmqKipczBmv/wk97e3v//3Ojo6f/96P7+/v///wAAAAAAAAAAAAAAAAAA
1099  AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEBADIALAAAAAAQABAAAAbm
1100  QJlMJpMBAAAAQCaTyWQymUwmAwQAAQAAIJPJZDKZTCYDQCInCQAgk8lkMplM
1101  JgMwOBoHACCTyYAymUwmkwEao5IFAADIZDKZTCaTAVQu2GsAAMhkMplMJgMU
1102  YrFY7AQAAGQymUwmA6RisVjsFQAAATKZTCYDBF6xWCwWewAAAJlMJjMoYrFY
1103  LBaDAAAAmUwW+oBWsVgsxlokFgCZTBYChS6oWCxmAn5CHYNMJhOJQiFS7JXS
1104  iEQjCkAmw3BCow0hAMiMNggAQCYDAAyTAwAASEwEAABAJpPJAAAAAACUAQAA
1105  gEwmCwIAOw==}
1106 set ::board::mark::tux16x16 tux16x16
1107 
1108 image create photo tux32x32 -data \
1109  {R0lGODlhIAAgAPU0AAAAABANAxERESAaBiwkCDAnCSQkJEM2DEA3GVBBDllJ
1110  EFNKLG5aFHBbFHpkFnZoMkBAQFBQUGBgYHBwcIBpF4xyGZ+DHZ+GKqmKHq+T
1111  Lb+hNsynJNSuJtu0J9+6NeW8Kc+wQPnMLPTJMP7QLv/UO//aVf/dYv/ifIiI
1112  hp+fn6+vr7+/v//lif/ol//rpM/Pz9/f3//22O/u6v/55f///////wAAAAAA
1113  AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEBADUALAAAAAAgACAAAAb+
1114  wFqtVqvVarVarQYAAAAAAABQq9VqtVqtVqvVarVarVar1Wq1Wg0AAAAAAAAA
1115  AKjVarVarVar1YC1Wq1Wq9VqtVqtBgAAAAAAAAAAAGq1Wq1Wq9VqtVqtVqvV
1116  arVaDQAAAAAAAAAAAABqtVqtVqsBa7VarVar1Wq1Wq0GMMgighdtAgAAALVa
1117  rVar1Wq1Wq1Wq9VqtVqtBphEUpCUQQUAAAC1Wq1WA9ZqtVqtVqvVarVarVYD
1118  RBYejwahAgAAgFqtVqvVarVarVar1Wq1Wq1WAxRIIdFolAEAAABArQas1Wq1
1119  Wq1Wq9VqtVqtVqvVGqPRaDTSAAAAAKBWq9VqtVr+rVar1Wq1Wq1Wq9UMp9Fo
1120  xJIJAAAAAFir1Wq1Wq1Wq9VqtVqtVqvVABGaqzWj0SYAAAAAqNVqtVqtVqvV
1121  arVarVarAQQyGo1Go9FgAAAQAAAAarVarVar1Wq1Wq1WqwEAExqNRqPRaDSD
1122  AAAAAGq1Wq1Wq9VqtVqtVqsBAC8ajUaj0Wg0oAoAAAAAgFqtVqvVarVarVar
1123  AQACGo1Go9FoNBpNAAAAAIBarVar1Wq1Wq1WqwEAKhqNRqPRaEAajYYCAAAA
1124  AKBWq9VqtVqtVqvVAAIajUaj0Wg0Go22AgAAAACgVqvVarVarVarAQARGo1G
1125  o9GANBqNRpMBAAAAAAD+qNVqtVqtVqvVAAAUjUaj0Wg0Go1GowkAAAAAAKjV
1126  arVarVar1QgUFI1GowFpNBqNRqPRDAZDAAAA1Gq1Wq1Wq9VGo1HpRaPRaDQa
1127  jUY7iQAAwUMBANRqtVqtVhuFRqPR6LIC0mg0Go1Go5lGiYBlVAEAarVarVar
1128  jUaj0Wg0KqRoNBqNRqOZRqPRaPQBAGq1Wq1Wq41Go9FoBBxtADIajUaj0Uyj
1129  0Wg0Gn0YgFqtVqvVRqPRaDQajVw0Go1Go6VGo9FoNBqNOABArVar1Uaj0Qg4
1130  Go1GoxiNRntFBqPRaDQajT4KAKBWq9Vqo9FoNBqNRiOHASIAAAqj0Wg0CmGW
1131  AAAAoFar1WoYDlAUGo1Go1FFAAAAAInRaDT6EAAAAABQq9VqNQAAAHB0QqNO
1132  AQAAAACA0Gi0AQAAAECtVqvVajUgAAAAAAAAAAAAAAAAAAAAAAAAAIBarVar
1133  1Wq1Wq1WqwEAAAAAAKjVarUaAAAAAAC1Wq1Wq9VqwFqtVqvVarVarVar1Wq1
1134  Wq1Wq9VqtVqtVqvVarUgADs=
1135  }
1136 set ::board::mark::tux32x32 tux32x32
1137 
1138 proc ::board::mark::DrawTux {pathName square discard} {
1139  variable tux16x16
1140  variable tux32x32
1141  set box [::board::mark::GetBox $pathName $square]
1142  for {set len [expr {int([lindex $box 4])}]} {$len > 0} {incr len -1} {
1143  if {[info exists tux${len}x${len}]} break
1144  }
1145  if {!$len} return
1146  $pathName create image [lrange $box 5 6] \
1147  -image tux${len}x${len} \
1148  -tag [list mark "mark$square" tux]
1149 }
1150 
1151 # ::board::mark::GetArrowCoords --
1152 #
1153 # Auxiliary function:
1154 # Similar to '::board::midSquare', but this function returns
1155 # coordinates of two (optional adjusted) squares.
1156 #
1157 # Arguments:
1158 # board A board canvas ('win.bd' for a frame 'win').
1159 # from Source square number (0-63).
1160 # to Destination square number (0-63).
1161 # shrink Optional shrink factor (0.0 - 1.0):
1162 # 0.0 = no shrink, i.e. just return midpoint coordinates,
1163 # 1.0 = start and end at edge (unless adjacent squares).
1164 # Results:
1165 # Returns a list of coordinates {x1 y1 x2 y2} for drawing
1166 # an arrow "from" --> "to".
1167 #
1168 proc ::board::mark::GetArrowCoords {board from to {shrink 0.6}} {
1169  if {$shrink < 0.0} {set shrink 0.0}
1170  if {$shrink > 1.0} {set shrink 1.0}
1171 
1172  # Get left, top, right, bottom, length, midpoint_x, midpoint_y:
1173  set fromXY [GetBox $board $from]
1174  set toXY [GetBox $board $to]
1175  # Get vector (dX,dY) = to(x,y) - from(x,y)
1176  # (yes, misusing the foreach multiple features)
1177  foreach {x0 y0} [lrange $fromXY 5 6] {x1 y1} [lrange $toXY 5 6] {break}
1178  set dX [expr {$x1 - $x0}]
1179  set dY [expr {$y1 - $y0}]
1180 
1181  # Check if we have good coordinates and shrink factor:
1182  if {($shrink == 0.0) || ($dX == 0.0 && $dY == 0.0)} {
1183  return [list $x0 $y0 $x1 $y1]
1184  }
1185 
1186  # Solve equation: "midpoint + (lambda * vector) = edge point":
1187  if {abs($dX) > abs($dY)} {
1188  set edge [expr {($dX > 0) ? [lindex $fromXY 2] : [lindex $fromXY 0]}]
1189  set lambda [expr {($edge - $x0) / $dX}]
1190  } else {
1191  set edge [expr {($dY > 0) ? [lindex $fromXY 3] : [lindex $fromXY 1]}]
1192  set lambda [expr {($edge - $y0) / $dY}]
1193  }
1194 
1195  # Check and adjust shrink factor for adjacent squares
1196  # (i.e. don't make arrows too short):
1197  set maxShrinkForAdjacent 0.667
1198  if {$shrink > $maxShrinkForAdjacent} {
1199  set dFile [expr {($to % 8) - ($from % 8)}]
1200  set dRank [expr {($from / 8) - ($to / 8)}]
1201  if {(abs($dFile) <= 1) && (abs($dRank) <= 1)} {
1202  set shrink $maxShrinkForAdjacent
1203  }
1204  }
1205 
1206  # Return shrinked line coordinates {x0', y0', x1', y1'}:
1207  set shrink [expr {$shrink * $lambda}]
1208  return [list [expr {$x0 + $shrink * $dX}] [expr {$y0 + $shrink * $dY}]\
1209  [expr {$x1 - $shrink * $dX}] [expr {$y1 - $shrink * $dY}]]
1210 }
1211 
1212 # ::board::mark::GetBox --
1213 #
1214 # Auxiliary function:
1215 # Get coordinates of an inner box for a specified square.
1216 #
1217 # Arguments:
1218 # pathName Name of a canvas widget containing squares.
1219 # square Square number (0..63).
1220 # portion Portion (length inner box) / (length square)
1221 # (1.0 means: box == square).
1222 # Results:
1223 # Returns a list whose elements are upper left and lower right
1224 # corners, length, and midpoint (x,y) of the inner box.
1225 #
1226 proc ::board::mark::GetBox {pathName square {portion 1.0}} {
1227  set coord [$pathName coords sq$square]
1228  set len [expr {[lindex $coord 2] - [lindex $coord 0]}]
1229  if {$portion < 1.0} {
1230  set dif [expr {$len * (1.0 -$portion) * 0.5}]
1231  foreach i {0 1} { lappend box [expr {[lindex $coord $i] + $dif}]}
1232  foreach i {2 3} { lappend box [expr {[lindex $coord $i] - $dif}]}
1233  } else {
1234  set box $coord
1235  }
1236  lappend box [expr { [lindex $box 2] - [lindex $box 0] }]
1237  lappend box [expr {([lindex $box 0] + [lindex $box 2]) / 2}]
1238  lappend box [expr {([lindex $box 1] + [lindex $box 3]) / 2}]
1239  return $box
1240 }
1241 
1242 ### End of namespace ::board::mark
1243 
1244 # ::board::piece {w sq}
1245 # Given a board and square number, returns the piece type
1246 # (e for empty, wp for White Pawn, etc) of the square.
1247 proc ::board::piece {w sq} {
1248  set p [string index $::board::_data($w) $sq]
1249  return $::board::letterToPiece($p)
1250 }
1251 
1252 # ::board::setDragSquare
1253 # Sets the square from whose piece should be dragged.
1254 # To drag nothing, the square value should be -1.
1255 # If the previous value is a valid square (0-63), the
1256 # piece being dragged is returned to its home square first.
1257 #
1258 proc ::board::setDragSquare {w sq} {
1259  set oldSq $::board::_drag($w)
1260  if {$oldSq >= 0 && $oldSq <= 63} {
1261  ::board::drawPiece $w $oldSq [string index $::board::_data($w) $oldSq]
1262  $w.bd raise arrows
1263  }
1264  set ::board::_drag($w) $sq
1265  return $oldSq
1266 }
1267 
1268 proc ::board::getDragSquare {w} {
1269  return $::board::_drag($w)
1270 }
1271 
1272 
1273 # ::board::dragPiece
1274 # Drags the piece of the drag-square (as set above) to
1275 # the specified global (root-window) screen coordinates.
1276 #
1277 proc ::board::dragPiece {w x y} {
1278  set sq $::board::_drag($w)
1279  if {$sq < 0} { return}
1280  set x [expr {$x - [winfo rootx $w.bd]}]
1281  set y [expr {$y - [winfo rooty $w.bd]}]
1282  $w.bd coords p$sq $x $y
1283  $w.bd raise p$sq
1284 }
1285 
1286 # ::board::bind
1287 # Binds the given event on the given square number to
1288 # the specified action.
1289 #
1290 proc ::board::bind {w sq event action} {
1291  if {$sq == "all"} {
1292  for {set i 0} {$i < 64} {incr i} {
1293  $w.bd bind p$i $event $action
1294  }
1295  } else {
1296  $w.bd bind p$sq $event $action
1297  }
1298 }
1299 
1300 # ::board::drawPiece
1301 # Draws a piece on a specified square.
1302 #
1303 proc ::board::drawPiece {w sq piece} {
1304  set psize $::board::_size($w)
1305  set flip $::board::_flip($w)
1306  # Compute the XY coordinates for the centre of the square:
1307  set midpoint [::board::midSquare $w $sq]
1308  set xc [lindex $midpoint 0]
1309  set yc [lindex $midpoint 1]
1310  # Delete any old image for this square, and add the new one:
1311  $w.bd delete p$sq
1312  $w.bd create image $xc $yc -image $::board::letterToPiece($piece)$psize -tag p$sq
1313 }
1314 
1315 # ::board::clearText
1316 # Remove all text annotations from the board.
1317 #
1318 proc ::board::clearText {w} {
1319  $w.bd delete texts
1320 }
1321 
1322 # ::board::drawText
1323 # Draws the specified text on the specified square.
1324 # Additional arguments are treated as canvas text parameters.
1325 #
1326 proc ::board::drawText {w sq text color args {shadow ""} } {
1327  mark::DrawText ${w}.bd $sq $text $color \
1328  [expr {[catch {font actual font_Bold -size} size] ? 11 : $size}] \
1329  $shadow
1330  #if {[llength $args] > 0} {
1331  # catch {eval $w.bd itemconfigure text$sq $args}
1332  #}
1333 }
1334 
1335 # Highlight last move played by drawing a red rectangle around the two squares
1336 proc ::board::lastMoveHighlight {w} {
1337  $w.bd delete highlightLastMove
1338  if { ! $::highlightLastMove } {return}
1339  set moveuci [ sc_game info previousMoveUCI]
1340  if {[string length $moveuci] >= 4} {
1341  set moveuci [ string range $moveuci 0 3]
1342  set square1 [ ::board::sq [string range $moveuci 0 1]]
1343  set square2 [ ::board::sq [string range $moveuci 2 3]]
1344  ::board::mark::DrawRectangle $w.bd $square1 $::highlightLastMoveColor $::highlightLastMovePattern
1345  ::board::mark::DrawRectangle $w.bd $square2 $::highlightLastMoveColor $::highlightLastMovePattern
1346  if { ! $::arrowLastMove } {return}
1347  ::board::mark::DrawArrow $w.bd $square1 $square2 $::highlightLastMoveColor
1348  }
1349 }
1350 
1351 # ::board::update
1352 # Update the board given a 64-character board string as returned
1353 # by the "sc_pos board" command. If the board string is empty, it
1354 # defaults to the previous value for this board.
1355 # If the optional parameter "animate" is 1 and the changes from
1356 # the previous board state appear to be a valid chess move, the
1357 # move is animated.
1358 #
1359 proc ::board::update {w {board ""} {animate 0}} {
1360  set oldboard $::board::_data($w)
1361  if {$board == ""} {
1362  set board $::board::_data($w)
1363  } else {
1364  set ::board::_data($w) $board
1365  }
1366  set psize $::board::_size($w)
1367 
1368  # Cancel any current animation:
1369  after cancel "::board::_animate $w"
1370 
1371  # Remove all marks (incl. arrows) from the board:
1372  $w.bd delete mark
1373 
1374  # Draw each square:
1375  for {set sq 0} { $sq < 64 } { incr sq} {
1376  set piece [string index $board $sq]
1377  # Compute the XY coordinates for the centre of the square:
1378  set midpoint [::board::midSquare $w $sq]
1379  set xc [lindex $midpoint 0]
1380  set yc [lindex $midpoint 1]
1381  #update every square with color and texture
1382  set color [::board::defaultColor $sq]
1383  $w.bd itemconfigure sq$sq -fill $color -outline "" ; #-outline $color
1384 
1385  set boc bgd$psize
1386  if { ($sq + ($sq / 8)) % 2 } { set boc bgl$psize}
1387  $w.bd delete br$sq
1388  $w.bd create image $xc $yc -image $boc -tag br$sq
1389 
1390  # Delete any old image for this square, and add the new one:
1391  $w.bd delete p$sq
1392  $w.bd create image $xc $yc -image $::board::letterToPiece($piece)$psize -tag p$sq
1393  }
1394 
1395  # Update side-to-move icon:
1396  ::board::sideToMove_ $w [string index $::board::_data($w) 65]
1397 
1398  # Gloss Of Danger:
1399  if { $::glossOfDanger } {
1400  foreach {sq col} [sc_pos attacks] {
1401  ::board::colorSquare $w $sq $col
1402  }
1403  }
1404 
1405  # Redraw marks and arrows if required:
1406  if {$::board::_showMarks($w)} {
1407  foreach mark $::board::_mark($w) {
1408  set type [lindex $mark 0]
1409  if {$type == "full"} {
1410  ::board::colorSquare $w [lindex $mark 1] [lindex $mark 3]
1411  } else {
1412  # Find a subroutine to draw the canvas object:
1413  set drawingScript "mark::Draw[string totitle $type]"
1414  if {[llength [info procs $drawingScript]]} {
1415  catch {eval $drawingScript $w.bd [join [lrange $mark 1 3]]}
1416  }
1417  }
1418  }
1419  }
1420 
1421  # Redraw last move highlight if mainboard
1422  if { $w == ".main.board"} {
1423  ::board::lastMoveHighlight $w
1424  }
1425 
1426  # Redraw material values
1427  if {$::board::_showmat($w)} {
1428  ::board::material $w
1429  }
1430 
1431  # Animate board changes if requested:
1432  if {$animate && $board != $oldboard} {
1433  ::board::animate $w $oldboard $board
1434  }
1435 }
1436 
1437 proc ::board::isFlipped {w} {
1438  return $::board::_flip($w)
1439 }
1440 
1441 # ::board::flipAuto
1442 # Sometimes SCID wants to automatically rotate the board,
1443 # i.e. when playing a game or loading a game with the "FlipB" flag set.
1444 # This function flip the board, but allow to restore the last state
1445 # (rotated, not rotated) selected by the user
1446 # @newstate: 0 ->white bottom
1447 # 1 ->black bottom
1448 # -1 ->restore previous state
1449 #
1450 proc ::board::flipAuto {w {newstate -1}} {
1451  if {$newstate == -1} {
1452  if {[info exists ::board::flipAuto_($w)]} {::board::flip $w $::board::flipAuto_($w)}
1453  return
1454  }
1455  set tmp $::board::_flip($w)
1456  if {[info exists ::board::flipAuto_($w)]} { set tmp $::board::flipAuto_($w)}
1457  ::board::flip $w $newstate
1458  set ::board::flipAuto_($w) $tmp
1459 }
1460 
1461 # ::board::flip
1462 # Rotate the board 180 degrees.
1463 #
1464 proc ::board::flip {w {newstate -1}} {
1465  if {! [info exists ::board::_flip($w)]} { return}
1466  catch {unset ::board::flipAuto_($w)}
1467  if {$newstate == $::board::_flip($w)} { return}
1468  set flip [expr {1 - $::board::_flip($w)}]
1469  set ::board::_flip($w) $flip
1470 
1471  # Swap squares:
1472  for {set i 0} {$i < 32} {incr i} {
1473  set swap [expr {63 - $i}]
1474  set coords(South) [$w.bd coords sq$i]
1475  set coords(North) [$w.bd coords sq$swap]
1476  $w.bd coords sq$i $coords(North)
1477  $w.bd coords sq$swap $coords(South)
1478  }
1479 
1480  # Change coordinate labels:
1481  for {set i 1} {$i <= 8} {incr i} {
1482  set value [expr {9 - [$w.lrank$i cget -text]}]
1483  $w.lrank$i configure -text $value
1484  $w.rrank$i configure -text $value
1485  }
1486  if {$flip} {
1487  foreach file {a b c d e f g h} newvalue {h g f e d c b a} {
1488  $w.tfile$file configure -text $newvalue
1489  $w.bfile$file configure -text $newvalue
1490  }
1491  } else {
1492  foreach file {a b c d e f g h} {
1493  $w.tfile$file configure -text $file
1494  $w.bfile$file configure -text $file
1495  }
1496  }
1497  ::board::flipNames_ $w $flip
1498  ::board::update $w
1499  return $w
1500 }
1501 ################################################################################
1502 # ::board::material
1503 # displays material balance
1504 ################################################################################
1505 proc ::board::material {w} {
1506  set f $w.mat
1507 
1508  $f delete material
1509 
1510  set fen [lindex [sc_pos fen] 0]
1511  set p 0
1512  set n 0
1513  set b 0
1514  set r 0
1515  set q 0
1516  for {set i 0} {$i < [string length $fen]} {incr i} {
1517  set ch [string index $fen $i]
1518  switch -- $ch {
1519  p {incr p -1}
1520  P {incr p}
1521  n {incr n -1}
1522  N {incr n}
1523  b {incr b -1}
1524  B {incr b}
1525  r {incr r -1}
1526  R {incr r}
1527  q {incr q -1}
1528  Q {incr q}
1529  }
1530  }
1531  set sum [expr abs($p) + abs($n) +abs($b) +abs($r) +abs($q)]
1532  set rank 0
1533 
1534  foreach pType {q r b n p} {
1535  set count [expr "\$$pType"]
1536  if {$count < 0} {
1537  addMaterial $count $pType $f $rank $sum
1538  incr rank [expr abs($count)]
1539  }
1540  }
1541  foreach pType {q r b n p} {
1542  set count [expr "\$$pType"]
1543  if {$count > 0} {
1544  addMaterial $count $pType $f $rank $sum
1545  incr rank [expr abs($count)]
1546  }
1547  }
1548 }
1549 proc ::board::addMaterial {count piece parent rank sum} {
1550  if {$count == 0} {return}
1551  if {$count <0} {
1552  set col "b"
1553  set count [expr 0 - $count]
1554  } else {
1555  set col "w"
1556  }
1557  set w [$parent cget -width]
1558  set h [$parent cget -height]
1559  set offset [expr ($h - ($sum * 20)) / 2]
1560  if {$offset <0} { set offset 0}
1561  set x [expr $w / 2]
1562  for {set i 0} {$i<$count} {incr i} {
1563  set y [expr $rank * 20 +10 + $offset + $i * 20]
1564  $parent create image $x $y -image $col${piece}20 -tag material
1565  }
1566 }
1567 proc ::board::toggleMaterial {w} {
1568  set ::board::_showmat($w) [expr {1 - $::board::_showmat($w)}]
1569  if {$::board::_showmat($w)} {
1570  grid $w.mat
1571  } else {
1572  grid remove $w.mat
1573  }
1574  ::board::update $w
1575  return $::board::_showmat($w)
1576 }
1577 
1578 ################################################################################
1579 #
1580 ################################################################################
1581 
1582 # ::board::coords
1583 # Add or remove coordinates around the edge of the board.
1584 # Toggle between 0,1,2.
1585 proc ::board::coords {w} {
1586  set coords [expr {1 + $::board::_coords($w)}]
1587  if { $coords > 2 } { set coords 0}
1588  set ::board::_coords($w) $coords
1589 
1590  if {$coords == 0 } {
1591  for {set i 1} {$i <= 8} {incr i} {
1592  grid remove $w.lrank$i
1593  grid remove $w.rrank$i
1594  }
1595  foreach i {a b c d e f g h} {
1596  grid remove $w.tfile$i
1597  grid remove $w.bfile$i
1598  }
1599  } elseif {$coords == 1 } {
1600  for {set i 1} {$i <= 8} {incr i} {
1601  grid configure $w.lrank$i
1602  grid remove $w.rrank$i
1603  }
1604  foreach i {a b c d e f g h} {
1605  grid remove $w.tfile$i
1606  grid configure $w.bfile$i
1607  }
1608  } else { #Klimmek: coords == 2 then show left and bottom
1609  for {set i 1} {$i <= 8} {incr i} {
1610  grid configure $w.lrank$i
1611  grid configure $w.rrank$i
1612  }
1613  foreach i {a b c d e f g h} {
1614  grid configure $w.tfile$i
1615  grid configure $w.bfile$i
1616  }
1617  }
1618 
1619  return $coords
1620 }
1621 
1622 # ::board::animate
1623 # Check for board changes that appear to be a valid chess move,
1624 # and start animating the move if applicable.
1625 #
1626 proc ::board::animate {w oldboard newboard} {
1627  global animateDelay
1628  if {$animateDelay <= 0} { return}
1629 
1630  # Find which squares differ between the old and new boards:
1631  set diffcount 0
1632  set difflist [list]
1633  for {set i 0} {$i < 64} {incr i} {
1634  if {[string index $oldboard $i] != [string index $newboard $i]} {
1635  incr diffcount
1636  lappend difflist $i
1637  }
1638  }
1639 
1640  # Check the number of differences could mean a valid move:
1641  if {$diffcount < 2 || $diffcount > 4} { return}
1642 
1643  for {set i 0} {$i < $diffcount} {incr i} {
1644  set sq($i) [lindex $difflist $i]
1645  set old($i) [string index $oldboard $sq($i)]
1646  set new($i) [string index $newboard $sq($i)]
1647  }
1648 
1649  set from -1
1650  set to -1
1651  set captured -1
1652  set capturedPiece "."
1653 
1654  if {$diffcount == 4} {
1655  # Check for making/unmaking a castling move:
1656  set castlingList [list [sq e1] [sq g1] [sq h1] [sq f1] \
1657  [sq e8] [sq g8] [sq h8] [sq f8] \
1658  [sq e1] [sq c1] [sq a1] [sq d1] \
1659  [sq e8] [sq c8] [sq a8] [sq d8]]
1660 
1661  foreach {kfrom kto rfrom rto} $castlingList {
1662  if {[lsort $difflist] == [lsort [list $kfrom $kto $rfrom $rto]]} {
1663  if {[string tolower [string index $oldboard $kfrom]] == "k" &&
1664  [string tolower [string index $oldboard $rfrom]] == "r" &&
1665  [string tolower [string index $newboard $kto]] == "k" &&
1666  [string tolower [string index $newboard $rto]] == "r"} {
1667  # A castling move animation.
1668  # Move the rook back to initial square until animation is complete:
1669  # TODO: It may look nicer if the rook was animated as well...
1670  eval $w.bd coords p$rto [::board::midSquare $w $rfrom]
1671  set from $kfrom
1672  set to $kto
1673  } elseif {[string tolower [string index $newboard $kfrom]] == "k" &&
1674  [string tolower [string index $newboard $rfrom]] == "r" &&
1675  [string tolower [string index $oldboard $kto]] == "k" &&
1676  [string tolower [string index $oldboard $rto]] == "r"} {
1677  # An undo-castling animation. No need to move the rook.
1678  set from $kto
1679  set to $kfrom
1680  }
1681  }
1682  }
1683  }
1684 
1685  if {$diffcount == 3} {
1686  # Three squares are different, so check for an En Passant capture:
1687  foreach i {0 1 2} {
1688  foreach j {0 1 2} {
1689  foreach k {0 1 2} {
1690  if {$i == $j || $i == $k || $j == $k} { continue}
1691  # Check for an en passant capture from i to j with the enemy
1692  # pawn on k:
1693  if {$old($i) == $new($j) && $old($j) == "." && $new($k) == "." &&
1694  (($old($i) == "p" && $old($k) == "P") ||
1695  ($old($i) == "P" && $old($k) == "p"))} {
1696  set from $sq($i)
1697  set to $sq($j)
1698  }
1699  # Check for undoing an en-passant capture from j to i with
1700  # the enemy pawn on k:
1701  if {$old($i) == $new($j) && $old($k) == "." && $new($i) == "." &&
1702  (($old($i) == "p" && $new($k) == "P") ||
1703  ($old($i) == "P" && $new($k) == "p"))} {
1704  set from $sq($i)
1705  set to $sq($j)
1706  set captured $sq($k)
1707  set capturedPiece $new($k)
1708  }
1709  }
1710  }
1711  }
1712  }
1713 
1714  if {$diffcount == 2} {
1715  # Check for a regular move or capture: one old square should have the
1716  # same (non-empty) piece as the other new square, and at least one
1717  # of the old or new squares should be empty.
1718 
1719  if {$old(0) != "." && $old(1) != "." && $new(0) != "." && $new(1) != "."} {
1720  return
1721  }
1722 
1723  foreach i {0 1} {
1724  foreach j {0 1} {
1725  if {$i == $j} { continue}
1726  if {$old($i) == $new($j) && $old($i) != "."} {
1727  set from $sq($i)
1728  set to $sq($j)
1729  set captured $sq($j)
1730  set capturedPiece $old($j)
1731  }
1732 
1733  # Check for a (white or black) pawn promotion from i to j:
1734  if {($old($i) == "P" && [string is upper $new($j)] &&
1735  $sq($j) >= [sq a8] && $sq($j) <= [sq h8]) ||
1736  ($old($i) == "p" && [string is lower $new($j)] &&
1737  $sq($j) >= [sq a1] && $sq($j) <= [sq h1])} {
1738  set from $sq($i)
1739  set to $sq($j)
1740  }
1741 
1742  # Check for undoing a pawn promotion from j to i:
1743  if {($new($j) == "P" && [string is upper $old($i)] &&
1744  $sq($i) >= [sq a8] && $sq($i) <= [sq h8]) ||
1745  ($new($j) == "p" && [string is lower $old($i)] &&
1746  $sq($i) >= [sq a1] && $sq($i) <= [sq h1])} {
1747  set from $sq($i)
1748  set to $sq($j)
1749  set captured $sq($j)
1750  set capturedPiece $old($j)
1751  }
1752  }
1753  }
1754  }
1755 
1756  # Check that we found a valid-looking move to animate:
1757  if {$from < 0 || $to < 0} { return}
1758 
1759  # Redraw the captured piece during the animation if necessary:
1760  if {$capturedPiece != "." && $captured >= 0} {
1761  ::board::drawPiece $w $from $capturedPiece
1762  eval $w.bd coords p$from [::board::midSquare $w $captured]
1763  }
1764 
1765  # Move the animated piece back to its starting point:
1766  eval $w.bd coords p$to [::board::midSquare $w $from]
1767  $w.bd raise p$to
1768 
1769  # Start the animation:
1770  set start [clock clicks -milli]
1771  set ::board::_animate($w,start) $start
1772  set ::board::_animate($w,end) [expr {$start + $::animateDelay}]
1773  set ::board::_animate($w,from) $from
1774  set ::board::_animate($w,to) $to
1775  ::board::_animate $w
1776 }
1777 
1778 # ::board::_animate
1779 # Internal procedure for updating a board move animation.
1780 #
1781 proc ::board::_animate {w} {
1782  if {! [winfo exists $w]} { return}
1783  set from $::board::_animate($w,from)
1784  set to $::board::_animate($w,to)
1785  set start $::board::_animate($w,start)
1786  set end $::board::_animate($w,end)
1787  set now [clock clicks -milli]
1788  if {$now > $end} {
1789  ::board::update $w
1790  return
1791  }
1792 
1793  # Compute where the moving piece should be displayed and move it:
1794  set ratio [expr {double($now - $start) / double($end - $start)}]
1795  set fromMid [::board::midSquare $w $from]
1796  set toMid [::board::midSquare $w $to]
1797  set fromX [lindex $fromMid 0]
1798  set fromY [lindex $fromMid 1]
1799  set toX [lindex $toMid 0]
1800  set toY [lindex $toMid 1]
1801  set x [expr {$fromX + round(($toX - $fromX) * $ratio)}]
1802  set y [expr {$fromY + round(($toY - $fromY) * $ratio)}]
1803  $w.bd coords p$to $x $y
1804  $w.bd raise p$to
1805 
1806  # Schedule another animation update in a few milliseconds:
1807  after 5 "::board::_animate $w"
1808 }
1809 
1810 proc InitBoard {} {
1811  # Ensure that the current board style is valid:
1812  if {[lsearch -exact "$::boardStyles" "$::boardStyle"] == -1} {
1813  set ::boardStyle [lindex $::boardStyles 0]
1814  }
1815 
1816  setPieceFont "$::boardStyle"
1817  menuUpdatePieces
1818 }
1819 InitBoard
1820 
1821 
1822 ###
1823 ### End of file: board.tcl
1824 ###
Generated by   doxygen 1.8.13