# $Id: browsecif.tcl,v 1.7 2003/07/25 00:29:10 toby Exp toby $
# possible future work:
# implement adding a new data item to a CIF? Delete one?
# can I bind to the tree window only? (.browser.pw.f0.frame.lf.tree)
# clean up use of block arrays. Should the prefix be changable? Use
# the same syntax throughout
#------------------------------------------------------------------------------
# Misc Tcl/Tk utility routines follow
#------------------------------------------------------------------------------
# Message box code that centers the message box over the parent.
# or along the edge, if too close,
# but leave a border along +x & +y for reasons I don't remember
# It also allows the button names to be defined using
# -type $list -- where $list has a list of button names
# larger messages are placed in a scrolled text widget
# capitalization is now ignored for -default
# The command returns the name button in all lower case letters
# otherwise see tk_messageBox for a description
#
# This is a modification of tkMessageBox (msgbox.tcl v1.5)
#
proc MyMessageBox {args} {
global tkPriv tcl_platform
set w tkPrivMsgBox
upvar #0 $w data
#
# The default value of the title is space (" ") not the empty string
# because for some window managers, a
# wm title .foo ""
# causes the window title to be "foo" instead of the empty string.
#
set specs {
{-default "" "" ""}
{-icon "" "" "info"}
{-message "" "" ""}
{-parent "" "" .}
{-title "" "" " "}
{-type "" "" "ok"}
{-helplink "" "" ""}
}
tclParseConfigSpec $w $specs "" $args
if {[lsearch {info warning error question} $data(-icon)] == -1} {
error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
}
if {![string compare $tcl_platform(platform) "macintosh"]} {
switch -- $data(-icon) {
"error" {set data(-icon) "stop"}
"warning" {set data(-icon) "caution"}
"info" {set data(-icon) "note"}
}
}
if {![winfo exists $data(-parent)]} {
error "bad window path name \"$data(-parent)\""
}
switch -- $data(-type) {
abortretryignore {
set buttons {
{abort -width 6 -text Abort -under 0}
{retry -width 6 -text Retry -under 0}
{ignore -width 6 -text Ignore -under 0}
}
}
ok {
set buttons {
{ok -width 6 -text OK -under 0}
}
if {![string compare $data(-default) ""]} {
set data(-default) "ok"
}
}
okcancel {
set buttons {
{ok -width 6 -text OK -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
retrycancel {
set buttons {
{retry -width 6 -text Retry -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
yesno {
set buttons {
{yes -width 6 -text Yes -under 0}
{no -width 6 -text No -under 0}
}
}
yesnocancel {
set buttons {
{yes -width 6 -text Yes -under 0}
{no -width 6 -text No -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
default {
# error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
foreach item $data(-type) {
lappend buttons [list [string tolower $item] -text $item -under 0]
}
}
}
if {[string compare $data(-default) ""]} {
set valid 0
foreach btn $buttons {
if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
set valid 1
break
}
}
if {!$valid} {
error "invalid default button \"$data(-default)\""
}
}
# 2. Set the dialog to be a child window of $parent
#
#
if {[string compare $data(-parent) .]} {
set w $data(-parent).__tk__messagebox
} else {
set w .__tk__messagebox
}
# 3. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $data(-title)
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
wm transient $w $data(-parent)
if {![string compare $tcl_platform(platform) "macintosh"]} {
unsupported1 style $w dBoxProc
}
frame $w.bot
pack $w.bot -side bottom -fill both
frame $w.top
pack $w.top -side top -fill both -expand 1
if {$data(-helplink) != ""} {
# frame $w.help
# pack $w.help -side top -fill both
pack [button $w.top.1 -text Help -bg yellow \
-command "MakeWWWHelp $data(-helplink)"] \
-side right -anchor ne
bind $w "MakeWWWHelp $data(-helplink)"
}
if {[string compare $tcl_platform(platform) "macintosh"]} {
$w.bot configure -relief raised -bd 1
$w.top configure -relief raised -bd 1
}
# 4. Fill the top part with bitmap and message (use the option
# database for -wraplength and -font so that they can be
# overridden by the caller).
option add *Dialog.msg.wrapLength 6i widgetDefault
if {[string length $data(-message)] > 300} {
if {![string compare $tcl_platform(platform) "macintosh"]} {
option add *Dialog.msg.t.font system widgetDefault
} else {
option add *Dialog.msg.t.font {Times 18} widgetDefault
}
frame $w.msg
grid [text $w.msg.t \
-height 20 -width 55 -relief flat -wrap word \
-yscrollcommand "$w.msg.rscr set" \
] -row 1 -column 0 -sticky news
grid [scrollbar $w.msg.rscr -command "$w.msg.t yview" \
] -row 1 -column 1 -sticky ns
# give extra space to the text box
grid columnconfigure $w.msg 0 -weight 1
grid rowconfigure $w.msg 1 -weight 1
$w.msg.t insert end $data(-message)
} else {
if {![string compare $tcl_platform(platform) "macintosh"]} {
option add *Dialog.msg.font system widgetDefault
} else {
option add *Dialog.msg.font {Times 18} widgetDefault
}
label $w.msg -justify left -text $data(-message)
}
pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
if {[string compare $data(-icon) ""]} {
label $w.bitmap -bitmap $data(-icon)
pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
}
# 5. Create a row of buttons at the bottom of the dialog.
set i 0
foreach but $buttons {
set name [lindex $but 0]
set opts [lrange $but 1 end]
if {![llength $opts]} {
# Capitalize the first letter of $name
set capName [string toupper \
[string index $name 0]][string range $name 1 end]
set opts [list -text $capName]
}
eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
if {![string compare $name [string tolower $data(-default)]]} {
$w.$name configure -default active
}
pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
# create the binding for the key accelerator, based on the underline
#
set underIdx [$w.$name cget -under]
if {$underIdx >= 0} {
set key [string index [$w.$name cget -text] $underIdx]
bind $w [list $w.$name invoke]
bind $w [list $w.$name invoke]
}
incr i
}
# 6. Create a binding for on the dialog if there is a
# default button.
if {[string compare $data(-default) ""]} {
bind $w [list tkButtonInvoke $w.[string tolower $data(-default)]]
}
# 7. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
wm withdraw $w
update idletasks
set wp $data(-parent)
# center the new window in the middle of the parent
set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
[winfo reqwidth $w]/2 - [winfo vrootx $wp]]
set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
[winfo reqheight $w]/2 - [winfo vrooty $wp]]
# make sure that we can see the entire window
set xborder 10
set yborder 25
if {$x < 0} {set x 0}
if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
incr x [expr \
[winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
}
if {$y < 0} {set y 0}
if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
incr y [expr \
[winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
}
wm geom $w +$x+$y
update
wm deiconify $w
# 8. Set a grab and claim the focus too.
catch {set oldFocus [focus]}
catch {set oldGrab [grab current $w]}
catch {
grab $w
if {[string compare $data(-default) ""]} {
focus $w.[string tolower $data(-default)]
} else {
focus $w
}
}
# 9. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
tkwait variable tkPriv(button)
catch {focus $oldFocus}
destroy $w
catch {grab $oldGrab}
return $tkPriv(button)
}
# tell'em what is happening
proc pleasewait {{message {}} {statusvar {}} {parent .} {button ""}} {
catch {destroy .msg}
toplevel .msg
wm transient .msg [winfo toplevel .]
pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5
pack [message .msg.f.m -text "Please wait $message"] -side top
if {$statusvar != ""} {
pack [label .msg.f.status -textvariable $statusvar] -side top
}
if {$button != ""} {
pack [button .msg.f.button -text [lindex $button 0] \
-command [lindex $button 1]] -side top
}
wm withdraw .msg
update idletasks
# place the message on top of the parent window
set x [expr [winfo x $parent] + [winfo width $parent]/2 - \
[winfo reqwidth .msg]/2 - [winfo vrootx $parent]]
if {$x < 0} {set x 0}
set y [expr [winfo y $parent] + [winfo height $parent]/2 - \
[winfo reqheight .msg]/2 - [winfo vrooty $parent]]
if {$y < 0} {set y 0}
wm geom .msg +$x+$y
update
wm deiconify .msg
global makenew
set makenew(OldGrab) ""
set makenew(OldFocus) ""
# save focus & grab
catch {set makenew(OldFocus) [focus]}
catch {set makenew(OldGrab) [grab current .msg]}
catch {grab .msg}
update
}
# clear the wait message
proc donewait {} {
global makenew
catch {destroy .msg}
# reset focus & grab
catch {
if {$makenew(OldFocus) != ""} {
focus $makenew(OldFocus)
}
}
catch {
if {$makenew(OldGrab) != ""} {
grab $makenew(OldGrab)
}
}
}
# this routine is used to fix up tk_optionMenu widgets that have too many
# entries for a single list -- by using cascades
proc FixBigOptionMenu {widget enum "cmd {}"} {
# max entries
set max 12
set menu [winfo children $widget]
$menu delete 0 end
eval destroy [winfo children $menu]
set var [$widget cget -textvariable]
# do we need a cascade?
if {[set n [llength $enum]] <= $max} {
# no
foreach l $enum {
$menu add radiobutton -value $l -label $l -variable $var \
-command $cmd
}
return
}
# yes
set nmenus [expr int(($max + $n - 1 )/ (1.*$max))]
set nper [expr 1 + $n/$nmenus]
if {$nper > $max} {set nper $max}
for {set i 0} {$i < $n} {incr i $nper} {
set j [expr $i + $nper -1]
set sublist [lrange $enum $i $j]
$menu add cascade -label "[lindex $sublist 0]-[lindex $sublist end]" \
-menu $menu.$i
menu $menu.$i
foreach l $sublist {
$menu.$i add radiobutton -value $l -label $l -variable $var \
-command $cmd
}
}
}
# this routine is used to add . and ? in a cascade for enum lists
proc AddSpecialEnumOpts {widget "cmd {}"} {
set menu [winfo children $widget]
set var [$widget cget -textvariable]
# add the cascade and entries to it
$menu add cascade -label "(special values)" -menu $menu.special
menu $menu.special
$menu.special add radiobutton -value . -command $cmd \
-label "Inapplicable (.)" -variable $var
$menu.special add radiobutton -value ? -command $cmd \
-label "Unknown (?)" -variable $var
}
#------------------------------------------------------------------------------
# end of Misc Tcl/Tk utility routines
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# ParseCIF reads and parses a CIF file putting the contents of
# each block into arrays block1, block2,... in the caller's level
# the name of the block is saved as blockN(data_)
# data names items are saved as blockN(_data_name) = marker_number
# where CIF data names are converted to lower case
# and marker_number.l marker_number.r define the range of the value
# for looped data names, the data items are included in a list:
# blockN(_cif_name) = {marker1 marker2 ...}
# the contents of each loop are saved as blockN(loop_M)
#
# if the filename is blank or not specified, the current contents
# of the text widget, $txt, is parsed.
#
# The proc returns the number of blocks that have been read or a
# null string if the file cannot be opened
#
# This parser does some error checking [errors are reported in blockN(error)]
# but the parser could get confused if the CIF has invalid syntax
#
proc ParseCIF {txt "filename {}"} {
global CIF tcl_version
global CIF_dataname_index
if {$tcl_version < 8.2} {
tk_dialog .error {Old Tcl/Tk} \
"Sorry, the CIF Browser requires version 8.2 or later of the Tcl/Tk package. This is $tcl_version" \
warning 0 Sorry
return
}
if {$filename != ""} {
if [catch {
$txt configure -state normal
set fp [open $filename r]
$txt insert end [read $fp]
close $fp
$txt configure -state disabled
}] {
return ""
}
}
# maximum size of file
set maxvalues 0
catch {
set maxvalues $CIF(maxvalues)
}
set CIF(undolist) {}
set CIF(redolist) {}
set pos 1.0
set blocks 0
set EOF 1
set dataname {}
set CIF(markcount) -1
# this flags where we are w/r a loop_
# -1 not in a loop
# 0 reading a loop header (data names)
# 1 reading the data items in a loop
set loopflag -1
set loopnum -1
# loop over tokens
while {$EOF} {
if {$CIF(markcount) % 1000 == 0} {
$txt see $pos
set CIF(status) "($CIF(markcount) values read.)"
update
# are we over the limit?
if {$maxvalues > 0 && $CIF(markcount) > $maxvalues} {
donewait
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"
set ans [MyMessageBox -parent . -title "CIF Too big" \
-message $msg -icon error -type "{Stop Parsing}" \
-default "stop parsing"]
return $blocks
}
}
# skip forward to the first non-blank character
set npos [$txt search -regexp {[^[:space:]]} $pos end]
# is this the end?
if {$npos == "" || \
[lindex [split $npos .] 0] < [lindex [split $pos .] 0] } {
set EOF 0
break
} else {
set pos $npos
}
# is this a comment, if so skip to next line
if {[$txt get $pos] == "#"} {
set pos [$txt index "$pos + 1 line linestart"]
continue
}
# find end of token
set epos [$txt search -regexp {[[:space:]]} $pos "$pos lineend"]
if {$epos == ""} {
set epos [$txt index "$pos lineend"]
}
set token [$txt get $pos $epos]
if {[string tolower [string range $token 0 4]] == "data_"} {
# this is the beginning of a data block
incr blocks
set blockname [string range $token 5 end]
global block$blocks
catch {unset block$blocks}
set block${blocks}(data_) $blockname
set loopnum -1
if {$dataname != ""} {
# this is an error -- data_ block where a data item is expected
append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
set dataname {}
}
# move forward past current token
set pos [$txt index "$epos +1c"]
continue
}
if {[$txt get $pos] == "_"} {
# this is a cif data name
if {$dataname != ""} {
# this is an error -- data name where a data item is expected
append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
}
# convert it to lower case & save
set dataname [string tolower $token]
# are we in a loop header or loop body?
if {$loopflag == 0} {
# in a loop header, save the names in the loop list
lappend looplist $dataname
# check the categories used in the loop
set category {}
catch {
set category [lindex \
[lindex $CIF_dataname_index($dataname) 1] 5]
}
# don't worry if we don't have a category
if {$category != ""} {
if {$catlist == ""} {
set catlist $category
} elseif {[lsearch $catlist $category] == -1} {
# error two categories in a loop
lappend catlist $category
append block${blocks}(errors) \
"Multiple categories ($catlist) in a loop_ for $dataname at line [lindex [split $pos .] 0]\n"
}
}
if {$blocks == 0} {
# an error -- a loop_ before a data_ block start
global block${blocks}
set block${blocks}(data_) undefined
append block${blocks}(errors) \
"A loop_ begins before a data_ block is defined (line [lindex [split $pos .] 0])\n"
}
set block${blocks}(loop_${loopnum}) $looplist
# clear the array element for the data item
# -- should not be needed for a valid CIF but if a name is used
# -- twice in the same block, want to wipe out the 1st data
catch {
if {[set block${blocks}($dataname)] != ""} {
# this is an error -- repeated data name
append block${blocks}(errors) \
"Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
}
set block${blocks}($dataname) {}
}
set dataname {}
} elseif {$loopflag > 0} {
# in a loop body, so the loop is over
set loopflag -1
}
# move forward past current token
set pos [$txt index "$epos +1c"]
continue
}
if {[string tolower [string range $token 0 4]] == "loop_"} {
set loopflag 0
incr loopnum
set looplist {}
set catlist {}
set block${blocks}(loop_${loopnum}) {}
# move forward past current token
set pos [$txt index "$epos +1c"]
continue
}
# keywords not matched, must be some type of data item
set item {}
incr CIF(markcount)
if {[$txt get "$pos linestart"] == ";" && \
[$txt index $pos] == [$txt index "$pos linestart"]} {
# multiline entry with semicolon termination
set epos [$txt search -regexp {^;} "$pos + 1 line linestart"]
if {$epos == ""} {
set epos end
append block${blocks}(errors) \
"Unmatched semicolon for $dataname starting at line [lindex [split $pos .] 0]\n"
}
$txt mark set $CIF(markcount).l "$pos linestart"
$txt mark set $CIF(markcount).r "$epos + 1c"
$txt mark gravity $CIF(markcount).l left
$txt mark gravity $CIF(markcount).r right
set item [$txt get "$pos linestart" "$epos +1c"]
# move forward past current token
set pos [$txt index "$epos + 1c"]
} elseif {[$txt get $pos] == "\""} {
# a quoted string -- find next quote
set epos [$txt search "\"" "$pos +1c" "$pos lineend"]
# skip over quotes followed by a non-blank
while {$epos != "" && \
[regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
set epos [$txt search "\"" "$epos +1c" "$pos lineend"]
}
# did we hit the end of line?
if {$epos == ""} {
set epos [$txt index "$pos lineend"]
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"
}
$txt mark set $CIF(markcount).l "$pos"
$txt mark set $CIF(markcount).r "$epos + 1c"
$txt mark gravity $CIF(markcount).l left
$txt mark gravity $CIF(markcount).r right
set item [$txt get $pos "$epos +1c"]
# move forward past current token
set pos [$txt index "$epos +2c"]
} elseif {[$txt get $pos] == {'}} {
# a quoted string -- find next quote
set epos [$txt search {'} "$pos +1c" "$pos lineend"]
# skip over quotes followed by a non-blank
while {$epos != "" && \
[regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
set epos [$txt search {'} "$epos +1c" "$pos lineend"]
}
# did we hit the end of line?
if {$epos == ""} {
set epos [$txt index "$pos lineend"]
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"
}
$txt mark set $CIF(markcount).l "$pos"
$txt mark set $CIF(markcount).r "$epos + 1c"
$txt mark gravity $CIF(markcount).l left
$txt mark gravity $CIF(markcount).r right
set item [$txt get $pos "$epos +1c"]
# move forward past current token
set pos [$txt index "$epos + 2 c"]
} elseif {[$txt get $pos] == {[}} {
# CIF v1.1 square bracket quotes
set count 1
set epos $pos
while {$count != 0} {
set epos [$txt search -regexp {[\]\[]} "$epos +1c"]
if {$epos == ""} {
# unmatched open square bracket
append block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n"
set count 0
set epos [$txt index end]
} elseif {[$txt get $epos] == {]}} {
# close bracket -- decrement
incr count -1
} else {
# open bracket -- increment
incr count
}
}
$txt mark set $CIF(markcount).l "$pos"
$txt mark set $CIF(markcount).r "$epos + 1c"
$txt mark gravity $CIF(markcount).l left
$txt mark gravity $CIF(markcount).r right
set item [$txt get $pos "$epos +1c"]
# move forward past current token
set pos [$txt index "$epos + 2 c"]
} else {
# must be a single space-delimited value
$txt mark set $CIF(markcount).l $pos
$txt mark set $CIF(markcount).r $epos
$txt mark gravity $CIF(markcount).l left
$txt mark gravity $CIF(markcount).r right
set item $token
set pos [$txt index "$epos + 1 c"]
}
# a data item has been read
# store the data item
if {$loopflag >= 0} {
# if in a loop, increment the loop element counter to select the
# appropriate array element
incr loopflag
set i [expr ($loopflag - 1) % [llength $looplist]]
lappend block${blocks}([lindex $looplist $i]) $CIF(markcount)
} elseif {$dataname == ""} {
# this is an error -- a data item where we do not expect one
append block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n"
} else {
if {$blocks == 0} {
# an error -- a data name before a data_ block start
global block${blocks}
set block${blocks}(data_) undefined
append block${blocks}(errors) \
"Data name $dataname appears before a data_ block is defined (line [lindex [split $pos .] 0])\n"
}
catch {
if {[set block${blocks}($dataname)] != ""} {
# this is an error -- repeated data name
append block${blocks}(errors) \
"Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
}
}
set block${blocks}($dataname) $CIF(markcount)
set dataname ""
}
}
$txt see 1.0
return $blocks
}
#------------------------------------------------------------------------------
# Create a CIF browser/editor
# $txt is a text widget with the entire CIF loaded
# blocklist contains the list of defined blocks (by #)
# selected is the list of blocks that will be expanded
# frame gives the name of the toplevel window to hold the browser
proc BrowseCIF {txt blocklist "selected {}" "frame .cif"} {
catch {destroy $frame}
toplevel $frame
wm title $frame "CIF Browser"
CIFOpenBrowser $frame
CIFBrowser $txt $blocklist $selected $frame
grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
}
# Populate a hierarchical CIF browser
# $txt is a text widget with the entire CIF loaded
# blocklist contains the list of defined blocks (by #)
# selected is the list of blocks that will be expanded
# frame gives the name of the toplevel or frame to hold the browser
proc CIFBrowser {txt blocklist "selected {}" "frame .cif"} {
global CIF CIFtreeindex CIF_dataname_index
if {$selected == ""} {set selected $blocklist}
# clear out old info, if any, from browser
eval $CIF(tree) delete [$CIF(tree) nodes root]
catch {unset CIFtreeindex}
# remove the loop counter frame from window & edit buttons from that frame
grid forget $CIF(LoopBar)
pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry)
# delete old contents of frame
set frame [$CIF(displayFrame) getframe]
eval destroy [grid slaves $frame]
set CIF(widgetlist) {}
# reset the scrollbars
$CIF(tree) see 0
$CIF(displayFrame) xview moveto 0
$CIF(displayFrame) yview moveto 0
# Bwidget seems to have problems with the name "1", so avoid it
set num 100
foreach n $blocklist {
global block$n
# make a list of data names in loops
set looplist {}
foreach loop [array names block$n loop_*] {
eval lappend looplist [set block${n}($loop)]
}
# put the block name
set blockname [set block${n}(data_)]
set open 0
if {[lsearch $selected $n] != -1} {set open 1}
$CIF(tree) insert end root block$n -text "_data_$blockname" \
-open $open -image [Bitmap::get folder]
# show errors, if any
foreach name [array names block$n errors] {
$CIF(tree) insert end block$n [incr num] -text "Parse-errors" \
-image [Bitmap::get undo] -data block$n
}
# loop over the names in each block
foreach name [lsort [array names block$n _*]] {
# don't include looped names
if {[lsearch $looplist $name] == -1} {
$CIF(tree) insert end block$n [incr num] -text $name \
-image [Bitmap::get file] -data block$n
set CIFtreeindex(block${n}$name) $num
}
}
foreach loop [lsort [array names block$n loop_*]] {
# make a list of categories used in the loop
set catlist {}
foreach name [lsort [set block${n}($loop)]] {
set category {}
catch {
foreach {type range elist esd units category} \
[lindex $CIF_dataname_index($name) 1] {}
}
if {$category != "" && [lsearch $catlist $category] == -1} {
lappend catlist $category
}
}
$CIF(tree) insert end block$n block${n}$loop \
-text "$loop ($catlist)" \
-image [Bitmap::get copy] -data "block$n loop"
set CIFtreeindex(block${n}$loop) block${n}$loop
foreach name [lsort [set block${n}($loop)]] {
$CIF(tree) insert end block${n}$loop [incr num] -text $name \
-image [Bitmap::get file] -data "block$n $loop"
set CIFtreeindex(block${n}$name) $num
}
}
}
$CIF(tree) bindImage <1> showCIFbyTreeID
$CIF(tree) bindText <1> showCIFbyTreeID
set CIF(tree_lastindex) $num
}
# Create the widgets for a hierarchical CIF browser in $frame
# (where $frame is a frame or toplevel)
# note that the BWidget package is required
proc CIFOpenBrowser {frame} {
global CIF
if [catch {package require BWidget}] {
tk_dialog .error {No BWidget} \
"Sorry, the CIF Browser requires the BWidget package" \
warning 0 Sorry
return
}
set pw [PanedWindow $frame.pw -side top]
grid $pw -sticky news -column 0 -row 0
set CIF(LoopBar) [frame $frame.f]
#grid $CIF(LoopBar) -sticky es -column 0 -row 1
set width 900
if {$width > [winfo screenwidth .]} {set width [winfo screenwidth .]}
grid columnconfigure $frame 0 -weight 1 -minsize $width
# shrink browser on small screens
set h 250
if {[winfo screenheight .] < 500} {set h 180}
grid rowconfigure $frame 0 -minsize $h -weight 1
# create a left hand side pane for the hierarchical tree
set pane [$pw add -weight 1]
set sw [ScrolledWindow $pane.lf \
-relief sunken -borderwidth 2]
set CIF(tree) [Tree $sw.tree \
-relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
-redraw 1]
bind $frame "$CIF(tree) yview scroll -1 page"
bind $frame "$CIF(tree) yview scroll 1 page"
# bind $frame "$CIF(tree) yview scroll -1 unit"
# bind $frame "$CIF(tree) yview scroll 1 unit"
bind $frame "$CIF(tree) yview moveto 0"
#bind $frame "$CIF(tree) yview moveto end" -- does not work
bind $frame "$CIF(tree) yview scroll 99999999 page"
grid $sw
grid $sw -sticky news -column 0 -row 0
grid columnconfigure $pane 0 -minsize 275 -weight 1
grid rowconfigure $pane 0 -weight 1
$sw setwidget $CIF(tree)
# create a right hand side pane to show the value
set pane [$pw add -weight 4]
set sw [ScrolledWindow $pane.sw \
-relief sunken -borderwidth 2]
pack $sw -fill both -expand yes -side top
set CIF(AddtoLoopButton) [button $CIF(LoopBar).l -text "Add to loop"]
set CIF(DeleteLoopEntry) [button $CIF(LoopBar).d \
-text "Delete loop entry" -command DeleteCIFRow]
label $CIF(LoopBar).1 -text "Loop\nelement #"
set CIF(LoopSpinBox) [SpinBox $CIF(LoopBar).2 -range "1 1 1" -width 5]
pack $CIF(LoopBar).2 $CIF(LoopBar).1 -side right
set CIF(displayFrame) $sw.lb
set lb [ScrollableFrame::create $CIF(displayFrame) -width 400]
$sw setwidget $lb
}
# Warn to save changes that are not saved in a file
proc CheckForCIFEdits {} {
#puts "CheckForCIFEdits [info level [expr [info level]-1]]"
global CIF
set errorlist {}
set errorflag 0
set msg "The following edits cannot be saved due to errors:\n"
foreach widget $CIF(widgetlist) {
CheckChanges $widget 1
if {$CIF(errormsg) != ""} {
set errorflag 1
foreach err $CIF(errormsg) {
append msg " " $err \n
}
}
}
if {$errorflag} {
append msg \n {Do you want to make corrections, or discard these edits?}
set ans [MyMessageBox -parent . -title "Invalid edits" \
-message $msg -icon error -type "Correct Discard" \
-default correct]
if {$ans == "correct"} {
# if not, don't allow the mode/loop value to change
set CIF(editmode) 1
catch {
$CIF(LoopSpinBox) setvalue @$CIF(lastLoopIndex)
}
return 1
}
}
return 0
}
# showCIFbyTreeID is used in BrowseCIF to response to clicking on a tree widget
# shows the contents data name or a loop
proc showCIFbyTreeID {name} {
if {[CheckForCIFEdits]} return
global CIF
# code to allow multiple selection within loops
#set loopname [lindex [$CIF(tree) itemcget $name -data] 1]
#set addtolist 1
#if {$loopname == "" || $loopname == "loop"} {set addtolist 0}
#foreach n $CIF(treeSelectedList) {
#if {$loopname != [lindex [$CIF(tree) itemcget $n -data] 1]} {
# set addtolist 0
# break
#}
#}
#if {$addtolist} {
#catch {$CIF(tree) itemconfigure $name -fill red}
#lappend CIF(treeSelectedList) $name
#} else {
foreach n $CIF(treeSelectedList) {
catch {$CIF(tree) itemconfigure $n -fill black}
}
set CIF(treeSelectedList) $name
# for some reason, BWidget sometimes has problems doing this:
# (but ignore the error)
catch {$CIF(tree) itemconfigure $name -fill red}
set CIF(lastShownTreeID) $name
set pointer [$CIF(tree) itemcget $name -data]
set dataname [lindex [$CIF(tree) itemcget $name -text] 0]
showCIFbyDataname $pointer $dataname
#}
}
proc showCIFbyDataname {pointer dataname "loopindex {}"} {
global CIF CIFtreeindex
set CIF(lastShownItem) [list $pointer $dataname]
# remove the loop counter frame from window & edit buttons from that frame
grid forget $CIF(LoopBar)
pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry)
# delete old contents of frame
set frame [$CIF(displayFrame) getframe]
eval destroy [grid slaves $frame]
# reset the scrollbars
$CIF(displayFrame) xview moveto 0
$CIF(displayFrame) yview moveto 0
# leave room for a scrollbar
grid columnconfig $frame 0 -minsize [expr \
[winfo width [winfo parent $frame]] - 20]
if {$pointer == ""} {
return
}
# create list of widgets defined here
set CIF(widgetlist) {}
# is this a looped data item?
set block [lindex $pointer 0]
if {[llength $pointer] == 2} {
global $block
# display contents of a rows of the loop
if {[lindex $pointer 1] == "loop"} {
if {$CIF(editmode)} {
pack $CIF(DeleteLoopEntry) -side right
pack $CIF(AddtoLoopButton) -side right
$CIF(AddtoLoopButton) config -command "AddToCIFloop ${block} $dataname"
}
set looplist [set ${block}($dataname)]
# get number of elements for first name
set names [llength [set ${block}([lindex $looplist 0])]]
# can't delete the only entry
if {$names == 1 && $CIF(editmode)} {
$CIF(DeleteLoopEntry) configure -state disabled
} else {
$CIF(DeleteLoopEntry) configure -state normal
}
$CIF(LoopSpinBox) configure -range "1 $names 1" \
-command "ShowLoopVar ${block} $dataname" \
-modifycmd "ShowLoopVar ${block} $dataname"
set CIF(lastLoopIndex) {}
if {$loopindex == ""} {
$CIF(LoopSpinBox) setvalue first
} else {
$CIF(LoopSpinBox) setvalue @$loopindex
}
# show the loop counter frame
grid $CIF(LoopBar) -sticky es -column 0 -row 1
set row 0
set i 0
ShowDictionaryDefinition $looplist
foreach var $looplist {
incr i
grid [TitleFrame $frame.$i -text $var -side left] \
-column 0 -row $i -sticky ew
set row $i
set frame0 [$frame.$i getframe]
DisplayCIFvalue $frame0.l $var 1 "" ${block}
grid columnconfig $frame0 2 -weight 1
}
ShowLoopVar ${block} $dataname
} else {
# look at a single looped variable
ShowDictionaryDefinition $dataname
grid [TitleFrame $frame.0 -text $dataname -side left] \
-column 0 -row 0 -sticky ew
set row 0
set i 0
set frame0 [$frame.0 getframe]
grid columnconfig $frame0 2 -weight 1
# maximum number of entries
set maxcols 100
catch {
set maxcols $CIF(maxRows)
}
if {[set l [llength [set ${block}($dataname)]]] > $maxcols} {
grid [label $frame0.a$i -justify left \
-text "$dataname has $l entries, too many to display by column" \
] -sticky w -column 0 -row $i
return
}
foreach mark [set ${block}($dataname)] {
incr i
if {$i == 1} {$CIF(txt) see $mark.l}
set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
grid [label $frame0.a$i -justify left -text $i]\
-sticky w -column 0 -row $i
DisplayCIFvalue $frame0.b$i $dataname $i $value ${block} $i
#grid $frame0.b$i -sticky new -column 1 -row $i
}
}
} else {
# unlooped data name
global ${block}
ShowDictionaryDefinition $dataname
grid [TitleFrame $frame.0 -text $dataname -side left] \
-column 0 -row 0 -sticky ew
set row 0
if {$dataname == "Parse-errors"} {
set value [set ${block}(errors)]
} elseif {$dataname == "Validation-errors"} {
set value [set ${block}(validate)]
} else {
set mark [set ${block}($dataname)]
set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
$CIF(txt) see $mark.l
}
set frame0 [$frame.0 getframe]
grid columnconfig $frame0 2 -weight 1
DisplayCIFvalue $frame0.l $dataname "" $value $block
#grid $frame0.l -sticky w -column 1 -row 0
}
}
# redisplay the last entry shown in showCIFbyTreeID
# this is used if the edit mode ($CIF(editmode)) changes or if edits are saved
proc RepeatLastshowCIFvalue {} {
global CIF
if {[CheckForCIFEdits]} return
set lastLoopIndex $CIF(lastLoopIndex)
catch {
eval showCIFbyDataname $CIF(lastShownItem)
# if we are in a loop, display the element
if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} {
$CIF(LoopSpinBox) setvalue @$lastLoopIndex
ShowLoopVar [lindex [lindex $CIF(lastShownItem) 0] 0] \
[lindex $CIF(lastShownItem) 1]
}
}
}
# used in BrowseCIF in response to the spinbox
# show entries in a specific row of a loop
proc ShowLoopVar {array loop} {
global $array CIF
# check for unsaved changes here
if {$CIF(lastLoopIndex) != ""} {
if {[CheckForCIFEdits]} return
}
set looplist [set ${array}($loop)]
set index [$CIF(LoopSpinBox) getvalue]
if {$index < 0} {
$CIF(LoopSpinBox) setvalue first
set index [$CIF(LoopSpinBox) getvalue]
} elseif {$index > [llength [set ${array}([lindex $looplist 0])]]} {
$CIF(LoopSpinBox) setvalue last
set index [$CIF(LoopSpinBox) getvalue]
}
set CIF(lastLoopIndex) $index
set frame [$CIF(displayFrame) getframe]
set i 0
foreach var $looplist {
incr i
set mark [lindex [set ${array}($var)] $index]
# ignore invalid entries -- should not happen
if {$mark == ""} {
$CIF(LoopSpinBox) setvalue first
return
}
set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
if {$i == 1} {$CIF(txt) see $mark.l}
if {$CIF(editmode)} {
global CIFeditArr CIFinfoArr
set widget [$frame.$i getframe].l
set CIFeditArr($widget) $value
switch [winfo class $widget] {
Text {
$widget delete 0.0 end
$widget insert end $value
}
Entry {
$widget config -fg black
}
}
set CIFinfoArr($widget) [lreplace $CIFinfoArr($widget) 2 2 $index]
} else {
[$frame.$i getframe].l config -text $value
}
}
}
# scan a number in crystallographic uncertainty representation
# i.e.: 1.234(12), 1234(23), 1.234e-2(14), -1.234-08(14), etc.
proc ParseSU">ParseSU {num} {
# is there an error on this value?
if {![regexp {([-+eEdD.0-9]+)\(([0-9]+)\)} $num x a err]} {
set a $num
set err {}
}
# parse off an exponent, if present
if {[regexp {([-+.0-9]+)[EeDd]([-+0-9]+)} $a x a1 exp]} {
# [+-]###.###e+## or [+-]###.###D-## etc.
set a $a1
# remove leading zeros from exponent
regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
} elseif {[regexp {([-+.0-9]+)([-+][0-9]+)} $a x a1 exp]} {
# [+-]###.###+## or [+-]###.###-## etc. [no
set a $a1
# remove leading zeros from exponent
regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
} else {
set exp 0
}
# now parse the main number and count the digits after the decimal
set a2 {}
set a3 {}
regexp {^([-+0-9]*)\.?([0-9]*)$} $a x a2 a3
set l [string length $a3]
set val .
set error {}
if {[catch {
set val [expr ${a2}.${a3} * pow(10,$exp)]
if {$err != ""} {
set error [expr $err*pow(10,$exp-$l)]
}
}]} {
# something above was invalid
if {$err != ""} {
return "$val ."
} else {
return $val
}
}
if {$error == ""} {
return $val
} else {
return [list $val $error]
}
}
# a stand-alone routine for testing. Select, read and browse a CIF
proc Read_BrowseCIF {} {
global tcl_platform
if {$tcl_platform(platform) == "windows"} {
set filetypelist {
{"CIF files" .CIF} {"All files" *}
}
} else {
set filetypelist {
{"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
}
}
set file [tk_getOpenFile -parent . -filetypes $filetypelist]
if {$file == ""} return
if {![file exists $file]} return
pleasewait "Reading CIF from file"
set blocks [ParseCIF $file]
if {$blocks == ""} {
donewait
MessageBox -parent . -type ok -icon warning \
-message "Note: no valid CIF blocks were read from file $filename"
return
}
catch {donewait}
set allblocks {}
for {set i 1} {$i <= $blocks} {incr i} {
lappend allblocks $i
}
if {$allblocks != ""} {
BrowseCIF $allblocks "" .cif
# wait for the window to close
tkwait window .cif
} else {
puts "no blocks read"
}
# clean up -- get rid of the CIF arrays
for {set i 1} {$i <= $blocks} {incr i} {
global block$i
catch {unset block$i}
}
}
# this takes a block of text, strips off the quotes ("", '', [] or ;;)
proc StripQuotes {value} {
set value [string trim $value]
if {[string range $value end-1 end] == "\n;" && \
[string range $value 0 0] == ";"} {
return [string range $value 1 end-2]
} elseif {[string range $value end end] == "\"" && \
[string range $value 0 0] == "\""} {
set value [string range $value 1 end-1]
} elseif {[string range $value end end] == "'" && \
[string range $value 0 0] == "'"} {
set value [string range $value 1 end-1]
} elseif {[string range $value end end] == {]} && \
[string range $value 0 0] == {[}} {
set value [string range $value 1 end-1]
}
return $value
}
# replace a CIF value in with a new value.
# add newlines as needed to make sure the new value does not
# exceed CIF(maxlinelength) [defaults to 80] characters/line
proc ReplaceMarkedText {txt mark value} {
$txt configure -state normal
# is this a multi-line string?
set num [string first \n $value]
set l [string length $value]
# are there spaces in the string?
set spaces [string first " " $value]
# if no, are there any square brackets? -- treat them as requiring quotes
if {$spaces == -1} {set spaces [string first {[} $value]}
# are there any reserved strings inside $value? If so, it must be quoted
if {$spaces == -1} {
set tmp [string toupper $value]
foreach s {DATA_ LOOP_ SAVE_ STOP_ GLOBAL_} {
if {[set spaces [string first $s $tmp]] != -1} break
}
}
# are there quotes inside the string?
set doublequote [string first "\"" $value]
set singlequote [string first {'} $value]
# if we have either type of quotes, use semicolon quoting
if {$singlequote != -1 && $doublequote != -1} {set num $l}
# lines longer than 78 characters with spaces need to be treated
# as multiline
if {$num == -1 && $l > 77 && $spaces != -1} {
set num $l
}
if {$num != -1} {
set tmp {}
if {[lindex [split [$txt index $mark.l] .] 1] != 0} {
append tmp \n
}
append tmp ";"
if {$num > 78} {
append tmp \n
} else {
append tmp " "
}
append tmp $value "\n;"
# is there something else on the line?
set restofline [$txt get $mark.r [lindex [split [$txt index $mark.r] .] 0].end]
if {[string trim $restofline] != ""} {
append tmp \n
}
$txt delete ${mark}.l ${mark}.r
$txt insert ${mark}.l $tmp
$txt configure -state disabled
return
} elseif {($spaces != -1 || [string trim $value] == "") \
&& $doublequote == -1} {
# use doublequotes, unless doublequotes are present inside the string
set tmp "\""
append tmp $value "\""
} elseif {$spaces != -1 || [string trim $value] == ""} {
# use single quotes, since doublequotes are present inside the string
set tmp {'}
append tmp $value {'}
} else {
# no quotes needed
set tmp $value
}
# is there room on the beginning of the line to add the string?
set l [string length $tmp]
set pos [lindex [split [$txt index $mark.l] .] 0]
if {$l + [string length [$txt get $pos.0 $mark.l]] <= 79} {
# will fit
$txt delete ${mark}.l ${mark}.r
$txt insert ${mark}.l $tmp
} else {
# no, stick a CR in front of string
$txt delete ${mark}.l ${mark}.r
$txt insert ${mark}.l \n$tmp
}
# is rest of the line after the inserted string still too long?
set pos [lindex [split [$txt index $mark.r] .] 0]
if {[string length [$txt get $pos.0 $pos.end]] > 79} {
$txt insert $mark.r \n
}
$txt configure -state disabled
}
# return the dictionary definition for a list of CIF data names
proc GetCIFDefinitions {datanamelist} {
global CIF_dataname_index
set l {}
# compile a list of definition pointers
foreach dataname $datanamelist {
set pointer {}
catch {
set pointer [lindex $CIF_dataname_index($dataname) 0]
}
lappend l [list $dataname $pointer]
}
set l [lsort -index 1 $l]
set pp {}
set dictdefs {}
set def {}
set nlist {}
# merge items with duplicate definitions
foreach item $l {
# is this the first loop through?
foreach {dataname pointer} $item {}
if {$def == ""} {
foreach {nlist pp} $item {}
set def [ReadCIFDefinition $pp]
} elseif {$pp == $pointer} {
# same as last
lappend nlist $dataname
} else {
# add the last entry to the list
set pp $pointer
lappend dictdefs [list $nlist $def]
set nlist $dataname
if {$pointer == ""} {
set def { Undefined dataname}
} else {
# lookup name
set def [ReadCIFDefinition $pointer]
}
}
}
lappend dictdefs [list $nlist $def]
return $dictdefs
}
# read the CIF definition for a dataname. The pointer contains 3 values
# a filename, the number of characters from the start of the file and
# the length of the definition.
proc ReadCIFDefinition {pointer} {
global CIF
set file {}
set loc {}
set line {}
foreach {file loc len} $pointer {}
if {$file != "" && $loc != "" && $loc != ""} {
set fp {}
foreach path $CIF(cif_path) {
catch {set fp [open [file join $path $file] r]}
if {$fp != ""} break
}
if {$fp == ""} return
fconfigure $fp -translation binary
catch {
seek $fp $loc
set line [read $fp $len]
close $fp
# remove line ends & superfluous spaces
regsub -all {\n} [StripQuotes $line] { } line
regsub -all {\r} $line { } line
regsub -all { +} $line { } line
# regsub -all { +} [StripQuotes $line] { } line
}
}
return $line
}
proc ValidateCIFName {dataname} {
global CIF_dataname_index
if {[
catch {
set CIF_dataname_index($dataname)
}
]} {return "warning: dataname $dataname not defined"}
}
# validates that a CIF value is valid for a specific dataname
proc ValidateCIFItem {dataname item} {
global CIF_dataname_index CIF
# maximum line length
set maxlinelength 80
catch {set maxlinelength $CIF(maxlinelength)}
if {[catch {
foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
}]} {return}
if {$type == "c"} {
# string type constant
set item [StripQuotes $item]
# is it enumerated?
if {$elist != ""} {
# check it against the list of values
foreach i [concat $elist . ?] {
if {[string tolower $item] == [string tolower [lindex $i 0]]} {return}
}
return "error: value \"$item\" is not an allowed option for $dataname"
} else {
# check it for line lengths
set l 0
set err {}
foreach line [split $item \n] {
incr l
if {[string length $line] > $maxlinelength} {lappend err $l}
}
if {$err != ""} {return "error: line(s) $err are too long"}
}
return
} elseif {$type == ""} {
return "error: dataname $dataname is not used for CIF data items"
} elseif {$type == "n"} {
# validate numbers
set unquoted [StripQuotes $item]
if {$unquoted == "?" || $unquoted == "."} return
if {$unquoted != $item} {
set err "\nwarning: number $item is quoted for $dataname"
set item $unquoted
} else {
set err {}
}
set v $item
# remove s.u., if allowed & present
set vals [ParseSU">ParseSU $item]
if {[set v [lindex $vals 0]] == "."} {
return "error: value \"$item\" is not a valid number for $dataname$err"
}
if {$esd} {
if {[lindex $vals 1] == "."} {
return "error: value \"$item\" for $dataname has an invalid uncertainty (esd)$err"
}
} elseif {[llength $vals] == 2} {
return "error: \"$item\" is invalid for $dataname, an uncertainty (esd) is not allowed$err"
}
# now validate the range
if {$range != ""} {
# is there a decimal point in the range?
set integer 0
if {[string first . $range] == -1} {set integer 1}
# pull out the range
foreach {min max} [split $range :] {}
if {$integer && int($v) != $v} {
return "warning: value \"$item\" is expected to be an integer for $dataname$err"
}
if {$min != ""} {
if {$v < $min} {
return "error: value \"$item\" is too small for $dataname (allowed range $range)$err"
}
}
if {$max != ""} {
if {$v > $max} {
return "error: value \"$item\" is too big for $dataname(allowed range $range)$err"
}
}
}
return $err
}
return {}
}
# displays the dictionary definitions in variable defs into a text widget
proc ShowDictionaryDefinition {defs} {
global CIF
set deflist [GetCIFDefinitions $defs]
catch {
$CIF(defBox) delete 1.0 end
foreach d $deflist {
foreach {namelist definition} $d {}
foreach n $namelist {
$CIF(defBox) insert end $n dataname
$CIF(defBox) insert end \n
}
$CIF(defBox) insert end \n
$CIF(defBox) insert end $definition
$CIF(defBox) insert end \n
$CIF(defBox) insert end \n
}
$CIF(defBox) tag config dataname -background yellow
}
}
# create a widget to display a CIF value
proc DisplayCIFvalue {widget dataname loopval value block "row 0"} {
global CIFeditArr CIFinfoArr
global CIF CIF_dataname_index
if {[
catch {
foreach {type range elist esd units category} [lindex $CIF_dataname_index($dataname) 1] {}
}
]} {
set type c
set elist {}
}
lappend CIF(widgetlist) $widget
set CIFinfoArr($widget) {}
if $CIF(editmode) {
if {$loopval != ""} {
set widgetinfo [list $dataname $block [expr $loopval -1]]
} else {
set widgetinfo [list $dataname $block 0]
}
set CIFeditArr($widget) $value
set CIFinfoArr($widget) $widgetinfo
if {$type == "n"} {
entry $widget -justify left -textvariable CIFeditArr($widget)
bind $widget "CheckChanges $widget"
grid $widget -sticky nsw -column 1 -row $row
if {$units != ""} {
set ws "${widget}u"
label $ws -text "($units)" -bg yellow
grid $ws -sticky nsw -column 2 -row $row
}
} elseif {$elist != ""} {
set enum {}
foreach e $elist {
lappend enum [lindex $e 0]
}
tk_optionMenu $widget CIFeditArr($widget) ""
FixBigOptionMenu $widget $enum "CheckChanges $widget"
AddSpecialEnumOpts $widget "CheckChanges $widget"
grid $widget -sticky nsw -column 1 -row $row
} else {
# count the number of lines in the text
set nlines [llength [split $value \n]]
if {$nlines < 1} {
set nlines 1
} elseif {$nlines > 10} {
set nlines 10
}
set ws "${widget}s"
text $widget -height $nlines -width 80 -yscrollcommand "$ws set"
scrollbar $ws -command "$widget yview" -width 10 -bd 1
$widget insert end $value
bind $widget "CheckChanges $widget"
if {$nlines > 1} {
grid $ws -sticky nsew -column 1 -row $row
grid $widget -sticky nsew -column 2 -row $row
} else {
grid $widget -sticky nsew -column 1 -columnspan 2 -row $row
}
}
} else {
label $widget -bd 2 -relief groove \
-justify left -anchor w -text $value
grid $widget -sticky nsw -column 1 -row $row
if {$type == "n" && $units != ""} {
set ws "${widget}u"
label $ws -text "($units)" -bg yellow
grid $ws -sticky nsw -column 2 -row $row
}
}
}
# this is called to see if the user has changed the value for a CIF
# data item and to validate it.
# save the change if $save is 1
# return 1 if the widget contents has changed
proc CheckChanges {widget "save 0"} {
global CIFeditArr CIFinfoArr CIF
# maximum line length
set maxlinelength 80
catch {set maxlinelength $CIF(maxlinelength)}
set CIF(errormsg) {}
if {![winfo exists $widget]} return
set dataname {}
catch {
foreach {dataname block index} $CIFinfoArr($widget) {}
}
# if this widget is a label, the info above will not be defined & checks are not needed
if {$dataname == ""} {return 0}
if {$dataname == "Parse-errors"} {return 0}
if {$dataname == "Validation-errors"} {return 0}
global ${block}
set mark [lindex [set ${block}($dataname)] $index]
if {$mark == ""} return
set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
# validate the entry
set error {}
set err {}
switch [winfo class $widget] {
Text {
set current [string trim [$widget get 1.0 end]]
set l 0
foreach line [set linelist [split $current \n]] {
incr l
if {[string length $line] > $maxlinelength} {
lappend err $l
lappend error "Error: line $l for $dataname is >$maxlinelength characters"
}
}
if {$err != ""} {
foreach l $err {
$widget tag add error $l.0 $l.end
}
$widget tag config error -foreground red
} else {
$widget tag delete error
}
# see if box should expand
set clines [$widget cget -height]
if {$clines <= 2 && \
[string trim $orig] != [string trim $current]} {
# count the number of lines in the text
set nlines [llength $linelist]
if {[lindex $linelist end] == ""} {incr nlines -1}
if {$nlines == 2} {
$widget config -height 2
} elseif {$nlines > 2} {
set i [lsearch [set s [grid info $widget]] -row]
set row [lindex $s [expr 1+$i]]
$widget config -height 3
set ws "${widget}s"
grid $ws -sticky nsew -column 1 -row $row
grid $widget -sticky nsew -column 2 -row $row
}
}
}
Entry {
set current [string trim [$widget get]]
set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current]
if {$err != "" && \
[string tolower [lindex $err 0]] != "warning:"} {
lappend error $err
$widget config -fg red
} else {
$widget config -fg black
}
}
Menubutton {
set current $CIFeditArr($widget)
}
Label {
return 0
}
}
if {[string trim $orig] != [string trim $current]} {
if {$err != ""} {
set CIF(errormsg) $error
} elseif {$save} {
SaveCIFedits $widget
return 0
}
return 1
}
return 0
}
# save the CIF edits into the CIF text widget
proc SaveCIFedits {widget} {
global CIFeditArr CIFinfoArr CIF
foreach {dataname block index} $CIFinfoArr($widget) {}
global ${block}
set mark [lindex [set ${block}($dataname)] $index]
set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
switch [winfo class $widget] {
Text {
set current [string trim [$widget get 1.0 end]]
}
Entry {
set current [string trim [$widget get]]
}
Menubutton {
set current $CIFeditArr($widget)
}
}
# save for undo & clear the redo list
set CIF(redolist) {}
if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} {
lappend CIF(undolist) [list $mark $orig \
$CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
} else {
lappend CIF(undolist) [list $mark $orig \
$CIF(lastShownItem) $CIF(lastShownTreeID)]
}
# count it
incr CIF(changes)
# make the change
ReplaceMarkedText $CIF(txt) $mark $current
}
# add a new "row" to a CIF loop. At least for now, we only add at the end.
proc AddToCIFloop {block loop} {
global $block CIF
# check for unsaved changes here
if {[CheckForCIFEdits]} return
$CIF(txt) configure -state normal
set looplist [set ${block}($loop)]
set length [llength [set ${block}([lindex $looplist 0])]]
# find the line following the last entry in the list
set var [lindex $looplist end]
set line [lindex [split [\
$CIF(txt) index [lindex [set ${block}($var)] end].r \
] .] 0]
incr line
set epos $line.0
$CIF(txt) insert $epos \n
# insert a ? token for each entry & add to marker list for each variable
set addlist {}
foreach var $looplist {
# go to next line?
if {[string length \
[$CIF(txt) get "$epos linestart" "$epos lineend"]\
] > 78} {
$CIF(txt) insert $epos \n
set epos [$CIF(txt) index "$epos + 1c"]
}
$CIF(txt) insert $epos "? "
incr CIF(markcount)
$CIF(txt) mark set $CIF(markcount).l "$epos"
$CIF(txt) mark set $CIF(markcount).r "$epos + 1c"
$CIF(txt) mark gravity $CIF(markcount).l left
$CIF(txt) mark gravity $CIF(markcount).r right
set epos [$CIF(txt) index "$epos + 2c"]
set index [llength [set ${block}($var)]]
lappend ${block}($var) $CIF(markcount)
lappend addlist [list $CIF(markcount) $var $index $block]
}
incr CIF(changes)
lappend CIF(undolist) [list "loop add" $addlist \
$CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
set CIF(redolist) {}
# now show the value we have added
set frame [$CIF(displayFrame) getframe]
set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
incr max
$CIF(LoopSpinBox) configure -range "1 $max 1"
$CIF(LoopSpinBox) setvalue last
ShowLoopVar $block $loop
$CIF(txt) configure -state disabled
$CIF(DeleteLoopEntry) configure -state normal
}
proc DeleteCIFRow {} {
global CIF
global CIFinfoArr CIFeditArr
set delrow [$CIF(LoopSpinBox) getvalue]
set msg {Are you sure you want to delete the following loop entries}
append msg " (row number [expr 1+$delrow])?\n"
set widget ""
foreach widget $CIF(widgetlist) {
set var [lindex $CIFinfoArr($widget) 0]
append msg "\n$var\n\t"
# get the value
switch [winfo class $widget] {
Text {
set value [string trim [$widget get 1.0 end]]
}
Entry {
set value [string trim [$widget get]]
}
Menubutton {
set value $CIFeditArr($widget)
}
}
append msg $value \n
}
if {$widget == ""} {
error "this should not happen"
}
foreach {dataname block index} $CIFinfoArr($widget) {}
global $block
if {[llength [set ${block}($dataname)]] == 1} {
MyMessageBox -parent . -title "Not only row" \
-message {Sorry, this program is unable to delete all entries from a loop.} \
-icon warning -type {Ignore} -default Ignore
return
}
set ans [MyMessageBox -parent . -title "Delete Row?" \
-message $msg \
-icon question -type {Keep Delete} -default Keep]
if {$ans == "keep"} {return}
$CIF(txt) configure -state normal
set deletelist {}
foreach widget $CIF(widgetlist) {
foreach {dataname block index} $CIFinfoArr($widget) {}
global $block
set mark [lindex [set ${block}($dataname)] $index]
set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
lappend deletelist [list $mark $dataname $index $block $orig]
$CIF(txt) delete $mark.l $mark.r
set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
}
set CIF(redolist) {}
lappend CIF(undolist) [list "loop delete" $deletelist \
$CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
# count it
incr CIF(changes)
$CIF(txt) configure -state disabled
set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
incr max -1
$CIF(LoopSpinBox) configure -range "1 $max 1"
if {$index >= $max} {set index $max; incr index -1}
$CIF(LoopSpinBox) setvalue @$index
if {$max == 1} {$CIF(DeleteLoopEntry) configure -state disabled}
# don't check for changes
set CIF(lastLoopIndex) {}
ShowLoopVar $block [lindex $CIF(lastShownItem) 1]
}
# display & highlight a line in the CIF text viewer
proc MarkGotoLine {line} {
global CIF
$CIF(txt) tag delete currentline
$CIF(txt) tag add currentline $line.0 $line.end
$CIF(txt) tag configure currentline -foreground blue
$CIF(txt) see $line.0
}
# Extract a value from a CIF in the CIF text viewer
proc ValueFromCIF {block item} {
global $block CIF
set val {}
catch {
set mark [set ${block}($item)]
if {[llength $mark] == 1} {
set val [string trim [StripQuotes [$CIF(txt) get $mark.l $mark.r]]]
} else {
foreach m $mark {
lappend val [string trim [StripQuotes [$CIF(txt) get $m.l $m.r]]]
}
}
}
return $val
}
proc UndoChanges {} {
global CIF
# save any current changes, if possible
if {[CheckForCIFEdits]} return
# are there edits to undo?
if {[llength $CIF(undolist)] == 0} return
foreach {mark orig lastShownItem lastShownTreeID lastLoopIndex} \
[lindex $CIF(undolist) end] {}
if {[llength $mark] == 1} {
# get the edited value
set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
# make the change back
ReplaceMarkedText $CIF(txt) $mark $orig
# add this undo to the redo list
lappend CIF(redolist) [list $mark $edited $lastShownItem \
$lastShownTreeID $lastLoopIndex]
} elseif {[lindex $mark 1] == "add"} {
set deletelist {}
$CIF(txt) configure -state normal
foreach m $orig {
foreach {mark dataname index block} $m {}
# get the inserted value
set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
$CIF(txt) delete $mark.l $mark.r
lappend deletelist [list $mark $dataname $index $block $edited]
global $block
set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
}
$CIF(txt) configure -state disabled
# add this action to the redo list
lappend CIF(redolist) [list "loop delete" $deletelist \
$lastShownItem $lastShownTreeID $lastLoopIndex]
} elseif {[lindex $mark 1] == "delete"} {
set addlist {}
foreach m $orig {
foreach {mark dataname index block orig} $m {}
# make the change back
ReplaceMarkedText $CIF(txt) $mark $orig
lappend addlist [list $mark $dataname $index $block]
global $block
set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark]
}
# show the entry that was added
set lastLoopIndex $index
# add this last entry to the redo list
lappend CIF(redolist) [list "loop add" $addlist \
$lastShownItem $lastShownTreeID $lastLoopIndex]
}
# drop the action from the undo list
set CIF(undolist) [lreplace $CIF(undolist) end end]
# count back
incr CIF(changes) -1
# scroll on the tree
$CIF(tree) see $lastShownTreeID
eval showCIFbyDataname $lastShownItem
# if we are in a loop, display the element
if {[lindex [lindex $lastShownItem 0] 1] == "loop"} {
$CIF(LoopSpinBox) setvalue @$lastLoopIndex
ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \
[lindex $lastShownItem 1]
}
}
proc RedoChanges {} {
global CIF
# save any current changes, if possible
if {[CheckForCIFEdits]} return
# are there edits to redo?
if {[llength $CIF(redolist)] == 0} return
foreach {mark edited lastShownItem lastShownTreeID lastLoopIndex} \
[lindex $CIF(redolist) end] {}
if {[llength $mark] == 1} {
# get the edited value
set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
# make the change back
ReplaceMarkedText $CIF(txt) $mark $edited
# add this action back to the undo list
lappend CIF(undolist) [list $mark $orig $lastShownItem \
$lastShownTreeID $lastLoopIndex]
# count up
incr CIF(changes)
} elseif {[lindex $mark 1] == "add"} {
set deletelist {}
$CIF(txt) configure -state normal
foreach m $edited {
foreach {mark dataname index block} $m {}
# get the inserted value
set edited [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
$CIF(txt) delete $mark.l $mark.r
lappend deletelist [list $mark $dataname $index $block $edited]
global $block
set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
}
$CIF(txt) configure -state disabled
# add this action back to the undo list
lappend CIF(undolist) [list "loop delete" $deletelist \
$lastShownItem $lastShownTreeID $lastLoopIndex]
# count up
incr CIF(changes)
} elseif {[lindex $mark 1] == "delete"} {
set addlist {}
foreach m $edited {
foreach {mark dataname index block orig} $m {}
# make the change back
ReplaceMarkedText $CIF(txt) $mark $orig
lappend addlist [list $mark $dataname $index $block]
global $block
set ${block}($dataname) [linsert [set ${block}($dataname)] $index $mark]
}
# show the entry that was added
set lastLoopIndex $index
# add this action back to the undo list
lappend CIF(undolist) [list "loop add" $addlist \
$lastShownItem $lastShownTreeID $lastLoopIndex]
# count up
incr CIF(changes)
}
# drop the action from the redo list
set CIF(redolist) [lreplace $CIF(redolist) end end]
# scroll on the tree
$CIF(tree) see $lastShownTreeID
eval showCIFbyDataname $lastShownItem
# if we are in a loop, display the element
if {[lindex [lindex $lastShownItem 0] 1] == "loop"} {
$CIF(LoopSpinBox) setvalue @$lastLoopIndex
ShowLoopVar [lindex [lindex $lastShownItem 0] 0] \
[lindex $lastShownItem 1]
}
}
# initialize misc variables
set CIF(changes) 0
set CIF(widgetlist) {}
set CIF(lastShownItem) {}
set CIF(lastLoopIndex) {}
set CIF(editmode) 0
set CIF(undolist) {}
set CIF(redolist) {}
set CIF(treeSelectedList) {}