Context Navigation

source: branches/sandbox/gsascmds.tcl @ 1119

Last change on this file since 1119 was 1119, checked in by toby, 13 years ago
conflicted
Property svn:keywords set to `Author Date Revision Id`
File size: 139.3 KB

Line
1	# $Id: gsascmds.tcl 1119 2011-03-23 21:57:24Z toby $
2	#------------------------------------------------------------------------------
3	# display routines
4	#------------------------------------------------------------------------------
5	# Message box code that centers the message box over the parent.
6	# or along the edge, if too close,
7	# but leave a border along +x & +y for reasons I don't remember
8	# It also allows the button names to be defined using
9	# -type $list -- where $list has a list of button names
10	# larger messages are placed in a scrolled text widget
11	# capitalization is now ignored for -default
12	# The command returns the name button in all lower case letters
13	# otherwise see tk_messageBox for a description
14	#
15	# This is a modification of tkMessageBox (msgbox.tcl v1.5)
16	#
17	proc MyMessageBox {args} {
18	global tkPriv tcl_platform
19
20	set w tkPrivMsgBox
21	upvar #0 $w data
22
23	#
24	# The default value of the title is space (" ") not the empty string
25	# because for some window managers, a
26	# wm title .foo ""
27	# causes the window title to be "foo" instead of the empty string.
28	#
29	set specs {
30	{-default "" "" ""}
31	{-icon "" "" "info"}
32	{-message "" "" ""}
33	{-parent "" "" .}
34	{-title "" "" " "}
35	{-type "" "" "ok"}
36	{-helplink "" "" ""}
37	}
38
39	tclParseConfigSpec $w $specs "" $args
40
41	if {[lsearch {info warning error question} $data(-icon)] == -1} {
42	error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
43	}
44	if {![string compare $tcl_platform(platform) "macintosh"]} {
45	switch -- $data(-icon) {
46	"error" {set data(-icon) "stop"}
47	"warning" {set data(-icon) "caution"}
48	"info" {set data(-icon) "note"}
49	}
50	}
51
52	if {![winfo exists $data(-parent)]} {
53	error "bad window path name \"$data(-parent)\""
54	}
55
56	switch -- $data(-type) {
57	abortretryignore {
58	set buttons {
59	{abort -width 6 -text Abort -under 0}
60	{retry -width 6 -text Retry -under 0}
61	{ignore -width 6 -text Ignore -under 0}
62	}
63	}
64	ok {
65	set buttons {
66	{ok -width 6 -text OK -under 0}
67	}
68	if {![string compare $data(-default) ""]} {
69	set data(-default) "ok"
70	}
71	}
72	okcancel {
73	set buttons {
74	{ok -width 6 -text OK -under 0}
75	{cancel -width 6 -text Cancel -under 0}
76	}
77	}
78	retrycancel {
79	set buttons {
80	{retry -width 6 -text Retry -under 0}
81	{cancel -width 6 -text Cancel -under 0}
82	}
83	}
84	yesno {
85	set buttons {
86	{yes -width 6 -text Yes -under 0}
87	{no -width 6 -text No -under 0}
88	}
89	}
90	yesnocancel {
91	set buttons {
92	{yes -width 6 -text Yes -under 0}
93	{no -width 6 -text No -under 0}
94	{cancel -width 6 -text Cancel -under 0}
95	}
96	}
97	default {
98	# error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
99	foreach item $data(-type) {
100	lappend buttons [list [string tolower $item] -text $item -under 0]
101	}
102	}
103	}
104
105	if {[string compare $data(-default) ""]} {
106	set valid 0
107	foreach btn $buttons {
108	if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
109	set valid 1
110	break
111	}
112	}
113	if {!$valid} {
114	error "invalid default button \"$data(-default)\""
115	}
116	}
117
118	# 2. Set the dialog to be a child window of $parent
119	#
120	#
121	if {[string compare $data(-parent) .]} {
122	set w $data(-parent).__tk__messagebox
123	} else {
124	set w .__tk__messagebox
125	}
126
127	# 3. Create the top-level window and divide it into top
128	# and bottom parts.
129
130	catch {destroy $w}
131	toplevel $w -class Dialog
132	wm title $w $data(-title)
133	wm iconname $w Dialog
134	wm protocol $w WM_DELETE_WINDOW { }
135	# Make the message box transient if the parent is viewable.
136	if {[winfo viewable [winfo toplevel $data(-parent)]] } {
137	wm transient $w $data(-parent)
138	}
139
140	catch {
141	if {[string equal [tk windowingsystem] "classic"]
142	\|\| [string equal [tk windowingsystem] "aqua"]} {
143	unsupported::MacWindowStyle style $w dBoxProc
144	}
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	wm deiconify $w
266
267	# 8. Set a grab and claim the focus too.
268
269	catch {set oldFocus [focus]}
270	catch {set oldGrab [grab current $w]}
271	catch {
272	grab $w
273	if {[string compare $data(-default) ""]} {
274	focus $w.[string tolower $data(-default)]
275	} else {
276	focus $w
277	}
278	}
279
280	# 9. Wait for the user to respond, then restore the focus and
281	# return the index of the selected button. Restore the focus
282	# before deleting the window, since otherwise the window manager
283	# may take the focus away so we can't redirect it. Finally,
284	# restore any grab that was in effect.
285
286	tkwait variable tkPriv(button)
287	catch {focus $oldFocus}
288	destroy $w
289	catch {grab $oldGrab}
290	return $tkPriv(button)
291	}
292
293	# tell'em what is happening
294	# message is a text message to display
295	# statusvar is a variable name containing a message that gets updated
296	# parent is the name of the parent window
297	# button defines a button for the window. Element 0 in $button is the
298	# text for the button and Element 1 is the command to execute.
299	proc pleasewait {{message {}} {statusvar {}} {parent .} {button ""}} {
300	catch {destroy .msg}
301	toplevel .msg
302	wm transient .msg [winfo toplevel .]
303	pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5
304	pack [message .msg.f.m -text "Please wait $message"] -side top
305	if {$statusvar != ""} {
306	pack [label .msg.f.status -textvariable $statusvar] -side top
307	}
308	if {$button != ""} {
309	pack [button .msg.f.button -text [lindex $button 0] \
310	-command [lindex $button 1]] -side top
311	}
312	wm withdraw .msg
313	update idletasks
314	# place the message on top of the parent window
315	set x [expr [winfo x $parent] + [winfo width $parent]/2 - \
316	[winfo reqwidth .msg]/2 - [winfo vrootx $parent]]
317	if {$x < 0} {set x 0}
318	set y [expr [winfo y $parent] + [winfo height $parent]/2 - \
319	[winfo reqheight .msg]/2 - [winfo vrooty $parent]]
320	if {$y < 0} {set y 0}
321	wm geom .msg +$x+$y
322	wm deiconify .msg
323	global makenew
324	set makenew(OldGrab) ""
325	set makenew(OldFocus) ""
326	# save focus & grab
327	catch {set makenew(OldFocus) [focus]}
328	catch {set makenew(OldGrab) [grab current .msg]}
329	catch {grab .msg}
330	update
331	}
332
333	# clear the message
334	proc donewait {} {
335	global makenew
336	catch {destroy .msg}
337	# reset focus & grab
338	catch {
339	if {$makenew(OldFocus) != ""} {
340	focus $makenew(OldFocus)
341	}
342	}
343	catch {
344	if {$makenew(OldGrab) != ""} {
345	grab $makenew(OldGrab)
346	}
347	}
348	}
349
350	proc putontop {w "center 0"} {
351	# center window $w above its parent and make it stay on top
352	set wpt [winfo toplevel [set wp [winfo parent $w]]]
353	if {[winfo viewable $wpt]} {
354	wm transient $w $wpt
355	}
356	wm withdraw $w
357	update idletasks
358	if {$center} {
359	set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
360	- [winfo vrootx $wpt]}]
361	set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
362	- [winfo vrooty $wpt]}]
363	} else {
364	# center the new window in the middle of the parent
365	set x [expr [winfo x $wpt] + [winfo width $wpt]/2 - \
366	[winfo reqwidth $w]/2 - [winfo vrootx $wpt]]
367	if {$x < 0} {set x 0}
368	set xborder 10
369	if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
370	incr x [expr [winfo screenwidth $w] - \
371	($x+[winfo reqwidth $w] + $xborder)]
372	}
373	set y [expr [winfo y $wpt] + [winfo height $wpt]/2 - \
374	[winfo reqheight $w]/2 - [winfo vrooty $wpt]]
375	if {$y < 0} {set y 0}
376	set yborder 25
377	if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
378	incr y [expr [winfo screenheight $w] - \
379	($y+[winfo reqheight $w] + $yborder)]
380	}
381	}
382	wm geometry $w +$x+$y
383	wm deiconify $w
384
385	global makenew
386	# set grab & focus; use new approach for 8.3 & later
387	if {[info proc ::tk::SetFocusGrab] == ""} {
388	set makenew(OldGrab) ""
389	set makenew(OldFocus) ""
390	catch {set makenew(OldFocus) [focus]}
391	catch {set makenew(OldGrab) [grab current $w]}
392	catch {grab $w}
393	} else {
394	set makenew(OldGrab) $w
395	set makenew(OldFocus) $w
396	::tk::SetFocusGrab $w $w
397	}
398	}
399
400	# restore focus after putontop has completed
401	proc afterputontop {} {
402	global makenew
403	# reset focus & grab; use new approach for 8.3 & later
404	if {[info proc ::tk::SetFocusGrab] == ""} {
405	if {$makenew(OldFocus) != ""} {
406	catch {focus $makenew(OldFocus)}
407	}
408	if {$makenew(OldGrab) != ""} {
409	catch {grab $makenew(OldGrab)}
410	}
411	} else {
412	catch {::tk::RestoreFocusGrab $makenew(OldGrab) $makenew(OldFocus)}
413	}
414	}
415
416	proc ShowBigMessage {win labeltext msg "optionlist OK" "link {}" "err 0"} {
417	catch {destroy $win}
418	toplevel $win
419
420	pack [label $win.l1 -text $labeltext] -side top
421	if {$err} {$win.l1 config -fg red}
422	pack [frame $win.f1] -side top -expand yes -fill both
423	grid [text $win.f1.t \
424	-height 20 -width 55 -wrap none -font Courier \
425	-xscrollcommand "$win.f1.bscr set" \
426	-yscrollcommand "$win.f1.rscr set" \
427	] -row 1 -column 0 -sticky news
428	grid [scrollbar $win.f1.bscr -orient horizontal \
429	-command "$win.f1.t xview" \
430	] -row 2 -column 0 -sticky ew
431	grid [scrollbar $win.f1.rscr -command "$win.f1.t yview" \
432	] -row 1 -column 1 -sticky ns
433	# give extra space to the text box
434	grid columnconfigure $win.f1 0 -weight 1
435	grid rowconfigure $win.f1 1 -weight 1
436	$win.f1.t insert end $msg
437
438	global makenew
439	set makenew(result) 0
440	bind $win <Return> "destroy $win"
441	bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
442	bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
443	bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
444	bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
445	bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
446	bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
447	bind $win <KeyPress-Home> "$win.f1.t yview 0"
448	bind $win <KeyPress-End> "$win.f1.t yview end"
449	set i 0
450	foreach item $optionlist {
451	pack [button $win.q[incr i] \
452	-command "set makenew(result) $i; destroy $win" -text $item] -side left
453	}
454	if {$link != ""} {
455	pack [button $win.help -text Help -bg yellow \
456	-command "MakeWWWHelp $link"] \
457	-side right
458	bind $win <Key-F1> "MakeWWWHelp $link"
459	}
460	putontop $win
461	tkwait window $win
462
463	# fix grab...
464	afterputontop
465	return $makenew(result)
466	}
467
468	# format numbers & errors in crystallographic notation
469	proc formatSU {num err} {
470	# errors less or equal to t are expressed as 2 digits
471	set T 19
472	set lnT [expr { log10($T) }]
473	# error is zero
474	if {$err == 0} {
475	# is this an integer?
476	if {int($num) == $num} {
477	return [format %d [expr int($num)]]
478	}
479	# allow six sig figs with a zero error (except for 0.0)
480	set dec [expr int(5.999999-log10( abs($num) ))]
481	if {$dec < -2 \|\| $dec > 9} {
482	return [format %.5E $num]
483	} elseif {$dec <= 0} {
484	return [format %d [expr int($num)]]
485	} else {
486	return [format %.${dec}f $num]
487	}
488	} else {
489	#set sigfigs [expr log10( abs(10) / abs(.012/$T) ) + 1]
490	# should the number be expressed in scientific notation?
491	if {$err > $T \|\| abs($num) < 0.0001} {
492	# get the exponent
493	set exp [lindex [split [format %E $num] E] end]
494	# strip leading zeros
495	regsub {([-\+])0+} $exp {\1} exp
496	# number of decimals in exponetial notation
497	set dec [expr int($lnT - log10( abs($err) ) + $exp)]
498	# should the error be displayed?
499	if {$err < 0} {
500	return [format "%.${dec}E" $num]
501	} else {
502	# scale the error into a decimal number
503	set serr [expr int(0.5 + $err * pow(10,$dec-$exp))]
504	return [format "%.${dec}E(%d)" $num $serr]
505	}
506	} else {
507	# number of digits
508	set dec [expr int($lnT - log10( abs($err) ))]
509	# should the error be displayed?
510	if {$err < 0} {
511	return [format "%.${dec}f" $num]
512	} else {
513	set serr [expr int(0.5 + $err * pow(10,$dec))]
514	return [format "%.${dec}f(%d)" $num $serr]
515	}
516	}
517	}
518	}
519
520	# place a window on a selected part of the screen
521	# xfrac specifies the hozontal position with 0 to the left and 100 to the right
522	# yfrac specifies the vertical position with 0 to the top and 100 to the bottom
523	# loc chooses the part of the window to place at that location: N: upper, S: lower, W: left, E: right
524	# use NSEW for center
525	proc LocateWindow {win {xfrac 50} {yfrac 50} {loc c}} {
526	wm withdraw $win
527	set maxx [winfo screenwidth $win]
528	set maxy [winfo screenheight $win]
529	set reqx [winfo reqwidth $win]
530	set reqy [winfo reqheight $win]
531	set x [expr {$maxx*$xfrac/100.}]
532	set y [expr {$maxy*$yfrac/100.}]
533	if {[string match -nocase "e" $loc] && [string match -nocase "w" $loc]} {
534	# EW: center
535	set x [expr {$x - $reqx/2. }]
536	} elseif {[string match -nocase "e" $loc]} {
537	# right corner
538	set x [expr {$x - $reqx}]
539	} elseif {[string match -nocase "w" $loc]} {
540	# left corner -- do nothing
541	} else {
542	# center
543	set x [expr {$x - $reqx/2. }]
544	}
545	if {[string match -nocase "n" $loc] && [string match -nocase "s" $loc]} {
546	# NS: center
547	set y [expr {$y - $reqy/2 }]
548	} elseif {[string match -nocase "n" $loc]} {
549	# upper corner -- do nothing
550	} elseif {[string match -nocase "s" $loc]} {
551	# lower corner
552	set y [expr {$y - $reqy}]
553	} else {
554	# center
555	set y [expr {$y - $reqy/2 }]
556	}
557	set x [expr {int($x + 0.5)}]
558	set y [expr {int($y + 0.5)}]
559	if {$x < 0} {set x 0}
560	if {$x > $maxx-$reqx} {set x [expr {$maxx-$reqx}]}
561	if {$y < 0} {set y 0}
562	if {$y > $maxy-$reqy} {set y [expr {$maxy-$reqy}]}
563	wm geom $win +$x+$y
564	wm deiconify $win
565	}
566
567	# get a value in a modal dialog
568	proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
569	global expgui expmap
570	set w .global
571	catch {destroy $w}
572	toplevel $w -bg beige
573	bind $w <Key-F1> "MakeWWWHelp expguierr.html Input[lindex $what 0]"
574	wm title $w "Input $what"
575	set expgui(temp) {}
576	pack [frame $w.0 -bd 6 -relief groove -bg beige] \
577	-side top -expand yes -fill both
578	grid [label $w.0.a -text "Input a value for the $what" \
579	-bg beige] \
580	-row 0 -column 0 -columnspan 10
581	grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
582	-row 1 -column 0
583
584	set expgui(temp) $initvalue
585	pack [frame $w.b -bg beige] -side top -fill x -expand yes
586	pack [button $w.b.2 -text Continue -command "destroy $w"] -side left
587	if $quit {
588	pack [button $w.b.3 -text Cancel \
589	-command "set expgui(temp) {}; destroy $w"] -side left
590	}
591	bind $w <Return> "destroy $w"
592	pack [button $w.b.help -text Help -bg yellow \
593	-command "MakeWWWHelp expguierr.html Input[lindex $what 0]"] \
594	-side right
595
596	# force the window to stay on top
597	putontop $w
598
599	focus $w.b.2
600	tkwait window $w
601	afterputontop
602
603	return $expgui(temp)
604	}
605
606	#------------------------------------------------------------------------------
607	# profile/symmetry routines
608	#------------------------------------------------------------------------------
609	# profile terms
610	array set expgui {
611	prof-T-names {"Von Dreele-Jorgensen-Windsor" \
612	"David-Ikeda-Carpenter" "Exponential pseudo-Voigt" \
613	"Exponential p-V+Stephens aniso strain" \
614	"Exponential p-V+macro strain"
615	}
616	prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
617	rsca s1ec s2ec }
618	prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
619	gam-2 ptec stec difc difa zero }
620	prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
621	gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
622	prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
623	rstr rsta rsca eta}
624	prof-T-5 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
625	gam-2 gsf g1ec g2ec rstr rsta rsca D1 D2 D3 D4 D5 D6 }
626	prof-C-names {"Gaussian only" "Pseudo-Voigt" \
627	"pseudo-Voigt/FCJ Asym" "p-V/FCJ+Stephens aniso strain" \
628	"p-V/FCJ+macro strain"
629	}
630	prof-C-1 {GU GV GW asym F1 F2 }
631	prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
632	L11 L22 L33 L12 L13 L23 }
633	prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
634	L11 L22 L33 L12 L13 L23 }
635	prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta}
636	prof-C-5 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
637	D1 D2 D3 D4 D5 D6 }
638	prof-E-names {Gaussian "Otto pseudo-Voigt"}
639	prof-E-1 {A B C ds cds}
640	prof-E-2 {A B C ds cds LX LY ptec stec}
641	}
642
643	# number of profile terms depends on the histogram type
644	# the LAUE symmetry and the profile number
645	proc GetProfileTerms {phase hist ptype} {
646	global expmap expgui
647	if {$hist == "C" \|\| $hist == "T" \|\| $hist == "E"} {
648	set htype $hist
649	} else {
650	set htype [string range $expmap(htype_$hist) 2 2]
651	}
652	# get the cached copy of the profile term labels, when possible
653	set lbls {}
654	catch {
655	set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
656	}
657	if {$lbls != ""} {return $lbls}
658
659	catch {set lbls $expgui(prof-$htype-$ptype)}
660	if {$lbls == ""} {return}
661	# add terms based on the Laue symmetry
662	if {($htype == "C" \|\| $htype == "T") && $ptype == 4} {
663	set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
664	eval lappend lbls [Profile4Terms $laueaxis]
665	}
666	set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
667	return $lbls
668	}
669
670	proc Profile4Terms {laueaxis} {
671	# GSAS Laue classes by number vs spacegrp labeling
672	# 1 2 3 4 5 6 7 8 9 10 11 12 13 14
673	# 1bar, 2/m, mmm, 4/m, 4/mmm, 3bar, 3bar m, 3bar, 3barm1, 3bar1m, 6/m, 6/mmm, m 3, m3m
674	# R R H H H
675	# (R=Rhombohedral setting; H=Hexagonal setting)
676	switch -exact $laueaxis {
677	1bar {return \
678	"S400 S040 S004 S220 S202 S022 S310 S103 S031 \
679	S130 S301 S013 S211 S121 S112"}
680	2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
681	2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
682	2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
683	mmm {return "S400 S040 S004 S220 S202 S022"}
684	4/m {return "S400 S004 S220 S202 S310"}
685	4/mmm {return "S400 S004 S220 S202"}
686	3barR {return "S400 S220 S310 S301 S211"}
687	"3bar mR" {return "S400 S220 S310 S211"}
688	3bar {return "S400 S004 S202 S310 S211"}
689	3barm1 {return "S400 S004 S202 S301"}
690	3bar1m {return "S400 S004 S202 S211"}
691	6/m {return "S400 S004 S202"}
692	6/mmm {return "S400 S004 S202"}
693	"m 3" {return "S400 S220"}
694	m3m {return "S400 S220"}
695	default {return ""}
696	}
697	}
698
699	proc GetLaue {spg} {
700	global tcl_platform expgui
701	# check the space group
702	set fp [open spg.in w]
703	puts $fp "N"
704	puts $fp "N"
705	puts $fp $spg
706	puts $fp "Q"
707	close $fp
708	catch {
709	if {$tcl_platform(platform) == "windows"} {
710	exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
711	} else {
712	exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
713	}
714	}
715	set fp [open spg.out r]
716	set laue {}
717	set uniqueaxis {}
718	while {[gets $fp line] >= 0} {
719	regexp {Laue symmetry (.*)} $line junk laue
720	regexp {The unique axis is (.*)} $line junk uniqueaxis
721	}
722	close $fp
723	catch {file delete -force spg.in spg.out}
724	set laue [string trim $laue]
725	# add a R suffix for rhombohedral settings
726	if {[string range [string trim $spg] end end] == "R"} {
727	return "${laue}${uniqueaxis}R"
728	}
729	return "${laue}$uniqueaxis"
730	}
731
732	# set up to change the profile type for a series of histogram/phase entries
733	# (histlist & phaselist should be lists of the same length)
734	#
735	proc ChangeProfileType {histlist phaselist} {
736	global expgui expmap
737	set w .profile
738	catch {destroy $w}
739	toplevel $w -bg beige
740	wm title $w "Change Profile Function"
741
742	# all histogram/phases better be the same type, so we can just use the 1st
743	set hist [lindex $histlist 0]
744	set phase [lindex $phaselist 0]
745	set ptype [string trim [hapinfo $hist $phase proftype]]
746
747	# get list of allowed profile terms for the current histogram type
748	set i 1
749	while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
750	lappend lbllist $lbls
751	incr i
752	}
753	# labels for the current type
754	set i $ptype
755	set oldlbls [lindex $lbllist [incr i -1]]
756
757	if {[llength $histlist] == 1} {
758	pack [label $w.a -bg beige \
759	-text "Change profile function for Histogram #$hist Phase #$phase" \
760	] -side top
761	} else {
762	# make a list of histograms by phase
763	foreach h $histlist p $phaselist {
764	lappend phlist($p) $h
765	}
766	set num 0
767	pack [frame $w.a -bg beige] -side top
768	pack [label $w.a.$num -bg beige \
769	-text "Change profile function for:" \
770	] -side top -anchor w
771	foreach i [lsort [array names phlist]] {
772	incr num
773	pack [label $w.a.$num -bg beige -text \
774	"\tPhase #$i, Histograms [CompressList $phlist($i)]" \
775	] -side top -anchor w
776	}
777	}
778	pack [label $w.e1 \
779	-text "Current function is type $ptype." \
780	-bg beige] -side top -anchor w
781	pack [frame $w.e -bg beige] -side top -expand yes -fill both
782	pack [label $w.e.1 \
783	-text "Set function to type" \
784	-bg beige] -side left
785	set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
786	pack $w.e.2 -side left -anchor w
787
788	pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
789	-command "set expgui(newpeaktype) $ptype; \
790	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
791	-value 1 -text "Current value overrides"] -side right
792	pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
793	-command \
794	"set expgui(newpeaktype) $ptype; \
795	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
796	-value 0 -text "Default value overrides"] -side right
797
798	$w.e.2 config -bg beige
799	pack [frame $w.c -bg beige] -side top -expand yes -fill both
800	pack [frame $w.d -bg beige] -side top -expand yes -fill both
801	pack [button $w.d.2 -text Continue \
802	-command "SaveChangeProfileType $w.c [list $histlist] [list $phaselist]; destroy $w"\
803	] -side left
804	pack [button $w.d.3 -text Cancel \
805	-command "destroy $w"] -side left
806	pack [button $w.d.help -text Help -bg yellow \
807	-command "MakeWWWHelp expgui5.html ChangeType"] \
808	-side right
809	bind $w <Key-F1> "MakeWWWHelp expgui5.html ChangeType"
810	bind $w <Return> "destroy $w"
811
812	$menu delete 0 end
813	set i 0
814	foreach lbls $lbllist {
815	incr i
816	set j $i
817	# determine if negative profiles are allowed
818	if {[string range $expmap(htype_$hist) 2 2] == "T"} {
819	if {[histinfo $hist proftbl] > 0 && $i > 2} {
820	set j -$i
821	}
822	}
823	$menu add command -label $j -command \
824	"set expgui(newpeaktype) $j; \
825	FillChangeProfileType $w.c $hist $phase $j [list $lbls] [list $oldlbls]"
826	}
827	set expgui(newpeaktype) $ptype
828	FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
829
830	# force the window to stay on top
831	putontop $w
832	focus $w.e.2
833	tkwait window $w
834	afterputontop
835	sethistlist
836	}
837
838	# save the changes to the profile
839	proc SaveChangeProfileType {w histlist phaselist} {
840	global expgui
841	foreach phase $phaselist hist $histlist {
842	hapinfo $hist $phase proftype set $expgui(newpeaktype)
843	RecordMacroEntry "hapinfo $hist $phase proftype set $expgui(newpeaktype)" 0
844	hapinfo $hist $phase profterms set $expgui(newProfileTerms)
845	RecordMacroEntry "hapinfo $hist $phase profterms set $expgui(newProfileTerms)" 0
846	for {set i 1} {$i <= $expgui(newProfileTerms)} {incr i} {
847	hapinfo $hist $phase pterm$i set [$w.ent${i} get]
848	RecordMacroEntry "hapinfo $hist $phase pterm$i set [$w.ent${i} get]" 0
849	hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
850	RecordMacroEntry "hapinfo $hist $phase pref$i set $expgui(ProfRef$i)" 0
851	}
852	set i [expr 1+$expgui(newProfileTerms)]
853	hapinfo $hist $phase pcut set [$w.ent$i get]
854	RecordMacroEntry "hapinfo $hist $phase pcut set [$w.ent$i get]" 0
855	incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
856	RecordMacroEntry "incr expgui(changed)" 0
857	}
858	}
859
860	# file the contents of the "Change Profile Type" Menu
861	proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
862	global expgui expmap
863	set ptype [string trim [hapinfo $hist $phase proftype]]
864	catch {unset oldval}
865	# loop through the old terms and set up an array of starting values
866	set num 0
867	foreach term $oldlbls {
868	incr num
869	set oldval($term) [hapinfo $hist $phase pterm$num]
870	}
871	set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
872
873	# is the new type the same as the current?
874	if {$ptype == $newtype} {
875	set nterms [hapinfo $hist $phase profterms]
876	} else {
877	set nterms [llength $lbls]
878	}
879	set expgui(newProfileTerms) $nterms
880	set expgui(CurrentProfileTerms) $nterms
881	# which default profile set matches the new type
882	set setnum {}
883	foreach j {" " 1 2 3 4 5 6 7 8 9} {
884	set i [profdefinfo $hist $j proftype]
885	if {$i == ""} continue
886	if {$i == $newtype} {
887	set setnum $j
888	break
889	}
890	}
891
892	eval destroy [winfo children $w]
893
894	set colstr 0
895	set row 2
896	set maxrow [expr $row + $nterms/2]
897	for { set num 1 } { $num <= $nterms + 1} { incr num } {
898	# get the default value (originally from the in .INS file)
899	set val {}
900	if {$setnum != ""} {
901	set val 0.0
902	catch {
903	set val [profdefinfo $hist $setnum pterm$num]
904	# pretty up the number
905	if {$val == 0.0} {
906	set val 0.0
907	} elseif {abs($val) < 1e-2 \|\| abs($val) > 1e6} {
908	set val [format %.3e $val]
909	} elseif {abs($val) > 1e-2 && abs($val) < 10} {
910	set val [format %.5f $val]
911	} elseif {abs($val) < 9999} {
912	set val [format %.2f $val]
913	} elseif {abs($val) < 1e6} {
914	set val [format %.0f $val]
915	}
916	}
917	}
918	# heading
919	if {$row == 2} {
920	set col $colstr
921	grid [label $w.h0${num} -text "lbl" -bg beige] \
922	-row $row -column $col
923	grid [label $w.h2${num} -text "ref" -bg beige] \
924	-row $row -column [incr col]
925	grid [label $w.h3${num} -text "next value" -bg beige] \
926	-row $row -column [incr col]
927	grid [label $w.h4${num} -text "default" -bg beige] \
928	-row $row -column [incr col]
929	grid [label $w.h5${num} -text "current" -bg beige] \
930	-row $row -column [incr col]
931	}
932	set col $colstr
933	incr row
934	set term {}
935	catch {set term [lindex $lbls [expr $num-1]]}
936	if {$term == ""} {set term $num}
937	if {$num == $nterms + 1} {
938	set term "Peak\nCutoff"
939	set val {}
940	if {$setnum != ""} {
941	set val 0.0
942	catch {set val [profdefinfo $hist $setnum pcut]}
943	}
944	}
945
946	grid [label $w.l${num} -text "$term" -bg beige] \
947	-row $row -column $col
948	grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
949	-bg beige -activebackground beige] -row $row -column [incr col]
950	grid [entry $w.ent${num} \
951	-width 12] -row $row -column [incr col]
952	if {$val != ""} {
953	grid [button $w.def${num} -text $val -command \
954	"$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
955	] -row $row -column [incr col] -sticky ew
956	} else {
957	grid [label $w.def${num} -text (none) \
958	] -row $row -column [incr col]
959	}
960	set curval {}
961	catch {
962	set curval [expr $oldval($term)]
963	# pretty up the number
964	if {$curval == 0.0} {
965	set curval 0.0
966	} elseif {abs($curval) < 1e-2 \|\| abs($curval) > 1e6} {
967	set curval [format %.3e $curval]
968	} elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
969	set curval [format %.5f $curval]
970	} elseif {abs($curval) < 9999} {
971	set curval [format %.2f $curval]
972	} elseif {abs($curval) < 1e6} {
973	set curval [format %.0f $curval]
974	}
975	grid [button $w.cur${num} -text $curval -command \
976	"$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
977	] -row $row -column [incr col] -sticky ew
978	}
979	# set default values for flag and value
980	set ref 0
981	if {$setnum != ""} {
982	catch {
983	if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
984	}
985	}
986	set expgui(ProfRef$num) $ref
987
988	$w.ent${num} delete 0 end
989	if {!$expgui(DefaultPeakType) && $val != ""} {
990	$w.ent${num} insert end $val
991	} elseif {$curval != ""} {
992	$w.ent${num} insert end $curval
993	} elseif {$val != ""} {
994	$w.ent${num} insert end $val
995	} else {
996	$w.ent${num} insert end 0.0
997	}
998	if {$row > $maxrow} {
999	set row 2
1000	incr colstr 5
1001	}
1002	}
1003	if {$::tcl_platform(os) == "Darwin"} {
1004	# on OS X force a window resize
1005	wm geometry [winfo toplevel $w] {}
1006	}
1007	}
1008
1009	#------------------------------------------------------------------------------
1010	# WWW/help routines
1011	#------------------------------------------------------------------------------
1012	# browse a WWW page with URL. The URL may contain a #anchor
1013	# On UNIX assume netscape or mozilla is in the path or env(BROWSER) is loaded.
1014	# On Windows search the registry for a browser. Mac branch not tested.
1015	# This is taken from http://mini.net/cgi-bin/wikit/557.html with many thanks
1016	# to the contributers
1017	proc urlOpen {url} {
1018	global env tcl_platform
1019	if {$tcl_platform(os) == "Darwin"} {
1020	# if this is an external URL or does not contain an anchor, take the
1021	# easy approach
1022	if {[string range $url 0 4] == "http:" \|\| \
1023	[string first "#" $url] == -1} {
1024	if {![catch {exec open $url}]} {
1025	return
1026	}
1027	}
1028	# so sorry, have to use Safari, even if not default
1029	set url [file nativename $url]; # replace ~/ if present
1030	if {[file pathtype $url] == "relative"} {
1031	set url [file join [pwd] $url]
1032	}
1033	exec osascript -e "tell application \"Safari\" to open location \"file://$url\""
1034	} elseif {$tcl_platform(platform) == "unix"} {
1035	set browserlist {}
1036	if {[info exists env(BROWSER)]} {
1037	set browserlist $env(BROWSER)
1038	}
1039	lappend browserlist netscape mozilla
1040	foreach p $browserlist {
1041	set progs [auto_execok $p]
1042	if {[llength $progs]} {
1043	if {[catch {exec $progs -remote openURL($url)}]} {
1044	# perhaps browser doesn't understand -remote flag
1045	if {[catch {exec $env(BROWSER) $url &} emsg]} {
1046	error "Error displaying $url in browser\n$emsg"
1047	}
1048	}
1049	return
1050	}
1051	}
1052	MyMessageBox -parent . -title "No Browser" \
1053	-message "Could not find a browser. Netscape & Mozilla not found. Define environment variable BROWSER to be full path name of browser." \
1054	-icon warning
1055	} elseif {$tcl_platform(platform) == "windows"} {
1056	package require registry
1057	# Look for the application under
1058	# HKEY_CLASSES_ROOT
1059	set root HKEY_CLASSES_ROOT
1060
1061	# Get the application key for HTML files
1062	set appKey [registry get $root\\.html ""]
1063
1064	# Get the command for opening HTML files
1065	set appCmd [registry get \
1066	$root\\$appKey\\shell\\open\\command ""]
1067
1068	# Substitute the HTML filename into the command for %1
1069	# or stick it on the end
1070	if {[string first %1 $appCmd] != -1} {
1071	regsub %1 $appCmd $url appCmd
1072	} else {
1073	append appCmd " " $url
1074	}
1075
1076	# Double up the backslashes for eval (below)
1077	regsub -all {\\} $appCmd {\\\\} appCmd
1078
1079	# Invoke the command
1080	eval exec $appCmd &
1081	} elseif {$tcl_platform(platform) == "macintosh"} {
1082	# preOSX -- this is not used
1083	if {0 == [info exists env(BROWSER)]} {
1084	set env(BROWSER) "Browse the Internet"
1085	}
1086	if {[catch {
1087	AppleScript execute\
1088	"tell application \"$env(BROWSER)\"
1089	open url \"$url\"
1090	end tell
1091	"} emsg]
1092	} then {
1093	error "Error displaying $url in browser\n$emsg"
1094	}
1095	}
1096	}
1097
1098	proc NetHelp {file anchor localloc netloc} {
1099	# use the file on-line, if it exists
1100	if {[file exists [file join $localloc $file]]} {
1101	set url "[file join $localloc $file]"
1102	} else {
1103	set url "http://$netloc/$file"
1104	}
1105	catch {
1106	pleasewait "Starting web browser..."
1107	after 2000 donewait
1108	}
1109	if {$anchor != ""} {
1110	append url # $anchor
1111	}
1112	urlOpen $url
1113	}
1114
1115	proc MakeWWWHelp {"topic {}" "anchor {}"} {
1116	global expgui
1117	if {$topic == ""} {
1118	foreach item $expgui(notebookpagelist) {
1119	if {[lindex $item 0] == $expgui(pagenow)} {
1120	NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
1121	return
1122	}
1123	}
1124	# this should not happen
1125	NetHelp expgui.html "" $expgui(docdir) $expgui(website)
1126	} elseif {$topic == "menu"} {
1127	NetHelp expguic.html "" $expgui(docdir) $expgui(website)
1128	} else {
1129	NetHelp $topic $anchor $expgui(docdir) $expgui(website)
1130	}
1131	}
1132
1133	# show help information
1134	proc showhelp {} {
1135	global expgui_helplist helpmsg
1136	set helpmsg {}
1137	set frm .help
1138	catch {destroy $frm}
1139	toplevel $frm
1140	wm title $frm "Help Summary"
1141	grid [label $frm.0 -text \
1142	"Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
1143	-column 0 -columnspan 4 -row 0
1144	# grid [message $frm.help -textvariable helpmsg -relief groove] \
1145	# -column 0 -columnspan 4 -row 2 -sticky nsew
1146	grid [text $frm.help -relief groove -bg beige -width 0\
1147	-height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
1148	-column 0 -columnspan 3 -row 2 -sticky nsew
1149	grid [scrollbar $frm.escroll -command "$frm.help yview"] \
1150	-column 4 -row 2 -sticky nsew
1151	grid rowconfig $frm 1 -weight 1 -minsize 50
1152	grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
1153	grid columnconfig $frm 0 -weight 1
1154	grid columnconfig $frm 2 -weight 1
1155	set lst [array names expgui_helplist]
1156	grid [listbox $frm.cmds -relief raised -bd 2 \
1157	-yscrollcommand "$frm.scroll set" \
1158	-height 8 -width 0 -exportselection 0 ] \
1159	-column 0 -row 1 -sticky nse
1160	grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
1161	-column 1 -row 1 -sticky nsew
1162	foreach item [lsort -dictionary $lst] {
1163	$frm.cmds insert end $item
1164	}
1165	if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
1166	grid [button $frm.done -text Done -command "destroy $frm"] \
1167	-column 2 -row 1
1168	# bind $frm.cmds <ButtonRelease-1> \
1169	# "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
1170	bind $frm.cmds <ButtonRelease-1> \
1171	"+$frm.help config -state normal; $frm.help delete 0.0 end; \
1172	$frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
1173	$frm.help config -state disabled"
1174
1175	# get the size of the window and expand the message boxes to match
1176	# update
1177	# $frm.help config -width [winfo width $frm.help ]
1178	}
1179
1180
1181	#------------------------------------------------------------------------------
1182	# utilities
1183	#------------------------------------------------------------------------------
1184	# run liveplot
1185	proc liveplot {} {
1186	global expgui liveplot wishshell expmap
1187	set expnam [file root [file tail $expgui(expfile)]]
1188	# which histograms are ready for use?
1189	set validlist {}
1190	foreach ihist $expmap(powderlist) {
1191	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1192	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1193	lappend validlist $ihist
1194	}
1195	}
1196	if {[llength $validlist] == 0} {
1197	MyMessageBox -parent . -title "No Valid Histograms" \
1198	-message "No histograms are ready to plot. Run GENLES and try again" \
1199	-icon warning -helplink "expguierr.html NoValidHist"
1200	return
1201	}
1202	# use $liveplot(hst) if valid, the 1st entry otherwise
1203	if {[lsearch $validlist $liveplot(hst)] != -1} {
1204	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1205	$expnam $liveplot(hst) $liveplot(legend) &
1206	} else {
1207	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1208	$expnam [lindex $validlist 0] $liveplot(legend) &
1209	}
1210	}
1211
1212	# run lstview
1213	proc lstview {} {
1214	global expgui wishshell
1215	set expnam [file root [file tail $expgui(expfile)]]
1216	exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1217	}
1218
1219	# run widplt
1220	proc widplt {"prog widplt"} {
1221	global expgui wishshell
1222	exec $wishshell [file join $expgui(scriptdir) $prog] \
1223	$expgui(expfile) &
1224	}
1225
1226	# run bkgedit
1227	proc bkgedit {"hst {}"} {
1228	global expgui liveplot wishshell expmap
1229	set expnam [file root [file tail $expgui(expfile)]]
1230	if {$hst == ""} {
1231	# which histograms are ready for use?
1232	set validlist {}
1233	foreach ihist $expmap(powderlist) {
1234	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1235	[string range $expmap(htype_$ihist) 3 3] == "*"} {
1236	lappend validlist $ihist
1237	}
1238	}
1239	if {[llength $validlist] == 0} {
1240	MyMessageBox -parent . -title "No Valid Histograms" \
1241	-message "No histograms are ready to plot. Run POWPREF and try again" \
1242	-icon warning -helplink "expguierr.html NoValidHist"
1243	return
1244	}
1245	# use $liveplot(hst) if valid, the 1st entry otherwise
1246	if {[lsearch $validlist $liveplot(hst)] != -1} {
1247	set hst $liveplot(hst)
1248	} else {
1249	set hst [lindex $validlist 0]
1250	}
1251	}
1252	# Save the current exp file
1253	savearchiveexp
1254	CantRecordMacroEntry "bkgedit"
1255	# disable the file change monitor if we will reload the .EXP file automatically
1256	if {$expgui(autoexpload)} {set expgui(expModifiedLast) 0}
1257	if {$expgui(autoiconify)} {wm iconify .}
1258	exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1259	$expnam $hst $liveplot(legend)
1260	if {$expgui(autoiconify)} {wm deiconify .}
1261	# load the changed .EXP file automatically?
1262	if {$expgui(autoexpload)} {
1263	# load the revised exp file
1264	loadexp $expgui(expfile)
1265	} else {
1266	# check for changes in the .EXP file immediately
1267	whenidle
1268	}
1269	}
1270
1271	# run excledt
1272	proc excledit {} {
1273	global expgui liveplot expmap
1274	set expnam [file root [file tail $expgui(expfile)]]
1275	# which histograms are ready for use?
1276	set validlist {}
1277	foreach ihist $expmap(powderlist) {
1278	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1279	[string range $expmap(htype_$ihist) 3 3] == "*" \|\| \
1280	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1281	lappend validlist $ihist
1282	}
1283	}
1284	if {[llength $validlist] == 0} {
1285	MyMessageBox -parent . -title "No Valid Histograms" \
1286	-message "No histograms are ready to plot. Run POWPREF and try again" \
1287	-icon warning -helplink "expguierr.html NoValidHist"
1288	return
1289	}
1290	#if {$expgui(autoiconify)} {wm iconify .}
1291	StartExcl
1292	#if {$expgui(autoiconify)} {wm deiconify .}
1293	}
1294
1295	# compute the composition for each phase and display in a dialog
1296	proc composition {} {
1297	global expmap expgui
1298	set Z 1
1299	foreach phase $expmap(phaselist) type $expmap(phasetype) {
1300	if {$type == 4} continue
1301	ResetMultiplicities $phase {}
1302	catch {unset total}
1303	foreach atom $expmap(atomlist_$phase) {
1304	set type [atominfo $phase $atom type]
1305	set mult [atominfo $phase $atom mult]
1306	if [catch {set total($type)}] {
1307	set total($type) [expr \
1308	$mult * [atominfo $phase $atom frac]]
1309	} else {
1310	set total($type) [expr $total($type) + \
1311	$mult * [atominfo $phase $atom frac]]
1312	}
1313	if {$mult > $Z} {set Z $mult}
1314	}
1315	append text "\nPhase $phase\n"
1316	append text " Unit cell contents\n"
1317	foreach type [lsort [array names total]] {
1318	append text " $type[format %8.3f $total($type)]"
1319	}
1320	append text "\n\n"
1321
1322	append text " Asymmetric Unit contents (Z=$Z)\n"
1323	foreach type [lsort [array names total]] {
1324	append text " $type[format %8.3f [expr $total($type)/$Z]]"
1325	}
1326	append text "\n"
1327	}
1328
1329	catch {destroy .comp}
1330	toplevel .comp -class MonoSpc
1331	bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1332	wm title .comp Composition
1333	pack [label .comp.results -text $text \
1334	-justify left] -side top
1335	pack [frame .comp.box] -side top -expand y -fill x
1336	pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1337
1338	set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1339	pack [button .comp.box.2 -text "Save to $lstnam file" \
1340	-command "writelst [list $text] ; destroy .comp"] -side left
1341	pack [button .comp.box.help -text Help -bg yellow \
1342	-command "MakeWWWHelp expgui.html Composition"] \
1343	-side right
1344	}
1345
1346	# Delete History Records
1347	proc DeleteHistoryRecords {{msg ""}} {
1348	global expgui
1349	set frm .history
1350	catch {destroy $frm}
1351	toplevel $frm
1352	bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1353	if {[string trim $msg] == ""} {
1354	set msg "There are [CountHistory] history records"
1355	}
1356	pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1357	pack [label $frm.1.0 -text $msg] -side top
1358	pack [frame $frm.1.1] -side top
1359	pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1360	pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1361	] -side left
1362	set expgui(historyKeep) 10
1363	pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1364	set expgui(renumber) 1
1365	pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1366	pack [button $frm.2.help -text Help -bg yellow \
1367	-command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1368	pack [button $frm.2.4 -text Cancel \
1369	-command {destroy .history}] -side bottom
1370	pack [button $frm.2.3 -text OK \
1371	-command {
1372	if ![catch {expr $expgui(historyKeep)}] {
1373	DeleteHistory $expgui(historyKeep) $expgui(renumber)
1374	set expgui(changed) 1
1375	destroy .history
1376	}
1377	}] -side bottom
1378	bind $frm <Return> "$frm.2.3 invoke"
1379
1380	# force the window to stay on top
1381	putontop $frm
1382	focus $frm.2.3
1383	tkwait window $frm
1384	afterputontop
1385	}
1386
1387	proc archiveexp {} {
1388	global expgui tcl_platform
1389	# is there a file to archive?
1390	if {![file exists $expgui(expfile)]} return
1391	set expnam [file rootname $expgui(expfile)]
1392	# get the last archived version
1393	set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1394	if {$lastf == ""} {
1395	set num 01
1396	} else {
1397	regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1398	scan $num %x num
1399	if {$num >= 255} {
1400	set num FF
1401	} else {
1402	set num [string toupper [format %.2x [incr num]]]
1403	}
1404	}
1405	catch {
1406	set file $expnam.O$num
1407	file copy -force $expgui(expfile) $file
1408	set fp [open $expnam.LST a+]
1409	puts $fp "\n----------------------------------------------"
1410	puts $fp " Archiving [file tail $expnam.EXP] as [file tail $file]"
1411	puts $fp "----------------------------------------------\n"
1412	close $fp
1413	} errmsg
1414	if {$errmsg != ""} {
1415	tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1416	}
1417	}
1418
1419	# save and optionally archive the expfile
1420	proc savearchiveexp {} {
1421	global expgui expmap
1422	if {$expgui(expfile) == ""} {
1423	SaveAsFile
1424	return
1425	}
1426	if !$expgui(changed) return
1427	if {$expgui(archive)} archiveexp
1428	# add a history record
1429	exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds] -format {%D %T}]"
1430	# now save the file
1431	expwrite $expgui(expfile)
1432	# change the icon and assign an app to this .EXP file
1433	global tcl_platform
1434	if {$tcl_platform(os) == "Darwin" && $expgui(MacAssignApp)} {
1435	MacSetResourceFork $expgui(expfile)
1436	}
1437	set expgui(changed) 0
1438	set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1439	set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1440	wm title . $expgui(expfile)
1441	set expgui(titleunchanged) 1
1442	# set convergence criterion
1443	InitLSvars
1444	}
1445
1446	#------------------------------------------------------------------------------
1447	# GSAS interface routines
1448	#------------------------------------------------------------------------------
1449	# run a GSAS program that does not require an experiment file
1450	proc runGSASprog {proglist "concurrent 1"} {
1451	# save call to Macro file
1452	RecordMacroEntry "runGSASprog [list $proglist] $concurrent" 0
1453	# if concurrent is 0, EXPGUI runs the GSAS program in background
1454	# -- this is not currently needed anywhere where the .EXP file is not.
1455	global expgui tcl_platform
1456	set cmd {}
1457	foreach prog $proglist {
1458	StartGRWND $prog
1459	if {$tcl_platform(platform) == "windows"} {
1460	append cmd " \"[file attributes $expgui(gsasexe)/${prog}.exe -shortname]\" "
1461	} else {
1462	if {$cmd != ""} {append cmd "\;"}
1463	append cmd "[file join $expgui(gsasexe) $prog]"
1464	}
1465	}
1466	forknewterm $prog $cmd [expr !$concurrent] 1
1467	}
1468
1469	# dummy routine, overridden if needed
1470	proc StartGRWND {prog} {
1471	}
1472
1473	# run a GSAS program that requires an experiment file for input/output
1474	proc runGSASwEXP {proglist "concurrent 0"} {
1475	# save call to Macro file
1476	RecordMacroEntry "runGSASwEXP [list $proglist] $concurrent" 0
1477	# most programs that require the .EXP file change it and
1478	# cannot be run concurrently
1479	global expgui tcl_platform
1480	# Save the current exp file
1481	savearchiveexp
1482	# load the changed .EXP file automatically?
1483	if {$expgui(autoexpload)} {
1484	# disable the file changed monitor
1485	set expgui(expModifiedLast) 0
1486	}
1487	set cmd {}
1488	set expnam [file root [file tail $expgui(expfile)]]
1489	foreach prog $proglist {
1490	if {$prog == "powpref"} {
1491	set expgui(needpowpref) 0
1492	set expgui(needpowpref_why) ""
1493	} elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1494	set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1495	set ans [MyMessageBox -parent . -title "Run POWPREF" \
1496	-message $msg -icon warning -type "Yes No" -default yes \
1497	-helplink "expguierr.html RunPowpref"]
1498	if {$ans == "yes"} {
1499	set expgui(needpowpref) 0
1500	set expgui(needpowpref_why) ""
1501	if {$tcl_platform(platform) == "windows"} {
1502	append cmd " \"[file attributes $expgui(gsasexe)/powpref.exe -shortname] $expnam \" "
1503	} else {
1504	if {$cmd != ""} {append cmd "\;"}
1505	append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1506	}
1507	}
1508	}
1509	StartGRWND $prog
1510	if {$tcl_platform(platform) == "windows"} {
1511	append cmd " \"[file attributes $expgui(gsasexe)/${prog}.exe -shortname] $expnam \" "
1512	} elseif {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1513	append cmd " \" [file join $expgui(gsasexe) $prog] $expnam \" "
1514	} else {
1515	if {$cmd != ""} {append cmd "\;"}
1516	append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1517	}
1518	}
1519	if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1520	set outfile ${expnam}_macout.LST
1521	runnoterm $cmd $outfile
1522	} else {
1523	forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1524	}
1525	# load the changed .EXP file automatically?
1526	if {$expgui(autoexpload)} {
1527	# load the revised exp file
1528	loadexp $expgui(expfile)
1529	}
1530	if {$expgui(MacroRunning)} {
1531	if {[file exists abort_${expnam}_macro.flag]} {
1532	file delete abort_${expnam}_macro.flag
1533	error "User requested to abort the macro"
1534	}
1535	update idletasks
1536	}
1537	}
1538
1539	# write text to the .LST file
1540	proc writelst {text} {
1541	global expgui
1542	set lstnam [file rootname $expgui(expfile)].LST
1543	set fp [open $lstnam a]
1544	puts $fp "\n-----------------------------------------------------------------"
1545	puts $fp $text
1546	puts $fp "-----------------------------------------------------------------\n"
1547	close $fp
1548	}
1549
1550
1551	# rename file current to suggested,
1552	# delete window if supplied
1553	# use parent, if supplied or .
1554	proc RenameAsFile {current suggested "window {}" "parent {}"} {
1555	if {$parent == "" && $window != ""} {set parent $window}
1556	if {$parent == ""} {set parent .}
1557	set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1558	if {$newfile == ""} return
1559	if {[catch {
1560	file rename -force $current $newfile
1561	}]} {
1562	file copy -force $current $newfile
1563	file delete -force $current
1564	}
1565	if {$window != ""} {destroy $window}
1566	}
1567
1568	# optionally run disagl as a windowless process, w/results in a separate window
1569	proc rundisagl {} {
1570	global expgui txtvw tcl_version tcl_platform
1571	# call up new DISAGL parm edit box
1572	if {[DA_Control_Panel 1]} {return}
1573	# Save the current exp file if needed
1574	savearchiveexp
1575	if {$expgui(disaglSeparateBox)} {
1576	set root [file root $expgui(expfile)]
1577	catch {file delete -force $root.tmp}
1578	if {[catch {file rename -force $root.LST $root.OLS}]} {
1579	file copy -force $root.LST $root.OLS
1580	file delete -force $root.OLS
1581	}
1582	# PSW reports this does not happen right away on windows
1583	set i 0
1584	while {$i < 10 && [file exists $root.LST]} {
1585	# debug code
1586	#catch {console show}
1587	#puts "try $i"
1588	# end debug code
1589	after 100
1590	incr i
1591	}
1592	if {[file exists $root.LST]} {
1593	# it was not possible to rename the file
1594	MyMessageBox -parent . -title "Rename Problem" \
1595	-message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1596	-icon warning -helplink "expguierr.html NoRename"
1597	return
1598	}
1599
1600	#run the program
1601	pleasewait "Running DISAGL"
1602	# create an empty input file
1603	close [open disagl.inp w]
1604	catch {exec [file join $expgui(gsasexe) disagl] \
1605	[file tail $root] < disagl.inp > disagl.out}
1606	if {[catch {file rename -force $root.LST $root.tmp}]} {
1607	file copy -force $root.LST $root.tmp
1608	file delete -force $root.LST
1609	}
1610	catch {file delete -force disagl.inp disagl.out}
1611	if {[catch {file rename -force $root.OLS $root.LST}]} {
1612	file copy -force $root.OLS $root.LST
1613	file delete -force $root.OLS
1614	}
1615	donewait
1616	# open a new window
1617	catch {toplevel .disagl}
1618	eval destroy [winfo child .disagl]
1619	set txt .disagl.txt
1620	catch {eval grid forget [grid slaves .disagl]}
1621	text $txt -width 100 -wrap none \
1622	-yscrollcommand ".disagl.yscroll set" \
1623	-xscrollcommand ".disagl.xscroll set"
1624	scrollbar .disagl.yscroll -command "$txt yview"
1625	scrollbar .disagl.xscroll -command "$txt xview" -orient horizontal
1626	grid .disagl.xscroll -column 0 -row 2 -sticky ew
1627	grid $txt -column 0 -row 1 -sticky nsew
1628	grid .disagl.yscroll -column 1 -row 1 -sticky ns
1629	grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1630	grid columnconfig .disagl.f 2 -weight 1
1631	grid [button .disagl.f.close -text "Close & Delete" \
1632	-command "destroy .disagl; file delete \[list $root.tmp\]"] \
1633	-column 3 -row 0 -sticky e
1634	grid [button .disagl.f.rename \
1635	-command "RenameAsFile \[list $root.tmp\] \[list $root.DIS\] .disagl" \
1636	-text "Close & Save as..."] \
1637	-column 4 -row 0 -sticky e
1638	# allow font changes on the fly
1639	if {$tcl_version >= 8.0} {
1640	$txt config -font $txtvw(font)
1641	set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1642	grid .disagl.f.font -column 1 -row 0 -sticky w
1643	grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1644	$fontbut delete 0 end
1645	foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1646	$fontbut add command -label "Courier $f" -font "Courier $f"\
1647	-command "set txtvw(font) \"Courier $f\"; \
1648	$txt config -font \$txtvw(font)"
1649	}
1650	}
1651
1652	grid columnconfigure .disagl 0 -weight 1
1653	grid rowconfigure .disagl 1 -weight 1
1654	wm title .disagl "DISAGL results $expgui(expfile)"
1655	wm iconname .disagl "DISAGL $root"
1656	set in [open $root.tmp r]
1657	$txt insert end [read $in]
1658	close $in
1659	bind all {destroy .disagl}
1660	bind .disagl "$txt yview scroll -1 page"
1661	bind .disagl "$txt yview scroll 1 page"
1662	bind .disagl "$txt xview scroll 1 unit"
1663	bind .disagl "$txt xview scroll -1 unit"
1664	bind .disagl "$txt yview scroll -1 unit"
1665	bind .disagl "$txt yview scroll 1 unit"
1666	bind .disagl "$txt yview 0"
1667	bind .disagl "$txt yview end"
1668	# don't disable in Win as this prevents the highlighting of selected text
1669	if {$tcl_platform(platform) != "windows"} {
1670	$txt config -state disabled
1671	}
1672	# find the beginning of the disagl text
1673
1674	set pos 1.0
1675	set nph 0
1676	while {[set loc [$txt search "Program DISAGL Version" $pos end]] != ""} {
1677	set pos [expr {$loc + 1}]
1678	incr nph
1679	}
1680	#puts "Found $nph DISAGL run(s)"
1681	# count phases
1682	set l {}
1683	while {[set loc [$txt search "Lattice constants are" $pos end]] != ""} {
1684	lappend l $loc
1685	set pos [expr {$loc + 1}]
1686	}
1687	catch {unset phaseloc}
1688
1689	set j 0
1690	foreach pos $l {
1691	if {$j == 0} {
1692	set prev $pos
1693	incr j
1694	continue
1695	}
1696	set phaseloc($j) [list $prev $pos]
1697	incr j
1698	}
1699	set phaseloc($j) [list $pos end]
1700	if {$nph >= 1 && $j >= 2} {
1701	grid [menubutton .disagl.f.copy \
1702	-menu .disagl.f.copy.menu \
1703	-text "Copy phase..." -bd 2 -relief raised] \
1704	-column 2 -row 0 -sticky nse
1705	menu .disagl.f.copy.menu
1706	for {set i 1} {$i <= $j} {incr i} {
1707	.disagl.f.copy.menu add command \
1708	-command "seldisaglphase $txt [list $phaseloc($i)]" \
1709	-label "Copy phase $i to clipboard"
1710	}
1711	} elseif {$nph >= 1} {
1712	grid [button .disagl.f.copy \
1713	-command "seldisaglphase $txt [list $phaseloc($j)]" \
1714	-text "Copy phase $j to clipboard"] \
1715	-column 2 -row 0 -sticky e
1716	}
1717	} else {
1718	runGSASwEXP disagl
1719	}
1720	}
1721
1722	proc seldisaglphase {txt phaselist} {
1723	# clear selection
1724	$txt tag remove sel 1.1 end
1725	eval $txt tag add sel $phaselist
1726	clipboard clear
1727	clipboard append " \| Program DISAGL Version MacOSX \|\n"
1728	clipboard append [eval $txt get [$txt tag ranges sel]]
1729	}
1730	#------------------------------------------------------------------------------
1731	# file conversions
1732	#------------------------------------------------------------------------------
1733	proc convfile {} {
1734	global expgui
1735	set frm .file
1736	catch {destroy $frm}
1737	toplevel $frm
1738	wm title $frm "Convert File"
1739	bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1740	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1741	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1742	-side left -fill y -expand yes
1743	pack [button $frmC.help -text Help -bg yellow \
1744	-command "MakeWWWHelp expgui.html ConvertWin"] -side top
1745	pack [button $frmC.q -text Cancel -command "destroy $frm"] -side bottom
1746	pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1747	-side bottom
1748	pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1749	winfilebox $frm
1750	bind $frm <Return> "ValidWinCnv $frm"
1751
1752	# force the window to stay on top
1753	putontop $frm
1754	focus $frmC.q
1755	tkwait window $frm
1756	afterputontop
1757	}
1758
1759	# validate the files and make the conversion
1760	proc ValidWinCnv {frm} {
1761	global expgui
1762	# change backslashes to something sensible
1763	regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1764	# allow entry of D: for D:/ and D:TEST for d:/TEST
1765	if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1766	[string first :/ $expgui(FileMenuCnvName)] == -1} {
1767	regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1768	}
1769	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1770	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1771	ChooseWinCnv $frm
1772	return
1773	} elseif [file isdirectory \
1774	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1775	if {$expgui(FileMenuCnvName) != "."} {
1776	set expgui(FileMenuDir) \
1777	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1778	}
1779	ChooseWinCnv $frm
1780	return
1781	}
1782
1783	set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1784	if ![file exists $file] {
1785	MyMessageBox -parent $frm -title "Convert Error" \
1786	-message "File $file does not exist" -icon error
1787	return
1788	}
1789
1790	set tmpname "[file join [file dirname $file] tempfile.xxx]"
1791	set oldname "[file rootname $file].org"
1792	if [file exists $oldname] {
1793	set ans [MyMessageBox -parent . -title "Overwrite?" \
1794	-message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1795	-icon warning -type {Overwrite Cancel} -default Overwrite \
1796	-helplink "expguierr.html OverwriteCnv"]
1797	if {[string tolower $ans] == "cancel"} return
1798	catch {file delete $oldname}
1799	}
1800
1801	if [catch {
1802	set in [open $file r]
1803	set out [open $tmpname w]
1804	fconfigure $out -translation crlf -encoding ascii
1805	set len [gets $in line]
1806	if {$len > 160} {
1807	# this is a UNIX file. Hope there are no control characters
1808	set i 0
1809	set j 79
1810	while {$j < $len} {
1811	puts $out [string range $line $i $j]
1812	incr i 80
1813	incr j 80
1814	}
1815	} else {
1816	while {$len >= 0} {
1817	append line " "
1818	append line " "
1819	set line [string range $line 0 79]
1820	puts $out $line
1821	set len [gets $in line]
1822	}
1823	}
1824	close $in
1825	close $out
1826	file rename -force $file $oldname
1827	file rename -force $tmpname $file
1828	} errmsg] {
1829	MyMessageBox -parent $frm -title "Conversion error" \
1830	-message "Error in conversion:\n$errmsg" -icon warning
1831	} else {
1832	set ans [MyMessageBox -parent $frm -title "More?" \
1833	-message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1834	-type yesno -default no]
1835	if {$ans == "no"} {destroy $frm}
1836	}
1837	}
1838
1839	# create a file box
1840	proc winfilebox {frm} {
1841	global expgui
1842	set bx $frm.1
1843	pack [frame $bx.top] -side top
1844	pack [label $bx.top.a -text "Directory" ] -side left
1845	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1846	pack $bx.top.d -side left
1847	set expgui(FileMenuDir) [pwd]
1848	# the icon below is from tk8.0/tkfbox.tcl
1849	set upfolder [image create bitmap -data {
1850	#define updir_width 28
1851	#define updir_height 16
1852	static char updir_bits[] = {
1853	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1854	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1855	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1856	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1857	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1858	0xf0, 0xff, 0xff, 0x01};}]
1859
1860	pack [button $bx.top.b -image $upfolder \
1861	-command "updir; ChooseWinCnv $frm" ]
1862	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1863	listbox $bx.a.files -relief raised -bd 2 \
1864	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1865	-height 15 -width 0 -exportselection 0
1866	listbox $bx.a.dates -relief raised -bd 2 \
1867	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1868	-height 15 -width 0 -takefocus 0 -exportselection 0
1869	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1870	ChooseWinCnv $frm
1871	bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1872	bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1873	bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1874	bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1875	pack $bx.a.scroll -side left -fill y
1876	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1877	pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1878	}
1879
1880	# set the box or file in the selection window
1881	proc ReleaseWinCnv {frm} {
1882	global expgui
1883	set files $frm.1.a.files
1884	set dates $frm.1.a.dates
1885	set select [$files curselection]
1886	if {$select == ""} {
1887	set select [$dates curselection]
1888	}
1889	if {$select == ""} {
1890	set expgui(FileMenuCnvName) ""
1891	} else {
1892	set expgui(FileMenuCnvName) [string trim [$files get $select]]
1893	}
1894	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1895	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1896	ChooseWinCnv $frm
1897	} elseif [file isdirectory \
1898	[file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1899	if {$expgui(FileMenuCnvName) != "."} {
1900	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1901	ChooseWinCnv $frm
1902	}
1903	}
1904	return
1905	}
1906
1907	# select a file or directory -- called on double click
1908	proc SelectWinCnv {frm} {
1909	global expgui
1910	set files $frm.1.a.files
1911	set dates $frm.1.a.dates
1912	set select [$files curselection]
1913	if {$select == ""} {
1914	set select [$dates curselection]
1915	}
1916	if {$select == ""} {
1917	set file .
1918	} else {
1919	set file [string trim [$files get $select]]
1920	}
1921	if {$file == "<Parent>"} {
1922	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1923	ChooseWinCnv $frm
1924	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1925	if {$file != "."} {
1926	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1927	ChooseWinCnv $frm
1928	}
1929	} else {
1930	set expgui(FileMenuCnvName) [file tail $file]
1931	ValidWinCnv $frm
1932	}
1933	}
1934
1935	# fill the files & dates & Directory selection box with current directory,
1936	# also called when box is created to fill it
1937	proc ChooseWinCnv {frm} {
1938	global expgui
1939	set files $frm.1.a.files
1940	set dates $frm.1.a.dates
1941	set expgui(FileMenuCnvName) {}
1942	$files delete 0 end
1943	$dates delete 0 end
1944	$files insert end {<Parent>}
1945	$dates insert end {(Directory)}
1946	set filelist [glob -nocomplain \
1947	[file join [set expgui(FileMenuDir)] *] ]
1948	foreach file [lsort -dictionary $filelist] {
1949	if {[file isdirectory $file]} {
1950	$files insert end [file tail $file]
1951	$dates insert end {(Directory)}
1952	}
1953	}
1954	foreach file [lsort -dictionary $filelist] {
1955	if {![file isdirectory $file]} {
1956	set modified [clock format [file mtime $file] -format "%T %D"]
1957	$files insert end [file tail $file]
1958	$dates insert end $modified
1959	}
1960	}
1961	$expgui(FileDirButtonMenu) delete 0 end
1962	set list ""
1963	global tcl_version
1964	if {$tcl_version > 8.0} {
1965	catch {set list [string tolower [file volume]]}
1966	}
1967	set dir ""
1968	foreach subdir [file split [set expgui(FileMenuDir)]] {
1969	set dir [string tolower [file join $dir $subdir]]
1970	if {[lsearch $list $dir] == -1} {lappend list $dir}
1971	}
1972	foreach path $list {
1973	$expgui(FileDirButtonMenu) add command -label $path \
1974	-command "[list set expgui(FileMenuDir) $path]; \
1975	ChooseWinCnv $frm"
1976	}
1977	return
1978	}
1979
1980	#------------------------------------------------------------------------------
1981	# set options for liveplot
1982	proc liveplotopt {} {
1983	global liveplot expmap
1984	set frm .file
1985	catch {destroy $frm}
1986	toplevel $frm
1987	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1988	set last [lindex [lsort -integer $expmap(powderlist)] end]
1989	if {$last == ""} {set last 1}
1990	pack [scale $frmA.1 -label "Histogram number" -from 1 -to $last \
1991	-length 150 -orient horizontal -variable liveplot(hst)] -side top
1992	pack [checkbutton $frmA.2 -text {include plot legend}\
1993	-variable liveplot(legend)] -side top
1994	pack [button $frm.2 -text OK \
1995	-command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1996	] -side top
1997	bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1998
1999	# force the window to stay on top
2000	putontop $frm
2001	focus $frm.2
2002	tkwait window $frm
2003	afterputontop
2004	}
2005
2006	#------------------------------------------------------------------------------
2007	# get/validate an experiment file name
2008	#------------------------------------------------------------------------------
2009	# validate and store the EXP file name. Create a new .EXP file if it does not
2010	# exist and set the wd to the location of the .EXP file.
2011	proc SetEXPfile {expfile "newOK 0"} {
2012	global expgui tcl_platform
2013	if {[string trim $expfile] == ""} return
2014
2015	# break up the file name and directory
2016	set dirname [file dirname $expfile]
2017	set expname [string toupper [file tail $expfile]]
2018
2019	# check the directory exists
2020	if {(! [file exists $dirname]) \|\| (! [file isdir $dirname])} {
2021	update
2022	MyMessageBox -parent . -title "Directory not found" \
2023	-message "Experiment file location \"$dirname\" is invalid -- no such directory exists" \
2024	-icon warning -type Continue -default continue
2025	set expgui(resize) 1
2026	return
2027	}
2028
2029	# is there a space in the directory name? On windows, try to fix it
2030	set origdir $dirname
2031	if {[string first " " $dirname] != -1} {
2032	set warn 1
2033	catch {set warn $expgui(warnonspaceonce)}
2034	if {$tcl_platform(platform) == "windows"} {
2035	set dirname [file attributes $dirname -shortname]
2036	# was the fix successful?
2037	if {[string first " " $dirname] == -1} {
2038	if {$warn} {
2039	update
2040	MyMessageBox -parent . -title "Still debugging..." \
2041	-message "You are using a directory with a space in the name ($origdir) that will be translated for Windows (to $dirname) -- This should obliviate bugs in EXPGUI, but if still you encounter any please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2042	-icon warning -type Continue -default continue
2043	set expgui(resize) 1
2044	}
2045	} else {
2046	if {$warn} {
2047	update
2048	MyMessageBox -parent . -title "Can't fix dir" \
2049	-message "You are using a directory with a space in the name ($origdir) in Windows that cannot be translated to a name without spaces (is this a network drive?) -- this could cause problems in EXPGUI. Please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2050	-icon warning -type Continue -default continue
2051	set expgui(resize) 1
2052	}
2053	}
2054	} elseif {$warn} {
2055	if {$warn} {
2056	update
2057	MyMessageBox -parent . -title "Still debugging..." \
2058	-message "You are using a directory with a space in the name ($origdir). This is not perhaps a wise idea, but I am trying to catch any bugs this causes in EXPGUI. If you encounter any, please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2059	-icon warning -type Continue -default continue
2060	set expgui(resize) 1
2061	}
2062	}
2063	set expgui(warnonspaceonce) 0
2064	}
2065
2066	# force exp files to be upper case, set to force save if name changes
2067	set origexp $expname
2068	if {$expname != [file tail $expfile] && $tcl_platform(platform) != "windows"} {
2069	set expgui(changed) 1
2070	}
2071	#puts $expgui(expfile)
2072	if {[string match {.O[0-9A-F][0-9A-F]} [file extension $expname]]} {
2073	set expname [ArchiveChoice $expname]
2074	set dirname ""
2075	if {$expname == ""} return
2076	} elseif {[file extension $expname] != ".EXP"} {
2077	append expname ".EXP"
2078	}
2079	if {$dirname == "." \|\| $dirname == ""} {
2080	set newexpfile $expname
2081	} else {
2082	set newexpfile [file join $dirname $expname]
2083	}
2084	# is there a space in the EXP name?
2085	if {[string first " " $expname] != -1} {
2086	# If the file exists in windows, see if there is an equivalent name available.
2087	# if not, we could try to create it and then see, but that is too much
2088	# work.
2089	if {$tcl_platform(platform) == "windows"} {
2090	if {[file exists $newexpfile]} {
2091	# try to translate it, if possible
2092	set expname [file tail [file attributes $newexpfile -shortname]]
2093	set newexpfile [file join $dirname $expname]
2094	# fixed?
2095	if {[string first " " $expname] == -1} {
2096	set warn 1
2097	catch {set warn $expgui(warnonexpspaceonce)}
2098	if {$warn} {
2099	update
2100	MyMessageBox -parent . -title "Still debugging..." \
2101	-message "You are using an EXP file name with a space in the name ($origexp) that will be translated for Windows (to $expname) -- This should obliviate bugs in EXPGUI, but if you still do encounter any please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2102	-icon warning -type Continue -default continue
2103	set expgui(resize) 1
2104	}
2105	set expgui(warnonexpspaceonce) 0
2106	}
2107	}
2108	if {[string first " " $expname] != -1} {
2109	# not fixed (file does not exist or shortname not supported)
2110	update
2111	MyMessageBox -parent . -title "Can't fix name" \
2112	-message "You are using an EXP file name with a space in the name ($origexp) in Windows that cannot be translated without spaces (is this a network drive?) -- this will cause problems in EXPGUI. Sorry." \
2113	-icon warning -type Continue -default continue
2114	set expgui(resize) 1
2115	return
2116	}
2117	} else {
2118	update
2119	MyMessageBox -parent . -title "Space in name" \
2120	-message "You are using an EXP file name with a space in the name ($origexp). This is likely to cause problems. Please rename the file or create one with another name. Sorry." \
2121	-icon warning -type Continue -default continue
2122	set expgui(resize) 1
2123	return
2124	}
2125	}
2126
2127	if {(! $newOK) && (! [file exists $newexpfile])} {
2128	update
2129	set ans [
2130	MyMessageBox -parent . -title "File Open Error" \
2131	-message "File $expname does not exist in ${dirname}. OK to create?" \
2132	-icon question -type {"Select other" "Create"} -default "select other" \
2133	-helplink "expguierr.html OpenErr"
2134	]
2135	set expgui(resize) 1
2136	if {[string tolower $ans] == "create"} {
2137	# you've been warned this .EXP does not exist!
2138	if [CreateMTexpfile $newexpfile] return
2139	} else {
2140	return
2141	}
2142	}
2143	catch {cd [string trim [file dirname $newexpfile]]}
2144	return $newexpfile
2145	}
2146
2147	proc ArchiveChoice {expfile} {
2148	set expnam [file rootname $expfile]
2149	set ans [MyMessageBox -parent . -title "Load Archived File" \
2150	-message "Loading archived version of $expnam. Do you want to continue using the same experiment name or work with the archived version under a new name?" \
2151	-icon question -type "{Use New Name} {Continue with current}" \
2152	-default {Use New Name} \
2153	-helplink "expguierr.html LoadArchived"
2154	]
2155	# archive the current .EXP file
2156	if {$ans != "use new name" && [file exists $expfile]} {
2157	# get the last archived version
2158	set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
2159	if {$lastf == ""} {
2160	set num 01
2161	} else {
2162	regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
2163	scan $num %x num
2164	if {$num >= 255} {
2165	set num FF
2166	} else {
2167	set num [string toupper [format %.2x [incr num]]]
2168	}
2169	}
2170	catch {
2171	set newfile $expnam.O$num
2172	file rename -force $expnam.EXP $newfile
2173	set fp [open $expnam.LST a+]
2174	puts $fp "\n----------------------------------------------"
2175	puts $fp " Regressing to archive file [file tail $expfile]"
2176	puts $fp " but first archiving [file tail $expnam.EXP] as [file tail $newfile]"
2177	puts $fp "----------------------------------------------\n"
2178	close $fp
2179	}
2180	file copy -force $expfile $expnam.EXP
2181	set expfile $expnam.EXP
2182	}
2183	if {$ans == "use new name"} {
2184	set newexpfile [getExpFileName new]
2185	if {$newexpfile == ""} {
2186	set expgui(FileMenuEXPNAM) ""
2187	return
2188	}
2189	file copy -force $expfile $newexpfile
2190	set expgui(needpowpref) 2
2191	set expgui(needpowpref_why) "\tA new .EXP file was created\n"
2192	return $newexpfile
2193	} else {
2194	return $expfile
2195	}
2196	}
2197
2198	# create an "empty" exp file
2199	proc CreateMTexpfile {newexpfile} {
2200	set expname [file tail $newexpfile]
2201	createexp $newexpfile \
2202	[getstring "title for experiment $expname" 60 0]
2203	if {! [file exists $newexpfile]} {
2204	update
2205	MyMessageBox -parent . -title "File Creation Error" \
2206	-message "Experiment file name \"$expname\" was not created -- This is unexpected, please try a different name" \
2207	-icon warning -type Continue -default continue
2208	set ::expgui(resize) 1
2209	return 1
2210	}
2211	return 0
2212	}
2213
2214	proc getExpFileName {mode} {
2215	global expgui tcl_platform
2216	set frm .file
2217	catch {destroy $frm}
2218	toplevel $frm
2219	wm title $frm "Experiment file"
2220	bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
2221	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
2222	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
2223	-fill y -expand yes
2224	pack [button $frmC.help -text Help -bg yellow \
2225	-command "MakeWWWHelp expguierr.html open"] \
2226	-side top -anchor e
2227	pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
2228	pack [radiobutton $frmC.1 -text "File Name" -value 1 \
2229	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
2230	pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
2231	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
2232
2233	set expgui(includearchived) 0
2234	set expgui(FileInfoBox) $frmC.info
2235	if {$mode == "old"} {
2236	pack [checkbutton $frmC.ar -text "Include Archived Files" \
2237	-variable expgui(includearchived) \
2238	-command "ChooseExpFil $frmA"] -side top -pady 10
2239	pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
2240	-class SmallFont] \
2241	-side top -fill both -expand yes -pady 5
2242	} elseif {$mode != "new"} {
2243	# for initial read, don't offer access to archived files
2244	pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
2245	-class SmallFont] \
2246	-side top -fill both -expand yes -pady 5
2247	set mode "old"
2248	}
2249	pack [button $frmC.b -text Read \
2250	-command "valid_exp_file $frmA $mode"] -side bottom
2251	if {$mode == "new"} {
2252	$frmC.b config -text Save
2253	}
2254	pack [button $frmC.q -text Cancel \
2255	-command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
2256	bind $frm <Return> "$frmC.b invoke"
2257
2258	if {$mode == "new"} {
2259	pack [label $frmA.0 -text "Enter an experiment file to create"] \
2260	-side top -anchor center
2261	} else {
2262	pack [label $frmA.0 -text "Select an experiment file to read"] \
2263	-side top -anchor center
2264	}
2265	expfilebox $frmA $mode
2266	# force the window to stay on top
2267	putontop $frm
2268	focus $frmC.b
2269	tkwait window $frm
2270	afterputontop
2271	if {$expgui(FileMenuEXPNAM) == ""} return
2272	#puts "end getexp $expgui(expfile)"
2273	return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2274	}
2275
2276	# validation routine
2277	# called from getExpFileName, either from Read button or from SelectExpFil (see expfilebox)
2278	proc valid_exp_file {frm mode} {
2279	global expgui tcl_platform
2280	# windows fixes
2281	if {$tcl_platform(platform) == "windows"} {
2282	# change backslashes to something sensible
2283	regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
2284	# allow entry of D: for D:/ and D:TEST for d:/TEST
2285	if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
2286	[string first :/ $expgui(FileMenuEXPNAM)] == -1} {
2287	regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
2288	}
2289	}
2290	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2291	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2292	ChooseExpFil $frm
2293	return
2294	} elseif [file isdirectory \
2295	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
2296	if {$expgui(FileMenuEXPNAM) != "."} {
2297	set expgui(FileMenuDir) \
2298	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2299	}
2300	ChooseExpFil $frm
2301	return
2302	}
2303	set ext [string toupper [file extension $expgui(FileMenuEXPNAM)]]
2304	if {$ext == ""} {
2305	# append a .EXP if not present
2306	append expgui(FileMenuEXPNAM) ".EXP"
2307	} elseif {[string match {*.O[0-9A-F][0-9A-F]} $ext] && \
2308	$mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
2309	# check for archive files
2310	destroy .file
2311	return
2312	} elseif {$ext != ".EXP"} {
2313	# check for files that end in something other than .EXP .exp or .Exp...
2314	MyMessageBox -parent . -title "File Open Error" \
2315	-message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
2316	-icon error
2317	return
2318	}
2319	# check on the file status
2320	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2321	if {$mode == "new" && [file exists $file]} {
2322	set ans [
2323	MyMessageBox -parent . -title "File Open Error" \
2324	-message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
2325	-icon question -type {"Select other" "Overwrite"} -default "select other" \
2326	-helplink "expguierr.html OverwriteErr"
2327	]
2328	if {[string tolower $ans] == "overwrite"} {destroy .file}
2329	return
2330	}
2331	# if file does not exist in case provided, set the name to all
2332	# upper case letters, since that is the best choice.
2333	# if it does exist, read from it as is. For UNIX we will force uppercase later.
2334	if {![file exists $file]} {
2335	set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
2336	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2337	}
2338	if {$mode == "old" && ![file exists $file]} {
2339	set ans [
2340	MyMessageBox -parent . -title "File Open Error" \
2341	-message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
2342	-icon question -type {"Select other" "Create"} -default "select other" \
2343	-helplink "expguierr.html OpenErr"
2344	]
2345	if {[string tolower $ans] == "create"} {
2346	if [CreateMTexpfile $file] return
2347	destroy .file
2348	}
2349	return
2350	}
2351	destroy .file
2352	}
2353
2354	proc updir {} {
2355	global expgui
2356	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
2357	}
2358
2359	# create a file box
2360	proc expfilebox {bx mode} {
2361	global expgui
2362	pack [frame $bx.top] -side top
2363	pack [label $bx.top.a -text "Directory" ] -side left
2364	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
2365	pack $bx.top.d -side left
2366	set expgui(FileMenuDir) [pwd]
2367	# the icon below is from tk8.0/tkfbox.tcl
2368	set upfolder [image create bitmap -data {
2369	#define updir_width 28
2370	#define updir_height 16
2371	static char updir_bits[] = {
2372	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
2373	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
2374	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
2375	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
2376	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
2377	0xf0, 0xff, 0xff, 0x01};}]
2378
2379	pack [button $bx.top.b -image $upfolder \
2380	-command "updir; ChooseExpFil $bx" ]
2381	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2382	listbox $bx.a.files -relief raised -bd 2 \
2383	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
2384	-height 15 -width 0 -exportselection 0
2385	listbox $bx.a.dates -relief raised -bd 2 \
2386	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
2387	-height 15 -width 0 -takefocus 0 -exportselection 0
2388	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2389	ChooseExpFil $bx
2390	bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2391	bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2392	bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
2393	bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
2394	pack $bx.a.scroll -side left -fill y
2395	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2396	pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2397	}
2398	proc sync2boxesX {master slave scroll args} {
2399	$slave xview moveto [lindex [$master xview] 0]
2400	eval $scroll set $args
2401	}
2402	proc move2boxesX {boxlist args} {
2403	foreach listbox $boxlist {
2404	eval $listbox xview $args
2405	}
2406	}
2407	proc sync2boxesY {master slave scroll args} {
2408	$slave yview moveto [lindex [$master yview] 0]
2409	eval $scroll set $args
2410	}
2411	proc move2boxesY {boxlist args} {
2412	foreach listbox $boxlist {
2413	eval $listbox yview $args
2414	}
2415	}
2416
2417	# creates a table that is scrollable in both x and y, use ResizeScrollTable
2418	# to set sizes after gridding the widgets
2419	proc MakeScrollTable {box} {
2420	proc sync2boxes {cmd master slave scroll args} {
2421	$slave $cmd moveto [lindex [$master $cmd] 0]
2422	eval $scroll set $args
2423	}
2424	proc move2boxes {cmd box1 box2 args} {
2425	eval $box1 $cmd $args
2426	eval $box2 $cmd $args
2427	}
2428	grid [label $box.0] -column 0 -row 0
2429	grid [canvas $box.top -scrollregion {0 0 10 10} \
2430	-xscrollcommand "sync2boxes xview $box.top $box.can $box.scroll" \
2431	-width 10 -height 10] -sticky sew -row 0 -column 1
2432	grid [canvas $box.side -scrollregion {0 0 10 10} \
2433	-yscrollcommand "sync2boxes yview $box.side $box.can $box.yscroll" \
2434	-width 10 -height 10] -sticky nes -row 1 -column 0
2435	grid [canvas $box.can -scrollregion {0 0 10 10} \
2436	-yscrollcommand "sync2boxes yview $box.can $box.side $box.yscroll" \
2437	-xscrollcommand "sync2boxes xview $box.can $box.top $box.scroll" \
2438	-width 200 -height 200 -bg lightgrey] -sticky news -row 1 -column 1
2439	grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2440	-command "move2boxes xview $box.can $box.top"]] \
2441	-sticky ew -row 2 -column 1
2442	grid [set sybox [scrollbar $box.yscroll \
2443	-command "move2boxes yview $box.can $box.side"]] \
2444	-sticky ns -row 1 -column 2
2445
2446	$box.top create window 0 0 -anchor nw -window [frame $box.top.f -bd 0]
2447	$box.can create window 0 0 -anchor nw -window [frame $box.can.f -bd 2]
2448	$box.side create window 0 0 -anchor nw -window [frame $box.side.f -bd 2]
2449	grid columnconfig $box 1 -weight 1
2450	grid rowconfig $box 1 -weight 1
2451	return [list $box.top.f $box.can.f $box.side.f $box.0]
2452	}
2453
2454	proc ResizeScrollTable {box} {
2455	update idletasks
2456	for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2457	set x1 [lindex [grid bbox $box.can.f $i 0] 2]
2458	set x2 [lindex [grid bbox $box.top.f $i 0] 2]
2459	if {$x2 > $x1} {set x1 $x2}
2460	grid columnconfigure $box.top.f $i -minsize $x1
2461	grid columnconfigure $box.can.f $i -minsize $x1
2462	}
2463	for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2464	set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2465	set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2466	if {$x2 > $x1} {set x1 $x2}
2467	grid rowconfigure $box.can.f $i -minsize $x1
2468	grid rowconfigure $box.side.f $i -minsize $x1
2469	}
2470	update idletasks
2471	set sizes [grid bbox $box.can.f]
2472	$box.can config -scrollregion $sizes
2473	$box.side config -scrollregion $sizes
2474	$box.top config -scrollregion $sizes
2475	$box.side config -width [lindex [grid bbox $box.side.f] 2]
2476	$box.top config -height [lindex [grid bbox $box.top.f] 3]
2477	# remove the scroll when not needed
2478	if {[lindex $sizes 3] > [winfo height $box.can]} {
2479	grid $box.yscroll -sticky ns -column 2 -row 1
2480	} else {
2481	grid forget $box.yscroll
2482	}
2483	if {[lindex $sizes 2] > [winfo width $box.can]} {
2484	grid $box.scroll -sticky ew -column 1 -row 2
2485	} else {
2486	grid forget $box.scroll
2487	}
2488	}
2489
2490	proc MouseWheelScrollTable {box} {
2491	# causes mouse wheel to operate scroll for main canvas in ScrollTable
2492	# mousewheel can be operated anywhere in parent window
2493	bind [winfo toplevel $box] <MouseWheel> "$box.can yview scroll \[expr {-abs(%D)/%D}\] unit"
2494	}
2495
2496
2497	# this is used in cifselect -- not sure why anymore
2498	proc ExpandScrollTable {box} {
2499	# set height & width of central box
2500	$box.can config -width \
2501	[expr [winfo width [winfo toplevel $box]] \
2502	- [winfo width $box.side] - [winfo width $box.yscroll]-20]
2503	$box.can config -height \
2504	[expr [winfo height [winfo toplevel $box]] \
2505	- [winfo height $box.top] - [winfo height $box.scroll]-25]
2506	}
2507	proc RevertExpFile {} {
2508	global expgui tcl_platform
2509	set frm .file
2510	catch {destroy $frm}
2511	toplevel $frm
2512	wm title $frm "Experiment file"
2513	bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
2514	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
2515	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
2516	-fill y -expand yes
2517	pack [button $frmC.help -text Help -bg yellow \
2518	-command "MakeWWWHelp expguierr.html open"] \
2519	-side top -anchor e
2520	set expgui(filesort) 0
2521	set expgui(includearchived) 1
2522	set expgui(FileInfoBox) $frmC.info
2523	pack [label $frmC.ar -text "(Showing Archived Files Only)"] -side top -pady 10
2524	pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
2525	-class SmallFont] \
2526	-side top -fill both -expand yes -pady 5
2527
2528	pack [button $frmC.b -text Read \
2529	-command "valid_exp_file $frmA old"] -side bottom
2530	pack [button $frmC.q -text Cancel \
2531	-command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
2532	bind $frm <Return> "$frmC.b invoke"
2533
2534	pack [label $frmA.0 -text "Select an archived experiment file to read"] \
2535	-side top -anchor center
2536	set bx $frmA
2537	pack [frame $bx.top] -side top
2538	#pack [label $bx.top.a -text "Directory" ] -side left
2539	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
2540	#pack $bx.top.d -side left
2541	#set expgui(FileMenuDir) [pwd]
2542	# the icon below is from tk8.0/tkfbox.tcl
2543	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2544	listbox $bx.a.files -relief raised -bd 2 \
2545	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
2546	-height 15 -width 0 -exportselection 0
2547	listbox $bx.a.dates -relief raised -bd 2 \
2548	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
2549	-height 15 -width 0 -takefocus 0 -exportselection 0
2550	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2551	ChooseExpFil $bx 1
2552	if {[llength [$bx.a.files get 0 end]] == 0} {
2553	destroy $frm
2554	MyMessageBox -parent . -title "No Archives" \
2555	-message "Sorry no archived versions of $::expgui(expfile) are present" \
2556	-icon warning -type ok -default ok
2557	return
2558	}
2559	bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2560	bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2561	bind $bx.a.files <Double-1> "SelectExpFil $bx old"
2562	bind $bx.a.dates <Double-1> "SelectExpFil $bx old"
2563	pack $bx.a.scroll -side left -fill y
2564	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2565	pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2566	# force the window to stay on top
2567	putontop $frm
2568	focus $frmC.b
2569	tkwait window $frm
2570	afterputontop
2571	if {$expgui(FileMenuEXPNAM) == ""} return
2572	return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2573	}
2574
2575	# support routine for SetHistUseFlags
2576	proc InitHistUseFlags {} {
2577	global expmap expgui
2578	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2579	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2580	set expgui(useflag_$i) [histinfo $i use]
2581	# }
2582	}
2583	}
2584
2585	# show all Powder histograms; set use/do not use flags
2586	proc SetHistUseFlags {} {
2587	set box .test
2588	catch {toplevel $box}
2589	eval destroy [winfo children $box]
2590	grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2591	grid [frame $box.a] -row 1 -column 0 -columnspan 2
2592	grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2593	grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2594	grid columnconfig $box 0 -weight 1
2595	grid columnconfig $box 1 -weight 1
2596	foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2597	$cbox config -text "Use\nFlag"
2598	[winfo parent $bbox] config -height 250 -width 400
2599	global expmap expgui
2600	set px 5
2601	set row -1
2602	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2603	if {[string range $expmap(htype_$i) 2 2] == "T"} {
2604	set det [format %8.2f [histinfo $i tofangle]]
2605	} elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2606	set det [format %8.5f [histinfo $i lam1]]
2607	} elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2608	set det [format %8.2f [histinfo $i lam1]]
2609	} else {
2610	set det {}
2611	}
2612	incr row
2613	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2614	grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0
2615	set expgui(useflag_$i) [histinfo $i use]
2616	# }
2617	grid [label $bbox.0$i \
2618	-text [string range $expmap(htype_$i) 0 3] \
2619	] -row $row -column 0 -padx $px
2620	grid [label $bbox.1$i -text [histinfo $i bank] \
2621	] -row $row -column 1 -padx $px
2622	grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2623	grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2624	] -row $row -column 3 -padx $px -sticky ew
2625	}
2626	grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2627	grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2628	grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2629	grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2630	ResizeScrollTable $box.a
2631	InitHistUseFlags
2632	putontop $box
2633	tkwait window $box
2634	afterputontop
2635	set prevchages $expgui(changed)
2636	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2637	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2638	if {$expgui(useflag_$i) != [histinfo $i use]} {
2639	histinfo $i use set $expgui(useflag_$i)
2640	RecordMacroEntry "histinfo $i use set $expgui(useflag_$i)" 0
2641	incr expgui(changed)
2642	RecordMacroEntry "incr expgui(changed)" 0
2643	}
2644	# }
2645	}
2646	if {$prevchages != $expgui(changed)} {
2647	set msg "You have changed [expr $expgui(changed)-$prevchages] "
2648	append msg "histogram flag(s). You must run POWPREF "
2649	append msg "to include/remove these histograms. Do you want to "
2650	append msg "run POWPREF?"
2651	set ans [MyMessageBox -parent . -message $msg \
2652	-title "Process changes?"\
2653	-helplink "expguierr.html ProcessUse" \
2654	-default {Run POWPREF} \
2655	-type {{Run POWPREF} Skip}]
2656
2657	if {$ans == "skip"} {
2658	# save and reload the experiment file
2659	savearchiveexp
2660	loadexp $expgui(expfile)
2661	} else {
2662	# run powpref and force a reload
2663	set saveautoload $expgui(autoexpload)
2664	set expgui(autoexpload) 1
2665	runGSASwEXP powpref
2666	set expgui(autoexpload) $saveautoload
2667	}
2668	}
2669	}
2670
2671	# set the box or file in the selection window
2672	proc ReleaseExpFil {frm} {
2673	global expgui
2674	set files $frm.a.files
2675	set dates $frm.a.dates
2676	set select [$files curselection]
2677	if {$select == ""} {
2678	set select [$dates curselection]
2679	}
2680	if {$select == ""} {
2681	set expgui(FileMenuEXPNAM) ""
2682	} else {
2683	set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2684	after idle UpdateInfoBox
2685	}
2686	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2687	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2688	ChooseExpFil $frm
2689	} elseif [file isdirectory \
2690	[file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2691	if {$expgui(FileMenuEXPNAM) != "."} {
2692	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2693	ChooseExpFil $frm
2694	}
2695	}
2696	return
2697	}
2698	<<<<<<< .mine
2699
2700	proc ScanEXPforError {"ns {}"} {
2701	# record types to ignore
2702	set ignorelist {DESCR HSTRY PNAM HNAM "REFN STATS"}
2703	set warn {}
2704	set badkeylist {}
2705	# scan file for warnings
2706	foreach key [array names ${ns}::exparray] {
2707	if {[string first "***" [set ${ns}::exparray($key)]] != -1 \|\|
2708	[string first "#IN" [set ${ns}::exparray($key)]] != -1 \|\|
2709	[string first "nan" [set ${ns}::exparray($key)]] != -1 \|\|
2710	[string first "NAN" [set ${ns}::exparray($key)]] != -1
2711	} {
2712	#puts [set ${ns}::exparray($key)]
2713	set OK 0
2714	foreach i $ignorelist {
2715	if {[string first $i $key] != -1} {
2716	set OK 1
2717	break
2718	}
2719	}
2720	# ignore atom name section of Atom records
2721	if {(! $OK) && [string match "CRSATA" $key]} {
2722	foreach str [list [string range [set ${ns}::exparray($key)] 0 49]
2723	[string range [set ${ns}::exparray($key)] 58 end]] {
2724	if {[string first "***" $str] \|\|
2725	[string first "#INF" $str] \|\|
2726	[string first "nan" $str] \|\|
2727	[string first "NAN" $str]} {
2728	append warn " Record \"$key\": [set ${ns}::exparray($key)]\n"
2729	lappend badkeylist $key
2730	break
2731	}
2732	}
2733	continue
2734	}
2735	if {! $OK} {
2736	append warn " Record \"$key\": [set ${ns}::exparray($key)]\n"
2737	lappend badkeylist $key
2738	}
2739	}
2740	}
2741	if {$warn == ""} return
2742	set hint ""
2743	set unknown ""
2744	foreach key $badkeylist {
2745	if {[string match "CRSAT" $key]} {
2746	if {[string first "atomic parameter" $hint] == -1} {
2747	append hint "\t* An atomic parameter (coordinate, occupancy or U) appears out of range\n"
2748	}
2749	} elseif {[string match "CRSABC" $key] \|\|
2750	[string match "CRSANGLES" $key] \|\|
2751	[string match "CRSCELVOL" $key]} {
2752	if {[string first "cell parameter" $hint] == -1} {
2753	append hint "\t* A unit cell parameter appears out of range\n"
2754	}
2755	} elseif {[string match "CRSODF" $key]} {
2756	if {[string first "spherical harmonic" $hint] == -1} {
2757	append hint "\t* A spherical harmonic (ODF) parameter appears out of range\n"
2758	}
2759	} elseif {[string match "HST*ICONS" $key]} {
2760	if {[string first "diffractometer constant" $hint] == -1} {
2761	append hint "\t* A diffractometer constant (wave, DIFC,...) appears out of range\n"
2762	}
2763	} elseif {[string match "HST*TRNGE" $key]} {
2764	if {[string first "histogram data range" $hint] == -1} {
2765	append hint "\t* A histogram data range value appears out of range\n"
2766	}
2767	} elseif {[string match "GNLS RUN" $key] \|\|
2768	[string match "*GNLS SHFTS" $key] \|\|
2769	[string match "HST*RPOWD" $key] \|\|
2770	[string match " REFN RPOWD " $key] \|\|
2771	[string match " REFN GDNFT " $key]
2772	} {
2773	if {[string first "refinement statistics" $hint] == -1} {
2774	append hint "\t* The refinement statistics imply the last refinement diverged\n"
2775	}
2776	} else {
2777	lappend unknown $key
2778	}
2779	}
2780	if {$unknown != ""} {
2781	append hint "\t* The following less common problem record(s) appear out of range:\n\t\t"
2782	foreach key $unknown {
2783	append hint "\"" [string trim $key] "\" "
2784	}
2785	}
2786	return "Likely error(s) noted:\n$hint\nDetails of problem(s):\n$warn"
2787	}
2788
2789	proc ExplainEXPerror {parent message file} {
2790	if {$parent == "."} {
2791	set w .experr
2792	} else {
2793	set w $parent.experr
2794	}
2795	catch {destroy $w}
2796	toplevel $w -class Dialog
2797	wm title $w "Corrupt .EXP file"
2798	wm iconname $w Dialog
2799	wm protocol $w WM_DELETE_WINDOW { }
2800	# Make the message box transient if the parent is viewable.
2801	if {[winfo viewable [winfo toplevel $parent]] } {
2802	wm transient $w $parent
2803	}
2804	frame $w.bot
2805	pack $w.bot -side bottom -fill both
2806	frame $w.top
2807	pack $w.top -side top -fill both -expand 1
2808	frame $w.msg
2809	pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
2810	set txt {Likely errors were noted when reading this file}
2811	append txt " ([file tail $file]). "
2812	append txt "These problems probably\narose from the last refinement, "
2813	append txt "based on settings applied in the previous saved file.\n"
2814	append txt "It is probably not possible to continue with this file.\n"
2815	append txt "You likely need to revert at least two archived versions back."
2816	grid [label $w.msg.s -text $txt -justify left] -row 0 -column 0 -sticky nws
2817	grid [button $w.msg.1 -text Help -bg yellow \
2818	-command "MakeWWWHelp expgui.html badexp"] -row 0 -column 1 -columnspan 2 -sticky ne
2819	bind $w <Key-F1> "MakeWWWHelp expgui.html badexp"
2820	set filelist [lsort -dictionary -decreasing \
2821	[glob -nocomplain \
2822	[file root $file.O* ]]]
2823	grid [text $w.msg.t -font {Times 12} \
2824	-height 10 -width 90 -relief flat -wrap word \
2825	-yscrollcommand "$w.msg.rscr set" \
2826	] -row 1 -column 0 -columnspan 2 -sticky news
2827	grid [scrollbar $w.msg.rscr -command "$w.msg.t yview" \
2828	] -row 1 -column 2 -sticky ns
2829	# give extra space to the text box
2830	grid columnconfigure $w.msg 0 -weight 1
2831	grid rowconfigure $w.msg 1 -weight 1
2832	$w.msg.t insert end $message
2833	button $w.ok -command [list destroy $w] -text OK -default active
2834	pack $w.ok -in $w.bot -side left -expand 1 -padx 3m -pady 2m
2835	putontop $w
2836	tkwait window $w
2837	afterputontop
2838	}
2839
2840	=======
2841
2842	proc ScanEXPforError {"ns {}"} {
2843	# record types to ignore
2844	set ignorelist {DESCR HSTRY PNAM HNAM "REFN STATS"}
2845	set warn {}
2846	set badkeylist {}
2847	# scan file for warnings
2848	foreach key [array names ${ns}::exparray] {
2849	if {[string first "***" [set ${ns}::exparray($key)]] != -1 \|\|
2850	[string first "nan" [set ${ns}::exparray($key)]] != -1 \|\|
2851	[string first "NAN" [set ${ns}::exparray($key)]] != -1
2852	} {
2853	#puts [set ${ns}::exparray($key)]
2854	set OK 0
2855	foreach i $ignorelist {
2856	if {[string first $i $key] != -1} {
2857	set OK 1
2858	break
2859	}
2860	}
2861	# ignore atom name section of Atom records
2862	if {(! $OK) && [string match "CRSATA" $key]} {
2863	foreach str [list [string range [set ${ns}::exparray($key)] 0 49]
2864	[string range [set ${ns}::exparray($key)] 58 end]] {
2865	if {[string first "***" $str] \|\| [string first "nan" $str] \|\| [string first "NAN" $str]} {
2866	append warn " Record \"$key\": [set ${ns}::exparray($key)]\n"
2867	lappend badkeylist $key
2868	break
2869	}
2870	}
2871	continue
2872	}
2873	if {! $OK} {
2874	append warn " Record \"$key\": [set ${ns}::exparray($key)]\n"
2875	lappend badkeylist $key
2876	}
2877	}
2878	}
2879	if {$warn == ""} return
2880	set hint ""
2881	set unknown ""
2882	foreach key $badkeylist {
2883	if {[string match "CRSAT" $key]} {
2884	if {[string first "atomic parameter" $hint] == -1} {
2885	append hint "\t* An atomic parameter (coordinate, occupancy or U) appears out of range\n"
2886	}
2887	} elseif {[string match "CRSABC" $key] \|\|
2888	[string match "CRSANGLES" $key] \|\|
2889	[string match "CRSCELVOL" $key]} {
2890	if {[string first "cell parameter" $hint] == -1} {
2891	append hint "\t* A unit cell parameter appears out of range\n"
2892	}
2893	} elseif {[string match "CRSODF" $key]} {
2894	if {[string first "spherical harmonic" $hint] == -1} {
2895	append hint "\t* A spherical harmonic (ODF) parameter appears out of range\n"
2896	}
2897	} elseif {[string match "HST*ICONS" $key]} {
2898	if {[string first "diffractometer constant" $hint] == -1} {
2899	append hint "\t* A diffractometer constant (wave, DIFC,...) appears out of range\n"
2900	}
2901	} elseif {[string match "HST*TRNGE" $key]} {
2902	if {[string first "histogram data range" $hint] == -1} {
2903	append hint "\t* A histogram data range value appears out of range\n"
2904	}
2905	} elseif {[string match "GNLS RUN" $key] \|\|
2906	[string match "*GNLS SHFTS" $key] \|\|
2907	[string match "HST*RPOWD" $key] \|\|
2908	[string match " REFN RPOWD " $key] \|\|
2909	[string match " REFN GDNFT " $key]
2910	} {
2911	if {[string first "refinement statistics" $hint] == -1} {
2912	append hint "\t* The refinement statistics imply the last refinement diverged\n"
2913	}
2914	} else {
2915	lappend unknown $key
2916	}
2917	}
2918	if {$unknown != ""} {
2919	append hint "\t* The following less common problem record(s) appear out of range:\n\t\t"
2920	foreach key $unknown {
2921	append hint "\"" [string trim $key] "\" "
2922	}
2923	}
2924	return "Likely error(s) noted:\n$hint\nDetails of problem(s):\n$warn"
2925	}
2926
2927	proc ExplainEXPerror {parent message file} {
2928	if {$parent == "."} {
2929	set w .experr
2930	} else {
2931	set w $parent.experr
2932	}
2933	catch {destroy $w}
2934	toplevel $w -class Dialog
2935	wm title $w "Corrupt .EXP file"
2936	wm iconname $w Dialog
2937	wm protocol $w WM_DELETE_WINDOW { }
2938	# Make the message box transient if the parent is viewable.
2939	if {[winfo viewable [winfo toplevel $parent]] } {
2940	wm transient $w $parent
2941	}
2942	frame $w.bot
2943	pack $w.bot -side bottom -fill both
2944	frame $w.top
2945	pack $w.top -side top -fill both -expand 1
2946	frame $w.msg
2947	pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
2948	set txt {Likely errors were noted when reading this file}
2949	append txt " ([file tail $file]). "
2950	append txt "These problems probably\narose from the last refinement, "
2951	append txt "based on settings applied in the previous saved file.\n"
2952	append txt "It is probably not possible to continue with this file.\n"
2953	append txt "You likely need to revert at least two archived versions back."
2954	grid [label $w.msg.s -text $txt -justify left] -row 0 -column 0 -sticky nws
2955	grid [button $w.msg.1 -text Help -bg yellow \
2956	-command "MakeWWWHelp expgui.html badexp"] -row 0 -column 1 -columnspan 2 -sticky ne
2957	bind $w <Key-F1> "MakeWWWHelp expgui.html badexp"
2958	set filelist [lsort -dictionary -decreasing \
2959	[glob -nocomplain \
2960	[file root $file.O* ]]]
2961	grid [text $w.msg.t -font {Times 12} \
2962	-height 10 -width 90 -relief flat -wrap word \
2963	-yscrollcommand "$w.msg.rscr set" \
2964	] -row 1 -column 0 -columnspan 2 -sticky news
2965	grid [scrollbar $w.msg.rscr -command "$w.msg.t yview" \
2966	] -row 1 -column 2 -sticky ns
2967	# give extra space to the text box
2968	grid columnconfigure $w.msg 0 -weight 1
2969	grid rowconfigure $w.msg 1 -weight 1
2970	$w.msg.t insert end $message
2971	button $w.ok -command [list destroy $w] -text OK -default active
2972	pack $w.ok -in $w.bot -side left -expand 1 -padx 3m -pady 2m
2973	putontop $w
2974	tkwait window $w
2975	afterputontop
2976	}
2977
2978	>>>>>>> .r1118
2979	proc UpdateInfoBox {} {
2980	global expgui
2981	if {![winfo exists $expgui(FileInfoBox)]} return
2982	eval destroy [winfo children $expgui(FileInfoBox)]
2983	set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2984	if [file isdirectory $file] return
2985	if [file exists $file] {
2986	pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2987	-side top
2988	catch {
2989	# load the EXP file into a namespace & scan for errors
2990	expload $file scan
2991	set warnings [ScanEXPforError scan]
2992	if {$warnings != ""} {
2993	pack [frame $expgui(FileInfoBox).1a -bg yellow -padx 4 -pady 4] -side top
2994	pack [label $expgui(FileInfoBox).1a.err -justify left \
2995	-text "WARNING: Likely corrupt" -bg yellow] \
2996	-side left -anchor w -fill both
2997	pack [button $expgui(FileInfoBox).1a.show \
2998	-text "More..." -padx 0 \
2999	-command "ExplainEXPerror $expgui(FileInfoBox) [list $warnings] $file"\
3000	] -side right -anchor w
3001	}
3002	set fp [open $file r]
3003	global testline
3004	set testline [read $fp]
3005	close $fp
3006	update
3007	regexp {GNLS RUN on (.) +Total.run *([0-9]+) } \
3008	$testline a last cycles
3009	pack [label $expgui(FileInfoBox).2 -justify left \
3010	-text "last GENLES run:\n $last\n total cycles: $cycles"] \
3011	-side top -anchor w
3012	set chi2 ?
3013	set vars ?
3014	regexp {REFN GDNFT.= ([0-9]\.[0-9]) +for *([0-9]+) variables} \
3015	$testline a chi2 vars
3016	pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
3017	-side top -anchor w
3018	pack [label $expgui(FileInfoBox).3.a -justify left \
3019	-text "c" -font symbol] \
3020	-side left -anchor w
3021	pack [label $expgui(FileInfoBox).3.b -justify left \
3022	-text "2: $chi2, $vars vars"] \
3023	-side top -anchor w
3024	# check first 9 histograms
3025	set lbl "h Rwp R(F2)"
3026	set n 0
3027	foreach k {1 2 3 4 5 6 7 8 9} {
3028	set key "HST $k"
3029	append key { RPOWD +([0-9]\.[0-9]) }
3030	set i [regexp $key $testline a Rwp]
3031	set key "HST $k"
3032	append key { R-FAC +[0-9]+ +([0-9]\.[0-9]) }
3033	set j [regexp $key $testline a Rb]
3034	if {$i \|\| $j} {
3035	incr n
3036	append lbl "\n$k "
3037	if {$i} {
3038	append lbl [string range $Rwp 0 5]
3039	} else {
3040	append lbl " "
3041	}
3042	}
3043	if {$j} {
3044	append lbl " [string range $Rb 0 5]"
3045	}
3046	# stick 1st 3 entries in box
3047	if {$n >= 3} break
3048	}
3049	pack [label $expgui(FileInfoBox).4 -justify left \
3050	-text $lbl] \
3051	-side top -anchor w
3052	} err
3053	}
3054	}
3055
3056	# select a file or directory -- called on double click
3057	proc SelectExpFil {frm mode} {
3058	global expgui
3059	set files $frm.a.files
3060	set dates $frm.a.dates
3061	set select [$files curselection]
3062	if {$select == ""} {
3063	set select [$dates curselection]
3064	}
3065	if {$select == ""} {
3066	set file .
3067	} else {
3068	set file [string trim [$files get $select]]
3069	}
3070	if {$file == "<Parent>"} {
3071	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
3072	ChooseExpFil $frm
3073	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
3074	if {$file != "."} {
3075	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
3076	ChooseExpFil $frm
3077	}
3078	} else {
3079	set expgui(FileMenuEXPNAM) [file tail $file]
3080	valid_exp_file $frm $mode
3081	}
3082	}
3083
3084	# fill the files & dates & Directory selection box with current directory,
3085	# also called when box is created to fill it
3086	proc ChooseExpFil {frm "archiveonly 0"} {
3087	global expgui
3088	set files $frm.a.files
3089	set dates $frm.a.dates
3090	set expgui(FileMenuEXPNAM) {}
3091	$files delete 0 end
3092	$dates delete 0 end
3093	if {$archiveonly == 0} {
3094	$files insert end {<Parent>}
3095	$dates insert end {(Directory)}
3096	set filelist [glob -nocomplain \
3097	[file join [set expgui(FileMenuDir)] *] ]
3098	foreach file [lsort -dictionary $filelist] {
3099	if {[file isdirectory $file]} {
3100	$files insert end [file tail $file]
3101	$dates insert end {(Directory)}
3102	}
3103	}
3104	} else {
3105	set filelist [glob -nocomplain \
3106	[file root $expgui(expfile)].O* ]
3107	}
3108	set pairlist {}
3109	foreach file [lsort -dictionary $filelist] {
3110	if {![file isdirectory $file] && \
3111	[string toupper [file extension $file]] == ".EXP" \
3112	&& $archiveonly == 0} {
3113	set modified [file mtime $file]
3114	lappend pairlist [list $file $modified]
3115	} elseif {![file isdirectory $file] && $expgui(includearchived) && \
3116	[string match {*.O[0-9A-F][0-9A-F]} $file]} {
3117	set modified [file mtime $file]
3118	lappend pairlist [list $file $modified]
3119	}
3120	}
3121	if {$expgui(filesort) == 0} {
3122	foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
3123	set file [lindex $pair 0]
3124	set modified [clock format [lindex $pair 1] -format "%T %D"]
3125	$files insert end [file tail $file]
3126	$dates insert end $modified
3127	}
3128	} else {
3129	foreach pair [lsort -dictionary -index 0 $pairlist] {
3130	set file [lindex $pair 0]
3131	set modified [clock format [lindex $pair 1] -format "%T %D"]
3132	$files insert end [file tail $file]
3133	$dates insert end $modified
3134	}
3135	}
3136	$expgui(FileDirButtonMenu) delete 0 end
3137	set list ""
3138	global tcl_platform tcl_version
3139	if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
3140	catch {set list [string tolower [file volume]]}
3141	}
3142	set dir ""
3143	foreach subdir [file split [set expgui(FileMenuDir)]] {
3144	set dir [file join $dir $subdir]
3145	if {$tcl_platform(platform) == "windows"} {
3146	set dir [string tolower $dir]
3147	if {[lsearch $list $dir] == -1} {lappend list $dir}
3148	} else {
3149	lappend list $dir
3150	}
3151	}
3152	foreach path $list {
3153	$expgui(FileDirButtonMenu) add command -label $path \
3154	-command "[list set expgui(FileMenuDir) $path]; \
3155	ChooseExpFil $frm"
3156	}
3157	# highlight the current experiment -- if present
3158	for {set i 0} {$i < [$files size]} {incr i} {
3159	set file [$files get $i]
3160	if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
3161	$files selection set $i
3162	set expgui(FileMenuEXPNAM) $file
3163	UpdateInfoBox
3164	}
3165	}
3166	return
3167	}
3168
3169
3170	#------------------------------------------------------------------------------
3171	# platform-specific definitions
3172	if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
3173	# windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
3174	# DOS box synchronously, so we create a "lock" file that is deleted
3175	# at the end of the DOS run so we can tell when the run is done.
3176	# We create a window to force the deleting of the file so that if
3177	# the DOS process crashes, the user can continue anyway.
3178	#
3179	# procedure to check if the lock file is still there (Win-9x/me only)
3180	proc checklockfile {file window} {
3181	if [file exists $file] {
3182	after 500 checklockfile $file $window
3183	} else {
3184	catch {destroy $window}
3185	}
3186	}
3187	# this procedure starts the GRWND program, if needed for program $prog
3188	proc StartGRWND {prog} {
3189	global expgui
3190	if {!$expgui(autoGRWND)} return
3191	# at some point we might want to have a real list
3192	if {$prog != "genles" && $prog != "powpref"} {
3193	# get a list of running jobs
3194	exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
3195	set fp [open tlist.tlist r]
3196	set text [read $fp]
3197	close $fp
3198	file delete -force tlist.tlist
3199	# if GRWND.EXE is not currently running, start it
3200	if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
3201	exec [file join $expgui(gsasexe) grwnd.exe] &
3202	# give grwnd a 1 second head start
3203	after 1000
3204	}
3205	}
3206	}
3207	# this creates a DOS box to run a program in
3208	proc forknewterm {title command "wait 1" "scrollbar 1"} {
3209	global env expgui
3210	# Windows environment variables
3211	set env(GSAS) [file nativename $expgui(gsasdir)]
3212	# PGPLOT_FONT is needed by PGPLOT
3213	set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
3214	# this is the number of lines/page in the .LST (etc.) file
3215	set env(LENPAGE) 60
3216	set pwd [file nativename [pwd]]
3217
3218	# check the .EXP path -- can DOS use it?
3219	if {[string first // [pwd]] != -1} {
3220	MyMessageBox -parent . -title "Invalid Path" \
3221	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
3222	-icon error -type ok -default ok \
3223	-helplink "expgui_Win_readme.html NetPath"
3224	return
3225	}
3226	if {[info command winutils::shell] == "" && \
3227	[info command winexec] == ""} {
3228	MyMessageBox -parent . -title "Setup error" \
3229	-message {Error -- Use "Neither WINEXEC not WINTILS were found. Can't do anything!"} \
3230	-icon error -type darn -default darn \
3231	-helplink "expgui_Win_readme.html Winexec"
3232	return
3233	}
3234	# loop over multiple commands
3235	foreach cmd $command {
3236	# simulate the wait with a lock file
3237	if {$wait} {
3238	if {$expgui(autoiconify)} {wm iconify .}
3239	# create a blank lock file and a message window
3240	close [open expgui.lck w]
3241	toplevel .lock
3242	grid [button .lock.0 -text Help -bg yellow \
3243	-command "MakeWWWHelp expguierr.html lock"] \
3244	-column 1 -row 0
3245	grid [label .lock.1 \
3246	-text "Please wait while the GSAS program finishes."] \
3247	-column 0 -row 0
3248	grid [label .lock.2 -text \
3249	"In case a problem occurs, close the DOS box"] \
3250	-column 0 -columnspan 2 -row 1
3251	grid [label .lock.3 -text \
3252	"and press the \"Continue\" button (below)"] \
3253	-column 0 -columnspan 2 -row 2
3254	grid [button .lock.b -text "Continue" \
3255	-command "destroy .lock; wm deiconify ."] \
3256	-column 0 -columnspan 2 -row 3
3257	putontop .lock
3258	update
3259	checklockfile expgui.lck .lock
3260	}
3261
3262	# pause is hard coded in the GSASTCL.BAT file
3263	if {$expgui(execprompt)} {
3264	set script gsastcl.bat
3265	} else {
3266	set script gsasnowt.bat
3267	}
3268
3269	# replace the forward slashes with backward
3270	regsub -all / $cmd \\ cmd
3271	if {[info command winutils::shell] != ""} {
3272	winutils::shell [file join $expgui(scriptdir) $script] $cmd
3273	} else {
3274	winexec -d [file nativename [pwd]] \
3275	[file join $expgui(scriptdir) $script] $cmd
3276	}
3277	if {$expgui(MacroRunning)} {
3278	update
3279	update idletasks
3280	}
3281	if {$wait} {
3282	tkwait window .lock
3283	file delete -force expgui.lck
3284	}
3285	}
3286	if {$expgui(autoiconify) && $wait} {wm deiconify .}
3287	# check for changes in the .EXP file immediately
3288	whenidle
3289	}
3290	} elseif {$tcl_platform(platform) == "windows"} {
3291	# now for Windows-NT, where we can run synchronously
3292	#
3293	# this creates a DOS box to run a program in
3294	proc forknewterm {title command "wait 1" "scrollbar 1"} {
3295	global env expgui
3296	# Windows environment variables
3297	set env(GSAS) [file nativename $expgui(gsasdir)]
3298	# PGPLOT_FONT is needed by PGPLOT
3299	set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
3300	set env(PGPLOT_DIR) $expgui(pgplotdir)
3301	# this is the number of lines/page in the .LST (etc.) file
3302	set env(LENPAGE) 60
3303	set pwd [file nativename [pwd]]
3304	# check the path -- can DOS use it?
3305	if {[string first // [pwd]] != -1} {
3306	MyMessageBox -parent . -title "Invalid Path" \
3307	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
3308	-icon error -type ok -default ok \
3309	-helplink "expgui_Win_readme.html NetPath"
3310	return
3311	}
3312	# pause is hard coded in the .BAT file
3313	if {$expgui(execprompt)} {
3314	set script gsastcl.bat
3315	} else {
3316	set script gsasnowt.bat
3317	}
3318
3319	if {$wait} {
3320	if {$expgui(autoiconify)} {wm iconify .}
3321	# create a blank lock file (keep liveplot from running)
3322	close [open expgui.lck w]
3323	# loop over commands
3324	foreach cmd $command {
3325	# replace the forward slashes with backward
3326	regsub -all / $cmd \\ cmd
3327	# use of file attributes -shortname & normalize and nativename
3328	# might help here
3329	exec $env(COMSPEC) /c \
3330	"start [file attributes [file join $expgui(scriptdir) $script] -shortname] $cmd"
3331	}
3332	file delete -force expgui.lck
3333	if {$expgui(autoiconify)} {wm deiconify .}
3334	# check for changes in the .EXP file immediately
3335	whenidle
3336	} else {
3337	# loop over commands
3338	foreach cmd $command {
3339	# replace the forward slashes with backward
3340	regsub -all / $cmd \\ cmd
3341	# run in background
3342	exec $env(COMSPEC) /c \
3343	"start [file attributes [file join $expgui(scriptdir) $script] -shortname] $cmd"
3344	if {$expgui(MacroRunning)} {
3345	update
3346	update idletasks
3347	}
3348	}
3349	}
3350	}
3351	} else {
3352	# UNIX-based machines
3353	if {[auto_execok xterm] != ""} {
3354	# this creates a xterm window for running programs inside
3355	proc forknewterm {title command "wait 1" "scrollbar 1"} {
3356	global env expgui
3357	# UNIX environment variables
3358	set env(GSAS) [file nativename $expgui(gsasdir)]
3359	set env(gsas) [file nativename $expgui(gsasdir)]
3360	set env(GSASEXE) $expgui(gsasexe)
3361	set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
3362	set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
3363	# PGPLOT_DIR is needed by PGPLOT
3364	set env(PGPLOT_DIR) $expgui(pgplotdir)
3365	# this is the number of lines/page in the .LST (etc.) file
3366	set env(LENPAGE) 60
3367	set termopts {}
3368	if $env(GSASBACKSPACE) {
3369	append termopts \
3370	{-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
3371	}
3372	if $scrollbar {
3373	append termopts " -sb"
3374	} else {
3375	append termopts " +sb"
3376	}
3377	if {$wait} {
3378	set suffix {}
3379	} else {
3380	set suffix {&}
3381	}
3382
3383	# hold window open after commands finish
3384	if {$expgui(execprompt)} {
3385	append command "\; echo -n Press Enter to continue \; read x"
3386	}
3387	if {$wait && $expgui(autoiconify)} {wm iconify .}
3388	catch {eval exec xterm $termopts -title [list $title] \
3389	-e /bin/sh -c [list $command] $suffix} errmsg
3390	if $expgui(debug) {puts "xterm result = $errmsg"}
3391	if {$expgui(MacroRunning)} {
3392	update
3393	update idletasks
3394	}
3395	if {$wait} {
3396	if {$expgui(autoiconify)} {wm deiconify .}
3397	# check for changes in the .EXP file immediately
3398	whenidle
3399	}
3400	}
3401	} elseif {[auto_execok gnome-terminal] != ""} {
3402	# this creates a xterm window for running programs inside
3403	proc forknewterm {title command "wait 1" "scrollbar 1"} {
3404	global env expgui
3405	# UNIX environment variables
3406	set env(GSAS) [file nativename $expgui(gsasdir)]
3407	set env(gsas) [file nativename $expgui(gsasdir)]
3408	set env(GSASEXE) $expgui(gsasexe)
3409	set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
3410	set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
3411	# PGPLOT_DIR is needed by PGPLOT
3412	set env(PGPLOT_DIR) $expgui(pgplotdir)
3413	# this is the number of lines/page in the .LST (etc.) file
3414	set env(LENPAGE) 60
3415	if {$wait} {
3416	set suffix {}
3417	} else {
3418	set suffix {&}
3419	}
3420
3421	# hold window open after commands finish
3422	if {$expgui(execprompt)} {
3423	append command "\; echo -n Press Enter to continue \; read x"
3424	}
3425	if {$wait && $expgui(autoiconify)} {wm iconify .}
3426	catch {exec gnome-terminal --title $title \
3427	-e " /bin/sh -c \" $command \" " $suffix} errmsg
3428	if $expgui(debug) {puts "gnome-terminal result = $errmsg"}
3429	if {$expgui(MacroRunning)} {
3430	update
3431	update idletasks
3432	}
3433	if {$wait} {
3434	if {$expgui(autoiconify)} {wm deiconify .}
3435	# check for changes in the .EXP file immediately
3436	whenidle
3437	}
3438	}
3439	} else {
3440	MyMessageBox -parent . -title "Error: no terminal program" \
3441	-message "Error, the xterm or gnome-terminal utility programs could not be found. It is not possible to run the GSAS programs without this." \
3442	-icon error -type NOT-OK -default not-ok
3443	}
3444	}
3445
3446	# run commands without a terminal window
3447	proc runnoterm {command outfile} {
3448	global env expgui tcl_platform
3449	if {$tcl_platform(platform) == "windows"} {
3450	# Windows environment variables
3451	set env(GSAS) [file nativename $expgui(gsasdir)]
3452	# PGPLOT_FONT is needed by PGPLOT
3453	set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
3454	# this is the number of lines/page in the .LST (etc.) file
3455	set env(LENPAGE) 60
3456	set pwd [file nativename [pwd]]
3457	# loop over multiple commands
3458	foreach cmd $command {
3459	# replace the forward slashes with backward
3460	regsub -all / $cmd \\ cmd
3461	exec $cmd >>& $outfile
3462	update
3463	update idletasks
3464	}
3465	} else {
3466	# UNIX environment variables
3467	set env(GSAS) [file nativename $expgui(gsasdir)]
3468	set env(gsas) [file nativename $expgui(gsasdir)]
3469	set env(GSASEXE) $expgui(gsasexe)
3470	set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
3471	set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
3472	# PGPLOT_DIR is needed by PGPLOT
3473	set env(PGPLOT_DIR) $expgui(pgplotdir)
3474	# this is the number of lines/page in the .LST (etc.) file
3475	set env(LENPAGE) 60
3476	foreach cmd $command {
3477	catch {eval exec $cmd >>& $outfile} errmsg
3478	}
3479	update
3480	update idletasks
3481	}
3482	# check for changes in the .EXP file immediately
3483	#whenidle
3484	}
3485
3486	proc MacMakeResource {file app} {
3487	# make a resource file. Note that OS X has gotten picky about the length of this
3488	set l [string length $app]
3489	if $::expgui(debug) {puts "$l bytes"}
3490	incr l
3491	if $::expgui(debug) {puts "$l bytes after incr"}
3492	set str "data 'usro' (0) {\n"
3493	append str " $\""
3494	append str [format %.8X $l]
3495	set bytes 4
3496	foreach char [split $app {}] {
3497	append str [format %.2X [scan $char %c]]
3498	}
3499	incr bytes $l
3500	set newline 1
3501	for {set i 0} {$i < [expr 1028-$bytes]} {incr i} {
3502	if $newline {
3503	append str "\" \n"
3504	append str " $\""
3505	set newline 0
3506	set j 0
3507	}
3508	append str {0000 }
3509	incr bytes
3510	incr j 2
3511	if {$j > 15} {set newline 1}
3512	}
3513	if {$l % 2} {
3514	append str "\"\n "
3515	} else {
3516	# even lengths need one more byte
3517	append str "00\"\n "
3518	}
3519	append str "/* $app */\n};\n"
3520	set fp [open $file w]
3521	puts $fp $str
3522	close $fp
3523	}
3524
3525	# modify resource fork info for a .EXP file on the Mac
3526	proc MacSetResourceFork {expfile} {
3527	global expgui tcl_platform
3528	if {$tcl_platform(os) != "Darwin"} {return}
3529	set expnative [file nativename $expfile]
3530	#
3531	# assign an app to the data file, if the app and the
3532	# required tool (Rez) are installed
3533	set app [file nativename [file join $expgui(gsasdir) expgui.app]]
3534	set RezApp {}
3535	foreach pth "/usr/bin /Developer/Tools $expgui(gsasexe)" {
3536	if [file exists [set tst [file join $pth Rez]]] {
3537	set RezApp $tst
3538	break
3539	}
3540	}
3541	set SetFileApp {}
3542	foreach pth "/usr/bin /Developer/Tools $expgui(gsasexe)" {
3543	if [file exists [set tst [file join $pth SetFile]]] {
3544	set SetFileApp $tst
3545	break
3546	}
3547	}
3548	if $::expgui(debug) {puts "found app=$app Rez=$RezApp and SetFile=$SetFileApp"}
3549	if {[file exists $app] && $RezApp != ""} {
3550	# make resource file
3551	MacMakeResource setapp.r $app
3552	if $::expgui(debug) {puts "$RezApp setapp.r -o $expnative -a"}
3553	exec $RezApp setapp.r -o $expnative -a
3554	if {! $::expgui(debug)} {
3555	file delete -force setapp.r
3556	}
3557	}
3558
3559	# assign an icon to the data file, if it and the required tools exist
3560	set icon [file join $expgui(gsasexe) gsasicon.r]
3561	if {[file exists $icon] && $RezApp != "" && $SetFileApp != ""} {
3562	exec $RezApp [file nativename $icon] -o $expnative -a
3563	exec $SetFileApp -a C $expnative
3564	if {$::expgui(debug)} {
3565	puts "$RezApp [file nativename $icon] -o $expnative -a"
3566	puts "$SetFileApp -a C $expnative"
3567	}
3568	} elseif {$::expgui(debug)} {
3569	puts "icon=$icon missing?"
3570	}
3571	}
3572
3573	#-------------------------------------------------------------------------------
3574	# Macro Recording
3575	#-------------------------------------------------------------------------------
3576	set expgui(MacroBufferedCommand) ""
3577	set expgui(fpMacroFile) ""
3578	set expgui(MacroFile) ""
3579	# Turn on/off mode to save commands in MacroFile
3580	proc SetRecordMacroOnOff {args} {
3581	global expgui
3582	if {$expgui(RecordMacro)} {
3583	set expgui(fpMacroFile) ""
3584	set expgui(MacroBufferedCommand) ""
3585	while {$expgui(fpMacroFile) == ""} {
3586	set expgui(MacroFile) [tk_getSaveFile -initialdir [pwd] \
3587	-parent . \
3588	-filetypes {{"EXPGUI Macro file" .expmac}} \
3589	-defaultextension .expmac \
3590	-initialfile EXPGUI.expmac \
3591	-title "Choose location to save macro"]
3592	if {$expgui(MacroFile) == ""} {
3593	# respond to cancel
3594	set expgui(fpMacroFile) ""
3595	set expgui(MacroFile) ""
3596	set expgui(RecordMacro) 0
3597	return
3598	}
3599	if {[catch {
3600	set expgui(fpMacroFile) [open $expgui(MacroFile) w]
3601	puts $expgui(fpMacroFile) "# [clock format [clock seconds] -format %Y-%m-%dT%T]"
3602	} errmsg]} {
3603	MyMessageBox -parent . -title "Error opening selected file" \
3604	-message "Error opening macro file:\n$errmsg" \
3605	-icon warning -type TryAgain -default tryagain
3606	catch {close $expgui(fpMacroFile)}
3607	set expgui(fpMacroFile) ""
3608	set expgui(MacroFile) ""
3609	set expgui(RecordMacro) 0
3610	}
3611	}
3612	} else {
3613	if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3614	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3615	}
3616	catch {close $expgui(fpMacroFile)}
3617	set expgui(fpMacroFile) ""
3618	set expgui(MacroFile) ""
3619	set expgui(MacroBufferedCommand) ""
3620	}
3621	}
3622
3623	# record a command in the Macro File
3624	proc RecordMacroEntry {command buffer} {
3625	global expgui
3626	if {! $expgui(RecordMacro)} return
3627	# in buffered mode: hold the last command in memory and compare to the
3628	# next. If two commands differ only in the final argument, then the
3629	# second command makes the previous redundant so only the latter version
3630	# is retained (This will happen when a user types a string into a box).
3631	# When the commands differ, then the previous is written to file
3632	# and the next is retained in memory.
3633	if {$buffer} {
3634	if {[string trim $expgui(MacroBufferedCommand)] == ""} {
3635	set expgui(MacroBufferedCommand) $command
3636	return
3637	}
3638	set diff 0
3639	# is command a repeat of previous?
3640	foreach a $command b $expgui(MacroBufferedCommand) {
3641	if {$diff} {
3642	# found a difference, other than in the last arg
3643	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3644	break
3645	}
3646	if {$a != $b} {set diff 1}
3647	}
3648	set expgui(MacroBufferedCommand) $command
3649	} else {
3650	# no buffering on current command; write the old and new to file.
3651	if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3652	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3653	}
3654	puts $expgui(fpMacroFile) $command
3655	set expgui(MacroBufferedCommand) ""
3656	}
3657	}
3658
3659	proc CantRecordMacroEntry {comment} {
3660	global expgui
3661	if {! $expgui(RecordMacro)} return
3662
3663	# no buffering on current command; write the old and new to file.
3664	if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3665	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3666	}
3667	puts $expgui(fpMacroFile) "# unrecorded: $comment"
3668	set expgui(MacroBufferedCommand) ""
3669	MyMessageBox -parent . -title "No command record" \
3670	-message "EXPGUI is not able to record this action in the macro file: $comment" \
3671	-icon warning
3672	}
3673
3674
3675	# Play back commands in Macro File
3676	proc ReplayMacroFile {"lineatatime 0"} {
3677	global expgui
3678	set expnam [file root [file tail $expgui(expfile)]]
3679	file delete abort_${expnam}_macro.flag
3680	set expgui(MacroRunning) 0
3681	set MacroFile [tk_getOpenFile -initialdir [pwd] \
3682	-parent . \
3683	-filetypes {{"EXPGUI Macro file" .expmac} {Everything .*}} \
3684	-defaultextension .expmac \
3685	-title "Choose location to read macro"]
3686	if {$MacroFile == ""} return
3687	set expgui(MacroRunning) 1
3688	if {$lineatatime} {
3689	set expgui(MacroChanged) 0
3690	set top1 .macro
3691	catch {destroy $top1}
3692	toplevel $top1
3693	set txt $top1.t
3694	grid [text $txt -width 30 -height 20 -yscrollcommand "$top1.s set"] \
3695	-column 0 -row 0 -sticky news
3696	wm title $top1 "File $MacroFile"
3697	grid [scrollbar $top1.s -command "$txt yview"] \
3698	-column 1 -row 0 -sticky ns
3699	grid [frame $top1.b] -column 0 -columnspan 2 -row 1 -sticky ew
3700	grid columnconfig $top1 0 -weight 1
3701	grid rowconfig $top1 0 -weight 1
3702	grid [button $top1.b.e -text "Execute line" \
3703	-command "MacroExecuteCurrentLine $txt"] \
3704	-column 0 -row 0 -sticky w
3705	grid columnconfig $top1.b 1 -weight 1
3706	grid [button $top1.b.s -text "Save As" -state disabled \
3707	-command "MacroResave $txt"] -column 1 -row 0
3708	set expgui(MacroSaveButton) $top1.b.s
3709	grid [button $top1.b.c -text "Close " \
3710	-command "MacroCloseWindow $txt"] -column 2 -row 0
3711	$txt delete 0.0 end
3712	set fp [open $MacroFile r]
3713	$txt insert 0.0 [read $fp]
3714	close $fp
3715	MacroHighlightText $txt 1
3716	# deal with editing in the box
3717	$txt configure -undo 1
3718	$txt edit modified 0
3719	bind $txt <<Modified>> {
3720	$expgui(MacroSaveButton) configure -state normal
3721	set expgui(MacroChanged) 1
3722	}
3723	} else {
3724	close [open running_${expnam}_macro.flag w]
3725	set saveprompt $expgui(execprompt)
3726	set saveautold $expgui(autoexpload)
3727	set expgui(execprompt) 0
3728	set expgui(autoexpload) 1
3729	set expnam [file root [file tail $expgui(expfile)]]
3730	if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
3731	set outfile ${expnam}_macout.LST
3732	# create an empty file
3733	catch {file delete $outfile}
3734	close [open $outfile w]
3735	# view it with LSTVIEW
3736	set outfile ${expnam}_macout
3737	exec $::wishshell [file join $expgui(scriptdir) lstview] $outfile &
3738	} else {
3739	# show status, offer abort with MACROMON
3740	exec $::wishshell [file join $expgui(scriptdir) macromon] $expnam &
3741	}
3742
3743	set expgui(MacroStatus) "starting script"
3744	pleasewait "\nrunning macro\n\nStatus:" expgui(MacroStatus)
3745
3746	if {[catch {
3747	source $MacroFile
3748	} errmsg]} {
3749	set txt $::errorInfo
3750	catch {
3751	set fp [open error.txt a]
3752	puts $fp "# [clock format [clock seconds] -format %Y-%m-%dT%T]"
3753	puts $fp $txt
3754	close $fp
3755	}
3756	donewait
3757	MyMessageBox -parent . -title "Error running Macro file" \
3758	-message "Error running macro file:\n$errmsg\n(details in file error.txt)" \
3759	-icon error -type OK -default ok
3760	} else {
3761	donewait
3762	}
3763	file delete running_${expnam}_macro.flag
3764	set expgui(execprompt) $saveprompt
3765	set expgui(autoexpload) $saveautold
3766	set expgui(MacroRunning) 0
3767	# show changes
3768	PaintEXPGUIpages
3769	# put comment in output file
3770	if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
3771	set outfile ${expnam}_macout.LST
3772	set fp [open $outfile a]
3773	puts $fp "\n** Macro ended **"
3774	close $fp
3775	}
3776	}
3777	}
3778
3779	# highlight a line in the Macro file display
3780	proc MacroHighlightText {txt line} {
3781	$txt tag delete next
3782	$txt tag add next $line.0 $line.end
3783	$txt see $line.0
3784	$txt tag configure next -background yellow
3785	# tag all text
3786	$txt tag delete all
3787	$txt tag add all 0.0 end
3788	# double-click moves the current line
3789	$txt tag bind all <Double-1> "after idle [list MacroDoubleClick $txt]"
3790	}
3791
3792	# respond to a double click by moving the next line to be executed to
3793	# the line where the double click occurred
3794	proc MacroDoubleClick {txt} {
3795	set line [lindex [split [$txt tag ranges sel] "."] 0]
3796	MacroHighlightText $txt $line
3797	}
3798
3799	# respond to Execute button: execute the current line
3800	# close window after last command
3801	proc MacroExecuteCurrentLine {txt} {
3802	global expgui
3803	set linenum [lindex [split [$txt tag ranges next] "."] 0]
3804	if {$linenum == ""} {return}
3805	set line [$txt get $linenum.0 $linenum.end]
3806	# is this continued (ends with \)?
3807	while {[string range $line end end] == "\\" } {
3808	incr linenum
3809	# get rid of trailing backslash
3810	set line [string range $line 0 end-1]
3811	#append next line
3812	append line [$txt get $linenum.0 $linenum.end]
3813	}
3814	if {[catch $line errmsg]} {
3815	MyMessageBox -parent $txt -title "Error on line" \
3816	-message "Error on line $linenum:\n$errmsg" \
3817	-icon warning -type Continue -default continue
3818	}
3819	# show changes
3820	PaintEXPGUIpages
3821	# move forward in macrofile
3822	incr linenum
3823	MacroHighlightText $txt $linenum
3824	set linenum [lindex [split [$txt tag ranges next] "."] 0]
3825	# at end?
3826	if {$linenum == ""} {MacroCloseWindow $txt}
3827	}
3828
3829	# Save a modified macro file
3830	proc MacroResave {txt} {
3831	global expgui
3832	set MacroFile [tk_getSaveFile -initialdir [pwd] \
3833	-parent $txt \
3834	-filetypes {{"EXPGUI Macro file" .expmac}} \
3835	-defaultextension .expmac \
3836	-initialfile $expgui(MacroFile) \
3837	-title "Choose location to save macro"]
3838	if {[string trim $MacroFile] == ""} {return}
3839	if {[catch {
3840	set fp [open $MacroFile w]
3841	puts $fp [string trim [$txt get 0.0 end]]
3842	close $fp
3843	} errmsg]} {
3844	MyMessageBox -parent $txt -title "Error writing to file" \
3845	-message "Error writing macro file:\n$errmsg" \
3846	-icon warning -type TryAgain -default tryagain
3847	return
3848	}
3849	set expgui(MacroChanged) 0
3850	# gray out the button
3851	$expgui(MacroSaveButton) configure -state disabled
3852	}
3853
3854	# close the window, but provide a chance to save the file first, if modified
3855	proc MacroCloseWindow {txt} {
3856	global expgui
3857	if {$expgui(MacroChanged)} {
3858
3859	set ans [MyMessageBox -parent $txt -title "Save macro file?" \
3860	-message "Macro file has been changed, do you want to save it?" \
3861	-icon warning -type "Yes No" -default no]
3862	if {$ans != "no"} {MacroResave $txt}
3863	}
3864	set expgui(MacroRunning) 0
3865	destroy [winfo toplevel $txt]
3866	}
3867
3868	# Add a comment to a macro file
3869	proc AddCommentMacroFile {} {
3870	global expgui
3871	if {! $expgui(RecordMacro)} return
3872	RecordMacroEntry "# [getstring "comment for macro file"]" 0
3873	}
3874
3875	#------------------------------------------------------------------------------
3876	# Subversion support routines
3877	#------------------------------------------------------------------------------
3878
3879	proc GetSVNVersion {scriptdir} {
3880	if {[CheckSVNinstalled]} {
3881	set SVN [auto_execok svn]
3882	if {! [catch {set res [eval exec $SVN info [list $scriptdir]]} err]} {
3883	set infolist [split $res]
3884	set pos [lsearch $infolist "Revision:"]
3885	return "GSAS/EXPGUI SVN version [lindex $infolist [incr pos]]"
3886	}
3887	}
3888	return "EXPGUI version: [lindex $::expgui(Revision) 1] ([lindex $::expgui(Revision) 4])"
3889	}
3890
3891	# can we find the svn program?
3892	proc CheckSVNinstalled {} {
3893	# can we find svn in the path?
3894	if {[auto_execok svn] != ""} {return 1}
3895	# add a locally supplied svn version and add to path
3896	if {$::tcl_platform(platform) == "windows"} {
3897	set s [file attributes $::expgui(gsasdir) -shortname]
3898	} else {
3899	set s $::expgui(gsasdir)
3900	}
3901	# look for svn
3902	set localsvn [file join $s svn bin]
3903	if {[file exists $localsvn]} {
3904	if {$::tcl_platform(platform) == "windows"} {
3905	set localsvn [file nativename $localsvn]
3906	set sep {;}
3907	} else {
3908	set sep {:}
3909	}
3910	if {[lsearch [split $::env(PATH) $sep] $localsvn] == -1} {
3911	append ::env(PATH) $sep $localsvn
3912	# note that auto_reset breaks the tkcon package in Windows -- not sure why
3913	auto_reset
3914	}
3915	}
3916	if {[auto_execok svn] != ""} {return 1}
3917	return 0
3918	}
3919
3920	proc CheckAndDoUpdate { } {
3921	if {! [CheckSVNinstalled]} {
3922	MyMessageBox -parent . -title "SVN not found" \
3923	-message "Unable to upgrade: Could not locate a copy of the subversion program. It does not appear that one of self-updating GSAS/EXPGUI releases was installed" \
3924	-icon error
3925	return
3926	}
3927	#is there a svn directory in the source?
3928	if {! [file exists [file join $::expgui(gsasdir) .svn]]} {
3929	MyMessageBox -parent . -title "No .svn directory" \
3930	-message "Unable to upgrade: It does not appear that one of self-updating GSAS/EXPGUI releases was installed" \
3931	-icon error
3932	return
3933	}
3934	# check for updates
3935	set SVN [auto_execok svn]
3936	if [catch {set res [eval exec $SVN status [list $::expgui(gsasdir)] -u]} err] {
3937	set ans [MyMessageBox -parent . -title "Error checking status" \
3938	-message "Error checking for updates: $err\n\nTry to update manually?" \
3939	-icon error -type "Yes No" -default yes]
3940	if {$ans != "no"} {
3941	forknewterm "manually update in subversion" \
3942	"$SVN update [file normalize $::expgui(gsasdir)]"
3943	}
3944	return
3945	} else {
3946	if {[string first "*" $res] == -1} {
3947	MyMessageBox -parent . -title "No updates" \
3948	-message "GSAS & EXPGUI appear up-to-date" \
3949	-icon info
3950	return
3951	}
3952	}
3953
3954	if {[MyMessageBox -parent . -title "Ready to Update" \
3955	-message {
3956	Updates to GSAS/EXPGUI found on server.
3957
3958	Press the "Update & Restart" button to begin the update process. After the update completes, EXPGUI will be restarted.} \
3959	-type {Cancel "Update & Restart"} -default cancel -icon warning
3960	] == "cancel"} {return}
3961
3962	if {[confirmBeforeSave] == "Cancel"} return
3963
3964	# special upgrade for windows, where the wish exec blocks upgrade of the exe directory
3965	if {$::tcl_platform(platform) == "windows" && $::tcl_platform(os) != "Windows 95"} {
3966	if {![file exists [file join $::expgui(gsasdir) update.bat]]} {
3967	MyMessageBox -parent . -title "No update.bat" \
3968	-message "File update.bat was not found. This should not happen. Will try to create it now."
3969	set fp [open [file join $::expgui(gsasdir) update.bat] w]
3970	puts $fp {@REM this script must be run from the GSAS installation directory
3971	@REM This is run to update the installation, the name of the EXP file is
3972	@REM expected as an argument
3973	@echo ****************************
3974	@echo Press return to start update
3975	@echo ****************************
3976	@pause
3977	.\svn\bin\svn cleanup .
3978	.\svn\bin\svn update .
3979	@if (%1)==() goto Install2
3980	@echo ****************************************************
3981	@echo Update has completed. Press return to restart EXPGUI
3982	@echo ****************************************************
3983	@pause
3984	%COMSPEC% /c "start exe\ncnrpack.exe expgui\expgui %1"
3985	exit
3986	:Install2
3987	@echo ****************************************************
3988	@echo Update has completed. EXPGUI starting w/o .EXP file
3989	@echo ****************************************************
3990	@pause
3991	%COMSPEC% /c "start exe\ncnrpack.exe expgui\expgui"
3992	exit
3993	}
3994	close $fp
3995	}
3996	# split the directory and EXP file and get rid os spaces in the directory name
3997	set exp [file normalize $::expgui(expfile)]
3998	set dir [file attributes [file dirname $exp] -shortname]
3999	cd $::expgui(gsasdir)
4000	#run the batch file
4001	exec $::env(COMSPEC) /c {start .\update.bat [file join $dir [file tail $exp]]} &
4002	exit
4003	}
4004
4005	# do a quiet cleanup. Sometimes needed after install, and never hurts
4006	if [catch {set res [eval exec $SVN cleanup [list $::expgui(gsasdir)]]} err] {
4007	MyMessageBox -parent . -title "Error in cleanup" \
4008	-message "Error performing cleanup. Will try to continue anyway. Error:\n$err" \
4009	-icon error
4010	}
4011	if [catch {set res [exec $SVN up $::expgui(gsasdir)]} err] {
4012	MyMessageBox -parent . -title "Error updating" \
4013	-message "Error performing update:\n$err" \
4014	-icon error
4015	return
4016	} else {
4017	MyMessageBox -parent . -title "Updating done" \
4018	-message "Results from update:\n$res\n\nPress OK to restart EXPGUI" \
4019	-icon info
4020	}
4021	exec [info nameofexecutable] [file normalize $::expgui(script)] [file normalize $::expgui(expfile)] &
4022	exit
4023	}

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

Download in other formats: