Context Navigation

source: trunk/browsecif.tcl @ 930

Last change on this file since 930 was 930, checked in by toby, 12 years ago
rcs:* properties removed
Property svn:keywords set to `Author Date Revision Id`
File size: 103.3 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: