source: trunk/browsecif.tcl @ 654

Last change on this file since 654 was 654, checked in by toby, 11 years ago

# on 2002/09/24 20:49:58, toby did:
quote reserved "words" (DATA_ LOOP_ SAVE_ STOP_ GLOBAL_)

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