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