source: trunk/gsascmds.tcl @ 988

Last change on this file since 988 was 988, checked in by toby, 11 years ago

work more on validating svn server certificate

  • Property svn:keywords set to Author Date Revision Id
File size: 113.5 KB
Line 
1# $Id: gsascmds.tcl 988 2010-04-26 18:33:19Z toby $
2#------------------------------------------------------------------------------
3# display routines
4#------------------------------------------------------------------------------
5#       Message box code that centers the message box over the parent.
6#          or along the edge, if too close,
7#          but leave a border along +x & +y for reasons I don't remember
8#       It also allows the button names to be defined using
9#            -type $list  -- where $list has a list of button names
10#       larger messages are placed in a scrolled text widget
11#       capitalization is now ignored for -default
12#       The command returns the name button in all lower case letters
13#       otherwise see  tk_messageBox for a description
14#
15#       This is a modification of tkMessageBox (msgbox.tcl v1.5)
16#
17proc MyMessageBox {args} {
18    global tkPriv tcl_platform
19
20    set w tkPrivMsgBox
21    upvar #0 $w data
22
23    #
24    # The default value of the title is space (" ") not the empty string
25    # because for some window managers, a
26    #           wm title .foo ""
27    # causes the window title to be "foo" instead of the empty string.
28    #
29    set specs {
30        {-default "" "" ""}
31        {-icon "" "" "info"}
32        {-message "" "" ""}
33        {-parent "" "" .}
34        {-title "" "" " "}
35        {-type "" "" "ok"}
36        {-helplink "" "" ""}
37    }
38
39    tclParseConfigSpec $w $specs "" $args
40
41    if {[lsearch {info warning error question} $data(-icon)] == -1} {
42        error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
43    }
44    if {![string compare $tcl_platform(platform) "macintosh"]} {
45      switch -- $data(-icon) {
46          "error"     {set data(-icon) "stop"}
47          "warning"   {set data(-icon) "caution"}
48          "info"      {set data(-icon) "note"}
49        }
50    }
51
52    if {![winfo exists $data(-parent)]} {
53        error "bad window path name \"$data(-parent)\""
54    }
55
56    switch -- $data(-type) {
57        abortretryignore {
58            set buttons {
59                {abort  -width 6 -text Abort -under 0}
60                {retry  -width 6 -text Retry -under 0}
61                {ignore -width 6 -text Ignore -under 0}
62            }
63        }
64        ok {
65            set buttons {
66                {ok -width 6 -text OK -under 0}
67            }
68          if {![string compare $data(-default) ""]} {
69                set data(-default) "ok"
70            }
71        }
72        okcancel {
73            set buttons {
74                {ok     -width 6 -text OK     -under 0}
75                {cancel -width 6 -text Cancel -under 0}
76            }
77        }
78        retrycancel {
79            set buttons {
80                {retry  -width 6 -text Retry  -under 0}
81                {cancel -width 6 -text Cancel -under 0}
82            }
83        }
84        yesno {
85            set buttons {
86                {yes    -width 6 -text Yes -under 0}
87                {no     -width 6 -text No  -under 0}
88            }
89        }
90        yesnocancel {
91            set buttons {
92                {yes    -width 6 -text Yes -under 0}
93                {no     -width 6 -text No  -under 0}
94                {cancel -width 6 -text Cancel -under 0}
95            }
96        }
97        default {
98#           error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
99            foreach item $data(-type) {
100                lappend buttons [list [string tolower $item] -text $item -under 0]
101            }
102        }
103    }
104
105    if {[string compare $data(-default) ""]} {
106        set valid 0
107        foreach btn $buttons {
108            if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
109                set valid 1
110                break
111            }
112        }
113        if {!$valid} {
114            error "invalid default button \"$data(-default)\""
115        }
116    }
117
118    # 2. Set the dialog to be a child window of $parent
119    #
120    #
121    if {[string compare $data(-parent) .]} {
122        set w $data(-parent).__tk__messagebox
123    } else {
124        set w .__tk__messagebox
125    }
126
127    # 3. Create the top-level window and divide it into top
128    # and bottom parts.
129
130    catch {destroy $w}
131    toplevel $w -class Dialog
132    wm title $w $data(-title)
133    wm iconname $w Dialog
134    wm protocol $w WM_DELETE_WINDOW { }
135    # Make the message box transient if the parent is viewable.
136    if {[winfo viewable [winfo toplevel $data(-parent)]] } {
137        wm transient $w $data(-parent)
138    } 
139   
140    catch {
141        if {[string equal [tk windowingsystem] "classic"]
142        || [string equal [tk windowingsystem] "aqua"]} {
143            unsupported::MacWindowStyle style $w dBoxProc
144        }
145    }
146
147    frame $w.bot
148    pack $w.bot -side bottom -fill both
149    frame $w.top
150    pack $w.top -side top -fill both -expand 1
151    if {$data(-helplink) != ""} {
152#       frame $w.help
153#       pack $w.help -side top -fill both
154        pack [button $w.top.1 -text Help -bg yellow \
155                -command "MakeWWWHelp $data(-helplink)"] \
156                -side right -anchor ne
157        bind $w <Key-F1> "MakeWWWHelp $data(-helplink)"
158    }
159    if {[string compare $tcl_platform(platform) "macintosh"]} {
160        $w.bot configure -relief raised -bd 1
161        $w.top configure -relief raised -bd 1
162    }
163
164    # 4. Fill the top part with bitmap and message (use the option
165    # database for -wraplength and -font so that they can be
166    # overridden by the caller).
167
168    option add *Dialog.msg.wrapLength 6i widgetDefault
169
170    if {[string length $data(-message)] > 300} {
171        if {![string compare $tcl_platform(platform) "macintosh"]} {
172            option add *Dialog.msg.t.font system widgetDefault
173        } else {
174            option add *Dialog.msg.t.font {Times 18} widgetDefault
175        }
176        frame $w.msg
177        grid [text  $w.msg.t  \
178                -height 20 -width 55 -relief flat -wrap word \
179                -yscrollcommand "$w.msg.rscr set" \
180                ] -row 1 -column 0 -sticky news
181        grid [scrollbar $w.msg.rscr  -command "$w.msg.t yview" \
182                ] -row 1 -column 1 -sticky ns
183        # give extra space to the text box
184        grid columnconfigure $w.msg 0 -weight 1
185        grid rowconfigure $w.msg 1 -weight 1
186        $w.msg.t insert end $data(-message)
187    } else {
188        if {![string compare $tcl_platform(platform) "macintosh"]} {
189            option add *Dialog.msg.font system widgetDefault
190        } else {
191            option add *Dialog.msg.font {Times 18} widgetDefault
192        }
193        label $w.msg -justify left -text $data(-message)
194    }
195    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
196    if {[string compare $data(-icon) ""]} {
197        label $w.bitmap -bitmap $data(-icon)
198        pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
199    }
200
201    # 5. Create a row of buttons at the bottom of the dialog.
202
203    set i 0
204    foreach but $buttons {
205        set name [lindex $but 0]
206        set opts [lrange $but 1 end]
207      if {![llength $opts]} {
208            # Capitalize the first letter of $name
209          set capName [string toupper \
210                    [string index $name 0]][string range $name 1 end]
211            set opts [list -text $capName]
212        }
213
214      eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
215
216        if {![string compare $name [string tolower $data(-default)]]} {
217            $w.$name configure -default active
218        }
219      pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
220
221        # create the binding for the key accelerator, based on the underline
222        #
223        set underIdx [$w.$name cget -under]
224        if {$underIdx >= 0} {
225            set key [string index [$w.$name cget -text] $underIdx]
226          bind $w <Alt-[string tolower $key]>  [list $w.$name invoke]
227          bind $w <Alt-[string toupper $key]>  [list $w.$name invoke]
228        }
229        incr i
230    }
231
232    # 6. Create a binding for <Return> on the dialog if there is a
233    # default button.
234
235    if {[string compare $data(-default) ""]} {
236      bind $w <Return> [list $w.[string tolower $data(-default)] invoke]
237    }
238
239    # 7. Withdraw the window, then update all the geometry information
240    # so we know how big it wants to be, then center the window in the
241    # display and de-iconify it.
242
243    wm withdraw $w
244    update idletasks
245    set wp $data(-parent)
246    # center the new window in the middle of the parent
247    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
248            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
249    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
250            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
251    # make sure that we can see the entire window
252    set xborder 10
253    set yborder 25
254    if {$x < 0} {set x 0}
255    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
256        incr x [expr \
257                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
258    }
259    if {$y < 0} {set y 0}
260    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
261        incr y [expr \
262                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
263    }
264    wm geom $w +$x+$y
265    wm deiconify $w
266
267    # 8. Set a grab and claim the focus too.
268
269    catch {set oldFocus [focus]}
270    catch {set oldGrab [grab current $w]}
271    catch {
272        grab $w
273        if {[string compare $data(-default) ""]} {
274            focus $w.[string tolower $data(-default)]
275        } else {
276            focus $w
277        }
278    }
279
280    # 9. Wait for the user to respond, then restore the focus and
281    # return the index of the selected button.  Restore the focus
282    # before deleting the window, since otherwise the window manager
283    # may take the focus away so we can't redirect it.  Finally,
284    # restore any grab that was in effect.
285
286    tkwait variable tkPriv(button)
287    catch {focus $oldFocus}
288    destroy $w
289    catch {grab $oldGrab}
290    return $tkPriv(button)
291}
292
293# tell'em what is happening
294#    message    is a text message to display
295#    statusvar  is a variable name containing a message that gets updated
296#    parent     is the name of the parent window
297#    button     defines a button for the window. Element 0 in $button is the
298#               text for the button and Element 1 is the command to execute.
299proc pleasewait {{message {}} {statusvar {}} {parent .} {button ""}} {
300    catch {destroy .msg}
301    toplevel .msg
302    wm transient .msg [winfo toplevel .]
303    pack [frame .msg.f -bd 4 -relief groove] -padx 5 -pady 5
304    pack [message .msg.f.m -text "Please wait $message"] -side top
305    if {$statusvar != ""} {
306        pack [label .msg.f.status -textvariable $statusvar] -side top
307    }
308    if {$button != ""} {
309        pack [button .msg.f.button -text [lindex $button 0] \
310                -command [lindex $button 1]] -side top
311    }
312    wm withdraw .msg
313    update idletasks
314    # place the message on top of the parent window
315    set x [expr [winfo x $parent] + [winfo width $parent]/2 - \
316            [winfo reqwidth .msg]/2 - [winfo vrootx $parent]]
317    if {$x < 0} {set x 0}
318    set y [expr [winfo y $parent] + [winfo height $parent]/2 - \
319            [winfo reqheight .msg]/2 - [winfo vrooty $parent]]
320    if {$y < 0} {set y 0}
321    wm geom .msg +$x+$y
322    wm deiconify .msg
323    global makenew
324    set makenew(OldGrab) ""
325    set makenew(OldFocus) ""
326    # save focus & grab
327    catch {set makenew(OldFocus) [focus]}
328    catch {set makenew(OldGrab) [grab current .msg]}
329    catch {grab .msg}
330    update
331}
332
333# clear the message
334proc donewait {} {
335    global makenew
336    catch {destroy .msg}
337    # reset focus & grab
338    catch {
339        if {$makenew(OldFocus) != ""} {
340            focus $makenew(OldFocus)
341        }
342    }
343    catch {
344        if {$makenew(OldGrab) != ""} {
345            grab $makenew(OldGrab)
346        }
347    }
348}
349
350proc putontop {w "center 0"} {
351    # center window $w above its parent and make it stay on top
352    set wpt [winfo toplevel [set wp [winfo parent $w]]]
353    if {[winfo viewable $wpt]} {
354        wm transient $w $wpt
355    }
356    wm withdraw $w
357    update idletasks
358    if {$center} {
359        set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
360                - [winfo vrootx $wpt]}]
361        set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
362                - [winfo vrooty $wpt]}]
363    } else {
364        # center the new window in the middle of the parent
365        set x [expr [winfo x $wpt] + [winfo width $wpt]/2 - \
366                [winfo reqwidth $w]/2 - [winfo vrootx $wpt]]
367        if {$x < 0} {set x 0}
368        set xborder 10
369        if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
370            incr x [expr [winfo screenwidth $w] - \
371                    ($x+[winfo reqwidth $w] + $xborder)]
372        }
373        set y [expr [winfo y $wpt] + [winfo height $wpt]/2 - \
374                [winfo reqheight $w]/2 - [winfo vrooty $wpt]]
375        if {$y < 0} {set y 0}
376        set yborder 25
377        if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
378            incr y [expr [winfo screenheight $w] - \
379                    ($y+[winfo reqheight $w] + $yborder)]
380        }
381    }
382    wm geometry $w +$x+$y
383    wm deiconify $w
384
385    global makenew
386    # set grab & focus; use new approach for 8.3 & later
387    if {[info proc ::tk::SetFocusGrab] == ""} {
388        set makenew(OldGrab) ""
389        set makenew(OldFocus) ""
390        catch {set makenew(OldFocus) [focus]}
391        catch {set makenew(OldGrab) [grab current $w]}
392        catch {grab $w}
393    } else {
394        set makenew(OldGrab) $w
395        set makenew(OldFocus) $w
396        ::tk::SetFocusGrab $w $w
397    }
398}
399
400# restore focus after putontop has completed
401proc afterputontop {} {
402    global makenew
403    # reset focus & grab; use new approach for 8.3 & later
404    if {[info proc ::tk::SetFocusGrab] == ""} {
405        if {$makenew(OldFocus) != ""} {
406            catch {focus $makenew(OldFocus)}
407        }
408        if {$makenew(OldGrab) != ""} {
409            catch {grab $makenew(OldGrab)}
410        }
411    } else {
412        catch {::tk::RestoreFocusGrab $makenew(OldGrab) $makenew(OldFocus)}
413    }
414}
415
416proc ShowBigMessage {win labeltext msg "optionlist OK" "link {}" "err 0"} {
417    catch {destroy $win}
418    toplevel $win
419
420    pack [label $win.l1 -text $labeltext] -side top
421    if {$err} {$win.l1 config -fg red}
422    pack [frame $win.f1] -side top -expand yes -fill both
423    grid [text  $win.f1.t  \
424            -height 20 -width 55  -wrap none -font Courier \
425            -xscrollcommand "$win.f1.bscr set" \
426            -yscrollcommand "$win.f1.rscr set" \
427            ] -row 1 -column 0 -sticky news
428    grid [scrollbar $win.f1.bscr -orient horizontal \
429            -command "$win.f1.t xview" \
430            ] -row 2 -column 0 -sticky ew
431    grid [scrollbar $win.f1.rscr  -command "$win.f1.t yview" \
432            ] -row 1 -column 1 -sticky ns
433    # give extra space to the text box
434    grid columnconfigure $win.f1 0 -weight 1
435    grid rowconfigure $win.f1 1 -weight 1
436    $win.f1.t insert end $msg
437
438    global makenew
439    set makenew(result) 0
440    bind $win <Return> "destroy $win"
441    bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
442    bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
443    bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
444    bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
445    bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
446    bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
447    bind $win <KeyPress-Home> "$win.f1.t yview 0"
448    bind $win <KeyPress-End> "$win.f1.t yview end"
449    set i 0
450    foreach item $optionlist {
451        pack [button $win.q[incr i] \
452                -command "set makenew(result) $i; destroy $win" -text $item] -side left
453    }
454    if {$link != ""} {
455        pack [button $win.help -text Help -bg yellow \
456            -command "MakeWWWHelp $link"] \
457            -side right
458        bind $win <Key-F1> "MakeWWWHelp $link"
459    }
460    putontop $win
461    tkwait window $win
462
463    # fix grab...
464    afterputontop
465    return $makenew(result)
466}
467
468# place a window on a selected part of the screen
469# xfrac specifies the hozontal position with 0 to the left and 100 to the right
470# yfrac specifies the vertical position with 0 to the top and 100 to the bottom
471# loc chooses the part of the window to place at that location: N: upper, S: lower, W: left, E: right
472# use NSEW for center
473proc LocateWindow {win {xfrac 50} {yfrac 50} {loc c}} {
474    wm withdraw $win
475    set maxx [winfo screenwidth $win]
476    set maxy [winfo screenheight $win]
477    set reqx [winfo reqwidth $win]
478    set reqy [winfo reqheight $win]
479    set x [expr {$maxx*$xfrac/100.}]
480    set y [expr {$maxy*$yfrac/100.}]
481    if {[string match -nocase "*e*" $loc] && [string match -nocase "*w*" $loc]} {
482        # EW: center
483        set x [expr {$x - $reqx/2. }]
484    } elseif {[string match -nocase "*e*" $loc]} {
485        # right corner
486        set x [expr {$x - $reqx}]
487    } elseif {[string match -nocase "*w*" $loc]} {     
488        # left corner -- do nothing
489    } else {
490        # center
491        set x [expr {$x - $reqx/2. }]
492    }
493    if {[string match -nocase "*n*" $loc] && [string match -nocase "*s*" $loc]} {
494        # NS: center
495        set y [expr {$y - $reqy/2 }]
496    } elseif {[string match -nocase "*n*" $loc]} {
497        # upper corner -- do nothing
498    } elseif {[string match -nocase "*s*" $loc]} {
499        # lower corner
500        set y [expr {$y - $reqy}]
501    } else {
502        # center
503        set y [expr {$y - $reqy/2 }]
504    }
505    set x [expr {int($x + 0.5)}]
506    set y [expr {int($y + 0.5)}]
507    if {$x < 0} {set x 0}
508    if {$x > $maxx-$reqx} {set x [expr {$maxx-$reqx}]}
509    if {$y < 0} {set y 0}
510    if {$y > $maxy-$reqy} {set y [expr {$maxy-$reqy}]}
511    wm geom $win +$x+$y
512    wm deiconify $win
513}
514
515# get a value in a modal dialog
516proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
517    global expgui expmap
518    set w .global
519    catch {destroy $w}
520    toplevel $w -bg beige
521    bind $w <Key-F1> "MakeWWWHelp expguierr.html Input[lindex $what 0]"
522    wm title $w "Input $what"
523    set expgui(temp) {}
524    pack [frame $w.0 -bd 6 -relief groove -bg beige] \
525            -side top -expand yes -fill both
526    grid [label $w.0.a -text "Input a value for the $what" \
527            -bg beige] \
528            -row 0 -column 0 -columnspan 10
529    grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
530            -row 1 -column 0 
531
532    set expgui(temp) $initvalue
533    pack [frame $w.b -bg beige] -side top -fill x -expand yes
534    pack [button $w.b.2 -text Continue -command "destroy $w"] -side left
535    if $quit {
536        pack [button $w.b.3 -text Cancel \
537                -command "set expgui(temp) {}; destroy $w"] -side left
538    }
539    bind $w <Return> "destroy $w"
540    pack [button $w.b.help -text Help -bg yellow \
541            -command "MakeWWWHelp expguierr.html Input[lindex $what 0]"] \
542            -side right
543
544    # force the window to stay on top
545    putontop $w
546
547    focus $w.b.2
548    tkwait window $w
549    afterputontop
550
551    return $expgui(temp)
552}
553
554#------------------------------------------------------------------------------
555# profile/symmetry routines
556#------------------------------------------------------------------------------
557# profile terms
558array set expgui {
559    prof-T-names {"Von Dreele-Jorgensen-Windsor" \
560                      "David-Ikeda-Carpenter" "Exponential pseudo-Voigt" \
561                      "Exponential p-V+Stephens aniso strain" \
562                      "Exponential p-V+macro strain"
563    }
564    prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
565            rsca s1ec s2ec }
566    prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
567            gam-2 ptec stec difc difa zero }
568    prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
569            gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
570    prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
571            rstr rsta rsca eta}
572    prof-T-5 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
573            gam-2 gsf g1ec g2ec rstr rsta rsca D1 D2 D3 D4 D5 D6 }
574    prof-C-names {"Gaussian only" "Pseudo-Voigt" \
575                      "pseudo-Voigt/FCJ Asym" "p-V/FCJ+Stephens aniso strain" \
576                      "p-V/FCJ+macro strain"
577    }
578    prof-C-1 {GU GV GW asym F1 F2 }
579    prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
580            L11 L22 L33 L12 L13 L23 }
581    prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
582            L11 L22 L33 L12 L13 L23 }
583    prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta} 
584    prof-C-5 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
585            D1 D2 D3 D4 D5 D6 }
586    prof-E-names {Gaussian "Otto pseudo-Voigt"}
587    prof-E-1 {A B C ds cds}
588    prof-E-2 {A B C ds cds LX LY ptec stec}
589}
590
591# number of profile terms depends on the histogram type
592# the LAUE symmetry and the profile number
593proc GetProfileTerms {phase hist ptype} {
594    global expmap expgui
595    if {$hist == "C" || $hist == "T" || $hist == "E"} {
596        set htype $hist
597    } else {
598        set htype [string range $expmap(htype_$hist) 2 2]
599    }
600    # get the cached copy of the profile term labels, when possible
601    set lbls {}
602    catch {
603        set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
604    }
605    if {$lbls != ""} {return $lbls}
606
607    catch {set lbls $expgui(prof-$htype-$ptype)}
608    if {$lbls == ""} {return}
609    # add terms based on the Laue symmetry
610    if {($htype == "C" || $htype == "T") && $ptype == 4} {
611        set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
612        eval lappend lbls [Profile4Terms $laueaxis]
613    }
614    set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
615    return $lbls
616}
617
618proc Profile4Terms {laueaxis} {
619# GSAS Laue classes by number vs spacegrp labeling
620#   1    2    3    4     5      6     7       8     9      10     11     12   13  14
621# 1bar, 2/m, mmm, 4/m, 4/mmm, 3bar, 3bar m, 3bar, 3barm1, 3bar1m, 6/m, 6/mmm, m 3, m3m
622#                              R      R      H      H       H
623# (R=Rhombohedral setting; H=Hexagonal setting)
624    switch -exact $laueaxis {
625        1bar {return \
626                "S400 S040 S004 S220 S202 S022 S310 S103 S031 \
627                S130 S301 S013 S211 S121 S112"}
628        2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
629        2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
630        2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
631        mmm  {return "S400 S040 S004 S220 S202 S022"}
632        4/{return "S400 S004 S220 S202 S310"}
633        4/mmm {return "S400 S004 S220 S202"}
634        3barR     {return "S400 S220 S310 S301 S211"}
635        "3bar mR" {return "S400 S220 S310 S211"}
636        3bar    {return "S400 S004 S202 S310 S211"}
637        3barm1 {return "S400 S004 S202 S301"}
638        3bar1m  {return "S400 S004 S202 S211"}
639        6/m    {return "S400 S004 S202"}
640        6/mmm  {return "S400 S004 S202"}
641        "m 3"  {return "S400 S220"}
642        m3m    {return "S400 S220"}
643        default {return ""}
644    }
645}
646
647proc GetLaue {spg} {
648    global tcl_platform expgui
649    # check the space group
650    set fp [open spg.in w]
651    puts $fp "N"
652    puts $fp "N"
653    puts $fp $spg
654    puts $fp "Q"
655    close $fp
656    catch {
657        if {$tcl_platform(platform) == "windows"} {
658            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
659        } else {
660            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
661        }
662    }
663    set fp [open spg.out r]
664    set laue {}
665    set uniqueaxis {}
666    while {[gets $fp line] >= 0} {
667        regexp {Laue symmetry (.*)} $line junk laue
668        regexp {The unique axis is (.*)} $line junk uniqueaxis
669    }
670    close $fp
671    catch {file delete -force spg.in spg.out}
672    set laue [string trim $laue]
673    # add a R suffix for rhombohedral settings
674    if {[string range [string trim $spg] end end] == "R"} {
675        return "${laue}${uniqueaxis}R"
676    }
677    return "${laue}$uniqueaxis"
678}
679
680# set up to change the profile type for a series of histogram/phase entries
681# (histlist & phaselist should be lists of the same length)
682#
683proc ChangeProfileType {histlist phaselist} {
684    global expgui expmap
685    set w .profile
686    catch {destroy $w}
687    toplevel $w -bg beige
688    wm title $w "Change Profile Function"
689   
690    # all histogram/phases better be the same type, so we can just use the 1st
691    set hist [lindex $histlist 0]
692    set phase [lindex $phaselist 0]
693    set ptype [string trim [hapinfo $hist $phase proftype]]
694
695    # get list of allowed profile terms for the current histogram type
696    set i 1
697    while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
698        lappend lbllist $lbls
699        incr i
700    }
701    # labels for the current type
702    set i $ptype
703    set oldlbls [lindex $lbllist [incr i -1]]
704   
705    if {[llength $histlist] == 1} {
706        pack [label $w.a -bg beige \
707                -text "Change profile function for Histogram #$hist Phase #$phase" \
708                ] -side top
709    } else {
710        # make a list of histograms by phase
711        foreach h $histlist p $phaselist {
712            lappend phlist($p) $h
713        }
714        set num 0
715        pack [frame $w.a -bg beige] -side top
716        pack [label $w.a.$num -bg beige \
717                -text "Change profile function for:" \
718                ] -side top -anchor w
719        foreach i [lsort [array names phlist]] {
720            incr num
721            pack [label $w.a.$num -bg beige -text \
722                    "\tPhase #$i, Histograms [CompressList $phlist($i)]" \
723                    ] -side top -anchor w
724        }
725    }
726    pack [label $w.e1 \
727            -text "Current function is type $ptype." \
728            -bg beige] -side top -anchor w
729    pack [frame $w.e -bg beige] -side top -expand yes -fill both
730    pack [label $w.e.1 \
731            -text "Set function to type" \
732            -bg beige] -side left
733    set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
734    pack $w.e.2 -side left -anchor w
735
736    pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
737            -command "set expgui(newpeaktype) $ptype; \
738            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
739            -value 1 -text "Current value overrides"] -side right
740    pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
741            -command \
742            "set expgui(newpeaktype) $ptype; \
743            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
744            -value 0 -text "Default value overrides"] -side right
745
746    $w.e.2 config -bg beige
747    pack [frame $w.c -bg beige] -side top -expand yes -fill both
748    pack [frame $w.d -bg beige] -side top -expand yes -fill both
749    pack [button $w.d.2 -text Continue  \
750              -command "SaveChangeProfileType $w.c [list $histlist] [list $phaselist]; destroy $w"\
751            ] -side left
752    pack [button $w.d.3 -text Cancel \
753            -command "destroy $w"] -side left
754    pack [button $w.d.help -text Help -bg yellow \
755            -command "MakeWWWHelp expgui5.html ChangeType"] \
756            -side right
757    bind $w <Key-F1> "MakeWWWHelp expgui5.html ChangeType"
758    bind $w <Return> "destroy $w"
759
760    $menu delete 0 end
761    set i 0
762    foreach lbls $lbllist {
763        incr i
764        $menu add command -label $i -command \
765                "set expgui(newpeaktype) $i; \
766                FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
767    }
768    set expgui(newpeaktype) $ptype
769    FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
770
771    # force the window to stay on top
772    putontop $w
773    focus $w.e.2
774    tkwait window $w
775    afterputontop
776    sethistlist
777}
778
779# save the changes to the profile
780proc SaveChangeProfileType {w histlist phaselist} {
781    global expgui
782    foreach phase $phaselist hist $histlist {
783        hapinfo $hist $phase proftype set $expgui(newpeaktype)
784        RecordMacroEntry "hapinfo $hist $phase proftype set $expgui(newpeaktype)" 0
785        hapinfo $hist $phase profterms set $expgui(newProfileTerms)
786        RecordMacroEntry "hapinfo $hist $phase profterms set $expgui(newProfileTerms)" 0
787        for {set i 1} {$i <=  $expgui(newProfileTerms)} {incr i} {
788            hapinfo $hist $phase pterm$i set [$w.ent${i} get]
789            RecordMacroEntry "hapinfo $hist $phase pterm$i set [$w.ent${i} get]" 0
790            hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
791            RecordMacroEntry "hapinfo $hist $phase pref$i set $expgui(ProfRef$i)" 0
792        }
793        set i [expr 1+$expgui(newProfileTerms)]
794        hapinfo $hist $phase pcut set [$w.ent$i get]
795        RecordMacroEntry "hapinfo $hist $phase pcut set [$w.ent$i get]" 0
796        incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
797        RecordMacroEntry "incr expgui(changed)" 0
798    }
799}
800
801# file the contents of the "Change Profile Type" Menu
802proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
803    global expgui expmap
804    set ptype [string trim [hapinfo $hist $phase proftype]]
805    catch {unset oldval}
806    # loop through the old terms and set up an array of starting values
807    set num 0
808    foreach term $oldlbls {
809        incr num
810        set oldval($term) [hapinfo $hist $phase pterm$num]
811    }
812    set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
813
814    # is the new type the same as the current?
815    if {$ptype == $newtype} {
816        set nterms [hapinfo $hist $phase profterms]
817    } else {
818        set nterms [llength $lbls]
819    }
820    set expgui(newProfileTerms) $nterms
821    set expgui(CurrentProfileTerms) $nterms
822    # which default profile set matches the new type
823    set setnum {}
824    foreach j {" " 1 2 3 4 5 6 7 8 9} {
825        set i [profdefinfo $hist $j proftype]
826        if {$i == ""} continue
827        if {$i == $newtype} {
828            set setnum $j
829            break
830        }
831    }
832
833    eval destroy [winfo children $w]
834
835    set colstr 0
836    set row 2
837    set maxrow [expr $row + $nterms/2]
838    for { set num 1 } { $num <= $nterms + 1} { incr num } {
839        # get the default value (originally from the in .INS file)
840        set val {}
841        if {$setnum != ""} {
842            set val 0.0
843            catch {
844                set val [profdefinfo $hist $setnum pterm$num]
845                # pretty up the number
846                if {$val == 0.0} {
847                    set val 0.0
848                } elseif {abs($val) < 1e-2 || abs($val) > 1e6} {
849                    set val [format %.3e $val]
850                } elseif {abs($val) > 1e-2 && abs($val) < 10} {
851                    set val [format %.5f $val]
852                } elseif {abs($val) < 9999} {
853                    set val [format %.2f $val]
854                } elseif {abs($val) < 1e6} {
855                    set val [format %.0f $val]
856                }
857            }
858        }
859        # heading
860        if {$row == 2} {
861            set col $colstr
862            grid [label $w.h0${num} -text "lbl" -bg beige] \
863                -row $row -column $col
864            grid [label $w.h2${num} -text "ref" -bg beige] \
865                -row $row -column [incr col]
866            grid [label $w.h3${num} -text "next value" -bg beige] \
867                -row $row -column [incr col]
868            grid [label $w.h4${num} -text "default" -bg beige] \
869                -row $row -column [incr col]
870            grid [label $w.h5${num} -text "current" -bg beige] \
871                -row $row -column [incr col]
872        }
873        set col $colstr
874        incr row
875        set term {}
876        catch {set term [lindex $lbls [expr $num-1]]}
877        if {$term == ""} {set term $num}
878        if {$num == $nterms + 1} {
879            set term "Peak\nCutoff"
880            set val {}
881            if {$setnum != ""} {
882                set val 0.0
883                catch {set val [profdefinfo $hist $setnum pcut]}
884            }
885        }
886
887        grid [label $w.l${num} -text "$term" -bg beige] \
888                -row $row -column $col
889        grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
890                -bg beige -activebackground beige] -row $row -column [incr col]
891        grid [entry $w.ent${num} \
892                -width 12] -row $row -column [incr col]
893        if {$val != ""} {
894            grid [button $w.def${num} -text $val -command \
895                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
896                    ] -row $row -column [incr col] -sticky ew
897        } else {
898            grid [label $w.def${num} -text (none) \
899                    ] -row $row -column [incr col]
900        }
901        set curval {}
902        catch {
903            set curval [expr $oldval($term)]
904            # pretty up the number
905            if {$curval == 0.0} {
906                set curval 0.0
907            } elseif {abs($curval) < 1e-2 || abs($curval) > 1e6} {
908                set curval [format %.3e $curval]
909            } elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
910                set curval [format %.5f $curval]
911            } elseif {abs($curval) < 9999} {
912                set curval [format %.2f $curval]
913            } elseif {abs($curval) < 1e6} {
914                set curval [format %.0f $curval]
915            }
916            grid [button $w.cur${num} -text $curval -command  \
917                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
918                    ] -row $row -column [incr col] -sticky ew
919        }
920        # set default values for flag and value
921        set ref 0
922        if {$setnum != ""} {
923            catch {
924                if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
925            }
926        }
927        set expgui(ProfRef$num) $ref
928       
929        $w.ent${num} delete 0 end
930        if {!$expgui(DefaultPeakType) && $val != ""} {
931            $w.ent${num} insert end $val
932        } elseif {$curval != ""} {
933            $w.ent${num} insert end $curval
934        } elseif {$val != ""} {
935            $w.ent${num} insert end $val
936        } else {
937            $w.ent${num} insert end 0.0
938        }
939        if {$row > $maxrow} {
940            set row 2
941            incr colstr 5
942        }
943    }
944    if {$::tcl_platform(os) == "Darwin"} {
945        # on OS X force a window resize
946        wm geometry [winfo toplevel $w] {}
947    }
948}
949
950#------------------------------------------------------------------------------
951# WWW/help routines
952#------------------------------------------------------------------------------
953# browse a WWW page with URL. The URL may contain a #anchor
954# On UNIX assume netscape or mozilla is in the path or env(BROWSER) is loaded.
955# On Windows search the registry for a browser. Mac branch not tested.
956# This is taken from http://mini.net/cgi-bin/wikit/557.html with many thanks
957# to the contributers
958proc urlOpen {url} {
959    global env tcl_platform
960    if {$tcl_platform(os) == "Darwin"} {
961        # if this is an external URL or does not contain an anchor, take the
962        # easy approach
963        if {[string range $url 0 4] == "http:" || \
964                [string first "#" $url] == -1} {
965            if {![catch {exec open $url}]} {
966                return
967            }
968        }
969        # so sorry, have to use Internet Explorer
970        set url [file nativename $url]; # replace ~/ if present
971        if {[file pathtype $url] == "relative"} {
972            set url [file join [pwd] $url]
973        }
974        exec osascript -e "tell application \"Internet Explorer\"\rGetURL \"file://$url\"\rend tell"
975    } elseif {$tcl_platform(platform) == "unix"} {
976        set browserlist {}
977        if {[info exists env(BROWSER)]} {
978            set browserlist $env(BROWSER)
979        }
980        lappend browserlist netscape mozilla
981        foreach p $browserlist {
982            set progs [auto_execok $p]
983            if {[llength $progs]} {
984                if {[catch {exec $progs -remote openURL($url)}]} {
985                    # perhaps browser doesn't understand -remote flag
986                    if {[catch {exec $env(BROWSER) $url &} emsg]} {
987                        error "Error displaying $url in browser\n$emsg"
988                    }
989                }
990                return
991            }
992        }
993        MyMessageBox -parent . -title "No Browser" \
994            -message "Could not find a browser. Netscape & Mozilla not found. Define environment variable BROWSER to be full path name of browser." \
995            -icon warning
996    } elseif {$tcl_platform(platform) == "windows"} {
997        package require registry
998        # Look for the application under
999        # HKEY_CLASSES_ROOT
1000        set root HKEY_CLASSES_ROOT
1001       
1002        # Get the application key for HTML files
1003        set appKey [registry get $root\\.html ""]
1004       
1005        # Get the command for opening HTML files
1006        set appCmd [registry get \
1007                        $root\\$appKey\\shell\\open\\command ""]
1008
1009        # Substitute the HTML filename into the command for %1
1010        # or stick it on the end
1011        if {[string first %1 $appCmd] != -1} {
1012            regsub %1 $appCmd $url appCmd
1013        } else {
1014            append appCmd " " $url
1015        }
1016       
1017        # Double up the backslashes for eval (below)
1018        regsub -all {\\} $appCmd  {\\\\} appCmd
1019       
1020        # Invoke the command
1021        eval exec $appCmd &
1022    } elseif {$tcl_platform(platform) == "macintosh"} {
1023        # preOSX -- this is not used
1024        if {0 == [info exists env(BROWSER)]} {
1025            set env(BROWSER) "Browse the Internet"
1026        }
1027        if {[catch {
1028            AppleScript execute\
1029                "tell application \"$env(BROWSER)\"
1030                         open url \"$url\"
1031                     end tell
1032                "} emsg]
1033        } then {
1034            error "Error displaying $url in browser\n$emsg"
1035        }
1036    }
1037}
1038
1039proc NetHelp {file anchor localloc netloc} {
1040    # use the file on-line, if it exists
1041    if {[file exists [file join $localloc $file]]} {
1042        set url "[file join $localloc $file]"
1043    } else {
1044        set url "http://$netloc/$file"
1045    }
1046    catch {
1047        pleasewait "Starting web browser..."
1048        after 2000 donewait
1049    }
1050    if {$anchor != ""} {
1051        append url # $anchor
1052    }
1053    urlOpen $url
1054}
1055
1056proc MakeWWWHelp {"topic {}" "anchor {}"} {
1057    global expgui
1058    if {$topic == ""} {
1059        foreach item $expgui(notebookpagelist) {
1060            if {[lindex $item 0] == $expgui(pagenow)} {
1061                NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
1062                return
1063            }
1064        }
1065        # this should not happen
1066        NetHelp expgui.html "" $expgui(docdir) $expgui(website)
1067    } elseif {$topic == "menu"} {
1068        NetHelp expguic.html "" $expgui(docdir) $expgui(website)
1069    } else {
1070        NetHelp $topic $anchor $expgui(docdir) $expgui(website)
1071    }
1072}
1073
1074# show help information
1075proc showhelp {} {
1076    global expgui_helplist helpmsg
1077    set helpmsg {}
1078    set frm .help
1079    catch {destroy $frm}
1080    toplevel $frm
1081    wm title $frm "Help Summary"
1082    grid [label $frm.0 -text \
1083            "Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
1084        -column 0 -columnspan 4 -row 0
1085#    grid [message $frm.help -textvariable helpmsg -relief groove] \
1086#          -column 0 -columnspan 4 -row 2 -sticky nsew
1087    grid [text $frm.help -relief groove -bg beige -width 0\
1088            -height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
1089           -column 0 -columnspan 3 -row 2 -sticky nsew
1090    grid [scrollbar $frm.escroll -command "$frm.help yview"] \
1091            -column 4 -row 2 -sticky nsew
1092    grid rowconfig $frm 1 -weight 1 -minsize 50
1093    grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
1094    grid columnconfig $frm 0 -weight 1
1095    grid columnconfig $frm 2 -weight 1
1096    set lst [array names expgui_helplist]
1097    grid [listbox $frm.cmds -relief raised -bd 2 \
1098            -yscrollcommand "$frm.scroll set" \
1099            -height 8 -width 0 -exportselection 0 ] \
1100            -column 0 -row 1 -sticky nse
1101    grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
1102            -column 1 -row 1 -sticky nsew
1103    foreach item [lsort -dictionary $lst] {
1104        $frm.cmds insert end $item 
1105    }
1106    if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
1107    grid [button $frm.done -text Done -command "destroy $frm"] \
1108            -column 2 -row 1
1109#    bind $frm.cmds <ButtonRelease-1> \
1110#           "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
1111    bind $frm.cmds <ButtonRelease-1> \
1112            "+$frm.help config -state normal; $frm.help delete 0.0 end; \
1113             $frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
1114             $frm.help config -state disabled"
1115
1116    # get the size of the window and expand the message boxes to match
1117#    update
1118#    $frm.help config -width [winfo width $frm.help ]
1119}
1120
1121
1122#------------------------------------------------------------------------------
1123# utilities
1124#------------------------------------------------------------------------------
1125# run liveplot
1126proc liveplot {} {
1127    global expgui liveplot wishshell expmap
1128    set expnam [file root [file tail $expgui(expfile)]]
1129    # which histograms are ready for use?
1130    set validlist {}
1131    foreach ihist $expmap(powderlist) {
1132        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1133                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1134            lappend validlist $ihist
1135        }
1136    }
1137    if {[llength $validlist] == 0} {
1138        MyMessageBox -parent . -title "No Valid Histograms" \
1139                -message "No histograms are ready to plot. Run GENLES and try again" \
1140                -icon warning -helplink "expguierr.html NoValidHist"
1141        return
1142    }
1143    # use $liveplot(hst) if valid, the 1st entry otherwise
1144    if {[lsearch $validlist $liveplot(hst)] != -1} {
1145        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1146                $expnam $liveplot(hst) $liveplot(legend) &
1147    } else {
1148        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1149                $expnam [lindex $validlist 0] $liveplot(legend) &
1150    }
1151}
1152
1153# run lstview
1154proc lstview {} {
1155    global expgui wishshell
1156    set expnam [file root [file tail $expgui(expfile)]]
1157    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1158}
1159
1160# run widplt
1161proc widplt {"prog widplt"} {
1162    global expgui wishshell
1163    exec $wishshell [file join $expgui(scriptdir) $prog] \
1164            $expgui(expfile) &
1165}
1166
1167# run bkgedit
1168proc bkgedit {"hst {}"} {
1169    global expgui liveplot wishshell expmap
1170    set expnam [file root [file tail $expgui(expfile)]]
1171    if {$hst == ""} {
1172        # which histograms are ready for use?
1173        set validlist {}
1174        foreach ihist $expmap(powderlist) {
1175            if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1176                    [string range $expmap(htype_$ihist) 3 3] == "*"} {
1177                lappend validlist $ihist
1178            }
1179        }
1180        if {[llength $validlist] == 0} {
1181            MyMessageBox -parent . -title "No Valid Histograms" \
1182                    -message "No histograms are ready to plot. Run POWPREF and try again" \
1183                    -icon warning -helplink "expguierr.html NoValidHist"
1184            return
1185        }
1186        # use $liveplot(hst) if valid, the 1st entry otherwise
1187        if {[lsearch $validlist $liveplot(hst)] != -1} {
1188            set hst $liveplot(hst)
1189        } else {
1190            set hst [lindex $validlist 0]
1191        }
1192    }
1193    # Save the current exp file
1194    savearchiveexp
1195    CantRecordMacroEntry "bkgedit"
1196    # disable the file change monitor if we will reload the .EXP file automatically
1197    if {$expgui(autoexpload)} {set expgui(expModifiedLast) 0}
1198    if {$expgui(autoiconify)} {wm iconify .}
1199    exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1200            $expnam $hst $liveplot(legend)
1201    if {$expgui(autoiconify)} {wm deiconify .}
1202    # load the changed .EXP file automatically?
1203    if {$expgui(autoexpload)} {
1204        # load the revised exp file
1205        loadexp $expgui(expfile)
1206    } else {
1207        # check for changes in the .EXP file immediately
1208        whenidle
1209    }
1210}
1211
1212# run excledt
1213proc excledit {} {
1214    global expgui liveplot expmap
1215    set expnam [file root [file tail $expgui(expfile)]]
1216    # which histograms are ready for use?
1217    set validlist {}
1218    foreach ihist $expmap(powderlist) {
1219        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1220                [string range $expmap(htype_$ihist) 3 3] == "*" || \
1221                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1222            lappend validlist $ihist
1223        }
1224    }
1225    if {[llength $validlist] == 0} {
1226        MyMessageBox -parent . -title "No Valid Histograms" \
1227                -message "No histograms are ready to plot. Run POWPREF and try again" \
1228                -icon warning -helplink "expguierr.html NoValidHist"
1229        return
1230    }
1231    #if {$expgui(autoiconify)} {wm iconify .}
1232    StartExcl 
1233    #if {$expgui(autoiconify)} {wm deiconify .}
1234}
1235
1236# compute the composition for each phase and display in a dialog
1237proc composition {} {
1238    global expmap expgui
1239    set Z 1
1240    foreach phase $expmap(phaselist) type $expmap(phasetype) {
1241        if {$type == 4} continue
1242        ResetMultiplicities $phase {}
1243        catch {unset total}
1244        foreach atom $expmap(atomlist_$phase) {
1245            set type [atominfo $phase $atom type]
1246            set mult [atominfo $phase $atom mult]
1247            if [catch {set total($type)}] {
1248                set total($type) [expr \
1249                        $mult * [atominfo $phase $atom frac]]
1250            } else {
1251                set total($type) [expr $total($type) + \
1252                        $mult * [atominfo $phase $atom frac]]
1253            }
1254            if {$mult > $Z} {set Z $mult}
1255        }
1256        append text "\nPhase $phase\n"
1257        append text "  Unit cell contents\n"
1258        foreach type [lsort [array names total]] {
1259            append text "   $type[format %8.3f $total($type)]"
1260        }
1261        append text "\n\n"
1262       
1263        append text "  Asymmetric Unit contents (Z=$Z)\n"
1264        foreach type [lsort [array names total]] {
1265            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
1266        }
1267        append text "\n"
1268    }
1269   
1270    catch {destroy .comp}
1271    toplevel .comp -class MonoSpc
1272    bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1273    wm title .comp Composition
1274    pack [label .comp.results -text $text \
1275            -justify left] -side top
1276    pack [frame .comp.box]  -side top -expand y -fill x
1277    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1278
1279    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1280    pack [button .comp.box.2 -text "Save to $lstnam file" \
1281            -command "writelst [list $text] ; destroy .comp"] -side left
1282    pack [button .comp.box.help -text Help -bg yellow \
1283            -command "MakeWWWHelp expgui.html Composition"] \
1284            -side right
1285}
1286
1287# Delete History Records
1288proc DeleteHistoryRecords {{msg ""}} {
1289    global expgui
1290    set frm .history
1291    catch {destroy $frm}
1292    toplevel $frm
1293    bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1294    if {[string trim $msg] == ""} {
1295        set msg "There are [CountHistory] history records"
1296    }
1297    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1298    pack [label $frm.1.0 -text $msg] -side top
1299    pack [frame $frm.1.1] -side top
1300    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1301    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1302            ] -side left
1303    set expgui(historyKeep) 10
1304    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1305    set expgui(renumber) 1
1306    pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1307    pack [button $frm.2.help -text Help -bg yellow \
1308            -command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1309    pack [button $frm.2.4 -text Cancel \
1310            -command {destroy .history}] -side bottom
1311    pack [button $frm.2.3 -text OK \
1312            -command { 
1313        if ![catch {expr $expgui(historyKeep)}] {
1314            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1315            set expgui(changed) 1
1316            destroy .history
1317        }
1318    }] -side bottom
1319    bind $frm <Return> "$frm.2.3 invoke"
1320   
1321    # force the window to stay on top
1322    putontop $frm 
1323    focus $frm.2.3
1324    tkwait window $frm
1325    afterputontop
1326}
1327
1328proc archiveexp {} {
1329    global expgui tcl_platform
1330    # is there a file to archive?
1331    if {![file exists $expgui(expfile)]} return
1332    set expnam [file rootname $expgui(expfile)]
1333    # get the last archived version
1334    set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1335    if {$lastf == ""} {
1336        set num 01
1337    } else {
1338        regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1339        scan $num %x num
1340        if {$num >= 255} {
1341            set num FF
1342        } else {
1343            set num [string toupper [format %.2x [incr num]]]
1344        }
1345    }
1346    catch {
1347        set file $expnam.O$num
1348        file copy -force $expgui(expfile) $file
1349        set fp [open $expnam.LST a+]
1350        puts $fp "\n----------------------------------------------"
1351        puts $fp "     Archiving [file tail $expnam.EXP] as [file tail $file]"
1352        puts $fp "----------------------------------------------\n"
1353        close $fp
1354    } errmsg
1355    if {$errmsg != ""} {
1356        tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1357    }
1358}
1359
1360# save and optionally archive the expfile
1361proc savearchiveexp {} {
1362    global expgui expmap
1363    if {$expgui(expfile) == ""} {
1364        SaveAsFile
1365        return
1366    }
1367    if !$expgui(changed) return
1368    if {$expgui(archive)} archiveexp
1369    # add a history record
1370    exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds] -format {%D %T}]"
1371    # now save the file
1372    expwrite $expgui(expfile)
1373    # change the icon and assign an app to this .EXP file
1374    global tcl_platform
1375    if {$tcl_platform(os) == "Darwin" && $expgui(MacAssignApp)} {
1376        MacSetResourceFork $expgui(expfile)
1377    }
1378    set expgui(changed) 0
1379    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1380    set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1381    wm title . $expgui(expfile)
1382    set expgui(titleunchanged) 1
1383    # set convergence criterion
1384    InitLSvars
1385}
1386
1387#------------------------------------------------------------------------------
1388# GSAS interface routines
1389#------------------------------------------------------------------------------
1390# run a GSAS program that does not require an experiment file
1391proc runGSASprog {proglist "concurrent 1"} {
1392    # save call to Macro file
1393    RecordMacroEntry "runGSASprog [list $proglist] $concurrent" 0
1394    # if concurrent is 0, EXPGUI runs the GSAS program in background
1395    # -- this is not currently needed anywhere where the .EXP file is not.
1396    global expgui tcl_platform
1397    set cmd {}
1398    foreach prog $proglist {
1399        StartGRWND $prog
1400        if {$tcl_platform(platform) == "windows"} {
1401            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1402        } else {
1403            if {$cmd != ""} {append cmd "\;"}
1404            append cmd "[file join $expgui(gsasexe) $prog]"
1405        }
1406    }
1407    forknewterm $prog $cmd [expr !$concurrent] 1
1408}
1409
1410# dummy routine, overridden if needed
1411proc StartGRWND {prog} {
1412}
1413
1414# run a GSAS program that requires an experiment file for input/output
1415proc runGSASwEXP {proglist "concurrent 0"} {
1416    # save call to Macro file
1417    RecordMacroEntry "runGSASwEXP [list $proglist] $concurrent" 0
1418    # most programs that require the .EXP file change it and
1419    # cannot be run concurrently
1420    global expgui tcl_platform
1421    # Save the current exp file
1422    savearchiveexp
1423    # load the changed .EXP file automatically?
1424    if {$expgui(autoexpload)} {
1425        # disable the file changed monitor
1426        set expgui(expModifiedLast) 0
1427    }
1428    set cmd {}
1429    set expnam [file root [file tail $expgui(expfile)]]
1430    foreach prog $proglist {
1431        if {$prog == "powpref"} {
1432            set expgui(needpowpref) 0
1433            set expgui(needpowpref_why) ""
1434        } elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1435            set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1436            set ans [MyMessageBox -parent . -title "Run POWPREF" \
1437                    -message $msg -icon warning -type "Yes No" -default yes \
1438                    -helplink "expguierr.html RunPowpref"]
1439            if {$ans == "yes"} {
1440                set expgui(needpowpref) 0
1441                set expgui(needpowpref_why) ""
1442                if {$tcl_platform(platform) == "windows"} {
1443                    append cmd " \"$expgui(gsasexe)/powpref.exe $expnam \" "
1444                } else {
1445                    if {$cmd != ""} {append cmd "\;"}
1446                    append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1447                }
1448            }
1449        }
1450        StartGRWND $prog
1451        if {$tcl_platform(platform) == "windows"} {
1452            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1453        } elseif {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1454            append cmd " \" [file join $expgui(gsasexe) $prog] $expnam \" "
1455        } else {
1456            if {$cmd != ""} {append cmd "\;"}
1457            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1458        }
1459    }
1460    if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1461        set outfile ${expnam}_macout.LST
1462        runnoterm $cmd $outfile
1463    } else {
1464        forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1465    }
1466    # load the changed .EXP file automatically?
1467    if {$expgui(autoexpload)} {
1468        # load the revised exp file
1469        loadexp $expgui(expfile)
1470    }
1471    if {$expgui(MacroRunning)} {
1472        if {[file exists  abort_${expnam}_macro.flag]} {
1473            file delete abort_${expnam}_macro.flag
1474            error "User requested to abort the macro"
1475        }
1476        update idletasks
1477    }
1478}
1479
1480# write text to the .LST file
1481proc writelst {text} {
1482    global expgui
1483    set lstnam [file rootname $expgui(expfile)].LST
1484    set fp [open $lstnam a]
1485    puts $fp "\n-----------------------------------------------------------------"
1486    puts $fp $text
1487    puts $fp "-----------------------------------------------------------------\n"
1488    close $fp
1489}
1490
1491
1492# rename file current to suggested,
1493#   delete window if supplied
1494#   use parent, if supplied or .
1495proc RenameAsFile {current suggested "window {}" "parent {}"} {
1496    if {$parent == "" && $window != ""} {set parent $window}
1497    if {$parent == ""} {set parent .}
1498    set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1499    if {$newfile == ""} return
1500    if {[catch {
1501        file rename -force $current $newfile
1502    }]} {
1503        file copy -force $current $newfile
1504        file delete -force $current
1505    }
1506    if {$window != ""} {destroy $window}
1507}
1508
1509# optionally run disagl as a windowless process, w/results in a separate window
1510proc rundisagl {} {
1511    global expgui txtvw tcl_version tcl_platform
1512    if {$expgui(disaglSeparateBox)} {
1513        set root [file root $expgui(expfile)] 
1514        catch {file delete -force $root.tmp}
1515        if {[catch {file rename -force $root.LST $root.OLS}]} {
1516            file copy -force $root.LST $root.OLS
1517            file delete -force $root.OLS
1518        }
1519        # PSW reports this does not happen right away on windows
1520        set i 0
1521        while {$i < 10 && [file exists $root.LST]} {
1522            # debug code
1523            #catch {console show}
1524            #puts "try $i"
1525            # end debug code
1526            after 100
1527            incr i
1528        }
1529        if {[file exists $root.LST]} {
1530            # it was not possible to rename the file
1531            MyMessageBox -parent . -title "Rename Problem" \
1532                -message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1533                -icon warning -helplink "expguierr.html NoRename"
1534            return
1535        }
1536
1537        #run the program
1538        pleasewait "Running DISAGL"     
1539        # create an empty input file
1540        close [open disagl.inp w]
1541        catch {exec [file join $expgui(gsasexe) disagl] \
1542                [file tail $root] < disagl.inp > disagl.out}
1543        if {[catch {file rename -force $root.LST $root.tmp}]} {
1544            file copy -force $root.LST $root.tmp
1545            file delete -force $root.LST
1546        }
1547        catch {file delete -force disagl.inp disagl.out}
1548        if {[catch {file rename -force $root.OLS $root.LST}]} {
1549            file copy -force $root.OLS $root.LST
1550            file delete -force $root.OLS
1551        }
1552        donewait
1553        # open a new window
1554        catch {toplevel .disagl}
1555        eval destroy [winfo child .disagl]
1556        set txt .disagl.txt
1557        catch {eval grid forget [grid slaves .disagl]}
1558        text $txt -width 100 -wrap none \
1559                -yscrollcommand ".disagl.yscroll set" \
1560                -xscrollcommand ".disagl.xscroll set" 
1561        scrollbar .disagl.yscroll -command "$txt yview"
1562        scrollbar .disagl.xscroll -command "$txt xview" -orient horizontal
1563        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1564        grid $txt -column 0 -row 1 -sticky nsew
1565        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1566        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1567        grid columnconfig .disagl.f 2 -weight 1
1568        grid [button .disagl.f.close -text "Close & Delete" \
1569                -command "destroy .disagl; file delete $root.tmp"] \
1570                -column 3 -row 0 -sticky e
1571        grid [button .disagl.f.rename \
1572                -command "RenameAsFile $root.tmp $root.DIS .disagl" \
1573                -text "Close & Save as..."] \
1574                -column 4 -row 0 -sticky e
1575        # allow font changes on the fly
1576        if {$tcl_version >= 8.0} {
1577            $txt config -font $txtvw(font)
1578            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1579            grid .disagl.f.font -column 1 -row 0 -sticky w
1580            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1581            $fontbut delete 0 end
1582            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1583                $fontbut add command -label "Courier $f" -font "Courier $f"\
1584                        -command "set txtvw(font) \"Courier $f\"; \
1585                        $txt config -font \$txtvw(font)"
1586            }
1587        }
1588       
1589        grid columnconfigure .disagl 0 -weight 1
1590        grid rowconfigure .disagl 1 -weight 1
1591        wm title .disagl "DISAGL results $expgui(expfile)"
1592        wm iconname .disagl "DISAGL $root"
1593        set in [open $root.tmp r]
1594        $txt insert end [read $in]
1595        close $in
1596        bind all  {destroy .disagl}
1597        bind .disagl  "$txt yview scroll -1 page"
1598        bind .disagl  "$txt yview scroll 1 page"
1599        bind .disagl  "$txt xview scroll 1 unit"
1600        bind .disagl  "$txt xview scroll -1 unit"
1601        bind .disagl  "$txt yview scroll -1 unit"
1602        bind .disagl  "$txt yview scroll 1 unit"
1603        bind .disagl  "$txt yview 0"
1604        bind .disagl  "$txt yview end"
1605        # don't disable in Win as this prevents the highlighting of selected text
1606        if {$tcl_platform(platform) != "windows"} {
1607            $txt config -state disabled
1608        }
1609        # find the beginning of the disagl text
1610
1611        set pos 1.0
1612        set nph 0
1613        while {[set loc [$txt search "Program DISAGL Version" $pos end]] != ""} {
1614            set pos [expr {$loc + 1}]
1615            incr nph
1616        }
1617        #puts "Found $nph DISAGL run(s)"
1618        # count phases
1619        set l {}
1620        while {[set loc [$txt search "Lattice constants are" $pos end]] != ""} {
1621            lappend l $loc
1622            set pos [expr {$loc + 1}]
1623}
1624        catch {unset phaseloc}
1625       
1626        set j 0
1627        foreach pos $l {
1628            if {$j == 0} {
1629                set prev $pos
1630                incr j
1631                continue
1632            }
1633            set phaseloc($j) [list $prev $pos]
1634            incr j
1635        }
1636        set phaseloc($j) [list $pos end]
1637        if {$nph >= 1 && $j >= 2} {
1638            grid [menubutton .disagl.f.copy \
1639                      -menu .disagl.f.copy.menu \
1640                      -text "Copy phase..." -bd 2 -relief raised] \
1641                -column 2 -row 0 -sticky nse
1642            menu .disagl.f.copy.menu
1643            for {set i 1} {$i <= $j} {incr i} {
1644                .disagl.f.copy.menu add command \
1645                    -command "seldisaglphase $txt [list $phaseloc($i)]" \
1646                    -label "Copy phase $i to clipboard"
1647            }
1648        } elseif {$nph >= 1} {
1649            grid [button .disagl.f.copy \
1650                      -command "seldisaglphase $txt [list $phaseloc($j)]" \
1651                -text "Copy phase $j to clipboard"] \
1652                -column 2 -row 0 -sticky e
1653        }
1654    } else {
1655        runGSASwEXP disagl
1656    }
1657}
1658
1659proc seldisaglphase {txt phaselist} {
1660    # clear selection
1661    $txt tag remove sel 1.1 end
1662    eval $txt tag add sel $phaselist
1663    clipboard clear
1664    clipboard append "               |         Program DISAGL Version MacOSX        |\n"
1665    clipboard append [eval $txt get [$txt tag ranges sel]]
1666} 
1667#------------------------------------------------------------------------------
1668# file conversions
1669#------------------------------------------------------------------------------
1670proc convfile {} {
1671    global expgui
1672    set frm .file
1673    catch {destroy $frm}
1674    toplevel $frm
1675    wm title $frm "Convert File"
1676    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1677    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1678    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1679            -side left -fill y -expand yes
1680    pack [button $frmC.help -text Help -bg yellow \
1681            -command "MakeWWWHelp expgui.html ConvertWin"] -side top
1682    pack [button $frmC.q -text Cancel -command "destroy $frm"] -side bottom
1683    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1684            -side bottom
1685    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1686    winfilebox $frm
1687    bind $frm <Return> "ValidWinCnv $frm"
1688
1689    # force the window to stay on top
1690    putontop $frm
1691    focus $frmC.q 
1692    tkwait window $frm
1693    afterputontop
1694}
1695
1696# validate the files and make the conversion
1697proc ValidWinCnv {frm} {
1698    global expgui
1699    # change backslashes to something sensible
1700    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1701    # allow entry of D: for D:/ and D:TEST for d:/TEST
1702    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1703            [string first :/ $expgui(FileMenuCnvName)] == -1} {
1704        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1705    }
1706    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1707        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1708        ChooseWinCnv $frm
1709        return
1710    } elseif [file isdirectory \
1711            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1712        if {$expgui(FileMenuCnvName) != "."} {
1713            set expgui(FileMenuDir) \
1714                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1715        }
1716        ChooseWinCnv $frm
1717        return
1718    }
1719 
1720    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1721    if ![file exists $file] {
1722        MyMessageBox -parent $frm -title "Convert Error" \
1723                -message "File $file does not exist" -icon error
1724        return
1725    }
1726
1727    set tmpname "[file join [file dirname $file] tempfile.xxx]"
1728    set oldname "[file rootname $file].org"
1729    if [file exists $oldname] {
1730        set ans [MyMessageBox -parent . -title "Overwrite?" \
1731                -message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1732                -icon warning -type {Overwrite Cancel} -default Overwrite \
1733                -helplink "expguierr.html OverwriteCnv"]
1734        if {[string tolower $ans] == "cancel"} return
1735        catch {file delete $oldname}
1736    }
1737
1738    if [catch {
1739        set in [open $file r]
1740        set out [open $tmpname w]
1741        fconfigure $out -translation crlf -encoding ascii
1742        set len [gets $in line]
1743        if {$len > 160} {
1744            # this is a UNIX file. Hope there are no control characters
1745            set i 0
1746            set j 79
1747            while {$j < $len} {
1748                puts $out [string range $line $i $j]
1749                incr i 80
1750                incr j 80
1751            }
1752        } else {
1753            while {$len >= 0} {
1754                append line "                                        "
1755                append line "                                        "
1756                set line [string range $line 0 79]
1757                puts $out $line
1758                set len [gets $in line]
1759            }
1760        }
1761        close $in
1762        close $out
1763        file rename -force $file $oldname
1764        file rename -force $tmpname $file
1765    } errmsg] {
1766        MyMessageBox -parent $frm -title "Conversion error" \
1767                -message "Error in conversion:\n$errmsg" -icon warning
1768    } else {
1769        set ans [MyMessageBox -parent $frm -title "More?" \
1770                -message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1771                -type yesno -default no]
1772        if {$ans == "no"} {destroy $frm}
1773    }
1774}
1775
1776# create a file box
1777proc winfilebox {frm} {
1778    global expgui
1779    set bx $frm.1
1780    pack [frame $bx.top] -side top
1781    pack [label $bx.top.a -text "Directory" ] -side left
1782    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1783    pack $bx.top.d -side left
1784    set expgui(FileMenuDir) [pwd]
1785    # the icon below is from tk8.0/tkfbox.tcl
1786    set upfolder [image create bitmap -data {
1787#define updir_width 28
1788#define updir_height 16
1789static char updir_bits[] = {
1790   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1791   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1792   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1793   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1794   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1795   0xf0, 0xff, 0xff, 0x01};}]
1796
1797    pack [button $bx.top.b -image $upfolder \
1798            -command "updir; ChooseWinCnv $frm" ]
1799    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1800    listbox $bx.a.files -relief raised -bd 2 \
1801            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1802            -height 15 -width 0 -exportselection 0 
1803    listbox $bx.a.dates -relief raised -bd 2 \
1804            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1805            -height 15 -width 0 -takefocus 0 -exportselection 0 
1806    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1807    ChooseWinCnv $frm
1808    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1809    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1810    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1811    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1812    pack $bx.a.scroll -side left -fill y
1813    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1814    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1815}
1816
1817# set the box or file in the selection window
1818proc ReleaseWinCnv {frm} {
1819    global expgui
1820    set files $frm.1.a.files
1821    set dates $frm.1.a.dates
1822    set select [$files curselection]
1823    if {$select == ""} {
1824        set select [$dates curselection]
1825    }
1826    if {$select == ""} {
1827        set expgui(FileMenuCnvName) ""
1828    } else {
1829        set expgui(FileMenuCnvName) [string trim [$files get $select]]
1830    }
1831    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1832        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1833        ChooseWinCnv $frm
1834    } elseif [file isdirectory \
1835            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1836        if {$expgui(FileMenuCnvName) != "."} {
1837            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1838            ChooseWinCnv $frm
1839        }
1840    }
1841    return
1842}
1843
1844# select a file or directory -- called on double click
1845proc SelectWinCnv {frm} {
1846    global expgui
1847    set files $frm.1.a.files
1848    set dates $frm.1.a.dates
1849    set select [$files curselection]
1850    if {$select == ""} {
1851        set select [$dates curselection]
1852    }
1853    if {$select == ""} {
1854        set file .
1855    } else {
1856        set file [string trim [$files get $select]]
1857    }
1858    if {$file == "<Parent>"} {
1859        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1860        ChooseWinCnv $frm
1861    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1862        if {$file != "."} {
1863            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1864            ChooseWinCnv $frm
1865        }
1866    } else {
1867        set expgui(FileMenuCnvName) [file tail $file]
1868        ValidWinCnv $frm
1869    }
1870}
1871
1872# fill the files & dates & Directory selection box with current directory,
1873# also called when box is created to fill it
1874proc ChooseWinCnv {frm} {
1875    global expgui
1876    set files $frm.1.a.files
1877    set dates $frm.1.a.dates
1878    set expgui(FileMenuCnvName) {}
1879    $files delete 0 end
1880    $dates delete 0 end
1881    $files insert end {<Parent>}
1882    $dates insert end {(Directory)}
1883    set filelist [glob -nocomplain \
1884            [file join [set expgui(FileMenuDir)] *] ]
1885    foreach file [lsort -dictionary $filelist] {
1886        if {[file isdirectory $file]} {
1887            $files insert end [file tail $file]
1888            $dates insert end {(Directory)}
1889        }
1890    }
1891    foreach file [lsort -dictionary $filelist] {
1892        if {![file isdirectory $file]} {
1893            set modified [clock format [file mtime $file] -format "%T %D"]
1894            $files insert end [file tail $file]
1895            $dates insert end $modified
1896        }
1897    }
1898    $expgui(FileDirButtonMenu)  delete 0 end
1899    set list ""
1900    global tcl_version
1901    if {$tcl_version > 8.0} {
1902        catch {set list [string tolower [file volume]]}
1903    }
1904    set dir ""
1905    foreach subdir [file split [set expgui(FileMenuDir)]] {
1906        set dir [string tolower [file join $dir $subdir]]
1907        if {[lsearch $list $dir] == -1} {lappend list $dir}
1908    }
1909    foreach path $list {
1910        $expgui(FileDirButtonMenu) add command -label $path \
1911                -command "[list set expgui(FileMenuDir) $path]; \
1912                ChooseWinCnv $frm"
1913    }
1914    return
1915}
1916
1917#------------------------------------------------------------------------------
1918# set options for liveplot
1919proc liveplotopt {} {
1920    global liveplot expmap
1921    set frm .file
1922    catch {destroy $frm}
1923    toplevel $frm
1924    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1925    set last [lindex [lsort -integer $expmap(powderlist)] end]
1926    if {$last == ""} {set last 1}
1927    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
1928            -length  150 -orient horizontal -variable liveplot(hst)] -side top
1929    pack [checkbutton $frmA.2 -text {include plot legend}\
1930            -variable liveplot(legend)] -side top
1931    pack [button $frm.2 -text OK \
1932            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1933            ] -side top
1934    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1935   
1936    # force the window to stay on top
1937    putontop $frm 
1938    focus $frm.2
1939    tkwait window $frm
1940    afterputontop
1941}
1942
1943#------------------------------------------------------------------------------
1944# get an experiment file name
1945#------------------------------------------------------------------------------
1946proc getExpFileName {mode} {
1947    global expgui tcl_platform
1948    set frm .file
1949    catch {destroy $frm}
1950    toplevel $frm
1951    wm title $frm "Experiment file"
1952    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1953    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1954    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1955            -fill y -expand yes
1956    pack [button $frmC.help -text Help -bg yellow \
1957            -command "MakeWWWHelp expguierr.html open"] \
1958            -side top -anchor e
1959    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1960    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1961            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1962    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1963            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1964
1965    set expgui(includearchived) 0
1966    set expgui(FileInfoBox) $frmC.info
1967    if {$mode == "old"} {
1968        pack [checkbutton $frmC.ar -text "Include Archived Files" \
1969                -variable expgui(includearchived) \
1970                -command "ChooseExpFil $frmA"] -side top -pady 10
1971        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1972                -class SmallFont] \
1973                -side top -fill both -expand yes -pady 5
1974    } elseif {$mode != "new"} {
1975        # for initial read, don't access archived files
1976        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1977                -class SmallFont] \
1978                -side top -fill both -expand yes -pady 5
1979        set mode "old"
1980    }
1981    pack [button $frmC.b -text Read \
1982            -command "valid_exp_file $frmA $mode"] -side bottom
1983    if {$mode == "new"} {
1984        $frmC.b config -text Save
1985    }
1986    pack [button $frmC.q -text Cancel \
1987            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1988    bind $frm <Return> "$frmC.b invoke"
1989
1990    if {$mode == "new"} {
1991        pack [label $frmA.0 -text "Enter an experiment file to create"] \
1992                -side top -anchor center
1993    } else {
1994        pack [label $frmA.0 -text "Select an experiment file to read"] \
1995                -side top -anchor center
1996    }
1997    expfilebox $frmA $mode
1998    # force the window to stay on top
1999    putontop $frm
2000    focus $frmC.b
2001    tkwait window $frm
2002    afterputontop
2003    if {$expgui(FileMenuEXPNAM) == ""} return
2004    # is there a space in the EXP name?
2005    if {[string first " " [file tail $expgui(FileMenuEXPNAM)]] != -1} {
2006        update
2007        MyMessageBox -parent . -title "File Name Error" \
2008            -message "File name \"$expgui(FileMenuEXPNAM)\" is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
2009            -icon warning -type Continue -default continue
2010#               -helplink "expguierr.html OpenErr"
2011        return
2012    }
2013    if {[string first " " $expgui(FileMenuDir)] != -1} {
2014        update
2015        MyMessageBox -parent . -title "Good luck..." \
2016            -message "You are using a directory with a space in the name ([file dirname $expgui(FileMenuDir)]) -- You may encounter bugs in EXPGUI. Please e-mail them to Brian.Toby@ANL.gov so they can be fixed." \
2017            -icon warning -type Continue -default continue
2018#               -helplink "expguierr.html OpenErr"
2019    }
2020    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2021}
2022
2023# validation routine
2024proc valid_exp_file {frm mode} {
2025    global expgui tcl_platform
2026    # windows fixes
2027    if {$tcl_platform(platform) == "windows"} {
2028        # change backslashes to something sensible
2029        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
2030        # allow entry of D: for D:/ and D:TEST for d:/TEST
2031        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
2032                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
2033            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
2034        }
2035    }
2036    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2037        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2038        ChooseExpFil $frm
2039        return
2040    } elseif [file isdirectory \
2041            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
2042        if {$expgui(FileMenuEXPNAM) != "."} {
2043            set expgui(FileMenuDir) \
2044                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2045        }
2046        ChooseExpFil $frm
2047        return
2048    }
2049    # append a .EXP if not present
2050    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
2051        append expgui(FileMenuEXPNAM) ".EXP"
2052    }
2053    # is there a space in the name?
2054    if {[string first " " $expgui(FileMenuEXPNAM)] != -1} {
2055        MyMessageBox -parent . -title "File Name Error" \
2056                -message "File name $expgui(FileMenuEXPNAM) is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
2057                -icon warning -type Continue -default continue
2058#               -helplink "expguierr.html OpenErr"
2059        return
2060    }
2061    # check for archive files
2062    if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
2063            $mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
2064        destroy .file
2065        return
2066    } elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
2067        # check for files that end in something other than .EXP .exp or .Exp...
2068        MyMessageBox -parent . -title "File Open Error" \
2069                -message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
2070                -icon error
2071        return
2072    }
2073    # check on the file status
2074    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2075    if {$mode == "new" && [file exists $file]} {
2076        set ans [
2077        MyMessageBox -parent . -title "File Open Error" \
2078                -message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
2079                -icon question -type {"Select other" "Overwrite"} -default "select other" \
2080                -helplink "expguierr.html OverwriteErr"
2081        ]
2082        if {[string tolower $ans] == "overwrite"} {destroy .file}
2083        return
2084    }
2085    # if file does not exist in case provided, set the name to all
2086    # upper case letters, since that is the best choice.
2087    # if it does exist, read from it as is. For UNIX we will force uppercase later.
2088    if {![file exists $file]} {
2089        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
2090        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2091    }
2092    if {$mode == "old" && ![file exists $file]} {
2093        set ans [
2094        MyMessageBox -parent . -title "File Open Error" \
2095                -message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
2096                -icon question -type {"Select other" "Create"} -default "select other" \
2097                -helplink "expguierr.html OpenErr"
2098        ]
2099        if {[string tolower $ans] == "create"} {destroy .file}
2100        return
2101    }
2102    destroy .file
2103}
2104
2105proc updir {} {
2106    global expgui
2107    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
2108}
2109
2110# create a file box
2111proc expfilebox {bx mode} {
2112    global expgui
2113    pack [frame $bx.top] -side top
2114    pack [label $bx.top.a -text "Directory" ] -side left
2115    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
2116    pack $bx.top.d -side left
2117    set expgui(FileMenuDir) [pwd]
2118    # the icon below is from tk8.0/tkfbox.tcl
2119    set upfolder [image create bitmap -data {
2120#define updir_width 28
2121#define updir_height 16
2122static char updir_bits[] = {
2123   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
2124   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
2125   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
2126   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
2127   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
2128   0xf0, 0xff, 0xff, 0x01};}]
2129
2130    pack [button $bx.top.b -image $upfolder \
2131            -command "updir; ChooseExpFil $bx" ]
2132    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2133    listbox $bx.a.files -relief raised -bd 2 \
2134            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
2135            -height 15 -width 0 -exportselection 0 
2136    listbox $bx.a.dates -relief raised -bd 2 \
2137            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
2138            -height 15 -width 0 -takefocus 0 -exportselection 0 
2139    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2140    ChooseExpFil $bx
2141    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2142    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2143    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
2144    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
2145    pack $bx.a.scroll -side left -fill y
2146    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2147    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2148}
2149proc sync2boxesX {master slave scroll args} {
2150    $slave xview moveto [lindex [$master xview] 0]
2151    eval $scroll set $args
2152}
2153proc move2boxesX {boxlist args} {
2154    foreach listbox $boxlist { 
2155        eval $listbox xview $args
2156    }
2157}
2158proc sync2boxesY {master slave scroll args} {
2159    $slave yview moveto [lindex [$master yview] 0]
2160    eval $scroll set $args
2161}
2162proc move2boxesY {boxlist args} {
2163    foreach listbox $boxlist { 
2164        eval $listbox yview $args
2165    }
2166}
2167
2168# creates a table that is scrollable in both x and y, use ResizeScrollTable
2169# to set sizes after gridding the boxes
2170proc MakeScrollTable {box} {
2171    grid [label $box.0] -column 0 -row 0
2172    grid [set tbox [canvas $box.top \
2173            -scrollregion {0 0 10 10} \
2174            -xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
2175            -width 10 -height 10]] \
2176            -sticky sew -row 0 -column 1
2177    grid [set sbox [canvas $box.side \
2178            -scrollregion {0 0 10 10} \
2179            -yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
2180            -width 10 -height 10]] \
2181            -sticky nes -row 1 -column 0
2182    grid [set bbox [canvas $box.can \
2183            -scrollregion {0 0 10 10} \
2184            -yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
2185            -xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
2186            -width 200 -height 200 -bg lightgrey]] \
2187            -sticky news -row 1 -column 1
2188    grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2189            -command "move2boxesX \" $box.can $box.top \" "]] \
2190            -sticky ew -row 2 -column 1
2191    grid [set sybox [scrollbar $box.yscroll \
2192            -command "move2boxesY \" $box.can $box.side \" "]] \
2193            -sticky ns -row 1 -column 2
2194    frame $tbox.f -bd 0
2195    $tbox create window 0 0 -anchor nw  -window $tbox.f
2196    frame $bbox.f -bd 2
2197    $bbox create window 0 0 -anchor nw  -window $bbox.f
2198    frame $sbox.f -bd 2 -relief raised
2199    $sbox create window 0 0 -anchor nw  -window $sbox.f
2200    grid columnconfig $box 1 -weight 1
2201    grid rowconfig $box 1 -weight 1
2202    return [list  $tbox.f  $bbox.f $sbox.f $box.0]
2203}
2204
2205proc ResizeScrollTable {box} {
2206    update idletasks
2207    for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2208        set x1 [lindex [grid bbox $box.can.f $i 0] 2]
2209        set x2 [lindex [grid bbox $box.top.f $i 0] 2]
2210        if {$x2 > $x1} {set x1 $x2}
2211        grid columnconfigure $box.top.f $i -minsize $x1
2212        grid columnconfigure $box.can.f $i -minsize $x1
2213    }
2214    for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2215        set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2216        set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2217        if {$x2 > $x1} {set x1 $x2}
2218        grid rowconfigure $box.can.f $i -minsize $x1
2219        grid rowconfigure $box.side.f $i -minsize $x1
2220    }
2221    update idletasks
2222    set sizes [grid bbox $box.can.f]
2223    $box.can config -scrollregion $sizes
2224    $box.side config -scrollregion $sizes
2225    $box.top config -scrollregion $sizes
2226    $box.top config -height [lindex [grid bbox $box.top.f] 3]
2227    $box.side config -width [lindex [grid bbox $box.side.f] 2]
2228}
2229proc ExpandScrollTable {box} {
2230    # set height & width of central box
2231    $box.can config -width \
2232            [expr [winfo width [winfo toplevel $box]] \
2233            - [winfo width $box.side] - [winfo width $box.yscroll]-20]
2234    $box.can config -height \
2235            [expr [winfo height [winfo toplevel $box]] \
2236            - [winfo height $box.top] - [winfo height $box.scroll]-25]
2237}
2238
2239
2240# support routine for SetHistUseFlags
2241proc InitHistUseFlags {} {
2242    global expmap expgui
2243    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2244#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2245            set expgui(useflag_$i) [histinfo $i use]
2246#       }
2247    }
2248}
2249
2250# show all Powder histograms; set use/do not use flags
2251proc SetHistUseFlags {} {
2252    set box .test
2253    catch {toplevel $box}
2254    eval destroy [winfo children $box]
2255    grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2256    grid [frame $box.a] -row 1 -column 0 -columnspan 2
2257    grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2258    grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2259    grid columnconfig $box 0 -weight 1
2260    grid columnconfig $box 1 -weight 1
2261    foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2262    $cbox config -text "Use\nFlag"
2263    [winfo parent $bbox] config -height 250 -width 400
2264    global expmap expgui
2265    set px 5
2266    set row -1
2267    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2268        if {[string range $expmap(htype_$i) 2 2] == "T"} {
2269            set det [format %8.2f [histinfo $i tofangle]]
2270        } elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2271            set det [format %8.5f [histinfo $i lam1]]
2272        } elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2273            set det [format %8.2f [histinfo $i lam1]]
2274        } else {
2275            set det {}
2276        }
2277        incr row
2278#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2279            grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0 
2280            set expgui(useflag_$i) [histinfo $i use]
2281#       }
2282        grid [label $bbox.0$i \
2283                -text [string range $expmap(htype_$i) 0 3] \
2284                ] -row $row -column 0 -padx $px
2285        grid [label $bbox.1$i -text [histinfo $i bank] \
2286                ] -row $row -column 1 -padx $px
2287        grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2288        grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2289                ] -row $row -column 3 -padx $px -sticky ew
2290    }
2291    grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2292    grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2293    grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2294    grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2295    ResizeScrollTable $box.a
2296    InitHistUseFlags
2297    putontop $box
2298    tkwait window $box
2299    afterputontop
2300    set prevchages $expgui(changed)
2301    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2302#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2303            if {$expgui(useflag_$i) != [histinfo $i use]} {
2304                histinfo $i use set $expgui(useflag_$i)
2305                RecordMacroEntry "histinfo $i use set $expgui(useflag_$i)" 0
2306                incr expgui(changed)
2307                RecordMacroEntry "incr expgui(changed)" 0
2308            }
2309#       }
2310    }
2311    if {$prevchages != $expgui(changed)} {
2312        set msg "You have changed [expr $expgui(changed)-$prevchages] "
2313        append msg "histogram flag(s). You must run POWPREF "
2314        append msg "to include/remove these histograms. Do you want to "
2315        append msg "run POWPREF?"
2316        set ans [MyMessageBox -parent . -message $msg \
2317                -title "Process changes?"\
2318                -helplink "expguierr.html ProcessUse" \
2319                -default {Run POWPREF} \
2320                -type {{Run POWPREF} Skip}]
2321       
2322        if {$ans == "skip"} {
2323            # save and reload the experiment file
2324            savearchiveexp
2325            loadexp $expgui(expfile)
2326        } else {
2327            # run powpref and force a reload
2328            set saveautoload $expgui(autoexpload)
2329            set expgui(autoexpload) 1
2330            runGSASwEXP powpref
2331            set expgui(autoexpload) $saveautoload
2332        }
2333    }
2334}
2335
2336# set the box or file in the selection window
2337proc ReleaseExpFil {frm} {
2338    global expgui
2339    set files $frm.a.files
2340    set dates $frm.a.dates
2341    set select [$files curselection]
2342    if {$select == ""} {
2343        set select [$dates curselection]
2344    }
2345    if {$select == ""} {
2346        set expgui(FileMenuEXPNAM) ""
2347    } else {
2348        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2349        after idle UpdateInfoBox
2350    }
2351    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2352        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2353        ChooseExpFil $frm
2354    } elseif [file isdirectory \
2355            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2356        if {$expgui(FileMenuEXPNAM) != "."} {
2357            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2358            ChooseExpFil $frm
2359        }
2360    }
2361    return
2362}
2363proc UpdateInfoBox {} {
2364    global expgui
2365    if {![winfo exists $expgui(FileInfoBox)]} return
2366    eval destroy [winfo children $expgui(FileInfoBox)]
2367    set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2368    if [file isdirectory $file] return
2369    if [file exists $file] {
2370        pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2371                -side top
2372        catch {
2373            set fp [open $file r]
2374            global testline
2375            set testline [read $fp]
2376            close $fp
2377            update
2378            regexp {GNLS  RUN on (.*) +Total.*run *([0-9]+) } \
2379                    $testline a last cycles
2380            pack [label $expgui(FileInfoBox).2 -justify left \
2381                    -text "last GENLES run:\n  $last\n  total cycles: $cycles"] \
2382                -side top -anchor w
2383            regexp {REFN GDNFT.*= *([0-9]*\.[0-9]*) +for *([0-9]+) variables} \
2384                    $testline a chi2 vars
2385            pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
2386                    -side top -anchor w
2387            pack [label $expgui(FileInfoBox).3.a -justify left \
2388                    -text "c" -font symbol] \
2389                    -side left -anchor w
2390            pack [label $expgui(FileInfoBox).3.b -justify left \
2391                    -text "2: $chi2, $vars vars"] \
2392                    -side top -anchor w
2393            # check first 9 histograms
2394            set lbl "h  Rwp     R(F2)"
2395            set n 0
2396            foreach k {1 2 3 4 5 6 7 8 9} {
2397                set key "HST  $k"
2398                append key { RPOWD +([0-9]*\.[0-9]*) }
2399                set i [regexp $key $testline a Rwp]
2400                set key "HST  $k"
2401                append key { R-FAC +[0-9]+ +([0-9]*\.[0-9]*) }
2402                set j [regexp $key $testline a Rb]
2403                if {$i || $j} {
2404                    incr n
2405                    append lbl "\n$k  "
2406                    if {$i} {
2407                        append lbl [string range $Rwp 0 5]
2408                    } else {
2409                        append lbl "    "
2410                    }
2411                }
2412                if {$j} {
2413                    append lbl " [string range $Rb 0 5]"
2414                }
2415                # stick 1st 3 entries in box
2416                if {$n >= 3} break
2417            }
2418            pack [label $expgui(FileInfoBox).4 -justify left \
2419                    -text $lbl] \
2420                    -side top -anchor w     
2421        }
2422    }
2423}
2424
2425# select a file or directory -- called on double click
2426proc SelectExpFil {frm mode} {
2427    global expgui
2428    set files $frm.a.files
2429    set dates $frm.a.dates
2430    set select [$files curselection]
2431    if {$select == ""} {
2432        set select [$dates curselection]
2433    }
2434    if {$select == ""} {
2435        set file .
2436    } else {
2437        set file [string trim [$files get $select]]
2438    }
2439    if {$file == "<Parent>"} {
2440        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2441        ChooseExpFil $frm
2442    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2443        if {$file != "."} {
2444            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2445            ChooseExpFil $frm
2446        }
2447    } else {
2448        set expgui(FileMenuEXPNAM) [file tail $file]
2449        valid_exp_file $frm $mode
2450    }
2451}
2452
2453# fill the files & dates & Directory selection box with current directory,
2454# also called when box is created to fill it
2455proc ChooseExpFil {frm} {
2456    global expgui
2457    set files $frm.a.files
2458    set dates $frm.a.dates
2459    set expgui(FileMenuEXPNAM) {}
2460    $files delete 0 end
2461    $dates delete 0 end
2462    $files insert end {<Parent>}
2463    $dates insert end {(Directory)}
2464    set filelist [glob -nocomplain \
2465            [file join [set expgui(FileMenuDir)] *] ]
2466    foreach file [lsort -dictionary $filelist] {
2467        if {[file isdirectory $file]} {
2468            $files insert end [file tail $file]
2469            $dates insert end {(Directory)}
2470        }
2471    }
2472    set pairlist {}
2473    foreach file [lsort -dictionary $filelist] {
2474        if {![file isdirectory $file]  && \
2475                [string toupper [file extension $file]] == ".EXP"} {
2476            set modified [file mtime $file]
2477            lappend pairlist [list $file $modified]
2478        } elseif {![file isdirectory $file] && $expgui(includearchived) && \
2479                [string match {*.O[0-9A-F][0-9A-F]} $file]} {
2480            set modified [file mtime $file]
2481            lappend pairlist [list $file $modified]
2482        }
2483    }
2484    if {$expgui(filesort) == 0} {
2485        foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
2486            set file [lindex $pair 0]
2487            set modified [clock format [lindex $pair 1] -format "%T %D"]
2488            $files insert end [file tail $file]
2489            $dates insert end $modified
2490        }
2491    } else {
2492        foreach pair [lsort -dictionary -index 0 $pairlist] {
2493            set file [lindex $pair 0]
2494            set modified [clock format [lindex $pair 1] -format "%T %D"]
2495            $files insert end [file tail $file]
2496            $dates insert end $modified
2497        }
2498    }
2499    $expgui(FileDirButtonMenu)  delete 0 end
2500    set list ""
2501    global tcl_platform tcl_version
2502    if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2503        catch {set list [string tolower [file volume]]}
2504    }
2505    set dir ""
2506    foreach subdir [file split [set expgui(FileMenuDir)]] {
2507        set dir [file join $dir $subdir]
2508        if {$tcl_platform(platform) == "windows"} {
2509            set dir [string tolower $dir]
2510            if {[lsearch $list $dir] == -1} {lappend list $dir}
2511        } else {
2512            lappend list $dir
2513        }
2514    }
2515    foreach path $list {
2516        $expgui(FileDirButtonMenu) add command -label $path \
2517                -command "[list set expgui(FileMenuDir) $path]; \
2518                ChooseExpFil $frm"
2519    }
2520    # highlight the current experiment -- if present
2521    for {set i 0} {$i < [$files size]} {incr i} {
2522        set file [$files get $i]
2523        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2524            $files selection set $i
2525        }
2526    }
2527    return
2528}
2529
2530
2531#------------------------------------------------------------------------------
2532# platform-specific definitions
2533if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2534    # windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2535    # DOS box synchronously, so we create a "lock" file that is deleted
2536    # at the end of the DOS run so we can tell when the run is done.
2537    # We create a window to force the deleting of the file so that if
2538    # the DOS process crashes, the user can continue anyway.
2539    #
2540    # procedure to check if the lock file is still there (Win-9x/me only)
2541    proc checklockfile {file window} {
2542        if [file exists $file] {
2543            after 500 checklockfile $file $window
2544        } else {
2545            catch {destroy $window}
2546        }
2547    }
2548    # this procedure starts the GRWND program, if needed for program $prog
2549    proc StartGRWND {prog} {
2550        global expgui
2551        if {!$expgui(autoGRWND)} return
2552        # at some point we might want to have a real list
2553        if {$prog != "genles" && $prog != "powpref"} {
2554            # get a list of running jobs
2555            exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
2556            set fp [open tlist.tlist r]
2557            set text [read $fp]
2558            close $fp
2559            file delete -force tlist.tlist
2560            # if GRWND.EXE is not currently running, start it
2561            if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
2562                exec [file join $expgui(gsasexe) grwnd.exe] &
2563                # give grwnd a 1 second head start
2564                after 1000
2565            }
2566        }
2567    }
2568    # this creates a DOS box to run a program in
2569    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2570        global env expgui
2571        # Windows environment variables
2572        set env(GSAS) [file nativename $expgui(gsasdir)]
2573        # PGPLOT_FONT is needed by PGPLOT
2574        set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
2575        # this is the number of lines/page in the .LST (etc.) file
2576        set env(LENPAGE) 60
2577        set pwd [file nativename [pwd]]
2578       
2579        # check the .EXP path -- can DOS use it?
2580        if {[string first // [pwd]] != -1} {
2581            MyMessageBox -parent . -title "Invalid Path" \
2582                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2583                    -icon error -type ok -default ok \
2584                    -helplink "expgui_Win_readme.html NetPath"
2585            return
2586        }
2587        if {[info command winutils::shell] == "" && \
2588                [info command winexec] == ""} {
2589            MyMessageBox -parent . -title "Setup error" \
2590                -message {Error -- Use "Neither WINEXEC not WINTILS were found. Can't do anything!"} \
2591                -icon error -type darn -default darn \
2592                -helplink "expgui_Win_readme.html Winexec"
2593            return
2594        }
2595        # loop over multiple commands
2596        foreach cmd $command {
2597            # simulate the wait with a lock file
2598            if {$wait} {
2599                if {$expgui(autoiconify)} {wm iconify .}
2600                # create a blank lock file and a message window
2601                close [open expgui.lck w]
2602                toplevel .lock
2603                grid [button .lock.0 -text Help -bg yellow \
2604                        -command "MakeWWWHelp expguierr.html lock"] \
2605                        -column 1 -row 0
2606                grid [label .lock.1 \
2607                        -text "Please wait while the GSAS program finishes."] \
2608                        -column 0 -row 0
2609                grid [label .lock.2 -text \
2610                        "In case a problem occurs, close the DOS box"] \
2611                        -column 0 -columnspan 2 -row 1
2612                grid [label .lock.3 -text \
2613                        "and press the \"Continue\" button (below)"] \
2614                        -column 0 -columnspan 2 -row 2
2615                grid [button .lock.b -text "Continue" \
2616                        -command "destroy .lock; wm deiconify ."] \
2617                        -column 0 -columnspan 2 -row 3
2618                putontop .lock
2619                update
2620                checklockfile expgui.lck .lock
2621            }
2622
2623            # pause is hard coded in the GSASTCL.BAT file
2624            if {$expgui(execprompt)} {
2625                set script gsastcl.bat
2626            } else {
2627                set script gsasnowt.bat
2628            }
2629
2630            # replace the forward slashes with backward
2631            regsub -all / $cmd \\ cmd
2632            if {[info command winutils::shell] != ""} {
2633                winutils::shell [file join $expgui(scriptdir) $script] $cmd
2634            } else {
2635                winexec -d [file nativename [pwd]] \
2636                    [file join $expgui(scriptdir) $script] $cmd
2637            }
2638            if {$expgui(MacroRunning)} {
2639                update 
2640                update idletasks
2641            }
2642            if {$wait} {
2643                tkwait window .lock
2644                file delete -force expgui.lck
2645            }
2646        }
2647        if {$expgui(autoiconify) && $wait} {wm deiconify .}
2648        # check for changes in the .EXP file immediately
2649        whenidle
2650    }
2651} elseif {$tcl_platform(platform) == "windows"} {
2652    # now for Windows-NT, where we can run synchronously
2653    #
2654    # this creates a DOS box to run a program in
2655    proc forknewterm {title command  "wait 1" "scrollbar 1"} {
2656        global env expgui
2657        # Windows environment variables
2658        set env(GSAS) [file nativename $expgui(gsasdir)]
2659        # PGPLOT_FONT is needed by PGPLOT
2660        set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
2661        set env(PGPLOT_DIR) $expgui(pgplotdir)
2662        # this is the number of lines/page in the .LST (etc.) file
2663        set env(LENPAGE) 60
2664        set pwd [file nativename [pwd]]
2665        # check the path -- can DOS use it?
2666        if {[string first // [pwd]] != -1} {
2667            MyMessageBox -parent . -title "Invalid Path" \
2668                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2669                    -icon error -type ok -default ok \
2670                    -helplink "expgui_Win_readme.html NetPath"
2671            return
2672        }
2673        # pause is hard coded in the .BAT file
2674        if {$expgui(execprompt)} {
2675            set script gsastcl.bat
2676        } else {
2677            set script gsasnowt.bat
2678        }
2679
2680        if {$wait} {
2681            if {$expgui(autoiconify)} {wm iconify .}
2682            # create a blank lock file (keep liveplot from running)
2683            close [open expgui.lck w]
2684            # loop over commands
2685            foreach cmd $command {
2686                # replace the forward slashes with backward
2687                regsub -all / $cmd \\ cmd
2688                # use of file attributes -shortname & normalize and nativename
2689                # might help here
2690                exec $env(COMSPEC) /c \
2691                        "start [file join $expgui(scriptdir) $script] $cmd"
2692            }
2693            file delete -force expgui.lck
2694            if {$expgui(autoiconify)} {wm deiconify .}
2695            # check for changes in the .EXP file immediately
2696            whenidle
2697        } else {
2698            # loop over commands
2699            foreach cmd $command {
2700                # replace the forward slashes with backward
2701                regsub -all / $cmd \\ cmd
2702                # run in background
2703                exec $env(COMSPEC) /c \
2704                        "start [file join $expgui(scriptdir) $script] $cmd" &
2705                if {$expgui(MacroRunning)} {
2706                    update 
2707                    update idletasks
2708                }
2709            }
2710        }
2711    }
2712} else {
2713    # UNIX-based machines
2714    if {[auto_execok xterm] != ""} {
2715        # this creates a xterm window for running programs inside
2716        proc forknewterm {title command "wait 1" "scrollbar 1"} {
2717            global env expgui
2718            # UNIX environment variables
2719            set env(GSAS) [file nativename $expgui(gsasdir)]
2720            set env(gsas) [file nativename $expgui(gsasdir)]
2721            set env(GSASEXE) $expgui(gsasexe)
2722            set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2723            set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2724            # PGPLOT_DIR is needed by PGPLOT
2725            set env(PGPLOT_DIR) $expgui(pgplotdir)
2726            # this is the number of lines/page in the .LST (etc.) file
2727            set env(LENPAGE) 60
2728            set termopts {}
2729            if $env(GSASBACKSPACE) {
2730                append termopts \
2731                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2732            }
2733            if $scrollbar {
2734                append termopts " -sb"
2735            } else {
2736                append termopts " +sb"
2737            }
2738            if {$wait} {
2739                set suffix {}
2740            } else {
2741                set suffix {&}
2742            }
2743           
2744            # hold window open after commands finish
2745            if {$expgui(execprompt)} {
2746                append command "\; echo -n Press Enter to continue \; read x"
2747            }
2748            if {$wait && $expgui(autoiconify)} {wm iconify .}
2749            catch {eval exec xterm $termopts -title [list $title] \
2750                       -e /bin/sh -c [list $command] $suffix} errmsg
2751            if $expgui(debug) {puts "xterm result = $errmsg"}
2752            if {$expgui(MacroRunning)} {
2753                update 
2754                update idletasks
2755            }
2756            if {$wait} {
2757                if {$expgui(autoiconify)} {wm deiconify .}
2758                # check for changes in the .EXP file immediately
2759                whenidle
2760            }
2761        }
2762    } elseif {[auto_execok gnome-terminal] != ""} {
2763        # this creates a xterm window for running programs inside
2764        proc forknewterm {title command "wait 1" "scrollbar 1"} {
2765            global env expgui
2766            # UNIX environment variables
2767            set env(GSAS) [file nativename $expgui(gsasdir)]
2768            set env(gsas) [file nativename $expgui(gsasdir)]
2769            set env(GSASEXE) $expgui(gsasexe)
2770            set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2771            set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2772            # PGPLOT_DIR is needed by PGPLOT
2773            set env(PGPLOT_DIR) $expgui(pgplotdir)
2774            # this is the number of lines/page in the .LST (etc.) file
2775            set env(LENPAGE) 60
2776            if {$wait} {
2777                set suffix {}
2778            } else {
2779                set suffix {&}
2780            }
2781           
2782            # hold window open after commands finish
2783            if {$expgui(execprompt)} {
2784                append command "\; echo -n Press Enter to continue \; read x"
2785            }
2786            if {$wait && $expgui(autoiconify)} {wm iconify .}
2787            catch {exec gnome-terminal --title $title \
2788                       -e " /bin/sh -c \" $command \" " $suffix} errmsg
2789            if $expgui(debug) {puts "gnome-terminal result = $errmsg"}
2790            if {$expgui(MacroRunning)} {
2791                update 
2792                update idletasks
2793            }
2794            if {$wait} {
2795                if {$expgui(autoiconify)} {wm deiconify .}
2796                # check for changes in the .EXP file immediately
2797                whenidle
2798            }
2799        }
2800    } else {
2801        MyMessageBox -parent . -title "Error: no terminal program" \
2802            -message "Error, the xterm or gnome-terminal utility programs could not be found. It is not possible to run the GSAS programs without this." \
2803            -icon error -type NOT-OK -default not-ok
2804    }
2805}
2806
2807# run commands without a terminal window
2808proc runnoterm {command outfile} {
2809    global env expgui tcl_platform
2810    if {$tcl_platform(platform) == "windows"} {
2811        # Windows environment variables
2812        set env(GSAS) [file nativename $expgui(gsasdir)]
2813        # PGPLOT_FONT is needed by PGPLOT
2814        set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
2815        # this is the number of lines/page in the .LST (etc.) file
2816        set env(LENPAGE) 60
2817        set pwd [file nativename [pwd]]
2818        # loop over multiple commands
2819        foreach cmd $command {
2820            # replace the forward slashes with backward
2821            regsub -all / $cmd \\ cmd
2822            exec $cmd >>& $outfile
2823            update
2824            update idletasks
2825        }
2826    } else { 
2827        # UNIX environment variables
2828        set env(GSAS) [file nativename $expgui(gsasdir)]
2829        set env(gsas) [file nativename $expgui(gsasdir)]
2830        set env(GSASEXE) $expgui(gsasexe)
2831        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2832        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2833        # PGPLOT_DIR is needed by PGPLOT
2834        set env(PGPLOT_DIR) $expgui(pgplotdir)
2835        # this is the number of lines/page in the .LST (etc.) file
2836        set env(LENPAGE) 60
2837        foreach cmd $command {
2838            catch {eval exec $cmd >>& $outfile} errmsg
2839        }
2840        update
2841        update idletasks
2842    }
2843    # check for changes in the .EXP file immediately
2844    #whenidle
2845}
2846
2847proc MacMakeResource {file app} {
2848    # make a resource file. Note that OS X has gotten picky about the length of this
2849    set l [string length $app]
2850    if $::expgui(debug) {puts "$l bytes"}
2851    incr l
2852    if $::expgui(debug) {puts "$l bytes after incr"}
2853    set str "data 'usro' (0) {\n"
2854    append str "  $\""
2855    append str [format %.8X $l]
2856    set bytes 4
2857    foreach char [split $app {}] {
2858        append str [format %.2X [scan $char %c]]   
2859    }
2860    incr bytes $l
2861    set newline 1
2862    for {set i 0} {$i < [expr 1028-$bytes]} {incr i} {
2863        if $newline {
2864            append str "\" \n"
2865            append str "  $\""
2866            set newline 0
2867            set j 0
2868        }
2869        append str {0000 }
2870        incr bytes
2871        incr j 2
2872        if {$j > 15} {set newline 1}
2873    }
2874    if {$l % 2} {
2875        append str "\"\n "
2876    } else {
2877        # even lengths need one more byte
2878        append str "00\"\n "
2879    }
2880    append str "/* $app */\n};\n"
2881    set fp [open $file w]
2882    puts $fp $str
2883    close $fp
2884}
2885
2886# modify resource fork info for a .EXP file on the Mac
2887proc MacSetResourceFork {expfile} {
2888    global expgui tcl_platform
2889    if {$tcl_platform(os) != "Darwin"} {return}
2890    set expnative [file nativename $expfile]
2891    #
2892    # assign an app to the data file, if the app and the
2893    # required tool (Rez) are installed
2894    set app [file nativename [file join $expgui(gsasdir) expgui.app]]
2895    set RezApp {}
2896    foreach pth "/usr/bin  /Developer/Tools $expgui(gsasexe)" {
2897        if [file exists [set tst [file join $pth Rez]]] {
2898            set RezApp $tst
2899            break
2900        }
2901    }
2902    set SetFileApp {}
2903    foreach pth "/usr/bin  /Developer/Tools $expgui(gsasexe)" {
2904        if [file exists [set tst [file join $pth SetFile]]] {
2905            set SetFileApp $tst
2906            break
2907        }
2908    }
2909    if $::expgui(debug) {puts "found app=$app Rez=$RezApp and SetFile=$SetFileApp"}
2910    if {[file exists $app] && $RezApp != ""} {
2911        # make resource file
2912        MacMakeResource setapp.r $app
2913        if $::expgui(debug) {puts "$RezApp setapp.r -o $expnative -a"}
2914        exec $RezApp setapp.r -o $expnative -a
2915        if {! $::expgui(debug)} {
2916            file delete -force setapp.r
2917        }
2918    }
2919
2920    # assign an icon to the data file, if it and the required tools exist
2921    set icon [file join $expgui(gsasexe) gsasicon.r]
2922    if {[file exists $icon] && $RezApp != "" && $SetFileApp != ""} {
2923        exec $RezApp [file nativename $icon] -o $expnative -a
2924        exec $SetFileApp -a C $expnative
2925        if {$::expgui(debug)} {
2926            puts "$RezApp [file nativename $icon] -o $expnative -a"
2927            puts "$SetFileApp -a C $expnative"
2928        }
2929    } elseif {$::expgui(debug)} {
2930        puts "icon=$icon missing?"
2931    }
2932}
2933
2934#-------------------------------------------------------------------------------
2935# Macro Recording
2936#-------------------------------------------------------------------------------
2937set expgui(MacroBufferedCommand) ""
2938set expgui(fpMacroFile) ""
2939set expgui(MacroFile) ""
2940# Turn on/off mode to save commands in MacroFile
2941proc SetRecordMacroOnOff {args} {
2942    global expgui
2943    if {$expgui(RecordMacro)} {
2944        set expgui(fpMacroFile) ""
2945        set expgui(MacroBufferedCommand) ""
2946        while {$expgui(fpMacroFile) == ""} {
2947            set expgui(MacroFile) [tk_getSaveFile -initialdir [pwd] \
2948                                       -parent . \
2949                                       -filetypes {{"EXPGUI Macro file" .expmac}} \
2950                                       -defaultextension .expmac  \
2951                                       -initialfile EXPGUI.expmac \
2952                                       -title "Choose location to save macro"]
2953            if {$expgui(MacroFile) == ""} {
2954                # respond to cancel
2955                set expgui(fpMacroFile) ""
2956                set expgui(MacroFile) ""
2957                set expgui(RecordMacro) 0
2958                return
2959            }
2960            if {[catch {
2961                set expgui(fpMacroFile) [open $expgui(MacroFile) w]
2962                puts $expgui(fpMacroFile) "# [clock format [clock seconds] -format %Y-%m-%dT%T]"
2963            } errmsg]} {
2964                MyMessageBox -parent . -title "Error opening selected file" \
2965                    -message "Error opening macro file:\n$errmsg" \
2966                    -icon warning -type TryAgain -default tryagain
2967                catch {close $expgui(fpMacroFile)}
2968                set expgui(fpMacroFile) ""
2969                set expgui(MacroFile) ""
2970                set expgui(RecordMacro) 0
2971            }
2972        }
2973    } else {
2974        if {[string trim $expgui(MacroBufferedCommand)] != ""} {
2975            puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
2976        }
2977        catch {close $expgui(fpMacroFile)}
2978        set expgui(fpMacroFile) ""
2979        set expgui(MacroFile) ""
2980        set expgui(MacroBufferedCommand) ""
2981    }
2982}
2983
2984# record a command in the Macro File
2985proc RecordMacroEntry {command buffer} {
2986    global expgui
2987    if {! $expgui(RecordMacro)} return
2988    # in buffered mode: hold the last command in memory and compare to the
2989    # next. If two commands differ only in the final argument, then the
2990    # second command makes the previous redundant so only the latter version
2991    # is retained (This will happen when a user types a string into a box).
2992    # When the commands differ, then the previous is written to file
2993    # and the next is retained in memory.
2994    if {$buffer} {
2995        if {[string trim $expgui(MacroBufferedCommand)] == ""} {
2996            set expgui(MacroBufferedCommand) $command
2997            return
2998        }
2999        set diff 0
3000        # is command a repeat of previous?
3001        foreach a $command b $expgui(MacroBufferedCommand) {
3002            if {$diff} {
3003                # found a difference, other than in the last arg
3004                puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3005                break
3006            }
3007            if {$a != $b} {set diff 1}
3008        }
3009        set expgui(MacroBufferedCommand) $command
3010    } else {
3011        # no buffering on current command; write the old and new to file.
3012        if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3013            puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3014        }
3015        puts $expgui(fpMacroFile) $command
3016        set expgui(MacroBufferedCommand) ""
3017    }
3018}
3019
3020proc CantRecordMacroEntry {comment} {
3021    global expgui
3022    if {! $expgui(RecordMacro)} return
3023
3024    # no buffering on current command; write the old and new to file.
3025    if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3026        puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3027    }
3028    puts $expgui(fpMacroFile) "# unrecorded: $comment"
3029    set expgui(MacroBufferedCommand) ""
3030    MyMessageBox -parent . -title "No command record" \
3031        -message "EXPGUI is not able to record this action in the macro file: $comment" \
3032        -icon warning
3033}
3034
3035
3036# Play back commands in Macro File
3037proc ReplayMacroFile {"lineatatime 0"} {
3038    global expgui
3039    set expnam [file root [file tail $expgui(expfile)]]
3040    file delete abort_${expnam}_macro.flag
3041    set expgui(MacroRunning) 0
3042    set MacroFile [tk_getOpenFile -initialdir [pwd] \
3043                       -parent . \
3044                       -filetypes {{"EXPGUI Macro file" .expmac} {Everything .*}} \
3045                       -defaultextension .expmac  \
3046                       -title "Choose location to read macro"]
3047    if {$MacroFile == ""} return
3048    set expgui(MacroRunning) 1
3049    if {$lineatatime} {
3050        set expgui(MacroChanged) 0
3051        set top1 .macro
3052        catch {destroy $top1}
3053        toplevel $top1
3054        set txt $top1.t
3055        grid [text $txt -width 30 -height 20 -yscrollcommand "$top1.s set"] \
3056            -column 0 -row 0 -sticky news
3057        wm title $top1 "File $MacroFile"
3058        grid [scrollbar $top1.s -command "$txt yview"] \
3059            -column 1 -row 0 -sticky ns
3060        grid [frame $top1.b] -column 0 -columnspan 2 -row 1 -sticky ew
3061        grid columnconfig $top1 0 -weight 1
3062        grid rowconfig $top1 0 -weight 1
3063        grid [button $top1.b.e -text "Execute line" \
3064                  -command "MacroExecuteCurrentLine $txt"] \
3065            -column 0 -row 0 -sticky w
3066        grid columnconfig $top1.b 1 -weight 1
3067        grid [button $top1.b.s -text "Save As" -state disabled \
3068                  -command "MacroResave $txt"] -column 1 -row 0
3069        set expgui(MacroSaveButton) $top1.b.s 
3070        grid [button $top1.b.c -text "Close " \
3071                  -command "MacroCloseWindow $txt"] -column 2 -row 0
3072        $txt delete 0.0 end
3073        set fp [open $MacroFile r]
3074        $txt insert 0.0 [read $fp]
3075        close $fp
3076        MacroHighlightText $txt 1
3077        # deal with editing in the box
3078        $txt configure -undo 1
3079        $txt edit modified 0
3080        bind $txt <<Modified>> {
3081            $expgui(MacroSaveButton) configure -state normal
3082            set expgui(MacroChanged) 1
3083        }
3084    } else {
3085        close [open running_${expnam}_macro.flag w]
3086        set saveprompt $expgui(execprompt)
3087        set saveautold $expgui(autoexpload)
3088        set expgui(execprompt) 0
3089        set expgui(autoexpload) 1
3090        set expnam [file root [file tail $expgui(expfile)]]
3091        if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
3092            set outfile ${expnam}_macout.LST
3093            # create an empty file
3094            catch {file delete $outfile}
3095            close [open $outfile w]
3096            # view it with LSTVIEW
3097            set outfile ${expnam}_macout
3098            exec $::wishshell [file join $expgui(scriptdir) lstview] $outfile &
3099        } else {
3100            # show status, offer abort with MACROMON
3101            exec $::wishshell [file join $expgui(scriptdir) macromon] $expnam &
3102        }
3103
3104        set  expgui(MacroStatus) "starting script"
3105        pleasewait "\nrunning macro\n\nStatus:" expgui(MacroStatus) 
3106
3107        if {[catch {
3108            source $MacroFile
3109        } errmsg]} {
3110            set txt $::errorInfo
3111            catch {
3112                set fp [open error.txt a]
3113                puts $fp "#  [clock format [clock seconds] -format %Y-%m-%dT%T]"
3114                puts $fp $txt
3115                close $fp
3116            }
3117            donewait
3118            MyMessageBox -parent . -title "Error running Macro file" \
3119                -message "Error running macro file:\n$errmsg\n(details in file error.txt)" \
3120                -icon error -type OK -default ok
3121        } else {
3122            donewait
3123        }
3124        file delete running_${expnam}_macro.flag
3125        set expgui(execprompt) $saveprompt
3126        set expgui(autoexpload) $saveautold
3127        set expgui(MacroRunning) 0
3128        # show changes
3129        PaintEXPGUIpages
3130        # put comment in output file
3131        if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
3132            set outfile ${expnam}_macout.LST
3133            set fp [open $outfile a]
3134            puts $fp "\n**** Macro ended ****" 
3135            close $fp
3136        }
3137    }
3138}
3139
3140# highlight a line in the Macro file display
3141proc MacroHighlightText {txt line} {
3142    $txt tag delete next
3143    $txt tag add next $line.0 $line.end
3144    $txt see $line.0
3145    $txt tag configure next -background yellow
3146    # tag all text
3147    $txt tag delete all
3148    $txt tag add all 0.0 end
3149    # double-click moves the current line
3150    $txt tag bind all <Double-1> "after idle [list MacroDoubleClick $txt]"
3151}
3152
3153# respond to a double click by moving the next line to be executed to
3154# the line where the double click occurred
3155proc MacroDoubleClick {txt} {
3156    set line [lindex [split [$txt tag ranges sel] "."] 0]
3157    MacroHighlightText $txt $line
3158}
3159
3160# respond to Execute button: execute the current line
3161# close window after last command
3162proc MacroExecuteCurrentLine {txt} {
3163    global expgui
3164    set linenum [lindex [split [$txt tag ranges next] "."] 0]
3165    if {$linenum == ""} {return}
3166    set line [$txt get $linenum.0 $linenum.end]
3167    # is this continued (ends with \)?
3168    while {[string range $line end end] == "\\" } {
3169        incr linenum
3170        # get rid of trailing backslash
3171        set line [string range $line 0 end-1]
3172        #append next line
3173        append line [$txt get $linenum.0 $linenum.end]
3174    }
3175     if {[catch $line errmsg]} {
3176        MyMessageBox -parent $txt -title "Error on line" \
3177            -message "Error on line $linenum:\n$errmsg" \
3178            -icon warning -type Continue -default continue
3179    }
3180    # show changes
3181    PaintEXPGUIpages
3182    # move forward in macrofile
3183    incr linenum
3184    MacroHighlightText $txt $linenum
3185    set linenum [lindex [split [$txt tag ranges next] "."] 0]
3186    # at end?
3187    if {$linenum == ""} {MacroCloseWindow $txt}
3188}
3189
3190# Save a modified macro file
3191proc MacroResave {txt} {
3192    global expgui
3193    set MacroFile [tk_getSaveFile -initialdir [pwd] \
3194                       -parent $txt \
3195                       -filetypes {{"EXPGUI Macro file" .expmac}} \
3196                       -defaultextension .expmac  \
3197                       -initialfile $expgui(MacroFile) \
3198                       -title "Choose location to save macro"]
3199    if {[string trim $MacroFile] == ""} {return}
3200    if {[catch {
3201        set fp [open $MacroFile w]
3202        puts $fp [string trim [$txt get 0.0 end]]
3203        close $fp
3204    } errmsg]} {
3205        MyMessageBox -parent $txt -title "Error writing to file" \
3206            -message "Error writing macro file:\n$errmsg" \
3207            -icon warning -type TryAgain -default tryagain
3208        return
3209    }
3210    set expgui(MacroChanged) 0
3211    # gray out the button
3212    $expgui(MacroSaveButton) configure -state disabled
3213}
3214
3215# close the window, but provide a chance to save the file first, if modified
3216proc MacroCloseWindow {txt} {
3217    global expgui
3218    if {$expgui(MacroChanged)} {
3219        set ans [MyMessageBox -parent $txt -title "Save macro file?" \
3220                     -message "Macro file has been changed, do you want to save it?" \
3221                     -icon warning -type "Yes No" -default no]
3222        if {$ans != "no"} {MacroResave $txt}
3223    }
3224    set expgui(MacroRunning) 0
3225    destroy [winfo toplevel $txt]
3226}
3227
3228# Add a comment to a macro file
3229proc AddCommentMacroFile {} {
3230    global expgui
3231    if {! $expgui(RecordMacro)} return
3232    RecordMacroEntry "# [getstring "comment for macro file"]" 0
3233}
3234
3235#------------------------------------------------------------------------------
3236# Subversion support routines
3237#------------------------------------------------------------------------------
3238# is there a subversion stub and can we find the svn program
3239proc CheckUpdateImplemented {scriptdir} {
3240    #is there a svn directory in the source?
3241    if {! [file exists [file join $scriptdir .svn]]} {return 0}
3242    # can we find svn in the path?
3243    if {[auto_execok svn] != ""} {return 1}
3244    # add a locally supplied svn version, if not in the path already
3245    set pathlist "[file join $scriptdir svn bin]"
3246    lappend pathlist "/sw/bin/"
3247    lappend pathlist "/opt/local/bin/"
3248    catch {lappend pathlist $::expgui(pathlist)}
3249    foreach localsvn $pathlist {
3250        if {[file exists $localsvn]} {
3251            if {$::tcl_platform(platform) == "windows"} {
3252                set localsvn [file nativename $localsvn]
3253                set sep {;}
3254            } else {
3255                set sep {:}
3256            }
3257            if {[lsearch [split $::env(PATH) $sep] $localsvn] == -1} {
3258                append ::env(PATH) $sep $localsvn
3259                auto_reset
3260                if {[auto_execok svn] != ""} {return 1}
3261            }
3262        }
3263    }
3264    return 0
3265}
3266
3267proc GetSVNVersion {scriptdir} {
3268    set SVN [auto_execok svn]
3269    if {$SVN != ""} {
3270        if {! [catch {set res [exec $SVN info $scriptdir]} err]} {
3271            set infolist [split $res]
3272            set pos [lsearch $infolist "Revision:"]
3273            return "EXPGUI SVN version [lindex $infolist [incr pos]]"
3274        }
3275    }
3276    return "EXPGUI version: $::expgui(Revision)"
3277}
3278
3279proc GetSVNrepository {scriptdir} {
3280    set SVN [auto_execok svn]
3281    if {$SVN != ""} {
3282        if {! [catch {set res [exec $SVN info $scriptdir]} err]} {
3283            set infolist [split $res]
3284            set pos [lsearch $infolist "URL:"]
3285            return [lindex $infolist [incr pos]]
3286        }
3287    }
3288    return {}
3289}
3290
3291proc SetSVNbranch {branch} {
3292    # reset the track label
3293    set ::command(SVNversion) [lindex [split [GetSVNrepository $::expgui(scriptdir)] '/'] end]
3294    set SVN [auto_execok svn]
3295    if {$SVN == ""} {
3296        return 0
3297    }
3298    set curURL [GetSVNrepository $expgui(scriptdir)]
3299    set curbranch [lindex [split $curURL '/'] end]
3300    if {$curbranch == $branch} {return 0}
3301    if {$branch == "trunk"} {
3302        set newURL "https://subversion.xor.aps.anl.gov/EXPGUI/trunk"
3303        set lbl development
3304    } elseif {$branch == "stable"} {
3305        set newURL "https://subversion.xor.aps.anl.gov/EXPGUI/tags/stable"
3306        set lbl standard
3307    } else {
3308        MyMessageBox -parent . -title "Internal error" \
3309        -message "No $branch track." -icon error
3310        return 0
3311    }
3312    set msg {Press the "Update & Restart" button to begin the update process. After the update completes, EXPGUI will be restarted.}
3313    if {[MyMessageBox -parent . -title "Ready to switch" \
3314        -message "Ready to update to the $lbl track.\n\n$msg" \
3315                 -type {Cancel "Update & Restart"} -default cancel -icon warning
3316        ] == "cancel"} {return}
3317    if {[confirmBeforeSave] == "Cancel"} return
3318
3319    # do a quiet cleanup. Sometimes needed after install, and never hurts
3320    if [catch {set res [exec $SVN cleanup $::expgui(scriptdir)]} err] {
3321        MyMessageBox -parent . -title "Error in cleanup" \
3322            -message "Error performing cleanup. Will try to continue anyway. Error:\n$err" \
3323            -icon error
3324    }
3325
3326    # switch the source
3327    set cmd1 "$SVN switch $newURL $scriptdir"
3328    if [catch {set res1 [exec $SVN switch $newURL $::expgui(scriptdir)]} err] {
3329        MyMessageBox -parent . -title "Error updating" \
3330            -message "Error performing update:\n$err" \
3331            -icon error
3332        return 0
3333    }
3334    set msg "Results from update:\n$cmd1\n$res1"
3335    # update done, now need to "reboot"
3336    MyMessageBox -parent . -title "Updating done" -icon info \
3337        -message "Update Complete\nPress OK to restart EXPGUI\n\n$msg"
3338    exec [info nameofexecutable] [file normalize $::expgui(script)] [file normalize $::expgui(expfile)] &
3339    exit
3340}
3341
3342proc CheckAndDoUpdate { } {
3343    set SVN [auto_execok svn]
3344    if {$SVN == ""} {
3345        tk_dialog .msg "Error: no svn" \
3346            "Error: SVN not found. Should not happen." \
3347            error 0 OK   
3348        return
3349    }
3350    #set wish "[info nameofexecutable]"
3351    # send a "p" to accept the server fingerprint in case needed on 1st access
3352    set svninp [file normalize "~/svntmp.txt"]
3353    set fp [open $svninp "w"]
3354    puts $fp "p"
3355    close $fp
3356    # check for updates
3357    if [catch {
3358        set res [exec $SVN status [file normalize $::expgui(gsasdir)] -u < $svninp]
3359    } err] {
3360        MyMessageBox -parent . -title "Error checking status" \
3361            -message "Error checking for updates: $err" \
3362            -icon error
3363        catch {file delete $svninp}
3364        return
3365    } else {
3366        if {[string first "*" $res] == -1} {
3367            MyMessageBox -parent . -title "No updates" \
3368                -message "GSAS/EXPGUI appears up-to-date" \
3369                -icon info
3370            return
3371        }
3372        catch {file delete $svninp}
3373    }
3374    if {[MyMessageBox -parent . -title "Ready to Update" \
3375             -message {
3376Updates to GSAS/EXPGUI found.
3377                 
3378Press the "Update & Restart" button to begin the update process. After the update completes, EXPGUI will be restarted.} \
3379             -type {Cancel "Update & Restart"} -default cancel -icon warning
3380        ] == "cancel"} {return}
3381
3382    if {[confirmBeforeSave] == "Cancel"} return
3383
3384     # special upgrade for windows, where the wish exec blocks upgrade of the exe directory
3385    if {$::tcl_platform(platform) == "windows" && $::tcl_platform(os) != "Windows 95"} {
3386        # create a batch file
3387        set out [file normalize ~/expgui_update.bat]
3388        set fp [open [file normalize ~/expgui_update.bat] w]
3389        puts $fp "@echo *"
3390        puts $fp "@echo ******************************************************************"
3391        puts $fp "@echo Preparing to start upgrade of EXPGUI."
3392        puts $fp "@pause"
3393        puts $fp "$SVN cleanup $::expgui(gsasdir)"
3394        puts $fp "$SVN up $::expgui(gsasdir)"
3395        puts $fp "@echo *"
3396        puts $fp "@echo ******************************************************************"
3397        puts $fp "@echo Upgrade is complete. This window will close and EXPGUI will restart."
3398        puts $fp "@pause"
3399        puts $fp "$::env(COMSPEC) /c \"start [info nameofexecutable] \
3400[file attributes [file normalize $::expgui(script)] -shortname] \
3401[file attributes [file normalize $::expgui(expfile)] -shortname] \""
3402        puts $fp "exit"
3403        close $fp
3404        #run the batch file
3405        exec $::env(COMSPEC) /c "start [file nativename [file attributes $out -shortname]]" &
3406        exit
3407    }
3408
3409    # do a quiet cleanup. Sometimes needed after install, and never hurts
3410    if [catch {set res [exec $SVN cleanup $::expgui(gsasdir)]} err] {
3411        MyMessageBox -parent . -title "Error in cleanup" \
3412            -message "Error performing cleanup. Will try to continue anyway. Error:\n$err" \
3413            -icon error
3414    }
3415    if [catch {set res [exec $SVN up $::expgui(gsasdir)]} err] {
3416        MyMessageBox -parent . -title "Error updating" \
3417            -message "Error performing update:\n$err" \
3418            -icon error
3419        return
3420    } else {
3421        MyMessageBox -parent . -title "Updating done" \
3422            -message "Results from update:\n$res\n\nPress OK to restart EXPGUI" \
3423            -icon info
3424    }
3425    exec [info nameofexecutable] [file normalize $::expgui(script)] [file normalize $::expgui(expfile)] &
3426    exit
3427}
Note: See TracBrowser for help on using the repository browser.