Context Navigation

source: trunk/liveplot @ 480

Last change on this file since 480 was 477, checked in by toby, 13 years ago
# on 2001/10/31 20:04:21, toby did: add next histogram feature
Property rcs:author set to `toby` Property rcs:date set to `2001/10/31 20:04:21` Property rcs:lines set to `+54 -34` Property rcs:rev set to `1.22` Property rcs:state set to `Exp` Property svn:keywords set to `Author Date Revision Id`
File size: 53.1 KB

Line
1	#!/usr/local/bin/wish
2	# $Id: liveplot 477 2009-12-04 23:06:49Z toby $
3	set Revision {$Revision: 477 $ $Date: 2009-12-04 23:06:49 +0000 (Fri, 04 Dec 2009) $}
4
5	bind all <Control-KeyPress-c> {destroy .}
6	# process command line arguments
7	set exitstat 0
8	set expnam [lindex $argv 0]
9	if {$expnam == ""} {puts "error -- no experiment name"; set exitstat 1}
10	if $exitstat {
11	puts "usage: $argv0 expnam \[hist #\] \[legend\]"
12	destroy .
13	}
14	set program [file tail $argv0]
15	#set program bkgedit
16
17	if {[lindex $argv 1] == ""} {
18	set hst 1
19	} else {
20	set hst [lindex $argv 1]
21	}
22	if {[lindex $argv 2] == ""} {
23	set graph(legend) 1
24	} else {
25	set graph(legend) [lindex $argv 2]
26	}
27
28	set graph(backsub) 0
29
30	if {$tcl_platform(platform) == "windows"} {
31	set graph(printout) 1
32	set expgui(tcldump) tcldump.exe
33	} else {
34	set graph(printout) 0
35	set expgui(tcldump) tcldump
36	}
37
38	# default values
39	set graph(outname) out.ps
40	set graph(outcmd) lpr
41	set xunits {}
42	set yunits {}
43	set graph(chi2) 0
44	set graph(xunits) 0
45	set graph(yunits) 0
46	set graph(autoraise) 1
47	set graph(color_diff) blue
48	set graph(color_chi2) magenta
49	set graph(color_bkg) green
50	set graph(color_calc) red
51	set graph(color_obs) black
52	set graph(color_input) magenta
53	set graph(color_fit) blue
54	set expgui(debug) 0
55	catch {if $env(DEBUG) {set expgui(debug) 1}}
56	#set expgui(debug) 1
57	set expgui(font) 14
58	set expgui(lblfontsize) 15
59	set expgui(fadetime) 10
60	set expgui(hklbox) 1
61	set expgui(autotick) 0
62	set expgui(pixelregion) 5
63	# location for web pages, if not found locally
64	set expgui(website) www.ncnr.nist.gov/xtal/software/expgui
65	set peakinfo(obssym) scross
66	set peakinfo(obssize) 1.0
67	set peakinfo(inpsym) triangle
68	set peakinfo(inpsize) 1.0
69	# create a set of markers for each phase
70	for {set i 1} {$i < 10} {incr i} {
71	set peakinfo(flag$i) 0
72	set peakinfo(max$i) Inf
73	set peakinfo(min$i) -Inf
74	set peakinfo(dashes$i) 1
75	}
76
77	if [catch {package require BLT} errmsg] {
78	tk_dialog .err "BLT Error" "Error -- Unable to load the BLT package" \
79	error 0 Quit
80	destroy .
81	}
82	# handle Tcl/Tk v8+ where BLT is in a namespace
83	# use the command so that it is loaded
84	catch {blt::graph}
85	catch {
86	namespace import blt::graph
87	namespace import blt::vector
88	}
89	# old versions of blt don't report a version number
90	if [catch {set blt_version}] {set blt_version 0}
91	# option for coloring markers: note that GH keeps changing how to do this!
92	# also element -mapped => -show
93	if {$blt_version < 2.3 \|\| $blt_version >= 8.0} {
94	# version 8.0 is ~same as 2.3
95	set graph(MarkerColorOpt) -fg
96	# mapped is needed in 8.0, both are OK in 2.3
97	set graph(ElementShowOption) "-mapped 1"
98	set graph(ElementHideOption) "-mapped 0"
99	} elseif {$blt_version >= 2.4} {
100	set graph(MarkerColorOpt) -outline
101	set graph(ElementShowOption) "-hide 0"
102	set graph(ElementHideOption) "-hide 1"
103	} else {
104	set graph(MarkerColorOpt) -color
105	set graph(ElementShowOption) "-mapped 1"
106	set graph(ElementHideOption) "-mapped 0"
107	}
108
109	proc waitmsg {message} {
110	set w .wait
111	# kill any window/frame with this name
112	catch {destroy $w}
113	pack [frame $w]
114	frame $w.bot -relief raised -bd 1
115	pack $w.bot -side bottom -fill both
116	frame $w.top -relief raised -bd 1
117	pack $w.top -side top -fill both -expand 1
118	label $w.msg -justify left -text $message -wrap 3i
119	catch {$w.msg configure -font \
120	-Adobe-Times-Medium-R-Normal---180------*
121	}
122	pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
123	label $w.bitmap -bitmap info
124	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
125	update
126	}
127
128	proc donewaitmsg {} {
129	catch {destroy .wait}
130	update
131	}
132
133	waitmsg "Loading histogram, Please wait"
134
135	#--------------------------------------------------------------
136	# define constants
137	array set peakinfo {
138	color1 magenta
139	color2 cyan
140	color3 yellow
141	color4 sienna
142	color5 orange
143	color6 DarkViolet
144	color7 HotPink
145	color8 salmon
146	color9 LimeGreen
147	}
148	set cycle -1
149	set modtime 0
150
151	#----------------------------------------------------------------
152	# where are we?
153	set expgui(script) [info script]
154	# translate links -- go six levels deep
155	foreach i {1 2 3 4 5 6} {
156	if {[file type $expgui(script)] == "link"} {
157	set link [file readlink $expgui(script)]
158	if { [file pathtype $link] == "absolute" } {
159	set expgui(script) $link
160	} {
161	set expgui(script) [file dirname $expgui(script)]/$link
162	}
163	} else {
164	break
165	}
166	}
167
168	# fixup relative paths
169	if {[file pathtype $expgui(script)] == "relative"} {
170	set expgui(script) [file join [pwd] $expgui(script)]
171	}
172	set expgui(scriptdir) [file dirname $expgui(script) ]
173	set expgui(gsasdir) [file dirname $expgui(scriptdir)]
174	set expgui(gsasexe) [file join $expgui(gsasdir) exe]
175	set expgui(docdir) [file join $expgui(scriptdir) doc]
176
177	# called by a trace on expgui(lblfontsize)
178	proc setfontsize {a b c} {
179	global expgui graph
180	catch {
181	font config lblfont -size [expr -$expgui(lblfontsize)]
182	# this forces a redraw of the plot by changing the title to itself
183	.g configure -title [.g cget -title]
184	}
185	}
186	# define a font used for labels
187	if {$tcl_version >= 8.0} {
188	font create lblfont -family Helvetica -size [expr -$expgui(lblfontsize)]
189	trace variable expgui(lblfontsize) w setfontsize
190	}
191
192	proc readdata {box} {
193	global expgui modtime expnam
194	if [catch {
195	set modtime [file mtime $expnam.EXP]
196	set loadtime [time {
197	if {$expgui(tcldump) == ""} {
198	readdata_hst $box
199	} else {
200	readdata_tcl $box
201	}
202	}]
203	if $expgui(debug) {
204	tk_dialog .time "Timing info" \
205	"Histogram loading took $loadtime" "" 0 OK
206	}
207	} errmsg] {
208	if $expgui(debug) {
209	catch {console show}
210	error $errmsg
211	}
212	$box config -title "Read error"
213	tk_dialog .err "Read Error" "Read Error -- $errmsg" \
214	error 0 OK
215	update
216	}
217	$box element show [lsort -decreasing [$box element show]]
218	global program
219	if {$program == "bkgedit"} bkghstInit
220	}
221
222	proc readdata_hst {box} {
223	global expgui expnam reflns
224	global lasthst
225	global hst peakinfo xunits
226	$box config -title "(Histogram update in progress)"
227	update
228	# parse the output of a file
229	set lasthst $hst
230	###########################################################################
231	# set input [open histdump.inp w]
232	# puts $input "$hst"
233	# close $input
234	# set input [open "\| $expgui(gsasexe)/hstdump $expnam < histdump.inp" w+]
235	###########################################################################
236	# use histdmp for histogram info
237	set input [open histdump$hst.inp w]
238	puts $input "$expnam"
239	puts $input "L"
240	puts $input "$hst"
241	puts $input "0"
242	close $input
243	# use hstdmp without an experiment name so that output
244	# is not sent to the .LST file
245	set input [open "\| $expgui(gsasexe)/hstdmp < histdump$hst.inp" r]
246
247	# initalize arrays
248	set num -1
249	set xlist {}
250	set obslist {}
251	set calclist {}
252	set bcklist {}
253	set xunits {}
254	# define a list of reflection positions for each phase
255	for {set i 1} {$i < 10} {incr i} {
256	set reflns($i) {}
257	}
258	set i 0
259	while {[gets $input line] >= 0} {
260	incr i
261	# run update every 50th line
262	if {$i > 50} {set i 0; update}
263	if [scan $line %d num] {
264	if {$num > 0} {
265	set Ispec 0
266	set X -999
267	scan [string range $line 8 end] %e%e%e%e%e%e \
268	X Iobs Icalc Ispec fixB fitB
269	#puts $line
270	# eliminate excluded points
271	if {$Ispec > 0.0 && $X >= 0} {
272	lappend xlist $X
273	lappend obslist $Iobs
274	lappend calclist $Icalc
275	lappend bcklist [expr $fixB + $fitB]
276	}
277	# add peaks to peak lists
278	# puts "[string range $line 6 6]"
279	# is this 6 or 7; 6 on win & 7 on SGI
280	if [regexp {[1-9]} [string range $line 6 7] ph] {
281	lappend reflns($ph) $X
282	}
283	}
284	} else {
285	regexp {Time\|Theta\|keV} $line xunits
286	}
287	}
288	if {$xunits == "Theta"} {set xunits "2-Theta"}
289	close $input
290	catch {file delete histdump$hst.inp}
291	xvec set $xlist
292	obsvec set $obslist
293	calcvec set $calclist
294	bckvec set $bcklist
295	diffvec set [obsvec - calcvec]
296	global obsvec calcvec diffvec
297	set maxdiff [set diffvec(max)]
298	set cmin [set calcvec(min)]
299	set omin [set obsvec(min)]
300	set cmax [set calcvec(max)]
301	set omax [set obsvec(max)]
302	set expgui(min) [expr $omin < $cmin ? $omin : $cmin]
303	set expgui(max) [expr $omax > $cmax ? $omax : $cmax]
304	set ymin1 [expr $cmin - 1.1*$maxdiff]
305	set ymin2 [expr $omin - 1.1*$maxdiff]
306	if {$ymin1 < $ymin2} {
307	diffvec set [diffvec + $ymin1]
308	} {
309	diffvec set [diffvec + $ymin2]
310	}
311	plotdata
312	}
313
314	proc readdata_tcl {box} {
315	global expgui expnam reflns
316	global lasthst graph
317	global hst peakinfo xunits yunits
318	$box config -title "(Histogram update in progress)"
319	update
320	# parse the output of a file
321	set lasthst $hst
322	# use tcldump
323	set input [open histdump$hst.inp w]
324	puts $input "$hst"
325	# x units -- native
326	puts $input "$graph(xunits)"
327	# y units -- native
328	puts $input "$graph(yunits)"
329	# format (if implemented someday)
330	puts $input "0"
331	close $input
332	# initalize arrays
333	set X {}
334	set OBS {}
335	set CALC {}
336	set BKG {}
337	set WGT {}
338	global refhkllist refphaselist refpos
339	set refpos {}
340	set refhkllist {}
341	set refphaselist {}
342	for {set i 1} {$i < 10} {incr i} {
343	set reflns($i) {}
344	}
345	eval [exec $expgui(tcldump) $expnam < histdump$hst.inp]
346	catch {file delete histdump$hst.inp}
347	if {$X == ""} {
348	$box config -title "(Error reading Histogram $hst)"
349	foreach elem [$box element show] {
350	eval $box element config $elem $graph(ElementHideOption)
351	}
352	return
353	}
354	foreach elem [$box element names] {
355	eval $box element config $elem $graph(ElementShowOption)
356	}
357	xvec set $X
358	obsvec set $OBS
359	calcvec set $CALC
360	bckvec set $BKG
361	refposvec set $refpos
362	diffvec set [obsvec - calcvec]
363	if {$graph(chi2)} {
364	wifdvec set $WGT
365	wifdvec set [wifdvec * diffvec]
366	wifdvec set [wifdvec * diffvec]
367	# now do a running sum
368	set sum 0
369	set sumlist {}
370	foreach n [wifdvec range 0 end] {
371	set sum [expr $sum + $n]
372	lappend sumlist $sum
373	}
374	wifdvec set $sumlist
375	wifdvec set [wifdvec / [wifdvec length]]
376	}
377	if $graph(backsub) {
378	obsvec set [obsvec - bckvec]
379	calcvec set [calcvec - bckvec]
380	}
381	global obsvec calcvec diffvec
382	set maxdiff [set diffvec(max)]
383	set cmin [set calcvec(min)]
384	set omin [set obsvec(min)]
385	set cmax [set calcvec(max)]
386	set omax [set obsvec(max)]
387	set expgui(min) [expr $omin < $cmin ? $omin : $cmin]
388	set expgui(max) [expr $omax > $cmax ? $omax : $cmax]
389	set ymin1 [expr $cmin - 1.1*$maxdiff]
390	set ymin2 [expr $omin - 1.1*$maxdiff]
391	if {$ymin1 < $ymin2} {
392	diffvec set [diffvec + $ymin1]
393	} {
394	diffvec set [diffvec + $ymin2]
395	}
396
397	plotdata
398	}
399
400	proc lblhkl {plot x} {
401	global blt_version expgui tcl_platform tcl_version
402	global refhkllist refphaselist peakinfo refpos
403	# look for peaks within pixelregion pixels or the entire plot range
404	if {$x == "all"} {
405	foreach {xmin xmax} [$plot xaxis limits] {}
406	} else {
407	set xmin [$plot xaxis invtransform [expr $x - $expgui(pixelregion)]]
408	set xmax [$plot xaxis invtransform [expr $x + $expgui(pixelregion)]]
409	}
410	set peaknums [refposvec search $xmin $xmax]
411	set peaklist {}
412	# create a box, if needed
413	if {$expgui(hklbox)} {
414	catch {
415	toplevel .hkl
416	text .hkl.txt -width 30 -height 10 -wrap none \
417	-yscrollcommand ".hkl.yscroll set"
418	scrollbar .hkl.yscroll -command ".hkl.txt yview"
419	grid .hkl.txt -column 0 -row 1 -sticky nsew
420	grid .hkl.yscroll -column 1 -row 1 -sticky ns
421	grid columnconfigure .hkl 0 -weight 1
422	grid rowconfigure .hkl 1 -weight 1
423	wm title .hkl "Liveplot HKL Labels"
424	wm iconname .hkl HKL
425	.hkl.txt insert end "Phase\thkl\tPosition"
426	}
427	}
428	set xcen 0
429	set lbls 0
430	foreach peak $peaknums {
431	# put all hkls, all phases in the box
432	if {$expgui(hklbox)} {
433	catch {
434	.hkl.txt insert end "\n[lindex $refphaselist $peak]"
435	.hkl.txt insert end "\t[lindex $refhkllist $peak]"
436	.hkl.txt insert end "\t[lindex $refpos $peak]"
437	.hkl.txt see end
438	}
439	}
440	# label phases with tick marks
441	if [set peakinfo(flag[lindex $refphaselist $peak])] {
442	set pos [refposvec range $peak $peak]
443	if {$lbls <= 0} {
444	set xcen $pos
445	set peaklist [lindex $refhkllist $peak]
446	set lbls 1
447	} elseif {abs($xcen/$lbls-$pos) <= $expgui(pixelregion)} {
448	set xcen [expr $xcen + $pos]
449	lappend peaklist [lindex $refhkllist $peak]
450	incr lbls
451	} else {
452	puthkllbl $plot $peaklist $xcen $lbls
453	set xcen $pos
454	set peaklist [lindex $refhkllist $peak]
455	set lbls 1
456	}
457	}
458	}
459	puthkllbl $plot $peaklist $xcen $lbls
460	}
461
462	proc puthkllbl {plot peaklist xcen lbls} {
463	global blt_version tcl_platform tcl_version expgui
464	if {$peaklist == ""} return
465	set xcen [expr $xcen / $lbls]
466	# avoid bug in BLT 2.3 where Inf does not work for text markers
467	if {$blt_version == 2.3} {
468	set ycen [lindex [$plot yaxis limits] 1]
469	} else {
470	set ycen Inf
471	}
472	# older BLT versions can't rotate text in windows
473	if {$tcl_platform(platform) == "windows" && \
474	($blt_version <= 2.3 \|\| $blt_version == 8.0)} {
475	regsub -all { } $peaklist "\n" peaklist
476	set mark [$plot marker create text -coords "$xcen $ycen" \
477	-text $peaklist -anchor n -bg "" -name hkl$xcen]
478	} else {
479	set mark [$plot marker create text -coords "$xcen $ycen" \
480	-rotate 90 -text $peaklist -anchor n -bg "" -name hkl$xcen]
481	}
482	if {$tcl_version >= 8.0} {
483	$plot marker config hkl$xcen -font lblfont
484	}
485	if {$expgui(fadetime) > 0} {
486	catch {
487	after [expr $expgui(fadetime) * 1000 ] \
488	"catch \{ $plot marker delete $mark \}"
489	}
490	}
491	}
492
493	proc delallhkllbl {plot} {
494	catch {
495	eval $plot marker delete [$plot marker names hkl*]
496	}
497	}
498
499	proc plotdata {} {
500	global expnam hst peakinfo xunits yunits cycle reflns modtime
501	global lasthst graph expgui box
502
503	# is there a new histogram to load?
504	if {$hst != $lasthst} {
505	xvec set {}
506	xvec notify now
507	set cycle -1
508	set modtime 0
509	$box config -title "Please wait: loading histogram $hst"
510	update
511	return
512	}
513	$box config -title "$expnam cycle $cycle Hist $hst"
514	$box xaxis config -title $xunits
515	$box yaxis config -title $yunits
516	setlegend $box $graph(legend)
517	# reconfigure the data
518	$box element configure 3 \
519	-symbol $peakinfo(obssym) -color $graph(color_obs) \
520	-pixels [expr 0.125 * $peakinfo(obssize)]i
521	$box element config 0 -color $graph(color_chi2)
522	$box element config 1 -color $graph(color_bkg)
523	$box element config 2 -color $graph(color_calc)
524	$box element config 4 -color $graph(color_diff)
525	global program
526	if {$program == "bkgedit"} {
527	$box element config 12 -color $graph(color_input) \
528	-pixels [expr 0.125 * $peakinfo(inpsize)]i \
529	-symbol $peakinfo(inpsym)
530	$box element config 11 -color $graph(color_fit)
531	}
532	xvec notify now
533	obsvec notify now
534	calcvec notify now
535	bckvec notify now
536	diffvec notify now
537	wifdvec notify now
538	# now deal with peaks
539	for {set i 1} {$i < 10} {incr i} {
540	if {$expgui(autotick)} {
541	set div [expr ( $expgui(max) - $expgui(min) )/40.]
542	set ymin [expr $expgui(min) - ($i+1) * $div]
543	set ymax [expr $expgui(min) - $i * $div]
544	} else {
545	set ymin $peakinfo(min$i)
546	set ymax $peakinfo(max$i)
547	}
548	set j 0
549	if [set peakinfo(flag$i)] {
550	foreach X $reflns($i) {
551	incr j
552	catch {
553	$box marker create line -name peaks${i}_$j
554	}
555	$box marker config peaks${i}_$j -under 1 \
556	-coords "$X $ymin $X $ymax"
557	catch {
558	$box marker config peaks${i}_$j \
559	$graph(MarkerColorOpt) [list $peakinfo(color$i)]
560	if $peakinfo(dashes$i) {
561	$box marker config peaks${i}_$j -dashes "5 5"
562	}
563	}
564	}
565	catch {$box element create phase$i}
566	catch {
567	$box element config phase$i -color $peakinfo(color$i)
568	}
569	} else {
570	eval $box marker delete [$box marker names peaks${i}_*]
571	eval $box element delete [$box element names phase$i]
572	}
573	}
574	# force an update of the plot as BLT may not
575	$box config -title [$box cget -title]
576	update
577	}
578
579	proc setlegend {box legend} {
580	global blt_version
581	if {$blt_version >= 2.3 && $blt_version < 8.0} {
582	if $legend {
583	$box legend config -hide no
584	} else {
585	$box legend config -hide yes
586	}
587	} else {
588	if $legend {
589	$box legend config -mapped yes
590	} else {
591	$box legend config -mapped no
592	}
593	}
594	}
595
596	proc minioptionsbox {num} {
597	global blt_version tcl_platform peakinfo expgui
598	set bx .opt$num
599	catch {destroy $bx}
600	toplevel $bx
601	wm iconname $bx "Phase $num options"
602	wm title $bx "Phase $num options"
603
604	set i $num
605	pack [label $bx.0 -text "Phase $i reflns" ] -side top
606	pack [checkbutton $bx.1 -text "Show reflections" \
607	-variable peakinfo(flag$i)] -side top
608	# remove option that does not work
609	if {$blt_version != 8.0 \|\| $tcl_platform(platform) != "windows"} {
610	pack [checkbutton $bx.2 -text "Use dashed line" \
611	-variable peakinfo(dashes$i)] -side top
612	}
613	if !$expgui(autotick) {
614	pack [frame $bx.p$i -bd 2 -relief groove] -side top
615	# pack [checkbutton $bx.p$i.0 -text "Show phase $i reflns" \
616	# -variable peakinfo(flag$i)] -side left -anchor w
617	pack [label $bx.p$i.1 -text " Y min:"] -side left
618	pack [entry $bx.p$i.2 -textvariable peakinfo(min$i) -width 5] \
619	-side left
620	pack [label $bx.p$i.3 -text " Y max:"] -side left
621	pack [entry $bx.p$i.4 -textvariable peakinfo(max$i) -width 5] \
622	-side left
623	}
624	pack [frame $bx.c$i -bd 2 -relief groove] -side top
625
626	pack [label $bx.c$i.5 -text " color:"] -side left
627	pack [entry $bx.c$i.6 -textvariable peakinfo(color$i) -width 12] \
628	-side left
629	pack [button $bx.c$i.2 -bg $peakinfo(color$i) -state disabled] -side left
630	pack [button $bx.c$i.1 -text "Color\nmenu" \
631	-command "setcolor $i"] -side left
632	pack [frame $bx.b] -side top
633	#pack [button $bx.b.1 -command plotdata -text "Update Plot"] \
634	# -side left
635	pack [button $bx.b.4 -command "destroy $bx" -text Close ] -side right
636	}
637
638	proc setcolor {num} {
639	global peakinfo
640	set color [tk_chooseColor -initialcolor $peakinfo(color$num) -title "Choose color"]
641	if {$color == ""} return
642	set peakinfo(color$num) $color
643	}
644
645	proc makepostscriptout {} {
646	global graph box
647	if !$graph(printout) {
648	set out [open "\| $graph(outcmd) >& liveplot.msg" w]
649	catch {
650	puts $out [$box postscript output -landscape 1 \
651	-decorations no -height 7.i -width 9.5i]
652	close $out
653	} msg
654	catch {
655	set out [open liveplot.msg r]
656	if {$msg != ""} {append msg "\n"}
657	append msg [read $out]
658	close $out
659	catch {file delete liveplot.msg}
660	}
661	if {$msg != ""} {
662	tk_dialog .msg "file created" \
663	"Postscript file processed with command \
664	$graph(outcmd). Result: $msg" "" 0 OK
665	} else {
666	tk_dialog .msg "file created" \
667	"Postscript file processed with command \
668	$graph(outcmd)" "" 0 OK
669	}
670	} else {
671	$box postscript output $graph(outname) -landscape 1 \
672	-decorations no -height 7.i -width 9.5i
673	tk_dialog .msg "file created" \
674	"Postscript file $graph(outname) created" "" 0 OK
675	}
676	}
677
678	proc setprintopt {page} {
679	global graph
680	if $graph(printout) {
681	$page.4.1 config -fg black
682	$page.4.2 config -fg black -state normal
683	$page.6.1 config -fg #888
684	$page.6.2 config -fg #888 -state disabled
685	} else {
686	$page.4.1 config -fg #888
687	$page.4.2 config -fg #888 -state disabled
688	$page.6.1 config -fg black
689	$page.6.2 config -fg black -state normal
690	}
691	}
692
693	proc setpostscriptout {} {
694	global graph tcl_platform
695	set box .out
696	catch {destroy $box}
697	toplevel $box
698	focus $box
699	wm title $box "Set PS options"
700	pack [frame $box.4] -side top -anchor w -fill x
701	pack [checkbutton $box.4.a -text "Write PostScript files" \
702	-variable graph(printout) -offvalue 0 -onvalue 1 \
703	-command "setprintopt $box"] -side left -anchor w
704	pack [entry $box.4.2 -textvariable graph(outname)] -side right -anchor w
705	pack [label $box.4.1 -text "PostScript file name:"] -side right -anchor w
706	pack [frame $box.6] -side top -anchor w -fill x
707	pack [checkbutton $box.6.a -text "Print PostScript files" \
708	-variable graph(printout) -offvalue 1 -onvalue 0 \
709	-command "setprintopt $box" ] -side left -anchor w
710	pack [entry $box.6.2 -textvariable graph(outcmd)] -side right -anchor w
711	pack [label $box.6.1 -text "Command to print files:"] -side right -anchor w
712
713	pack [button $box.a -text "Close" -command "destroy $box"] -side top
714	if {$tcl_platform(platform) == "windows"} {
715	set graph(printout) 1
716	$box.4.a config -state disabled
717	$box.6.a config -fg #888 -state disabled
718	}
719	setprintopt $box
720	}
721
722	proc setlblopts {} {
723	global expgui tcl_platform tcl_version
724	set box .out
725	catch {destroy $box}
726	toplevel $box
727	focus $box
728	wm title $box "Set hkl options"
729	pack [frame $box.c] -side top -anchor w
730	pack [label $box.c.l -text "HKL label\nerase time:"] -side left
731	pack [entry $box.c.e -textvariable expgui(fadetime) -width 8] \
732	-side left
733	pack [label $box.c.l1 -text seconds] -side left
734	pack [frame $box.d] -side top -anchor w
735	pack [label $box.d.l -text "HKL label size:"] -side left
736	pack [entry $box.d.e -textvariable expgui(lblfontsize) -width 4] \
737	-side left
738	pack [label $box.d.l1 -text pixels] -side left
739	# old versions if tcl/tk don't support the font command
740	if {$tcl_version < 8.0} {
741	$box.d.l config -fg #888
742	$box.d.e config -fg #888 -state disabled
743	$box.d.l1 config -fg #888
744	}
745	pack [frame $box.f] -side top -anchor w
746	pack [label $box.f.l -text "HKL search region:"] -side left
747	pack [entry $box.f.e -textvariable expgui(pixelregion) -width 3] \
748	-side left
749	pack [label $box.f.l1 -text pixels] -side left
750	pack [frame $box.e] -side top -anchor w
751	pack [checkbutton $box.e.b -text "Separate window for HKL labels"\
752	-variable expgui(hklbox)] -side left
753	pack [button $box.a -text "Close" -command "destroy $box"] -side top
754	}
755
756	proc getsymopts {"sym obs"} {
757	global expgui peakinfo
758	set box .out
759	catch {destroy $box}
760	toplevel $box
761	focus $box
762	wm title .out "set $sym symbol"
763	pack [frame $box.d] -side left -anchor n
764	pack [label $box.d.t -text "Symbol type"] -side top
765	set expgui(sym) $peakinfo(${sym}sym)
766	set expgui(size) $peakinfo(${sym}size)
767	foreach symbol {square circle diamond triangle plus cross \
768	splus scross} \
769	symbol_name {square circle diamond triangle plus cross \
770	thin-plus thin-cross} {
771	pack [radiobutton $box.d.$symbol \
772	-text $symbol_name -variable expgui(sym) \
773	-value $symbol] -side top -anchor w
774	}
775	pack [frame $box.e] -side left -anchor n -fill y
776	pack [label $box.e.l -text "Symbol Size"] -side top
777	pack [scale $box.e.s -variable expgui(size) \
778	-from .1 -to 3 -resolution 0.05] -side top
779	pack [frame $box.a] -side bottom
780	pack [button $box.a.1 -text "Apply" -command "setsymopts $sym"] -side left
781	pack [button $box.a.2 -text "Close" -command "destroy $box"] -side left
782	}
783	proc setsymopts {sym} {
784	global peakinfo expgui
785	if {$peakinfo(${sym}sym) != $expgui(sym)} {set peakinfo(${sym}sym) $expgui(sym)}
786	if {$peakinfo(${sym}size) != $expgui(size)} {set peakinfo(${sym}size) $expgui(size)}
787	}
788
789	# save some of the global options in ~/.gsas_config
790	proc SaveOptions {} {
791	global graph expgui peakinfo
792	set fp [open [file join ~ .gsas_config] a]
793	foreach v {printout legend outname outcmd autoraise chi2} {
794	puts $fp "set graph($v) $graph($v)"
795	}
796	foreach v {diff chi2 bkg calc obs input fit} {
797	puts $fp "set graph(color_$v) $graph(color_$v)"
798	}
799	foreach v {font lblfontsize fadetime hklbox pixelregion autotick} {
800	puts $fp "set expgui($v) $expgui($v)"
801	}
802	foreach v {obssym obssize inpsym inpsize} {
803	puts $fp "set peakinfo($v) $peakinfo($v)"
804	}
805	close $fp
806	}
807
808	proc aboutliveplot {} {
809	global Revision
810	tk_dialog .warn About "
811	GSAS\n\
812	A. C. Larson and\n R. B. Von Dreele,\n LANSCE, Los Alamos\n\n\
813	LIVEPLOT\nB. Toby, NIST\nNot subject to copyright\n\n\
814	$Revision\n\
815	" {} 0 OK
816	}
817
818	proc getcycle {} {
819	global expnam
820	set cycle -1
821	catch {
822	set fp [open $expnam.EXP r]
823	set text [read $fp]
824	close $fp
825	regexp {GNLS RUN.Total cycles run ([0-9]*) } $text x cycle
826	}
827	return $cycle
828	}
829
830	proc updateifnew {} {
831	global cycle modtime expnam env tcl_platform graph
832	# has the .EXP file been changed?
833	if {[file mtime $expnam.EXP] != $modtime} {
834	# are we in windows and are "locked?" If not, OK to update
835	if {$tcl_platform(platform) == "windows" && [file exists expgui.lck]} {
836	.g config -title "(Experiment directory locked)"
837	} else {
838	set modtime [file mtime $expnam.EXP]
839	set newcycle [getcycle]
840	if {$newcycle != $cycle} {
841	set cycle $newcycle
842	readdata .g
843	}
844	if {$tcl_platform(platform) == "windows" && $graph(autoraise)} {
845	# raise does not seem to be global in Windows,
846	# but this works in Win-95
847	# nothing seems to work in Win-NT
848	wm withdraw .
849	wm deiconify .
850	} elseif {$graph(autoraise)} {
851	raise .
852	}
853	}
854	}
855	# check again in a second
856	after 1000 updateifnew
857	}
858
859	proc plotdataupdate {array element action} {
860	global box peakinfo reflns graph
861	# parse the element
862	regexp {([a-z])([0-9])} $element junk var num
863	if {$var == "color"} {
864	if {$peakinfo($element) == ""} return
865	if [catch {
866	.opt$num.c$num.2 config -bg $peakinfo($element)
867	} ] return
868	set i $num
869	set j 0
870	if [set peakinfo(flag$i)] {
871	catch {
872	$box element config phase$i -color $peakinfo(color$i)
873	}
874	foreach X $reflns($i) {
875	incr j
876	catch {
877	$box marker config peaks${i}_$j \
878	$graph(MarkerColorOpt) [list $peakinfo(color$i)]
879	}
880	}
881	}
882	return
883	}
884	waitmsg {Updating}
885	plotdata
886	donewaitmsg
887	}
888	proc ShowCumulativeChi2 {} {
889	global graph box
890	if $graph(chi2) {
891	eval $box y2axis config $graph(ElementShowOption)
892	eval $box element config 0 $graph(ElementShowOption) -label "Chi2"
893	set cycle [getcycle]
894	readdata .g
895	} else {
896	eval $box element config 0 $graph(ElementHideOption)
897	eval $box y2axis config $graph(ElementHideOption)
898	$box element config 0 -label ""
899	}
900	}
901	# evaluate the Chebyshev polynomial with coefficients A at point x
902	# coordinates are rescaled from $xmin=-1 to $xmax=1
903	proc chebeval {A x xmin xmax} {
904	set xs [expr {-1 + 2 * (1.$x - $xmin) / (1.$xmax - 1.*$xmin)}]
905	set Tpp 0
906	set Tp 0
907	set total 0
908	foreach a $A {
909	if {$Tpp == $Tp && $Tp == 0} {
910	set T 1
911	} elseif {$Tpp == 0} {
912	set T $xs
913	} else {
914	set T [expr {2. * $xs * $Tp - $Tpp}]
915	}
916	set total [expr {$total + $a * $T}]
917	set Tpp $Tp
918	set Tp $T
919	}
920	return $total
921	}
922
923	# determine a very approximate set of Chebyshev coefficients of order n
924	# to compute Y from X (fast but not very good)
925	proc chebgen {X Y xmin xmax n} {
926	if {[llength $X] != [llength $Y]} return
927	set xnorm [expr {2. / ($xmax - $xmin)}]
928	set pi [expr {2*asin(1)}]
929	set a(0) 0.
930	for {set i 1} {$i < $n} {incr i} {set a($i) 0.}
931	foreach x1 $X x2 [lrange $X 1 end] y1 $Y y2 [lrange $Y 1 end] {
932	if {$x2 == ""} break
933	set xs1 [expr {-1 + ($x1 - $xmin) * $xnorm}]
934	set th1 [expr {acos(-1 + ($x1 - $xmin) * $xnorm)}]
935	set xs2 [expr {-1 + ($x2 - $xmin) * $xnorm}]
936	set th2 [expr {acos(-1 + ($x2 - $xmin) * $xnorm)}]
937	set thbar [expr {($th1 + $th2)/2.}]
938	set dth [expr {$th1 - $th2}]
939	set xsbar [expr {cos($thbar)}]
940	set ybar [expr {($xsbar - $xs1) / ($xs2 - $xs1) * ($y2 - $y1) + $y1}]
941	# seems to work better starting with just 2 terms
942	# for {set i 0} {$i < $n} {incr i}
943	for {set i 0} {$i < 2} {incr i} {
944	set a($i) [expr {$a($i) + $ybar * cos($i$thbar) $dth}]
945	}
946	}
947	set A [expr {$a(0) / $pi}]
948	for {set i 1} {$i < $n} {incr i} {
949	lappend A [expr {2 * $a($i) / $pi}]
950	}
951	return $A
952	}
953
954	# disable the improve fit button
955	proc bkgResetFit {} {
956	.bkg.f.fit2 config -state disabled
957	}
958
959	# enable the improve fit button, if appropriate
960	proc bkgMoreFit {} {
961	global cheblist
962	if {[llength $cheblist] < 2} {bkgResetFit;return}
963	.bkg.f.fit2 config -state normal
964	}
965
966	# perform a Gauss-Newton fit to optimize Chebyshev coefficients A
967	proc chebGN {X Y S A xmin xmax "damp 0.75"} {
968	# Gauss-Newton
969	if {[llength $X] != [llength $Y]} return
970	set xnorm [expr {2. / ($xmax - $xmin)}]
971	# denominator
972	set sum2 0.
973	foreach x $X s $S {
974	set xs [expr {-1 + (1.$x - $xmin) $xnorm}]
975	set Tpp 0
976	set Tp 0
977	foreach a1 $A {
978	if {$Tpp == $Tp && $Tp == 0} {
979	set T 1
980	} elseif {$Tpp == 0} {
981	set T $xs
982	} else {
983	set T [expr {2. * $xs * $Tp - $Tpp}]
984	}
985	set sum2 [expr {$sum2 + $T /($s*$s)}]
986	set Tpp $Tp
987	set Tp $T
988	}
989	}
990	# Evaluate Ycalc & sum(delta2)
991	set sumd2 0.
992	foreach x $X y $Y {
993	# set xs [expr {-1 + (1.$x - $xmin) $xnorm}]
994	lappend Ycalc [set yc [chebeval $A $x $xmin $xmax]]
995	set sumd2 [expr {$sumd2 + ($y - $yc)*($y - $yc)}]
996	}
997	set k -1
998	foreach a $A {incr k; set sum($k) 0}
999	foreach x $X y $Y yc $Ycalc s $S {
1000	set xs [expr {-1 + (1.$x - $xmin) $xnorm}]
1001	set Tpp 0
1002	set Tp 0
1003	set k -1
1004	foreach a $A {
1005	incr k
1006	if {$Tpp == $Tp && $Tp == 0} {
1007	set T 1
1008	} elseif {$Tpp == 0} {
1009	set T $xs
1010	} else {
1011	set T [expr {2. * $xs * $Tp - $Tpp}]
1012	}
1013	set sum($k) [expr {$sum($k) + ($T * ($yc - $y))/($s*$s)}]
1014	set Tpp $Tp
1015	set Tp $T
1016	}
1017	}
1018	set sumd2r $sumd2
1019	set d $damp
1020	# compute new cheb terms
1021	while {$d > $damp/32} {
1022	set k -1
1023	set Anew {}
1024	foreach a $A {
1025	incr k
1026	lappend Anew [expr {$a - $d*($sum($k) / $sum2)}]
1027	}
1028	# Evaluate new Ycalc & sum(delta2)
1029	set sumd2r 0.
1030	foreach x $X y $Y {
1031	# set xs [expr {-1 + (1.$x - $xmin) $xnorm}]
1032	set yc [chebeval $Anew $x $xmin $xmax]
1033	set sumd2r [expr {$sumd2r + ($y - $yc)*($y - $yc)}]
1034	}
1035	# are these shifts an improvement?
1036	if {$sumd2r < $sumd2} {
1037	# are we converged?
1038	if {[expr {($sumd2-$sumd2r)/$sumd2}] < 0.0001} {return ""}
1039	return $Anew
1040	}
1041	set d [expr {$d/2.}]
1042	}
1043	return ""
1044	}
1045
1046	# change the binding of the mouse, based on the selected mode
1047	proc bkgEditMode {b} {
1048	global zoomcommand box
1049	# get binding
1050	set bindtag $box
1051	catch {
1052	if {[bind bltZoomGraph] != ""} {
1053	set bindtag bltZoomGraph
1054	}
1055	}
1056	# save the zoom command
1057	if [catch {set zoomcommand}] {
1058	set zoomcommand [bind $bindtag <1>]
1059	.bkg.f.fit1 config -state disabled
1060	.bkg.f.fit2 config -state disabled
1061	.bkg.f.terms config -state disabled
1062	}
1063	foreach c {1 2 3} {
1064	if {$c == $b} {
1065	.bkg.l.b$c config -relief sunken
1066	} else {
1067	.bkg.l.b$c config -relief raised
1068	}
1069	}
1070	# reset previous mode; if in the middle
1071	if {[string trim [bind $box <Motion>]] != ""} {
1072	blt::ResetZoom $box
1073	}
1074	if {$b == 2} {
1075	bind $bindtag <1> "bkgAddPoint %x %y"
1076	.g config -cursor arrow
1077	} elseif {$b == 3} {
1078	bind $bindtag <1> "bkgDelPoint %x %y"
1079	.g config -cursor circle
1080	} else {
1081	bind $bindtag <1> $zoomcommand
1082	.g config -cursor crosshair
1083	}
1084	}
1085
1086	# plot the background points
1087	proc bkgPointPlot {} {
1088	global bkglist termmenu chebterms expnam hst tmin tmax
1089	set l {}
1090	set fp [open $expnam.bkg$hst w]
1091	puts $fp "y p h e $hst b ! fixed background points for use in BKGEDIT"
1092	foreach p $bkglist {
1093	puts $fp "i\t$p\t0.0"
1094	append l " $p"
1095	}
1096	if {[llength $bkglist] > 0} {
1097	puts $fp "i\t[expr $tmin*0.99] [lindex [lindex $bkglist 0] 1]\t0.0"
1098	puts $fp "i\t[expr $tmax*1.01] [lindex [lindex $bkglist end] 1]\t0.0"
1099	}
1100	close $fp
1101	.g element config 12 -data $l
1102	if {[set l [llength $bkglist]] > 3} {
1103	.bkg.f.fit1 config -state normal
1104	.bkg.f.terms config -state normal
1105	$termmenu delete 0 end
1106	set imax {}
1107	for {set i 2} {$i <= $l/1.5} {incr i 2} {
1108	$termmenu insert end radiobutton -label $i \
1109	-variable chebterms -command {bkgMoreFit}
1110	set imax $i
1111	}
1112	if {$imax < $chebterms} {set chebterms $imax}
1113	} else {
1114	.bkg.f.fit1 config -state disabled
1115	.bkg.f.fit2 config -state disabled
1116	.bkg.f.terms config -state disabled
1117	set chebterms 2
1118	}
1119	}
1120
1121	# add a bkg point at screen coordinates x,y
1122	proc bkgAddPoint {x y} {
1123	global bkglist tmin tmax
1124	set xy [.g invtransform $x $y]
1125	set x [lindex $xy 0]
1126	if {$x < $tmin} {set x $tmin}
1127	if {$x > $tmax} {set x $tmax}
1128	lappend bkglist [list $x [lindex $xy 1]]
1129	set bkglist [lsort -real -index 0 $bkglist]
1130	bkgMoreFit
1131	bkgFillPoints
1132	bkgPointPlot
1133	}
1134
1135	# delete the bkg point closest to screen coordinates x,y
1136	proc bkgDelPoint {x y} {
1137	global bkglist
1138	set closest {}
1139	set dist2 {}
1140	set i -1
1141	foreach p $bkglist {
1142	incr i
1143	set sxy [eval .g transform $p]
1144	if {$closest == ""} {
1145	set closest $i
1146	set dist2 0
1147	foreach v1 $sxy v2 "$x $y" {
1148	set dist2 [expr {$dist2 + ($v1 - $v2)*($v1 - $v2)}]
1149	}
1150	} else {
1151	set d2 0
1152	foreach v1 $sxy v2 "$x $y" {
1153	set d2 [expr {$d2 + ($v1 - $v2)*($v1 - $v2)}]
1154	}
1155	if {$d2 < $dist2} {
1156	set closest $i
1157	set dist2 $d2
1158	}
1159	}
1160	}
1161	set bkglist [lreplace $bkglist $closest $closest]
1162	bkgMoreFit
1163	bkgPointPlot
1164	bkgFillPoints
1165	}
1166
1167	# initialize the background plot
1168	proc bkghstInit {} {
1169	global bkglist tmin tmax hst expnam cheblist chebterms
1170	set tmin [histinfo $hst tmin]
1171	set tmax [histinfo $hst tmax]
1172	if {[catch {expr $tmin}] \|\| [catch {expr $tmax}]} {
1173	tk_dialog .err "MIN/MAX Error" "Error -- Unable read tmin or tmax (has POWPREF been run?" \
1174	error 0 Quit
1175	destroy .
1176	}
1177
1178	set bkglist {}
1179	if [file exists $expnam.bkg$hst] {
1180	catch {
1181	set fp [open $expnam.bkg$hst r]
1182	gets $fp line
1183	while {[gets $fp line]>=0} {
1184	set x [lindex $line 1]
1185	set y [lindex $line 2]
1186	if {$x >= $tmin && $x <= $tmax} {
1187	lappend bkglist [list $x $y]
1188	}
1189	}
1190	}
1191	close $fp
1192	}
1193
1194	bkgEditMode 1
1195	bkgPointPlot
1196	bkgFillPoints
1197	set cheblist ""
1198	bkgResetFit
1199	BkgFillCheb
1200	set chebterms 2
1201	}
1202
1203	# fit a Chebyshev polynomial to the selected background points
1204	proc bkgFit {termlist button} {
1205	global bkglist chebterms cheblist
1206	$button config -relief sunken
1207	update
1208	foreach p $bkglist {
1209	lappend S 1.
1210	foreach v $p var {X Y} {
1211	lappend $var $v
1212	}
1213	}
1214	global tmin tmax
1215	if {[llength $termlist] < 2} {
1216	# get a starting point
1217	set termlist [chebgen $X $Y $tmin $tmax $chebterms]
1218	# plot it
1219	set calcb {}
1220	foreach x [xvec range 0 end] {
1221	lappend calcb [chebeval $termlist $x $tmin $tmax]
1222	}
1223	.g element configure 11 -xdata xvec -ydata $calcb
1224	update
1225	} elseif {[llength $termlist] < $chebterms} {
1226	while {[llength $termlist] < $chebterms} {
1227	lappend termlist 0.
1228	}
1229	} elseif {[llength $termlist] > $chebterms} {
1230	set termlist [lrange $termlist 0 [expr $chebterms -1]]
1231	}
1232	# iterate
1233	for {set i 1} {$i < 20} {incr i} {
1234	set termlist1 [chebGN $X $Y $S $termlist $tmin $tmax]
1235	# have we converged?
1236	if {$termlist1 == ""} {
1237	bkgResetFit
1238	set cheblist $termlist
1239	BkgFillCheb
1240	bkgFillPoints
1241	$button config -relief raised
1242	return
1243	}
1244	set termlist $termlist1
1245	set calcb {}
1246	foreach x [xvec range 0 end] {
1247	lappend calcb [chebeval $termlist $x $tmin $tmax]
1248	}
1249	.g element configure 11 -xdata xvec -ydata $calcb
1250	update
1251	}
1252	set cheblist $termlist
1253	BkgFillCheb
1254	bkgFillPoints
1255	bkgMoreFit
1256	$button config -relief raised
1257	}
1258
1259	# put the Chebyshev coefficients into edit widgets
1260	proc BkgFillCheb {} {
1261	global cheblist
1262	global chebedit
1263	catch {destroy .bkg.canvas.fr}
1264	set top [frame .bkg.canvas.fr]
1265	.bkg.canvas create window 0 0 -anchor nw -window $top
1266	# delete trace on chebedit
1267	foreach v [ trace vinfo chebedit] {
1268	eval trace vdelete chebedit $v
1269	}
1270	if {[llength $cheblist] == 0} {
1271	grid [label $top.0 -text "(no terms defined)"] -col 1 -row 1
1272	.bkg.cw config -state disabled
1273	} else {
1274	set i -1
1275	.bkg.cw config -state normal
1276	foreach c $cheblist {
1277	incr i
1278	grid [frame $top.$i -relief groove -bd 3] -col $i -row 1
1279	grid [label $top.$i.l -text "[expr 1+$i]"] -col 1 -row 1
1280	grid [entry $top.$i.e -textvariable chebedit($i) -width 13] \
1281	-col 2 -row 1
1282	set chebedit($i) $c
1283	}
1284	trace variable chebedit w "BkgRecalcCheb $top"
1285	}
1286	update idletasks
1287	set sizes [grid bbox $top]
1288	.bkg.canvas config -scrollregion $sizes -height [lindex $sizes 3]
1289	}
1290
1291	# respond to edits made to Chebyshev terms
1292	proc BkgRecalcCheb {top var i mode} {
1293	global chebedit cheblist
1294	if [catch {expr $chebedit($i)}] {
1295	$top.$i.e config -fg red
1296	} else {
1297	$top.$i.e config -fg black
1298	set cheblist [lreplace $cheblist $i $i $chebedit($i)]
1299	global tmin tmax
1300	# plot it
1301	set calcb {}
1302	foreach x [xvec range 0 end] {
1303	lappend calcb [chebeval $cheblist $x $tmin $tmax]
1304	}
1305	.g element configure 11 -xdata xvec -ydata $calcb
1306	update
1307	bkgMoreFit
1308	}
1309	}
1310
1311	# put the bkg points into edit widgets
1312	proc bkgFillPoints {} {
1313	global bkglist tmin tmax bkgedit
1314	# delete trace on bkgedit
1315	foreach v [ trace vinfo bkgedit] {
1316	eval trace vdelete bkgedit $v
1317	}
1318	catch {destroy .bkg.bc.fr}
1319	set top [frame .bkg.bc.fr]
1320	.bkg.bc create window 0 0 -anchor nw -window $top
1321	if {[llength $bkglist] == 0} {
1322	grid [label $top.0 -text "(no points defined)"] -col 1 -row 1
1323	} else {
1324	set i -1
1325	foreach p $bkglist {
1326	incr i
1327	grid [frame $top.$i -relief groove -bd 3] -col $i -row 1
1328	grid [label $top.$i.l -text "[expr 1+$i]"] -col 1 -rowspan 2 -row 1
1329	grid [entry $top.$i.ex -textvariable bkgedit(x$i) -width 13] \
1330	-col 2 -row 1
1331	grid [entry $top.$i.ey -textvariable bkgedit(y$i) -width 13] \
1332	-col 2 -row 2
1333	foreach val $p var {x y} {
1334	set bkgedit(${var}$i) $val
1335	}
1336	}
1337	trace variable bkgedit w "BkgRecalcBkg $top"
1338	}
1339	update idletasks
1340	set sizes [grid bbox $top]
1341	.bkg.bc config -scrollregion $sizes -height [lindex $sizes 3]
1342	}
1343
1344	# respond to edits made to bkg points
1345	proc BkgRecalcBkg {top var i mode} {
1346	global bkgedit bkglist tmin tmax
1347	regexp {(.)([0-9]*)} $i junk var num
1348	if [catch {expr $bkgedit($i)}] {
1349	$top.$num.e$var config -fg red
1350	} else {
1351	$top.$num.e$var config -fg black
1352	set p [lindex $bkglist $num]
1353	if {$var == "x"} {
1354	set x $bkgedit($i)
1355	if {$x < $tmin} {set x $tmin}
1356	if {$x > $tmax} {set x $tmax}
1357	set bkglist [lreplace $bkglist $num $num \
1358	[list $x [lindex $p 1]]]
1359	} else {
1360	set bkglist [lreplace $bkglist $num $num \
1361	[list [lindex $p 0] $bkgedit($i)]]
1362	}
1363	}
1364	bkgPointPlot
1365	}
1366
1367	# save the Chebyshev terms in the .EXP file
1368	proc bkgChebSave {} {
1369	global hst cheblist expgui Revision expmap expnam
1370	histinfo $hst backtype set 1
1371	histinfo $hst backterms set [llength $cheblist]
1372	set num 0
1373	foreach v $cheblist {
1374	set var "bterm[incr num]"
1375	histinfo $hst $var set $v
1376	}
1377	histinfo $hst bref set 0
1378	# add a history record
1379	exphistory add " BKGEDIT [lindex $Revision 1] [lindex $expmap(Revision) 1] -- [clock format [clock seconds]]"
1380	# now save the file
1381	expwrite $expnam.EXP
1382	}
1383
1384	#-------------------------------------------------------------------------
1385	# manual zoom option
1386	proc BLTmanualZoom {} {
1387	global graph
1388	catch {toplevel .zoom}
1389	eval destroy [grid slaves .zoom]
1390	raise .zoom
1391	wm title .zoom {Manual Scaling}
1392	grid [label .zoom.l1 -text minimum] -row 1 -column 2
1393	grid [label .zoom.l2 -text maximum] -row 1 -column 3
1394	grid [label .zoom.l3 -text x] -row 2 -column 1
1395	grid [label .zoom.l4 -text y] -row 3 -column 1
1396	grid [entry .zoom.xmin -textvariable graph(xmin) -width 10] -row 2 -column 2
1397	grid [entry .zoom.xmax -textvariable graph(xmax) -width 10] -row 2 -column 3
1398	grid [entry .zoom.ymin -textvariable graph(ymin) -width 10] -row 3 -column 2
1399	grid [entry .zoom.ymax -textvariable graph(ymax) -width 10] -row 3 -column 3
1400	grid [frame .zoom.b] -row 4 -column 1 -columnspan 3
1401	grid [button .zoom.b.1 -text "Set Scaling" \
1402	-command "SetManualZoom set"] -row 4 -column 1 -columnspan 2
1403	grid [button .zoom.b.2 -text Reset \
1404	-command "SetManualZoom clear"] -row 4 -column 3
1405	grid [button .zoom.b.3 -text Close -command "destroy .zoom"] -row 4 -column 4
1406	grid rowconfigure .zoom 1 -weight 1 -pad 5
1407	grid rowconfigure .zoom 2 -weight 1 -pad 5
1408	grid rowconfigure .zoom 3 -weight 1 -pad 5
1409	grid rowconfigure .zoom 4 -weight 0 -pad 5
1410	grid columnconfigure .zoom 1 -weight 1 -pad 20
1411	grid columnconfigure .zoom 1 -weight 1
1412	grid columnconfigure .zoom 3 -weight 1 -pad 10
1413	foreach item {min min max max} \
1414	format {3 2 3 2} \
1415	axis {x y x y} {
1416	set val [$graph(blt) ${axis}axis cget -${item}]
1417	set graph(${axis}${item}) {(auto)}
1418	catch {set graph(${axis}${item}) [format %.${format}f $val]}
1419	}
1420	}
1421
1422	proc SetManualZoom {mode} {
1423	global graph
1424	if {$mode == "clear"} {
1425	foreach item {xmin ymin xmax ymax} {
1426	set graph($item) {(auto)}
1427	}
1428	}
1429	foreach item {xmin ymin xmax ymax} {
1430	set $item {}
1431	catch {set $item [expr $graph($item)]}
1432	}
1433	# reset the zoomstack
1434	catch {Blt_ZoomStack $graph(blt)}
1435	catch {$graph(blt) xaxis config -min $xmin -max $xmax}
1436	catch {$graph(blt) yaxis config -min $ymin -max $ymax}
1437	}
1438
1439	source [file join $expgui(scriptdir) gsascmds.tcl]
1440	source [file join $expgui(scriptdir) readexp.tcl]
1441	source [file join $expgui(scriptdir) opts.tcl]
1442
1443	# override options with locally defined values
1444	if [file exists [file join $expgui(scriptdir) localconfig]] {
1445	source [file join $expgui(scriptdir) localconfig]
1446	}
1447	if [file exists [file join ~ .gsas_config]] {
1448	source [file join ~ .gsas_config]
1449	}
1450	SetTkDefaultOptions $expgui(font)
1451
1452	if [file executable [file join $expgui(gsasexe) $expgui(tcldump)]] {
1453	set expgui(tcldump) [file join $expgui(gsasexe) $expgui(tcldump)]
1454	# puts "got tcldump"
1455	} else {
1456	set expgui(tcldump) {}
1457	# puts "no tcldump"
1458	}
1459
1460	# vectors
1461	foreach vec {xvec obsvec calcvec bckvec diffvec refposvec wifdvec} {
1462	vector $vec
1463	$vec notify never
1464	}
1465	# create the graph
1466	if [catch {
1467	set box [graph .g -plotbackground white]
1468	} errmsg] {
1469	tk_dialog .err "BLT Error" \
1470	"BLT Setup Error: could not create a graph (msg: $errmsg). \
1471	There is a problem with the setup of BLT on your system.
1472	See the expgui.html file for more info." \
1473	error 0 "Quit"
1474	exit
1475	}
1476	if [catch {
1477	Blt_ZoomStack $box
1478	} errmsg] {
1479	tk_dialog .err "BLT Error" \
1480	"BLT Setup Error: could not access a Blt_ routine (msg: $errmsg). \
1481	The pkgIndex.tcl is probably not loading bltGraph.tcl.
1482	See the expgui.html file for more info." \
1483	error 0 "Limp ahead"
1484	}
1485	# modify zoom so that y2axis is not zoomed in for blt2.4u+
1486	catch {
1487	regsub -all y2axis [info body blt::PushZoom] " " b1
1488	proc blt::PushZoom {graph} $b1
1489	}
1490
1491	$box element create 0 -xdata xvec -ydata wifdvec -color $graph(color_chi2) \
1492	-line 3 -symbol none -label "Chi2" -mapy y2
1493	$box element create 1 -label bckgr -symbol none
1494	$box element config 1 -xdata xvec -ydata bckvec -color $graph(color_bkg)
1495	$box element create 3 -color $graph(color_obs) -linewidth 0 -label Obs \
1496	-symbol $peakinfo(obssym) \
1497	-pixels [expr 0.125 * $peakinfo(obssize)]i
1498	$box element create 2 -label Calc -color $graph(color_calc) -symbol none
1499	$box element create 4 -label diff -color $graph(color_diff) -symbol none
1500
1501	if {$program == "liveplot"} {
1502	$box y2axis config -min 0 -title {Cumulative Chi Squared}
1503	} elseif {$program == "bkgedit"} {
1504	eval $box element config 0 $graph(ElementHideOption)
1505	eval $box y2axis config $graph(ElementHideOption)
1506	$box element config 0 -label ""
1507	eval $box element config 1 $graph(ElementHideOption)
1508	$box element config 1 -label ""
1509	eval $box element config 4 $graph(ElementHideOption)
1510	$box element config 4 -label ""
1511	$box element create 11
1512	$box element create 12
1513	$box element configure 12 -color $graph(color_input) \
1514	-pixels [expr 0.125 * $peakinfo(inpsize)]i \
1515	-line 0 -symbol $peakinfo(inpsym) -label "bkg pts"
1516	$box element configure 11 -color $graph(color_fit) \
1517	-symbol none -label "Cheb fit" -dashes 5 -line 2
1518	$box element show "3 2 11 12"
1519	}
1520	$box element config 3 -xdata xvec -ydata obsvec
1521	$box element config 2 -xdata xvec -ydata calcvec
1522	$box element config 4 -xdata xvec -ydata diffvec
1523
1524	if {$expgui(tcldump) != ""} {
1525	bind . <Key-h> "lblhkl $box %x"
1526	bind . <Key-H> "lblhkl $box %x"
1527	bind . <Key-a> "lblhkl $box all"
1528	bind . <Key-A> "lblhkl $box all"
1529	bind . <Key-d> "delallhkllbl $box"
1530	bind . <Key-D> "delallhkllbl $box"
1531	if {[bind bltZoomGraph] != ""} {
1532	bind bltZoomGraph <Shift-Button-1> "lblhkl $box %x"
1533	bind bltZoomGraph <Shift-Button-3> "delallhkllbl %W"
1534	} else {
1535	bind $box <Shift-Button-1> "lblhkl $box %x"
1536	bind $box <Shift-Button-3> "delallhkllbl %W"
1537	}
1538	} else {
1539	$box element config 1 -label ""
1540	eval $box element config 4 $graph(ElementHideOption)
1541	}
1542	bind . <Key-z> {BLTmanualZoom}
1543	bind . <Key-Z> {BLTmanualZoom}
1544
1545	$box yaxis config -title {}
1546	setlegend $box $graph(legend)
1547
1548	frame .a -bd 3 -relief groove
1549	pack [menubutton .a.file -text File -underline 0 -menu .a.file.menu] -side left
1550	menu .a.file.menu
1551	.a.file.menu add cascade -label Tickmarks -menu .a.file.menu.tick
1552	menu .a.file.menu.tick
1553	foreach num {1 2 3 4 5 6 7 8 9} {
1554	.a.file.menu.tick add checkbutton -label "Phase $num" \
1555	-variable peakinfo(flag$num) \
1556	-command plotdata
1557	}
1558	.a.file.menu add cascade -label Histogram -menu .a.file.menu.hist -state disabled
1559	.a.file.menu add command -label "Update Plot" \
1560	-command {set cycle [getcycle];readdata .g}
1561	.a.file.menu add command -label "Make PostScript" -command makepostscriptout
1562	.a.file.menu add command -label Quit -command "destroy ."
1563
1564	pack [menubutton .a.options -text Options -underline 0 -menu .a.options.menu] \
1565	-side left
1566	menu .a.options.menu
1567	.a.options.menu add cascade -label "Configure Tickmarks" -menu .a.options.menu.tick
1568	menu .a.options.menu.tick
1569	.a.options.menu.tick add radiobutton -label "Manual Placement" \
1570	-value 0 -variable expgui(autotick) -command plotdata
1571	.a.options.menu.tick add radiobutton -label "Auto locate" \
1572	-value 1 -variable expgui(autotick) -command plotdata
1573	.a.options.menu.tick add separator
1574	foreach num {1 2 3 4 5 6 7 8 9} {
1575	.a.options.menu.tick add command -label "Phase $num" \
1576	-command "minioptionsbox $num"
1577	}
1578	if {$program == "liveplot"} {
1579	.a.options.menu add command -label "Obs symbol" -command getsymopts
1580	} else {
1581	.a.options.menu add cascade -label "Symbol Type" -menu .a.options.menu.sym
1582	menu .a.options.menu.sym
1583	foreach var {obs inp} lbl {Observed "Input bkg"} {
1584	.a.options.menu.sym add command -label $lbl -command "getsymopts $var"
1585	}
1586	}
1587	.a.options.menu add cascade -label "Symbol color" -menu .a.options.menu.color
1588	menu .a.options.menu.color
1589	set l1 {obs calc diff bkg chi2}
1590	set l2 {Observed Calculated Obs-Calc Background Cumulative-Chi2}
1591	if {$program != "liveplot"} {
1592	lappend l1 input fit
1593	lappend l2 "Input points" "Cheb. fit"
1594	}
1595
1596	foreach var $l1 lbl $l2 {
1597	.a.options.menu.color add command -label $lbl \
1598	-command "set graph(color_$var) \[tk_chooseColor -initialcolor \$graph(color_$var) -title \"Choose \$lbl color\"]; plotdata"
1599	}
1600	if {$expgui(tcldump) != "" && $program == "liveplot"} {
1601	.a.options.menu add cascade -label "X units" -menu .a.options.menu.xunits
1602	menu .a.options.menu.xunits
1603	.a.options.menu.xunits add radiobutton -label "As collected" \
1604	-variable graph(xunits) -value 0 \
1605	-command {set cycle [getcycle];readdata .g}
1606	.a.options.menu.xunits add radiobutton -label "d-space" \
1607	-variable graph(xunits) -value 1 \
1608	-command {set cycle [getcycle];readdata .g}
1609	.a.options.menu.xunits add radiobutton -label "Q" \
1610	-variable graph(xunits) -value 2 \
1611	-command {set cycle [getcycle];readdata .g}
1612	.a.options.menu add cascade -label "Y units" -menu .a.options.menu.yunits
1613	menu .a.options.menu.yunits
1614	.a.options.menu.yunits add radiobutton -label "As collected" \
1615	-variable graph(yunits) -value 0 \
1616	-command {set cycle [getcycle];readdata .g}
1617	.a.options.menu.yunits add radiobutton -label "Normalized" \
1618	-variable graph(yunits) -value 1 \
1619	-command {set cycle [getcycle];readdata .g}
1620	.a.options.menu add command -label "HKL labeling" -command setlblopts
1621	.a.options.menu add checkbutton -label "Subtract background" \
1622	-variable graph(backsub) \
1623	-command {set cycle [getcycle];readdata .g}
1624	} else {
1625	set graph(xunits) 0
1626	}
1627
1628	.a.options.menu add checkbutton -label "Include legend" \
1629	-variable graph(legend) \
1630	-command {setlegend $box $graph(legend)}
1631	.a.options.menu add command -label "Set PS output" -command setpostscriptout
1632	.a.options.menu add cascade -menu .a.options.menu.font \
1633	-label "Screen font"
1634	menu .a.options.menu.font
1635	foreach f {10 11 12 13 14 16 18 20 22} {
1636	.a.options.menu.font add radiobutton \
1637	-command {SetTkDefaultOptions $expgui(font); ResizeFont .} \
1638	-label $f -value $f -variable expgui(font) -font "Helvetica -$f"
1639	}
1640	if {$program == "liveplot"} {
1641	.a.options.menu add checkbutton -label "Raise on update" \
1642	-variable graph(autoraise)
1643	.a.options.menu add checkbutton -label "Cumulative Chi2" \
1644	-variable graph(chi2) -command ShowCumulativeChi2
1645	.a.options.menu add command -label "Save Options" -underline 1 \
1646	-command "SaveOptions"
1647	ShowCumulativeChi2
1648	} elseif {$program == "bkgedit"} {
1649	catch {pack [frame .bkg -bd 3 -relief sunken] -side bottom -fill both}
1650	grid [label .bkg.top -text "Background Point Editing"] \
1651	-col 0 -row 0 -columnspan 4
1652	grid [button .bkg.help -text Help -bg yellow \
1653	-command "MakeWWWHelp liveplot.html bkgedit"] \
1654	-column 5 -row 0 -rowspan 2 -sticky n
1655
1656	grid [frame .bkg.l -bd 3 -relief groove] \
1657	-col 0 -row 1 -columnspan 2 -sticky nse
1658	grid [label .bkg.l.1 -text "Mouse click\naction"] -col 0 -row 0
1659	foreach c {1 2 3} l {zoom add delete} {
1660	grid [button .bkg.l.b$c -text $l -command "bkgEditMode $c"] \
1661	-col $c -row 0
1662	}
1663	grid [frame .bkg.f -bd 3 -relief groove] \
1664	-col 3 -row 1 -columnspan 2 -sticky nsw
1665	grid [button .bkg.f.fit1 -text "Start\nFit" -command {bkgFit "" .bkg.f.fit1}] \
1666	-col 1 -row 1
1667	grid [button .bkg.f.fit2 -text "Improve\nFit" \
1668	-command {bkgFit $cheblist .bkg.f.fit2}] -col 2 -row 1
1669	grid [label .bkg.f.tl -text "with"] -col 3 -row 1
1670	set termmenu [tk_optionMenu .bkg.f.terms chebterms 0]
1671	grid .bkg.f.terms -col 4 -row 1
1672	grid [label .bkg.f.tl1 -text "terms"] -col 5 -row 1
1673
1674	grid [frame .bkg.c1 -bd 3 -relief groove] \
1675	-col 0 -row 5 -rowspan 2 -sticky nsew
1676	grid [label .bkg.c1.1 -text "Chebyshev\nterms"] -col 0 -row 0
1677	grid [canvas .bkg.canvas \
1678	-scrollregion {0 0 5000 500} -width 0 -height 0 \
1679	-xscrollcommand ".bkg.scroll set"] \
1680	-column 1 -row 5 -columnspan 3 -sticky nsew
1681	grid [scrollbar .bkg.scroll -command ".bkg.canvas xview" \
1682	-orient horizontal] -column 1 -row 6 -columnspan 3 -sticky nsew
1683	grid [button .bkg.cw -text "Save in EXP\nfile & Exit" \
1684	-command "bkgChebSave;exit"] \
1685	-col 4 -columnspan 2 -row 5 -rowspan 2 -sticky ns
1686
1687	grid [frame .bkg.bl -bd 3 -relief groove] \
1688	-col 0 -row 3 -rowspan 2 -sticky nsew
1689	grid [label .bkg.bl.1 -text "Background\npoints"] -col 0 -row 0
1690	grid [canvas .bkg.bc \
1691	-scrollregion {0 0 5000 500} -width 0 -height 0 \
1692	-xscrollcommand ".bkg.bs set"] \
1693	-column 1 -row 3 -columnspan 5 -sticky nsew
1694	grid [scrollbar .bkg.bs -command ".bkg.bc xview" -orient horizontal] \
1695	-column 1 -row 4 -columnspan 5 -sticky nsew
1696
1697	grid columnconfigure .bkg 1 -weight 1
1698	grid columnconfigure .bkg 2 -weight 1
1699	grid columnconfigure .bkg 3 -weight 1
1700	grid rowconfigure .bkg 3 -weight 1
1701	grid rowconfigure .bkg 5 -weight 1
1702	.g config -title ""
1703	}
1704
1705	pack [menubutton .a.help -text Help -underline 0 -menu .a.help.menu] -side right
1706	menu .a.help.menu -tearoff 0
1707	.a.help.menu add command -command "MakeWWWHelp liveplot.html" -label "Web page"
1708	.a.help.menu add command -command aboutliveplot -label About
1709
1710	pack .a -side top -fill both
1711	pack $box -fill both -expand yes
1712
1713	# add the extra options
1714	set fl [file join $expgui(scriptdir) icddcmd.tcl]
1715	if [file exists $fl] {source $fl}
1716	set fl [file join $expgui(scriptdir) cellgen.tcl]
1717	if [file exists $fl] {source $fl}
1718
1719	expload $expnam.EXP
1720	mapexp
1721
1722	# fill the histogram menu
1723	if {[llength $expmap(powderlist)] > 15} {
1724	set expgui(plotlist) {}
1725	.a.file.menu entryconfigure Histogram -state normal
1726	menu .a.file.menu.hist
1727	set i 0
1728	foreach num [lsort -integer $expmap(powderlist)] {
1729	incr i
1730	# for now include, but disable histograms
1731	set state disabled
1732	if {[string range $expmap(htype_$num) 3 3] != "*"} {
1733	set state normal
1734	lappend expgui(plotlist) $num
1735	}
1736	if {$i == 1} {
1737	set num1 $num
1738	menu .a.file.menu.hist.$num1
1739	}
1740	.a.file.menu.hist.$num1 add radiobutton -label $num -value $num \
1741	-variable hst -state $state \
1742	-command {set cycle [getcycle];readdata .g}
1743	if {$i >= 10} {
1744	set i 0
1745	.a.file.menu.hist add cascade -label "$num1-$num" \
1746	-menu .a.file.menu.hist.$num1
1747	}
1748	}
1749	if {$i != 0} {
1750	.a.file.menu.hist add cascade -label "$num1-$num" \
1751	-menu .a.file.menu.hist.$num1
1752	}
1753	} elseif {[llength $expmap(powderlist)] > 1} {
1754	set expgui(plotlist) {}
1755	.a.file.menu entryconfigure Histogram -state normal
1756	menu .a.file.menu.hist
1757	foreach num [lsort -integer $expmap(powderlist)] {
1758	# for now include, but disable unprocessed histograms
1759	set state disabled
1760	if {[string range $expmap(htype_$num) 3 3] != "*"} {
1761	set state normal
1762	lappend expgui(plotlist) $num
1763	}
1764	.a.file.menu.hist add radiobutton -label $num -value $num \
1765	-variable hst -state $state \
1766	-command {set cycle [getcycle];readdata .g}
1767	}
1768	} else {
1769	set expgui(plotlist) [lindex $expmap(powderlist) 0]
1770	}
1771	# N = load next histogram
1772	bind . <Key-n> {
1773	set i [lsearch $expgui(plotlist) $hst]
1774	incr i
1775	if {$i >= [llength $expgui(plotlist)]} {set i 0}
1776	set hst [lindex $expgui(plotlist) $i]
1777	set cycle [getcycle];readdata .g
1778	}
1779	bind . <Key-N> {
1780	set i [lsearch $expgui(plotlist) $hst]
1781	incr i
1782	if {$i >= [llength $expgui(plotlist)]} {set i 0}
1783	set hst [lindex $expgui(plotlist) $i]
1784	set cycle [getcycle];readdata .g
1785	}
1786	updateifnew
1787	donewaitmsg
1788	trace variable peakinfo w plotdataupdate

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

Download in other formats:

Original Format