source: trunk/browsecif.tcl @ 664

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

# on 2002/12/30 17:00:34, toby did:
updated pleasewait
implement CIF(maxvalues) to control max CIF size
define contents of CIF(status) , to be displayed on "pleasewait" & check

CIF size against maximum

check to see if skip forward is in fact going backwards (prevent infinite loop)
scroll text box while parsing -- looks neat!
implement (&comment out) multiple selection of looped items

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