Context Navigation

source: trunk/gsascmds.tcl @ 805

Last change on this file since 805 was 805, checked in by toby, 16 years ago

# on 2004/09/20 15:32:20, toby did:
force all output to instfile to be in ASCII

this might solve bugs where non-ascii chars invalidate .EXP file

Property rcs:author set to toby
Property rcs:date set to 2004/09/20 15:32:20
Property rcs:lines set to +2 -2
Property rcs:rev set to 1.58
Property rcs:state set to Exp
Property svn:keywords set to Author Date Revision Id

File size: 86.5 KB

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

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

Download in other formats: