Context Navigation

source: trunk/gsascmds.tcl @ 360

Last change on this file since 360 was 360, checked in by toby, 13 years ago

# on 2000/12/22 19:44:07, toby did:
Major reworking of routines to run GSAS routines:

non-EXP using programs run independently by default
Pause is now hard-coded
EXP using programs run in foreground by default (exception is POWPLOT)

Win-95 implementation of forknewterm rewritten to loop over commands

& use lock file (resume when lock file is deleted) & have "lock" window

Win-NT revised to not use WINEXEC & run in foreground
UNIX implementation of forknewterm revised to match previous

Property rcs:author set to toby
Property rcs:date set to 2000/12/22 19:44:07
Property rcs:lines set to +109 -40
Property rcs:rev set to 1.28
Property rcs:state set to Exp
Property svn:keywords set to Author Date Revision Id

File size: 75.9 KB

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

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

Context Navigation

source: trunk/gsascmds.tcl @ 360

Download in other formats: