Context Navigation

source: trunk/gsascmds.tcl @ 322

Last change on this file since 322 was 322, checked in by toby, 13 years ago
# on 2000/10/12 21:36:23, toby did: Add www help support improve formatting of help box at catch statements to focus and grab calls save grab in pleasewait and restore in donewait Add link arg in ShowBigMessage? & -helplink to MyMessageBox?
Property rcs:author set to `toby` Property rcs:date set to `2000/10/12 21:36:23` Property rcs:lines set to `+231 -80` Property rcs:rev set to `1.24` Property rcs:state set to `Exp` Property svn:keywords set to `Author Date Revision Id`
File size: 71.1 KB

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

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

Download in other formats: