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