source: trunk/browsecif.tcl @ 646

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

# on 2002/09/05 18:24:04, toby did:
add categories to loops
improve number parsing
lock edits in text window
(above grew from suggestions by B. McMahon?)

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