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

Last change on this file since 120 was 120, checked in by ajj, 15 years ago

Correcting error in naming of motors 3 and 4

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