source: trunk/browsecif.tcl

Last change on this file was 1251, checked in by toby, 7 years ago

use svn ps svn:eol-style "native" * to change line ends

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Revision Id
File size: 103.3 KB
Line 
1# $Id: browsecif.tcl 1251 2014-03-10 22:17:29Z 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 $w.[string tolower $data(-default)] invoke]
237    }
238
239    # 7. Withdraw the window, then update all the geometry information
240    # so we know how big it wants to be, then center the window in the
241    # display and de-iconify it.
242
243    wm withdraw $w
244    update idletasks
245    set wp $data(-parent)
246    # center the new window in the middle of the parent
247    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
248            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
249    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
250            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
251    # make sure that we can see the entire window
252    set xborder 10
253    set yborder 25
254    if {$x < 0} {set x 0}
255    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
256        incr x [expr \
257                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
258    }
259    if {$y < 0} {set y 0}
260    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
261        incr y [expr \
262                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
263    }
264    wm geom $w +$x+$y
265    update
266    wm deiconify $w
267
268    # 8. Set a grab and claim the focus too.
269
270    catch {set oldFocus [focus]}
271    catch {set oldGrab [grab current $w]}
272    catch {
273        grab $w
274        if {[string compare $data(-default) ""]} {
275            focus $w.[string tolower $data(-default)]
276        } else {
277            focus $w
278        }
279    }
280
281    # 9. Wait for the user to respond, then restore the focus and
282    # return the index of the selected button.  Restore the focus
283    # before deleting the window, since otherwise the window manager
284    # may take the focus away so we can't redirect it.  Finally,
285    # restore any grab that was in effect.
286
287    tkwait variable tkPriv(button)
288    catch {focus $oldFocus}
289    destroy $w
290    catch {grab $oldGrab}
291    return $tkPriv(button)
292}
293
294# tell'em what is happening
295proc pleasewait {{message {}} {statusvar {}} {parent .} {button ""}} {
296    catch {destroy .msg}
297    toplevel .msg
298    wm transient .msg [winfo toplevel .]
299    pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5
300    pack [message .msg.f.m -text "Please wait $message"] -side top
301    if {$statusvar != ""} {
302        pack [label .msg.f.status -textvariable $statusvar] -side top
303    }
304    if {$button != ""} {
305        pack [button .msg.f.button -text [lindex $button 0] \
306                -command [lindex $button 1]] -side top
307    }
308    wm withdraw .msg
309    update idletasks
310    # place the message on top of the parent window
311    set x [expr [winfo x $parent] + [winfo width $parent]/2 - \
312            [winfo reqwidth .msg]/2 - [winfo vrootx $parent]]
313    if {$x < 0} {set x 0}
314    set y [expr [winfo y $parent] + [winfo height $parent]/2 - \
315            [winfo reqheight .msg]/2 - [winfo vrooty $parent]]
316    if {$y < 0} {set y 0}
317    wm geom .msg +$x+$y
318    update
319    wm deiconify .msg
320    global makenew
321    set makenew(OldGrab) ""
322    set makenew(OldFocus) ""
323    # save focus & grab
324    catch {set makenew(OldFocus) [focus]}
325    catch {set makenew(OldGrab) [grab current .msg]}
326    catch {grab .msg}
327    update
328}
329
330# clear the wait message
331proc donewait {} {
332    global makenew
333    catch {destroy .msg}
334    # reset focus & grab
335    catch {
336        if {$makenew(OldFocus) != ""} {
337            focus $makenew(OldFocus)
338        }
339    }
340    catch {
341        if {$makenew(OldGrab) != ""} {
342            grab $makenew(OldGrab)
343        }
344    }
345}
346
347# this routine is used to fix up tk_optionMenu widgets that have too many
348# entries for a single list -- by using cascades
349proc FixBigOptionMenu {widget enum "cmd {}"} {
350    # max entries
351    set max 12
352    set menu [winfo children $widget]
353    $menu delete 0 end
354    eval destroy [winfo children $menu]
355    set var [$widget cget -textvariable]
356    # do we need a cascade?
357    if {[set n [llength $enum]] <= $max} {
358        # no
359        foreach l $enum {
360            $menu add radiobutton -value $l -label $l -variable $var \
361                    -command $cmd
362        }
363        return
364    }
365    # yes
366    set nmenus [expr int(($max + $n - 1 )/ (1.*$max))]
367    set nper [expr 1 + $n/$nmenus]
368    if {$nper > $max} {set nper $max}
369    for {set i 0} {$i < $n} {incr i $nper} {
370        set j [expr $i + $nper -1]
371        set sublist [lrange $enum $i $j]
372        $menu add cascade -label "[lindex $sublist 0]-[lindex $sublist end]" \
373                -menu $menu.$i
374        menu $menu.$i
375        foreach l $sublist {
376            $menu.$i add radiobutton -value $l -label $l -variable $var \
377                    -command $cmd
378        }
379    }
380}
381
382# this routine is used to add . and ? in a cascade for enum lists
383proc AddSpecialEnumOpts {widget "cmd {}"} {
384    set menu [winfo children $widget]
385    set var [$widget cget -textvariable]
386
387    # add the cascade and entries to it
388    $menu add cascade -label "(special values)" -menu $menu.special
389    menu $menu.special
390    $menu.special add radiobutton -value . -command $cmd \
391            -label "Inapplicable (.)" -variable $var
392    $menu.special add radiobutton -value ? -command $cmd \
393            -label "Unknown (?)" -variable $var
394}
395
396proc putontop {w "center 0"} {
397    # center window $w above its parent and make it stay on top
398    set wp [winfo parent $w]
399    wm transient $w [winfo toplevel $wp]
400    wm withdraw $w
401    update idletasks
402    if {$center} {
403        set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
404                - [winfo vrootx [winfo parent $w]]}]
405        set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
406                - [winfo vrooty [winfo parent $w]]}]
407    } else {
408        # center the new window in the middle of the parent
409        set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
410                [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
411        if {$x < 0} {set x 0}
412        set xborder 10
413        if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
414            incr x [expr [winfo screenwidth $w] - \
415                    ($x+[winfo reqwidth $w] + $xborder)]
416        }
417        set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
418                [winfo reqheight $w]/2 - [winfo vrooty $wp]]
419        if {$y < 0} {set y 0}
420        set yborder 25
421        if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
422            incr y [expr [winfo screenheight $w] - \
423                    ($y+[winfo reqheight $w] + $yborder)]
424        }
425    }
426    wm geometry $w +$x+$y
427    wm deiconify $w
428
429    global makenew
430    set makenew(OldGrab) ""
431    set makenew(OldFocus) ""
432    catch {set makenew(OldFocus) [focus]}
433    catch {set makenew(OldGrab) [grab current $w]}
434    catch {grab $w}
435}
436
437proc afterputontop {} {
438    # restore focus
439    global makenew
440    # reset focus & grab
441    catch {
442        if {$makenew(OldFocus) != ""} {
443            focus $makenew(OldFocus)
444        }
445    }
446    catch {
447        if {$makenew(OldGrab) != ""} {
448            grab $makenew(OldGrab)
449        }
450    }
451}
452
453#------------------------------------------------------------------------------
454# end of Misc Tcl/Tk utility routines
455#------------------------------------------------------------------------------
456
457#------------------------------------------------------------------------------
458# ParseCIF reads and parses a CIF file putting the contents of
459# each block into arrays block1, block2,... in the caller's level
460#    the name of the block is saved as blockN(data_)
461# data names items are saved as blockN(_data_name) = marker_number
462#    where CIF data names are converted to lower case
463#    and marker_number.l marker_number.r define the range of the value
464# for looped data names, the data items are included in a list:
465#    blockN(_cif_name) = {marker1 marker2 ...}
466# the contents of each loop are saved as blockN(loop_M)
467#
468# if the filename is blank or not specified, the current contents
469#    of the text widget, $txt, is parsed.
470#
471# The proc returns the number of blocks that have been read or a
472#    null string if the file cannot be opened
473#
474# This parser does some error checking [errors are reported in blockN(error)]
475#    but the parser could get confused if the CIF has invalid syntax
476#
477proc ParseCIF {txt "filename {}" "namespace {}"} {
478    global CIF tcl_version
479    global CIF_dataname_index
480    # create a namespace, if one is needed
481    if {$namespace != ""} {
482        namespace eval $namespace {}
483    }
484
485    if {$tcl_version < 8.2} {
486        tk_dialog .error {Old Tcl/Tk} \
487                "Sorry, the CIF Browser requires version 8.2 or later of the Tcl/Tk package. This is $tcl_version" \
488                warning 0 Sorry
489        return
490    }
491
492    if {$filename != ""} {
493        if [catch {
494            $txt configure -state normal
495            set fp [open $filename r]
496            $txt insert end [read $fp]
497            close $fp
498            $txt configure -state disabled
499        }] {
500            return ""
501        }
502    }
503
504    # maximum size of file
505    set maxvalues 0
506    catch {
507        set maxvalues $CIF(maxvalues)
508    }
509
510    set CIF(undolist) {}
511    set CIF(redolist) {}
512    set pos 1.0
513    set blocks 0
514    set EOF 1
515    set dataname {}
516    set CIF(markcount) -1
517    # this flags where we are w/r a loop_
518    #    -1 not in a loop
519    #     0 reading a loop header (data names)
520    #     1 reading the data items in a loop
521    set loopflag -1
522    set loopnum -1
523    # loop over tokens
524    while {$EOF} {
525        if {$CIF(markcount) % 1000 == 0} {
526            $txt see $pos
527            set CIF(status) "($CIF(markcount) values read.)"
528            update
529            # are we over the limit?
530            if {$maxvalues > 0 && $CIF(markcount) > $maxvalues} {
531                donewait
532                set msg "Too many data values to parse; stopping at $CIF(markcount), line [lindex [split $pos .] 0].\n\nIf your computer has sufficient memory to read more, increase CIF(maxvalues) in cifedit.tcl"
533                set ans [MyMessageBox -parent . -title "CIF Too big" \
534                        -message $msg -icon error -type "{Stop Parsing}" \
535                        -default "stop parsing"]
536               
537                return $blocks
538            }
539        }
540        # skip forward to the first non-blank character
541        set npos [$txt search -regexp {[^[:space:]]} $pos end]
542        # is this the end?
543        if {$npos == "" || \
544                [lindex [split $npos .] 0] < [lindex [split $pos .] 0] } {
545            set EOF 0
546            break
547        } else {
548            set pos $npos
549        }
550
551        # is this a comment, if so skip to next line
552        if {[$txt get $pos] == "#"} {
553            set pos [$txt index "$pos + 1 line linestart"]
554            continue
555        }
556
557        # find end of token
558        set epos [$txt search -regexp {[[:space:]]} $pos "$pos lineend"]
559        if {$epos == ""} {
560            set epos [$txt index "$pos lineend"]
561        }
562
563        set token [$txt get $pos $epos]
564
565        if {[string tolower [string range $token 0 4]] == "data_"} {
566            # this is the beginning of a data block
567            incr blocks
568            set blockname [string range $token 5 end]
569            catch {unset ${namespace}::block$blocks}
570            set ${namespace}::block${blocks}(data_) $blockname
571            set loopnum -1
572            if {$dataname != ""} {
573                # this is an error -- data_ block where a data item is expected
574                append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
575                set dataname {}
576            }
577            # move forward past current token
578            set pos [$txt index "$epos +1c"]
579            continue
580        }
581       
582        if {[$txt get $pos] == "_"} {
583            # this is a cif data name
584            if {$dataname != ""} {
585                # this is an error -- data name where a data item is expected
586                append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
587            }
588            # convert it to lower case & save
589            set dataname [string tolower $token]
590
591            # are we in a loop header or loop body?
592            if {$loopflag == 0} {
593                # in a loop header, save the names in the loop list
594                lappend looplist $dataname
595                # check the categories used in the loop
596                set category {}
597                catch {
598                    set category [lindex \
599                            [lindex $CIF_dataname_index($dataname) 1] 5]
600                }
601                # don't worry if we don't have a category
602                if {$category != ""} {
603                    if {$catlist == ""} {
604                        set catlist $category
605                    } elseif {[lsearch $catlist $category] == -1} {
606                        # error two categories in a loop
607                        lappend catlist $category
608                        append ${namespace}::block${blocks}(errors) \
609                                "Multiple categories ($catlist) in a loop_ for $dataname at line [lindex [split $pos .] 0]\n"
610                    }
611                }
612               
613                if {$blocks == 0} {
614                    # an error -- a loop_ before a data_ block start
615                    set ${namespace}::block${blocks}(data_) undefined
616                    append ${namespace}::block${blocks}(errors) \
617                            "A loop_ begins before a data_ block is defined (line [lindex [split $pos .] 0])\n"
618                }
619                set ${namespace}::block${blocks}(loop_${loopnum}) $looplist
620                # clear the array element for the data item
621                # -- should not be needed for a valid CIF but if a name is used
622                # -- twice in the same block, want to wipe out the 1st data
623                catch {
624                    if {[set ${namespace}::block${blocks}($dataname)] != ""} {
625                        # this is an error -- repeated data name
626                        append ${namespace}::block${blocks}(errors) \
627                                "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
628                    }   
629                    set ${namespace}::block${blocks}($dataname) {}
630                }
631                set dataname {}
632            } elseif {$loopflag > 0} {
633                # in a loop body, so the loop is over
634                set loopflag -1
635            }
636            # move forward past current token
637            set pos [$txt index "$epos +1c"]
638            continue
639        }
640       
641        if {[string tolower [string range $token 0 4]] == "loop_"} {
642            set loopflag 0
643            incr loopnum
644            set looplist {}
645            set catlist {}
646            set ${namespace}::block${blocks}(loop_${loopnum}) {}
647            # move forward past current token
648            set pos [$txt index "$epos +1c"]
649            continue
650        }
651
652        # keywords not matched, must be some type of data item
653        set item {}
654        incr CIF(markcount)
655       
656        if {[$txt get "$pos linestart"] == ";" && \
657                [$txt index $pos] == [$txt index "$pos linestart"]} {
658            # multiline entry with semicolon termination
659            set epos [$txt search -regexp {^;} "$pos + 1 line linestart"]
660            if {$epos == ""} {
661                set epos end
662                append ${namespace}::block${blocks}(errors) \
663                        "Unmatched semicolon for $dataname starting at line [lindex [split $pos .] 0]\n"
664            }
665
666            $txt mark set $CIF(markcount).l "$pos linestart"
667            $txt mark set $CIF(markcount).r "$epos + 1c"
668            $txt mark gravity $CIF(markcount).l left
669            $txt mark gravity $CIF(markcount).r right
670            set item [$txt get "$pos linestart" "$epos +1c"]
671            # move forward past current token
672            set pos [$txt index "$epos + 1c"]
673        } elseif {[$txt get $pos] == "\""} {
674            # a quoted string -- find next quote
675            set epos [$txt search "\"" "$pos +1c" "$pos lineend"]
676            # skip over quotes followed by a non-blank
677            while {$epos != "" && \
678                    [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
679                set epos [$txt search "\"" "$epos +1c" "$pos lineend"]
680            }
681            # did we hit the end of line?
682            if {$epos == ""} {
683                set epos [$txt index "$pos lineend"]
684                append ${namespace}::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"
685            }
686            $txt mark set $CIF(markcount).l "$pos"
687            $txt mark set $CIF(markcount).r "$epos + 1c" 
688            $txt mark gravity $CIF(markcount).l left
689            $txt mark gravity $CIF(markcount).r right
690            set item [$txt get  $pos "$epos +1c"]
691            # move forward past current token
692            set pos [$txt index "$epos +2c"]
693        } elseif {[$txt get $pos] == {'}} {
694            # a quoted string -- find next quote
695            set epos [$txt search {'} "$pos +1c" "$pos lineend"]
696            # skip over quotes followed by a non-blank
697            while {$epos != "" && \
698                    [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
699                set epos [$txt search {'} "$epos +1c" "$pos lineend"]
700            }
701            # did we hit the end of line?
702            if {$epos == ""} {
703                set epos [$txt index "$pos lineend"]
704                append ${namespace}::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"
705            }
706            $txt mark set $CIF(markcount).l "$pos"       
707            $txt mark set $CIF(markcount).r "$epos + 1c" 
708            $txt mark gravity $CIF(markcount).l left
709            $txt mark gravity $CIF(markcount).r right
710            set item [$txt get $pos "$epos +1c"]
711            # move forward past current token
712            set pos [$txt index "$epos + 2 c"]
713        } elseif {[$txt get $pos] == {[}} {
714            # CIF v1.1 square bracket quotes
715            set count 1
716            set epos $pos
717            while {$count != 0} {
718                set epos [$txt search -regexp {[\]\[]} "$epos +1c"]
719                if {$epos == ""} {
720                    # unmatched open square bracket
721                    append ${namespace}::block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n"
722                    set count 0
723                    set epos [$txt index end]
724                } elseif {[$txt get $epos] == {]}} {
725                    # close bracket -- decrement
726                    incr count -1
727                } else {
728                    # open bracket -- increment
729                    incr count
730                }
731            }
732            $txt mark set $CIF(markcount).l "$pos"       
733            $txt mark set $CIF(markcount).r "$epos + 1c" 
734            $txt mark gravity $CIF(markcount).l left
735            $txt mark gravity $CIF(markcount).r right
736            set item [$txt get $pos "$epos +1c"]
737            # move forward past current token
738            set pos [$txt index "$epos + 2 c"]
739        } else {
740            # must be a single space-delimited value
741            $txt mark set $CIF(markcount).l $pos
742            $txt mark set $CIF(markcount).r $epos
743            $txt mark gravity $CIF(markcount).l left
744            $txt mark gravity $CIF(markcount).r right
745            set item $token
746            set pos [$txt index "$epos + 1 c"]
747        }
748        # a data item has been read
749
750        # store the data item
751        if {$loopflag >= 0} {
752            # if in a loop, increment the loop element counter to select the
753            # appropriate array element
754            incr loopflag
755            set i [expr ($loopflag - 1) % [llength $looplist]]
756            lappend ${namespace}::block${blocks}([lindex $looplist $i]) $CIF(markcount)
757            set ${namespace}::block${blocks}(lastmark) $CIF(markcount)
758        } elseif {$dataname == ""} {
759            # this is an error -- a data item where we do not expect one
760            append ${namespace}::block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n"
761        } else {
762            if {$blocks == 0} {
763                # an error -- a data name before a data_ block start
764                set ${namespace}::block${blocks}(data_) undefined
765                append ${namespace}::block${blocks}(errors) \
766                            "Data name $dataname appears before a data_ block is defined (line [lindex [split $pos .] 0])\n"
767            }
768            catch {
769                if {[set ${namespace}::block${blocks}($dataname)] != ""} {
770                    # this is an error -- repeated data name
771                    append ${namespace}::block${blocks}(errors) \
772                            "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
773                }
774            }
775            set ${namespace}::block${blocks}($dataname) $CIF(markcount)
776            set ${namespace}::block${blocks}(lastmark) $CIF(markcount)
777            set dataname ""
778        }
779    }
780    $txt see 1.0
781    return $blocks
782}
783
784#------------------------------------------------------------------------------
785# Create a CIF browser/editor
786#  $txt is a text widget with the entire CIF loaded
787#  blocklist contains the list of defined blocks (by #)
788#  selected is the list of blocks that will be expanded
789#  frame gives the name of the toplevel window to hold the browser
790proc BrowseCIF {txt blocklist "selected {}" "frame .cif"} {
791    catch {destroy $frame}
792    toplevel $frame 
793    wm title $frame "CIF Browser"
794    CIFOpenBrowser $frame
795    CIFBrowser $txt $blocklist $selected $frame
796    grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
797}
798
799# Populate a hierarchical CIF browser
800#    $txt is a text widget with the entire CIF loaded
801#    blocklist contains the list of defined blocks (by #)
802#    selected is the list of blocks that will be expanded
803#    frame gives the name of the toplevel or frame to hold the browser
804proc CIFBrowser {txt blocklist "selected {}" "frame .cif"} {
805    global CIF CIFtreeindex CIF_dataname_index
806
807    if {$selected == ""} {set selected $blocklist}
808
809    # clear out old info, if any, from browser
810    eval $CIF(tree) delete [$CIF(tree) nodes root]
811    catch {unset CIFtreeindex}
812    # remove the loop counter frame from window & edit buttons from that frame
813    grid forget $CIF(LoopBar)
814    pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry)
815    # delete old contents of frame
816    set frame [$CIF(displayFrame) getframe]
817    eval destroy [grid slaves $frame]
818    set CIF(widgetlist) {}
819    # reset the scrollbars
820    $CIF(tree) see 0
821    $CIF(displayFrame) xview moveto 0
822    $CIF(displayFrame) yview moveto 0
823
824    # Bwidget seems to have problems with the name "1", so avoid it
825    set num 100
826    foreach n $blocklist {
827        global block$n
828        # make a list of data names in loops
829        set looplist {}
830        foreach loop [array names block$n loop_*] {
831            eval lappend looplist [set block${n}($loop)]
832        }
833        # put the block name
834        set blockname [set block${n}(data_)]
835        set open 0
836        if {[lsearch $selected $n] != -1} {set open 1}
837        $CIF(tree) insert end root block$n -text "_data_$blockname" \
838                -open $open -image [Bitmap::get folder]
839
840        # show errors, if any
841        foreach name [array names block$n errors] {
842            $CIF(tree) insert end block$n [incr num] -text "Parse-errors" \
843                    -image [Bitmap::get undo] -data block$n
844        }
845        # loop over the names in each block
846        foreach name [lsort [array names block$n _*]] {
847            # don't include looped names
848            if {[lsearch $looplist $name] == -1} {
849                $CIF(tree) insert end block$n [incr num] -text $name \
850                        -image [Bitmap::get file] -data block$n
851                set CIFtreeindex(block${n}$name) $num
852            }
853        }
854        foreach loop [lsort [array names block$n loop_*]] {
855            # make a list of categories used in the loop
856            set catlist {}
857            foreach name [lsort [set block${n}($loop)]] {
858                set category {}
859                catch {
860                    set category [lindex \
861                            [lindex $CIF_dataname_index($name) 1] 5]
862                }
863                if {$category != "" && [lsearch $catlist $category] == -1} {
864                    lappend catlist $category
865                }
866            }
867
868            $CIF(tree) insert end block$n block${n}$loop \
869                    -text "$loop ($catlist)" \
870                    -image [Bitmap::get copy] -data "block$n loop"
871            set CIFtreeindex(block${n}$loop) block${n}$loop
872            foreach name [lsort [set block${n}($loop)]] {
873                $CIF(tree) insert end block${n}$loop [incr num] -text $name \
874                        -image [Bitmap::get file] -data "block$n $loop"
875                set CIFtreeindex(block${n}$name) $num
876            }
877        }
878    }
879    $CIF(tree) bindImage <1> showCIFbyTreeID
880    $CIF(tree) bindText <1>  showCIFbyTreeID
881    set CIF(tree_lastindex) $num
882}
883
884# Create the widgets for a hierarchical CIF browser in $frame
885#   (where $frame is a frame or toplevel)
886#   note that the BWidget package is required
887proc CIFOpenBrowser {frame} {
888    global CIF
889    if [catch {package require BWidget}] {
890        tk_dialog .error {No BWidget} \
891                "Sorry, the CIF Browser requires the BWidget package" \
892                warning 0 Sorry
893        return
894    }
895
896    set pw    [PanedWindow $frame.pw -side top]
897    grid $pw -sticky news -column 0 -row 0 
898    set CIF(LoopBar) [frame $frame.f]
899    #grid $CIF(LoopBar) -sticky es -column 0 -row 1
900    set width 900
901    if {$width > [winfo screenwidth .]} {set width [winfo screenwidth .]}
902    grid columnconfigure $frame 0 -weight 1 -minsize $width
903    # shrink browser on small screens
904    set h 250 
905    if {[winfo screenheight .] < 500} {set h 180}
906    grid rowconfigure $frame 0 -minsize $h -weight 1
907
908    # create a left hand side pane for the hierarchical tree
909    set pane  [$pw add -weight 1]
910    set sw    [ScrolledWindow $pane.lf \
911            -relief sunken -borderwidth 2]
912    set CIF(tree)  [Tree $sw.tree \
913            -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
914            -redraw 1]
915    # get the size of the font and adjust the line spacing accordingly
916    catch {
917        set font [option get $CIF(tree) font Canvas]
918        $CIF(tree) configure -deltay [font metrics $font -linespace]
919    }
920    bind $frame <KeyPress-Prior> "$CIF(tree) yview scroll -1 page"
921    bind $frame <KeyPress-Next> "$CIF(tree) yview scroll 1 page"
922#    bind $frame <KeyPress-Up> "$CIF(tree) yview scroll -1 unit"
923#    bind $frame <KeyPress-Down> "$CIF(tree) yview scroll 1 unit"
924    bind $frame <KeyPress-Home> "$CIF(tree) yview moveto 0"
925    #bind $frame <KeyPress-End> "$CIF(tree) yview moveto end" -- does not work
926    bind $frame <KeyPress-End> "$CIF(tree) yview scroll 99999999 page"
927    grid $sw
928    grid $sw -sticky news -column 0 -row 0 
929    grid columnconfigure $pane 0 -minsize 275 -weight 1
930    grid rowconfigure $pane 0 -weight 1
931    $sw setwidget $CIF(tree)
932   
933    # create a right hand side pane to show the value
934    set pane [$pw add -weight 4]
935    set sw   [ScrolledWindow $pane.sw \
936            -relief sunken -borderwidth 2]
937    pack $sw -fill both -expand yes -side top
938
939    set CIF(AddtoLoopButton) [button $CIF(LoopBar).l -text "Add to loop"]
940    set CIF(DeleteLoopEntry) [button $CIF(LoopBar).d \
941            -text "Delete loop entry" -command DeleteCIFRow]
942    label $CIF(LoopBar).1 -text "Loop\nelement #"
943    set CIF(LoopSpinBox) [SpinBox $CIF(LoopBar).2 -range "1 1 1"  -width 5]
944    pack $CIF(LoopBar).2 $CIF(LoopBar).1 -side right
945    set CIF(displayFrame) $sw.lb
946    set lb [ScrollableFrame::create $CIF(displayFrame) -width 400]
947    $sw setwidget $lb
948}
949
950# Warn to save changes that are not saved in a file
951proc CheckForCIFEdits {} {
952    #puts "CheckForCIFEdits [info level [expr [info level]-1]]"
953    global CIF
954    set errorlist {}
955    set errorflag 0
956    set msg "The following edits cannot be saved due to errors:\n"
957    foreach widget $CIF(widgetlist) {
958        CheckChanges $widget 1
959        if {$CIF(errormsg) != ""} {
960            set errorflag 1
961            foreach err $CIF(errormsg) {
962                append msg "  " $err \n
963            }
964        }
965
966    }
967    if {$errorflag} {
968        append msg \n {Do you want to make corrections, or discard these edits?}
969        set ans [MyMessageBox -parent . -title "Invalid edits" \
970                -message $msg -icon error -type "Correct Discard" \
971                -default correct]
972        if {$ans == "correct"} {
973            # if not, don't allow the mode/loop value to change
974            set CIF(editmode) 1
975            catch {
976                $CIF(LoopSpinBox) setvalue @$CIF(lastLoopIndex)
977            }
978            return 1
979        }
980    }
981    return 0
982}
983
984# showCIFbyTreeID is used in BrowseCIF to response to clicking on a tree widget
985#   shows the contents data name or a loop
986proc showCIFbyTreeID {name} {
987    if {[CheckForCIFEdits]} return
988
989    global CIF
990    # code to allow multiple selection within loops
991    #set loopname [lindex [$CIF(tree) itemcget $name -data] 1]
992    #set addtolist 1
993    #if {$loopname == "" || $loopname == "loop"} {set addtolist 0}
994    #foreach n $CIF(treeSelectedList) {
995        #if {$loopname != [lindex [$CIF(tree) itemcget $n -data] 1]} {
996        #    set addtolist 0
997        #    break
998        #}
999    #}
1000    #if {$addtolist} {
1001        #catch {$CIF(tree) itemconfigure $name -fill red}
1002        #lappend CIF(treeSelectedList) $name
1003    #} else {
1004        foreach n $CIF(treeSelectedList) {
1005            catch {$CIF(tree) itemconfigure $n -fill black}
1006        }
1007        set CIF(treeSelectedList) $name
1008        # for some reason, BWidget sometimes has problems doing this:
1009        # (but ignore the error)
1010        catch {$CIF(tree) itemconfigure $name -fill red}
1011        set CIF(lastShownTreeID) $name
1012        set pointer [$CIF(tree) itemcget $name -data]
1013        set dataname [lindex [$CIF(tree) itemcget $name -text] 0]
1014        showCIFbyDataname $pointer $dataname
1015    #}
1016}
1017
1018proc showCIFbyDataname {pointer dataname "loopindex {}"} {
1019    global CIF CIFtreeindex
1020    set CIF(lastShownItem) [list $pointer $dataname]
1021    # remove the loop counter frame from window & edit buttons from that frame
1022    grid forget $CIF(LoopBar)
1023    pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry)
1024
1025    # delete old contents of frame
1026    set frame [$CIF(displayFrame) getframe]
1027    eval destroy [grid slaves $frame]
1028    # reset the scrollbars
1029    $CIF(displayFrame) xview moveto 0
1030    $CIF(displayFrame) yview moveto 0
1031    # leave room for a scrollbar
1032    grid columnconfig $frame 0 -minsize [expr \
1033            [winfo width [winfo parent $frame]] - 20]
1034    if {$pointer == ""} {
1035        return
1036    }
1037    # create list of widgets defined here
1038    set CIF(widgetlist) {}
1039
1040    # is this a looped data item?
1041    set block [lindex $pointer 0]
1042    if {[llength $pointer] == 2} {
1043        global $block
1044        # display contents of a rows of the loop
1045        if {[lindex $pointer 1] == "loop"} {
1046            if {$CIF(editmode)} {
1047                pack $CIF(DeleteLoopEntry) -side right
1048                pack $CIF(AddtoLoopButton) -side right
1049                $CIF(AddtoLoopButton) config -command "AddToCIFloop ${block} $dataname"
1050            }
1051            set looplist [set ${block}($dataname)]
1052            # get number of elements for first name
1053            set names [llength [set ${block}([lindex $looplist 0])]]
1054            # can't delete the only entry
1055            if {$names == 1 && $CIF(editmode)} {
1056                $CIF(DeleteLoopEntry) configure -state disabled
1057            } else {
1058                $CIF(DeleteLoopEntry) configure -state normal
1059            }
1060            $CIF(LoopSpinBox) configure -range "1 $names 1" \
1061                    -command    "ShowLoopVar ${block} $dataname" \
1062                    -modifycmd  "ShowLoopVar ${block} $dataname"
1063            set CIF(lastLoopIndex) {}
1064            if {$loopindex == ""} {
1065                $CIF(LoopSpinBox) setvalue first
1066            } else {
1067                $CIF(LoopSpinBox) setvalue @$loopindex
1068            }
1069            # show the loop counter frame
1070            grid $CIF(LoopBar) -sticky es -column 0 -row 1
1071            set row 0
1072            set i 0
1073            ShowDictionaryDefinition $looplist
1074            foreach var $looplist {
1075                incr i
1076                grid [TitleFrame $frame.$i -text $var -side left] \
1077                        -column 0 -row $i -sticky ew
1078                set row $i
1079                set frame0 [$frame.$i getframe]
1080                DisplayCIFvalue $frame0.l $var 1 "" ${block}
1081                grid columnconfig $frame0 2 -weight 1
1082            }
1083            ShowLoopVar ${block} $dataname
1084        } else {
1085            # look at a single looped variable
1086            ShowDictionaryDefinition $dataname
1087            grid [TitleFrame $frame.0 -text $dataname -side left] \
1088                    -column 0 -row 0 -sticky ew
1089            set row 0
1090            set i 0
1091            set frame0 [$frame.0 getframe]
1092            grid columnconfig $frame0 2 -weight 1
1093            # maximum number of entries
1094            set maxcols 100
1095            catch {
1096                set maxcols $CIF(maxRows)
1097            }
1098            if {[set l [llength [set ${block}($dataname)]]] > $maxcols} {
1099                grid [label $frame0.a$i -justify left \
1100                        -text "$dataname has $l entries, too many to display by column" \
1101                        ] -sticky w -column 0 -row $i
1102                return
1103            }
1104            foreach mark [set ${block}($dataname)] {
1105                incr i
1106                if {$i == 1} {$CIF(txt) see $mark.l}
1107                set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]     
1108                grid [label $frame0.a$i -justify left -text $i]\
1109                        -sticky w -column 0 -row $i
1110                DisplayCIFvalue $frame0.b$i $dataname $i $value ${block} $i
1111                #grid $frame0.b$i -sticky new -column 1 -row $i
1112            }
1113        }
1114    } else {
1115        # unlooped data name
1116        global ${block}
1117        ShowDictionaryDefinition $dataname
1118        grid [TitleFrame $frame.0 -text $dataname -side left] \
1119                -column 0 -row 0 -sticky ew
1120        set row 0
1121        if {$dataname == "Parse-errors"} {
1122            set value [set ${block}(errors)]
1123        } elseif {$dataname == "Validation-errors"} {
1124            set value [set ${block}(validate)]
1125        } else {
1126            set mark [set ${block}($dataname)]
1127            set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]         
1128            $CIF(txt) see $mark.l
1129        }
1130        set frame0 [$frame.0 getframe]
1131        grid columnconfig $frame0 2 -weight 1
1132        DisplayCIFvalue $frame0.l $dataname "" $value $block
1133        #grid $frame0.l -sticky w -column 1 -row 0
1134    }
1135}
1136
1137# redisplay the last entry shown in showCIFbyTreeID
1138# this is used if the edit mode ($CIF(editmode)) changes or if edits are saved
1139proc RepeatLastshowCIFvalue {} {
1140    global CIF
1141    if {[CheckForCIFEdits]} return
1142    set lastLoopIndex $CIF(lastLoopIndex)
1143
1144    catch {
1145        eval showCIFbyDataname $CIF(lastShownItem)
1146        # if we are in a loop, display the element
1147        if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} {
1148            $CIF(LoopSpinBox) setvalue @$lastLoopIndex
1149            ShowLoopVar [lindex [lindex $CIF(lastShownItem) 0] 0] \
1150                    [lindex $CIF(lastShownItem) 1]
1151        }
1152       
1153    }
1154}
1155
1156# used in BrowseCIF in response to the spinbox
1157# show entries in a specific row of a loop
1158proc ShowLoopVar {array loop} {
1159    global $array CIF
1160    # check for unsaved changes here
1161    if {$CIF(lastLoopIndex) != ""} {
1162        if {[CheckForCIFEdits]} return
1163    }
1164
1165    set looplist [set ${array}($loop)]
1166    set index [$CIF(LoopSpinBox) getvalue]
1167    if {$index < 0} {
1168        $CIF(LoopSpinBox) setvalue first
1169        set index [$CIF(LoopSpinBox) getvalue]
1170    } elseif {$index > [llength [set ${array}([lindex $looplist 0])]]} {
1171        $CIF(LoopSpinBox) setvalue last
1172        set index [$CIF(LoopSpinBox) getvalue]
1173    }
1174    set CIF(lastLoopIndex) $index
1175    set frame [$CIF(displayFrame) getframe]
1176    set i 0
1177    foreach var $looplist {
1178        incr i
1179        set mark [lindex [set ${array}($var)] $index]
1180        # ignore invalid entries -- should not happen
1181        if {$mark == ""} {
1182            $CIF(LoopSpinBox) setvalue first
1183            return
1184        }
1185        set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]     
1186        if {$i == 1} {$CIF(txt) see $mark.l}
1187        if {$CIF(editmode)} {
1188            global CIFeditArr CIFinfoArr
1189            set widget [$frame.$i getframe].l
1190            set CIFeditArr($widget) $value
1191            switch [winfo class $widget] {
1192                Text {
1193                    $widget delete 0.0 end
1194                    $widget insert end $value
1195                }
1196                Entry {
1197                    $widget config -fg black
1198                }
1199            }
1200            set CIFinfoArr($widget) [lreplace $CIFinfoArr($widget) 2 2 $index]
1201        } else {
1202            [$frame.$i getframe].l config -text $value
1203        }
1204    }
1205}
1206
1207# scan a number in crystallographic uncertainty representation
1208# i.e.: 1.234(12), 1234(23), 1.234e-2(14),  -1.234-08(14), etc.
1209proc ParseSU {num} {
1210    # is there an error on this value?
1211    if {![regexp {([-+eEdD.0-9]+)\(([0-9]+)\)} $num x a err]} {
1212        set a $num
1213        set err {}
1214    }
1215    # parse off an exponent, if present
1216    if {[regexp {([-+.0-9]+)[EeDd]([-+0-9]+)} $a x a1 exp]} {
1217        # [+-]###.###e+## or [+-]###.###D-## etc.
1218        set a $a1
1219        # remove leading zeros from exponent
1220        regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
1221    } elseif {[regexp {([-+.0-9]+)([-+][0-9]+)} $a x a1 exp]} {
1222        # [+-]###.###+## or [+-]###.###-## etc. [no
1223        set a $a1
1224        # remove leading zeros from exponent
1225        regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
1226    } else {
1227        set exp 0
1228    }
1229    # now parse the main number and count the digits after the decimal
1230    set a2 {}
1231    set a3 {}
1232    regexp {^([-+0-9]*)\.?([0-9]*)$} $a x a2 a3
1233    set l [string length $a3]
1234
1235    set val .
1236    set error {}
1237    if {[catch {
1238        set val [expr ${a2}.${a3} * pow(10,$exp)]
1239        if {$err != ""} {
1240            set error [expr $err*pow(10,$exp-$l)]
1241        }
1242    }]} {
1243        # something above was invalid
1244        if {$err != ""} {
1245            return "$val ."
1246        } else {
1247            return $val
1248        }
1249    }
1250    if {$error == ""} {
1251        return $val
1252    } else {
1253        return [list $val $error]
1254    }
1255}
1256
1257# a stand-alone routine for testing: Select, read and browse a CIF
1258proc Read_BrowseCIF {} {
1259    global tcl_platform
1260    if {$tcl_platform(platform) == "windows"} {
1261        set filetypelist {
1262            {"CIF files" .CIF} {"All files" *}
1263        }
1264    } else {
1265        set filetypelist {
1266            {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
1267        }
1268    }   
1269    set file [tk_getOpenFile -parent . -filetypes $filetypelist]
1270    if {$file == ""} return
1271    if {![file exists $file]} return
1272    pleasewait "Reading CIF from file"
1273    set blocks [ParseCIF $file]
1274    if {$blocks == ""} {
1275        donewait
1276        MessageBox -parent . -type ok -icon warning \
1277                -message "Note: no valid CIF blocks were read from file $filename"
1278        return
1279    }
1280    catch {donewait}
1281    set allblocks {}
1282    for {set i 1} {$i <= $blocks} {incr i} {
1283        lappend allblocks $i
1284    }
1285    if {$allblocks != ""} {
1286        BrowseCIF $allblocks "" .cif
1287        # wait for the window to close
1288        tkwait window .cif
1289    } else {
1290        puts "no blocks read"
1291    }
1292    # clean up -- get rid of the CIF arrays
1293    for {set i 1} {$i <= $blocks} {incr i} {
1294        global block$i
1295        catch {unset block$i}
1296    }
1297}
1298
1299# this takes a block of text, strips off the quotes ("", '', [] or ;;)
1300proc StripQuotes {value} {
1301    set value [string trim $value]
1302    if {[string range $value end-1 end] == "\n;" && \
1303            [string range $value 0 0] == ";"} {
1304        return [string range $value 1 end-2]
1305    } elseif {[string range $value end end] == "\"" && \
1306            [string range $value 0 0] == "\""} {
1307        set value [string range $value 1 end-1]
1308    } elseif {[string range $value end end] == "'" && \
1309            [string range $value 0 0] == "'"} {
1310        set value [string range $value 1 end-1]
1311    } elseif {[string range $value end end] == {]} && \
1312            [string range $value 0 0] == {[}} {
1313        set value [string range $value 1 end-1]
1314    }
1315    return $value
1316}
1317
1318# replace a CIF value in with a new value.
1319# add newlines as needed to make sure the new value does not
1320# exceed CIF(maxlinelength) [defaults to 80] characters/line
1321proc ReplaceMarkedText {txt mark value} {
1322    $txt configure -state normal
1323    # is this a multi-line string?
1324    set num [string first \n $value]
1325    set l [string length $value]
1326    # are there spaces in the string?
1327    set spaces [string first " " $value]
1328    # if no, are there any square brackets? -- treat them as requiring quotes
1329    if {$spaces == -1} {set spaces [string first {[} $value]}
1330    # are there any reserved strings inside $value? If so, it must be quoted
1331    if {$spaces == -1} {
1332        set tmp [string toupper $value]
1333        foreach s {DATA_ LOOP_ SAVE_ STOP_ GLOBAL_} {
1334            if {[set spaces [string first $s $tmp]] != -1} break
1335        }
1336    }
1337    # are there quotes inside the string?
1338    set doublequote [string first "\"" $value]
1339    set singlequote [string first {'} $value]
1340    # if we have either type of quotes, use semicolon quoting
1341    if {$singlequote != -1 && $doublequote != -1} {set num $l}
1342
1343    # lines longer than 78 characters with spaces need to be treated
1344    # as multiline
1345    if {$num == -1 && $l > 77 && $spaces != -1} {
1346        set num $l
1347    }
1348    if {$num != -1} {
1349        set tmp {}
1350        if {[lindex [split [$txt index $mark.l] .] 1] != 0} {
1351            append tmp \n
1352        }
1353        append tmp ";"
1354        if {$num > 78} {
1355            append tmp \n
1356        } else {
1357            append tmp " "
1358        }
1359        append tmp $value "\n;"
1360        # is there something else on the line?
1361        set restofline [$txt get $mark.r [lindex [split [$txt index $mark.r] .] 0].end]
1362        if {[string trim $restofline] != ""} {
1363            append tmp \n
1364        }
1365        $txt delete ${mark}.l ${mark}.r
1366        $txt insert ${mark}.l $tmp
1367        $txt configure -state disabled
1368        return
1369    } elseif {($spaces != -1 || [string trim $value] == "") \
1370            && $doublequote == -1} {
1371        # use doublequotes, unless doublequotes are present inside the string
1372        set tmp "\""
1373        append tmp $value "\""
1374    } elseif {$spaces != -1 || [string trim $value] == ""} {
1375        # use single quotes, since doublequotes are present inside the string
1376        set tmp {'}
1377        append tmp $value {'}
1378    } else {
1379        # no quotes needed
1380        set tmp $value
1381    }
1382    # is there room on the beginning of the line to add the string?
1383    set l [string length $tmp]
1384    set pos [lindex [split [$txt index $mark.l] .] 0]
1385    if {$l + [string length [$txt get $pos.0 $mark.l]] <= 79} {
1386        # will fit
1387        $txt delete ${mark}.l ${mark}.r
1388        $txt insert ${mark}.l $tmp
1389    } else {
1390        # no, stick a CR in front of string
1391        $txt delete ${mark}.l ${mark}.r
1392        $txt insert ${mark}.l \n$tmp
1393    }
1394    # is rest of the line after the inserted string still too long?
1395    set pos [lindex [split [$txt index $mark.r] .] 0]
1396    if {[string length [$txt get $pos.0 $pos.end]] > 79} {
1397        $txt insert $mark.r \n
1398    }
1399    $txt configure -state disabled
1400}
1401
1402# return the dictionary definition for a list of CIF data names
1403proc GetCIFDefinitions {datanamelist} {
1404    global CIF_dataname_index
1405    set l {}
1406    # compile a list of definition pointers
1407    foreach dataname $datanamelist {
1408        set pointer {}
1409        catch {
1410            set pointer [lindex $CIF_dataname_index($dataname) 0]
1411        }
1412        lappend l [list $dataname $pointer]
1413    }
1414    set l [lsort -index 1 $l]
1415    set pp {}
1416    set dictdefs {}
1417    set def {start}
1418    set nlist {}
1419    # merge items with duplicate definitions
1420    foreach item $l {
1421        # is this the first loop through?
1422        foreach {dataname pointer} $item {}
1423        if {$def == "start"} {
1424            foreach {nlist pp} $item {}
1425            set def [ReadCIFDefinition $pp]
1426        } elseif {$pp == $pointer} {
1427            # same as last
1428            lappend nlist $dataname
1429        } else {
1430            # add the last entry to the list
1431            set file [lindex $pp 0]
1432            set pp $pointer
1433            lappend dictdefs [list $nlist $def $file]
1434            set nlist $dataname
1435            if {$pointer == ""} {
1436                set def { Undefined dataname}
1437            } else {
1438                # lookup name
1439                set def [ReadCIFDefinition $pointer]
1440            }
1441        }
1442    }
1443    set file [lindex $pointer 0]
1444    lappend dictdefs [list $nlist $def $file]
1445    return $dictdefs
1446}
1447
1448# read the CIF definition for a dataname. The pointer contains 3 values
1449# a filename, the number of characters from the start of the file and
1450# the length of the definition.
1451proc ReadCIFDefinition {pointer} {
1452    global CIF CIF_file_paths
1453    set file {}
1454    set loc {}
1455    set line {}
1456    foreach {file loc len} $pointer {}
1457    if {$file != "" && $loc != "" && $loc != ""} {
1458        set fp {}
1459        if {[array names CIF_file_paths $file] != ""} {
1460            catch {set fp [open $CIF_file_paths($file) r]}
1461            if {$fp == ""} return
1462        } elseif {[array names CIF_file_paths] != ""} {
1463            return
1464        } else {
1465            # support legacy applications using CIF(cif_path)
1466            foreach path $CIF(cif_path) {
1467                catch {set fp [open [file join $path $file] r]}
1468                if {$fp != ""} break
1469            }
1470        }
1471        if {$fp == ""} return
1472        fconfigure $fp -translation binary
1473        catch {
1474            seek $fp $loc
1475            set line [read $fp $len]
1476            close $fp
1477            # remove line ends & superfluous spaces
1478            regsub -all {\n} [StripQuotes $line] { } line
1479            regsub -all {\r} $line { } line
1480            regsub -all {  +} $line { } line
1481#           regsub -all {  +} [StripQuotes $line] { } line
1482        }
1483    }
1484    return $line
1485}
1486
1487proc ValidateCIFName {dataname} {
1488    global CIF_dataname_index
1489    if {[
1490        catch {
1491            set CIF_dataname_index($dataname)
1492        }
1493    ]} {return "warning: dataname $dataname not defined"}
1494}
1495
1496# validates that a CIF value is valid for a specific dataname
1497proc ValidateCIFItem {dataname item} {
1498    global CIF_dataname_index CIF
1499    # maximum line length
1500    set maxlinelength 80
1501    catch {set maxlinelength $CIF(maxlinelength)}
1502    if {[catch {
1503        foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {}
1504    }]} {return}
1505    if {$type == "c"} {
1506        # string type constant
1507        set item [StripQuotes $item]
1508        # is it enumerated?
1509        if {$elist != ""} {
1510            # check it against the list of values
1511            foreach i [concat $elist . ?] {
1512                if {[string tolower $item] == [string tolower [lindex $i 0]]} {return}
1513            }
1514            return "error: value \"$item\" is not an allowed option for $dataname"
1515        } else {
1516            # check it for line lengths
1517            set l 0
1518            set err {}
1519            foreach line [split $item \n] {
1520                incr l
1521                if {[string length $line] > $maxlinelength} {lappend err $l}
1522            }
1523            if {$err != ""} {return "error: line(s) $err are too long"}
1524        }
1525        return
1526    } elseif {$type == ""} {
1527        return "error: dataname $dataname is not used for CIF data items"
1528    } elseif {$type == "n"} {
1529        # validate numbers
1530        set unquoted [StripQuotes $item]
1531        if {$unquoted == "?" || $unquoted == "."} return
1532        if {$unquoted != $item} {
1533            set err "\nwarning: number $item is quoted for $dataname"
1534            set item $unquoted
1535        } else {
1536            set err {}
1537        }
1538        set v $item
1539        # remove s.u., if allowed & present
1540        set vals [ParseSU $item]
1541        if {[set v [lindex $vals 0]] == "."} {
1542            return "error: value \"$item\" is not a valid number for $dataname$err"
1543        }
1544        if {$esd} {
1545            if {[lindex $vals 1] == "."} {
1546                return "error: value \"$item\" for $dataname has an invalid uncertainty (esd)$err"
1547            }
1548        } elseif {[llength $vals] == 2} {
1549            return "error: \"$item\" is invalid for $dataname, an uncertainty (esd) is not allowed$err"
1550        }
1551
1552        # now validate the range
1553        if {$range != ""} {
1554            # is there a decimal point in the range?
1555            set integer 0
1556            if {[string first . $range] == -1} {set integer 1}
1557            # pull out the range
1558            foreach {min max} [split $range :] {}
1559            if {$integer && int($v) != $v} {
1560                return "warning: value \"$item\" is expected to be an integer for $dataname$err"
1561            }
1562            if {$min != ""} {
1563                if {$v < $min} {
1564                    return "error: value \"$item\" is too small for $dataname (allowed range $range)$err"
1565                }
1566            }
1567            if {$max != ""} {
1568                if {$v > $max} {
1569                    return "error: value \"$item\" is too big for $dataname(allowed range $range)$err"
1570                }
1571            }
1572        }
1573        return $err
1574    }
1575    return {}
1576}
1577
1578# displays the dictionary definitions in variable defs into a text widget
1579proc ShowDictionaryDefinition {defs} {
1580    global CIF
1581    set deflist [GetCIFDefinitions $defs]
1582    catch {
1583        $CIF(defBox) delete 1.0 end
1584        foreach d $deflist {
1585            foreach {namelist definition file} $d {}
1586            foreach n $namelist {
1587                $CIF(defBox) insert end $n dataname
1588                $CIF(defBox) insert end \n
1589            }
1590            $CIF(defBox) insert end \n
1591            if {$definition == ""} {
1592                $CIF(defBox) insert end "No definition found\n\n"
1593            } else {
1594                $CIF(defBox) insert end $definition
1595                $CIF(defBox) insert end "\n\[$file\]\n\n"
1596            }
1597
1598        }
1599        $CIF(defBox) tag config dataname -background yellow
1600    }
1601}
1602
1603# create a widget to display a CIF value
1604proc DisplayCIFvalue {widget dataname loopval value block "row 0"} {
1605    global CIFeditArr CIFinfoArr
1606    global CIF CIF_dataname_index
1607    if {[
1608        catch {
1609            foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {}
1610        }
1611    ]} {
1612        set type c
1613        set elist {}
1614    }
1615
1616    lappend CIF(widgetlist) $widget
1617    set CIFinfoArr($widget) {}
1618
1619    if $CIF(editmode) {
1620        if {$loopval != ""} {
1621            set widgetinfo [list $dataname $block [expr $loopval -1]]
1622        } else {
1623            set widgetinfo [list $dataname $block 0]
1624        }
1625        set CIFeditArr($widget) $value
1626        set CIFinfoArr($widget) $widgetinfo
1627
1628        if {$type == "n"} {
1629            entry $widget -justify left -textvariable CIFeditArr($widget)
1630            bind $widget <Leave> "CheckChanges $widget"
1631            grid $widget -sticky nsw -column 1 -row $row
1632            if {$units != ""} {
1633                set ws "${widget}u"
1634                label $ws -text "($units)" -bg yellow
1635                grid $ws -sticky nsw -column 2 -row $row
1636            }
1637        } elseif {$elist != ""} {
1638            set enum {}
1639            foreach e $elist {
1640                lappend enum [lindex $e 0]
1641            }
1642            tk_optionMenu $widget CIFeditArr($widget) ""
1643            FixBigOptionMenu $widget $enum "CheckChanges $widget"
1644            AddSpecialEnumOpts $widget "CheckChanges $widget"
1645            grid $widget -sticky nsw -column 1 -row $row
1646        } else {
1647            # count the number of lines in the text
1648            set nlines [llength [split $value \n]]
1649            if {$nlines < 1} {
1650                set nlines 1
1651            } elseif {$nlines > 10} {
1652                set nlines 10
1653            }
1654            set ws "${widget}s"
1655            text $widget -height $nlines -width 80 -yscrollcommand "$ws set"
1656            scrollbar $ws -command "$widget yview" -width 10 -bd 1
1657            $widget insert end $value
1658            bind $widget <Leave> "CheckChanges $widget"
1659            if {$nlines > 1} {
1660                grid $ws -sticky nsew -column 1 -row $row
1661                grid $widget -sticky nsew -column 2 -row $row
1662            } else {
1663                grid $widget -sticky nsew -column 1 -columnspan 2 -row $row
1664            }
1665        }
1666    } else {
1667        label $widget -bd 2 -relief groove \
1668                -justify left -anchor w -text $value
1669        grid $widget -sticky nsw -column 1 -row $row
1670        if {$type == "n" && $units != ""} {
1671            set ws "${widget}u"
1672            label $ws -text "($units)" -bg yellow
1673            grid $ws -sticky nsw -column 2 -row $row
1674        }
1675    }
1676}
1677
1678# this is called to see if the user has changed the value for a CIF
1679# data item and to validate it.
1680#   save the change if $save is 1
1681#   return 1 if the widget contents has changed
1682proc CheckChanges {widget "save 0"} {
1683    global CIFeditArr CIFinfoArr CIF
1684    # maximum line length
1685    set maxlinelength 80
1686    catch {set maxlinelength $CIF(maxlinelength)}
1687
1688    set CIF(errormsg) {}
1689
1690    if {![winfo exists $widget]} return
1691
1692    set dataname {}
1693    catch {
1694        foreach {dataname block index} $CIFinfoArr($widget) {}
1695    }
1696    # if this widget is a label, the info above will not be defined & checks are not needed
1697    if {$dataname == ""} {return 0}
1698    if {$dataname == "Parse-errors"} {return 0}
1699    if {$dataname == "Validation-errors"} {return 0}
1700
1701    global ${block}
1702    set mark [lindex [set ${block}($dataname)] $index]
1703    if {$mark == ""} return
1704    set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1705
1706    # validate the entry
1707    set error {}
1708    set err {}
1709    switch [winfo class $widget] {
1710        Text {
1711            set current [string trim [$widget get 1.0 end]]
1712            set l 0
1713            foreach line [set linelist [split $current \n]] {
1714                incr l
1715                if {[string length $line] > $maxlinelength} {
1716                    lappend err $l
1717                    lappend error "Error: line $l for $dataname is >$maxlinelength characters"
1718                }
1719            }
1720            if {$err != ""} {
1721                foreach l $err {
1722                    $widget tag add error $l.0 $l.end
1723                }
1724                $widget tag config error -foreground red
1725            } else {
1726                $widget tag delete error
1727            }
1728            # see if box should expand
1729            set clines [$widget cget -height]
1730            if {$clines <= 2 && \
1731                    [string trim $orig] != [string trim $current]} {
1732                # count the number of lines in the text
1733                set nlines [llength $linelist]
1734                if {[lindex $linelist end] == ""} {incr nlines -1}
1735                if {$nlines == 2} {
1736                    $widget config -height 2
1737                } elseif {$nlines > 2} {
1738                    set i [lsearch [set s [grid info $widget]] -row]
1739                    set row [lindex $s [expr 1+$i]]
1740                    $widget config -height 3
1741                    set ws "${widget}s"
1742                    grid $ws -sticky nsew -column 1 -row $row
1743                    grid $widget -sticky nsew -column 2 -row $row
1744                }
1745            }
1746        }
1747        Entry {
1748            set current [string trim [$widget get]]
1749            set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current]
1750            if {$err != "" && \
1751                    [string tolower [lindex $err 0]] != "warning:"} {
1752                lappend error $err
1753                $widget config -fg red
1754            } else {
1755                $widget config -fg black
1756            }
1757        }
1758        Menubutton {
1759            set current $CIFeditArr($widget)
1760        }
1761        Label {
1762            return 0
1763        }
1764    }
1765    if {[string trim $orig] != [string trim $current]} {
1766        if {$err != ""} {
1767            set CIF(errormsg) $error
1768        } elseif {$save} {
1769            SaveCIFedits $widget
1770            return 0
1771        }
1772        return 1
1773    }
1774    return 0
1775}
1776
1777# save the CIF edits into the CIF text widget
1778proc SaveCIFedits {widget} {
1779    global CIFeditArr CIFinfoArr CIF
1780
1781    foreach {dataname block index} $CIFinfoArr($widget) {}
1782    global ${block}
1783    set mark [lindex [set ${block}($dataname)] $index]
1784    set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1785    switch [winfo class $widget] {
1786        Text {
1787            set current [string trim [$widget get 1.0 end]]
1788        }
1789        Entry {
1790            set current [string trim [$widget get]]
1791        }
1792        Menubutton {
1793            set current $CIFeditArr($widget)
1794        }
1795    }
1796    # save for undo & clear the redo list
1797    set CIF(redolist) {}
1798    if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} {
1799        lappend CIF(undolist) [list $mark $orig \
1800                $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1801    } else {
1802        lappend CIF(undolist) [list $mark $orig \
1803                $CIF(lastShownItem) $CIF(lastShownTreeID)]
1804    }
1805    # count it
1806    incr CIF(changes)
1807    # make the change
1808    ReplaceMarkedText $CIF(txt) $mark $current
1809}
1810
1811# add a new "row" to a CIF loop. At least for now, we only add at the end.
1812proc AddToCIFloop {block loop} {
1813    global $block CIF
1814    # check for unsaved changes here
1815    if {[CheckForCIFEdits]} return
1816
1817    $CIF(txt) configure -state normal
1818    set looplist [set ${block}($loop)]
1819    set length [llength [set ${block}([lindex $looplist 0])]]
1820    # find the line following the last entry in the list
1821    set var [lindex $looplist end]
1822    set line [lindex [split [\
1823            $CIF(txt) index [lindex [set ${block}($var)] end].r \
1824            ] .] 0]
1825    incr line
1826    set epos $line.0
1827    $CIF(txt) insert $epos \n
1828
1829    # insert a ? token for each entry & add to marker list for each variable
1830    set addlist {}
1831    foreach var $looplist {
1832        # go to next line?
1833        if {[string length \
1834                [$CIF(txt) get "$epos linestart" "$epos lineend"]\
1835                ] > 78} {
1836            $CIF(txt) insert $epos \n
1837            set epos [$CIF(txt) index "$epos + 1c"]
1838        }
1839        $CIF(txt) insert $epos "? "
1840        incr CIF(markcount)
1841        $CIF(txt) mark set $CIF(markcount).l "$epos"
1842        $CIF(txt) mark set $CIF(markcount).r "$epos + 1c"
1843        $CIF(txt) mark gravity $CIF(markcount).l left
1844        $CIF(txt) mark gravity $CIF(markcount).r right
1845        set epos [$CIF(txt) index "$epos + 2c"]
1846        set index [llength [set ${block}($var)]]
1847        lappend ${block}($var) $CIF(markcount)
1848        lappend addlist [list $CIF(markcount) $var $index $block]
1849    }
1850    incr CIF(changes)
1851    lappend CIF(undolist) [list "loop add" $addlist \
1852            $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1853    set CIF(redolist) {}
1854
1855    # now show the value we have added
1856    set frame [$CIF(displayFrame) getframe]
1857    set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1858    incr max
1859    $CIF(LoopSpinBox) configure -range "1 $max 1"
1860    $CIF(LoopSpinBox) setvalue last
1861    ShowLoopVar $block $loop
1862    $CIF(txt) configure -state disabled
1863    $CIF(DeleteLoopEntry) configure -state normal
1864}
1865
1866proc DeleteCIFRow {} {
1867    global CIF
1868    global CIFinfoArr CIFeditArr
1869
1870    set delrow [$CIF(LoopSpinBox) getvalue]
1871
1872    set msg {Are you sure you want to delete the following loop entries}
1873    append msg " (row number [expr 1+$delrow])?\n"
1874    set widget ""
1875    foreach widget $CIF(widgetlist) {
1876        set var [lindex $CIFinfoArr($widget) 0]
1877        append msg "\n$var\n\t"
1878        # get the value
1879        switch [winfo class $widget] {
1880            Text {
1881                set value [string trim [$widget get 1.0 end]]
1882            }
1883            Entry {
1884                set value [string trim [$widget get]]
1885            }
1886            Menubutton {
1887                set value $CIFeditArr($widget)
1888            }
1889        }
1890        append msg $value \n
1891    }
1892    if {$widget == ""} {
1893        error "this should not happen"
1894    }
1895    foreach {dataname block index} $CIFinfoArr($widget) {}
1896    global $block
1897    if {[llength [set ${block}($dataname)]] == 1} {
1898        MyMessageBox -parent . -title "Not only row" \
1899                -message {Sorry, this program is unable to delete all entries from a loop.} \
1900                -icon warning -type {Ignore} -default Ignore
1901        return
1902    }
1903
1904    set ans [MyMessageBox -parent . -title "Delete Row?" \
1905                -message $msg \
1906                -icon question -type {Keep Delete} -default Keep]
1907    if {$ans == "keep"} {return}
1908
1909    $CIF(txt) configure -state normal
1910    set deletelist {}
1911    foreach widget $CIF(widgetlist) {
1912        foreach {dataname block index} $CIFinfoArr($widget) {}
1913        global $block
1914        set mark [lindex [set ${block}($dataname)] $index]
1915        set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1916        lappend deletelist [list $mark $dataname $index $block $orig]
1917        $CIF(txt) delete $mark.l $mark.r
1918        set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
1919    }
1920    set CIF(redolist) {}
1921    lappend CIF(undolist) [list "loop delete" $deletelist \
1922            $CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1923    # count it
1924    incr CIF(changes)
1925
1926    $CIF(txt) configure -state disabled
1927
1928    set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1929    incr max -1
1930    $CIF(LoopSpinBox) configure -range "1 $max 1"
1931    if {$index >= $max} {set index $max; incr index -1}
1932    $CIF(LoopSpinBox) setvalue @$index
1933    if {$max == 1} {$CIF(DeleteLoopEntry) configure -state disabled}
1934    # don't check for changes
1935    set CIF(lastLoopIndex) {}
1936    ShowLoopVar $block [lindex $CIF(lastShownItem) 1]
1937}
1938
1939# display & highlight a line in the CIF text viewer
1940proc MarkGotoLine {line} {
1941    global CIF
1942    $CIF(txt) tag delete currentline
1943    $CIF(txt) tag add currentline $line.0 $line.end
1944    $CIF(txt) tag configure currentline -foreground blue
1945    $CIF(txt) see $line.0
1946}
1947
1948# Extract a value from a CIF in the  CIF text viewer
1949proc ValueFromCIF {block item} {
1950    global $block CIF
1951    set val {}
1952    catch {
1953        set mark [set ${block}($item)]
1954        if {[llength $mark] == 1} {
1955            set val [string trim [StripQuotes [$CIF(txt) get $mark.l $mark.r]]]
1956        } else {
1957            foreach m $mark {
1958                lappend val [string trim [StripQuotes [$CIF(txt) get $m.l $m.r]]]
1959            }
1960        }
1961    }
1962    return $val
1963}
1964
1965proc UndoChanges {} {
1966    global CIF
1967    # save any current changes, if possible
1968    if {[CheckForCIFEdits]} return
1969    # are there edits to undo?
1970    if {[llength $CIF(undolist)] == 0} return
1971
1972    foreach {mark orig lastShownItem lastShownTreeID lastLoopIndex} \
1973            [lindex $CIF(undolist) end] {} 
1974
1975    if {[llength $mark] == 1} {
1976        # get the edited value
1977        set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1978        # make the change back
1979        ReplaceMarkedText $CIF(txt) $mark $orig
1980        # add this undo to the redo list
1981        lappend CIF(redolist) [list $mark $edited $lastShownItem \
1982                $lastShownTreeID $lastLoopIndex]
1983    } elseif {[lindex $mark 1] == "add"} {
1984        set deletelist {}
1985        $CIF(txt) configure -state normal
1986        foreach m $orig {
1987            foreach {mark dataname index block} $m {}
1988            # get the inserted value
1989            set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]   
1990            $CIF(txt) delete $mark.l $mark.r
1991            lappend deletelist [list $mark $dataname $index $block $edited]
1992            global $block
1993            set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
1994        }
1995        $CIF(txt) configure -state disabled
1996        # add this action to the redo list
1997        lappend CIF(redolist) [list "loop delete" $deletelist \
1998                $lastShownItem $lastShownTreeID $lastLoopIndex]
1999    } elseif {[lindex $mark 1] == "delete"} {
2000        set addlist {}
2001        foreach m $orig {
2002            foreach {mark dataname index block orig} $m {}
2003            # make the change back
2004            ReplaceMarkedText $CIF(txt) $mark $orig
2005            lappend addlist [list $mark $dataname $index $block]
2006            global $block
2007            set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark]
2008        }
2009        # show the entry that was added
2010        set lastLoopIndex $index
2011        # add this last entry to the redo list
2012        lappend CIF(redolist) [list "loop add" $addlist \
2013                $lastShownItem $lastShownTreeID $lastLoopIndex]
2014    }
2015
2016    # drop the action from the undo list
2017    set CIF(undolist) [lreplace $CIF(undolist) end end]
2018    # count back
2019    incr CIF(changes) -1
2020    # scroll on the tree
2021    $CIF(tree) see $lastShownTreeID
2022    eval showCIFbyDataname $lastShownItem
2023
2024    # if we are in a loop, display the element
2025    if {[lindex [lindex $lastShownItem 0] 1] == "loop"} {
2026        $CIF(LoopSpinBox) setvalue @$lastLoopIndex
2027        ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \
2028                [lindex $lastShownItem 1]
2029    }
2030}
2031
2032
2033proc RedoChanges {} {
2034    global CIF
2035    # save any current changes, if possible
2036    if {[CheckForCIFEdits]} return
2037    # are there edits to redo?
2038    if {[llength $CIF(redolist)] == 0} return
2039
2040    foreach {mark edited lastShownItem lastShownTreeID lastLoopIndex} \
2041            [lindex $CIF(redolist) end] {} 
2042
2043    if {[llength $mark] == 1} {
2044        # get the edited value
2045        set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
2046        # make the change back
2047        ReplaceMarkedText $CIF(txt) $mark $edited
2048        # add this action back to the undo list
2049        lappend CIF(undolist) [list $mark $orig $lastShownItem \
2050                $lastShownTreeID $lastLoopIndex]
2051        # count up
2052        incr CIF(changes)
2053    } elseif {[lindex $mark 1] == "add"} {
2054        set deletelist {}
2055        $CIF(txt) configure -state normal
2056        foreach m $edited {
2057            foreach {mark dataname index block} $m {}
2058            # get the inserted value
2059            set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]   
2060            $CIF(txt) delete $mark.l $mark.r
2061            lappend deletelist [list $mark $dataname $index $block $edited]
2062            global $block
2063            set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
2064        }
2065        $CIF(txt) configure -state disabled
2066        # add this action back to the undo list
2067        lappend CIF(undolist) [list "loop delete" $deletelist \
2068                $lastShownItem $lastShownTreeID $lastLoopIndex]
2069        # count up
2070        incr CIF(changes)
2071    } elseif {[lindex $mark 1] == "delete"} {
2072        set addlist {}
2073        foreach m $edited {
2074            foreach {mark dataname index block orig} $m {}
2075            # make the change back
2076            ReplaceMarkedText $CIF(txt) $mark $orig
2077            lappend addlist [list $mark $dataname $index $block]
2078            global $block
2079            set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark]
2080        }
2081        # show the entry that was added
2082        set lastLoopIndex $index
2083        # add this action back to the undo list
2084        lappend CIF(undolist) [list "loop add" $addlist \
2085                $lastShownItem $lastShownTreeID $lastLoopIndex]
2086        # count up
2087        incr CIF(changes)
2088    }
2089   
2090    # drop the action from the redo list
2091    set CIF(redolist) [lreplace $CIF(redolist) end end]
2092    # scroll on the tree
2093    $CIF(tree) see $lastShownTreeID
2094    eval showCIFbyDataname $lastShownItem
2095   
2096    # if we are in a loop, display the element
2097    if {[lindex [lindex $lastShownItem 0] 1] == "loop"} {
2098        $CIF(LoopSpinBox) setvalue @$lastLoopIndex
2099        ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \
2100                [lindex $lastShownItem 1]
2101    }
2102}
2103
2104# create a category browser to select a single CIF item (mode=single)
2105# or to populate a loop_ (mode=multiple)
2106proc CatBrowserWindow {parent "mode multiple"} {
2107    global CIF CIF_dataname_index
2108    global catlist
2109    if {$mode == "multiple"} {
2110        set CIF(catselectmode) 1
2111    } else {
2112        set CIF(catselectmode) 0
2113    }
2114    set CIF(CategoryBrowserWin) [set frame $parent.catselect]
2115    if {[winfo exists $frame]} {
2116        set CIF(searchtext) ""
2117        # the window exists so go ahead and use it
2118        set CIF(SelCat) {}
2119        set CIF(CatSelList) {}
2120        set CIF(CatSelItems) {}
2121        wm deiconify $frame
2122        $CIF(cattree) selection clear
2123        tkwait variable CIF(CatSelectDone)
2124        wm withdraw $frame
2125        return
2126    }
2127    catch {unset catlist}
2128    set CIF(searchtext) ""
2129    pleasewait "building category window" "" $parent
2130    # create an index by category
2131    foreach name [lsort [array names CIF_dataname_index]] {
2132        set category [lindex [lindex $CIF_dataname_index($name) 1] 5]
2133        lappend catlist($category) $name
2134    }
2135    catch {destroy $frame}
2136    toplevel $frame
2137    wm withdraw $frame
2138    wm title $frame "CIF Category Browser"
2139    wm protocol $frame WM_DELETE_WINDOW "set CIF(CatSelItems) {}; set CIF(CatSelectDone) Q"
2140    if {$CIF(catselectmode)} {
2141        set text "Select one or more data names in a\nsingle category to create a new loop"
2142    } else {
2143        set text "Select a single data name to add to the CIF"
2144    }
2145    grid [frame $frame.top -bg beige] -sticky news -column 0 -row 0
2146    grid columnconfigure $frame.top 0 -weight 1
2147    grid columnconfigure $frame.top 1 -pad 10
2148    grid [label $frame.top.1 -text $text -bg beige] \
2149            -sticky news -column 0 -row 0 
2150    grid [set CIF(usebutton) [button $frame.top.use -text "Insert" \
2151            -command "set CIF(CatSelectDone) done" \
2152            -state disabled]] -column 1 -row 0
2153    grid [frame $frame.bot] -sticky news -column 0 -row 2
2154    grid [label $frame.bot.txt -text "Enter search text:"] \
2155            -column 0 -row 1
2156    grid [entry $frame.bot.e -textvariable CIF(searchtext)] \
2157            -column 1 -row 1
2158    bind $frame.bot.e <Return> CatLookupName
2159    grid [button $frame.bot.src -text "Search" \
2160            -command CatLookupName] -column 2 -row 1
2161    grid [button $frame.bot.next -text "Next" -command ShowNextcatSearch] \
2162            -column 3 -row 1
2163    grid [button $frame.bot.q -text Quit \
2164            -command "set CIF(CatSelItems) {}; set CIF(CatSelectDone) Q"\
2165            ] -column 5 -row 1
2166    set sw    [ScrolledWindow $frame.lf]
2167    $frame.lf configure -relief sunken -borderwidth 2
2168    set CIF(cattree) [Tree $sw.tree -relief flat -borderwidth 0 -width 45 \
2169            -highlightthickness 0 -redraw 1 -height 20]
2170    # get the size of the font and adjust the line spacing accordingly
2171    catch {
2172        set font [option get $CIF(cattree) font Canvas]
2173        $CIF(cattree) configure -deltay [font metrics $font -linespace]
2174    }
2175    grid $sw -sticky news -column 0 -row 1 
2176    grid columnconfigure $frame 0 -minsize 275 -weight 1
2177    grid rowconfigure $frame 1 -weight 1
2178    $sw setwidget $CIF(cattree)
2179   
2180    bind $frame <KeyPress-Prior> "$CIF(cattree) yview scroll -1 page"
2181    bind $frame <KeyPress-Next> "$CIF(cattree) yview scroll 1 page"
2182    bind $frame <KeyPress-Up> "$CIF(cattree) yview scroll -1 unit"
2183    bind $frame <KeyPress-Down> "$CIF(cattree) yview scroll 1 unit"
2184    bind $frame <KeyPress-Home> "$CIF(cattree) yview moveto 0"
2185    #bind $frame <KeyPress-End> "$CIF(cattree) yview moveto end"
2186    # -- does not work
2187    bind $frame <KeyPress-End> "$CIF(cattree) yview scroll 99999999 page"
2188    $CIF(cattree) see 0
2189
2190    # Bwidget seems to have problems with the name "1", so avoid it
2191    set num 100
2192    set n 0
2193    global catCIFindex
2194    catch {unset catCIFindex}
2195    set normalfont [option get [winfo toplevel $CIF(cattree)] font Canvas]
2196    set italic "$font italic"
2197    foreach cat [lsort [array names catlist]] {
2198        if {$cat == ""} continue
2199        $CIF(cattree) insert end root cat$n -text $cat \
2200                -open 0 -image [Bitmap::get folder]
2201        foreach item [lsort $catlist($cat)] {
2202            set loop [lindex [lindex $CIF_dataname_index($item) 1] 6]
2203            if {$loop || !$CIF(catselectmode)} {
2204                set font $normalfont
2205                set sel 1
2206            } else {
2207                set font $italic
2208                set sel 0
2209            }
2210            $CIF(cattree) insert end cat$n [incr num] -text $item \
2211                    -image [Bitmap::get file] -selectable $sel -font $font
2212            set catCIFindex($item) $num
2213        }
2214        incr n
2215    }
2216    # set code to respond to mouse clicks
2217    $CIF(cattree) bindImage <1> selectCat
2218    $CIF(cattree) bindText <1>  selectCat
2219    $CIF(cattree) bindImage <Control-1> {}
2220    $CIF(cattree) bindText <Control-1>  {}
2221   
2222    set CIF(SelCat) {}
2223    set CIF(CatSelList) {}
2224    set CIF(CatSelItems) {}
2225    donewait
2226    wm deiconify $frame
2227    tkwait variable CIF(CatSelectDone)
2228    wm withdraw $frame
2229}
2230
2231# respond to a selection event in CatBrowserWindow
2232proc selectCat {item} {
2233    global CIF
2234    # ignore selected category items
2235    if {[string first cat $item] == 0} {return}
2236    set name [$CIF(cattree) itemcget $item -text]
2237    set category [$CIF(cattree) itemcget [$CIF(cattree) parent $item] -text]
2238    if {!$CIF(catselectmode)} {
2239        # single selection mode
2240        set CIF(SelCat) $category
2241        set CIF(CatSelList) $item
2242    } elseif {$CIF(SelCat) != $category} {
2243        # new category
2244        set CIF(SelCat) $category
2245        set CIF(CatSelList) $item
2246    } elseif {[set ind [lsearch $CIF(CatSelList) $item]] >= 0} {
2247        # toggle
2248        set CIF(CatSelList) [lreplace $CIF(CatSelList) $ind $ind]
2249    } else {
2250        # add to category
2251        lappend CIF(CatSelList) $item
2252    }
2253    if {[llength $CIF(CatSelList)] == 0} {
2254        $CIF(cattree) selection clear
2255    } else {
2256        eval $CIF(cattree) selection set $CIF(CatSelList)
2257    }
2258    set CIF(CatSelItems) {}
2259    foreach node $CIF(CatSelList) {
2260        lappend CIF(CatSelItems) [$CIF(cattree) itemcget $node -text]
2261    }
2262    if {$CIF(CatSelItems) != ""} {
2263        ShowDictionaryDefinition $CIF(CatSelItems)
2264        $CIF(usebutton) configure -state normal
2265    } else {
2266        $CIF(usebutton) configure -state disabled
2267    }
2268}
2269
2270# search through the category browser for a string
2271proc CatLookupName {} {
2272    global CIF catCIFindex
2273    pleasewait "performing search" "" [winfo toplevel $CIF(cattree)]
2274
2275    set str $CIF(searchtext)
2276    # close all nodes
2277    foreach node [$CIF(cattree) nodes root] {
2278        $CIF(cattree) closetree $node
2279    }
2280    set catsearchlist {}
2281    set namelist [array names catCIFindex *[string tolower $str]*]
2282    if {[llength $namelist] == 0} {
2283        MyMessageBox -parent [winfo toplevel $CIF(cattree)] \
2284                -title "Not found" \
2285                -message "String not found" -icon warning -type OK \
2286                -default ok
2287    }
2288    foreach name $namelist {
2289        set node $catCIFindex($name)
2290        lappend catsearchlist $node
2291        set pnode [$CIF(cattree) parent $node]
2292        $CIF(cattree) opentree $pnode
2293    }
2294    set CIF(catsearchlist) [lsort -integer $catsearchlist]
2295    set CIF(catsearchnum) -1
2296    donewait
2297    # find 1st element
2298    ShowNextcatSearch
2299}
2300
2301# successively display located data items in the category browser
2302proc ShowNextcatSearch {} {
2303    global CIF
2304    $CIF(usebutton) configure -state disabled
2305    set node [lindex $CIF(catsearchlist) [incr CIF(catsearchnum)]]
2306    if {$node == ""} {
2307        set CIF(catsearchnum) 0
2308        set node [lindex $CIF(catsearchlist) 0]
2309    }
2310    if {$node == ""} {
2311        $CIF(cattree) selection set
2312        return
2313    }
2314    ShowDictionaryDefinition [$CIF(cattree) itemcget $node -text]
2315    $CIF(cattree) see $node
2316    $CIF(cattree) selection set $node
2317}
2318
2319# create a data item browser to select a single CIF item
2320#
2321proc CatListWindow {parent} {
2322    global CIF CIF_dataname_index
2323    global catlist
2324    set CIF(searchtext) ""
2325    set frame $parent.catselect
2326    catch {destroy $frame}
2327    toplevel $frame
2328    wm title $frame "CIF Data Name Browser"
2329    grid [label $frame.top -text "Select a CIF data name to add" \
2330            -bd 2 -bg beige -relief raised] \
2331            -sticky news -column 0 -row 0  -columnspan 3
2332    grid [label $frame.top1 -text "Dictionary" -bg beige -anchor w] \
2333            -sticky news -column 0 -row 1  -columnspan 2
2334    grid [label $frame.top2 -text "Data name" -bg beige -anchor w] \
2335            -sticky news -column 2 -row 1 
2336    grid [frame $frame.bot] -sticky news -column 0 -row 3 -columnspan 3
2337    grid [label $frame.bot.txt -text "Enter search text:"] \
2338            -column 0 -row 1
2339    grid [entry $frame.bot.e -textvariable CIF(searchtext)] \
2340            -column 1 -row 1
2341    bind $frame.bot.e <Return> CatFindMatchingNames
2342    grid [button $frame.bot.src -text "Search" \
2343            -command CatFindMatchingNames] -column 2 -row 1
2344    grid [checkbutton $frame.bot.sort -text "Sort by dict." \
2345            -variable CIF(sortbydict) \
2346            -command CatFindMatchingNames] -column 3 -row 1
2347    grid [set CIF(usebutton) [button $frame.bot.use -text "Insert" \
2348            -command "destroy $frame"]] -column 4 -row 1
2349    grid [button $frame.bot.q -text Quit \
2350            -command "set CIF(CatSelItems) {}; destroy $frame"] -column 5 -row 1
2351    grid [set CIF(catlist) [listbox $frame.list -width 55 \
2352            -height 20 -exportselection 0 \
2353            -yscrollcommand "syncLists $frame.list $frame.dict $frame.ys yview"\
2354            ]] -column 2 -row 2 -sticky nsew
2355    grid [set CIF(dictlist) [listbox $frame.dict -width 12 \
2356            -height 20 -exportselection 0 \
2357            -yscrollcommand "syncLists $frame.dict $frame.list $frame.ys yview"\
2358            ]] -column 0 -row 2 -sticky nsew
2359    grid [scrollbar $frame.ys -width 15 -bd 2 \
2360            -command "moveLists \[list $frame.list $frame.dict] yview" \
2361            ] -column 1 -row 2  -sticky ns
2362
2363    bind $CIF(catlist) <<ListboxSelect>> \
2364            "ListSelectedCmd $CIF(catlist) $CIF(dictlist); SetSelectedCmd $CIF(catlist)"
2365    bind $CIF(dictlist) <<ListboxSelect>> \
2366            "ListSelectedCmd $CIF(dictlist) $CIF(catlist); SetSelectedCmd $CIF(catlist)"
2367    grid columnconfigure $frame 2 -minsize 275 -weight 1
2368    grid rowconfigure $frame 2 -weight 1
2369   
2370    bind $frame <KeyPress-Prior> "$CIF(catlist) yview scroll -1 page"
2371    bind $frame <KeyPress-Next> "$CIF(catlist) yview scroll 1 page"
2372    bind $frame <KeyPress-Up> "$CIF(catlist) yview scroll -1 unit"
2373    bind $frame <KeyPress-Down> "$CIF(catlist) yview scroll 1 unit"
2374    bind $frame <KeyPress-Home> "$CIF(catlist) yview moveto 0"
2375    bind $frame <KeyPress-End> "$CIF(catlist) yview moveto end"
2376    $CIF(catlist) see 0
2377
2378    CatFindMatchingNames
2379    tkwait window $frame
2380}
2381
2382#
2383# populate the data item browser created in CatListWindow
2384proc CatFindMatchingNames {} {
2385    global CIF CIF_dataname_index
2386    set str $CIF(searchtext)
2387    set searchlist {}
2388    foreach name [array names CIF_dataname_index *[string tolower $str]*] {
2389        lappend searchlist [list $name [lindex [lindex $CIF_dataname_index($name) 0] 0]]
2390    }
2391    $CIF(catlist) delete 0 end
2392    $CIF(dictlist) delete 0 end
2393    set searchlist [lsort -index 0 $searchlist]
2394    if {$CIF(sortbydict)} {set searchlist [lsort -index 1 $searchlist]}
2395    foreach item $searchlist {
2396        foreach {name dict} $item {}
2397        $CIF(catlist) insert end $name
2398        $CIF(dictlist) insert end $dict
2399    }
2400    $CIF(usebutton) configure -state disabled
2401}
2402
2403# replicate selection between list boxes
2404# list must be config'ed -exportselection 0
2405proc ListSelectedCmd {master slaves} {
2406    global CIF
2407    foreach slave $slaves {
2408        $slave selection clear 0 end
2409        $slave selection set [$master curselection]
2410    }
2411    $CIF(usebutton) configure -state normal
2412}
2413
2414proc SetSelectedCmd {itemlist} {
2415    global CIF
2416    set CIF(CatSelItems) [$itemlist get [$itemlist curselection]]
2417    ShowDictionaryDefinition $CIF(CatSelItems)
2418}
2419
2420# sync one or more slaved listboxes to a master
2421# cmd is xview or yview
2422proc syncLists {master slaves scroll cmd args} {
2423    foreach slave $slaves {
2424        $slave $cmd moveto [lindex [$master $cmd] 0]
2425    }
2426    eval $scroll set $args
2427}
2428
2429# move multiple listboxes based on a single scrollbar
2430# cmd is xview or yview
2431proc moveLists {listlist cmd args} {
2432    foreach list $listlist { 
2433        eval $list $cmd $args
2434    }
2435}
2436
2437# insert a data item into block $blk
2438proc InsertDataItem {dataname blk "value ?"} {
2439    global CIF
2440    global $blk
2441
2442    # find the last data item in the CIF
2443    set txt $CIF(txt)
2444    set last [set ${blk}(lastmark)]
2445    set i [$txt index $last.r]
2446    # insert the new dataname right after the last data item
2447    $txt config -state normal
2448    $txt insert $i "\n$dataname        " x $value y
2449    # reposition the mark for the original last data item in case it moved
2450    $txt mark set $last.r $i
2451    $txt mark gravity $last.r right
2452    # convert the tags around $value to marks
2453    foreach {pos epos} [$txt tag range y] {}
2454    $txt tag delete x y
2455    incr CIF(markcount)
2456    $txt mark set $CIF(markcount).l $pos
2457    $txt mark set $CIF(markcount).r $epos
2458    $txt mark gravity $CIF(markcount).l left
2459    $txt mark gravity $CIF(markcount).r right
2460    $txt config -state disabled
2461    set ${blk}($dataname) $CIF(markcount)
2462    # this is now the last data item in block
2463    set ${blk}(lastmark)  $CIF(markcount)
2464    # show the data item in the CIF text
2465    $txt see $CIF(markcount).r
2466    # add & show the data item in the tree; open for editing
2467    set num [incr CIF(tree_lastindex)]
2468    $CIF(tree) insert end $blk $num -text $dataname \
2469            -image [Bitmap::get file] -data $blk
2470    $CIF(tree) see $num
2471    set CIF(editmode) 1
2472    showCIFbyTreeID $num
2473    # register this as a change
2474    incr CIF(changes)
2475    # can't undo this so clear the undo status
2476    set CIF(undolist) {}
2477    set CIF(redolist) {}
2478}
2479
2480# insert a loop into CIF block $blk
2481proc InsertDataLoop {namelist blk} {
2482    global CIF CIF_dataname_index
2483    global $blk
2484
2485    # find the last data item in the CIF
2486    set txt $CIF(txt)
2487    set last [set ${blk}(lastmark)]
2488    set i [$txt index $last.r]
2489    # insert the new dataname right after the last data item
2490    $txt config -state normal
2491    # get the last loop number
2492    regsub -all "loop_" [array names $blk loop*] "" l
2493    set n [lindex [lsort -integer $l] end]
2494    incr n
2495    # insert the loop into the CIF
2496    $txt insert $i "\nloop_" x
2497    foreach name $namelist {
2498        set epos [lindex [$txt tag range x] end]
2499        $txt tag delete x
2500        $txt insert $epos "\n   $name" x
2501        lappend ${blk}(loop_$n) $name
2502        set ${blk}($name) {}
2503    }
2504    set epos [lindex [$txt tag range x] end]
2505    $txt tag delete x
2506    $txt insert $epos "\n     " x
2507    set epos [lindex [$txt tag range x] end]
2508    $txt tag delete x
2509    set catlist {}
2510    # insert a value for each data name
2511    foreach name $namelist {
2512        set epos [$txt index "$epos lineend"] 
2513        if {[lindex [split $epos .] 1] > 70} {
2514            $txt insert $epos "\n     " x
2515            set epos [lindex [$txt tag range x] end]
2516            $txt tag delete x
2517            set epos [$txt index "$epos lineend"] 
2518        }
2519        $txt insert $epos ? y " " x
2520        # convert the tags around the "?" to marks
2521        foreach {pos epos} [$txt tag range y] {}
2522        $txt tag delete x y
2523        incr CIF(markcount)
2524        $txt mark set $CIF(markcount).l $pos
2525        $txt mark set $CIF(markcount).r $epos
2526        $txt mark gravity $CIF(markcount).l left
2527        $txt mark gravity $CIF(markcount).r right
2528        lappend ${blk}($name) $CIF(markcount)
2529        # get the category
2530        set category {}
2531        catch {
2532            set category [lindex \
2533                    [lindex $CIF_dataname_index($name) 1] 5]
2534        }
2535        if {$category != "" && [lsearch $catlist $category] == -1} {
2536            lappend catlist $category
2537        }
2538    }
2539    # this is now the last data item in block
2540    set ${blk}(lastmark)  $CIF(markcount)
2541    # reposition the mark for the original last data item in case it moved
2542    $txt mark set $last.r $i
2543    $txt mark gravity $last.r right
2544    $txt config -state disabled
2545    # show the data item in the CIF text
2546    $txt see $CIF(markcount).r
2547    # add & show the data item in the tree; open for editing
2548    $CIF(tree) insert end $blk ${blk}loop_$n \
2549            -text "loop_$n ($catlist)" -open 1 \
2550            -image [Bitmap::get copy] -data "$blk loop"
2551    # insert a value for each data name
2552    foreach name $namelist {
2553        $CIF(tree) insert end ${blk}loop_$n [incr CIF(tree_lastindex)] \
2554                -text $name \
2555                -image [Bitmap::get file] -data $blk
2556    }
2557    $CIF(tree) see $CIF(tree_lastindex)
2558    set CIF(editmode) 1
2559    showCIFbyTreeID ${blk}loop_$n
2560    # register this as a change
2561    incr CIF(changes)
2562    # can't undo this so clear the undo status
2563    set CIF(undolist) {}
2564    set CIF(redolist) {}
2565}
2566
2567# add an item to a CIF
2568proc AddDataItem2CIF {mode parent} {
2569    global CIF
2570    if {[llength $CIF(blocklist)] == 1} {
2571        set block block$CIF(blocklist)
2572    } else {
2573        # select a block here
2574        set frame $parent.blksel
2575        catch {destroy $frame}
2576        toplevel $frame
2577        wm title $frame "Select a block"
2578        grid [label $frame.top -text "Select the data block where\nitems will be added" \
2579            -bd 2 -bg beige -relief raised] \
2580            -sticky news -column 0 -row 0  -columnspan 3
2581        grid [listbox $frame.list -width 30 \
2582                -height 20 -exportselection 0 \
2583                -yscrollcommand "$frame.ys set"] -column 0 -row 2 -sticky nsew
2584        grid [scrollbar $frame.ys -width 15 -bd 2 \
2585                -command "$frame.list yview"] -column 1 -row 2  -sticky ns
2586        grid [frame $frame.bot] -sticky news -column 0 -row 3 -columnspan 3
2587        grid [button $frame.bot.use -text Use -state disabled \
2588            -command "destroy $frame"] -column 4 -row 1
2589        grid [button $frame.bot.q -text Quit \
2590                -command "set CIF(selectedBlock) {}; destroy $frame"\
2591                ] -column 5 -row 1
2592        foreach n $CIF(blocklist) {
2593            global block${n}
2594            set blockname [set block${n}(data_)]
2595            $frame.list insert end "($n) $blockname"
2596        }
2597        bind $frame.list <<ListboxSelect>> \
2598            "BlockSelectedCmd $frame.list $frame.bot.use"
2599        bind $frame.list <Double-1> "destroy $frame"
2600        putontop $frame
2601        tkwait window $frame
2602        afterputontop
2603        if {$CIF(selectedBlock) == ""} return
2604        set block block$CIF(selectedBlock)
2605    }
2606    if {$mode == "loop"} {
2607        # open a browser window
2608        CatBrowserWindow $parent
2609        if {$CIF(CatSelItems) == ""} return
2610        InsertDataLoop $CIF(CatSelItems) $block
2611    } elseif {$mode == "category"} {
2612        # open a browser window to select a single data item
2613        CatBrowserWindow $parent single
2614        if {[llength $CIF(CatSelItems)] != 1} return
2615        InsertDataItem $CIF(CatSelItems) $block
2616    } else {
2617        CatListWindow $parent
2618        if {[llength $CIF(CatSelItems)] != 1} return
2619        InsertDataItem $CIF(CatSelItems) $block
2620    }
2621}
2622
2623# respond to selection of a block, when needed
2624proc BlockSelectedCmd {listbox usebutton} {
2625    global CIF
2626    set selected [$listbox curselection]
2627    if {[llength $selected] == 1} {
2628        $usebutton configure -state normal
2629        set CIF(selectedBlock) [lindex [split [$listbox get $selected] "()"] 1]
2630    } else {
2631        $usebutton configure -state disabled
2632        set CIF(selectedBlock) {}
2633    }
2634}
2635#----------------------------------------------------------------------
2636#----------------------------------------------------------------------
2637# index and manage dictionaries
2638#----------------------------------------------------------------------
2639
2640# parse a CIF dictionary & save pertinent bits (more for DDL1 than DDL2)
2641proc MakeCIFdictIndex {f message} {
2642    global CIF
2643    set top1 .mkDictIndexTop
2644    set stat .mkDictIndexStat
2645    # create an invisible window for parsing a dictionary
2646    catch {destroy $top1}
2647    toplevel $top1
2648    set txt $top1.t
2649    grid [text $txt -width 80 -yscrollcommand "$top1.s set"] -column 0 -row 0
2650    grid [scrollbar $top1.s -command "$txt yview"] -column 1 -row 0 -sticky ns
2651    wm withdraw $top1
2652    # create a status window
2653    catch {destroy $stat}
2654    toplevel $stat
2655    wm title $stat "Dictionary Parse Status"
2656    if {$message != ""} {
2657        grid [label $stat.l0 -text $message] -column 0 -columnspan 2 -row 0
2658    }
2659    grid [label $stat.l1 -text "Definitions Processed"] -column 0 -row 1
2660    grid [label $stat.l2 -textvariable parsestatus] -column 1 -row 1
2661    putontop $stat 1
2662    update
2663
2664    set counter 0
2665
2666    set file [file tail $f]
2667    global parsestatus
2668    set parsestatus "$counter (reading $file)" 
2669    update
2670
2671    if {[catch {
2672        set inp [open $f r]
2673        fconfigure $inp -translation binary
2674    } errmsg]} {
2675        catch {close $inp}
2676        destroy $stat $top1
2677        return [list 1 $errmsg]
2678    }
2679
2680    # input file is open, can we write to the index?
2681    set errorstat 0
2682    if {[catch {
2683        set fp [open ${f}_index w]
2684        puts $fp "set CIF_file_name [list $file]"
2685        puts $fp "set CIF_file_size [file size $f]"
2686        puts $fp "set CIF_index_version $CIF(indexversion)"
2687    } errmsg]} {
2688        set errorstat 2
2689        catch {close $fp}
2690        catch {file delete -force ${f}_index}
2691        set ::CIF_file_paths($file) $f
2692    }
2693   
2694    set text [read $inp]
2695    close $inp
2696    # is this a DDL2 dictionary (with save frames)?
2697    if {[string match -nocase "*save_*" $text]} {
2698        set DDL2 1
2699        regsub -all "save__" $text "data__" text
2700        regsub -all "save_" $text "####_" text
2701    } else {
2702        set DDL2 0
2703    }
2704    $txt insert end $text
2705    # free up some memory
2706    unset text
2707
2708    set parsestatus "$counter (starting parse)" 
2709    update
2710
2711
2712    set blocks [ParseCIF $txt {} CIFdict]
2713    set allblocks {}
2714    set prevpos 1.0
2715    set prevbytes 0
2716    set parsestatus "$counter (parse complete)" 
2717    update
2718
2719    if {$errorstat == 0} {
2720        puts $fp "set CIF_file_mtime [file mtime $f]"
2721        puts $fp "array set CIF_dataname_index \{"
2722    }
2723    set definednames {}
2724    for {set i 1} {$i <= $blocks} {incr i} {
2725        incr counter
2726        if {$counter % 10 == 0} {
2727            set parsestatus $counter
2728            update
2729        }
2730        lappend allblocks $i
2731        if {![catch {set CIFdict::block${i}(errors)}]} {
2732            puts stderr "Block $i ([set CIFdict::block${i}(data_)]) errors:"
2733            puts stderr "[set CIFdict::block${i}(errors)]"
2734        }
2735        # list of positions for dataname
2736        set list {}
2737        catch {set list [set CIFdict::block${i}(_name)]}
2738        if {$list == "" && $DDL2} { 
2739            catch {set list [set CIFdict::block${i}(_item.name)]}
2740        }
2741        # definition entry
2742        set def {}
2743        catch {set def  [set CIFdict::block${i}(_definition)]}
2744        if {$def == "" && $DDL2} { 
2745            catch {set def  [set CIFdict::block${i}(_item_description.description)]}
2746        } 
2747        if {$def == ""} continue
2748        if {[llength $def] != 1} {puts stderr "problem with [set CIFdict::block${i}(data_)]"}
2749        # count the number of bytes from the previous position
2750        # (much faster than counting from the beginning each time)
2751        #set defpos [string length [$txt get 1.0 $def.l]]
2752        set defpos [string length [$txt get $prevpos $def.l]]
2753        incr defpos $prevbytes
2754        set prevpos $def.l
2755        set prevbytes $defpos
2756        set deflen [string length [$txt get $def.l $def.r]]
2757        # item type (numb/char/null)
2758        set type {}
2759        catch {set type [set CIFdict::block${i}(_type)]}
2760        if {$type == "" && $DDL2} {
2761            catch {set type [set CIFdict::block${i}(_item_type.code)]}
2762            if {[llength $type] != 1} {
2763                set typeval "?"
2764            } else {
2765                set typeval [StripQuotes [$txt get $type.l $type.r]]
2766            }
2767            # mmCIF uses: atcode, code, float, int, line, symop, text
2768            #             uchar1, uchar3, ucode, uline, yyyy-mm-dd
2769            # treat everything but float & int as character
2770            if {$typeval == "float" || $typeval == "int"} {
2771                set typeval "n"
2772            } else {
2773                set typeval "c"
2774            }
2775        } elseif {[llength $type] != 1} {
2776            puts stderr "type problem for [set CIFdict::block${i}(data_)]"
2777            set typeval "?"
2778        } else {
2779            set typeval [StripQuotes [$txt get $type.l $type.r]]
2780            if {$typeval == "numb"} {
2781                set typeval "n"
2782            } elseif {$typeval == "char"} {
2783                set typeval "c"
2784            } elseif {$typeval == "null"} {
2785                set typeval ""
2786            } else {
2787                puts stderr "Block [set CIFdict::block${i}(data_)] has invalid _type ($typeval)"
2788                set typeval "?"
2789            }
2790        }
2791        # flag if esd's are allowed
2792        set pos {}
2793        catch {set pos [set CIFdict::block${i}(_type_conditions)]}
2794        if {$pos == "" && $DDL2} { 
2795            catch {set pos [set CIFdict::block${i}(_item_type_conditions.code)]}
2796        }
2797        if {[llength $pos] != 1} {
2798            set esd 0
2799        } else {
2800            if {"esd" == [string tolower \
2801                    [StripQuotes [$txt get $pos.l $pos.r]]]} {set esd 1}
2802        }
2803        # units (_units_details overrides _units)
2804        set pos {}
2805        catch {set pos [set CIFdict::block${i}(_units)]}
2806        if {$pos == "" && $DDL2} {
2807            catch {set pos [set CIFdict::block${i}(_item_units.code)]}
2808        } else {
2809            catch {set pos [set CIFdict::block${i}(_units_details)]}
2810        }
2811        if {[llength $pos] != 1} {
2812            set units {}
2813        } else {
2814            set units [StripQuotes [$txt get $pos.l $pos.r]]
2815        }
2816        # parse out _enumeration _enumeration_detail & _enumeration_range
2817        set elist ""
2818        set enumlist {}
2819        set enumdetaillist {}
2820        if {$DDL2} {
2821            catch {
2822                set enumlist [set CIFdict::block${i}(_item_enumeration.value)]
2823                set enumdetaillist [set CIFdict::block${i}(_item_enumeration.detail)]
2824            }
2825        } else {
2826            catch {
2827                set enumlist [set CIFdict::block${i}(_enumeration)]
2828                set enumdetaillist [set CIFdict::block${i}(_enumeration_detail)]
2829            }
2830        }
2831        catch {
2832            foreach m1 $enumlist \
2833                    m2 $enumdetaillist {
2834                if {$m2 != ""} {
2835                    set detail [StripQuotes [$txt get $m2.l $m2.r]]]
2836                    # condense multiple spaces out
2837                    regsub -all {  +} $detail { } detail
2838                } else {
2839                    set detail {}
2840                }
2841                lappend elist [list [StripQuotes [$txt get $m1.l $m1.r]] $detail]
2842            }
2843        }
2844        # mmCIF ranges are too complex to do here
2845        set range ""
2846        catch {
2847            set mark [set CIFdict::block${i}(_enumeration_range)] 
2848            lappend range [StripQuotes [$txt get $mark.l $mark.r]]
2849        }
2850
2851        # category names
2852        set pos ""
2853        catch {set pos [set CIFdict::block${i}(_category)]}
2854        if {$pos == "" && $DDL2} {
2855            catch {set pos [set CIFdict::block${i}(_item.category_id)]}
2856        }
2857        if {[llength $pos] != 1} {
2858            set category {}
2859        } else {
2860            set category [StripQuotes [$txt get $pos.l $pos.r]]
2861        }
2862        # loop is 1 if loops are allowed
2863        if {$DDL2} {
2864            # at least for now, don't worry about DDL2 dictionaries
2865            set loop 1
2866        } else {
2867            set loop 0
2868            catch {
2869                set pos [set CIFdict::block${i}(_list)]
2870                set val [string tolower [StripQuotes [$txt get $pos.l $pos.r]]]
2871                if {$val == "yes" || $val == "both"} {set loop 1}
2872            }
2873        }
2874        foreach mark $list {
2875            set dataname [string tolower [StripQuotes [$txt get $mark.l $mark.r]]]
2876            lappend definednames $dataname
2877            # note that this list must match foreach "type range elist... uses
2878            set value   [list [list $file $defpos $deflen] \
2879                        [list $typeval $range $elist $esd $units $category $loop]]
2880            if {$errorstat == 0} {
2881                puts $fp "\t$dataname \t[list $value]"
2882            } else {
2883                set ::CIF_dataname_index($dataname) $value
2884            }
2885        }
2886    }
2887    set parsestatus "$counter (close file)"
2888    update
2889
2890    if {$errorstat == 0} {
2891        puts $fp "\}"
2892        puts $fp "set definednames \{"
2893        foreach name [lsort $definednames] {
2894            puts $fp "\t[list $name]"
2895        }
2896        puts $fp "\}"
2897    }
2898    catch {close $fp}
2899    afterputontop
2900    destroy $top1
2901    destroy $stat
2902    namespace delete CIFdict
2903    if {$errorstat == 0} {
2904        return {}
2905    } else {
2906        return [list $errorstat $errmsg]
2907    }
2908}
2909
2910# load indices to the dictionaries in CIF(dictfilelist), unless
2911# the variable does not exist or is empty
2912proc LoadDictIndices {} {
2913    global scriptdir CIF CIF_file_paths
2914    global CIF_dataname_index
2915    # clear out any previous dictionary entries
2916    catch {unset CIF_dataname_index}
2917    # clear out array of file paths
2918    catch {unset CIF_file_paths}
2919    # clear out error listings
2920    set CIF(overloaded) 0
2921    set CIF(overloadlist) {}
2922    set CIF(dictwriteerrorlist) {}
2923    set CIF(dictwriteerrors) {}
2924    # clear out an old category browser window
2925    catch {destroy $CIF(CategoryBrowserWin)}
2926   
2927    # is there a defined list of dictionary files?
2928    set flag 0
2929    if {[catch {set CIF(dictfilelist)}]} {
2930        set flag 1
2931    } elseif {[llength $CIF(dictfilelist)] == 0} {
2932        set flag 1
2933    }
2934    # if no files are present in the dictionary list, look
2935    # in the standard places for them
2936    if {$flag} {
2937        # get a list of dictionary files
2938        #    CIFTOOLS location:
2939        set dictfilelist [glob -nocomplain [file join $scriptdir dict *.dic]]
2940        #
2941        foreach file $dictfilelist {
2942            lappend CIF(dictfilelist) $file
2943            set CIF(dict_$file) 1
2944        }
2945    }
2946
2947    if {[catch {set CIF(dictfilelist)}]} {
2948        set CIF(dictfilelist) {}
2949    }
2950    # load the dictionaries
2951    foreach file $CIF(dictfilelist) {
2952        if {!$CIF(dict_$file)} continue
2953        if {![file exists $file]} continue
2954        IndexLoadDict $file
2955    }
2956    if {[llength $CIF(dictwriteerrorlist)] >0} {
2957        set msg "Error: unable to writing index files for dictionary:"
2958        foreach dict $CIF(dictwriteerrorlist) {
2959            append msg "\n\t[file tail $dict]"
2960        }
2961        append msg "\n\nDo you have write permission?"
2962        set ans [MyMessageBox -parent . -title "CIF index error" \
2963                -message $msg \
2964                -icon error -type {Continue "See List"} -default continue]
2965        if {$ans != "continue"} {
2966            MyMessageBox -parent . -title "Error(s)" \
2967                    -message $CIF(dictwriteerrors) \
2968                    -icon warning -type Continue -default continue
2969        }
2970    }
2971    if {$CIF(overloaded) != 0 && $CIF(ShowDictDups)} {
2972        set ans [MyMessageBox -parent . -title "Definitions overridden" \
2973                -message "Loading CIF dictionaries.\nNote: $CIF(overloaded) datanames appeared in more than one dictionary -- only the last reference is used." \
2974                -icon warning -type {Continue "See List"} -default continue]
2975        if {$ans != "continue"} {
2976            MyMessageBox -parent . -title "List of overridden definitions" \
2977                    -message $CIF(overloadlist) \
2978                    -icon warning -type Continue -default continue
2979        }
2980    }
2981}
2982
2983# load an index to a dictionary file, create the index if needed.
2984# save the index to CIF dictionary named XXXXX.dic as XXXXX.dic_index
2985# if the file cannot be written, create an error message and just load
2986# it anyway.
2987proc IndexLoadDict {file} {
2988    global CIF
2989    global CIF_dataname_index CIF_file_paths
2990    # save the array contents
2991    set orignamelist [array names CIF_dataname_index]
2992
2993    set flag 0
2994    if {![file exists ${file}_index]} {
2995        set flag 1
2996    } elseif {[file mtime $file] > [file mtime ${file}_index]} {
2997        set flag 1
2998    }
2999    if {$flag} {
3000        set stat [MakeCIFdictIndex $file "Please wait, indexing file $file"]
3001        if {[lindex $stat 0] != ""} {
3002            lappend CIF(dictwriteerrorlist) $file
3003            append CIF(dictwriteerrors) "=================================\n"
3004            append CIF(dictwriteerrors) "Error indexing file $file:\n"
3005            append CIF(dictwriteerrors) "=================================\n"
3006            append CIF(dictwriteerrors) [lindex $stat 1]
3007            append CIF(dictwriteerrors) "\n\n"
3008            return 1
3009        }
3010    }
3011
3012    set CIF_index_version 0
3013    set redo 0
3014    if {[catch {
3015        source ${file}_index
3016    } errmsg]} {
3017        set stat [MakeCIFdictIndex $file \
3018                "Please wait, reindexing $file, Error reading file index."]
3019#       MyMessageBox -parent . -title "CIF index error" \
3020#               -message "Error reading file ${file}_index -- this should not happen:\n$errmsg" \
3021#               -icon error -type {"Oh darn"} -default "oh darn"
3022        set redo 1
3023    }
3024    if {$CIF_index_version < $CIF(indexversion)} {
3025        set redo 1
3026        set stat [MakeCIFdictIndex $file \
3027                "Please wait, reindexing $file, index is out of date."]
3028    } elseif {[file size $file] != $CIF_file_size} {
3029        set redo 1
3030        set stat [MakeCIFdictIndex $file \
3031                "Please wait, reindexing $file, file size has changed"]
3032    }
3033    if {$redo} {
3034        if {[lindex $stat 0] != ""} {
3035            lappend CIF(dictwriteerrorlist) $file
3036            append CIF(dictwriteerrors) "=================================\n"
3037            append CIF(dictwriteerrors) "Error indexing file $file:\n"
3038            append CIF(dictwriteerrors) "=================================\n"
3039            append CIF(dictwriteerrors) [lindex $stat 1]
3040            append CIF(dictwriteerrors) "\n\n"
3041            return 1
3042        }
3043        if {[catch {
3044            source ${file}_index
3045        } errmsg]} {
3046            MyMessageBox -parent . -title "CIF index error" \
3047                    -message "Error reading file ${file}_index -- this should not happen:\n$errmsg" \
3048                    -icon error -type {"Oh darn"} -default "oh darn"
3049            return 1
3050        }
3051    }
3052    if {[array names CIF_file_paths $CIF_file_name] != ""} {
3053        MyMessageBox -parent . -title "Duplicate dictionary name" \
3054                -message "Note: you are using two dictionaries with the same name ($CIF_file_name). The locations are:\n$CIF_file_paths($CIF_file_name)\n$file\n\nOnly the latter file will be accessed." \
3055                -icon warning -type {"Oh well"} -default "oh well"
3056    }
3057    set CIF_file_paths($CIF_file_name) $file
3058    # now check for overridden names
3059    set errorlist {}
3060    foreach name $definednames {
3061        if {[lsearch -exact $orignamelist $name] != -1} {
3062            incr CIF(overloaded) 
3063            append errorlist "\t$name\n"
3064        }
3065    }
3066    if {$errorlist != ""} {
3067        append CIF(overloadlist) "\ndictionary $file overrides definitions for datanames:\n" $errorlist
3068    }
3069    return
3070}
3071
3072# make a window for selecting dictionaries
3073proc MakeDictSelect {parent} {
3074    global CIF
3075    global CIF_dataname_index
3076    #global icon
3077    set icon(up) [image create bitmap -data {
3078        #define up_width 24
3079        #define up_height 24
3080        static unsigned char up_bits[] = {
3081            0x00, 0x18, 0x00, 0x00, 0x18, 0x00, 
3082            0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00,
3083            0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00, 
3084            0x00, 0xff, 0x00, 0x00, 0xff, 0x00,
3085            0x80, 0xff, 0x01, 0x80, 0xff, 0x01, 
3086            0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03,
3087            0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07, 
3088            0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f,
3089            0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f, 
3090            0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f,
3091            0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f, 
3092            0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
3093    }]
3094
3095    set icon(down) [image create bitmap -data {
3096        #define down_width 24
3097        #define down_height 24
3098        static unsigned char down_bits[] = {
3099            0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 
3100            0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f,
3101            0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f, 
3102            0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f,
3103            0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f,
3104            0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07,
3105            0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03,
3106            0x80, 0xff, 0x01, 0x80, 0xff, 0x01,
3107            0x00, 0xff, 0x00, 0x00, 0xff, 0x00,
3108            0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00,
3109            0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00,
3110            0x00, 0x18, 0x00, 0x00, 0x18, 0x00};
3111    }]
3112
3113    set win $parent.dictselect
3114    catch {destroy $win}
3115    toplevel $win
3116    wm title $win "Select CIF dictionaries"
3117    grid [canvas $win.canvas \
3118            -scrollregion {0 0 5000 500} -width 0 -height 200 \
3119            -xscrollcommand "$win.xscroll set" \
3120            -yscrollcommand "$win.scroll set"] \
3121            -column 0 -row 2 -sticky nsew
3122    grid columnconfigure $win 0 -weight 1
3123    grid rowconfigure $win 2 -weight 1
3124    scrollbar $win.scroll \
3125            -command "$win.canvas yview"
3126    scrollbar $win.xscroll -orient horizontal \
3127            -command "$win.canvas xview"
3128    frame [set CIF(dictlistbox) $win.canvas.fr]
3129    $win.canvas create window 0 0 -anchor nw -window $CIF(dictlistbox)
3130    grid [label $win.top -text "Select dictionaries to be loaded" -bg beige] \
3131            -column 0 -columnspan 99 -row 0 -sticky ew
3132    grid [label $win.top1 \
3133            -text "(Dictionaries are loaded in the order listed)" -bg beige] \
3134            -column 0 -columnspan 99 -row 1 -sticky ew
3135    catch {$win.top1 config -font "[$win.top1 cget -font] italic"}
3136    grid [frame  $win.bot] \
3137            -column 0 -columnspan 99 -row 99 -sticky ew
3138    set col 0
3139    grid [button $win.bot.add -text "Add Dictionary" \
3140            -command "OpenLoadDict $win"] \
3141            -column $col -row 0
3142    grid [button $win.bot.save -text "Save current settings" \
3143            -command "SaveOptions"] \
3144            -column [incr col] -row 0
3145    grid [button $win.bot.up -image $icon(up) -width 35\
3146            -command ShiftDictUp] \
3147            -column [incr col] -row 0
3148    grid [button $win.bot.down -image $icon(down) -width 35 \
3149            -command ShiftDictDown] \
3150            -column [incr col] -row 0
3151
3152    grid [button $win.bot.cancel -text Close -command "destroy $win; LoadDictIndices"] \
3153            -column [incr col] -row 0
3154    wm protocol $win WM_DELETE_WINDOW "$win.bot.cancel invoke"
3155
3156    FillDictSelect
3157
3158    update
3159    #putontop $win
3160    #tkwait window $win
3161    #afterputontop
3162}
3163
3164
3165# respond to a dictionary selection
3166proc SelectDict {row} {
3167    global CIF
3168    set widget $CIF(dictlistbox)
3169    if {$CIF(selected_dict) != ""} {
3170        ${widget}.c$CIF(selected_dict) config -bg \
3171                [option get [winfo toplevel $widget] background Frame]
3172    }
3173    set CIF(selected_dict) $row
3174    ${widget}.c$row config -bg black
3175}
3176
3177# shift the selected dictionary up in the list
3178proc ShiftDictUp {} {
3179    global CIF
3180    if {$CIF(selected_dict) == ""} {
3181        bell
3182        return
3183    }
3184    if {$CIF(selected_dict) == 0} {
3185        return
3186    }
3187    set prev [set pos $CIF(selected_dict)]
3188    incr prev -1
3189    set CIF(dictfilelist) [lreplace $CIF(dictfilelist) $prev $pos \
3190            [lindex $CIF(dictfilelist) $pos] \
3191            [lindex $CIF(dictfilelist) $prev]]
3192    FillDictSelect
3193    SelectDict $prev
3194}
3195
3196# shift the selected dictionary down in the list
3197proc ShiftDictDown {} {
3198    global CIF
3199    if {$CIF(selected_dict) == ""} {
3200        bell
3201        return
3202    }
3203    if {$CIF(selected_dict) == [llength  $CIF(dictfilelist)]-1} {
3204        return
3205    }
3206    set next [set pos $CIF(selected_dict)]
3207    incr next 1
3208    set CIF(dictfilelist) [lreplace $CIF(dictfilelist) $pos $next \
3209            [lindex $CIF(dictfilelist) $next] \
3210            [lindex $CIF(dictfilelist) $pos]]
3211    FillDictSelect
3212    SelectDict $next
3213}
3214
3215# place the dictionary list into the window
3216proc FillDictSelect {} {
3217    global CIF
3218
3219    set win [winfo toplevel $CIF(dictlistbox)]
3220    eval destroy [winfo children $CIF(dictlistbox)]
3221    set CIF(dictlistboxRow) -1
3222    foreach file $CIF(dictfilelist) {
3223        set lbl $file
3224        if {![file exists $file]} {
3225            set lbl "$file (not found)"
3226            set CIF(dict_$file) 0
3227        }
3228        set row [incr CIF(dictlistboxRow)]
3229        grid [frame $CIF(dictlistbox).c$row -bd 3] -column 0 -row $row -sticky w
3230        grid [checkbutton $CIF(dictlistbox).c$row.c -text $lbl \
3231                -command "SelectDict $row" \
3232                -variable CIF(dict_$file)] \
3233                -column 0 -row 0 -sticky w
3234        if {![file exists $file]} {
3235            $CIF(dictlistbox).c$row.c config -state disabled
3236        }
3237    }
3238    set CIF(selected_dict) {}
3239    # resize the list
3240    update
3241    set sizes [grid bbox $win.canvas.fr]
3242    $win.canvas config -scrollregion $sizes -width [lindex $sizes 2]
3243    # use the scroll for BIG lists
3244    if {[lindex $sizes 3] > [winfo height $win.canvas]} {
3245        grid $win.scroll -sticky ns -column 1 -row 2
3246    } else {
3247        grid forget $win.scroll 
3248    }
3249    if {[lindex $sizes 2] > [winfo width $win.canvas]} {
3250        grid $win.xscroll -sticky ew -column 0 -row 3
3251    } else {
3252        grid forget $win.xscroll 
3253    }
3254}
3255
3256# open a new dictionary and add it to the list
3257proc OpenLoadDict {win} {
3258    global CIF
3259    set file [tk_getOpenFile -title "Select CIF" -parent $win \
3260            -defaultextension .dic -filetypes {{"CIF dictionary" ".dic"}}]
3261    if {$file == ""} {return}
3262    if {![file exists $file]} {
3263        MyMessageBox -parent . -title "CIF error" \
3264                -message "Error file $file does not exist -- this should not happen" \
3265                -icon error -type {"Oh darn"} -default "oh darn"
3266    }
3267    if {[IndexLoadDict $file] == 1} return
3268    set CIF(dict_$file) 1
3269    lappend CIF(dictfilelist) $file
3270
3271    FillDictSelect
3272
3273    $win.canvas xview moveto 0
3274}
3275
3276# a dummy routine -- each program should have its own SaveOptions routine
3277proc SaveOptions {} {
3278    MyMessageBox -parent . -title "Not saved" \
3279            -message "SaveOptions is not implemented in this program" \
3280            -icon "info" -type OK -default OK
3281}
3282
3283#----------------------------------------------------------------------
3284# initialize misc variables
3285set CIF(changes) 0
3286set CIF(widgetlist) {}
3287set CIF(lastShownItem) {}
3288set CIF(lastLoopIndex) {}
3289set CIF(editmode) 0
3290set CIF(undolist) {}
3291set CIF(redolist) {}
3292set CIF(treeSelectedList) {}
3293set CIF(catsearchnum) -1
3294set CIF(catsearchlist) {}
3295# version of the dictionary that is needed by the current program
3296set CIF(indexversion) 1.1
3297# make sure this variable is defined
3298if {[catch {set CIF(ShowDictDups)}]} {set CIF(ShowDictDups) 0}
Note: See TracBrowser for help on using the repository browser.