Context Navigation

source: trunk/gsascmds.tcl @ 731

Last change on this file since 731 was 731, checked in by toby, 14 years ago
# on 2003/08/11 19:28:54, toby did: code cleanup -col -> -column
Property rcs:author set to `toby` Property rcs:date set to `2003/08/11 19:28:54` Property rcs:lines set to `+11 -11` Property rcs:rev set to `1.51` Property rcs:state set to `Exp` Property svn:keywords set to `Author Date Revision Id`
File size: 83.1 KB

Line
1	# $Id: gsascmds.tcl 731 2009-12-04 23:11:04Z 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	wm transient $w $data(-parent)
136	if {![string compare $tcl_platform(platform) "macintosh"]} {
137	unsupported1 style $w dBoxProc
138	}
139
140	frame $w.bot
141	pack $w.bot -side bottom -fill both
142	frame $w.top
143	pack $w.top -side top -fill both -expand 1
144	if {$data(-helplink) != ""} {
145	# frame $w.help
146	# pack $w.help -side top -fill both
147	pack [button $w.top.1 -text Help -bg yellow \
148	-command "MakeWWWHelp $data(-helplink)"] \
149	-side right -anchor ne
150	bind $w <Key-F1> "MakeWWWHelp $data(-helplink)"
151	}
152	if {[string compare $tcl_platform(platform) "macintosh"]} {
153	$w.bot configure -relief raised -bd 1
154	$w.top configure -relief raised -bd 1
155	}
156
157	# 4. Fill the top part with bitmap and message (use the option
158	# database for -wraplength and -font so that they can be
159	# overridden by the caller).
160
161	option add *Dialog.msg.wrapLength 6i widgetDefault
162
163	if {[string length $data(-message)] > 300} {
164	if {![string compare $tcl_platform(platform) "macintosh"]} {
165	option add *Dialog.msg.t.font system widgetDefault
166	} else {
167	option add *Dialog.msg.t.font {Times 18} widgetDefault
168	}
169	frame $w.msg
170	grid [text $w.msg.t \
171	-height 20 -width 55 -relief flat -wrap word \
172	-yscrollcommand "$w.msg.rscr set" \
173	] -row 1 -column 0 -sticky news
174	grid [scrollbar $w.msg.rscr -command "$w.msg.t yview" \
175	] -row 1 -column 1 -sticky ns
176	# give extra space to the text box
177	grid columnconfigure $w.msg 0 -weight 1
178	grid rowconfigure $w.msg 1 -weight 1
179	$w.msg.t insert end $data(-message)
180	} else {
181	if {![string compare $tcl_platform(platform) "macintosh"]} {
182	option add *Dialog.msg.font system widgetDefault
183	} else {
184	option add *Dialog.msg.font {Times 18} widgetDefault
185	}
186	label $w.msg -justify left -text $data(-message)
187	}
188	pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
189	if {[string compare $data(-icon) ""]} {
190	label $w.bitmap -bitmap $data(-icon)
191	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
192	}
193
194	# 5. Create a row of buttons at the bottom of the dialog.
195
196	set i 0
197	foreach but $buttons {
198	set name [lindex $but 0]
199	set opts [lrange $but 1 end]
200	if {![llength $opts]} {
201	# Capitalize the first letter of $name
202	set capName [string toupper \
203	[string index $name 0]][string range $name 1 end]
204	set opts [list -text $capName]
205	}
206
207	eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
208
209	if {![string compare $name [string tolower $data(-default)]]} {
210	$w.$name configure -default active
211	}
212	pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
213
214	# create the binding for the key accelerator, based on the underline
215	#
216	set underIdx [$w.$name cget -under]
217	if {$underIdx >= 0} {
218	set key [string index [$w.$name cget -text] $underIdx]
219	bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
220	bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
221	}
222	incr i
223	}
224
225	# 6. Create a binding for <Return> on the dialog if there is a
226	# default button.
227
228	if {[string compare $data(-default) ""]} {
229	bind $w <Return> [list tkButtonInvoke $w.[string tolower $data(-default)]]
230	}
231
232	# 7. Withdraw the window, then update all the geometry information
233	# so we know how big it wants to be, then center the window in the
234	# display and de-iconify it.
235
236	wm withdraw $w
237	update idletasks
238	set wp $data(-parent)
239	# center the new window in the middle of the parent
240	set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
241	[winfo reqwidth $w]/2 - [winfo vrootx $wp]]
242	set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
243	[winfo reqheight $w]/2 - [winfo vrooty $wp]]
244	# make sure that we can see the entire window
245	set xborder 10
246	set yborder 25
247	if {$x < 0} {set x 0}
248	if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
249	incr x [expr \
250	[winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
251	}
252	if {$y < 0} {set y 0}
253	if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
254	incr y [expr \
255	[winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
256	}
257	wm geom $w +$x+$y
258	wm deiconify $w
259
260	# 8. Set a grab and claim the focus too.
261
262	catch {set oldFocus [focus]}
263	catch {set oldGrab [grab current $w]}
264	catch {
265	grab $w
266	if {[string compare $data(-default) ""]} {
267	focus $w.[string tolower $data(-default)]
268	} else {
269	focus $w
270	}
271	}
272
273	# 9. Wait for the user to respond, then restore the focus and
274	# return the index of the selected button. Restore the focus
275	# before deleting the window, since otherwise the window manager
276	# may take the focus away so we can't redirect it. Finally,
277	# restore any grab that was in effect.
278
279	tkwait variable tkPriv(button)
280	catch {focus $oldFocus}
281	destroy $w
282	catch {grab $oldGrab}
283	return $tkPriv(button)
284	}
285
286	# tell'em what is happening
287	# message is a text message to display
288	# statusvar is a variable name containing a message that gets updated
289	# parent is the name of the parent window
290	# button defines a button for the window. Element 0 in $button is the
291	# text for the button and Element 1 is the command to execute.
292	proc pleasewait {{message {}} {statusvar {}} {parent .} {button ""}} {
293	catch {destroy .msg}
294	toplevel .msg
295	wm transient .msg [winfo toplevel .]
296	pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5
297	pack [message .msg.f.m -text "Please wait $message"] -side top
298	if {$statusvar != ""} {
299	pack [label .msg.f.status -textvariable $statusvar] -side top
300	}
301	if {$button != ""} {
302	pack [button .msg.f.button -text [lindex $button 0] \
303	-command [lindex $button 1]] -side top
304	}
305	wm withdraw .msg
306	update idletasks
307	# place the message on top of the parent window
308	set x [expr [winfo x $parent] + [winfo width $parent]/2 - \
309	[winfo reqwidth .msg]/2 - [winfo vrootx $parent]]
310	if {$x < 0} {set x 0}
311	set y [expr [winfo y $parent] + [winfo height $parent]/2 - \
312	[winfo reqheight .msg]/2 - [winfo vrooty $parent]]
313	if {$y < 0} {set y 0}
314	wm geom .msg +$x+$y
315	wm deiconify .msg
316	global makenew
317	set makenew(OldGrab) ""
318	set makenew(OldFocus) ""
319	# save focus & grab
320	catch {set makenew(OldFocus) [focus]}
321	catch {set makenew(OldGrab) [grab current .msg]}
322	catch {grab .msg}
323	update
324	}
325
326	# clear the message
327	proc donewait {} {
328	global makenew
329	catch {destroy .msg}
330	# reset focus & grab
331	catch {
332	if {$makenew(OldFocus) != ""} {
333	focus $makenew(OldFocus)
334	}
335	}
336	catch {
337	if {$makenew(OldGrab) != ""} {
338	grab $makenew(OldGrab)
339	}
340	}
341	}
342
343	proc putontop {w} {
344	# center window $w above its parent and make it stay on top
345	set wp [winfo parent $w]
346	wm transient $w [winfo toplevel $wp]
347	wm withdraw $w
348	update idletasks
349	# center the new window in the middle of the parent
350	set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
351	[winfo reqwidth $w]/2 - [winfo vrootx $wp]]
352	if {$x < 0} {set x 0}
353	set xborder 10
354	if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
355	incr x [expr \
356	[winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
357	}
358	set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
359	[winfo reqheight $w]/2 - [winfo vrooty $wp]]
360	if {$y < 0} {set y 0}
361	set yborder 25
362	if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
363	incr y [expr \
364	[winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
365	}
366	wm geom $w +$x+$y
367	wm deiconify $w
368
369	global makenew
370	set makenew(OldGrab) ""
371	set makenew(OldFocus) ""
372	catch {set makenew(OldFocus) [focus]}
373	catch {set makenew(OldGrab) [grab current $w]}
374	catch {grab $w}
375	}
376
377	proc afterputontop {} {
378	# restore focus
379	global makenew
380	# reset focus & grab
381	catch {
382	if {$makenew(OldFocus) != ""} {
383	focus $makenew(OldFocus)
384	}
385	}
386	catch {
387	if {$makenew(OldGrab) != ""} {
388	grab $makenew(OldGrab)
389	}
390	}
391	}
392
393	proc ShowBigMessage {win labeltext msg "optionlist OK" "link {}" "err 0"} {
394	catch {destroy $win}
395	toplevel $win
396
397	pack [label $win.l1 -text $labeltext] -side top
398	if {$err} {$win.l1 config -fg red}
399	pack [frame $win.f1] -side top -expand yes -fill both
400	grid [text $win.f1.t \
401	-height 20 -width 55 -wrap none -font Courier \
402	-xscrollcommand "$win.f1.bscr set" \
403	-yscrollcommand "$win.f1.rscr set" \
404	] -row 1 -column 0 -sticky news
405	grid [scrollbar $win.f1.bscr -orient horizontal \
406	-command "$win.f1.t xview" \
407	] -row 2 -column 0 -sticky ew
408	grid [scrollbar $win.f1.rscr -command "$win.f1.t yview" \
409	] -row 1 -column 1 -sticky ns
410	# give extra space to the text box
411	grid columnconfigure $win.f1 0 -weight 1
412	grid rowconfigure $win.f1 1 -weight 1
413	$win.f1.t insert end $msg
414
415	global makenew
416	set makenew(result) 0
417	bind $win <Return> "destroy $win"
418	bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
419	bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
420	bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
421	bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
422	bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
423	bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
424	bind $win <KeyPress-Home> "$win.f1.t yview 0"
425	bind $win <KeyPress-End> "$win.f1.t yview end"
426	set i 0
427	foreach item $optionlist {
428	pack [button $win.q[incr i] \
429	-command "set makenew(result) $i; destroy $win" -text $item] -side left
430	}
431	if {$link != ""} {
432	pack [button $win.help -text Help -bg yellow \
433	-command "MakeWWWHelp $link"] \
434	-side right
435	bind $win <Key-F1> "MakeWWWHelp $link"
436	}
437	putontop $win
438	tkwait window $win
439
440	# fix grab...
441	afterputontop
442	return $makenew(result)
443	}
444
445	# get a value in a modal dialog
446	proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
447	global expgui expmap
448	set w .global
449	catch {destroy $w}
450	toplevel $w -bg beige
451	bind $w <Key-F1> "MakeWWWHelp expguierr.html Input[lindex $what 0]"
452	wm title $w "Input $what"
453	set expgui(temp) {}
454	pack [frame $w.0 -bd 6 -relief groove -bg beige] \
455	-side top -expand yes -fill both
456	grid [label $w.0.a -text "Input a value for the $what" \
457	-bg beige] \
458	-row 0 -column 0 -columnspan 10
459	grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
460	-row 1 -column 0
461
462	set expgui(temp) $initvalue
463	pack [frame $w.b -bg beige] -side top -fill x -expand yes
464	pack [button $w.b.2 -text Set -command "destroy $w"] -side left
465	if $quit {
466	pack [button $w.b.3 -text Quit \
467	-command "set expgui(temp) {}; destroy $w"] -side left
468	}
469	bind $w <Return> "destroy $w"
470	pack [button $w.b.help -text Help -bg yellow \
471	-command "MakeWWWHelp expguierr.html Input[lindex $what 0]"] \
472	-side right
473
474	# force the window to stay on top
475	putontop $w
476
477	focus $w.b.2
478	tkwait window $w
479	afterputontop
480
481	return $expgui(temp)
482	}
483
484	#------------------------------------------------------------------------------
485	# profile/symmetry routines
486	#------------------------------------------------------------------------------
487	# profile terms
488	array set expgui {
489	prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
490	rsca s1ec s2ec }
491	prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
492	gam-2 ptec stec difc difa zero }
493	prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
494	gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
495	prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
496	rstr rsta rsca eta}
497	prof-C-1 {GU GV GW asym F1 F2 }
498	prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
499	L11 L22 L33 L12 L13 L23 }
500	prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
501	L11 L22 L33 L12 L13 L23 }
502	prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta}
503	prof-E-1 {A B C ds cds}
504	}
505
506	# number of profile terms depends on the histogram type
507	# the LAUE symmetry and the profile number
508	proc GetProfileTerms {phase hist ptype} {
509	global expmap expgui
510	if {$hist == "C" \|\| $hist == "T" \|\| $hist == "E"} {
511	set htype $hist
512	} else {
513	set htype [string range $expmap(htype_$hist) 2 2]
514	}
515	# get the cached copy of the profile term labels, when possible
516	set lbls {}
517	catch {
518	set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
519	}
520	if {$lbls != ""} {return $lbls}
521
522	catch {set lbls $expgui(prof-$htype-$ptype)}
523	if {$lbls == ""} {return}
524	# add terms based on the Laue symmetry
525	if {($htype == "C" \|\| $htype == "T") && $ptype == 4} {
526	set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
527	eval lappend lbls [Profile4Terms $laueaxis]
528	}
529	set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
530	return $lbls
531	}
532
533	proc Profile4Terms {laueaxis} {
534	switch -exact $laueaxis {
535	1bar {return \
536	"S400 S040 S004 S220 S202 S022 S310 S103 S031 \
537	S130 S301 S013 S211 S121 S112"}
538	2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
539	2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
540	2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
541	mmm {return "S400 S040 S004 S220 S202 S022"}
542	4/m {return "S400 S004 S220 S202"}
543	4/mmm {return "S400 S004 S220 S202"}
544	3barR {return "S400 S220 S310 S211"}
545	"3bar mR" {return "S400 S220 S310 S211"}
546	3bar {return "S400 S004 S202 S211"}
547	3barm1 {return "S400 S004 S202"}
548	3bar1m {return "S400 S004 S202 S211"}
549	6/m {return "S400 S004 S202"}
550	6/mmm {return "S400 S004 S202"}
551	"m 3" {return "S400 S220"}
552	m3m {return "S400 S220"}
553	default {return ""}
554	}
555	}
556
557	proc GetLaue {spg} {
558	global tcl_platform expgui
559	# check the space group
560	set fp [open spg.in w]
561	puts $fp "N"
562	puts $fp "N"
563	puts $fp $spg
564	puts $fp "Q"
565	close $fp
566	catch {
567	if {$tcl_platform(platform) == "windows"} {
568	exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
569	} else {
570	exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
571	}
572	}
573	set fp [open spg.out r]
574	set laue {}
575	set uniqueaxis {}
576	while {[gets $fp line] >= 0} {
577	regexp {Laue symmetry (.*)} $line junk laue
578	regexp {The unique axis is (.*)} $line junk uniqueaxis
579	}
580	close $fp
581	catch {file delete -force spg.in spg.out}
582	set laue [string trim $laue]
583	# add a R suffix for rhombohedral settings
584	if {[string range [string trim $spg] end end] == "R"} {
585	return "${laue}${uniqueaxis}R"
586	}
587	return "${laue}$uniqueaxis"
588	}
589
590	# set up to change the profile type for a series of histogram/phase entries
591	# (histlist & phaselist should be lists of the same length)
592	#
593	proc ChangeProfileType {histlist phaselist} {
594	global expgui expmap
595	set w .profile
596	catch {destroy $w}
597	toplevel $w -bg beige
598	wm title $w "Change Profile Function"
599
600	# all histogram/phases better be the same type, so we can just use the 1st
601	set hist [lindex $histlist 0]
602	set phase [lindex $phaselist 0]
603	set ptype [string trim [hapinfo $hist $phase proftype]]
604
605	# get list of allowed profile terms for the current histogram type
606	set i 1
607	while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
608	lappend lbllist $lbls
609	incr i
610	}
611	# labels for the current type
612	set i $ptype
613	set oldlbls [lindex $lbllist [incr i -1]]
614
615	if {[llength $histlist] == 1} {
616	pack [label $w.a -bg beige \
617	-text "Change profile function for Histogram #$hist Phase #$phase" \
618	] -side top
619	} else {
620	# make a list of histograms by phase
621	foreach h $histlist p $phaselist {
622	lappend phlist($p) $h
623	}
624	set num 0
625	pack [frame $w.a -bg beige] -side top
626	pack [label $w.a.$num -bg beige \
627	-text "Change profile function for:" \
628	] -side top -anchor w
629	foreach i [lsort [array names phlist]] {
630	incr num
631	pack [label $w.a.$num -bg beige -text \
632	"\tPhase #$i, Histograms [CompressList $phlist($i)]" \
633	] -side top -anchor w
634	}
635	}
636	pack [label $w.e1 \
637	-text "Current function is type $ptype." \
638	-bg beige] -side top -anchor w
639	pack [frame $w.e -bg beige] -side top -expand yes -fill both
640	pack [label $w.e.1 \
641	-text "Set function to type" \
642	-bg beige] -side left
643	set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
644	pack $w.e.2 -side left -anchor w
645
646	pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
647	-command "set expgui(newpeaktype) $ptype; \
648	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
649	-value 1 -text "Current value overrides"] -side right
650	pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
651	-command \
652	"set expgui(newpeaktype) $ptype; \
653	FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
654	-value 0 -text "Default value overrides"] -side right
655
656	$w.e.2 config -bg beige
657	pack [frame $w.c -bg beige] -side top -expand yes -fill both
658	pack [frame $w.d -bg beige] -side top -expand yes -fill both
659	pack [button $w.d.2 -text Set \
660	-command "SaveChangeProfileType $w.c $histlist $phaselist; destroy $w"\
661	] -side left
662	pack [button $w.d.3 -text Quit \
663	-command "destroy $w"] -side left
664	pack [button $w.d.help -text Help -bg yellow \
665	-command "MakeWWWHelp expgui5.html ChangeType"] \
666	-side right
667	bind $w <Key-F1> "MakeWWWHelp expgui5.html ChangeType"
668	bind $w <Return> "destroy $w"
669
670	$menu delete 0 end
671	set i 0
672	foreach lbls $lbllist {
673	incr i
674	$menu add command -label $i -command \
675	"set expgui(newpeaktype) $i; \
676	FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
677	}
678	set expgui(newpeaktype) $ptype
679	FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
680
681	# force the window to stay on top
682	putontop $w
683	focus $w.e.2
684	tkwait window $w
685	afterputontop
686	sethistlist
687	}
688
689	# save the changes to the profile
690	proc SaveChangeProfileType {w histlist phaselist} {
691	global expgui
692	foreach phase $phaselist hist $histlist {
693	hapinfo $hist $phase proftype set $expgui(newpeaktype)
694	hapinfo $hist $phase profterms set $expgui(newProfileTerms)
695	for {set i 1} {$i <= $expgui(newProfileTerms)} {incr i} {
696	hapinfo $hist $phase pterm$i set [$w.ent${i} get]
697	hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
698	}
699	set i [expr 1+$expgui(newProfileTerms)]
700	hapinfo $hist $phase pcut set [$w.ent$i get]
701	incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
702	}
703	}
704
705	# file the contents of the "Change Profile Type" Menu
706	proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
707	global expgui expmap
708	set ptype [string trim [hapinfo $hist $phase proftype]]
709	catch {unset oldval}
710	# loop through the old terms and set up an array of starting values
711	set num 0
712	foreach term $oldlbls {
713	incr num
714	set oldval($term) [hapinfo $hist $phase pterm$num]
715	}
716	set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
717
718	# is the new type the same as the current?
719	if {$ptype == $newtype} {
720	set nterms [hapinfo $hist $phase profterms]
721	} else {
722	set nterms [llength $lbls]
723	}
724	set expgui(newProfileTerms) $nterms
725	set expgui(CurrentProfileTerms) $nterms
726	# which default profile set matches the new type
727	set setnum {}
728	foreach j {" " 1 2 3 4 5 6 7 8 9} {
729	set i [profdefinfo $hist $j proftype]
730	if {$i == ""} continue
731	if {$i == $newtype} {
732	set setnum $j
733	break
734	}
735	}
736
737	eval destroy [winfo children $w]
738
739	set colstr 0
740	set row 2
741	set maxrow [expr $row + $nterms/2]
742	for { set num 1 } { $num <= $nterms + 1} { incr num } {
743	# get the default value (originally from the in .INS file)
744	set val {}
745	if {$setnum != ""} {
746	set val 0.0
747	catch {
748	set val [profdefinfo $hist $setnum pterm$num]
749	# pretty up the number
750	if {$val == 0.0} {
751	set val 0.0
752	} elseif {abs($val) < 1e-2 \|\| abs($val) > 1e6} {
753	set val [format %.3e $val]
754	} elseif {abs($val) > 1e-2 && abs($val) < 10} {
755	set val [format %.5f $val]
756	} elseif {abs($val) < 9999} {
757	set val [format %.2f $val]
758	} elseif {abs($val) < 1e6} {
759	set val [format %.0f $val]
760	}
761	}
762	}
763	# heading
764	if {$row == 2} {
765	set col $colstr
766	grid [label $w.h0${num} -text "lbl" -bg beige] \
767	-row $row -column $col
768	grid [label $w.h2${num} -text "ref" -bg beige] \
769	-row $row -column [incr col]
770	grid [label $w.h3${num} -text "next value" -bg beige] \
771	-row $row -column [incr col]
772	grid [label $w.h4${num} -text "default" -bg beige] \
773	-row $row -column [incr col]
774	grid [label $w.h5${num} -text "current" -bg beige] \
775	-row $row -column [incr col]
776	}
777	set col $colstr
778	incr row
779	set term {}
780	catch {set term [lindex $lbls [expr $num-1]]}
781	if {$term == ""} {set term $num}
782	if {$num == $nterms + 1} {
783	set term "Peak\nCutoff"
784	set val {}
785	if {$setnum != ""} {
786	set val 0.0
787	catch {set val [profdefinfo $hist $setnum pcut]}
788	}
789	}
790
791	grid [label $w.l${num} -text "$term" -bg beige] \
792	-row $row -column $col
793	grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
794	-bg beige -activebackground beige] -row $row -column [incr col]
795	grid [entry $w.ent${num} \
796	-width 12] -row $row -column [incr col]
797	if {$val != ""} {
798	grid [button $w.def${num} -text $val -command \
799	"$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
800	] -row $row -column [incr col] -sticky ew
801	} else {
802	grid [label $w.def${num} -text (none) \
803	] -row $row -column [incr col]
804	}
805	set curval {}
806	catch {
807	set curval [expr $oldval($term)]
808	# pretty up the number
809	if {$curval == 0.0} {
810	set curval 0.0
811	} elseif {abs($curval) < 1e-2 \|\| abs($curval) > 1e6} {
812	set curval [format %.3e $curval]
813	} elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
814	set curval [format %.5f $curval]
815	} elseif {abs($curval) < 9999} {
816	set curval [format %.2f $curval]
817	} elseif {abs($curval) < 1e6} {
818	set curval [format %.0f $curval]
819	}
820	grid [button $w.cur${num} -text $curval -command \
821	"$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
822	] -row $row -column [incr col] -sticky ew
823	}
824	# set default values for flag and value
825	set ref 0
826	if {$setnum != ""} {
827	catch {
828	if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
829	}
830	}
831	set expgui(ProfRef$num) $ref
832
833	$w.ent${num} delete 0 end
834	if {!$expgui(DefaultPeakType) && $val != ""} {
835	$w.ent${num} insert end $val
836	} elseif {$curval != ""} {
837	$w.ent${num} insert end $curval
838	} elseif {$val != ""} {
839	$w.ent${num} insert end $val
840	} else {
841	$w.ent${num} insert end 0.0
842	}
843	if {$row > $maxrow} {
844	set row 2
845	incr colstr 5
846	}
847	}
848	}
849
850	#------------------------------------------------------------------------------
851	# WWW/help routines
852	#------------------------------------------------------------------------------
853	# browse a WWW page with URL. The URL may contain a #anchor
854	# On UNIX assume netscape is in the path or env(BROWSER) is loaded.
855	# On Windows search the registry for a browser. Mac branch not tested.
856	# This is taken from http://mini.net/cgi-bin/wikit/557.html with many thanks
857	# to the contributers
858	proc urlOpen {url} {
859	global env tcl_platform
860	switch $tcl_platform(platform) {
861	"unix" {
862	if {![info exists env(BROWSER)]} {
863	set progs [auto_execok netscape]
864	if {[llength $progs]} {
865	set env(BROWSER) [list $progs]
866	}
867	}
868	if {[info exists env(BROWSER)]} {
869	if {[catch {exec $env(BROWSER) -remote openURL($url)}]} {
870	# perhaps browser doesn't understand -remote flag
871	if {[catch {exec $env(BROWSER) $url &} emsg]} {
872	error "Error displaying $url in browser\n$emsg"
873	}
874	}
875	} else {
876	MyMessageBox -parent . -title "No Browser" \
877	-message "Could not find a browser. Netscape is not in path. Define environment variable BROWSER to be full path name of browser." \
878	-icon warn
879	}
880	}
881	"windows" {
882	package require registry
883	# Look for the application under
884	# HKEY_CLASSES_ROOT
885	set root HKEY_CLASSES_ROOT
886
887	# Get the application key for HTML files
888	set appKey [registry get $root\\.html ""]
889
890	# Get the command for opening HTML files
891	set appCmd [registry get \
892	$root\\$appKey\\shell\\open\\command ""]
893
894	# Substitute the HTML filename into the command for %1
895	# or stick it on the end
896	if {[string first %1 $appCmd] != -1} {
897	regsub %1 $appCmd $url appCmd
898	} else {
899	append appCmd " " $url
900	}
901
902	# Double up the backslashes for eval (below)
903	regsub -all {\\} $appCmd {\\\\} appCmd
904
905	# Invoke the command
906	eval exec $appCmd &
907	}
908	"macintosh" {
909	if {0 == [info exists env(BROWSER)]} {
910	set env(BROWSER) "Browse the Internet"
911	}
912	if {[catch {
913	AppleScript execute\
914	"tell application \"$env(BROWSER)\"
915	open url \"$url\"
916	end tell
917	"} emsg]
918	} then {
919	error "Error displaying $url in browser\n$emsg"
920	}
921	}
922	}
923	}
924
925	proc NetHelp {file anchor localloc netloc} {
926	if {[file exists [file join $localloc $file]]} {
927	set url "[file join $localloc $file]"
928	} else {
929	set url "http://$netloc/$file"
930	}
931	catch {
932	pleasewait "Starting web browser..."
933	after 2000 donewait
934	}
935	if {$anchor != ""} {
936	append url # $anchor
937	}
938	urlOpen $url
939	}
940
941	proc MakeWWWHelp {"topic {}" "anchor {}"} {
942	global expgui
943	if {$topic == ""} {
944	foreach item $expgui(notebookpagelist) {
945	if {[lindex $item 0] == $expgui(pagenow)} {
946	NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
947	return
948	}
949	}
950	# this should not happen
951	NetHelp expgui.html "" $expgui(docdir) $expgui(website)
952	} elseif {$topic == "menu"} {
953	NetHelp expguic.html "" $expgui(docdir) $expgui(website)
954	} else {
955	NetHelp $topic $anchor $expgui(docdir) $expgui(website)
956	}
957	}
958
959	# show help information
960	proc showhelp {} {
961	global expgui_helplist helpmsg
962	set helpmsg {}
963	set frm .help
964	catch {destroy $frm}
965	toplevel $frm
966	wm title $frm "Help Summary"
967	grid [label $frm.0 -text \
968	"Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
969	-column 0 -columnspan 4 -row 0
970	# grid [message $frm.help -textvariable helpmsg -relief groove] \
971	# -column 0 -columnspan 4 -row 2 -sticky nsew
972	grid [text $frm.help -relief groove -bg beige -width 0\
973	-height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
974	-column 0 -columnspan 3 -row 2 -sticky nsew
975	grid [scrollbar $frm.escroll -command "$frm.help yview"] \
976	-column 4 -row 2 -sticky nsew
977	grid rowconfig $frm 1 -weight 1 -minsize 50
978	grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
979	grid columnconfig $frm 0 -weight 1
980	grid columnconfig $frm 2 -weight 1
981	set lst [array names expgui_helplist]
982	grid [listbox $frm.cmds -relief raised -bd 2 \
983	-yscrollcommand "$frm.scroll set" \
984	-height 8 -width 0 -exportselection 0 ] \
985	-column 0 -row 1 -sticky nse
986	grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
987	-column 1 -row 1 -sticky nsew
988	foreach item [lsort -dictionary $lst] {
989	$frm.cmds insert end $item
990	}
991	if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
992	grid [button $frm.done -text Done -command "destroy $frm"] \
993	-column 2 -row 1
994	# bind $frm.cmds <ButtonRelease-1> \
995	# "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
996	bind $frm.cmds <ButtonRelease-1> \
997	"+$frm.help config -state normal; $frm.help delete 0.0 end; \
998	$frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
999	$frm.help config -state disabled"
1000
1001	# get the size of the window and expand the message boxes to match
1002	# update
1003	# $frm.help config -width [winfo width $frm.help ]
1004	}
1005
1006
1007	#------------------------------------------------------------------------------
1008	# utilities
1009	#------------------------------------------------------------------------------
1010	# run liveplot
1011	proc liveplot {} {
1012	global expgui liveplot wishshell expmap
1013	set expnam [file root [file tail $expgui(expfile)]]
1014	# which histograms are ready for use?
1015	set validlist {}
1016	foreach ihist $expmap(powderlist) {
1017	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1018	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1019	lappend validlist $ihist
1020	}
1021	}
1022	if {[llength $validlist] == 0} {
1023	MyMessageBox -parent . -title "No Valid Histograms" \
1024	-message "No histograms are ready to plot. Run GENLES and try again" \
1025	-icon warning -helplink "expguierr.html NoValidHist"
1026	return
1027	}
1028	# use $liveplot(hst) if valid, the 1st entry otherwise
1029	if {[lsearch $validlist $liveplot(hst)] != -1} {
1030	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1031	$expnam $liveplot(hst) $liveplot(legend) &
1032	} else {
1033	exec $wishshell [file join $expgui(scriptdir) liveplot] \
1034	$expnam [lindex $validlist 0] $liveplot(legend) &
1035	}
1036	}
1037
1038	# run lstview
1039	proc lstview {} {
1040	global expgui wishshell
1041	set expnam [file root [file tail $expgui(expfile)]]
1042	exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1043	}
1044
1045	# run widplt
1046	proc widplt {"prog widplt"} {
1047	global expgui wishshell
1048	exec $wishshell [file join $expgui(scriptdir) $prog] \
1049	$expgui(expfile) &
1050	}
1051
1052	# run bkgedit
1053	proc bkgedit {"hst {}"} {
1054	global expgui liveplot wishshell expmap
1055	set expnam [file root [file tail $expgui(expfile)]]
1056	if {$hst == ""} {
1057	# which histograms are ready for use?
1058	set validlist {}
1059	foreach ihist $expmap(powderlist) {
1060	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1061	[string range $expmap(htype_$ihist) 3 3] == "*"} {
1062	lappend validlist $ihist
1063	}
1064	}
1065	if {[llength $validlist] == 0} {
1066	MyMessageBox -parent . -title "No Valid Histograms" \
1067	-message "No histograms are ready to plot. Run POWPREF and try again" \
1068	-icon warning -helplink "expguierr.html NoValidHist"
1069	return
1070	}
1071	# use $liveplot(hst) if valid, the 1st entry otherwise
1072	if {[lsearch $validlist $liveplot(hst)] != -1} {
1073	set hst $liveplot(hst)
1074	} else {
1075	set hst [lindex $validlist 0]
1076	}
1077	}
1078	if {$expgui(autoiconify)} {wm iconify .}
1079	exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1080	$expnam $hst $liveplot(legend)
1081	if {$expgui(autoiconify)} {wm deiconify .}
1082	# check for changes in the .EXP file immediately
1083	whenidle
1084	}
1085
1086	# run excledt
1087	proc excledit {} {
1088	global expgui liveplot wishshell expmap
1089	set expnam [file root [file tail $expgui(expfile)]]
1090	# which histograms are ready for use?
1091	set validlist {}
1092	foreach ihist $expmap(powderlist) {
1093	if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" \|\| \
1094	[string range $expmap(htype_$ihist) 3 3] == "*" \|\| \
1095	[string range $expmap(htype_$ihist) 3 3] == "D"} {
1096	lappend validlist $ihist
1097	}
1098	}
1099	if {[llength $validlist] == 0} {
1100	MyMessageBox -parent . -title "No Valid Histograms" \
1101	-message "No histograms are ready to plot. Run POWPREF and try again" \
1102	-icon warning -helplink "expguierr.html NoValidHist"
1103	return
1104	}
1105	#if {$expgui(autoiconify)} {wm iconify .}
1106	StartExcl
1107	#if {$expgui(autoiconify)} {wm deiconify .}
1108	}
1109
1110	# compute the composition for each phase and display in a dialog
1111	proc composition {} {
1112	global expmap expgui
1113	set Z 1
1114	foreach phase $expmap(phaselist) type $expmap(phasetype) {
1115	if {$type > 2} continue
1116	catch {unset total}
1117	foreach atom $expmap(atomlist_$phase) {
1118	set type [atominfo $phase $atom type]
1119	set mult [atominfo $phase $atom mult]
1120	if [catch {set total($type)}] {
1121	set total($type) [expr \
1122	$mult * [atominfo $phase $atom frac]]
1123	} else {
1124	set total($type) [expr $total($type) + \
1125	$mult * [atominfo $phase $atom frac]]
1126	}
1127	if {$mult > $Z} {set Z $mult}
1128	}
1129	append text "\nPhase $phase\n"
1130	append text " Unit cell contents\n"
1131	foreach type [lsort [array names total]] {
1132	append text " $type[format %8.3f $total($type)]"
1133	}
1134	append text "\n\n"
1135
1136	append text " Asymmetric Unit contents (Z=$Z)\n"
1137	foreach type [lsort [array names total]] {
1138	append text " $type[format %8.3f [expr $total($type)/$Z]]"
1139	}
1140	append text "\n"
1141	}
1142
1143	catch {destroy .comp}
1144	toplevel .comp -class MonoSpc
1145	bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1146	wm title .comp Composition
1147	pack [label .comp.results -text $text \
1148	-justify left] -side top
1149	pack [frame .comp.box] -side top -expand y -fill x
1150	pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1151
1152	set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1153	pack [button .comp.box.2 -text "Save to $lstnam file" \
1154	-command "writelst [list $text] ; destroy .comp"] -side left
1155	pack [button .comp.box.help -text Help -bg yellow \
1156	-command "MakeWWWHelp expgui.html Composition"] \
1157	-side right
1158	}
1159
1160	# Delete History Records
1161	proc DeleteHistoryRecords {{msg ""}} {
1162	global expgui
1163	set frm .history
1164	catch {destroy $frm}
1165	toplevel $frm
1166	bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1167	if {[string trim $msg] == ""} {
1168	set msg "There are [CountHistory] history records"
1169	}
1170	pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1171	pack [label $frm.1.0 -text $msg] -side top
1172	pack [frame $frm.1.1] -side top
1173	pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1174	pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1175	] -side left
1176	set expgui(historyKeep) 10
1177	pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1178	set expgui(renumber) 1
1179	pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1180	pack [button $frm.2.help -text Help -bg yellow \
1181	-command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1182	pack [button $frm.2.4 -text Quit \
1183	-command {destroy .history}] -side bottom
1184	pack [button $frm.2.3 -text OK \
1185	-command {
1186	if ![catch {expr $expgui(historyKeep)}] {
1187	DeleteHistory $expgui(historyKeep) $expgui(renumber)
1188	set expgui(changed) 1
1189	destroy .history
1190	}
1191	}] -side bottom
1192	bind $frm <Return> "$frm.2.3 invoke"
1193
1194	# force the window to stay on top
1195	putontop $frm
1196	focus $frm.2.3
1197	tkwait window $frm
1198	afterputontop
1199	}
1200
1201	proc archiveexp {} {
1202	global expgui tcl_platform
1203	# is there a file to archive?
1204	if {![file exists $expgui(expfile)]} return
1205	set expnam [file rootname $expgui(expfile)]
1206	# get the last archived version
1207	set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1208	if {$lastf == ""} {
1209	set num 01
1210	} else {
1211	regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1212	scan $num %x num
1213	if {$num >= 255} {
1214	set num FF
1215	} else {
1216	set num [string toupper [format %.2x [incr num]]]
1217	}
1218	}
1219	catch {
1220	set file $expnam.O$num
1221	file copy -force $expgui(expfile) $file
1222	set fp [open $expnam.LST a+]
1223	puts $fp "\n----------------------------------------------"
1224	puts $fp " Archiving [file tail $expnam.EXP] as [file tail $file]"
1225	puts $fp "----------------------------------------------\n"
1226	close $fp
1227	} errmsg
1228	if {$errmsg != ""} {
1229	tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1230	}
1231	}
1232
1233	# save and optionally archive the expfile
1234	proc savearchiveexp {} {
1235	global expgui expmap
1236	if {$expgui(expfile) == ""} {
1237	SaveAsFile
1238	return
1239	}
1240	if !$expgui(changed) return
1241	if {$expgui(archive)} archiveexp
1242	# add a history record
1243	exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds]]"
1244	# now save the file
1245	expwrite $expgui(expfile)
1246	set expgui(changed) 0
1247	set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1248	set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1249	wm title . $expgui(expfile)
1250	set expgui(titleunchanged) 1
1251	# set convergence criterion
1252	InitLSvars
1253	}
1254
1255	#------------------------------------------------------------------------------
1256	# GSAS interface routines
1257	#------------------------------------------------------------------------------
1258	# run a GSAS program that does not require an experiment file
1259	proc runGSASprog {proglist "concurrent 1"} {
1260	# if concurrent is 0, EXPGUI runs the GSAS program in background
1261	# -- this is not currently needed anywhere where the .EXP file is not.
1262	global expgui tcl_platform
1263	set cmd {}
1264	foreach prog $proglist {
1265	StartGRWND $prog
1266	if {$tcl_platform(platform) == "windows"} {
1267	append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1268	} else {
1269	if {$cmd != ""} {append cmd "\;"}
1270	append cmd "[file join $expgui(gsasexe) $prog]"
1271	}
1272	}
1273	forknewterm $prog $cmd [expr !$concurrent] 1
1274	}
1275
1276	# dummy routine, overridden if needed
1277	proc StartGRWND {prog} {
1278	}
1279
1280	# run a GSAS program that requires an experiment file for input/output
1281	proc runGSASwEXP {proglist "concurrent 0"} {
1282	# most programs that require the .EXP file change it and
1283	# cannot be run concurrently
1284	global expgui tcl_platform
1285	# Save the current exp file
1286	savearchiveexp
1287	# load the changed .EXP file automatically?
1288	if {$expgui(autoexpload)} {
1289	# disable the file changed monitor
1290	set expgui(expModifiedLast) 0
1291	}
1292	set cmd {}
1293	set expnam [file root [file tail $expgui(expfile)]]
1294	foreach prog $proglist {
1295	if {$prog == "powpref"} {
1296	set expgui(needpowpref) 0
1297	set expgui(needpowpref_why) ""
1298	} elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1299	set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1300	set ans [MyMessageBox -parent . -title "Run POWPREF" \
1301	-message $msg -icon warning -type "Yes No" -default yes \
1302	-helplink "expguierr.html RunPowpref"]
1303	if {$ans == "yes"} {
1304	set expgui(needpowpref) 0
1305	set expgui(needpowpref_why) ""
1306	if {$tcl_platform(platform) == "windows"} {
1307	append cmd " \"$expgui(gsasexe)/powpref.exe $expnam \" "
1308	} else {
1309	if {$cmd != ""} {append cmd "\;"}
1310	append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1311	}
1312	}
1313	}
1314	StartGRWND $prog
1315	if {$tcl_platform(platform) == "windows"} {
1316	append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1317	} else {
1318	if {$cmd != ""} {append cmd "\;"}
1319	append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1320	}
1321	}
1322	forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1323	# load the changed .EXP file automatically?
1324	if {$expgui(autoexpload)} {
1325	# load the revised exp file
1326	loadexp $expgui(expfile)
1327	}
1328	}
1329
1330	# write text to the .LST file
1331	proc writelst {text} {
1332	global expgui
1333	set lstnam [file rootname $expgui(expfile)].LST
1334	set fp [open $lstnam a]
1335	puts $fp "\n-----------------------------------------------------------------"
1336	puts $fp $text
1337	puts $fp "-----------------------------------------------------------------\n"
1338	close $fp
1339	}
1340
1341
1342	# rename file current to suggested,
1343	# delete window if supplied
1344	# use parent, if supplied or .
1345	proc RenameAsFile {current suggested "window {}" "parent {}"} {
1346	if {$parent == "" && $window != ""} {set parent $window}
1347	if {$parent == ""} {set parent .}
1348	set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1349	if {$newfile == ""} return
1350	if {[catch {
1351	file rename -force $current $newfile
1352	}]} {
1353	file copy -force $current $newfile
1354	file delete -force $current
1355	}
1356	if {$window != ""} {destroy $window}
1357	}
1358
1359	# optionally run disagl as a windowless process, w/results in a separate window
1360	proc rundisagl {} {
1361	global expgui txtvw tcl_version tcl_platform
1362	if {$expgui(disaglSeparateBox)} {
1363	set root [file root $expgui(expfile)]
1364	catch {file delete -force $root.tmp}
1365	if {[catch {file rename -force $root.LST $root.OLS}]} {
1366	file copy -force $root.LST $root.OLS
1367	file delete -force $root.OLS
1368	}
1369	# PSW reports this does not happen right away on windows
1370	set i 0
1371	while {$i < 10 && [file exists $root.LST]} {
1372	# debug code
1373	#catch {console show}
1374	#puts "try $i"
1375	# end debug code
1376	after 100
1377	incr i
1378	}
1379	if {[file exists $root.LST]} {
1380	# it was not possible to rename the file
1381	MyMessageBox -parent . -title "Rename Problem" \
1382	-message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1383	-icon warning -helplink "expguierr.html NoRename"
1384	return
1385	}
1386
1387	#run the program
1388	pleasewait "Running DISAGL"
1389	# create an empty input file
1390	close [open disagl.inp w]
1391	catch {exec [file join $expgui(gsasexe) disagl] \
1392	[file tail $root] < disagl.inp > disagl.out}
1393	if {[catch {file rename -force $root.LST $root.tmp}]} {
1394	file copy -force $root.LST $root.tmp
1395	file delete -force $root.LST
1396	}
1397	catch {file delete -force disagl.inp disagl.out}
1398	if {[catch {file rename -force $root.OLS $root.LST}]} {
1399	file copy -force $root.OLS $root.LST
1400	file delete -force $root.OLS
1401	}
1402	donewait
1403	# open a new window
1404	catch {toplevel .disagl}
1405	catch {eval grid forget [grid slaves .disagl]}
1406	text .disagl.txt -width 100 -wrap none \
1407	-yscrollcommand ".disagl.yscroll set" \
1408	-xscrollcommand ".disagl.xscroll set"
1409	scrollbar .disagl.yscroll -command ".disagl.txt yview"
1410	scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1411	grid .disagl.xscroll -column 0 -row 2 -sticky ew
1412	grid .disagl.txt -column 0 -row 1 -sticky nsew
1413	grid .disagl.yscroll -column 1 -row 1 -sticky ns
1414	grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1415	grid columnconfig .disagl.f 2 -weight 1
1416	grid [button .disagl.f.close -text "Close & Delete" \
1417	-command "destroy .disagl; file delete $root.tmp"] \
1418	-column 3 -row 0 -sticky e
1419	grid [button .disagl.f.rename \
1420	-command "RenameAsFile $root.tmp $root.DIS .disagl" \
1421	-text "Close & Save as..."] \
1422	-column 4 -row 0 -sticky e
1423	# allow font changes on the fly
1424	if {$tcl_version >= 8.0} {
1425	.disagl.txt config -font $txtvw(font)
1426	set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1427	grid .disagl.f.font -column 1 -row 0 -sticky w
1428	grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1429	$fontbut delete 0 end
1430	foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1431	$fontbut add command -label "Courier $f" -font "Courier $f"\
1432	-command "set txtvw(font) \"Courier $f\"; \
1433	.disagl.txt config -font \$txtvw(font)"
1434	}
1435	}
1436
1437	grid columnconfigure .disagl 0 -weight 1
1438	grid rowconfigure .disagl 1 -weight 1
1439	wm title .disagl "DISAGL results $expgui(expfile)"
1440	wm iconname .disagl "DISAGL $root"
1441	set in [open $root.tmp r]
1442	.disagl.txt insert end [read $in]
1443	close $in
1444	bind all {destroy .disagl}
1445	bind .disagl ".disagl.txt yview scroll -1 page"
1446	bind .disagl ".disagl.txt yview scroll 1 page"
1447	bind .disagl ".disagl.txt xview scroll 1 unit"
1448	bind .disagl ".disagl.txt xview scroll -1 unit"
1449	bind .disagl ".disagl.txt yview scroll -1 unit"
1450	bind .disagl ".disagl.txt yview scroll 1 unit"
1451	bind .disagl ".disagl.txt yview 0"
1452	bind .disagl ".disagl.txt yview end"
1453	# don't disable in Win as this prevents the highlighting of selected text
1454	if {$tcl_platform(platform) != "windows"} {
1455	.disagl.txt config -state disabled
1456	}
1457	} else {
1458	runGSASwEXP disagl
1459	}
1460	}
1461
1462	#------------------------------------------------------------------------------
1463	# file conversions
1464	#------------------------------------------------------------------------------
1465	proc convfile {} {
1466	global expgui
1467	set frm .file
1468	catch {destroy $frm}
1469	toplevel $frm
1470	wm title $frm "Convert File"
1471	bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1472	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1473	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1474	-side left -fill y -expand yes
1475	pack [button $frmC.help -text Help -bg yellow \
1476	-command "MakeWWWHelp expgui.html ConvertWin"] -side top
1477	pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1478	pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1479	-side bottom
1480	pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1481	winfilebox $frm
1482	bind $frm <Return> "ValidWinCnv $frm"
1483
1484	# force the window to stay on top
1485	putontop $frm
1486	focus $frmC.q
1487	tkwait window $frm
1488	afterputontop
1489	}
1490
1491	# validate the files and make the conversion
1492	proc ValidWinCnv {frm} {
1493	global expgui
1494	# change backslashes to something sensible
1495	regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1496	# allow entry of D: for D:/ and D:TEST for d:/TEST
1497	if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1498	[string first :/ $expgui(FileMenuCnvName)] == -1} {
1499	regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1500	}
1501	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1502	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1503	ChooseWinCnv $frm
1504	return
1505	} elseif [file isdirectory \
1506	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1507	if {$expgui(FileMenuCnvName) != "."} {
1508	set expgui(FileMenuDir) \
1509	[file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1510	}
1511	ChooseWinCnv $frm
1512	return
1513	}
1514
1515	set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1516	if ![file exists $file] {
1517	MyMessageBox -parent $frm -title "Convert Error" \
1518	-message "File $file does not exist" -icon error
1519	return
1520	}
1521
1522	set tmpname "[file join [file dirname $file] tempfile.xxx]"
1523	set oldname "[file rootname $file].org"
1524	if [file exists $oldname] {
1525	set ans [MyMessageBox -parent . -title "Overwrite?" \
1526	-message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1527	-icon warning -type {Overwrite Cancel} -default Overwrite \
1528	-helplink "expguierr.html OverwriteCnv"]
1529	if {[string tolower $ans] == "cancel"} return
1530	catch {file delete $oldname}
1531	}
1532
1533	if [catch {
1534	set in [open $file r]
1535	set out [open $tmpname w]
1536	fconfigure $out -translation crlf
1537	set len [gets $in line]
1538	if {$len > 160} {
1539	# this is a UNIX file. Hope there are no control characters
1540	set i 0
1541	set j 79
1542	while {$j < $len} {
1543	puts $out [string range $line $i $j]
1544	incr i 80
1545	incr j 80
1546	}
1547	} else {
1548	while {$len >= 0} {
1549	append line " "
1550	append line " "
1551	set line [string range $line 0 79]
1552	puts $out $line
1553	set len [gets $in line]
1554	}
1555	}
1556	close $in
1557	close $out
1558	file rename -force $file $oldname
1559	file rename -force $tmpname $file
1560	} errmsg] {
1561	MyMessageBox -parent $frm -title "Conversion error" \
1562	-message "Error in conversion:\n$errmsg" -icon warning
1563	} else {
1564	set ans [MyMessageBox -parent $frm -title "More?" \
1565	-message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1566	-type yesno -default no]
1567	if {$ans == "no"} {destroy $frm}
1568	}
1569	}
1570
1571	# create a file box
1572	proc winfilebox {frm} {
1573	global expgui
1574	set bx $frm.1
1575	pack [frame $bx.top] -side top
1576	pack [label $bx.top.a -text "Directory" ] -side left
1577	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1578	pack $bx.top.d -side left
1579	set expgui(FileMenuDir) [pwd]
1580	# the icon below is from tk8.0/tkfbox.tcl
1581	set upfolder [image create bitmap -data {
1582	#define updir_width 28
1583	#define updir_height 16
1584	static char updir_bits[] = {
1585	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1586	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1587	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1588	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1589	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1590	0xf0, 0xff, 0xff, 0x01};}]
1591
1592	pack [button $bx.top.b -image $upfolder \
1593	-command "updir; ChooseWinCnv $frm" ]
1594	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1595	listbox $bx.a.files -relief raised -bd 2 \
1596	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1597	-height 15 -width 0 -exportselection 0
1598	listbox $bx.a.dates -relief raised -bd 2 \
1599	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1600	-height 15 -width 0 -takefocus 0 -exportselection 0
1601	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1602	ChooseWinCnv $frm
1603	bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1604	bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1605	bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1606	bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1607	pack $bx.a.scroll -side left -fill y
1608	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1609	pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1610	}
1611
1612	# set the box or file in the selection window
1613	proc ReleaseWinCnv {frm} {
1614	global expgui
1615	set files $frm.1.a.files
1616	set dates $frm.1.a.dates
1617	set select [$files curselection]
1618	if {$select == ""} {
1619	set select [$dates curselection]
1620	}
1621	if {$select == ""} {
1622	set expgui(FileMenuCnvName) ""
1623	} else {
1624	set expgui(FileMenuCnvName) [string trim [$files get $select]]
1625	}
1626	if {$expgui(FileMenuCnvName) == "<Parent>"} {
1627	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1628	ChooseWinCnv $frm
1629	} elseif [file isdirectory \
1630	[file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1631	if {$expgui(FileMenuCnvName) != "."} {
1632	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1633	ChooseWinCnv $frm
1634	}
1635	}
1636	return
1637	}
1638
1639	# select a file or directory -- called on double click
1640	proc SelectWinCnv {frm} {
1641	global expgui
1642	set files $frm.1.a.files
1643	set dates $frm.1.a.dates
1644	set select [$files curselection]
1645	if {$select == ""} {
1646	set select [$dates curselection]
1647	}
1648	if {$select == ""} {
1649	set file .
1650	} else {
1651	set file [string trim [$files get $select]]
1652	}
1653	if {$file == "<Parent>"} {
1654	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1655	ChooseWinCnv $frm
1656	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1657	if {$file != "."} {
1658	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1659	ChooseWinCnv $frm
1660	}
1661	} else {
1662	set expgui(FileMenuCnvName) [file tail $file]
1663	ValidWinCnv $frm
1664	}
1665	}
1666
1667	# fill the files & dates & Directory selection box with current directory,
1668	# also called when box is created to fill it
1669	proc ChooseWinCnv {frm} {
1670	global expgui
1671	set files $frm.1.a.files
1672	set dates $frm.1.a.dates
1673	set expgui(FileMenuCnvName) {}
1674	$files delete 0 end
1675	$dates delete 0 end
1676	$files insert end {<Parent>}
1677	$dates insert end {(Directory)}
1678	set filelist [glob -nocomplain \
1679	[file join [set expgui(FileMenuDir)] *] ]
1680	foreach file [lsort -dictionary $filelist] {
1681	if {[file isdirectory $file]} {
1682	$files insert end [file tail $file]
1683	$dates insert end {(Directory)}
1684	}
1685	}
1686	foreach file [lsort -dictionary $filelist] {
1687	if {![file isdirectory $file]} {
1688	set modified [clock format [file mtime $file] -format "%T %D"]
1689	$files insert end [file tail $file]
1690	$dates insert end $modified
1691	}
1692	}
1693	$expgui(FileDirButtonMenu) delete 0 end
1694	set list ""
1695	global tcl_version
1696	if {$tcl_version > 8.0} {
1697	catch {set list [string tolower [file volume]]}
1698	}
1699	set dir ""
1700	foreach subdir [file split [set expgui(FileMenuDir)]] {
1701	set dir [string tolower [file join $dir $subdir]]
1702	if {[lsearch $list $dir] == -1} {lappend list $dir}
1703	}
1704	foreach path $list {
1705	$expgui(FileDirButtonMenu) add command -label $path \
1706	-command "[list set expgui(FileMenuDir) $path]; \
1707	ChooseWinCnv $frm"
1708	}
1709	return
1710	}
1711
1712	#------------------------------------------------------------------------------
1713	# set options for liveplot
1714	proc liveplotopt {} {
1715	global liveplot expmap
1716	set frm .file
1717	catch {destroy $frm}
1718	toplevel $frm
1719	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1720	set last [lindex [lsort -integer $expmap(powderlist)] end]
1721	if {$last == ""} {set last 1}
1722	pack [scale $frmA.1 -label "Histogram number" -from 1 -to $last \
1723	-length 150 -orient horizontal -variable liveplot(hst)] -side top
1724	pack [checkbutton $frmA.2 -text {include plot legend}\
1725	-variable liveplot(legend)] -side top
1726	pack [button $frm.2 -text OK \
1727	-command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1728	] -side top
1729	bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1730
1731	# force the window to stay on top
1732	putontop $frm
1733	focus $frm.2
1734	tkwait window $frm
1735	afterputontop
1736	}
1737
1738	#------------------------------------------------------------------------------
1739	# get an experiment file name
1740	#------------------------------------------------------------------------------
1741	proc getExpFileName {mode} {
1742	global expgui tcl_platform
1743	set frm .file
1744	catch {destroy $frm}
1745	toplevel $frm
1746	wm title $frm "Experiment file"
1747	bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1748	pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1749	pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1750	-fill y -expand yes
1751	pack [button $frmC.help -text Help -bg yellow \
1752	-command "MakeWWWHelp expguierr.html open"] \
1753	-side top -anchor e
1754	pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1755	pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1756	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1757	pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1758	-variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1759
1760	set expgui(includearchived) 0
1761	set expgui(FileInfoBox) $frmC.info
1762	if {$mode == "old"} {
1763	pack [checkbutton $frmC.ar -text "Include Archived Files" \
1764	-variable expgui(includearchived) \
1765	-command "ChooseExpFil $frmA"] -side top -pady 10
1766	pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1767	-class SmallFont] \
1768	-side top -fill both -expand yes -pady 5
1769	}
1770	pack [button $frmC.b -text Read \
1771	-command "valid_exp_file $frmA $mode"] -side bottom
1772	if {$mode == "new"} {
1773	$frmC.b config -text Save
1774	}
1775	pack [button $frmC.q -text Quit \
1776	-command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1777	bind $frm <Return> "$frmC.b invoke"
1778
1779	if {$mode == "new"} {
1780	pack [label $frmA.0 -text "Enter an experiment file to create"] \
1781	-side top -anchor center
1782	} else {
1783	pack [label $frmA.0 -text "Select an experiment file to read"] \
1784	-side top -anchor center
1785	}
1786	expfilebox $frmA $mode
1787	# force the window to stay on top
1788	putontop $frm
1789	focus $frmC.b
1790	tkwait window $frm
1791	afterputontop
1792	if {$expgui(FileMenuEXPNAM) == ""} return
1793	# is there a space in the EXP name?
1794	if {[string first " " [file tail $expgui(FileMenuEXPNAM)]] != -1} {
1795	update
1796	MyMessageBox -parent . -title "File Name Error" \
1797	-message "File name \"$expgui(FileMenuEXPNAM)\" is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1798	-icon warning -type Continue -default continue
1799	# -helplink "expguierr.html OpenErr"
1800	return
1801	}
1802	if {[string first " " $expgui(FileMenuDir)] != -1} {
1803	update
1804	MyMessageBox -parent . -title "Good luck..." \
1805	-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." \
1806	-icon warning -type Continue -default continue
1807	# -helplink "expguierr.html OpenErr"
1808	}
1809	return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1810	}
1811
1812	# validation routine
1813	proc valid_exp_file {frm mode} {
1814	global expgui tcl_platform
1815	# windows fixes
1816	if {$tcl_platform(platform) == "windows"} {
1817	# change backslashes to something sensible
1818	regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1819	# allow entry of D: for D:/ and D:TEST for d:/TEST
1820	if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1821	[string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1822	regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1823	}
1824	}
1825	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1826	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1827	ChooseExpFil $frm
1828	return
1829	} elseif [file isdirectory \
1830	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1831	if {$expgui(FileMenuEXPNAM) != "."} {
1832	set expgui(FileMenuDir) \
1833	[file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1834	}
1835	ChooseExpFil $frm
1836	return
1837	}
1838	# append a .EXP if not present
1839	if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
1840	append expgui(FileMenuEXPNAM) ".EXP"
1841	}
1842	# is there a space in the name?
1843	if {[string first " " $expgui(FileMenuEXPNAM)] != -1} {
1844	MyMessageBox -parent . -title "File Name Error" \
1845	-message "File name $expgui(FileMenuEXPNAM) is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1846	-icon warning -type Continue -default continue
1847	# -helplink "expguierr.html OpenErr"
1848	return
1849	}
1850	# check for archive files
1851	if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
1852	$mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
1853	destroy .file
1854	return
1855	} elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
1856	# check for files that end in something other than .EXP .exp or .Exp...
1857	MyMessageBox -parent . -title "File Open Error" \
1858	-message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
1859	-icon error
1860	return
1861	}
1862	# check on the file status
1863	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1864	if {$mode == "new" && [file exists $file]} {
1865	set ans [
1866	MyMessageBox -parent . -title "File Open Error" \
1867	-message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
1868	-icon question -type {"Select other" "Overwrite"} -default "select other" \
1869	-helplink "expguierr.html OverwriteErr"
1870	]
1871	if {[string tolower $ans] == "overwrite"} {destroy .file}
1872	return
1873	}
1874	# if file does not exist in case provided, set the name to all
1875	# upper case letters, since that is the best choice.
1876	# if it does exist, read from it as is. For UNIX we will force uppercase later.
1877	if {![file exists $file]} {
1878	set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1879	set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1880	}
1881	if {$mode == "old" && ![file exists $file]} {
1882	set ans [
1883	MyMessageBox -parent . -title "File Open Error" \
1884	-message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
1885	-icon question -type {"Select other" "Create"} -default "select other" \
1886	-helplink "expguierr.html OpenErr"
1887	]
1888	if {[string tolower $ans] == "create"} {destroy .file}
1889	return
1890	}
1891	destroy .file
1892	}
1893
1894	proc updir {} {
1895	global expgui
1896	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1897	}
1898
1899	# create a file box
1900	proc expfilebox {bx mode} {
1901	global expgui
1902	pack [frame $bx.top] -side top
1903	pack [label $bx.top.a -text "Directory" ] -side left
1904	set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1905	pack $bx.top.d -side left
1906	set expgui(FileMenuDir) [pwd]
1907	# the icon below is from tk8.0/tkfbox.tcl
1908	set upfolder [image create bitmap -data {
1909	#define updir_width 28
1910	#define updir_height 16
1911	static char updir_bits[] = {
1912	0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1913	0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1914	0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1915	0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1916	0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1917	0xf0, 0xff, 0xff, 0x01};}]
1918
1919	pack [button $bx.top.b -image $upfolder \
1920	-command "updir; ChooseExpFil $bx" ]
1921	pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1922	listbox $bx.a.files -relief raised -bd 2 \
1923	-yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1924	-height 15 -width 0 -exportselection 0
1925	listbox $bx.a.dates -relief raised -bd 2 \
1926	-yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1927	-height 15 -width 0 -takefocus 0 -exportselection 0
1928	scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1929	ChooseExpFil $bx
1930	bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1931	bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1932	bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1933	bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1934	pack $bx.a.scroll -side left -fill y
1935	pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1936	pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1937	}
1938	proc sync2boxesX {master slave scroll args} {
1939	$slave xview moveto [lindex [$master xview] 0]
1940	eval $scroll set $args
1941	}
1942	proc move2boxesX {boxlist args} {
1943	foreach listbox $boxlist {
1944	eval $listbox xview $args
1945	}
1946	}
1947	proc sync2boxesY {master slave scroll args} {
1948	$slave yview moveto [lindex [$master yview] 0]
1949	eval $scroll set $args
1950	}
1951	proc move2boxesY {boxlist args} {
1952	foreach listbox $boxlist {
1953	eval $listbox yview $args
1954	}
1955	}
1956
1957	# creates a table that is scrollable in both x and y, use ResizeScrollTable
1958	# to set sizes after gridding the boxes
1959	proc MakeScrollTable {box} {
1960	grid [label $box.0] -column 0 -row 0
1961	grid [set tbox [canvas $box.top \
1962	-scrollregion {0 0 10 10} \
1963	-xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
1964	-width 10 -height 10]] \
1965	-sticky sew -row 0 -column 1
1966	grid [set sbox [canvas $box.side \
1967	-scrollregion {0 0 10 10} \
1968	-yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
1969	-width 10 -height 10]] \
1970	-sticky nes -row 1 -column 0
1971	grid [set bbox [canvas $box.can \
1972	-scrollregion {0 0 10 10} \
1973	-yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
1974	-xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
1975	-width 200 -height 200 -bg lightgrey]] \
1976	-sticky news -row 1 -column 1
1977	grid [set sxbox [scrollbar $box.scroll -orient horizontal \
1978	-command "move2boxesX \" $box.can $box.top \" "]] \
1979	-sticky ew -row 2 -column 1
1980	grid [set sybox [scrollbar $box.yscroll \
1981	-command "move2boxesY \" $box.can $box.side \" "]] \
1982	-sticky ns -row 1 -column 2
1983	frame $tbox.f -bd 0
1984	$tbox create window 0 0 -anchor nw -window $tbox.f
1985	frame $bbox.f -bd 2
1986	$bbox create window 0 0 -anchor nw -window $bbox.f
1987	frame $sbox.f -bd 2 -relief raised
1988	$sbox create window 0 0 -anchor nw -window $sbox.f
1989	grid columnconfig $box 1 -weight 1
1990	grid rowconfig $box 1 -weight 1
1991	return [list $tbox.f $bbox.f $sbox.f $box.0]
1992	}
1993
1994	proc ResizeScrollTable {box} {
1995	update idletasks
1996	for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
1997	set x1 [lindex [grid bbox $box.can.f $i 0] 2]
1998	set x2 [lindex [grid bbox $box.top.f $i 0] 2]
1999	if {$x2 > $x1} {set x1 $x2}
2000	grid columnconfigure $box.top.f $i -minsize $x1
2001	grid columnconfigure $box.can.f $i -minsize $x1
2002	}
2003	for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2004	set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2005	set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2006	if {$x2 > $x1} {set x1 $x2}
2007	grid rowconfigure $box.can.f $i -minsize $x1
2008	grid rowconfigure $box.side.f $i -minsize $x1
2009	}
2010	update idletasks
2011	set sizes [grid bbox $box.can.f]
2012	$box.can config -scrollregion $sizes
2013	$box.side config -scrollregion $sizes
2014	$box.top config -scrollregion $sizes
2015	$box.top config -height [lindex [grid bbox $box.top.f] 3]
2016	$box.side config -width [lindex [grid bbox $box.side.f] 2]
2017	}
2018	proc ExpandScrollTable {box} {
2019	# set height & width of central box
2020	$box.can config -width \
2021	[expr [winfo width [winfo toplevel $box]] \
2022	- [winfo width $box.side] - [winfo width $box.yscroll]-20]
2023	$box.can config -height \
2024	[expr [winfo height [winfo toplevel $box]] \
2025	- [winfo height $box.top] - [winfo height $box.scroll]-25]
2026	}
2027
2028
2029	# support routine for SetHistUseFlags
2030	proc InitHistUseFlags {} {
2031	global expmap expgui
2032	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2033	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2034	set expgui(useflag_$i) [histinfo $i use]
2035	# }
2036	}
2037	}
2038
2039	# show all Powder histograms; set use/do not use flags
2040	proc SetHistUseFlags {} {
2041	set box .test
2042	catch {toplevel $box}
2043	eval destroy [winfo children $box]
2044	grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2045	grid [frame $box.a] -row 1 -column 0 -columnspan 2
2046	grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2047	grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2048	grid columnconfig $box 0 -weight 1
2049	grid columnconfig $box 1 -weight 1
2050	foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2051	$cbox config -text "Use\nFlag"
2052	[winfo parent $bbox] config -height 250 -width 400
2053	global expmap expgui
2054	set px 5
2055	set row -1
2056	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2057	if {[string range $expmap(htype_$i) 2 2] == "T"} {
2058	set det [format %8.2f [histinfo $i tofangle]]
2059	} elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2060	set det [format %8.5f [histinfo $i lam1]]
2061	} elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2062	set det [format %8.2f [histinfo $i lam1]]
2063	} else {
2064	set det {}
2065	}
2066	incr row
2067	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2068	grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0
2069	set expgui(useflag_$i) [histinfo $i use]
2070	# }
2071	grid [label $bbox.0$i \
2072	-text [string range $expmap(htype_$i) 0 3] \
2073	] -row $row -column 0 -padx $px
2074	grid [label $bbox.1$i -text [histinfo $i bank] \
2075	] -row $row -column 1 -padx $px
2076	grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2077	grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2078	] -row $row -column 3 -padx $px -sticky ew
2079	}
2080	grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2081	grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2082	grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2083	grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2084	ResizeScrollTable $box.a
2085	InitHistUseFlags
2086	putontop $box
2087	tkwait window $box
2088	afterputontop
2089	set prevchages $expgui(changed)
2090	for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2091	# if {[string range $expmap(htype_$i) 0 0] == "P"} {
2092	if {$expgui(useflag_$i) != [histinfo $i use]} {
2093	histinfo $i use set $expgui(useflag_$i)
2094	incr expgui(changed)
2095	}
2096	# }
2097	}
2098	if {$prevchages != $expgui(changed)} {
2099	set msg "You have changed [expr $expgui(changed)-$prevchages] "
2100	append msg "histogram flag(s). You must run POWPREF "
2101	append msg "to include/remove these histograms. Do you want to "
2102	append msg "run POWPREF?"
2103	set ans [MyMessageBox -parent . -message $msg \
2104	-title "Process changes?"\
2105	-helplink "expguierr.html ProcessUse" \
2106	-default {Run POWPREF} \
2107	-type {{Run POWPREF} Skip}]
2108
2109	if {$ans == "skip"} {
2110	# save and reload the experiment file
2111	savearchiveexp
2112	loadexp $expgui(expfile)
2113	} else {
2114	# run powpref and force a reload
2115	set saveautoload $expgui(autoexpload)
2116	set expgui(autoexpload) 1
2117	runGSASwEXP powpref
2118	set expgui(autoexpload) $saveautoload
2119	}
2120	}
2121	}
2122
2123	# set the box or file in the selection window
2124	proc ReleaseExpFil {frm} {
2125	global expgui
2126	set files $frm.a.files
2127	set dates $frm.a.dates
2128	set select [$files curselection]
2129	if {$select == ""} {
2130	set select [$dates curselection]
2131	}
2132	if {$select == ""} {
2133	set expgui(FileMenuEXPNAM) ""
2134	} else {
2135	set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2136	after idle UpdateInfoBox
2137	}
2138	if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2139	set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2140	ChooseExpFil $frm
2141	} elseif [file isdirectory \
2142	[file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2143	if {$expgui(FileMenuEXPNAM) != "."} {
2144	set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2145	ChooseExpFil $frm
2146	}
2147	}
2148	return
2149	}
2150	proc UpdateInfoBox {} {
2151	global expgui
2152	if {![winfo exists $expgui(FileInfoBox)]} return
2153	eval destroy [winfo children $expgui(FileInfoBox)]
2154	set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2155	if [file isdirectory $file] return
2156	if [file exists $file] {
2157	pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2158	-side top
2159	catch {
2160	set fp [open $file r]
2161	global testline
2162	set testline [read $fp]
2163	close $fp
2164	update
2165	regexp {GNLS RUN on (.) +Total.run +([0-9]+) } \
2166	$testline a last cycles
2167	pack [label $expgui(FileInfoBox).2 -justify left \
2168	-text "last GENLES run:\n $last\n total cycles: $cycles"] \
2169	-side top -anchor w
2170	regexp {REFN GDNFT.= ([0-9]\.[0-9]) +for *([0-9]+) variables} \
2171	$testline a chi2 vars
2172	pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
2173	-side top -anchor w
2174	pack [label $expgui(FileInfoBox).3.a -justify left \
2175	-text "c" -font symbol] \
2176	-side left -anchor w
2177	pack [label $expgui(FileInfoBox).3.b -justify left \
2178	-text "2: $chi2, $vars vars"] \
2179	-side top -anchor w
2180	# check first 9 histograms
2181	set lbl "h Rwp R(F2)"
2182	set n 0
2183	foreach k {1 2 3 4 5 6 7 8 9} {
2184	set key "HST $k"
2185	append key { RPOWD +([0-9]\.[0-9]) }
2186	set i [regexp $key $testline a Rwp]
2187	set key "HST $k"
2188	append key { R-FAC +[0-9]+ +([0-9]\.[0-9]) }
2189	set j [regexp $key $testline a Rb]
2190	if {$i \|\| $j} {
2191	incr n
2192	append lbl "\n$k "
2193	if {$i} {
2194	append lbl [string range $Rwp 0 5]
2195	} else {
2196	append lbl " "
2197	}
2198	}
2199	if {$j} {
2200	append lbl " [string range $Rb 0 5]"
2201	}
2202	# stick 1st 3 entries in box
2203	if {$n >= 3} break
2204	}
2205	pack [label $expgui(FileInfoBox).4 -justify left \
2206	-text $lbl] \
2207	-side top -anchor w
2208	}
2209	}
2210	}
2211
2212	# select a file or directory -- called on double click
2213	proc SelectExpFil {frm mode} {
2214	global expgui
2215	set files $frm.a.files
2216	set dates $frm.a.dates
2217	set select [$files curselection]
2218	if {$select == ""} {
2219	set select [$dates curselection]
2220	}
2221	if {$select == ""} {
2222	set file .
2223	} else {
2224	set file [string trim [$files get $select]]
2225	}
2226	if {$file == "<Parent>"} {
2227	set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2228	ChooseExpFil $frm
2229	} elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2230	if {$file != "."} {
2231	set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2232	ChooseExpFil $frm
2233	}
2234	} else {
2235	set expgui(FileMenuEXPNAM) [file tail $file]
2236	valid_exp_file $frm $mode
2237	}
2238	}
2239
2240	# fill the files & dates & Directory selection box with current directory,
2241	# also called when box is created to fill it
2242	proc ChooseExpFil {frm} {
2243	global expgui
2244	set files $frm.a.files
2245	set dates $frm.a.dates
2246	set expgui(FileMenuEXPNAM) {}
2247	$files delete 0 end
2248	$dates delete 0 end
2249	$files insert end {<Parent>}
2250	$dates insert end {(Directory)}
2251	set filelist [glob -nocomplain \
2252	[file join [set expgui(FileMenuDir)] *] ]
2253	foreach file [lsort -dictionary $filelist] {
2254	if {[file isdirectory $file]} {
2255	$files insert end [file tail $file]
2256	$dates insert end {(Directory)}
2257	}
2258	}
2259	set pairlist {}
2260	foreach file [lsort -dictionary $filelist] {
2261	if {![file isdirectory $file] && \
2262	[string toupper [file extension $file]] == ".EXP"} {
2263	set modified [file mtime $file]
2264	lappend pairlist [list $file $modified]
2265	} elseif {![file isdirectory $file] && $expgui(includearchived) && \
2266	[string match {*.O[0-9A-F][0-9A-F]} $file]} {
2267	set modified [file mtime $file]
2268	lappend pairlist [list $file $modified]
2269	}
2270	}
2271	if {$expgui(filesort) == 0} {
2272	foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
2273	set file [lindex $pair 0]
2274	set modified [clock format [lindex $pair 1] -format "%T %D"]
2275	$files insert end [file tail $file]
2276	$dates insert end $modified
2277	}
2278	} else {
2279	foreach pair [lsort -dictionary -index 0 $pairlist] {
2280	set file [lindex $pair 0]
2281	set modified [clock format [lindex $pair 1] -format "%T %D"]
2282	$files insert end [file tail $file]
2283	$dates insert end $modified
2284	}
2285	}
2286	$expgui(FileDirButtonMenu) delete 0 end
2287	set list ""
2288	global tcl_platform tcl_version
2289	if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2290	catch {set list [string tolower [file volume]]}
2291	}
2292	set dir ""
2293	foreach subdir [file split [set expgui(FileMenuDir)]] {
2294	set dir [file join $dir $subdir]
2295	if {$tcl_platform(platform) == "windows"} {
2296	set dir [string tolower $dir]
2297	if {[lsearch $list $dir] == -1} {lappend list $dir}
2298	} else {
2299	lappend list $dir
2300	}
2301	}
2302	foreach path $list {
2303	$expgui(FileDirButtonMenu) add command -label $path \
2304	-command "[list set expgui(FileMenuDir) $path]; \
2305	ChooseExpFil $frm"
2306	}
2307	# highlight the current experiment -- if present
2308	for {set i 0} {$i < [$files size]} {incr i} {
2309	set file [$files get $i]
2310	if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2311	$files selection set $i
2312	}
2313	}
2314	return
2315	}
2316
2317
2318	#------------------------------------------------------------------------------
2319	# platform-specific definitions
2320	if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2321	# windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2322	# DOS box synchronously, so we create a "lock" file that is deleted
2323	# at the end of the DOS run so we can tell when the run is done.
2324	# We create a window to force the deleting of the file so that if
2325	# the DOS process crashes, the user can continue anyway.
2326	#
2327	# procedure to check if the lock file is still there (Win-9x/me only)
2328	proc checklockfile {file window} {
2329	if [file exists $file] {
2330	after 500 checklockfile $file $window
2331	} else {
2332	catch {destroy $window}
2333	}
2334	}
2335	# this procedure starts the GRWND program, if needed for program $prog
2336	proc StartGRWND {prog} {
2337	global expgui
2338	if {!$expgui(autoGRWND)} return
2339	# at some point we might want to have a real list
2340	if {$prog != "genles" && $prog != "powpref"} {
2341	# get a list of running jobs
2342	exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
2343	set fp [open tlist.tlist r]
2344	set text [read $fp]
2345	close $fp
2346	file delete -force tlist.tlist
2347	# if GRWND.EXE is not currently running, start it
2348	if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
2349	exec [file join $expgui(gsasexe) grwnd.exe] &
2350	# give grwnd a 1 second head start
2351	after 1000
2352	}
2353	}
2354	}
2355	# this creates a DOS box to run a program in
2356	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2357	global env expgui
2358	# Windows environment variables
2359	set env(GSAS) [file nativename $expgui(gsasdir)]
2360	# PGPLOT_FONT is needed by PGPLOT
2361	set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2362	# this is the number of lines/page in the .LST (etc.) file
2363	set env(LENPAGE) 60
2364	set pwd [file nativename [pwd]]
2365
2366	# check the .EXP path -- can DOS use it?
2367	if {[string first // [pwd]] != -1} {
2368	MyMessageBox -parent . -title "Invalid Path" \
2369	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2370	-icon error -type ok -default ok \
2371	-helplink "expgui_Win_readme.html NetPath"
2372	return
2373	}
2374	# pause is hard coded in the .BAT file
2375	#
2376	# loop over multiple commands
2377	foreach cmd $command {
2378	# simulate the wait with a lock file
2379	if {$wait} {
2380	if {$expgui(autoiconify)} {wm iconify .}
2381	# create a blank lock file and a message window
2382	close [open expgui.lck w]
2383	toplevel .lock
2384	grid [button .lock.0 -text Help -bg yellow \
2385	-command "MakeWWWHelp expguierr.html lock"] \
2386	-column 1 -row 0
2387	grid [label .lock.1 \
2388	-text "Please wait while the GSAS program finishes."] \
2389	-column 0 -row 0
2390	grid [label .lock.2 -text \
2391	"In case a problem occurs, close the DOS box"] \
2392	-column 0 -columnspan 2 -row 1
2393	grid [label .lock.3 -text \
2394	"and press the \"Continue\" button (below)"] \
2395	-column 0 -columnspan 2 -row 2
2396	grid [button .lock.b -text "Continue" \
2397	-command "destroy .lock; wm deiconify ."] \
2398	-column 0 -columnspan 2 -row 3
2399	putontop .lock
2400	update
2401	checklockfile expgui.lck .lock
2402	}
2403	# replace the forward slashes with backward
2404	regsub -all / $cmd \\ cmd
2405	winexec -d [file nativename [pwd]] \
2406	[file join $expgui(scriptdir) gsastcl.bat] $cmd
2407	if {$wait} {
2408	tkwait window .lock
2409	file delete -force expgui.lck
2410	}
2411	}
2412	if {$expgui(autoiconify) && $wait} {wm deiconify .}
2413	# check for changes in the .EXP file immediately
2414	whenidle
2415	}
2416	} elseif {$tcl_platform(platform) == "windows"} {
2417	# now for Windows-NT, where we can run synchronously
2418	#
2419	# this creates a DOS box to run a program in
2420	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2421	global env expgui
2422	# Windows environment variables
2423	set env(GSAS) [file nativename $expgui(gsasdir)]
2424	# PGPLOT_FONT is needed by PGPLOT
2425	set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2426	# this is the number of lines/page in the .LST (etc.) file
2427	set env(LENPAGE) 60
2428	set pwd [file nativename [pwd]]
2429	# check the path -- can DOS use it?
2430	if {[string first // [pwd]] != -1} {
2431	MyMessageBox -parent . -title "Invalid Path" \
2432	-message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2433	-icon error -type ok -default ok \
2434	-helplink "expgui_Win_readme.html NetPath"
2435	return
2436	}
2437	# pause is hard coded in the .BAT file
2438
2439	if {$wait} {
2440	if {$expgui(autoiconify)} {wm iconify .}
2441	# create a blank lock file (keep liveplot from running)
2442	close [open expgui.lck w]
2443	# loop over commands
2444	foreach cmd $command {
2445	# replace the forward slashes with backward
2446	regsub -all / $cmd \\ cmd
2447	exec $env(COMSPEC) /c \
2448	"start [file join $expgui(scriptdir) gsastcl.bat] $cmd"
2449	}
2450	file delete -force expgui.lck
2451	if {$expgui(autoiconify)} {wm deiconify .}
2452	# check for changes in the .EXP file immediately
2453	whenidle
2454	} else {
2455	# loop over commands
2456	foreach cmd $command {
2457	# replace the forward slashes with backward
2458	regsub -all / $cmd \\ cmd
2459	# run in background
2460	exec $env(COMSPEC) /c \
2461	"start [file join $expgui(scriptdir) gsastcl.bat] $cmd" &
2462	}
2463	}
2464	}
2465	} else {
2466	# this creates a xterm window to run a program in
2467	proc forknewterm {title command "wait 1" "scrollbar 1"} {
2468	global env expgui
2469	# UNIX environment variables
2470	set env(GSAS) [file nativename $expgui(gsasdir)]
2471	set env(gsas) [file nativename $expgui(gsasdir)]
2472	set env(GSASEXE) $expgui(gsasexe)
2473	set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2474	set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2475	# PGPLOT_DIR is needed by PGPLOT
2476	set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2477	# this is the number of lines/page in the .LST (etc.) file
2478	set env(LENPAGE) 60
2479	set termopts {}
2480	if $env(GSASBACKSPACE) {
2481	append termopts \
2482	{-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2483	}
2484	if $scrollbar {
2485	append termopts " -sb"
2486	} else {
2487	append termopts " +sb"
2488	}
2489	if {$wait} {
2490	set suffix {}
2491	} else {
2492	set suffix {&}
2493	}
2494	#
2495	#if $wait {
2496	append command "\; echo -n Press Enter to continue \; read x"
2497	#}
2498	if {$wait && $expgui(autoiconify)} {wm iconify .}
2499	catch {eval exec xterm $termopts -title [list $title] \
2500	-e /bin/sh -c [list $command] $suffix} errmsg
2501	if $expgui(debug) {puts "xterm result = $errmsg"}
2502	if {$wait} {
2503	if {$expgui(autoiconify)} {wm deiconify .}
2504	# check for changes in the .EXP file immediately
2505	whenidle
2506	}
2507	}
2508	}

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

Download in other formats: