1 | # $Id: browsecif.tcl 771 2009-12-04 23:11:45Z toby $ |
---|
2 | |
---|
3 | # possible future work: |
---|
4 | # implement adding a new data item to a CIF? Delete one? |
---|
5 | # can I bind to the tree window only? (.browser.pw.f0.frame.lf.tree) |
---|
6 | # clean up use of block<n> arrays. Should the prefix be changable? Use |
---|
7 | # the same syntax throughout |
---|
8 | |
---|
9 | #------------------------------------------------------------------------------ |
---|
10 | # Misc Tcl/Tk utility routines follow |
---|
11 | #------------------------------------------------------------------------------ |
---|
12 | # Message box code that centers the message box over the parent. |
---|
13 | # or along the edge, if too close, |
---|
14 | # but leave a border along +x & +y for reasons I don't remember |
---|
15 | # It also allows the button names to be defined using |
---|
16 | # -type $list -- where $list has a list of button names |
---|
17 | # larger messages are placed in a scrolled text widget |
---|
18 | # capitalization is now ignored for -default |
---|
19 | # The command returns the name button in all lower case letters |
---|
20 | # otherwise see tk_messageBox for a description |
---|
21 | # |
---|
22 | # This is a modification of tkMessageBox (msgbox.tcl v1.5) |
---|
23 | # |
---|
24 | proc MyMessageBox {args} { |
---|
25 | global tkPriv tcl_platform |
---|
26 | |
---|
27 | set w tkPrivMsgBox |
---|
28 | upvar #0 $w data |
---|
29 | |
---|
30 | # |
---|
31 | # The default value of the title is space (" ") not the empty string |
---|
32 | # because for some window managers, a |
---|
33 | # wm title .foo "" |
---|
34 | # causes the window title to be "foo" instead of the empty string. |
---|
35 | # |
---|
36 | set specs { |
---|
37 | {-default "" "" ""} |
---|
38 | {-icon "" "" "info"} |
---|
39 | {-message "" "" ""} |
---|
40 | {-parent "" "" .} |
---|
41 | {-title "" "" " "} |
---|
42 | {-type "" "" "ok"} |
---|
43 | {-helplink "" "" ""} |
---|
44 | } |
---|
45 | |
---|
46 | tclParseConfigSpec $w $specs "" $args |
---|
47 | |
---|
48 | if {[lsearch {info warning error question} $data(-icon)] == -1} { |
---|
49 | error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning" |
---|
50 | } |
---|
51 | if {![string compare $tcl_platform(platform) "macintosh"]} { |
---|
52 | switch -- $data(-icon) { |
---|
53 | "error" {set data(-icon) "stop"} |
---|
54 | "warning" {set data(-icon) "caution"} |
---|
55 | "info" {set data(-icon) "note"} |
---|
56 | } |
---|
57 | } |
---|
58 | |
---|
59 | if {![winfo exists $data(-parent)]} { |
---|
60 | error "bad window path name \"$data(-parent)\"" |
---|
61 | } |
---|
62 | |
---|
63 | switch -- $data(-type) { |
---|
64 | abortretryignore { |
---|
65 | set buttons { |
---|
66 | {abort -width 6 -text Abort -under 0} |
---|
67 | {retry -width 6 -text Retry -under 0} |
---|
68 | {ignore -width 6 -text Ignore -under 0} |
---|
69 | } |
---|
70 | } |
---|
71 | ok { |
---|
72 | set buttons { |
---|
73 | {ok -width 6 -text OK -under 0} |
---|
74 | } |
---|
75 | if {![string compare $data(-default) ""]} { |
---|
76 | set data(-default) "ok" |
---|
77 | } |
---|
78 | } |
---|
79 | okcancel { |
---|
80 | set buttons { |
---|
81 | {ok -width 6 -text OK -under 0} |
---|
82 | {cancel -width 6 -text Cancel -under 0} |
---|
83 | } |
---|
84 | } |
---|
85 | retrycancel { |
---|
86 | set buttons { |
---|
87 | {retry -width 6 -text Retry -under 0} |
---|
88 | {cancel -width 6 -text Cancel -under 0} |
---|
89 | } |
---|
90 | } |
---|
91 | yesno { |
---|
92 | set buttons { |
---|
93 | {yes -width 6 -text Yes -under 0} |
---|
94 | {no -width 6 -text No -under 0} |
---|
95 | } |
---|
96 | } |
---|
97 | yesnocancel { |
---|
98 | set buttons { |
---|
99 | {yes -width 6 -text Yes -under 0} |
---|
100 | {no -width 6 -text No -under 0} |
---|
101 | {cancel -width 6 -text Cancel -under 0} |
---|
102 | } |
---|
103 | } |
---|
104 | default { |
---|
105 | # error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel" |
---|
106 | foreach item $data(-type) { |
---|
107 | lappend buttons [list [string tolower $item] -text $item -under 0] |
---|
108 | } |
---|
109 | } |
---|
110 | } |
---|
111 | |
---|
112 | if {[string compare $data(-default) ""]} { |
---|
113 | set valid 0 |
---|
114 | foreach btn $buttons { |
---|
115 | if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} { |
---|
116 | set valid 1 |
---|
117 | break |
---|
118 | } |
---|
119 | } |
---|
120 | if {!$valid} { |
---|
121 | error "invalid default button \"$data(-default)\"" |
---|
122 | } |
---|
123 | } |
---|
124 | |
---|
125 | # 2. Set the dialog to be a child window of $parent |
---|
126 | # |
---|
127 | # |
---|
128 | if {[string compare $data(-parent) .]} { |
---|
129 | set w $data(-parent).__tk__messagebox |
---|
130 | } else { |
---|
131 | set w .__tk__messagebox |
---|
132 | } |
---|
133 | |
---|
134 | # 3. Create the top-level window and divide it into top |
---|
135 | # and bottom parts. |
---|
136 | |
---|
137 | catch {destroy $w} |
---|
138 | toplevel $w -class Dialog |
---|
139 | wm title $w $data(-title) |
---|
140 | wm iconname $w Dialog |
---|
141 | wm protocol $w WM_DELETE_WINDOW { } |
---|
142 | wm transient $w $data(-parent) |
---|
143 | if {![string compare $tcl_platform(platform) "macintosh"]} { |
---|
144 | unsupported1 style $w dBoxProc |
---|
145 | } |
---|
146 | |
---|
147 | frame $w.bot |
---|
148 | pack $w.bot -side bottom -fill both |
---|
149 | frame $w.top |
---|
150 | pack $w.top -side top -fill both -expand 1 |
---|
151 | if {$data(-helplink) != ""} { |
---|
152 | # frame $w.help |
---|
153 | # pack $w.help -side top -fill both |
---|
154 | pack [button $w.top.1 -text Help -bg yellow \ |
---|
155 | -command "MakeWWWHelp $data(-helplink)"] \ |
---|
156 | -side right -anchor ne |
---|
157 | bind $w <Key-F1> "MakeWWWHelp $data(-helplink)" |
---|
158 | } |
---|
159 | if {[string compare $tcl_platform(platform) "macintosh"]} { |
---|
160 | $w.bot configure -relief raised -bd 1 |
---|
161 | $w.top configure -relief raised -bd 1 |
---|
162 | } |
---|
163 | |
---|
164 | # 4. Fill the top part with bitmap and message (use the option |
---|
165 | # database for -wraplength and -font so that they can be |
---|
166 | # overridden by the caller). |
---|
167 | |
---|
168 | option add *Dialog.msg.wrapLength 6i widgetDefault |
---|
169 | |
---|
170 | if {[string length $data(-message)] > 300} { |
---|
171 | if {![string compare $tcl_platform(platform) "macintosh"]} { |
---|
172 | option add *Dialog.msg.t.font system widgetDefault |
---|
173 | } else { |
---|
174 | option add *Dialog.msg.t.font {Times 18} widgetDefault |
---|
175 | } |
---|
176 | frame $w.msg |
---|
177 | grid [text $w.msg.t \ |
---|
178 | -height 20 -width 55 -relief flat -wrap word \ |
---|
179 | -yscrollcommand "$w.msg.rscr set" \ |
---|
180 | ] -row 1 -column 0 -sticky news |
---|
181 | grid [scrollbar $w.msg.rscr -command "$w.msg.t yview" \ |
---|
182 | ] -row 1 -column 1 -sticky ns |
---|
183 | # give extra space to the text box |
---|
184 | grid columnconfigure $w.msg 0 -weight 1 |
---|
185 | grid rowconfigure $w.msg 1 -weight 1 |
---|
186 | $w.msg.t insert end $data(-message) |
---|
187 | } else { |
---|
188 | if {![string compare $tcl_platform(platform) "macintosh"]} { |
---|
189 | option add *Dialog.msg.font system widgetDefault |
---|
190 | } else { |
---|
191 | option add *Dialog.msg.font {Times 18} widgetDefault |
---|
192 | } |
---|
193 | label $w.msg -justify left -text $data(-message) |
---|
194 | } |
---|
195 | pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m |
---|
196 | if {[string compare $data(-icon) ""]} { |
---|
197 | label $w.bitmap -bitmap $data(-icon) |
---|
198 | pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m |
---|
199 | } |
---|
200 | |
---|
201 | # 5. Create a row of buttons at the bottom of the dialog. |
---|
202 | |
---|
203 | set i 0 |
---|
204 | foreach but $buttons { |
---|
205 | set name [lindex $but 0] |
---|
206 | set opts [lrange $but 1 end] |
---|
207 | if {![llength $opts]} { |
---|
208 | # Capitalize the first letter of $name |
---|
209 | set capName [string toupper \ |
---|
210 | [string index $name 0]][string range $name 1 end] |
---|
211 | set opts [list -text $capName] |
---|
212 | } |
---|
213 | |
---|
214 | eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]] |
---|
215 | |
---|
216 | if {![string compare $name [string tolower $data(-default)]]} { |
---|
217 | $w.$name configure -default active |
---|
218 | } |
---|
219 | pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m |
---|
220 | |
---|
221 | # create the binding for the key accelerator, based on the underline |
---|
222 | # |
---|
223 | set underIdx [$w.$name cget -under] |
---|
224 | if {$underIdx >= 0} { |
---|
225 | set key [string index [$w.$name cget -text] $underIdx] |
---|
226 | bind $w <Alt-[string tolower $key]> [list $w.$name invoke] |
---|
227 | bind $w <Alt-[string toupper $key]> [list $w.$name invoke] |
---|
228 | } |
---|
229 | incr i |
---|
230 | } |
---|
231 | |
---|
232 | # 6. Create a binding for <Return> on the dialog if there is a |
---|
233 | # default button. |
---|
234 | |
---|
235 | if {[string compare $data(-default) ""]} { |
---|
236 | bind $w <Return> [list $w.[string tolower $data(-default)] invoke] |
---|
237 | } |
---|
238 | |
---|
239 | # 7. Withdraw the window, then update all the geometry information |
---|
240 | # so we know how big it wants to be, then center the window in the |
---|
241 | # display and de-iconify it. |
---|
242 | |
---|
243 | wm withdraw $w |
---|
244 | update idletasks |
---|
245 | set wp $data(-parent) |
---|
246 | # center the new window in the middle of the parent |
---|
247 | set x [expr [winfo x $wp] + [winfo width $wp]/2 - \ |
---|
248 | [winfo reqwidth $w]/2 - [winfo vrootx $wp]] |
---|
249 | set y [expr [winfo y $wp] + [winfo height $wp]/2 - \ |
---|
250 | [winfo reqheight $w]/2 - [winfo vrooty $wp]] |
---|
251 | # make sure that we can see the entire window |
---|
252 | set xborder 10 |
---|
253 | set yborder 25 |
---|
254 | if {$x < 0} {set x 0} |
---|
255 | if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} { |
---|
256 | incr x [expr \ |
---|
257 | [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)] |
---|
258 | } |
---|
259 | if {$y < 0} {set y 0} |
---|
260 | if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} { |
---|
261 | incr y [expr \ |
---|
262 | [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)] |
---|
263 | } |
---|
264 | wm geom $w +$x+$y |
---|
265 | update |
---|
266 | wm deiconify $w |
---|
267 | |
---|
268 | # 8. Set a grab and claim the focus too. |
---|
269 | |
---|
270 | catch {set oldFocus [focus]} |
---|
271 | catch {set oldGrab [grab current $w]} |
---|
272 | catch { |
---|
273 | grab $w |
---|
274 | if {[string compare $data(-default) ""]} { |
---|
275 | focus $w.[string tolower $data(-default)] |
---|
276 | } else { |
---|
277 | focus $w |
---|
278 | } |
---|
279 | } |
---|
280 | |
---|
281 | # 9. Wait for the user to respond, then restore the focus and |
---|
282 | # return the index of the selected button. Restore the focus |
---|
283 | # before deleting the window, since otherwise the window manager |
---|
284 | # may take the focus away so we can't redirect it. Finally, |
---|
285 | # restore any grab that was in effect. |
---|
286 | |
---|
287 | tkwait variable tkPriv(button) |
---|
288 | catch {focus $oldFocus} |
---|
289 | destroy $w |
---|
290 | catch {grab $oldGrab} |
---|
291 | return $tkPriv(button) |
---|
292 | } |
---|
293 | |
---|
294 | # tell'em what is happening |
---|
295 | proc pleasewait {{message {}} {statusvar {}} {parent .} {button ""}} { |
---|
296 | catch {destroy .msg} |
---|
297 | toplevel .msg |
---|
298 | wm transient .msg [winfo toplevel .] |
---|
299 | pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5 |
---|
300 | pack [message .msg.f.m -text "Please wait $message"] -side top |
---|
301 | if {$statusvar != ""} { |
---|
302 | pack [label .msg.f.status -textvariable $statusvar] -side top |
---|
303 | } |
---|
304 | if {$button != ""} { |
---|
305 | pack [button .msg.f.button -text [lindex $button 0] \ |
---|
306 | -command [lindex $button 1]] -side top |
---|
307 | } |
---|
308 | wm withdraw .msg |
---|
309 | update idletasks |
---|
310 | # place the message on top of the parent window |
---|
311 | set x [expr [winfo x $parent] + [winfo width $parent]/2 - \ |
---|
312 | [winfo reqwidth .msg]/2 - [winfo vrootx $parent]] |
---|
313 | if {$x < 0} {set x 0} |
---|
314 | set y [expr [winfo y $parent] + [winfo height $parent]/2 - \ |
---|
315 | [winfo reqheight .msg]/2 - [winfo vrooty $parent]] |
---|
316 | if {$y < 0} {set y 0} |
---|
317 | wm geom .msg +$x+$y |
---|
318 | update |
---|
319 | wm deiconify .msg |
---|
320 | global makenew |
---|
321 | set makenew(OldGrab) "" |
---|
322 | set makenew(OldFocus) "" |
---|
323 | # save focus & grab |
---|
324 | catch {set makenew(OldFocus) [focus]} |
---|
325 | catch {set makenew(OldGrab) [grab current .msg]} |
---|
326 | catch {grab .msg} |
---|
327 | update |
---|
328 | } |
---|
329 | |
---|
330 | # clear the wait message |
---|
331 | proc donewait {} { |
---|
332 | global makenew |
---|
333 | catch {destroy .msg} |
---|
334 | # reset focus & grab |
---|
335 | catch { |
---|
336 | if {$makenew(OldFocus) != ""} { |
---|
337 | focus $makenew(OldFocus) |
---|
338 | } |
---|
339 | } |
---|
340 | catch { |
---|
341 | if {$makenew(OldGrab) != ""} { |
---|
342 | grab $makenew(OldGrab) |
---|
343 | } |
---|
344 | } |
---|
345 | } |
---|
346 | |
---|
347 | # this routine is used to fix up tk_optionMenu widgets that have too many |
---|
348 | # entries for a single list -- by using cascades |
---|
349 | proc FixBigOptionMenu {widget enum "cmd {}"} { |
---|
350 | # max entries |
---|
351 | set max 12 |
---|
352 | set menu [winfo children $widget] |
---|
353 | $menu delete 0 end |
---|
354 | eval destroy [winfo children $menu] |
---|
355 | set var [$widget cget -textvariable] |
---|
356 | # do we need a cascade? |
---|
357 | if {[set n [llength $enum]] <= $max} { |
---|
358 | # no |
---|
359 | foreach l $enum { |
---|
360 | $menu add radiobutton -value $l -label $l -variable $var \ |
---|
361 | -command $cmd |
---|
362 | } |
---|
363 | return |
---|
364 | } |
---|
365 | # yes |
---|
366 | set nmenus [expr int(($max + $n - 1 )/ (1.*$max))] |
---|
367 | set nper [expr 1 + $n/$nmenus] |
---|
368 | if {$nper > $max} {set nper $max} |
---|
369 | for {set i 0} {$i < $n} {incr i $nper} { |
---|
370 | set j [expr $i + $nper -1] |
---|
371 | set sublist [lrange $enum $i $j] |
---|
372 | $menu add cascade -label "[lindex $sublist 0]-[lindex $sublist end]" \ |
---|
373 | -menu $menu.$i |
---|
374 | menu $menu.$i |
---|
375 | foreach l $sublist { |
---|
376 | $menu.$i add radiobutton -value $l -label $l -variable $var \ |
---|
377 | -command $cmd |
---|
378 | } |
---|
379 | } |
---|
380 | } |
---|
381 | |
---|
382 | # this routine is used to add . and ? in a cascade for enum lists |
---|
383 | proc AddSpecialEnumOpts {widget "cmd {}"} { |
---|
384 | set menu [winfo children $widget] |
---|
385 | set var [$widget cget -textvariable] |
---|
386 | |
---|
387 | # add the cascade and entries to it |
---|
388 | $menu add cascade -label "(special values)" -menu $menu.special |
---|
389 | menu $menu.special |
---|
390 | $menu.special add radiobutton -value . -command $cmd \ |
---|
391 | -label "Inapplicable (.)" -variable $var |
---|
392 | $menu.special add radiobutton -value ? -command $cmd \ |
---|
393 | -label "Unknown (?)" -variable $var |
---|
394 | } |
---|
395 | |
---|
396 | proc putontop {w "center 0"} { |
---|
397 | # center window $w above its parent and make it stay on top |
---|
398 | set wp [winfo parent $w] |
---|
399 | wm transient $w [winfo toplevel $wp] |
---|
400 | wm withdraw $w |
---|
401 | update idletasks |
---|
402 | if {$center} { |
---|
403 | set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ |
---|
404 | - [winfo vrootx [winfo parent $w]]}] |
---|
405 | set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ |
---|
406 | - [winfo vrooty [winfo parent $w]]}] |
---|
407 | } else { |
---|
408 | # center the new window in the middle of the parent |
---|
409 | set x [expr [winfo x $wp] + [winfo width $wp]/2 - \ |
---|
410 | [winfo reqwidth $w]/2 - [winfo vrootx $wp]] |
---|
411 | if {$x < 0} {set x 0} |
---|
412 | set xborder 10 |
---|
413 | if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} { |
---|
414 | incr x [expr [winfo screenwidth $w] - \ |
---|
415 | ($x+[winfo reqwidth $w] + $xborder)] |
---|
416 | } |
---|
417 | set y [expr [winfo y $wp] + [winfo height $wp]/2 - \ |
---|
418 | [winfo reqheight $w]/2 - [winfo vrooty $wp]] |
---|
419 | if {$y < 0} {set y 0} |
---|
420 | set yborder 25 |
---|
421 | if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} { |
---|
422 | incr y [expr [winfo screenheight $w] - \ |
---|
423 | ($y+[winfo reqheight $w] + $yborder)] |
---|
424 | } |
---|
425 | } |
---|
426 | wm geometry $w +$x+$y |
---|
427 | wm deiconify $w |
---|
428 | |
---|
429 | global makenew |
---|
430 | set makenew(OldGrab) "" |
---|
431 | set makenew(OldFocus) "" |
---|
432 | catch {set makenew(OldFocus) [focus]} |
---|
433 | catch {set makenew(OldGrab) [grab current $w]} |
---|
434 | catch {grab $w} |
---|
435 | } |
---|
436 | |
---|
437 | proc afterputontop {} { |
---|
438 | # restore focus |
---|
439 | global makenew |
---|
440 | # reset focus & grab |
---|
441 | catch { |
---|
442 | if {$makenew(OldFocus) != ""} { |
---|
443 | focus $makenew(OldFocus) |
---|
444 | } |
---|
445 | } |
---|
446 | catch { |
---|
447 | if {$makenew(OldGrab) != ""} { |
---|
448 | grab $makenew(OldGrab) |
---|
449 | } |
---|
450 | } |
---|
451 | } |
---|
452 | |
---|
453 | #------------------------------------------------------------------------------ |
---|
454 | # end of Misc Tcl/Tk utility routines |
---|
455 | #------------------------------------------------------------------------------ |
---|
456 | |
---|
457 | #------------------------------------------------------------------------------ |
---|
458 | # ParseCIF reads and parses a CIF file putting the contents of |
---|
459 | # each block into arrays block1, block2,... in the caller's level |
---|
460 | # the name of the block is saved as blockN(data_) |
---|
461 | # data names items are saved as blockN(_data_name) = marker_number |
---|
462 | # where CIF data names are converted to lower case |
---|
463 | # and marker_number.l marker_number.r define the range of the value |
---|
464 | # for looped data names, the data items are included in a list: |
---|
465 | # blockN(_cif_name) = {marker1 marker2 ...} |
---|
466 | # the contents of each loop are saved as blockN(loop_M) |
---|
467 | # |
---|
468 | # if the filename is blank or not specified, the current contents |
---|
469 | # of the text widget, $txt, is parsed. |
---|
470 | # |
---|
471 | # The proc returns the number of blocks that have been read or a |
---|
472 | # null string if the file cannot be opened |
---|
473 | # |
---|
474 | # This parser does some error checking [errors are reported in blockN(error)] |
---|
475 | # but the parser could get confused if the CIF has invalid syntax |
---|
476 | # |
---|
477 | proc ParseCIF {txt "filename {}" "namespace {}"} { |
---|
478 | global CIF tcl_version |
---|
479 | global CIF_dataname_index |
---|
480 | # create a namespace, if one is needed |
---|
481 | if {$namespace != ""} { |
---|
482 | namespace eval $namespace {} |
---|
483 | } |
---|
484 | |
---|
485 | if {$tcl_version < 8.2} { |
---|
486 | tk_dialog .error {Old Tcl/Tk} \ |
---|
487 | "Sorry, the CIF Browser requires version 8.2 or later of the Tcl/Tk package. This is $tcl_version" \ |
---|
488 | warning 0 Sorry |
---|
489 | return |
---|
490 | } |
---|
491 | |
---|
492 | if {$filename != ""} { |
---|
493 | if [catch { |
---|
494 | $txt configure -state normal |
---|
495 | set fp [open $filename r] |
---|
496 | $txt insert end [read $fp] |
---|
497 | close $fp |
---|
498 | $txt configure -state disabled |
---|
499 | }] { |
---|
500 | return "" |
---|
501 | } |
---|
502 | } |
---|
503 | |
---|
504 | # maximum size of file |
---|
505 | set maxvalues 0 |
---|
506 | catch { |
---|
507 | set maxvalues $CIF(maxvalues) |
---|
508 | } |
---|
509 | |
---|
510 | set CIF(undolist) {} |
---|
511 | set CIF(redolist) {} |
---|
512 | set pos 1.0 |
---|
513 | set blocks 0 |
---|
514 | set EOF 1 |
---|
515 | set dataname {} |
---|
516 | set CIF(markcount) -1 |
---|
517 | # this flags where we are w/r a loop_ |
---|
518 | # -1 not in a loop |
---|
519 | # 0 reading a loop header (data names) |
---|
520 | # 1 reading the data items in a loop |
---|
521 | set loopflag -1 |
---|
522 | set loopnum -1 |
---|
523 | # loop over tokens |
---|
524 | while {$EOF} { |
---|
525 | if {$CIF(markcount) % 1000 == 0} { |
---|
526 | $txt see $pos |
---|
527 | set CIF(status) "($CIF(markcount) values read.)" |
---|
528 | update |
---|
529 | # are we over the limit? |
---|
530 | if {$maxvalues > 0 && $CIF(markcount) > $maxvalues} { |
---|
531 | donewait |
---|
532 | set msg "Too many data values to parse; stopping at $CIF(markcount), line [lindex [split $pos .] 0].\n\nIf your computer has sufficient memory to read more, increase CIF(maxvalues) in cifedit.tcl" |
---|
533 | set ans [MyMessageBox -parent . -title "CIF Too big" \ |
---|
534 | -message $msg -icon error -type "{Stop Parsing}" \ |
---|
535 | -default "stop parsing"] |
---|
536 | |
---|
537 | return $blocks |
---|
538 | } |
---|
539 | } |
---|
540 | # skip forward to the first non-blank character |
---|
541 | set npos [$txt search -regexp {[^[:space:]]} $pos end] |
---|
542 | # is this the end? |
---|
543 | if {$npos == "" || \ |
---|
544 | [lindex [split $npos .] 0] < [lindex [split $pos .] 0] } { |
---|
545 | set EOF 0 |
---|
546 | break |
---|
547 | } else { |
---|
548 | set pos $npos |
---|
549 | } |
---|
550 | |
---|
551 | # is this a comment, if so skip to next line |
---|
552 | if {[$txt get $pos] == "#"} { |
---|
553 | set pos [$txt index "$pos + 1 line linestart"] |
---|
554 | continue |
---|
555 | } |
---|
556 | |
---|
557 | # find end of token |
---|
558 | set epos [$txt search -regexp {[[:space:]]} $pos "$pos lineend"] |
---|
559 | if {$epos == ""} { |
---|
560 | set epos [$txt index "$pos lineend"] |
---|
561 | } |
---|
562 | |
---|
563 | set token [$txt get $pos $epos] |
---|
564 | |
---|
565 | if {[string tolower [string range $token 0 4]] == "data_"} { |
---|
566 | # this is the beginning of a data block |
---|
567 | incr blocks |
---|
568 | set blockname [string range $token 5 end] |
---|
569 | catch {unset ${namespace}::block$blocks} |
---|
570 | set ${namespace}::block${blocks}(data_) $blockname |
---|
571 | set loopnum -1 |
---|
572 | if {$dataname != ""} { |
---|
573 | # this is an error -- data_ block where a data item is expected |
---|
574 | append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n" |
---|
575 | set dataname {} |
---|
576 | } |
---|
577 | # move forward past current token |
---|
578 | set pos [$txt index "$epos +1c"] |
---|
579 | continue |
---|
580 | } |
---|
581 | |
---|
582 | if {[$txt get $pos] == "_"} { |
---|
583 | # this is a cif data name |
---|
584 | if {$dataname != ""} { |
---|
585 | # this is an error -- data name where a data item is expected |
---|
586 | append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n" |
---|
587 | } |
---|
588 | # convert it to lower case & save |
---|
589 | set dataname [string tolower $token] |
---|
590 | |
---|
591 | # are we in a loop header or loop body? |
---|
592 | if {$loopflag == 0} { |
---|
593 | # in a loop header, save the names in the loop list |
---|
594 | lappend looplist $dataname |
---|
595 | # check the categories used in the loop |
---|
596 | set category {} |
---|
597 | catch { |
---|
598 | set category [lindex \ |
---|
599 | [lindex $CIF_dataname_index($dataname) 1] 5] |
---|
600 | } |
---|
601 | # don't worry if we don't have a category |
---|
602 | if {$category != ""} { |
---|
603 | if {$catlist == ""} { |
---|
604 | set catlist $category |
---|
605 | } elseif {[lsearch $catlist $category] == -1} { |
---|
606 | # error two categories in a loop |
---|
607 | lappend catlist $category |
---|
608 | append ${namespace}::block${blocks}(errors) \ |
---|
609 | "Multiple categories ($catlist) in a loop_ for $dataname at line [lindex [split $pos .] 0]\n" |
---|
610 | } |
---|
611 | } |
---|
612 | |
---|
613 | if {$blocks == 0} { |
---|
614 | # an error -- a loop_ before a data_ block start |
---|
615 | set ${namespace}::block${blocks}(data_) undefined |
---|
616 | append ${namespace}::block${blocks}(errors) \ |
---|
617 | "A loop_ begins before a data_ block is defined (line [lindex [split $pos .] 0])\n" |
---|
618 | } |
---|
619 | set ${namespace}::block${blocks}(loop_${loopnum}) $looplist |
---|
620 | # clear the array element for the data item |
---|
621 | # -- should not be needed for a valid CIF but if a name is used |
---|
622 | # -- twice in the same block, want to wipe out the 1st data |
---|
623 | catch { |
---|
624 | if {[set ${namespace}::block${blocks}($dataname)] != ""} { |
---|
625 | # this is an error -- repeated data name |
---|
626 | append ${namespace}::block${blocks}(errors) \ |
---|
627 | "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n" |
---|
628 | } |
---|
629 | set ${namespace}::block${blocks}($dataname) {} |
---|
630 | } |
---|
631 | set dataname {} |
---|
632 | } elseif {$loopflag > 0} { |
---|
633 | # in a loop body, so the loop is over |
---|
634 | set loopflag -1 |
---|
635 | } |
---|
636 | # move forward past current token |
---|
637 | set pos [$txt index "$epos +1c"] |
---|
638 | continue |
---|
639 | } |
---|
640 | |
---|
641 | if {[string tolower [string range $token 0 4]] == "loop_"} { |
---|
642 | set loopflag 0 |
---|
643 | incr loopnum |
---|
644 | set looplist {} |
---|
645 | set catlist {} |
---|
646 | set ${namespace}::block${blocks}(loop_${loopnum}) {} |
---|
647 | # move forward past current token |
---|
648 | set pos [$txt index "$epos +1c"] |
---|
649 | continue |
---|
650 | } |
---|
651 | |
---|
652 | # keywords not matched, must be some type of data item |
---|
653 | set item {} |
---|
654 | incr CIF(markcount) |
---|
655 | |
---|
656 | if {[$txt get "$pos linestart"] == ";" && \ |
---|
657 | [$txt index $pos] == [$txt index "$pos linestart"]} { |
---|
658 | # multiline entry with semicolon termination |
---|
659 | set epos [$txt search -regexp {^;} "$pos + 1 line linestart"] |
---|
660 | if {$epos == ""} { |
---|
661 | set epos end |
---|
662 | append ${namespace}::block${blocks}(errors) \ |
---|
663 | "Unmatched semicolon for $dataname starting at line [lindex [split $pos .] 0]\n" |
---|
664 | } |
---|
665 | |
---|
666 | $txt mark set $CIF(markcount).l "$pos linestart" |
---|
667 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
668 | $txt mark gravity $CIF(markcount).l left |
---|
669 | $txt mark gravity $CIF(markcount).r right |
---|
670 | set item [$txt get "$pos linestart" "$epos +1c"] |
---|
671 | # move forward past current token |
---|
672 | set pos [$txt index "$epos + 1c"] |
---|
673 | } elseif {[$txt get $pos] == "\""} { |
---|
674 | # a quoted string -- find next quote |
---|
675 | set epos [$txt search "\"" "$pos +1c" "$pos lineend"] |
---|
676 | # skip over quotes followed by a non-blank |
---|
677 | while {$epos != "" && \ |
---|
678 | [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} { |
---|
679 | set epos [$txt search "\"" "$epos +1c" "$pos lineend"] |
---|
680 | } |
---|
681 | # did we hit the end of line? |
---|
682 | if {$epos == ""} { |
---|
683 | set epos [$txt index "$pos lineend"] |
---|
684 | append ${namespace}::block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n" |
---|
685 | } |
---|
686 | $txt mark set $CIF(markcount).l "$pos" |
---|
687 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
688 | $txt mark gravity $CIF(markcount).l left |
---|
689 | $txt mark gravity $CIF(markcount).r right |
---|
690 | set item [$txt get $pos "$epos +1c"] |
---|
691 | # move forward past current token |
---|
692 | set pos [$txt index "$epos +2c"] |
---|
693 | } elseif {[$txt get $pos] == {'}} { |
---|
694 | # a quoted string -- find next quote |
---|
695 | set epos [$txt search {'} "$pos +1c" "$pos lineend"] |
---|
696 | # skip over quotes followed by a non-blank |
---|
697 | while {$epos != "" && \ |
---|
698 | [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} { |
---|
699 | set epos [$txt search {'} "$epos +1c" "$pos lineend"] |
---|
700 | } |
---|
701 | # did we hit the end of line? |
---|
702 | if {$epos == ""} { |
---|
703 | set epos [$txt index "$pos lineend"] |
---|
704 | append ${namespace}::block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n" |
---|
705 | } |
---|
706 | $txt mark set $CIF(markcount).l "$pos" |
---|
707 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
708 | $txt mark gravity $CIF(markcount).l left |
---|
709 | $txt mark gravity $CIF(markcount).r right |
---|
710 | set item [$txt get $pos "$epos +1c"] |
---|
711 | # move forward past current token |
---|
712 | set pos [$txt index "$epos + 2 c"] |
---|
713 | } elseif {[$txt get $pos] == {[}} { |
---|
714 | # CIF v1.1 square bracket quotes |
---|
715 | set count 1 |
---|
716 | set epos $pos |
---|
717 | while {$count != 0} { |
---|
718 | set epos [$txt search -regexp {[\]\[]} "$epos +1c"] |
---|
719 | if {$epos == ""} { |
---|
720 | # unmatched open square bracket |
---|
721 | append ${namespace}::block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n" |
---|
722 | set count 0 |
---|
723 | set epos [$txt index end] |
---|
724 | } elseif {[$txt get $epos] == {]}} { |
---|
725 | # close bracket -- decrement |
---|
726 | incr count -1 |
---|
727 | } else { |
---|
728 | # open bracket -- increment |
---|
729 | incr count |
---|
730 | } |
---|
731 | } |
---|
732 | $txt mark set $CIF(markcount).l "$pos" |
---|
733 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
734 | $txt mark gravity $CIF(markcount).l left |
---|
735 | $txt mark gravity $CIF(markcount).r right |
---|
736 | set item [$txt get $pos "$epos +1c"] |
---|
737 | # move forward past current token |
---|
738 | set pos [$txt index "$epos + 2 c"] |
---|
739 | } else { |
---|
740 | # must be a single space-delimited value |
---|
741 | $txt mark set $CIF(markcount).l $pos |
---|
742 | $txt mark set $CIF(markcount).r $epos |
---|
743 | $txt mark gravity $CIF(markcount).l left |
---|
744 | $txt mark gravity $CIF(markcount).r right |
---|
745 | set item $token |
---|
746 | set pos [$txt index "$epos + 1 c"] |
---|
747 | } |
---|
748 | # a data item has been read |
---|
749 | |
---|
750 | # store the data item |
---|
751 | if {$loopflag >= 0} { |
---|
752 | # if in a loop, increment the loop element counter to select the |
---|
753 | # appropriate array element |
---|
754 | incr loopflag |
---|
755 | set i [expr ($loopflag - 1) % [llength $looplist]] |
---|
756 | lappend ${namespace}::block${blocks}([lindex $looplist $i]) $CIF(markcount) |
---|
757 | set ${namespace}::block${blocks}(lastmark) $CIF(markcount) |
---|
758 | } elseif {$dataname == ""} { |
---|
759 | # this is an error -- a data item where we do not expect one |
---|
760 | append ${namespace}::block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n" |
---|
761 | } else { |
---|
762 | if {$blocks == 0} { |
---|
763 | # an error -- a data name before a data_ block start |
---|
764 | set ${namespace}::block${blocks}(data_) undefined |
---|
765 | append ${namespace}::block${blocks}(errors) \ |
---|
766 | "Data name $dataname appears before a data_ block is defined (line [lindex [split $pos .] 0])\n" |
---|
767 | } |
---|
768 | catch { |
---|
769 | if {[set ${namespace}::block${blocks}($dataname)] != ""} { |
---|
770 | # this is an error -- repeated data name |
---|
771 | append ${namespace}::block${blocks}(errors) \ |
---|
772 | "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n" |
---|
773 | } |
---|
774 | } |
---|
775 | set ${namespace}::block${blocks}($dataname) $CIF(markcount) |
---|
776 | set ${namespace}::block${blocks}(lastmark) $CIF(markcount) |
---|
777 | set dataname "" |
---|
778 | } |
---|
779 | } |
---|
780 | $txt see 1.0 |
---|
781 | return $blocks |
---|
782 | } |
---|
783 | |
---|
784 | #------------------------------------------------------------------------------ |
---|
785 | # Create a CIF browser/editor |
---|
786 | # $txt is a text widget with the entire CIF loaded |
---|
787 | # blocklist contains the list of defined blocks (by #) |
---|
788 | # selected is the list of blocks that will be expanded |
---|
789 | # frame gives the name of the toplevel window to hold the browser |
---|
790 | proc BrowseCIF {txt blocklist "selected {}" "frame .cif"} { |
---|
791 | catch {destroy $frame} |
---|
792 | toplevel $frame |
---|
793 | wm title $frame "CIF Browser" |
---|
794 | CIFOpenBrowser $frame |
---|
795 | CIFBrowser $txt $blocklist $selected $frame |
---|
796 | grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1 |
---|
797 | } |
---|
798 | |
---|
799 | # Populate a hierarchical CIF browser |
---|
800 | # $txt is a text widget with the entire CIF loaded |
---|
801 | # blocklist contains the list of defined blocks (by #) |
---|
802 | # selected is the list of blocks that will be expanded |
---|
803 | # frame gives the name of the toplevel or frame to hold the browser |
---|
804 | proc CIFBrowser {txt blocklist "selected {}" "frame .cif"} { |
---|
805 | global CIF CIFtreeindex CIF_dataname_index |
---|
806 | |
---|
807 | if {$selected == ""} {set selected $blocklist} |
---|
808 | |
---|
809 | # clear out old info, if any, from browser |
---|
810 | eval $CIF(tree) delete [$CIF(tree) nodes root] |
---|
811 | catch {unset CIFtreeindex} |
---|
812 | # remove the loop counter frame from window & edit buttons from that frame |
---|
813 | grid forget $CIF(LoopBar) |
---|
814 | pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry) |
---|
815 | # delete old contents of frame |
---|
816 | set frame [$CIF(displayFrame) getframe] |
---|
817 | eval destroy [grid slaves $frame] |
---|
818 | set CIF(widgetlist) {} |
---|
819 | # reset the scrollbars |
---|
820 | $CIF(tree) see 0 |
---|
821 | $CIF(displayFrame) xview moveto 0 |
---|
822 | $CIF(displayFrame) yview moveto 0 |
---|
823 | |
---|
824 | # Bwidget seems to have problems with the name "1", so avoid it |
---|
825 | set num 100 |
---|
826 | foreach n $blocklist { |
---|
827 | global block$n |
---|
828 | # make a list of data names in loops |
---|
829 | set looplist {} |
---|
830 | foreach loop [array names block$n loop_*] { |
---|
831 | eval lappend looplist [set block${n}($loop)] |
---|
832 | } |
---|
833 | # put the block name |
---|
834 | set blockname [set block${n}(data_)] |
---|
835 | set open 0 |
---|
836 | if {[lsearch $selected $n] != -1} {set open 1} |
---|
837 | $CIF(tree) insert end root block$n -text "_data_$blockname" \ |
---|
838 | -open $open -image [Bitmap::get folder] |
---|
839 | |
---|
840 | # show errors, if any |
---|
841 | foreach name [array names block$n errors] { |
---|
842 | $CIF(tree) insert end block$n [incr num] -text "Parse-errors" \ |
---|
843 | -image [Bitmap::get undo] -data block$n |
---|
844 | } |
---|
845 | # loop over the names in each block |
---|
846 | foreach name [lsort [array names block$n _*]] { |
---|
847 | # don't include looped names |
---|
848 | if {[lsearch $looplist $name] == -1} { |
---|
849 | $CIF(tree) insert end block$n [incr num] -text $name \ |
---|
850 | -image [Bitmap::get file] -data block$n |
---|
851 | set CIFtreeindex(block${n}$name) $num |
---|
852 | } |
---|
853 | } |
---|
854 | foreach loop [lsort [array names block$n loop_*]] { |
---|
855 | # make a list of categories used in the loop |
---|
856 | set catlist {} |
---|
857 | foreach name [lsort [set block${n}($loop)]] { |
---|
858 | set category {} |
---|
859 | catch { |
---|
860 | set category [lindex \ |
---|
861 | [lindex $CIF_dataname_index($name) 1] 5] |
---|
862 | } |
---|
863 | if {$category != "" && [lsearch $catlist $category] == -1} { |
---|
864 | lappend catlist $category |
---|
865 | } |
---|
866 | } |
---|
867 | |
---|
868 | $CIF(tree) insert end block$n block${n}$loop \ |
---|
869 | -text "$loop ($catlist)" \ |
---|
870 | -image [Bitmap::get copy] -data "block$n loop" |
---|
871 | set CIFtreeindex(block${n}$loop) block${n}$loop |
---|
872 | foreach name [lsort [set block${n}($loop)]] { |
---|
873 | $CIF(tree) insert end block${n}$loop [incr num] -text $name \ |
---|
874 | -image [Bitmap::get file] -data "block$n $loop" |
---|
875 | set CIFtreeindex(block${n}$name) $num |
---|
876 | } |
---|
877 | } |
---|
878 | } |
---|
879 | $CIF(tree) bindImage <1> showCIFbyTreeID |
---|
880 | $CIF(tree) bindText <1> showCIFbyTreeID |
---|
881 | set CIF(tree_lastindex) $num |
---|
882 | } |
---|
883 | |
---|
884 | # Create the widgets for a hierarchical CIF browser in $frame |
---|
885 | # (where $frame is a frame or toplevel) |
---|
886 | # note that the BWidget package is required |
---|
887 | proc CIFOpenBrowser {frame} { |
---|
888 | global CIF |
---|
889 | if [catch {package require BWidget}] { |
---|
890 | tk_dialog .error {No BWidget} \ |
---|
891 | "Sorry, the CIF Browser requires the BWidget package" \ |
---|
892 | warning 0 Sorry |
---|
893 | return |
---|
894 | } |
---|
895 | |
---|
896 | set pw [PanedWindow $frame.pw -side top] |
---|
897 | grid $pw -sticky news -column 0 -row 0 |
---|
898 | set CIF(LoopBar) [frame $frame.f] |
---|
899 | #grid $CIF(LoopBar) -sticky es -column 0 -row 1 |
---|
900 | set width 900 |
---|
901 | if {$width > [winfo screenwidth .]} {set width [winfo screenwidth .]} |
---|
902 | grid columnconfigure $frame 0 -weight 1 -minsize $width |
---|
903 | # shrink browser on small screens |
---|
904 | set h 250 |
---|
905 | if {[winfo screenheight .] < 500} {set h 180} |
---|
906 | grid rowconfigure $frame 0 -minsize $h -weight 1 |
---|
907 | |
---|
908 | # create a left hand side pane for the hierarchical tree |
---|
909 | set pane [$pw add -weight 1] |
---|
910 | set sw [ScrolledWindow $pane.lf \ |
---|
911 | -relief sunken -borderwidth 2] |
---|
912 | set CIF(tree) [Tree $sw.tree \ |
---|
913 | -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \ |
---|
914 | -redraw 1] |
---|
915 | # get the size of the font and adjust the line spacing accordingly |
---|
916 | catch { |
---|
917 | set font [option get $CIF(tree) font Canvas] |
---|
918 | $CIF(tree) configure -deltay [font metrics $font -linespace] |
---|
919 | } |
---|
920 | bind $frame <KeyPress-Prior> "$CIF(tree) yview scroll -1 page" |
---|
921 | bind $frame <KeyPress-Next> "$CIF(tree) yview scroll 1 page" |
---|
922 | # bind $frame <KeyPress-Up> "$CIF(tree) yview scroll -1 unit" |
---|
923 | # bind $frame <KeyPress-Down> "$CIF(tree) yview scroll 1 unit" |
---|
924 | bind $frame <KeyPress-Home> "$CIF(tree) yview moveto 0" |
---|
925 | #bind $frame <KeyPress-End> "$CIF(tree) yview moveto end" -- does not work |
---|
926 | bind $frame <KeyPress-End> "$CIF(tree) yview scroll 99999999 page" |
---|
927 | grid $sw |
---|
928 | grid $sw -sticky news -column 0 -row 0 |
---|
929 | grid columnconfigure $pane 0 -minsize 275 -weight 1 |
---|
930 | grid rowconfigure $pane 0 -weight 1 |
---|
931 | $sw setwidget $CIF(tree) |
---|
932 | |
---|
933 | # create a right hand side pane to show the value |
---|
934 | set pane [$pw add -weight 4] |
---|
935 | set sw [ScrolledWindow $pane.sw \ |
---|
936 | -relief sunken -borderwidth 2] |
---|
937 | pack $sw -fill both -expand yes -side top |
---|
938 | |
---|
939 | set CIF(AddtoLoopButton) [button $CIF(LoopBar).l -text "Add to loop"] |
---|
940 | set CIF(DeleteLoopEntry) [button $CIF(LoopBar).d \ |
---|
941 | -text "Delete loop entry" -command DeleteCIFRow] |
---|
942 | label $CIF(LoopBar).1 -text "Loop\nelement #" |
---|
943 | set CIF(LoopSpinBox) [SpinBox $CIF(LoopBar).2 -range "1 1 1" -width 5] |
---|
944 | pack $CIF(LoopBar).2 $CIF(LoopBar).1 -side right |
---|
945 | set CIF(displayFrame) $sw.lb |
---|
946 | set lb [ScrollableFrame::create $CIF(displayFrame) -width 400] |
---|
947 | $sw setwidget $lb |
---|
948 | } |
---|
949 | |
---|
950 | # Warn to save changes that are not saved in a file |
---|
951 | proc CheckForCIFEdits {} { |
---|
952 | #puts "CheckForCIFEdits [info level [expr [info level]-1]]" |
---|
953 | global CIF |
---|
954 | set errorlist {} |
---|
955 | set errorflag 0 |
---|
956 | set msg "The following edits cannot be saved due to errors:\n" |
---|
957 | foreach widget $CIF(widgetlist) { |
---|
958 | CheckChanges $widget 1 |
---|
959 | if {$CIF(errormsg) != ""} { |
---|
960 | set errorflag 1 |
---|
961 | foreach err $CIF(errormsg) { |
---|
962 | append msg " " $err \n |
---|
963 | } |
---|
964 | } |
---|
965 | |
---|
966 | } |
---|
967 | if {$errorflag} { |
---|
968 | append msg \n {Do you want to make corrections, or discard these edits?} |
---|
969 | set ans [MyMessageBox -parent . -title "Invalid edits" \ |
---|
970 | -message $msg -icon error -type "Correct Discard" \ |
---|
971 | -default correct] |
---|
972 | if {$ans == "correct"} { |
---|
973 | # if not, don't allow the mode/loop value to change |
---|
974 | set CIF(editmode) 1 |
---|
975 | catch { |
---|
976 | $CIF(LoopSpinBox) setvalue @$CIF(lastLoopIndex) |
---|
977 | } |
---|
978 | return 1 |
---|
979 | } |
---|
980 | } |
---|
981 | return 0 |
---|
982 | } |
---|
983 | |
---|
984 | # showCIFbyTreeID is used in BrowseCIF to response to clicking on a tree widget |
---|
985 | # shows the contents data name or a loop |
---|
986 | proc showCIFbyTreeID {name} { |
---|
987 | if {[CheckForCIFEdits]} return |
---|
988 | |
---|
989 | global CIF |
---|
990 | # code to allow multiple selection within loops |
---|
991 | #set loopname [lindex [$CIF(tree) itemcget $name -data] 1] |
---|
992 | #set addtolist 1 |
---|
993 | #if {$loopname == "" || $loopname == "loop"} {set addtolist 0} |
---|
994 | #foreach n $CIF(treeSelectedList) { |
---|
995 | #if {$loopname != [lindex [$CIF(tree) itemcget $n -data] 1]} { |
---|
996 | # set addtolist 0 |
---|
997 | # break |
---|
998 | #} |
---|
999 | #} |
---|
1000 | #if {$addtolist} { |
---|
1001 | #catch {$CIF(tree) itemconfigure $name -fill red} |
---|
1002 | #lappend CIF(treeSelectedList) $name |
---|
1003 | #} else { |
---|
1004 | foreach n $CIF(treeSelectedList) { |
---|
1005 | catch {$CIF(tree) itemconfigure $n -fill black} |
---|
1006 | } |
---|
1007 | set CIF(treeSelectedList) $name |
---|
1008 | # for some reason, BWidget sometimes has problems doing this: |
---|
1009 | # (but ignore the error) |
---|
1010 | catch {$CIF(tree) itemconfigure $name -fill red} |
---|
1011 | set CIF(lastShownTreeID) $name |
---|
1012 | set pointer [$CIF(tree) itemcget $name -data] |
---|
1013 | set dataname [lindex [$CIF(tree) itemcget $name -text] 0] |
---|
1014 | showCIFbyDataname $pointer $dataname |
---|
1015 | #} |
---|
1016 | } |
---|
1017 | |
---|
1018 | proc showCIFbyDataname {pointer dataname "loopindex {}"} { |
---|
1019 | global CIF CIFtreeindex |
---|
1020 | set CIF(lastShownItem) [list $pointer $dataname] |
---|
1021 | # remove the loop counter frame from window & edit buttons from that frame |
---|
1022 | grid forget $CIF(LoopBar) |
---|
1023 | pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry) |
---|
1024 | |
---|
1025 | # delete old contents of frame |
---|
1026 | set frame [$CIF(displayFrame) getframe] |
---|
1027 | eval destroy [grid slaves $frame] |
---|
1028 | # reset the scrollbars |
---|
1029 | $CIF(displayFrame) xview moveto 0 |
---|
1030 | $CIF(displayFrame) yview moveto 0 |
---|
1031 | # leave room for a scrollbar |
---|
1032 | grid columnconfig $frame 0 -minsize [expr \ |
---|
1033 | [winfo width [winfo parent $frame]] - 20] |
---|
1034 | if {$pointer == ""} { |
---|
1035 | return |
---|
1036 | } |
---|
1037 | # create list of widgets defined here |
---|
1038 | set CIF(widgetlist) {} |
---|
1039 | |
---|
1040 | # is this a looped data item? |
---|
1041 | set block [lindex $pointer 0] |
---|
1042 | if {[llength $pointer] == 2} { |
---|
1043 | global $block |
---|
1044 | # display contents of a rows of the loop |
---|
1045 | if {[lindex $pointer 1] == "loop"} { |
---|
1046 | if {$CIF(editmode)} { |
---|
1047 | pack $CIF(DeleteLoopEntry) -side right |
---|
1048 | pack $CIF(AddtoLoopButton) -side right |
---|
1049 | $CIF(AddtoLoopButton) config -command "AddToCIFloop ${block} $dataname" |
---|
1050 | } |
---|
1051 | set looplist [set ${block}($dataname)] |
---|
1052 | # get number of elements for first name |
---|
1053 | set names [llength [set ${block}([lindex $looplist 0])]] |
---|
1054 | # can't delete the only entry |
---|
1055 | if {$names == 1 && $CIF(editmode)} { |
---|
1056 | $CIF(DeleteLoopEntry) configure -state disabled |
---|
1057 | } else { |
---|
1058 | $CIF(DeleteLoopEntry) configure -state normal |
---|
1059 | } |
---|
1060 | $CIF(LoopSpinBox) configure -range "1 $names 1" \ |
---|
1061 | -command "ShowLoopVar ${block} $dataname" \ |
---|
1062 | -modifycmd "ShowLoopVar ${block} $dataname" |
---|
1063 | set CIF(lastLoopIndex) {} |
---|
1064 | if {$loopindex == ""} { |
---|
1065 | $CIF(LoopSpinBox) setvalue first |
---|
1066 | } else { |
---|
1067 | $CIF(LoopSpinBox) setvalue @$loopindex |
---|
1068 | } |
---|
1069 | # show the loop counter frame |
---|
1070 | grid $CIF(LoopBar) -sticky es -column 0 -row 1 |
---|
1071 | set row 0 |
---|
1072 | set i 0 |
---|
1073 | ShowDictionaryDefinition $looplist |
---|
1074 | foreach var $looplist { |
---|
1075 | incr i |
---|
1076 | grid [TitleFrame $frame.$i -text $var -side left] \ |
---|
1077 | -column 0 -row $i -sticky ew |
---|
1078 | set row $i |
---|
1079 | set frame0 [$frame.$i getframe] |
---|
1080 | DisplayCIFvalue $frame0.l $var 1 "" ${block} |
---|
1081 | grid columnconfig $frame0 2 -weight 1 |
---|
1082 | } |
---|
1083 | ShowLoopVar ${block} $dataname |
---|
1084 | } else { |
---|
1085 | # look at a single looped variable |
---|
1086 | ShowDictionaryDefinition $dataname |
---|
1087 | grid [TitleFrame $frame.0 -text $dataname -side left] \ |
---|
1088 | -column 0 -row 0 -sticky ew |
---|
1089 | set row 0 |
---|
1090 | set i 0 |
---|
1091 | set frame0 [$frame.0 getframe] |
---|
1092 | grid columnconfig $frame0 2 -weight 1 |
---|
1093 | # maximum number of entries |
---|
1094 | set maxcols 100 |
---|
1095 | catch { |
---|
1096 | set maxcols $CIF(maxRows) |
---|
1097 | } |
---|
1098 | if {[set l [llength [set ${block}($dataname)]]] > $maxcols} { |
---|
1099 | grid [label $frame0.a$i -justify left \ |
---|
1100 | -text "$dataname has $l entries, too many to display by column" \ |
---|
1101 | ] -sticky w -column 0 -row $i |
---|
1102 | return |
---|
1103 | } |
---|
1104 | foreach mark [set ${block}($dataname)] { |
---|
1105 | incr i |
---|
1106 | if {$i == 1} {$CIF(txt) see $mark.l} |
---|
1107 | set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1108 | grid [label $frame0.a$i -justify left -text $i]\ |
---|
1109 | -sticky w -column 0 -row $i |
---|
1110 | DisplayCIFvalue $frame0.b$i $dataname $i $value ${block} $i |
---|
1111 | #grid $frame0.b$i -sticky new -column 1 -row $i |
---|
1112 | } |
---|
1113 | } |
---|
1114 | } else { |
---|
1115 | # unlooped data name |
---|
1116 | global ${block} |
---|
1117 | ShowDictionaryDefinition $dataname |
---|
1118 | grid [TitleFrame $frame.0 -text $dataname -side left] \ |
---|
1119 | -column 0 -row 0 -sticky ew |
---|
1120 | set row 0 |
---|
1121 | if {$dataname == "Parse-errors"} { |
---|
1122 | set value [set ${block}(errors)] |
---|
1123 | } elseif {$dataname == "Validation-errors"} { |
---|
1124 | set value [set ${block}(validate)] |
---|
1125 | } else { |
---|
1126 | set mark [set ${block}($dataname)] |
---|
1127 | set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1128 | $CIF(txt) see $mark.l |
---|
1129 | } |
---|
1130 | set frame0 [$frame.0 getframe] |
---|
1131 | grid columnconfig $frame0 2 -weight 1 |
---|
1132 | DisplayCIFvalue $frame0.l $dataname "" $value $block |
---|
1133 | #grid $frame0.l -sticky w -column 1 -row 0 |
---|
1134 | } |
---|
1135 | } |
---|
1136 | |
---|
1137 | # redisplay the last entry shown in showCIFbyTreeID |
---|
1138 | # this is used if the edit mode ($CIF(editmode)) changes or if edits are saved |
---|
1139 | proc RepeatLastshowCIFvalue {} { |
---|
1140 | global CIF |
---|
1141 | if {[CheckForCIFEdits]} return |
---|
1142 | set lastLoopIndex $CIF(lastLoopIndex) |
---|
1143 | |
---|
1144 | catch { |
---|
1145 | eval showCIFbyDataname $CIF(lastShownItem) |
---|
1146 | # if we are in a loop, display the element |
---|
1147 | if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} { |
---|
1148 | $CIF(LoopSpinBox) setvalue @$lastLoopIndex |
---|
1149 | ShowLoopVar [lindex [lindex $CIF(lastShownItem) 0] 0] \ |
---|
1150 | [lindex $CIF(lastShownItem) 1] |
---|
1151 | } |
---|
1152 | |
---|
1153 | } |
---|
1154 | } |
---|
1155 | |
---|
1156 | # used in BrowseCIF in response to the spinbox |
---|
1157 | # show entries in a specific row of a loop |
---|
1158 | proc ShowLoopVar {array loop} { |
---|
1159 | global $array CIF |
---|
1160 | # check for unsaved changes here |
---|
1161 | if {$CIF(lastLoopIndex) != ""} { |
---|
1162 | if {[CheckForCIFEdits]} return |
---|
1163 | } |
---|
1164 | |
---|
1165 | set looplist [set ${array}($loop)] |
---|
1166 | set index [$CIF(LoopSpinBox) getvalue] |
---|
1167 | if {$index < 0} { |
---|
1168 | $CIF(LoopSpinBox) setvalue first |
---|
1169 | set index [$CIF(LoopSpinBox) getvalue] |
---|
1170 | } elseif {$index > [llength [set ${array}([lindex $looplist 0])]]} { |
---|
1171 | $CIF(LoopSpinBox) setvalue last |
---|
1172 | set index [$CIF(LoopSpinBox) getvalue] |
---|
1173 | } |
---|
1174 | set CIF(lastLoopIndex) $index |
---|
1175 | set frame [$CIF(displayFrame) getframe] |
---|
1176 | set i 0 |
---|
1177 | foreach var $looplist { |
---|
1178 | incr i |
---|
1179 | set mark [lindex [set ${array}($var)] $index] |
---|
1180 | # ignore invalid entries -- should not happen |
---|
1181 | if {$mark == ""} { |
---|
1182 | $CIF(LoopSpinBox) setvalue first |
---|
1183 | return |
---|
1184 | } |
---|
1185 | set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1186 | if {$i == 1} {$CIF(txt) see $mark.l} |
---|
1187 | if {$CIF(editmode)} { |
---|
1188 | global CIFeditArr CIFinfoArr |
---|
1189 | set widget [$frame.$i getframe].l |
---|
1190 | set CIFeditArr($widget) $value |
---|
1191 | switch [winfo class $widget] { |
---|
1192 | Text { |
---|
1193 | $widget delete 0.0 end |
---|
1194 | $widget insert end $value |
---|
1195 | } |
---|
1196 | Entry { |
---|
1197 | $widget config -fg black |
---|
1198 | } |
---|
1199 | } |
---|
1200 | set CIFinfoArr($widget) [lreplace $CIFinfoArr($widget) 2 2 $index] |
---|
1201 | } else { |
---|
1202 | [$frame.$i getframe].l config -text $value |
---|
1203 | } |
---|
1204 | } |
---|
1205 | } |
---|
1206 | |
---|
1207 | # scan a number in crystallographic uncertainty representation |
---|
1208 | # i.e.: 1.234(12), 1234(23), 1.234e-2(14), -1.234-08(14), etc. |
---|
1209 | proc ParseSU {num} { |
---|
1210 | # is there an error on this value? |
---|
1211 | if {![regexp {([-+eEdD.0-9]+)\(([0-9]+)\)} $num x a err]} { |
---|
1212 | set a $num |
---|
1213 | set err {} |
---|
1214 | } |
---|
1215 | # parse off an exponent, if present |
---|
1216 | if {[regexp {([-+.0-9]+)[EeDd]([-+0-9]+)} $a x a1 exp]} { |
---|
1217 | # [+-]###.###e+## or [+-]###.###D-## etc. |
---|
1218 | set a $a1 |
---|
1219 | # remove leading zeros from exponent |
---|
1220 | regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp |
---|
1221 | } elseif {[regexp {([-+.0-9]+)([-+][0-9]+)} $a x a1 exp]} { |
---|
1222 | # [+-]###.###+## or [+-]###.###-## etc. [no |
---|
1223 | set a $a1 |
---|
1224 | # remove leading zeros from exponent |
---|
1225 | regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp |
---|
1226 | } else { |
---|
1227 | set exp 0 |
---|
1228 | } |
---|
1229 | # now parse the main number and count the digits after the decimal |
---|
1230 | set a2 {} |
---|
1231 | set a3 {} |
---|
1232 | regexp {^([-+0-9]*)\.?([0-9]*)$} $a x a2 a3 |
---|
1233 | set l [string length $a3] |
---|
1234 | |
---|
1235 | set val . |
---|
1236 | set error {} |
---|
1237 | if {[catch { |
---|
1238 | set val [expr ${a2}.${a3} * pow(10,$exp)] |
---|
1239 | if {$err != ""} { |
---|
1240 | set error [expr $err*pow(10,$exp-$l)] |
---|
1241 | } |
---|
1242 | }]} { |
---|
1243 | # something above was invalid |
---|
1244 | if {$err != ""} { |
---|
1245 | return "$val ." |
---|
1246 | } else { |
---|
1247 | return $val |
---|
1248 | } |
---|
1249 | } |
---|
1250 | if {$error == ""} { |
---|
1251 | return $val |
---|
1252 | } else { |
---|
1253 | return [list $val $error] |
---|
1254 | } |
---|
1255 | } |
---|
1256 | |
---|
1257 | # a stand-alone routine for testing: Select, read and browse a CIF |
---|
1258 | proc Read_BrowseCIF {} { |
---|
1259 | global tcl_platform |
---|
1260 | if {$tcl_platform(platform) == "windows"} { |
---|
1261 | set filetypelist { |
---|
1262 | {"CIF files" .CIF} {"All files" *} |
---|
1263 | } |
---|
1264 | } else { |
---|
1265 | set filetypelist { |
---|
1266 | {"CIF files" .CIF} {"CIF files" .cif} {"All files" *} |
---|
1267 | } |
---|
1268 | } |
---|
1269 | set file [tk_getOpenFile -parent . -filetypes $filetypelist] |
---|
1270 | if {$file == ""} return |
---|
1271 | if {![file exists $file]} return |
---|
1272 | pleasewait "Reading CIF from file" |
---|
1273 | set blocks [ParseCIF $file] |
---|
1274 | if {$blocks == ""} { |
---|
1275 | donewait |
---|
1276 | MessageBox -parent . -type ok -icon warning \ |
---|
1277 | -message "Note: no valid CIF blocks were read from file $filename" |
---|
1278 | return |
---|
1279 | } |
---|
1280 | catch {donewait} |
---|
1281 | set allblocks {} |
---|
1282 | for {set i 1} {$i <= $blocks} {incr i} { |
---|
1283 | lappend allblocks $i |
---|
1284 | } |
---|
1285 | if {$allblocks != ""} { |
---|
1286 | BrowseCIF $allblocks "" .cif |
---|
1287 | # wait for the window to close |
---|
1288 | tkwait window .cif |
---|
1289 | } else { |
---|
1290 | puts "no blocks read" |
---|
1291 | } |
---|
1292 | # clean up -- get rid of the CIF arrays |
---|
1293 | for {set i 1} {$i <= $blocks} {incr i} { |
---|
1294 | global block$i |
---|
1295 | catch {unset block$i} |
---|
1296 | } |
---|
1297 | } |
---|
1298 | |
---|
1299 | # this takes a block of text, strips off the quotes ("", '', [] or ;;) |
---|
1300 | proc StripQuotes {value} { |
---|
1301 | set value [string trim $value] |
---|
1302 | if {[string range $value end-1 end] == "\n;" && \ |
---|
1303 | [string range $value 0 0] == ";"} { |
---|
1304 | return [string range $value 1 end-2] |
---|
1305 | } elseif {[string range $value end end] == "\"" && \ |
---|
1306 | [string range $value 0 0] == "\""} { |
---|
1307 | set value [string range $value 1 end-1] |
---|
1308 | } elseif {[string range $value end end] == "'" && \ |
---|
1309 | [string range $value 0 0] == "'"} { |
---|
1310 | set value [string range $value 1 end-1] |
---|
1311 | } elseif {[string range $value end end] == {]} && \ |
---|
1312 | [string range $value 0 0] == {[}} { |
---|
1313 | set value [string range $value 1 end-1] |
---|
1314 | } |
---|
1315 | return $value |
---|
1316 | } |
---|
1317 | |
---|
1318 | # replace a CIF value in with a new value. |
---|
1319 | # add newlines as needed to make sure the new value does not |
---|
1320 | # exceed CIF(maxlinelength) [defaults to 80] characters/line |
---|
1321 | proc ReplaceMarkedText {txt mark value} { |
---|
1322 | $txt configure -state normal |
---|
1323 | # is this a multi-line string? |
---|
1324 | set num [string first \n $value] |
---|
1325 | set l [string length $value] |
---|
1326 | # are there spaces in the string? |
---|
1327 | set spaces [string first " " $value] |
---|
1328 | # if no, are there any square brackets? -- treat them as requiring quotes |
---|
1329 | if {$spaces == -1} {set spaces [string first {[} $value]} |
---|
1330 | # are there any reserved strings inside $value? If so, it must be quoted |
---|
1331 | if {$spaces == -1} { |
---|
1332 | set tmp [string toupper $value] |
---|
1333 | foreach s {DATA_ LOOP_ SAVE_ STOP_ GLOBAL_} { |
---|
1334 | if {[set spaces [string first $s $tmp]] != -1} break |
---|
1335 | } |
---|
1336 | } |
---|
1337 | # are there quotes inside the string? |
---|
1338 | set doublequote [string first "\"" $value] |
---|
1339 | set singlequote [string first {'} $value] |
---|
1340 | # if we have either type of quotes, use semicolon quoting |
---|
1341 | if {$singlequote != -1 && $doublequote != -1} {set num $l} |
---|
1342 | |
---|
1343 | # lines longer than 78 characters with spaces need to be treated |
---|
1344 | # as multiline |
---|
1345 | if {$num == -1 && $l > 77 && $spaces != -1} { |
---|
1346 | set num $l |
---|
1347 | } |
---|
1348 | if {$num != -1} { |
---|
1349 | set tmp {} |
---|
1350 | if {[lindex [split [$txt index $mark.l] .] 1] != 0} { |
---|
1351 | append tmp \n |
---|
1352 | } |
---|
1353 | append tmp ";" |
---|
1354 | if {$num > 78} { |
---|
1355 | append tmp \n |
---|
1356 | } else { |
---|
1357 | append tmp " " |
---|
1358 | } |
---|
1359 | append tmp $value "\n;" |
---|
1360 | # is there something else on the line? |
---|
1361 | set restofline [$txt get $mark.r [lindex [split [$txt index $mark.r] .] 0].end] |
---|
1362 | if {[string trim $restofline] != ""} { |
---|
1363 | append tmp \n |
---|
1364 | } |
---|
1365 | $txt delete ${mark}.l ${mark}.r |
---|
1366 | $txt insert ${mark}.l $tmp |
---|
1367 | $txt configure -state disabled |
---|
1368 | return |
---|
1369 | } elseif {($spaces != -1 || [string trim $value] == "") \ |
---|
1370 | && $doublequote == -1} { |
---|
1371 | # use doublequotes, unless doublequotes are present inside the string |
---|
1372 | set tmp "\"" |
---|
1373 | append tmp $value "\"" |
---|
1374 | } elseif {$spaces != -1 || [string trim $value] == ""} { |
---|
1375 | # use single quotes, since doublequotes are present inside the string |
---|
1376 | set tmp {'} |
---|
1377 | append tmp $value {'} |
---|
1378 | } else { |
---|
1379 | # no quotes needed |
---|
1380 | set tmp $value |
---|
1381 | } |
---|
1382 | # is there room on the beginning of the line to add the string? |
---|
1383 | set l [string length $tmp] |
---|
1384 | set pos [lindex [split [$txt index $mark.l] .] 0] |
---|
1385 | if {$l + [string length [$txt get $pos.0 $mark.l]] <= 79} { |
---|
1386 | # will fit |
---|
1387 | $txt delete ${mark}.l ${mark}.r |
---|
1388 | $txt insert ${mark}.l $tmp |
---|
1389 | } else { |
---|
1390 | # no, stick a CR in front of string |
---|
1391 | $txt delete ${mark}.l ${mark}.r |
---|
1392 | $txt insert ${mark}.l \n$tmp |
---|
1393 | } |
---|
1394 | # is rest of the line after the inserted string still too long? |
---|
1395 | set pos [lindex [split [$txt index $mark.r] .] 0] |
---|
1396 | if {[string length [$txt get $pos.0 $pos.end]] > 79} { |
---|
1397 | $txt insert $mark.r \n |
---|
1398 | } |
---|
1399 | $txt configure -state disabled |
---|
1400 | } |
---|
1401 | |
---|
1402 | # return the dictionary definition for a list of CIF data names |
---|
1403 | proc GetCIFDefinitions {datanamelist} { |
---|
1404 | global CIF_dataname_index |
---|
1405 | set l {} |
---|
1406 | # compile a list of definition pointers |
---|
1407 | foreach dataname $datanamelist { |
---|
1408 | set pointer {} |
---|
1409 | catch { |
---|
1410 | set pointer [lindex $CIF_dataname_index($dataname) 0] |
---|
1411 | } |
---|
1412 | lappend l [list $dataname $pointer] |
---|
1413 | } |
---|
1414 | set l [lsort -index 1 $l] |
---|
1415 | set pp {} |
---|
1416 | set dictdefs {} |
---|
1417 | set def {start} |
---|
1418 | set nlist {} |
---|
1419 | # merge items with duplicate definitions |
---|
1420 | foreach item $l { |
---|
1421 | # is this the first loop through? |
---|
1422 | foreach {dataname pointer} $item {} |
---|
1423 | if {$def == "start"} { |
---|
1424 | foreach {nlist pp} $item {} |
---|
1425 | set def [ReadCIFDefinition $pp] |
---|
1426 | } elseif {$pp == $pointer} { |
---|
1427 | # same as last |
---|
1428 | lappend nlist $dataname |
---|
1429 | } else { |
---|
1430 | # add the last entry to the list |
---|
1431 | set file [lindex $pp 0] |
---|
1432 | set pp $pointer |
---|
1433 | lappend dictdefs [list $nlist $def $file] |
---|
1434 | set nlist $dataname |
---|
1435 | if {$pointer == ""} { |
---|
1436 | set def { Undefined dataname} |
---|
1437 | } else { |
---|
1438 | # lookup name |
---|
1439 | set def [ReadCIFDefinition $pointer] |
---|
1440 | } |
---|
1441 | } |
---|
1442 | } |
---|
1443 | set file [lindex $pointer 0] |
---|
1444 | lappend dictdefs [list $nlist $def $file] |
---|
1445 | return $dictdefs |
---|
1446 | } |
---|
1447 | |
---|
1448 | # read the CIF definition for a dataname. The pointer contains 3 values |
---|
1449 | # a filename, the number of characters from the start of the file and |
---|
1450 | # the length of the definition. |
---|
1451 | proc ReadCIFDefinition {pointer} { |
---|
1452 | global CIF CIF_file_paths |
---|
1453 | set file {} |
---|
1454 | set loc {} |
---|
1455 | set line {} |
---|
1456 | foreach {file loc len} $pointer {} |
---|
1457 | if {$file != "" && $loc != "" && $loc != ""} { |
---|
1458 | set fp {} |
---|
1459 | if {[array names CIF_file_paths $file] != ""} { |
---|
1460 | catch {set fp [open $CIF_file_paths($file) r]} |
---|
1461 | if {$fp == ""} return |
---|
1462 | } elseif {[array names CIF_file_paths] != ""} { |
---|
1463 | return |
---|
1464 | } else { |
---|
1465 | # support legacy applications using CIF(cif_path) |
---|
1466 | foreach path $CIF(cif_path) { |
---|
1467 | catch {set fp [open [file join $path $file] r]} |
---|
1468 | if {$fp != ""} break |
---|
1469 | } |
---|
1470 | } |
---|
1471 | if {$fp == ""} return |
---|
1472 | fconfigure $fp -translation binary |
---|
1473 | catch { |
---|
1474 | seek $fp $loc |
---|
1475 | set line [read $fp $len] |
---|
1476 | close $fp |
---|
1477 | # remove line ends & superfluous spaces |
---|
1478 | regsub -all {\n} [StripQuotes $line] { } line |
---|
1479 | regsub -all {\r} $line { } line |
---|
1480 | regsub -all { +} $line { } line |
---|
1481 | # regsub -all { +} [StripQuotes $line] { } line |
---|
1482 | } |
---|
1483 | } |
---|
1484 | return $line |
---|
1485 | } |
---|
1486 | |
---|
1487 | proc ValidateCIFName {dataname} { |
---|
1488 | global CIF_dataname_index |
---|
1489 | if {[ |
---|
1490 | catch { |
---|
1491 | set CIF_dataname_index($dataname) |
---|
1492 | } |
---|
1493 | ]} {return "warning: dataname $dataname not defined"} |
---|
1494 | } |
---|
1495 | |
---|
1496 | # validates that a CIF value is valid for a specific dataname |
---|
1497 | proc ValidateCIFItem {dataname item} { |
---|
1498 | global CIF_dataname_index CIF |
---|
1499 | # maximum line length |
---|
1500 | set maxlinelength 80 |
---|
1501 | catch {set maxlinelength $CIF(maxlinelength)} |
---|
1502 | if {[catch { |
---|
1503 | foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {} |
---|
1504 | }]} {return} |
---|
1505 | if {$type == "c"} { |
---|
1506 | # string type constant |
---|
1507 | set item [StripQuotes $item] |
---|
1508 | # is it enumerated? |
---|
1509 | if {$elist != ""} { |
---|
1510 | # check it against the list of values |
---|
1511 | foreach i [concat $elist . ?] { |
---|
1512 | if {[string tolower $item] == [string tolower [lindex $i 0]]} {return} |
---|
1513 | } |
---|
1514 | return "error: value \"$item\" is not an allowed option for $dataname" |
---|
1515 | } else { |
---|
1516 | # check it for line lengths |
---|
1517 | set l 0 |
---|
1518 | set err {} |
---|
1519 | foreach line [split $item \n] { |
---|
1520 | incr l |
---|
1521 | if {[string length $line] > $maxlinelength} {lappend err $l} |
---|
1522 | } |
---|
1523 | if {$err != ""} {return "error: line(s) $err are too long"} |
---|
1524 | } |
---|
1525 | return |
---|
1526 | } elseif {$type == ""} { |
---|
1527 | return "error: dataname $dataname is not used for CIF data items" |
---|
1528 | } elseif {$type == "n"} { |
---|
1529 | # validate numbers |
---|
1530 | set unquoted [StripQuotes $item] |
---|
1531 | if {$unquoted == "?" || $unquoted == "."} return |
---|
1532 | if {$unquoted != $item} { |
---|
1533 | set err "\nwarning: number $item is quoted for $dataname" |
---|
1534 | set item $unquoted |
---|
1535 | } else { |
---|
1536 | set err {} |
---|
1537 | } |
---|
1538 | set v $item |
---|
1539 | # remove s.u., if allowed & present |
---|
1540 | set vals [ParseSU $item] |
---|
1541 | if {[set v [lindex $vals 0]] == "."} { |
---|
1542 | return "error: value \"$item\" is not a valid number for $dataname$err" |
---|
1543 | } |
---|
1544 | if {$esd} { |
---|
1545 | if {[lindex $vals 1] == "."} { |
---|
1546 | return "error: value \"$item\" for $dataname has an invalid uncertainty (esd)$err" |
---|
1547 | } |
---|
1548 | } elseif {[llength $vals] == 2} { |
---|
1549 | return "error: \"$item\" is invalid for $dataname, an uncertainty (esd) is not allowed$err" |
---|
1550 | } |
---|
1551 | |
---|
1552 | # now validate the range |
---|
1553 | if {$range != ""} { |
---|
1554 | # is there a decimal point in the range? |
---|
1555 | set integer 0 |
---|
1556 | if {[string first . $range] == -1} {set integer 1} |
---|
1557 | # pull out the range |
---|
1558 | foreach {min max} [split $range :] {} |
---|
1559 | if {$integer && int($v) != $v} { |
---|
1560 | return "warning: value \"$item\" is expected to be an integer for $dataname$err" |
---|
1561 | } |
---|
1562 | if {$min != ""} { |
---|
1563 | if {$v < $min} { |
---|
1564 | return "error: value \"$item\" is too small for $dataname (allowed range $range)$err" |
---|
1565 | } |
---|
1566 | } |
---|
1567 | if {$max != ""} { |
---|
1568 | if {$v > $max} { |
---|
1569 | return "error: value \"$item\" is too big for $dataname(allowed range $range)$err" |
---|
1570 | } |
---|
1571 | } |
---|
1572 | } |
---|
1573 | return $err |
---|
1574 | } |
---|
1575 | return {} |
---|
1576 | } |
---|
1577 | |
---|
1578 | # displays the dictionary definitions in variable defs into a text widget |
---|
1579 | proc ShowDictionaryDefinition {defs} { |
---|
1580 | global CIF |
---|
1581 | set deflist [GetCIFDefinitions $defs] |
---|
1582 | catch { |
---|
1583 | $CIF(defBox) delete 1.0 end |
---|
1584 | foreach d $deflist { |
---|
1585 | foreach {namelist definition file} $d {} |
---|
1586 | foreach n $namelist { |
---|
1587 | $CIF(defBox) insert end $n dataname |
---|
1588 | $CIF(defBox) insert end \n |
---|
1589 | } |
---|
1590 | $CIF(defBox) insert end \n |
---|
1591 | if {$definition == ""} { |
---|
1592 | $CIF(defBox) insert end "No definition found\n\n" |
---|
1593 | } else { |
---|
1594 | $CIF(defBox) insert end $definition |
---|
1595 | $CIF(defBox) insert end "\n\[$file\]\n\n" |
---|
1596 | } |
---|
1597 | |
---|
1598 | } |
---|
1599 | $CIF(defBox) tag config dataname -background yellow |
---|
1600 | } |
---|
1601 | } |
---|
1602 | |
---|
1603 | # create a widget to display a CIF value |
---|
1604 | proc DisplayCIFvalue {widget dataname loopval value block "row 0"} { |
---|
1605 | global CIFeditArr CIFinfoArr |
---|
1606 | global CIF CIF_dataname_index |
---|
1607 | if {[ |
---|
1608 | catch { |
---|
1609 | foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {} |
---|
1610 | } |
---|
1611 | ]} { |
---|
1612 | set type c |
---|
1613 | set elist {} |
---|
1614 | } |
---|
1615 | |
---|
1616 | lappend CIF(widgetlist) $widget |
---|
1617 | set CIFinfoArr($widget) {} |
---|
1618 | |
---|
1619 | if $CIF(editmode) { |
---|
1620 | if {$loopval != ""} { |
---|
1621 | set widgetinfo [list $dataname $block [expr $loopval -1]] |
---|
1622 | } else { |
---|
1623 | set widgetinfo [list $dataname $block 0] |
---|
1624 | } |
---|
1625 | set CIFeditArr($widget) $value |
---|
1626 | set CIFinfoArr($widget) $widgetinfo |
---|
1627 | |
---|
1628 | if {$type == "n"} { |
---|
1629 | entry $widget -justify left -textvariable CIFeditArr($widget) |
---|
1630 | bind $widget <Leave> "CheckChanges $widget" |
---|
1631 | grid $widget -sticky nsw -column 1 -row $row |
---|
1632 | if {$units != ""} { |
---|
1633 | set ws "${widget}u" |
---|
1634 | label $ws -text "($units)" -bg yellow |
---|
1635 | grid $ws -sticky nsw -column 2 -row $row |
---|
1636 | } |
---|
1637 | } elseif {$elist != ""} { |
---|
1638 | set enum {} |
---|
1639 | foreach e $elist { |
---|
1640 | lappend enum [lindex $e 0] |
---|
1641 | } |
---|
1642 | tk_optionMenu $widget CIFeditArr($widget) "" |
---|
1643 | FixBigOptionMenu $widget $enum "CheckChanges $widget" |
---|
1644 | AddSpecialEnumOpts $widget "CheckChanges $widget" |
---|
1645 | grid $widget -sticky nsw -column 1 -row $row |
---|
1646 | } else { |
---|
1647 | # count the number of lines in the text |
---|
1648 | set nlines [llength [split $value \n]] |
---|
1649 | if {$nlines < 1} { |
---|
1650 | set nlines 1 |
---|
1651 | } elseif {$nlines > 10} { |
---|
1652 | set nlines 10 |
---|
1653 | } |
---|
1654 | set ws "${widget}s" |
---|
1655 | text $widget -height $nlines -width 80 -yscrollcommand "$ws set" |
---|
1656 | scrollbar $ws -command "$widget yview" -width 10 -bd 1 |
---|
1657 | $widget insert end $value |
---|
1658 | bind $widget <Leave> "CheckChanges $widget" |
---|
1659 | if {$nlines > 1} { |
---|
1660 | grid $ws -sticky nsew -column 1 -row $row |
---|
1661 | grid $widget -sticky nsew -column 2 -row $row |
---|
1662 | } else { |
---|
1663 | grid $widget -sticky nsew -column 1 -columnspan 2 -row $row |
---|
1664 | } |
---|
1665 | } |
---|
1666 | } else { |
---|
1667 | label $widget -bd 2 -relief groove \ |
---|
1668 | -justify left -anchor w -text $value |
---|
1669 | grid $widget -sticky nsw -column 1 -row $row |
---|
1670 | if {$type == "n" && $units != ""} { |
---|
1671 | set ws "${widget}u" |
---|
1672 | label $ws -text "($units)" -bg yellow |
---|
1673 | grid $ws -sticky nsw -column 2 -row $row |
---|
1674 | } |
---|
1675 | } |
---|
1676 | } |
---|
1677 | |
---|
1678 | # this is called to see if the user has changed the value for a CIF |
---|
1679 | # data item and to validate it. |
---|
1680 | # save the change if $save is 1 |
---|
1681 | # return 1 if the widget contents has changed |
---|
1682 | proc CheckChanges {widget "save 0"} { |
---|
1683 | global CIFeditArr CIFinfoArr CIF |
---|
1684 | # maximum line length |
---|
1685 | set maxlinelength 80 |
---|
1686 | catch {set maxlinelength $CIF(maxlinelength)} |
---|
1687 | |
---|
1688 | set CIF(errormsg) {} |
---|
1689 | |
---|
1690 | if {![winfo exists $widget]} return |
---|
1691 | |
---|
1692 | set dataname {} |
---|
1693 | catch { |
---|
1694 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1695 | } |
---|
1696 | # if this widget is a label, the info above will not be defined & checks are not needed |
---|
1697 | if {$dataname == ""} {return 0} |
---|
1698 | if {$dataname == "Parse-errors"} {return 0} |
---|
1699 | if {$dataname == "Validation-errors"} {return 0} |
---|
1700 | |
---|
1701 | global ${block} |
---|
1702 | set mark [lindex [set ${block}($dataname)] $index] |
---|
1703 | if {$mark == ""} return |
---|
1704 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1705 | |
---|
1706 | # validate the entry |
---|
1707 | set error {} |
---|
1708 | set err {} |
---|
1709 | switch [winfo class $widget] { |
---|
1710 | Text { |
---|
1711 | set current [string trim [$widget get 1.0 end]] |
---|
1712 | set l 0 |
---|
1713 | foreach line [set linelist [split $current \n]] { |
---|
1714 | incr l |
---|
1715 | if {[string length $line] > $maxlinelength} { |
---|
1716 | lappend err $l |
---|
1717 | lappend error "Error: line $l for $dataname is >$maxlinelength characters" |
---|
1718 | } |
---|
1719 | } |
---|
1720 | if {$err != ""} { |
---|
1721 | foreach l $err { |
---|
1722 | $widget tag add error $l.0 $l.end |
---|
1723 | } |
---|
1724 | $widget tag config error -foreground red |
---|
1725 | } else { |
---|
1726 | $widget tag delete error |
---|
1727 | } |
---|
1728 | # see if box should expand |
---|
1729 | set clines [$widget cget -height] |
---|
1730 | if {$clines <= 2 && \ |
---|
1731 | [string trim $orig] != [string trim $current]} { |
---|
1732 | # count the number of lines in the text |
---|
1733 | set nlines [llength $linelist] |
---|
1734 | if {[lindex $linelist end] == ""} {incr nlines -1} |
---|
1735 | if {$nlines == 2} { |
---|
1736 | $widget config -height 2 |
---|
1737 | } elseif {$nlines > 2} { |
---|
1738 | set i [lsearch [set s [grid info $widget]] -row] |
---|
1739 | set row [lindex $s [expr 1+$i]] |
---|
1740 | $widget config -height 3 |
---|
1741 | set ws "${widget}s" |
---|
1742 | grid $ws -sticky nsew -column 1 -row $row |
---|
1743 | grid $widget -sticky nsew -column 2 -row $row |
---|
1744 | } |
---|
1745 | } |
---|
1746 | } |
---|
1747 | Entry { |
---|
1748 | set current [string trim [$widget get]] |
---|
1749 | set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current] |
---|
1750 | if {$err != "" && \ |
---|
1751 | [string tolower [lindex $err 0]] != "warning:"} { |
---|
1752 | lappend error $err |
---|
1753 | $widget config -fg red |
---|
1754 | } else { |
---|
1755 | $widget config -fg black |
---|
1756 | } |
---|
1757 | } |
---|
1758 | Menubutton { |
---|
1759 | set current $CIFeditArr($widget) |
---|
1760 | } |
---|
1761 | Label { |
---|
1762 | return 0 |
---|
1763 | } |
---|
1764 | } |
---|
1765 | if {[string trim $orig] != [string trim $current]} { |
---|
1766 | if {$err != ""} { |
---|
1767 | set CIF(errormsg) $error |
---|
1768 | } elseif {$save} { |
---|
1769 | SaveCIFedits $widget |
---|
1770 | return 0 |
---|
1771 | } |
---|
1772 | return 1 |
---|
1773 | } |
---|
1774 | return 0 |
---|
1775 | } |
---|
1776 | |
---|
1777 | # save the CIF edits into the CIF text widget |
---|
1778 | proc SaveCIFedits {widget} { |
---|
1779 | global CIFeditArr CIFinfoArr CIF |
---|
1780 | |
---|
1781 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1782 | global ${block} |
---|
1783 | set mark [lindex [set ${block}($dataname)] $index] |
---|
1784 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1785 | switch [winfo class $widget] { |
---|
1786 | Text { |
---|
1787 | set current [string trim [$widget get 1.0 end]] |
---|
1788 | } |
---|
1789 | Entry { |
---|
1790 | set current [string trim [$widget get]] |
---|
1791 | } |
---|
1792 | Menubutton { |
---|
1793 | set current $CIFeditArr($widget) |
---|
1794 | } |
---|
1795 | } |
---|
1796 | # save for undo & clear the redo list |
---|
1797 | set CIF(redolist) {} |
---|
1798 | if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} { |
---|
1799 | lappend CIF(undolist) [list $mark $orig \ |
---|
1800 | $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)] |
---|
1801 | } else { |
---|
1802 | lappend CIF(undolist) [list $mark $orig \ |
---|
1803 | $CIF(lastShownItem) $CIF(lastShownTreeID)] |
---|
1804 | } |
---|
1805 | # count it |
---|
1806 | incr CIF(changes) |
---|
1807 | # make the change |
---|
1808 | ReplaceMarkedText $CIF(txt) $mark $current |
---|
1809 | } |
---|
1810 | |
---|
1811 | # add a new "row" to a CIF loop. At least for now, we only add at the end. |
---|
1812 | proc AddToCIFloop {block loop} { |
---|
1813 | global $block CIF |
---|
1814 | # check for unsaved changes here |
---|
1815 | if {[CheckForCIFEdits]} return |
---|
1816 | |
---|
1817 | $CIF(txt) configure -state normal |
---|
1818 | set looplist [set ${block}($loop)] |
---|
1819 | set length [llength [set ${block}([lindex $looplist 0])]] |
---|
1820 | # find the line following the last entry in the list |
---|
1821 | set var [lindex $looplist end] |
---|
1822 | set line [lindex [split [\ |
---|
1823 | $CIF(txt) index [lindex [set ${block}($var)] end].r \ |
---|
1824 | ] .] 0] |
---|
1825 | incr line |
---|
1826 | set epos $line.0 |
---|
1827 | $CIF(txt) insert $epos \n |
---|
1828 | |
---|
1829 | # insert a ? token for each entry & add to marker list for each variable |
---|
1830 | set addlist {} |
---|
1831 | foreach var $looplist { |
---|
1832 | # go to next line? |
---|
1833 | if {[string length \ |
---|
1834 | [$CIF(txt) get "$epos linestart" "$epos lineend"]\ |
---|
1835 | ] > 78} { |
---|
1836 | $CIF(txt) insert $epos \n |
---|
1837 | set epos [$CIF(txt) index "$epos + 1c"] |
---|
1838 | } |
---|
1839 | $CIF(txt) insert $epos "? " |
---|
1840 | incr CIF(markcount) |
---|
1841 | $CIF(txt) mark set $CIF(markcount).l "$epos" |
---|
1842 | $CIF(txt) mark set $CIF(markcount).r "$epos + 1c" |
---|
1843 | $CIF(txt) mark gravity $CIF(markcount).l left |
---|
1844 | $CIF(txt) mark gravity $CIF(markcount).r right |
---|
1845 | set epos [$CIF(txt) index "$epos + 2c"] |
---|
1846 | set index [llength [set ${block}($var)]] |
---|
1847 | lappend ${block}($var) $CIF(markcount) |
---|
1848 | lappend addlist [list $CIF(markcount) $var $index $block] |
---|
1849 | } |
---|
1850 | incr CIF(changes) |
---|
1851 | lappend CIF(undolist) [list "loop add" $addlist \ |
---|
1852 | $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)] |
---|
1853 | set CIF(redolist) {} |
---|
1854 | |
---|
1855 | # now show the value we have added |
---|
1856 | set frame [$CIF(displayFrame) getframe] |
---|
1857 | set max [lindex [$CIF(LoopSpinBox) cget -range] 1] |
---|
1858 | incr max |
---|
1859 | $CIF(LoopSpinBox) configure -range "1 $max 1" |
---|
1860 | $CIF(LoopSpinBox) setvalue last |
---|
1861 | ShowLoopVar $block $loop |
---|
1862 | $CIF(txt) configure -state disabled |
---|
1863 | $CIF(DeleteLoopEntry) configure -state normal |
---|
1864 | } |
---|
1865 | |
---|
1866 | proc DeleteCIFRow {} { |
---|
1867 | global CIF |
---|
1868 | global CIFinfoArr CIFeditArr |
---|
1869 | |
---|
1870 | set delrow [$CIF(LoopSpinBox) getvalue] |
---|
1871 | |
---|
1872 | set msg {Are you sure you want to delete the following loop entries} |
---|
1873 | append msg " (row number [expr 1+$delrow])?\n" |
---|
1874 | set widget "" |
---|
1875 | foreach widget $CIF(widgetlist) { |
---|
1876 | set var [lindex $CIFinfoArr($widget) 0] |
---|
1877 | append msg "\n$var\n\t" |
---|
1878 | # get the value |
---|
1879 | switch [winfo class $widget] { |
---|
1880 | Text { |
---|
1881 | set value [string trim [$widget get 1.0 end]] |
---|
1882 | } |
---|
1883 | Entry { |
---|
1884 | set value [string trim [$widget get]] |
---|
1885 | } |
---|
1886 | Menubutton { |
---|
1887 | set value $CIFeditArr($widget) |
---|
1888 | } |
---|
1889 | } |
---|
1890 | append msg $value \n |
---|
1891 | } |
---|
1892 | if {$widget == ""} { |
---|
1893 | error "this should not happen" |
---|
1894 | } |
---|
1895 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1896 | global $block |
---|
1897 | if {[llength [set ${block}($dataname)]] == 1} { |
---|
1898 | MyMessageBox -parent . -title "Not only row" \ |
---|
1899 | -message {Sorry, this program is unable to delete all entries from a loop.} \ |
---|
1900 | -icon warning -type {Ignore} -default Ignore |
---|
1901 | return |
---|
1902 | } |
---|
1903 | |
---|
1904 | set ans [MyMessageBox -parent . -title "Delete Row?" \ |
---|
1905 | -message $msg \ |
---|
1906 | -icon question -type {Keep Delete} -default Keep] |
---|
1907 | if {$ans == "keep"} {return} |
---|
1908 | |
---|
1909 | $CIF(txt) configure -state normal |
---|
1910 | set deletelist {} |
---|
1911 | foreach widget $CIF(widgetlist) { |
---|
1912 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1913 | global $block |
---|
1914 | set mark [lindex [set ${block}($dataname)] $index] |
---|
1915 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1916 | lappend deletelist [list $mark $dataname $index $block $orig] |
---|
1917 | $CIF(txt) delete $mark.l $mark.r |
---|
1918 | set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index] |
---|
1919 | } |
---|
1920 | set CIF(redolist) {} |
---|
1921 | lappend CIF(undolist) [list "loop delete" $deletelist \ |
---|
1922 | $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)] |
---|
1923 | # count it |
---|
1924 | incr CIF(changes) |
---|
1925 | |
---|
1926 | $CIF(txt) configure -state disabled |
---|
1927 | |
---|
1928 | set max [lindex [$CIF(LoopSpinBox) cget -range] 1] |
---|
1929 | incr max -1 |
---|
1930 | $CIF(LoopSpinBox) configure -range "1 $max 1" |
---|
1931 | if {$index >= $max} {set index $max; incr index -1} |
---|
1932 | $CIF(LoopSpinBox) setvalue @$index |
---|
1933 | if {$max == 1} {$CIF(DeleteLoopEntry) configure -state disabled} |
---|
1934 | # don't check for changes |
---|
1935 | set CIF(lastLoopIndex) {} |
---|
1936 | ShowLoopVar $block [lindex $CIF(lastShownItem) 1] |
---|
1937 | } |
---|
1938 | |
---|
1939 | # display & highlight a line in the CIF text viewer |
---|
1940 | proc MarkGotoLine {line} { |
---|
1941 | global CIF |
---|
1942 | $CIF(txt) tag delete currentline |
---|
1943 | $CIF(txt) tag add currentline $line.0 $line.end |
---|
1944 | $CIF(txt) tag configure currentline -foreground blue |
---|
1945 | $CIF(txt) see $line.0 |
---|
1946 | } |
---|
1947 | |
---|
1948 | # Extract a value from a CIF in the CIF text viewer |
---|
1949 | proc ValueFromCIF {block item} { |
---|
1950 | global $block CIF |
---|
1951 | set val {} |
---|
1952 | catch { |
---|
1953 | set mark [set ${block}($item)] |
---|
1954 | if {[llength $mark] == 1} { |
---|
1955 | set val [string trim [StripQuotes [$CIF(txt) get $mark.l $mark.r]]] |
---|
1956 | } else { |
---|
1957 | foreach m $mark { |
---|
1958 | lappend val [string trim [StripQuotes [$CIF(txt) get $m.l $m.r]]] |
---|
1959 | } |
---|
1960 | } |
---|
1961 | } |
---|
1962 | return $val |
---|
1963 | } |
---|
1964 | |
---|
1965 | proc UndoChanges {} { |
---|
1966 | global CIF |
---|
1967 | # save any current changes, if possible |
---|
1968 | if {[CheckForCIFEdits]} return |
---|
1969 | # are there edits to undo? |
---|
1970 | if {[llength $CIF(undolist)] == 0} return |
---|
1971 | |
---|
1972 | foreach {mark orig lastShownItem lastShownTreeID lastLoopIndex} \ |
---|
1973 | [lindex $CIF(undolist) end] {} |
---|
1974 | |
---|
1975 | if {[llength $mark] == 1} { |
---|
1976 | # get the edited value |
---|
1977 | set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1978 | # make the change back |
---|
1979 | ReplaceMarkedText $CIF(txt) $mark $orig |
---|
1980 | # add this undo to the redo list |
---|
1981 | lappend CIF(redolist) [list $mark $edited $lastShownItem \ |
---|
1982 | $lastShownTreeID $lastLoopIndex] |
---|
1983 | } elseif {[lindex $mark 1] == "add"} { |
---|
1984 | set deletelist {} |
---|
1985 | $CIF(txt) configure -state normal |
---|
1986 | foreach m $orig { |
---|
1987 | foreach {mark dataname index block} $m {} |
---|
1988 | # get the inserted value |
---|
1989 | set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1990 | $CIF(txt) delete $mark.l $mark.r |
---|
1991 | lappend deletelist [list $mark $dataname $index $block $edited] |
---|
1992 | global $block |
---|
1993 | set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index] |
---|
1994 | } |
---|
1995 | $CIF(txt) configure -state disabled |
---|
1996 | # add this action to the redo list |
---|
1997 | lappend CIF(redolist) [list "loop delete" $deletelist \ |
---|
1998 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
1999 | } elseif {[lindex $mark 1] == "delete"} { |
---|
2000 | set addlist {} |
---|
2001 | foreach m $orig { |
---|
2002 | foreach {mark dataname index block orig} $m {} |
---|
2003 | # make the change back |
---|
2004 | ReplaceMarkedText $CIF(txt) $mark $orig |
---|
2005 | lappend addlist [list $mark $dataname $index $block] |
---|
2006 | global $block |
---|
2007 | set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark] |
---|
2008 | } |
---|
2009 | # show the entry that was added |
---|
2010 | set lastLoopIndex $index |
---|
2011 | # add this last entry to the redo list |
---|
2012 | lappend CIF(redolist) [list "loop add" $addlist \ |
---|
2013 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
2014 | } |
---|
2015 | |
---|
2016 | # drop the action from the undo list |
---|
2017 | set CIF(undolist) [lreplace $CIF(undolist) end end] |
---|
2018 | # count back |
---|
2019 | incr CIF(changes) -1 |
---|
2020 | # scroll on the tree |
---|
2021 | $CIF(tree) see $lastShownTreeID |
---|
2022 | eval showCIFbyDataname $lastShownItem |
---|
2023 | |
---|
2024 | # if we are in a loop, display the element |
---|
2025 | if {[lindex [lindex $lastShownItem 0] 1] == "loop"} { |
---|
2026 | $CIF(LoopSpinBox) setvalue @$lastLoopIndex |
---|
2027 | ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \ |
---|
2028 | [lindex $lastShownItem 1] |
---|
2029 | } |
---|
2030 | } |
---|
2031 | |
---|
2032 | |
---|
2033 | proc RedoChanges {} { |
---|
2034 | global CIF |
---|
2035 | # save any current changes, if possible |
---|
2036 | if {[CheckForCIFEdits]} return |
---|
2037 | # are there edits to redo? |
---|
2038 | if {[llength $CIF(redolist)] == 0} return |
---|
2039 | |
---|
2040 | foreach {mark edited lastShownItem lastShownTreeID lastLoopIndex} \ |
---|
2041 | [lindex $CIF(redolist) end] {} |
---|
2042 | |
---|
2043 | if {[llength $mark] == 1} { |
---|
2044 | # get the edited value |
---|
2045 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
2046 | # make the change back |
---|
2047 | ReplaceMarkedText $CIF(txt) $mark $edited |
---|
2048 | # add this action back to the undo list |
---|
2049 | lappend CIF(undolist) [list $mark $orig $lastShownItem \ |
---|
2050 | $lastShownTreeID $lastLoopIndex] |
---|
2051 | # count up |
---|
2052 | incr CIF(changes) |
---|
2053 | } elseif {[lindex $mark 1] == "add"} { |
---|
2054 | set deletelist {} |
---|
2055 | $CIF(txt) configure -state normal |
---|
2056 | foreach m $edited { |
---|
2057 | foreach {mark dataname index block} $m {} |
---|
2058 | # get the inserted value |
---|
2059 | set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
2060 | $CIF(txt) delete $mark.l $mark.r |
---|
2061 | lappend deletelist [list $mark $dataname $index $block $edited] |
---|
2062 | global $block |
---|
2063 | set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index] |
---|
2064 | } |
---|
2065 | $CIF(txt) configure -state disabled |
---|
2066 | # add this action back to the undo list |
---|
2067 | lappend CIF(undolist) [list "loop delete" $deletelist \ |
---|
2068 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
2069 | # count up |
---|
2070 | incr CIF(changes) |
---|
2071 | } elseif {[lindex $mark 1] == "delete"} { |
---|
2072 | set addlist {} |
---|
2073 | foreach m $edited { |
---|
2074 | foreach {mark dataname index block orig} $m {} |
---|
2075 | # make the change back |
---|
2076 | ReplaceMarkedText $CIF(txt) $mark $orig |
---|
2077 | lappend addlist [list $mark $dataname $index $block] |
---|
2078 | global $block |
---|
2079 | set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark] |
---|
2080 | } |
---|
2081 | # show the entry that was added |
---|
2082 | set lastLoopIndex $index |
---|
2083 | # add this action back to the undo list |
---|
2084 | lappend CIF(undolist) [list "loop add" $addlist \ |
---|
2085 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
2086 | # count up |
---|
2087 | incr CIF(changes) |
---|
2088 | } |
---|
2089 | |
---|
2090 | # drop the action from the redo list |
---|
2091 | set CIF(redolist) [lreplace $CIF(redolist) end end] |
---|
2092 | # scroll on the tree |
---|
2093 | $CIF(tree) see $lastShownTreeID |
---|
2094 | eval showCIFbyDataname $lastShownItem |
---|
2095 | |
---|
2096 | # if we are in a loop, display the element |
---|
2097 | if {[lindex [lindex $lastShownItem 0] 1] == "loop"} { |
---|
2098 | $CIF(LoopSpinBox) setvalue @$lastLoopIndex |
---|
2099 | ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \ |
---|
2100 | [lindex $lastShownItem 1] |
---|
2101 | } |
---|
2102 | } |
---|
2103 | |
---|
2104 | # create a category browser to select a single CIF item (mode=single) |
---|
2105 | # or to populate a loop_ (mode=multiple) |
---|
2106 | proc CatBrowserWindow {parent "mode multiple"} { |
---|
2107 | global CIF CIF_dataname_index |
---|
2108 | global catlist |
---|
2109 | if {$mode == "multiple"} { |
---|
2110 | set CIF(catselectmode) 1 |
---|
2111 | } else { |
---|
2112 | set CIF(catselectmode) 0 |
---|
2113 | } |
---|
2114 | set CIF(CategoryBrowserWin) [set frame $parent.catselect] |
---|
2115 | if {[winfo exists $frame]} { |
---|
2116 | set CIF(searchtext) "" |
---|
2117 | # the window exists so go ahead and use it |
---|
2118 | set CIF(SelCat) {} |
---|
2119 | set CIF(CatSelList) {} |
---|
2120 | set CIF(CatSelItems) {} |
---|
2121 | wm deiconify $frame |
---|
2122 | $CIF(cattree) selection clear |
---|
2123 | tkwait variable CIF(CatSelectDone) |
---|
2124 | wm withdraw $frame |
---|
2125 | return |
---|
2126 | } |
---|
2127 | catch {unset catlist} |
---|
2128 | set CIF(searchtext) "" |
---|
2129 | pleasewait "building category window" "" $parent |
---|
2130 | # create an index by category |
---|
2131 | foreach name [lsort [array names CIF_dataname_index]] { |
---|
2132 | set category [lindex [lindex $CIF_dataname_index($name) 1] 5] |
---|
2133 | lappend catlist($category) $name |
---|
2134 | } |
---|
2135 | catch {destroy $frame} |
---|
2136 | toplevel $frame |
---|
2137 | wm withdraw $frame |
---|
2138 | wm title $frame "CIF Category Browser" |
---|
2139 | wm protocol $frame WM_DELETE_WINDOW "set CIF(CatSelItems) {}; set CIF(CatSelectDone) Q" |
---|
2140 | if {$CIF(catselectmode)} { |
---|
2141 | set text "Select one or more data names in a\nsingle category to create a new loop" |
---|
2142 | } else { |
---|
2143 | set text "Select a single data name to add to the CIF" |
---|
2144 | } |
---|
2145 | grid [frame $frame.top -bg beige] -sticky news -column 0 -row 0 |
---|
2146 | grid columnconfigure $frame.top 0 -weight 1 |
---|
2147 | grid columnconfigure $frame.top 1 -pad 10 |
---|
2148 | grid [label $frame.top.1 -text $text -bg beige] \ |
---|
2149 | -sticky news -column 0 -row 0 |
---|
2150 | grid [set CIF(usebutton) [button $frame.top.use -text "Insert" \ |
---|
2151 | -command "set CIF(CatSelectDone) done" \ |
---|
2152 | -state disabled]] -column 1 -row 0 |
---|
2153 | grid [frame $frame.bot] -sticky news -column 0 -row 2 |
---|
2154 | grid [label $frame.bot.txt -text "Enter search text:"] \ |
---|
2155 | -column 0 -row 1 |
---|
2156 | grid [entry $frame.bot.e -textvariable CIF(searchtext)] \ |
---|
2157 | -column 1 -row 1 |
---|
2158 | bind $frame.bot.e <Return> CatLookupName |
---|
2159 | grid [button $frame.bot.src -text "Search" \ |
---|
2160 | -command CatLookupName] -column 2 -row 1 |
---|
2161 | grid [button $frame.bot.next -text "Next" -command ShowNextcatSearch] \ |
---|
2162 | -column 3 -row 1 |
---|
2163 | grid [button $frame.bot.q -text Quit \ |
---|
2164 | -command "set CIF(CatSelItems) {}; set CIF(CatSelectDone) Q"\ |
---|
2165 | ] -column 5 -row 1 |
---|
2166 | set sw [ScrolledWindow $frame.lf] |
---|
2167 | $frame.lf configure -relief sunken -borderwidth 2 |
---|
2168 | set CIF(cattree) [Tree $sw.tree -relief flat -borderwidth 0 -width 45 \ |
---|
2169 | -highlightthickness 0 -redraw 1 -height 20] |
---|
2170 | # get the size of the font and adjust the line spacing accordingly |
---|
2171 | catch { |
---|
2172 | set font [option get $CIF(cattree) font Canvas] |
---|
2173 | $CIF(cattree) configure -deltay [font metrics $font -linespace] |
---|
2174 | } |
---|
2175 | grid $sw -sticky news -column 0 -row 1 |
---|
2176 | grid columnconfigure $frame 0 -minsize 275 -weight 1 |
---|
2177 | grid rowconfigure $frame 1 -weight 1 |
---|
2178 | $sw setwidget $CIF(cattree) |
---|
2179 | |
---|
2180 | bind $frame <KeyPress-Prior> "$CIF(cattree) yview scroll -1 page" |
---|
2181 | bind $frame <KeyPress-Next> "$CIF(cattree) yview scroll 1 page" |
---|
2182 | bind $frame <KeyPress-Up> "$CIF(cattree) yview scroll -1 unit" |
---|
2183 | bind $frame <KeyPress-Down> "$CIF(cattree) yview scroll 1 unit" |
---|
2184 | bind $frame <KeyPress-Home> "$CIF(cattree) yview moveto 0" |
---|
2185 | #bind $frame <KeyPress-End> "$CIF(cattree) yview moveto end" |
---|
2186 | # -- does not work |
---|
2187 | bind $frame <KeyPress-End> "$CIF(cattree) yview scroll 99999999 page" |
---|
2188 | $CIF(cattree) see 0 |
---|
2189 | |
---|
2190 | # Bwidget seems to have problems with the name "1", so avoid it |
---|
2191 | set num 100 |
---|
2192 | set n 0 |
---|
2193 | global catCIFindex |
---|
2194 | catch {unset catCIFindex} |
---|
2195 | set normalfont [option get [winfo toplevel $CIF(cattree)] font Canvas] |
---|
2196 | set italic "$font italic" |
---|
2197 | foreach cat [lsort [array names catlist]] { |
---|
2198 | if {$cat == ""} continue |
---|
2199 | $CIF(cattree) insert end root cat$n -text $cat \ |
---|
2200 | -open 0 -image [Bitmap::get folder] |
---|
2201 | foreach item [lsort $catlist($cat)] { |
---|
2202 | set loop [lindex [lindex $CIF_dataname_index($item) 1] 6] |
---|
2203 | if {$loop || !$CIF(catselectmode)} { |
---|
2204 | set font $normalfont |
---|
2205 | set sel 1 |
---|
2206 | } else { |
---|
2207 | set font $italic |
---|
2208 | set sel 0 |
---|
2209 | } |
---|
2210 | $CIF(cattree) insert end cat$n [incr num] -text $item \ |
---|
2211 | -image [Bitmap::get file] -selectable $sel -font $font |
---|
2212 | set catCIFindex($item) $num |
---|
2213 | } |
---|
2214 | incr n |
---|
2215 | } |
---|
2216 | # set code to respond to mouse clicks |
---|
2217 | $CIF(cattree) bindImage <1> selectCat |
---|
2218 | $CIF(cattree) bindText <1> selectCat |
---|
2219 | $CIF(cattree) bindImage <Control-1> {} |
---|
2220 | $CIF(cattree) bindText <Control-1> {} |
---|
2221 | |
---|
2222 | set CIF(SelCat) {} |
---|
2223 | set CIF(CatSelList) {} |
---|
2224 | set CIF(CatSelItems) {} |
---|
2225 | donewait |
---|
2226 | wm deiconify $frame |
---|
2227 | tkwait variable CIF(CatSelectDone) |
---|
2228 | wm withdraw $frame |
---|
2229 | } |
---|
2230 | |
---|
2231 | # respond to a selection event in CatBrowserWindow |
---|
2232 | proc selectCat {item} { |
---|
2233 | global CIF |
---|
2234 | # ignore selected category items |
---|
2235 | if {[string first cat $item] == 0} {return} |
---|
2236 | set name [$CIF(cattree) itemcget $item -text] |
---|
2237 | set category [$CIF(cattree) itemcget [$CIF(cattree) parent $item] -text] |
---|
2238 | if {!$CIF(catselectmode)} { |
---|
2239 | # single selection mode |
---|
2240 | set CIF(SelCat) $category |
---|
2241 | set CIF(CatSelList) $item |
---|
2242 | } elseif {$CIF(SelCat) != $category} { |
---|
2243 | # new category |
---|
2244 | set CIF(SelCat) $category |
---|
2245 | set CIF(CatSelList) $item |
---|
2246 | } elseif {[set ind [lsearch $CIF(CatSelList) $item]] >= 0} { |
---|
2247 | # toggle |
---|
2248 | set CIF(CatSelList) [lreplace $CIF(CatSelList) $ind $ind] |
---|
2249 | } else { |
---|
2250 | # add to category |
---|
2251 | lappend CIF(CatSelList) $item |
---|
2252 | } |
---|
2253 | if {[llength $CIF(CatSelList)] == 0} { |
---|
2254 | $CIF(cattree) selection clear |
---|
2255 | } else { |
---|
2256 | eval $CIF(cattree) selection set $CIF(CatSelList) |
---|
2257 | } |
---|
2258 | set CIF(CatSelItems) {} |
---|
2259 | foreach node $CIF(CatSelList) { |
---|
2260 | lappend CIF(CatSelItems) [$CIF(cattree) itemcget $node -text] |
---|
2261 | } |
---|
2262 | if {$CIF(CatSelItems) != ""} { |
---|
2263 | ShowDictionaryDefinition $CIF(CatSelItems) |
---|
2264 | $CIF(usebutton) configure -state normal |
---|
2265 | } else { |
---|
2266 | $CIF(usebutton) configure -state disabled |
---|
2267 | } |
---|
2268 | } |
---|
2269 | |
---|
2270 | # search through the category browser for a string |
---|
2271 | proc CatLookupName {} { |
---|
2272 | global CIF catCIFindex |
---|
2273 | pleasewait "performing search" "" [winfo toplevel $CIF(cattree)] |
---|
2274 | |
---|
2275 | set str $CIF(searchtext) |
---|
2276 | # close all nodes |
---|
2277 | foreach node [$CIF(cattree) nodes root] { |
---|
2278 | $CIF(cattree) closetree $node |
---|
2279 | } |
---|
2280 | set catsearchlist {} |
---|
2281 | set namelist [array names catCIFindex *[string tolower $str]*] |
---|
2282 | if {[llength $namelist] == 0} { |
---|
2283 | MyMessageBox -parent [winfo toplevel $CIF(cattree)] \ |
---|
2284 | -title "Not found" \ |
---|
2285 | -message "String not found" -icon warning -type OK \ |
---|
2286 | -default ok |
---|
2287 | } |
---|
2288 | foreach name $namelist { |
---|
2289 | set node $catCIFindex($name) |
---|
2290 | lappend catsearchlist $node |
---|
2291 | set pnode [$CIF(cattree) parent $node] |
---|
2292 | $CIF(cattree) opentree $pnode |
---|
2293 | } |
---|
2294 | set CIF(catsearchlist) [lsort -integer $catsearchlist] |
---|
2295 | set CIF(catsearchnum) -1 |
---|
2296 | donewait |
---|
2297 | # find 1st element |
---|
2298 | ShowNextcatSearch |
---|
2299 | } |
---|
2300 | |
---|
2301 | # successively display located data items in the category browser |
---|
2302 | proc ShowNextcatSearch {} { |
---|
2303 | global CIF |
---|
2304 | $CIF(usebutton) configure -state disabled |
---|
2305 | set node [lindex $CIF(catsearchlist) [incr CIF(catsearchnum)]] |
---|
2306 | if {$node == ""} { |
---|
2307 | set CIF(catsearchnum) 0 |
---|
2308 | set node [lindex $CIF(catsearchlist) 0] |
---|
2309 | } |
---|
2310 | if {$node == ""} { |
---|
2311 | $CIF(cattree) selection set |
---|
2312 | return |
---|
2313 | } |
---|
2314 | ShowDictionaryDefinition [$CIF(cattree) itemcget $node -text] |
---|
2315 | $CIF(cattree) see $node |
---|
2316 | $CIF(cattree) selection set $node |
---|
2317 | } |
---|
2318 | |
---|
2319 | # create a data item browser to select a single CIF item |
---|
2320 | # |
---|
2321 | proc CatListWindow {parent} { |
---|
2322 | global CIF CIF_dataname_index |
---|
2323 | global catlist |
---|
2324 | set CIF(searchtext) "" |
---|
2325 | set frame $parent.catselect |
---|
2326 | catch {destroy $frame} |
---|
2327 | toplevel $frame |
---|
2328 | wm title $frame "CIF Data Name Browser" |
---|
2329 | grid [label $frame.top -text "Select a CIF data name to add" \ |
---|
2330 | -bd 2 -bg beige -relief raised] \ |
---|
2331 | -sticky news -column 0 -row 0 -columnspan 3 |
---|
2332 | grid [label $frame.top1 -text "Dictionary" -bg beige -anchor w] \ |
---|
2333 | -sticky news -column 0 -row 1 -columnspan 2 |
---|
2334 | grid [label $frame.top2 -text "Data name" -bg beige -anchor w] \ |
---|
2335 | -sticky news -column 2 -row 1 |
---|
2336 | grid [frame $frame.bot] -sticky news -column 0 -row 3 -columnspan 3 |
---|
2337 | grid [label $frame.bot.txt -text "Enter search text:"] \ |
---|
2338 | -column 0 -row 1 |
---|
2339 | grid [entry $frame.bot.e -textvariable CIF(searchtext)] \ |
---|
2340 | -column 1 -row 1 |
---|
2341 | bind $frame.bot.e <Return> CatFindMatchingNames |
---|
2342 | grid [button $frame.bot.src -text "Search" \ |
---|
2343 | -command CatFindMatchingNames] -column 2 -row 1 |
---|
2344 | grid [checkbutton $frame.bot.sort -text "Sort by dict." \ |
---|
2345 | -variable CIF(sortbydict) \ |
---|
2346 | -command CatFindMatchingNames] -column 3 -row 1 |
---|
2347 | grid [set CIF(usebutton) [button $frame.bot.use -text "Insert" \ |
---|
2348 | -command "destroy $frame"]] -column 4 -row 1 |
---|
2349 | grid [button $frame.bot.q -text Quit \ |
---|
2350 | -command "set CIF(CatSelItems) {}; destroy $frame"] -column 5 -row 1 |
---|
2351 | grid [set CIF(catlist) [listbox $frame.list -width 55 \ |
---|
2352 | -height 20 -exportselection 0 \ |
---|
2353 | -yscrollcommand "syncLists $frame.list $frame.dict $frame.ys yview"\ |
---|
2354 | ]] -column 2 -row 2 -sticky nsew |
---|
2355 | grid [set CIF(dictlist) [listbox $frame.dict -width 12 \ |
---|
2356 | -height 20 -exportselection 0 \ |
---|
2357 | -yscrollcommand "syncLists $frame.dict $frame.list $frame.ys yview"\ |
---|
2358 | ]] -column 0 -row 2 -sticky nsew |
---|
2359 | grid [scrollbar $frame.ys -width 15 -bd 2 \ |
---|
2360 | -command "moveLists \[list $frame.list $frame.dict] yview" \ |
---|
2361 | ] -column 1 -row 2 -sticky ns |
---|
2362 | |
---|
2363 | bind $CIF(catlist) <<ListboxSelect>> \ |
---|
2364 | "ListSelectedCmd $CIF(catlist) $CIF(dictlist); SetSelectedCmd $CIF(catlist)" |
---|
2365 | bind $CIF(dictlist) <<ListboxSelect>> \ |
---|
2366 | "ListSelectedCmd $CIF(dictlist) $CIF(catlist); SetSelectedCmd $CIF(catlist)" |
---|
2367 | grid columnconfigure $frame 2 -minsize 275 -weight 1 |
---|
2368 | grid rowconfigure $frame 2 -weight 1 |
---|
2369 | |
---|
2370 | bind $frame <KeyPress-Prior> "$CIF(catlist) yview scroll -1 page" |
---|
2371 | bind $frame <KeyPress-Next> "$CIF(catlist) yview scroll 1 page" |
---|
2372 | bind $frame <KeyPress-Up> "$CIF(catlist) yview scroll -1 unit" |
---|
2373 | bind $frame <KeyPress-Down> "$CIF(catlist) yview scroll 1 unit" |
---|
2374 | bind $frame <KeyPress-Home> "$CIF(catlist) yview moveto 0" |
---|
2375 | bind $frame <KeyPress-End> "$CIF(catlist) yview moveto end" |
---|
2376 | $CIF(catlist) see 0 |
---|
2377 | |
---|
2378 | CatFindMatchingNames |
---|
2379 | tkwait window $frame |
---|
2380 | } |
---|
2381 | |
---|
2382 | # |
---|
2383 | # populate the data item browser created in CatListWindow |
---|
2384 | proc CatFindMatchingNames {} { |
---|
2385 | global CIF CIF_dataname_index |
---|
2386 | set str $CIF(searchtext) |
---|
2387 | set searchlist {} |
---|
2388 | foreach name [array names CIF_dataname_index *[string tolower $str]*] { |
---|
2389 | lappend searchlist [list $name [lindex [lindex $CIF_dataname_index($name) 0] 0]] |
---|
2390 | } |
---|
2391 | $CIF(catlist) delete 0 end |
---|
2392 | $CIF(dictlist) delete 0 end |
---|
2393 | set searchlist [lsort -index 0 $searchlist] |
---|
2394 | if {$CIF(sortbydict)} {set searchlist [lsort -index 1 $searchlist]} |
---|
2395 | foreach item $searchlist { |
---|
2396 | foreach {name dict} $item {} |
---|
2397 | $CIF(catlist) insert end $name |
---|
2398 | $CIF(dictlist) insert end $dict |
---|
2399 | } |
---|
2400 | $CIF(usebutton) configure -state disabled |
---|
2401 | } |
---|
2402 | |
---|
2403 | # replicate selection between list boxes |
---|
2404 | # list must be config'ed -exportselection 0 |
---|
2405 | proc ListSelectedCmd {master slaves} { |
---|
2406 | global CIF |
---|
2407 | foreach slave $slaves { |
---|
2408 | $slave selection clear 0 end |
---|
2409 | $slave selection set [$master curselection] |
---|
2410 | } |
---|
2411 | $CIF(usebutton) configure -state normal |
---|
2412 | } |
---|
2413 | |
---|
2414 | proc SetSelectedCmd {itemlist} { |
---|
2415 | global CIF |
---|
2416 | set CIF(CatSelItems) [$itemlist get [$itemlist curselection]] |
---|
2417 | ShowDictionaryDefinition $CIF(CatSelItems) |
---|
2418 | } |
---|
2419 | |
---|
2420 | # sync one or more slaved listboxes to a master |
---|
2421 | # cmd is xview or yview |
---|
2422 | proc syncLists {master slaves scroll cmd args} { |
---|
2423 | foreach slave $slaves { |
---|
2424 | $slave $cmd moveto [lindex [$master $cmd] 0] |
---|
2425 | } |
---|
2426 | eval $scroll set $args |
---|
2427 | } |
---|
2428 | |
---|
2429 | # move multiple listboxes based on a single scrollbar |
---|
2430 | # cmd is xview or yview |
---|
2431 | proc moveLists {listlist cmd args} { |
---|
2432 | foreach list $listlist { |
---|
2433 | eval $list $cmd $args |
---|
2434 | } |
---|
2435 | } |
---|
2436 | |
---|
2437 | # insert a data item into block $blk |
---|
2438 | proc InsertDataItem {dataname blk "value ?"} { |
---|
2439 | global CIF |
---|
2440 | global $blk |
---|
2441 | |
---|
2442 | # find the last data item in the CIF |
---|
2443 | set txt $CIF(txt) |
---|
2444 | set last [set ${blk}(lastmark)] |
---|
2445 | set i [$txt index $last.r] |
---|
2446 | # insert the new dataname right after the last data item |
---|
2447 | $txt config -state normal |
---|
2448 | $txt insert $i "\n$dataname " x $value y |
---|
2449 | # reposition the mark for the original last data item in case it moved |
---|
2450 | $txt mark set $last.r $i |
---|
2451 | $txt mark gravity $last.r right |
---|
2452 | # convert the tags around $value to marks |
---|
2453 | foreach {pos epos} [$txt tag range y] {} |
---|
2454 | $txt tag delete x y |
---|
2455 | incr CIF(markcount) |
---|
2456 | $txt mark set $CIF(markcount).l $pos |
---|
2457 | $txt mark set $CIF(markcount).r $epos |
---|
2458 | $txt mark gravity $CIF(markcount).l left |
---|
2459 | $txt mark gravity $CIF(markcount).r right |
---|
2460 | $txt config -state disabled |
---|
2461 | set ${blk}($dataname) $CIF(markcount) |
---|
2462 | # this is now the last data item in block |
---|
2463 | set ${blk}(lastmark) $CIF(markcount) |
---|
2464 | # show the data item in the CIF text |
---|
2465 | $txt see $CIF(markcount).r |
---|
2466 | # add & show the data item in the tree; open for editing |
---|
2467 | set num [incr CIF(tree_lastindex)] |
---|
2468 | $CIF(tree) insert end $blk $num -text $dataname \ |
---|
2469 | -image [Bitmap::get file] -data $blk |
---|
2470 | $CIF(tree) see $num |
---|
2471 | set CIF(editmode) 1 |
---|
2472 | showCIFbyTreeID $num |
---|
2473 | # register this as a change |
---|
2474 | incr CIF(changes) |
---|
2475 | # can't undo this so clear the undo status |
---|
2476 | set CIF(undolist) {} |
---|
2477 | set CIF(redolist) {} |
---|
2478 | } |
---|
2479 | |
---|
2480 | # insert a loop into CIF block $blk |
---|
2481 | proc InsertDataLoop {namelist blk} { |
---|
2482 | global CIF CIF_dataname_index |
---|
2483 | global $blk |
---|
2484 | |
---|
2485 | # find the last data item in the CIF |
---|
2486 | set txt $CIF(txt) |
---|
2487 | set last [set ${blk}(lastmark)] |
---|
2488 | set i [$txt index $last.r] |
---|
2489 | # insert the new dataname right after the last data item |
---|
2490 | $txt config -state normal |
---|
2491 | # get the last loop number |
---|
2492 | regsub -all "loop_" [array names $blk loop*] "" l |
---|
2493 | set n [lindex [lsort -integer $l] end] |
---|
2494 | incr n |
---|
2495 | # insert the loop into the CIF |
---|
2496 | $txt insert $i "\nloop_" x |
---|
2497 | foreach name $namelist { |
---|
2498 | set epos [lindex [$txt tag range x] end] |
---|
2499 | $txt tag delete x |
---|
2500 | $txt insert $epos "\n $name" x |
---|
2501 | lappend ${blk}(loop_$n) $name |
---|
2502 | set ${blk}($name) {} |
---|
2503 | } |
---|
2504 | set epos [lindex [$txt tag range x] end] |
---|
2505 | $txt tag delete x |
---|
2506 | $txt insert $epos "\n " x |
---|
2507 | set epos [lindex [$txt tag range x] end] |
---|
2508 | $txt tag delete x |
---|
2509 | set catlist {} |
---|
2510 | # insert a value for each data name |
---|
2511 | foreach name $namelist { |
---|
2512 | set epos [$txt index "$epos lineend"] |
---|
2513 | if {[lindex [split $epos .] 1] > 70} { |
---|
2514 | $txt insert $epos "\n " x |
---|
2515 | set epos [lindex [$txt tag range x] end] |
---|
2516 | $txt tag delete x |
---|
2517 | set epos [$txt index "$epos lineend"] |
---|
2518 | } |
---|
2519 | $txt insert $epos ? y " " x |
---|
2520 | # convert the tags around the "?" to marks |
---|
2521 | foreach {pos epos} [$txt tag range y] {} |
---|
2522 | $txt tag delete x y |
---|
2523 | incr CIF(markcount) |
---|
2524 | $txt mark set $CIF(markcount).l $pos |
---|
2525 | $txt mark set $CIF(markcount).r $epos |
---|
2526 | $txt mark gravity $CIF(markcount).l left |
---|
2527 | $txt mark gravity $CIF(markcount).r right |
---|
2528 | lappend ${blk}($name) $CIF(markcount) |
---|
2529 | # get the category |
---|
2530 | set category {} |
---|
2531 | catch { |
---|
2532 | set category [lindex \ |
---|
2533 | [lindex $CIF_dataname_index($name) 1] 5] |
---|
2534 | } |
---|
2535 | if {$category != "" && [lsearch $catlist $category] == -1} { |
---|
2536 | lappend catlist $category |
---|
2537 | } |
---|
2538 | } |
---|
2539 | # this is now the last data item in block |
---|
2540 | set ${blk}(lastmark) $CIF(markcount) |
---|
2541 | # reposition the mark for the original last data item in case it moved |
---|
2542 | $txt mark set $last.r $i |
---|
2543 | $txt mark gravity $last.r right |
---|
2544 | $txt config -state disabled |
---|
2545 | # show the data item in the CIF text |
---|
2546 | $txt see $CIF(markcount).r |
---|
2547 | # add & show the data item in the tree; open for editing |
---|
2548 | $CIF(tree) insert end $blk ${blk}loop_$n \ |
---|
2549 | -text "loop_$n ($catlist)" -open 1 \ |
---|
2550 | -image [Bitmap::get copy] -data "$blk loop" |
---|
2551 | # insert a value for each data name |
---|
2552 | foreach name $namelist { |
---|
2553 | $CIF(tree) insert end ${blk}loop_$n [incr CIF(tree_lastindex)] \ |
---|
2554 | -text $name \ |
---|
2555 | -image [Bitmap::get file] -data $blk |
---|
2556 | } |
---|
2557 | $CIF(tree) see $CIF(tree_lastindex) |
---|
2558 | set CIF(editmode) 1 |
---|
2559 | showCIFbyTreeID ${blk}loop_$n |
---|
2560 | # register this as a change |
---|
2561 | incr CIF(changes) |
---|
2562 | # can't undo this so clear the undo status |
---|
2563 | set CIF(undolist) {} |
---|
2564 | set CIF(redolist) {} |
---|
2565 | } |
---|
2566 | |
---|
2567 | # add an item to a CIF |
---|
2568 | proc AddDataItem2CIF {mode parent} { |
---|
2569 | global CIF |
---|
2570 | if {[llength $CIF(blocklist)] == 1} { |
---|
2571 | set block block$CIF(blocklist) |
---|
2572 | } else { |
---|
2573 | # select a block here |
---|
2574 | set frame $parent.blksel |
---|
2575 | catch {destroy $frame} |
---|
2576 | toplevel $frame |
---|
2577 | wm title $frame "Select a block" |
---|
2578 | grid [label $frame.top -text "Select the data block where\nitems will be added" \ |
---|
2579 | -bd 2 -bg beige -relief raised] \ |
---|
2580 | -sticky news -column 0 -row 0 -columnspan 3 |
---|
2581 | grid [listbox $frame.list -width 30 \ |
---|
2582 | -height 20 -exportselection 0 \ |
---|
2583 | -yscrollcommand "$frame.ys set"] -column 0 -row 2 -sticky nsew |
---|
2584 | grid [scrollbar $frame.ys -width 15 -bd 2 \ |
---|
2585 | -command "$frame.list yview"] -column 1 -row 2 -sticky ns |
---|
2586 | grid [frame $frame.bot] -sticky news -column 0 -row 3 -columnspan 3 |
---|
2587 | grid [button $frame.bot.use -text Use -state disabled \ |
---|
2588 | -command "destroy $frame"] -column 4 -row 1 |
---|
2589 | grid [button $frame.bot.q -text Quit \ |
---|
2590 | -command "set CIF(selectedBlock) {}; destroy $frame"\ |
---|
2591 | ] -column 5 -row 1 |
---|
2592 | foreach n $CIF(blocklist) { |
---|
2593 | global block${n} |
---|
2594 | set blockname [set block${n}(data_)] |
---|
2595 | $frame.list insert end "($n) $blockname" |
---|
2596 | } |
---|
2597 | bind $frame.list <<ListboxSelect>> \ |
---|
2598 | "BlockSelectedCmd $frame.list $frame.bot.use" |
---|
2599 | bind $frame.list <Double-1> "destroy $frame" |
---|
2600 | putontop $frame |
---|
2601 | tkwait window $frame |
---|
2602 | afterputontop |
---|
2603 | if {$CIF(selectedBlock) == ""} return |
---|
2604 | set block block$CIF(selectedBlock) |
---|
2605 | } |
---|
2606 | if {$mode == "loop"} { |
---|
2607 | # open a browser window |
---|
2608 | CatBrowserWindow $parent |
---|
2609 | if {$CIF(CatSelItems) == ""} return |
---|
2610 | InsertDataLoop $CIF(CatSelItems) $block |
---|
2611 | } elseif {$mode == "category"} { |
---|
2612 | # open a browser window to select a single data item |
---|
2613 | CatBrowserWindow $parent single |
---|
2614 | if {[llength $CIF(CatSelItems)] != 1} return |
---|
2615 | InsertDataItem $CIF(CatSelItems) $block |
---|
2616 | } else { |
---|
2617 | CatListWindow $parent |
---|
2618 | if {[llength $CIF(CatSelItems)] != 1} return |
---|
2619 | InsertDataItem $CIF(CatSelItems) $block |
---|
2620 | } |
---|
2621 | } |
---|
2622 | |
---|
2623 | # respond to selection of a block, when needed |
---|
2624 | proc BlockSelectedCmd {listbox usebutton} { |
---|
2625 | global CIF |
---|
2626 | set selected [$listbox curselection] |
---|
2627 | if {[llength $selected] == 1} { |
---|
2628 | $usebutton configure -state normal |
---|
2629 | set CIF(selectedBlock) [lindex [split [$listbox get $selected] "()"] 1] |
---|
2630 | } else { |
---|
2631 | $usebutton configure -state disabled |
---|
2632 | set CIF(selectedBlock) {} |
---|
2633 | } |
---|
2634 | } |
---|
2635 | #---------------------------------------------------------------------- |
---|
2636 | #---------------------------------------------------------------------- |
---|
2637 | # index and manage dictionaries |
---|
2638 | #---------------------------------------------------------------------- |
---|
2639 | |
---|
2640 | # parse a CIF dictionary & save pertinent bits (more for DDL1 than DDL2) |
---|
2641 | proc MakeCIFdictIndex {f message} { |
---|
2642 | global CIF |
---|
2643 | set top1 .mkDictIndexTop |
---|
2644 | set stat .mkDictIndexStat |
---|
2645 | # create an invisible window for parsing a dictionary |
---|
2646 | catch {destroy $top1} |
---|
2647 | toplevel $top1 |
---|
2648 | set txt $top1.t |
---|
2649 | grid [text $txt -width 80 -yscrollcommand "$top1.s set"] -column 0 -row 0 |
---|
2650 | grid [scrollbar $top1.s -command "$txt yview"] -column 1 -row 0 -sticky ns |
---|
2651 | wm withdraw $top1 |
---|
2652 | # create a status window |
---|
2653 | catch {destroy $stat} |
---|
2654 | toplevel $stat |
---|
2655 | wm title $stat "Dictionary Parse Status" |
---|
2656 | if {$message != ""} { |
---|
2657 | grid [label $stat.l0 -text $message] -column 0 -columnspan 2 -row 0 |
---|
2658 | } |
---|
2659 | grid [label $stat.l1 -text "Definitions Processed"] -column 0 -row 1 |
---|
2660 | grid [label $stat.l2 -textvariable parsestatus] -column 1 -row 1 |
---|
2661 | putontop $stat 1 |
---|
2662 | update |
---|
2663 | |
---|
2664 | set counter 0 |
---|
2665 | |
---|
2666 | set file [file tail $f] |
---|
2667 | global parsestatus |
---|
2668 | set parsestatus "$counter (reading $file)" |
---|
2669 | update |
---|
2670 | |
---|
2671 | if {[catch { |
---|
2672 | set inp [open $f r] |
---|
2673 | fconfigure $inp -translation binary |
---|
2674 | } errmsg]} { |
---|
2675 | catch {close $inp} |
---|
2676 | destroy $stat $top1 |
---|
2677 | return [list 1 $errmsg] |
---|
2678 | } |
---|
2679 | |
---|
2680 | # input file is open, can we write to the index? |
---|
2681 | set errorstat 0 |
---|
2682 | if {[catch { |
---|
2683 | set fp [open ${f}_index w] |
---|
2684 | puts $fp "set CIF_file_name [list $file]" |
---|
2685 | puts $fp "set CIF_file_size [file size $f]" |
---|
2686 | puts $fp "set CIF_index_version $CIF(indexversion)" |
---|
2687 | } errmsg]} { |
---|
2688 | set errorstat 2 |
---|
2689 | catch {close $fp} |
---|
2690 | catch {file delete -force ${f}_index} |
---|
2691 | set ::CIF_file_paths($file) $f |
---|
2692 | } |
---|
2693 | |
---|
2694 | set text [read $inp] |
---|
2695 | close $inp |
---|
2696 | # is this a DDL2 dictionary (with save frames)? |
---|
2697 | if {[string match -nocase "*save_*" $text]} { |
---|
2698 | set DDL2 1 |
---|
2699 | regsub -all "save__" $text "data__" text |
---|
2700 | regsub -all "save_" $text "####_" text |
---|
2701 | } else { |
---|
2702 | set DDL2 0 |
---|
2703 | } |
---|
2704 | $txt insert end $text |
---|
2705 | # free up some memory |
---|
2706 | unset text |
---|
2707 | |
---|
2708 | set parsestatus "$counter (starting parse)" |
---|
2709 | update |
---|
2710 | |
---|
2711 | |
---|
2712 | set blocks [ParseCIF $txt {} CIFdict] |
---|
2713 | set allblocks {} |
---|
2714 | set prevpos 1.0 |
---|
2715 | set prevbytes 0 |
---|
2716 | set parsestatus "$counter (parse complete)" |
---|
2717 | update |
---|
2718 | |
---|
2719 | if {$errorstat == 0} { |
---|
2720 | puts $fp "set CIF_file_mtime [file mtime $f]" |
---|
2721 | puts $fp "array set CIF_dataname_index \{" |
---|
2722 | } |
---|
2723 | set definednames {} |
---|
2724 | for {set i 1} {$i <= $blocks} {incr i} { |
---|
2725 | incr counter |
---|
2726 | if {$counter % 10 == 0} { |
---|
2727 | set parsestatus $counter |
---|
2728 | update |
---|
2729 | } |
---|
2730 | lappend allblocks $i |
---|
2731 | if {![catch {set CIFdict::block${i}(errors)}]} { |
---|
2732 | puts stderr "Block $i ([set CIFdict::block${i}(data_)]) errors:" |
---|
2733 | puts stderr "[set CIFdict::block${i}(errors)]" |
---|
2734 | } |
---|
2735 | # list of positions for dataname |
---|
2736 | set list {} |
---|
2737 | catch {set list [set CIFdict::block${i}(_name)]} |
---|
2738 | if {$list == "" && $DDL2} { |
---|
2739 | catch {set list [set CIFdict::block${i}(_item.name)]} |
---|
2740 | } |
---|
2741 | # definition entry |
---|
2742 | set def {} |
---|
2743 | catch {set def [set CIFdict::block${i}(_definition)]} |
---|
2744 | if {$def == "" && $DDL2} { |
---|
2745 | catch {set def [set CIFdict::block${i}(_item_description.description)]} |
---|
2746 | } |
---|
2747 | if {$def == ""} continue |
---|
2748 | if {[llength $def] != 1} {puts stderr "problem with [set CIFdict::block${i}(data_)]"} |
---|
2749 | # count the number of bytes from the previous position |
---|
2750 | # (much faster than counting from the beginning each time) |
---|
2751 | #set defpos [string length [$txt get 1.0 $def.l]] |
---|
2752 | set defpos [string length [$txt get $prevpos $def.l]] |
---|
2753 | incr defpos $prevbytes |
---|
2754 | set prevpos $def.l |
---|
2755 | set prevbytes $defpos |
---|
2756 | set deflen [string length [$txt get $def.l $def.r]] |
---|
2757 | # item type (numb/char/null) |
---|
2758 | set type {} |
---|
2759 | catch {set type [set CIFdict::block${i}(_type)]} |
---|
2760 | if {$type == "" && $DDL2} { |
---|
2761 | catch {set type [set CIFdict::block${i}(_item_type.code)]} |
---|
2762 | if {[llength $type] != 1} { |
---|
2763 | set typeval "?" |
---|
2764 | } else { |
---|
2765 | set typeval [StripQuotes [$txt get $type.l $type.r]] |
---|
2766 | } |
---|
2767 | # mmCIF uses: atcode, code, float, int, line, symop, text |
---|
2768 | # uchar1, uchar3, ucode, uline, yyyy-mm-dd |
---|
2769 | # treat everything but float & int as character |
---|
2770 | if {$typeval == "float" || $typeval == "int"} { |
---|
2771 | set typeval "n" |
---|
2772 | } else { |
---|
2773 | set typeval "c" |
---|
2774 | } |
---|
2775 | } elseif {[llength $type] != 1} { |
---|
2776 | puts stderr "type problem for [set CIFdict::block${i}(data_)]" |
---|
2777 | set typeval "?" |
---|
2778 | } else { |
---|
2779 | set typeval [StripQuotes [$txt get $type.l $type.r]] |
---|
2780 | if {$typeval == "numb"} { |
---|
2781 | set typeval "n" |
---|
2782 | } elseif {$typeval == "char"} { |
---|
2783 | set typeval "c" |
---|
2784 | } elseif {$typeval == "null"} { |
---|
2785 | set typeval "" |
---|
2786 | } else { |
---|
2787 | puts stderr "Block [set CIFdict::block${i}(data_)] has invalid _type ($typeval)" |
---|
2788 | set typeval "?" |
---|
2789 | } |
---|
2790 | } |
---|
2791 | # flag if esd's are allowed |
---|
2792 | set pos {} |
---|
2793 | catch {set pos [set CIFdict::block${i}(_type_conditions)]} |
---|
2794 | if {$pos == "" && $DDL2} { |
---|
2795 | catch {set pos [set CIFdict::block${i}(_item_type_conditions.code)]} |
---|
2796 | } |
---|
2797 | if {[llength $pos] != 1} { |
---|
2798 | set esd 0 |
---|
2799 | } else { |
---|
2800 | if {"esd" == [string tolower \ |
---|
2801 | [StripQuotes [$txt get $pos.l $pos.r]]]} {set esd 1} |
---|
2802 | } |
---|
2803 | # units (_units_details overrides _units) |
---|
2804 | set pos {} |
---|
2805 | catch {set pos [set CIFdict::block${i}(_units)]} |
---|
2806 | if {$pos == "" && $DDL2} { |
---|
2807 | catch {set pos [set CIFdict::block${i}(_item_units.code)]} |
---|
2808 | } else { |
---|
2809 | catch {set pos [set CIFdict::block${i}(_units_details)]} |
---|
2810 | } |
---|
2811 | if {[llength $pos] != 1} { |
---|
2812 | set units {} |
---|
2813 | } else { |
---|
2814 | set units [StripQuotes [$txt get $pos.l $pos.r]] |
---|
2815 | } |
---|
2816 | # parse out _enumeration _enumeration_detail & _enumeration_range |
---|
2817 | set elist "" |
---|
2818 | set enumlist {} |
---|
2819 | set enumdetaillist {} |
---|
2820 | if {$DDL2} { |
---|
2821 | catch { |
---|
2822 | set enumlist [set CIFdict::block${i}(_item_enumeration.value)] |
---|
2823 | set enumdetaillist [set CIFdict::block${i}(_item_enumeration.detail)] |
---|
2824 | } |
---|
2825 | } else { |
---|
2826 | catch { |
---|
2827 | set enumlist [set CIFdict::block${i}(_enumeration)] |
---|
2828 | set enumdetaillist [set CIFdict::block${i}(_enumeration_detail)] |
---|
2829 | } |
---|
2830 | } |
---|
2831 | catch { |
---|
2832 | foreach m1 $enumlist \ |
---|
2833 | m2 $enumdetaillist { |
---|
2834 | if {$m2 != ""} { |
---|
2835 | set detail [StripQuotes [$txt get $m2.l $m2.r]]] |
---|
2836 | # condense multiple spaces out |
---|
2837 | regsub -all { +} $detail { } detail |
---|
2838 | } else { |
---|
2839 | set detail {} |
---|
2840 | } |
---|
2841 | lappend elist [list [StripQuotes [$txt get $m1.l $m1.r]] $detail] |
---|
2842 | } |
---|
2843 | } |
---|
2844 | # mmCIF ranges are too complex to do here |
---|
2845 | set range "" |
---|
2846 | catch { |
---|
2847 | set mark [set CIFdict::block${i}(_enumeration_range)] |
---|
2848 | lappend range [StripQuotes [$txt get $mark.l $mark.r]] |
---|
2849 | } |
---|
2850 | |
---|
2851 | # category names |
---|
2852 | set pos "" |
---|
2853 | catch {set pos [set CIFdict::block${i}(_category)]} |
---|
2854 | if {$pos == "" && $DDL2} { |
---|
2855 | catch {set pos [set CIFdict::block${i}(_item.category_id)]} |
---|
2856 | } |
---|
2857 | if {[llength $pos] != 1} { |
---|
2858 | set category {} |
---|
2859 | } else { |
---|
2860 | set category [StripQuotes [$txt get $pos.l $pos.r]] |
---|
2861 | } |
---|
2862 | # loop is 1 if loops are allowed |
---|
2863 | if {$DDL2} { |
---|
2864 | # at least for now, don't worry about DDL2 dictionaries |
---|
2865 | set loop 1 |
---|
2866 | } else { |
---|
2867 | set loop 0 |
---|
2868 | catch { |
---|
2869 | set pos [set CIFdict::block${i}(_list)] |
---|
2870 | set val [string tolower [StripQuotes [$txt get $pos.l $pos.r]]] |
---|
2871 | if {$val == "yes" || $val == "both"} {set loop 1} |
---|
2872 | } |
---|
2873 | } |
---|
2874 | foreach mark $list { |
---|
2875 | set dataname [string tolower [StripQuotes [$txt get $mark.l $mark.r]]] |
---|
2876 | lappend definednames $dataname |
---|
2877 | # note that this list must match foreach "type range elist... uses |
---|
2878 | set value [list [list $file $defpos $deflen] \ |
---|
2879 | [list $typeval $range $elist $esd $units $category $loop]] |
---|
2880 | if {$errorstat == 0} { |
---|
2881 | puts $fp "\t$dataname \t[list $value]" |
---|
2882 | } else { |
---|
2883 | set ::CIF_dataname_index($dataname) $value |
---|
2884 | } |
---|
2885 | } |
---|
2886 | } |
---|
2887 | set parsestatus "$counter (close file)" |
---|
2888 | update |
---|
2889 | |
---|
2890 | if {$errorstat == 0} { |
---|
2891 | puts $fp "\}" |
---|
2892 | puts $fp "set definednames \{" |
---|
2893 | foreach name [lsort $definednames] { |
---|
2894 | puts $fp "\t[list $name]" |
---|
2895 | } |
---|
2896 | puts $fp "\}" |
---|
2897 | } |
---|
2898 | catch {close $fp} |
---|
2899 | afterputontop |
---|
2900 | destroy $top1 |
---|
2901 | destroy $stat |
---|
2902 | namespace delete CIFdict |
---|
2903 | if {$errorstat == 0} { |
---|
2904 | return {} |
---|
2905 | } else { |
---|
2906 | return [list $errorstat $errmsg] |
---|
2907 | } |
---|
2908 | } |
---|
2909 | |
---|
2910 | # load indices to the dictionaries in CIF(dictfilelist), unless |
---|
2911 | # the variable does not exist or is empty |
---|
2912 | proc LoadDictIndices {} { |
---|
2913 | global scriptdir CIF CIF_file_paths |
---|
2914 | global CIF_dataname_index |
---|
2915 | # clear out any previous dictionary entries |
---|
2916 | catch {unset CIF_dataname_index} |
---|
2917 | # clear out array of file paths |
---|
2918 | catch {unset CIF_file_paths} |
---|
2919 | # clear out error listings |
---|
2920 | set CIF(overloaded) 0 |
---|
2921 | set CIF(overloadlist) {} |
---|
2922 | set CIF(dictwriteerrorlist) {} |
---|
2923 | set CIF(dictwriteerrors) {} |
---|
2924 | # clear out an old category browser window |
---|
2925 | catch {destroy $CIF(CategoryBrowserWin)} |
---|
2926 | |
---|
2927 | # is there a defined list of dictionary files? |
---|
2928 | set flag 0 |
---|
2929 | if {[catch {set CIF(dictfilelist)}]} { |
---|
2930 | set flag 1 |
---|
2931 | } elseif {[llength $CIF(dictfilelist)] == 0} { |
---|
2932 | set flag 1 |
---|
2933 | } |
---|
2934 | # if no files are present in the dictionary list, look |
---|
2935 | # in the standard places for them |
---|
2936 | if {$flag} { |
---|
2937 | # get a list of dictionary files |
---|
2938 | # CIFTOOLS location: |
---|
2939 | set dictfilelist [glob -nocomplain [file join $scriptdir dict *.dic]] |
---|
2940 | # |
---|
2941 | foreach file $dictfilelist { |
---|
2942 | lappend CIF(dictfilelist) $file |
---|
2943 | set CIF(dict_$file) 1 |
---|
2944 | } |
---|
2945 | } |
---|
2946 | |
---|
2947 | if {[catch {set CIF(dictfilelist)}]} { |
---|
2948 | set CIF(dictfilelist) {} |
---|
2949 | } |
---|
2950 | # load the dictionaries |
---|
2951 | foreach file $CIF(dictfilelist) { |
---|
2952 | if {!$CIF(dict_$file)} continue |
---|
2953 | if {![file exists $file]} continue |
---|
2954 | IndexLoadDict $file |
---|
2955 | } |
---|
2956 | if {[llength $CIF(dictwriteerrorlist)] >0} { |
---|
2957 | set msg "Error: unable to writing index files for dictionary:" |
---|
2958 | foreach dict $CIF(dictwriteerrorlist) { |
---|
2959 | append msg "\n\t[file tail $dict]" |
---|
2960 | } |
---|
2961 | append msg "\n\nDo you have write permission?" |
---|
2962 | set ans [MyMessageBox -parent . -title "CIF index error" \ |
---|
2963 | -message $msg \ |
---|
2964 | -icon error -type {Continue "See List"} -default continue] |
---|
2965 | if {$ans != "continue"} { |
---|
2966 | MyMessageBox -parent . -title "Error(s)" \ |
---|
2967 | -message $CIF(dictwriteerrors) \ |
---|
2968 | -icon warning -type Continue -default continue |
---|
2969 | } |
---|
2970 | } |
---|
2971 | if {$CIF(overloaded) != 0 && $CIF(ShowDictDups)} { |
---|
2972 | set ans [MyMessageBox -parent . -title "Definitions overridden" \ |
---|
2973 | -message "Loading CIF dictionaries.\nNote: $CIF(overloaded) datanames appeared in more than one dictionary -- only the last reference is used." \ |
---|
2974 | -icon warning -type {Continue "See List"} -default continue] |
---|
2975 | if {$ans != "continue"} { |
---|
2976 | MyMessageBox -parent . -title "List of overridden definitions" \ |
---|
2977 | -message $CIF(overloadlist) \ |
---|
2978 | -icon warning -type Continue -default continue |
---|
2979 | } |
---|
2980 | } |
---|
2981 | } |
---|
2982 | |
---|
2983 | # load an index to a dictionary file, create the index if needed. |
---|
2984 | # save the index to CIF dictionary named XXXXX.dic as XXXXX.dic_index |
---|
2985 | # if the file cannot be written, create an error message and just load |
---|
2986 | # it anyway. |
---|
2987 | proc IndexLoadDict {file} { |
---|
2988 | global CIF |
---|
2989 | global CIF_dataname_index CIF_file_paths |
---|
2990 | # save the array contents |
---|
2991 | set orignamelist [array names CIF_dataname_index] |
---|
2992 | |
---|
2993 | set flag 0 |
---|
2994 | if {![file exists ${file}_index]} { |
---|
2995 | set flag 1 |
---|
2996 | } elseif {[file mtime $file] > [file mtime ${file}_index]} { |
---|
2997 | set flag 1 |
---|
2998 | } |
---|
2999 | if {$flag} { |
---|
3000 | set stat [MakeCIFdictIndex $file "Please wait, indexing file $file"] |
---|
3001 | if {[lindex $stat 0] != ""} { |
---|
3002 | lappend CIF(dictwriteerrorlist) $file |
---|
3003 | append CIF(dictwriteerrors) "=================================\n" |
---|
3004 | append CIF(dictwriteerrors) "Error indexing file $file:\n" |
---|
3005 | append CIF(dictwriteerrors) "=================================\n" |
---|
3006 | append CIF(dictwriteerrors) [lindex $stat 1] |
---|
3007 | append CIF(dictwriteerrors) "\n\n" |
---|
3008 | return 1 |
---|
3009 | } |
---|
3010 | } |
---|
3011 | |
---|
3012 | set CIF_index_version 0 |
---|
3013 | set redo 0 |
---|
3014 | if {[catch { |
---|
3015 | source ${file}_index |
---|
3016 | } errmsg]} { |
---|
3017 | set stat [MakeCIFdictIndex $file \ |
---|
3018 | "Please wait, reindexing $file, Error reading file index."] |
---|
3019 | # MyMessageBox -parent . -title "CIF index error" \ |
---|
3020 | # -message "Error reading file ${file}_index -- this should not happen:\n$errmsg" \ |
---|
3021 | # -icon error -type {"Oh darn"} -default "oh darn" |
---|
3022 | set redo 1 |
---|
3023 | } |
---|
3024 | if {$CIF_index_version < $CIF(indexversion)} { |
---|
3025 | set redo 1 |
---|
3026 | set stat [MakeCIFdictIndex $file \ |
---|
3027 | "Please wait, reindexing $file, index is out of date."] |
---|
3028 | } elseif {[file size $file] != $CIF_file_size} { |
---|
3029 | set redo 1 |
---|
3030 | set stat [MakeCIFdictIndex $file \ |
---|
3031 | "Please wait, reindexing $file, file size has changed"] |
---|
3032 | } |
---|
3033 | if {$redo} { |
---|
3034 | if {[lindex $stat 0] != ""} { |
---|
3035 | lappend CIF(dictwriteerrorlist) $file |
---|
3036 | append CIF(dictwriteerrors) "=================================\n" |
---|
3037 | append CIF(dictwriteerrors) "Error indexing file $file:\n" |
---|
3038 | append CIF(dictwriteerrors) "=================================\n" |
---|
3039 | append CIF(dictwriteerrors) [lindex $stat 1] |
---|
3040 | append CIF(dictwriteerrors) "\n\n" |
---|
3041 | return 1 |
---|
3042 | } |
---|
3043 | if {[catch { |
---|
3044 | source ${file}_index |
---|
3045 | } errmsg]} { |
---|
3046 | MyMessageBox -parent . -title "CIF index error" \ |
---|
3047 | -message "Error reading file ${file}_index -- this should not happen:\n$errmsg" \ |
---|
3048 | -icon error -type {"Oh darn"} -default "oh darn" |
---|
3049 | return 1 |
---|
3050 | } |
---|
3051 | } |
---|
3052 | if {[array names CIF_file_paths $CIF_file_name] != ""} { |
---|
3053 | MyMessageBox -parent . -title "Duplicate dictionary name" \ |
---|
3054 | -message "Note: you are using two dictionaries with the same name ($CIF_file_name). The locations are:\n$CIF_file_paths($CIF_file_name)\n$file\n\nOnly the latter file will be accessed." \ |
---|
3055 | -icon warning -type {"Oh well"} -default "oh well" |
---|
3056 | } |
---|
3057 | set CIF_file_paths($CIF_file_name) $file |
---|
3058 | # now check for overridden names |
---|
3059 | set errorlist {} |
---|
3060 | foreach name $definednames { |
---|
3061 | if {[lsearch -exact $orignamelist $name] != -1} { |
---|
3062 | incr CIF(overloaded) |
---|
3063 | append errorlist "\t$name\n" |
---|
3064 | } |
---|
3065 | } |
---|
3066 | if {$errorlist != ""} { |
---|
3067 | append CIF(overloadlist) "\ndictionary $file overrides definitions for datanames:\n" $errorlist |
---|
3068 | } |
---|
3069 | return |
---|
3070 | } |
---|
3071 | |
---|
3072 | # make a window for selecting dictionaries |
---|
3073 | proc MakeDictSelect {parent} { |
---|
3074 | global CIF |
---|
3075 | global CIF_dataname_index |
---|
3076 | #global icon |
---|
3077 | set icon(up) [image create bitmap -data { |
---|
3078 | #define up_width 24 |
---|
3079 | #define up_height 24 |
---|
3080 | static unsigned char up_bits[] = { |
---|
3081 | 0x00, 0x18, 0x00, 0x00, 0x18, 0x00, |
---|
3082 | 0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00, |
---|
3083 | 0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00, |
---|
3084 | 0x00, 0xff, 0x00, 0x00, 0xff, 0x00, |
---|
3085 | 0x80, 0xff, 0x01, 0x80, 0xff, 0x01, |
---|
3086 | 0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03, |
---|
3087 | 0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07, |
---|
3088 | 0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f, |
---|
3089 | 0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f, |
---|
3090 | 0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f, |
---|
3091 | 0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f, |
---|
3092 | 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; |
---|
3093 | }] |
---|
3094 | |
---|
3095 | set icon(down) [image create bitmap -data { |
---|
3096 | #define down_width 24 |
---|
3097 | #define down_height 24 |
---|
3098 | static unsigned char down_bits[] = { |
---|
3099 | 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, |
---|
3100 | 0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f, |
---|
3101 | 0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f, |
---|
3102 | 0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f, |
---|
3103 | 0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f, |
---|
3104 | 0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07, |
---|
3105 | 0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03, |
---|
3106 | 0x80, 0xff, 0x01, 0x80, 0xff, 0x01, |
---|
3107 | 0x00, 0xff, 0x00, 0x00, 0xff, 0x00, |
---|
3108 | 0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00, |
---|
3109 | 0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00, |
---|
3110 | 0x00, 0x18, 0x00, 0x00, 0x18, 0x00}; |
---|
3111 | }] |
---|
3112 | |
---|
3113 | set win $parent.dictselect |
---|
3114 | catch {destroy $win} |
---|
3115 | toplevel $win |
---|
3116 | wm title $win "Select CIF dictionaries" |
---|
3117 | grid [canvas $win.canvas \ |
---|
3118 | -scrollregion {0 0 5000 500} -width 0 -height 200 \ |
---|
3119 | -xscrollcommand "$win.xscroll set" \ |
---|
3120 | -yscrollcommand "$win.scroll set"] \ |
---|
3121 | -column 0 -row 2 -sticky nsew |
---|
3122 | grid columnconfigure $win 0 -weight 1 |
---|
3123 | grid rowconfigure $win 2 -weight 1 |
---|
3124 | scrollbar $win.scroll \ |
---|
3125 | -command "$win.canvas yview" |
---|
3126 | scrollbar $win.xscroll -orient horizontal \ |
---|
3127 | -command "$win.canvas xview" |
---|
3128 | frame [set CIF(dictlistbox) $win.canvas.fr] |
---|
3129 | $win.canvas create window 0 0 -anchor nw -window $CIF(dictlistbox) |
---|
3130 | grid [label $win.top -text "Select dictionaries to be loaded" -bg beige] \ |
---|
3131 | -column 0 -columnspan 99 -row 0 -sticky ew |
---|
3132 | grid [label $win.top1 \ |
---|
3133 | -text "(Dictionaries are loaded in the order listed)" -bg beige] \ |
---|
3134 | -column 0 -columnspan 99 -row 1 -sticky ew |
---|
3135 | catch {$win.top1 config -font "[$win.top1 cget -font] italic"} |
---|
3136 | grid [frame $win.bot] \ |
---|
3137 | -column 0 -columnspan 99 -row 99 -sticky ew |
---|
3138 | set col 0 |
---|
3139 | grid [button $win.bot.add -text "Add Dictionary" \ |
---|
3140 | -command "OpenLoadDict $win"] \ |
---|
3141 | -column $col -row 0 |
---|
3142 | grid [button $win.bot.save -text "Save current settings" \ |
---|
3143 | -command "SaveOptions"] \ |
---|
3144 | -column [incr col] -row 0 |
---|
3145 | grid [button $win.bot.up -image $icon(up) -width 35\ |
---|
3146 | -command ShiftDictUp] \ |
---|
3147 | -column [incr col] -row 0 |
---|
3148 | grid [button $win.bot.down -image $icon(down) -width 35 \ |
---|
3149 | -command ShiftDictDown] \ |
---|
3150 | -column [incr col] -row 0 |
---|
3151 | |
---|
3152 | grid [button $win.bot.cancel -text Close -command "destroy $win; LoadDictIndices"] \ |
---|
3153 | -column [incr col] -row 0 |
---|
3154 | wm protocol $win WM_DELETE_WINDOW "$win.bot.cancel invoke" |
---|
3155 | |
---|
3156 | FillDictSelect |
---|
3157 | |
---|
3158 | update |
---|
3159 | #putontop $win |
---|
3160 | #tkwait window $win |
---|
3161 | #afterputontop |
---|
3162 | } |
---|
3163 | |
---|
3164 | |
---|
3165 | # respond to a dictionary selection |
---|
3166 | proc SelectDict {row} { |
---|
3167 | global CIF |
---|
3168 | set widget $CIF(dictlistbox) |
---|
3169 | if {$CIF(selected_dict) != ""} { |
---|
3170 | ${widget}.c$CIF(selected_dict) config -bg \ |
---|
3171 | [option get [winfo toplevel $widget] background Frame] |
---|
3172 | } |
---|
3173 | set CIF(selected_dict) $row |
---|
3174 | ${widget}.c$row config -bg black |
---|
3175 | } |
---|
3176 | |
---|
3177 | # shift the selected dictionary up in the list |
---|
3178 | proc ShiftDictUp {} { |
---|
3179 | global CIF |
---|
3180 | if {$CIF(selected_dict) == ""} { |
---|
3181 | bell |
---|
3182 | return |
---|
3183 | } |
---|
3184 | if {$CIF(selected_dict) == 0} { |
---|
3185 | return |
---|
3186 | } |
---|
3187 | set prev [set pos $CIF(selected_dict)] |
---|
3188 | incr prev -1 |
---|
3189 | set CIF(dictfilelist) [lreplace $CIF(dictfilelist) $prev $pos \ |
---|
3190 | [lindex $CIF(dictfilelist) $pos] \ |
---|
3191 | [lindex $CIF(dictfilelist) $prev]] |
---|
3192 | FillDictSelect |
---|
3193 | SelectDict $prev |
---|
3194 | } |
---|
3195 | |
---|
3196 | # shift the selected dictionary down in the list |
---|
3197 | proc ShiftDictDown {} { |
---|
3198 | global CIF |
---|
3199 | if {$CIF(selected_dict) == ""} { |
---|
3200 | bell |
---|
3201 | return |
---|
3202 | } |
---|
3203 | if {$CIF(selected_dict) == [llength $CIF(dictfilelist)]-1} { |
---|
3204 | return |
---|
3205 | } |
---|
3206 | set next [set pos $CIF(selected_dict)] |
---|
3207 | incr next 1 |
---|
3208 | set CIF(dictfilelist) [lreplace $CIF(dictfilelist) $pos $next \ |
---|
3209 | [lindex $CIF(dictfilelist) $next] \ |
---|
3210 | [lindex $CIF(dictfilelist) $pos]] |
---|
3211 | FillDictSelect |
---|
3212 | SelectDict $next |
---|
3213 | } |
---|
3214 | |
---|
3215 | # place the dictionary list into the window |
---|
3216 | proc FillDictSelect {} { |
---|
3217 | global CIF |
---|
3218 | |
---|
3219 | set win [winfo toplevel $CIF(dictlistbox)] |
---|
3220 | eval destroy [winfo children $CIF(dictlistbox)] |
---|
3221 | set CIF(dictlistboxRow) -1 |
---|
3222 | foreach file $CIF(dictfilelist) { |
---|
3223 | set lbl $file |
---|
3224 | if {![file exists $file]} { |
---|
3225 | set lbl "$file (not found)" |
---|
3226 | set CIF(dict_$file) 0 |
---|
3227 | } |
---|
3228 | set row [incr CIF(dictlistboxRow)] |
---|
3229 | grid [frame $CIF(dictlistbox).c$row -bd 3] -column 0 -row $row -sticky w |
---|
3230 | grid [checkbutton $CIF(dictlistbox).c$row.c -text $lbl \ |
---|
3231 | -command "SelectDict $row" \ |
---|
3232 | -variable CIF(dict_$file)] \ |
---|
3233 | -column 0 -row 0 -sticky w |
---|
3234 | if {![file exists $file]} { |
---|
3235 | $CIF(dictlistbox).c$row.c config -state disabled |
---|
3236 | } |
---|
3237 | } |
---|
3238 | set CIF(selected_dict) {} |
---|
3239 | # resize the list |
---|
3240 | update |
---|
3241 | set sizes [grid bbox $win.canvas.fr] |
---|
3242 | $win.canvas config -scrollregion $sizes -width [lindex $sizes 2] |
---|
3243 | # use the scroll for BIG lists |
---|
3244 | if {[lindex $sizes 3] > [winfo height $win.canvas]} { |
---|
3245 | grid $win.scroll -sticky ns -column 1 -row 2 |
---|
3246 | } else { |
---|
3247 | grid forget $win.scroll |
---|
3248 | } |
---|
3249 | if {[lindex $sizes 2] > [winfo width $win.canvas]} { |
---|
3250 | grid $win.xscroll -sticky ew -column 0 -row 3 |
---|
3251 | } else { |
---|
3252 | grid forget $win.xscroll |
---|
3253 | } |
---|
3254 | } |
---|
3255 | |
---|
3256 | # open a new dictionary and add it to the list |
---|
3257 | proc OpenLoadDict {win} { |
---|
3258 | global CIF |
---|
3259 | set file [tk_getOpenFile -title "Select CIF" -parent $win \ |
---|
3260 | -defaultextension .dic -filetypes {{"CIF dictionary" ".dic"}}] |
---|
3261 | if {$file == ""} {return} |
---|
3262 | if {![file exists $file]} { |
---|
3263 | MyMessageBox -parent . -title "CIF error" \ |
---|
3264 | -message "Error file $file does not exist -- this should not happen" \ |
---|
3265 | -icon error -type {"Oh darn"} -default "oh darn" |
---|
3266 | } |
---|
3267 | if {[IndexLoadDict $file] == 1} return |
---|
3268 | set CIF(dict_$file) 1 |
---|
3269 | lappend CIF(dictfilelist) $file |
---|
3270 | |
---|
3271 | FillDictSelect |
---|
3272 | |
---|
3273 | $win.canvas xview moveto 0 |
---|
3274 | } |
---|
3275 | |
---|
3276 | # a dummy routine -- each program should have its own SaveOptions routine |
---|
3277 | proc SaveOptions {} { |
---|
3278 | MyMessageBox -parent . -title "Not saved" \ |
---|
3279 | -message "SaveOptions is not implemented in this program" \ |
---|
3280 | -icon "info" -type OK -default OK |
---|
3281 | } |
---|
3282 | |
---|
3283 | #---------------------------------------------------------------------- |
---|
3284 | # initialize misc variables |
---|
3285 | set CIF(changes) 0 |
---|
3286 | set CIF(widgetlist) {} |
---|
3287 | set CIF(lastShownItem) {} |
---|
3288 | set CIF(lastLoopIndex) {} |
---|
3289 | set CIF(editmode) 0 |
---|
3290 | set CIF(undolist) {} |
---|
3291 | set CIF(redolist) {} |
---|
3292 | set CIF(treeSelectedList) {} |
---|
3293 | set CIF(catsearchnum) -1 |
---|
3294 | set CIF(catsearchlist) {} |
---|
3295 | # version of the dictionary that is needed by the current program |
---|
3296 | set CIF(indexversion) 1.1 |
---|
3297 | # make sure this variable is defined |
---|
3298 | if {[catch {set CIF(ShowDictDups)}]} {set CIF(ShowDictDups) 0} |
---|