source: trunk/browsecif.tcl @ 650

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

# on 2002/09/05 21:03:37, toby did:
Major revision.

Implement undo
get rid of "Save Changes"
change use of icons
don't show tables with more than 100 loop values (by "column")

  • Property rcs:author set to toby
  • Property rcs:date set to 2002/09/05 21:03:37
  • Property rcs:lines set to +313 -122
  • Property rcs:rev set to 1.3
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 58.8 KB
Line 
1# $Id: browsecif.tcl 650 2009-12-04 23:09:43Z 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 quotes inside the string?
1189    set doublequote [string first "\"" $value]
1190    set singlequote [string first {'} $value]
1191    # if we have both types of quotes, use semicolon quoting
1192    if {$singlequote != -1 && $doublequote != -1} {set num $l}
1193
1194    # lines longer than 78 characters with spaces need to be treated
1195    # as multiline
1196    if {$num == -1 && $l > 77 && $spaces != -1} {
1197        set num $l
1198    }
1199    if {$num != -1} {
1200        set tmp {}
1201        if {[lindex [split [$txt index $mark.l] .] 1] != 0} {
1202            append tmp \n
1203        }
1204        append tmp ";"
1205        if {$num > 78} {
1206            append tmp \n
1207        } else {
1208            append tmp " "
1209        }
1210        append tmp $value "\n;"
1211        # is there something else on the line?
1212        set restofline [$txt get $mark.r [lindex [split [$txt index $mark.r] .] 0].end]
1213        if {[string trim $restofline] != ""} {
1214            append tmp \n
1215        }
1216        $txt delete ${mark}.l ${mark}.r
1217        $txt insert ${mark}.l $tmp
1218        $txt configure -state disabled
1219        return
1220    } elseif {($spaces != -1 || [string trim $value] == "") \
1221            && $doublequote == -1} {
1222        # use doublequotes, unless doublequotes are present inside the string
1223        set tmp "\""
1224        append tmp $value "\""
1225    } elseif {$spaces != -1 || [string trim $value] == ""} {
1226        # use single quotes, since doublequotes are present inside the string
1227        set tmp {'}
1228        append tmp $value {'}
1229    } else {
1230        # no quotes needed
1231        set tmp $value
1232    }
1233    # is there room on the beginning of the line to add the string?
1234    set l [string length $tmp]
1235    set pos [lindex [split [$txt index $mark.l] .] 0]
1236    if {$l + [string length [$txt get $pos.0 $mark.l]] <= 79} {
1237        # will fit
1238        $txt delete ${mark}.l ${mark}.r
1239        $txt insert ${mark}.l $tmp
1240    } else {
1241        # no, stick a CR in front of string
1242        $txt delete ${mark}.l ${mark}.r
1243        $txt insert ${mark}.l \n$tmp
1244    }
1245    # is rest of the line after the inserted string still too long?
1246    set pos [lindex [split [$txt index $mark.r] .] 0]
1247    if {[string length [$txt get $pos.0 $pos.end]] > 79} {
1248        $txt insert $mark.r \n
1249    }
1250    $txt configure -state disabled
1251}
1252
1253# return the dictionary definition for a list of CIF data names
1254proc GetCIFDefinitions {datanamelist} {
1255    global CIF_dataname_index
1256    set l {}
1257    # compile a list of definition pointers
1258    foreach dataname $datanamelist {
1259        set pointer {}
1260        catch {
1261            set pointer [lindex $CIF_dataname_index($dataname) 0]
1262        }
1263        lappend l [list $dataname $pointer]
1264    }
1265    set l [lsort -index 1 $l]
1266    set pp {}
1267    set dictdefs {}
1268    set def {}
1269    set nlist {}
1270    # merge items with duplicate definitions
1271    foreach item $l {
1272        # is this the first loop through?
1273        foreach {dataname pointer} $item {}
1274        if {$def == ""} {
1275            foreach {nlist pp} $item {}
1276            set def [ReadCIFDefinition $pp]
1277        } elseif {$pp == $pointer} {
1278            # same as last
1279            lappend nlist $dataname
1280        } else {
1281            # add the last entry to the list
1282            set pp $pointer
1283            lappend dictdefs [list $nlist $def]
1284            set nlist $dataname
1285            if {$pointer == ""} {
1286                set def { Undefined dataname}
1287            } else {
1288                # lookup name
1289                set def [ReadCIFDefinition $pointer]
1290            }
1291        }
1292    }
1293    lappend dictdefs [list $nlist $def]
1294    return $dictdefs
1295}
1296
1297# read the CIF definition for a dataname. The pointer contains 3 values
1298# a filename, the number of characters from the start of the file and
1299# the length of the definition.
1300proc ReadCIFDefinition {pointer} {
1301    global CIF
1302    set file {}
1303    set loc {}
1304    set line {}
1305    foreach {file loc len} $pointer {}
1306    if {$file != "" && $loc != "" && $loc != ""} {
1307        set fp {}
1308        foreach path $CIF(cif_path) {
1309            catch {set fp [open [file join $path $file] r]}
1310            if {$fp != ""} break
1311        }
1312        catch {
1313            seek $fp $loc
1314            set line [read $fp $len]
1315            close $fp
1316            # remove superfluous spaces
1317            regsub -all {  +} [StripQuotes $line] { } line
1318        }
1319    }
1320    return $line
1321}
1322
1323# validates that a CIF value is valid for a specific dataname
1324proc ValidateCIFItem {dataname item} {
1325    global CIF_dataname_index
1326    if {[
1327        catch {
1328            foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
1329        }
1330    ]} {return "warning: dataname $dataname not defined"}
1331    if {$type == "c"} {
1332        if {$elist != ""} {
1333            foreach i $elist {
1334                if {[string tolower $item] == [string tolower [lindex $i 0]]} {return}
1335            }
1336            return "error: value $item is not an allowed option for $dataname"
1337        } else {
1338            set l 0
1339            set err {}
1340            foreach line [split $item \n] {
1341                incr l
1342                if {[string length $line] > 80} {lappend err $l}
1343            }
1344            if {$err != ""} {return "error: line(s) $err are too long"}
1345            return
1346        }
1347    }
1348    if {$type == ""} {return "error: dataname $dataname is not used for CIF data items"}
1349    # validate numbers
1350    if {$type == "n"} {
1351        if {$item == "?" || $item == "."} return
1352        set v $item
1353        # remove s.u., if allowed & present
1354        set vals [ParseSU $item]
1355        if {[set v [lindex $vals 0]] == "."} {
1356            return "error: value $item is not a valid number for $dataname"
1357        }
1358        if {$esd} {
1359            if {[lindex $vals 1] == "."} {
1360                return "error: value $item for $dataname has an invalid uncertainty (esd)"
1361            }
1362        } elseif {[llength $vals] == 2} {
1363            return "error: $item is invalid for $dataname, an uncertainty (esd) is not allowed"
1364        }
1365
1366        # now validate the range
1367        if {$range != ""} {
1368            # is there a decimal point in the range?
1369            set integer 0
1370            if {[string first . $range] == -1} {set integer 1}
1371            # pull out the range
1372            foreach {min max} [split $range :] {}
1373            if {$integer && int($v) != $v} {
1374                return "error: value $item must be an integer for $dataname"
1375            }
1376            if {$min != ""} {
1377                if {$v < $min} {
1378                    return "error: value $item is too small for $dataname (allowed range $range)"
1379                }
1380            }
1381            if {$max != ""} {
1382                if {$v > $max} {
1383                    return "error: value $item is too big for $dataname(allowed range $range)"
1384                }
1385            }
1386        }
1387    }
1388    return {}
1389}
1390
1391# displays the dictionary definitions in variable defs into a text widget
1392proc ShowDictionaryDefinition {defs} {
1393    global CIF
1394    set deflist [GetCIFDefinitions $defs]
1395    catch {
1396        $CIF(defBox) delete 1.0 end
1397        foreach d $deflist {
1398            foreach {namelist definition} $d {}
1399            foreach n $namelist {
1400                $CIF(defBox) insert end $n dataname
1401                $CIF(defBox) insert end \n
1402            }
1403            $CIF(defBox) insert end \n
1404            $CIF(defBox) insert end $definition
1405            $CIF(defBox) insert end \n
1406            $CIF(defBox) insert end \n
1407        }
1408        $CIF(defBox) tag config dataname -background yellow
1409    }
1410}
1411
1412# create a widget to display a CIF value
1413proc DisplayCIFvalue {widget dataname loopval value block "row 0"} {
1414    global CIFeditArr CIFinfoArr
1415    global CIF CIF_dataname_index
1416    if {[
1417        catch {
1418            foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
1419        }
1420    ]} {
1421        set type c
1422        set elist {}
1423    }
1424
1425    lappend CIF(widgetlist) $widget
1426    set CIFinfoArr($widget) {}
1427
1428    if $CIF(editmode) {
1429        if {$loopval != ""} {
1430            set widgetinfo [list $dataname $block [expr $loopval -1]]
1431        } else {
1432            set widgetinfo [list $dataname $block 0]
1433        }
1434        set CIFeditArr($widget) $value
1435        set CIFinfoArr($widget) $widgetinfo
1436
1437        if {$type == "n"} {
1438            entry $widget -justify left -textvariable CIFeditArr($widget)
1439            bind $widget <Leave> "CheckChanges $widget"
1440            grid $widget -sticky nsw -column 1 -row $row
1441            if {$units != ""} {
1442                set ws "${widget}u"
1443                label $ws -text "($units)" -bg yellow
1444                grid $ws -sticky nsw -column 2 -row $row
1445            }
1446        } elseif {$elist != ""} {
1447            set enum {}
1448            foreach e $elist {
1449                lappend enum [lindex $e 0]
1450            }
1451            tk_optionMenu $widget CIFeditArr($widget) ""
1452            FixBigOptionMenu $widget $enum "CheckChanges $widget"
1453            AddSpecialEnumOpts $widget "CheckChanges $widget"
1454            grid $widget -sticky nsw -column 1 -row $row
1455        } else {
1456            # count the number of lines in the text
1457            set nlines [llength [split $value \n]]
1458            if {$nlines < 1} {
1459                set nlines 1
1460            } elseif {$nlines > 10} {
1461                set nlines 10
1462            }
1463            set ws "${widget}s"
1464            text $widget -height $nlines -width 80 -yscrollcommand "$ws set"
1465            scrollbar $ws -command "$widget yview" -width 10 -bd 1
1466            $widget insert end $value
1467            bind $widget <Leave> "CheckChanges $widget"
1468            if {$nlines > 1} {
1469                grid $ws -sticky nsew -column 1 -row $row
1470                grid $widget -sticky nsew -column 2 -row $row
1471            } else {
1472                grid $widget -sticky nsew -column 1 -columnspan 2 -row $row
1473            }
1474        }
1475    } else {
1476        label $widget -bd 2 -relief groove \
1477                -justify left -anchor w -text $value
1478        grid $widget -sticky nsw -column 1 -row $row
1479        if {$type == "n" && $units != ""} {
1480            set ws "${widget}u"
1481            label $ws -text "($units)" -bg yellow
1482            grid $ws -sticky nsw -column 2 -row $row
1483        }
1484    }
1485}
1486
1487# this is called to see if the user has changed the value for a CIF
1488# data item and to validate it.
1489#   save the change if $save is 1
1490#   return 1 if the widget contents has changed
1491proc CheckChanges {widget "save 0"} {
1492    global CIFeditArr CIFinfoArr CIF
1493
1494    set CIF(errormsg) {}
1495
1496    if {![winfo exists $widget]} return
1497
1498    set dataname {}
1499    catch {
1500        foreach {dataname block index} $CIFinfoArr($widget) {}
1501    }
1502    # if this widget is a label, the info above will not be defined & checks are not needed
1503    if {$dataname == ""} {return 0}
1504
1505    global ${block}
1506    set mark [lindex [set ${block}($dataname)] $index]
1507    if {$mark == ""} return
1508    set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1509
1510    # validate the entry
1511    set error {}
1512    set err {}
1513    switch [winfo class $widget] {
1514        Text {
1515            set current [string trim [$widget get 1.0 end]]
1516            set l 0
1517            foreach line [set linelist [split $current \n]] {
1518                incr l
1519                if {[string length $line] > 80} {
1520                    lappend err $l
1521                    lappend error "Error: line $l for $dataname is >80 characters"
1522                }
1523            }
1524            if {$err != ""} {
1525                foreach l $err {
1526                    $widget tag add error $l.0 $l.end
1527                }
1528                $widget tag config error -foreground red
1529            } else {
1530                $widget tag delete error
1531            }
1532            # see if box should expand
1533            set clines [$widget cget -height]
1534            if {$clines <= 2 && \
1535                    [string trim $orig] != [string trim $current]} {
1536                # count the number of lines in the text
1537                set nlines [llength $linelist]
1538                if {[lindex $linelist end] == ""} {incr nlines -1}
1539                if {$nlines == 2} {
1540                    $widget config -height 2
1541                } elseif {$nlines > 2} {
1542                    set i [lsearch [set s [grid info $widget]] -row]
1543                    set row [lindex $s [expr 1+$i]]
1544                    $widget config -height 3
1545                    set ws "${widget}s"
1546                    grid $ws -sticky nsew -column 1 -row $row
1547                    grid $widget -sticky nsew -column 2 -row $row
1548                }
1549            }
1550        }
1551        Entry {
1552            set current [string trim [$widget get]]
1553            set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current]
1554            if {$err != "" && \
1555                    [string tolower [lindex $err 0]] != "warning:"} {
1556                lappend error $err
1557                $widget config -fg red
1558            } else {
1559                $widget config -fg black
1560            }
1561        }
1562        Menubutton {
1563            set current $CIFeditArr($widget)
1564        }
1565        Label {
1566            return 0
1567        }
1568    }
1569    if {[string trim $orig] != [string trim $current]} {
1570        if {$err != ""} {
1571            set CIF(errormsg) $error
1572        } elseif {$save} {
1573            SaveCIFedits $widget
1574            return 0
1575        }
1576        return 1
1577    }
1578    return 0
1579}
1580
1581# save the CIF edits into the CIF text widget
1582proc SaveCIFedits {widget} {
1583    global CIFeditArr CIFinfoArr CIF
1584
1585    foreach {dataname block index} $CIFinfoArr($widget) {}
1586    global ${block}
1587    set mark [lindex [set ${block}($dataname)] $index]
1588    set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1589    switch [winfo class $widget] {
1590        Text {
1591            set current [string trim [$widget get 1.0 end]]
1592        }
1593        Entry {
1594            set current [string trim [$widget get]]
1595        }
1596        Menubutton {
1597            set current $CIFeditArr($widget)
1598        }
1599    }
1600    # save for undo & clear the redo list
1601    set CIF(redolist) {}
1602    if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} {
1603        lappend CIF(undolist) [list $mark $orig \
1604                $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1605    } else {
1606        lappend CIF(undolist) [list $mark $orig \
1607                $CIF(lastShownItem) $CIF(lastShownTreeID)]
1608    }
1609    # count it
1610    incr CIF(changes)
1611    # make the change
1612    ReplaceMarkedText $CIF(txt) $mark $current
1613}
1614
1615# add a new "row" to a CIF loop. At least for now, we only add at the end.
1616proc AddToCIFloop {block loop} {
1617    global $block CIF
1618    # check for unsaved changes here
1619    if {[CheckForCIFEdits]} return
1620
1621    $CIF(txt) configure -state normal
1622    set looplist [set ${block}($loop)]
1623    set length [llength [set ${block}([lindex $looplist 0])]]
1624    # find the line following the last entry in the list
1625    set var [lindex $looplist end]
1626    set line [lindex [split [\
1627            $CIF(txt) index [lindex [set ${block}($var)] end].r \
1628            ] .] 0]
1629    incr line
1630    set epos $line.0
1631    $CIF(txt) insert $epos \n
1632
1633    # insert a ? token for each entry & add to marker list for each variable
1634    set addlist {}
1635    foreach var $looplist {
1636        # go to next line?
1637        if {[string length \
1638                [$CIF(txt) get "$epos linestart" "$epos lineend"]\
1639                ] > 78} {
1640            $CIF(txt) insert $epos \n
1641            set epos [$CIF(txt) index "$epos + 1c"]
1642        }
1643        $CIF(txt) insert $epos "? "
1644        incr CIF(markcount)
1645        $CIF(txt) mark set $CIF(markcount).l "$epos"
1646        $CIF(txt) mark set $CIF(markcount).r "$epos + 1c"
1647        $CIF(txt) mark gravity $CIF(markcount).l left
1648        $CIF(txt) mark gravity $CIF(markcount).r right
1649        set epos [$CIF(txt) index "$epos + 2c"]
1650        set index [llength [set ${block}($var)]]
1651        lappend ${block}($var) $CIF(markcount)
1652        lappend addlist [list $CIF(markcount) $var $index $block]
1653    }
1654    incr CIF(changes)
1655    lappend CIF(undolist) [list "loop add" $addlist \
1656            $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1657    set CIF(redolist) {}
1658
1659    # now show the value we have added
1660    set frame [$CIF(displayFrame) getframe]
1661    set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1662    incr max
1663    $CIF(LoopSpinBox) configure -range "1 $max 1"
1664    $CIF(LoopSpinBox) setvalue last
1665    ShowLoopVar $block $loop
1666    $CIF(txt) configure -state disabled
1667    $CIF(DeleteLoopEntry) configure -state normal
1668}
1669
1670proc DeleteCIFRow {} {
1671    global CIF
1672    global CIFinfoArr CIFeditArr
1673
1674    set delrow [$CIF(LoopSpinBox) getvalue]
1675
1676    set msg {Are you sure you want to delete the following loop entries}
1677    append msg " (row number [expr 1+$delrow])?\n"
1678    set widget ""
1679    foreach widget $CIF(widgetlist) {
1680        set var [lindex $CIFinfoArr($widget) 0]
1681        append msg "\n$var\n\t"
1682        # get the value
1683        switch [winfo class $widget] {
1684            Text {
1685                set value [string trim [$widget get 1.0 end]]
1686            }
1687            Entry {
1688                set value [string trim [$widget get]]
1689            }
1690            Menubutton {
1691                set value $CIFeditArr($widget)
1692            }
1693        }
1694        append msg $value \n
1695    }
1696    if {$widget == ""} {
1697        error "this should not happen"
1698    }
1699    foreach {dataname block index} $CIFinfoArr($widget) {}
1700    global $block
1701    if {[llength [set ${block}($dataname)]] == 1} {
1702        MyMessageBox -parent . -title "Not only row" \
1703                -message {Sorry, this program is unable to delete all entries from a loop.} \
1704                -icon warning -type {Ignore} -default Ignore
1705        return
1706    }
1707
1708    set ans [MyMessageBox -parent . -title "Delete Row?" \
1709                -message $msg \
1710                -icon question -type {Keep Delete} -default Keep]
1711    if {$ans == "keep"} {return}
1712
1713    $CIF(txt) configure -state normal
1714    set deletelist {}
1715    foreach widget $CIF(widgetlist) {
1716        foreach {dataname block index} $CIFinfoArr($widget) {}
1717        global $block
1718        set mark [lindex [set ${block}($dataname)] $index]
1719        set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1720        lappend deletelist [list $mark $dataname $index $block $orig]
1721        $CIF(txt) delete $mark.l $mark.r
1722        set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
1723    }
1724    set CIF(redolist) {}
1725    lappend CIF(undolist) [list "loop delete" $deletelist \
1726            $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1727    # count it
1728    incr CIF(changes)
1729
1730    $CIF(txt) configure -state disabled
1731
1732    set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1733    incr max -1
1734    $CIF(LoopSpinBox) configure -range "1 $max 1"
1735    if {$index >= $max} {set index $max; incr index -1}
1736    $CIF(LoopSpinBox) setvalue @$index
1737    if {$max == 1} {$CIF(DeleteLoopEntry) configure -state disabled}
1738    # don't check for changes
1739    set CIF(lastLoopIndex) {}
1740    ShowLoopVar $block [lindex $CIF(lastShownItem) 1]
1741}
1742
1743# display & highlight a line in the CIF text viewer
1744proc MarkGotoLine {line} {
1745    global CIF
1746    $CIF(txt) tag delete currentline
1747    $CIF(txt) tag add currentline $line.0 $line.end
1748    $CIF(txt) tag configure currentline -foreground blue
1749    $CIF(txt) see $line.0
1750}
1751
1752# Extract a value from a CIF in the  CIF text viewer
1753proc ValueFromCIF {block item} {
1754    global $block CIF
1755    set val {}
1756    catch {
1757        set mark [set ${block}($item)]
1758        if {[llength $mark] == 1} {
1759            set val [string trim [StripQuotes [$CIF(txt) get $mark.l $mark.r]]]
1760        } else {
1761            foreach m $mark {
1762                lappend val [string trim [StripQuotes [$CIF(txt) get $m.l $m.r]]]
1763            }
1764        }
1765    }
1766    return $val
1767}
1768
1769proc UndoChanges {} {
1770    global CIF
1771    # save any current changes, if possible
1772    if {[CheckForCIFEdits]} return
1773    # are there edits to undo?
1774    if {[llength $CIF(undolist)] == 0} return
1775
1776    foreach {mark orig lastShownItem lastShownTreeID lastLoopIndex} \
1777            [lindex $CIF(undolist) end] {} 
1778
1779    if {[llength $mark] == 1} {
1780        # get the edited value
1781        set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1782        # make the change back
1783        ReplaceMarkedText $CIF(txt) $mark $orig
1784        # add this undo to the redo list
1785        lappend CIF(redolist) [list $mark $edited $lastShownItem \
1786                $lastShownTreeID $lastLoopIndex]
1787    } elseif {[lindex $mark 1] == "add"} {
1788        set deletelist {}
1789        $CIF(txt) configure -state normal
1790        foreach m $orig {
1791            foreach {mark dataname index block} $m {}
1792            # get the inserted value
1793            set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]   
1794            $CIF(txt) delete $mark.l $mark.r
1795            lappend deletelist [list $mark $dataname $index $block $edited]
1796            global $block
1797            set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
1798        }
1799        $CIF(txt) configure -state disabled
1800        # add this action to the redo list
1801        lappend CIF(redolist) [list "loop delete" $deletelist \
1802                $lastShownItem $lastShownTreeID $lastLoopIndex]
1803    } elseif {[lindex $mark 1] == "delete"} {
1804        set addlist {}
1805        foreach m $orig {
1806            foreach {mark dataname index block orig} $m {}
1807            # make the change back
1808            ReplaceMarkedText $CIF(txt) $mark $orig
1809            lappend addlist [list $mark $dataname $index $block]
1810            global $block
1811            set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark]
1812        }
1813        # show the entry that was added
1814        set lastLoopIndex $index
1815        # add this last entry to the redo list
1816        lappend CIF(redolist) [list "loop add" $addlist \
1817                $lastShownItem $lastShownTreeID $lastLoopIndex]
1818    }
1819
1820    # drop the action from the undo list
1821    set CIF(undolist) [lreplace $CIF(undolist) end end]
1822    # count back
1823    incr CIF(changes) -1
1824    # scroll on the tree
1825    $CIF(tree) see $lastShownTreeID
1826    eval showCIFbyDataname $lastShownItem
1827
1828    # if we are in a loop, display the element
1829    if {[lindex [lindex $lastShownItem 0] 1] == "loop"} {
1830        $CIF(LoopSpinBox) setvalue @$lastLoopIndex
1831        ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \
1832                [lindex $lastShownItem 1]
1833    }
1834}
1835
1836
1837proc RedoChanges {} {
1838    global CIF
1839    # save any current changes, if possible
1840    if {[CheckForCIFEdits]} return
1841    # are there edits to redo?
1842    if {[llength $CIF(redolist)] == 0} return
1843
1844    foreach {mark edited lastShownItem lastShownTreeID lastLoopIndex} \
1845            [lindex $CIF(redolist) end] {} 
1846
1847    if {[llength $mark] == 1} {
1848        # get the edited value
1849        set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1850        # make the change back
1851        ReplaceMarkedText $CIF(txt) $mark $edited
1852        # add this action back to the undo list
1853        lappend CIF(undolist) [list $mark $orig $lastShownItem \
1854                $lastShownTreeID $lastLoopIndex]
1855        # count up
1856        incr CIF(changes)
1857    } elseif {[lindex $mark 1] == "add"} {
1858        set deletelist {}
1859        $CIF(txt) configure -state normal
1860        foreach m $edited {
1861            foreach {mark dataname index block} $m {}
1862            # get the inserted value
1863            set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]   
1864            $CIF(txt) delete $mark.l $mark.r
1865            lappend deletelist [list $mark $dataname $index $block $edited]
1866            global $block
1867            set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
1868        }
1869        $CIF(txt) configure -state disabled
1870        # add this action back to the undo list
1871        lappend CIF(undolist) [list "loop delete" $deletelist \
1872                $lastShownItem $lastShownTreeID $lastLoopIndex]
1873        # count up
1874        incr CIF(changes)
1875    } elseif {[lindex $mark 1] == "delete"} {
1876        set addlist {}
1877        foreach m $edited {
1878            foreach {mark dataname index block orig} $m {}
1879            # make the change back
1880            ReplaceMarkedText $CIF(txt) $mark $orig
1881            lappend addlist [list $mark $dataname $index $block]
1882            global $block
1883            set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark]
1884        }
1885        # show the entry that was added
1886        set lastLoopIndex $index
1887        # add this action back to the undo list
1888        lappend CIF(undolist) [list "loop add" $addlist \
1889                $lastShownItem $lastShownTreeID $lastLoopIndex]
1890        # count up
1891        incr CIF(changes)
1892    }
1893   
1894    # drop the action from the redo list
1895    set CIF(redolist) [lreplace $CIF(redolist) end end]
1896    # scroll on the tree
1897    $CIF(tree) see $lastShownTreeID
1898    eval showCIFbyDataname $lastShownItem
1899   
1900    # if we are in a loop, display the element
1901    if {[lindex [lindex $lastShownItem 0] 1] == "loop"} {
1902        $CIF(LoopSpinBox) setvalue @$lastLoopIndex
1903        ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \
1904                [lindex $lastShownItem 1]
1905    }
1906}
1907
1908# initialize misc variables
1909set CIF(changes) 0
1910set CIF(widgetlist) {}
1911set CIF(lastShownItem) {}
1912set CIF(lastLoopIndex) {}
1913set CIF(editmode) 0
1914set CIF(undolist) {}
1915set CIF(redolist) {}
1916set CIF(treeSelectedList) {}
Note: See TracBrowser for help on using the repository browser.