1 | # $Id: browsecif.tcl 728 2009-12-04 23:11:01Z 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 tkButtonInvoke $w.[string tolower $data(-default)]] |
---|
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 | #------------------------------------------------------------------------------ |
---|
397 | # end of Misc Tcl/Tk utility routines |
---|
398 | #------------------------------------------------------------------------------ |
---|
399 | |
---|
400 | #------------------------------------------------------------------------------ |
---|
401 | # ParseCIF reads and parses a CIF file putting the contents of |
---|
402 | # each block into arrays block1, block2,... in the caller's level |
---|
403 | # the name of the block is saved as blockN(data_) |
---|
404 | # data names items are saved as blockN(_data_name) = marker_number |
---|
405 | # where CIF data names are converted to lower case |
---|
406 | # and marker_number.l marker_number.r define the range of the value |
---|
407 | # for looped data names, the data items are included in a list: |
---|
408 | # blockN(_cif_name) = {marker1 marker2 ...} |
---|
409 | # the contents of each loop are saved as blockN(loop_M) |
---|
410 | # |
---|
411 | # if the filename is blank or not specified, the current contents |
---|
412 | # of the text widget, $txt, is parsed. |
---|
413 | # |
---|
414 | # The proc returns the number of blocks that have been read or a |
---|
415 | # null string if the file cannot be opened |
---|
416 | # |
---|
417 | # This parser does some error checking [errors are reported in blockN(error)] |
---|
418 | # but the parser could get confused if the CIF has invalid syntax |
---|
419 | # |
---|
420 | proc ParseCIF {txt "filename {}"} { |
---|
421 | global CIF tcl_version |
---|
422 | global CIF_dataname_index |
---|
423 | |
---|
424 | if {$tcl_version < 8.2} { |
---|
425 | tk_dialog .error {Old Tcl/Tk} \ |
---|
426 | "Sorry, the CIF Browser requires version 8.2 or later of the Tcl/Tk package. This is $tcl_version" \ |
---|
427 | warning 0 Sorry |
---|
428 | return |
---|
429 | } |
---|
430 | |
---|
431 | if {$filename != ""} { |
---|
432 | if [catch { |
---|
433 | $txt configure -state normal |
---|
434 | set fp [open $filename r] |
---|
435 | $txt insert end [read $fp] |
---|
436 | close $fp |
---|
437 | $txt configure -state disabled |
---|
438 | }] { |
---|
439 | return "" |
---|
440 | } |
---|
441 | } |
---|
442 | |
---|
443 | # maximum size of file |
---|
444 | set maxvalues 0 |
---|
445 | catch { |
---|
446 | set maxvalues $CIF(maxvalues) |
---|
447 | } |
---|
448 | |
---|
449 | set CIF(undolist) {} |
---|
450 | set CIF(redolist) {} |
---|
451 | set pos 1.0 |
---|
452 | set blocks 0 |
---|
453 | set EOF 1 |
---|
454 | set dataname {} |
---|
455 | set CIF(markcount) -1 |
---|
456 | # this flags where we are w/r a loop_ |
---|
457 | # -1 not in a loop |
---|
458 | # 0 reading a loop header (data names) |
---|
459 | # 1 reading the data items in a loop |
---|
460 | set loopflag -1 |
---|
461 | set loopnum -1 |
---|
462 | # loop over tokens |
---|
463 | while {$EOF} { |
---|
464 | if {$CIF(markcount) % 1000 == 0} { |
---|
465 | $txt see $pos |
---|
466 | set CIF(status) "($CIF(markcount) values read.)" |
---|
467 | update |
---|
468 | # are we over the limit? |
---|
469 | if {$maxvalues > 0 && $CIF(markcount) > $maxvalues} { |
---|
470 | donewait |
---|
471 | 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" |
---|
472 | set ans [MyMessageBox -parent . -title "CIF Too big" \ |
---|
473 | -message $msg -icon error -type "{Stop Parsing}" \ |
---|
474 | -default "stop parsing"] |
---|
475 | |
---|
476 | return $blocks |
---|
477 | } |
---|
478 | } |
---|
479 | # skip forward to the first non-blank character |
---|
480 | set npos [$txt search -regexp {[^[:space:]]} $pos end] |
---|
481 | # is this the end? |
---|
482 | if {$npos == "" || \ |
---|
483 | [lindex [split $npos .] 0] < [lindex [split $pos .] 0] } { |
---|
484 | set EOF 0 |
---|
485 | break |
---|
486 | } else { |
---|
487 | set pos $npos |
---|
488 | } |
---|
489 | |
---|
490 | # is this a comment, if so skip to next line |
---|
491 | if {[$txt get $pos] == "#"} { |
---|
492 | set pos [$txt index "$pos + 1 line linestart"] |
---|
493 | continue |
---|
494 | } |
---|
495 | |
---|
496 | # find end of token |
---|
497 | set epos [$txt search -regexp {[[:space:]]} $pos "$pos lineend"] |
---|
498 | if {$epos == ""} { |
---|
499 | set epos [$txt index "$pos lineend"] |
---|
500 | } |
---|
501 | |
---|
502 | set token [$txt get $pos $epos] |
---|
503 | |
---|
504 | if {[string tolower [string range $token 0 4]] == "data_"} { |
---|
505 | # this is the beginning of a data block |
---|
506 | incr blocks |
---|
507 | set blockname [string range $token 5 end] |
---|
508 | global block$blocks |
---|
509 | catch {unset block$blocks} |
---|
510 | set block${blocks}(data_) $blockname |
---|
511 | set loopnum -1 |
---|
512 | if {$dataname != ""} { |
---|
513 | # this is an error -- data_ block where a data item is expected |
---|
514 | append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n" |
---|
515 | set dataname {} |
---|
516 | } |
---|
517 | # move forward past current token |
---|
518 | set pos [$txt index "$epos +1c"] |
---|
519 | continue |
---|
520 | } |
---|
521 | |
---|
522 | if {[$txt get $pos] == "_"} { |
---|
523 | # this is a cif data name |
---|
524 | if {$dataname != ""} { |
---|
525 | # this is an error -- data name where a data item is expected |
---|
526 | append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n" |
---|
527 | } |
---|
528 | # convert it to lower case & save |
---|
529 | set dataname [string tolower $token] |
---|
530 | |
---|
531 | # are we in a loop header or loop body? |
---|
532 | if {$loopflag == 0} { |
---|
533 | # in a loop header, save the names in the loop list |
---|
534 | lappend looplist $dataname |
---|
535 | # check the categories used in the loop |
---|
536 | set category {} |
---|
537 | catch { |
---|
538 | set category [lindex \ |
---|
539 | [lindex $CIF_dataname_index($dataname) 1] 5] |
---|
540 | } |
---|
541 | # don't worry if we don't have a category |
---|
542 | if {$category != ""} { |
---|
543 | if {$catlist == ""} { |
---|
544 | set catlist $category |
---|
545 | } elseif {[lsearch $catlist $category] == -1} { |
---|
546 | # error two categories in a loop |
---|
547 | lappend catlist $category |
---|
548 | append block${blocks}(errors) \ |
---|
549 | "Multiple categories ($catlist) in a loop_ for $dataname at line [lindex [split $pos .] 0]\n" |
---|
550 | } |
---|
551 | } |
---|
552 | |
---|
553 | if {$blocks == 0} { |
---|
554 | # an error -- a loop_ before a data_ block start |
---|
555 | global block${blocks} |
---|
556 | set block${blocks}(data_) undefined |
---|
557 | append block${blocks}(errors) \ |
---|
558 | "A loop_ begins before a data_ block is defined (line [lindex [split $pos .] 0])\n" |
---|
559 | } |
---|
560 | set block${blocks}(loop_${loopnum}) $looplist |
---|
561 | # clear the array element for the data item |
---|
562 | # -- should not be needed for a valid CIF but if a name is used |
---|
563 | # -- twice in the same block, want to wipe out the 1st data |
---|
564 | catch { |
---|
565 | if {[set block${blocks}($dataname)] != ""} { |
---|
566 | # this is an error -- repeated data name |
---|
567 | append block${blocks}(errors) \ |
---|
568 | "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n" |
---|
569 | } |
---|
570 | set block${blocks}($dataname) {} |
---|
571 | } |
---|
572 | set dataname {} |
---|
573 | } elseif {$loopflag > 0} { |
---|
574 | # in a loop body, so the loop is over |
---|
575 | set loopflag -1 |
---|
576 | } |
---|
577 | # move forward past current token |
---|
578 | set pos [$txt index "$epos +1c"] |
---|
579 | continue |
---|
580 | } |
---|
581 | |
---|
582 | if {[string tolower [string range $token 0 4]] == "loop_"} { |
---|
583 | set loopflag 0 |
---|
584 | incr loopnum |
---|
585 | set looplist {} |
---|
586 | set catlist {} |
---|
587 | set block${blocks}(loop_${loopnum}) {} |
---|
588 | # move forward past current token |
---|
589 | set pos [$txt index "$epos +1c"] |
---|
590 | continue |
---|
591 | } |
---|
592 | |
---|
593 | # keywords not matched, must be some type of data item |
---|
594 | set item {} |
---|
595 | incr CIF(markcount) |
---|
596 | |
---|
597 | if {[$txt get "$pos linestart"] == ";" && \ |
---|
598 | [$txt index $pos] == [$txt index "$pos linestart"]} { |
---|
599 | # multiline entry with semicolon termination |
---|
600 | set epos [$txt search -regexp {^;} "$pos + 1 line linestart"] |
---|
601 | if {$epos == ""} { |
---|
602 | set epos end |
---|
603 | append block${blocks}(errors) \ |
---|
604 | "Unmatched semicolon for $dataname starting at line [lindex [split $pos .] 0]\n" |
---|
605 | } |
---|
606 | |
---|
607 | $txt mark set $CIF(markcount).l "$pos linestart" |
---|
608 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
609 | $txt mark gravity $CIF(markcount).l left |
---|
610 | $txt mark gravity $CIF(markcount).r right |
---|
611 | set item [$txt get "$pos linestart" "$epos +1c"] |
---|
612 | # move forward past current token |
---|
613 | set pos [$txt index "$epos + 1c"] |
---|
614 | } elseif {[$txt get $pos] == "\""} { |
---|
615 | # a quoted string -- find next quote |
---|
616 | set epos [$txt search "\"" "$pos +1c" "$pos lineend"] |
---|
617 | # skip over quotes followed by a non-blank |
---|
618 | while {$epos != "" && \ |
---|
619 | [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} { |
---|
620 | set epos [$txt search "\"" "$epos +1c" "$pos lineend"] |
---|
621 | } |
---|
622 | # did we hit the end of line? |
---|
623 | if {$epos == ""} { |
---|
624 | set epos [$txt index "$pos lineend"] |
---|
625 | append 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" |
---|
626 | } |
---|
627 | $txt mark set $CIF(markcount).l "$pos" |
---|
628 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
629 | $txt mark gravity $CIF(markcount).l left |
---|
630 | $txt mark gravity $CIF(markcount).r right |
---|
631 | set item [$txt get $pos "$epos +1c"] |
---|
632 | # move forward past current token |
---|
633 | set pos [$txt index "$epos +2c"] |
---|
634 | } elseif {[$txt get $pos] == {'}} { |
---|
635 | # a quoted string -- find next quote |
---|
636 | set epos [$txt search {'} "$pos +1c" "$pos lineend"] |
---|
637 | # skip over quotes followed by a non-blank |
---|
638 | while {$epos != "" && \ |
---|
639 | [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} { |
---|
640 | set epos [$txt search {'} "$epos +1c" "$pos lineend"] |
---|
641 | } |
---|
642 | # did we hit the end of line? |
---|
643 | if {$epos == ""} { |
---|
644 | set epos [$txt index "$pos lineend"] |
---|
645 | append 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" |
---|
646 | } |
---|
647 | $txt mark set $CIF(markcount).l "$pos" |
---|
648 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
649 | $txt mark gravity $CIF(markcount).l left |
---|
650 | $txt mark gravity $CIF(markcount).r right |
---|
651 | set item [$txt get $pos "$epos +1c"] |
---|
652 | # move forward past current token |
---|
653 | set pos [$txt index "$epos + 2 c"] |
---|
654 | } elseif {[$txt get $pos] == {[}} { |
---|
655 | # CIF v1.1 square bracket quotes |
---|
656 | set count 1 |
---|
657 | set epos $pos |
---|
658 | while {$count != 0} { |
---|
659 | set epos [$txt search -regexp {[\]\[]} "$epos +1c"] |
---|
660 | if {$epos == ""} { |
---|
661 | # unmatched open square bracket |
---|
662 | append block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n" |
---|
663 | set count 0 |
---|
664 | set epos [$txt index end] |
---|
665 | } elseif {[$txt get $epos] == {]}} { |
---|
666 | # close bracket -- decrement |
---|
667 | incr count -1 |
---|
668 | } else { |
---|
669 | # open bracket -- increment |
---|
670 | incr count |
---|
671 | } |
---|
672 | } |
---|
673 | $txt mark set $CIF(markcount).l "$pos" |
---|
674 | $txt mark set $CIF(markcount).r "$epos + 1c" |
---|
675 | $txt mark gravity $CIF(markcount).l left |
---|
676 | $txt mark gravity $CIF(markcount).r right |
---|
677 | set item [$txt get $pos "$epos +1c"] |
---|
678 | # move forward past current token |
---|
679 | set pos [$txt index "$epos + 2 c"] |
---|
680 | } else { |
---|
681 | # must be a single space-delimited value |
---|
682 | $txt mark set $CIF(markcount).l $pos |
---|
683 | $txt mark set $CIF(markcount).r $epos |
---|
684 | $txt mark gravity $CIF(markcount).l left |
---|
685 | $txt mark gravity $CIF(markcount).r right |
---|
686 | set item $token |
---|
687 | set pos [$txt index "$epos + 1 c"] |
---|
688 | } |
---|
689 | # a data item has been read |
---|
690 | |
---|
691 | # store the data item |
---|
692 | if {$loopflag >= 0} { |
---|
693 | # if in a loop, increment the loop element counter to select the |
---|
694 | # appropriate array element |
---|
695 | incr loopflag |
---|
696 | set i [expr ($loopflag - 1) % [llength $looplist]] |
---|
697 | lappend block${blocks}([lindex $looplist $i]) $CIF(markcount) |
---|
698 | } elseif {$dataname == ""} { |
---|
699 | # this is an error -- a data item where we do not expect one |
---|
700 | append block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n" |
---|
701 | } else { |
---|
702 | if {$blocks == 0} { |
---|
703 | # an error -- a data name before a data_ block start |
---|
704 | global block${blocks} |
---|
705 | set block${blocks}(data_) undefined |
---|
706 | append block${blocks}(errors) \ |
---|
707 | "Data name $dataname appears before a data_ block is defined (line [lindex [split $pos .] 0])\n" |
---|
708 | } |
---|
709 | catch { |
---|
710 | if {[set block${blocks}($dataname)] != ""} { |
---|
711 | # this is an error -- repeated data name |
---|
712 | append block${blocks}(errors) \ |
---|
713 | "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n" |
---|
714 | } |
---|
715 | } |
---|
716 | set block${blocks}($dataname) $CIF(markcount) |
---|
717 | set dataname "" |
---|
718 | } |
---|
719 | } |
---|
720 | $txt see 1.0 |
---|
721 | return $blocks |
---|
722 | } |
---|
723 | |
---|
724 | #------------------------------------------------------------------------------ |
---|
725 | # Create a CIF browser/editor |
---|
726 | # $txt is a text widget with the entire CIF loaded |
---|
727 | # blocklist contains the list of defined blocks (by #) |
---|
728 | # selected is the list of blocks that will be expanded |
---|
729 | # frame gives the name of the toplevel window to hold the browser |
---|
730 | proc BrowseCIF {txt blocklist "selected {}" "frame .cif"} { |
---|
731 | catch {destroy $frame} |
---|
732 | toplevel $frame |
---|
733 | wm title $frame "CIF Browser" |
---|
734 | CIFOpenBrowser $frame |
---|
735 | CIFBrowser $txt $blocklist $selected $frame |
---|
736 | grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1 |
---|
737 | } |
---|
738 | |
---|
739 | # Populate a hierarchical CIF browser |
---|
740 | # $txt is a text widget with the entire CIF loaded |
---|
741 | # blocklist contains the list of defined blocks (by #) |
---|
742 | # selected is the list of blocks that will be expanded |
---|
743 | # frame gives the name of the toplevel or frame to hold the browser |
---|
744 | proc CIFBrowser {txt blocklist "selected {}" "frame .cif"} { |
---|
745 | global CIF CIFtreeindex CIF_dataname_index |
---|
746 | |
---|
747 | if {$selected == ""} {set selected $blocklist} |
---|
748 | |
---|
749 | # clear out old info, if any, from browser |
---|
750 | eval $CIF(tree) delete [$CIF(tree) nodes root] |
---|
751 | catch {unset CIFtreeindex} |
---|
752 | # remove the loop counter frame from window & edit buttons from that frame |
---|
753 | grid forget $CIF(LoopBar) |
---|
754 | pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry) |
---|
755 | # delete old contents of frame |
---|
756 | set frame [$CIF(displayFrame) getframe] |
---|
757 | eval destroy [grid slaves $frame] |
---|
758 | set CIF(widgetlist) {} |
---|
759 | # reset the scrollbars |
---|
760 | $CIF(tree) see 0 |
---|
761 | $CIF(displayFrame) xview moveto 0 |
---|
762 | $CIF(displayFrame) yview moveto 0 |
---|
763 | |
---|
764 | # Bwidget seems to have problems with the name "1", so avoid it |
---|
765 | set num 100 |
---|
766 | foreach n $blocklist { |
---|
767 | global block$n |
---|
768 | # make a list of data names in loops |
---|
769 | set looplist {} |
---|
770 | foreach loop [array names block$n loop_*] { |
---|
771 | eval lappend looplist [set block${n}($loop)] |
---|
772 | } |
---|
773 | # put the block name |
---|
774 | set blockname [set block${n}(data_)] |
---|
775 | set open 0 |
---|
776 | if {[lsearch $selected $n] != -1} {set open 1} |
---|
777 | $CIF(tree) insert end root block$n -text "_data_$blockname" \ |
---|
778 | -open $open -image [Bitmap::get folder] |
---|
779 | |
---|
780 | # show errors, if any |
---|
781 | foreach name [array names block$n errors] { |
---|
782 | $CIF(tree) insert end block$n [incr num] -text "Parse-errors" \ |
---|
783 | -image [Bitmap::get undo] -data block$n |
---|
784 | } |
---|
785 | # loop over the names in each block |
---|
786 | foreach name [lsort [array names block$n _*]] { |
---|
787 | # don't include looped names |
---|
788 | if {[lsearch $looplist $name] == -1} { |
---|
789 | $CIF(tree) insert end block$n [incr num] -text $name \ |
---|
790 | -image [Bitmap::get file] -data block$n |
---|
791 | set CIFtreeindex(block${n}$name) $num |
---|
792 | } |
---|
793 | } |
---|
794 | foreach loop [lsort [array names block$n loop_*]] { |
---|
795 | # make a list of categories used in the loop |
---|
796 | set catlist {} |
---|
797 | foreach name [lsort [set block${n}($loop)]] { |
---|
798 | set category {} |
---|
799 | catch { |
---|
800 | foreach {type range elist esd units category} \ |
---|
801 | [lindex $CIF_dataname_index($name) 1] {} |
---|
802 | } |
---|
803 | if {$category != "" && [lsearch $catlist $category] == -1} { |
---|
804 | lappend catlist $category |
---|
805 | } |
---|
806 | } |
---|
807 | |
---|
808 | $CIF(tree) insert end block$n block${n}$loop \ |
---|
809 | -text "$loop ($catlist)" \ |
---|
810 | -image [Bitmap::get copy] -data "block$n loop" |
---|
811 | set CIFtreeindex(block${n}$loop) block${n}$loop |
---|
812 | foreach name [lsort [set block${n}($loop)]] { |
---|
813 | $CIF(tree) insert end block${n}$loop [incr num] -text $name \ |
---|
814 | -image [Bitmap::get file] -data "block$n $loop" |
---|
815 | set CIFtreeindex(block${n}$name) $num |
---|
816 | } |
---|
817 | } |
---|
818 | } |
---|
819 | $CIF(tree) bindImage <1> showCIFbyTreeID |
---|
820 | $CIF(tree) bindText <1> showCIFbyTreeID |
---|
821 | set CIF(tree_lastindex) $num |
---|
822 | } |
---|
823 | |
---|
824 | # Create the widgets for a hierarchical CIF browser in $frame |
---|
825 | # (where $frame is a frame or toplevel) |
---|
826 | # note that the BWidget package is required |
---|
827 | proc CIFOpenBrowser {frame} { |
---|
828 | global CIF |
---|
829 | if [catch {package require BWidget}] { |
---|
830 | tk_dialog .error {No BWidget} \ |
---|
831 | "Sorry, the CIF Browser requires the BWidget package" \ |
---|
832 | warning 0 Sorry |
---|
833 | return |
---|
834 | } |
---|
835 | |
---|
836 | set pw [PanedWindow $frame.pw -side top] |
---|
837 | grid $pw -sticky news -column 0 -row 0 |
---|
838 | set CIF(LoopBar) [frame $frame.f] |
---|
839 | #grid $CIF(LoopBar) -sticky es -column 0 -row 1 |
---|
840 | set width 900 |
---|
841 | if {$width > [winfo screenwidth .]} {set width [winfo screenwidth .]} |
---|
842 | grid columnconfigure $frame 0 -weight 1 -minsize $width |
---|
843 | # shrink browser on small screens |
---|
844 | set h 250 |
---|
845 | if {[winfo screenheight .] < 500} {set h 180} |
---|
846 | grid rowconfigure $frame 0 -minsize $h -weight 1 |
---|
847 | |
---|
848 | # create a left hand side pane for the hierarchical tree |
---|
849 | set pane [$pw add -weight 1] |
---|
850 | set sw [ScrolledWindow $pane.lf \ |
---|
851 | -relief sunken -borderwidth 2] |
---|
852 | set CIF(tree) [Tree $sw.tree \ |
---|
853 | -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \ |
---|
854 | -redraw 1] |
---|
855 | # get the size of the font and adjust the line spacing accordingly |
---|
856 | catch { |
---|
857 | set font [option get $CIF(tree) font Canvas] |
---|
858 | $CIF(tree) configure -deltay [font metrics $font -linespace] |
---|
859 | } |
---|
860 | bind $frame <KeyPress-Prior> "$CIF(tree) yview scroll -1 page" |
---|
861 | bind $frame <KeyPress-Next> "$CIF(tree) yview scroll 1 page" |
---|
862 | # bind $frame <KeyPress-Up> "$CIF(tree) yview scroll -1 unit" |
---|
863 | # bind $frame <KeyPress-Down> "$CIF(tree) yview scroll 1 unit" |
---|
864 | bind $frame <KeyPress-Home> "$CIF(tree) yview moveto 0" |
---|
865 | #bind $frame <KeyPress-End> "$CIF(tree) yview moveto end" -- does not work |
---|
866 | bind $frame <KeyPress-End> "$CIF(tree) yview scroll 99999999 page" |
---|
867 | grid $sw |
---|
868 | grid $sw -sticky news -column 0 -row 0 |
---|
869 | grid columnconfigure $pane 0 -minsize 275 -weight 1 |
---|
870 | grid rowconfigure $pane 0 -weight 1 |
---|
871 | $sw setwidget $CIF(tree) |
---|
872 | |
---|
873 | # create a right hand side pane to show the value |
---|
874 | set pane [$pw add -weight 4] |
---|
875 | set sw [ScrolledWindow $pane.sw \ |
---|
876 | -relief sunken -borderwidth 2] |
---|
877 | pack $sw -fill both -expand yes -side top |
---|
878 | |
---|
879 | set CIF(AddtoLoopButton) [button $CIF(LoopBar).l -text "Add to loop"] |
---|
880 | set CIF(DeleteLoopEntry) [button $CIF(LoopBar).d \ |
---|
881 | -text "Delete loop entry" -command DeleteCIFRow] |
---|
882 | label $CIF(LoopBar).1 -text "Loop\nelement #" |
---|
883 | set CIF(LoopSpinBox) [SpinBox $CIF(LoopBar).2 -range "1 1 1" -width 5] |
---|
884 | pack $CIF(LoopBar).2 $CIF(LoopBar).1 -side right |
---|
885 | set CIF(displayFrame) $sw.lb |
---|
886 | set lb [ScrollableFrame::create $CIF(displayFrame) -width 400] |
---|
887 | $sw setwidget $lb |
---|
888 | } |
---|
889 | |
---|
890 | # Warn to save changes that are not saved in a file |
---|
891 | proc CheckForCIFEdits {} { |
---|
892 | #puts "CheckForCIFEdits [info level [expr [info level]-1]]" |
---|
893 | global CIF |
---|
894 | set errorlist {} |
---|
895 | set errorflag 0 |
---|
896 | set msg "The following edits cannot be saved due to errors:\n" |
---|
897 | foreach widget $CIF(widgetlist) { |
---|
898 | CheckChanges $widget 1 |
---|
899 | if {$CIF(errormsg) != ""} { |
---|
900 | set errorflag 1 |
---|
901 | foreach err $CIF(errormsg) { |
---|
902 | append msg " " $err \n |
---|
903 | } |
---|
904 | } |
---|
905 | |
---|
906 | } |
---|
907 | if {$errorflag} { |
---|
908 | append msg \n {Do you want to make corrections, or discard these edits?} |
---|
909 | set ans [MyMessageBox -parent . -title "Invalid edits" \ |
---|
910 | -message $msg -icon error -type "Correct Discard" \ |
---|
911 | -default correct] |
---|
912 | if {$ans == "correct"} { |
---|
913 | # if not, don't allow the mode/loop value to change |
---|
914 | set CIF(editmode) 1 |
---|
915 | catch { |
---|
916 | $CIF(LoopSpinBox) setvalue @$CIF(lastLoopIndex) |
---|
917 | } |
---|
918 | return 1 |
---|
919 | } |
---|
920 | } |
---|
921 | return 0 |
---|
922 | } |
---|
923 | |
---|
924 | # showCIFbyTreeID is used in BrowseCIF to response to clicking on a tree widget |
---|
925 | # shows the contents data name or a loop |
---|
926 | proc showCIFbyTreeID {name} { |
---|
927 | if {[CheckForCIFEdits]} return |
---|
928 | |
---|
929 | global CIF |
---|
930 | # code to allow multiple selection within loops |
---|
931 | #set loopname [lindex [$CIF(tree) itemcget $name -data] 1] |
---|
932 | #set addtolist 1 |
---|
933 | #if {$loopname == "" || $loopname == "loop"} {set addtolist 0} |
---|
934 | #foreach n $CIF(treeSelectedList) { |
---|
935 | #if {$loopname != [lindex [$CIF(tree) itemcget $n -data] 1]} { |
---|
936 | # set addtolist 0 |
---|
937 | # break |
---|
938 | #} |
---|
939 | #} |
---|
940 | #if {$addtolist} { |
---|
941 | #catch {$CIF(tree) itemconfigure $name -fill red} |
---|
942 | #lappend CIF(treeSelectedList) $name |
---|
943 | #} else { |
---|
944 | foreach n $CIF(treeSelectedList) { |
---|
945 | catch {$CIF(tree) itemconfigure $n -fill black} |
---|
946 | } |
---|
947 | set CIF(treeSelectedList) $name |
---|
948 | # for some reason, BWidget sometimes has problems doing this: |
---|
949 | # (but ignore the error) |
---|
950 | catch {$CIF(tree) itemconfigure $name -fill red} |
---|
951 | set CIF(lastShownTreeID) $name |
---|
952 | set pointer [$CIF(tree) itemcget $name -data] |
---|
953 | set dataname [lindex [$CIF(tree) itemcget $name -text] 0] |
---|
954 | showCIFbyDataname $pointer $dataname |
---|
955 | #} |
---|
956 | } |
---|
957 | |
---|
958 | proc showCIFbyDataname {pointer dataname "loopindex {}"} { |
---|
959 | global CIF CIFtreeindex |
---|
960 | set CIF(lastShownItem) [list $pointer $dataname] |
---|
961 | # remove the loop counter frame from window & edit buttons from that frame |
---|
962 | grid forget $CIF(LoopBar) |
---|
963 | pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry) |
---|
964 | |
---|
965 | # delete old contents of frame |
---|
966 | set frame [$CIF(displayFrame) getframe] |
---|
967 | eval destroy [grid slaves $frame] |
---|
968 | # reset the scrollbars |
---|
969 | $CIF(displayFrame) xview moveto 0 |
---|
970 | $CIF(displayFrame) yview moveto 0 |
---|
971 | # leave room for a scrollbar |
---|
972 | grid columnconfig $frame 0 -minsize [expr \ |
---|
973 | [winfo width [winfo parent $frame]] - 20] |
---|
974 | if {$pointer == ""} { |
---|
975 | return |
---|
976 | } |
---|
977 | # create list of widgets defined here |
---|
978 | set CIF(widgetlist) {} |
---|
979 | |
---|
980 | # is this a looped data item? |
---|
981 | set block [lindex $pointer 0] |
---|
982 | if {[llength $pointer] == 2} { |
---|
983 | global $block |
---|
984 | # display contents of a rows of the loop |
---|
985 | if {[lindex $pointer 1] == "loop"} { |
---|
986 | if {$CIF(editmode)} { |
---|
987 | pack $CIF(DeleteLoopEntry) -side right |
---|
988 | pack $CIF(AddtoLoopButton) -side right |
---|
989 | $CIF(AddtoLoopButton) config -command "AddToCIFloop ${block} $dataname" |
---|
990 | } |
---|
991 | set looplist [set ${block}($dataname)] |
---|
992 | # get number of elements for first name |
---|
993 | set names [llength [set ${block}([lindex $looplist 0])]] |
---|
994 | # can't delete the only entry |
---|
995 | if {$names == 1 && $CIF(editmode)} { |
---|
996 | $CIF(DeleteLoopEntry) configure -state disabled |
---|
997 | } else { |
---|
998 | $CIF(DeleteLoopEntry) configure -state normal |
---|
999 | } |
---|
1000 | $CIF(LoopSpinBox) configure -range "1 $names 1" \ |
---|
1001 | -command "ShowLoopVar ${block} $dataname" \ |
---|
1002 | -modifycmd "ShowLoopVar ${block} $dataname" |
---|
1003 | set CIF(lastLoopIndex) {} |
---|
1004 | if {$loopindex == ""} { |
---|
1005 | $CIF(LoopSpinBox) setvalue first |
---|
1006 | } else { |
---|
1007 | $CIF(LoopSpinBox) setvalue @$loopindex |
---|
1008 | } |
---|
1009 | # show the loop counter frame |
---|
1010 | grid $CIF(LoopBar) -sticky es -column 0 -row 1 |
---|
1011 | set row 0 |
---|
1012 | set i 0 |
---|
1013 | ShowDictionaryDefinition $looplist |
---|
1014 | foreach var $looplist { |
---|
1015 | incr i |
---|
1016 | grid [TitleFrame $frame.$i -text $var -side left] \ |
---|
1017 | -column 0 -row $i -sticky ew |
---|
1018 | set row $i |
---|
1019 | set frame0 [$frame.$i getframe] |
---|
1020 | DisplayCIFvalue $frame0.l $var 1 "" ${block} |
---|
1021 | grid columnconfig $frame0 2 -weight 1 |
---|
1022 | } |
---|
1023 | ShowLoopVar ${block} $dataname |
---|
1024 | } else { |
---|
1025 | # look at a single looped variable |
---|
1026 | ShowDictionaryDefinition $dataname |
---|
1027 | grid [TitleFrame $frame.0 -text $dataname -side left] \ |
---|
1028 | -column 0 -row 0 -sticky ew |
---|
1029 | set row 0 |
---|
1030 | set i 0 |
---|
1031 | set frame0 [$frame.0 getframe] |
---|
1032 | grid columnconfig $frame0 2 -weight 1 |
---|
1033 | # maximum number of entries |
---|
1034 | set maxcols 100 |
---|
1035 | catch { |
---|
1036 | set maxcols $CIF(maxRows) |
---|
1037 | } |
---|
1038 | if {[set l [llength [set ${block}($dataname)]]] > $maxcols} { |
---|
1039 | grid [label $frame0.a$i -justify left \ |
---|
1040 | -text "$dataname has $l entries, too many to display by column" \ |
---|
1041 | ] -sticky w -column 0 -row $i |
---|
1042 | return |
---|
1043 | } |
---|
1044 | foreach mark [set ${block}($dataname)] { |
---|
1045 | incr i |
---|
1046 | if {$i == 1} {$CIF(txt) see $mark.l} |
---|
1047 | set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1048 | grid [label $frame0.a$i -justify left -text $i]\ |
---|
1049 | -sticky w -column 0 -row $i |
---|
1050 | DisplayCIFvalue $frame0.b$i $dataname $i $value ${block} $i |
---|
1051 | #grid $frame0.b$i -sticky new -column 1 -row $i |
---|
1052 | } |
---|
1053 | } |
---|
1054 | } else { |
---|
1055 | # unlooped data name |
---|
1056 | global ${block} |
---|
1057 | ShowDictionaryDefinition $dataname |
---|
1058 | grid [TitleFrame $frame.0 -text $dataname -side left] \ |
---|
1059 | -column 0 -row 0 -sticky ew |
---|
1060 | set row 0 |
---|
1061 | if {$dataname == "Parse-errors"} { |
---|
1062 | set value [set ${block}(errors)] |
---|
1063 | } elseif {$dataname == "Validation-errors"} { |
---|
1064 | set value [set ${block}(validate)] |
---|
1065 | } else { |
---|
1066 | set mark [set ${block}($dataname)] |
---|
1067 | set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1068 | $CIF(txt) see $mark.l |
---|
1069 | } |
---|
1070 | set frame0 [$frame.0 getframe] |
---|
1071 | grid columnconfig $frame0 2 -weight 1 |
---|
1072 | DisplayCIFvalue $frame0.l $dataname "" $value $block |
---|
1073 | #grid $frame0.l -sticky w -column 1 -row 0 |
---|
1074 | } |
---|
1075 | } |
---|
1076 | |
---|
1077 | # redisplay the last entry shown in showCIFbyTreeID |
---|
1078 | # this is used if the edit mode ($CIF(editmode)) changes or if edits are saved |
---|
1079 | proc RepeatLastshowCIFvalue {} { |
---|
1080 | global CIF |
---|
1081 | if {[CheckForCIFEdits]} return |
---|
1082 | set lastLoopIndex $CIF(lastLoopIndex) |
---|
1083 | |
---|
1084 | catch { |
---|
1085 | eval showCIFbyDataname $CIF(lastShownItem) |
---|
1086 | # if we are in a loop, display the element |
---|
1087 | if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} { |
---|
1088 | $CIF(LoopSpinBox) setvalue @$lastLoopIndex |
---|
1089 | ShowLoopVar [lindex [lindex $CIF(lastShownItem) 0] 0] \ |
---|
1090 | [lindex $CIF(lastShownItem) 1] |
---|
1091 | } |
---|
1092 | |
---|
1093 | } |
---|
1094 | } |
---|
1095 | |
---|
1096 | # used in BrowseCIF in response to the spinbox |
---|
1097 | # show entries in a specific row of a loop |
---|
1098 | proc ShowLoopVar {array loop} { |
---|
1099 | global $array CIF |
---|
1100 | # check for unsaved changes here |
---|
1101 | if {$CIF(lastLoopIndex) != ""} { |
---|
1102 | if {[CheckForCIFEdits]} return |
---|
1103 | } |
---|
1104 | |
---|
1105 | set looplist [set ${array}($loop)] |
---|
1106 | set index [$CIF(LoopSpinBox) getvalue] |
---|
1107 | if {$index < 0} { |
---|
1108 | $CIF(LoopSpinBox) setvalue first |
---|
1109 | set index [$CIF(LoopSpinBox) getvalue] |
---|
1110 | } elseif {$index > [llength [set ${array}([lindex $looplist 0])]]} { |
---|
1111 | $CIF(LoopSpinBox) setvalue last |
---|
1112 | set index [$CIF(LoopSpinBox) getvalue] |
---|
1113 | } |
---|
1114 | set CIF(lastLoopIndex) $index |
---|
1115 | set frame [$CIF(displayFrame) getframe] |
---|
1116 | set i 0 |
---|
1117 | foreach var $looplist { |
---|
1118 | incr i |
---|
1119 | set mark [lindex [set ${array}($var)] $index] |
---|
1120 | # ignore invalid entries -- should not happen |
---|
1121 | if {$mark == ""} { |
---|
1122 | $CIF(LoopSpinBox) setvalue first |
---|
1123 | return |
---|
1124 | } |
---|
1125 | set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1126 | if {$i == 1} {$CIF(txt) see $mark.l} |
---|
1127 | if {$CIF(editmode)} { |
---|
1128 | global CIFeditArr CIFinfoArr |
---|
1129 | set widget [$frame.$i getframe].l |
---|
1130 | set CIFeditArr($widget) $value |
---|
1131 | switch [winfo class $widget] { |
---|
1132 | Text { |
---|
1133 | $widget delete 0.0 end |
---|
1134 | $widget insert end $value |
---|
1135 | } |
---|
1136 | Entry { |
---|
1137 | $widget config -fg black |
---|
1138 | } |
---|
1139 | } |
---|
1140 | set CIFinfoArr($widget) [lreplace $CIFinfoArr($widget) 2 2 $index] |
---|
1141 | } else { |
---|
1142 | [$frame.$i getframe].l config -text $value |
---|
1143 | } |
---|
1144 | } |
---|
1145 | } |
---|
1146 | |
---|
1147 | # scan a number in crystallographic uncertainty representation |
---|
1148 | # i.e.: 1.234(12), 1234(23), 1.234e-2(14), -1.234-08(14), etc. |
---|
1149 | proc ParseSU {num} { |
---|
1150 | # is there an error on this value? |
---|
1151 | if {![regexp {([-+eEdD.0-9]+)\(([0-9]+)\)} $num x a err]} { |
---|
1152 | set a $num |
---|
1153 | set err {} |
---|
1154 | } |
---|
1155 | # parse off an exponent, if present |
---|
1156 | if {[regexp {([-+.0-9]+)[EeDd]([-+0-9]+)} $a x a1 exp]} { |
---|
1157 | # [+-]###.###e+## or [+-]###.###D-## etc. |
---|
1158 | set a $a1 |
---|
1159 | # remove leading zeros from exponent |
---|
1160 | regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp |
---|
1161 | } elseif {[regexp {([-+.0-9]+)([-+][0-9]+)} $a x a1 exp]} { |
---|
1162 | # [+-]###.###+## or [+-]###.###-## etc. [no |
---|
1163 | set a $a1 |
---|
1164 | # remove leading zeros from exponent |
---|
1165 | regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp |
---|
1166 | } else { |
---|
1167 | set exp 0 |
---|
1168 | } |
---|
1169 | # now parse the main number and count the digits after the decimal |
---|
1170 | set a2 {} |
---|
1171 | set a3 {} |
---|
1172 | regexp {^([-+0-9]*)\.?([0-9]*)$} $a x a2 a3 |
---|
1173 | set l [string length $a3] |
---|
1174 | |
---|
1175 | set val . |
---|
1176 | set error {} |
---|
1177 | if {[catch { |
---|
1178 | set val [expr ${a2}.${a3} * pow(10,$exp)] |
---|
1179 | if {$err != ""} { |
---|
1180 | set error [expr $err*pow(10,$exp-$l)] |
---|
1181 | } |
---|
1182 | }]} { |
---|
1183 | # something above was invalid |
---|
1184 | if {$err != ""} { |
---|
1185 | return "$val ." |
---|
1186 | } else { |
---|
1187 | return $val |
---|
1188 | } |
---|
1189 | } |
---|
1190 | if {$error == ""} { |
---|
1191 | return $val |
---|
1192 | } else { |
---|
1193 | return [list $val $error] |
---|
1194 | } |
---|
1195 | } |
---|
1196 | |
---|
1197 | # a stand-alone routine for testing. Select, read and browse a CIF |
---|
1198 | proc Read_BrowseCIF {} { |
---|
1199 | global tcl_platform |
---|
1200 | if {$tcl_platform(platform) == "windows"} { |
---|
1201 | set filetypelist { |
---|
1202 | {"CIF files" .CIF} {"All files" *} |
---|
1203 | } |
---|
1204 | } else { |
---|
1205 | set filetypelist { |
---|
1206 | {"CIF files" .CIF} {"CIF files" .cif} {"All files" *} |
---|
1207 | } |
---|
1208 | } |
---|
1209 | set file [tk_getOpenFile -parent . -filetypes $filetypelist] |
---|
1210 | if {$file == ""} return |
---|
1211 | if {![file exists $file]} return |
---|
1212 | pleasewait "Reading CIF from file" |
---|
1213 | set blocks [ParseCIF $file] |
---|
1214 | if {$blocks == ""} { |
---|
1215 | donewait |
---|
1216 | MessageBox -parent . -type ok -icon warning \ |
---|
1217 | -message "Note: no valid CIF blocks were read from file $filename" |
---|
1218 | return |
---|
1219 | } |
---|
1220 | catch {donewait} |
---|
1221 | set allblocks {} |
---|
1222 | for {set i 1} {$i <= $blocks} {incr i} { |
---|
1223 | lappend allblocks $i |
---|
1224 | } |
---|
1225 | if {$allblocks != ""} { |
---|
1226 | BrowseCIF $allblocks "" .cif |
---|
1227 | # wait for the window to close |
---|
1228 | tkwait window .cif |
---|
1229 | } else { |
---|
1230 | puts "no blocks read" |
---|
1231 | } |
---|
1232 | # clean up -- get rid of the CIF arrays |
---|
1233 | for {set i 1} {$i <= $blocks} {incr i} { |
---|
1234 | global block$i |
---|
1235 | catch {unset block$i} |
---|
1236 | } |
---|
1237 | } |
---|
1238 | |
---|
1239 | # this takes a block of text, strips off the quotes ("", '', [] or ;;) |
---|
1240 | proc StripQuotes {value} { |
---|
1241 | set value [string trim $value] |
---|
1242 | if {[string range $value end-1 end] == "\n;" && \ |
---|
1243 | [string range $value 0 0] == ";"} { |
---|
1244 | return [string range $value 1 end-2] |
---|
1245 | } elseif {[string range $value end end] == "\"" && \ |
---|
1246 | [string range $value 0 0] == "\""} { |
---|
1247 | set value [string range $value 1 end-1] |
---|
1248 | } elseif {[string range $value end end] == "'" && \ |
---|
1249 | [string range $value 0 0] == "'"} { |
---|
1250 | set value [string range $value 1 end-1] |
---|
1251 | } elseif {[string range $value end end] == {]} && \ |
---|
1252 | [string range $value 0 0] == {[}} { |
---|
1253 | set value [string range $value 1 end-1] |
---|
1254 | } |
---|
1255 | return $value |
---|
1256 | } |
---|
1257 | |
---|
1258 | # replace a CIF value in with a new value. |
---|
1259 | # add newlines as needed to make sure the new value does not |
---|
1260 | # exceed CIF(maxlinelength) [defaults to 80] characters/line |
---|
1261 | proc ReplaceMarkedText {txt mark value} { |
---|
1262 | $txt configure -state normal |
---|
1263 | # is this a multi-line string? |
---|
1264 | set num [string first \n $value] |
---|
1265 | set l [string length $value] |
---|
1266 | # are there spaces in the string? |
---|
1267 | set spaces [string first " " $value] |
---|
1268 | # if no, are there any square brackets? -- treat them as requiring quotes |
---|
1269 | if {$spaces == -1} {set spaces [string first {[} $value]} |
---|
1270 | # are there any reserved strings inside $value? If so, it must be quoted |
---|
1271 | if {$spaces == -1} { |
---|
1272 | set tmp [string toupper $value] |
---|
1273 | foreach s {DATA_ LOOP_ SAVE_ STOP_ GLOBAL_} { |
---|
1274 | if {[set spaces [string first $s $tmp]] != -1} break |
---|
1275 | } |
---|
1276 | } |
---|
1277 | # are there quotes inside the string? |
---|
1278 | set doublequote [string first "\"" $value] |
---|
1279 | set singlequote [string first {'} $value] |
---|
1280 | # if we have either type of quotes, use semicolon quoting |
---|
1281 | if {$singlequote != -1 && $doublequote != -1} {set num $l} |
---|
1282 | |
---|
1283 | # lines longer than 78 characters with spaces need to be treated |
---|
1284 | # as multiline |
---|
1285 | if {$num == -1 && $l > 77 && $spaces != -1} { |
---|
1286 | set num $l |
---|
1287 | } |
---|
1288 | if {$num != -1} { |
---|
1289 | set tmp {} |
---|
1290 | if {[lindex [split [$txt index $mark.l] .] 1] != 0} { |
---|
1291 | append tmp \n |
---|
1292 | } |
---|
1293 | append tmp ";" |
---|
1294 | if {$num > 78} { |
---|
1295 | append tmp \n |
---|
1296 | } else { |
---|
1297 | append tmp " " |
---|
1298 | } |
---|
1299 | append tmp $value "\n;" |
---|
1300 | # is there something else on the line? |
---|
1301 | set restofline [$txt get $mark.r [lindex [split [$txt index $mark.r] .] 0].end] |
---|
1302 | if {[string trim $restofline] != ""} { |
---|
1303 | append tmp \n |
---|
1304 | } |
---|
1305 | $txt delete ${mark}.l ${mark}.r |
---|
1306 | $txt insert ${mark}.l $tmp |
---|
1307 | $txt configure -state disabled |
---|
1308 | return |
---|
1309 | } elseif {($spaces != -1 || [string trim $value] == "") \ |
---|
1310 | && $doublequote == -1} { |
---|
1311 | # use doublequotes, unless doublequotes are present inside the string |
---|
1312 | set tmp "\"" |
---|
1313 | append tmp $value "\"" |
---|
1314 | } elseif {$spaces != -1 || [string trim $value] == ""} { |
---|
1315 | # use single quotes, since doublequotes are present inside the string |
---|
1316 | set tmp {'} |
---|
1317 | append tmp $value {'} |
---|
1318 | } else { |
---|
1319 | # no quotes needed |
---|
1320 | set tmp $value |
---|
1321 | } |
---|
1322 | # is there room on the beginning of the line to add the string? |
---|
1323 | set l [string length $tmp] |
---|
1324 | set pos [lindex [split [$txt index $mark.l] .] 0] |
---|
1325 | if {$l + [string length [$txt get $pos.0 $mark.l]] <= 79} { |
---|
1326 | # will fit |
---|
1327 | $txt delete ${mark}.l ${mark}.r |
---|
1328 | $txt insert ${mark}.l $tmp |
---|
1329 | } else { |
---|
1330 | # no, stick a CR in front of string |
---|
1331 | $txt delete ${mark}.l ${mark}.r |
---|
1332 | $txt insert ${mark}.l \n$tmp |
---|
1333 | } |
---|
1334 | # is rest of the line after the inserted string still too long? |
---|
1335 | set pos [lindex [split [$txt index $mark.r] .] 0] |
---|
1336 | if {[string length [$txt get $pos.0 $pos.end]] > 79} { |
---|
1337 | $txt insert $mark.r \n |
---|
1338 | } |
---|
1339 | $txt configure -state disabled |
---|
1340 | } |
---|
1341 | |
---|
1342 | # return the dictionary definition for a list of CIF data names |
---|
1343 | proc GetCIFDefinitions {datanamelist} { |
---|
1344 | global CIF_dataname_index |
---|
1345 | set l {} |
---|
1346 | # compile a list of definition pointers |
---|
1347 | foreach dataname $datanamelist { |
---|
1348 | set pointer {} |
---|
1349 | catch { |
---|
1350 | set pointer [lindex $CIF_dataname_index($dataname) 0] |
---|
1351 | } |
---|
1352 | lappend l [list $dataname $pointer] |
---|
1353 | } |
---|
1354 | set l [lsort -index 1 $l] |
---|
1355 | set pp {} |
---|
1356 | set dictdefs {} |
---|
1357 | set def {} |
---|
1358 | set nlist {} |
---|
1359 | # merge items with duplicate definitions |
---|
1360 | foreach item $l { |
---|
1361 | # is this the first loop through? |
---|
1362 | foreach {dataname pointer} $item {} |
---|
1363 | if {$def == ""} { |
---|
1364 | foreach {nlist pp} $item {} |
---|
1365 | set def [ReadCIFDefinition $pp] |
---|
1366 | } elseif {$pp == $pointer} { |
---|
1367 | # same as last |
---|
1368 | lappend nlist $dataname |
---|
1369 | } else { |
---|
1370 | # add the last entry to the list |
---|
1371 | set pp $pointer |
---|
1372 | lappend dictdefs [list $nlist $def] |
---|
1373 | set nlist $dataname |
---|
1374 | if {$pointer == ""} { |
---|
1375 | set def { Undefined dataname} |
---|
1376 | } else { |
---|
1377 | # lookup name |
---|
1378 | set def [ReadCIFDefinition $pointer] |
---|
1379 | } |
---|
1380 | } |
---|
1381 | } |
---|
1382 | lappend dictdefs [list $nlist $def] |
---|
1383 | return $dictdefs |
---|
1384 | } |
---|
1385 | |
---|
1386 | # read the CIF definition for a dataname. The pointer contains 3 values |
---|
1387 | # a filename, the number of characters from the start of the file and |
---|
1388 | # the length of the definition. |
---|
1389 | proc ReadCIFDefinition {pointer} { |
---|
1390 | global CIF |
---|
1391 | set file {} |
---|
1392 | set loc {} |
---|
1393 | set line {} |
---|
1394 | foreach {file loc len} $pointer {} |
---|
1395 | if {$file != "" && $loc != "" && $loc != ""} { |
---|
1396 | set fp {} |
---|
1397 | foreach path $CIF(cif_path) { |
---|
1398 | catch {set fp [open [file join $path $file] r]} |
---|
1399 | if {$fp != ""} break |
---|
1400 | } |
---|
1401 | if {$fp == ""} return |
---|
1402 | fconfigure $fp -translation binary |
---|
1403 | catch { |
---|
1404 | seek $fp $loc |
---|
1405 | set line [read $fp $len] |
---|
1406 | close $fp |
---|
1407 | # remove line ends & superfluous spaces |
---|
1408 | regsub -all {\n} [StripQuotes $line] { } line |
---|
1409 | regsub -all {\r} $line { } line |
---|
1410 | regsub -all { +} $line { } line |
---|
1411 | # regsub -all { +} [StripQuotes $line] { } line |
---|
1412 | } |
---|
1413 | } |
---|
1414 | return $line |
---|
1415 | } |
---|
1416 | |
---|
1417 | proc ValidateCIFName {dataname} { |
---|
1418 | global CIF_dataname_index |
---|
1419 | if {[ |
---|
1420 | catch { |
---|
1421 | set CIF_dataname_index($dataname) |
---|
1422 | } |
---|
1423 | ]} {return "warning: dataname $dataname not defined"} |
---|
1424 | } |
---|
1425 | |
---|
1426 | # validates that a CIF value is valid for a specific dataname |
---|
1427 | proc ValidateCIFItem {dataname item} { |
---|
1428 | global CIF_dataname_index CIF |
---|
1429 | # maximum line length |
---|
1430 | set maxlinelength 80 |
---|
1431 | catch {set maxlinelength $CIF(maxlinelength)} |
---|
1432 | if {[catch { |
---|
1433 | foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {} |
---|
1434 | }]} {return} |
---|
1435 | if {$type == "c"} { |
---|
1436 | # string type constant |
---|
1437 | set item [StripQuotes $item] |
---|
1438 | # is it enumerated? |
---|
1439 | if {$elist != ""} { |
---|
1440 | # check it against the list of values |
---|
1441 | foreach i [concat $elist . ?] { |
---|
1442 | if {[string tolower $item] == [string tolower [lindex $i 0]]} {return} |
---|
1443 | } |
---|
1444 | return "error: value \"$item\" is not an allowed option for $dataname" |
---|
1445 | } else { |
---|
1446 | # check it for line lengths |
---|
1447 | set l 0 |
---|
1448 | set err {} |
---|
1449 | foreach line [split $item \n] { |
---|
1450 | incr l |
---|
1451 | if {[string length $line] > $maxlinelength} {lappend err $l} |
---|
1452 | } |
---|
1453 | if {$err != ""} {return "error: line(s) $err are too long"} |
---|
1454 | } |
---|
1455 | return |
---|
1456 | } elseif {$type == ""} { |
---|
1457 | return "error: dataname $dataname is not used for CIF data items" |
---|
1458 | } elseif {$type == "n"} { |
---|
1459 | # validate numbers |
---|
1460 | set unquoted [StripQuotes $item] |
---|
1461 | if {$unquoted == "?" || $unquoted == "."} return |
---|
1462 | if {$unquoted != $item} { |
---|
1463 | set err "\nwarning: number $item is quoted for $dataname" |
---|
1464 | set item $unquoted |
---|
1465 | } else { |
---|
1466 | set err {} |
---|
1467 | } |
---|
1468 | set v $item |
---|
1469 | # remove s.u., if allowed & present |
---|
1470 | set vals [ParseSU $item] |
---|
1471 | if {[set v [lindex $vals 0]] == "."} { |
---|
1472 | return "error: value \"$item\" is not a valid number for $dataname$err" |
---|
1473 | } |
---|
1474 | if {$esd} { |
---|
1475 | if {[lindex $vals 1] == "."} { |
---|
1476 | return "error: value \"$item\" for $dataname has an invalid uncertainty (esd)$err" |
---|
1477 | } |
---|
1478 | } elseif {[llength $vals] == 2} { |
---|
1479 | return "error: \"$item\" is invalid for $dataname, an uncertainty (esd) is not allowed$err" |
---|
1480 | } |
---|
1481 | |
---|
1482 | # now validate the range |
---|
1483 | if {$range != ""} { |
---|
1484 | # is there a decimal point in the range? |
---|
1485 | set integer 0 |
---|
1486 | if {[string first . $range] == -1} {set integer 1} |
---|
1487 | # pull out the range |
---|
1488 | foreach {min max} [split $range :] {} |
---|
1489 | if {$integer && int($v) != $v} { |
---|
1490 | return "warning: value \"$item\" is expected to be an integer for $dataname$err" |
---|
1491 | } |
---|
1492 | if {$min != ""} { |
---|
1493 | if {$v < $min} { |
---|
1494 | return "error: value \"$item\" is too small for $dataname (allowed range $range)$err" |
---|
1495 | } |
---|
1496 | } |
---|
1497 | if {$max != ""} { |
---|
1498 | if {$v > $max} { |
---|
1499 | return "error: value \"$item\" is too big for $dataname(allowed range $range)$err" |
---|
1500 | } |
---|
1501 | } |
---|
1502 | } |
---|
1503 | return $err |
---|
1504 | } |
---|
1505 | return {} |
---|
1506 | } |
---|
1507 | |
---|
1508 | # displays the dictionary definitions in variable defs into a text widget |
---|
1509 | proc ShowDictionaryDefinition {defs} { |
---|
1510 | global CIF |
---|
1511 | set deflist [GetCIFDefinitions $defs] |
---|
1512 | catch { |
---|
1513 | $CIF(defBox) delete 1.0 end |
---|
1514 | foreach d $deflist { |
---|
1515 | foreach {namelist definition} $d {} |
---|
1516 | foreach n $namelist { |
---|
1517 | $CIF(defBox) insert end $n dataname |
---|
1518 | $CIF(defBox) insert end \n |
---|
1519 | } |
---|
1520 | $CIF(defBox) insert end \n |
---|
1521 | $CIF(defBox) insert end $definition |
---|
1522 | $CIF(defBox) insert end \n |
---|
1523 | $CIF(defBox) insert end \n |
---|
1524 | } |
---|
1525 | $CIF(defBox) tag config dataname -background yellow |
---|
1526 | } |
---|
1527 | } |
---|
1528 | |
---|
1529 | # create a widget to display a CIF value |
---|
1530 | proc DisplayCIFvalue {widget dataname loopval value block "row 0"} { |
---|
1531 | global CIFeditArr CIFinfoArr |
---|
1532 | global CIF CIF_dataname_index |
---|
1533 | if {[ |
---|
1534 | catch { |
---|
1535 | foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {} |
---|
1536 | } |
---|
1537 | ]} { |
---|
1538 | set type c |
---|
1539 | set elist {} |
---|
1540 | } |
---|
1541 | |
---|
1542 | lappend CIF(widgetlist) $widget |
---|
1543 | set CIFinfoArr($widget) {} |
---|
1544 | |
---|
1545 | if $CIF(editmode) { |
---|
1546 | if {$loopval != ""} { |
---|
1547 | set widgetinfo [list $dataname $block [expr $loopval -1]] |
---|
1548 | } else { |
---|
1549 | set widgetinfo [list $dataname $block 0] |
---|
1550 | } |
---|
1551 | set CIFeditArr($widget) $value |
---|
1552 | set CIFinfoArr($widget) $widgetinfo |
---|
1553 | |
---|
1554 | if {$type == "n"} { |
---|
1555 | entry $widget -justify left -textvariable CIFeditArr($widget) |
---|
1556 | bind $widget <Leave> "CheckChanges $widget" |
---|
1557 | grid $widget -sticky nsw -column 1 -row $row |
---|
1558 | if {$units != ""} { |
---|
1559 | set ws "${widget}u" |
---|
1560 | label $ws -text "($units)" -bg yellow |
---|
1561 | grid $ws -sticky nsw -column 2 -row $row |
---|
1562 | } |
---|
1563 | } elseif {$elist != ""} { |
---|
1564 | set enum {} |
---|
1565 | foreach e $elist { |
---|
1566 | lappend enum [lindex $e 0] |
---|
1567 | } |
---|
1568 | tk_optionMenu $widget CIFeditArr($widget) "" |
---|
1569 | FixBigOptionMenu $widget $enum "CheckChanges $widget" |
---|
1570 | AddSpecialEnumOpts $widget "CheckChanges $widget" |
---|
1571 | grid $widget -sticky nsw -column 1 -row $row |
---|
1572 | } else { |
---|
1573 | # count the number of lines in the text |
---|
1574 | set nlines [llength [split $value \n]] |
---|
1575 | if {$nlines < 1} { |
---|
1576 | set nlines 1 |
---|
1577 | } elseif {$nlines > 10} { |
---|
1578 | set nlines 10 |
---|
1579 | } |
---|
1580 | set ws "${widget}s" |
---|
1581 | text $widget -height $nlines -width 80 -yscrollcommand "$ws set" |
---|
1582 | scrollbar $ws -command "$widget yview" -width 10 -bd 1 |
---|
1583 | $widget insert end $value |
---|
1584 | bind $widget <Leave> "CheckChanges $widget" |
---|
1585 | if {$nlines > 1} { |
---|
1586 | grid $ws -sticky nsew -column 1 -row $row |
---|
1587 | grid $widget -sticky nsew -column 2 -row $row |
---|
1588 | } else { |
---|
1589 | grid $widget -sticky nsew -column 1 -columnspan 2 -row $row |
---|
1590 | } |
---|
1591 | } |
---|
1592 | } else { |
---|
1593 | label $widget -bd 2 -relief groove \ |
---|
1594 | -justify left -anchor w -text $value |
---|
1595 | grid $widget -sticky nsw -column 1 -row $row |
---|
1596 | if {$type == "n" && $units != ""} { |
---|
1597 | set ws "${widget}u" |
---|
1598 | label $ws -text "($units)" -bg yellow |
---|
1599 | grid $ws -sticky nsw -column 2 -row $row |
---|
1600 | } |
---|
1601 | } |
---|
1602 | } |
---|
1603 | |
---|
1604 | # this is called to see if the user has changed the value for a CIF |
---|
1605 | # data item and to validate it. |
---|
1606 | # save the change if $save is 1 |
---|
1607 | # return 1 if the widget contents has changed |
---|
1608 | proc CheckChanges {widget "save 0"} { |
---|
1609 | global CIFeditArr CIFinfoArr CIF |
---|
1610 | # maximum line length |
---|
1611 | set maxlinelength 80 |
---|
1612 | catch {set maxlinelength $CIF(maxlinelength)} |
---|
1613 | |
---|
1614 | set CIF(errormsg) {} |
---|
1615 | |
---|
1616 | if {![winfo exists $widget]} return |
---|
1617 | |
---|
1618 | set dataname {} |
---|
1619 | catch { |
---|
1620 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1621 | } |
---|
1622 | # if this widget is a label, the info above will not be defined & checks are not needed |
---|
1623 | if {$dataname == ""} {return 0} |
---|
1624 | if {$dataname == "Parse-errors"} {return 0} |
---|
1625 | if {$dataname == "Validation-errors"} {return 0} |
---|
1626 | |
---|
1627 | global ${block} |
---|
1628 | set mark [lindex [set ${block}($dataname)] $index] |
---|
1629 | if {$mark == ""} return |
---|
1630 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1631 | |
---|
1632 | # validate the entry |
---|
1633 | set error {} |
---|
1634 | set err {} |
---|
1635 | switch [winfo class $widget] { |
---|
1636 | Text { |
---|
1637 | set current [string trim [$widget get 1.0 end]] |
---|
1638 | set l 0 |
---|
1639 | foreach line [set linelist [split $current \n]] { |
---|
1640 | incr l |
---|
1641 | if {[string length $line] > $maxlinelength} { |
---|
1642 | lappend err $l |
---|
1643 | lappend error "Error: line $l for $dataname is >$maxlinelength characters" |
---|
1644 | } |
---|
1645 | } |
---|
1646 | if {$err != ""} { |
---|
1647 | foreach l $err { |
---|
1648 | $widget tag add error $l.0 $l.end |
---|
1649 | } |
---|
1650 | $widget tag config error -foreground red |
---|
1651 | } else { |
---|
1652 | $widget tag delete error |
---|
1653 | } |
---|
1654 | # see if box should expand |
---|
1655 | set clines [$widget cget -height] |
---|
1656 | if {$clines <= 2 && \ |
---|
1657 | [string trim $orig] != [string trim $current]} { |
---|
1658 | # count the number of lines in the text |
---|
1659 | set nlines [llength $linelist] |
---|
1660 | if {[lindex $linelist end] == ""} {incr nlines -1} |
---|
1661 | if {$nlines == 2} { |
---|
1662 | $widget config -height 2 |
---|
1663 | } elseif {$nlines > 2} { |
---|
1664 | set i [lsearch [set s [grid info $widget]] -row] |
---|
1665 | set row [lindex $s [expr 1+$i]] |
---|
1666 | $widget config -height 3 |
---|
1667 | set ws "${widget}s" |
---|
1668 | grid $ws -sticky nsew -column 1 -row $row |
---|
1669 | grid $widget -sticky nsew -column 2 -row $row |
---|
1670 | } |
---|
1671 | } |
---|
1672 | } |
---|
1673 | Entry { |
---|
1674 | set current [string trim [$widget get]] |
---|
1675 | set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current] |
---|
1676 | if {$err != "" && \ |
---|
1677 | [string tolower [lindex $err 0]] != "warning:"} { |
---|
1678 | lappend error $err |
---|
1679 | $widget config -fg red |
---|
1680 | } else { |
---|
1681 | $widget config -fg black |
---|
1682 | } |
---|
1683 | } |
---|
1684 | Menubutton { |
---|
1685 | set current $CIFeditArr($widget) |
---|
1686 | } |
---|
1687 | Label { |
---|
1688 | return 0 |
---|
1689 | } |
---|
1690 | } |
---|
1691 | if {[string trim $orig] != [string trim $current]} { |
---|
1692 | if {$err != ""} { |
---|
1693 | set CIF(errormsg) $error |
---|
1694 | } elseif {$save} { |
---|
1695 | SaveCIFedits $widget |
---|
1696 | return 0 |
---|
1697 | } |
---|
1698 | return 1 |
---|
1699 | } |
---|
1700 | return 0 |
---|
1701 | } |
---|
1702 | |
---|
1703 | # save the CIF edits into the CIF text widget |
---|
1704 | proc SaveCIFedits {widget} { |
---|
1705 | global CIFeditArr CIFinfoArr CIF |
---|
1706 | |
---|
1707 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1708 | global ${block} |
---|
1709 | set mark [lindex [set ${block}($dataname)] $index] |
---|
1710 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1711 | switch [winfo class $widget] { |
---|
1712 | Text { |
---|
1713 | set current [string trim [$widget get 1.0 end]] |
---|
1714 | } |
---|
1715 | Entry { |
---|
1716 | set current [string trim [$widget get]] |
---|
1717 | } |
---|
1718 | Menubutton { |
---|
1719 | set current $CIFeditArr($widget) |
---|
1720 | } |
---|
1721 | } |
---|
1722 | # save for undo & clear the redo list |
---|
1723 | set CIF(redolist) {} |
---|
1724 | if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} { |
---|
1725 | lappend CIF(undolist) [list $mark $orig \ |
---|
1726 | $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)] |
---|
1727 | } else { |
---|
1728 | lappend CIF(undolist) [list $mark $orig \ |
---|
1729 | $CIF(lastShownItem) $CIF(lastShownTreeID)] |
---|
1730 | } |
---|
1731 | # count it |
---|
1732 | incr CIF(changes) |
---|
1733 | # make the change |
---|
1734 | ReplaceMarkedText $CIF(txt) $mark $current |
---|
1735 | } |
---|
1736 | |
---|
1737 | # add a new "row" to a CIF loop. At least for now, we only add at the end. |
---|
1738 | proc AddToCIFloop {block loop} { |
---|
1739 | global $block CIF |
---|
1740 | # check for unsaved changes here |
---|
1741 | if {[CheckForCIFEdits]} return |
---|
1742 | |
---|
1743 | $CIF(txt) configure -state normal |
---|
1744 | set looplist [set ${block}($loop)] |
---|
1745 | set length [llength [set ${block}([lindex $looplist 0])]] |
---|
1746 | # find the line following the last entry in the list |
---|
1747 | set var [lindex $looplist end] |
---|
1748 | set line [lindex [split [\ |
---|
1749 | $CIF(txt) index [lindex [set ${block}($var)] end].r \ |
---|
1750 | ] .] 0] |
---|
1751 | incr line |
---|
1752 | set epos $line.0 |
---|
1753 | $CIF(txt) insert $epos \n |
---|
1754 | |
---|
1755 | # insert a ? token for each entry & add to marker list for each variable |
---|
1756 | set addlist {} |
---|
1757 | foreach var $looplist { |
---|
1758 | # go to next line? |
---|
1759 | if {[string length \ |
---|
1760 | [$CIF(txt) get "$epos linestart" "$epos lineend"]\ |
---|
1761 | ] > 78} { |
---|
1762 | $CIF(txt) insert $epos \n |
---|
1763 | set epos [$CIF(txt) index "$epos + 1c"] |
---|
1764 | } |
---|
1765 | $CIF(txt) insert $epos "? " |
---|
1766 | incr CIF(markcount) |
---|
1767 | $CIF(txt) mark set $CIF(markcount).l "$epos" |
---|
1768 | $CIF(txt) mark set $CIF(markcount).r "$epos + 1c" |
---|
1769 | $CIF(txt) mark gravity $CIF(markcount).l left |
---|
1770 | $CIF(txt) mark gravity $CIF(markcount).r right |
---|
1771 | set epos [$CIF(txt) index "$epos + 2c"] |
---|
1772 | set index [llength [set ${block}($var)]] |
---|
1773 | lappend ${block}($var) $CIF(markcount) |
---|
1774 | lappend addlist [list $CIF(markcount) $var $index $block] |
---|
1775 | } |
---|
1776 | incr CIF(changes) |
---|
1777 | lappend CIF(undolist) [list "loop add" $addlist \ |
---|
1778 | $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)] |
---|
1779 | set CIF(redolist) {} |
---|
1780 | |
---|
1781 | # now show the value we have added |
---|
1782 | set frame [$CIF(displayFrame) getframe] |
---|
1783 | set max [lindex [$CIF(LoopSpinBox) cget -range] 1] |
---|
1784 | incr max |
---|
1785 | $CIF(LoopSpinBox) configure -range "1 $max 1" |
---|
1786 | $CIF(LoopSpinBox) setvalue last |
---|
1787 | ShowLoopVar $block $loop |
---|
1788 | $CIF(txt) configure -state disabled |
---|
1789 | $CIF(DeleteLoopEntry) configure -state normal |
---|
1790 | } |
---|
1791 | |
---|
1792 | proc DeleteCIFRow {} { |
---|
1793 | global CIF |
---|
1794 | global CIFinfoArr CIFeditArr |
---|
1795 | |
---|
1796 | set delrow [$CIF(LoopSpinBox) getvalue] |
---|
1797 | |
---|
1798 | set msg {Are you sure you want to delete the following loop entries} |
---|
1799 | append msg " (row number [expr 1+$delrow])?\n" |
---|
1800 | set widget "" |
---|
1801 | foreach widget $CIF(widgetlist) { |
---|
1802 | set var [lindex $CIFinfoArr($widget) 0] |
---|
1803 | append msg "\n$var\n\t" |
---|
1804 | # get the value |
---|
1805 | switch [winfo class $widget] { |
---|
1806 | Text { |
---|
1807 | set value [string trim [$widget get 1.0 end]] |
---|
1808 | } |
---|
1809 | Entry { |
---|
1810 | set value [string trim [$widget get]] |
---|
1811 | } |
---|
1812 | Menubutton { |
---|
1813 | set value $CIFeditArr($widget) |
---|
1814 | } |
---|
1815 | } |
---|
1816 | append msg $value \n |
---|
1817 | } |
---|
1818 | if {$widget == ""} { |
---|
1819 | error "this should not happen" |
---|
1820 | } |
---|
1821 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1822 | global $block |
---|
1823 | if {[llength [set ${block}($dataname)]] == 1} { |
---|
1824 | MyMessageBox -parent . -title "Not only row" \ |
---|
1825 | -message {Sorry, this program is unable to delete all entries from a loop.} \ |
---|
1826 | -icon warning -type {Ignore} -default Ignore |
---|
1827 | return |
---|
1828 | } |
---|
1829 | |
---|
1830 | set ans [MyMessageBox -parent . -title "Delete Row?" \ |
---|
1831 | -message $msg \ |
---|
1832 | -icon question -type {Keep Delete} -default Keep] |
---|
1833 | if {$ans == "keep"} {return} |
---|
1834 | |
---|
1835 | $CIF(txt) configure -state normal |
---|
1836 | set deletelist {} |
---|
1837 | foreach widget $CIF(widgetlist) { |
---|
1838 | foreach {dataname block index} $CIFinfoArr($widget) {} |
---|
1839 | global $block |
---|
1840 | set mark [lindex [set ${block}($dataname)] $index] |
---|
1841 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1842 | lappend deletelist [list $mark $dataname $index $block $orig] |
---|
1843 | $CIF(txt) delete $mark.l $mark.r |
---|
1844 | set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index] |
---|
1845 | } |
---|
1846 | set CIF(redolist) {} |
---|
1847 | lappend CIF(undolist) [list "loop delete" $deletelist \ |
---|
1848 | $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)] |
---|
1849 | # count it |
---|
1850 | incr CIF(changes) |
---|
1851 | |
---|
1852 | $CIF(txt) configure -state disabled |
---|
1853 | |
---|
1854 | set max [lindex [$CIF(LoopSpinBox) cget -range] 1] |
---|
1855 | incr max -1 |
---|
1856 | $CIF(LoopSpinBox) configure -range "1 $max 1" |
---|
1857 | if {$index >= $max} {set index $max; incr index -1} |
---|
1858 | $CIF(LoopSpinBox) setvalue @$index |
---|
1859 | if {$max == 1} {$CIF(DeleteLoopEntry) configure -state disabled} |
---|
1860 | # don't check for changes |
---|
1861 | set CIF(lastLoopIndex) {} |
---|
1862 | ShowLoopVar $block [lindex $CIF(lastShownItem) 1] |
---|
1863 | } |
---|
1864 | |
---|
1865 | # display & highlight a line in the CIF text viewer |
---|
1866 | proc MarkGotoLine {line} { |
---|
1867 | global CIF |
---|
1868 | $CIF(txt) tag delete currentline |
---|
1869 | $CIF(txt) tag add currentline $line.0 $line.end |
---|
1870 | $CIF(txt) tag configure currentline -foreground blue |
---|
1871 | $CIF(txt) see $line.0 |
---|
1872 | } |
---|
1873 | |
---|
1874 | # Extract a value from a CIF in the CIF text viewer |
---|
1875 | proc ValueFromCIF {block item} { |
---|
1876 | global $block CIF |
---|
1877 | set val {} |
---|
1878 | catch { |
---|
1879 | set mark [set ${block}($item)] |
---|
1880 | if {[llength $mark] == 1} { |
---|
1881 | set val [string trim [StripQuotes [$CIF(txt) get $mark.l $mark.r]]] |
---|
1882 | } else { |
---|
1883 | foreach m $mark { |
---|
1884 | lappend val [string trim [StripQuotes [$CIF(txt) get $m.l $m.r]]] |
---|
1885 | } |
---|
1886 | } |
---|
1887 | } |
---|
1888 | return $val |
---|
1889 | } |
---|
1890 | |
---|
1891 | proc UndoChanges {} { |
---|
1892 | global CIF |
---|
1893 | # save any current changes, if possible |
---|
1894 | if {[CheckForCIFEdits]} return |
---|
1895 | # are there edits to undo? |
---|
1896 | if {[llength $CIF(undolist)] == 0} return |
---|
1897 | |
---|
1898 | foreach {mark orig lastShownItem lastShownTreeID lastLoopIndex} \ |
---|
1899 | [lindex $CIF(undolist) end] {} |
---|
1900 | |
---|
1901 | if {[llength $mark] == 1} { |
---|
1902 | # get the edited value |
---|
1903 | set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1904 | # make the change back |
---|
1905 | ReplaceMarkedText $CIF(txt) $mark $orig |
---|
1906 | # add this undo to the redo list |
---|
1907 | lappend CIF(redolist) [list $mark $edited $lastShownItem \ |
---|
1908 | $lastShownTreeID $lastLoopIndex] |
---|
1909 | } elseif {[lindex $mark 1] == "add"} { |
---|
1910 | set deletelist {} |
---|
1911 | $CIF(txt) configure -state normal |
---|
1912 | foreach m $orig { |
---|
1913 | foreach {mark dataname index block} $m {} |
---|
1914 | # get the inserted value |
---|
1915 | set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1916 | $CIF(txt) delete $mark.l $mark.r |
---|
1917 | lappend deletelist [list $mark $dataname $index $block $edited] |
---|
1918 | global $block |
---|
1919 | set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index] |
---|
1920 | } |
---|
1921 | $CIF(txt) configure -state disabled |
---|
1922 | # add this action to the redo list |
---|
1923 | lappend CIF(redolist) [list "loop delete" $deletelist \ |
---|
1924 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
1925 | } elseif {[lindex $mark 1] == "delete"} { |
---|
1926 | set addlist {} |
---|
1927 | foreach m $orig { |
---|
1928 | foreach {mark dataname index block orig} $m {} |
---|
1929 | # make the change back |
---|
1930 | ReplaceMarkedText $CIF(txt) $mark $orig |
---|
1931 | lappend addlist [list $mark $dataname $index $block] |
---|
1932 | global $block |
---|
1933 | set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark] |
---|
1934 | } |
---|
1935 | # show the entry that was added |
---|
1936 | set lastLoopIndex $index |
---|
1937 | # add this last entry to the redo list |
---|
1938 | lappend CIF(redolist) [list "loop add" $addlist \ |
---|
1939 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
1940 | } |
---|
1941 | |
---|
1942 | # drop the action from the undo list |
---|
1943 | set CIF(undolist) [lreplace $CIF(undolist) end end] |
---|
1944 | # count back |
---|
1945 | incr CIF(changes) -1 |
---|
1946 | # scroll on the tree |
---|
1947 | $CIF(tree) see $lastShownTreeID |
---|
1948 | eval showCIFbyDataname $lastShownItem |
---|
1949 | |
---|
1950 | # if we are in a loop, display the element |
---|
1951 | if {[lindex [lindex $lastShownItem 0] 1] == "loop"} { |
---|
1952 | $CIF(LoopSpinBox) setvalue @$lastLoopIndex |
---|
1953 | ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \ |
---|
1954 | [lindex $lastShownItem 1] |
---|
1955 | } |
---|
1956 | } |
---|
1957 | |
---|
1958 | |
---|
1959 | proc RedoChanges {} { |
---|
1960 | global CIF |
---|
1961 | # save any current changes, if possible |
---|
1962 | if {[CheckForCIFEdits]} return |
---|
1963 | # are there edits to redo? |
---|
1964 | if {[llength $CIF(redolist)] == 0} return |
---|
1965 | |
---|
1966 | foreach {mark edited lastShownItem lastShownTreeID lastLoopIndex} \ |
---|
1967 | [lindex $CIF(redolist) end] {} |
---|
1968 | |
---|
1969 | if {[llength $mark] == 1} { |
---|
1970 | # get the edited value |
---|
1971 | set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1972 | # make the change back |
---|
1973 | ReplaceMarkedText $CIF(txt) $mark $edited |
---|
1974 | # add this action back to the undo list |
---|
1975 | lappend CIF(undolist) [list $mark $orig $lastShownItem \ |
---|
1976 | $lastShownTreeID $lastLoopIndex] |
---|
1977 | # count up |
---|
1978 | incr CIF(changes) |
---|
1979 | } elseif {[lindex $mark 1] == "add"} { |
---|
1980 | set deletelist {} |
---|
1981 | $CIF(txt) configure -state normal |
---|
1982 | foreach m $edited { |
---|
1983 | foreach {mark dataname index block} $m {} |
---|
1984 | # get the inserted value |
---|
1985 | set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]] |
---|
1986 | $CIF(txt) delete $mark.l $mark.r |
---|
1987 | lappend deletelist [list $mark $dataname $index $block $edited] |
---|
1988 | global $block |
---|
1989 | set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index] |
---|
1990 | } |
---|
1991 | $CIF(txt) configure -state disabled |
---|
1992 | # add this action back to the undo list |
---|
1993 | lappend CIF(undolist) [list "loop delete" $deletelist \ |
---|
1994 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
1995 | # count up |
---|
1996 | incr CIF(changes) |
---|
1997 | } elseif {[lindex $mark 1] == "delete"} { |
---|
1998 | set addlist {} |
---|
1999 | foreach m $edited { |
---|
2000 | foreach {mark dataname index block orig} $m {} |
---|
2001 | # make the change back |
---|
2002 | ReplaceMarkedText $CIF(txt) $mark $orig |
---|
2003 | lappend addlist [list $mark $dataname $index $block] |
---|
2004 | global $block |
---|
2005 | set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark] |
---|
2006 | } |
---|
2007 | # show the entry that was added |
---|
2008 | set lastLoopIndex $index |
---|
2009 | # add this action back to the undo list |
---|
2010 | lappend CIF(undolist) [list "loop add" $addlist \ |
---|
2011 | $lastShownItem $lastShownTreeID $lastLoopIndex] |
---|
2012 | # count up |
---|
2013 | incr CIF(changes) |
---|
2014 | } |
---|
2015 | |
---|
2016 | # drop the action from the redo list |
---|
2017 | set CIF(redolist) [lreplace $CIF(redolist) end end] |
---|
2018 | # scroll on the tree |
---|
2019 | $CIF(tree) see $lastShownTreeID |
---|
2020 | eval showCIFbyDataname $lastShownItem |
---|
2021 | |
---|
2022 | # if we are in a loop, display the element |
---|
2023 | if {[lindex [lindex $lastShownItem 0] 1] == "loop"} { |
---|
2024 | $CIF(LoopSpinBox) setvalue @$lastLoopIndex |
---|
2025 | ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \ |
---|
2026 | [lindex $lastShownItem 1] |
---|
2027 | } |
---|
2028 | } |
---|
2029 | |
---|
2030 | # initialize misc variables |
---|
2031 | set CIF(changes) 0 |
---|
2032 | set CIF(widgetlist) {} |
---|
2033 | set CIF(lastShownItem) {} |
---|
2034 | set CIF(lastLoopIndex) {} |
---|
2035 | set CIF(editmode) 0 |
---|
2036 | set CIF(undolist) {} |
---|
2037 | set CIF(redolist) {} |
---|
2038 | set CIF(treeSelectedList) {} |
---|