Context Navigation

prepare @ 89

Last change on this file since 89 was 17, checked in by ajj, 16 years ago
Changes made to show BT5 relevant motors in buffer display
Property svn:executable set to ``*
File size: 190.9 KB

Line
1	#!/usr/bin/wish
2	#
3	# Prepare - Instrument Control Program buffer editor
4	#
5	# Dr. Nicholas C. Maliszewskyj - NIST Center for Neutron Research
6	#
7	# Changelog - June 2000 Initial revision in CVS - NCM
8	# Jan 2001 Automon, Sequence editor, Configuration - NCM/BHT
9	# Feb 2001 Customize further by adding mon choices - NCM/BHT
10	# Aug 2001 Change null padding to space padding in buffer writes
11	# Sep 2001 Modify to run with either wish or cwsh
12	# (text-based wish) - JC/NCM
13	# May 2002 Automon fixes, use of classes to dictate fonts
14	# add DisableWidget command, etc - BHT
15	# Jul 2002 Enable Bragg buffers - NCM
16	# Jan 2003 Finally correct problem of shifting elements in
17	# buffer summary window. Make sure changes registered
18	# after bufop - NCM
19	# Mar 2003 Add support for diffraction buffers - NCM
20	# Mar 2004 Change packing of GUI to permit expansion of buf list
21	# Fix buffer copy bug - KOD
22	# May 2006 Change contents of I-Buffer list to show relevant
23	# motors for BT5 - AJJ
24	set version {$Id: prepare.tcl,v 1.47 2005/08/11 19:55:25 nickm Exp $}
25	# set tcl_precision 12
26	#set config(root) $env(HOME)
27	set config(root) /usr/local/icp
28	switch -regexp [info nameofexecutable] {
29	"cwsh" { set text_only 1 }
30	default { wm withdraw .; update; set text_only 0 }
31	}
32
33	#=Global variables=============================================================
34	# ibuf_fields
35	# ibuf
36	# ibufdisp
37	# qbuf_fields
38	# qbuf
39	# qbufdisp
40	# bbuf_fields
41	# bbuf
42	# bbufdisp
43	# tbuf_fields
44	# tbuf
45	# tbufdisp
46	# rbuf_fields
47	# rbuf
48	# rbufdisp
49	# dbuf_fields
50	# dbuf
51	# dbufdisp
52	#
53	# changed
54	# monrec
55	set ibuf_fields { a1beg a1end a1inc a2beg a2end a2inc a3beg a3end a3inc \
56	a4beg a4end a4inc a5beg a5end a5inc a6beg a6end a6inc \
57	comment ter th th0 mon mt mpf t0 it tw pts \
58	flip1 flip2 flip3 flip4 hf ihf hfw hfh }
59
60	set qbuf_fields { comment a b c aa bb cc ec es ef eft \
61	hc kc lc hs ks ls pts \
62	hkl11 hkl12 hkl13 a1 hkl21 hkl22 hkl23 hkl1 hkl2 \
63	tmp it tw th0 ter hf mon mpf mt flip1 flip2 flip3 flip4 \
64	ihf hfw hfh th }
65
66	set bbuf_fields { comment a b c aa bb cc ec es ef eft \
67	hc kc lc hs ks ls pts \
68	hkl11 hkl12 hkl13 a1 hkl21 hkl22 hkl23 hkl1 hkl2 \
69	tmp it tw th0 ter hf mon mpf mt flip1 flip2 flip3 flip4 \
70	a_1 a_2 a_3 a_4 a_5 a_6 \
71	i_1 i_2 i_3 i_4 i_5 i_6 \
72	r_3 r_4 \
73	ihf hfw hfh th }
74
75	set tbuf_fields { comment ec es ef m3 \
76	tmp it tw th0 ter hf mon mpf pts \
77	mt ihf hfw hfh th }
78
79	set rbuf_fields { comment pts qx qxi qz qzi scan_mode \
80	s_1 s_2 s_3 s_4 i_1 i_2 i_3 i_4 \
81	tmp it tw th0 ter hf mon0 mon1 exp mpf \
82	mt flip1 flip2 flip3 flip4 numx sx ix \
83	ihf hfw hfh th }
84
85	set dbuf_fields { comment lpn_1 lpn_2 lpn_3 lpn_4 lpn_5 lpn_6 \
86	lpts_1 lpts_2 lpts_3 lpts_4 lpts_5 lpts_6 \
87	mn_1 mn_2 mn_3 mn_4 mn_5 mn_6 \
88	a_1 a_2 a_3 a_4 a_5 a_6 \
89	i_1 i_2 i_3 i_4 i_5 i_6 \
90	xyz_1 xyz_2 xyz_3 xyz_4 xyz_5 xyz_6 \
91	a_xyz_1 a_xyz_2 a_xyz_3 a_xyz_4 a_xyz_5 a_xyz_6 \
92	i_xyz_1 i_xyz_2 i_xyz_3 i_xyz_4 i_xyz_5 i_xyz_6 \
93	pts hf phi psi phi_inc psi_inc \
94	tmp it tw th0 ter mon mpf mt flip1 flip2 flip3 flip4 \
95	ihf hfw hfh th }
96
97	array set changed { ibufdisp 0 qbufdisp 0 bbufdisp 0 tbufdisp 0 rbufdisp 0 dbufdisp 0}
98
99	#set monrec(mfile) "$env(HOME)/cfg/MONITOR.REC"
100	set monrec(mfile) "$config(root)/cfg/MONITOR.REC"
101	set monrec(prefix) "deflt"
102	set monrec(user) ""
103	set monrec(sample) ""
104	set monrec(quantity) 1
105	set monrec(power) 20
106	set monrec(beamh) 2
107	set monrec(beamw) 1
108	set monrec(mono) none
109	set monrec(ana) none
110	set monrec(filter) none
111	set monrec(coll) 20-20-99-99
112	set monrec(efix) 14.70
113	set Pi 3.1415926535897932384626433832795
114
115	#=Configuration================================================================
116
117	#
118	# Initialize configuration variables used to customize GUI
119	proc ConfigInit { } {
120	global config env
121
122	set config(cfgfile) $config(root)/cfg/INSTR.CFG
123
124	# set config(nsta) -1
125	set config(ibuf_state) normal
126	set config(tbuf_state) disabled
127	set config(qbuf_state) disabled
128	set config(bbuf_state) disabled
129	set config(rbuf_state) disabled
130	set config(dbuf_state) disabled
131
132	set config(ibuf_mots) {1 2 3 4 5 6}
133	set config(pola_state) normal
134
135	set config(ibufentry) {}
136	set config(tbufentry) {}
137	set config(qbufentry) {}
138	set config(bbufentry) {}
139	set config(rbufentry) {}
140
141	set config(default_buf) increment
142
143	set config(mode) 2 ;# Edit mode: 0=simple, 1=tempctrl, 2=expert
144	set config(mono) default
145	set config(mono_list) default
146
147	set config(instr) default ;# Desired instrument configuration
148	set config(instr_list) default ;# List of instrument configurations
149
150	set config(paranoid) 0 ;# Check for buffer changes to display dialog
151	}
152
153	# Read INSTR.CFG ... just enough to read nsta for the moment
154	proc ConfigRead { } {
155	global config
156
157	if [info exists config(nsta)] { return }
158	if [catch {open $config(cfgfile) r} f] {
159	puts "Could not open config file $config(cfgfile)"
160	return
161	}
162	gets $f
163	gets $f input
164	regsub -all {([ ]+)} [string trimleft $input] { } input
165	set fields [split $input]
166	set nsta [lindex $fields 0]
167	set nmots [lindex $fields 1]
168	# Skip garbage
169	for {set i 0} {$i < 8} {incr i} {
170	gets $f
171	}
172
173	set config(nsta) $nsta
174	# Take care of extra lines for histogramming memory
175	if {$nsta == -1 \|\| $nsta == -7 \|\| $nsta == 8} {
176	gets $f
177	gets $f
178	}
179
180	set config(motlist) {}
181	for {set i 0} {$i < $nmots} {incr i} {
182	gets $f input
183	regsub -all {([ ]+)} [string trimleft $input] { } input
184	set fields [split $input]
185	lappend config(motlist) [lindex $fields 0]
186	}
187	set config(motlist) [lsort -integer $config(motlist)]
188	close $f
189	}
190
191	#
192	# Apply some instrument-specific customizations
193	#
194	proc ConfigCruft { } {
195	global env config text_only
196
197	if {![info exists config(nsta)]} {
198	# Note: tk_dialog returns index of selected button
199	if $text_only {
200	set iname [ck_dialog .instr "Choose Instrument" \
201	"Choose the instrument you will use" \
202	XR0 BT1 BT2 BT4 BT5 BT7 BT8 BT9 NG1 NG5 NG7]
203	} else {
204	set iname [tk_dialog .instr "Choose Instrument" \
205	"Choose the instrument you will use" \
206	question 0 XR0 BT1 BT2 BT4 BT5 BT7 BT8 BT9 NG1 NG5 NG7]
207	}
208
209	switch $iname {
210	0 { set config(nsta) 0 }
211	1 { set config(nsta) 1 }
212	2 { set config(nsta) 2 }
213	3 { set config(nsta) 4 }
214	4 { set config(nsta) 5 }
215	5 { set config(nsta) 7 }
216	6 { set config(nsta) 8 }
217	7 { set config(nsta) 9 }
218	8 { set config(nsta) -1 }
219	9 { set config(nsta) -5 }
220	10 { set config(nsta) -7 }
221	default { set config(nsta) 10 }
222	}
223	}
224
225	switch -- $config(nsta) {
226	0 {
227	set config(qbuf_state) disabled
228	set config(bbuf_state) disabled
229	set config(tbuf_state) disabled
230	set config(rbuf_state) disabled
231	set config(ibuf_mots) { 1 2 3 4 5 6 }
232	set config(pola_state) disabled
233	set config(mono_list) {PG002}
234	}
235	1 {
236	set config(qbuf_state) disabled
237	set config(bbuf_state) disabled
238	set config(tbuf_state) disabled
239	set config(rbuf_state) disabled
240	set config(ibuf_mots) { 3 4 }
241	set config(pola_state) disabled
242	set config(mode) 0
243	set config(mono_list) {Ge311 Cu311 Si531}
244	set config(instr_list) {}
245
246	foreach mon $config(mono_list) {
247	lappend config(instr_list) "$mon-15'"
248	}
249	foreach mon $config(mono_list) {
250	lappend config(instr_list) "$mon-7'"
251	}
252
253	set config(instr) "Cu311-15'"
254
255	# Store monitor rates in cps
256	set config(cps-Ge311-15') 2100
257	set config(cps-Cu311-15') 1100
258	set config(cps-Si531-15') 600
259	set config(cps-Ge311-7') 1050
260	set config(cps-Cu311-7') 550
261	set config(cps-Si531-7') 300
262	# Instrument scientist values for monitor rates
263	if {[catch {source $config(root)/cfg/bt1-mrat.dat} errmsg]} {
264	puts "BT-1 mrat source error = $errmsg"
265	}
266	if [ConfigBT1] { return }
267	set config(paranoid) 1
268	}
269	2 {
270	set config(tbuf_state) disabled
271	set config(rbuf_state) disabled
272	set config(qbuf_state) normal
273	set config(bbuf_state) normal
274	set config(mono_list) {PG002 Heusler}
275	set config(ibuf_mots) { 1 2 3 4 5 6 }
276	}
277	4 {
278	set config(default_buf) trash
279	set config(rbuf_state) disabled
280	set config(pola_state) disabled
281	set config(qbuf_state) normal
282	set config(bbuf_state) normal
283	set config(tbuf_state) normal
284	set config(ibuf_mots) { 1 2 3 4 5 6 }
285	set config(mono_list) {Ge311 Cu311}
286	}
287	5 {
288	set config(qbuf_state) disabled
289	set config(bbuf_state) disabled
290	set config(tbuf_state) disabled
291	set config(rbuf_state) disabled
292	set config(ibuf_mots) { 1 2 3 4 5 6 }
293	set config(pola_state) disabled
294	set config(mono_list) {Si220}
295	}
296	7 {
297	set config(default_buf) increment
298	set config(tbuf_state) disabled
299	set config(rbuf_state) disabled
300	set config(ibuf_mots) { 3 4 5 6 }
301	set config(pola_state) disabled
302	set config(mono_list) {PG002}
303	}
304	8 {
305	set config(default_buf) diffraction
306	set config(ibuf_state) disabled
307	set config(tbuf_state) disabled
308	set config(qbuf_state) disabled
309	set config(bbuf_state) disabled
310	set config(rbuf_state) disabled
311	set config(dbuf_state) normal
312	set config(pola_state) disabled
313	set config(mono_list) {PG002}
314	}
315	9 {
316	set config(tbuf_state) disabled
317	set config(rbuf_state) disabled
318	set config(pola_state) disabled
319	set config(qbuf_state) normal
320	set config(bbuf_state) normal
321	set config(mono_list) {Si111 PG002}
322	}
323	-1 {
324	set config(default_buf) increment
325	set config(qbuf_state) disabled
326	set config(bbuf_state) disabled
327	set config(tbuf_state) disabled
328	set config(rbuf_state) disabled
329	}
330	-5 {
331	set config(default_buf) increment
332	set config(tbuf_state) disabled
333	set config(rbuf_state) disabled
334	set config(qbuf_state) normal
335	set config(bbuf_state) normal
336	}
337	-7 {
338	set config(default_buf) reflectivity
339	set config(ibuf_state) disabled
340	set config(qbuf_state) disabled
341	set config(bbuf_state) disabled
342	set config(tbuf_state) disabled
343	set config(rbuf_state) normal
344	set config(pola_state) disabled
345	set config(mono_list) {PG002}
346	}
347	}
348
349	# If bragg or trash buffers enabled, load shared library for calculations
350
351	set config(mono) [lindex $config(mono_list) 0]
352	}
353
354	#=BT1 specific routines========================================================
355
356	# Reads and returns the monochromator setting for BT1
357	proc GetBT1Mono {} {
358	global env config
359	if {![file exists $config(root)/cfg/MOTORS.BUF]} {
360	return
361	}
362	set f [open $config(root)/cfg/MOTORS.BUF]
363	fconfigure $f -encoding binary
364	seek $f [expr 160 * 33 + 10 * 4] start
365	set input [read $f 5]
366	set monobt1 $input
367
368	# Get current instrument configuration
369	switch -glob $monobt1 {
370	G* { return Ge311 }
371	S* { return Si311 }
372	}
373	return Cu311
374	}
375
376	# check for change in BT1 monochromator
377	proc CheckBT1MonoChange {} {
378	global config text_only
379	# if we do not have a saved value, don't check
380	if {$config(BT1mono-asread) == ""} return
381	set newmono [GetBT1Mono]
382	if {$config(BT1mono-asread) != $newmono && $config(mono) != $newmono} {
383	if $text_only {
384	set change [ck_dialog .change "Monochromator Changed!" \
385	"The monochromator setting on BT1 has changed. Set monochromator to $newmono?" \
386	Yes No]
387	} else {
388	set change [tk_dialog .change "Monochromator Changed!" \
389	"The monochromator setting on BT1 has changed. Set monochromator to $newmono?" \
390	error 0 Yes No]
391	}
392	if {$change == 0} {
393	set config(mono) $newmono
394	set config(instr) "$newmono-15'"
395	IBufCalcBT1
396	}
397	# either way, set the saved value to the new
398	set config(BT1mono-asread) $newmono
399	}
400	}
401
402	# Read additional configuration information for BT1
403	# Current monochromator and collimation
404	# T+/T- flag
405	# No safety yet - should "protect" this with catch statements
406	proc ConfigBT1 { args } {
407	global config env
408
409	set config(BT1mono-asread) ""
410	if {![file exists $config(root)/cfg/MOTORS.BUF]} {
411	return 0
412	}
413	set f [open $config(root)/cfg/MOTORS.BUF]
414	fconfigure $f -encoding binary
415
416	seek $f [expr 160 * 33] start
417	set input [read $f 4]
418	binary scan $input i collim
419
420	seek $f [expr 160 * 33 + 10 * 4] start
421	set input [read $f 5]
422	set monobt1 $input
423
424	seek $f [expr 160 * 34 + 32*4] start
425	set input [read $f 4]
426	binary scan $input i tempctr
427
428	# Set default edit mode
429	if {$tempctr} {
430	set config(mode) 1 ;# Temperature control
431	} else {
432	set config(mode) 0 ;# Expert
433	}
434
435	# Get current instrument configuration
436	switch -glob $monobt1 {
437	G* { set config(mono) Ge311 }
438	S* { set config(mono) Si311 }
439	default {
440	set config(mono) Cu311
441	}
442	}
443	set config(BT1mono-asread) $config(mono)
444
445	switch $collim {
446	7 { set coll "7'" }
447	default { set coll "15'" }
448	}
449
450	set config(instr) "$config(mono)-$coll"
451	close $f
452	return 1
453	}
454
455	# invoked when the instrument configuration changes
456	proc ConfigChange { args } {
457	global config
458
459	switch -- $config(nsta) {
460	1 {
461	switch -glob $config(instr) {
462	Ge* { set config(mono) Ge311 }
463	Si* { set config(mono) Si531 }
464	default {
465	set config(mono) Cu311
466	}
467	}
468	# Enforce rules for BT1 after each monochromator change
469	IBufCalcBT1
470	}
471	}
472	}
473
474
475	# enable & disable widgets here
476	proc DisableWidget {wlist mode} {
477	if {$mode} {
478	foreach {state bg fg} {normal white black} {}
479	} else {
480	foreach {state bg fg} {disabled gray86 gray} {}
481	}
482	foreach w $wlist {
483	switch [winfo class $w] {
484	Label {$w config -fg $fg}
485	Checkbutton {$w config -fg $fg -state $state}
486	Button -
487	Entry {$w config -fg $fg -state $state -bg $bg}
488	default {puts "$w class is [winfo class $w]"}
489	}
490	}
491	}
492	#=I BUFFER=====================================================================
493
494	proc IBufEntryCreate { parent } {
495	global ibufdisp config text_only
496
497	set config(ibufentry) $parent
498
499	label $parent.bufnolabel -textvariable ibufdisp(label)
500	label $parent.commentlabel -text "Comment:"
501	entry $parent.comment -width 35 -textvariable ibufdisp(comment)
502	if $text_only {
503	grid $parent.bufnolabel -row 0 -column 0 -sticky w
504	grid $parent.commentlabel -row 0 -column 1 -ipadx 3 -sticky e
505	grid $parent.comment -row 0 -column 2 -columnspan 6 -sticky ew
506	set width 5
507	} else {
508	grid $parent.bufnolabel -row 0 -column 0
509	grid $parent.commentlabel -row 0 -column 1
510	grid $parent.comment -row 0 -column 2 -columnspan 6 -sticky ew
511	set width 7
512	}
513	set row 1
514	foreach i $config(ibuf_mots) {
515	label $parent.a${i}beglabel -text "A${i}-beg:"
516	entry $parent.a${i}beg -width $width -textvariable ibufdisp(a${i}beg)
517	label $parent.a${i}inclabel -text "Inc-A${i}:"
518	entry $parent.a${i}inc -width $width -textvariable ibufdisp(a${i}inc)
519	label $parent.a${i}endlabel -text "A${i}-end:"
520	entry $parent.a${i}end -width $width -textvariable ibufdisp(a${i}end)
521	if $text_only {
522	grid $parent.a${i}beglabel -row $row -column 1 -ipadx 1 -sticky w
523	grid $parent.a${i}beg -row $row -column 2 -ipadx 1 -sticky w
524	grid $parent.a${i}inclabel -row $row -column 3 -ipadx 1 -sticky w
525	grid $parent.a${i}inc -row $row -column 4 -ipadx 1 -sticky w
526	grid $parent.a${i}endlabel -row $row -column 5 -ipadx 1 -sticky w
527	grid $parent.a${i}end -row $row -column 6 -ipadx 1 -sticky w
528	} else {
529	grid $parent.a${i}beglabel -row $row -column 1
530	grid $parent.a${i}beg -row $row -column 2
531	grid $parent.a${i}inclabel -row $row -column 3
532	grid $parent.a${i}inc -row $row -column 4
533	grid $parent.a${i}endlabel -row $row -column 5
534	grid $parent.a${i}end -row $row -column 6
535	}
536	bind $parent.a${i}beg <Return> "IBufAngleBinding ibufdisp a${i}beg w"
537	bind $parent.a${i}inc <Return> "IBufAngleBinding ibufdisp a${i}inc w"
538	bind $parent.a${i}end <Return> "IBufAngleBinding ibufdisp a${i}end w"
539	bind $parent.a${i}beg <FocusOut> "IBufAngleBinding ibufdisp a${i}beg w"
540	bind $parent.a${i}inc <FocusOut> "IBufAngleBinding ibufdisp a${i}inc w"
541	bind $parent.a${i}end <FocusOut> "IBufAngleBinding ibufdisp a${i}end w"
542	if {!$text_only} {
543
544	bind $parent.a${i}beg <<Paste>> "IBufAngleBinding ibufdisp a${i}beg w"
545	bind $parent.a${i}inc <<Paste>> "IBufAngleBinding ibufdisp a${i}inc w"
546	bind $parent.a${i}end <<Paste>> "IBufAngleBinding ibufdisp a${i}end w"
547
548	}
549	incr row
550	}
551	if $text_only {
552	# blank line
553	label $parent.blank -text " "
554	grid $parent.blank -row $row -column 0
555	incr row
556	}
557	frame $parent.t
558	label $parent.tlabel -text "Temp/H:"
559	if $text_only {
560	grid $parent.tlabel -row $row -column 0 -sticky w
561	grid $parent.t -row $row -column 1 -columnspan 7 -sticky w
562	} else {
563	grid $parent.tlabel -row $row -column 0
564	grid $parent.t -row $row -column 1 -columnspan 6
565	}
566	label $parent.t.t0label -text "T0: "
567	entry $parent.t.t0 -textvariable ibufdisp(t0)
568	label $parent.t.itlabel -text "Inc-T: "
569	entry $parent.t.it -textvariable ibufdisp(it)
570	label $parent.t.twlabel -text "Wait: "
571	entry $parent.t.tw -textvariable ibufdisp(tw)
572	label $parent.t.errlabel -text "Err: "
573	entry $parent.t.err -textvariable ibufdisp(ter)
574	label $parent.t.hld0label -text "Hld0: "
575	entry $parent.t.hld0 -textvariable ibufdisp(th0)
576	label $parent.t.hldlabel -text "Hld: "
577	entry $parent.t.hld -textvariable ibufdisp(th)
578	button $parent.t.field -text FIELD -command IBufFieldDialog
579	label $parent.timelabel -text "Time:"
580
581	pack $parent.t.t0label $parent.t.t0 $parent.t.itlabel $parent.t.it \
582	$parent.t.twlabel $parent.t.tw $parent.t.errlabel $parent.t.err \
583	$parent.t.hld0label $parent.t.hld0 $parent.t.hldlabel \
584	$parent.t.hld $parent.t.field -side left
585
586	if $text_only {
587	$parent.t.t0 configure -width 4
588	$parent.t.it configure -width 4
589	$parent.t.tw configure -width 4
590	$parent.t.err configure -width 4
591	$parent.t.hld0 configure -width 4
592	$parent.t.hld configure -width 4
593	} else {
594	$parent.t.t0 configure -width 6
595	$parent.t.it configure -width 6
596	$parent.t.tw configure -width 4
597	$parent.t.err configure -width 4
598	$parent.t.hld0 configure -width 4
599	$parent.t.hld configure -width 4
600	}
601
602	incr row
603	frame $parent.time
604
605	if $text_only {
606	grid $parent.timelabel -row $row -column 0 -sticky w
607	grid $parent.time -row $row -column 1 -columnspan 7 -sticky w
608	} else {
609	grid $parent.timelabel -row $row -column 0
610	grid $parent.time -row $row -column 1 -columnspan 6
611	}
612	label $parent.time.monlabel -text "Monit:"
613	entry $parent.time.mon -width 7 -textvariable ibufdisp(mon)
614	label $parent.time.prelabel -text "Prefac:"
615	entry $parent.time.pre -width 4 -textvariable ibufdisp(mpf)
616	label $parent.time.mtlabel -text "M-typ:"
617	button $parent.time.pol -text "POLARIZE" -command IBufPolDialogShow \
618	-state $config(pola_state)
619	if {$config(pola_state) == "disabled"} {
620	DisableWidget $parent.time.pol 0
621	} else {
622	DisableWidget $parent.time.pol 1
623	}
624	button $parent.time.amon -text "AUTOMON" -command AutomonShow
625	if $text_only {
626	ck_optionMenu $parent.time.mt ibufdisp(mt) TIME NEUT
627	pack $parent.time.monlabel -side left
628	pack $parent.time.mon -side left -padx 1
629	pack $parent.time.prelabel -side left
630	pack $parent.time.pre -side left -padx 1
631	pack $parent.time.mtlabel -side left
632	pack $parent.time.mt -side left
633	pack $parent.time.pol -side left
634	pack $parent.time.amon -side left -padx 1
635	} else {
636	tk_optionMenu $parent.time.mt ibufdisp(mt) TIME NEUT
637	pack $parent.time.monlabel $parent.time.mon $parent.time.prelabel \
638	$parent.time.pre $parent.time.mtlabel $parent.time.mt \
639	$parent.time.pol $parent.time.amon -side left
640	}
641
642	frame $parent.pts
643	label $parent.pts.label -text "NPTS: "
644	entry $parent.pts.val -textvariable ibufdisp(pts) -width 6
645
646	pack $parent.pts.label $parent.pts.val -side left
647	grid $parent.pts -row 1 -column 7
648
649	bind $parent.pts.val <Return> IBufCalcAngles
650	bind $parent.pts.val <FocusOut> IBufCalcAngles
651
652	return $parent
653	}
654
655	# Edit mode modifications
656	proc IBufEntryMod { } {
657	global ibufdisp config text_only
658
659	set parent $config(ibufentry)
660	if {$config(mode) == 0} {
661	set state disabled
662	if $text_only {
663	set color white
664	} else {
665	set color gray
666	}
667	} else {
668	set state normal
669	if $text_only {
670	set color white
671	} else {
672	set color black
673	}
674	}
675	foreach w "$parent.tlabel [winfo children $parent.t]" {
676	switch [winfo class $w] {
677	Label {$w config -fg $color}
678	Entry {$w config -fg $color -state $state}
679	}
680	}
681
682	if {$config(mode) == 2} {
683	set state normal
684	if $text_only {
685	set color white
686	} else {
687	set color black
688	}
689	} else {
690	set state disabled
691	if $text_only {
692	set color white
693	} else {
694	set color gray
695	}
696	}
697	if {$config(nsta) == 1} {
698	foreach i $config(ibuf_mots) {
699	foreach l "a${i}beglabel a${i}inclabel a${i}endlabel" {
700	$parent.$l config -fg $color
701	}
702	foreach e "a${i}beg a${i}inc a${i}end" {
703	$parent.$e config -state $state -fg $color
704	}
705	}
706	$parent.pts.label config -fg $color
707	$parent.pts.val config -state $state -fg $color
708	}
709	foreach l {t.itlabel t.hldlabel} {
710	$parent.$l config -fg $color
711	}
712	foreach e {t.it t.hld t.field} {
713	$parent.$e config -state $state -fg $color
714	}
715
716	# Enforce rules for BT1
717	if { $config(nsta) == 1 } { IBufCalcBT1 }
718	}
719
720	proc IBufReadRec { file rec } {
721	upvar $rec r
722	set input [read $file 320]
723	binary scan $input \
724	A50sfffffffffffffffffffffA4iiiiffff \
725	r(comment) pad1 \
726	r(a1beg) r(a2beg) r(a3beg) r(a4beg) r(a5beg) r(a6beg) \
727	r(a1inc) r(a2inc) r(a3inc) r(a4inc) r(a5inc) r(a6inc) \
728	r(pts) r(hf) r(t0) r(it) r(tw) r(th0) r(ter) \
729	r(mon) r(mpf) r(mt) \
730	r(flip1) r(flip2) r(flip3) r(flip4) \
731	r(ihf) r(hfw) r(hfh) r(th)
732	}
733
734	proc IBufReadFile { } {
735	global ibuf ibuf_fields
736
737	set f [open IBUFFER.BUF r]
738	fconfigure $f -encoding binary
739	for {set i 0} {$i < 30} {incr i} {
740	IBufReadRec $f icpin
741	foreach fld $ibuf_fields {
742	# for a*end values compute
743	if {[regexp {a([0-9]+)end} $fld junk n]} {
744	set icpin($fld) [expr $icpin(a${n}beg) + \
745	$icpin(a${n}inc) * ($icpin(pts) - 1)]
746	}
747	# now store in ibuf array
748	if {![catch {set icpin($fld)} result]} {
749	set ibuf($i,$fld) $result
750	}
751	}
752	}
753	# Read last record which contains run sequence information
754	set contents [read $f 320]
755	binary scan $contents A320 contents
756	set ibuf(sequence) [string trimright $contents]
757	close $f
758
759	set ibuf(mtime) [file mtime IBUFFER.BUF]
760	}
761
762	proc IBufCheckFld { } {
763	global ibufdisp
764	set flds {a1beg a2beg a3beg a4beg a5beg a6beg \
765	a1inc a2inc a3inc a4inc a5inc a6inc \
766	pts hf t0 it tw th0 ter mon mpf ihf hfw hfh th }
767	foreach fld $flds {
768	# Check to make sure these are floating point numbers
769	if [catch { expr 1.0 * $ibufdisp($fld) } result] {
770	set ibufdisp($fld) "--------"
771	return -code error "Parameter \"$fld\" must be floating point number"
772	}
773	}
774	}
775
776	proc IBufWriteRec { file rec } {
777	upvar $rec r
778
779	set pad1 0
780	set recval [binary format \
781	A50sfffffffffffffffffffffA4iiiiffff \
782	$r(comment) $pad1 \
783	$r(a1beg) $r(a2beg) $r(a3beg) $r(a4beg) $r(a5beg) $r(a6beg) \
784	$r(a1inc) $r(a2inc) $r(a3inc) $r(a4inc) $r(a5inc) $r(a6inc) \
785	$r(pts) $r(hf) $r(t0) $r(it) $r(tw) $r(th0) $r(ter) \
786	$r(mon) $r(mpf) $r(mt) \
787	$r(flip1) $r(flip2) $r(flip3) $r(flip4) \
788	$r(ihf) $r(hfw) $r(hfh) $r(th)]
789	set record [binary format A320 $recval]
790	puts -nonewline $file $record
791	string length $record
792	}
793
794
795	proc IBufWriteFile { } {
796	global ibuf ibuf_fields
797
798	if [file exists IBUFFER.BUF] {
799	set f [open IBUFFER.BUF r+]
800	fconfigure $f -encoding binary
801	seek $f [expr 320 * 30] start
802	set sequence [read $f 320]
803	set ibuf(sequence) [string trimright $sequence]
804	seek $f 0
805	} else {
806	set f [open IBUFFER.BUF w]
807	fconfigure $f -encoding binary
808	}
809	for {set i 0} {$i < 30} {incr i} {
810	foreach fld $ibuf_fields {
811	set icpout($fld) $ibuf($i,$fld)
812	}
813	IBufWriteRec $f icpout
814	}
815	puts -nonewline $f [binary format A320 $ibuf(sequence)]
816	close $f
817
818	set ibuf(mtime) [file mtime IBUFFER.BUF]
819	}
820
821	proc IBufInit { } {
822	global ibuf config
823	array set ibuf {buftype Increment}
824	for {set i 0} {$i < 30} {incr i} {
825	set ibuf($i,comment) "empty"
826	for {set j 1} {$j <= 6} {incr j} {
827	set ibuf($i,a${j}beg) 0.0
828	set ibuf($i,a${j}inc) 0.0
829	set ibuf($i,a${j}end) 0.0
830	}
831	set ibuf($i,t0) 0
832	set ibuf($i,it) 0
833	set ibuf($i,tw) 0
834	set ibuf($i,ter) 0
835	set ibuf($i,th0) 0
836	set ibuf($i,th) 0
837	set ibuf($i,mon) 1000
838	set ibuf($i,mpf) 1
839	set ibuf($i,mt) TIME
840	set ibuf($i,pts) 1
841	set ibuf($i,flip1) 0
842	set ibuf($i,flip2) 0
843	set ibuf($i,flip3) 0
844	set ibuf($i,flip4) 0
845	set ibuf($i,hf) 0
846	set ibuf($i,ihf) 0
847	set ibuf($i,hfw) 0
848	set ibuf($i,hfh) 0
849	}
850	set ibuf(currentrec) 0
851	set ibuf(mtime) 0
852
853	if {$config(nsta) == 1} {
854	for {set i 0} {$i < 30} {incr i} {
855	set ibuf($i,mpf) 4
856	set ibuf($i,mt) NEUT
857	}
858	}
859
860	set ibuf(sequence) ""
861	}
862
863	proc IBufList { } {
864	global text_only
865	# Clear out our list if it contains anything.
866	set lbox .l.list
867	set start [expr int([lindex [$lbox yview] 0] * [$lbox index end])]
868	$lbox delete 0 end
869	$lbox configure -font {-family courier -size 12}
870	for {set i 0} {$i < 30} {incr i} {
871	$lbox insert end [IBufFormatRec $i]
872	}
873
874	$lbox yview $start
875	bind $lbox <ButtonRelease-1> "IBufDisp \[$lbox curselection\]"
876	if $text_only {
877	set bind_type <Linefeed>
878	} else {
879	set bind_type <Return>
880	}
881	bind $lbox $bind_type "IBufDisp \[$lbox curselection\]"
882	}
883
884	proc IBufFormatRec { recno } {
885	global ibuf
886	set output [format "%-3d " [expr $recno + 1]]
887	append output [binary format A20 $ibuf($recno,comment)]
888	append output [format " %8.2f" $ibuf($recno,a2beg)]
889	append output [format "%8.2f" $ibuf($recno,a2end)]
890	append output [format "%8.2f" $ibuf($recno,a2inc)]
891	append output [format "%8.2f" $ibuf($recno,a5beg)]
892	append output [format "%8.2f" $ibuf($recno,a5end)]
893	append output [format "%8.2f" $ibuf($recno,a5inc)]
894	append output [format "%2.0f\* " $ibuf($recno,mpf)]
895	append output [format "%6.0f " $ibuf($recno,mon)]
896	append output [binary format A4 $ibuf($recno,mt)]
897	append output [format "%6.1f" $ibuf($recno,t0)]
898	append output [format "%4.0f" $ibuf($recno,th0)]
899
900	return $output
901	}
902
903	proc IBufDisp { recno } {
904	global ibufdisp ibuf ibuf_fields changed config
905
906	set mtime [file mtime IBUFFER.BUF]
907	if {$mtime != $ibuf(mtime)} {
908	IBufReadFile
909	IBufList
910	}
911
912	if { $config(nsta) == 1 } { CheckBT1MonoChange }
913	if { $config(paranoid)} { CheckBufChange }
914
915	foreach fld $ibuf_fields {
916	set ibufdisp($fld) $ibuf($recno,$fld)
917	}
918	set num [format "%2d" [expr $recno + 1]]
919	set ibufdisp(label) "IBuffer No: $num"
920	set ibufdisp(current) $recno
921	# Fix up several fields
922	set flfields { a1beg a1end a1inc a2beg a2end a2inc a3beg a3end a3inc \
923	a4beg a4end a4inc a5beg a5end a5inc a6beg a6end a6inc }
924
925	foreach f $flfields {
926	set ibufdisp($f) [fltrim $ibufdisp($f) 10000]
927	}
928
929	if [catch {expr $ibufdisp(pts) * 1} ibufdisp(pts)] {
930	set ibufdisp(pts) 1
931	}
932
933	IBufCalcAngles
934
935	# clear changed flag
936	set changed(ibufdisp) 0
937
938	# Enforce rules for BT1
939	if { $config(nsta) == 1 } { IBufCalcBT1 }
940
941	# switch focus to listbox so Return & arrowkeys work
942	# and force selection (for 1st time)
943	focus .l.list
944	.l.list selection set $recno
945	}
946
947	proc IBufUpdate { } {
948	global ibufdisp ibuf changed config
949
950	if [catch {IBufCheckFld} result] {
951	return -code error $result
952	}
953
954	if { $config(nsta) == 1 } { CheckBT1MonoChange }
955
956	set recno $ibufdisp(current)
957	foreach fld [array names ibufdisp] {
958	set ibuf($recno,$fld) $ibufdisp($fld)
959	}
960	# update display on the list
961	.l.list delete $recno
962	.l.list insert $recno [IBufFormatRec $recno]
963	# update buffer information on disk
964	IBufWriteFile
965	set changed(ibufdisp) 0
966	}
967
968	proc IBufGetSequence { } {
969	global ibuf
970	if {![file exists IBUFFER.BUF]} {
971	return
972	}
973	set f [open IBUFFER.BUF r]
974	fconfigure $f -encoding binary
975	seek $f [expr 320 * 30] start
976	set sequence [read $f 320]
977	set ibuf(sequence) [string trimright $sequence]
978	}
979
980	proc IBufFieldDialog { } {
981	global ibufdisp ibuf text_only
982
983	toplevel .field
984
985	label .field.title -text "MAGNETIC FIELD"
986	label .field.initlab -text "Initial Field (user units):"
987	label .field.incrlab -text "Field Increment (user units):"
988	label .field.waitlab -text "Max Wait Per Point (secs) :"
989	entry .field.initentry -textvariable ibufdisp(hf) -width 10
990	entry .field.increntry -textvariable ibufdisp(ihf) -width 10
991	entry .field.waitentry -textvariable ibufdisp(ihw) -width 10
992	label .field.t1 -text "(Wait used in non-persistent mode on SC only)"
993	label .field.t2 -text "(Reply 0 to get default optimum wait times)"
994	button .field.dismiss -text "Dismiss" -command IBufFieldDialogDismiss
995	if $text_only {
996	grid .field.title -row 0 -column 0 -columnspan 2 -sticky news
997	label .field.blank1 -text " "
998	grid .field.blank1 -row 1
999	grid .field.initlab -row 2 -column 0 -sticky w
1000	grid .field.incrlab -row 3 -column 0 -sticky w
1001	grid .field.waitlab -row 4 -column 0 -sticky w
1002	grid .field.initentry -row 2 -column 1
1003	grid .field.increntry -row 3 -column 1
1004	grid .field.waitentry -row 4 -column 1
1005	label .field.blank2 -text " "
1006	grid .field.blank2 -row 5
1007	grid .field.t1 -row 6 -column 0 -columnspan 2 -sticky ew
1008	grid .field.t2 -row 7 -column 0 -columnspan 2 -sticky ew
1009	label .field.blank3 -text " "
1010	grid .field.blank3 -row 8
1011	grid .field.dismiss -row 9 -column 0 -columnspan 2 -sticky ew
1012	place .field -relheight 1.0 -relwidth 1.0
1013	focus .field
1014	} else {
1015	wm protocol .field WM_DELETE_WINDOW ".field.dismiss invoke"
1016	grid .field.title -row 0 -column 0 -columnspan 2 -sticky news
1017	grid .field.initlab -row 1 -column 0
1018	grid .field.incrlab -row 2 -column 0
1019	grid .field.waitlab -row 3 -column 0
1020	grid .field.initentry -row 1 -column 1
1021	grid .field.increntry -row 2 -column 1
1022	grid .field.waitentry -row 3 -column 1
1023	grid .field.t1 -row 4 -column 0 -columnspan 2 -sticky ew
1024	grid .field.t2 -row 5 -column 0 -columnspan 2 -sticky ew
1025	grid .field.dismiss -row 6 -column 0 -columnspan 2 -sticky ew
1026	}
1027	return .field
1028	}
1029
1030	proc IBufFieldDialogDismiss { } {
1031	global text_only
1032	if $text_only {
1033	place forget .field
1034	focus .
1035	}
1036	destroy .field
1037	}
1038
1039	proc IBufPolDialogBuild { } {
1040	global ibufdisp text_only
1041	set p [toplevel .polarization]
1042	label $p.title -text "Polarization Setup"
1043	set f [frame $p.f]
1044	set d [button $p.dismiss -text "Dismiss" -command IBufPolDialogHide]
1045	wm protocol $p WM_DELETE_WINDOW "$d invoke"
1046	label $f.flip1t -text "Flipper 1"
1047	label $f.flip2t -text "Flipper 2"
1048	label $f.flipet -text "Execute ?"
1049	frame $f.flip1
1050	frame $f.flip2
1051	frame $f.flipe
1052	label $f.flip1.a -text "OFF"
1053	label $f.flip1.b -text "ON"
1054	label $f.flip1.c -text "OFF"
1055	label $f.flip1.d -text "ON"
1056	label $f.flip2.a -text "OFF"
1057	label $f.flip2.b -text "OFF"
1058	label $f.flip2.c -text "ON"
1059	label $f.flip2.d -text "ON"
1060	#toggle_create $f.flipe.a ibufdisp(flip1)
1061	#toggle_create $f.flipe.b ibufdisp(flip2)
1062	#toggle_create $f.flipe.c ibufdisp(flip3)
1063	#toggle_create $f.flipe.d ibufdisp(flip4)
1064	tk_optionMenu $f.flipe.a ibufdisp(flip1) 0 1
1065	tk_optionMenu $f.flipe.b ibufdisp(flip2) 0 1
1066	tk_optionMenu $f.flipe.c ibufdisp(flip3) 0 1
1067	tk_optionMenu $f.flipe.d ibufdisp(flip4) 0 1
1068
1069	if {!$text_only} {
1070	$f.flip1t configure -relief ridge
1071	$f.flip2t configure -relief ridge
1072	$f.flipet configure -relief ridge
1073	$f.flip1 configure -relief ridge -borderwidth 2
1074	$f.flip2 configure -relief ridge -borderwidth 2
1075	$f.flipe configure -relief ridge -borderwidth 2
1076	$f.flip1.a configure -pady 5
1077	$f.flip1.b configure -pady 5
1078	$f.flip1.c configure -pady 5
1079	$f.flip1.d configure -pady 5
1080	$f.flip2.a configure -pady 5
1081	$f.flip2.b configure -pady 5
1082	$f.flip2.c configure -pady 5
1083	$f.flip2.d configure -pady 5
1084	}
1085
1086	pack $p.title $f $d -side top -fill x
1087	grid $f.flip1t $f.flip2t $f.flipet -sticky ew
1088	grid $f.flip1 $f.flip2 $f.flipe -sticky ew
1089	pack $f.flip1.a $f.flip1.b $f.flip1.c $f.flip1.d -side top
1090	pack $f.flip2.a $f.flip2.b $f.flip2.c $f.flip2.d -side top
1091	pack $f.flipe.a $f.flipe.b $f.flipe.c $f.flipe.d -side top -fill x
1092	return $p
1093	}
1094
1095	proc IBufPolDialogHide { } {
1096	global text_only
1097	if $text_only {
1098	destroy .polarization
1099	} else {
1100	wm withdraw .polarization
1101	}
1102	}
1103
1104	proc IBufPolDialogShow { } {
1105	global text_only
1106
1107	if $text_only {
1108	catch { destroy .polarization }
1109	IBufPolDialogBuild
1110	place .polarization -relheight 1.0 -relwidth 1.0
1111	focus .polarization
1112	} else {
1113	if [winfo exists .polarization] {
1114	wm deiconify .polarization
1115	} else {
1116	IBufPolDialogBuild
1117	}
1118	}
1119	}
1120
1121	proc IBufCalcAngles {{anglist {1 2 3 4 5 6}}} {
1122	global ibufdisp
1123	if [catch {expr $ibufdisp(pts) * 1} ibufdisp(pts)] {
1124	set ibufdisp(pts) "------"
1125	return
1126	}
1127
1128	foreach i $anglist {
1129	set beg "a${i}beg"
1130	set inc "a${i}inc"
1131	set end "a${i}end"
1132	if [catch {expr $ibufdisp($beg) * 1.0} ibufdisp($beg)] {
1133	set ibufdisp($beg) "------"
1134	return
1135	}
1136	if [catch {expr $ibufdisp($inc) * 1.0} ibufdisp($inc)] {
1137	set ibufdisp($inc) "------"
1138	return
1139	}
1140	set ibufdisp($end) [expr $ibufdisp($beg) + \
1141	$ibufdisp($inc) * ($ibufdisp(pts) - 1)]
1142	}
1143	update
1144	}
1145
1146	#
1147	# end = beg + pts * inc
1148	# pts = (end - beg) / inc
1149	#
1150	proc IBufAngleBinding { args } {
1151	global ibufdisp
1152	set largs [llength $args]
1153
1154	# puts [join $args " "]
1155	if {$largs < 3} { return }
1156	set key [lindex $args 1]
1157	if {[string compare $key "pts"] == 0} {
1158	return [IBufCalcAngles]
1159	}
1160
1161	if {![regexp {a([0-9])(beg\|inc\|end)} $key match axis which]} {
1162	return
1163	}
1164	set beg "a${axis}beg"
1165	set inc "a${axis}inc"
1166	set end "a${axis}end"
1167	if [catch {expr $ibufdisp($beg) * 1.0} ibufdisp($beg)] {
1168	set ibufdisp($beg) "******"
1169	return
1170	}
1171	if [catch {expr $ibufdisp($inc) * 1.0} ibufdisp($inc)] {
1172	set ibufdisp($inc) "******"
1173	return
1174	}
1175	if [catch {expr $ibufdisp($end) * 1.0} ibufdisp($end)] {
1176	set ibufdisp($end) "******"
1177	return
1178	}
1179
1180	switch $which {
1181	beg {
1182	}
1183	end {
1184	if {$ibufdisp($inc) == 0} {
1185	return
1186	}
1187	set pts [expr ($ibufdisp($end)-$ibufdisp($beg))/$ibufdisp($inc) + 1]
1188	set ibufdisp(pts) $pts
1189	}
1190	inc {
1191	}
1192	}
1193	return [IBufCalcAngles]
1194	}
1195
1196	# Special rules for BT1
1197	proc IBufCalcBT1 {} {
1198	global ibufdisp config
1199
1200	if {$config(mode) != 2} {
1201	set varlist {a3beg a3end a3inc a4inc pts it th}
1202	set vallist {0. 0. 0. 0.05 201 0 0}
1203	if {$config(mono) == "Ge311"} {
1204	lappend varlist a4beg a4end
1205	lappend vallist 1.3 11.3
1206	} else {
1207	lappend varlist a4beg a4end
1208	lappend vallist 3.0 13.0
1209	}
1210	if {$config(mode) == 0} {
1211	lappend varlist "t0"
1212	lappend vallist "0"
1213	}
1214	foreach f $varlist v $vallist {
1215	if {$ibufdisp($f) != $v} {set ibufdisp($f) $v}
1216	}
1217	}
1218	}
1219
1220	proc IBufKeyBinding { } {
1221	bind all <KeyPress-F1> IBufUpdate
1222	bind all <KeyPress-F2> BufopShow
1223	bind all <KeyPress-F3> {notebook_display .e ibuf}
1224	bind all <KeyPress-F4> {notebook_display .e blank}
1225	}
1226
1227	#=Q BUFFER=====================================================================
1228
1229	proc QBufEntryCreate { p } {
1230	global qbuf qbufdisp config text_only
1231
1232	set config(qbufentry) $p
1233
1234	# Create widgets
1235	label $p.bufnolabel -textvariable qbufdisp(label)
1236	label $p.commentlabel -text "Comment:"
1237	entry $p.comment -textvariable qbufdisp(comment)
1238
1239
1240	label $p.latlabel -text "Lattice:"
1241	label $p.alabel -text "a:"
1242	entry $p.a -textvariable qbufdisp(a) -width 6
1243	label $p.blabel -text "b:"
1244	entry $p.b -textvariable qbufdisp(b) -width 6
1245	label $p.clabel -text "c:"
1246	entry $p.c -textvariable qbufdisp(c) -width 6
1247	label $p.aalabel -text "aa:"
1248	entry $p.aa -textvariable qbufdisp(aa) -width 6
1249	label $p.bblabel -text "bb:"
1250	entry $p.bb -textvariable qbufdisp(bb) -width 6
1251	label $p.cclabel -text "cc:"
1252	entry $p.cc -textvariable qbufdisp(cc) -width 6
1253
1254	label $p.energylabel -text "Energy:"
1255	label $p.eclabel -text "EC:"
1256	entry $p.ec -textvariable qbufdisp(ec) -width 6
1257	label $p.eslabel -text "ES:"
1258	entry $p.es -textvariable qbufdisp(es) -width 6
1259	label $p.eflabel -text "EF:"
1260	entry $p.ef -textvariable qbufdisp(ef) -width 6
1261	label $p.eftlabel -text "EFT:"
1262	if {!$text_only} {
1263	tk_optionMenu $p.eft qbufdisp(eft) ANA MON
1264	} else {
1265	ck_optionMenu $p.eft qbufdisp(eft) ANA MON
1266	}
1267
1268	label $p.spacelabel -text "Space:"
1269	label $p.hclabel -text "HC:"
1270	entry $p.hc -textvariable qbufdisp(hc) -width 6
1271	label $p.kclabel -text "KC:"
1272	entry $p.kc -textvariable qbufdisp(kc) -width 6
1273	label $p.lclabel -text "LC:"
1274	entry $p.lc -textvariable qbufdisp(lc) -width 6
1275	label $p.hslabel -text "HS:"
1276	entry $p.hs -textvariable qbufdisp(hs) -width 6
1277	label $p.kslabel -text "KS:"
1278	entry $p.ks -textvariable qbufdisp(ks) -width 6
1279	label $p.lslabel -text "LS:"
1280	entry $p.ls -textvariable qbufdisp(ls) -width 6
1281
1282	label $p.orientlabel -text "Orient:"
1283	frame $p.orient
1284	label $p.orient.hkl1label -text "(h k l):"
1285	entry $p.orient.hkl1 -textvariable qbufdisp(hkl1) -width 6
1286	label $p.orient.a1label -text "Angle:"
1287	entry $p.orient.a1 -textvariable qbufdisp(a1) -width 6
1288	label $p.orient.hkl2label -text "(h k l)':"
1289	entry $p.orient.hkl2 -textvariable qbufdisp(hkl2) -width 6
1290	if $text_only {
1291	$p.orient.hkl1 configure -width 8
1292	$p.orient.hkl2 configure -width 8
1293	grid $p.orient.hkl1label -row 0 -column 0
1294	grid $p.orient.hkl1 -row 0 -column 1 -padx 2
1295	grid $p.orient.a1label -row 0 -column 2
1296	grid $p.orient.a1 -row 0 -column 3 -padx 2
1297	grid $p.orient.hkl2label -row 0 -column 4
1298	grid $p.orient.hkl2 -row 0 -column 5 -padx 2
1299	} else {
1300	pack $p.orient.hkl1label $p.orient.hkl1 $p.orient.a1label \
1301	$p.orient.a1 $p.orient.hkl2label $p.orient.hkl2 -side left
1302	}
1303
1304	label $p.templabel -text "Temp/H:"
1305	frame $p.temp
1306	label $p.temp.t0label -text "T0:"
1307	entry $p.temp.t0 -textvariable qbufdisp(tmp) -width 6
1308	label $p.temp.tinclabel -text "Inc-T:"
1309	entry $p.temp.tinc -textvariable qbufdisp(it) -width 6
1310	label $p.temp.twlabel -text "Wait:"
1311	entry $p.temp.tw -textvariable qbufdisp(tw) -width 6
1312	label $p.temp.terlabel -text "Err:"
1313	entry $p.temp.ter -textvariable qbufdisp(ter) -width 6
1314	label $p.temp.th0label -text "Hld0:"
1315	entry $p.temp.th0 -textvariable qbufdisp(th0) -width 6
1316	label $p.temp.thlabel -text "Hld:"
1317	entry $p.temp.th -textvariable qbufdisp(th) -width 6
1318	button $p.temp.field -text FIELD -command QBufFieldDialog
1319	if $text_only {
1320	$p.temp.t0 configure -width 4
1321	$p.temp.tinc configure -width 4
1322	$p.temp.tw configure -width 4
1323	$p.temp.ter configure -width 4
1324	$p.temp.th0 configure -width 4
1325	$p.temp.th configure -width 4
1326	grid $p.temp.t0label -row 0 -column 0
1327	grid $p.temp.t0 -row 0 -column 1 -padx 1
1328	grid $p.temp.tinclabel -row 0 -column 2
1329	grid $p.temp.tinc -row 0 -column 3 -padx 1
1330	grid $p.temp.twlabel -row 0 -column 4
1331	grid $p.temp.tw -row 0 -column 5 -padx 1
1332	grid $p.temp.terlabel -row 0 -column 6
1333	grid $p.temp.ter -row 0 -column 7 -padx 1
1334	grid $p.temp.th0label -row 0 -column 8
1335	grid $p.temp.th0 -row 0 -column 9 -padx 1
1336	grid $p.temp.thlabel -row 0 -column 10
1337	grid $p.temp.th -row 0 -column 11 -padx 1
1338	grid $p.temp.field -row 0 -column 12
1339	} else {
1340	pack $p.temp.t0label $p.temp.t0 $p.temp.tinclabel $p.temp.tinc \
1341	$p.temp.twlabel $p.temp.tw $p.temp.terlabel $p.temp.ter \
1342	$p.temp.th0label $p.temp.th0 $p.temp.thlabel $p.temp.th \
1343	$p.temp.field -side left
1344	}
1345
1346	label $p.timelabel -text "Time:"
1347	frame $p.time
1348	label $p.time.monlabel -text "Monitor:"
1349	entry $p.time.mon -textvariable qbufdisp(mon) -width 6
1350	label $p.time.mpflabel -text "Prefac:"
1351	entry $p.time.mpf -textvariable qbufdisp(mpf) -width 6
1352	label $p.time.mtlabel -text "M-typ:"
1353	if {!$text_only} {
1354	tk_optionMenu $p.time.mt qbufdisp(mt) TIME NEUT
1355	} else {
1356	ck_optionMenu $p.time.mt qbufdisp(mt) TIME NEUT
1357	}
1358	button $p.time.pol -text "POLARIZE" -command QBufPolDialogShow \
1359	-state $config(pola_state)
1360
1361
1362	label $p.time.nptslabel -text "NPTS:"
1363	entry $p.time.npts -textvariable qbufdisp(pts) -width 6
1364	if $text_only {
1365	grid $p.time.monlabel -row 0 -column 0
1366	grid $p.time.mon -row 0 -column 1 -padx 2
1367	grid $p.time.mpflabel -row 0 -column 2
1368	grid $p.time.mpf -row 0 -column 3 -padx 2
1369	grid $p.time.mtlabel -row 0 -column 4
1370	grid $p.time.mt -row 0 -column 5 -padx 1
1371	grid $p.time.pol -row 0 -column 6
1372	grid $p.time.nptslabel -row 0 -column 7
1373	grid $p.time.npts -row 0 -column 8 -padx 2
1374	} else {
1375	pack $p.time.monlabel $p.time.mon $p.time.mpflabel $p.time.mpf \
1376	$p.time.mtlabel $p.time.mt $p.time.pol $p.time.nptslabel \
1377	$p.time.npts \
1378	-side left
1379	}
1380
1381	# Pack widgets into parent
1382	if $text_only {
1383	grid $p.bufnolabel -row 0 -column 0 -sticky w
1384	grid $p.commentlabel -row 0 -column 2 -sticky e
1385	grid $p.comment -row 0 -column 3 -columnspan 6 -sticky ew -padx 3
1386	grid $p.latlabel -row 1 -column 0 -sticky w
1387	grid $p.alabel -row 1 -column 1 -padx 1
1388	grid $p.a -row 1 -column 2
1389	grid $p.blabel -row 1 -column 3 -padx 1
1390	grid $p.b -row 1 -column 4
1391	grid $p.clabel -row 1 -column 5 -padx 1
1392	grid $p.c -row 1 -column 6
1393	grid $p.aalabel -row 1 -column 7 -padx 1
1394	grid $p.aa -row 1 -column 8
1395	grid $p.bblabel -row 1 -column 9 -padx 1
1396	grid $p.bb -row 1 -column 10
1397	grid $p.cclabel -row 1 -column 11 -padx 1
1398	grid $p.cc -row 1 -column 12
1399	grid $p.energylabel $p.eclabel $p.ec $p.eslabel $p.es $p.eflabel $p.ef \
1400	$p.eftlabel $p.eft -sticky w
1401	grid $p.spacelabel $p.hclabel $p.hc $p.kclabel $p.kc $p.lclabel $p.lc \
1402	$p.hslabel $p.hs $p.kslabel $p.ks $p.lslabel $p.ls -sticky w
1403	grid $p.orientlabel -row 4 -column 0 -sticky w
1404	grid $p.orient -row 4 -column 1 -columnspan 12 -sticky w
1405	label $p.blank -text " "
1406	grid $p.blank -row 5 -column 0
1407	grid $p.templabel -row 6 -column 0 -sticky w
1408	grid $p.temp -row 6 -column 1 -columnspan 12 -sticky w
1409	grid $p.timelabel -row 7 -column 0 -sticky w
1410	grid $p.time -row 7 -column 1 -columnspan 12 -sticky w
1411	} else {
1412	grid $p.bufnolabel $p.commentlabel
1413	grid $p.comment -row 0 -column 2 -columnspan 6 -sticky ew
1414	grid $p.latlabel $p.alabel $p.a $p.blabel $p.b $p.clabel $p.c \
1415	$p.aalabel $p.aa $p.bblabel $p.bb $p.cclabel $p.cc
1416
1417	grid $p.energylabel $p.eclabel $p.ec $p.eslabel $p.es $p.eflabel $p.ef \
1418	$p.eftlabel $p.eft
1419
1420	grid $p.spacelabel $p.hclabel $p.hc $p.kclabel $p.kc $p.lclabel $p.lc \
1421	$p.hslabel $p.hs $p.kslabel $p.ks $p.lslabel $p.ls
1422
1423	grid $p.orientlabel $p.orient - - - - - -
1424	grid $p.templabel $p.temp - - - - - -
1425	grid $p.timelabel $p.time - - - - - -
1426	}
1427
1428	# Set up widget bindings
1429	bind $p.orient.hkl1 <FocusOut> "QBufHKL 1"
1430	bind $p.orient.hkl1 <Return> "QBufHKL 1"
1431	bind $p.orient.hkl2 <FocusOut> "QBufHKL 2"
1432	bind $p.orient.hkl2 <Return> "QBufHKL 2"
1433
1434	return $p
1435	}
1436
1437	proc QBufEntryMod { } {
1438	global qbufdisp config text_only
1439
1440	set parent $config(qbufentry)
1441	if {$config(mode) == 0} {
1442	set state disabled
1443	if {!$text_only} {
1444	set color gray
1445	} else {
1446	set color white
1447	}
1448	} else {
1449	set state normal
1450	if $text_only {
1451	set color white
1452	} else {
1453	set color black
1454	}
1455	}
1456	foreach w "$parent.templabel [winfo children $parent.temp]" {
1457	switch [winfo class $w] {
1458	Label {$w config -fg $color}
1459	Entry {$w config -fg $color -state $state}
1460	}
1461	}
1462
1463	if {$config(mode) == 2} {
1464	set state normal
1465	if $text_only {
1466	set color white
1467	} else {
1468	set color black
1469	}
1470	} else {
1471	set state disabled
1472	if {!$text_only} {
1473	set color gray
1474	} else {
1475	set color white
1476	}
1477	}
1478
1479	foreach l {temp.tinclabel temp.thlabel} {
1480	$parent.$l config -fg $color
1481	}
1482	foreach e {temp.tinc temp.th} {
1483	$parent.$e config -state $state -fg $color
1484	}
1485	}
1486
1487
1488	proc QBufInit { } {
1489	global qbuf
1490	array set qbuf {buftype Q}
1491	for {set i 0} {$i < 30} {incr i} {
1492	set qbuf($i,comment) "empty"
1493	set qbuf($i,a) 6.283
1494	set qbuf($i,b) 0.0
1495	set qbuf($i,c) 0.0
1496	set qbuf($i,aa) 90.0
1497	set qbuf($i,bb) 0.0
1498	set qbuf($i,cc) 0.0
1499	set qbuf($i,ec) 0.0
1500	set qbuf($i,es) 0.0
1501	set qbuf($i,ef) 14.70
1502	set qbuf($i,eft) ANA
1503	set qbuf($i,hc) 1.0
1504	set qbuf($i,kc) 0.0
1505	set qbuf($i,lc) 0.0
1506	set qbuf($i,hs) 0.1
1507	set qbuf($i,ks) 0.0
1508	set qbuf($i,ls) 0.0
1509	set qbuf($i,hkl11) 1
1510	set qbuf($i,hkl12) 0
1511	set qbuf($i,hkl13) 0
1512	set qbuf($i,a1) 0.0
1513	set qbuf($i,hkl21) 0
1514	set qbuf($i,hkl22) 0
1515	set qbuf($i,hkl23) 1
1516	set qbuf($i,hkl1) " 1, 0, 0"
1517	set qbuf($i,hkl2) " 0, 0, 1"
1518	set qbuf($i,tmp) 0
1519	set qbuf($i,it) 0
1520	set qbuf($i,tw) 0
1521	set qbuf($i,ter) 0
1522	set qbuf($i,th0) 0
1523	set qbuf($i,th) 0
1524	set qbuf($i,mon) 1000
1525	set qbuf($i,mpf) 1
1526	set qbuf($i,mt) TIME
1527	set qbuf($i,pts) 0
1528	set qbuf($i,flip1) 0
1529	set qbuf($i,flip2) 0
1530	set qbuf($i,flip3) 0
1531	set qbuf($i,flip4) 0
1532	set qbuf($i,hf) 0
1533	set qbuf($i,ihf) 0
1534	set qbuf($i,hfw) 0
1535	set qbuf($i,hfh) 0
1536	}
1537	set qbuf(currentrec) 0
1538	set qbuf(mtime) 0
1539	}
1540
1541	proc QBufReadRec { file rec } {
1542	upvar $rec r
1543	# First seek to correct location
1544	set input [read $file 50]
1545	binary scan $input A50 r(comment)
1546	set input [read $file 2]
1547	set input [read $file 36]
1548	binary scan $input fffffffff r(a) r(b) r(c) r(aa) r(bb) r(cc) r(ec) r(es) r(ef)
1549	set input [read $file 4]
1550	binary scan $input A3 r(eft)
1551	set input [read $file 4]
1552	binary scan $input f r(hc)
1553	set input [read $file 84]
1554	binary scan $input fffffffffffffffffffff \
1555	r(kc) r(lc) r(hs) r(ks) r(ls) r(pts) \
1556	r(hkl11) r(hkl12) r(hkl13) r(a1) r(hkl21) r(hkl22) r(hkl23) \
1557	r(tmp) r(it) r(tw) r(th0) r(ter) \
1558	r(hf) r(mon) r(mpf)
1559	set input [read $file 36]
1560	binary scan $input A4iiiiffff \
1561	r(mt) \
1562	r(flip1) r(flip2) r(flip3) r(flip4) \
1563	r(ihf) r(hfw) r(hfh) r(th)
1564	# binary scan $input \
1565	# A50sfffffffffA3cffffffffffffffffffffffA4iiiiffff \
1566	# r(comment) pad1 \
1567	# r(a) r(b) r(c) r(aa) r(bb) r(cc) r(ec) r(es) r(ef) r(eft) pad2 \
1568	# r(hc) r(kc) r(lc) r(hs) r(ks) r(ls) r(pts) \
1569	# r(hkl11) r(hkl12) r(hkl13) r(a1) r(hkl21) r(hkl22) r(hkl23) \
1570	# r(tmp) r(it) r(tw) r(th0) r(ter) \
1571	# r(hf) r(mon) r(mpf) r(mt) \
1572	# r(flip1) r(flip2) r(flip3) r(flip4) \
1573	# r(ihf) r(hfw) r(hfh) r(th)
1574	}
1575
1576	proc QBufReadFile { } {
1577	global qbuf qbuf_fields
1578
1579	set f [open QBUFFER.BUF r]
1580	fconfigure $f -encoding binary
1581	for {set i 0} {$i < 30} {incr i} {
1582	seek $f [expr $i * 320]
1583	QBufReadRec $f icpin
1584	foreach fld $qbuf_fields {
1585	if {![catch {set icpin($fld)} result]} {
1586	set qbuf($i,$fld) $result
1587	}
1588	}
1589	}
1590	close $f
1591	set qbuf(mtime) [file mtime QBUFFER.BUF]
1592	}
1593
1594	proc QBufCheckFld { } {
1595	global qbufdisp
1596	set flds { a b c aa bb cc ec es ef hc kc lc hs ks ls pts \
1597	hkl11 hkl12 hkl13 a1 hkl21 hkl22 hkl23 \
1598	tmp it tw th0 ter hf mon mpf ihf hfw hfh th }
1599	foreach fld $flds {
1600	# Check to make sure these are floating point numbers
1601	if [catch { expr 1.0 * $qbufdisp($fld) } result] {
1602	set qbufdisp($fld) "--------"
1603	return -code error "Parameter \"$fld\" must be floating point number"
1604	}
1605	}
1606	}
1607
1608	proc QBufWriteRec { file rec } {
1609	upvar $rec r
1610
1611	set pad1 0
1612	set pad2 0
1613	set recval [binary format \
1614	A50sfffffffffA3cffffffffffffffffffffffA4iiiiffff \
1615	$r(comment) $pad1 \
1616	$r(a) $r(b) $r(c) $r(aa) $r(bb) $r(cc) $r(ec) \
1617	$r(es) $r(ef) $r(eft) $pad2 \
1618	$r(hc) $r(kc) $r(lc) $r(hs) $r(ks) $r(ls) $r(pts) \
1619	$r(hkl11) $r(hkl12) $r(hkl13) $r(a1) \
1620	$r(hkl21) $r(hkl22) $r(hkl23) \
1621	$r(tmp) $r(it) $r(tw) $r(th0) $r(ter) \
1622	$r(hf) $r(mon) $r(mpf) $r(mt) \
1623	$r(flip1) $r(flip2) $r(flip3) $r(flip4) \
1624	$r(ihf) $r(hfw) $r(hfh) $r(th)]
1625	set record [binary format A320 $recval]
1626	puts -nonewline $file $record
1627	string length $record
1628	}
1629
1630	proc QBufWriteFile { } {
1631	global qbuf qbuf_fields
1632
1633	set f [open QBUFFER.BUF w]
1634	fconfigure $f -encoding binary
1635	for {set i 0} {$i < 30} {incr i} {
1636	foreach fld $qbuf_fields {
1637	set icpout($fld) $qbuf($i,$fld)
1638	}
1639	QBufWriteRec $f icpout
1640	}
1641	puts -nonewline $f [binary format A320 "\#"]
1642	close $f
1643	set qbuf(mtime) [file mtime QBUFFER.BUF]
1644	}
1645
1646	proc QBufList { } {
1647	# Clear out our list if it contains anything.
1648	set lbox .l.list
1649	set start [expr int([lindex [$lbox yview] 0] * [$lbox index end])]
1650	$lbox delete 0 end
1651	#$lbox configure -font fixed
1652	for {set i 0} {$i < 30} {incr i} {
1653	$lbox insert end [QBufFormatRec $i]
1654	}
1655	global text_only
1656	if $text_only {
1657	$lbox selection set 0 0
1658	}
1659
1660	$lbox yview $start
1661	bind $lbox <ButtonRelease-1> "QBufDisp \[$lbox curselection\]; set changed(qbufdisp) 0"
1662	if $text_only {
1663	set bind_type <Linefeed>
1664	} else {
1665	set bind_type <Return>
1666	}
1667	bind $lbox $bind_type "QBufDisp \[$lbox curselection\]; set changed(qbufdisp) 0"
1668	}
1669
1670	proc QBufFormatRec { recno } {
1671	global qbuf
1672	set output [format "%2d " [expr $recno + 1]]
1673	append output [binary format A20 $qbuf($recno,comment)]
1674	append output " "
1675	append output [format "%6.2f " $qbuf($recno,hc)]
1676	append output [format "%6.2f " $qbuf($recno,kc)]
1677	append output [format "%6.2f " $qbuf($recno,lc)]
1678	append output [format "%4.2f " $qbuf($recno,ec)]
1679	append output [format "%4.2f " $qbuf($recno,es)]
1680	append output [format "%2.0f\* " $qbuf($recno,mpf)]
1681	append output [format "%6.0f " $qbuf($recno,mon)]
1682	append output [binary format A4 $qbuf($recno,mt)]
1683	return $output
1684	}
1685
1686	proc QBufDisp { recno } {
1687	global qbufdisp qbuf qbuf_fields config changed
1688
1689	set num [format "%2d" [expr $recno + 1]]
1690	set qbufdisp(label) "QBuffer No: $num"
1691	set qbufdisp(current) $recno
1692	set mtime [file mtime QBUFFER.BUF]
1693	if {$mtime != $qbuf(mtime)} {
1694	QBufReadFile
1695	QBufList
1696	}
1697	if {$config(paranoid)} { CheckBufChange }
1698
1699	foreach fld $qbuf_fields {
1700	set qbufdisp($fld) $qbuf($recno,$fld)
1701	}
1702
1703	if [catch {expr $qbufdisp(pts) * 1} qbufdisp(pts)] {
1704	set qbufdisp(pts) 1
1705	}
1706
1707	# Trim floating point numbers to sensible decimal places
1708	set flfields { a b c aa bb cc ec es ef hc kc lc hs ks ls pts \
1709	hkl11 hkl12 hkl13 a1 hkl21 hkl22 hkl23 }
1710	foreach f $flfields {
1711	set qbufdisp($f) [fltrim $qbufdisp($f) 10000]
1712	}
1713
1714	set qbufdisp(hkl1) [format "%2d,%2d,%2d" [expr int($qbufdisp(hkl11))] \
1715	[expr int($qbufdisp(hkl12))] [expr int($qbufdisp(hkl13))]]
1716
1717	set qbufdisp(hkl2) [format "%2d,%2d,%2d" [expr int($qbufdisp(hkl21))] \
1718	[expr int($qbufdisp(hkl22))] [expr int($qbufdisp(hkl23))]]
1719
1720	# clear changed flag
1721	set changed(qbufdisp) 0
1722	}
1723
1724	proc QBufUpdate { } {
1725	global qbufdisp qbuf changed
1726
1727	if [catch {QBufCheckFld} result] {
1728	return -code error $result
1729	}
1730
1731	set recno $qbufdisp(current)
1732	foreach fld [array names qbufdisp] {
1733	set qbuf($recno,$fld) $qbufdisp($fld)
1734	}
1735	# update display on the list
1736	.l.list delete $recno
1737	.l.list insert $recno [QBufFormatRec $recno]
1738	# update buffer information on disk
1739	QBufWriteFile
1740
1741	}
1742
1743	proc QBufFieldDialog { } {
1744	global qbufdisp qbuf text_only
1745
1746	if [winfo exists .field_q] {
1747	wm deiconify .field_q
1748	return .field_q
1749	}
1750
1751
1752	toplevel .field_q
1753
1754	label .field_q.title -text "MAGNETIC FIELD"
1755	label .field_q.initlab -text "Initial Field (user units):"
1756	label .field_q.incrlab -text "Field Increment (user units):"
1757	label .field_q.waitlab -text "Max Wait Per Point (secs) :"
1758	entry .field_q.initentry -textvariable qbufdisp(hf) -width 10
1759	entry .field_q.increntry -textvariable qbufdisp(ihf) -width 10
1760	entry .field_q.waitentry -textvariable qbufdisp(ihw) -width 10
1761	label .field_q.t1 -text "(Wait used in non-persistent mode on SC only)"
1762	label .field_q.t2 -text "(Reply 0 to get default optimum wait times)"
1763	button .field_q.dismiss -text "Dismiss" -command QBufFieldDialogDismiss
1764	if $text_only {
1765	grid .field_q.title -row 0 -column 0 -columnspan 2 -sticky news
1766	label .field_q.blank1 -text " "
1767	grid .field_q.blank1 -row 1
1768	grid .field_q.initlab -row 2 -column 0 -sticky w
1769	grid .field_q.incrlab -row 3 -column 0 -sticky w
1770	grid .field_q.waitlab -row 4 -column 0 -sticky w
1771	grid .field_q.initentry -row 2 -column 1
1772	grid .field_q.increntry -row 3 -column 1
1773	grid .field_q.waitentry -row 4 -column 1
1774	label .field_q.blank2 -text " "
1775	grid .field_q.blank2 -row 5
1776	grid .field_q.t1 -row 6 -column 0 -columnspan 2 -sticky ew
1777	grid .field_q.t2 -row 7 -column 0 -columnspan 2 -sticky ew
1778	label .field_q.blank3 -text " "
1779	grid .field_q.blank3 -row 8
1780	grid .field_q.dismiss -row 9 -column 0 -columnspan 2 -sticky ew
1781	place .field_q -relheight 1.0 -relwidth 1.0
1782	focus .field_q
1783	} else {
1784	wm protocol .field_q WM_DELETE_WINDOW ".field_q.dismiss invoke"
1785	grid .field_q.title -row 0 -column 0 -columnspan 2 -sticky news
1786	grid .field_q.initlab -row 1 -column 0
1787	grid .field_q.incrlab -row 2 -column 0
1788	grid .field_q.waitlab -row 3 -column 0
1789	grid .field_q.initentry -row 1 -column 1
1790	grid .field_q.increntry -row 2 -column 1
1791	grid .field_q.waitentry -row 3 -column 1
1792	grid .field_q.t1 -row 4 -column 0 -columnspan 2 -sticky ew
1793	grid .field_q.t2 -row 5 -column 0 -columnspan 2 -sticky ew
1794	grid .field_q.dismiss -row 6 -column 0 -columnspan 2 -sticky ew
1795	}
1796	return .field_q
1797	}
1798
1799	proc QBufFieldDialogDismiss { } {
1800	global text_only
1801	wm withdraw .field_q
1802	}
1803
1804	proc QBufPolDialogBuild { } {
1805	global qbufdisp text_only
1806	set p [toplevel .polarize_q]
1807	label $p.title -text "Polarization Setup"
1808	set f [frame $p.f]
1809	set d [button $p.dismiss -text "Dismiss" -command QBufPolDialogHide]
1810
1811	label $f.flip1t -text "Flipper 1"
1812	label $f.flip2t -text "Flipper 2"
1813	label $f.flipet -text "Execute ?"
1814	frame $f.flip1
1815	frame $f.flip2
1816	frame $f.flipe
1817	label $f.flip1.a -text "OFF"
1818	label $f.flip1.b -text "ON"
1819	label $f.flip1.c -text "OFF"
1820	label $f.flip1.d -text "ON"
1821	label $f.flip2.a -text "OFF"
1822	label $f.flip2.b -text "OFF"
1823	label $f.flip2.c -text "ON"
1824	label $f.flip2.d -text "ON"
1825	#toggle_create $f.flipe.a qbufdisp(flip1)
1826	#toggle_create $f.flipe.b qbufdisp(flip2)
1827	#toggle_create $f.flipe.c qbufdisp(flip3)
1828	#toggle_create $f.flipe.d qbufdisp(flip4)
1829	tk_optionMenu $f.flipe.a qbufdisp(flip1) 0 1
1830	tk_optionMenu $f.flipe.b qbufdisp(flip2) 0 1
1831	tk_optionMenu $f.flipe.c qbufdisp(flip3) 0 1
1832	tk_optionMenu $f.flipe.d qbufdisp(flip4) 0 1
1833
1834	if {!$text_only} {
1835	$f.flip1t configure -relief ridge
1836	$f.flip2t configure -relief ridge
1837	$f.flipet configure -relief ridge
1838	$f.flip1 configure -relief ridge -borderwidth 2
1839	$f.flip2 configure -relief ridge -borderwidth 2
1840	$f.flipe configure -relief ridge -borderwidth 2
1841	$f.flip1.a configure -pady 5
1842	$f.flip1.b configure -pady 5
1843	$f.flip1.c configure -pady 5
1844	$f.flip1.d configure -pady 5
1845	$f.flip2.a configure -pady 5
1846	$f.flip2.b configure -pady 5
1847	$f.flip2.c configure -pady 5
1848	$f.flip2.d configure -pady 5
1849	}
1850
1851	pack $p.title $f $d -side top -fill x
1852	grid $f.flip1t $f.flip2t $f.flipet -sticky ew
1853	grid $f.flip1 $f.flip2 $f.flipe -sticky ew
1854	pack $f.flip1.a $f.flip1.b $f.flip1.c $f.flip1.d -side top
1855	pack $f.flip2.a $f.flip2.b $f.flip2.c $f.flip2.d -side top
1856	pack $f.flipe.a $f.flipe.b $f.flipe.c $f.flipe.d -side top -fill x
1857	return $p
1858	}
1859
1860	proc QBufPolDialogHide { } {
1861	global text_only
1862	if $text_only {
1863	destroy .polarize_q
1864	} else {
1865	wm withdraw .polarize_q
1866	}
1867	}
1868
1869	proc QBufPolDialogShow { } {
1870	global text_only
1871
1872	if $text_only {
1873	catch { destroy .polarize_q }
1874	QBufPolDialogBuild
1875	place .polarize_q -relheight 1.0 -relwidth 1.0
1876	focus .polarize_q
1877	} else {
1878	if [winfo exists .polarize_q] {
1879	wm deiconify .polarize_q
1880	} else {
1881	QBufPolDialogBuild
1882	}
1883	}
1884	}
1885
1886	proc QBufHKL { which args } {
1887	global qbufdisp changed
1888	if {$which == 1} {
1889	set no 1
1890	} else {
1891	set no 2
1892	}
1893	set key "hkl$no"
1894	if {[catch {scan $qbufdisp($key) "%d,%d,%d" h k l} result]} {
1895	set qbufdisp($key) "-------"
1896	return
1897	}
1898
1899	# Write string back out again
1900	if {$which == 1} {
1901	if {$result == 3} {
1902	set qbufdisp(hkl11) $h
1903	set qbufdisp(hkl12) $k
1904	set qbufdisp(hkl13) $l
1905	}
1906	set qbufdisp(hkl1) [format "%2d,%2d,%2d" [expr int($qbufdisp(hkl11))] \
1907	[expr int($qbufdisp(hkl12))] [expr int($qbufdisp(hkl13))]]
1908	} else {
1909	if {$result == 3} {
1910	set qbufdisp(hkl21) $h
1911	set qbufdisp(hkl22) $k
1912	set qbufdisp(hkl23) $l
1913	}
1914	set qbufdisp(hkl2) [format "%2d,%2d,%2d" [expr int($qbufdisp(hkl21))] \
1915	[expr int($qbufdisp(hkl22))] [expr int($qbufdisp(hkl23))]]
1916	}
1917	set changed(qbufdisp) 0
1918	}
1919
1920	#=B BUFFER=====================================================================
1921
1922	proc BBufEntryCreate { p } {
1923	global bbuf bbufdisp config text_only
1924
1925	# Create widgets
1926	label $p.bufnolabel -textvariable bbufdisp(label)
1927	label $p.commentlabel -text "Comment:"
1928	entry $p.comment -textvariable bbufdisp(comment)
1929
1930
1931	label $p.latlabel -text "Lattice:"
1932	label $p.alabel -text "a:"
1933	entry $p.a -textvariable bbufdisp(a) -width 6
1934	label $p.blabel -text "b:"
1935	entry $p.b -textvariable bbufdisp(b) -width 6
1936	label $p.clabel -text "c:"
1937	entry $p.c -textvariable bbufdisp(c) -width 6
1938	label $p.aalabel -text "aa:"
1939	entry $p.aa -textvariable bbufdisp(aa) -width 6
1940	label $p.bblabel -text "bb:"
1941	entry $p.bb -textvariable bbufdisp(bb) -width 6
1942	label $p.cclabel -text "cc:"
1943	entry $p.cc -textvariable bbufdisp(cc) -width 6
1944
1945	label $p.energylabel -text "Energy:"
1946	label $p.eclabel -text "EC:"
1947	label $p.ec -textvariable bbufdisp(ec) -width 6
1948	label $p.eslabel -text "ES:"
1949	entry $p.es -textvariable bbufdisp(es) -width 6
1950	label $p.eflabel -text "EF:"
1951	entry $p.ef -textvariable bbufdisp(ef) -width 6
1952	label $p.eftlabel -text "EFT:"
1953	if {!$text_only} {
1954	tk_optionMenu $p.eft bbufdisp(eft) ANA MON
1955	} else {
1956	ck_optionMenu $p.eft bbufdisp(eft) ANA MON
1957	}
1958
1959	label $p.spacelabel -text "Space:"
1960	label $p.hclabel -text "HC:"
1961	entry $p.hc -textvariable bbufdisp(hc) -width 6
1962	label $p.kclabel -text "KC:"
1963	entry $p.kc -textvariable bbufdisp(kc) -width 6
1964	label $p.lclabel -text "LC:"
1965	entry $p.lc -textvariable bbufdisp(lc) -width 6
1966	label $p.hslabel -text "HS:"
1967	entry $p.hs -textvariable bbufdisp(hs) -width 6
1968	label $p.kslabel -text "KS:"
1969	entry $p.ks -textvariable bbufdisp(ks) -width 6
1970	label $p.lslabel -text "LS:"
1971	entry $p.ls -textvariable bbufdisp(ls) -width 6
1972
1973	label $p.orientlabel -text "Orient:"
1974	frame $p.orient
1975	label $p.orient.hkl1label -text "(h k l):"
1976	entry $p.orient.hkl1 -textvariable bbufdisp(hkl1) -width 6
1977	label $p.orient.a1label -text "Angle:"
1978	entry $p.orient.a1 -textvariable bbufdisp(a1) -width 6
1979	label $p.orient.hkl2label -text "(h k l)':"
1980	entry $p.orient.hkl2 -textvariable bbufdisp(hkl2) -width 6
1981	pack $p.orient.hkl1label $p.orient.hkl1 $p.orient.a1label \
1982	$p.orient.a1 $p.orient.hkl2label $p.orient.hkl2 -side left
1983
1984	label $p.templabel -text "Temp/H:"
1985	frame $p.temp
1986	label $p.temp.t0label -text "T0:"
1987	entry $p.temp.t0 -textvariable bbufdisp(tmp) -width 6
1988	label $p.temp.tinclabel -text "Inc-T:"
1989	entry $p.temp.tinc -textvariable bbufdisp(it) -width 6
1990	label $p.temp.twlabel -text "Wait:"
1991	entry $p.temp.tw -textvariable bbufdisp(tw) -width 6
1992	label $p.temp.terlabel -text "Err:"
1993	entry $p.temp.ter -textvariable bbufdisp(ter) -width 6
1994	label $p.temp.th0label -text "Hld0:"
1995	entry $p.temp.th0 -textvariable bbufdisp(th0) -width 6
1996	button $p.temp.field -text FIELD -command QBufFieldDialog
1997	pack $p.temp.t0label $p.temp.t0 $p.temp.tinclabel $p.temp.tinc \
1998	$p.temp.twlabel $p.temp.tw $p.temp.terlabel $p.temp.ter \
1999	$p.temp.th0label $p.temp.th0 $p.temp.field -side left
2000
2001	label $p.timelabel -text "Time:"
2002	frame $p.time
2003	label $p.time.monlabel -text "Monitor:"
2004	entry $p.time.mon -textvariable bbufdisp(mon) -width 6
2005	label $p.time.mpflabel -text "Prefac:"
2006	entry $p.time.mpf -textvariable bbufdisp(mpf) -width 6
2007	label $p.time.mtlabel -text "M-typ:"
2008	if {!$text_only} {
2009	tk_optionMenu $p.time.mt bbufdisp(mt) TIME NEUT
2010	} else {
2011	ck_optionMenu $p.time.mt bbufdisp(mt) TIME NEUT
2012	}
2013	button $p.time.pol -text "POLARIZE" -command BBufPolDialogShow \
2014	-state $config(pola_state)
2015
2016	pack $p.time.monlabel $p.time.mon $p.time.mpflabel $p.time.mpf \
2017	$p.time.mtlabel $p.time.mt $p.time.pol -side left
2018
2019	label $p.anglabel -text "Angles:"
2020	label $p.i3lab -text "Inc-3:"
2021	entry $p.i3 -textvariable bbufdisp(i_3) -width 6
2022	label $p.i4lab -text "Inc-4:"
2023	entry $p.i4 -textvariable bbufdisp(i_4) -width 6
2024	label $p.r3lab -text "A3-range:"
2025	entry $p.r3 -textvariable bbufdisp(r_3) -width 6
2026	label $p.r4lab -text "A4-range:"
2027	entry $p.r4 -textvariable bbufdisp(r_4) -width 6
2028
2029	label $p.nptslabel -text "NPTS:"
2030	entry $p.npts -textvariable bbufdisp(pts) -width 6
2031
2032
2033	# Pack widgets into parent
2034	grid $p.bufnolabel $p.commentlabel
2035	grid $p.comment -row 0 -column 2 -columnspan 6 -sticky ew
2036	grid $p.latlabel $p.alabel $p.a $p.blabel $p.b $p.clabel $p.c \
2037	$p.aalabel $p.aa $p.bblabel $p.bb $p.cclabel $p.cc
2038
2039	grid $p.energylabel $p.eclabel $p.ec $p.eslabel $p.es $p.eflabel $p.ef \
2040	$p.eftlabel $p.eft
2041
2042	grid $p.spacelabel $p.hclabel $p.hc $p.kclabel $p.kc $p.lclabel $p.lc \
2043	$p.hslabel $p.hs $p.kslabel $p.ks $p.lslabel $p.ls
2044
2045	grid $p.orientlabel $p.orient - - - - - -
2046	grid $p.templabel $p.temp - - - - - -
2047	grid $p.timelabel $p.time - - - - - -
2048
2049	grid $p.anglabel $p.i3lab $p.i3 $p.r3lab $p.r3 $p.nptslabel $p.npts
2050	grid x $p.i4lab $p.i4 $p.r4lab $p.r4
2051
2052	# Set up widget bindings
2053	bind $p.orient.hkl1 <FocusOut> "BBufHKL 1"
2054	bind $p.orient.hkl1 <Return> "BBufHKL 1"
2055	bind $p.orient.hkl2 <FocusOut> "BBufHKL 2"
2056	bind $p.orient.hkl2 <Return> "BBufHKL 2"
2057
2058	bind $p.i3 <Return> "BBufAngleBinding bbufdisp i_3 w"
2059	bind $p.i3 <FocusOut> "BBufAngleBinding bbufdisp i_3 w"
2060	bind $p.i4 <Return> "BBufAngleBinding bbufdisp i_4 w"
2061	bind $p.i4 <FocusOut> "BBufAngleBinding bbufdisp i_4 w"
2062	bind $p.r3 <Return> "BBufAngleBinding bbufdisp r_3 w"
2063	bind $p.r3 <FocusOut> "BBufAngleBinding bbufdisp r_3 w"
2064	bind $p.r4 <Return> "BBufAngleBinding bbufdisp r_4 w"
2065	bind $p.r4 <FocusOut> "BBufAngleBinding bbufdisp r_4 w"
2066
2067	bind $p.npts <Return> "BBufCalcRange"
2068	bind $p.npts <FocusOut> "BBufCalcRange"
2069
2070	return $p
2071	}
2072
2073	proc BBufInit { } {
2074	global bbuf
2075	array set bbuf {buftype Bragg}
2076	for {set i 0} {$i < 30} {incr i} {
2077	set bbuf($i,comment) "empty"
2078	set bbuf($i,a) 5.000
2079	set bbuf($i,b) 5.000
2080	set bbuf($i,c) 5.000
2081	set bbuf($i,aa) 90.00
2082	set bbuf($i,bb) 90.00
2083	set bbuf($i,cc) 90.00
2084	set bbuf($i,ec) 0.0
2085	set bbuf($i,es) 0.0
2086	set bbuf($i,ef) 14.70
2087	set bbuf($i,eft) ANA
2088	set bbuf($i,hc) 1.0
2089	set bbuf($i,kc) 0.0
2090	set bbuf($i,lc) 0.0
2091	set bbuf($i,hs) 0.1
2092	set bbuf($i,ks) 0.0
2093	set bbuf($i,ls) 0.0
2094	set bbuf($i,hkl11) 1
2095	set bbuf($i,hkl12) 0
2096	set bbuf($i,hkl13) 0
2097	set bbuf($i,a1) 0.0
2098	set bbuf($i,hkl21) 0
2099	set bbuf($i,hkl22) 0
2100	set bbuf($i,hkl23) 1
2101	set bbuf($i,hkl1) " 1, 0, 0"
2102	set bbuf($i,hkl2) " 0, 0, 1"
2103	set bbuf($i,tmp) 0
2104	set bbuf($i,it) 0
2105	set bbuf($i,tw) 0
2106	set bbuf($i,ter) 0
2107	set bbuf($i,th0) 0
2108	set bbuf($i,th) 0
2109	set bbuf($i,mon) 1000
2110	set bbuf($i,mpf) 1
2111	set bbuf($i,mt) TIME
2112	set bbuf($i,pts) 1
2113	set bbuf($i,flip1) 0
2114	set bbuf($i,flip2) 0
2115	set bbuf($i,flip3) 0
2116	set bbuf($i,flip4) 0
2117	set bbuf($i,a_1) 0.0
2118	set bbuf($i,a_2) 0.0
2119	set bbuf($i,a_3) 0.0
2120	set bbuf($i,a_4) 0.0
2121	set bbuf($i,a_5) 0.0
2122	set bbuf($i,a_6) 0.0
2123	set bbuf($i,i_1) 0.0
2124	set bbuf($i,i_2) 0.0
2125	set bbuf($i,i_3) 0.0
2126	set bbuf($i,i_4) 0.0
2127	set bbuf($i,i_5) 0.0
2128	set bbuf($i,i_6) 0.0
2129	set bbuf($i,r_3) 0.0
2130	set bbuf($i,r_4) 0.0
2131	set bbuf($i,hf) 0
2132	set bbuf($i,ihf) 0
2133	set bbuf($i,hfw) 0
2134	set bbuf($i,hfh) 0
2135	}
2136	set bbuf(currentrec) 0
2137	set bbuf(mtime) 0
2138	}
2139
2140	proc BBufReadRec { file rec } {
2141	upvar $rec r
2142	set input [read $file 320]
2143	binary scan $input \
2144	A50sfffffffffA3cffffffffffffffffffffffA4iiiiffffffffffffffff \
2145	r(comment) pad1 \
2146	r(a) r(b) r(c) r(aa) r(bb) r(cc) r(ec) r(es) r(ef) r(eft) pad2 \
2147	r(hc) r(kc) r(lc) r(hs) r(ks) r(ls) r(pts) \
2148	r(hkl11) r(hkl12) r(hkl13) r(a1) r(hkl21) r(hkl22) r(hkl23) \
2149	r(tmp) r(it) r(tw) r(th0) r(ter) \
2150	r(hf) r(mon) r(mpf) r(mt) \
2151	r(flip1) r(flip2) r(flip3) r(flip4) \
2152	r(a_1) r(a_2) r(a_3) r(a_4) r(a_5) r(a_6) \
2153	r(i_1) r(i_2) r(i_3) r(i_4) r(i_5) r(i_6) \
2154	r(ihf) r(hfw) r(hfh) r(th)
2155	}
2156
2157	proc BBufReadFile { } {
2158	global bbuf bbuf_fields
2159
2160	set f [open BBUFFER.BUF r]
2161	fconfigure $f -encoding binary
2162	for {set i 0} {$i < 30} {incr i} {
2163	BBufReadRec $f icpin
2164	foreach fld $bbuf_fields {
2165	if {![catch {set icpin($fld)} result]} {
2166	set bbuf($i,$fld) $result
2167	}
2168	}
2169	}
2170	close $f
2171	set bbuf(mtime) [file mtime BBUFFER.BUF]
2172	}
2173
2174	proc BBufCheckFld { } {
2175	global bbufdisp
2176	set flds { a b c aa bb cc ec es ef hc kc lc hs ks ls pts \
2177	hkl11 hkl12 hkl13 a1 hkl21 hkl22 hkl23 \
2178	tmp it tw th0 ter hf mon mpf \
2179	a_1 a_2 a_3 a_4 a_5 a_6 i_1 i_2 i_3 i_4 i_5 i_6 \
2180	ihf hfw hfh th }
2181	foreach fld $flds {
2182	# Check to make sure these are floating point numbers
2183	if [catch { expr 1.0 * $bbufdisp($fld) } result] {
2184	set bbufdisp($fld) "--------"
2185	return -code error "Parameter \"$fld\" must be floating point number"
2186	}
2187	}
2188	}
2189
2190	proc BBufWriteRec { file rec } {
2191	upvar $rec r
2192
2193	set pad1 0
2194	set pad2 0
2195	set recval [binary format \
2196	A50sfffffffffA3cffffffffffffffffffffffA4iiiiffffffffffffffff \
2197	$r(comment) $pad1 \
2198	$r(a) $r(b) $r(c) $r(aa) $r(bb) $r(cc) $r(ec) \
2199	$r(es) $r(ef) $r(eft) $pad2 \
2200	$r(hc) $r(kc) $r(lc) $r(hs) $r(ks) $r(ls) $r(pts) \
2201	$r(hkl11) $r(hkl12) $r(hkl13) $r(a1) \
2202	$r(hkl21) $r(hkl22) $r(hkl23) \
2203	$r(tmp) $r(it) $r(tw) $r(th0) $r(ter) \
2204	$r(hf) $r(mon) $r(mpf) $r(mt) \
2205	$r(flip1) $r(flip2) $r(flip3) $r(flip4) \
2206	$r(a_1) $r(a_2) $r(a_3) $r(a_4) $r(a_5) $r(a_6) \
2207	$r(i_1) $r(i_2) $r(i_3) $r(i_4) $r(i_5) $r(i_6) \
2208	$r(ihf) $r(hfw) $r(hfh) $r(th)]
2209	set record [binary format A320 $recval]
2210	puts -nonewline $file $record
2211	string length $record
2212	}
2213
2214	proc BBufWriteFile { } {
2215	global bbuf bbuf_fields
2216
2217	set f [open BBUFFER.BUF w]
2218	fconfigure $f -encoding binary
2219	for {set i 0} {$i < 30} {incr i} {
2220	foreach fld $bbuf_fields {
2221	set icpout($fld) $bbuf($i,$fld)
2222	}
2223	BBufWriteRec $f icpout
2224	}
2225	puts -nonewline $f [binary format A320 "\#"]
2226	close $f
2227	set bbuf(mtime) [file mtime BBUFFER.BUF]
2228	}
2229
2230	proc BBufList { } {
2231	global text_only
2232	# Clear out our list if it contains anything.
2233	set lbox .l.list
2234	set start [expr int([lindex [$lbox yview] 0] * [$lbox index end])]
2235	$lbox delete 0 end
2236	#$lbox configure -font fixed
2237	for {set i 0} {$i < 30} {incr i} {
2238	$lbox insert end [BBufFormatRec $i]
2239	}
2240
2241	$lbox yview $start
2242	bind $lbox <ButtonRelease-1> "BBufDisp \[$lbox curselection\]"
2243	if $text_only {
2244	set bind_type <Linefeed>
2245	} else {
2246	set bind_type <Return>
2247	}
2248	bind $lbox $bind_type "BBufDisp \[$lbox curselection\]"
2249	}
2250
2251	proc BBufFormatRec { recno } {
2252	global bbuf
2253	set output [format "%2d " [expr $recno + 1]]
2254	append output [binary format A20 $bbuf($recno,comment)]
2255	append output " "
2256	append output [format "%6.2f " $bbuf($recno,hc)]
2257	append output [format "%6.2f " $bbuf($recno,kc)]
2258	append output [format "%6.2f " $bbuf($recno,lc)]
2259	append output [format "%4.2f " $bbuf($recno,ec)]
2260	append output [format "%4.2f " $bbuf($recno,es)]
2261	append output [format "%2.0f\* " $bbuf($recno,mpf)]
2262	append output [format "%6.0f " $bbuf($recno,mon)]
2263	append output [binary format A4 $bbuf($recno,mt)]
2264	return $output
2265	}
2266
2267	proc BBufDisp { recno } {
2268	global bbufdisp bbuf bbuf_fields config
2269
2270	set mtime [file mtime BBUFFER.BUF]
2271	if {$mtime != $bbuf(mtime)} {
2272	BBufReadFile
2273	BBufList
2274	}
2275
2276	if {$config(paranoid)} { CheckBufChange }
2277
2278	foreach fld $bbuf_fields {
2279	set bbufdisp($fld) $bbuf($recno,$fld)
2280	}
2281	set num [format "%2d" [expr $recno + 1]]
2282	set bbufdisp(label) "BBuffer No: $num"
2283	set bbufdisp(current) $recno
2284	if [catch {expr $bbufdisp(pts) * 1} bbufdisp(pts)] {
2285	set bbufdisp(pts) 1
2286	}
2287
2288	set bbufdisp(hkl1) [format "%2d,%2d,%2d" [expr int($bbufdisp(hkl11))] \
2289	[expr int($bbufdisp(hkl12))] [expr int($bbufdisp(hkl13))]]
2290
2291	set bbufdisp(hkl2) [format "%2d,%2d,%2d" [expr int($bbufdisp(hkl21))] \
2292	[expr int($bbufdisp(hkl22))] [expr int($bbufdisp(hkl23))]]
2293
2294	BBufCalcRange
2295
2296	# clear changed flag
2297	set changed(bbufdisp) 0
2298	}
2299
2300	proc BBufUpdate { } {
2301	global bbufdisp bbuf changed
2302
2303	if [catch {BBufCheckFld} result] {
2304	return -code error $result
2305	}
2306
2307	set recno $bbufdisp(current)
2308	foreach fld [array names bbufdisp] {
2309	set bbuf($recno,$fld) $bbufdisp($fld)
2310	}
2311	# update display on the list
2312	.l.list delete $recno
2313	.l.list insert $recno [BBufFormatRec $recno]
2314	# update buffer information on disk
2315	BBufWriteFile
2316
2317	set changed(bbufdisp) 0
2318	}
2319
2320	proc BBufFieldDialog { } {
2321	global bbufdisp bbuf text_only
2322
2323	if [winfo exists .field_b] {
2324	wm deiconify .field_b
2325	return .field_b
2326	}
2327
2328	toplevel .field_b
2329
2330	label .field_b.title -text "MAGNETIC FIELD"
2331	label .field_b.initlab -text "Initial Field (user units):"
2332	label .field_b.incrlab -text "Field Increment (user units):"
2333	label .field_b.waitlab -text "Max Wait Per Point (secs) :"
2334	entry .field_b.initentry -textvariable bbufdisp(hf) -width 10
2335	entry .field_b.increntry -textvariable bbufdisp(ihf) -width 10
2336	entry .field_b.waitentry -textvariable bbufdisp(ihw) -width 10
2337	label .field_b.t1 -text "(Wait used in non-persistent mode on SC only)"
2338	label .field_b.t2 -text "(Reply 0 to get default optimum wait times)"
2339	button .field_b.dismiss -text "Dismiss" -command BBufFieldDialogDismiss
2340	if $text_only {
2341	grid .field_b.title -row 0 -column 0 -columnspan 2 -sticky news
2342	label .field_b.blank1 -text " "
2343	grid .field_b.blank1 -row 1
2344	grid .field_b.initlab -row 2 -column 0 -sticky w
2345	grid .field_b.incrlab -row 3 -column 0 -sticky w
2346	grid .field_b.waitlab -row 4 -column 0 -sticky w
2347	grid .field_b.initentry -row 2 -column 1
2348	grid .field_b.increntry -row 3 -column 1
2349	grid .field_b.waitentry -row 4 -column 1
2350	label .field_b.blank2 -text " "
2351	grid .field_b.blank2 -row 5
2352	grid .field_b.t1 -row 6 -column 0 -columnspan 2 -sticky ew
2353	grid .field_b.t2 -row 7 -column 0 -columnspan 2 -sticky ew
2354	label .field_b.blank3 -text " "
2355	grid .field_b.blank3 -row 8
2356	grid .field_b.dismiss -row 9 -column 0 -columnspan 2 -sticky ew
2357	place .field_b -relheight 1.0 -relwidth 1.0
2358	focus .field_b
2359	} else {
2360	wm protocol .field_b WM_DELETE_WINDOW ".field_b.dismiss invoke"
2361	grid .field_b.title -row 0 -column 0 -columnspan 2 -sticky news
2362	grid .field_b.initlab -row 1 -column 0
2363	grid .field_b.incrlab -row 2 -column 0
2364	grid .field_b.waitlab -row 3 -column 0
2365	grid .field_b.initentry -row 1 -column 1
2366	grid .field_b.increntry -row 2 -column 1
2367	grid .field_b.waitentry -row 3 -column 1
2368	grid .field_b.t1 -row 4 -column 0 -columnspan 2 -sticky ew
2369	grid .field_b.t2 -row 5 -column 0 -columnspan 2 -sticky ew
2370	grid .field_b.dismiss -row 6 -column 0 -columnspan 2 -sticky ew
2371	}
2372	return .field_b
2373	}
2374
2375	proc BBufFieldDialogDismiss { } {
2376	global text_only
2377
2378	wm withdraw .field_b
2379	}
2380
2381	proc BBufPolDialogBuild { } {
2382	global bbufdisp text_only
2383	set p [toplevel .polarize_b]
2384	label $p.title -text "Polarization Setup"
2385	set f [frame $p.f]
2386	set d [button $p.dismiss -text "Dismiss" -command BBufPolDialogHide]
2387
2388	label $f.flip1t -text "Flipper 1"
2389	label $f.flip2t -text "Flipper 2"
2390	label $f.flipet -text "Execute ?"
2391	frame $f.flip1
2392	frame $f.flip2
2393	frame $f.flipe
2394	label $f.flip1.a -text "OFF"
2395	label $f.flip1.b -text "ON"
2396	label $f.flip1.c -text "OFF"
2397	label $f.flip1.d -text "ON"
2398	label $f.flip2.a -text "OFF"
2399	label $f.flip2.b -text "OFF"
2400	label $f.flip2.c -text "ON"
2401	label $f.flip2.d -text "ON"
2402	#toggle_create $f.flipe.a bbufdisp(flip1)
2403	#toggle_create $f.flipe.b bbufdisp(flip2)
2404	#toggle_create $f.flipe.c bbufdisp(flip3)
2405	#toggle_create $f.flipe.d bbufdisp(flip4)
2406	tk_optionMenu $f.flipe.a bbufdisp(flip1) 0 1
2407	tk_optionMenu $f.flipe.b bbufdisp(flip2) 0 1
2408	tk_optionMenu $f.flipe.c bbufdisp(flip3) 0 1
2409	tk_optionMenu $f.flipe.d bbufdisp(flip4) 0 1
2410
2411	if {!$text_only} {
2412	$f.flip1t configure -relief ridge
2413	$f.flip2t configure -relief ridge
2414	$f.flipet configure -relief ridge
2415	$f.flip1 configure -relief ridge -borderwidth 2
2416	$f.flip2 configure -relief ridge -borderwidth 2
2417	$f.flipe configure -relief ridge -borderwidth 2
2418	$f.flip1.a configure -pady 5
2419	$f.flip1.b configure -pady 5
2420	$f.flip1.c configure -pady 5
2421	$f.flip1.d configure -pady 5
2422	$f.flip2.a configure -pady 5
2423	$f.flip2.b configure -pady 5
2424	$f.flip2.c configure -pady 5
2425	$f.flip2.d configure -pady 5
2426	}
2427
2428	pack $p.title $f $d -side top -fill x
2429	grid $f.flip1t $f.flip2t $f.flipet -sticky ew
2430	grid $f.flip1 $f.flip2 $f.flipe -sticky ew
2431	pack $f.flip1.a $f.flip1.b $f.flip1.c $f.flip1.d -side top
2432	pack $f.flip2.a $f.flip2.b $f.flip2.c $f.flip2.d -side top
2433	pack $f.flipe.a $f.flipe.b $f.flipe.c $f.flipe.d -side top -fill x
2434	return $p
2435	}
2436
2437	proc BBufPolDialogHide { } {
2438	global text_only
2439	if $text_only {
2440	destroy .polarize_b
2441	} else {
2442	wm withdraw .polarize_b
2443	}
2444	}
2445
2446	proc BBufPolDialogShow { } {
2447	global text_only
2448
2449	if $text_only {
2450	catch { destroy .polarize_b }
2451	BBufPolDialogBuild
2452	place .polarize_b -relheight 1.0 -relwidth 1.0
2453	focus .polarize_b
2454	} else {
2455	if [winfo exists .polarize_b] {
2456	wm deiconify .polarize_b
2457	} else {
2458	BBufPolDialogBuild
2459	}
2460	}
2461	}
2462
2463	proc BBufHKL { which args } {
2464	global bbufdisp
2465	if {$which == 1} {
2466	set no 1
2467	} else {
2468	set no 2
2469	}
2470	set key "hkl$no"
2471	if {[catch {scan $bbufdisp($key) "%d,%d,%d" h k l} result]} {
2472	set bbufdisp($key) "-------"
2473	return
2474	}
2475
2476	# Write string back out again
2477	if {$which == 1} {
2478	if {$result == 3} {
2479	set bbufdisp(hkl11) $h
2480	set bbufdisp(hkl12) $k
2481	set bbufdisp(hkl13) $l
2482	}
2483	set bbufdisp(hkl1) [format "%2d,%2d,%2d" [expr int($bbufdisp(hkl11))] \
2484	[expr int($bbufdisp(hkl12))] [expr int($bbufdisp(hkl13))]]
2485	} else {
2486	if {$result == 3} {
2487	set bbufdisp(hkl21) $h
2488	set bbufdisp(hkl22) $k
2489	set bbufdisp(hkl23) $l
2490	}
2491	set bbufdisp(hkl2) [format "%2d,%2d,%2d" [expr int($bbufdisp(hkl21))] \
2492	[expr int($bbufdisp(hkl22))] [expr int($bbufdisp(hkl23))]]
2493	}
2494	}
2495
2496	proc BBufCalcRange { args } {
2497	global bbufdisp
2498
2499	if {$bbufdisp(pts) < 0} { set bbufdisp(pts) 1 }
2500	set bbufdisp(r_3) [expr ($bbufdisp(pts)-1) * $bbufdisp(i_3)]
2501	set bbufdisp(r_4) [expr ($bbufdisp(pts)-1) * $bbufdisp(i_4)]
2502	}
2503
2504	proc BBufAngleBinding { args } {
2505	global bbufdisp
2506
2507	if {3 > [llength $args]} { return }
2508	set key [lindex $args 1]
2509	if {[string compare $key "npts"] == 0} {
2510	return [BBufCalcRange]
2511	}
2512	if {![regexp {(i\|r)_(3\|4)} $key match which axis]} {
2513	return
2514	}
2515
2516	switch $which {
2517	r {
2518	set ikey i_${axis}
2519	if {$bbufdisp($ikey) == 0} {
2520	set bbufdisp($key) 0
2521	return
2522	}
2523	set bbufdisp(pts) [expr floor($bbufdisp($key)/$bbufdisp($ikey))+1]
2524	return [BBufCalcRange]
2525	}
2526	i {
2527	return [BBufCalcRange]
2528	}
2529	}
2530	}
2531
2532	#=T BUFFER=====================================================================
2533
2534	# Configuration variables for FANS resolution calculation
2535	set res(col1) 20.0
2536	set res(col2) 20.0
2537	set res(dmono) 1.278
2538	set res(e_fin) 1.2
2539	set res(de_fin) 1.1
2540	set res(e_max) 260.0
2541
2542	# Variables used in calculation of FANS resolution
2543	set res(colp1) [expr $res(col1) / (60.0 * 57.296)]
2544	set res(colp2) [expr $res(col2) / (60.0 * 57.296)]
2545	set res(rmos) [expr 30.0 / (60.0 * 57.296)]
2546	set res(dtheta) [expr sqrt((($res(colp1) * $res(colp2)) * \
2547	($res(colp1) * $res(colp2)) + \
2548	($res(colp1) * $res(rmos)) * ($res(colp1) * $res(rmos)) + \
2549	($res(colp2) * $res(rmos)) * ($res(colp2) * $res(rmos))) / \
2550	($res(colp1) * $res(colp1) + $res(colp2) * $res(colp2) + \
2551	4 * $res(rmos) * $res(rmos)))]
2552
2553	proc fansres { energy } {
2554	global res
2555	set wavelength [expr sqrt(81.805 / ($energy + 1.2))]
2556	set stheta [expr $wavelength / (2 * $res(dmono))]
2557	if {[expr abs($stheta)] < 1.0} {
2558	set cot_theta [expr sqrt(1 - $stheta*$stheta) / $stheta]
2559	} else {
2560	set cot_theta 0.0
2561	}
2562	set de [expr 2.0 * ($energy + $res(e_fin)) * $cot_theta * $res(dtheta)]
2563	return [expr sqrt($res(de_fin) * $res(de_fin) + $de * $de)]
2564	}
2565
2566	proc fansvec { energy0 {npts 1} {de_frac 1.0} } {
2567	global res
2568	if { $npts <= 0 } {
2569	return -code error "Enter positive number of points"
2570	}
2571	if { $energy0 < 0 } {
2572	return -code error "Enter positive starting energy"
2573	}
2574
2575	set vector ""
2576	if {$energy0 < 25.0} {
2577	set en 25.0
2578	set scratch ""
2579	while {$en >= $energy0} {
2580	lappend scratch $en
2581	set de [fansres $en]
2582	#set en [expr $en - $de_frac * $de]
2583	set en [expr floor(($en - $de_frac * $de) * 100) / 100.0]
2584	}
2585	set vector [lrange [lsort -real -increasing $scratch] 0 [expr $npts-1]]
2586	}
2587
2588	set en 25.0
2589	if {([llength $vector] < $npts) && ($en >= $energy0)} {
2590	lappend vector $en
2591	}
2592
2593	while {[llength $vector] < $npts} {
2594	set de [fansres $en]
2595	#set en [expr $en + $de_frac * $de]
2596	set en [expr floor(($en + $de_frac * $de) * 100) / 100.0]
2597	if {$en > $res(e_max)} { break }
2598	if {$en < $energy0} { continue }
2599	lappend vector $en
2600	}
2601	return $vector
2602	}
2603
2604	proc TBufScanBinding { args } {
2605	global tbufdisp
2606	# puts $args
2607	set vec [fansvec $tbufdisp(ec) 1000 $tbufdisp(es)]
2608	set tbufdisp(ec) [lindex $vec 0]
2609	# Unset active traces
2610	# TBufTraceOff
2611
2612	# Ptno binding
2613	set nargs [llength $args]
2614
2615	if {$nargs > 2} {
2616	switch [lindex $args 1] {
2617	ef {
2618	for {set i 0} { $i < [llength $vec]} {incr i} {
2619	if {$i > $tbufdisp(ef)} { break }
2620	}
2621	set tbufdisp(pts) $i
2622	set tbufdisp(ef) [lindex $vec [expr $i - 1]]
2623	}
2624	default {
2625	if {[llength $vec] > $tbufdisp(pts)} {
2626	set tbufdisp(ef) [lindex [lrange $vec 0 \
2627	[expr int($tbufdisp(pts)-1)]] end]
2628	set changed(tbufdisp) 0
2629	} elseif {[llength $vec] < $tbufdisp(pts)} {
2630	set tbufdisp(pts) [llength $vec]
2631	set tbufdisp(ef) [lindex $vec end]
2632	} else {
2633	set tbufdisp(ef) [lindex $vec end]
2634	set changed(tbufdisp) 0
2635	}
2636	}
2637	}
2638	}
2639	update
2640	# Reestablish traces
2641	#TBufTraceOn
2642	}
2643
2644	proc TBufTraceOn { } {
2645	uplevel #0 trace variable tbufdisp(ec) w TBufScanBinding
2646	uplevel #0 trace variable tbufdisp(es) w TBufScanBinding
2647	uplevel #0 trace variable tbufdisp(ef) w TBufScanBinding
2648	uplevel #0 trace variable tbufdisp(pts) w TBufScanBinding
2649	}
2650
2651	proc TBufTraceOff { } {
2652	uplevel #0 trace vdelete tbufdisp(ec) w TBufScanBinding
2653	uplevel #0 trace vdelete tbufdisp(es) w TBufScanBinding
2654	uplevel #0 trace vdelete tbufdisp(ef) w TBufScanBinding
2655	uplevel #0 trace vdelete tbufdisp(pts) w TBufScanBinding
2656	}
2657
2658	proc TBufReadRec { file rec } {
2659	upvar $rec r
2660	set input [read $file 320]
2661	binary scan $input \
2662	A50sfffcc3fffffffffA4ffff \
2663	r(comment) pad1 \
2664	r(ec) r(es) r(ef) \
2665	r(m3) pad2\
2666	r(tmp) r(it) r(tw) r(th0) r(ter) \
2667	r(hf) r(mon) r(mpf) r(pts) \
2668	r(mt) \
2669	r(ihf) r(hfw) r(hfh) r(th)
2670	}
2671
2672	proc TBufReadFile { } {
2673	global tbuf tbuf_fields
2674
2675	set f [open TBUFFER.BUF r]
2676	fconfigure $f -encoding binary
2677	for {set i 0} {$i < 30} {incr i} {
2678	TBufReadRec $f icpin
2679	foreach fld $tbuf_fields {
2680	if {![catch {set icpin($fld)} result]} {
2681	set tbuf($i,$fld) $result
2682	}
2683	}
2684	}
2685	close $f
2686	set tbuf(mtime) [file mtime TBUFFER.BUF]
2687	}
2688
2689	proc TBufCheckFld { } {
2690	global tbufdisp
2691	set flds { ec es ef tmp it tw th0 ter hf mon mpf pts ihf hfw hfh th}
2692	foreach fld $flds {
2693	# Check to make sure these are floating point numbers
2694	if [catch { expr 1.0 * $tbufdisp($fld) } result] {
2695	set tbufdisp($fld) "--------"
2696	return -code error "Parameter \"$fld\" must be floating point number"
2697	}
2698	}
2699	}
2700
2701	proc TBufWriteRec { file rec } {
2702	upvar $rec r
2703
2704	set pad1 0
2705	set pad2 " "
2706	set recval [binary format \
2707	A50sfffcA3fffffffffA4ffff \
2708	$r(comment) $pad1 \
2709	$r(ec) $r(es) $r(ef) \
2710	$r(m3) $pad2\
2711	$r(tmp) $r(it) $r(tw) $r(th0) $r(ter) \
2712	$r(hf) $r(mon) $r(mpf) $r(pts) \
2713	$r(mt) \
2714	$r(ihf) $r(hfw) $r(hfh) $r(th)]
2715	set record [binary format A320 $recval]
2716	puts -nonewline $file $record
2717	string length $record
2718	}
2719
2720
2721	proc TBufWriteFile { } {
2722	global tbuf tbuf_fields
2723
2724	set f [open TBUFFER.BUF w]
2725	fconfigure $f -encoding binary
2726	for {set i 0} {$i < 30} {incr i} {
2727	foreach fld $tbuf_fields {
2728	set icpout($fld) $tbuf($i,$fld)
2729	}
2730	TBufWriteRec $f icpout
2731	}
2732	puts -nonewline $f [binary format A320 "\#"]
2733	close $f
2734	set tbuf(mtime) [file mtime TBUFFER.BUF]
2735	}
2736
2737	proc TBufInit { } {
2738	global tbuf
2739	array set tbuf {buftype Increment}
2740	for {set i 0} {$i < 30} {incr i} {
2741	set tbuf($i,comment) "empty"
2742	set tbuf($i,ec) 10.0
2743	set tbuf($i,es) 1.0
2744	set tbuf($i,ef) 11.1
2745	set tbuf($i,m3) 0
2746	set tbuf($i,tmp) 300
2747	set tbuf($i,it) 0
2748	set tbuf($i,tw) 0
2749	set tbuf($i,th0) 0
2750	set tbuf($i,ter) 1
2751	set tbuf($i,hf) 0
2752	set tbuf($i,mon) 1000
2753	set tbuf($i,mpf) 1
2754	set tbuf($i,pts) 1.0
2755	set tbuf($i,mt) TIME
2756	set tbuf($i,ihf) 0.0
2757	set tbuf($i,hfw) 0.0
2758	set tbuf($i,hfh) 0.0
2759	set tbuf($i,th) 0.0
2760	}
2761	set tbuf(currentrec) 0
2762	set tbuf(mtime) 0
2763	}
2764
2765	proc TBufList { } {
2766	# Clear out our list if it contains anything.
2767	set lbox .l.list
2768	set start [expr int([lindex [$lbox yview] 0] * [$lbox index end])]
2769	$lbox delete 0 end
2770	#$lbox configure -font fixed
2771	for {set i 0} {$i < 30} {incr i} {
2772	$lbox insert end [TBufFormatRec $i]
2773	}
2774	global text_only
2775	if $text_only {
2776	$lbox selection set 0 0
2777	}
2778
2779	$lbox yview $start
2780	bind $lbox <ButtonRelease-1> "TBufDisp \[$lbox curselection\]; set changed(tbufdisp) 0"
2781	if $text_only {
2782	set bind_type <Linefeed>
2783	} else {
2784	set bind_type <Return>
2785	}
2786	bind $lbox $bind_type "TBufDisp \[$lbox curselection\]; set changed(tbufdisp) 0"
2787	}
2788
2789	proc TBufFormatRec { recno } {
2790	global tbuf
2791	set output [format "%2d " [expr $recno + 1]]
2792	append output [binary format A20 $tbuf($recno,comment)]
2793	append output [format " %6.2f " $tbuf($recno,ec)]
2794	append output [format "%6.2f " $tbuf($recno,es)]
2795	append output [format "%6.2f " $tbuf($recno,ef)]
2796	append output [format "%4.0f " $tbuf($recno,pts)]
2797	append output [format "%2.0f\* " $tbuf($recno,mpf)]
2798	append output [format "%6.0f " $tbuf($recno,mon)]
2799	append output [binary format A4 $tbuf($recno,mt)]
2800	return $output
2801	}
2802
2803	proc TBufDisp { recno } {
2804	global tbufdisp tbuf tbuf_fields config
2805
2806	set mtime [file mtime TBUFFER.BUF]
2807	if {$mtime != $tbuf(mtime)} {
2808	TBufReadFile
2809	TBufList
2810	}
2811
2812	if { $config(paranoid) } { CheckBufChange }
2813
2814	foreach fld $tbuf_fields {
2815	set tbufdisp($fld) $tbuf($recno,$fld)
2816	}
2817	set num [format "%2d" [expr $recno + 1]]
2818	set tbufdisp(label) "TBuffer No: $num"
2819	set tbufdisp(current) $recno
2820
2821	set tbufdisp(es) [fltrim $tbufdisp(es) 10000]
2822	if [catch {expr $tbufdisp(pts) * 1} tbufdisp(pts)] {
2823	set tbufdisp(pts) 1
2824	}
2825
2826	# Clear changed flag
2827	set changed(tbufdisp) 0
2828
2829	}
2830
2831	proc TBufUpdate { } {
2832	global tbufdisp tbuf changed
2833
2834	if [catch {TBufCheckFld} result] {
2835	return -code error $result
2836	}
2837	set recno $tbufdisp(current)
2838	foreach fld [array names tbufdisp] {
2839	set tbuf($recno,$fld) $tbufdisp($fld)
2840	}
2841	# update display on the list
2842	.l.list delete $recno
2843	.l.list insert $recno [TBufFormatRec $recno]
2844	# update buffer information on disk
2845	TBufWriteFile
2846
2847	set changed(tbufdisp) 0
2848	}
2849
2850	proc TBufEntryCreate { p } {
2851	global tbufdisp config text_only
2852
2853	set config(tbufentry) $p
2854
2855	label $p.bufnolabel -textvariable tbufdisp(label)
2856	label $p.commentlabel -text "Comment:"
2857	entry $p.comment -width 35 -textvariable tbufdisp(comment)
2858
2859	label $p.energylab -text "Energy:"
2860	frame $p.energy
2861
2862	label $p.energy.eclab -text "E Start:"
2863	entry $p.energy.ec -width 6 -textvariable tbufdisp(ec)
2864	label $p.energy.eslab -text "E Step (x dE):"
2865	if {!$text_only} {
2866	tk_optionMenu $p.energy.es tbufdisp(es) 0.125 0.2 0.25 0.4 0.5 1.0
2867	} else {
2868	ck_optionMenu $p.energy.es tbufdisp(es) 0.125 0.2 0.25 0.4 0.5 1.0
2869	}
2870	# entry $p.energy.es -width 6 -textvariable tbufdisp(es)
2871	label $p.energy.eflab -text "E Final:"
2872	entry $p.energy.ef -width 6 -textvariable tbufdisp(ef)
2873	if $text_only {
2874	grid $p.energy.eclab -row 0 -column 0
2875	grid $p.energy.ec -row 0 -column 1 -padx 1
2876	grid $p.energy.eslab -row 0 -column 2
2877	grid $p.energy.es -row 0 -column 3 -padx 1
2878	grid $p.energy.eflab -row 0 -column 4
2879	grid $p.energy.ef -row 0 -column 5 -padx 1
2880	} else {
2881	pack $p.energy.eclab $p.energy.ec \
2882	$p.energy.eslab $p.energy.es \
2883	$p.energy.eflab $p.energy.ef -side left
2884	}
2885
2886	label $p.ang3label -text "Angle 3:"
2887	frame $p.ang3
2888	label $p.ang3.m3lab -text "M3:"
2889	#checkbutton $p.ang3.m3 -variable tbufdisp(m3)
2890	set tbufdisp(m3) 1
2891	toggle_create $p.ang3.m3 tbufdisp(m3)
2892	pack $p.ang3.m3lab $p.ang3.m3 -side left
2893
2894	label $p.templabel -text "Temp/H:"
2895	frame $p.temp
2896	label $p.temp.t0label -text "T0:"
2897	entry $p.temp.t0 -width 6 -textvariable tbufdisp(tmp)
2898	label $p.temp.tinclabel -text "Inc-T:"
2899	entry $p.temp.tinc -width 6 -textvariable tbufdisp(it)
2900	label $p.temp.twlabel -text "Wait:"
2901	entry $p.temp.tw -width 3 -textvariable tbufdisp(tw)
2902	label $p.temp.terlabel -text "Err:"
2903	entry $p.temp.ter -width 3 -textvariable tbufdisp(ter)
2904	label $p.temp.th0label -text "Hld0:"
2905	entry $p.temp.th0 -width 3 -textvariable tbufdisp(th0)
2906	label $p.temp.thlabel -text "Hld:"
2907	entry $p.temp.th -width 3 -textvariable tbufdisp(th)
2908	if $text_only {
2909	grid $p.temp.t0label -row 0 -column 0
2910	grid $p.temp.t0 -row 0 -column 1 -padx 1
2911	grid $p.temp.tinclabel -row 0 -column 2
2912	grid $p.temp.tinc -row 0 -column 3 -padx 1
2913	grid $p.temp.twlabel -row 0 -column 4
2914	grid $p.temp.tw -row 0 -column 5 -padx 1
2915	grid $p.temp.terlabel -row 0 -column 6
2916	grid $p.temp.ter -row 0 -column 7 -padx 1
2917	grid $p.temp.th0label -row 0 -column 8
2918	grid $p.temp.th0 -row 0 -column 9 -padx 1
2919	grid $p.temp.thlabel -row 0 -column 10
2920	grid $p.temp.th -row 0 -column 11 -padx 1
2921	} else {
2922	pack $p.temp.t0label $p.temp.t0 \
2923	$p.temp.tinclabel $p.temp.tinc \
2924	$p.temp.twlabel $p.temp.tw \
2925	$p.temp.terlabel $p.temp.ter \
2926	$p.temp.th0label $p.temp.th0 \
2927	$p.temp.thlabel $p.temp.th -side left
2928	}
2929
2930	label $p.timelabel -text "Time:"
2931	frame $p.time
2932	label $p.time.monlabel -text "Monitor:"
2933	entry $p.time.mon -width 6 -textvariable tbufdisp(mon)
2934	label $p.time.mpflabel -text "Prefac:"
2935	entry $p.time.mpf -width 3 -textvariable tbufdisp(mpf)
2936	label $p.time.mtlabel -text "M-typ:"
2937	if {!$text_only} {
2938	tk_optionMenu $p.time.mt tbufdisp(mt) TIME NEUT
2939	} else {
2940	ck_optionMenu $p.time.mt tbufdisp(mt) TIME NEUT
2941	}
2942	if $text_only {
2943	grid $p.time.monlabel -row 0 -column 0
2944	grid $p.time.mon -row 0 -column 1 -padx 1
2945	grid $p.time.mpflabel -row 0 -column 2
2946	grid $p.time.mpf -row 0 -column 3 -padx 1
2947	grid $p.time.mtlabel -row 0 -column 4
2948	grid $p.time.mt -row 0 -column 5 -padx 1
2949	} else {
2950	pack $p.time.monlabel $p.time.mon \
2951	$p.time.mpflabel $p.time.mpf \
2952	$p.time.mtlabel $p.time.mt -side left
2953	}
2954
2955	frame $p.pts
2956	label $p.pts.label -text "NPTS: "
2957	entry $p.pts.val -textvariable tbufdisp(pts) -width 6
2958	pack $p.pts.label $p.pts.val -side left
2959
2960	# pack widgets
2961	if $text_only {
2962	grid $p.bufnolabel -row 0 -column 0 -columnspan 2 -sticky w
2963	grid $p.commentlabel -row 0 -column 2 -padx 3
2964	grid $p.comment -row 0 -column 3 -columnspan 6 -sticky ew
2965	grid $p.energylab -row 1 -column 0 -sticky w
2966	grid $p.energy -row 1 -column 1 -columnspan 5 -padx 2 -sticky w
2967	grid $p.pts -row 1 -column 7
2968	label $p.blank -text " "
2969	grid $p.blank -row 2 -column 0
2970	grid $p.templabel -row 3 -column 0 -sticky w
2971	grid $p.temp -row 3 -column 1 -columnspan 7 -padx 2 -sticky w
2972	grid $p.timelabel -row 4 -column 0 -sticky w
2973	grid $p.time -row 4 -column 1 -columnspan 6 -padx 2 -sticky w
2974	} else {
2975	grid $p.bufnolabel -row 0 -column 0
2976	grid $p.commentlabel -row 0 -column 1
2977	grid $p.comment -row 0 -column 2 -columnspan 6 -sticky ew
2978	grid $p.energylab -row 1 -column 0
2979	grid $p.energy -row 1 -column 1 -columnspan 5 -sticky w
2980	grid $p.pts -row 1 -column 7
2981	# grid $p.ang3label -row 2 -column 0
2982	# grid $p.ang3 -row 2 -column 1 -columnspan 6 -sticky w
2983	grid $p.templabel -row 2 -column 0
2984	grid $p.temp -row 2 -column 1 -columnspan 6 -sticky w
2985	grid $p.timelabel -row 3 -column 0
2986	grid $p.time -row 3 -column 1 -columnspan 6 -sticky w
2987	}
2988
2989	# Set variable traces
2990	# TBufTraceOn
2991	trace variable tbufdisp(es) w TBufScanBinding
2992	bind $p.pts.val <Return> {TBufScanBinding tbufdisp pts w}
2993	# bind $p.pts.val <FocusOut> {TBufScanBinding tbufdisp pts w}
2994	bind $p.energy.ef <Return> {TBufScanBinding tbufdisp ef w}
2995	# bind $p.energy.ef <FocusOut> {TBufScanBinding tbufdisp ef w}
2996	bind $p.energy.ec <Return> {TBufScanBinding tbufdisp ec w}
2997	# bind $p.energy.ec <FocusOut> {TBufScanBinding tbufdisp ec w}
2998
2999	if {!$text_only} {
3000
3001	bind $p.pts.val <<Paste>> {TBufScanBinding tbufdisp pts w}
3002	bind $p.energy.ef <<Paste>> {TBufScanBinding tbufdisp ef w}
3003	bind $p.energy.ec <<Paste>> {TBufScanBinding tbufdisp ec w}
3004
3005	}
3006
3007	return $p
3008	}
3009
3010	proc TBufEntryMod { } {
3011	global tbufdisp config text_only
3012
3013	set parent $config(tbufentry)
3014	if {$config(mode) == 0} {
3015	set state disabled
3016	if {!$text_only} {
3017	set color gray
3018	} else {
3019	set color white
3020	}
3021	} else {
3022	set state normal
3023	if $text_only {
3024	set color white
3025	} else {
3026	set color black
3027	}
3028	}
3029	foreach w "$parent.templabel [winfo children $parent.temp]" {
3030	switch [winfo class $w] {
3031	Label {$w config -fg $color}
3032	Entry {$w config -fg $color -state $state}
3033	}
3034	}
3035
3036	if {$config(mode) == 2} {
3037	set state normal
3038	if $text_only {
3039	set color white
3040	} else {
3041	set color black
3042	}
3043	} else {
3044	set state disabled
3045	if {!$text_only} {
3046	set color gray
3047	} else {
3048	set color white
3049	}
3050	}
3051
3052	foreach l {temp.tinclabel temp.thlabel} {
3053	$parent.$l config -fg $color
3054	}
3055	foreach e {temp.tinc temp.th} {
3056	$parent.$e config -state $state -fg $color
3057	}
3058	}
3059
3060
3061	proc TBufKeyBinding { } {
3062	bind all <KeyPress-F1> TBufUpdate
3063	bind all <KeyPress-F2> BufopShow
3064	bind all <KeyPress-F3> {notebook_display .e tbuf}
3065	bind all <KeyPress-F4> {notebook_display .e blank}
3066	}
3067
3068	#==============================================================================
3069
3070	# CHARACTER*50 com
3071	# REAL pts
3072	# REAL qx,qxi,qZ,qZi
3073	# REAL scan_mode
3074	# REAL s(4)
3075	# REAL i(4)
3076	# REAL tmp , it , tw , th0 , ter
3077	# REAL hf , mon0 , mon1,exp,mpf
3078	# CHARACTER*4 mt
3079	# LOGICAL flip_state(4)
3080	# INTEGER*4 numx !number of xtra motor
3081	# REAL sx,ix
3082	# REAL ihf , hfw , hfh , th
3083
3084	set rbuf_fields { comment pts qx qxi qz qzi scan_mode \
3085	s_1 s_2 s_3 s_4 i_1 i_2 i_3 i_4 \
3086	tmp it tw th0 ter hf mon0 mon1 exp mpf \
3087	mt flip1 flip2 flip3 flip4 numx sx ix \
3088	ihf hfw hfh th }
3089
3090
3091	proc RBufReadRec { file rec } {
3092	upvar $rec r
3093	set input [read $file 320]
3094	binary scan $input \
3095	A50sffffffffffffffffffffffffA4iiiiiffffff \
3096	r(comment) pad1 \
3097	r(pts) r(qx) r(qxi) r(qz) r(qzi) r(scan_mode) \
3098	r(s_1) r(s_2) r(s_3) r(s_4) r(i_1) r(i_2) r(i_3) r(i_4) \
3099	r(tmp) r(it) r(tw) r(th0) r(ter) \
3100	r(hf) r(mon0) r(mon1) r(exp) r(mpf) \
3101	r(mt) r(flip1) r(flip2) r(flip3) r(flip4) \
3102	r(numx) r(sx) r(ix) r(ihf) r(hfw) r(hfh) r(th)
3103	if {$r(numx) == 10} { set r(numx) 13 } ;# _Wierd_ bug
3104	}
3105
3106	proc RBufReadFile { } {
3107	global rbuf rbuf_fields
3108
3109	set f [open RBUFFER.BUF r]
3110	fconfigure $f -encoding binary
3111	for {set i 0} {$i < 30} {incr i} {
3112	RBufReadRec $f icpin
3113	foreach fld $rbuf_fields {
3114	if {![catch {set icpin($fld)} result]} {
3115	set rbuf($i,$fld) $result
3116	}
3117	}
3118	}
3119	close $f
3120	set rbuf(mtime) [file mtime RBUFFER.BUF]
3121	}
3122
3123	proc RBufCheckFld { } {
3124	global rbufdisp
3125	set flds { tmp it tw th0 ter hf mon0 mon1 exp mpf pts ihf hfw hfh th}
3126	foreach fld $flds {
3127	# Check to make sure these are floating point numbers
3128	if [catch { expr 1.0 * $rbufdisp($fld) } result] {
3129	set rbufdisp($fld) "--------"
3130	return -code error "Parameter \"$fld\" must be floating point number"
3131	}
3132	}
3133	}
3134
3135	proc RBufWriteRec { file rec } {
3136	upvar $rec r
3137
3138	set pad1 0
3139	set pad2 " "
3140
3141	set recval [binary format \
3142	A50sffffffffffffffffffffffffA4iiiiiffffff \
3143	$r(comment) $pad1 \
3144	$r(pts) $r(qx) $r(qxi) $r(qz) $r(qzi) $r(scan_mode) \
3145	$r(s_1) $r(s_2) $r(s_3) $r(s_4) $r(i_1) $r(i_2) $r(i_3) $r(i_4) \
3146	$r(tmp) $r(it) $r(tw) $r(th0) $r(ter) \
3147	$r(hf) $r(mon0) $r(mon1) $r(exp) $r(mpf) \
3148	$r(mt) $r(flip1) $r(flip2) $r(flip3) $r(flip4) \
3149	$r(numx) $r(sx) $r(ix) $r(ihf) $r(hfw) $r(hfh) $r(th)]
3150	set record [binary format A320 $recval]
3151	puts -nonewline $file $record
3152	string length $record
3153	}
3154
3155
3156	proc RBufWriteFile { } {
3157	global rbuf rbuf_fields
3158
3159	set f [open RBUFFER.BUF w]
3160	fconfigure $f -encoding binary
3161	for {set i 0} {$i < 30} {incr i} {
3162	foreach fld $rbuf_fields {
3163	set icpout($fld) $rbuf($i,$fld)
3164	}
3165	RBufWriteRec $f icpout
3166	}
3167	puts -nonewline $f [binary format A320 "\#"]
3168	close $f
3169	set rbuf(mtime) [file mtime RBUFFER.BUF]
3170	}
3171
3172	proc RBufInit { } {
3173	global rbuf
3174	array set rbuf {buftype Reflectivity}
3175	for {set i 0} {$i < 30} {incr i} {
3176	set rbuf($i,comment) "empty"
3177	set rbuf($i,scan_mode) 1
3178	set rbuf($i,pts) 31
3179	set rbuf($i,qx) 0.0
3180	set rbuf($i,qxi) 0.0
3181	set rbuf($i,qxe) 0.0
3182	set rbuf($i,qz) 0.005
3183	set rbuf($i,qzi) 0.0005
3184	set rbuf($i,qze) 0.020
3185	set rbuf($i,s_1) 0.1
3186	set rbuf($i,s_2) 0.1
3187	set rbuf($i,s_3) 0.5
3188	set rbuf($i,s_4) 0.0
3189	set rbuf($i,i_1) 0.01
3190	set rbuf($i,i_2) 0.01
3191	set rbuf($i,i_3) 0.02
3192	set rbuf($i,i_4) 0.0
3193	set rbuf($i,e_1) 0.0
3194	set rbuf($i,e_2) 0.0
3195	set rbuf($i,e_3) 0.0
3196	set rbuf($i,e_4) 0.0
3197	set rbuf($i,tmp) 300.0
3198	set rbuf($i,it) 0.0
3199	set rbuf($i,tw) 0.0
3200	set rbuf($i,th0) 0.0
3201	set rbuf($i,ter) 1.0
3202	set rbuf($i,hf) 0
3203	set rbuf($i,mon0) 1000
3204	set rbuf($i,mon1) 1000
3205	set rbuf($i,exp) 1.0
3206	set rbuf($i,mpf) 1.0
3207	set rbuf($i,mt) TIME
3208	set rbuf($i,flip1) 0
3209	set rbuf($i,flip2) 0
3210	set rbuf($i,flip3) 0
3211	set rbuf($i,flip4) 0
3212	set rbuf($i,numx) 0
3213	set rbuf($i,sx) 0.0
3214	set rbuf($i,ix) 0.0
3215	set rbuf($i,ihf) 0.0
3216	set rbuf($i,hfw) 0.0
3217	set rbuf($i,hfh) 0.0
3218	set rbuf($i,th) 0.0
3219	}
3220	set rbuf(currentrec) 0
3221	set rbuf(mtime) 0
3222	}
3223
3224	proc RBufList { } {
3225	# Clear out our list if it contains anything.
3226	set lbox .l.list
3227	set start [expr int([lindex [$lbox yview] 0] * [$lbox index end])]
3228	$lbox delete 0 end
3229	#$lbox configure -font fixed
3230	for {set i 0} {$i < 30} {incr i} {
3231	$lbox insert end [RBufFormatRec $i]
3232	}
3233	global text_only
3234	if $text_only {
3235	$lbox selection set 0 0
3236	}
3237
3238	$lbox yview $start
3239	bind $lbox <ButtonRelease-1> "RBufDisp \[$lbox curselection\]; set changed(rbufdisp) 0"
3240	if $text_only {
3241	set bind_type <Linefeed>
3242	} else {
3243	set bind_type <Return>
3244	}
3245	bind $lbox $bind_type "RBufDisp \[$lbox curselection\]; set changed(rbufdisp) 0"
3246	}
3247	proc RBufFormatRec { recno } {
3248	global rbuf
3249	set output [format "%2d " [expr $recno + 1]]
3250	append output [binary format A20 $rbuf($recno,comment)]
3251	append output [format " %8.6f" $rbuf($recno,qz)]
3252	append output [format " %8.6f" $rbuf($recno,qze)]
3253	append output [format " %8.6f" $rbuf($recno,qx)]
3254	append output [format " %8.6f" $rbuf($recno,qxe)]
3255	append output [format " %2.0f\* " $rbuf($recno,mpf)]
3256	append output "varies"
3257	append output [format " %4.0f" $rbuf($recno,pts)]
3258	return $output
3259	}
3260	proc RBufDisp { recno } {
3261	global rbufdisp rbuf rbuf_fields config
3262
3263	set mtime [file mtime RBUFFER.BUF]
3264	if {$mtime != $rbuf(mtime)} {
3265	RBufReadFile
3266	RBufList
3267	}
3268
3269	if {$config(paranoid)} { CheckBufChange }
3270
3271	foreach fld $rbuf_fields {
3272	set rbufdisp($fld) $rbuf($recno,$fld)
3273	}
3274	set num [format "%2d" [expr $recno + 1]]
3275	set rbufdisp(label) "RBuffer No: $num"
3276	set rbufdisp(current) $recno
3277
3278	set flfields { qx qxi qz qzi s_1 i_1 s_2 i_2 s_3 i_3 s_4 i_4 sx ix}
3279
3280	foreach f $flfields {
3281	set rbufdisp($f) [fltrim $rbufdisp($f) 10000]
3282	}
3283
3284
3285	if [catch {expr $rbufdisp(pts) * 1} rbufdisp(pts)] {
3286	set rbufdisp(pts) 1
3287	}
3288
3289	RBufCalcAngles
3290
3291	# Clear changed flag
3292	set changed(rbufdisp) 0
3293
3294	}
3295
3296	proc RBufUpdate { } {
3297	global rbufdisp rbuf changed
3298
3299	if [catch {RBufCheckFld} result] {
3300	return -code error $result
3301	}
3302	set recno $rbufdisp(current)
3303	foreach fld [array names rbufdisp] {
3304	set rbuf($recno,$fld) $rbufdisp($fld)
3305	}
3306	# update display on the list
3307	.l.list delete $recno
3308	.l.list insert $recno [RBufFormatRec $recno]
3309	# update buffer information on disk
3310	RBufWriteFile
3311
3312	set changed(rbufdisp) 0
3313	}
3314
3315	proc RBufEntryCreate { p } {
3316	global rbufdisp config text_only
3317
3318	set config(rbufentry) $p
3319
3320	label $p.bufnolabel -textvariable rbufdisp(label)
3321	label $p.commentlabel -text "Comment:"
3322	entry $p.comment -width 35 -textvariable rbufdisp(comment)
3323	if $text_only {
3324	grid $p.bufnolabel -row 0 -column 0 -sticky w
3325	grid $p.commentlabel -row 0 -column 1 -ipadx 3 -sticky e
3326	grid $p.comment -row 0 -column 2 -columnspan 6 -sticky ew
3327	set width 5
3328	} else {
3329	grid $p.bufnolabel -row 0 -column 0
3330	grid $p.commentlabel -row 0 -column 1
3331	grid $p.comment -row 0 -column 2 -columnspan 6 -sticky ew
3332	set width 7
3333	}
3334	label $p.qzlabel -text "qz-beg:"
3335	entry $p.qz -textvariable rbufdisp(qz) -width 8
3336	label $p.qzilabel -text "Inc-qz:"
3337	entry $p.qzi -textvariable rbufdisp(qzi) -width 8
3338	label $p.qzelabel -text "qz-end:"
3339	entry $p.qze -textvariable rbufdisp(qze) -width 8
3340
3341	label $p.qxlabel -text "qx-beg:"
3342	entry $p.qx -textvariable rbufdisp(qx) -width 8
3343	label $p.qxilabel -text "Inc-qx:"
3344	entry $p.qxi -textvariable rbufdisp(qxi) -width 8
3345	label $p.qxelabel -text "qx-end:"
3346	entry $p.qxe -textvariable rbufdisp(qxe) -width 8
3347
3348	grid $p.qzlabel -row 1 -column 1 -sticky w
3349	grid $p.qz -row 1 -column 2 -sticky w
3350	grid $p.qzilabel -row 1 -column 3 -sticky w
3351	grid $p.qzi -row 1 -column 4 -sticky w
3352	grid $p.qzelabel -row 1 -column 5 -sticky w
3353	grid $p.qze -row 1 -column 6 -sticky w
3354	grid $p.qxlabel -row 2 -column 1 -sticky w
3355	grid $p.qx -row 2 -column 2 -sticky w
3356	grid $p.qxilabel -row 2 -column 3 -sticky w
3357	grid $p.qxi -row 2 -column 4 -sticky w
3358	grid $p.qxelabel -row 2 -column 5 -sticky w
3359	grid $p.qxe -row 2 -column 6 -sticky w
3360
3361	set row 3
3362	foreach i {1 2 3 4} {
3363	label $p.s_${i}label -text "S${i}-beg:"
3364	entry $p.s_${i} -textvariable rbufdisp(s_$i) -width 8
3365	label $p.i_${i}label -text "S${i}-inc:"
3366	entry $p.i_${i} -textvariable rbufdisp(i_$i) -width 8
3367	label $p.e_${i}label -text "S${i}-end:"
3368	entry $p.e_${i} -textvariable rbufdisp(e_$i) -width 8
3369
3370	grid $p.s_${i}label -row $row -column 1 -sticky w
3371	grid $p.s_${i} -row $row -column 2 -sticky w
3372	grid $p.i_${i}label -row $row -column 3 -sticky w
3373	grid $p.i_${i} -row $row -column 4 -sticky w
3374	grid $p.e_${i}label -row $row -column 5 -sticky w
3375	grid $p.e_${i} -row $row -column 6 -sticky w
3376	incr row
3377	}
3378
3379	frame $p.xm
3380	label $p.xm.mlabel -text "XM-num:"
3381	entry $p.xm.m -textvariable rbufdisp(numx) -width 2
3382
3383	label $p.slabel -text "XM-beg:"
3384	entry $p.s -textvariable rbufdisp(sx) -width 8
3385	label $p.silabel -text "XM-inc:"
3386	entry $p.si -textvariable rbufdisp(ix) -width 8
3387	label $p.selabel -text "XM-end:"
3388	entry $p.se -textvariable rbufdisp(ex) -width 8
3389
3390	frame $p.sm
3391	label $p.sm.slabel -text "scan_mode:"
3392	entry $p.sm.s -textvariable rbufdisp(scan_mode) -width 1
3393
3394	grid $p.xm.mlabel $p.xm.m -sticky w
3395	grid $p.sm.slabel $p.sm.s -sticky w
3396	grid $p.xm $p.slabel $p.s $p.silabel $p.si $p.selabel $p.se \
3397	$p.sm -sticky w
3398
3399	# Sample environment fields
3400
3401	label $p.templabel -text "Temp/H:"
3402	frame $p.temp
3403	label $p.temp.t0label -text "T0:"
3404	entry $p.temp.t0 -width 6 -textvariable rbufdisp(tmp)
3405	label $p.temp.tinclabel -text "Inc-T:"
3406	entry $p.temp.tinc -width 6 -textvariable rbufdisp(it)
3407	label $p.temp.twlabel -text "Wait:"
3408	entry $p.temp.tw -width 3 -textvariable rbufdisp(tw)
3409	label $p.temp.terlabel -text "Err:"
3410	entry $p.temp.ter -width 3 -textvariable rbufdisp(ter)
3411	label $p.temp.th0label -text "Hld0:"
3412	entry $p.temp.th0 -width 3 -textvariable rbufdisp(th0)
3413	label $p.temp.thlabel -text "Hld:"
3414	entry $p.temp.th -width 3 -textvariable rbufdisp(th)
3415	if $text_only {
3416	grid $p.temp.t0label -row 0 -column 0
3417	grid $p.temp.t0 -row 0 -column 1 -padx 1
3418	grid $p.temp.tinclabel -row 0 -column 2
3419	grid $p.temp.tinc -row 0 -column 3 -padx 1
3420	grid $p.temp.twlabel -row 0 -column 4
3421	grid $p.temp.tw -row 0 -column 5 -padx 1
3422	grid $p.temp.terlabel -row 0 -column 6
3423	grid $p.temp.ter -row 0 -column 7 -padx 1
3424	grid $p.temp.th0label -row 0 -column 8
3425	grid $p.temp.th0 -row 0 -column 9 -padx 1
3426	grid $p.temp.thlabel -row 0 -column 10
3427	grid $p.temp.th -row 0 -column 11 -padx 1
3428	} else {
3429	pack $p.temp.t0label $p.temp.t0 \
3430	$p.temp.tinclabel $p.temp.tinc \
3431	$p.temp.twlabel $p.temp.tw \
3432	$p.temp.terlabel $p.temp.ter \
3433	$p.temp.th0label $p.temp.th0 \
3434	$p.temp.thlabel $p.temp.th -side left
3435	}
3436
3437	grid $p.templabel $p.temp - - - - - - -sticky w
3438
3439	label $p.timelabel -text "Time:"
3440	frame $p.time
3441	label $p.time.mpflabel -text "Prefac:"
3442	entry $p.time.mpf -width 3 -textvariable rbufdisp(mpf)
3443	label $p.time.mon0label -text "Mon0:"
3444	entry $p.time.mon0 -width 6 -textvariable rbufdisp(mon0)
3445	label $p.time.mon1label -text "Mon1:"
3446	entry $p.time.mon1 -width 6 -textvariable rbufdisp(mon1)
3447	label $p.time.explabel -text "Exp:"
3448	entry $p.time.exp -width 6 -textvariable rbufdisp(exp)
3449
3450	label $p.time.mtlabel -text "M-typ:"
3451	if {!$text_only} {
3452	tk_optionMenu $p.time.mt rbufdisp(mt) TIME NEUT
3453	} else {
3454	ck_optionMenu $p.time.mt rbufdisp(mt) TIME NEUT
3455	}
3456	if $text_only {
3457	grid $p.time.mpflabel -row 0 -column 0
3458	grid $p.time.mpf -row 0 -column 1 -padx 1
3459	grid $p.time.mon0label -row 0 -column 2
3460	grid $p.time.mon0 -row 0 -column 3 -padx 1
3461	grid $p.time.mon1label -row 0 -column 4
3462	grid $p.time.mon1 -row 0 -column 5 -padx 1
3463	grid $p.time.explabel -row 0 -column 6
3464	grid $p.time.exp -row 0 -column 7 -padx 1
3465	grid $p.time.mtlabel -row 0 -column 8
3466	grid $p.time.mt -row 0 -column 9 -padx 1
3467	} else {
3468	pack $p.time.mpflabel $p.time.mpf \
3469	$p.time.mon0label $p.time.mon0 \
3470	$p.time.mon1label $p.time.mon1 \
3471	$p.time.explabel $p.time.exp \
3472	$p.time.mtlabel $p.time.mt -side left
3473	}
3474
3475	grid $p.timelabel $p.time - - - - - - -sticky w
3476
3477	# Number of points
3478	frame $p.pts
3479	label $p.pts.label -text "NPTS: "
3480	entry $p.pts.val -textvariable rbufdisp(pts) -width 6
3481	pack $p.pts.label $p.pts.val -side left
3482	grid $p.pts -row 4 -column 7
3483
3484	bind $p.pts.val <Return> RBufCalcAngles
3485	bind $p.pts.val <FocusOut> RBufCalcAngles
3486	bind $p.qz <Return> "RBufAngleBinding rbufdisp qz w"
3487	bind $p.qzi <Return> "RBufAngleBinding rbufdisp qzi w"
3488	bind $p.qze <Return> "RBufAngleBinding rbufdisp qze w"
3489	bind $p.qx <Return> "RBufAngleBinding rbufdisp qx w"
3490	bind $p.qxi <Return> "RBufAngleBinding rbufdisp qxi w"
3491	bind $p.qxe <Return> "RBufAngleBinding rbufdisp qxe w"
3492	bind $p.qz <FocusOut> "RBufAngleBinding rbufdisp qz w"
3493	bind $p.qzi <FocusOut> "RBufAngleBinding rbufdisp qzi w"
3494	bind $p.qze <FocusOut> "RBufAngleBinding rbufdisp qze w"
3495	bind $p.qx <FocusOut> "RBufAngleBinding rbufdisp qx w"
3496	bind $p.qxi <FocusOut> "RBufAngleBinding rbufdisp qxi w"
3497	bind $p.qxe <FocusOut> "RBufAngleBinding rbufdisp qxe w"
3498
3499	return $p
3500	}
3501
3502	# end = beg + (pts-1) * inc
3503	# pts = (end - beg) / inc + 1
3504	proc RBufCalcAngles { } {
3505	global rbufdisp
3506	if [catch {expr $rbufdisp(pts) * 1} rbufdisp(pts)] {
3507	set rbufdisp(pts) "------"
3508	return
3509	}
3510
3511	foreach i {qx qz} {
3512	set beg $i
3513	set inc "${i}i"
3514	set end "${i}e"
3515	if [catch {expr $rbufdisp($beg) * 1.0} rbufdisp($beg)] {
3516	set rbufdisp($beg) "------"
3517	return
3518	}
3519	if [catch {expr $rbufdisp($inc) * 1.0} rbufdisp($inc)] {
3520	set rbufdisp($inc) "------"
3521	return
3522	}
3523	set rbufdisp($end) [expr $rbufdisp($beg) + \
3524	$rbufdisp($inc) * ($rbufdisp(pts) - 1)]
3525	}
3526
3527	foreach i {x _1 _2 _3 _4} {
3528	set beg "s$i"
3529	set inc "i$i"
3530	set end "e$i"
3531	if [catch {expr $rbufdisp($beg) * 1.0} rbufdisp($beg)] {
3532	set rbufdisp($beg) "------"
3533	return
3534	}
3535	if [catch {expr $rbufdisp($inc) * 1.0} rbufdisp($inc)] {
3536	set rbufdisp($inc) "------"
3537	return
3538	}
3539	set rbufdisp($end) [expr $rbufdisp($beg) + \
3540	$rbufdisp($inc) * ($rbufdisp(pts) - 1)]
3541	}
3542	}
3543
3544	proc RBufAngleBinding { args } {
3545	global rbufdisp
3546	set largs [llength $args]
3547
3548	if {$largs < 3} { return }
3549	set key [lindex $args 1]
3550	if {[string compare $key "pts"] == 0} {
3551	return [RBufCalcAngles]
3552	}
3553
3554	if {[string compare $key "qxe"] == 0} {
3555	if [catch {expr $rbufdisp(qxe) * 1.0} rbufdisp(qxe)] {
3556	set rbufdisp(qxe) "------"
3557	return
3558	}
3559	if {$rbufdisp(qxi) == 0.0} {
3560	set rbufdisp(qxe) $rbufdisp(qx)
3561	set rbufdisp(pts) 1
3562	} else {
3563	set rbufdisp(pts) [expr (($rbufdisp(qxe) - $rbufdisp(qx))/$rbufdisp(qxi)) + 1]
3564	}
3565
3566	}
3567
3568	if {[string compare $key "qze"] == 0} {
3569	if [catch {expr $rbufdisp(qze) * 1.0} rbufdisp(qze)] {
3570	set rbufdisp(qze) "------"
3571	return
3572	}
3573	if {$rbufdisp(qzi) == 0.0} {
3574	set rbufdisp(qze) $rbufdisp(qz)
3575	set rbufdisp(pts) 1
3576	} else {
3577	set rbufdisp(pts) [expr (($rbufdisp(qze) - $rbufdisp(qz))/$rbufdisp(qzi)) + 1]
3578	}
3579
3580	}
3581
3582	return [RBufCalcAngles]
3583	}
3584
3585	#=D BUFFER=====================================================================
3586
3587	proc DBufWriteRec { file rec } {
3588	upvar $rec r
3589
3590	set pad1 0
3591	set pad2 " "
3592	set recval [binary format \
3593	"A50siiiiiiiiiiiiiiiiiiffffffffffffiiiiiifffffffffffffffffffffffffA4iiiiffff" \
3594	$r(comment) $pad1 \
3595	$r(lpn_1) $r(lpn_2) $r(lpn_3) $r(lpn_4) $r(lpn_5) $r(lpn_6) \
3596	$r(lpts_1) $r(lpts_2) $r(lpts_3) $r(lpts_4) $r(lpts_5) $r(lpts_6) \
3597	$r(mn_1) $r(mn_2) $r(mn_3) $r(mn_4) $r(mn_5) $r(mn_6) \
3598	$r(a_1) $r(a_2) $r(a_3) $r(a_4) $r(a_5) $r(a_6) \
3599	$r(i_1) $r(i_2) $r(i_3) $r(i_4) $r(i_5) $r(i_6) \
3600	$r(xyz_1) $r(xyz_2) $r(xyz_3) $r(xyz_4) $r(xyz_5) $r(xyz_6) \
3601	$r(a_xyz_1) $r(a_xyz_2) $r(a_xyz_3) $r(a_xyz_4) $r(a_xyz_5) $r(a_xyz_6) \
3602	$r(i_xyz_1) $r(i_xyz_2) $r(i_xyz_3) $r(i_xyz_4) $r(i_xyz_5) $r(i_xyz_6) \
3603	$r(pts) $r(hf) $r(phi) $r(psi) $r(phi_inc) $r(psi_inc) \
3604	$r(tmp) $r(it) $r(tw) $r(th0) $r(ter) $r(mon) $r(mpf) $r(mt) \
3605	$r(flip1) $r(flip2) $r(flip3) $r(flip4) \
3606	$r(ihf) $r(hfw) $r(hfh) $r(th)]
3607	set record [binary format A336 $recval]
3608	puts -nonewline $file $record
3609	string length $record
3610	}
3611
3612	proc DBufWriteFile { } {
3613	global dbuf dbuf_fields
3614
3615	set f [open DBUFFER.BUF w]
3616	fconfigure $f -encoding binary
3617	for {set i 0} {$i < 30} {incr i} {
3618	foreach fld $dbuf_fields {
3619	set icpout($fld) $dbuf($i,$fld)
3620	}
3621	DBufWriteRec $f icpout
3622	}
3623	puts -nonewline $f [binary format A336 "\#"]
3624	close $f
3625	set dbuf(mtime) [file mtime DBUFFER.BUF]
3626	}
3627
3628	proc DBufReadRec { file rec } {
3629	upvar $rec r
3630	set input [read $file 336]
3631	binary scan $input \
3632	A50siiiiiiiiiiiiiiiiiiffffffffffffiiiiiifffffffffffffffffffffffffA4iiiiffff \
3633	r(comment) pad1 \
3634	r(lpn_1) r(lpn_2) r(lpn_3) r(lpn_4) r(lpn_5) r(lpn_6) \
3635	r(lpts_1) r(lpts_2) r(lpts_3) r(lpts_4) r(lpts_5) r(lpts_6) \
3636	r(mn_1) r(mn_2) r(mn_3) r(mn_4) r(mn_5) r(mn_6) \
3637	r(a_1) r(a_2) r(a_3) r(a_4) r(a_5) r(a_6) \
3638	r(i_1) r(i_2) r(i_3) r(i_4) r(i_5) r(i_6) \
3639	r(xyz_1) r(xyz_2) r(xyz_3) r(xyz_4) r(xyz_5) r(xyz_6) \
3640	r(a_xyz_1) r(a_xyz_2) r(a_xyz_3) r(a_xyz_4) r(a_xyz_5) r(a_xyz_6) \
3641	r(i_xyz_1) r(i_xyz_2) r(i_xyz_3) r(i_xyz_4) r(i_xyz_5) r(i_xyz_6) \
3642	r(pts) r(hf) r(phi) r(psi) r(phi_inc) r(psi_inc) \
3643	r(tmp) r(it) r(tw) r(th0) r(ter) r(mon) r(mpf) r(mt) \
3644	r(flip1) r(flip2) r(flip3) r(flip4) \
3645	r(ihf) r(hfw) r(hfh) r(th)
3646	}
3647
3648	proc DBufReadFile { } {
3649	global dbuf dbuf_fields
3650
3651	set f [open DBUFFER.BUF r]
3652	fconfigure $f -encoding binary
3653	for {set i 0} {$i < 30} {incr i} {
3654	DBufReadRec $f icpin
3655	foreach fld $dbuf_fields {
3656	if {![catch {set icpin($fld)} result]} {
3657	set dbuf($i,$fld) $result
3658	}
3659	}
3660	}
3661	close $f
3662	set dbuf(mtime) [file mtime DBUFFER.BUF]
3663	}
3664
3665	proc DBufList { } {
3666
3667	# Clear out our list if it contains anything.
3668	set lbox .l.list
3669	set start [expr int([lindex [$lbox yview] 0] * [$lbox index end])]
3670	$lbox delete 0 end
3671	#$lbox configure -font fixed
3672	for {set i 0} {$i < 30} {incr i} {
3673	$lbox insert end [DBufFormatRec $i]
3674	}
3675
3676	$lbox yview $start
3677	bind $lbox <ButtonRelease-1> "DBufDisp \[$lbox curselection\]"
3678	set bind_type <Return>
3679	bind $lbox $bind_type "DBufDisp \[$lbox curselection\]"
3680	}
3681
3682	proc DBufFormatRec { recno } {
3683	global dbuf
3684	set output [format "%2d " [expr $recno + 1]]
3685	append output [binary format A20 $dbuf($recno,comment)]
3686	append output [format " %4d " $dbuf($recno,mn_1)]
3687	append output [format "%6.2f " $dbuf($recno,a_1)]
3688	append output [format "%6.2f " $dbuf($recno,i_1)]
3689	append output [format "%6.2f " $dbuf($recno,e_1)]
3690	append output [format "%2.0f\* " $dbuf($recno,mpf)]
3691	append output [format "%6.0f " $dbuf($recno,mon)]
3692	append output [binary format A4 $dbuf($recno,mt)]
3693
3694	return $output
3695	}
3696
3697	proc DBufDisp { recno } {
3698	global dbufdisp dbuf dbuf_fields changed config
3699
3700	set mtime [file mtime DBUFFER.BUF]
3701	if {$mtime != $dbuf(mtime)} {
3702	DBufReadFile
3703	DBufList
3704	}
3705
3706	if { $config(paranoid)} { CheckBufChange }
3707
3708	foreach fld $dbuf_fields {
3709	set dbufdisp($fld) $dbuf($recno,$fld)
3710	}
3711	set num [format "%2d" [expr $recno + 1]]
3712	set dbufdisp(label) "DBuffer No: $num"
3713	set dbufdisp(current) $recno
3714	# Fix up several fields
3715
3716	DBufCalcAngles
3717	# clear changed flag
3718	set changed(dbufdisp) 0
3719
3720	# switch focus to listbox so Return & arrowkeys work
3721	# and force selection (for 1st time)
3722	focus .l.list
3723	.l.list selection set $recno
3724	}
3725
3726	proc DBufUpdate { } {
3727	global dbufdisp dbuf changed config
3728
3729	if [catch {DBufCheckFld} result] {
3730	return -code error $result
3731	}
3732
3733	set recno $dbufdisp(current)
3734	foreach fld [array names dbufdisp] {
3735	set dbuf($recno,$fld) $dbufdisp($fld)
3736	}
3737
3738	# update display on the list
3739	.l.list delete $recno
3740	.l.list insert $recno [DBufFormatRec $recno]
3741	# update buffer information on disk
3742	DBufWriteFile
3743	set changed(dbufdisp) 0
3744	}
3745
3746
3747	proc DBufInit { } {
3748	global dbuf
3749	array set dbuf {buftype Diffraction}
3750	for {set i 0} {$i < 30} {incr i} {
3751	set dbuf(${i},comment) empty
3752	set dbuf(${i},lpn_1) 1
3753	set dbuf(${i},lpn_2) 1
3754	set dbuf(${i},lpn_3) 1
3755	set dbuf(${i},lpn_4) 1
3756	set dbuf(${i},lpn_5) 1
3757	set dbuf(${i},lpn_6) 1
3758	set dbuf(${i},lpts_1) 0
3759	set dbuf(${i},lpts_2) 0
3760	set dbuf(${i},lpts_3) 0
3761	set dbuf(${i},lpts_4) 0
3762	set dbuf(${i},lpts_5) 0
3763	set dbuf(${i},lpts_6) 0
3764	set dbuf(${i},mn_1) 0
3765	set dbuf(${i},mn_2) 0
3766	set dbuf(${i},mn_3) 0
3767	set dbuf(${i},mn_4) 0
3768	set dbuf(${i},mn_5) 0
3769	set dbuf(${i},mn_6) 0
3770	set dbuf(${i},a_1) 0
3771	set dbuf(${i},a_2) 0
3772	set dbuf(${i},a_3) 0
3773	set dbuf(${i},a_4) 0
3774	set dbuf(${i},a_5) 0
3775	set dbuf(${i},a_6) 0
3776	set dbuf(${i},i_1) 0
3777	set dbuf(${i},i_2) 0
3778	set dbuf(${i},i_3) 0
3779	set dbuf(${i},i_4) 0
3780	set dbuf(${i},i_5) 0
3781	set dbuf(${i},i_6) 0
3782	set dbuf(${i},e_1) 0
3783	set dbuf(${i},e_2) 0
3784	set dbuf(${i},e_3) 0
3785	set dbuf(${i},e_4) 0
3786	set dbuf(${i},e_5) 0
3787	set dbuf(${i},e_6) 0
3788	set dbuf(${i},xyz_1) 0
3789	set dbuf(${i},xyz_2) 0
3790	set dbuf(${i},xyz_3) 0
3791	set dbuf(${i},xyz_4) 0
3792	set dbuf(${i},xyz_5) 0
3793	set dbuf(${i},xyz_6) 0
3794	set dbuf(${i},a_xyz_1) 0
3795	set dbuf(${i},a_xyz_2) 0
3796	set dbuf(${i},a_xyz_3) 0
3797	set dbuf(${i},a_xyz_4) 0
3798	set dbuf(${i},a_xyz_5) 0
3799	set dbuf(${i},a_xyz_6) 0
3800	set dbuf(${i},i_xyz_1) 0
3801	set dbuf(${i},i_xyz_2) 0
3802	set dbuf(${i},i_xyz_3) 0
3803	set dbuf(${i},i_xyz_4) 0
3804	set dbuf(${i},i_xyz_5) 0
3805	set dbuf(${i},i_xyz_6) 0
3806	set dbuf(${i},e_xyz_1) 0
3807	set dbuf(${i},e_xyz_2) 0
3808	set dbuf(${i},e_xyz_3) 0
3809	set dbuf(${i},e_xyz_4) 0
3810	set dbuf(${i},e_xyz_5) 0
3811	set dbuf(${i},e_xyz_6) 0
3812	set dbuf(${i},pts) 1
3813	set dbuf(${i},hf) 0
3814	set dbuf(${i},phi) 0
3815	set dbuf(${i},psi) 0
3816	set dbuf(${i},phi_inc) 0
3817	set dbuf(${i},psi_inc) 0
3818	set dbuf(${i},tmp) 300
3819	set dbuf(${i},it) 0
3820	set dbuf(${i},tw) 0
3821	set dbuf(${i},th0) 0
3822	set dbuf(${i},ter) 0
3823	set dbuf(${i},mon) 1
3824	set dbuf(${i},mpf) 1
3825	set dbuf(${i},mt) NEUT
3826	set dbuf(${i},flip1) 0
3827	set dbuf(${i},flip2) 0
3828	set dbuf(${i},flip3) 0
3829	set dbuf(${i},flip4) 0
3830	set dbuf(${i},ihf) 0
3831	set dbuf(${i},hfw) 0
3832	set dbuf(${i},hfh) 0
3833	set dbuf(${i},th) 0
3834	}
3835	set dbuf(currentrec) 0
3836	set dbuf(mtime) 0
3837	}
3838
3839	proc DBufEntryCreate { p } {
3840	global dbuf dbufdisp config
3841
3842	# Create widgets
3843	label $p.bufnolabel -textvariable dbufdisp(label)
3844	label $p.commentlabel -width 8 -text "Comment:"
3845	entry $p.comment -textvariable dbufdisp(comment)
3846	label $p.lpn_l -width 4 -text "Loop"
3847	label $p.mn_l -width 3 -text "Mot"
3848	label $p.xyz_l -width 3 -text "xyz"
3849	label $p.a_l -width 7 -text "a_Beg"
3850	label $p.i_l -width 7 -text "a_Inc"
3851	label $p.e_l -width 7 -text "a_End"
3852	label $p.a_xyz_l -width 7 -text "xyz_Beg"
3853	label $p.i_xyz_l -width 7 -text "xyz_Inc"
3854	label $p.e_xyz_l -width 7 -text "xyz_End"
3855	label $p.lpts_l -width 4 -text "\#pts"
3856	label $p.phi_l -width 5 -text "phi"
3857	label $p.psi_l -width 5 -text "psi"
3858
3859	entry $p.lpn_1 -width 2 -textvariable dbufdisp(lpn_1)
3860	entry $p.mn_1 -width 2 -textvariable dbufdisp(mn_1)
3861	entry $p.xyz_1 -width 1 -textvariable dbufdisp(xyz_1)
3862	entry $p.a_1 -width 7 -textvariable dbufdisp(a_1)
3863	entry $p.i_1 -width 7 -textvariable dbufdisp(i_1)
3864	entry $p.e_1 -width 7 -textvariable dbufdisp(e_1)
3865	entry $p.a_xyz_1 -width 7 -textvariable dbufdisp(a_xyz_1)
3866	entry $p.i_xyz_1 -width 7 -textvariable dbufdisp(i_xyz_1)
3867	entry $p.e_xyz_1 -width 7 -textvariable dbufdisp(e_xyz_1)
3868	entry $p.lpts_1 -width 4 -textvariable dbufdisp(lpts_1)
3869
3870	entry $p.phi -width 5 -textvariable dbufdisp(phi)
3871	entry $p.psi -width 5 -textvariable dbufdisp(psi)
3872
3873	entry $p.lpn_2 -width 2 -textvariable dbufdisp(lpn_2)
3874	entry $p.mn_2 -width 2 -textvariable dbufdisp(mn_2)
3875	entry $p.xyz_2 -width 1 -textvariable dbufdisp(xyz_2)
3876	entry $p.a_2 -width 7 -textvariable dbufdisp(a_2)
3877	entry $p.i_2 -width 7 -textvariable dbufdisp(i_2)
3878	entry $p.e_2 -width 7 -textvariable dbufdisp(e_2)
3879	entry $p.a_xyz_2 -width 7 -textvariable dbufdisp(a_xyz_2)
3880	entry $p.i_xyz_2 -width 7 -textvariable dbufdisp(i_xyz_2)
3881	entry $p.e_xyz_2 -width 7 -textvariable dbufdisp(e_xyz_2)
3882	entry $p.lpts_2 -width 4 -textvariable dbufdisp(lpts_2)
3883
3884	entry $p.lpn_3 -width 2 -textvariable dbufdisp(lpn_3)
3885	entry $p.mn_3 -width 2 -textvariable dbufdisp(mn_3)
3886	entry $p.xyz_3 -width 1 -textvariable dbufdisp(xyz_3)
3887	entry $p.a_3 -width 7 -textvariable dbufdisp(a_3)
3888	entry $p.i_3 -width 7 -textvariable dbufdisp(i_3)
3889	entry $p.e_3 -width 7 -textvariable dbufdisp(e_3)
3890	entry $p.a_xyz_3 -width 7 -textvariable dbufdisp(a_xyz_3)
3891	entry $p.i_xyz_3 -width 7 -textvariable dbufdisp(i_xyz_3)
3892	entry $p.e_xyz_3 -width 7 -textvariable dbufdisp(e_xyz_3)
3893	entry $p.lpts_3 -width 4 -textvariable dbufdisp(lpts_3)
3894
3895	entry $p.lpn_4 -width 2 -textvariable dbufdisp(lpn_4)
3896	entry $p.mn_4 -width 2 -textvariable dbufdisp(mn_4)
3897	entry $p.xyz_4 -width 1 -textvariable dbufdisp(xyz_4)
3898	entry $p.a_4 -width 7 -textvariable dbufdisp(a_4)
3899	entry $p.i_4 -width 7 -textvariable dbufdisp(i_4)
3900	entry $p.e_4 -width 7 -textvariable dbufdisp(e_4)
3901	entry $p.a_xyz_4 -width 7 -textvariable dbufdisp(a_xyz_4)
3902	entry $p.i_xyz_4 -width 7 -textvariable dbufdisp(i_xyz_4)
3903	entry $p.e_xyz_4 -width 7 -textvariable dbufdisp(e_xyz_4)
3904	entry $p.lpts_4 -width 4 -textvariable dbufdisp(lpts_4)
3905
3906	entry $p.lpn_5 -width 2 -textvariable dbufdisp(lpn_5)
3907	entry $p.mn_5 -width 2 -textvariable dbufdisp(mn_5)
3908	entry $p.xyz_5 -width 1 -textvariable dbufdisp(xyz_5)
3909	entry $p.a_5 -width 7 -textvariable dbufdisp(a_5)
3910	entry $p.i_5 -width 7 -textvariable dbufdisp(i_5)
3911	entry $p.e_5 -width 7 -textvariable dbufdisp(e_5)
3912	entry $p.a_xyz_5 -width 7 -textvariable dbufdisp(a_xyz_5)
3913	entry $p.i_xyz_5 -width 7 -textvariable dbufdisp(i_xyz_5)
3914	entry $p.e_xyz_5 -width 7 -textvariable dbufdisp(e_xyz_5)
3915	entry $p.lpts_5 -width 4 -textvariable dbufdisp(lpts_5)
3916
3917	entry $p.lpn_6 -width 2 -textvariable dbufdisp(lpn_6)
3918	entry $p.mn_6 -width 2 -textvariable dbufdisp(mn_6)
3919	entry $p.xyz_6 -width 1 -textvariable dbufdisp(xyz_6)
3920	entry $p.a_6 -width 7 -textvariable dbufdisp(a_6)
3921	entry $p.i_6 -width 7 -textvariable dbufdisp(i_6)
3922	entry $p.e_6 -width 7 -textvariable dbufdisp(e_6)
3923	entry $p.a_xyz_6 -width 7 -textvariable dbufdisp(a_xyz_6)
3924	entry $p.i_xyz_6 -width 7 -textvariable dbufdisp(i_xyz_6)
3925	entry $p.e_xyz_6 -width 7 -textvariable dbufdisp(e_xyz_6)
3926	entry $p.lpts_6 -width 4 -textvariable dbufdisp(lpts_6)
3927
3928	label $p.pts_l -text "#Pts:"
3929	label $p.pts -width 5 -anchor w -textvariable dbufdisp(pts)
3930
3931	label $p.templabel -text "Temp/H:"
3932	frame $p.temp
3933	label $p.temp.t0label -text "T0:"
3934	entry $p.temp.t0 -textvariable dbufdisp(tmp) -width 6
3935	label $p.temp.tinclabel -text "Inc-T:"
3936	entry $p.temp.tinc -textvariable dbufdisp(it) -width 6
3937	label $p.temp.twlabel -text "Wait:"
3938	entry $p.temp.tw -textvariable dbufdisp(tw) -width 6
3939	label $p.temp.terlabel -text "Err:"
3940	entry $p.temp.ter -textvariable dbufdisp(ter) -width 6
3941	label $p.temp.th0label -text "Hld0:"
3942	entry $p.temp.th0 -textvariable dbufdisp(th0) -width 6
3943	button $p.temp.field -text FIELD -command DBufFieldDialog -state disabled
3944	pack $p.temp.t0label $p.temp.t0 $p.temp.tinclabel $p.temp.tinc \
3945	$p.temp.twlabel $p.temp.tw $p.temp.terlabel $p.temp.ter \
3946	$p.temp.th0label $p.temp.th0 $p.temp.field -side left
3947
3948	label $p.timelabel -text "Time:"
3949	frame $p.time
3950	label $p.time.monlabel -text "Monitor:"
3951	entry $p.time.mon -textvariable dbufdisp(mon) -width 6
3952	label $p.time.mpflabel -text "Prefac:"
3953	entry $p.time.mpf -textvariable dbufdisp(mpf) -width 6
3954	label $p.time.mtlabel -text "M-typ:"
3955	tk_optionMenu $p.time.mt dbufdisp(mt) TIME NEUT
3956	pack $p.time.monlabel $p.time.mon $p.time.mpflabel $p.time.mpf \
3957	$p.time.mtlabel $p.time.mt -side left
3958
3959	grid $p.bufnolabel $p.commentlabel - $p.comment - - - - - - - - - -sticky ew
3960	grid x $p.lpn_l $p.mn_l $p.xyz_l $p.a_l $p.i_l $p.e_l \
3961	$p.a_xyz_l $p.i_xyz_l $p.e_xyz_l $p.lpts_l $p.phi_l $p.psi_l
3962	grid x $p.lpn_1 $p.mn_1 $p.xyz_1 $p.a_1 $p.i_1 $p.e_1 \
3963	$p.a_xyz_1 $p.i_xyz_1 $p.e_xyz_1 $p.lpts_1 $p.phi $p.psi
3964	grid x $p.lpn_2 $p.mn_2 $p.xyz_2 $p.a_2 $p.i_2 $p.e_2 \
3965	$p.a_xyz_2 $p.i_xyz_2 $p.e_xyz_2 $p.lpts_2
3966	grid x $p.lpn_3 $p.mn_3 $p.xyz_3 $p.a_3 $p.i_3 $p.e_3 \
3967	$p.a_xyz_3 $p.i_xyz_3 $p.e_xyz_3 $p.lpts_3 $p.pts_l $p.pts
3968	grid x $p.lpn_4 $p.mn_4 $p.xyz_4 $p.a_4 $p.i_4 $p.e_4 \
3969	$p.a_xyz_4 $p.i_xyz_4 $p.e_xyz_4 $p.lpts_4
3970	grid x $p.lpn_5 $p.mn_5 $p.xyz_5 $p.a_5 $p.i_5 $p.e_5 \
3971	$p.a_xyz_5 $p.i_xyz_5 $p.e_xyz_5 $p.lpts_5
3972	grid x $p.lpn_6 $p.mn_6 $p.xyz_6 $p.a_6 $p.i_6 $p.e_6 \
3973	$p.a_xyz_6 $p.i_xyz_6 $p.e_xyz_6 $p.lpts_6
3974	grid $p.templabel $p.temp - - - - - -
3975	grid $p.timelabel $p.time - - - - - -
3976
3977
3978	bind $p.lpts_1 <Return> DBufCalcAngles
3979	bind $p.lpts_2 <Return> DBufCalcAngles
3980	bind $p.lpts_3 <Return> DBufCalcAngles
3981	bind $p.lpts_4 <Return> DBufCalcAngles
3982	bind $p.lpts_5 <Return> DBufCalcAngles
3983	bind $p.lpts_6 <Return> DBufCalcAngles
3984
3985	bind $p.lpts_1 <FocusOut> DBufCalcAngles
3986	bind $p.lpts_2 <FocusOut> DBufCalcAngles
3987	bind $p.lpts_3 <FocusOut> DBufCalcAngles
3988	bind $p.lpts_4 <FocusOut> DBufCalcAngles
3989	bind $p.lpts_5 <FocusOut> DBufCalcAngles
3990	bind $p.lpts_6 <FocusOut> DBufCalcAngles
3991
3992	bind $p.a_1 <Return> DBufCalcAngles
3993	bind $p.a_2 <Return> DBufCalcAngles
3994	bind $p.a_3 <Return> DBufCalcAngles
3995	bind $p.a_4 <Return> DBufCalcAngles
3996	bind $p.a_5 <Return> DBufCalcAngles
3997	bind $p.a_6 <Return> DBufCalcAngles
3998
3999	bind $p.a_1 <FocusOut> DBufCalcAngles
4000	bind $p.a_2 <FocusOut> DBufCalcAngles
4001	bind $p.a_3 <FocusOut> DBufCalcAngles
4002	bind $p.a_4 <FocusOut> DBufCalcAngles
4003	bind $p.a_5 <FocusOut> DBufCalcAngles
4004	bind $p.a_6 <FocusOut> DBufCalcAngles
4005
4006	bind $p.i_1 <Return> DBufCalcAngles
4007	bind $p.i_2 <Return> DBufCalcAngles
4008	bind $p.i_3 <Return> DBufCalcAngles
4009	bind $p.i_4 <Return> DBufCalcAngles
4010	bind $p.i_5 <Return> DBufCalcAngles
4011	bind $p.i_6 <Return> DBufCalcAngles
4012
4013	bind $p.i_1 <FocusOut> DBufCalcAngles
4014	bind $p.i_2 <FocusOut> DBufCalcAngles
4015	bind $p.i_3 <FocusOut> DBufCalcAngles
4016	bind $p.i_4 <FocusOut> DBufCalcAngles
4017	bind $p.i_5 <FocusOut> DBufCalcAngles
4018	bind $p.i_6 <FocusOut> DBufCalcAngles
4019	}
4020
4021	proc DBufCheckFld { } {
4022	global dbufdisp
4023	return
4024	set flds {a_1 a_2 a_3 a_4 a_5 a_6 \
4025	i_1 i_2 i_3 i_4 i_5 i_6 \
4026	a_xyz_1 a_xyz_2 a_xyz_3 a_xyz_4 a_xyz_5 a_xyz_6 \
4027	i_xyz_1 i_xyz_2 i_xyz_3 i_xyz_4 i_xyz_5 i_xyz_6 \
4028	lpts_1 lpts_2 lpts_3 lpts_4 lpts_5 lpts_6 \
4029	hf tmp it tw th0 ter mon mpf ihf hfw hfh th }
4030	foreach fld $flds {
4031	# Check to make sure these are floating point numbers
4032	if [catch { expr 1.0 * $dbufdisp($fld) } result] {
4033	set dbufdisp($fld) "--------"
4034	return -code error "Parameter $fld must be floating point number"
4035	}
4036	}
4037
4038
4039	}
4040
4041	proc DBufCalcAngles {{anglist {1 2 3 4 5 6}}} {
4042	global dbufdisp
4043
4044
4045	array set ploop { pts_1 0 pts_2 0 pts_3 0 pts_4 0 pts_5 0 pts_6 0 }
4046	set maxloop 1
4047	foreach i $anglist {
4048	if [catch {expr $dbufdisp(lpn_$i) * 1} dbufdisp(lpn_$i)] {
4049	set dbufdisp(lpts_$i) "------"
4050	return
4051	}
4052
4053	if [catch {expr $dbufdisp(lpts_$i) * 1} dbufdisp(lpts_$i)] {
4054	set dbufdisp(lpts_$i) "------"
4055	return
4056	}
4057
4058	if {$dbufdisp(lpn_$i) < 1} { set dbufdisp(lpn_$i) 1 }
4059	if {$dbufdisp(lpn_$i) > 6} { set dbufdisp(lpn_$i) 6 }
4060	set iloop $dbufdisp(lpn_$i)
4061	if { $ploop(pts_$iloop) == 0 } {
4062	set ploop(pts_$iloop) $dbufdisp(lpts_$i)
4063	} else {
4064	set dbufdisp(lpts_$i) $ploop(pts_$iloop)
4065	}
4066	}
4067
4068	set pts 0
4069	foreach i $anglist {
4070	if { $ploop(pts_$i) > 0 } {
4071	if {$pts == 0} {
4072	set pts $ploop(pts_$i)
4073	} else {
4074	set pts [expr $pts * $ploop(pts_$i)]
4075	}
4076	}
4077	}
4078	set dbufdisp(pts) $pts
4079
4080	foreach i $anglist {
4081	set abeg "a_$i"
4082	set ainc "i_$i"
4083	set aend "e_$i"
4084	set xbeg "a_xyz_$i"
4085	set xinc "i_xyz_$i"
4086	set xend "e_xyz_$i"
4087
4088
4089
4090	if [catch {expr $dbufdisp($abeg) * 1.0} ibufdisp($abeg)] {
4091	set dbufdisp($abeg) "------"
4092	set dbufdisp($aend) "------"
4093	return
4094	}
4095	if [catch {expr $dbufdisp($ainc) * 1.0} dbufdisp($ainc)] {
4096	set dbufdisp($ainc) "------"
4097	set dbufdisp($aend) "------"
4098	return
4099	}
4100	if [catch {expr $dbufdisp($xbeg) * 1.0} ibufdisp($xbeg)] {
4101	set dbufdisp($xbeg) "------"
4102	set dbufdisp($xend) "------"
4103	return
4104	}
4105	if [catch {expr $dbufdisp($xinc) * 1.0} dbufdisp($xinc)] {
4106	set dbufdisp($xinc) "------"
4107	set dbufdisp($xend) "------"
4108	return
4109	}
4110	set dbufdisp($aend) [expr $dbufdisp($abeg) + \
4111	$dbufdisp($ainc) * ($dbufdisp(lpts_$i) - 1)]
4112	set dbufdisp($xend) [expr $dbufdisp($xbeg) + \
4113	$dbufdisp($xinc) * ($dbufdisp(lpts_$i) - 1)]
4114	}
4115	update
4116	}
4117
4118
4119	#==============================================================================
4120
4121	proc BufopEntryCreate { parent } {
4122	global bufop text_only
4123	set cl [label $parent.clab -text "Command:" -anchor w]
4124	set ce [entry $parent.cent -textvariable bufop(command) -width 30]
4125	set rt [label $parent.result -height 6 -anchor nw]
4126	set ex [button $parent.dismiss -text "Return" -command BufopHide]
4127
4128	if {!$text_only} {
4129	$rt configure -font fixed -relief sunken -justify left
4130	}
4131
4132	grid $cl $ce -sticky ew
4133	grid $rt - -sticky ew
4134	grid $ex - -sticky ew
4135	set bufop(msgwid) $rt
4136
4137	# Setup bindings
4138	bind $ce <KeyPress-Return> BufopAction
4139
4140	}
4141
4142	proc BufopShow { } {
4143	global bufop
4144	notebook_display .e bufop
4145	}
4146
4147	proc BufopHide { } {
4148	global mode bufop ibufdisp bbufdisp tbufdisp qbufdisp rbufdisp dbufdisp
4149	switch $mode {
4150	bragg {
4151	BBufDisp $bbufdisp(current)
4152	notebook_display .e bbuf
4153	}
4154	increment {
4155	IBufDisp $ibufdisp(current)
4156	notebook_display .e ibuf
4157	}
4158	q {
4159	QBufDisp $qbufdisp(current)
4160	notebook_display .e qbuf
4161	}
4162	trash {
4163	TBufDisp $tbufdisp(current)
4164	notebook_display .e tbuf
4165	}
4166	reflectivity {
4167	RBufDisp $rbufdisp(current)
4168	notebook_display .e rbuf
4169	}
4170	diffraction {
4171	DBufDisp $dbufdisp(current)
4172	notebook_display .e dbuf
4173	}
4174	}
4175	}
4176
4177	proc BufopMsg { msg } {
4178	global bufop
4179	$bufop(msgwid) configure -text $msg
4180	}
4181
4182	#
4183	# Parse bufop(command) and take the appropriate action
4184	#
4185	proc BufopAction { } {
4186	global bufop mode ibuf tbuf qbuf rbuf dbuf bbuf ibufdisp tbufdisp qbufdisp rbufdisp dbufdisp bbufdisp
4187	set bufop(command) [string tolower $bufop(command)]
4188
4189	if [regexp {copy} $bufop(command)] {
4190	return [BufopCopy]
4191	}
4192
4193	if {![regexp = $bufop(command)]} {
4194	BufopMsg "Syntax: parameter = value"
4195	}
4196	set parts [split $bufop(command) "="]
4197	set parm [string trimleft [string trimright [lindex $parts 0]]]
4198	set val [lindex $parts 1]
4199
4200	# First test to see if parameter exists in hash
4201	switch $mode {
4202	bragg {
4203	set exists [info exists bbuf(0,$parm)]
4204	}
4205	increment {
4206	set exists [info exists ibuf(0,$parm)]
4207	}
4208	trash {
4209	set exists [info exists tbuf(0,$parm)]
4210	}
4211	q {
4212	set exists [info exists qbuf(0,$parm)]
4213	}
4214	reflectivity {
4215	set exists [info exists rbuf(0,$parm)]
4216	}
4217	diffraction {
4218	set exists [info exists dbuf(0,$parm)]
4219	}
4220	default {
4221	set exists 0
4222	}
4223	}
4224	if {!$exists} {
4225	BufopMsg "Parameter $parm does not exist\n in $mode buffers"
4226	return
4227	}
4228
4229	# Take care of "special" syntax
4230	if {[string compare $parm "mt"] == 0} {
4231	if [regexp n $val] {
4232	set val NEUT
4233	} else {
4234	set val TIME
4235	}
4236	}
4237
4238	# Set values
4239	for {set i 0} {$i < 30} {incr i} {
4240	switch $mode {
4241	bragg {
4242	set bbuf($i,$parm) $val
4243	}
4244	increment {
4245	set ibuf($i,$parm) $val
4246	}
4247	trash {
4248	set tbuf($i,$parm) $val
4249	}
4250	q {
4251	set qbuf($i,$parm) $val
4252	}
4253	reflectivity {
4254	set rbuf($i,$parm) $val
4255	}
4256	diffraction {
4257	set dbuf($i,$parm) $val
4258	}
4259	}
4260	}
4261	BufopMsg "Updating buffers"
4262	# Now update the buffers and displays
4263	#### Make sure we update the entry mask as well!!!
4264	switch $mode {
4265	bragg {
4266	BBufWriteFile
4267	BBufList
4268	}
4269	increment {
4270	IBufWriteFile
4271	IBufList
4272	}
4273	q {
4274	QBufWriteFile
4275	QBufList
4276	}
4277	trash {
4278	TBufWriteFile
4279	TBufList
4280	}
4281	reflectivity {
4282	RBufWriteFile
4283	RBufList
4284	}
4285	diffraction {
4286	DBufWriteFile
4287	DBufList
4288	}
4289	}
4290	after 500 {BufopMsg ""}
4291	}
4292
4293	#
4294	# Syntax: copy n1-n2,m - copy buffers n1 to n2 to buffers m to m+(n2-n1)
4295	# need to know which buffers are active
4296	#
4297	#
4298	proc BufopCopy { } {
4299	global mode bufop ibufdisp bbufdisp qbufdisp rbufdisp tbufdisp dbufdisp
4300
4301	if {![regexp {copy ([^,]+),(.+)} $bufop(command) match src trg]} {
4302	BufopMsg "Syntax:\ncopy src,trg"
4303	}
4304
4305	# Parse source string - possibly fragile
4306	if {[regexp {([0-9]+)-([0-9]+)} $src match srclo srchi]} {
4307	set srclist {}
4308	for {set i $srclo} {$i <= $srchi} {incr i} {
4309	lappend srclist $i
4310	}
4311	} else {
4312	set srclist [expr $src * 1]
4313	}
4314
4315	foreach s $srclist {
4316	#puts "copying $s -> $trg"
4317	if { $trg <= 30 } {
4318	BufopTransfer [expr $s - 1] [expr $trg - 1]
4319	}
4320	incr trg
4321	}
4322	# Update buffers and displays
4323	BufopMsg "Updating buffers"
4324	# Now update the buffers and displays
4325	switch $mode {
4326	bragg {
4327	BBufWriteFile
4328	BBufDisp $bbufdisp(current)
4329	BBufList
4330	}
4331	increment {
4332	IBufWriteFile
4333	IBufDisp $ibufdisp(current)
4334	IBufList
4335	}
4336	q {
4337	QBufWriteFile
4338	QBufDisp $qbufdisp(current)
4339	QBufList
4340	}
4341	trash {
4342	TBufWriteFile
4343	TBufDisp $tbufdisp(current)
4344	TBufList
4345	}
4346	reflectivity {
4347	RBufWriteFile
4348	RBufDisp $rbufdisp(current)
4349	RBufList
4350	}
4351	diffraction {
4352	DBufWriteFile
4353	DBufDisp $dbufdisp(current)
4354	DBufList
4355	}
4356	}
4357	after 500 {BufopMsg ""}
4358	}
4359
4360	proc BufopTransfer { src trg } {
4361	global mode ibuf tbuf qbuf rbuf bbuf dbuf ibuf_fields qbuf_fields tbuf_fields rbuf_fields bbuf_fields dbuf_fields
4362
4363	switch $mode {
4364	bragg {
4365	foreach fld $bbuf_fields {
4366	set bbuf($trg,$fld) $bbuf($src,$fld)
4367	}
4368	}
4369	increment {
4370	foreach fld $ibuf_fields {
4371	set ibuf($trg,$fld) $ibuf($src,$fld)
4372	}
4373	}
4374	q {
4375	foreach fld $qbuf_fields {
4376	set qbuf($trg,$fld) $qbuf($src,$fld)
4377	}
4378	}
4379	trash {
4380	foreach fld $tbuf_fields {
4381	set tbuf($trg,$fld) $tbuf($src,$fld)
4382	}
4383	}
4384	reflectivity {
4385	foreach fld $rbuf_fields {
4386	set rbuf($trg,$fld) $rbuf($src,$fld)
4387	}
4388	}
4389	diffraction {
4390	foreach fld $dbuf_fields {
4391	set dbuf($trg,$fld) $dbuf($src,$fld)
4392	}
4393	}
4394	}
4395	}
4396
4397	proc MsgShow { args } {
4398	global msgpane
4399	if {[llength $args] > 0} {
4400	$msgpane configure -text [lindex $args 0]
4401	}
4402	notebook_display .e msg
4403	}
4404
4405	proc MsgHide { } {
4406	global mode
4407	switch $mode {
4408	bragg {
4409	notebook_display .e bbuf
4410	}
4411	increment {
4412	notebook_display .e ibuf
4413	}
4414	q {
4415	notebook_display .e qbuf
4416	}
4417	trash {
4418	notebook_display .e tbuf
4419	}
4420	reflectivity {
4421	notebook_display .e rbuf
4422	}
4423	diffraction {
4424	notebook_display .e dbuf
4425	}
4426	}
4427	}
4428
4429	#
4430	# Check to see whether the buffer file has changed on the disk under us
4431	#
4432	proc BufChangeCheck { } {
4433	global mode ibuf ibufdisp qbuf qbufdisp tbuf tbufdisp bbuf bbufdisp \
4434	rbuf rbufdisp dbuf dbufdisp changed text_only
4435
4436	switch $mode {
4437	increment {
4438	set mtime [file mtime IBUFFER.BUF]
4439	if { $mtime != $ibuf(mtime) } {
4440	if {!$text_only} {
4441	set save [tk_dialog .change "Buffer Changed!" \
4442	"The Buffer file has changed on the disk. Save anyway?" \
4443	error 0 No Yes]
4444	} else {
4445	set save [ck_dialog .change "Buffer Changed!" \
4446	"The Buffer file has changed on the disk. Save anyway?" \
4447	No Yes]
4448	}
4449	if { $save } { return 1 }
4450	IBufReadFile
4451	IBufList
4452	IBufDisp $ibufdisp(current)
4453	# set changed(ibufdisp) 0
4454	return 0
4455	}
4456	return 1
4457	}
4458	q {
4459	set mtime [file mtime QBUFFER.BUF]
4460	if { $mtime != $qbuf(mtime) } {
4461	if {!$text_only} {
4462	set save [tk_dialog .change "Buffer Changed!" \
4463	"The Buffer file has changed on the disk. Save anyway?" \
4464	error 0 No Yes]
4465	} else {
4466	set save [ck_dialog .change "Buffer Changed!" \
4467	"The Buffer file has changed on the disk. Save anyway?" \
4468	No Yes]
4469	}
4470	if { $save } { return 1 }
4471	QBufReadFile
4472	QBufList
4473	QBufDisp $qbufdisp(current)
4474	set changed(qbufdisp) 0
4475	return 0
4476	}
4477	return 1
4478	}
4479	bragg {
4480	set mtime [file mtime BBUFFER.BUF]
4481	if { $mtime != $bbuf(mtime) } {
4482	if {!$text_only} {
4483	set save [tk_dialog .change "Buffer Changed!" \
4484	"The Buffer file has changed on the disk. Save anyway?" \
4485	error 0 No Yes]
4486	} else {
4487	set save [ck_dialog .change "Buffer Changed!" \
4488	"The Buffer file has changed on the disk. Save anyway?" \
4489	No Yes]
4490	}
4491	if { $save } { return 1 }
4492	BBufReadFile
4493	BBufList
4494	BBufDisp $bbufdisp(current)
4495	set changed(bbufdisp) 0
4496	return 0
4497	}
4498	return 1
4499	}
4500	trash {
4501	set mtime [file mtime TBUFFER.BUF]
4502	if { $mtime != $tbuf(mtime) } {
4503	if {!$text_only} {
4504	set save [tk_dialog .change "Buffer Changed!" \
4505	"The Buffer file has changed on the disk. Save anyway?" \
4506	error 0 No Yes]
4507	} else {
4508	set save [ck_dialog .change "Buffer Changed!" \
4509	"The Buffer file has changed on the disk. Save anyway?" \
4510	No Yes]
4511	}
4512	if { $save } { return 1 }
4513	TBufReadFile
4514	TBufList
4515	TBufDisp $tbufdisp(current)
4516	set changed(tbufdisp) 0
4517	return 0
4518	}
4519	return 1
4520	}
4521	reflectivity {
4522	set mtime [file mtime RBUFFER.BUF]
4523	if { $mtime != $rbuf(mtime) } {
4524	if {!$text_only} {
4525	set save [tk_dialog .change "Buffer Changed!" \
4526	"The Buffer file has changed on the disk. Save anyway?" \
4527	error 0 No Yes]
4528	} else {
4529	set save [ck_dialog .change "Buffer Changed!" \
4530	"The Buffer file has changed on the disk. Save anyway?" \
4531	No Yes]
4532	}
4533	if { $save } { return 1 }
4534	RBufReadFile
4535	RBufList
4536	RBufDisp $rbufdisp(current)
4537	set changed(rbufdisp) 0
4538	return 0
4539	}
4540	return 1
4541	}
4542	diffraction {
4543	set mtime [file mtime DBUFFER.BUF]
4544	if { $mtime != $dbuf(mtime) } {
4545	if {!$text_only} {
4546	set save [tk_dialog .change "Buffer Changed!" \
4547	"The Buffer file has changed on the disk. Save anyway?" \
4548	error 0 No Yes]
4549	} else {
4550	set save [ck_dialog .change "Buffer Changed!" \
4551	"The Buffer file has changed on the disk. Save anyway?" \
4552	No Yes]
4553	}
4554	if { $save } { return 1 }
4555	DBufReadFile
4556	DBufList
4557	DBufDisp $dbufdisp(current)
4558	set changed(dbufdisp) 0
4559	return 0
4560	}
4561	return 1
4562	}
4563	}
4564	return 1
4565	}
4566
4567	proc CheckBufChange {} {
4568	global changed mode text_only
4569
4570	if {![info exists mode]} { return }
4571
4572	switch $mode {
4573	increment { set buf ibufdisp }
4574	q { set buf qbufdisp }
4575	bragg { set buf bbufdisp }
4576	trash { set buf tbufdisp }
4577	reflectivity { set buf rbufdisp }
4578	diffraction { set buf dbufdisp }
4579	default return
4580	}
4581	#puts $buf
4582	upvar #0 $buf bufdisp
4583
4584	if {$changed($buf)} {
4585	if {!$text_only} {
4586	set save [tk_dialog .change "Buffer Changed!" \
4587	"$mode Buffer [expr 1+$bufdisp(current)] has been edited, Save?" \
4588	warning 0 Yes No]
4589	} else {
4590	set save [ck_dialog .change "Buffer Changed!" \
4591	"$mode Buffer [expr 1+$bufdisp(current)] has been edited, Save?" \
4592	Yes No]
4593	}
4594	if { ! $save } { UpdateBuf }
4595	}
4596	set changed($buf) 0 ;# Reset changed flag
4597	}
4598
4599	proc UpdateBuf { } {
4600	global mode
4601	set finish [BufChangeCheck]
4602	if { !$finish } { return }
4603	MonRecCheck
4604	switch $mode {
4605	increment {
4606	MsgShow "Updating Buffer"
4607	if [catch {IBufUpdate} result] {
4608	MsgShow $result
4609	return
4610	}
4611	after 500 MsgHide
4612	}
4613	q {
4614	MsgShow "Updating Buffer"
4615	if [catch {QBufUpdate} result] {
4616	MsgShow $result
4617	return
4618	}
4619	after 500 MsgHide
4620	}
4621	bragg {
4622	MsgShow "Updating Buffer"
4623	if [catch {BBufUpdate} result] {
4624	MsgShow $result
4625	return
4626	}
4627	after 500 MsgHide
4628	}
4629	trash {
4630	MsgShow "Updating Buffer"
4631	if [catch {TBufUpdate} result] {
4632	MsgShow $result
4633	return
4634	}
4635	after 500 MsgHide
4636	}
4637	reflectivity {
4638	MsgShow "Updating Buffer"
4639	if [catch {RBufUpdate} result] {
4640	MsgShow $result
4641	return
4642	}
4643	after 500 MsgHide
4644	}
4645	diffraction {
4646	MsgShow "Updating Buffer"
4647	if [catch {DBufUpdate} result] {
4648	MsgShow $result
4649	return
4650	}
4651	after 500 MsgHide
4652	}
4653	}
4654	}
4655
4656	proc MonRecDialogBuild { } {
4657	global monrec config text_only
4658
4659	set p [toplevel .datainfo]
4660	set monrec(top) $p
4661
4662	if $text_only {
4663	set color white
4664	} else {
4665	set color gray
4666	wm title $p "Log Sample"
4667	wm withdraw $p
4668	}
4669
4670	label $p.userlab -text "Experimenters: "
4671	entry $p.user -textvariable monrec(user) -width 60
4672	label $p.samplab -text "Sample:"
4673	entry $p.samp -textvariable monrec(sample) -width 30
4674	label $p.quanlab -text "Quantity (g):"
4675	entry $p.quan -textvariable monrec(quantity) -width 8
4676	label $p.powerlab -text "Reactor Power: "
4677	entry $p.power -textvariable monrec(power) -width 8
4678	label $p.beamhlab -text "Beam Height: "
4679	entry $p.beamh -textvariable monrec(beamh) -width 8
4680	label $p.beamwlab -text "Beam Width:"
4681	entry $p.beamw -textvariable monrec(beamw) -width 8
4682	label $p.monolab -text "Monochromator: "
4683	entry $p.mono -textvariable monrec(mono) -width 8
4684	label $p.analab -text "Analyzer:"
4685	entry $p.ana -textvariable monrec(ana) -width 8
4686	label $p.filtlab -text "Filter:"
4687	entry $p.filt -textvariable monrec(filter) -width 8
4688	label $p.colllab -text "Collimation:"
4689	entry $p.coll -textvariable monrec(coll) -width 30
4690	label $p.efixlab -text "Fixed Energy (meV): "
4691	entry $p.efix -textvariable monrec(efix) -width 8
4692
4693	button $p.finish -text OK -command MonRecWrite
4694
4695	# Customizations
4696	if { $config(nsta) == 1 } {
4697	$p.powerlab config -fg $color
4698	$p.power config -fg $color -state disabled
4699	$p.beamhlab config -fg $color
4700	$p.beamh config -fg $color -state disabled
4701	$p.monolab config -fg $color
4702	$p.mono config -fg $color -state disabled
4703	$p.analab config -fg $color
4704	$p.ana config -fg $color -state disabled
4705	$p.filtlab config -fg $color
4706	$p.filt config -fg $color -state disabled
4707	$p.colllab config -fg $color
4708	$p.coll config -fg $color -state disabled
4709	$p.efixlab config -fg $color
4710	$p.efix config -fg $color -state disabled
4711	}
4712
4713	grid $p.userlab $p.user - - - - -sticky w
4714	grid $p.samplab $p.samp - - $p.quanlab $p.quan -sticky w
4715	grid $p.powerlab $p.power $p.beamhlab $p.beamh $p.beamwlab $p.beamw \
4716	-sticky w
4717	grid $p.monolab $p.mono $p.analab $p.ana $p.filtlab $p.filt -sticky w
4718	grid $p.colllab $p.coll - - $p.efixlab $p.efix -sticky w
4719	if {!$text_only} {
4720	grid x x $p.finish - -sticky ew
4721	wm protocol $p WM_DELETE_WINDOW "$p.finish invoke"
4722	} else {
4723	grid $p.finish - -sticky ew
4724	}
4725
4726	}
4727
4728	proc MonRecDialogShow { } {
4729	global monrec config text_only
4730	if $text_only {
4731	catch { destroy $monrec(top) }
4732	MonRecDialogBuild
4733	}
4734	set monrec(mono) $config(mono)
4735	if {!$text_only} {
4736	# center the dialog in the middle of the main
4737	set x [expr [winfo x .] + [winfo width .]/2 - \
4738	[winfo reqwidth $monrec(top)]/2 - [winfo vrootx .]]
4739	set y [expr [winfo y .] + [winfo height .]/2 - \
4740	[winfo reqheight $monrec(top)]/2 - [winfo vrooty .]]
4741	wm geom $monrec(top) +$x+$y
4742	wm transient $monrec(top) .
4743	wm deiconify $monrec(top)
4744	# set the grab
4745	grab $monrec(top)
4746	} else {
4747	place $monrec(top) -relheight 1.0 -relwidth 1.0
4748	focus $monrec(top)
4749	}
4750	}
4751
4752	proc MonRecDialogHide { } {
4753	global monrec text_only
4754	if {!$text_only} {
4755	# reset the grab
4756	grab .
4757	wm withdraw $monrec(top)
4758	} else {
4759	place forget $monrec(top)
4760	focus .
4761	destroy $monrec(top)
4762	.l.list selection set 0 0
4763	}
4764	}
4765
4766	proc MonRecWrite { } {
4767	global mode monrec
4768
4769	set vaxformat "%d-%b-%Y %H:%M"
4770	set ctformat "%b %d %Y %H:%M"
4771
4772	set time [clock format [clock seconds] -format $ctformat]
4773	if [catch {open $monrec(mfile) a+} file] {
4774	puts stderr "Can't open $monrec(mfile)"
4775	MonRecDialogHide
4776	return
4777	}
4778	puts $file " $time [pwd] $monrec(prefix)"
4779	puts $file " Experimenters: $monrec(user)"
4780	puts $file " Sample: $monrec(sample)\t\tQuantity (g): $monrec(quantity)"
4781	puts $file " Reactor Power: $monrec(power)\tBeam Height (in): $monrec(beamh)\tWidth: $monrec(beamw)"
4782	puts $file " Monochromator: $monrec(mono)\tAnalyzer: $monrec(ana)\tFilter: $monrec(filter)"
4783	puts $file " Collimator: $monrec(coll)\t\tFixed Energy (meV): $monrec(efix)"
4784	close $file
4785
4786	MonRecDialogHide
4787	}
4788
4789	proc MonRecCheck { } {
4790	global mode monrec
4791	switch $mode {
4792	increment { set p i }
4793	q { set p q }
4794	trash { set p t }
4795	default return
4796	}
4797
4798	global ${p}buf ${p}bufdisp
4799
4800	set prefix [string range [set ${p}bufdisp(comment)] 0 4]
4801	# validate prefix
4802	while {![regexp {[a-zA-Z0-9][a-zA-Z0-9][a-zA-Z0-9][a-zA-Z0-9][a-zA-Z0-9]} $prefix]} {
4803	set prefix [GetNewPrefix $prefix]
4804	set ${p}bufdisp(comment) "${prefix}[string range [set ${p}bufdisp(comment)] 5 end]"
4805	}
4806	for { set i 0} { $i < 30 } {incr i} {
4807	lappend preflist [string range [set ${p}buf(${i},comment)] 0 4]
4808	}
4809	if {[lsearch $preflist $prefix] < 0} {
4810	set monrec(prefix) $prefix
4811	return [MonRecDialogShow]
4812	} else {
4813	global text_only
4814	if $text_only {
4815	.l.list selection set 0 0
4816	}
4817	}
4818	}
4819
4820	#=Eval entry dialog============================================================
4821
4822	proc EvalEntryCreate { parent } {
4823	global evalbox text_only
4824
4825	set evalbox(parent) $parent
4826	set evalbox(current) ""
4827	set evalbox(result) ""
4828
4829	set el [label $parent.label -text "Command:"]
4830	set ee [entry $parent.entry -textvariable evalbox(current) -width 50]
4831
4832	set er [label $parent.result -textvariable evalbox(result) \
4833	-height 8 -width 60 -anchor nw]
4834	set ex [button $parent.dismiss -text "Return" -command EvalHide]
4835
4836	if {!$text_only} {
4837	$er configure -font fixed -relief sunken
4838	}
4839
4840	grid $el $ee -sticky ew
4841	grid $er - -sticky ew
4842	grid $ex - -sticky ew
4843
4844
4845	bind $ee <Return> EvalAction
4846	return $parent
4847	}
4848
4849	proc EvalAction { } {
4850	global evalbox
4851	if {[string length [string trimright $evalbox(current)]] != 0} {
4852	catch {uplevel #0 eval $evalbox(current)} evalbox(result)
4853	}
4854	set evalbox(current) ""
4855	}
4856
4857	proc EvalShow { } {
4858	global evalbox
4859	notebook_display .e evalbox
4860	}
4861
4862	proc EvalHide { } {
4863	global mode ibufdisp tbufdisp qbufdisp
4864	switch $mode {
4865	bragg {
4866	BBufDisp $ibufdisp(current)
4867	notebook_display .e bbuf
4868	}
4869	increment {
4870	IBufDisp $ibufdisp(current)
4871	notebook_display .e ibuf
4872	}
4873	q {
4874	QBufDisp $qbufdisp(current)
4875	notebook_display .e qbuf
4876	}
4877	trash {
4878	TBufDisp $tbufdisp(current)
4879	notebook_display .e tbuf
4880	}
4881	}
4882	}
4883
4884	#=Automon Dialog===============================================================
4885
4886	proc AutomonInit { } {
4887	global automon env config
4888
4889	set automon(file) "$config(root)/cfg/HWLONG.BUF"
4890	set automon(cps) 500
4891	set automon(hwlconst) 1.0
4892	set automon(mon) ?
4893	set automon(pre) 1
4894	set automon(base) duration
4895	set automon(cps) 500
4896	set automon(savedcps) 500
4897	set automon(weekday) Sun
4898	set automon(hours) 1
4899	set automon(hh) 00
4900	set automon(mm) 00
4901	set automon(usewait) 0
4902	set automon(usehold) 0
4903
4904	}
4905
4906	proc AutomonReadFile { } {
4907	global automon
4908	if {![file exists $automon(file)]} { return }
4909	set f [open $automon(file) r]
4910	fconfigure $f -encoding binary
4911	set input [read $f 20]
4912	binary scan $input fffif dlast monang cps cnstover hwlconst
4913	# Trim values to reasonable precision
4914	# set automon(cps) [format %.2f $cps]
4915	set automon(savedcps) [format %.2f $cps]
4916	set automon(hwlconst) [format %.1f $hwlconst]
4917	return
4918	}
4919
4920	proc AutomonBuild { } {
4921	global automon ibufdisp ibuf text_only
4922
4923	AutomonInit
4924	set p [toplevel .automon]
4925	set automon(top) $p
4926
4927	if {!$text_only} {
4928	wm withdraw $automon(top)
4929	}
4930
4931	set pm [frame $p.mon]
4932	label $pm.1 -text "Monitor computation settings"
4933	label $pm.2 -text "MRAT (cps)"
4934	entry $pm.cps -textvariable automon(cps) -width 10
4935	label $pm.3 -text "ovrhd (sec/pt)"
4936	entry $pm.hwl -textvariable automon(hwlconst) -width 5
4937	grid $pm.1 -columnspan 4
4938	if $text_only {
4939	label $pm.blank -text " "
4940	grid $pm.blank
4941	}
4942	grid $pm.2 $pm.cps $pm.3 $pm.hwl
4943
4944	# Perhaps make this a global option
4945	global config
4946	if {$config(nsta) == 1} {
4947	label $pm.4 -text "Set MRAT to"
4948	if $text_only {
4949	set menu [ck_optionMenu $pm.5 automon(amonlbl) junk]
4950	} else {
4951	set menu [tk_optionMenu $pm.5 automon(amonlbl) junk]
4952	}
4953	$menu delete 0 end
4954	foreach var $config(instr_list) {
4955	$menu add command -label "$var default" \
4956	-command \
4957	"set automon(amonlbl) $var;\
4958	set automon(cps) $config(cps-$var);\
4959	set config(instr) $var;\
4960	ConfigChange";
4961	}
4962
4963	$menu add command -label "last saved MRAT" \
4964	-command "set automon(amonlbl) {(last saved MRAT)};\
4965	AutomonReadFile; set automon(cps) $automon(savedcps)"
4966	set automon(amonlbl) "(last saved MRAT)"
4967	grid $pm.4 $pm.5
4968	grid $pm.4 -sticky e
4969	grid $pm.5 -sticky w -columnspan 3
4970	}
4971
4972	set pv1 [frame $p.vars1 -relief groove -bd 4]
4973	set pv2 [frame $p.vars2]
4974	checkbutton $pv1.wlab -text Wait -variable automon(usewait)
4975	checkbutton $pv1.hlab -text Hold -variable automon(usehold)
4976	entry $pv1.wait -textvariable ibufdisp(tw) -width 6
4977	entry $pv1.hold -textvariable ibufdisp(th0) -width 6
4978	label $pv1.lab -text "Control Delays "
4979	label $pv2.mlab -text "Monitor:"
4980	label $pv2.plab -text Prefactors
4981
4982	label $pv2.mon -textvariable automon(mon) -width 10 \
4983	-bg lightyellow -justify center -anchor center
4984	entry $pv2.pre -textvariable automon(mpf) -width 4
4985	button $pv2.compute -text Compute -command AutomonCompute
4986
4987	set pb [frame $p.base]
4988	radiobutton $pb.dlab -text "Scan duration (hrs):" -value duration \
4989	-variable automon(base)
4990	radiobutton $pb.elab -text "End at time:" -value endtime \
4991	-variable automon(base)
4992	entry $pb.hours -textvariable automon(hours) -width 7
4993
4994
4995	if $text_only {
4996	ck_optionMenu $pb.weekday automon(weekday) Sun Mon Tue Wed Thu Fri Sat
4997	ck_optionMenu $pb.hh automon(hh) 00 01 02 03 04 05 06 07 08 09 10 11 \
4998	12 13 14 15 16 17 18 19 20 21 22 23
4999	label $pb.colon -text :
5000	ck_optionMenu $pb.mm automon(mm) 00 05 10 15 20 25 30 35 40 45 50 55
5001	} else {
5002	$p.mon configure -relief groove -bd 4
5003	$pv2.mon configure -relief sunken
5004	tk_optionMenu $pb.weekday automon(weekday) Sun Mon Tue Wed Thu Fri Sat
5005	tk_optionMenu $pb.hh automon(hh) 00 01 02 03 04 05 06 07 08 09 10 11 \
5006	12 13 14 15 16 17 18 19 20 21 22 23
5007	label $pb.colon -text :
5008	tk_optionMenu $pb.mm automon(mm) 00 05 10 15 20 25 30 35 40 45 50 55
5009	}
5010
5011	set pB [frame $p.buttons]
5012	button $pB.ok -text OK -command "AutomonCompute; AutomonApply; AutomonHide"
5013	button $pB.cancel -text Cancel -command AutomonHide
5014	wm protocol $p WM_DELETE_WINDOW "$pB.cancel invoke"
5015
5016	grid $pv1.lab $pv1.wlab $pv1.wait $pv1.hlab $pv1.hold
5017	grid $pv2.plab $pv2.pre $pv2.mlab $pv2.mon $pv2.compute
5018	grid $pv2.mon -sticky ew
5019
5020	grid $pb.dlab $pb.hours -in $pb -sticky w
5021	grid $pb.elab $pb.weekday $pb.hh $pb.colon $pb.mm -in $pb -sticky w
5022
5023	grid $pB.ok $pB.cancel -row 1
5024
5025	pack $pm $pv1 $pv2 $pb $pB -side top -expand true -fill x -anchor w
5026	}
5027
5028	proc AutomonShow { } {
5029	global automon text_only ibufdisp config
5030	AutomonReadFile
5031	if $text_only {
5032	catch { destroy $automon(top) }
5033	AutomonBuild
5034	place $automon(top) -relheight 1.0 -relwidth 1.0
5035	focus $automon(top)
5036	} else {
5037	# center the dialog in the middle of the main
5038	set x [expr [winfo x .] + [winfo width .]/2 - \
5039	[winfo reqwidth $automon(top)]/2 - [winfo vrootx .]]
5040	set y [expr [winfo y .] + [winfo height .]/2 - \
5041	[winfo reqheight $automon(top)]/2 - [winfo vrooty .]]
5042	wm geom $automon(top) +$x+$y
5043	wm transient $automon(top) .
5044	wm deiconify $automon(top)
5045	if {$config(mode) == 0} {set mode 0} else {set mode 1}
5046	set pv1 .automon.vars1
5047	DisableWidget "$pv1.lab $pv1.wlab $pv1.wait $pv1.hlab $pv1.hold" $mode
5048	# if this is BT-1 and we are using the MRAT/S value, update to the latest value
5049	if {$config(nsta) == 1 && $automon(amonlbl) == {(last saved MRAT)}} {
5050	AutomonReadFile
5051	set automon(cps) $automon(savedcps)
5052	}
5053	# round up invalid prefactor value, default is 4
5054	set automon(mpf) $ibufdisp(mpf)
5055	set automon(mpf) [expr int($automon(mpf)+0.5)]
5056	if {$automon(mpf) <= 0} {set automon(mpf) 4}
5057	grab $automon(top)
5058	}
5059	}
5060
5061	proc AutomonHide { } {
5062	global automon text_only
5063
5064	if $text_only {
5065	place forget $automon(top)
5066	focus .
5067	destroy $automon(top)
5068	.l.list selection set 0 0
5069	} else {
5070	grab release $automon(top)
5071	wm withdraw $automon(top)
5072	}
5073	}
5074
5075	proc AutomonCompute { } {
5076	global automon ibufdisp
5077
5078	#AutomonReadFile
5079	switch $automon(base) {
5080	endtime {
5081	set curtime [clock seconds]
5082	set endtime [clock scan \
5083	"$automon(weekday) $automon(hh):$automon(mm)"]
5084	set total_t [expr $endtime - $curtime]
5085	}
5086	default {
5087	# duration
5088	set total_t [expr 3600 * $automon(hours)]
5089	}
5090	}
5091
5092	if {$automon(mpf) <= 0} { set ibufdisp(mpf) 1}
5093
5094	# Now calculate how much overhead to subtract
5095	# Do it cheap and dirty for now - assume a constant monitor rate
5096
5097	# Subtract hold
5098	if {$automon(usehold)} {
5099	set t_ho $ibufdisp(th0)
5100	} else {
5101	set t_ho 0
5102	}
5103
5104	# Subtract hardware overhead
5105	set t_hw [expr $ibufdisp(pts) * $automon(hwlconst)]
5106
5107	# Subtract wait/pt
5108	if {$automon(usewait)} {
5109	set t_tw [expr $ibufdisp(tw) * $ibufdisp(pts)]
5110	} else {
5111	set t_tw 0
5112	}
5113
5114	set delta_t [expr $total_t - $t_ho - $t_hw - $t_tw]
5115	set t_pt [expr $delta_t / $ibufdisp(pts)]
5116
5117	# Get time/prefactor
5118	set t_pre [expr $t_pt / $automon(mpf)]
5119
5120
5121	switch $ibufdisp(mt) {
5122	NEUT {
5123	set automon(mon) [expr floor($t_pre * $automon(cps))]
5124	}
5125	default {
5126	set automon(mon) [expr floor($t_pre)]
5127	}
5128	}
5129
5130	}
5131
5132	# Apply monitor value to buffer in question
5133	#
5134	proc AutomonApply { } {
5135	global automon ibufdisp
5136
5137	set ibufdisp(mpf) $automon(mpf)
5138	set ibufdisp(mon) $automon(mon)
5139	update
5140
5141	}
5142
5143	#=Sequence Editor==============================================================
5144
5145	proc SequenceRead { } {
5146	global env sequence ibuf
5147
5148	if {![file exists $sequence(file)]} {
5149	return
5150	}
5151
5152	if [file exists IBUFFER.BUF] {
5153	set f [open IBUFFER.BUF r+]
5154	fconfigure $f -encoding binary
5155	seek $f [expr 320 * 30] start
5156	set contents [read $f 320]
5157	binary scan $contents A320 contents
5158	set contents [string trimright $contents]
5159	set ibuf(sequence) $contents
5160	close $f
5161	} else {
5162	set contents {}
5163	}
5164
5165	$sequence(list) delete 0 end
5166	regsub {#$} $contents {} contents
5167	foreach s [split $contents \;] {
5168	$sequence(list) insert end $s
5169	}
5170	}
5171
5172	proc SequenceWrite { } {
5173	global ibuf sequence
5174
5175	set contents [join [$sequence(list) get 0 end] ";"]
5176	append contents {#}
5177	set ibuf(sequence) $contents
5178
5179	if [file exists IBUFFER.BUF] {
5180	set f [open IBUFFER.BUF r+]
5181	fconfigure $f -encoding binary
5182	seek $f [expr 320 * 30] start
5183	puts -nonewline $f [binary format A320 $ibuf(sequence)]
5184	close $f
5185	}
5186	}
5187
5188	proc SequenceEditorBuild { parent } {
5189	global env sequence text_only
5190
5191	# initialize array sequence
5192	set sequence(run) 1
5193	set sequence(wait) 1
5194	set sequence(temp) 300.0
5195	set sequence(cmd) "NEXT"
5196	set sequence(file) IBUFFER.BUF
5197	set sequence(toplevel) [toplevel $parent]
5198
5199	if {!$text_only} {
5200
5201	set sequence(up) [image create bitmap -data {
5202	#define up_width 24
5203	#define up_height 24
5204	static unsigned char up_bits[] = {
5205	0x00, 0x18, 0x00, 0x00, 0x18, 0x00,
5206	0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00,
5207	0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00,
5208	0x00, 0xff, 0x00, 0x00, 0xff, 0x00,
5209	0x80, 0xff, 0x01, 0x80, 0xff, 0x01,
5210	0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03,
5211	0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07,
5212	0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f,
5213	0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f,
5214	0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f,
5215	0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f,
5216	0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
5217	}]
5218
5219	set sequence(down) [image create bitmap -data {
5220	#define down_width 24
5221	#define down_height 24
5222	static unsigned char down_bits[] = {
5223	0xff, 0xff, 0xff, 0xff, 0xff, 0xff,
5224	0xfe, 0xff, 0x7f, 0xfe, 0xff, 0x7f,
5225	0xfc, 0xff, 0x3f, 0xfc, 0xff, 0x3f,
5226	0xf8, 0xff, 0x1f, 0xf8, 0xff, 0x1f,
5227	0xf0, 0xff, 0x0f, 0xf0, 0xff, 0x0f,
5228	0xe0, 0xff, 0x07, 0xe0, 0xff, 0x07,
5229	0xc0, 0xff, 0x03, 0xc0, 0xff, 0x03,
5230	0x80, 0xff, 0x01, 0x80, 0xff, 0x01,
5231	0x00, 0xff, 0x00, 0x00, 0xff, 0x00,
5232	0x00, 0x7e, 0x00, 0x00, 0x7e, 0x00,
5233	0x00, 0x3c, 0x00, 0x00, 0x3c, 0x00,
5234	0x00, 0x18, 0x00, 0x00, 0x18, 0x00};
5235	}]
5236
5237	wm withdraw $sequence(toplevel)
5238
5239	}
5240
5241	set tf [frame $parent.top]
5242
5243	set sequence(list) [ScrolledListbox $tf.l -width 20 -height 8]
5244
5245	set f [frame $tf.f1]
5246	set frl [label $f.runlab -text " Run "]
5247	set ftl [label $f.templab -text " Temperature "]
5248	set fwl [label $f.waitlab -text " Wait "]
5249	set fcl [label $f.cmdlab -text " Command "]
5250	set fru [label $f.rununits -text "(Buffer) "]
5251	set ftu [label $f.tempunits -text "(K) "]
5252	set fwu [label $f.waitunits -text "(Min) "]
5253	set fcu [label $f.cmdunits -text " "]
5254	set fre $f.runentry
5255	if $text_only {
5256	ck_optionMenu $fre sequence(run) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 \
5257	16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
5258	} else {
5259	$tf.f1 configure -bd 2 -relief ridge
5260	tk_optionMenu $fre sequence(run) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 \
5261	16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
5262	}
5263	set fte [entry $f.tempentry -width 10 -textvariable sequence(temp)]
5264	set fwe [entry $f.waitentry -width 10 -textvariable sequence(wait)]
5265	set fce [entry $f.cmdentry -width 10 -textvariable sequence(cmd)]
5266	set fri [button $f.runbut -text Insert -command SequenceInsertRun]
5267	set fti [button $f.tempbut -text Insert -command SequenceInsertTemp]
5268	set fwi [button $f.waitbut -text Insert -command SequenceInsertWait]
5269	set fci [button $f.cmdbut -text Insert -command SequenceInsertCmd]
5270
5271	if $text_only {
5272	label $f.title -text "Sequence Edit"
5273	label $f.blank -text " "
5274	grid $f.title -sticky ew -columnspan 4
5275	grid $f.blank
5276	}
5277
5278	grid $frl $fru $fre $fri -sticky w
5279	grid $fre -sticky we
5280	grid $ftl $ftu $fte $fti -sticky w
5281	grid $fwl $fwu $fwe $fwi -sticky w
5282	grid $fcl $fcu $fce $fci -sticky w
5283
5284	set bf [frame $parent.bot]
5285	set fu [button $bf.up \
5286	-command SequenceRaiseCommand]
5287	set fl [button $bf.down \
5288	-command SequenceLowerCommand]
5289	set fd [button $bf.delete -text Delete -width 8 \
5290	-command SequenceDeleteElement]
5291	set fc [button $bf.clear -text Clear -width 8 \
5292	-command SequenceClear]
5293	set fa [button $bf.apply -text OK -width 8 \
5294	-command "SequenceWrite;SequenceEditorHide"]
5295	set fx [button $bf.dismiss -text Cancel -width 8 \
5296	-command SequenceEditorHide]
5297
5298	if $text_only {
5299	$bf.up configure -text " /\\ "
5300	$bf.down configure -text " \\/ "
5301	} else {
5302	wm protocol $parent WM_DELETE_WINDOW SequenceEditorHide
5303	$bf.up configure -image $sequence(up) -width 50
5304	$bf.down configure -image $sequence(down) -width 50
5305	}
5306
5307	pack $fu $fl $fd $fc $fa $fx -side left -expand true -fill x
5308	pack $tf.l $f -side left
5309	pack $tf $bf -side top
5310
5311	bind $sequence(toplevel) <Destroy> SequenceEditorHide
5312	return $sequence(toplevel)
5313	}
5314
5315	proc SequenceClear { } {
5316	global sequence
5317	$sequence(list) delete 0 end
5318	}
5319
5320	proc SequenceDeleteElement { } {
5321	global sequence
5322	set idx [$sequence(list) curselection]
5323	if {[string length $idx] == 0} {set idx end}
5324	$sequence(list) delete $idx
5325	}
5326
5327	proc SequenceInsertRun { } {
5328	global sequence mode
5329	#set cmd "run buffer $sequence(run)"
5330
5331	switch $mode {
5332	increment { set cmd RI }
5333	q { set cmd RQ }
5334	bragg { set cmd RB }
5335	trash { set cmd RT }
5336	}
5337
5338	append cmd $sequence(run)
5339	set idx [$sequence(list) curselection]
5340	if {[string length $idx] == 0} {set idx end}
5341	$sequence(list) insert $idx $cmd
5342	# this little goodie makes it easier to set up sequences of buffers IMHO
5343	incr sequence(run)
5344	if {$sequence(run) > 30} {set sequence(run) 1}
5345	}
5346
5347	proc SequenceInsertTemp { } {
5348	global sequence
5349	#set cmd "temperature set $sequence(temp)"
5350	set cmd "ST=$sequence(temp)"
5351	set idx [$sequence(list) curselection]
5352	if {[string length $idx] == 0} {set idx end}
5353	$sequence(list) insert $idx $cmd
5354	}
5355
5356	proc SequenceInsertWait { } {
5357	global sequence
5358	#set cmd "wait minutes $sequence(wait)"
5359	set cmd "HOLD=$sequence(wait)"
5360	set idx [$sequence(list) curselection]
5361	if {[string length $idx] == 0} {set idx end}
5362	$sequence(list) insert $idx $cmd
5363	}
5364
5365	proc SequenceInsertCmd { } {
5366	global sequence
5367	set cmd $sequence(cmd)
5368	set idx [$sequence(list) curselection]
5369	if {[string length $idx] == 0} {set idx end}
5370	$sequence(list) insert $idx $cmd
5371	}
5372
5373	proc SequenceEditorShow { } {
5374	global sequence text_only
5375	if $text_only {
5376	catch { destroy $sequence(toplevel) }
5377	SequenceEditorBuild .sequence
5378	SequenceRead
5379	place $sequence(toplevel) -relheight 1.0 -relwidth 1.0
5380	focus $sequence(toplevel)
5381	} else {
5382	SequenceRead
5383	# center the dialog in the middle of the main
5384	set x [expr [winfo x .] + [winfo width .]/2 - \
5385	[winfo reqwidth $sequence(toplevel)]/2 - [winfo vrootx .]]
5386	set y [expr [winfo y .] + [winfo height .]/2 - \
5387	[winfo reqheight $sequence(toplevel)]/2 - [winfo vrooty .]]
5388	wm geom $sequence(toplevel) +$x+$y
5389	wm transient $sequence(toplevel) .
5390	wm deiconify $sequence(toplevel)
5391	grab $sequence(toplevel)
5392	}
5393	}
5394
5395	proc SequenceEditorHide { } {
5396	global sequence text_only
5397	if $text_only {
5398	place forget $sequence(toplevel)
5399	focus .
5400	destroy $sequence(toplevel)
5401	# .l.list selection set 0 0
5402	} else {
5403	wm withdraw $sequence(toplevel)
5404	grab release $sequence(toplevel)
5405	}
5406	}
5407
5408	proc SequenceRaiseCommand { } {
5409	global sequence
5410	set c [$sequence(list) curselection]
5411	if {$c == 0 \|\| $c == ""} return
5412	set val [$sequence(list) get $c]
5413	$sequence(list) delete $c
5414	incr c -1
5415	$sequence(list) insert $c $val
5416	$sequence(list) selection set $c
5417	}
5418	proc SequenceLowerCommand { } {
5419	global sequence
5420	set c [$sequence(list) curselection]
5421	if {$c == [expr [$sequence(list) size]-1] \|\| $c == ""} return
5422	set val [$sequence(list) get $c]
5423	$sequence(list) delete $c
5424	incr c
5425	$sequence(list) insert $c $val
5426	$sequence(list) selection set $c
5427	}
5428
5429	#=Switch buffers===============================================================
5430
5431	proc SwitchBuf { which } {
5432	global mode changed
5433	switch $which {
5434	increment {
5435	.l.title configure -text \
5436	"# Comment I-Buf A2-beg A2-end A2-Inc A5-beg A5-end A5-Inc Monitor Temp Hold"\
5437	-font {-family courier -size 11}
5438	IBufReadFile ;# Make sure we get the latest data from disk
5439	IBufList
5440	notebook_display .e ibuf
5441	set mode $which
5442	set changed(ibufdisp) 0
5443	# this must be done after the resetting the changed flag
5444	# or IBufCalcBT1 changes are not noted
5445	IBufDisp 0
5446	}
5447	q {
5448	.l.title configure -text \
5449	"No Comment *Q-Buffer HC KC LC EC ES Monitor"
5450	QBufReadFile ;# Make sure we get the latest data from disk
5451	QBufList
5452	QBufDisp 0
5453	notebook_display .e qbuf
5454	set mode $which
5455	set changed(qbufdisp) 0
5456	}
5457	bragg {
5458	.l.title configure -text \
5459	"No Comment *B-Buffer HC KC LC EC ES Monitor"
5460	BBufReadFile ;# Make sure we get the latest data from disk
5461	BBufList
5462	BBufDisp 0
5463	notebook_display .e bbuf
5464	set mode $which
5465	set changed(bbufdisp) 0
5466	}
5467	trash {
5468	.l.title configure -text \
5469	"No Comment T-Buffer Ec-meV Es-xdE Ef-meV NPTS Monitor "
5470	TBufReadFile ;# Make sure we get the latest data from disk
5471	TBufList
5472	TBufDisp 0
5473	notebook_display .e tbuf
5474	set mode $which
5475	set changed(tbufdisp) 0
5476	}
5477	reflectivity {
5478	.l.title configure -text \
5479	"No Comment R-Buffer qz-beg qz-end qx-beg qx-end Monitor NPTS"
5480	RBufReadFile ;# Make sure we get the latest data from disk
5481	RBufList
5482	RBufDisp 0
5483	notebook_display .e rbuf
5484	set mode $which
5485	set changed(rbufdisp) 0
5486	}
5487	diffraction {
5488	.l.title configure -text \
5489	"No Comment D-Buffer A A-Beg A-Inc A-End Monitor NPTS"
5490	DBufReadFile ;# Make sure we get the latest data from disk
5491	DBufList
5492	DBufDisp 0
5493	notebook_display .e dbuf
5494	set mode $which
5495	set changed(dbufdisp) 0
5496	}
5497	}
5498	}
5499
5500	###############################################################################
5501	# GUI helper functions
5502	#
5503
5504	proc About { } {
5505	global text_only
5506	if $text_only {
5507	ck_dialog .about {About...} \
5508	"Prepare\nN.C. Maliszewskyj\n<nickm@nist.gov>" \
5509	OK
5510	} else {
5511	tk_dialog .about {About...} \
5512	"Prepare\nN.C. Maliszewskyj\n<nickm@nist.gov>" \
5513	info 0 OK
5514	}
5515	}
5516
5517	proc ScrolledListbox { parent args } {
5518	# Create listbox attached to scrollbars, pass through $args
5519	frame $parent
5520	eval {listbox $parent.list \
5521	-yscrollcommand [list $parent.sy set] } $args
5522	# Create scrollbar attached to the listbox
5523	scrollbar $parent.sy -orient vertical \
5524	-command [list $parent.list yview]
5525	pack $parent.sy -side right -fill y
5526	# pack to allow for resizing
5527	pack $parent.list -side left -fill both -expand true
5528	return $parent.list
5529	}
5530
5531	proc ScrolledLabelledListbox { parent {title ""} args } {
5532	global tcl_platform text_only
5533	set fontname fixed
5534	if [regexp {windows} $tcl_platform(platform)] {
5535	set fontname ansifixed
5536	}
5537
5538	# Create listbox attached to scrollbars, pass through $args
5539	frame $parent -class MonoSpc
5540	eval {listbox $parent.list \
5541	-yscrollcommand [list $parent.sy set] } $args
5542	# Create scrollbar attached to the listbox
5543	scrollbar $parent.sy -orient vertical \
5544	-command [list $parent.list yview]
5545	label $parent.title -text $title -anchor w
5546
5547	if {!$text_only} {
5548	$parent.list configure -font $fontname
5549	$parent.title configure -borderwidth 4 -font $fontname
5550	}
5551
5552	pack $parent.title -fill x
5553	pack $parent.sy -side right -fill y
5554	pack $parent.list -side left -fill both -expand true
5555	# pack to allow for resizing
5556
5557	# Figure out how to expand in main window
5558	return $parent.list
5559	}
5560
5561	proc fltrim { var { factor 1000 } } {
5562	set outvar [expr round($var * $factor)/ (1.0 * $factor)]
5563	return $outvar
5564	}
5565
5566	proc GetNewPrefix {prefix} {
5567	global text_only monrec
5568	set p .prefix
5569
5570	toplevel $p
5571
5572	if {!$text_only} {
5573	# center the dialog in the middle of the main
5574	set x [expr [winfo x .] + [winfo width .]/2 - \
5575	[winfo reqwidth $p]/2 - [winfo vrootx .]]
5576	set y [expr [winfo y .] + [winfo height .]/2 - \
5577	[winfo reqheight $p]/2 - [winfo vrooty .]]
5578	wm geom $p +$x+$y
5579	wm transient $p .
5580	wm deiconify $p
5581	# set the grab
5582	grab $p
5583	wm title $p "Fix File Name"
5584	}
5585
5586	label $p.title -anchor center \
5587	-text "Please modify the experiment prefix."
5588	label $p.title2 -anchor center \
5589	-text "\"$prefix\" is invalid."
5590	label $p.expl -text "The first five letters of the comment set the file name for the experiment."
5591	label $p.expl2 -text "You must use letters and or digits, but no other symbols or spaces."
5592	if {!$text_only} {
5593	$p.expl configure -font "Helvetica -12 italic" -wraplength 200
5594	$p.expl2 configure -font "Helvetica -12 italic" -wraplength 200
5595	}
5596	label $p.newlbl -text "New prefix: "
5597	entry $p.new -width 5 -textvariable monrec(newprefix)
5598	set monrec(newprefix) [string trim $prefix]
5599	button $p.ok -text Change -command {
5600	global text_only
5601	if $text_only {
5602	place forget .prefix
5603	focus .
5604	}
5605	destroy .prefix
5606	.l.list selection set 0 0
5607	}
5608	grid $p.title -columnspan 2 -sticky ew
5609	label $p.lineskip -text " "
5610	grid $p.lineskip
5611
5612	grid $p.title2 -columnspan 2 -sticky ew
5613	label $p.lineskip2 -text " "
5614	grid $p.lineskip2
5615
5616	grid $p.expl -columnspan 2
5617	grid $p.expl2 -columnspan 2
5618	label $p.lineskip3 -text " "
5619	grid $p.lineskip3
5620
5621	if $text_only {
5622	$p.new configure -width 8
5623	grid $p.newlbl -row 8 -column 0 -sticky e
5624	grid $p.new -row 8 -column 1 -sticky w
5625	} else {
5626	grid $p.newlbl $p.new -sticky e
5627	grid $p.new -sticky w
5628	}
5629	label $p.lineskip4 -text " "
5630	grid $p.lineskip4
5631
5632	grid $p.ok -columnspan 2
5633
5634	if $text_only {
5635	place $p -relheight 1.0 -relwidth 1.0
5636	focus $p
5637	}
5638	tkwait window $p
5639	return [string range "$monrec(newprefix) " 0 4]
5640	}
5641
5642	###############################################################################
5643	#
5644	#
5645	option add *Notebook.borderWidth 2 widgetDefault
5646	option add *Notebook.relief sunken widgetDefault
5647
5648	proc notebook_create { win } {
5649	global nbInfo
5650
5651	frame $win -class Notebook
5652
5653	pack propagate $win 0
5654
5655	set nbInfo($win-count) 0
5656	set nbInfo($win-pages) ""
5657	set nbInfo($win-current) ""
5658
5659	# Remember to bind to destroy method
5660	bind $win <Destroy> "notebook_destroy $win"
5661
5662	return $win
5663	}
5664
5665	proc notebook_destroy { win } {
5666	global nbInfo
5667
5668	foreach p [array names nbInfo] {
5669	if [regexp "^$win" $p] {
5670	unset nbInfo($p)
5671	}
5672	}
5673	}
5674
5675	proc notebook_page { win name } {
5676	global nbInfo
5677
5678	set page "$win.page[incr nbInfo($win-count)]"
5679	lappend nbInfo($win-pages) $page
5680	set nbInfo($win-page-$name) $page
5681
5682	frame $page
5683
5684	if {$nbInfo($win-count) == 1} {
5685	after idle [list notebook_display $win $name]
5686	}
5687
5688	return $page
5689	}
5690
5691	proc notebook_display {win name} {
5692	global nbInfo
5693
5694	set page ""
5695	if {[info exists nbInfo($win-page-$name)]} {
5696	set page $nbInfo($win-page-$name)
5697	} elseif {[winfo exists $win.page$name]} {
5698	set page $win.page$name
5699	}
5700	if {"" == $page} {
5701	error "bad notebook page \"$name\""
5702	}
5703
5704	# perform size calculation
5705	notebook_fix_size $win
5706	if {"" != $nbInfo($win-current)} {
5707	pack forget $nbInfo($win-current)
5708	}
5709	pack $page -expand yes -anchor nw
5710	set nbInfo($win-current) $page
5711	return $page
5712	}
5713
5714	proc notebook_fix_size { win } {
5715	global nbInfo text_only
5716
5717	update idletasks
5718
5719	set maxw 0
5720	set maxh 0
5721	foreach page $nbInfo($win-pages) {
5722	set w [winfo reqwidth $page]
5723	if {$w > $maxw} {set maxw $w}
5724
5725	set h [winfo reqheight $page]
5726	if {$h > $maxh} {set maxh $h}
5727	}
5728
5729	if $text_only {
5730	set bd 1
5731	} else {
5732	set bd [$win cget -borderwidth]
5733	}
5734	set maxw [expr $maxw + 2 * $bd]
5735	set maxh [expr $maxh + 2 * $bd]
5736	$win configure -width $maxw -height $maxh
5737	}
5738
5739	proc toggle_create { win boolvar {boolvals {OFF ON}}} {
5740	global tInfo
5741
5742	upvar $boolvar b
5743	if {[llength $boolvals] != 2} {
5744	return -code error "toggle_create: specify only two possible labels"
5745	}
5746
5747	if {$b} {
5748	set initvar [lindex $boolvals 1]
5749	} else {
5750	set initvar [lindex $boolvals 0]
5751	}
5752	set tInfo($win-var) $boolvar
5753	set tInfo($win-lab) $boolvals
5754	button $win -text $initvar -command "toggle_action $win"
5755
5756	bind $win <Destroy> "toggle_destroy $win"
5757
5758	return $win
5759	}
5760
5761	proc toggle_destroy { win } {
5762	global tInfo
5763	catch {unset tInfo($win-var)}
5764	catch {unset tInfo($win-lab)}
5765	}
5766
5767	proc toggle_action { win } {
5768	global tInfo
5769	upvar $tInfo($win-var) t
5770	if {$t} {
5771	$win configure -text [lindex $tInfo($win-lab) 0]
5772	set t 0
5773	} else {
5774	$win configure -text [lindex $tInfo($win-lab) 1]
5775	set t 1
5776	}
5777	return $t
5778	}
5779
5780	proc toggle_set { win } {
5781	global tInfo
5782	upvar #0 $tInfo($win-var) t
5783	if {$t} {
5784	$win configure -text [lindex $tInfo($win-lab) 0]
5785	} else {
5786	$win configure -text [lindex $tInfo($win-lab) 1]
5787	}
5788	return $t
5789	}
5790
5791	# Track changes to displayed buffers
5792	proc bufchanged { args } {
5793	global changed
5794	if {[llength $args] < 1} { return }
5795	set changed([lindex $args 0]) 1
5796	}
5797
5798	proc SetTkDefaultOptions {"basefont 14"} {
5799
5800	global font
5801	set font $basefont
5802
5803	set Opt(prio) 100
5804	set Opt(font) "Helvetica -$basefont"
5805	set Opt(bold_font) "Helvetica -$basefont bold"
5806	set Opt(menu_font) "Helvetica -$basefont bold"
5807	set Opt(italic_font) "Helvetica -$basefont bold italic"
5808	#set Opt(fixed_font) --courier-medium-r---14-------
5809	incr basefont -2
5810	set Opt(graph_font) "Helvetica -$basefont"
5811	set Opt(small_bold_font) "Helvetica -$basefont bold"
5812	set Opt(small_font) "Helvetica -$basefont"
5813	set Opt(coord_font) "Courier -$basefont bold"
5814
5815	option add *Font $Opt(bold_font) $Opt(prio)
5816	option add *font $Opt(bold_font) $Opt(prio)
5817	option add GraphFont $Opt(graph_font) $Opt(prio)
5818	option add *Graph.font $Opt(graph_font) $Opt(prio)
5819	option add *Canvas.font $Opt(bold_font) $Opt(prio)
5820	option add *Button.font $Opt(bold_font) $Opt(prio)
5821	option add *Menu.font $Opt(menu_font) $Opt(prio)
5822	option add *Menubutton.font $Opt(menu_font) $Opt(prio)
5823	option add *Label.font $Opt(bold_font) $Opt(prio)
5824	option add *Scale.font $Opt(italic_font) $Opt(prio)
5825	option add *TitleFrame.font $Opt(italic_font) $Opt(prio)
5826	option add *SmallFont.Label.font $Opt(small_bold_font) $Opt(prio)
5827	option add *SmallFont.Checkbutton.font $Opt(small_font) $Opt(prio)
5828	option add *SmallFont.Button.font $Opt(small_font) $Opt(prio)
5829	option add *Coord.Listbox.font $Opt(coord_font) $Opt(prio)
5830	option add *HistList.Listbox.font $Opt(coord_font) $Opt(prio)
5831	option add *MonoSpc.Label.font $Opt(coord_font) $Opt(prio)
5832	option add *MonoSpc.Listbox.font $Opt(coord_font) $Opt(prio)
5833
5834	set Opt(bg) lightgray
5835	set Opt(fg) black
5836
5837	set Opt(dark1_bg) gray86
5838	set Opt(dark1_fg) black
5839	#set Opt(dark2_bg) gray77
5840	#set Opt(dark2_fg) black
5841	set Opt(inactive_bg) gray77
5842	set Opt(inactive_fg) black
5843
5844	set Opt(light1_bg) gray92
5845
5846	set Opt(active_bg) $Opt(dark1_bg)
5847	set Opt(active_fg) $Opt(fg)
5848	set Opt(disabled_fg) gray55
5849
5850	set Opt(input_bg) gray95
5851	set Opt(output1_bg) $Opt(dark1_bg)
5852	set Opt(output2_bg) $Opt(bg)
5853
5854	set Opt(select_fg) black
5855	set Opt(select_bg) lightblue
5856
5857	set Opt(selector) yellow
5858
5859	option add *background $Opt(bg) 10
5860	option add *Background $Opt(bg) $Opt(prio)
5861	option add *background $Opt(bg) $Opt(prio)
5862	option add *Foreground $Opt(fg) $Opt(prio)
5863	option add *foreground $Opt(fg) $Opt(prio)
5864	option add *activeBackground $Opt(active_bg) $Opt(prio)
5865	option add *activeForeground $Opt(active_fg) $Opt(prio)
5866	option add *HighlightBackground $Opt(bg) $Opt(prio)
5867	option add *selectBackground $Opt(select_bg) $Opt(prio)
5868	option add *selectForeground $Opt(select_fg) $Opt(prio)
5869	option add *selectBorderWidth 0 $Opt(prio)
5870	option add *Menu.selectColor $Opt(selector) $Opt(prio)
5871	option add *Menubutton.padY 1p $Opt(prio)
5872	option add *Menubutton.activeBackground $Opt(select_bg) $Opt(prio)
5873	option add *Menubutton.background $Opt(light1_bg) $Opt(prio)
5874	option add *Button.activeBackground $Opt(select_bg) $Opt(prio)
5875	option add *Button.background $Opt(light1_bg) $Opt(prio)
5876	option add *Button.borderWidth 2 $Opt(prio)
5877	option add *Button.anchor c $Opt(prio)
5878	option add *Checkbutton.selectColor $Opt(selector) $Opt(prio)
5879	option add *Checkbutton.activeBackground $Opt(select_bg) $Opt(prio)
5880	option add *Radiobutton.selectColor $Opt(selector) $Opt(prio)
5881	option add *Radiobutton.activeBackground $Opt(select_bg) $Opt(prio)
5882	option add *Entry.relief sunken $Opt(prio)
5883	option add *Entry.background $Opt(input_bg) $Opt(prio)
5884	option add *Entry.foreground black $Opt(prio)
5885	option add *Entry.insertBackground black $Opt(prio)
5886	option add *Label.anchor w $Opt(prio)
5887	option add *Label.borderWidth 0 $Opt(prio)
5888	option add *Listbox.background $Opt(light1_bg) $Opt(prio)
5889	option add *Listbox.relief sunken $Opt(prio)
5890	option add *Notebook.borderWidth 2 widgetDefault
5891	option add *Notebook.relief sunken widgetDefault
5892	option add *Scale.foreground $Opt(fg) $Opt(prio)
5893	option add *Scale.activeForeground $Opt(bg) $Opt(prio)
5894	option add *Scale.background $Opt(bg) $Opt(prio)
5895	option add *Scale.sliderForeground $Opt(bg) $Opt(prio)
5896	option add *Scale.sliderBackground $Opt(light1_bg) $Opt(prio)
5897	option add *Scrollbar.background $Opt(bg) $Opt(prio)
5898	option add *Scrollbar.troughColor $Opt(light1_bg) $Opt(prio)
5899	option add *Scrollbar.relief sunken $Opt(prio)
5900	option add *Scrollbar.borderWidth 1 $Opt(prio)
5901	option add *Scrollbar.width 15 $Opt(prio)
5902	option add *Text.background $Opt(input_bg) $Opt(prio)
5903	option add *Text.relief sunken $Opt(prio)
5904	. config -background $Opt(bg)
5905	}
5906
5907	# recursive routine to set all
5908	proc ResizeFont {path} {
5909	foreach child [winfo children $path] {
5910	set childtype [winfo class $child]
5911	# class "FixedFont" should not be resized
5912	if {$childtype == "FixedFont"} continue
5913	set font [option get $child font $childtype]
5914	if {$font != ""} {
5915	catch {
5916	set curfont [$child cget -font]
5917	if {[string tolower [lindex $curfont 0]] == "symbol"} {
5918	$child configure -font "Symbol [lrange $font 1 end]"
5919	} else {
5920	$child configure -font $font
5921	}
5922	}
5923	}
5924	ResizeFont $child
5925	}
5926	}
5927
5928	#------------------------------------------------------------------------------
5929	# Message box code that centers the message box over the parent.
5930	# or along the edge, if too close,
5931	# but leave a border along +x & +y for reasons I don't remember
5932	# It also allows the button names to be defined using
5933	# -type $list -- where $list has a list of button names
5934	# larger messages are placed in a scrolled text widget
5935	# capitalization is now ignored for -default
5936	# The command returns the name button in all lower case letters
5937	# otherwise see tk_messageBox for a description
5938	#
5939	# This is a modification of tkMessageBox (msgbox.tcl v1.5)
5940	#
5941	proc MyMessageBox {args} {
5942	global tkPriv tcl_platform
5943
5944	set w tkPrivMsgBox
5945	upvar #0 $w data
5946
5947	#
5948	# The default value of the title is space (" ") not the empty string
5949	# because for some window managers, a
5950	# wm title .foo ""
5951	# causes the window title to be "foo" instead of the empty string.
5952	#
5953	set specs {
5954	{-default "" "" ""}
5955	{-icon "" "" "info"}
5956	{-message "" "" ""}
5957	{-parent "" "" .}
5958	{-title "" "" " "}
5959	{-type "" "" "ok"}
5960	{-helplink "" "" ""}
5961	}
5962
5963	tclParseConfigSpec $w $specs "" $args
5964
5965	if {[lsearch {info warning error question} $data(-icon)] == -1} {
5966	error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
5967	}
5968	if {![string compare $tcl_platform(platform) "macintosh"]} {
5969	switch -- $data(-icon) {
5970	"error" {set data(-icon) "stop"}
5971	"warning" {set data(-icon) "caution"}
5972	"info" {set data(-icon) "note"}
5973	}
5974	}
5975
5976	if {![winfo exists $data(-parent)]} {
5977	error "bad window path name \"$data(-parent)\""
5978	}
5979
5980	switch -- $data(-type) {
5981	abortretryignore {
5982	set buttons {
5983	{abort -width 6 -text Abort -under 0}
5984	{retry -width 6 -text Retry -under 0}
5985	{ignore -width 6 -text Ignore -under 0}
5986	}
5987	}
5988	ok {
5989	set buttons {
5990	{ok -width 6 -text OK -under 0}
5991	}
5992	if {![string compare $data(-default) ""]} {
5993	set data(-default) "ok"
5994	}
5995	}
5996	okcancel {
5997	set buttons {
5998	{ok -width 6 -text OK -under 0}
5999	{cancel -width 6 -text Cancel -under 0}
6000	}
6001	}
6002	retrycancel {
6003	set buttons {
6004	{retry -width 6 -text Retry -under 0}
6005	{cancel -width 6 -text Cancel -under 0}
6006	}
6007	}
6008	yesno {
6009	set buttons {
6010	{yes -width 6 -text Yes -under 0}
6011	{no -width 6 -text No -under 0}
6012	}
6013	}
6014	yesnocancel {
6015	set buttons {
6016	{yes -width 6 -text Yes -under 0}
6017	{no -width 6 -text No -under 0}
6018	{cancel -width 6 -text Cancel -under 0}
6019	}
6020	}
6021	default {
6022	# error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
6023	foreach item $data(-type) {
6024	lappend buttons [list [string tolower $item] -text $item -under 0]
6025	}
6026	}
6027	}
6028
6029	if {[string compare $data(-default) ""]} {
6030	set valid 0
6031	foreach btn $buttons {
6032	if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
6033	set valid 1
6034	break
6035	}
6036	}
6037	if {!$valid} {
6038	error "invalid default button \"$data(-default)\""
6039	}
6040	}
6041
6042	# 2. Set the dialog to be a child window of $parent
6043	#
6044	#
6045	if {[string compare $data(-parent) .]} {
6046	set w $data(-parent).__tk__messagebox
6047	} else {
6048	set w .__tk__messagebox
6049	}
6050
6051	# 3. Create the top-level window and divide it into top
6052	# and bottom parts.
6053
6054	catch {destroy $w}
6055	toplevel $w -class Dialog
6056	wm title $w $data(-title)
6057	wm iconname $w Dialog
6058	wm protocol $w WM_DELETE_WINDOW { }
6059	wm transient $w $data(-parent)
6060	if {![string compare $tcl_platform(platform) "macintosh"]} {
6061	unsupported1 style $w dBoxProc
6062	}
6063
6064	frame $w.bot
6065	pack $w.bot -side bottom -fill both
6066	frame $w.top
6067	pack $w.top -side top -fill both -expand 1
6068	if {$data(-helplink) != ""} {
6069	# frame $w.help
6070	# pack $w.help -side top -fill both
6071	pack [button $w.top.1 -text Help -bg yellow \
6072	-command "MakeWWWHelp $data(-helplink)"] \
6073	-side right -anchor ne
6074	bind $w <Key-F1> "MakeWWWHelp $data(-helplink)"
6075	}
6076	if {[string compare $tcl_platform(platform) "macintosh"]} {
6077	$w.bot configure -relief raised -bd 1
6078	$w.top configure -relief raised -bd 1
6079	}
6080
6081	# 4. Fill the top part with bitmap and message (use the option
6082	# database for -wraplength and -font so that they can be
6083	# overridden by the caller).
6084
6085	option add *Dialog.msg.wrapLength 6i widgetDefault
6086
6087	if {[string length $data(-message)] > 300} {
6088	if {![string compare $tcl_platform(platform) "macintosh"]} {
6089	option add *Dialog.msg.t.font system widgetDefault
6090	} else {
6091	option add *Dialog.msg.t.font {Times 18} widgetDefault
6092	}
6093	frame $w.msg
6094	grid [text $w.msg.t \
6095	-height 20 -width 55 -relief flat -wrap word \
6096	-yscrollcommand "$w.msg.rscr set" \
6097	] -row 1 -column 0 -sticky news
6098	grid [scrollbar $w.msg.rscr -command "$w.msg.t yview" \
6099	] -row 1 -column 1 -sticky ns
6100	# give extra space to the text box
6101	grid columnconfigure $w.msg 0 -weight 1
6102	grid rowconfigure $w.msg 1 -weight 1
6103	$w.msg.t insert end $data(-message)
6104	} else {
6105	if {![string compare $tcl_platform(platform) "macintosh"]} {
6106	option add *Dialog.msg.font system widgetDefault
6107	} else {
6108	option add *Dialog.msg.font {Times 18} widgetDefault
6109	}
6110	label $w.msg -justify left -text $data(-message)
6111	}
6112	pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
6113	if {[string compare $data(-icon) ""]} {
6114	label $w.bitmap -bitmap $data(-icon)
6115	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
6116	}
6117
6118	# 5. Create a row of buttons at the bottom of the dialog.
6119
6120	set i 0
6121	foreach but $buttons {
6122	set name [lindex $but 0]
6123	set opts [lrange $but 1 end]
6124	if {![llength $opts]} {
6125	# Capitalize the first letter of $name
6126	set capName [string toupper \
6127	[string index $name 0]][string range $name 1 end]
6128	set opts [list -text $capName]
6129	}
6130
6131	eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
6132
6133	if {![string compare $name [string tolower $data(-default)]]} {
6134	$w.$name configure -default active
6135	}
6136	pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
6137
6138	# create the binding for the key accelerator, based on the underline
6139	#
6140	set underIdx [$w.$name cget -under]
6141	if {$underIdx >= 0} {
6142	set key [string index [$w.$name cget -text] $underIdx]
6143	bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
6144	bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
6145	}
6146	incr i
6147	}
6148
6149	# 6. Create a binding for <Return> on the dialog if there is a
6150	# default button.
6151
6152	if {[string compare $data(-default) ""]} {
6153	bind $w <Return> [list tkButtonInvoke $w.[string tolower $data(-default)]]
6154	}
6155
6156	# 7. Withdraw the window, then update all the geometry information
6157	# so we know how big it wants to be, then center the window in the
6158	# display and de-iconify it.
6159
6160	wm withdraw $w
6161	update idletasks
6162	set wp $data(-parent)
6163	# center the new window in the middle of the parent
6164	set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
6165	[winfo reqwidth $w]/2 - [winfo vrootx $wp]]
6166	set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
6167	[winfo reqheight $w]/2 - [winfo vrooty $wp]]
6168	# make sure that we can see the entire window
6169	set xborder 10
6170	set yborder 25
6171	if {$x < 0} {set x 0}
6172	if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
6173	incr x [expr \
6174	[winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
6175	}
6176	if {$y < 0} {set y 0}
6177	if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
6178	incr y [expr \
6179	[winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
6180	}
6181	wm geom $w +$x+$y
6182	wm deiconify $w
6183
6184	# 8. Set a grab and claim the focus too.
6185
6186	catch {set oldFocus [focus]}
6187	catch {set oldGrab [grab current $w]}
6188	catch {
6189	grab $w
6190	if {[string compare $data(-default) ""]} {
6191	focus $w.[string tolower $data(-default)]
6192	} else {
6193	focus $w
6194	}
6195	}
6196
6197	# 9. Wait for the user to respond, then restore the focus and
6198	# return the index of the selected button. Restore the focus
6199	# before deleting the window, since otherwise the window manager
6200	# may take the focus away so we can't redirect it. Finally,
6201	# restore any grab that was in effect.
6202
6203	tkwait variable tkPriv(button)
6204	catch {focus $oldFocus}
6205	destroy $w
6206	catch {grab $oldGrab}
6207	return $tkPriv(button)
6208	}
6209
6210	###############################################################################
6211	# Build GUI
6212	#
6213
6214	proc GUIBuild { } {
6215	global config msgpane text_only
6216	if {!$text_only} {
6217	set cwd [pwd]
6218	wm title . "ICP Prepare - $cwd"
6219	set m [frame .mbar -relief raised -borderwidth 2]
6220	} else {
6221	set m [frame .mbar]
6222	}
6223	set mf [menubutton $m.file -width 6 -text File -underline 0 \
6224	-menu $m.file.menu]
6225	set mfm [menu $mf.menu]
6226	$mfm add command -label "About" -underline 0 -command About
6227	$mfm add command -label "Exit" -underline 1 -command "CheckBufChange; exit"
6228
6229	set mb [menubutton $m.buf -width 6 -text Buffer -underline 0 \
6230	-menu $m.buf.menu]
6231	set mbm [menu $mb.menu]
6232	$mbm add command -label "Increment" -command {SwitchBuf increment} \
6233	-state $config(ibuf_state)
6234	$mbm add command -label "Constant Q" -command {SwitchBuf q} \
6235	-state $config(qbuf_state)
6236	$mbm add command -label "Bragg" -command {SwitchBuf bragg} \
6237	-state $config(bbuf_state)
6238	$mbm add command -label "Trash" -command {SwitchBuf trash} \
6239	-state $config(tbuf_state)
6240	$mbm add command -label "Reflectivity" -command {SwitchBuf reflectivity} \
6241	-state $config(rbuf_state)
6242	$mbm add command -label "Diffraction" -command {SwitchBuf diffraction} \
6243	-state $config(dbuf_state)
6244
6245	set ms [menubutton $m.seq -width 8 -text Sequence -underline 0 \
6246	-menu $m.seq.menu]
6247	set msm [menu $ms.menu]
6248	$msm add command -label "Edit" -command {SequenceEditorShow}
6249
6250	set me [menubutton $m.edit -width 9 -text "Edit mode" -underline 0 \
6251	-menu $m.edit.mode]
6252	set mem [menu $m.edit.mode]
6253	foreach opt {0 1 2} lbl {Simple "Temp Control" Expert} {
6254	$mem add radiobutton -command "IBufEntryMod; TBufEntryMod; QBufEntryMod" \
6255	-label $lbl -value $opt -variable config(mode)
6256	}
6257
6258	set mc [menubutton $m.conf -width 12 -text Configuration -underline 0 \
6259	-menu $m.conf.menu]
6260	set mcm [menu $m.conf.menu]
6261	foreach opt $config(instr_list) {
6262	$mcm add radiobutton -command ConfigChange \
6263	-label $opt -value $opt -variable config(instr)
6264	}
6265
6266	label $m.cfg -textvariable config(instr)
6267	if {!$text_only} {
6268	$m.cfg configure -font "Helvetica -14 bold italic"
6269	pack $mf $mb $ms $me $mc -side left
6270	} else {
6271	pack $mf $mb $ms $me $mc -side left -ipadx 1
6272	}
6273	pack $m.cfg -side right
6274
6275	ScrolledLabelledListbox .l \
6276	"No Comment I-Buffer A4-beg A4-end Inc Monitor " \
6277	-height 6 -width 80
6278
6279	if {!$text_only} {
6280	# turn off selection export so raised selection stays on
6281	.l.list config -exportselection 0
6282	# looks better
6283	.l.list config -highlightthickness 0
6284	}
6285
6286	notebook_create .e
6287	set page [notebook_page .e ibuf ]
6288	IBufEntryCreate $page
6289	set page [notebook_page .e tbuf]
6290	TBufEntryCreate $page
6291	set page [notebook_page .e qbuf]
6292	QBufEntryCreate $page
6293	set page [notebook_page .e bbuf]
6294	BBufEntryCreate $page
6295	set page [notebook_page .e rbuf]
6296	RBufEntryCreate $page
6297	set page [notebook_page .e dbuf]
6298	DBufEntryCreate $page
6299	set page [notebook_page .e bufop]
6300	BufopEntryCreate $page
6301	set page [notebook_page .e evalbox]
6302	EvalEntryCreate $page
6303	set page [notebook_page .e msg ]
6304	set msgpane [label $page.label -text "Updating Buffer" ]
6305	button $page.dismiss -text "Dismiss" -command MsgHide
6306	pack $page.label -expand true -fill x
6307	pack $page.dismiss -side bottom
6308	set page [notebook_page .e blank]
6309	notebook_display .e blank
6310
6311	# Pack widgets
6312	frame .k
6313	button .k.f1 -text "Update: F1" -width 11 -command UpdateBuf
6314	button .k.f2 -text "BufOps: F2" -width 11 -command BufopShow
6315	if $text_only {
6316	label .k.keys -text \
6317	"(F10 & Ctrl-U = menu, Tab & Ctrl-N = next, Ctrl-P = prev)"
6318	}
6319
6320	pack $m -side top -fill x -anchor nw
6321	pack .k -side bottom -fill x
6322	pack .e -side bottom -fill x
6323	pack .l -side top -expand true -fill both
6324
6325
6326	if {!$text_only} {
6327	pack .k.f1 .k.f2 -side left
6328	} else {
6329	pack .k.f1 .k.f2 .k.keys -side left
6330	}
6331
6332	# Build additional dialogs
6333	MonRecDialogBuild
6334	SequenceEditorBuild .sequence
6335	AutomonBuild
6336
6337	# Set key bindings
6338	bind all <KeyPress-F1> UpdateBuf
6339	bind all <KeyPress-F2> BufopShow
6340	bind all <KeyPress-F4> EvalShow
6341
6342	if {!$text_only} {
6343	set xmax [expr [winfo screenwidth .]/2]
6344	set ymax [expr [winfo screenheight .]/2]
6345	set x [expr ($xmax - [winfo reqwidth .])/2]
6346	set y [expr ($ymax - [winfo reqheight .])/2]
6347	wm geom . +$x+$y
6348	wm protocol . WM_DELETE_WINDOW "CheckBufChange;exit"
6349	wm deiconify . ;# Show toplevel window
6350	wm protocol . WM_DELETE_WINDOW "CheckBufChange;exit"
6351	wm deiconify . ;# Show toplevel window
6352	if {$config(nsta) == 1} { wm geometry . 773x423+254+63 }
6353	update
6354	}
6355	}
6356
6357	#<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
6358	# Body of the script itself
6359	#
6360	# Check command line arguments
6361	if {[llength $argv] > 0} {
6362	set instr [string tolower [lindex $argv 0]]
6363	switch $instr {
6364	bt0 { set config(nsta) 0 }
6365	bt1 { set config(nsta) 1 }
6366	bt2 { set config(nsta) 2 }
6367	bt4 { set config(nsta) 4 }
6368	bt5 { set config(nsta) 5 }
6369	bt7 { set config(nsta) 7 }
6370	bt8 { set config(nsta) 8 }
6371	bt9 { set config(nsta) 9 }
6372	ng1 { set config(nsta) -1 }
6373	ng5 { set config(nsta) -5 }
6374	ng7 { set config(nsta) -7 }
6375	xr0 { set config(nsta) 0 }
6376	default {
6377	puts stderr "Instrument \"$instr\" not supported"
6378	exit
6379	}
6380	}
6381	}
6382
6383	ConfigInit ;# Initialize variables
6384	ConfigRead ;# Determine configuration
6385	ConfigCruft ;# Make instrument-specific customizations
6386
6387	IBufInit
6388	QBufInit
6389	BBufInit
6390	TBufInit
6391	RBufInit
6392	DBufInit
6393
6394	GUIBuild
6395
6396	# Last minute initializations
6397	#
6398	#
6399
6400	if {1 == $config(nsta)} {
6401	if $text_only {
6402	set config(mode) [ck_dialog .instr "Choose Edit Mode" \
6403	"Choose the buffer setup mode you will use" \
6404	"Simple" "Temperature Control" "Expert"]
6405	} else {
6406	set config(mode) [tk_dialog .instr "Choose Edit Mode" \
6407	"Choose the buffer setup mode you will use" \
6408	question $config(mode) "Simple" "Temperature\nControl" "Expert"]
6409	}
6410	}
6411
6412	IBufEntryMod
6413	TBufEntryMod
6414	QBufEntryMod
6415
6416	if {[file exists IBUFFER.BUF] && $config(ibuf_state) == "normal"} { IBufReadFile } else { IBufWriteFile }
6417	if {[file exists QBUFFER.BUF] && $config(qbuf_state) == "normal"} { QBufReadFile } else { QBufWriteFile }
6418	if {[file exists TBUFFER.BUF] && $config(tbuf_state) == "normal"} { TBufReadFile } else { TBufWriteFile }
6419	if {[file exists BBUFFER.BUF] && $config(bbuf_state) == "normal"} { BBufReadFile } else { BBufWriteFile }
6420	if {[file exists RBUFFER.BUF] && $config(rbuf_state) == "normal"} { RBufReadFile } else { RBufWriteFile }
6421	if {[file exists DBUFFER.BUF] && $config(dbuf_state) == "normal"} { DBufReadFile } else { DBufWriteFile }
6422
6423
6424	# Set up changed buffer traces -- for BT1 only
6425	if {$config(paranoid)} {
6426	trace variable ibufdisp w bufchanged
6427	trace variable qbufdisp w bufchanged
6428	trace variable tbufdisp w bufchanged
6429	trace variable bbufdisp w bufchanged
6430	trace variable rbufdisp w bufchanged
6431	trace variable dbufdisp w bufchanged
6432	}
6433
6434	# Set the default buffer type to increment for all instruments (for now)
6435	# Note: this command must be executed after the trace is set so that
6436	# changes to the 1st entry are tracked!
6437	SwitchBuf $config(default_buf)
6438
6439	# Add menu and emacs-style key bindings to move from field to field
6440
6441	if $text_only {
6442	bind all <Control-n> {focus [ck_focusNext %W]}
6443	bind all <Control-p> {focus [ck_focusPrev %W]}
6444	bind all <Control-f> {focus [ck_focusNext %W]}
6445	bind all <Control-b> {focus [ck_focusPrev %W]}
6446	bind all <Control-u> {focus .mbar.file}
6447	}
6448
6449	# Show current version if we're running from the wish prompt
6450	set version

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

Download in other formats:

Original Format