source: sans/utils/bt5/prepare/prepare @ 209

Last change on this file since 209 was 141, checked in by ajj, 16 years ago

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