source: trunk/browsecif.tcl @ 728

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

# on 2003/08/11 19:23:56, toby did:
significant revision for CIFTOOLS

cleanup for Mac OS X
improve error reporting
make variable for max line length (defaults to 80)

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