Context Navigation

source: trunk/gsascmds.tcl @ 924

Last change on this file since 924 was 924, checked in by toby, 14 years ago
# on 2008/07/14 01:19:02, toby did: change Set to Continue for getstring (so that initial window has Continue) use variable to hold disagl window name add code to export a phase to clipboard for Andrew Will's VaList? program
Property rcs:author set to `toby` Property rcs:date set to `2008/07/14 01:19:02` Property rcs:lines set to `+73 -18` Property rcs:rev set to `1.65` Property rcs:state set to `Exp` Property svn:keywords set to `Author Date Revision Id`
File size: 102.4 KB

Line
1	# $Id: gsascmds.tcl 924 2009-12-04 23:14: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	# get a value in a modal dialog
469	proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
470	global expgui expmap
471	set w .global
472	catch {destroy $w}
473	toplevel $w -bg beige
474	bind $w <Key-F1> "MakeWWWHelp expguierr.html Input[lindex $what 0]"
475	wm title $w "Input $what"
476	set expgui(temp) {}
477	pack [frame $w.0 -bd 6 -relief groove -bg beige] \
478	-side top -expand yes -fill both
479	grid [label $w.0.a -text "Input a value for the $what" \
480	-bg beige] \
481	-row 0 -column 0 -columnspan 10
482	grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
483	-row 1 -column 0
484
485	set expgui(temp) $initvalue
486	pack [frame $w.b -bg beige] -side top -fill x -expand yes
487	pack [button $w.b.2 -text Continue -command "destroy $w"] -side left
488	if $quit {
489	pack [button $w.b.3 -text Quit \
490	-command "set expgui(temp) {}; destroy $w"] -side left
491	}
492	bind $w <Return> "destroy $w"
493	pack [button $w.b.help -text Help -bg yellow \
494	-command "MakeWWWHelp expguierr.html Input[lindex $what 0]"] \
495	-side right
496
497	# force the window to stay on top
498	putontop $w
499
500	focus $w.b.2
501	tkwait window $w
502	afterputontop
503
504	return $expgui(temp)
505	}
506
507	#------------------------------------------------------------------------------
508	# profile/symmetry routines
509	#------------------------------------------------------------------------------
510	# profile terms
511	array set expgui {
512	prof-T-names {"Von Dreele-Jorgensen-Windsor" \
513	"David-Ikeda-Carpenter" "Exponential pseudo-Voigt" \
514	"Exponential p-V+Stephens aniso strain" \
515	"Exponential p-V+macro strain"
516	}
517	prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
518	rsca s1ec s2ec }
519	prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
520	gam-2 ptec stec difc difa zero }
521	prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
522	gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
523	prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
524	rstr rsta rsca eta}
525	prof-T-5 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
526	gam-2 gsf g1ec g2ec rstr rsta rsca D1 D2 D3 D4 D5 D6 }
527	prof-C-names {"Gaussian only" "Pseudo-Voigt" \
528	"pseudo-Voigt/FCJ Asym" "p-V/FCJ+Stephens aniso strain" \
529	"p-V/FCJ+macro strain"
530	}
531	prof-C-1 {GU GV GW asym F1 F2 }
532	prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
533	L11 L22 L33 L12 L13 L23 }
534	prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
535	L11 L22 L33 L12 L13 L23 }
536	prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta}
537	prof-C-5 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
538	D1 D2 D3 D4 D5 D6 }
539	prof-E-names {Gaussian "Otto pseudo-Voigt"}
540	prof-E-1 {A B C ds cds}
541	prof-E-2 {A B C ds cds LX LY ptec stec}
542	}
543
544	# number of profile terms depends on the histogram type
545	# the LAUE symmetry and the profile number
546	proc GetProfileTerms {phase hist ptype} {
547	global expmap expgui
548	if {$hist == "C" \|\| $hist == "T" \|\| $hist == "E"} {
549	set htype $hist
550	} else {
551	set htype [string range $expmap(htype_$hist) 2 2]
552	}
553	# get the cached copy of the profile term labels, when possible
554	set lbls {}
555	catch {
556	set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
557	}
558	if {$lbls != ""} {return $lbls}
559
560	catch {set lbls $expgui(prof-$htype-$ptype)}
561	if {$lbls == ""} {return}
562	# add terms based on the Laue symmetry
563	if {($htype == "C" \|\| $htype == "T") && $ptype == 4} {
564	set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
565	eval lappend lbls [Profile4Terms $laueaxis]
566	}
567	set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
568	return $lbls
569	}
570
571	proc Profile4Terms {laueaxis} {
572	# GSAS Laue classes by number vs spacegrp labeling
573	# 1 2 3 4 5 6 7 8 9 10 11 12 13 14
574	# 1bar, 2/m, mmm, 4/m, 4/mmm, 3bar, 3bar m, 3bar, 3barm1, 3bar1m, 6/m, 6/mmm, m 3, m3m
575	# R R H H H
576	# (R=Rhombohedral setting; H=Hexagonal setting)
577	switch -exact $laueaxis {
578	1bar {return \
579	"S400 S040 S004 S220 S202 S022 S310 S103 S031 \
580	S130 S301 S013 S211 S121 S112"}
581	2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
582	2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
583	2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
584	mmm {return "S400 S040 S004 S220 S202 S022"}
585	4/m {return "S400 S004 S220 S202 S310"}
586	4/mmm {return "S400 S004 S220 S202"}
587	3barR {return "S400 S220 S310 S301 S211"}
588	"3bar mR" {return "S400 S220 S310 S211"}
589	3bar {return "S400 S004 S202 S310 S211"}
590	3barm1 {return "S400 S004 S202 S301"}
591	3bar1m {return "S400 S004 S202 S211"}
592	6/m {return "S400 S004 S202"}
593	6/mmm {return "S400 S004 S202"}
594	"m 3" {return "S400 S220"}
595	m3m {return "S400 S220"}
596	default {return ""}
597	}
598	}
599
600	proc GetLaue {spg} {
601	global tcl_platform expgui
602	# check the space group
603	set fp [open spg.in w]
604	puts $fp "N"
605	puts $fp "N"
606	puts $fp $spg
607	puts $fp "Q"
608	close $fp
609	catch {
610	if {$tcl_platform(platform) == "windows"} {
611	exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
612	} else {
613	exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
614	}
615	}
616	set fp [open spg.out r]
617	set laue {}
618	set uniqueaxis {}
619	while {[gets $fp line] >= 0} {
620	regexp {Laue symmetry (.*)} $line junk laue
621	regexp {The unique axis is (.*)} $line junk uniqueaxis
622	}
623	close $fp
624	catch {file delete -force spg.in spg.out}
625	set laue [string trim $laue]
626	# add a R suffix for rhombohedral settings
627	if {[string range [string trim $spg] end end] == "R"} {
628	return "${laue}${uniqueaxis}R"
629	}
630	return "${laue}$uniqueaxis"
631	}
632
633	# set up to change the profile type for a series of histogram/phase entries
634	# (histlist & phaselist should be lists of the same length)
635	#
636	proc ChangeProfileType {histlist phaselist} {
637	global expgui expmap
638	set w .profile
639	catch {destroy $w}
640	toplevel $w -bg beige
641	wm title $w "Change Profile Function"
642
643	# all histogram/phases better be the same type, so we can just use the 1st
644	set hist [lindex $histlist 0]
645	set phase [lindex $phaselist 0]
646	set ptype [string trim [hapinfo $hist $phase proftype]]
647
648	# get list of allowed profile terms for the current histogram type
649	set i 1
650	while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
651	lappend lbllist $lbls
652	incr i
653	}
654	# labels for the current type
655	set i $ptype
656	set oldlbls [lindex $lbllist [incr i -1]]
657
658	if {[llength $histlist] == 1} {
659	pack [label $w.a -bg beige \
660	-text "Change profile function for Histogram #$hist Phase #$phase" \
661	] -side top
662	} else {
663	# make a list of histograms by phase
664	foreach h $histlist p $phaselist {
665	lappend phlist($p) $h
666	}
667	set num 0
668	pack [frame $w.a -bg beige] -side top
669	pack [label $w.a.$num -bg beige \
670	-text "Change profile function for:" \
671	] -side top -anchor w
672	foreach i [lsort [array names phlist]] {
673	incr num
674	pack [label $w.a.$num -bg beige -text \
675	"\tPhase #$i, Histograms [CompressList $phlist($i)]" \
676	] -side top -anchor w
677	}
678	}
679	pack [label $w.e1 \
680	-text "Current function is type $ptype." \
681	-bg beige] -side top -anchor w
682	pack [frame $w.e -bg beige] -side top -expand yes -fill both
683	pack [label $w.e.1 \
684	-text "Set function to type" \
685	-bg beige] -side left
686	set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
687	pack $w.e.2 -side left -anchor w
688
689	pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
690	-command "set expgui(newpeaktype) $ptype; \
691	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
692	-value 1 -text "Current value overrides"] -side right
693	pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
694	-command \
695	"set expgui(newpeaktype) $ptype; \
696	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
697	-value 0 -text "Default value overrides"] -side right
698
699	$w.e.2 config -bg beige
700	pack [frame $w.c -bg beige] -side top -expand yes -fill both
701	pack [frame $w.d -bg beige] -side top -expand yes -fill both
702	pack [button $w.d.2 -text Set \
703	-command "SaveChangeProfileType $w.c [list $histlist] [list $phaselist]; destroy $w"\
704	] -side left
705	pack [button $w.d.3 -text Quit \
706	-command "destroy $w"] -side left
707	pack [button $w.d.help -text Help -bg yellow \
708	-command "MakeWWWHelp expgui5.html ChangeType"] \
709	-side right
710	bind $w <Key-F1> "MakeWWWHelp expgui5.html ChangeType"
711	bind $w <Return> "destroy $w"
712
713	$menu delete 0 end
714	set i 0
715	foreach lbls $lbllist {
716	incr i
717	$menu add command -label $i -command \
718	"set expgui(newpeaktype) $i; \
719	FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
720	}
721	set expgui(newpeaktype) $ptype
722	FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
723
724	# force the window to stay on top
725	putontop $w
726	focus $w.e.2
727	tkwait window $w
728	afterputontop
729	sethistlist
730	}
731
732	# save the changes to the profile
733	proc SaveChangeProfileType {w histlist phaselist} {
734	global expgui
735	foreach phase $phaselist hist $histlist {
736	hapinfo $hist $phase proftype set $expgui(newpeaktype)
737	RecordMacroEntry "hapinfo $hist $phase proftype set $expgui(newpeaktype)" 0
738	hapinfo $hist $phase profterms set $expgui(newProfileTerms)
739	RecordMacroEntry "hapinfo $hist $phase profterms set $expgui(newProfileTerms)" 0
740	for {set i 1} {$i <= $expgui(newProfileTerms)} {incr i} {
741	hapinfo $hist $phase pterm$i set [$w.ent${i} get]
742	RecordMacroEntry "hapinfo $hist $phase pterm$i set [$w.ent${i} get]" 0
743	hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
744	RecordMacroEntry "hapinfo $hist $phase pref$i set $expgui(ProfRef$i)" 0
745	}
746	set i [expr 1+$expgui(newProfileTerms)]
747	hapinfo $hist $phase pcut set [$w.ent$i get]
748	RecordMacroEntry "hapinfo $hist $phase pcut set [$w.ent$i get]" 0
749	incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
750	RecordMacroEntry "incr expgui(changed)" 0
751	}
752	}
753
754	# file the contents of the "Change Profile Type" Menu
755	proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
756	global expgui expmap
757	set ptype [string trim [hapinfo $hist $phase proftype]]
758	catch {unset oldval}
759	# loop through the old terms and set up an array of starting values
760	set num 0
761	foreach term $oldlbls {
762	incr num
763	set oldval($term) [hapinfo $hist $phase pterm$num]
764	}
765	set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
766
767	# is the new type the same as the current?
768	if {$ptype == $newtype} {
769	set nterms [hapinfo $hist $phase profterms]
770	} else {
771	set nterms [llength $lbls]
772	}
773	set expgui(newProfileTerms) $nterms
774	set expgui(CurrentProfileTerms) $nterms
775	# which default profile set matches the new type
776	set setnum {}
777	foreach j {" " 1 2 3 4 5 6 7 8 9} {
778	set i [profdefinfo $hist $j proftype]
779	if {$i == ""} continue
780	if {$i == $newtype} {
781	set setnum $j
782	break
783	}
784	}
785
786	eval destroy [winfo children $w]
787
788	set colstr 0
789	set row 2
790	set maxrow [expr $row + $nterms/2]
791	for { set num 1 } { $num <= $nterms + 1} { incr num } {
792	# get the default value (originally from the in .INS file)
793	set val {}
794	if {$setnum != ""} {
795	set val 0.0
796	catch {
797	set val [profdefinfo $hist $setnum pterm$num]
798	# pretty up the number
799	if {$val == 0.0} {
800	set val 0.0
801	} elseif {abs($val) < 1e-2 \|\| abs($val) > 1e6} {
802	set val [format %.3e $val]
803	} elseif {abs($val) > 1e-2 && abs($val) < 10} {
804	set val [format %.5f $val]
805	} elseif {abs($val) < 9999} {
806	set val [format %.2f $val]
807	} elseif {abs($val) < 1e6} {
808	set val [format %.0f $val]
809	}
810	}
811	}
812	# heading
813	if {$row == 2} {
814	set col $colstr
815	grid [label $w.h0${num} -text "lbl" -bg beige] \
816	-row $row -column $col
817	grid [label $w.h2${num} -text "ref" -bg beige] \
818	-row $row -column [incr col]
819	grid [label $w.h3${num} -text "next value" -bg beige] \
820	-row $row -column [incr col]
821	grid [label $w.h4${num} -text "default" -bg beige] \
822	-row $row -column [incr col]
823	grid [label $w.h5${num} -text "current" -bg beige] \
824	-row $row -column [incr col]
825	}
826	set col $colstr
827	incr row
828	set term {}
829	catch {set term [lindex $lbls [expr $num-1]]}
830	if {$term == ""} {set term $num}
831	if {$num == $nterms + 1} {
832	set term "Peak\nCutoff"
833	set val {}
834	if {$setnum != ""} {
835	set val 0.0
836	catch {set val [profdefinfo $hist $setnum pcut]}
837	}
838	}
839
840	grid [label $w.l${num} -text "$term" -bg beige] \
841	-row $row -column $col
842	grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
843	-bg beige -activebackground beige] -row $row -column [incr col]
844	grid [entry $w.ent${num} \
845	-width 12] -row $row -column [incr col]
846	if {$val != ""} {
847	grid [button $w.def${num} -text $val -command \
848	"$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
849	] -row $row -column [incr col] -sticky ew
850	} else {
851	grid [label $w.def${num} -text (none) \
852	] -row $row -column [incr col]
853	}
854	set curval {}
855	catch {
856	set curval [expr $oldval($term)]
857	# pretty up the number
858	if {$curval == 0.0} {
859	set curval 0.0
860	} elseif {abs($curval) < 1e-2 \|\| abs($curval) > 1e6} {
861	set curval [format %.3e $curval]
862	} elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
863	set curval [format %.5f $curval]
864	} elseif {abs($curval) < 9999} {
865	set curval [format %.2f $curval]
866	} elseif {abs($curval) < 1e6} {
867	set curval [format %.0f $curval]
868	}
869	grid [button $w.cur${num} -text $curval -command \
870	"$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
871	] -row $row -column [incr col] -sticky ew
872	}
873	# set default values for flag and value
874	set ref 0
875	if {$setnum != ""} {
876	catch {
877	if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
878	}
879	}
880	set expgui(ProfRef$num) $ref
881
882	$w.ent${num} delete 0 end
883	if {!$expgui(DefaultPeakType) && $val != ""} {
884	$w.ent${num} insert end $val
885	} elseif {$curval != ""} {
886	$w.ent${num} insert end $curval
887	} elseif {$val != ""} {
888	$w.ent${num} insert end $val
889	} else {
890	$w.ent${num} insert end 0.0
891	}
892	if {$row > $maxrow} {
893	set row 2
894	incr colstr 5
895	}
896	}
897	if {$::tcl_platform(os) == "Darwin"} {
898	# on OS X force a window resize
899	wm geometry [winfo toplevel $w] {}
900	}
901	}
902
903	#------------------------------------------------------------------------------
904	# WWW/help routines
905	#------------------------------------------------------------------------------
906	# browse a WWW page with URL. The URL may contain a #anchor
907	# On UNIX assume netscape or mozilla is in the path or env(BROWSER) is loaded.
908	# On Windows search the registry for a browser. Mac branch not tested.
909	# This is taken from http://mini.net/cgi-bin/wikit/557.html with many thanks
910	# to the contributers
911	proc urlOpen {url} {
912	global env tcl_platform
913	if {$tcl_platform(os) == "Darwin"} {
914	# if this is an external URL or does not contain an anchor, take the
915	# easy approach
916	if {[string range $url 0 4] == "http:" \|\| \
917	[string first "#" $url] == -1} {
918	if {![catch {exec open $url}]} {
919	return
920	}
921	}
922	# so sorry, have to use Internet Explorer
923	set url [file nativename $url]; # replace ~/ if present
924	if {[file pathtype $url] == "relative"} {
925	set url [file join [pwd] $url]
926	}
927	exec osascript -e "tell application \"Internet Explorer\"\rGetURL \"file://$url\"\rend tell"
928	} elseif {$tcl_platform(platform) == "unix"} {
929	set browserlist {}
930	if {[info exists env(BROWSER)]} {
931	set browserlist $env(BROWSER)
932	}
933	lappend browserlist netscape mozilla
934	foreach p $browserlist {
935	set progs [auto_execok $p]
936	if {[llength $progs]} {
937	if {[catch {exec $progs -remote openURL($url)}]} {
938	# perhaps browser doesn't understand -remote flag
939	if {[catch {exec $env(BROWSER) $url &} emsg]} {
940	error "Error displaying $url in browser\n$emsg"
941	}
942	}
943	return
944	}
945	}
946	MyMessageBox -parent . -title "No Browser" \
947	-message "Could not find a browser. Netscape & Mozilla not found. Define environment variable BROWSER to be full path name of browser." \
948	-icon warning
949	} elseif {$tcl_platform(platform) == "windows"} {
950	package require registry
951	# Look for the application under
952	# HKEY_CLASSES_ROOT
953	set root HKEY_CLASSES_ROOT
954
955	# Get the application key for HTML files
956	set appKey [registry get $root\\.html ""]
957
958	# Get the command for opening HTML files
959	set appCmd [registry get \
960	$root\\$appKey\\shell\\open\\command ""]
961
962	# Substitute the HTML filename into the command for %1
963	# or stick it on the end
964	if {[string first %1 $appCmd] != -1} {
965	regsub %1 $appCmd $url appCmd
966	} else {
967	append appCmd " " $url
968	}
969
970	# Double up the backslashes for eval (below)
971	regsub -all {\\} $appCmd {\\\\} appCmd
972
973	# Invoke the command
974	eval exec $appCmd &
975	} elseif {$tcl_platform(platform) == "macintosh"} {
976	# preOSX -- this is not used
977	if {0 == [info exists env(BROWSER)]} {
978	set env(BROWSER) "Browse the Internet"
979	}
980	if {[catch {
981	AppleScript execute\
982	"tell application \"$env(BROWSER)\"
983	open url \"$url\"
984	end tell
985	"} emsg]
986	} then {
987	error "Error displaying $url in browser\n$emsg"
988	}
989	}
990	}
991
992	proc NetHelp {file anchor localloc netloc} {
993	# use the file on-line, if it exists
994	if {[file exists [file join $localloc $file]]} {
995	set url "[file join $localloc $file]"
996	} else {
997	set url "http://$netloc/$file"
998	}
999	catch {
1000	pleasewait "Starting web browser..."
1001	after 2000 donewait
1002	}
1003	if {$anchor != ""} {
1004	append url # $anchor
1005	}
1006	urlOpen $url
1007	}
1008
1009	proc MakeWWWHelp {"topic {}" "anchor {}"} {
1010	global expgui
1011	if {$topic == ""} {
1012	foreach item $expgui(notebookpagelist) {
1013	if {[lindex $item 0] == $expgui(pagenow)} {
1014	NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
1015	return
1016	}
1017	}
1018	# this should not happen
1019	NetHelp expgui.html "" $expgui(docdir) $expgui(website)
1020	} elseif {$topic == "menu"} {
1021	NetHelp expguic.html "" $expgui(docdir) $expgui(website)
1022	} else {
1023	NetHelp $topic $anchor $expgui(docdir) $expgui(website)
1024	}
1025	}
1026
1027	# show help information
1028	proc showhelp {} {
1029	global expgui_helplist helpmsg
1030	set helpmsg {}
1031	set frm .help
1032	catch {destroy $frm}
1033	toplevel $frm
1034	wm title $frm "Help Summary"
1035	grid [label $frm.0 -text \
1036	"Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
1037	-column 0 -columnspan 4 -row 0
1038	# grid [message $frm.help -textvariable helpmsg -relief groove] \
1039	# -column 0 -columnspan 4 -row 2 -sticky nsew
1040	grid [text $frm.help -relief groove -bg beige -width 0\
1041	-height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
1042	-column 0 -columnspan 3 -row 2 -sticky nsew
1043	grid [scrollbar $frm.escroll -command "$frm.help yview"] \
1044	-column 4 -row 2 -sticky nsew
1045	grid rowconfig $frm 1 -weight 1 -minsize 50
1046	grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
1047	grid columnconfig $frm 0 -weight 1
1048	grid columnconfig $frm 2 -weight 1
1049	set lst [array names expgui_helplist]
1050	grid [listbox $frm.cmds -relief raised -bd 2 \
1051	-yscrollcommand "$frm.scroll set" \
1052	-height 8 -width 0 -exportselection 0 ] \
1053	-column 0 -row 1 -sticky nse
1054	grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
1055	-column 1 -row 1 -sticky nsew
1056	foreach item [lsort -dictionary $lst] {
1057	$frm.cmds insert end $item
1058	}
1059	if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
1060	grid [button $frm.done -text Done -command "destroy $frm"] \
1061	-column 2 -row 1
1062	# bind $frm.cmds <ButtonRelease-1> \
1063	# "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
1064	bind $frm.cmds <ButtonRelease-1> \
1065	"+$frm.help config -state normal; $frm.help delete 0.0 end; \
1066	$frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
1067	$frm.help config -state disabled"
1068
1069	# get the size of the window and expand the message boxes to match
1070	# update
1071	# $frm.help config -width [winfo width $frm.help ]
1072	}
1073
1074
1075	#------------------------------------------------------------------------------
1076	# utilities
1077	#------------------------------------------------------------------------------
1078	# run liveplot
1079	proc liveplot {} {
1080	global expgui liveplot wishshell expmap
1081	set expnam [file root [file tail $expgui(expfile)]]
1082	# which histograms are ready for use?
1083	set validlist {}
1084	foreach ihist $expmap(powderlist) {
1085	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1086	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1087	lappend validlist $ihist
1088	}
1089	}
1090	if {[llength $validlist] == 0} {
1091	MyMessageBox -parent . -title "No Valid Histograms" \
1092	-message "No histograms are ready to plot. Run GENLES and try again" \
1093	-icon warning -helplink "expguierr.html NoValidHist"
1094	return
1095	}
1096	# use $liveplot(hst) if valid, the 1st entry otherwise
1097	if {[lsearch $validlist $liveplot(hst)] != -1} {
1098	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1099	$expnam $liveplot(hst) $liveplot(legend) &
1100	} else {
1101	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1102	$expnam [lindex $validlist 0] $liveplot(legend) &
1103	}
1104	}
1105
1106	# run lstview
1107	proc lstview {} {
1108	global expgui wishshell
1109	set expnam [file root [file tail $expgui(expfile)]]
1110	exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1111	}
1112
1113	# run widplt
1114	proc widplt {"prog widplt"} {
1115	global expgui wishshell
1116	exec $wishshell [file join $expgui(scriptdir) $prog] \
1117	$expgui(expfile) &
1118	}
1119
1120	# run bkgedit
1121	proc bkgedit {"hst {}"} {
1122	global expgui liveplot wishshell expmap
1123	set expnam [file root [file tail $expgui(expfile)]]
1124	if {$hst == ""} {
1125	# which histograms are ready for use?
1126	set validlist {}
1127	foreach ihist $expmap(powderlist) {
1128	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1129	[string range $expmap(htype_$ihist) 3 3] == "*"} {
1130	lappend validlist $ihist
1131	}
1132	}
1133	if {[llength $validlist] == 0} {
1134	MyMessageBox -parent . -title "No Valid Histograms" \
1135	-message "No histograms are ready to plot. Run POWPREF and try again" \
1136	-icon warning -helplink "expguierr.html NoValidHist"
1137	return
1138	}
1139	# use $liveplot(hst) if valid, the 1st entry otherwise
1140	if {[lsearch $validlist $liveplot(hst)] != -1} {
1141	set hst $liveplot(hst)
1142	} else {
1143	set hst [lindex $validlist 0]
1144	}
1145	}
1146	# Save the current exp file
1147	savearchiveexp
1148	CantRecordMacroEntry "bkgedit"
1149	# disable the file change monitor if we will reload the .EXP file automatically
1150	if {$expgui(autoexpload)} {set expgui(expModifiedLast) 0}
1151	if {$expgui(autoiconify)} {wm iconify .}
1152	exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1153	$expnam $hst $liveplot(legend)
1154	if {$expgui(autoiconify)} {wm deiconify .}
1155	# load the changed .EXP file automatically?
1156	if {$expgui(autoexpload)} {
1157	# load the revised exp file
1158	loadexp $expgui(expfile)
1159	} else {
1160	# check for changes in the .EXP file immediately
1161	whenidle
1162	}
1163	}
1164
1165	# run excledt
1166	proc excledit {} {
1167	global expgui liveplot expmap
1168	set expnam [file root [file tail $expgui(expfile)]]
1169	# which histograms are ready for use?
1170	set validlist {}
1171	foreach ihist $expmap(powderlist) {
1172	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1173	[string range $expmap(htype_$ihist) 3 3] == "*" \|\| \
1174	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1175	lappend validlist $ihist
1176	}
1177	}
1178	if {[llength $validlist] == 0} {
1179	MyMessageBox -parent . -title "No Valid Histograms" \
1180	-message "No histograms are ready to plot. Run POWPREF and try again" \
1181	-icon warning -helplink "expguierr.html NoValidHist"
1182	return
1183	}
1184	#if {$expgui(autoiconify)} {wm iconify .}
1185	StartExcl
1186	#if {$expgui(autoiconify)} {wm deiconify .}
1187	}
1188
1189	# compute the composition for each phase and display in a dialog
1190	proc composition {} {
1191	global expmap expgui
1192	set Z 1
1193	foreach phase $expmap(phaselist) type $expmap(phasetype) {
1194	if {$type == 4} continue
1195	ResetMultiplicities $phase {}
1196	catch {unset total}
1197	foreach atom $expmap(atomlist_$phase) {
1198	set type [atominfo $phase $atom type]
1199	set mult [atominfo $phase $atom mult]
1200	if [catch {set total($type)}] {
1201	set total($type) [expr \
1202	$mult * [atominfo $phase $atom frac]]
1203	} else {
1204	set total($type) [expr $total($type) + \
1205	$mult * [atominfo $phase $atom frac]]
1206	}
1207	if {$mult > $Z} {set Z $mult}
1208	}
1209	append text "\nPhase $phase\n"
1210	append text " Unit cell contents\n"
1211	foreach type [lsort [array names total]] {
1212	append text " $type[format %8.3f $total($type)]"
1213	}
1214	append text "\n\n"
1215
1216	append text " Asymmetric Unit contents (Z=$Z)\n"
1217	foreach type [lsort [array names total]] {
1218	append text " $type[format %8.3f [expr $total($type)/$Z]]"
1219	}
1220	append text "\n"
1221	}
1222
1223	catch {destroy .comp}
1224	toplevel .comp -class MonoSpc
1225	bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1226	wm title .comp Composition
1227	pack [label .comp.results -text $text \
1228	-justify left] -side top
1229	pack [frame .comp.box] -side top -expand y -fill x
1230	pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1231
1232	set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1233	pack [button .comp.box.2 -text "Save to $lstnam file" \
1234	-command "writelst [list $text] ; destroy .comp"] -side left
1235	pack [button .comp.box.help -text Help -bg yellow \
1236	-command "MakeWWWHelp expgui.html Composition"] \
1237	-side right
1238	}
1239
1240	# Delete History Records
1241	proc DeleteHistoryRecords {{msg ""}} {
1242	global expgui
1243	set frm .history
1244	catch {destroy $frm}
1245	toplevel $frm
1246	bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1247	if {[string trim $msg] == ""} {
1248	set msg "There are [CountHistory] history records"
1249	}
1250	pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1251	pack [label $frm.1.0 -text $msg] -side top
1252	pack [frame $frm.1.1] -side top
1253	pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1254	pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1255	] -side left
1256	set expgui(historyKeep) 10
1257	pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1258	set expgui(renumber) 1
1259	pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1260	pack [button $frm.2.help -text Help -bg yellow \
1261	-command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1262	pack [button $frm.2.4 -text Quit \
1263	-command {destroy .history}] -side bottom
1264	pack [button $frm.2.3 -text OK \
1265	-command {
1266	if ![catch {expr $expgui(historyKeep)}] {
1267	DeleteHistory $expgui(historyKeep) $expgui(renumber)
1268	set expgui(changed) 1
1269	destroy .history
1270	}
1271	}] -side bottom
1272	bind $frm <Return> "$frm.2.3 invoke"
1273
1274	# force the window to stay on top
1275	putontop $frm
1276	focus $frm.2.3
1277	tkwait window $frm
1278	afterputontop
1279	}
1280
1281	proc archiveexp {} {
1282	global expgui tcl_platform
1283	# is there a file to archive?
1284	if {![file exists $expgui(expfile)]} return
1285	set expnam [file rootname $expgui(expfile)]
1286	# get the last archived version
1287	set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1288	if {$lastf == ""} {
1289	set num 01
1290	} else {
1291	regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1292	scan $num %x num
1293	if {$num >= 255} {
1294	set num FF
1295	} else {
1296	set num [string toupper [format %.2x [incr num]]]
1297	}
1298	}
1299	catch {
1300	set file $expnam.O$num
1301	file copy -force $expgui(expfile) $file
1302	set fp [open $expnam.LST a+]
1303	puts $fp "\n----------------------------------------------"
1304	puts $fp " Archiving [file tail $expnam.EXP] as [file tail $file]"
1305	puts $fp "----------------------------------------------\n"
1306	close $fp
1307	} errmsg
1308	if {$errmsg != ""} {
1309	tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1310	}
1311	}
1312
1313	# save and optionally archive the expfile
1314	proc savearchiveexp {} {
1315	global expgui expmap
1316	if {$expgui(expfile) == ""} {
1317	SaveAsFile
1318	return
1319	}
1320	if !$expgui(changed) return
1321	if {$expgui(archive)} archiveexp
1322	# add a history record
1323	exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds] -format {%D %T}]"
1324	# now save the file
1325	expwrite $expgui(expfile)
1326	# change the icon and assign an app to this .EXP file
1327	global tcl_platform
1328	if {$tcl_platform(os) == "Darwin" && $expgui(MacAssignApp)} {
1329	MacSetResourceFork $expgui(expfile)
1330	}
1331	set expgui(changed) 0
1332	set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1333	set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1334	wm title . $expgui(expfile)
1335	set expgui(titleunchanged) 1
1336	# set convergence criterion
1337	InitLSvars
1338	}
1339
1340	#------------------------------------------------------------------------------
1341	# GSAS interface routines
1342	#------------------------------------------------------------------------------
1343	# run a GSAS program that does not require an experiment file
1344	proc runGSASprog {proglist "concurrent 1"} {
1345	# save call to Macro file
1346	RecordMacroEntry "runGSASprog [list $proglist] $concurrent" 0
1347	# if concurrent is 0, EXPGUI runs the GSAS program in background
1348	# -- this is not currently needed anywhere where the .EXP file is not.
1349	global expgui tcl_platform
1350	set cmd {}
1351	foreach prog $proglist {
1352	StartGRWND $prog
1353	if {$tcl_platform(platform) == "windows"} {
1354	append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1355	} else {
1356	if {$cmd != ""} {append cmd "\;"}
1357	append cmd "[file join $expgui(gsasexe) $prog]"
1358	}
1359	}
1360	forknewterm $prog $cmd [expr !$concurrent] 1
1361	}
1362
1363	# dummy routine, overridden if needed
1364	proc StartGRWND {prog} {
1365	}
1366
1367	# run a GSAS program that requires an experiment file for input/output
1368	proc runGSASwEXP {proglist "concurrent 0"} {
1369	# save call to Macro file
1370	RecordMacroEntry "runGSASwEXP [list $proglist] $concurrent" 0
1371	# most programs that require the .EXP file change it and
1372	# cannot be run concurrently
1373	global expgui tcl_platform
1374	# Save the current exp file
1375	savearchiveexp
1376	# load the changed .EXP file automatically?
1377	if {$expgui(autoexpload)} {
1378	# disable the file changed monitor
1379	set expgui(expModifiedLast) 0
1380	}
1381	set cmd {}
1382	set expnam [file root [file tail $expgui(expfile)]]
1383	foreach prog $proglist {
1384	if {$prog == "powpref"} {
1385	set expgui(needpowpref) 0
1386	set expgui(needpowpref_why) ""
1387	} elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1388	set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1389	set ans [MyMessageBox -parent . -title "Run POWPREF" \
1390	-message $msg -icon warning -type "Yes No" -default yes \
1391	-helplink "expguierr.html RunPowpref"]
1392	if {$ans == "yes"} {
1393	set expgui(needpowpref) 0
1394	set expgui(needpowpref_why) ""
1395	if {$tcl_platform(platform) == "windows"} {
1396	append cmd " \"$expgui(gsasexe)/powpref.exe $expnam \" "
1397	} else {
1398	if {$cmd != ""} {append cmd "\;"}
1399	append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1400	}
1401	}
1402	}
1403	StartGRWND $prog
1404	if {$tcl_platform(platform) == "windows"} {
1405	append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1406	} elseif {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1407	append cmd " \" [file join $expgui(gsasexe) $prog] $expnam \" "
1408	} else {
1409	if {$cmd != ""} {append cmd "\;"}
1410	append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1411	}
1412	}
1413	if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1414	set outfile ${expnam}_macout.LST
1415	runnoterm $cmd $outfile
1416	} else {
1417	forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1418	}
1419	# load the changed .EXP file automatically?
1420	if {$expgui(autoexpload)} {
1421	# load the revised exp file
1422	loadexp $expgui(expfile)
1423	}
1424	if {$expgui(MacroRunning)} {
1425	if {[file exists abort_${expnam}_macro.flag]} {
1426	file delete abort_${expnam}_macro.flag
1427	error "User requested to abort the macro"
1428	}
1429	update idletasks
1430	}
1431	}
1432
1433	# write text to the .LST file
1434	proc writelst {text} {
1435	global expgui
1436	set lstnam [file rootname $expgui(expfile)].LST
1437	set fp [open $lstnam a]
1438	puts $fp "\n-----------------------------------------------------------------"
1439	puts $fp $text
1440	puts $fp "-----------------------------------------------------------------\n"
1441	close $fp
1442	}
1443
1444
1445	# rename file current to suggested,
1446	# delete window if supplied
1447	# use parent, if supplied or .
1448	proc RenameAsFile {current suggested "window {}" "parent {}"} {
1449	if {$parent == "" && $window != ""} {set parent $window}
1450	if {$parent == ""} {set parent .}
1451	set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1452	if {$newfile == ""} return
1453	if {[catch {
1454	file rename -force $current $newfile
1455	}]} {
1456	file copy -force $current $newfile
1457	file delete -force $current
1458	}
1459	if {$window != ""} {destroy $window}
1460	}
1461
1462	# optionally run disagl as a windowless process, w/results in a separate window
1463	proc rundisagl {} {
1464	global expgui txtvw tcl_version tcl_platform
1465	if {$expgui(disaglSeparateBox)} {
1466	set root [file root $expgui(expfile)]
1467	catch {file delete -force $root.tmp}
1468	if {[catch {file rename -force $root.LST $root.OLS}]} {
1469	file copy -force $root.LST $root.OLS
1470	file delete -force $root.OLS
1471	}
1472	# PSW reports this does not happen right away on windows
1473	set i 0
1474	while {$i < 10 && [file exists $root.LST]} {
1475	# debug code
1476	#catch {console show}
1477	#puts "try $i"
1478	# end debug code
1479	after 100
1480	incr i
1481	}
1482	if {[file exists $root.LST]} {
1483	# it was not possible to rename the file
1484	MyMessageBox -parent . -title "Rename Problem" \
1485	-message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1486	-icon warning -helplink "expguierr.html NoRename"
1487	return
1488	}
1489
1490	#run the program
1491	pleasewait "Running DISAGL"
1492	# create an empty input file
1493	close [open disagl.inp w]
1494	catch {exec [file join $expgui(gsasexe) disagl] \
1495	[file tail $root] < disagl.inp > disagl.out}
1496	if {[catch {file rename -force $root.LST $root.tmp}]} {
1497	file copy -force $root.LST $root.tmp
1498	file delete -force $root.LST
1499	}
1500	catch {file delete -force disagl.inp disagl.out}
1501	if {[catch {file rename -force $root.OLS $root.LST}]} {
1502	file copy -force $root.OLS $root.LST
1503	file delete -force $root.OLS
1504	}
1505	donewait
1506	# open a new window
1507	catch {toplevel .disagl}
1508	eval destroy [winfo child .disagl]
1509	set txt .disagl.txt
1510	catch {eval grid forget [grid slaves .disagl]}
1511	text $txt -width 100 -wrap none \
1512	-yscrollcommand ".disagl.yscroll set" \
1513	-xscrollcommand ".disagl.xscroll set"
1514	scrollbar .disagl.yscroll -command "$txt yview"
1515	scrollbar .disagl.xscroll -command "$txt xview" -orient horizontal
1516	grid .disagl.xscroll -column 0 -row 2 -sticky ew
1517	grid $txt -column 0 -row 1 -sticky nsew
1518	grid .disagl.yscroll -column 1 -row 1 -sticky ns
1519	grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1520	grid columnconfig .disagl.f 2 -weight 1
1521	grid [button .disagl.f.close -text "Close & Delete" \
1522	-command "destroy .disagl; file delete $root.tmp"] \
1523	-column 3 -row 0 -sticky e
1524	grid [button .disagl.f.rename \
1525	-command "RenameAsFile $root.tmp $root.DIS .disagl" \
1526	-text "Close & Save as..."] \
1527	-column 4 -row 0 -sticky e
1528	# allow font changes on the fly
1529	if {$tcl_version >= 8.0} {
1530	$txt config -font $txtvw(font)
1531	set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1532	grid .disagl.f.font -column 1 -row 0 -sticky w
1533	grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1534	$fontbut delete 0 end
1535	foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1536	$fontbut add command -label "Courier $f" -font "Courier $f"\
1537	-command "set txtvw(font) \"Courier $f\"; \
1538	$txt config -font \$txtvw(font)"
1539	}
1540	}
1541
1542	grid columnconfigure .disagl 0 -weight 1
1543	grid rowconfigure .disagl 1 -weight 1
1544	wm title .disagl "DISAGL results $expgui(expfile)"
1545	wm iconname .disagl "DISAGL $root"
1546	set in [open $root.tmp r]
1547	$txt insert end [read $in]
1548	close $in
1549	bind all {destroy .disagl}
1550	bind .disagl "$txt yview scroll -1 page"
1551	bind .disagl "$txt yview scroll 1 page"
1552	bind .disagl "$txt xview scroll 1 unit"
1553	bind .disagl "$txt xview scroll -1 unit"
1554	bind .disagl "$txt yview scroll -1 unit"
1555	bind .disagl "$txt yview scroll 1 unit"
1556	bind .disagl "$txt yview 0"
1557	bind .disagl "$txt yview end"
1558	# don't disable in Win as this prevents the highlighting of selected text
1559	if {$tcl_platform(platform) != "windows"} {
1560	$txt config -state disabled
1561	}
1562	# find the beginning of the disagl text
1563
1564	set pos 1.0
1565	set nph 0
1566	while {[set loc [$txt search "Program DISAGL Version" $pos end]] != ""} {
1567	set pos [expr {$loc + 1}]
1568	incr nph
1569	}
1570	#puts "Found $nph DISAGL run(s)"
1571	# count phases
1572	set l {}
1573	while {[set loc [$txt search "Lattice constants are" $pos end]] != ""} {
1574	lappend l $loc
1575	set pos [expr {$loc + 1}]
1576	}
1577	catch {unset phaseloc}
1578
1579	set j 0
1580	foreach pos $l {
1581	if {$j == 0} {
1582	set prev $pos
1583	incr j
1584	continue
1585	}
1586	set phaseloc($j) [list $prev $pos]
1587	incr j
1588	}
1589	set phaseloc($j) [list $pos end]
1590	if {$nph >= 1 && $j >= 2} {
1591	grid [menubutton .disagl.f.copy \
1592	-menu .disagl.f.copy.menu \
1593	-text "Copy phase..." -bd 2 -relief raised] \
1594	-column 2 -row 0 -sticky nse
1595	menu .disagl.f.copy.menu
1596	for {set i 1} {$i <= $j} {incr i} {
1597	.disagl.f.copy.menu add command \
1598	-command "seldisaglphase $txt [list $phaseloc($i)]" \
1599	-label "Copy phase $i to clipboard"
1600	}
1601	} elseif {$nph >= 1} {
1602	grid [button .disagl.f.copy \
1603	-command "seldisaglphase $txt [list $phaseloc($j)]" \
1604	-text "Copy phase $j to clipboard"] \
1605	-column 2 -row 0 -sticky e
1606	}
1607	} else {
1608	runGSASwEXP disagl
1609	}
1610	}
1611
1612	proc seldisaglphase {txt phaselist} {
1613	# clear selection
1614	$txt tag remove sel 1.1 end
1615	eval $txt tag add sel $phaselist
1616	clipboard clear
1617	clipboard append " \| Program DISAGL Version MacOSX \|\n"
1618	clipboard append [eval $txt get [$txt tag ranges sel]]
1619	}
1620	#------------------------------------------------------------------------------
1621	# file conversions
1622	#------------------------------------------------------------------------------
1623	proc convfile {} {
1624	global expgui
1625	set frm .file
1626	catch {destroy $frm}
1627	toplevel $frm
1628	wm title $frm "Convert File"
1629	bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1630	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1631	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1632	-side left -fill y -expand yes
1633	pack [button $frmC.help -text Help -bg yellow \
1634	-command "MakeWWWHelp expgui.html ConvertWin"] -side top
1635	pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1636	pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1637	-side bottom
1638	pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1639	winfilebox $frm
1640	bind $frm <Return> "ValidWinCnv $frm"
1641
1642	# force the window to stay on top
1643	putontop $frm
1644	focus $frmC.q
1645	tkwait window $frm
1646	afterputontop
1647	}
1648
1649	# validate the files and make the conversion
1650	proc ValidWinCnv {frm} {
1651	global expgui
1652	# change backslashes to something sensible
1653	regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1654	# allow entry of D: for D:/ and D:TEST for d:/TEST
1655	if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1656	[string first :/ $expgui(FileMenuCnvName)] == -1} {
1657	regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1658	}
1659	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1660	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1661	ChooseWinCnv $frm
1662	return
1663	} elseif [file isdirectory \
1664	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1665	if {$expgui(FileMenuCnvName) != "."} {
1666	set expgui(FileMenuDir) \
1667	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1668	}
1669	ChooseWinCnv $frm
1670	return
1671	}
1672
1673	set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1674	if ![file exists $file] {
1675	MyMessageBox -parent $frm -title "Convert Error" \
1676	-message "File $file does not exist" -icon error
1677	return
1678	}
1679
1680	set tmpname "[file join [file dirname $file] tempfile.xxx]"
1681	set oldname "[file rootname $file].org"
1682	if [file exists $oldname] {
1683	set ans [MyMessageBox -parent . -title "Overwrite?" \
1684	-message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1685	-icon warning -type {Overwrite Cancel} -default Overwrite \
1686	-helplink "expguierr.html OverwriteCnv"]
1687	if {[string tolower $ans] == "cancel"} return
1688	catch {file delete $oldname}
1689	}
1690
1691	if [catch {
1692	set in [open $file r]
1693	set out [open $tmpname w]
1694	fconfigure $out -translation crlf -encoding ascii
1695	set len [gets $in line]
1696	if {$len > 160} {
1697	# this is a UNIX file. Hope there are no control characters
1698	set i 0
1699	set j 79
1700	while {$j < $len} {
1701	puts $out [string range $line $i $j]
1702	incr i 80
1703	incr j 80
1704	}
1705	} else {
1706	while {$len >= 0} {
1707	append line " "
1708	append line " "
1709	set line [string range $line 0 79]
1710	puts $out $line
1711	set len [gets $in line]
1712	}
1713	}
1714	close $in
1715	close $out
1716	file rename -force $file $oldname
1717	file rename -force $tmpname $file
1718	} errmsg] {
1719	MyMessageBox -parent $frm -title "Conversion error" \
1720	-message "Error in conversion:\n$errmsg" -icon warning
1721	} else {
1722	set ans [MyMessageBox -parent $frm -title "More?" \
1723	-message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1724	-type yesno -default no]
1725	if {$ans == "no"} {destroy $frm}
1726	}
1727	}
1728
1729	# create a file box
1730	proc winfilebox {frm} {
1731	global expgui
1732	set bx $frm.1
1733	pack [frame $bx.top] -side top
1734	pack [label $bx.top.a -text "Directory" ] -side left
1735	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1736	pack $bx.top.d -side left
1737	set expgui(FileMenuDir) [pwd]
1738	# the icon below is from tk8.0/tkfbox.tcl
1739	set upfolder [image create bitmap -data {
1740	#define updir_width 28
1741	#define updir_height 16
1742	static char updir_bits[] = {
1743	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1744	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1745	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1746	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1747	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1748	0xf0, 0xff, 0xff, 0x01};}]
1749
1750	pack [button $bx.top.b -image $upfolder \
1751	-command "updir; ChooseWinCnv $frm" ]
1752	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1753	listbox $bx.a.files -relief raised -bd 2 \
1754	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1755	-height 15 -width 0 -exportselection 0
1756	listbox $bx.a.dates -relief raised -bd 2 \
1757	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1758	-height 15 -width 0 -takefocus 0 -exportselection 0
1759	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1760	ChooseWinCnv $frm
1761	bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1762	bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1763	bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1764	bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1765	pack $bx.a.scroll -side left -fill y
1766	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1767	pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1768	}
1769
1770	# set the box or file in the selection window
1771	proc ReleaseWinCnv {frm} {
1772	global expgui
1773	set files $frm.1.a.files
1774	set dates $frm.1.a.dates
1775	set select [$files curselection]
1776	if {$select == ""} {
1777	set select [$dates curselection]
1778	}
1779	if {$select == ""} {
1780	set expgui(FileMenuCnvName) ""
1781	} else {
1782	set expgui(FileMenuCnvName) [string trim [$files get $select]]
1783	}
1784	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1785	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1786	ChooseWinCnv $frm
1787	} elseif [file isdirectory \
1788	[file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1789	if {$expgui(FileMenuCnvName) != "."} {
1790	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1791	ChooseWinCnv $frm
1792	}
1793	}
1794	return
1795	}
1796
1797	# select a file or directory -- called on double click
1798	proc SelectWinCnv {frm} {
1799	global expgui
1800	set files $frm.1.a.files
1801	set dates $frm.1.a.dates
1802	set select [$files curselection]
1803	if {$select == ""} {
1804	set select [$dates curselection]
1805	}
1806	if {$select == ""} {
1807	set file .
1808	} else {
1809	set file [string trim [$files get $select]]
1810	}
1811	if {$file == "<Parent>"} {
1812	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1813	ChooseWinCnv $frm
1814	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1815	if {$file != "."} {
1816	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1817	ChooseWinCnv $frm
1818	}
1819	} else {
1820	set expgui(FileMenuCnvName) [file tail $file]
1821	ValidWinCnv $frm
1822	}
1823	}
1824
1825	# fill the files & dates & Directory selection box with current directory,
1826	# also called when box is created to fill it
1827	proc ChooseWinCnv {frm} {
1828	global expgui
1829	set files $frm.1.a.files
1830	set dates $frm.1.a.dates
1831	set expgui(FileMenuCnvName) {}
1832	$files delete 0 end
1833	$dates delete 0 end
1834	$files insert end {<Parent>}
1835	$dates insert end {(Directory)}
1836	set filelist [glob -nocomplain \
1837	[file join [set expgui(FileMenuDir)] *] ]
1838	foreach file [lsort -dictionary $filelist] {
1839	if {[file isdirectory $file]} {
1840	$files insert end [file tail $file]
1841	$dates insert end {(Directory)}
1842	}
1843	}
1844	foreach file [lsort -dictionary $filelist] {
1845	if {![file isdirectory $file]} {
1846	set modified [clock format [file mtime $file] -format "%T %D"]
1847	$files insert end [file tail $file]
1848	$dates insert end $modified
1849	}
1850	}
1851	$expgui(FileDirButtonMenu) delete 0 end
1852	set list ""
1853	global tcl_version
1854	if {$tcl_version > 8.0} {
1855	catch {set list [string tolower [file volume]]}
1856	}
1857	set dir ""
1858	foreach subdir [file split [set expgui(FileMenuDir)]] {
1859	set dir [string tolower [file join $dir $subdir]]
1860	if {[lsearch $list $dir] == -1} {lappend list $dir}
1861	}
1862	foreach path $list {
1863	$expgui(FileDirButtonMenu) add command -label $path \
1864	-command "[list set expgui(FileMenuDir) $path]; \
1865	ChooseWinCnv $frm"
1866	}
1867	return
1868	}
1869
1870	#------------------------------------------------------------------------------
1871	# set options for liveplot
1872	proc liveplotopt {} {
1873	global liveplot expmap
1874	set frm .file
1875	catch {destroy $frm}
1876	toplevel $frm
1877	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1878	set last [lindex [lsort -integer $expmap(powderlist)] end]
1879	if {$last == ""} {set last 1}
1880	pack [scale $frmA.1 -label "Histogram number" -from 1 -to $last \
1881	-length 150 -orient horizontal -variable liveplot(hst)] -side top
1882	pack [checkbutton $frmA.2 -text {include plot legend}\
1883	-variable liveplot(legend)] -side top
1884	pack [button $frm.2 -text OK \
1885	-command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1886	] -side top
1887	bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1888
1889	# force the window to stay on top
1890	putontop $frm
1891	focus $frm.2
1892	tkwait window $frm
1893	afterputontop
1894	}
1895
1896	#------------------------------------------------------------------------------
1897	# get an experiment file name
1898	#------------------------------------------------------------------------------
1899	proc getExpFileName {mode} {
1900	global expgui tcl_platform
1901	set frm .file
1902	catch {destroy $frm}
1903	toplevel $frm
1904	wm title $frm "Experiment file"
1905	bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1906	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1907	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1908	-fill y -expand yes
1909	pack [button $frmC.help -text Help -bg yellow \
1910	-command "MakeWWWHelp expguierr.html open"] \
1911	-side top -anchor e
1912	pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1913	pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1914	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1915	pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1916	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1917
1918	set expgui(includearchived) 0
1919	set expgui(FileInfoBox) $frmC.info
1920	if {$mode == "old"} {
1921	pack [checkbutton $frmC.ar -text "Include Archived Files" \
1922	-variable expgui(includearchived) \
1923	-command "ChooseExpFil $frmA"] -side top -pady 10
1924	pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1925	-class SmallFont] \
1926	-side top -fill both -expand yes -pady 5
1927	} elseif {$mode != "new"} {
1928	# for initial read, don't access archived files
1929	pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1930	-class SmallFont] \
1931	-side top -fill both -expand yes -pady 5
1932	set mode "old"
1933	}
1934	pack [button $frmC.b -text Read \
1935	-command "valid_exp_file $frmA $mode"] -side bottom
1936	if {$mode == "new"} {
1937	$frmC.b config -text Save
1938	}
1939	pack [button $frmC.q -text Quit \
1940	-command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1941	bind $frm <Return> "$frmC.b invoke"
1942
1943	if {$mode == "new"} {
1944	pack [label $frmA.0 -text "Enter an experiment file to create"] \
1945	-side top -anchor center
1946	} else {
1947	pack [label $frmA.0 -text "Select an experiment file to read"] \
1948	-side top -anchor center
1949	}
1950	expfilebox $frmA $mode
1951	# force the window to stay on top
1952	putontop $frm
1953	focus $frmC.b
1954	tkwait window $frm
1955	afterputontop
1956	if {$expgui(FileMenuEXPNAM) == ""} return
1957	# is there a space in the EXP name?
1958	if {[string first " " [file tail $expgui(FileMenuEXPNAM)]] != -1} {
1959	update
1960	MyMessageBox -parent . -title "File Name Error" \
1961	-message "File name \"$expgui(FileMenuEXPNAM)\" is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1962	-icon warning -type Continue -default continue
1963	# -helplink "expguierr.html OpenErr"
1964	return
1965	}
1966	if {[string first " " $expgui(FileMenuDir)] != -1} {
1967	update
1968	MyMessageBox -parent . -title "Good luck..." \
1969	-message "You are using a directory with a space in the name ([file dirname $expgui(FileMenuDir)]) -- You may encounter bugs in EXPGUI. Please e-mail them to Brian.Toby@NIST.gov so they can be fixed." \
1970	-icon warning -type Continue -default continue
1971	# -helplink "expguierr.html OpenErr"
1972	}
1973	return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1974	}
1975
1976	# validation routine
1977	proc valid_exp_file {frm mode} {
1978	global expgui tcl_platform
1979	# windows fixes
1980	if {$tcl_platform(platform) == "windows"} {
1981	# change backslashes to something sensible
1982	regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1983	# allow entry of D: for D:/ and D:TEST for d:/TEST
1984	if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1985	[string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1986	regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1987	}
1988	}
1989	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1990	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1991	ChooseExpFil $frm
1992	return
1993	} elseif [file isdirectory \
1994	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1995	if {$expgui(FileMenuEXPNAM) != "."} {
1996	set expgui(FileMenuDir) \
1997	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1998	}
1999	ChooseExpFil $frm
2000	return
2001	}
2002	# append a .EXP if not present
2003	if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
2004	append expgui(FileMenuEXPNAM) ".EXP"
2005	}
2006	# is there a space in the name?
2007	if {[string first " " $expgui(FileMenuEXPNAM)] != -1} {
2008	MyMessageBox -parent . -title "File Name Error" \
2009	-message "File name $expgui(FileMenuEXPNAM) is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
2010	-icon warning -type Continue -default continue
2011	# -helplink "expguierr.html OpenErr"
2012	return
2013	}
2014	# check for archive files
2015	if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
2016	$mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
2017	destroy .file
2018	return
2019	} elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
2020	# check for files that end in something other than .EXP .exp or .Exp...
2021	MyMessageBox -parent . -title "File Open Error" \
2022	-message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
2023	-icon error
2024	return
2025	}
2026	# check on the file status
2027	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2028	if {$mode == "new" && [file exists $file]} {
2029	set ans [
2030	MyMessageBox -parent . -title "File Open Error" \
2031	-message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
2032	-icon question -type {"Select other" "Overwrite"} -default "select other" \
2033	-helplink "expguierr.html OverwriteErr"
2034	]
2035	if {[string tolower $ans] == "overwrite"} {destroy .file}
2036	return
2037	}
2038	# if file does not exist in case provided, set the name to all
2039	# upper case letters, since that is the best choice.
2040	# if it does exist, read from it as is. For UNIX we will force uppercase later.
2041	if {![file exists $file]} {
2042	set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
2043	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2044	}
2045	if {$mode == "old" && ![file exists $file]} {
2046	set ans [
2047	MyMessageBox -parent . -title "File Open Error" \
2048	-message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
2049	-icon question -type {"Select other" "Create"} -default "select other" \
2050	-helplink "expguierr.html OpenErr"
2051	]
2052	if {[string tolower $ans] == "create"} {destroy .file}
2053	return
2054	}
2055	destroy .file
2056	}
2057
2058	proc updir {} {
2059	global expgui
2060	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
2061	}
2062
2063	# create a file box
2064	proc expfilebox {bx mode} {
2065	global expgui
2066	pack [frame $bx.top] -side top
2067	pack [label $bx.top.a -text "Directory" ] -side left
2068	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
2069	pack $bx.top.d -side left
2070	set expgui(FileMenuDir) [pwd]
2071	# the icon below is from tk8.0/tkfbox.tcl
2072	set upfolder [image create bitmap -data {
2073	#define updir_width 28
2074	#define updir_height 16
2075	static char updir_bits[] = {
2076	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
2077	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
2078	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
2079	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
2080	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
2081	0xf0, 0xff, 0xff, 0x01};}]
2082
2083	pack [button $bx.top.b -image $upfolder \
2084	-command "updir; ChooseExpFil $bx" ]
2085	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2086	listbox $bx.a.files -relief raised -bd 2 \
2087	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
2088	-height 15 -width 0 -exportselection 0
2089	listbox $bx.a.dates -relief raised -bd 2 \
2090	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
2091	-height 15 -width 0 -takefocus 0 -exportselection 0
2092	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2093	ChooseExpFil $bx
2094	bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2095	bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2096	bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
2097	bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
2098	pack $bx.a.scroll -side left -fill y
2099	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2100	pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2101	}
2102	proc sync2boxesX {master slave scroll args} {
2103	$slave xview moveto [lindex [$master xview] 0]
2104	eval $scroll set $args
2105	}
2106	proc move2boxesX {boxlist args} {
2107	foreach listbox $boxlist {
2108	eval $listbox xview $args
2109	}
2110	}
2111	proc sync2boxesY {master slave scroll args} {
2112	$slave yview moveto [lindex [$master yview] 0]
2113	eval $scroll set $args
2114	}
2115	proc move2boxesY {boxlist args} {
2116	foreach listbox $boxlist {
2117	eval $listbox yview $args
2118	}
2119	}
2120
2121	# creates a table that is scrollable in both x and y, use ResizeScrollTable
2122	# to set sizes after gridding the boxes
2123	proc MakeScrollTable {box} {
2124	grid [label $box.0] -column 0 -row 0
2125	grid [set tbox [canvas $box.top \
2126	-scrollregion {0 0 10 10} \
2127	-xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
2128	-width 10 -height 10]] \
2129	-sticky sew -row 0 -column 1
2130	grid [set sbox [canvas $box.side \
2131	-scrollregion {0 0 10 10} \
2132	-yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
2133	-width 10 -height 10]] \
2134	-sticky nes -row 1 -column 0
2135	grid [set bbox [canvas $box.can \
2136	-scrollregion {0 0 10 10} \
2137	-yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
2138	-xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
2139	-width 200 -height 200 -bg lightgrey]] \
2140	-sticky news -row 1 -column 1
2141	grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2142	-command "move2boxesX \" $box.can $box.top \" "]] \
2143	-sticky ew -row 2 -column 1
2144	grid [set sybox [scrollbar $box.yscroll \
2145	-command "move2boxesY \" $box.can $box.side \" "]] \
2146	-sticky ns -row 1 -column 2
2147	frame $tbox.f -bd 0
2148	$tbox create window 0 0 -anchor nw -window $tbox.f
2149	frame $bbox.f -bd 2
2150	$bbox create window 0 0 -anchor nw -window $bbox.f
2151	frame $sbox.f -bd 2 -relief raised
2152	$sbox create window 0 0 -anchor nw -window $sbox.f
2153	grid columnconfig $box 1 -weight 1
2154	grid rowconfig $box 1 -weight 1
2155	return [list $tbox.f $bbox.f $sbox.f $box.0]
2156	}
2157
2158	proc ResizeScrollTable {box} {
2159	update idletasks
2160	for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2161	set x1 [lindex [grid bbox $box.can.f $i 0] 2]
2162	set x2 [lindex [grid bbox $box.top.f $i 0] 2]
2163	if {$x2 > $x1} {set x1 $x2}
2164	grid columnconfigure $box.top.f $i -minsize $x1
2165	grid columnconfigure $box.can.f $i -minsize $x1
2166	}
2167	for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2168	set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2169	set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2170	if {$x2 > $x1} {set x1 $x2}
2171	grid rowconfigure $box.can.f $i -minsize $x1
2172	grid rowconfigure $box.side.f $i -minsize $x1
2173	}
2174	update idletasks
2175	set sizes [grid bbox $box.can.f]
2176	$box.can config -scrollregion $sizes
2177	$box.side config -scrollregion $sizes
2178	$box.top config -scrollregion $sizes
2179	$box.top config -height [lindex [grid bbox $box.top.f] 3]
2180	$box.side config -width [lindex [grid bbox $box.side.f] 2]
2181	}
2182	proc ExpandScrollTable {box} {
2183	# set height & width of central box
2184	$box.can config -width \
2185	[expr [winfo width [winfo toplevel $box]] \
2186	- [winfo width $box.side] - [winfo width $box.yscroll]-20]
2187	$box.can config -height \
2188	[expr [winfo height [winfo toplevel $box]] \
2189	- [winfo height $box.top] - [winfo height $box.scroll]-25]
2190	}
2191
2192
2193	# support routine for SetHistUseFlags
2194	proc InitHistUseFlags {} {
2195	global expmap expgui
2196	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2197	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2198	set expgui(useflag_$i) [histinfo $i use]
2199	# }
2200	}
2201	}
2202
2203	# show all Powder histograms; set use/do not use flags
2204	proc SetHistUseFlags {} {
2205	set box .test
2206	catch {toplevel $box}
2207	eval destroy [winfo children $box]
2208	grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2209	grid [frame $box.a] -row 1 -column 0 -columnspan 2
2210	grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2211	grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2212	grid columnconfig $box 0 -weight 1
2213	grid columnconfig $box 1 -weight 1
2214	foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2215	$cbox config -text "Use\nFlag"
2216	[winfo parent $bbox] config -height 250 -width 400
2217	global expmap expgui
2218	set px 5
2219	set row -1
2220	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2221	if {[string range $expmap(htype_$i) 2 2] == "T"} {
2222	set det [format %8.2f [histinfo $i tofangle]]
2223	} elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2224	set det [format %8.5f [histinfo $i lam1]]
2225	} elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2226	set det [format %8.2f [histinfo $i lam1]]
2227	} else {
2228	set det {}
2229	}
2230	incr row
2231	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2232	grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0
2233	set expgui(useflag_$i) [histinfo $i use]
2234	# }
2235	grid [label $bbox.0$i \
2236	-text [string range $expmap(htype_$i) 0 3] \
2237	] -row $row -column 0 -padx $px
2238	grid [label $bbox.1$i -text [histinfo $i bank] \
2239	] -row $row -column 1 -padx $px
2240	grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2241	grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2242	] -row $row -column 3 -padx $px -sticky ew
2243	}
2244	grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2245	grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2246	grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2247	grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2248	ResizeScrollTable $box.a
2249	InitHistUseFlags
2250	putontop $box
2251	tkwait window $box
2252	afterputontop
2253	set prevchages $expgui(changed)
2254	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2255	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2256	if {$expgui(useflag_$i) != [histinfo $i use]} {
2257	histinfo $i use set $expgui(useflag_$i)
2258	RecordMacroEntry "histinfo $i use set $expgui(useflag_$i)" 0
2259	incr expgui(changed)
2260	RecordMacroEntry "incr expgui(changed)" 0
2261	}
2262	# }
2263	}
2264	if {$prevchages != $expgui(changed)} {
2265	set msg "You have changed [expr $expgui(changed)-$prevchages] "
2266	append msg "histogram flag(s). You must run POWPREF "
2267	append msg "to include/remove these histograms. Do you want to "
2268	append msg "run POWPREF?"
2269	set ans [MyMessageBox -parent . -message $msg \
2270	-title "Process changes?"\
2271	-helplink "expguierr.html ProcessUse" \
2272	-default {Run POWPREF} \
2273	-type {{Run POWPREF} Skip}]
2274
2275	if {$ans == "skip"} {
2276	# save and reload the experiment file
2277	savearchiveexp
2278	loadexp $expgui(expfile)
2279	} else {
2280	# run powpref and force a reload
2281	set saveautoload $expgui(autoexpload)
2282	set expgui(autoexpload) 1
2283	runGSASwEXP powpref
2284	set expgui(autoexpload) $saveautoload
2285	}
2286	}
2287	}
2288
2289	# set the box or file in the selection window
2290	proc ReleaseExpFil {frm} {
2291	global expgui
2292	set files $frm.a.files
2293	set dates $frm.a.dates
2294	set select [$files curselection]
2295	if {$select == ""} {
2296	set select [$dates curselection]
2297	}
2298	if {$select == ""} {
2299	set expgui(FileMenuEXPNAM) ""
2300	} else {
2301	set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2302	after idle UpdateInfoBox
2303	}
2304	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2305	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2306	ChooseExpFil $frm
2307	} elseif [file isdirectory \
2308	[file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2309	if {$expgui(FileMenuEXPNAM) != "."} {
2310	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2311	ChooseExpFil $frm
2312	}
2313	}
2314	return
2315	}
2316	proc UpdateInfoBox {} {
2317	global expgui
2318	if {![winfo exists $expgui(FileInfoBox)]} return
2319	eval destroy [winfo children $expgui(FileInfoBox)]
2320	set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2321	if [file isdirectory $file] return
2322	if [file exists $file] {
2323	pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2324	-side top
2325	catch {
2326	set fp [open $file r]
2327	global testline
2328	set testline [read $fp]
2329	close $fp
2330	update
2331	regexp {GNLS RUN on (.) +Total.run *([0-9]+) } \
2332	$testline a last cycles
2333	pack [label $expgui(FileInfoBox).2 -justify left \
2334	-text "last GENLES run:\n $last\n total cycles: $cycles"] \
2335	-side top -anchor w
2336	regexp {REFN GDNFT.= ([0-9]\.[0-9]) +for *([0-9]+) variables} \
2337	$testline a chi2 vars
2338	pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
2339	-side top -anchor w
2340	pack [label $expgui(FileInfoBox).3.a -justify left \
2341	-text "c" -font symbol] \
2342	-side left -anchor w
2343	pack [label $expgui(FileInfoBox).3.b -justify left \
2344	-text "2: $chi2, $vars vars"] \
2345	-side top -anchor w
2346	# check first 9 histograms
2347	set lbl "h Rwp R(F2)"
2348	set n 0
2349	foreach k {1 2 3 4 5 6 7 8 9} {
2350	set key "HST $k"
2351	append key { RPOWD +([0-9]\.[0-9]) }
2352	set i [regexp $key $testline a Rwp]
2353	set key "HST $k"
2354	append key { R-FAC +[0-9]+ +([0-9]\.[0-9]) }
2355	set j [regexp $key $testline a Rb]
2356	if {$i \|\| $j} {
2357	incr n
2358	append lbl "\n$k "
2359	if {$i} {
2360	append lbl [string range $Rwp 0 5]
2361	} else {
2362	append lbl " "
2363	}
2364	}
2365	if {$j} {
2366	append lbl " [string range $Rb 0 5]"
2367	}
2368	# stick 1st 3 entries in box
2369	if {$n >= 3} break
2370	}
2371	pack [label $expgui(FileInfoBox).4 -justify left \
2372	-text $lbl] \
2373	-side top -anchor w
2374	}
2375	}
2376	}
2377
2378	# select a file or directory -- called on double click
2379	proc SelectExpFil {frm mode} {
2380	global expgui
2381	set files $frm.a.files
2382	set dates $frm.a.dates
2383	set select [$files curselection]
2384	if {$select == ""} {
2385	set select [$dates curselection]
2386	}
2387	if {$select == ""} {
2388	set file .
2389	} else {
2390	set file [string trim [$files get $select]]
2391	}
2392	if {$file == "<Parent>"} {
2393	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2394	ChooseExpFil $frm
2395	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2396	if {$file != "."} {
2397	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2398	ChooseExpFil $frm
2399	}
2400	} else {
2401	set expgui(FileMenuEXPNAM) [file tail $file]
2402	valid_exp_file $frm $mode
2403	}
2404	}
2405
2406	# fill the files & dates & Directory selection box with current directory,
2407	# also called when box is created to fill it
2408	proc ChooseExpFil {frm} {
2409	global expgui
2410	set files $frm.a.files
2411	set dates $frm.a.dates
2412	set expgui(FileMenuEXPNAM) {}
2413	$files delete 0 end
2414	$dates delete 0 end
2415	$files insert end {<Parent>}
2416	$dates insert end {(Directory)}
2417	set filelist [glob -nocomplain \
2418	[file join [set expgui(FileMenuDir)] *] ]
2419	foreach file [lsort -dictionary $filelist] {
2420	if {[file isdirectory $file]} {
2421	$files insert end [file tail $file]
2422	$dates insert end {(Directory)}
2423	}
2424	}
2425	set pairlist {}
2426	foreach file [lsort -dictionary $filelist] {
2427	if {![file isdirectory $file] && \
2428	[string toupper [file extension $file]] == ".EXP"} {
2429	set modified [file mtime $file]
2430	lappend pairlist [list $file $modified]
2431	} elseif {![file isdirectory $file] && $expgui(includearchived) && \
2432	[string match {*.O[0-9A-F][0-9A-F]} $file]} {
2433	set modified [file mtime $file]
2434	lappend pairlist [list $file $modified]
2435	}
2436	}
2437	if {$expgui(filesort) == 0} {
2438	foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
2439	set file [lindex $pair 0]
2440	set modified [clock format [lindex $pair 1] -format "%T %D"]
2441	$files insert end [file tail $file]
2442	$dates insert end $modified
2443	}
2444	} else {
2445	foreach pair [lsort -dictionary -index 0 $pairlist] {
2446	set file [lindex $pair 0]
2447	set modified [clock format [lindex $pair 1] -format "%T %D"]
2448	$files insert end [file tail $file]
2449	$dates insert end $modified
2450	}
2451	}
2452	$expgui(FileDirButtonMenu) delete 0 end
2453	set list ""
2454	global tcl_platform tcl_version
2455	if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2456	catch {set list [string tolower [file volume]]}
2457	}
2458	set dir ""
2459	foreach subdir [file split [set expgui(FileMenuDir)]] {
2460	set dir [file join $dir $subdir]
2461	if {$tcl_platform(platform) == "windows"} {
2462	set dir [string tolower $dir]
2463	if {[lsearch $list $dir] == -1} {lappend list $dir}
2464	} else {
2465	lappend list $dir
2466	}
2467	}
2468	foreach path $list {
2469	$expgui(FileDirButtonMenu) add command -label $path \
2470	-command "[list set expgui(FileMenuDir) $path]; \
2471	ChooseExpFil $frm"
2472	}
2473	# highlight the current experiment -- if present
2474	for {set i 0} {$i < [$files size]} {incr i} {
2475	set file [$files get $i]
2476	if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2477	$files selection set $i
2478	}
2479	}
2480	return
2481	}
2482
2483
2484	#------------------------------------------------------------------------------
2485	# platform-specific definitions
2486	if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2487	# windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2488	# DOS box synchronously, so we create a "lock" file that is deleted
2489	# at the end of the DOS run so we can tell when the run is done.
2490	# We create a window to force the deleting of the file so that if
2491	# the DOS process crashes, the user can continue anyway.
2492	#
2493	# procedure to check if the lock file is still there (Win-9x/me only)
2494	proc checklockfile {file window} {
2495	if [file exists $file] {
2496	after 500 checklockfile $file $window
2497	} else {
2498	catch {destroy $window}
2499	}
2500	}
2501	# this procedure starts the GRWND program, if needed for program $prog
2502	proc StartGRWND {prog} {
2503	global expgui
2504	if {!$expgui(autoGRWND)} return
2505	# at some point we might want to have a real list
2506	if {$prog != "genles" && $prog != "powpref"} {
2507	# get a list of running jobs
2508	exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
2509	set fp [open tlist.tlist r]
2510	set text [read $fp]
2511	close $fp
2512	file delete -force tlist.tlist
2513	# if GRWND.EXE is not currently running, start it
2514	if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
2515	exec [file join $expgui(gsasexe) grwnd.exe] &
2516	# give grwnd a 1 second head start
2517	after 1000
2518	}
2519	}
2520	}
2521	# this creates a DOS box to run a program in
2522	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2523	global env expgui
2524	# Windows environment variables
2525	set env(GSAS) [file nativename $expgui(gsasdir)]
2526	# PGPLOT_FONT is needed by PGPLOT
2527	set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2528	# this is the number of lines/page in the .LST (etc.) file
2529	set env(LENPAGE) 60
2530	set pwd [file nativename [pwd]]
2531
2532	# check the .EXP path -- can DOS use it?
2533	if {[string first // [pwd]] != -1} {
2534	MyMessageBox -parent . -title "Invalid Path" \
2535	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2536	-icon error -type ok -default ok \
2537	-helplink "expgui_Win_readme.html NetPath"
2538	return
2539	}
2540	if {[info command winutils::shell] == "" && \
2541	[info command winexec] == ""} {
2542	MyMessageBox -parent . -title "Setup error" \
2543	-message {Error -- Use "Neither WINEXEC not WINTILS were found. Can't do anything!"} \
2544	-icon error -type darn -default darn \
2545	-helplink "expgui_Win_readme.html Winexec"
2546	return
2547	}
2548	# loop over multiple commands
2549	foreach cmd $command {
2550	# simulate the wait with a lock file
2551	if {$wait} {
2552	if {$expgui(autoiconify)} {wm iconify .}
2553	# create a blank lock file and a message window
2554	close [open expgui.lck w]
2555	toplevel .lock
2556	grid [button .lock.0 -text Help -bg yellow \
2557	-command "MakeWWWHelp expguierr.html lock"] \
2558	-column 1 -row 0
2559	grid [label .lock.1 \
2560	-text "Please wait while the GSAS program finishes."] \
2561	-column 0 -row 0
2562	grid [label .lock.2 -text \
2563	"In case a problem occurs, close the DOS box"] \
2564	-column 0 -columnspan 2 -row 1
2565	grid [label .lock.3 -text \
2566	"and press the \"Continue\" button (below)"] \
2567	-column 0 -columnspan 2 -row 2
2568	grid [button .lock.b -text "Continue" \
2569	-command "destroy .lock; wm deiconify ."] \
2570	-column 0 -columnspan 2 -row 3
2571	putontop .lock
2572	update
2573	checklockfile expgui.lck .lock
2574	}
2575
2576	# pause is hard coded in the GSASTCL.BAT file
2577	if {$expgui(execprompt)} {
2578	set script gsastcl.bat
2579	} else {
2580	set script gsasnowt.bat
2581	}
2582
2583	# replace the forward slashes with backward
2584	regsub -all / $cmd \\ cmd
2585	if {[info command winutils::shell] != ""} {
2586	winutils::shell [file join $expgui(scriptdir) $script] $cmd
2587	} else {
2588	winexec -d [file nativename [pwd]] \
2589	[file join $expgui(scriptdir) $script] $cmd
2590	}
2591	if {$expgui(MacroRunning)} {
2592	update
2593	update idletasks
2594	}
2595	if {$wait} {
2596	tkwait window .lock
2597	file delete -force expgui.lck
2598	}
2599	}
2600	if {$expgui(autoiconify) && $wait} {wm deiconify .}
2601	# check for changes in the .EXP file immediately
2602	whenidle
2603	}
2604	} elseif {$tcl_platform(platform) == "windows"} {
2605	# now for Windows-NT, where we can run synchronously
2606	#
2607	# this creates a DOS box to run a program in
2608	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2609	global env expgui
2610	# Windows environment variables
2611	set env(GSAS) [file nativename $expgui(gsasdir)]
2612	# PGPLOT_FONT is needed by PGPLOT
2613	set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2614	# this is the number of lines/page in the .LST (etc.) file
2615	set env(LENPAGE) 60
2616	set pwd [file nativename [pwd]]
2617	# check the path -- can DOS use it?
2618	if {[string first // [pwd]] != -1} {
2619	MyMessageBox -parent . -title "Invalid Path" \
2620	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2621	-icon error -type ok -default ok \
2622	-helplink "expgui_Win_readme.html NetPath"
2623	return
2624	}
2625	# pause is hard coded in the .BAT file
2626	if {$expgui(execprompt)} {
2627	set script gsastcl.bat
2628	} else {
2629	set script gsasnowt.bat
2630	}
2631
2632	if {$wait} {
2633	if {$expgui(autoiconify)} {wm iconify .}
2634	# create a blank lock file (keep liveplot from running)
2635	close [open expgui.lck w]
2636	# loop over commands
2637	foreach cmd $command {
2638	# replace the forward slashes with backward
2639	regsub -all / $cmd \\ cmd
2640	exec $env(COMSPEC) /c \
2641	"start [file join $expgui(scriptdir) $script] $cmd"
2642	}
2643	file delete -force expgui.lck
2644	if {$expgui(autoiconify)} {wm deiconify .}
2645	# check for changes in the .EXP file immediately
2646	whenidle
2647	} else {
2648	# loop over commands
2649	foreach cmd $command {
2650	# replace the forward slashes with backward
2651	regsub -all / $cmd \\ cmd
2652	# run in background
2653	exec $env(COMSPEC) /c \
2654	"start [file join $expgui(scriptdir) $script] $cmd" &
2655	if {$expgui(MacroRunning)} {
2656	update
2657	update idletasks
2658	}
2659	}
2660	}
2661	}
2662	} else {
2663	# this creates a xterm window to run a program in
2664	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2665	global env expgui
2666	# UNIX environment variables
2667	set env(GSAS) [file nativename $expgui(gsasdir)]
2668	set env(gsas) [file nativename $expgui(gsasdir)]
2669	set env(GSASEXE) $expgui(gsasexe)
2670	set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2671	set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2672	# PGPLOT_DIR is needed by PGPLOT
2673	set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2674	# this is the number of lines/page in the .LST (etc.) file
2675	set env(LENPAGE) 60
2676	set termopts {}
2677	if $env(GSASBACKSPACE) {
2678	append termopts \
2679	{-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2680	}
2681	if $scrollbar {
2682	append termopts " -sb"
2683	} else {
2684	append termopts " +sb"
2685	}
2686	if {$wait} {
2687	set suffix {}
2688	} else {
2689	set suffix {&}
2690	}
2691
2692	# hold window open after commands finish
2693	if {$expgui(execprompt)} {
2694	append command "\; echo -n Press Enter to continue \; read x"
2695	}
2696	if {$wait && $expgui(autoiconify)} {wm iconify .}
2697	catch {eval exec xterm $termopts -title [list $title] \
2698	-e /bin/sh -c [list $command] $suffix} errmsg
2699	if $expgui(debug) {puts "xterm result = $errmsg"}
2700	if {$expgui(MacroRunning)} {
2701	update
2702	update idletasks
2703	}
2704	if {$wait} {
2705	if {$expgui(autoiconify)} {wm deiconify .}
2706	# check for changes in the .EXP file immediately
2707	whenidle
2708	}
2709	}
2710	}
2711
2712	# run commands without a terminal window
2713	proc runnoterm {command outfile} {
2714	global env expgui tcl_platform
2715	if {$tcl_platform(platform) == "windows"} {
2716	# Windows environment variables
2717	set env(GSAS) [file nativename $expgui(gsasdir)]
2718	# PGPLOT_FONT is needed by PGPLOT
2719	set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2720	# this is the number of lines/page in the .LST (etc.) file
2721	set env(LENPAGE) 60
2722	set pwd [file nativename [pwd]]
2723	# loop over multiple commands
2724	foreach cmd $command {
2725	# replace the forward slashes with backward
2726	regsub -all / $cmd \\ cmd
2727	exec $cmd >>& $outfile
2728	update
2729	update idletasks
2730	}
2731	} else {
2732	# UNIX environment variables
2733	set env(GSAS) [file nativename $expgui(gsasdir)]
2734	set env(gsas) [file nativename $expgui(gsasdir)]
2735	set env(GSASEXE) $expgui(gsasexe)
2736	set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2737	set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2738	# PGPLOT_DIR is needed by PGPLOT
2739	set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2740	# this is the number of lines/page in the .LST (etc.) file
2741	set env(LENPAGE) 60
2742	foreach cmd $command {
2743	catch {eval exec $cmd >>& $outfile} errmsg
2744	}
2745	update
2746	update idletasks
2747	}
2748	# check for changes in the .EXP file immediately
2749	#whenidle
2750	}
2751
2752	# modify resource fork info for a .EXP file on the Mac
2753	proc MacSetResourceFork {expfile} {
2754	global expgui tcl_platform
2755	if {$tcl_platform(os) != "Darwin"} {return}
2756	set expnative [file nativename $expfile]
2757	#
2758	# assign an app to the data file, if the app and the
2759	# required tool (Rez) are installed
2760	set app [file join $expgui(gsasdir) expgui.app]
2761	if {[file exists /Developer/Tools/Rez]} {
2762	set RezApp /Developer/Tools/Rez
2763	} elseif {[file exists [file join $expgui(gsasdir) Rez]]} {
2764	set RezApp [file join $expgui(gsasdir) Rez]
2765	} else {
2766	set RezApp {}
2767	}
2768	if {[file exists /Developer/Tools/SetFile]} {
2769	set SetFileApp /Developer/Tools/SetFile
2770	} elseif {[file exists [file join $expgui(gsasdir) SetFile]]} {
2771	set SetFileApp [file join $expgui(gsasdir) SetFile]
2772	} else {
2773	set SetFileApp {}
2774	}
2775	if {[file exists $app] && $RezApp != ""} {
2776	# make a resource file
2777	set l [string length $app]; incr l
2778	set str "data 'usro' (0) {\n"
2779	append str { $"}
2780	append str [format %.8X $l]
2781	foreach char [split $app {}] {
2782	append str [format %.2X [scan $char %c]]
2783	}
2784	append str {00"}
2785	append str " \t/* ....$app. */\n};"
2786	set fp [open setapp.r w]
2787	puts $fp $str
2788	close $fp
2789	exec $RezApp setapp.r -o $expnative -a
2790	file delete -force setapp.r
2791	}
2792
2793	# assign an icon to the data file, if it and the required tools exist
2794	set icon [file join $expgui(gsasdir) gsasicon.r]
2795	if {[file exists $icon] && $RezApp != "" && $SetFileApp != ""} {
2796	exec $RezApp [file nativename $icon] -o $expnative -a
2797	exec $SetFileApp -a C $expnative
2798	}
2799	}
2800
2801	#-------------------------------------------------------------------------------
2802	# Macro Recording
2803	#-------------------------------------------------------------------------------
2804	set expgui(MacroBufferedCommand) ""
2805	set expgui(fpMacroFile) ""
2806	set expgui(MacroFile) ""
2807	# Turn on/off mode to save commands in MacroFile
2808	proc SetRecordMacroOnOff {args} {
2809	global expgui
2810	if {$expgui(RecordMacro)} {
2811	set expgui(fpMacroFile) ""
2812	set expgui(MacroBufferedCommand) ""
2813	while {$expgui(fpMacroFile) == ""} {
2814	set expgui(MacroFile) [tk_getSaveFile -initialdir [pwd] \
2815	-parent . \
2816	-filetypes {{"EXPGUI Macro file" .expmac}} \
2817	-defaultextension .expmac \
2818	-initialfile EXPGUI.expmac \
2819	-title "Choose location to save macro"]
2820	if {$expgui(MacroFile) == ""} {
2821	# respond to cancel
2822	set expgui(fpMacroFile) ""
2823	set expgui(MacroFile) ""
2824	set expgui(RecordMacro) 0
2825	return
2826	}
2827	if {[catch {
2828	set expgui(fpMacroFile) [open $expgui(MacroFile) w]
2829	puts $expgui(fpMacroFile) "# [clock format [clock seconds] -format %Y-%m-%dT%T]"
2830	} errmsg]} {
2831	MyMessageBox -parent . -title "Error opening selected file" \
2832	-message "Error opening macro file:\n$errmsg" \
2833	-icon warning -type TryAgain -default tryagain
2834	catch {close $expgui(fpMacroFile)}
2835	set expgui(fpMacroFile) ""
2836	set expgui(MacroFile) ""
2837	set expgui(RecordMacro) 0
2838	}
2839	}
2840	} else {
2841	if {[string trim $expgui(MacroBufferedCommand)] != ""} {
2842	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
2843	}
2844	catch {close $expgui(fpMacroFile)}
2845	set expgui(fpMacroFile) ""
2846	set expgui(MacroFile) ""
2847	set expgui(MacroBufferedCommand) ""
2848	}
2849	}
2850
2851	# record a command in the Macro File
2852	proc RecordMacroEntry {command buffer} {
2853	global expgui
2854	if {! $expgui(RecordMacro)} return
2855	# in buffered mode: hold the last command in memory and compare to the
2856	# next. If two commands differ only in the final argument, then the
2857	# second command makes the previous redundant so only the latter version
2858	# is retained (This will happen when a user types a string into a box).
2859	# When the commands differ, then the previous is written to file
2860	# and the next is retained in memory.
2861	if {$buffer} {
2862	if {[string trim $expgui(MacroBufferedCommand)] == ""} {
2863	set expgui(MacroBufferedCommand) $command
2864	return
2865	}
2866	set diff 0
2867	# is command a repeat of previous?
2868	foreach a $command b $expgui(MacroBufferedCommand) {
2869	if {$diff} {
2870	# found a difference, other than in the last arg
2871	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
2872	break
2873	}
2874	if {$a != $b} {set diff 1}
2875	}
2876	set expgui(MacroBufferedCommand) $command
2877	} else {
2878	# no buffering on current command; write the old and new to file.
2879	if {[string trim $expgui(MacroBufferedCommand)] != ""} {
2880	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
2881	}
2882	puts $expgui(fpMacroFile) $command
2883	set expgui(MacroBufferedCommand) ""
2884	}
2885	}
2886
2887	proc CantRecordMacroEntry {comment} {
2888	global expgui
2889	if {! $expgui(RecordMacro)} return
2890
2891	# no buffering on current command; write the old and new to file.
2892	if {[string trim $expgui(MacroBufferedCommand)] != ""} {
2893	puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
2894	}
2895	puts $expgui(fpMacroFile) "# unrecorded: $comment"
2896	set expgui(MacroBufferedCommand) ""
2897	MyMessageBox -parent . -title "No command record" \
2898	-message "EXPGUI is not able to record this action in the macro file: $comment" \
2899	-icon warning
2900	}
2901
2902
2903	# Play back commands in Macro File
2904	proc ReplayMacroFile {"lineatatime 0"} {
2905	global expgui
2906	set expnam [file root [file tail $expgui(expfile)]]
2907	file delete abort_${expnam}_macro.flag
2908	set expgui(MacroRunning) 0
2909	set MacroFile [tk_getOpenFile -initialdir [pwd] \
2910	-parent . \
2911	-filetypes {{"EXPGUI Macro file" .expmac} {Everything .*}} \
2912	-defaultextension .expmac \
2913	-title "Choose location to read macro"]
2914	if {$MacroFile == ""} return
2915	set expgui(MacroRunning) 1
2916	if {$lineatatime} {
2917	set expgui(MacroChanged) 0
2918	set top1 .macro
2919	catch {destroy $top1}
2920	toplevel $top1
2921	set txt $top1.t
2922	grid [text $txt -width 30 -height 20 -yscrollcommand "$top1.s set"] \
2923	-column 0 -row 0 -sticky news
2924	wm title $top1 "File $MacroFile"
2925	grid [scrollbar $top1.s -command "$txt yview"] \
2926	-column 1 -row 0 -sticky ns
2927	grid [frame $top1.b] -column 0 -columnspan 2 -row 1 -sticky ew
2928	grid columnconfig $top1 0 -weight 1
2929	grid rowconfig $top1 0 -weight 1
2930	grid [button $top1.b.e -text "Execute line" \
2931	-command "MacroExecuteCurrentLine $txt"] \
2932	-column 0 -row 0 -sticky w
2933	grid columnconfig $top1.b 1 -weight 1
2934	grid [button $top1.b.s -text "Save As" -state disabled \
2935	-command "MacroResave $txt"] -column 1 -row 0
2936	set expgui(MacroSaveButton) $top1.b.s
2937	grid [button $top1.b.c -text "Close " \
2938	-command "MacroCloseWindow $txt"] -column 2 -row 0
2939	$txt delete 0.0 end
2940	set fp [open $MacroFile r]
2941	$txt insert 0.0 [read $fp]
2942	close $fp
2943	MacroHighlightText $txt 1
2944	# deal with editing in the box
2945	$txt configure -undo 1
2946	$txt edit modified 0
2947	bind $txt <<Modified>> {
2948	$expgui(MacroSaveButton) configure -state normal
2949	set expgui(MacroChanged) 1
2950	}
2951	} else {
2952	close [open running_${expnam}_macro.flag w]
2953	set saveprompt $expgui(execprompt)
2954	set saveautold $expgui(autoexpload)
2955	set expgui(execprompt) 0
2956	set expgui(autoexpload) 1
2957	set expnam [file root [file tail $expgui(expfile)]]
2958	if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
2959	set outfile ${expnam}_macout.LST
2960	# create an empty file
2961	catch {file delete $outfile}
2962	close [open $outfile w]
2963	# view it with LSTVIEW
2964	set outfile ${expnam}_macout
2965	exec $::wishshell [file join $expgui(scriptdir) lstview] $outfile &
2966	} else {
2967	# show status, offer abort with MACROMON
2968	exec $::wishshell [file join $expgui(scriptdir) macromon] $expnam &
2969	}
2970
2971	set expgui(MacroStatus) "starting script"
2972	pleasewait "\nrunning macro\n\nStatus:" expgui(MacroStatus)
2973
2974	if {[catch {
2975	source $MacroFile
2976	} errmsg]} {
2977	set txt $::errorInfo
2978	catch {
2979	set fp [open error.txt a]
2980	puts $fp "# [clock format [clock seconds] -format %Y-%m-%dT%T]"
2981	puts $fp $txt
2982	close $fp
2983	}
2984	donewait
2985	MyMessageBox -parent . -title "Error running Macro file" \
2986	-message "Error running macro file:\n$errmsg\n(details in file error.txt)" \
2987	-icon error -type OK -default ok
2988	} else {
2989	donewait
2990	}
2991	file delete running_${expnam}_macro.flag
2992	set expgui(execprompt) $saveprompt
2993	set expgui(autoexpload) $saveautold
2994	set expgui(MacroRunning) 0
2995	# show changes
2996	PaintEXPGUIpages
2997	# put comment in output file
2998	if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
2999	set outfile ${expnam}_macout.LST
3000	set fp [open $outfile a]
3001	puts $fp "\n** Macro ended **"
3002	close $fp
3003	}
3004	}
3005	}
3006
3007	# highlight a line in the Macro file display
3008	proc MacroHighlightText {txt line} {
3009	$txt tag delete next
3010	$txt tag add next $line.0 $line.end
3011	$txt see $line.0
3012	$txt tag configure next -background yellow
3013	# tag all text
3014	$txt tag delete all
3015	$txt tag add all 0.0 end
3016	# double-click moves the current line
3017	$txt tag bind all <Double-1> "after idle [list MacroDoubleClick $txt]"
3018	}
3019
3020	# respond to a double click by moving the next line to be executed to
3021	# the line where the double click occurred
3022	proc MacroDoubleClick {txt} {
3023	set line [lindex [split [$txt tag ranges sel] "."] 0]
3024	MacroHighlightText $txt $line
3025	}
3026
3027	# respond to Execute button: execute the current line
3028	# close window after last command
3029	proc MacroExecuteCurrentLine {txt} {
3030	global expgui
3031	set linenum [lindex [split [$txt tag ranges next] "."] 0]
3032	if {$linenum == ""} {return}
3033	set line [$txt get $linenum.0 $linenum.end]
3034	# is this continued (ends with \)?
3035	while {[string range $line end end] == "\\" } {
3036	incr linenum
3037	# get rid of trailing backslash
3038	set line [string range $line 0 end-1]
3039	#append next line
3040	append line [$txt get $linenum.0 $linenum.end]
3041	}
3042	if {[catch $line errmsg]} {
3043	MyMessageBox -parent $txt -title "Error on line" \
3044	-message "Error on line $linenum:\n$errmsg" \
3045	-icon warning -type Continue -default continue
3046	}
3047	# show changes
3048	PaintEXPGUIpages
3049	# move forward in macrofile
3050	incr linenum
3051	MacroHighlightText $txt $linenum
3052	set linenum [lindex [split [$txt tag ranges next] "."] 0]
3053	# at end?
3054	if {$linenum == ""} {MacroCloseWindow $txt}
3055	}
3056
3057	# Save a modified macro file
3058	proc MacroResave {txt} {
3059	global expgui
3060	set MacroFile [tk_getSaveFile -initialdir [pwd] \
3061	-parent $txt \
3062	-filetypes {{"EXPGUI Macro file" .expmac}} \
3063	-defaultextension .expmac \
3064	-initialfile $expgui(MacroFile) \
3065	-title "Choose location to save macro"]
3066	if {[string trim $MacroFile] == ""} {return}
3067	if {[catch {
3068	set fp [open $MacroFile w]
3069	puts $fp [string trim [$txt get 0.0 end]]
3070	close $fp
3071	} errmsg]} {
3072	MyMessageBox -parent $txt -title "Error writing to file" \
3073	-message "Error writing macro file:\n$errmsg" \
3074	-icon warning -type TryAgain -default tryagain
3075	return
3076	}
3077	set expgui(MacroChanged) 0
3078	# gray out the button
3079	$expgui(MacroSaveButton) configure -state disabled
3080	}
3081
3082	# close the window, but provide a chance to save the file first, if modified
3083	proc MacroCloseWindow {txt} {
3084	global expgui
3085	if {$expgui(MacroChanged)} {
3086	set ans [MyMessageBox -parent $txt -title "Save macro file?" \
3087	-message "Macro file has been changed, do you want to save it?" \
3088	-icon warning -type "Yes No" -default no]
3089	if {$ans != "no"} {MacroResave $txt}
3090	}
3091	set expgui(MacroRunning) 0
3092	destroy [winfo toplevel $txt]
3093	}
3094
3095	# Add a comment to a macro file
3096	proc AddCommentMacroFile {} {
3097	global expgui
3098	if {! $expgui(RecordMacro)} return
3099	RecordMacroEntry "# [getstring "comment for macro file"]" 0
3100	}

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

Download in other formats: