Context Navigation

source: trunk/browsecif.tcl @ 771

Last change on this file since 771 was 771, checked in by toby, 11 years ago
# on 2004/01/30 00:41:19, toby did: update to match new version of CIFEDIT etc.
Property rcs:author set to `toby` Property rcs:date set to `2004/01/30 00:41:19` Property rcs:lines set to `+1306 -46` Property rcs:rev set to `1.9` Property rcs:state set to `Exp` Property svn:keywords set to `Author Date Revision Id`
File size: 103.3 KB

Line
1	# $Id: browsecif.tcl 771 2009-12-04 23:11:45Z 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) ""]} {
236	bind $w <Return> [list $w.[string tolower $data(-default)] invoke]
237	}
238
239	# 7. Withdraw the window, then update all the geometry information
240	# so we know how big it wants to be, then center the window in the
241	# display and de-iconify it.
242
243	wm withdraw $w
244	update idletasks
245	set wp $data(-parent)
246	# center the new window in the middle of the parent
247	set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
248	[winfo reqwidth $w]/2 - [winfo vrootx $wp]]
249	set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
250	[winfo reqheight $w]/2 - [winfo vrooty $wp]]
251	# make sure that we can see the entire window
252	set xborder 10
253	set yborder 25
254	if {$x < 0} {set x 0}
255	if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
256	incr x [expr \
257	[winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
258	}
259	if {$y < 0} {set y 0}
260	if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
261	incr y [expr \
262	[winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
263	}
264	wm geom $w +$x+$y
265	update
266	wm deiconify $w
267
268	# 8. Set a grab and claim the focus too.
269
270	catch {set oldFocus [focus]}
271	catch {set oldGrab [grab current $w]}
272	catch {
273	grab $w
274	if {[string compare $data(-default) ""]} {
275	focus $w.[string tolower $data(-default)]
276	} else {
277	focus $w
278	}
279	}
280
281	# 9. Wait for the user to respond, then restore the focus and
282	# return the index of the selected button. Restore the focus
283	# before deleting the window, since otherwise the window manager
284	# may take the focus away so we can't redirect it. Finally,
285	# restore any grab that was in effect.
286
287	tkwait variable tkPriv(button)
288	catch {focus $oldFocus}
289	destroy $w
290	catch {grab $oldGrab}
291	return $tkPriv(button)
292	}
293
294	# tell'em what is happening
295	proc pleasewait {{message {}} {statusvar {}} {parent .} {button ""}} {
296	catch {destroy .msg}
297	toplevel .msg
298	wm transient .msg [winfo toplevel .]
299	pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5
300	pack [message .msg.f.m -text "Please wait $message"] -side top
301	if {$statusvar != ""} {
302	pack [label .msg.f.status -textvariable $statusvar] -side top
303	}
304	if {$button != ""} {
305	pack [button .msg.f.button -text [lindex $button 0] \
306	-command [lindex $button 1]] -side top
307	}
308	wm withdraw .msg
309	update idletasks
310	# place the message on top of the parent window
311	set x [expr [winfo x $parent] + [winfo width $parent]/2 - \
312	[winfo reqwidth .msg]/2 - [winfo vrootx $parent]]
313	if {$x < 0} {set x 0}
314	set y [expr [winfo y $parent] + [winfo height $parent]/2 - \
315	[winfo reqheight .msg]/2 - [winfo vrooty $parent]]
316	if {$y < 0} {set y 0}
317	wm geom .msg +$x+$y
318	update
319	wm deiconify .msg
320	global makenew
321	set makenew(OldGrab) ""
322	set makenew(OldFocus) ""
323	# save focus & grab
324	catch {set makenew(OldFocus) [focus]}
325	catch {set makenew(OldGrab) [grab current .msg]}
326	catch {grab .msg}
327	update
328	}
329
330	# clear the wait message
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
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
453	#------------------------------------------------------------------------------
454	# end of Misc Tcl/Tk utility routines
455	#------------------------------------------------------------------------------
456
457	#------------------------------------------------------------------------------
458	# ParseCIF reads and parses a CIF file putting the contents of
459	# each block into arrays block1, block2,... in the caller's level
460	# the name of the block is saved as blockN(data_)
461	# data names items are saved as blockN(_data_name) = marker_number
462	# where CIF data names are converted to lower case
463	# and marker_number.l marker_number.r define the range of the value
464	# for looped data names, the data items are included in a list:
465	# blockN(_cif_name) = {marker1 marker2 ...}
466	# the contents of each loop are saved as blockN(loop_M)
467	#
468	# if the filename is blank or not specified, the current contents
469	# of the text widget, $txt, is parsed.
470	#
471	# The proc returns the number of blocks that have been read or a
472	# null string if the file cannot be opened
473	#
474	# This parser does some error checking [errors are reported in blockN(error)]
475	# but the parser could get confused if the CIF has invalid syntax
476	#
477	proc ParseCIF {txt "filename {}" "namespace {}"} {
478	global CIF tcl_version
479	global CIF_dataname_index
480	# create a namespace, if one is needed
481	if {$namespace != ""} {
482	namespace eval $namespace {}
483	}
484
485	if {$tcl_version < 8.2} {
486	tk_dialog .error {Old Tcl/Tk} \
487	"Sorry, the CIF Browser requires version 8.2 or later of the Tcl/Tk package. This is $tcl_version" \
488	warning 0 Sorry
489	return
490	}
491
492	if {$filename != ""} {
493	if [catch {
494	$txt configure -state normal
495	set fp [open $filename r]
496	$txt insert end [read $fp]
497	close $fp
498	$txt configure -state disabled
499	}] {
500	return ""
501	}
502	}
503
504	# maximum size of file
505	set maxvalues 0
506	catch {
507	set maxvalues $CIF(maxvalues)
508	}
509
510	set CIF(undolist) {}
511	set CIF(redolist) {}
512	set pos 1.0
513	set blocks 0
514	set EOF 1
515	set dataname {}
516	set CIF(markcount) -1
517	# this flags where we are w/r a loop_
518	# -1 not in a loop
519	# 0 reading a loop header (data names)
520	# 1 reading the data items in a loop
521	set loopflag -1
522	set loopnum -1
523	# loop over tokens
524	while {$EOF} {
525	if {$CIF(markcount) % 1000 == 0} {
526	$txt see $pos
527	set CIF(status) "($CIF(markcount) values read.)"
528	update
529	# are we over the limit?
530	if {$maxvalues > 0 && $CIF(markcount) > $maxvalues} {
531	donewait
532	set msg "Too many data values to parse; stopping at $CIF(markcount), line [lindex [split $pos .] 0].\n\nIf your computer has sufficient memory to read more, increase CIF(maxvalues) in cifedit.tcl"
533	set ans [MyMessageBox -parent . -title "CIF Too big" \
534	-message $msg -icon error -type "{Stop Parsing}" \
535	-default "stop parsing"]
536
537	return $blocks
538	}
539	}
540	# skip forward to the first non-blank character
541	set npos [$txt search -regexp {[^[:space:]]} $pos end]
542	# is this the end?
543	if {$npos == "" \|\| \
544	[lindex [split $npos .] 0] < [lindex [split $pos .] 0] } {
545	set EOF 0
546	break
547	} else {
548	set pos $npos
549	}
550
551	# is this a comment, if so skip to next line
552	if {[$txt get $pos] == "#"} {
553	set pos [$txt index "$pos + 1 line linestart"]
554	continue
555	}
556
557	# find end of token
558	set epos [$txt search -regexp {[[:space:]]} $pos "$pos lineend"]
559	if {$epos == ""} {
560	set epos [$txt index "$pos lineend"]
561	}
562
563	set token [$txt get $pos $epos]
564
565	if {[string tolower [string range $token 0 4]] == "data_"} {
566	# this is the beginning of a data block
567	incr blocks
568	set blockname [string range $token 5 end]
569	catch {unset ${namespace}::block$blocks}
570	set ${namespace}::block${blocks}(data_) $blockname
571	set loopnum -1
572	if {$dataname != ""} {
573	# this is an error -- data_ block where a data item is expected
574	append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
575	set dataname {}
576	}
577	# move forward past current token
578	set pos [$txt index "$epos +1c"]
579	continue
580	}
581
582	if {[$txt get $pos] == "_"} {
583	# this is a cif data name
584	if {$dataname != ""} {
585	# this is an error -- data name where a data item is expected
586	append ${namespace}::block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
587	}
588	# convert it to lower case & save
589	set dataname [string tolower $token]
590
591	# are we in a loop header or loop body?
592	if {$loopflag == 0} {
593	# in a loop header, save the names in the loop list
594	lappend looplist $dataname
595	# check the categories used in the loop
596	set category {}
597	catch {
598	set category [lindex \
599	[lindex $CIF_dataname_index($dataname) 1] 5]
600	}
601	# don't worry if we don't have a category
602	if {$category != ""} {
603	if {$catlist == ""} {
604	set catlist $category
605	} elseif {[lsearch $catlist $category] == -1} {
606	# error two categories in a loop
607	lappend catlist $category
608	append ${namespace}::block${blocks}(errors) \
609	"Multiple categories ($catlist) in a loop_ for $dataname at line [lindex [split $pos .] 0]\n"
610	}
611	}
612
613	if {$blocks == 0} {
614	# an error -- a loop_ before a data_ block start
615	set ${namespace}::block${blocks}(data_) undefined
616	append ${namespace}::block${blocks}(errors) \
617	"A loop_ begins before a data_ block is defined (line [lindex [split $pos .] 0])\n"
618	}
619	set ${namespace}::block${blocks}(loop_${loopnum}) $looplist
620	# clear the array element for the data item
621	# -- should not be needed for a valid CIF but if a name is used
622	# -- twice in the same block, want to wipe out the 1st data
623	catch {
624	if {[set ${namespace}::block${blocks}($dataname)] != ""} {
625	# this is an error -- repeated data name
626	append ${namespace}::block${blocks}(errors) \
627	"Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
628	}
629	set ${namespace}::block${blocks}($dataname) {}
630	}
631	set dataname {}
632	} elseif {$loopflag > 0} {
633	# in a loop body, so the loop is over
634	set loopflag -1
635	}
636	# move forward past current token
637	set pos [$txt index "$epos +1c"]
638	continue
639	}
640
641	if {[string tolower [string range $token 0 4]] == "loop_"} {
642	set loopflag 0
643	incr loopnum
644	set looplist {}
645	set catlist {}
646	set ${namespace}::block${blocks}(loop_${loopnum}) {}
647	# move forward past current token
648	set pos [$txt index "$epos +1c"]
649	continue
650	}
651
652	# keywords not matched, must be some type of data item
653	set item {}
654	incr CIF(markcount)
655
656	if {[$txt get "$pos linestart"] == ";" && \
657	[$txt index $pos] == [$txt index "$pos linestart"]} {
658	# multiline entry with semicolon termination
659	set epos [$txt search -regexp {^;} "$pos + 1 line linestart"]
660	if {$epos == ""} {
661	set epos end
662	append ${namespace}::block${blocks}(errors) \
663	"Unmatched semicolon for $dataname starting at line [lindex [split $pos .] 0]\n"
664	}
665
666	$txt mark set $CIF(markcount).l "$pos linestart"
667	$txt mark set $CIF(markcount).r "$epos + 1c"
668	$txt mark gravity $CIF(markcount).l left
669	$txt mark gravity $CIF(markcount).r right
670	set item [$txt get "$pos linestart" "$epos +1c"]
671	# move forward past current token
672	set pos [$txt index "$epos + 1c"]
673	} elseif {[$txt get $pos] == "\""} {
674	# a quoted string -- find next quote
675	set epos [$txt search "\"" "$pos +1c" "$pos lineend"]
676	# skip over quotes followed by a non-blank
677	while {$epos != "" && \
678	[regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
679	set epos [$txt search "\"" "$epos +1c" "$pos lineend"]
680	}
681	# did we hit the end of line?
682	if {$epos == ""} {
683	set epos [$txt index "$pos lineend"]
684	append ${namespace}::block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
685	}
686	$txt mark set $CIF(markcount).l "$pos"
687	$txt mark set $CIF(markcount).r "$epos + 1c"
688	$txt mark gravity $CIF(markcount).l left
689	$txt mark gravity $CIF(markcount).r right
690	set item [$txt get $pos "$epos +1c"]
691	# move forward past current token
692	set pos [$txt index "$epos +2c"]
693	} elseif {[$txt get $pos] == {'}} {
694	# a quoted string -- find next quote
695	set epos [$txt search {'} "$pos +1c" "$pos lineend"]
696	# skip over quotes followed by a non-blank
697	while {$epos != "" && \
698	[regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
699	set epos [$txt search {'} "$epos +1c" "$pos lineend"]
700	}
701	# did we hit the end of line?
702	if {$epos == ""} {
703	set epos [$txt index "$pos lineend"]
704	append ${namespace}::block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
705	}
706	$txt mark set $CIF(markcount).l "$pos"
707	$txt mark set $CIF(markcount).r "$epos + 1c"
708	$txt mark gravity $CIF(markcount).l left
709	$txt mark gravity $CIF(markcount).r right
710	set item [$txt get $pos "$epos +1c"]
711	# move forward past current token
712	set pos [$txt index "$epos + 2 c"]
713	} elseif {[$txt get $pos] == {[}} {
714	# CIF v1.1 square bracket quotes
715	set count 1
716	set epos $pos
717	while {$count != 0} {
718	set epos [$txt search -regexp {[\]\[]} "$epos +1c"]
719	if {$epos == ""} {
720	# unmatched open square bracket
721	append ${namespace}::block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n"
722	set count 0
723	set epos [$txt index end]
724	} elseif {[$txt get $epos] == {]}} {
725	# close bracket -- decrement
726	incr count -1
727	} else {
728	# open bracket -- increment
729	incr count
730	}
731	}
732	$txt mark set $CIF(markcount).l "$pos"
733	$txt mark set $CIF(markcount).r "$epos + 1c"
734	$txt mark gravity $CIF(markcount).l left
735	$txt mark gravity $CIF(markcount).r right
736	set item [$txt get $pos "$epos +1c"]
737	# move forward past current token
738	set pos [$txt index "$epos + 2 c"]
739	} else {
740	# must be a single space-delimited value
741	$txt mark set $CIF(markcount).l $pos
742	$txt mark set $CIF(markcount).r $epos
743	$txt mark gravity $CIF(markcount).l left
744	$txt mark gravity $CIF(markcount).r right
745	set item $token
746	set pos [$txt index "$epos + 1 c"]
747	}
748	# a data item has been read
749
750	# store the data item
751	if {$loopflag >= 0} {
752	# if in a loop, increment the loop element counter to select the
753	# appropriate array element
754	incr loopflag
755	set i [expr ($loopflag - 1) % [llength $looplist]]
756	lappend ${namespace}::block${blocks}([lindex $looplist $i]) $CIF(markcount)
757	set ${namespace}::block${blocks}(lastmark) $CIF(markcount)
758	} elseif {$dataname == ""} {
759	# this is an error -- a data item where we do not expect one
760	append ${namespace}::block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n"
761	} else {
762	if {$blocks == 0} {
763	# an error -- a data name before a data_ block start
764	set ${namespace}::block${blocks}(data_) undefined
765	append ${namespace}::block${blocks}(errors) \
766	"Data name $dataname appears before a data_ block is defined (line [lindex [split $pos .] 0])\n"
767	}
768	catch {
769	if {[set ${namespace}::block${blocks}($dataname)] != ""} {
770	# this is an error -- repeated data name
771	append ${namespace}::block${blocks}(errors) \
772	"Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
773	}
774	}
775	set ${namespace}::block${blocks}($dataname) $CIF(markcount)
776	set ${namespace}::block${blocks}(lastmark) $CIF(markcount)
777	set dataname ""
778	}
779	}
780	$txt see 1.0
781	return $blocks
782	}
783
784	#------------------------------------------------------------------------------
785	# Create a CIF browser/editor
786	# $txt is a text widget with the entire CIF loaded
787	# blocklist contains the list of defined blocks (by #)
788	# selected is the list of blocks that will be expanded
789	# frame gives the name of the toplevel window to hold the browser
790	proc BrowseCIF {txt blocklist "selected {}" "frame .cif"} {
791	catch {destroy $frame}
792	toplevel $frame
793	wm title $frame "CIF Browser"
794	CIFOpenBrowser $frame
795	CIFBrowser $txt $blocklist $selected $frame
796	grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
797	}
798
799	# Populate a hierarchical CIF browser
800	# $txt is a text widget with the entire CIF loaded
801	# blocklist contains the list of defined blocks (by #)
802	# selected is the list of blocks that will be expanded
803	# frame gives the name of the toplevel or frame to hold the browser
804	proc CIFBrowser {txt blocklist "selected {}" "frame .cif"} {
805	global CIF CIFtreeindex CIF_dataname_index
806
807	if {$selected == ""} {set selected $blocklist}
808
809	# clear out old info, if any, from browser
810	eval $CIF(tree) delete [$CIF(tree) nodes root]
811	catch {unset CIFtreeindex}
812	# remove the loop counter frame from window & edit buttons from that frame
813	grid forget $CIF(LoopBar)
814	pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry)
815	# delete old contents of frame
816	set frame [$CIF(displayFrame) getframe]
817	eval destroy [grid slaves $frame]
818	set CIF(widgetlist) {}
819	# reset the scrollbars
820	$CIF(tree) see 0
821	$CIF(displayFrame) xview moveto 0
822	$CIF(displayFrame) yview moveto 0
823
824	# Bwidget seems to have problems with the name "1", so avoid it
825	set num 100
826	foreach n $blocklist {
827	global block$n
828	# make a list of data names in loops
829	set looplist {}
830	foreach loop [array names block$n loop_*] {
831	eval lappend looplist [set block${n}($loop)]
832	}
833	# put the block name
834	set blockname [set block${n}(data_)]
835	set open 0
836	if {[lsearch $selected $n] != -1} {set open 1}
837	$CIF(tree) insert end root block$n -text "_data_$blockname" \
838	-open $open -image [Bitmap::get folder]
839
840	# show errors, if any
841	foreach name [array names block$n errors] {
842	$CIF(tree) insert end block$n [incr num] -text "Parse-errors" \
843	-image [Bitmap::get undo] -data block$n
844	}
845	# loop over the names in each block
846	foreach name [lsort [array names block$n _*]] {
847	# don't include looped names
848	if {[lsearch $looplist $name] == -1} {
849	$CIF(tree) insert end block$n [incr num] -text $name \
850	-image [Bitmap::get file] -data block$n
851	set CIFtreeindex(block${n}$name) $num
852	}
853	}
854	foreach loop [lsort [array names block$n loop_*]] {
855	# make a list of categories used in the loop
856	set catlist {}
857	foreach name [lsort [set block${n}($loop)]] {
858	set category {}
859	catch {
860	set category [lindex \
861	[lindex $CIF_dataname_index($name) 1] 5]
862	}
863	if {$category != "" && [lsearch $catlist $category] == -1} {
864	lappend catlist $category
865	}
866	}
867
868	$CIF(tree) insert end block$n block${n}$loop \
869	-text "$loop ($catlist)" \
870	-image [Bitmap::get copy] -data "block$n loop"
871	set CIFtreeindex(block${n}$loop) block${n}$loop
872	foreach name [lsort [set block${n}($loop)]] {
873	$CIF(tree) insert end block${n}$loop [incr num] -text $name \
874	-image [Bitmap::get file] -data "block$n $loop"
875	set CIFtreeindex(block${n}$name) $num
876	}
877	}
878	}
879	$CIF(tree) bindImage <1> showCIFbyTreeID
880	$CIF(tree) bindText <1> showCIFbyTreeID
881	set CIF(tree_lastindex) $num
882	}
883
884	# Create the widgets for a hierarchical CIF browser in $frame
885	# (where $frame is a frame or toplevel)
886	# note that the BWidget package is required
887	proc CIFOpenBrowser {frame} {
888	global CIF
889	if [catch {package require BWidget}] {
890	tk_dialog .error {No BWidget} \
891	"Sorry, the CIF Browser requires the BWidget package" \
892	warning 0 Sorry
893	return
894	}
895
896	set pw [PanedWindow $frame.pw -side top]
897	grid $pw -sticky news -column 0 -row 0
898	set CIF(LoopBar) [frame $frame.f]
899	#grid $CIF(LoopBar) -sticky es -column 0 -row 1
900	set width 900
901	if {$width > [winfo screenwidth .]} {set width [winfo screenwidth .]}
902	grid columnconfigure $frame 0 -weight 1 -minsize $width
903	# shrink browser on small screens
904	set h 250
905	if {[winfo screenheight .] < 500} {set h 180}
906	grid rowconfigure $frame 0 -minsize $h -weight 1
907
908	# create a left hand side pane for the hierarchical tree
909	set pane [$pw add -weight 1]
910	set sw [ScrolledWindow $pane.lf \
911	-relief sunken -borderwidth 2]
912	set CIF(tree) [Tree $sw.tree \
913	-relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
914	-redraw 1]
915	# get the size of the font and adjust the line spacing accordingly
916	catch {
917	set font [option get $CIF(tree) font Canvas]
918	$CIF(tree) configure -deltay [font metrics $font -linespace]
919	}
920	bind $frame <KeyPress-Prior> "$CIF(tree) yview scroll -1 page"
921	bind $frame <KeyPress-Next> "$CIF(tree) yview scroll 1 page"
922	# bind $frame <KeyPress-Up> "$CIF(tree) yview scroll -1 unit"
923	# bind $frame <KeyPress-Down> "$CIF(tree) yview scroll 1 unit"
924	bind $frame <KeyPress-Home> "$CIF(tree) yview moveto 0"
925	#bind $frame <KeyPress-End> "$CIF(tree) yview moveto end" -- does not work
926	bind $frame <KeyPress-End> "$CIF(tree) yview scroll 99999999 page"
927	grid $sw
928	grid $sw -sticky news -column 0 -row 0
929	grid columnconfigure $pane 0 -minsize 275 -weight 1
930	grid rowconfigure $pane 0 -weight 1
931	$sw setwidget $CIF(tree)
932
933	# create a right hand side pane to show the value
934	set pane [$pw add -weight 4]
935	set sw [ScrolledWindow $pane.sw \
936	-relief sunken -borderwidth 2]
937	pack $sw -fill both -expand yes -side top
938
939	set CIF(AddtoLoopButton) [button $CIF(LoopBar).l -text "Add to loop"]
940	set CIF(DeleteLoopEntry) [button $CIF(LoopBar).d \
941	-text "Delete loop entry" -command DeleteCIFRow]
942	label $CIF(LoopBar).1 -text "Loop\nelement #"
943	set CIF(LoopSpinBox) [SpinBox $CIF(LoopBar).2 -range "1 1 1" -width 5]
944	pack $CIF(LoopBar).2 $CIF(LoopBar).1 -side right
945	set CIF(displayFrame) $sw.lb
946	set lb [ScrollableFrame::create $CIF(displayFrame) -width 400]
947	$sw setwidget $lb
948	}
949
950	# Warn to save changes that are not saved in a file
951	proc CheckForCIFEdits {} {
952	#puts "CheckForCIFEdits [info level [expr [info level]-1]]"
953	global CIF
954	set errorlist {}
955	set errorflag 0
956	set msg "The following edits cannot be saved due to errors:\n"
957	foreach widget $CIF(widgetlist) {
958	CheckChanges $widget 1
959	if {$CIF(errormsg) != ""} {
960	set errorflag 1
961	foreach err $CIF(errormsg) {
962	append msg " " $err \n
963	}
964	}
965
966	}
967	if {$errorflag} {
968	append msg \n {Do you want to make corrections, or discard these edits?}
969	set ans [MyMessageBox -parent . -title "Invalid edits" \
970	-message $msg -icon error -type "Correct Discard" \
971	-default correct]
972	if {$ans == "correct"} {
973	# if not, don't allow the mode/loop value to change
974	set CIF(editmode) 1
975	catch {
976	$CIF(LoopSpinBox) setvalue @$CIF(lastLoopIndex)
977	}
978	return 1
979	}
980	}
981	return 0
982	}
983
984	# showCIFbyTreeID is used in BrowseCIF to response to clicking on a tree widget
985	# shows the contents data name or a loop
986	proc showCIFbyTreeID {name} {
987	if {[CheckForCIFEdits]} return
988
989	global CIF
990	# code to allow multiple selection within loops
991	#set loopname [lindex [$CIF(tree) itemcget $name -data] 1]
992	#set addtolist 1
993	#if {$loopname == "" \|\| $loopname == "loop"} {set addtolist 0}
994	#foreach n $CIF(treeSelectedList) {
995	#if {$loopname != [lindex [$CIF(tree) itemcget $n -data] 1]} {
996	# set addtolist 0
997	# break
998	#}
999	#}
1000	#if {$addtolist} {
1001	#catch {$CIF(tree) itemconfigure $name -fill red}
1002	#lappend CIF(treeSelectedList) $name
1003	#} else {
1004	foreach n $CIF(treeSelectedList) {
1005	catch {$CIF(tree) itemconfigure $n -fill black}
1006	}
1007	set CIF(treeSelectedList) $name
1008	# for some reason, BWidget sometimes has problems doing this:
1009	# (but ignore the error)
1010	catch {$CIF(tree) itemconfigure $name -fill red}
1011	set CIF(lastShownTreeID) $name
1012	set pointer [$CIF(tree) itemcget $name -data]
1013	set dataname [lindex [$CIF(tree) itemcget $name -text] 0]
1014	showCIFbyDataname $pointer $dataname
1015	#}
1016	}
1017
1018	proc showCIFbyDataname {pointer dataname "loopindex {}"} {
1019	global CIF CIFtreeindex
1020	set CIF(lastShownItem) [list $pointer $dataname]
1021	# remove the loop counter frame from window & edit buttons from that frame
1022	grid forget $CIF(LoopBar)
1023	pack forget $CIF(AddtoLoopButton) $CIF(DeleteLoopEntry)
1024
1025	# delete old contents of frame
1026	set frame [$CIF(displayFrame) getframe]
1027	eval destroy [grid slaves $frame]
1028	# reset the scrollbars
1029	$CIF(displayFrame) xview moveto 0
1030	$CIF(displayFrame) yview moveto 0
1031	# leave room for a scrollbar
1032	grid columnconfig $frame 0 -minsize [expr \
1033	[winfo width [winfo parent $frame]] - 20]
1034	if {$pointer == ""} {
1035	return
1036	}
1037	# create list of widgets defined here
1038	set CIF(widgetlist) {}
1039
1040	# is this a looped data item?
1041	set block [lindex $pointer 0]
1042	if {[llength $pointer] == 2} {
1043	global $block
1044	# display contents of a rows of the loop
1045	if {[lindex $pointer 1] == "loop"} {
1046	if {$CIF(editmode)} {
1047	pack $CIF(DeleteLoopEntry) -side right
1048	pack $CIF(AddtoLoopButton) -side right
1049	$CIF(AddtoLoopButton) config -command "AddToCIFloop ${block} $dataname"
1050	}
1051	set looplist [set ${block}($dataname)]
1052	# get number of elements for first name
1053	set names [llength [set ${block}([lindex $looplist 0])]]
1054	# can't delete the only entry
1055	if {$names == 1 && $CIF(editmode)} {
1056	$CIF(DeleteLoopEntry) configure -state disabled
1057	} else {
1058	$CIF(DeleteLoopEntry) configure -state normal
1059	}
1060	$CIF(LoopSpinBox) configure -range "1 $names 1" \
1061	-command "ShowLoopVar ${block} $dataname" \
1062	-modifycmd "ShowLoopVar ${block} $dataname"
1063	set CIF(lastLoopIndex) {}
1064	if {$loopindex == ""} {
1065	$CIF(LoopSpinBox) setvalue first
1066	} else {
1067	$CIF(LoopSpinBox) setvalue @$loopindex
1068	}
1069	# show the loop counter frame
1070	grid $CIF(LoopBar) -sticky es -column 0 -row 1
1071	set row 0
1072	set i 0
1073	ShowDictionaryDefinition $looplist
1074	foreach var $looplist {
1075	incr i
1076	grid [TitleFrame $frame.$i -text $var -side left] \
1077	-column 0 -row $i -sticky ew
1078	set row $i
1079	set frame0 [$frame.$i getframe]
1080	DisplayCIFvalue $frame0.l $var 1 "" ${block}
1081	grid columnconfig $frame0 2 -weight 1
1082	}
1083	ShowLoopVar ${block} $dataname
1084	} else {
1085	# look at a single looped variable
1086	ShowDictionaryDefinition $dataname
1087	grid [TitleFrame $frame.0 -text $dataname -side left] \
1088	-column 0 -row 0 -sticky ew
1089	set row 0
1090	set i 0
1091	set frame0 [$frame.0 getframe]
1092	grid columnconfig $frame0 2 -weight 1
1093	# maximum number of entries
1094	set maxcols 100
1095	catch {
1096	set maxcols $CIF(maxRows)
1097	}
1098	if {[set l [llength [set ${block}($dataname)]]] > $maxcols} {
1099	grid [label $frame0.a$i -justify left \
1100	-text "$dataname has $l entries, too many to display by column" \
1101	] -sticky w -column 0 -row $i
1102	return
1103	}
1104	foreach mark [set ${block}($dataname)] {
1105	incr i
1106	if {$i == 1} {$CIF(txt) see $mark.l}
1107	set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1108	grid [label $frame0.a$i -justify left -text $i]\
1109	-sticky w -column 0 -row $i
1110	DisplayCIFvalue $frame0.b$i $dataname $i $value ${block} $i
1111	#grid $frame0.b$i -sticky new -column 1 -row $i
1112	}
1113	}
1114	} else {
1115	# unlooped data name
1116	global ${block}
1117	ShowDictionaryDefinition $dataname
1118	grid [TitleFrame $frame.0 -text $dataname -side left] \
1119	-column 0 -row 0 -sticky ew
1120	set row 0
1121	if {$dataname == "Parse-errors"} {
1122	set value [set ${block}(errors)]
1123	} elseif {$dataname == "Validation-errors"} {
1124	set value [set ${block}(validate)]
1125	} else {
1126	set mark [set ${block}($dataname)]
1127	set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1128	$CIF(txt) see $mark.l
1129	}
1130	set frame0 [$frame.0 getframe]
1131	grid columnconfig $frame0 2 -weight 1
1132	DisplayCIFvalue $frame0.l $dataname "" $value $block
1133	#grid $frame0.l -sticky w -column 1 -row 0
1134	}
1135	}
1136
1137	# redisplay the last entry shown in showCIFbyTreeID
1138	# this is used if the edit mode ($CIF(editmode)) changes or if edits are saved
1139	proc RepeatLastshowCIFvalue {} {
1140	global CIF
1141	if {[CheckForCIFEdits]} return
1142	set lastLoopIndex $CIF(lastLoopIndex)
1143
1144	catch {
1145	eval showCIFbyDataname $CIF(lastShownItem)
1146	# if we are in a loop, display the element
1147	if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} {
1148	$CIF(LoopSpinBox) setvalue @$lastLoopIndex
1149	ShowLoopVar [lindex [lindex $CIF(lastShownItem) 0] 0] \
1150	[lindex $CIF(lastShownItem) 1]
1151	}
1152
1153	}
1154	}
1155
1156	# used in BrowseCIF in response to the spinbox
1157	# show entries in a specific row of a loop
1158	proc ShowLoopVar {array loop} {
1159	global $array CIF
1160	# check for unsaved changes here
1161	if {$CIF(lastLoopIndex) != ""} {
1162	if {[CheckForCIFEdits]} return
1163	}
1164
1165	set looplist [set ${array}($loop)]
1166	set index [$CIF(LoopSpinBox) getvalue]
1167	if {$index < 0} {
1168	$CIF(LoopSpinBox) setvalue first
1169	set index [$CIF(LoopSpinBox) getvalue]
1170	} elseif {$index > [llength [set ${array}([lindex $looplist 0])]]} {
1171	$CIF(LoopSpinBox) setvalue last
1172	set index [$CIF(LoopSpinBox) getvalue]
1173	}
1174	set CIF(lastLoopIndex) $index
1175	set frame [$CIF(displayFrame) getframe]
1176	set i 0
1177	foreach var $looplist {
1178	incr i
1179	set mark [lindex [set ${array}($var)] $index]
1180	# ignore invalid entries -- should not happen
1181	if {$mark == ""} {
1182	$CIF(LoopSpinBox) setvalue first
1183	return
1184	}
1185	set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1186	if {$i == 1} {$CIF(txt) see $mark.l}
1187	if {$CIF(editmode)} {
1188	global CIFeditArr CIFinfoArr
1189	set widget [$frame.$i getframe].l
1190	set CIFeditArr($widget) $value
1191	switch [winfo class $widget] {
1192	Text {
1193	$widget delete 0.0 end
1194	$widget insert end $value
1195	}
1196	Entry {
1197	$widget config -fg black
1198	}
1199	}
1200	set CIFinfoArr($widget) [lreplace $CIFinfoArr($widget) 2 2 $index]
1201	} else {
1202	[$frame.$i getframe].l config -text $value
1203	}
1204	}
1205	}
1206
1207	# scan a number in crystallographic uncertainty representation
1208	# i.e.: 1.234(12), 1234(23), 1.234e-2(14), -1.234-08(14), etc.
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 {}
1214	}
1215	# parse off an exponent, if present
1216	if {[regexp {([-+.0-9]+)[EeDd]([-+0-9]+)} $a x a1 exp]} {
1217	# [+-]###.###e+## or [+-]###.###D-## etc.
1218	set a $a1
1219	# remove leading zeros from exponent
1220	regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
1221	} elseif {[regexp {([-+.0-9]+)([-+][0-9]+)} $a x a1 exp]} {
1222	# [+-]###.###+## or [+-]###.###-## etc. [no
1223	set a $a1
1224	# remove leading zeros from exponent
1225	regsub {([+-]?)0*([0-9]+)} $exp {\1\2} exp
1226	} else {
1227	set exp 0
1228	}
1229	# now parse the main number and count the digits after the decimal
1230	set a2 {}
1231	set a3 {}
1232	regexp {^([-+0-9])\.?([0-9])$} $a x a2 a3
1233	set l [string length $a3]
1234
1235	set val .
1236	set error {}
1237	if {[catch {
1238	set val [expr ${a2}.${a3} * pow(10,$exp)]
1239	if {$err != ""} {
1240	set error [expr $err*pow(10,$exp-$l)]
1241	}
1242	}]} {
1243	# something above was invalid
1244	if {$err != ""} {
1245	return "$val ."
1246	} else {
1247	return $val
1248	}
1249	}
1250	if {$error == ""} {
1251	return $val
1252	} else {
1253	return [list $val $error]
1254	}
1255	}
1256
1257	# a stand-alone routine for testing: Select, read and browse a CIF
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
1272	pleasewait "Reading CIF from file"
1273	set blocks [ParseCIF $file]
1274	if {$blocks == ""} {
1275	donewait
1276	MessageBox -parent . -type ok -icon warning \
1277	-message "Note: no valid CIF blocks were read from file $filename"
1278	return
1279	}
1280	catch {donewait}
1281	set allblocks {}
1282	for {set i 1} {$i <= $blocks} {incr i} {
1283	lappend allblocks $i
1284	}
1285	if {$allblocks != ""} {
1286	BrowseCIF $allblocks "" .cif
1287	# wait for the window to close
1288	tkwait window .cif
1289	} else {
1290	puts "no blocks read"
1291	}
1292	# clean up -- get rid of the CIF arrays
1293	for {set i 1} {$i <= $blocks} {incr i} {
1294	global block$i
1295	catch {unset block$i}
1296	}
1297	}
1298
1299	# this takes a block of text, strips off the quotes ("", '', [] or ;;)
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
1320	# exceed CIF(maxlinelength) [defaults to 80] characters/line
1321	proc ReplaceMarkedText {txt mark value} {
1322	$txt configure -state normal
1323	# is this a multi-line string?
1324	set num [string first \n $value]
1325	set l [string length $value]
1326	# are there spaces in the string?
1327	set spaces [string first " " $value]
1328	# if no, are there any square brackets? -- treat them as requiring quotes
1329	if {$spaces == -1} {set spaces [string first {[} $value]}
1330	# are there any reserved strings inside $value? If so, it must be quoted
1331	if {$spaces == -1} {
1332	set tmp [string toupper $value]
1333	foreach s {DATA_ LOOP_ SAVE_ STOP_ GLOBAL_} {
1334	if {[set spaces [string first $s $tmp]] != -1} break
1335	}
1336	}
1337	# are there quotes inside the string?
1338	set doublequote [string first "\"" $value]
1339	set singlequote [string first {'} $value]
1340	# if we have either type of quotes, use semicolon quoting
1341	if {$singlequote != -1 && $doublequote != -1} {set num $l}
1342
1343	# lines longer than 78 characters with spaces need to be treated
1344	# as multiline
1345	if {$num == -1 && $l > 77 && $spaces != -1} {
1346	set num $l
1347	}
1348	if {$num != -1} {
1349	set tmp {}
1350	if {[lindex [split [$txt index $mark.l] .] 1] != 0} {
1351	append tmp \n
1352	}
1353	append tmp ";"
1354	if {$num > 78} {
1355	append tmp \n
1356	} else {
1357	append tmp " "
1358	}
1359	append tmp $value "\n;"
1360	# is there something else on the line?
1361	set restofline [$txt get $mark.r [lindex [split [$txt index $mark.r] .] 0].end]
1362	if {[string trim $restofline] != ""} {
1363	append tmp \n
1364	}
1365	$txt delete ${mark}.l ${mark}.r
1366	$txt insert ${mark}.l $tmp
1367	$txt configure -state disabled
1368	return
1369	} elseif {($spaces != -1 \|\| [string trim $value] == "") \
1370	&& $doublequote == -1} {
1371	# use doublequotes, unless doublequotes are present inside the string
1372	set tmp "\""
1373	append tmp $value "\""
1374	} elseif {$spaces != -1 \|\| [string trim $value] == ""} {
1375	# use single quotes, since doublequotes are present inside the string
1376	set tmp {'}
1377	append tmp $value {'}
1378	} else {
1379	# no quotes needed
1380	set tmp $value
1381	}
1382	# is there room on the beginning of the line to add the string?
1383	set l [string length $tmp]
1384	set pos [lindex [split [$txt index $mark.l] .] 0]
1385	if {$l + [string length [$txt get $pos.0 $mark.l]] <= 79} {
1386	# will fit
1387	$txt delete ${mark}.l ${mark}.r
1388	$txt insert ${mark}.l $tmp
1389	} else {
1390	# no, stick a CR in front of string
1391	$txt delete ${mark}.l ${mark}.r
1392	$txt insert ${mark}.l \n$tmp
1393	}
1394	# is rest of the line after the inserted string still too long?
1395	set pos [lindex [split [$txt index $mark.r] .] 0]
1396	if {[string length [$txt get $pos.0 $pos.end]] > 79} {
1397	$txt insert $mark.r \n
1398	}
1399	$txt configure -state disabled
1400	}
1401
1402	# return the dictionary definition for a list of CIF data names
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 {}
1417	set def {start}
1418	set nlist {}
1419	# merge items with duplicate definitions
1420	foreach item $l {
1421	# is this the first loop through?
1422	foreach {dataname pointer} $item {}
1423	if {$def == "start"} {
1424	foreach {nlist pp} $item {}
1425	set def [ReadCIFDefinition $pp]
1426	} elseif {$pp == $pointer} {
1427	# same as last
1428	lappend nlist $dataname
1429	} else {
1430	# add the last entry to the list
1431	set file [lindex $pp 0]
1432	set pp $pointer
1433	lappend dictdefs [list $nlist $def $file]
1434	set nlist $dataname
1435	if {$pointer == ""} {
1436	set def { Undefined dataname}
1437	} else {
1438	# lookup name
1439	set def [ReadCIFDefinition $pointer]
1440	}
1441	}
1442	}
1443	set file [lindex $pointer 0]
1444	lappend dictdefs [list $nlist $def $file]
1445	return $dictdefs
1446	}
1447
1448	# read the CIF definition for a dataname. The pointer contains 3 values
1449	# a filename, the number of characters from the start of the file and
1450	# the length of the definition.
1451	proc ReadCIFDefinition {pointer} {
1452	global CIF CIF_file_paths
1453	set file {}
1454	set loc {}
1455	set line {}
1456	foreach {file loc len} $pointer {}
1457	if {$file != "" && $loc != "" && $loc != ""} {
1458	set fp {}
1459	if {[array names CIF_file_paths $file] != ""} {
1460	catch {set fp [open $CIF_file_paths($file) r]}
1461	if {$fp == ""} return
1462	} elseif {[array names CIF_file_paths] != ""} {
1463	return
1464	} else {
1465	# support legacy applications using CIF(cif_path)
1466	foreach path $CIF(cif_path) {
1467	catch {set fp [open [file join $path $file] r]}
1468	if {$fp != ""} break
1469	}
1470	}
1471	if {$fp == ""} return
1472	fconfigure $fp -translation binary
1473	catch {
1474	seek $fp $loc
1475	set line [read $fp $len]
1476	close $fp
1477	# remove line ends & superfluous spaces
1478	regsub -all {\n} [StripQuotes $line] { } line
1479	regsub -all {\r} $line { } line
1480	regsub -all { +} $line { } line
1481	# regsub -all { +} [StripQuotes $line] { } line
1482	}
1483	}
1484	return $line
1485	}
1486
1487	proc ValidateCIFName {dataname} {
1488	global CIF_dataname_index
1489	if {[
1490	catch {
1491	set CIF_dataname_index($dataname)
1492	}
1493	]} {return "warning: dataname $dataname not defined"}
1494	}
1495
1496	# validates that a CIF value is valid for a specific dataname
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 {
1503	foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {}
1504	}]} {return}
1505	if {$type == "c"} {
1506	# string type constant
1507	set item [StripQuotes $item]
1508	# is it enumerated?
1509	if {$elist != ""} {
1510	# check it against the list of values
1511	foreach i [concat $elist . ?] {
1512	if {[string tolower $item] == [string tolower [lindex $i 0]]} {return}
1513	}
1514	return "error: value \"$item\" is not an allowed option for $dataname"
1515	} else {
1516	# check it for line lengths
1517	set l 0
1518	set err {}
1519	foreach line [split $item \n] {
1520	incr l
1521	if {[string length $line] > $maxlinelength} {lappend err $l}
1522	}
1523	if {$err != ""} {return "error: line(s) $err are too long"}
1524	}
1525	return
1526	} elseif {$type == ""} {
1527	return "error: dataname $dataname is not used for CIF data items"
1528	} elseif {$type == "n"} {
1529	# validate numbers
1530	set unquoted [StripQuotes $item]
1531	if {$unquoted == "?" \|\| $unquoted == "."} return
1532	if {$unquoted != $item} {
1533	set err "\nwarning: number $item is quoted for $dataname"
1534	set item $unquoted
1535	} else {
1536	set err {}
1537	}
1538	set v $item
1539	# remove s.u., if allowed & present
1540	set vals [ParseSU $item]
1541	if {[set v [lindex $vals 0]] == "."} {
1542	return "error: value \"$item\" is not a valid number for $dataname$err"
1543	}
1544	if {$esd} {
1545	if {[lindex $vals 1] == "."} {
1546	return "error: value \"$item\" for $dataname has an invalid uncertainty (esd)$err"
1547	}
1548	} elseif {[llength $vals] == 2} {
1549	return "error: \"$item\" is invalid for $dataname, an uncertainty (esd) is not allowed$err"
1550	}
1551
1552	# now validate the range
1553	if {$range != ""} {
1554	# is there a decimal point in the range?
1555	set integer 0
1556	if {[string first . $range] == -1} {set integer 1}
1557	# pull out the range
1558	foreach {min max} [split $range :] {}
1559	if {$integer && int($v) != $v} {
1560	return "warning: value \"$item\" is expected to be an integer for $dataname$err"
1561	}
1562	if {$min != ""} {
1563	if {$v < $min} {
1564	return "error: value \"$item\" is too small for $dataname (allowed range $range)$err"
1565	}
1566	}
1567	if {$max != ""} {
1568	if {$v > $max} {
1569	return "error: value \"$item\" is too big for $dataname(allowed range $range)$err"
1570	}
1571	}
1572	}
1573	return $err
1574	}
1575	return {}
1576	}
1577
1578	# displays the dictionary definitions in variable defs into a text widget
1579	proc ShowDictionaryDefinition {defs} {
1580	global CIF
1581	set deflist [GetCIFDefinitions $defs]
1582	catch {
1583	$CIF(defBox) delete 1.0 end
1584	foreach d $deflist {
1585	foreach {namelist definition file} $d {}
1586	foreach n $namelist {
1587	$CIF(defBox) insert end $n dataname
1588	$CIF(defBox) insert end \n
1589	}
1590	$CIF(defBox) insert end \n
1591	if {$definition == ""} {
1592	$CIF(defBox) insert end "No definition found\n\n"
1593	} else {
1594	$CIF(defBox) insert end $definition
1595	$CIF(defBox) insert end "\n\[$file\]\n\n"
1596	}
1597
1598	}
1599	$CIF(defBox) tag config dataname -background yellow
1600	}
1601	}
1602
1603	# create a widget to display a CIF value
1604	proc DisplayCIFvalue {widget dataname loopval value block "row 0"} {
1605	global CIFeditArr CIFinfoArr
1606	global CIF CIF_dataname_index
1607	if {[
1608	catch {
1609	foreach {type range elist esd units category loopallow} [lindex $CIF_dataname_index($dataname) 1] {}
1610	}
1611	]} {
1612	set type c
1613	set elist {}
1614	}
1615
1616	lappend CIF(widgetlist) $widget
1617	set CIFinfoArr($widget) {}
1618
1619	if $CIF(editmode) {
1620	if {$loopval != ""} {
1621	set widgetinfo [list $dataname $block [expr $loopval -1]]
1622	} else {
1623	set widgetinfo [list $dataname $block 0]
1624	}
1625	set CIFeditArr($widget) $value
1626	set CIFinfoArr($widget) $widgetinfo
1627
1628	if {$type == "n"} {
1629	entry $widget -justify left -textvariable CIFeditArr($widget)
1630	bind $widget <Leave> "CheckChanges $widget"
1631	grid $widget -sticky nsw -column 1 -row $row
1632	if {$units != ""} {
1633	set ws "${widget}u"
1634	label $ws -text "($units)" -bg yellow
1635	grid $ws -sticky nsw -column 2 -row $row
1636	}
1637	} elseif {$elist != ""} {
1638	set enum {}
1639	foreach e $elist {
1640	lappend enum [lindex $e 0]
1641	}
1642	tk_optionMenu $widget CIFeditArr($widget) ""
1643	FixBigOptionMenu $widget $enum "CheckChanges $widget"
1644	AddSpecialEnumOpts $widget "CheckChanges $widget"
1645	grid $widget -sticky nsw -column 1 -row $row
1646	} else {
1647	# count the number of lines in the text
1648	set nlines [llength [split $value \n]]
1649	if {$nlines < 1} {
1650	set nlines 1
1651	} elseif {$nlines > 10} {
1652	set nlines 10
1653	}
1654	set ws "${widget}s"
1655	text $widget -height $nlines -width 80 -yscrollcommand "$ws set"
1656	scrollbar $ws -command "$widget yview" -width 10 -bd 1
1657	$widget insert end $value
1658	bind $widget <Leave> "CheckChanges $widget"
1659	if {$nlines > 1} {
1660	grid $ws -sticky nsew -column 1 -row $row
1661	grid $widget -sticky nsew -column 2 -row $row
1662	} else {
1663	grid $widget -sticky nsew -column 1 -columnspan 2 -row $row
1664	}
1665	}
1666	} else {
1667	label $widget -bd 2 -relief groove \
1668	-justify left -anchor w -text $value
1669	grid $widget -sticky nsw -column 1 -row $row
1670	if {$type == "n" && $units != ""} {
1671	set ws "${widget}u"
1672	label $ws -text "($units)" -bg yellow
1673	grid $ws -sticky nsw -column 2 -row $row
1674	}
1675	}
1676	}
1677
1678	# this is called to see if the user has changed the value for a CIF
1679	# data item and to validate it.
1680	# save the change if $save is 1
1681	# return 1 if the widget contents has changed
1682	proc CheckChanges {widget "save 0"} {
1683	global CIFeditArr CIFinfoArr CIF
1684	# maximum line length
1685	set maxlinelength 80
1686	catch {set maxlinelength $CIF(maxlinelength)}
1687
1688	set CIF(errormsg) {}
1689
1690	if {![winfo exists $widget]} return
1691
1692	set dataname {}
1693	catch {
1694	foreach {dataname block index} $CIFinfoArr($widget) {}
1695	}
1696	# if this widget is a label, the info above will not be defined & checks are not needed
1697	if {$dataname == ""} {return 0}
1698	if {$dataname == "Parse-errors"} {return 0}
1699	if {$dataname == "Validation-errors"} {return 0}
1700
1701	global ${block}
1702	set mark [lindex [set ${block}($dataname)] $index]
1703	if {$mark == ""} return
1704	set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1705
1706	# validate the entry
1707	set error {}
1708	set err {}
1709	switch [winfo class $widget] {
1710	Text {
1711	set current [string trim [$widget get 1.0 end]]
1712	set l 0
1713	foreach line [set linelist [split $current \n]] {
1714	incr l
1715	if {[string length $line] > $maxlinelength} {
1716	lappend err $l
1717	lappend error "Error: line $l for $dataname is >$maxlinelength characters"
1718	}
1719	}
1720	if {$err != ""} {
1721	foreach l $err {
1722	$widget tag add error $l.0 $l.end
1723	}
1724	$widget tag config error -foreground red
1725	} else {
1726	$widget tag delete error
1727	}
1728	# see if box should expand
1729	set clines [$widget cget -height]
1730	if {$clines <= 2 && \
1731	[string trim $orig] != [string trim $current]} {
1732	# count the number of lines in the text
1733	set nlines [llength $linelist]
1734	if {[lindex $linelist end] == ""} {incr nlines -1}
1735	if {$nlines == 2} {
1736	$widget config -height 2
1737	} elseif {$nlines > 2} {
1738	set i [lsearch [set s [grid info $widget]] -row]
1739	set row [lindex $s [expr 1+$i]]
1740	$widget config -height 3
1741	set ws "${widget}s"
1742	grid $ws -sticky nsew -column 1 -row $row
1743	grid $widget -sticky nsew -column 2 -row $row
1744	}
1745	}
1746	}
1747	Entry {
1748	set current [string trim [$widget get]]
1749	set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current]
1750	if {$err != "" && \
1751	[string tolower [lindex $err 0]] != "warning:"} {
1752	lappend error $err
1753	$widget config -fg red
1754	} else {
1755	$widget config -fg black
1756	}
1757	}
1758	Menubutton {
1759	set current $CIFeditArr($widget)
1760	}
1761	Label {
1762	return 0
1763	}
1764	}
1765	if {[string trim $orig] != [string trim $current]} {
1766	if {$err != ""} {
1767	set CIF(errormsg) $error
1768	} elseif {$save} {
1769	SaveCIFedits $widget
1770	return 0
1771	}
1772	return 1
1773	}
1774	return 0
1775	}
1776
1777	# save the CIF edits into the CIF text widget
1778	proc SaveCIFedits {widget} {
1779	global CIFeditArr CIFinfoArr CIF
1780
1781	foreach {dataname block index} $CIFinfoArr($widget) {}
1782	global ${block}
1783	set mark [lindex [set ${block}($dataname)] $index]
1784	set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1785	switch [winfo class $widget] {
1786	Text {
1787	set current [string trim [$widget get 1.0 end]]
1788	}
1789	Entry {
1790	set current [string trim [$widget get]]
1791	}
1792	Menubutton {
1793	set current $CIFeditArr($widget)
1794	}
1795	}
1796	# save for undo & clear the redo list
1797	set CIF(redolist) {}
1798	if {[lindex [lindex $CIF(lastShownItem) 0] 1] == "loop"} {
1799	lappend CIF(undolist) [list $mark $orig \
1800	$CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1801	} else {
1802	lappend CIF(undolist) [list $mark $orig \
1803	$CIF(lastShownItem) $CIF(lastShownTreeID)]
1804	}
1805	# count it
1806	incr CIF(changes)
1807	# make the change
1808	ReplaceMarkedText $CIF(txt) $mark $current
1809	}
1810
1811	# add a new "row" to a CIF loop. At least for now, we only add at the end.
1812	proc AddToCIFloop {block loop} {
1813	global $block CIF
1814	# check for unsaved changes here
1815	if {[CheckForCIFEdits]} return
1816
1817	$CIF(txt) configure -state normal
1818	set looplist [set ${block}($loop)]
1819	set length [llength [set ${block}([lindex $looplist 0])]]
1820	# find the line following the last entry in the list
1821	set var [lindex $looplist end]
1822	set line [lindex [split [\
1823	$CIF(txt) index [lindex [set ${block}($var)] end].r \
1824	] .] 0]
1825	incr line
1826	set epos $line.0
1827	$CIF(txt) insert $epos \n
1828
1829	# insert a ? token for each entry & add to marker list for each variable
1830	set addlist {}
1831	foreach var $looplist {
1832	# go to next line?
1833	if {[string length \
1834	[$CIF(txt) get "$epos linestart" "$epos lineend"]\
1835	] > 78} {
1836	$CIF(txt) insert $epos \n
1837	set epos [$CIF(txt) index "$epos + 1c"]
1838	}
1839	$CIF(txt) insert $epos "? "
1840	incr CIF(markcount)
1841	$CIF(txt) mark set $CIF(markcount).l "$epos"
1842	$CIF(txt) mark set $CIF(markcount).r "$epos + 1c"
1843	$CIF(txt) mark gravity $CIF(markcount).l left
1844	$CIF(txt) mark gravity $CIF(markcount).r right
1845	set epos [$CIF(txt) index "$epos + 2c"]
1846	set index [llength [set ${block}($var)]]
1847	lappend ${block}($var) $CIF(markcount)
1848	lappend addlist [list $CIF(markcount) $var $index $block]
1849	}
1850	incr CIF(changes)
1851	lappend CIF(undolist) [list "loop add" $addlist \
1852	$CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1853	set CIF(redolist) {}
1854
1855	# now show the value we have added
1856	set frame [$CIF(displayFrame) getframe]
1857	set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1858	incr max
1859	$CIF(LoopSpinBox) configure -range "1 $max 1"
1860	$CIF(LoopSpinBox) setvalue last
1861	ShowLoopVar $block $loop
1862	$CIF(txt) configure -state disabled
1863	$CIF(DeleteLoopEntry) configure -state normal
1864	}
1865
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
1909	$CIF(txt) configure -state normal
1910	set deletelist {}
1911	foreach widget $CIF(widgetlist) {
1912	foreach {dataname block index} $CIFinfoArr($widget) {}
1913	global $block
1914	set mark [lindex [set ${block}($dataname)] $index]
1915	set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]
1916	lappend deletelist [list $mark $dataname $index $block $orig]
1917	$CIF(txt) delete $mark.l $mark.r
1918	set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
1919	}
1920	set CIF(redolist) {}
1921	lappend CIF(undolist) [list "loop delete" $deletelist \
1922	$CIF(lastShownItem) $CIF(lastShownTreeID) $CIF(lastLoopIndex)]
1923	# count it
1924	incr CIF(changes)
1925
1926	$CIF(txt) configure -state disabled
1927
1928	set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1929	incr max -1
1930	$CIF(LoopSpinBox) configure -range "1 $max 1"
1931	if {$index >= $max} {set index $max; incr index -1}
1932	$CIF(LoopSpinBox) setvalue @$index
1933	if {$max == 1} {$CIF(DeleteLoopEntry) configure -state disabled}
1934	# don't check for changes
1935	set CIF(lastLoopIndex) {}
1936	ShowLoopVar $block [lindex $CIF(lastShownItem) 1]
1937	}
1938
1939	# display & highlight a line in the CIF text viewer
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
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
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	#----------------------------------------------------------------------
3284	# initialize misc variables
3285	set CIF(changes) 0
3286	set CIF(widgetlist) {}
3287	set CIF(lastShownItem) {}
3288	set CIF(lastLoopIndex) {}
3289	set CIF(editmode) 0
3290	set CIF(undolist) {}
3291	set CIF(redolist) {}
3292	set CIF(treeSelectedList) {}
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: