Scid  4.6.5
misc.tcl
Go to the documentation of this file.
1 ###
2 ### misc.tcl: part of Scid.
3 ### Copyright (C) 2001 Shane Hudson.
4 ### Copyright (C) 2007 Pascal Georges
5 ### Copyright (C) 2015 Fulvio Benini
6 ###
7 ### Miscellaneous routines called by other Tcl functions
8 
9 ################################################################################
10 # vwait but will timeout after a delay. Var must be fully qualified (::)
11 ################################################################################
12 proc vwaitTimed { var {delay 0} {warn "warnuser"} } {
13 
14  proc trigger {var warn} {
15  if {$warn == "warnuser"} {
16  tk_messageBox -type ok -icon error -parent . -title "Protocol error" -message "vwait timeout for $var"
17  }
18  set $var 1
19  }
20 
21  if { $delay != 0 } {
22  set timerId [after $delay "trigger $var $warn"]
23  }
24 
25  vwait $var
26 
27  if [info exists timerId] { after cancel $timerId}
28 
29 }
30 
31 ################################################################################
32 # bindFocusColors:
33 # Configures a text or entry widget so it turns lightYellow when it
34 # gets the focus, and turns white again when it loses focus.
35 #
36 # THIS IS CURRENTLY DISABLED since it works fine with regular entry widgets
37 # but causes problems with our combobox widgets, not sure why!
38 #
39 proc bindFocusColors {w {inColor lightYellow} {outColor white}} {
40  $w configure -background $outColor
41  #bind $w <FocusIn> "+$w configure -background $inColor"
42  #bind $w <FocusOut> "+$w configure -background $outColor"
43 }
44 
45 
46 ## FROM TK 8.5.9
47 ## ttk::bindMouseWheel $bindtag $command...
48 # Adds basic mousewheel support to $bindtag.
49 # $command will be passed one additional argument
50 # specifying the mousewheel direction (-1: up, +1: down).
51 #
52 
53 proc bindMouseWheel {bindtag callback} {
54  switch -- [tk windowingsystem] {
55  x11 {
56  bind $bindtag <ButtonPress-4> "$callback -1; break"
57  bind $bindtag <ButtonPress-5> "$callback +1; break"
58  }
59  win32 {
60  bind $bindtag <<MWheel>> "[append callback { [expr {-(%d/120)}]}]; break"
61  }
62  aqua {
63  bind $bindtag <MouseWheel> "[append callback { [expr {-(%D)}]}]; break"
64  }
65  }
66 }
67 
68 # dialogbuttonframe:
69 # Creates a frame that will be shown at the bottom of a
70 # dialog window. It takes two parameters: the frame widget
71 # name to create, and a list of button args. Each element
72 # should contain a widget name, and button arguments.
73 #
74 proc dialogbuttonframe {frame buttonlist} {
75  ttk::frame $frame
76  set bnames {}
77  set maxlength 0
78  foreach buttonargs $buttonlist {
79  set bname $frame.[lindex $buttonargs 0]
80  set bargs [lrange $buttonargs 1 end]
81  eval ttk::button $bname $bargs
82  set bnames [linsert $bnames 0 $bname]
83  set length [string length [$bname cget -text]]
84  if {$length > $maxlength} { set length $maxlength}
85  }
86  if {$maxlength < 7} { set maxlength 7}
87  foreach b $bnames {
88  $b configure -width $maxlength -padx 4
89  pack $b -side right -padx 4 -pady 4
90  }
91 }
92 
93 # packbuttons
94 # Packs a row of dialog buttons to the left/right of their frame
95 # with a standard amount of padding.
96 #
97 proc packbuttons {side args} {
98  eval pack $args -side $side -padx 5 -pady 3
99 }
100 
101 # dialogbutton:
102 # Creates a button that will be shown in a dialog box, so it
103 # is given a minimum width.
104 #
105 proc dialogbutton {w args} {
106  set retval [eval ttk::button $w $args] ;# -style TButton
107  set length [string length [$w cget -text]]
108  if {$length < 7} { set length 7}
109  $w configure -width $length
110  return retval
111 }
112 
113 proc dialogbuttonsmall {w args {style "Small.TButton"} } {
114  set retval [eval ttk::button $w -style $style $args]
115  set length [string length [$w cget -text]]
116  if {$length < 7} { set length 7}
117  $w configure -width $length
118  return retval
119 }
120 
121 # autoscrollframe
122 # Creates and returns a frame containing a widget which is gridded
123 # with scrollbars that automatically hide themselves when they are
124 # not needed.
125 # The frame and widget may already exist; they are created if needed.
126 # FBF 2011.03.05:
127 # $frame and $w aspects are not changed if they already exists
128 # scrollbars are created on time 0, otherwise they are not hidden
129 #
130 # Usage:
131 # autoscrollframe [-bars none|x|y|both] frame type w args
132 #
133 proc autoscrollframe {args} {
134  global _autoscroll
135  set bars both
136  if {[lindex $args 0] == "-bars"} {
137  set bars [lindex $args 1]
138  if {$bars != "x" && $bars != "y" && $bars != "none" && $bars != "both"} {
139  return -code error "Invalid parameter: -bars $bars"
140  }
141  set args [lrange $args 2 end]
142  }
143  if {[llength $args] < 3} {
144  return -code error "Insufficient number of parameters"
145  }
146  set frame [lindex $args 0]
147  set type [lindex $args 1]
148  set w [lindex $args 2]
149  set args [lrange $args 3 end]
150 
151  set retval $frame
152  if {! [winfo exists $frame]} {
153  frame $frame
154  $frame configure -relief sunken -borderwidth 2
155  }
156  if {! [winfo exists $w]} {
157  $type $w
158  if {[llength $args] > 0} {
159  eval $w configure $args
160  }
161  $w configure -relief flat -borderwidth 0
162  }
163  grid $w -in $frame -row 0 -column 0 -sticky news
164  set setgrid 0
165  catch {set setgrid [$w cget -setgrid]}
166 
167  if {$bars == "y" || $bars == "both"} {
168  ttk::scrollbar $frame.ybar -command [list $w yview] -takefocus 0
169  $w configure -yscrollcommand [list _autoscroll $frame.ybar]
170  grid $frame.ybar -row 0 -column 1 -sticky ns
171  set _autoscroll($frame.ybar) 1
172  set _autoscroll(time:$frame.ybar) 0
173  bindMouseWheel $w "_autoscrollMouseWheel $w $frame.ybar"
174  if {! $setgrid} {
175  # bind $frame.ybar <Map> [list _autoscrollMap $frame]
176  }
177  }
178  if {$bars == "x" || $bars == "both"} {
179  ttk::scrollbar $frame.xbar -command [list $w xview] -takefocus 0 -orient horizontal
180  $w configure -xscrollcommand [list _autoscroll $frame.xbar]
181  grid $frame.xbar -row 1 -column 0 -sticky we
182  set _autoscroll($frame.xbar) 1
183  set _autoscroll(time:$frame.xbar) 0
184  if {! $setgrid} {
185  # bind $frame.xbar <Map> [list _autoscrollMap $frame]
186  }
187  }
188  grid rowconfigure $frame 0 -weight 1
189  grid columnconfigure $frame 0 -weight 1
190  grid rowconfigure $frame 1 -weight 0
191  grid columnconfigure $frame 1 -weight 0
192  return $retval
193 }
194 
195 proc _autoscrollMouseWheel {{w} {bar} {direction}} {
196  if {$::_autoscroll($bar) == 0} return
197  $w yview scroll $direction units
198 }
199 
200 array set _autoscroll {}
201 
202 # _autoscroll
203 # This is the "set" command called for auto-scrollbars.
204 # If the bar is shown but should not be, it is hidden.
205 # If the bar is hidden but should be shown, it is redrawn.
206 # Note that once a bar is shown, it will not be removed again for
207 # at least a few milliseconds; this is to overcome problematic
208 # interactions between the x and y scrollbars where hiding one
209 # causes the other to be shown etc. This usually happens because
210 # the stupid Tcl/Tk text widget doesn't handle scrollbars well.
211 #
212 proc _autoscroll {bar args} {
213  global _autoscroll
214  if {[llength $args] == 2} {
215  set min [lindex $args 0]
216  set max [lindex $args 1]
217  if {$min > 0.0 || $max < 1.0} {
218  if {! $_autoscroll($bar)} {
219  grid configure $bar
220  set _autoscroll($bar) 1
221  set _autoscroll(time:$bar) [clock clicks -milli]
222  }
223  } else {
224  if {[clock clicks -milli] > [expr {$_autoscroll(time:$bar) + 100}]} {
225  grid remove $bar
226  set _autoscroll($bar) 0
227  }
228  }
229  # update idletasks
230  }
231  eval $bar set $args
232 }
233 
234 proc _autoscrollMap {frame} {
235  # wm geometry [winfo toplevel $frame] [wm geometry [winfo toplevel $frame]]
236 }
237 
238 
239 # busyCursor, unbusyCursor:
240 # Sets all cursors to watch (indicating busy) or back to their normal
241 # setting again.
242 
243 array set scid_busycursor {}
244 set scid_busycursorState 0
245 
246 proc doBusyCursor {w flag} {
247  global scid_busycursor
248  if {! [winfo exists $w]} { return}
249  if {[winfo class $w] == "Menu"} { return}
250 
251  if {$flag} {
252  if { [ catch { set scid_busycursor($w) [$w cget -cursor]}] } {
253  return
254  }
255  catch {$w configure -cursor watch}
256  } else {
257  catch {$w configure -cursor $scid_busycursor($w)} err
258  }
259  foreach i [winfo children $w] { doBusyCursor $i $flag}
260 }
261 
262 proc busyCursor {w {flag 1}} {
263  global scid_busycursor scid_busycursorState
264  if {$scid_busycursorState == $flag} { return}
265  set scid_busycursorState $flag
266  doBusyCursor $w $flag
267 }
268 
269 proc unbusyCursor {w} {busyCursor $w 0}
270 
271 
272 # addHorizontalRule, addVerticalRule
273 # Add a horizontal/vertical rule frame to a window.
274 # The optional parameters [x/y]padding and sunken allow the spacing and
275 # appearance of the rule to be specified.
276 #
277 set horizRuleCounter 0
278 set vertRuleCounter 0
279 
280 proc addHorizontalRule {w {ypadding 5} {relief sunken} {height 2} } {
281  global horizRuleCounter
282 
283  ttk::separator $w.line$horizRuleCounter -orient horizontal
284  pack $w.line$horizRuleCounter -fill x ;# -pady $ypadding
285 
286  # set f [ ttk::frame $w.line$horizRuleCounter -height $height -borderwidth 2 -relief $relief ]
287  # pack $f -fill x -pady $ypadding
288  incr horizRuleCounter
289 }
290 
291 proc addVerticalRule {w {xpadding 5} {relief sunken}} {
292  global vertRuleCounter
293 
294  ttk::separator $w.line$vertRuleCounter -orient vertical
295  pack $w.line$vertRuleCounter -fill y -side left ;# -padx $xpadding
296 
297  # set f [ ttk::frame $w.line$vertRuleCounter -width 2 -borderwidth 2 -relief $relief ]
298  # pack $f -fill y -padx $xpadding -side left
299  incr vertRuleCounter
300 }
301 
302 # progressWindow:
303 # Creates a window with a label, progress bar, and (if specified),
304 # a cancel button and cancellation command.
305 #
306 proc progressWindow { title text {button ""} {command "progressBarCancel"} } {
307  set w .progressWin
308  if {[winfo exists $w]} { return}
309 
310  set ::progressWin_focus [focus]
311 
312  toplevel $w
313  wm resizable $w 0 0
314  wm title $w $title
315 
316  ttk::frame $w.f
317  ttk::label $w.f.t -text $text
318  autoscrollframe -bars y $w.f.cmsg text $w.f.cmsg.text -width 70 -height 14 -wrap word -font font_Regular
319  canvas $w.f.c -width 400 -height 20 -bg white -relief solid -border 1 -highlightthickness 0
320  $w.f.c create rectangle 0 0 0 0 -fill blue -outline blue -tags bar
321  $w.f.c create text 395 10 -anchor e -font font_Regular -tags time -fill black -text "0:00 / 0:00"
322  ttk::button $w.f.cancel -text $button -command "$command"
323 
324  grid $w.f.t -row 0 -columnspan 2 -padx 3 -pady 5 -sticky news
325  grid $w.f.cmsg -row 1 -columnspan 2 -sticky news
326  grid $w.f.c -row 2 -column 0 -padx 3 -pady 5 -stick w
327  grid $w.f.cancel -row 2 -column 1 -padx 3
328  grid $w.f -sticky news
329  grid rowconfigure $w.f 1 -weight 1
330  grid columnconfigure $w.f 0 -weight 1
331  grid remove $w.f.cmsg
332  if {$button == ""} { grid remove $w.f.cancel}
333 
334  # Set up geometry for middle of screen:
335  set x [expr ([winfo screenwidth $w] - 400) / 2]
336  set y [expr ([winfo screenheight $w] - 40) / 2]
337  wm geometry $w +$x+$y
338  grab $w
339  wm withdraw $w
340 
341  set ::progressWin_time [clock seconds]
342  progressBarSet $w.f.c 401 21
343 
344  set ::progressCanvas(show) "catch {wm deiconify $w}"
345 }
346 
347 proc progressBarSet { canvasname width height } {
348  update idletasks
349  set ::progressCanvas(name) $canvasname
350  set ::progressCanvas(w) $width
351  set ::progressCanvas(h) $height
352  set ::progressCanvas(cancel) 0
353  set ::progressCanvas(init) 1
354  set ::progressCanvas(show) {}
355  after idle { unset ::progressCanvas(init) }
356 }
357 
358 proc progressBarCancel { } {
359  set ::progressCanvas(cancel) 1
360 }
361 
362 
363 proc progressCallBack {done {total 1} {elapsed 0} {estimated 0} {msg ""}} {
364  if {$done == "init"} {
365  if {[info exists ::progressCanvas(init)]} {
366  return $::progressCanvas(init)
367  }
368  # No progress bar
369  return -code break
370  }
371 
372  if {! [winfo exists $::progressCanvas(name)] || $::progressCanvas(cancel)} {
373  #Interrupted
374  return -code break
375  }
376 
377  if {$::progressCanvas(show) != ""} {
378  if {$elapsed == 0 && $estimated < 2 && $msg == ""} { return}
379  eval $::progressCanvas(show)
380  set ::progressCanvas(show) {}
381  }
382 
383  set width $::progressCanvas(w)
384  if {$total > 0} {
385  set width [expr {int(double($width) * double($done) / double($total))}]
386  }
387  $::progressCanvas(name) coords bar 0 0 $width $::progressCanvas(h)
388 
389  set t [format "%d:%02d / %d:%02d" \
390  [expr {$elapsed / 60}] [expr {$elapsed % 60}] \
391  [expr {$estimated / 60}] [expr {$estimated % 60}]]
392  $::progressCanvas(name) itemconfigure time -text $t
393 
394  if {$msg != ""} {
395  catch {
396  set widget "$::progressCanvas(name)msg"
397  grid $widget
398  append widget ".text"
399  $widget insert end "$msg\n"
400  }
401  }
402 
403  update
404 }
405 
406 proc changeProgressWindow {newtext} {
407  set w .progressWin
408  if {[winfo exists $w]} {
409  $w.f.t configure -text $newtext
410  update idletasks
411  }
412 }
413 
414 proc updateProgressWindow {done total} {
415  set w .progressWin
416  if {! [winfo exists $w]} { return}
417  set elapsed [expr {[clock seconds] - $::progressWin_time}]
418  set estimated $elapsed
419  if {$done != 0} {
420  set estimated [expr {int(double($elapsed) * double($total) / double($done))}]
421  }
422  ::progressCallBack "$done" "$total" "$elapsed" "$estimated"
423 }
424 
425 proc closeProgressWindow {{force false}} {
426  set w .progressWin
427  if {! [winfo exists $w]} { return}
428 
429  if {!$force && [$w.f.cmsg.text index end] != "2.0" } {
430  $w.f.cancel configure -text "$::tr(Close)"
431  $w.f.cancel configure -command "closeProgressWindow true"
432  grid forget $w.f.c
433  grid $w.f.cancel
434  $w.f.cmsg.text configure -state disabled
435  return
436  }
437  grab release $w
438  destroy $w
439  update idletasks
440  catch {focus $::progressWin_focus}
441 }
442 
443 proc CreateSelectDBWidget {{w} {varname} {ref_base ""} {readOnly 1}} {
444  set listbases {}
445  if {$ref_base == ""} { set ref_base [sc_base current]}
446  set selected 0
447  foreach i [sc_base list] {
448  if {$readOnly || ![sc_base isReadOnly $i]} {
449  set fname [file tail [sc_base filename $i]]
450  if {$i == $ref_base} { set selected [llength $listbases]}
451  lappend listbases "$i: $fname"
452  }
453  }
454  ttk::combobox $w.lb -textvariable $varname -values $listbases
455  $w.lb current $selected
456  grid $w.lb -sticky news
457  grid columnconfigure $w 0 -weight 1
458 }
459 
460 ################################################################################
461 # clock widget
462 ################################################################################
463 namespace eval gameclock {
464  array set data {}
465  ################################################################################
466  proc new { parent n { size 100 } {showfall 0} } {
467  global ::gameclock::data
468  set data(showfallen$n) $showfall
469  set data(id$n) $parent.clock$n
470  canvas $data(id$n) -height $size -width $size
471  pack $data(id$n) -side top -anchor center
472  for {set i 1} {$i<13} {incr i} {
473  set a [expr {$i/6.*acos(-1)}]
474  set x [expr { ($size/2 + (($size-15)/2)*sin($a) ) }]
475  set y [expr { ($size/2 - (($size-15)/2)*cos($a) ) }]
476  $data(id$n) create text $x $y -text $i -tag clock$n
477  }
478  set data(fg$n) "black"
479  set data(running$n) 0
480  set data(digital$n) 1
483  bind $data(id$n) <Button-1> "::gameclock::toggleClock $n"
484  }
485  ################################################################################
486  proc draw { n } {
487  global ::gameclock::data
488 
489  #TODO: Hack. For the moment we assume that:
490  # -clock 1 is the white clock on the main board
491  # -clock 2 is the black clock on the main board
492  set sec $data(counter$n)
493  set h [format "%d" [expr abs($sec) / 60 / 60]]
494  set m [format "%02d" [expr (abs($sec) / 60) % 60]]
495  set s [format "%02d" [expr abs($sec) % 60]]
496  if {$n == 1} { set ::gamePlayers(clockW) "$h:$m:$s"}
497  if {$n == 2} { set ::gamePlayers(clockB) "$h:$m:$s"}
498 
499  if {! [winfo exists $data(id$n)]} { return}
500  $data(id$n) delete aig$n
501 
502  set w [$data(id$n) cget -width]
503  set h [$data(id$n) cget -height]
504  set cx [ expr $w / 2]
505  set cy [ expr $h / 2]
506  if {$w < $h} {
507  set size [ expr $w - 15]
508  } else {
509  set size [ expr $h - 15]
510  }
511 
512  if { $sec > 0 && $data(showfallen$n) } {
513  set color "red"
514  } else {
515  set color $::gameclock::data(fg$n)
516  }
517 
518  if {$color == "white"} {set fg "black"} else {set fg "white"}
519 
520  foreach divisor {30 1800 21600} length "[expr $size/2 * 0.8] [expr $size/2 * 0.7] [expr $size/2 * 0.4]" \
521  width {1 2 3} {
522  set angle [expr {$sec * acos(-1) / $divisor}]
523  set x [expr {$cx + $length * sin($angle)}]
524  set y [expr {$cy - $length * cos($angle)}]
525  $data(id$n) create line $cx $cy $x $y -width $width -tags aig$n -fill $color
526  }
527  # draw a digital clock
528  if {$data(digital$n)} {
529  set m [format "%02d" [expr abs($sec) / 60]]
530  set s [format "%02d" [expr abs($sec) % 60]]
531  $data(id$n) create text $cx [expr $cy + $size/4] -text "$m:$s" -anchor center -fill $color -tag aig$n
532  }
533  }
534  ################################################################################
535  proc every {ms body n} {
536  incr ::gameclock::data(counter$n)
537  eval $body
538  if {[winfo exists $::gameclock::data(id$n)]} {
539  after $ms [info level 0]
540  }
541  }
542  ################################################################################
543  proc getSec { n } {
544  return [expr 0 - $::gameclock::data(counter$n)]
545  }
546  ################################################################################
547  proc setSec { n value } {
548  set ::gameclock::data(counter$n) $value
550  }
551  ################################################################################
552  proc add { n value } {
553  set ::gameclock::data(counter$n) [ expr $::gameclock::data(counter$n) - $value]
555  }
556 
557  ################################################################################
558  proc reset { n } {
560  set ::gameclock::data(counter$n) 0
561  }
562  ################################################################################
563  proc start { n } {
564  if {$::gameclock::data(running$n)} { return}
565  set ::gameclock::data(running$n) 1
566  ::gameclock::every 1000 "draw $n" $n
567  }
568  ################################################################################
569  proc stop { n } {
570  if {! $::gameclock::data(running$n)} { return}
571  set ::gameclock::data(running$n) 0
572  after cancel "::gameclock::every 1000 \{draw $n\} $n"
573  }
574  ################################################################################
575  proc toggleClock { n } {
576  if { $::gameclock::data(running$n) } {
577  stop $n
578  } else {
579  start $n
580  }
581  }
582  ################################################################################
583  proc setColor { n color } {
584  if {$color == "white"} {
585  set fg "black"
586  set bg "white"
587  } else {
588  set fg "white"
589  set bg "black"
590  }
591  set ::gameclock::data(fg$n) $fg
592  $::gameclock::data(id$n) configure -background $bg
593  $::gameclock::data(id$n) itemconfigure clock$n -fill $fg
594  $::gameclock::data(id$n) itemconfigure aig$n -fill $fg
595  }
596  ################################################################################
597  proc isRunning { } {
598  global ::gameclock::data
599  catch {
600  if {$data(running1) || $data(running2)} { return 1}
601  }
602  return 0
603  }
604 }
605 ################################################################################
606 # html generation
607 ################################################################################
608 namespace eval html {
609  set data {}
610  set idx 0
611 
612  ################################################################################
613  proc exportCurrentFilter {} {
614  # Check that we have some games to export:
615  if {[sc_filter count] == 0} {
616  tk_messageBox -title "Scid: Filter empty" -type ok -icon info \
617  -message "The filter contains no games."
618  return
619  }
620  set ftype {
621  { "HTML files" {".html" ".htm"} }
622  { "All files" {"*"} }
623  }
624  set idir $::initialDir(html)
625  set fName [tk_getSaveFile -initialdir $idir -filetypes $ftype -defaultextension ".html" -title "Create an HTML file"]
626  if {$fName == ""} { return}
627  if {[file extension $fName] != ".html" } {
628  append fName ".html"
629  }
630  set prefix [file rootname [file tail $fName]]
631  set dirtarget [file dirname $fName]
632  set sourcedir [file join $::scidExeDir html]
633  catch {file copy -force [file join $sourcedir bitmaps] $dirtarget}
634  catch {file copy -force [file join $sourcedir scid.js] $dirtarget}
635  catch {file copy -force [file join $sourcedir scid.css] $dirtarget}
636  # writeIndex "[file join $dirtarget $prefix].html" $prefix
637  progressWindow "Scid" "Exporting games..."
638  set savedGameNum [sc_game number]
639  set gn [sc_filter first]
640  set players {}
641  set ::html::cancelHTML 0
642  set total [sc_filter count]
643 
644  # build the list of matches
645  set idx 1
646  while {$gn != 0 && ! $::html::cancelHTML} {
647  updateProgressWindow $idx $total
648  sc_game load $gn
649  set pl "[sc_game tags get White] - [sc_game tags get Black]"
650  lappend players $pl
651  set gn [sc_filter next]
652  incr idx
653  }
654 
655  set idx 1
656  set gn [sc_filter first]
657  while {$gn != 0 && ! $::html::cancelHTML} {
658  updateProgressWindow $idx $total
659  sc_game load $gn
660  fillData
661  set pl "[sc_game tags get White] - [sc_game tags get Black]"
662  toHtml $::html::data $idx $dirtarget $prefix $players $pl [sc_game tags get "Event"] [sc_game tags get "ECO"] [sc_game info result] [sc_game tags get "Date"]
663  set gn [sc_filter next]
664  incr idx
665  }
666 
668  exportPGN "[file join $dirtarget $prefix].pgn" "filter"
669  sc_game load $savedGameNum
670  }
671  ################################################################################
672  proc sc_progressBar {} {
673  set ::html::cancelHTML 1
674  }
675  ################################################################################
676  proc exportCurrentGame {} {
677 
678  set ftype {
679  { "HTML files" {".html" ".htm"} }
680  { "All files" {"*"} }
681  }
682  set idir $::initialDir(html)
683  set fName [tk_getSaveFile -initialdir $idir -filetypes $ftype -defaultextension ".html" -title "Create an HTML file"]
684  if {[file extension $fName] != ".html" && [file extension $fName] != ".htm" } {
685  append fName ".html"
686  }
687  if {$fName == ""} { return}
688  set prefix [file rootname [file tail $fName]]
689  set dirtarget [file dirname $fName]
690  set sourcedir [file join $::scidExeDir html]
691  catch { file copy -force [file join $sourcedir bitmaps] $dirtarget}
692  catch { file copy -force [file join $sourcedir scid.js] $dirtarget}
693  catch { file copy -force [file join $sourcedir scid.css] $dirtarget}
694 
695  fillData
696  set players [list "[sc_game tags get White] - [sc_game tags get Black]"]
697  toHtml $::html::data -1 $dirtarget $prefix $players [lindex $players 0] \
698  [sc_game tags get "Event"] [sc_game tags get "ECO"] \
699  [sc_game info result] [sc_game tags get "Date"]
700  exportPGN "[file join $dirtarget $prefix].pgn" "current"
701  }
702  ################################################################################
703  # Dictionary mapping from special characters to their entities. (from tcllib)
704  variable entities {
705  \xa0 &nbsp; \xa1 &iexcl; \xa2 &cent; \xa3 &pound; \xa4 &curren;
706  \xa5 &yen; \xa6 &brvbar; \xa7 &sect; \xa8 &uml; \xa9 &copy;
707  \xaa &ordf; \xab &laquo; \xac &not; \xad &shy; \xae &reg;
708  \xaf &macr; \xb0 &deg; \xb1 &plusmn; \xb2 &sup2; \xb3 &sup3;
709  \xb4 &acute; \xb5 &micro; \xb6 &para; \xb7 &middot; \xb8 &cedil;
710  \xb9 &sup1; \xba &ordm; \xbb &raquo; \xbc &frac14; \xbd &frac12;
711  \xbe &frac34; \xbf &iquest; \xc0 &Agrave; \xc1 &Aacute; \xc2 &Acirc;
712  \xc3 &Atilde; \xc4 &Auml; \xc5 &Aring; \xc6 &AElig; \xc7 &Ccedil;
713  \xc8 &Egrave; \xc9 &Eacute; \xca &Ecirc; \xcb &Euml; \xcc &Igrave;
714  \xcd &Iacute; \xce &Icirc; \xcf &Iuml; \xd0 &ETH; \xd1 &Ntilde;
715  \xd2 &Ograve; \xd3 &Oacute; \xd4 &Ocirc; \xd5 &Otilde; \xd6 &Ouml;
716  \xd7 &times; \xd8 &Oslash; \xd9 &Ugrave; \xda &Uacute; \xdb &Ucirc;
717  \xdc &Uuml; \xdd &Yacute; \xde &THORN; \xdf &szlig; \xe0 &agrave;
718  \xe1 &aacute; \xe2 &acirc; \xe3 &atilde; \xe4 &auml; \xe5 &aring;
719  \xe6 &aelig; \xe7 &ccedil; \xe8 &egrave; \xe9 &eacute; \xea &ecirc;
720  \xeb &euml; \xec &igrave; \xed &iacute; \xee &icirc; \xef &iuml;
721  \xf0 &eth; \xf1 &ntilde; \xf2 &ograve; \xf3 &oacute; \xf4 &ocirc;
722  \xf5 &otilde; \xf6 &ouml; \xf7 &divide; \xf8 &oslash; \xf9 &ugrave;
723  \xfa &uacute; \xfb &ucirc; \xfc &uuml; \xfd &yacute; \xfe &thorn;
724  \xff &yuml; \u192 &fnof; \u391 &Alpha; \u392 &Beta; \u393 &Gamma;
725  \u394 &Delta; \u395 &Epsilon; \u396 &Zeta; \u397 &Eta; \u398 &Theta;
726  \u399 &Iota; \u39A &Kappa; \u39B &Lambda; \u39C &Mu; \u39D &Nu;
727  \u39E &Xi; \u39F &Omicron; \u3A0 &Pi; \u3A1 &Rho; \u3A3 &Sigma;
728  \u3A4 &Tau; \u3A5 &Upsilon; \u3A6 &Phi; \u3A7 &Chi; \u3A8 &Psi;
729  \u3A9 &Omega; \u3B1 &alpha; \u3B2 &beta; \u3B3 &gamma; \u3B4 &delta;
730  \u3B5 &epsilon; \u3B6 &zeta; \u3B7 &eta; \u3B8 &theta; \u3B9 &iota;
731  \u3BA &kappa; \u3BB &lambda; \u3BC &mu; \u3BD &nu; \u3BE &xi;
732  \u3BF &omicron; \u3C0 &pi; \u3C1 &rho; \u3C2 &sigmaf; \u3C3 &sigma;
733  \u3C4 &tau; \u3C5 &upsilon; \u3C6 &phi; \u3C7 &chi; \u3C8 &psi;
734  \u3C9 &omega; \u3D1 &thetasym; \u3D2 &upsih; \u3D6 &piv;
735  \u2022 &bull; \u2026 &hellip; \u2032 &prime; \u2033 &Prime;
736  \u203E &oline; \u2044 &frasl; \u2118 &weierp; \u2111 &image;
737  \u211C &real; \u2122 &trade; \u2135 &alefsym; \u2190 &larr;
738  \u2191 &uarr; \u2192 &rarr; \u2193 &darr; \u2194 &harr; \u21B5 &crarr;
739  \u21D0 &lArr; \u21D1 &uArr; \u21D2 &rArr; \u21D3 &dArr; \u21D4 &hArr;
740  \u2200 &forall; \u2202 &part; \u2203 &exist; \u2205 &empty;
741  \u2207 &nabla; \u2208 &isin; \u2209 &notin; \u220B &ni; \u220F &prod;
742  \u2211 &sum; \u2212 &minus; \u2217 &lowast; \u221A &radic;
743  \u221D &prop; \u221E &infin; \u2220 &ang; \u2227 &and; \u2228 &or;
744  \u2229 &cap; \u222A &cup; \u222B &int; \u2234 &there4; \u223C &sim;
745  \u2245 &cong; \u2248 &asymp; \u2260 &ne; \u2261 &equiv; \u2264 &le;
746  \u2265 &ge; \u2282 &sub; \u2283 &sup; \u2284 &nsub; \u2286 &sube;
747  \u2287 &supe; \u2295 &oplus; \u2297 &otimes; \u22A5 &perp;
748  \u22C5 &sdot; \u2308 &lceil; \u2309 &rceil; \u230A &lfloor;
749  \u230B &rfloor; \u2329 &lang; \u232A &rang; \u25CA &loz;
750  \u2660 &spades; \u2663 &clubs; \u2665 &hearts; \u2666 &diams;
751  \x22 &quot; \x26 &amp; \x3C &lt; \x3E &gt; \u152 &OElig;
752  \u153 &oelig; \u160 &Scaron; \u161 &scaron; \u178 &Yuml;
753  \u2C6 &circ; \u2DC &tilde; \u2002 &ensp; \u2003 &emsp; \u2009 &thinsp;
754  \u200C &zwnj; \u200D &zwj; \u200E &lrm; \u200F &rlm; \u2013 &ndash;
755  \u2014 &mdash; \u2018 &lsquo; \u2019 &rsquo; \u201A &sbquo;
756  \u201C &ldquo; \u201D &rdquo; \u201E &bdquo; \u2020 &dagger;
757  \u2021 &Dagger; \u2030 &permil; \u2039 &lsaquo; \u203A &rsaquo;
758  \u20AC &euro;
759  }
760  proc html_entities {s} {
761  variable entities
762  return [string map $entities $s]
763  }
764  ################################################################################
765  proc toHtml { dt game dirtarget prefix {players ""} {this_players ""} {event ""} {eco "ECO"} {result "*"} {date ""} } {
766 
767  if { $game != -1 } {
768  set f [open "[file join $dirtarget $prefix]_${game}.html" w]
769  } else {
770  set f [open "[file join $dirtarget $prefix].html" w]
771  }
772  # header
773  puts $f "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
774  puts $f "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">"
775  puts $f "<head>"
776  puts $f "<meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />"
777  puts $f "<link rel=\"stylesheet\" type=\"text/css\" href=\"scid.css\" />"
778  puts $f "<script src=\"scid.js\" type=\"text/javascript\"></script>"
779  puts $f "<script type=\"text/javascript\">"
780  puts $f "// <!\[CDATA\["
781  puts $f "movesArray = new Array("
782  for {set i 0} {$i<[llength $dt]} {incr i} {
783  array set elt [lindex $dt $i]
784  puts -nonewline $f "\"$elt(fen) $elt(prev) $elt(next)\""
785  if {$i < [expr [llength $dt] -1]} { puts $f ","}
786  }
787  puts $f ");"
788  puts $f "var current = 0;"
789  puts $f "var prefix = \"$prefix\";"
790  puts $f "// \]\]>"
791  puts $f "</script>"
792  puts $f "<title>Scid</title>"
793  puts $f "<meta content=\"Scid\" name=\"author\" />"
794  puts $f "</head>"
795  puts $f "<body onload=\"doinit()\" onkeydown=\"handlekey(event)\">"
796  puts $f "<div id=\"framecontent\">"
797  puts $f "<div class=\"innertube\">"
798  # diagram
799  puts $f "<div id=\"diagram\"><!-- diagram goes here --></div>"
800  # navigation
801  puts $f "<div id=\"nav\" style=\"text-align: center\"><!-- navigation goes here -->"
802  puts $f "<form action=\"#\">"
803  puts $f "<p>"
804  puts $f "<input type='button' value=' &darr;&uarr; ' onclick='rotate()' /> <input type='button' value=' |&lt; ' onclick='jump(0)' /> <input type='button' value=' &lt; ' onclick='moveForward(0)' /> <input type='button' value=' &gt; ' onclick='moveForward(1)' /> <input type='button' value=' &gt;| ' onclick='jump(1)' /> "
805  puts $f "</p><p>"
806  # other games navigation
807  puts $f "<select name=\"gameselect\" id=\"gameselect\" size=\"1\" onchange=\"gotogame()\">"
808  set i 1
809  foreach l $players {
810  if { $game == $i } {
811  puts $f "<option selected=\"selected\">$i. [html_entities $l]</option>"
812  } else {
813  puts $f "<option>$i. [html_entities $l]</option>"
814  }
815  incr i
816  }
817  puts $f "</select>"
818  puts $f "</p><p>"
819  puts $f "<input type=\"button\" value=\"&lt;--\" onclick=\"gotoprevgame()\" /> &nbsp; <input type=\"button\" value=\"--&gt;\" onclick=\"gotonextgame()\" />"
820  puts $f "</p><p>"
821  puts $f "<a href=\"${prefix}.pgn\">${prefix}.pgn</a>"
822  puts $f "</p>"
823  puts $f "</form>"
824  puts $f "</div>"
825  puts $f "</div>"
826  puts $f "</div>"
827  puts $f "<div id=\"maincontent\">"
828  puts $f "<div class=\"innertube\">"
829  puts $f "<div id=\"moves\"><!-- moves go here -->"
830  # game header
831  puts $f "<span class=\"hPlayers\"> [html_entities $this_players]</span>"
832  puts $f "<span class=\"hEvent\"><br /> [html_entities $event]</span>"
833  puts $f "<span class=\"hEvent\"><br />\[$date\]</span>"
834  puts $f "<span class=\"hAnnot\"><br />\[$eco\]</span>"
835  puts $f "<p>"
836  # link moves
837  set prevdepth 0
838  set prevvarnumber 0
839  for {set i 0} {$i<[llength $dt]} {incr i} {
840  array set elt [lindex $dt $i]
841  if {$elt(depth) == 0} {
842  set class "V0"
843  } elseif {$elt(depth) == 1} {
844  set class "V1"
845  } else {
846  set class "V2"
847  }
848  if { $prevdepth == $elt(depth) && $prevvarnumber != $elt(var) } {
849  puts $f "<span class=\"VC\">\]</span></div>"
850  puts $f "<div class=\"var\"><span class=\"VC\">\[</span>"
851  } else {
852  while { $prevdepth > $elt(depth) } {
853  puts $f "<span class=\"VC\">\]</span></div>"
854  set prevdepth [expr $prevdepth - 1]
855  }
856  while { $prevdepth < $elt(depth) } {
857  puts $f "<div class=\"var\"><span class=\"VC\">\[</span>"
858  set prevdepth [expr $prevdepth + 1]
859  }
860  }
861  set prevvarnumber $elt(var)
862  # id = "mv1" not "id=1" now
863  set nag [html_entities $elt(nag)]
864  set comment [html_entities $elt(comment)]
865  puts $f "<a href=\"javascript:gotoMove($elt(idx))\" id=\"mv$elt(idx)\" class=\"$class\">$elt(move)$nag</a>"
866  if {$elt(diag)} {
867  insertMiniDiag $elt(fen) $f
868  }
869  if {$comment != ""} {
870  puts $f "<span class=\"VC\">$comment</span>"
871  }
872  }
873  while { $prevdepth > 0 } {
874  puts $f "<span class=\"VC\">\]</span></div>"
875  set prevdepth [expr $prevdepth - 1]
876  }
877 
878  puts $f "<br /><span class=\"VH\">$result</span>"
879  puts $f "<p>"
880  puts $f "<a href=\"http://scid.sourceforge.net/\" style=\"font-size: 0.8em\">Created with Scid</a>"
881  puts $f "</div>"
882  puts $f "</div>"
883  puts $f "</div>"
884  puts $f "</body>"
885  puts $f "</html>"
886  close $f
887  }
888  ################################################################################
889  proc colorSq {sq} {
890  if { [expr $sq % 2] == 1 && [expr int($sq / 8) %2] == 0 || [expr $sq % 2] == 0 && [expr int($sq / 8) %2] == 1 } {
891  return "bs"
892  } else {
893  return "ws"
894  }
895  }
896  ################################################################################
897  proc piece2gif {piece} {
898  if {$piece == "K"} { return "wk"}
899  if {$piece == "k"} { return "bk"}
900  if {$piece == "Q"} { return "wq"}
901  if {$piece == "q"} { return "bq"}
902  if {$piece == "R"} { return "wr"}
903  if {$piece == "r"} { return "br"}
904  if {$piece == "B"} { return "wb"}
905  if {$piece == "b"} { return "bb"}
906  if {$piece == "N"} { return "wn"}
907  if {$piece == "n"} { return "bn"}
908  if {$piece == "P"} { return "wp"}
909  if {$piece == "p"} { return "bp"}
910  if {$piece == " "} { return "sq"}
911  }
912  ################################################################################
913  proc insertMiniDiag {fen f} {
914 
915  set square 0
916  set space " "
917  puts $f "<table Border=0 CellSpacing=0 CellPadding=0><tr>"
918 
919  for {set i 0} {$i < [string length $fen]} {incr i} {
920  set l [string range $fen $i $i]
921  set res [scan $l "%d" c]
922  if {$res == 1} {
923  if { $c >= 1 && $c <= 8 } {
924  for { set j 0} {$j < $c} {incr j} {
925  puts $f "<td class=\"[colorSq $square]\"><img border=0 align=\"left\" src=\"bitmaps/mini/[piece2gif $space].gif\"></td>"
926  incr square
927  }
928  }
929  } elseif {$l == "/"} {
930  puts $f "</tr><tr>"
931  } else {
932  puts $f "<td class=\"[colorSq $square]\"><img border=0 align=\"left\" src=\"bitmaps/mini/[piece2gif $l].gif\"></td>"
933  incr square
934  }
935  }
936 
937  puts $f "</tr></table>"
938  }
939 
940  ################################################################################
941  # fill data with { idx FEN prev next move nag comment depth }
942  proc fillData {} {
943  set ::html::data {}
944  set ::html::idx -1
945  sc_move start
946  parseGame
947  }
948 
949  ################################################################################
950  proc parseGame { {prev -2} } {
951  global ::html::data ::html::idx
952 
953  set already_written 0
954 
955  set dots 0
956 
957  while {1} {
958  if { ! $already_written } {
959  recordElt $dots $prev
960  set dots 0
961  set prev -2
962  } else {
963  set dots 1
964  }
965  set already_written 0
966 
967  # handle variants
968  if {[sc_var count]>0} {
969  # First write the move in the current line for which variations exist
970  #
971  if { ![sc_pos isAt vend]} {
972  sc_move forward
973  recordElt $dots $prev
974  sc_move back
975  set lastIdx $idx
976  set already_written 1
977  }
978  for {set v 0} {$v<[sc_var count]} {incr v} {
979  sc_var enter $v
980  # in order to get the comment before first move
981  sc_move back
982  parseGame -1
983  sc_var exit
984  }
985  #update the "next" token
986  array set elt [lindex $data $lastIdx]
987  set elt(next) [expr $idx + 1]
988  lset data $lastIdx [array get elt]
989  #update the "previous" token
990  set prev $lastIdx
991  }
992 
993  if {[sc_pos isAt vend]} { break}
994  sc_move forward
995  }
996  }
997  ################################################################################
998  proc recordElt { dots {prev -2} } {
999  global ::html::data ::html::idx
1000 
1001  array set elt {}
1002 
1003  incr idx
1004  set elt(idx) $idx
1005  set elt(fen) [lindex [split [sc_pos fen]] 0]
1006  if {$prev != -2} {
1007  set elt(prev) $prev
1008  } else {
1009  set elt(prev) [expr $idx-1]
1010  }
1011 
1012  set nag [sc_pos getNags]
1013  if {$nag == "0"} { set nag ""}
1014  if {[string match "*D *" $nag] || [string match "*# *" $nag]} {
1015  set elt(diag) 1
1016  } else {
1017  set elt(diag) 0
1018  }
1019  set nag [regsub -all "D " $nag ""]
1020  set nag [regsub -all "# " $nag ""]
1021  set elt(nag) $nag
1022  set comment [sc_pos getComment]
1023  set comment [regsub -all "\[\x5B\]%draw (.)+\[\x5D\]" $comment ""]
1024  set elt(comment) $comment
1025  set elt(depth) [sc_var level]
1026  set elt(var) [sc_var number]
1027  if {![sc_pos isAt vend]} {
1028  set elt(next) [expr $idx +1]
1029  } else {
1030  set elt(next) -1
1031  }
1032 
1033  set m [sc_game info previousMove]
1034  set mn [sc_pos moveNumber]
1035 
1036  set elt(move) ""
1037  if {[sc_pos side] == "black" && $m != ""} {
1038  set elt(move) "$mn.$m"
1039  } else {
1040 
1041  if {! [sc_pos isAt vstart] } {
1042  sc_move back
1043  set pnag [sc_pos getNags]
1044  if {$pnag == "0"} { set pnag ""}
1045  if {[string match "*D *" $pnag] || [string match "*# *" $pnag]} {
1046  set pdiag 1
1047  } else {
1048  set pdiag 0
1049  }
1050  if { [sc_pos isAt vstart] || [sc_pos getComment] != "" || $pdiag > 0 } {
1051  set dots 1
1052  }
1053  sc_move forward
1054  }
1055 
1056  if {$dots && $m != ""} {
1057  set elt(move) "[expr $mn -1]. ... $m"
1058  } else {
1059  set elt(move) $m
1060  }
1061 
1062  }
1063 
1064  lappend ::html::data [array get elt]
1065 
1066  }
1067 
1068  ################################################################################
1069  # proc writeIndex {fn prefix} {
1070  # set f [open $fn w]
1071  # puts $f "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">"
1072  # puts $f "<html>"
1073  # puts $f "<head>"
1074  # puts $f "<meta content=\"text/html; charset=ISO-8859-1\" http-equiv=\"content-type\">"
1075  # puts $f "<title>Scid</title>"
1076  # puts $f "<meta content=\"Scid\" name=\"author\">"
1077  # puts $f "</head>"
1078  # puts $f "<frameset BORDER=\"0\" FRAMEBORDER=\"0\" FRAMESPACING=\"0\" COLS=\"380,*\">"
1079  # puts $f "<frameset BORDER=\"0\" FRAMEBORDER=\"0\" FRAMESPACING=\"0\" ROWS=\"380,*\">"
1080  # puts $f "<frame NAME=\"diagram\" SCROLLING=\"Auto\">"
1081  # puts $f "<frame NAME=\"nav\" SRC=\"${prefix}_nav.html\" SCROLLING=\"Auto\">"
1082  # puts $f "</frameset>"
1083  # puts $f "<frame NAME=\"moves\" SRC=\"${prefix}_1.html\" SCROLLING=\"Auto\">"
1084  # puts $f "</frameset>"
1085  # puts $f "</html>"
1086  # close $f
1087  # }
1088  ################################################################################
1089  proc exportPGN { fName selection } {
1090  if {$selection == "filter"} {
1091  progressWindow "Scid" "Exporting games..." $::tr(Cancel)
1092  }
1093  sc_base export $selection "PGN" $fName -append 0 -starttext "" -endtext "" -comments 1 -variations 1 \
1094  -space 1 -symbols 1 -indentC 0 -indentV 0 -column 0 -noMarkCodes 1 -convertNullMoves 1
1095  if {$selection == "filter"} {
1097  }
1098  }
1099 
1100 }
1101 ################################################################################
1102 #
1103 ################################################################################
1104 
1105 # end of misc.tcl