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