Scid  4.7.0
•All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros
pgn.tcl
Go to the documentation of this file.
1 ############################################################
2 ### PGN window
3 
4 namespace eval pgn {
5  ################################################################################
6  #
7  ################################################################################
8  proc ChooseColor {type name} {
9  global pgnColor
10  set x [tk_chooseColor -initialcolor $pgnColor($type) -title "PGN $name color"]
11  if {$x != ""} { set pgnColor($type) $x; ::pgn::ResetColors}
12  }
13  ################################################################################
14  #
15  ################################################################################
16  proc ConfigMenus {{lang ""}} {
17  if {! [winfo exists .pgnWin]} { return}
18  if {$lang == ""} { set lang $::language}
19  set m .pgnWin.menu
20  foreach idx {0 1 2 3} tag {File Opt Color Help} {
21  configMenuText $m $idx Pgn$tag $lang
22  }
23  foreach idx {0 1 3} tag {Copy Print Close} {
24  configMenuText $m.file $idx PgnFile$tag $lang
25  }
26  foreach idx {0 1 2 3 4 5 6 7 8} tag {
27  Color Short Symbols IndentC IndentV Space Column StripMarks BoldMainLine
28  } {
29  configMenuText $m.opt $idx PgnOpt$tag $lang
30  }
31  foreach idx {9} tag {GInfoPhotos} {
32  configMenuText $m.opt $idx $tag $lang
33  }
34  foreach idx {0 1 2 3 4 5} tag {Header Anno Comments Vars Background Current} {
35  configMenuText $m.color $idx PgnColor$tag $lang
36  }
37  foreach idx {0 1} tag {Pgn Index} {
38  configMenuText $m.helpmenu $idx PgnHelp$tag $lang
39  }
40  }
41 
42  proc PgnClipboardCopy {} {
43  setLanguageTemp E
44  set pgnStr [sc_game pgn -width 75 -indentComments $::pgn::indentComments \
45  -indentVariations $::pgn::indentVars -space $::pgn::moveNumberSpaces]
46  setLanguageTemp $::language
47 
48  set wt .tempFEN
49 
50  if {! [winfo exists $wt]} { text $wt}
51  $wt delete 1.0 end
52  $wt insert end $pgnStr sel
53  clipboard clear
54  clipboard append $pgnStr
55  selection own $wt
56  selection get
57  }
58 
59  ################################################################################
60  #
61  ################################################################################
62  proc OpenClose {} {
63  global pgnWin pgnHeight pgnWidth pgnColor
64 
65  set w .pgnWin
66  if {! [::win::createWindow $w [tr PgnWindowTitle]]} {
67  ::win::closeWindow $w
68  return
69  }
70 
71  menu $w.menu
72  ::setMenu $w $w.menu
73 
74  $w.menu add cascade -label PgnFile -menu $w.menu.file -underline 0
75  $w.menu add cascade -label PgnOpt -menu $w.menu.opt -underline 0
76  $w.menu add cascade -label PgnColor -menu $w.menu.color -underline 0
77  $w.menu add cascade -label PgnHelp -menu $w.menu.helpmenu -underline 0
78  foreach i {file opt color helpmenu} {
79  menu $w.menu.$i -tearoff 0
80  }
81 
82  $w.menu.file add command -label PgnFileCopy -command {::pgn::PgnClipboardCopy }
83 
84  $w.menu.file add command -label PgnFilePrint -command {
85  set ftype {
86  { "PGN files" {".pgn"} }
87  { "Text files" {".txt"} }
88  { "All files" {"*"} }
89  }
90  set fname [tk_getSaveFile -initialdir [pwd] -filetypes $ftype -title "Save PGN file"]
91  if {$fname != ""} {
92  if {[file extension $fname] != ".txt" && [file extension $fname] != ".pgn" } {
93  append fname ".pgn"
94  }
95  if {[catch {set tempfile [open $fname w]}]} {
96  tk_messageBox -title "Scid: Error saving file" -type ok -icon warning \
97  -message "Unable to save the file: $fname\n\n"
98  } else {
99  puts $tempfile \
100  [sc_game pgn -width 75 -symbols $::pgn::symbolicNags \
101  -indentVar $::pgn::indentVars -indentCom $::pgn::indentComments \
102  -space $::pgn::moveNumberSpaces -format plain -column $::pgn::columnFormat \
103  -markCodes $::pgn::stripMarks]
104  close $tempfile
105  }
106  }
107  }
108  $w.menu.file add separator
109  $w.menu.file add command -label PgnFileClose \
110  -command "::win::closeWindow $w"
111 
112  $w.menu.opt add checkbutton -label PgnOptColor \
113  -variable ::pgn::showColor -command {updateBoard -pgn}
114  $w.menu.opt add checkbutton -label PgnOptShort \
115  -variable ::pgn::shortHeader -command {updateBoard -pgn}
116  $w.menu.opt add checkbutton -label PgnOptSymbols \
117  -variable ::pgn::symbolicNags -command {updateBoard -pgn}
118  $w.menu.opt add checkbutton -label PgnOptIndentC \
119  -variable ::pgn::indentComments -command {updateBoard -pgn}
120  $w.menu.opt add checkbutton -label PgnOptIndentV \
121  -variable ::pgn::indentVars -command {updateBoard -pgn}
122  $w.menu.opt add checkbutton -label PgnOptSpace \
123  -variable ::pgn::moveNumberSpaces -command {updateBoard -pgn}
124  $w.menu.opt add checkbutton -label PgnOptColumn \
125  -variable ::pgn::columnFormat -command {updateBoard -pgn}
126  $w.menu.opt add checkbutton -label PgnOptStripMarks \
127  -variable ::pgn::stripMarks -command {updateBoard -pgn}
128  $w.menu.opt add checkbutton -label PgnOptBoldMainLine \
129  -variable ::pgn::boldMainLine -command {updateBoard -pgn}
130  $w.menu.opt add checkbutton -label GInfoPhotos \
131  -variable ::pgn::showPhoto -command {::pgn::Refresh 1}
132 
133  $w.menu.color add command -label PgnColorHeader \
134  -command {::pgn::ChooseColor Header "header text"}
135  $w.menu.color add command -label PgnColorAnno \
136  -command {::pgn::ChooseColor Nag annotation}
137  $w.menu.color add command -label PgnColorComments \
138  -command {::pgn::ChooseColor Comment comment}
139  $w.menu.color add command -label PgnColorVars \
140  -command {::pgn::ChooseColor Var variation}
141  $w.menu.color add command -label PgnColorBackground \
142  -command {::pgn::ChooseColor Background background}
143  $w.menu.color add command -label PgnColorCurrent -command {::pgn::ChooseColor Current current}
144 
145  $w.menu.helpmenu add command -label PgnHelpPgn -command {helpWindow PGN}
146  $w.menu.helpmenu add command -label PgnHelpIndex -command {helpWindow Index}
147 
148  ::pgn::ConfigMenus
149 
150  frame $w.frame
151  text $w.text -wrap word \
152  -background $pgnColor(Background) -cursor crosshair \
153  -tabs {1c right 2c 4c}
154  if { $::pgn::boldMainLine } {
155  $w.text configure -font font_Bold
156  }
157 
158  autoscrollframe -bars y $w.frame "" $w.text
159  grid $w.frame -sticky news
160  grid rowconfigure $w 0 -weight 1
161  grid columnconfigure $w 0 -weight 1
162 
163  set pgnWin 1
164  bind $w <Destroy> { set pgnWin 0 }
165 
166  # Take input focus even if -state is disabled
167  bind $w.text <ButtonPress-1> "focus %W"
168 
169  # Bind right button to popup a contextual menu:
170  bind $w.text <ButtonPress-$::MB3> "::pgn::contextMenu .pgnWin.text %X %Y"
171 
172  # Workaround for Text widget bug (Tk 8.6.6+)
173  # The new "asynchronous update of line heights" does not work if
174  # the Text widget is inside an inactive ttk::notebook tab.
175  if {![catch { $w.text sync}]} { bind $w.text <Visibility> "$w.text sync"}
176 
177  $w.text tag add Current 0.0 0.0
178  ::pgn::ResetColors
179  }
180 
181  ################################################################################
182  #
183  ################################################################################
184  proc contextMenu {win x y} {
185 
186  update idletasks
187 
188  set mctxt $win.ctxtMenu
189  if { [winfo exists $mctxt] } { destroy $mctxt}
190  if {[sc_var level] == 0} {
191  set state disabled
192  } else {
193  set state normal
194  }
195 
196  menu $mctxt
197 
198  menu $mctxt.evals1
199  $mctxt.evals1 add command -label "Clear" -command {::addNag X}
200  $mctxt.evals1 add command -label "!" -command {::addNag !}
201  $mctxt.evals1 add command -label "?" -command {::addNag ?}
202  $mctxt.evals1 add command -label "!?" -command {::addNag !?}
203  $mctxt.evals1 add command -label "?!" -command {::addNag ?!}
204  $mctxt.evals1 add command -label "!!" -command {::addNag !!}
205  $mctxt.evals1 add command -label "??" -command {::addNag ??}
206 
207  menu $mctxt.evals2
208  $mctxt.evals2 add command -label "Clear" -command {::addNag Y}
209  $mctxt.evals2 add command -label "=" -command {::addNag =}
210  $mctxt.evals2 add command -label "~" -command {::addNag ~}
211  $mctxt.evals2 add command -label "+=" -command {::addNag +=}
212  $mctxt.evals2 add command -label "=+" -command {::addNag =+}
213  $mctxt.evals2 add command -label "+/-" -command {::addNag +/-}
214  $mctxt.evals2 add command -label "-/+" -command {::addNag -/+}
215  $mctxt.evals2 add command -label "+-" -command {::addNag +-}
216  $mctxt.evals2 add command -label "-+" -command {::addNag -+}
217  $mctxt.evals2 add command -label "+--" -command {::addNag +--}
218  $mctxt.evals2 add command -label "--+" -command {::addNag --+}
219  $mctxt.evals2 add command -label "N" -command {::addNag N}
220  $mctxt.evals2 add command -label "D" -command {::addNag D}
221 
222  $mctxt add command -label [tr EditDelete] -state $state -command "::pgn::deleteVar"
223  $mctxt add command -label [tr EditFirst] -state $state -command "::pgn::firstVar"
224  $mctxt add command -label [tr EditMain] -state $state -command "::pgn::mainVar"
225  $mctxt add separator
226  $mctxt add command -label "[tr EditStrip]:[tr EditStripBegin]" -command {::game::TruncateBegin}
227  $mctxt add command -label "[tr EditStrip]:[tr EditStripEnd]" -command {::game::Truncate}
228  $mctxt add separator
229  $mctxt add command -label "[tr EditStrip]:[tr EditStripComments]" -command {::game::Strip comments}
230  $mctxt add command -label "[tr EditStrip]:[tr EditStripVars]" -command {::game::Strip variations}
231  $mctxt add separator
232  $mctxt add cascade -label "! ? ..." -menu $mctxt.evals1
233  $mctxt add cascade -label "+- +/- ..." -menu $mctxt.evals2
234  $mctxt add command -label "[tr WindowsComment]" -command {::makeCommentWin}
235 
236  tk_popup $mctxt $x $y
237  }
238 
239  proc deleteVar {} {
240  undoFeature save
241  sc_var delete
242  updateBoard -pgn
243  }
244 
245  proc firstVar {} {
246  undoFeature save
247  sc_var first
248  updateBoard -pgn
249  }
250 
251  proc mainVar {} {
252  undoFeature save
253  sc_var promote
254  updateBoard -pgn
255  }
256  ################################################################################
257  # ::pgn::ShowBoard:
258  # Produces a popup window showing the board position in the
259  # game at the current mouse location in the PGN window.
260  #
261  ################################################################################
262  proc ShowBoard {win moveTag xc yc} {
263  set offSet [sc_pos pgnOffset]
264  sc_move pgn [string range $moveTag 2 end]
265  set bd [sc_pos board]
266  if {[::board::isFlipped .main.board]} {set bd [string reverse [lindex $bd 0]]}
267  sc_move pgn $offSet
268 
269  set w .pgnPopup
270  set psize 30
271  if {$psize > $::boardSize} { set psize $::boardSize}
272 
273  if {! [winfo exists $w]} {
274  toplevel $w -relief solid -borderwidth 2
275  wm withdraw $w
276  wm overrideredirect $w 1
277  ::board::new $w.bd $psize
278  pack $w.bd -side top -padx 2 -pady 2
279  wm withdraw $w
280  }
281 
282  ::board::update $w.bd $bd
283 
284  # Make sure the popup window can fit on the screen:
285  incr xc 5
286  incr yc 5
287  update idletasks
288  set dx [winfo width $w]
289  set dy [winfo height $w]
290  if {($xc+$dx) > [winfo screenwidth $w]} {
291  set xc [expr {[winfo screenwidth $w] - $dx}]
292  }
293  if {($yc+$dy) > [winfo screenheight $w]} {
294  set yc [expr {[winfo screenheight $w] - $dy}]
295  }
296  wm geometry $w "+$xc+$yc"
297  wm deiconify $w
298  raiseWin $w
299  }
300 
301  ################################################################################
302  # ::pgn::HideBoard
303  #
304  # Hides the window produced by ::pgn::ShowBoard.
305  #
306  ################################################################################
307  proc HideBoard {} {
308  if {[winfo exists .pgnPopup]} {wm withdraw .pgnPopup}
309  }
310 
311  ################################################################################
312  # # ::pgn::ResetColors
313  #
314  # Reconfigures the pgn Colors, after a color is changed by the user
315  #
316  ################################################################################
317  proc ResetColors {} {
318  global pgnColor
319  if {![winfo exists .pgnWin]} { return}
320  .pgnWin.text configure -background $pgnColor(Background)
321  .pgnWin.text tag configure Current -background $pgnColor(Current)
322  ::htext::init .pgnWin.text
323  ::htext::updateRate .pgnWin.text 0
324  ::pgn::Refresh 1
325  }
326  ################################################################################
327  # ::pgn::Refresh
328  #
329  # Updates the PGN window. If $pgnNeedsUpdate == 0, then the
330  # window text is not regenerated; only the current and next move
331  # tags will be updated.
332  ################################################################################
333  proc Refresh { {pgnNeedsUpdate 0} } {
334  if {![winfo exists .pgnWin]} { return}
335 
336  if {$pgnNeedsUpdate} {
337  busyCursor .
338  set format plain
339  if {$::pgn::showColor} {set format color}
340  set pgnStr [sc_game pgn -symbols $::pgn::symbolicNags \
341  -indentVar $::pgn::indentVars -indentCom $::pgn::indentComments \
342  -space $::pgn::moveNumberSpaces -format $format -column $::pgn::columnFormat \
343  -short $::pgn::shortHeader -markCodes $::pgn::stripMarks]
344 
345  set windowTitle [format $::tr(PgnWindowTitle) [sc_game number]]
346  ::setTitle .pgnWin "$windowTitle"
347  .pgnWin.text configure -state normal
348  .pgnWin.text delete 1.0 end
349 
350  if {$::pgn::showColor} {
351  ::htext::display .pgnWin.text $pgnStr
352  } else {
353  .pgnWin.text insert 1.0 $pgnStr
354  }
355 
356  if {$::pgn::showPhoto} {
357  updatePlayerPhotos
358  if {[image width photoW] != 0} {
359  .pgnWin.text image create 1.0 -image photoW -padx 10 -pady 10
360  }
361  if {[image width photoB] != 0} {
362  .pgnWin.text image create 1.end -image photoB -padx 10 -pady 10
363  }
364  }
365 
366  .pgnWin.text configure -state disabled
367  unbusyCursor .
368  }
369 
370  if {$::pgn::showColor} {
371  set offset [sc_pos pgnOffset]
372  .pgnWin.text tag remove Current 1.0 end
373  set moveRange [.pgnWin.text tag nextrange "m_$offset" 1.0]
374  if {[llength $moveRange] == 2} {
375  .pgnWin.text tag add Current [lindex $moveRange 0] [lindex $moveRange 1]
376  .pgnWin.text see [lindex $moveRange 1]
377  } else {
378  .pgnWin.text yview moveto 0
379  }
380  }
381  }
382  ################################################################################
383  #
384  ################################################################################
385 
386 }
Generated by   doxygen 1.8.13