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