source: trunk/gsascmds.tcl @ 876

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

# on 2006/03/29 03:52:11, toby did:
Associate profile names with term labels

  • Property rcs:author set to toby
  • Property rcs:date set to 2006/03/29 03:52:11
  • Property rcs:lines set to +11 -1
  • Property rcs:rev set to 1.63
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 88.4 KB
Line 
1# $Id: gsascmds.tcl 876 2009-12-04 23:13:33Z 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# get a value in a modal dialog
469proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
470    global expgui expmap
471    set w .global
472    catch {destroy $w}
473    toplevel $w -bg beige
474    bind $w <Key-F1> "MakeWWWHelp expguierr.html Input[lindex $what 0]"
475    wm title $w "Input $what"
476    set expgui(temp) {}
477    pack [frame $w.0 -bd 6 -relief groove -bg beige] \
478            -side top -expand yes -fill both
479    grid [label $w.0.a -text "Input a value for the $what" \
480            -bg beige] \
481            -row 0 -column 0 -columnspan 10
482    grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
483            -row 1 -column 0 
484
485    set expgui(temp) $initvalue
486    pack [frame $w.b -bg beige] -side top -fill x -expand yes
487    pack [button $w.b.2 -text Set -command "destroy $w"] -side left
488    if $quit {
489        pack [button $w.b.3 -text Quit \
490                -command "set expgui(temp) {}; destroy $w"] -side left
491    }
492    bind $w <Return> "destroy $w"
493    pack [button $w.b.help -text Help -bg yellow \
494            -command "MakeWWWHelp expguierr.html Input[lindex $what 0]"] \
495            -side right
496
497    # force the window to stay on top
498    putontop $w
499
500    focus $w.b.2
501    tkwait window $w
502    afterputontop
503
504    return $expgui(temp)
505}
506
507#------------------------------------------------------------------------------
508# profile/symmetry routines
509#------------------------------------------------------------------------------
510# profile terms
511array set expgui {
512    prof-T-names {"Von Dreele-Jorgensen-Windsor" \
513                      "David-Ikeda-Carpenter" "Exponential pseudo-Voigt" \
514                      "Exponential p-V+Stephens aniso strain" \
515                      "Exponential p-V+macro strain"
516    }
517    prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
518            rsca s1ec s2ec }
519    prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
520            gam-2 ptec stec difc difa zero }
521    prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
522            gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
523    prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
524            rstr rsta rsca eta}
525    prof-T-5 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
526            gam-2 gsf g1ec g2ec rstr rsta rsca D1 D2 D3 D4 D5 D6 }
527    prof-C-names {"Gaussian only" "Pseudo-Voigt" \
528                      "pseudo-Voigt/FCJ Asym" "p-V/FCJ+Stephens aniso strain" \
529                      "p-V/FCJ+macro strain"
530    }
531    prof-C-1 {GU GV GW asym F1 F2 }
532    prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
533            L11 L22 L33 L12 L13 L23 }
534    prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
535            L11 L22 L33 L12 L13 L23 }
536    prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta} 
537    prof-C-5 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
538            D1 D2 D3 D4 D5 D6 }
539    prof-E-names {Gaussian "Otto pseudo-Voigt"}
540    prof-E-1 {A B C ds cds}
541    prof-E-2 {A B C ds cds LX LY ptec stec}
542}
543
544# number of profile terms depends on the histogram type
545# the LAUE symmetry and the profile number
546proc GetProfileTerms {phase hist ptype} {
547    global expmap expgui
548    if {$hist == "C" || $hist == "T" || $hist == "E"} {
549        set htype $hist
550    } else {
551        set htype [string range $expmap(htype_$hist) 2 2]
552    }
553    # get the cached copy of the profile term labels, when possible
554    set lbls {}
555    catch {
556        set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
557    }
558    if {$lbls != ""} {return $lbls}
559
560    catch {set lbls $expgui(prof-$htype-$ptype)}
561    if {$lbls == ""} {return}
562    # add terms based on the Laue symmetry
563    if {($htype == "C" || $htype == "T") && $ptype == 4} {
564        set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
565        eval lappend lbls [Profile4Terms $laueaxis]
566    }
567    set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
568    return $lbls
569}
570
571proc Profile4Terms {laueaxis} {
572# GSAS Laue classes by number vs spacegrp labeling
573#   1    2    3    4     5      6     7       8     9      10     11     12   13  14
574# 1bar, 2/m, mmm, 4/m, 4/mmm, 3bar, 3bar m, 3bar, 3barm1, 3bar1m, 6/m, 6/mmm, m 3, m3m
575#                              R      R      H      H       H
576# (R=Rhombohedral setting; H=Hexagonal setting)
577    switch -exact $laueaxis {
578        1bar {return \
579                "S400 S040 S004 S220 S202 S022 S310 S103 S031 \
580                S130 S301 S013 S211 S121 S112"}
581        2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
582        2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
583        2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
584        mmm  {return "S400 S040 S004 S220 S202 S022"}
585        4/{return "S400 S004 S220 S202 S310"}
586        4/mmm {return "S400 S004 S220 S202"}
587        3barR     {return "S400 S220 S310 S301 S211"}
588        "3bar mR" {return "S400 S220 S310 S211"}
589        3bar    {return "S400 S004 S202 S310 S211"}
590        3barm1 {return "S400 S004 S202 S301"}
591        3bar1m  {return "S400 S004 S202 S211"}
592        6/m    {return "S400 S004 S202"}
593        6/mmm  {return "S400 S004 S202"}
594        "m 3"  {return "S400 S220"}
595        m3m    {return "S400 S220"}
596        default {return ""}
597    }
598}
599
600proc GetLaue {spg} {
601    global tcl_platform expgui
602    # check the space group
603    set fp [open spg.in w]
604    puts $fp "N"
605    puts $fp "N"
606    puts $fp $spg
607    puts $fp "Q"
608    close $fp
609    catch {
610        if {$tcl_platform(platform) == "windows"} {
611            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
612        } else {
613            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
614        }
615    }
616    set fp [open spg.out r]
617    set laue {}
618    set uniqueaxis {}
619    while {[gets $fp line] >= 0} {
620        regexp {Laue symmetry (.*)} $line junk laue
621        regexp {The unique axis is (.*)} $line junk uniqueaxis
622    }
623    close $fp
624    catch {file delete -force spg.in spg.out}
625    set laue [string trim $laue]
626    # add a R suffix for rhombohedral settings
627    if {[string range [string trim $spg] end end] == "R"} {
628        return "${laue}${uniqueaxis}R"
629    }
630    return "${laue}$uniqueaxis"
631}
632
633# set up to change the profile type for a series of histogram/phase entries
634# (histlist & phaselist should be lists of the same length)
635#
636proc ChangeProfileType {histlist phaselist} {
637    global expgui expmap
638    set w .profile
639    catch {destroy $w}
640    toplevel $w -bg beige
641    wm title $w "Change Profile Function"
642   
643    # all histogram/phases better be the same type, so we can just use the 1st
644    set hist [lindex $histlist 0]
645    set phase [lindex $phaselist 0]
646    set ptype [string trim [hapinfo $hist $phase proftype]]
647
648    # get list of allowed profile terms for the current histogram type
649    set i 1
650    while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
651        lappend lbllist $lbls
652        incr i
653    }
654    # labels for the current type
655    set i $ptype
656    set oldlbls [lindex $lbllist [incr i -1]]
657   
658    if {[llength $histlist] == 1} {
659        pack [label $w.a -bg beige \
660                -text "Change profile function for Histogram #$hist Phase #$phase" \
661                ] -side top
662    } else {
663        # make a list of histograms by phase
664        foreach h $histlist p $phaselist {
665            lappend phlist($p) $h
666        }
667        set num 0
668        pack [frame $w.a -bg beige] -side top
669        pack [label $w.a.$num -bg beige \
670                -text "Change profile function for:" \
671                ] -side top -anchor w
672        foreach i [lsort [array names phlist]] {
673            incr num
674            pack [label $w.a.$num -bg beige -text \
675                    "\tPhase #$i, Histograms [CompressList $phlist($i)]" \
676                    ] -side top -anchor w
677        }
678    }
679    pack [label $w.e1 \
680            -text "Current function is type $ptype." \
681            -bg beige] -side top -anchor w
682    pack [frame $w.e -bg beige] -side top -expand yes -fill both
683    pack [label $w.e.1 \
684            -text "Set function to type" \
685            -bg beige] -side left
686    set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
687    pack $w.e.2 -side left -anchor w
688
689    pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
690            -command "set expgui(newpeaktype) $ptype; \
691            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
692            -value 1 -text "Current value overrides"] -side right
693    pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
694            -command \
695            "set expgui(newpeaktype) $ptype; \
696            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
697            -value 0 -text "Default value overrides"] -side right
698
699    $w.e.2 config -bg beige
700    pack [frame $w.c -bg beige] -side top -expand yes -fill both
701    pack [frame $w.d -bg beige] -side top -expand yes -fill both
702    pack [button $w.d.2 -text Set  \
703              -command "SaveChangeProfileType $w.c [list $histlist] [list $phaselist]; destroy $w"\
704            ] -side left
705    pack [button $w.d.3 -text Quit \
706            -command "destroy $w"] -side left
707    pack [button $w.d.help -text Help -bg yellow \
708            -command "MakeWWWHelp expgui5.html ChangeType"] \
709            -side right
710    bind $w <Key-F1> "MakeWWWHelp expgui5.html ChangeType"
711    bind $w <Return> "destroy $w"
712
713    $menu delete 0 end
714    set i 0
715    foreach lbls $lbllist {
716        incr i
717        $menu add command -label $i -command \
718                "set expgui(newpeaktype) $i; \
719                FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
720    }
721    set expgui(newpeaktype) $ptype
722    FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
723
724    # force the window to stay on top
725    putontop $w
726    focus $w.e.2
727    tkwait window $w
728    afterputontop
729    sethistlist
730}
731
732# save the changes to the profile
733proc SaveChangeProfileType {w histlist phaselist} {
734    global expgui
735    foreach phase $phaselist hist $histlist {
736        hapinfo $hist $phase proftype set $expgui(newpeaktype)
737        hapinfo $hist $phase profterms set $expgui(newProfileTerms)
738        for {set i 1} {$i <=  $expgui(newProfileTerms)} {incr i} {
739            hapinfo $hist $phase pterm$i set [$w.ent${i} get]
740            hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
741        }
742        set i [expr 1+$expgui(newProfileTerms)]
743        hapinfo $hist $phase pcut set [$w.ent$i get]
744        incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
745    }
746}
747
748# file the contents of the "Change Profile Type" Menu
749proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
750    global expgui expmap
751    set ptype [string trim [hapinfo $hist $phase proftype]]
752    catch {unset oldval}
753    # loop through the old terms and set up an array of starting values
754    set num 0
755    foreach term $oldlbls {
756        incr num
757        set oldval($term) [hapinfo $hist $phase pterm$num]
758    }
759    set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
760
761    # is the new type the same as the current?
762    if {$ptype == $newtype} {
763        set nterms [hapinfo $hist $phase profterms]
764    } else {
765        set nterms [llength $lbls]
766    }
767    set expgui(newProfileTerms) $nterms
768    set expgui(CurrentProfileTerms) $nterms
769    # which default profile set matches the new type
770    set setnum {}
771    foreach j {" " 1 2 3 4 5 6 7 8 9} {
772        set i [profdefinfo $hist $j proftype]
773        if {$i == ""} continue
774        if {$i == $newtype} {
775            set setnum $j
776            break
777        }
778    }
779
780    eval destroy [winfo children $w]
781
782    set colstr 0
783    set row 2
784    set maxrow [expr $row + $nterms/2]
785    for { set num 1 } { $num <= $nterms + 1} { incr num } {
786        # get the default value (originally from the in .INS file)
787        set val {}
788        if {$setnum != ""} {
789            set val 0.0
790            catch {
791                set val [profdefinfo $hist $setnum pterm$num]
792                # pretty up the number
793                if {$val == 0.0} {
794                    set val 0.0
795                } elseif {abs($val) < 1e-2 || abs($val) > 1e6} {
796                    set val [format %.3e $val]
797                } elseif {abs($val) > 1e-2 && abs($val) < 10} {
798                    set val [format %.5f $val]
799                } elseif {abs($val) < 9999} {
800                    set val [format %.2f $val]
801                } elseif {abs($val) < 1e6} {
802                    set val [format %.0f $val]
803                }
804            }
805        }
806        # heading
807        if {$row == 2} {
808            set col $colstr
809            grid [label $w.h0${num} -text "lbl" -bg beige] \
810                -row $row -column $col
811            grid [label $w.h2${num} -text "ref" -bg beige] \
812                -row $row -column [incr col]
813            grid [label $w.h3${num} -text "next value" -bg beige] \
814                -row $row -column [incr col]
815            grid [label $w.h4${num} -text "default" -bg beige] \
816                -row $row -column [incr col]
817            grid [label $w.h5${num} -text "current" -bg beige] \
818                -row $row -column [incr col]
819        }
820        set col $colstr
821        incr row
822        set term {}
823        catch {set term [lindex $lbls [expr $num-1]]}
824        if {$term == ""} {set term $num}
825        if {$num == $nterms + 1} {
826            set term "Peak\nCutoff"
827            set val {}
828            if {$setnum != ""} {
829                set val 0.0
830                catch {set val [profdefinfo $hist $setnum pcut]}
831            }
832        }
833
834        grid [label $w.l${num} -text "$term" -bg beige] \
835                -row $row -column $col
836        grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
837                -bg beige -activebackground beige] -row $row -column [incr col]
838        grid [entry $w.ent${num} \
839                -width 12] -row $row -column [incr col]
840        if {$val != ""} {
841            grid [button $w.def${num} -text $val -command \
842                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
843                    ] -row $row -column [incr col] -sticky ew
844        } else {
845            grid [label $w.def${num} -text (none) \
846                    ] -row $row -column [incr col]
847        }
848        set curval {}
849        catch {
850            set curval [expr $oldval($term)]
851            # pretty up the number
852            if {$curval == 0.0} {
853                set curval 0.0
854            } elseif {abs($curval) < 1e-2 || abs($curval) > 1e6} {
855                set curval [format %.3e $curval]
856            } elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
857                set curval [format %.5f $curval]
858            } elseif {abs($curval) < 9999} {
859                set curval [format %.2f $curval]
860            } elseif {abs($curval) < 1e6} {
861                set curval [format %.0f $curval]
862            }
863            grid [button $w.cur${num} -text $curval -command  \
864                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
865                    ] -row $row -column [incr col] -sticky ew
866        }
867        # set default values for flag and value
868        set ref 0
869        if {$setnum != ""} {
870            catch {
871                if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
872            }
873        }
874        set expgui(ProfRef$num) $ref
875       
876        $w.ent${num} delete 0 end
877        if {!$expgui(DefaultPeakType) && $val != ""} {
878            $w.ent${num} insert end $val
879        } elseif {$curval != ""} {
880            $w.ent${num} insert end $curval
881        } elseif {$val != ""} {
882            $w.ent${num} insert end $val
883        } else {
884            $w.ent${num} insert end 0.0
885        }
886        if {$row > $maxrow} {
887            set row 2
888            incr colstr 5
889        }
890    }
891    if {$::tcl_platform(os) == "Darwin"} {
892        # on OS X force a window resize
893        wm geometry [winfo toplevel $w] {}
894    }
895}
896
897#------------------------------------------------------------------------------
898# WWW/help routines
899#------------------------------------------------------------------------------
900# browse a WWW page with URL. The URL may contain a #anchor
901# On UNIX assume netscape or mozilla is in the path or env(BROWSER) is loaded.
902# On Windows search the registry for a browser. Mac branch not tested.
903# This is taken from http://mini.net/cgi-bin/wikit/557.html with many thanks
904# to the contributers
905proc urlOpen {url} {
906    global env tcl_platform
907    if {$tcl_platform(os) == "Darwin"} {
908        # if this is an external URL or does not contain an anchor, take the
909        # easy approach
910        if {[string range $url 0 4] == "http:" || \
911                [string first "#" $url] == -1} {
912            if {![catch {exec open $url}]} {
913                return
914            }
915        }
916        # so sorry, have to use Internet Explorer
917        set url [file nativename $url]; # replace ~/ if present
918        if {[file pathtype $url] == "relative"} {
919            set url [file join [pwd] $url]
920        }
921        exec osascript -e "tell application \"Internet Explorer\"\rGetURL \"file://$url\"\rend tell"
922    } elseif {$tcl_platform(platform) == "unix"} {
923        set browserlist {}
924        if {[info exists env(BROWSER)]} {
925            set browserlist $env(BROWSER)
926        }
927        lappend browserlist netscape mozilla
928        foreach p $browserlist {
929            set progs [auto_execok $p]
930            if {[llength $progs]} {
931                if {[catch {exec $progs -remote openURL($url)}]} {
932                    # perhaps browser doesn't understand -remote flag
933                    if {[catch {exec $env(BROWSER) $url &} emsg]} {
934                        error "Error displaying $url in browser\n$emsg"
935                    }
936                }
937                return
938            }
939        }
940        MyMessageBox -parent . -title "No Browser" \
941            -message "Could not find a browser. Netscape & Mozilla not found. Define environment variable BROWSER to be full path name of browser." \
942            -icon warning
943    } elseif {$tcl_platform(platform) == "windows"} {
944        package require registry
945        # Look for the application under
946        # HKEY_CLASSES_ROOT
947        set root HKEY_CLASSES_ROOT
948       
949        # Get the application key for HTML files
950        set appKey [registry get $root\\.html ""]
951       
952        # Get the command for opening HTML files
953        set appCmd [registry get \
954                        $root\\$appKey\\shell\\open\\command ""]
955
956        # Substitute the HTML filename into the command for %1
957        # or stick it on the end
958        if {[string first %1 $appCmd] != -1} {
959            regsub %1 $appCmd $url appCmd
960        } else {
961            append appCmd " " $url
962        }
963       
964        # Double up the backslashes for eval (below)
965        regsub -all {\\} $appCmd  {\\\\} appCmd
966       
967        # Invoke the command
968        eval exec $appCmd &
969    } elseif {$tcl_platform(platform) == "macintosh"} {
970        # preOSX -- this is not used
971        if {0 == [info exists env(BROWSER)]} {
972            set env(BROWSER) "Browse the Internet"
973        }
974        if {[catch {
975            AppleScript execute\
976                "tell application \"$env(BROWSER)\"
977                         open url \"$url\"
978                     end tell
979                "} emsg]
980        } then {
981            error "Error displaying $url in browser\n$emsg"
982        }
983    }
984}
985
986proc NetHelp {file anchor localloc netloc} {
987    # use the file on-line, if it exists
988    if {[file exists [file join $localloc $file]]} {
989        set url "[file join $localloc $file]"
990    } else {
991        set url "http://$netloc/$file"
992    }
993    catch {
994        pleasewait "Starting web browser..."
995        after 2000 donewait
996    }
997    if {$anchor != ""} {
998        append url # $anchor
999    }
1000    urlOpen $url
1001}
1002
1003proc MakeWWWHelp {"topic {}" "anchor {}"} {
1004    global expgui
1005    if {$topic == ""} {
1006        foreach item $expgui(notebookpagelist) {
1007            if {[lindex $item 0] == $expgui(pagenow)} {
1008                NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
1009                return
1010            }
1011        }
1012        # this should not happen
1013        NetHelp expgui.html "" $expgui(docdir) $expgui(website)
1014    } elseif {$topic == "menu"} {
1015        NetHelp expguic.html "" $expgui(docdir) $expgui(website)
1016    } else {
1017        NetHelp $topic $anchor $expgui(docdir) $expgui(website)
1018    }
1019}
1020
1021# show help information
1022proc showhelp {} {
1023    global expgui_helplist helpmsg
1024    set helpmsg {}
1025    set frm .help
1026    catch {destroy $frm}
1027    toplevel $frm
1028    wm title $frm "Help Summary"
1029    grid [label $frm.0 -text \
1030            "Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
1031        -column 0 -columnspan 4 -row 0
1032#    grid [message $frm.help -textvariable helpmsg -relief groove] \
1033#          -column 0 -columnspan 4 -row 2 -sticky nsew
1034    grid [text $frm.help -relief groove -bg beige -width 0\
1035            -height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
1036           -column 0 -columnspan 3 -row 2 -sticky nsew
1037    grid [scrollbar $frm.escroll -command "$frm.help yview"] \
1038            -column 4 -row 2 -sticky nsew
1039    grid rowconfig $frm 1 -weight 1 -minsize 50
1040    grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
1041    grid columnconfig $frm 0 -weight 1
1042    grid columnconfig $frm 2 -weight 1
1043    set lst [array names expgui_helplist]
1044    grid [listbox $frm.cmds -relief raised -bd 2 \
1045            -yscrollcommand "$frm.scroll set" \
1046            -height 8 -width 0 -exportselection 0 ] \
1047            -column 0 -row 1 -sticky nse
1048    grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
1049            -column 1 -row 1 -sticky nsew
1050    foreach item [lsort -dictionary $lst] {
1051        $frm.cmds insert end $item 
1052    }
1053    if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
1054    grid [button $frm.done -text Done -command "destroy $frm"] \
1055            -column 2 -row 1
1056#    bind $frm.cmds <ButtonRelease-1> \
1057#           "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
1058    bind $frm.cmds <ButtonRelease-1> \
1059            "+$frm.help config -state normal; $frm.help delete 0.0 end; \
1060             $frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
1061             $frm.help config -state disabled"
1062
1063    # get the size of the window and expand the message boxes to match
1064#    update
1065#    $frm.help config -width [winfo width $frm.help ]
1066}
1067
1068
1069#------------------------------------------------------------------------------
1070# utilities
1071#------------------------------------------------------------------------------
1072# run liveplot
1073proc liveplot {} {
1074    global expgui liveplot wishshell expmap
1075    set expnam [file root [file tail $expgui(expfile)]]
1076    # which histograms are ready for use?
1077    set validlist {}
1078    foreach ihist $expmap(powderlist) {
1079        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1080                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1081            lappend validlist $ihist
1082        }
1083    }
1084    if {[llength $validlist] == 0} {
1085        MyMessageBox -parent . -title "No Valid Histograms" \
1086                -message "No histograms are ready to plot. Run GENLES and try again" \
1087                -icon warning -helplink "expguierr.html NoValidHist"
1088        return
1089    }
1090    # use $liveplot(hst) if valid, the 1st entry otherwise
1091    if {[lsearch $validlist $liveplot(hst)] != -1} {
1092        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1093                $expnam $liveplot(hst) $liveplot(legend) &
1094    } else {
1095        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1096                $expnam [lindex $validlist 0] $liveplot(legend) &
1097    }
1098}
1099
1100# run lstview
1101proc lstview {} {
1102    global expgui wishshell
1103    set expnam [file root [file tail $expgui(expfile)]]
1104    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1105}
1106
1107# run widplt
1108proc widplt {"prog widplt"} {
1109    global expgui wishshell
1110    exec $wishshell [file join $expgui(scriptdir) $prog] \
1111            $expgui(expfile) &
1112}
1113
1114# run bkgedit
1115proc bkgedit {"hst {}"} {
1116    global expgui liveplot wishshell expmap
1117    set expnam [file root [file tail $expgui(expfile)]]
1118    if {$hst == ""} {
1119        # which histograms are ready for use?
1120        set validlist {}
1121        foreach ihist $expmap(powderlist) {
1122            if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1123                    [string range $expmap(htype_$ihist) 3 3] == "*"} {
1124                lappend validlist $ihist
1125            }
1126        }
1127        if {[llength $validlist] == 0} {
1128            MyMessageBox -parent . -title "No Valid Histograms" \
1129                    -message "No histograms are ready to plot. Run POWPREF and try again" \
1130                    -icon warning -helplink "expguierr.html NoValidHist"
1131            return
1132        }
1133        # use $liveplot(hst) if valid, the 1st entry otherwise
1134        if {[lsearch $validlist $liveplot(hst)] != -1} {
1135            set hst $liveplot(hst)
1136        } else {
1137            set hst [lindex $validlist 0]
1138        }
1139    }
1140    # Save the current exp file
1141    savearchiveexp
1142    # disable the file change monitor if we will reload the .EXP file automatically
1143    if {$expgui(autoexpload)} {set expgui(expModifiedLast) 0}
1144    if {$expgui(autoiconify)} {wm iconify .}
1145    exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1146            $expnam $hst $liveplot(legend)
1147    if {$expgui(autoiconify)} {wm deiconify .}
1148    # load the changed .EXP file automatically?
1149    if {$expgui(autoexpload)} {
1150        # load the revised exp file
1151        loadexp $expgui(expfile)
1152    } else {
1153        # check for changes in the .EXP file immediately
1154        whenidle
1155    }
1156}
1157
1158# run excledt
1159proc excledit {} {
1160    global expgui liveplot wishshell expmap
1161    set expnam [file root [file tail $expgui(expfile)]]
1162    # which histograms are ready for use?
1163    set validlist {}
1164    foreach ihist $expmap(powderlist) {
1165        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1166                [string range $expmap(htype_$ihist) 3 3] == "*" || \
1167                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1168            lappend validlist $ihist
1169        }
1170    }
1171    if {[llength $validlist] == 0} {
1172        MyMessageBox -parent . -title "No Valid Histograms" \
1173                -message "No histograms are ready to plot. Run POWPREF and try again" \
1174                -icon warning -helplink "expguierr.html NoValidHist"
1175        return
1176    }
1177    #if {$expgui(autoiconify)} {wm iconify .}
1178    StartExcl 
1179    #if {$expgui(autoiconify)} {wm deiconify .}
1180}
1181
1182# compute the composition for each phase and display in a dialog
1183proc composition {} {
1184    global expmap expgui
1185    set Z 1
1186    foreach phase $expmap(phaselist) type $expmap(phasetype) {
1187        if {$type == 4} continue
1188        ResetMultiplicities $phase {}
1189        catch {unset total}
1190        foreach atom $expmap(atomlist_$phase) {
1191            set type [atominfo $phase $atom type]
1192            set mult [atominfo $phase $atom mult]
1193            if [catch {set total($type)}] {
1194                set total($type) [expr \
1195                        $mult * [atominfo $phase $atom frac]]
1196            } else {
1197                set total($type) [expr $total($type) + \
1198                        $mult * [atominfo $phase $atom frac]]
1199            }
1200            if {$mult > $Z} {set Z $mult}
1201        }
1202        append text "\nPhase $phase\n"
1203        append text "  Unit cell contents\n"
1204        foreach type [lsort [array names total]] {
1205            append text "   $type[format %8.3f $total($type)]"
1206        }
1207        append text "\n\n"
1208       
1209        append text "  Asymmetric Unit contents (Z=$Z)\n"
1210        foreach type [lsort [array names total]] {
1211            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
1212        }
1213        append text "\n"
1214    }
1215   
1216    catch {destroy .comp}
1217    toplevel .comp -class MonoSpc
1218    bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1219    wm title .comp Composition
1220    pack [label .comp.results -text $text \
1221            -justify left] -side top
1222    pack [frame .comp.box]  -side top -expand y -fill x
1223    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1224
1225    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1226    pack [button .comp.box.2 -text "Save to $lstnam file" \
1227            -command "writelst [list $text] ; destroy .comp"] -side left
1228    pack [button .comp.box.help -text Help -bg yellow \
1229            -command "MakeWWWHelp expgui.html Composition"] \
1230            -side right
1231}
1232
1233# Delete History Records
1234proc DeleteHistoryRecords {{msg ""}} {
1235    global expgui
1236    set frm .history
1237    catch {destroy $frm}
1238    toplevel $frm
1239    bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1240    if {[string trim $msg] == ""} {
1241        set msg "There are [CountHistory] history records"
1242    }
1243    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1244    pack [label $frm.1.0 -text $msg] -side top
1245    pack [frame $frm.1.1] -side top
1246    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1247    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1248            ] -side left
1249    set expgui(historyKeep) 10
1250    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1251    set expgui(renumber) 1
1252    pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1253    pack [button $frm.2.help -text Help -bg yellow \
1254            -command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1255    pack [button $frm.2.4 -text Quit \
1256            -command {destroy .history}] -side bottom
1257    pack [button $frm.2.3 -text OK \
1258            -command { 
1259        if ![catch {expr $expgui(historyKeep)}] {
1260            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1261            set expgui(changed) 1
1262            destroy .history
1263        }
1264    }] -side bottom
1265    bind $frm <Return> "$frm.2.3 invoke"
1266   
1267    # force the window to stay on top
1268    putontop $frm 
1269    focus $frm.2.3
1270    tkwait window $frm
1271    afterputontop
1272}
1273
1274proc archiveexp {} {
1275    global expgui tcl_platform
1276    # is there a file to archive?
1277    if {![file exists $expgui(expfile)]} return
1278    set expnam [file rootname $expgui(expfile)]
1279    # get the last archived version
1280    set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1281    if {$lastf == ""} {
1282        set num 01
1283    } else {
1284        regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1285        scan $num %x num
1286        if {$num >= 255} {
1287            set num FF
1288        } else {
1289            set num [string toupper [format %.2x [incr num]]]
1290        }
1291    }
1292    catch {
1293        set file $expnam.O$num
1294        file copy -force $expgui(expfile) $file
1295        set fp [open $expnam.LST a+]
1296        puts $fp "\n----------------------------------------------"
1297        puts $fp "     Archiving [file tail $expnam.EXP] as [file tail $file]"
1298        puts $fp "----------------------------------------------\n"
1299        close $fp
1300    } errmsg
1301    if {$errmsg != ""} {
1302        tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1303    }
1304}
1305
1306# save and optionally archive the expfile
1307proc savearchiveexp {} {
1308    global expgui expmap
1309    if {$expgui(expfile) == ""} {
1310        SaveAsFile
1311        return
1312    }
1313    if !$expgui(changed) return
1314    if {$expgui(archive)} archiveexp
1315    # add a history record
1316    exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds] -format {%D %T}]"
1317    # now save the file
1318    expwrite $expgui(expfile)
1319    # change the icon and assign an app to this .EXP file
1320    global tcl_platform
1321    if {$tcl_platform(os) == "Darwin" && $expgui(MacAssignApp)} {
1322        MacSetResourceFork $expgui(expfile)
1323    }
1324    set expgui(changed) 0
1325    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1326    set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1327    wm title . $expgui(expfile)
1328    set expgui(titleunchanged) 1
1329    # set convergence criterion
1330    InitLSvars
1331}
1332
1333#------------------------------------------------------------------------------
1334# GSAS interface routines
1335#------------------------------------------------------------------------------
1336# run a GSAS program that does not require an experiment file
1337proc runGSASprog {proglist "concurrent 1"} {
1338    # if concurrent is 0, EXPGUI runs the GSAS program in background
1339    # -- this is not currently needed anywhere where the .EXP file is not.
1340    global expgui tcl_platform
1341    set cmd {}
1342    foreach prog $proglist {
1343        StartGRWND $prog
1344        if {$tcl_platform(platform) == "windows"} {
1345            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1346        } else {
1347            if {$cmd != ""} {append cmd "\;"}
1348            append cmd "[file join $expgui(gsasexe) $prog]"
1349        }
1350    }
1351    forknewterm $prog $cmd [expr !$concurrent] 1
1352}
1353
1354# dummy routine, overridden if needed
1355proc StartGRWND {prog} {
1356}
1357
1358# run a GSAS program that requires an experiment file for input/output
1359proc runGSASwEXP {proglist "concurrent 0"} {
1360    # most programs that require the .EXP file change it and
1361    # cannot be run concurrently
1362    global expgui tcl_platform
1363    # Save the current exp file
1364    savearchiveexp
1365    # load the changed .EXP file automatically?
1366    if {$expgui(autoexpload)} {
1367        # disable the file changed monitor
1368        set expgui(expModifiedLast) 0
1369    }
1370    set cmd {}
1371    set expnam [file root [file tail $expgui(expfile)]]
1372    foreach prog $proglist {
1373        if {$prog == "powpref"} {
1374            set expgui(needpowpref) 0
1375            set expgui(needpowpref_why) ""
1376        } elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1377            set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1378            set ans [MyMessageBox -parent . -title "Run POWPREF" \
1379                    -message $msg -icon warning -type "Yes No" -default yes \
1380                    -helplink "expguierr.html RunPowpref"]
1381            if {$ans == "yes"} {
1382                set expgui(needpowpref) 0
1383                set expgui(needpowpref_why) ""
1384                if {$tcl_platform(platform) == "windows"} {
1385                    append cmd " \"$expgui(gsasexe)/powpref.exe $expnam \" "
1386                } else {
1387                    if {$cmd != ""} {append cmd "\;"}
1388                    append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1389                }
1390            }
1391        }
1392        StartGRWND $prog
1393        if {$tcl_platform(platform) == "windows"} {
1394            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1395        } else {
1396            if {$cmd != ""} {append cmd "\;"}
1397            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1398        }
1399    }
1400    forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1401    # load the changed .EXP file automatically?
1402    if {$expgui(autoexpload)} {
1403        # load the revised exp file
1404        loadexp $expgui(expfile)
1405    }
1406}
1407
1408# write text to the .LST file
1409proc writelst {text} {
1410    global expgui
1411    set lstnam [file rootname $expgui(expfile)].LST
1412    set fp [open $lstnam a]
1413    puts $fp "\n-----------------------------------------------------------------"
1414    puts $fp $text
1415    puts $fp "-----------------------------------------------------------------\n"
1416    close $fp
1417}
1418
1419
1420# rename file current to suggested,
1421#   delete window if supplied
1422#   use parent, if supplied or .
1423proc RenameAsFile {current suggested "window {}" "parent {}"} {
1424    if {$parent == "" && $window != ""} {set parent $window}
1425    if {$parent == ""} {set parent .}
1426    set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1427    if {$newfile == ""} return
1428    if {[catch {
1429        file rename -force $current $newfile
1430    }]} {
1431        file copy -force $current $newfile
1432        file delete -force $current
1433    }
1434    if {$window != ""} {destroy $window}
1435}
1436
1437# optionally run disagl as a windowless process, w/results in a separate window
1438proc rundisagl {} {
1439    global expgui txtvw tcl_version tcl_platform
1440    if {$expgui(disaglSeparateBox)} {
1441        set root [file root $expgui(expfile)] 
1442        catch {file delete -force $root.tmp}
1443        if {[catch {file rename -force $root.LST $root.OLS}]} {
1444            file copy -force $root.LST $root.OLS
1445            file delete -force $root.OLS
1446        }
1447        # PSW reports this does not happen right away on windows
1448        set i 0
1449        while {$i < 10 && [file exists $root.LST]} {
1450            # debug code
1451            #catch {console show}
1452            #puts "try $i"
1453            # end debug code
1454            after 100
1455            incr i
1456        }
1457        if {[file exists $root.LST]} {
1458            # it was not possible to rename the file
1459            MyMessageBox -parent . -title "Rename Problem" \
1460                -message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1461                -icon warning -helplink "expguierr.html NoRename"
1462            return
1463        }
1464
1465        #run the program
1466        pleasewait "Running DISAGL"     
1467        # create an empty input file
1468        close [open disagl.inp w]
1469        catch {exec [file join $expgui(gsasexe) disagl] \
1470                [file tail $root] < disagl.inp > disagl.out}
1471        if {[catch {file rename -force $root.LST $root.tmp}]} {
1472            file copy -force $root.LST $root.tmp
1473            file delete -force $root.LST
1474        }
1475        catch {file delete -force disagl.inp disagl.out}
1476        if {[catch {file rename -force $root.OLS $root.LST}]} {
1477            file copy -force $root.OLS $root.LST
1478            file delete -force $root.OLS
1479        }
1480        donewait
1481        # open a new window
1482        catch {toplevel .disagl}
1483        catch {eval grid forget [grid slaves .disagl]}
1484        text .disagl.txt -width 100 -wrap none \
1485                -yscrollcommand ".disagl.yscroll set" \
1486                -xscrollcommand ".disagl.xscroll set" 
1487        scrollbar .disagl.yscroll -command ".disagl.txt yview"
1488        scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1489        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1490        grid .disagl.txt -column 0 -row 1 -sticky nsew
1491        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1492        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1493        grid columnconfig .disagl.f 2 -weight 1
1494        grid [button .disagl.f.close -text "Close & Delete" \
1495                -command "destroy .disagl; file delete $root.tmp"] \
1496                -column 3 -row 0 -sticky e
1497        grid [button .disagl.f.rename \
1498                -command "RenameAsFile $root.tmp $root.DIS .disagl" \
1499                -text "Close & Save as..."] \
1500                -column 4 -row 0 -sticky e
1501        # allow font changes on the fly
1502        if {$tcl_version >= 8.0} {
1503            .disagl.txt config -font $txtvw(font)
1504            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1505            grid .disagl.f.font -column 1 -row 0 -sticky w
1506            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1507            $fontbut delete 0 end
1508            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1509                $fontbut add command -label "Courier $f" -font "Courier $f"\
1510                        -command "set txtvw(font) \"Courier $f\"; \
1511                        .disagl.txt config -font \$txtvw(font)"
1512            }
1513        }
1514       
1515        grid columnconfigure .disagl 0 -weight 1
1516        grid rowconfigure .disagl 1 -weight 1
1517        wm title .disagl "DISAGL results $expgui(expfile)"
1518        wm iconname .disagl "DISAGL $root"
1519        set in [open $root.tmp r]
1520        .disagl.txt insert end [read $in]
1521        close $in
1522        bind all  {destroy .disagl}
1523        bind .disagl  ".disagl.txt yview scroll -1 page"
1524        bind .disagl  ".disagl.txt yview scroll 1 page"
1525        bind .disagl  ".disagl.txt xview scroll 1 unit"
1526        bind .disagl  ".disagl.txt xview scroll -1 unit"
1527        bind .disagl  ".disagl.txt yview scroll -1 unit"
1528        bind .disagl  ".disagl.txt yview scroll 1 unit"
1529        bind .disagl  ".disagl.txt yview 0"
1530        bind .disagl  ".disagl.txt yview end"
1531        # don't disable in Win as this prevents the highlighting of selected text
1532        if {$tcl_platform(platform) != "windows"} {
1533            .disagl.txt config -state disabled
1534        }
1535    } else {
1536        runGSASwEXP disagl
1537    }
1538}
1539
1540#------------------------------------------------------------------------------
1541# file conversions
1542#------------------------------------------------------------------------------
1543proc convfile {} {
1544    global expgui
1545    set frm .file
1546    catch {destroy $frm}
1547    toplevel $frm
1548    wm title $frm "Convert File"
1549    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1550    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1551    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1552            -side left -fill y -expand yes
1553    pack [button $frmC.help -text Help -bg yellow \
1554            -command "MakeWWWHelp expgui.html ConvertWin"] -side top
1555    pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1556    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1557            -side bottom
1558    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1559    winfilebox $frm
1560    bind $frm <Return> "ValidWinCnv $frm"
1561
1562    # force the window to stay on top
1563    putontop $frm
1564    focus $frmC.q 
1565    tkwait window $frm
1566    afterputontop
1567}
1568
1569# validate the files and make the conversion
1570proc ValidWinCnv {frm} {
1571    global expgui
1572    # change backslashes to something sensible
1573    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1574    # allow entry of D: for D:/ and D:TEST for d:/TEST
1575    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1576            [string first :/ $expgui(FileMenuCnvName)] == -1} {
1577        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1578    }
1579    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1580        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1581        ChooseWinCnv $frm
1582        return
1583    } elseif [file isdirectory \
1584            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1585        if {$expgui(FileMenuCnvName) != "."} {
1586            set expgui(FileMenuDir) \
1587                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1588        }
1589        ChooseWinCnv $frm
1590        return
1591    }
1592 
1593    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1594    if ![file exists $file] {
1595        MyMessageBox -parent $frm -title "Convert Error" \
1596                -message "File $file does not exist" -icon error
1597        return
1598    }
1599
1600    set tmpname "[file join [file dirname $file] tempfile.xxx]"
1601    set oldname "[file rootname $file].org"
1602    if [file exists $oldname] {
1603        set ans [MyMessageBox -parent . -title "Overwrite?" \
1604                -message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1605                -icon warning -type {Overwrite Cancel} -default Overwrite \
1606                -helplink "expguierr.html OverwriteCnv"]
1607        if {[string tolower $ans] == "cancel"} return
1608        catch {file delete $oldname}
1609    }
1610
1611    if [catch {
1612        set in [open $file r]
1613        set out [open $tmpname w]
1614        fconfigure $out -translation crlf -encoding ascii
1615        set len [gets $in line]
1616        if {$len > 160} {
1617            # this is a UNIX file. Hope there are no control characters
1618            set i 0
1619            set j 79
1620            while {$j < $len} {
1621                puts $out [string range $line $i $j]
1622                incr i 80
1623                incr j 80
1624            }
1625        } else {
1626            while {$len >= 0} {
1627                append line "                                        "
1628                append line "                                        "
1629                set line [string range $line 0 79]
1630                puts $out $line
1631                set len [gets $in line]
1632            }
1633        }
1634        close $in
1635        close $out
1636        file rename -force $file $oldname
1637        file rename -force $tmpname $file
1638    } errmsg] {
1639        MyMessageBox -parent $frm -title "Conversion error" \
1640                -message "Error in conversion:\n$errmsg" -icon warning
1641    } else {
1642        set ans [MyMessageBox -parent $frm -title "More?" \
1643                -message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1644                -type yesno -default no]
1645        if {$ans == "no"} {destroy $frm}
1646    }
1647}
1648
1649# create a file box
1650proc winfilebox {frm} {
1651    global expgui
1652    set bx $frm.1
1653    pack [frame $bx.top] -side top
1654    pack [label $bx.top.a -text "Directory" ] -side left
1655    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1656    pack $bx.top.d -side left
1657    set expgui(FileMenuDir) [pwd]
1658    # the icon below is from tk8.0/tkfbox.tcl
1659    set upfolder [image create bitmap -data {
1660#define updir_width 28
1661#define updir_height 16
1662static char updir_bits[] = {
1663   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1664   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1665   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1666   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1667   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1668   0xf0, 0xff, 0xff, 0x01};}]
1669
1670    pack [button $bx.top.b -image $upfolder \
1671            -command "updir; ChooseWinCnv $frm" ]
1672    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1673    listbox $bx.a.files -relief raised -bd 2 \
1674            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1675            -height 15 -width 0 -exportselection 0 
1676    listbox $bx.a.dates -relief raised -bd 2 \
1677            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1678            -height 15 -width 0 -takefocus 0 -exportselection 0 
1679    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1680    ChooseWinCnv $frm
1681    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1682    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1683    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1684    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1685    pack $bx.a.scroll -side left -fill y
1686    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1687    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1688}
1689
1690# set the box or file in the selection window
1691proc ReleaseWinCnv {frm} {
1692    global expgui
1693    set files $frm.1.a.files
1694    set dates $frm.1.a.dates
1695    set select [$files curselection]
1696    if {$select == ""} {
1697        set select [$dates curselection]
1698    }
1699    if {$select == ""} {
1700        set expgui(FileMenuCnvName) ""
1701    } else {
1702        set expgui(FileMenuCnvName) [string trim [$files get $select]]
1703    }
1704    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1705        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1706        ChooseWinCnv $frm
1707    } elseif [file isdirectory \
1708            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1709        if {$expgui(FileMenuCnvName) != "."} {
1710            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1711            ChooseWinCnv $frm
1712        }
1713    }
1714    return
1715}
1716
1717# select a file or directory -- called on double click
1718proc SelectWinCnv {frm} {
1719    global expgui
1720    set files $frm.1.a.files
1721    set dates $frm.1.a.dates
1722    set select [$files curselection]
1723    if {$select == ""} {
1724        set select [$dates curselection]
1725    }
1726    if {$select == ""} {
1727        set file .
1728    } else {
1729        set file [string trim [$files get $select]]
1730    }
1731    if {$file == "<Parent>"} {
1732        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1733        ChooseWinCnv $frm
1734    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1735        if {$file != "."} {
1736            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1737            ChooseWinCnv $frm
1738        }
1739    } else {
1740        set expgui(FileMenuCnvName) [file tail $file]
1741        ValidWinCnv $frm
1742    }
1743}
1744
1745# fill the files & dates & Directory selection box with current directory,
1746# also called when box is created to fill it
1747proc ChooseWinCnv {frm} {
1748    global expgui
1749    set files $frm.1.a.files
1750    set dates $frm.1.a.dates
1751    set expgui(FileMenuCnvName) {}
1752    $files delete 0 end
1753    $dates delete 0 end
1754    $files insert end {<Parent>}
1755    $dates insert end {(Directory)}
1756    set filelist [glob -nocomplain \
1757            [file join [set expgui(FileMenuDir)] *] ]
1758    foreach file [lsort -dictionary $filelist] {
1759        if {[file isdirectory $file]} {
1760            $files insert end [file tail $file]
1761            $dates insert end {(Directory)}
1762        }
1763    }
1764    foreach file [lsort -dictionary $filelist] {
1765        if {![file isdirectory $file]} {
1766            set modified [clock format [file mtime $file] -format "%T %D"]
1767            $files insert end [file tail $file]
1768            $dates insert end $modified
1769        }
1770    }
1771    $expgui(FileDirButtonMenu)  delete 0 end
1772    set list ""
1773    global tcl_version
1774    if {$tcl_version > 8.0} {
1775        catch {set list [string tolower [file volume]]}
1776    }
1777    set dir ""
1778    foreach subdir [file split [set expgui(FileMenuDir)]] {
1779        set dir [string tolower [file join $dir $subdir]]
1780        if {[lsearch $list $dir] == -1} {lappend list $dir}
1781    }
1782    foreach path $list {
1783        $expgui(FileDirButtonMenu) add command -label $path \
1784                -command "[list set expgui(FileMenuDir) $path]; \
1785                ChooseWinCnv $frm"
1786    }
1787    return
1788}
1789
1790#------------------------------------------------------------------------------
1791# set options for liveplot
1792proc liveplotopt {} {
1793    global liveplot expmap
1794    set frm .file
1795    catch {destroy $frm}
1796    toplevel $frm
1797    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1798    set last [lindex [lsort -integer $expmap(powderlist)] end]
1799    if {$last == ""} {set last 1}
1800    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
1801            -length  150 -orient horizontal -variable liveplot(hst)] -side top
1802    pack [checkbutton $frmA.2 -text {include plot legend}\
1803            -variable liveplot(legend)] -side top
1804    pack [button $frm.2 -text OK \
1805            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1806            ] -side top
1807    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1808   
1809    # force the window to stay on top
1810    putontop $frm 
1811    focus $frm.2
1812    tkwait window $frm
1813    afterputontop
1814}
1815
1816#------------------------------------------------------------------------------
1817# get an experiment file name
1818#------------------------------------------------------------------------------
1819proc getExpFileName {mode} {
1820    global expgui tcl_platform
1821    set frm .file
1822    catch {destroy $frm}
1823    toplevel $frm
1824    wm title $frm "Experiment file"
1825    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1826    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1827    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1828            -fill y -expand yes
1829    pack [button $frmC.help -text Help -bg yellow \
1830            -command "MakeWWWHelp expguierr.html open"] \
1831            -side top -anchor e
1832    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1833    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1834            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1835    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1836            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1837
1838    set expgui(includearchived) 0
1839    set expgui(FileInfoBox) $frmC.info
1840    if {$mode == "old"} {
1841        pack [checkbutton $frmC.ar -text "Include Archived Files" \
1842                -variable expgui(includearchived) \
1843                -command "ChooseExpFil $frmA"] -side top -pady 10
1844        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1845                -class SmallFont] \
1846                -side top -fill both -expand yes -pady 5
1847    } elseif {$mode != "new"} {
1848        # for initial read, don't access archived files
1849        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1850                -class SmallFont] \
1851                -side top -fill both -expand yes -pady 5
1852        set mode "old"
1853    }
1854    pack [button $frmC.b -text Read \
1855            -command "valid_exp_file $frmA $mode"] -side bottom
1856    if {$mode == "new"} {
1857        $frmC.b config -text Save
1858    }
1859    pack [button $frmC.q -text Quit \
1860            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1861    bind $frm <Return> "$frmC.b invoke"
1862
1863    if {$mode == "new"} {
1864        pack [label $frmA.0 -text "Enter an experiment file to create"] \
1865                -side top -anchor center
1866    } else {
1867        pack [label $frmA.0 -text "Select an experiment file to read"] \
1868                -side top -anchor center
1869    }
1870    expfilebox $frmA $mode
1871    # force the window to stay on top
1872    putontop $frm
1873    focus $frmC.b
1874    tkwait window $frm
1875    afterputontop
1876    if {$expgui(FileMenuEXPNAM) == ""} return
1877    # is there a space in the EXP name?
1878    if {[string first " " [file tail $expgui(FileMenuEXPNAM)]] != -1} {
1879        update
1880        MyMessageBox -parent . -title "File Name Error" \
1881            -message "File name \"$expgui(FileMenuEXPNAM)\" is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1882            -icon warning -type Continue -default continue
1883#               -helplink "expguierr.html OpenErr"
1884        return
1885    }
1886    if {[string first " " $expgui(FileMenuDir)] != -1} {
1887        update
1888        MyMessageBox -parent . -title "Good luck..." \
1889            -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@NIST.gov so they can be fixed." \
1890            -icon warning -type Continue -default continue
1891#               -helplink "expguierr.html OpenErr"
1892    }
1893    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1894}
1895
1896# validation routine
1897proc valid_exp_file {frm mode} {
1898    global expgui tcl_platform
1899    # windows fixes
1900    if {$tcl_platform(platform) == "windows"} {
1901        # change backslashes to something sensible
1902        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1903        # allow entry of D: for D:/ and D:TEST for d:/TEST
1904        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1905                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1906            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1907        }
1908    }
1909    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1910        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1911        ChooseExpFil $frm
1912        return
1913    } elseif [file isdirectory \
1914            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1915        if {$expgui(FileMenuEXPNAM) != "."} {
1916            set expgui(FileMenuDir) \
1917                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1918        }
1919        ChooseExpFil $frm
1920        return
1921    }
1922    # append a .EXP if not present
1923    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
1924        append expgui(FileMenuEXPNAM) ".EXP"
1925    }
1926    # is there a space in the name?
1927    if {[string first " " $expgui(FileMenuEXPNAM)] != -1} {
1928        MyMessageBox -parent . -title "File Name Error" \
1929                -message "File name $expgui(FileMenuEXPNAM) is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1930                -icon warning -type Continue -default continue
1931#               -helplink "expguierr.html OpenErr"
1932        return
1933    }
1934    # check for archive files
1935    if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
1936            $mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
1937        destroy .file
1938        return
1939    } elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
1940        # check for files that end in something other than .EXP .exp or .Exp...
1941        MyMessageBox -parent . -title "File Open Error" \
1942                -message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
1943                -icon error
1944        return
1945    }
1946    # check on the file status
1947    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1948    if {$mode == "new" && [file exists $file]} {
1949        set ans [
1950        MyMessageBox -parent . -title "File Open Error" \
1951                -message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
1952                -icon question -type {"Select other" "Overwrite"} -default "select other" \
1953                -helplink "expguierr.html OverwriteErr"
1954        ]
1955        if {[string tolower $ans] == "overwrite"} {destroy .file}
1956        return
1957    }
1958    # if file does not exist in case provided, set the name to all
1959    # upper case letters, since that is the best choice.
1960    # if it does exist, read from it as is. For UNIX we will force uppercase later.
1961    if {![file exists $file]} {
1962        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1963        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1964    }
1965    if {$mode == "old" && ![file exists $file]} {
1966        set ans [
1967        MyMessageBox -parent . -title "File Open Error" \
1968                -message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
1969                -icon question -type {"Select other" "Create"} -default "select other" \
1970                -helplink "expguierr.html OpenErr"
1971        ]
1972        if {[string tolower $ans] == "create"} {destroy .file}
1973        return
1974    }
1975    destroy .file
1976}
1977
1978proc updir {} {
1979    global expgui
1980    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1981}
1982
1983# create a file box
1984proc expfilebox {bx mode} {
1985    global expgui
1986    pack [frame $bx.top] -side top
1987    pack [label $bx.top.a -text "Directory" ] -side left
1988    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1989    pack $bx.top.d -side left
1990    set expgui(FileMenuDir) [pwd]
1991    # the icon below is from tk8.0/tkfbox.tcl
1992    set upfolder [image create bitmap -data {
1993#define updir_width 28
1994#define updir_height 16
1995static char updir_bits[] = {
1996   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1997   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1998   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1999   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
2000   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
2001   0xf0, 0xff, 0xff, 0x01};}]
2002
2003    pack [button $bx.top.b -image $upfolder \
2004            -command "updir; ChooseExpFil $bx" ]
2005    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2006    listbox $bx.a.files -relief raised -bd 2 \
2007            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
2008            -height 15 -width 0 -exportselection 0 
2009    listbox $bx.a.dates -relief raised -bd 2 \
2010            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
2011            -height 15 -width 0 -takefocus 0 -exportselection 0 
2012    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2013    ChooseExpFil $bx
2014    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2015    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2016    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
2017    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
2018    pack $bx.a.scroll -side left -fill y
2019    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2020    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2021}
2022proc sync2boxesX {master slave scroll args} {
2023    $slave xview moveto [lindex [$master xview] 0]
2024    eval $scroll set $args
2025}
2026proc move2boxesX {boxlist args} {
2027    foreach listbox $boxlist { 
2028        eval $listbox xview $args
2029    }
2030}
2031proc sync2boxesY {master slave scroll args} {
2032    $slave yview moveto [lindex [$master yview] 0]
2033    eval $scroll set $args
2034}
2035proc move2boxesY {boxlist args} {
2036    foreach listbox $boxlist { 
2037        eval $listbox yview $args
2038    }
2039}
2040
2041# creates a table that is scrollable in both x and y, use ResizeScrollTable
2042# to set sizes after gridding the boxes
2043proc MakeScrollTable {box} {
2044    grid [label $box.0] -column 0 -row 0
2045    grid [set tbox [canvas $box.top \
2046            -scrollregion {0 0 10 10} \
2047            -xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
2048            -width 10 -height 10]] \
2049            -sticky sew -row 0 -column 1
2050    grid [set sbox [canvas $box.side \
2051            -scrollregion {0 0 10 10} \
2052            -yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
2053            -width 10 -height 10]] \
2054            -sticky nes -row 1 -column 0
2055    grid [set bbox [canvas $box.can \
2056            -scrollregion {0 0 10 10} \
2057            -yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
2058            -xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
2059            -width 200 -height 200 -bg lightgrey]] \
2060            -sticky news -row 1 -column 1
2061    grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2062            -command "move2boxesX \" $box.can $box.top \" "]] \
2063            -sticky ew -row 2 -column 1
2064    grid [set sybox [scrollbar $box.yscroll \
2065            -command "move2boxesY \" $box.can $box.side \" "]] \
2066            -sticky ns -row 1 -column 2
2067    frame $tbox.f -bd 0
2068    $tbox create window 0 0 -anchor nw  -window $tbox.f
2069    frame $bbox.f -bd 2
2070    $bbox create window 0 0 -anchor nw  -window $bbox.f
2071    frame $sbox.f -bd 2 -relief raised
2072    $sbox create window 0 0 -anchor nw  -window $sbox.f
2073    grid columnconfig $box 1 -weight 1
2074    grid rowconfig $box 1 -weight 1
2075    return [list  $tbox.f  $bbox.f $sbox.f $box.0]
2076}
2077
2078proc ResizeScrollTable {box} {
2079    update idletasks
2080    for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2081        set x1 [lindex [grid bbox $box.can.f $i 0] 2]
2082        set x2 [lindex [grid bbox $box.top.f $i 0] 2]
2083        if {$x2 > $x1} {set x1 $x2}
2084        grid columnconfigure $box.top.f $i -minsize $x1
2085        grid columnconfigure $box.can.f $i -minsize $x1
2086    }
2087    for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2088        set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2089        set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2090        if {$x2 > $x1} {set x1 $x2}
2091        grid rowconfigure $box.can.f $i -minsize $x1
2092        grid rowconfigure $box.side.f $i -minsize $x1
2093    }
2094    update idletasks
2095    set sizes [grid bbox $box.can.f]
2096    $box.can config -scrollregion $sizes
2097    $box.side config -scrollregion $sizes
2098    $box.top config -scrollregion $sizes
2099    $box.top config -height [lindex [grid bbox $box.top.f] 3]
2100    $box.side config -width [lindex [grid bbox $box.side.f] 2]
2101}
2102proc ExpandScrollTable {box} {
2103    # set height & width of central box
2104    $box.can config -width \
2105            [expr [winfo width [winfo toplevel $box]] \
2106            - [winfo width $box.side] - [winfo width $box.yscroll]-20]
2107    $box.can config -height \
2108            [expr [winfo height [winfo toplevel $box]] \
2109            - [winfo height $box.top] - [winfo height $box.scroll]-25]
2110}
2111
2112
2113# support routine for SetHistUseFlags
2114proc InitHistUseFlags {} {
2115    global expmap expgui
2116    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2117#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2118            set expgui(useflag_$i) [histinfo $i use]
2119#       }
2120    }
2121}
2122
2123# show all Powder histograms; set use/do not use flags
2124proc SetHistUseFlags {} {
2125    set box .test
2126    catch {toplevel $box}
2127    eval destroy [winfo children $box]
2128    grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2129    grid [frame $box.a] -row 1 -column 0 -columnspan 2
2130    grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2131    grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2132    grid columnconfig $box 0 -weight 1
2133    grid columnconfig $box 1 -weight 1
2134    foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2135    $cbox config -text "Use\nFlag"
2136    [winfo parent $bbox] config -height 250 -width 400
2137    global expmap expgui
2138    set px 5
2139    set row -1
2140    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2141        if {[string range $expmap(htype_$i) 2 2] == "T"} {
2142            set det [format %8.2f [histinfo $i tofangle]]
2143        } elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2144            set det [format %8.5f [histinfo $i lam1]]
2145        } elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2146            set det [format %8.2f [histinfo $i lam1]]
2147        } else {
2148            set det {}
2149        }
2150        incr row
2151#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2152            grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0 
2153            set expgui(useflag_$i) [histinfo $i use]
2154#       }
2155        grid [label $bbox.0$i \
2156                -text [string range $expmap(htype_$i) 0 3] \
2157                ] -row $row -column 0 -padx $px
2158        grid [label $bbox.1$i -text [histinfo $i bank] \
2159                ] -row $row -column 1 -padx $px
2160        grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2161        grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2162                ] -row $row -column 3 -padx $px -sticky ew
2163    }
2164    grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2165    grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2166    grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2167    grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2168    ResizeScrollTable $box.a
2169    InitHistUseFlags
2170    putontop $box
2171    tkwait window $box
2172    afterputontop
2173    set prevchages $expgui(changed)
2174    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2175#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2176            if {$expgui(useflag_$i) != [histinfo $i use]} {
2177                histinfo $i use set $expgui(useflag_$i)
2178                incr expgui(changed)
2179            }
2180#       }
2181    }
2182    if {$prevchages != $expgui(changed)} {
2183        set msg "You have changed [expr $expgui(changed)-$prevchages] "
2184        append msg "histogram flag(s). You must run POWPREF "
2185        append msg "to include/remove these histograms. Do you want to "
2186        append msg "run POWPREF?"
2187        set ans [MyMessageBox -parent . -message $msg \
2188                -title "Process changes?"\
2189                -helplink "expguierr.html ProcessUse" \
2190                -default {Run POWPREF} \
2191                -type {{Run POWPREF} Skip}]
2192       
2193        if {$ans == "skip"} {
2194            # save and reload the experiment file
2195            savearchiveexp
2196            loadexp $expgui(expfile)
2197        } else {
2198            # run powpref and force a reload
2199            set saveautoload $expgui(autoexpload)
2200            set expgui(autoexpload) 1
2201            runGSASwEXP powpref
2202            set expgui(autoexpload) $saveautoload
2203        }
2204    }
2205}
2206
2207# set the box or file in the selection window
2208proc ReleaseExpFil {frm} {
2209    global expgui
2210    set files $frm.a.files
2211    set dates $frm.a.dates
2212    set select [$files curselection]
2213    if {$select == ""} {
2214        set select [$dates curselection]
2215    }
2216    if {$select == ""} {
2217        set expgui(FileMenuEXPNAM) ""
2218    } else {
2219        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2220        after idle UpdateInfoBox
2221    }
2222    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2223        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2224        ChooseExpFil $frm
2225    } elseif [file isdirectory \
2226            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2227        if {$expgui(FileMenuEXPNAM) != "."} {
2228            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2229            ChooseExpFil $frm
2230        }
2231    }
2232    return
2233}
2234proc UpdateInfoBox {} {
2235    global expgui
2236    if {![winfo exists $expgui(FileInfoBox)]} return
2237    eval destroy [winfo children $expgui(FileInfoBox)]
2238    set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2239    if [file isdirectory $file] return
2240    if [file exists $file] {
2241        pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2242                -side top
2243        catch {
2244            set fp [open $file r]
2245            global testline
2246            set testline [read $fp]
2247            close $fp
2248            update
2249            regexp {GNLS  RUN on (.*) +Total.*run *([0-9]+) } \
2250                    $testline a last cycles
2251            pack [label $expgui(FileInfoBox).2 -justify left \
2252                    -text "last GENLES run:\n  $last\n  total cycles: $cycles"] \
2253                -side top -anchor w
2254            regexp {REFN GDNFT.*= *([0-9]*\.[0-9]*) +for *([0-9]+) variables} \
2255                    $testline a chi2 vars
2256            pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
2257                    -side top -anchor w
2258            pack [label $expgui(FileInfoBox).3.a -justify left \
2259                    -text "c" -font symbol] \
2260                    -side left -anchor w
2261            pack [label $expgui(FileInfoBox).3.b -justify left \
2262                    -text "2: $chi2, $vars vars"] \
2263                    -side top -anchor w
2264            # check first 9 histograms
2265            set lbl "h  Rwp     R(F2)"
2266            set n 0
2267            foreach k {1 2 3 4 5 6 7 8 9} {
2268                set key "HST  $k"
2269                append key { RPOWD +([0-9]*\.[0-9]*) }
2270                set i [regexp $key $testline a Rwp]
2271                set key "HST  $k"
2272                append key { R-FAC +[0-9]+ +([0-9]*\.[0-9]*) }
2273                set j [regexp $key $testline a Rb]
2274                if {$i || $j} {
2275                    incr n
2276                    append lbl "\n$k  "
2277                    if {$i} {
2278                        append lbl [string range $Rwp 0 5]
2279                    } else {
2280                        append lbl "    "
2281                    }
2282                }
2283                if {$j} {
2284                    append lbl " [string range $Rb 0 5]"
2285                }
2286                # stick 1st 3 entries in box
2287                if {$n >= 3} break
2288            }
2289            pack [label $expgui(FileInfoBox).4 -justify left \
2290                    -text $lbl] \
2291                    -side top -anchor w     
2292        }
2293    }
2294}
2295
2296# select a file or directory -- called on double click
2297proc SelectExpFil {frm mode} {
2298    global expgui
2299    set files $frm.a.files
2300    set dates $frm.a.dates
2301    set select [$files curselection]
2302    if {$select == ""} {
2303        set select [$dates curselection]
2304    }
2305    if {$select == ""} {
2306        set file .
2307    } else {
2308        set file [string trim [$files get $select]]
2309    }
2310    if {$file == "<Parent>"} {
2311        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2312        ChooseExpFil $frm
2313    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2314        if {$file != "."} {
2315            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2316            ChooseExpFil $frm
2317        }
2318    } else {
2319        set expgui(FileMenuEXPNAM) [file tail $file]
2320        valid_exp_file $frm $mode
2321    }
2322}
2323
2324# fill the files & dates & Directory selection box with current directory,
2325# also called when box is created to fill it
2326proc ChooseExpFil {frm} {
2327    global expgui
2328    set files $frm.a.files
2329    set dates $frm.a.dates
2330    set expgui(FileMenuEXPNAM) {}
2331    $files delete 0 end
2332    $dates delete 0 end
2333    $files insert end {<Parent>}
2334    $dates insert end {(Directory)}
2335    set filelist [glob -nocomplain \
2336            [file join [set expgui(FileMenuDir)] *] ]
2337    foreach file [lsort -dictionary $filelist] {
2338        if {[file isdirectory $file]} {
2339            $files insert end [file tail $file]
2340            $dates insert end {(Directory)}
2341        }
2342    }
2343    set pairlist {}
2344    foreach file [lsort -dictionary $filelist] {
2345        if {![file isdirectory $file]  && \
2346                [string toupper [file extension $file]] == ".EXP"} {
2347            set modified [file mtime $file]
2348            lappend pairlist [list $file $modified]
2349        } elseif {![file isdirectory $file] && $expgui(includearchived) && \
2350                [string match {*.O[0-9A-F][0-9A-F]} $file]} {
2351            set modified [file mtime $file]
2352            lappend pairlist [list $file $modified]
2353        }
2354    }
2355    if {$expgui(filesort) == 0} {
2356        foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
2357            set file [lindex $pair 0]
2358            set modified [clock format [lindex $pair 1] -format "%T %D"]
2359            $files insert end [file tail $file]
2360            $dates insert end $modified
2361        }
2362    } else {
2363        foreach pair [lsort -dictionary -index 0 $pairlist] {
2364            set file [lindex $pair 0]
2365            set modified [clock format [lindex $pair 1] -format "%T %D"]
2366            $files insert end [file tail $file]
2367            $dates insert end $modified
2368        }
2369    }
2370    $expgui(FileDirButtonMenu)  delete 0 end
2371    set list ""
2372    global tcl_platform tcl_version
2373    if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2374        catch {set list [string tolower [file volume]]}
2375    }
2376    set dir ""
2377    foreach subdir [file split [set expgui(FileMenuDir)]] {
2378        set dir [file join $dir $subdir]
2379        if {$tcl_platform(platform) == "windows"} {
2380            set dir [string tolower $dir]
2381            if {[lsearch $list $dir] == -1} {lappend list $dir}
2382        } else {
2383            lappend list $dir
2384        }
2385    }
2386    foreach path $list {
2387        $expgui(FileDirButtonMenu) add command -label $path \
2388                -command "[list set expgui(FileMenuDir) $path]; \
2389                ChooseExpFil $frm"
2390    }
2391    # highlight the current experiment -- if present
2392    for {set i 0} {$i < [$files size]} {incr i} {
2393        set file [$files get $i]
2394        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2395            $files selection set $i
2396        }
2397    }
2398    return
2399}
2400
2401
2402#------------------------------------------------------------------------------
2403# platform-specific definitions
2404if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2405    # windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2406    # DOS box synchronously, so we create a "lock" file that is deleted
2407    # at the end of the DOS run so we can tell when the run is done.
2408    # We create a window to force the deleting of the file so that if
2409    # the DOS process crashes, the user can continue anyway.
2410    #
2411    # procedure to check if the lock file is still there (Win-9x/me only)
2412    proc checklockfile {file window} {
2413        if [file exists $file] {
2414            after 500 checklockfile $file $window
2415        } else {
2416            catch {destroy $window}
2417        }
2418    }
2419    # this procedure starts the GRWND program, if needed for program $prog
2420    proc StartGRWND {prog} {
2421        global expgui
2422        if {!$expgui(autoGRWND)} return
2423        # at some point we might want to have a real list
2424        if {$prog != "genles" && $prog != "powpref"} {
2425            # get a list of running jobs
2426            exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
2427            set fp [open tlist.tlist r]
2428            set text [read $fp]
2429            close $fp
2430            file delete -force tlist.tlist
2431            # if GRWND.EXE is not currently running, start it
2432            if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
2433                exec [file join $expgui(gsasexe) grwnd.exe] &
2434                # give grwnd a 1 second head start
2435                after 1000
2436            }
2437        }
2438    }
2439    # this creates a DOS box to run a program in
2440    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2441        global env expgui
2442        # Windows environment variables
2443        set env(GSAS) [file nativename $expgui(gsasdir)]
2444        # PGPLOT_FONT is needed by PGPLOT
2445        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2446        # this is the number of lines/page in the .LST (etc.) file
2447        set env(LENPAGE) 60
2448        set pwd [file nativename [pwd]]
2449       
2450        # check the .EXP path -- can DOS use it?
2451        if {[string first // [pwd]] != -1} {
2452            MyMessageBox -parent . -title "Invalid Path" \
2453                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2454                    -icon error -type ok -default ok \
2455                    -helplink "expgui_Win_readme.html NetPath"
2456            return
2457        }
2458        if {[info command winutils::shell] == "" && \
2459                [info command winexec] == ""} {
2460            MyMessageBox -parent . -title "Setup error" \
2461                -message {Error -- Use "Neither WINEXEC not WINTILS were found. Can't do anything!"} \
2462                -icon error -type darn -default darn \
2463                -helplink "expgui_Win_readme.html Winexec"
2464            return
2465        }
2466        # N. B. pause is now hard coded in the .BAT file
2467        #
2468        # loop over multiple commands
2469        foreach cmd $command {
2470            # simulate the wait with a lock file
2471            if {$wait} {
2472                if {$expgui(autoiconify)} {wm iconify .}
2473                # create a blank lock file and a message window
2474                close [open expgui.lck w]
2475                toplevel .lock
2476                grid [button .lock.0 -text Help -bg yellow \
2477                        -command "MakeWWWHelp expguierr.html lock"] \
2478                        -column 1 -row 0
2479                grid [label .lock.1 \
2480                        -text "Please wait while the GSAS program finishes."] \
2481                        -column 0 -row 0
2482                grid [label .lock.2 -text \
2483                        "In case a problem occurs, close the DOS box"] \
2484                        -column 0 -columnspan 2 -row 1
2485                grid [label .lock.3 -text \
2486                        "and press the \"Continue\" button (below)"] \
2487                        -column 0 -columnspan 2 -row 2
2488                grid [button .lock.b -text "Continue" \
2489                        -command "destroy .lock; wm deiconify ."] \
2490                        -column 0 -columnspan 2 -row 3
2491                putontop .lock
2492                update
2493                checklockfile expgui.lck .lock
2494            }
2495            # replace the forward slashes with backward
2496            regsub -all / $cmd \\ cmd
2497            if {[info command winutils::shell] != ""} {
2498                winutils::shell [file join $expgui(scriptdir) gsastcl.bat] $cmd
2499            } else {
2500                winexec -d [file nativename [pwd]] \
2501                    [file join $expgui(scriptdir) gsastcl.bat] $cmd
2502            }
2503            if {$wait} {
2504                tkwait window .lock
2505                file delete -force expgui.lck
2506            }
2507        }
2508        if {$expgui(autoiconify) && $wait} {wm deiconify .}
2509        # check for changes in the .EXP file immediately
2510        whenidle
2511    }
2512} elseif {$tcl_platform(platform) == "windows"} {
2513    # now for Windows-NT, where we can run synchronously
2514    #
2515    # this creates a DOS box to run a program in
2516    proc forknewterm {title command  "wait 1" "scrollbar 1"} {
2517        global env expgui
2518        # Windows environment variables
2519        set env(GSAS) [file nativename $expgui(gsasdir)]
2520        # PGPLOT_FONT is needed by PGPLOT
2521        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2522        # this is the number of lines/page in the .LST (etc.) file
2523        set env(LENPAGE) 60
2524        set pwd [file nativename [pwd]]
2525        # check the path -- can DOS use it?
2526        if {[string first // [pwd]] != -1} {
2527            MyMessageBox -parent . -title "Invalid Path" \
2528                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2529                    -icon error -type ok -default ok \
2530                    -helplink "expgui_Win_readme.html NetPath"
2531            return
2532        }
2533        # pause is hard coded in the .BAT file
2534
2535        if {$wait} {
2536            if {$expgui(autoiconify)} {wm iconify .}
2537            # create a blank lock file (keep liveplot from running)
2538            close [open expgui.lck w]
2539            # loop over commands
2540            foreach cmd $command {
2541                # replace the forward slashes with backward
2542                regsub -all / $cmd \\ cmd
2543                exec $env(COMSPEC) /c \
2544                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd"
2545            }
2546            file delete -force expgui.lck
2547            if {$expgui(autoiconify)} {wm deiconify .}
2548            # check for changes in the .EXP file immediately
2549            whenidle
2550        } else {
2551            # loop over commands
2552            foreach cmd $command {
2553                # replace the forward slashes with backward
2554                regsub -all / $cmd \\ cmd
2555                # run in background
2556                exec $env(COMSPEC) /c \
2557                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd" &
2558            }
2559        }
2560    }
2561} else {
2562    # this creates a xterm window to run a program in
2563    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2564        global env expgui
2565        # UNIX environment variables
2566        set env(GSAS) [file nativename $expgui(gsasdir)]
2567        set env(gsas) [file nativename $expgui(gsasdir)]
2568        set env(GSASEXE) $expgui(gsasexe)
2569        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2570        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2571        # PGPLOT_DIR is needed by PGPLOT
2572        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2573        # this is the number of lines/page in the .LST (etc.) file
2574        set env(LENPAGE) 60
2575        set termopts {}
2576        if $env(GSASBACKSPACE) {
2577            append termopts \
2578                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2579        }
2580        if $scrollbar {
2581            append termopts " -sb"
2582        } else {
2583            append termopts " +sb"
2584        }
2585        if {$wait} {
2586            set suffix {}
2587        } else {
2588            set suffix {&}
2589        }
2590        #
2591        #if $wait {
2592            append command "\; echo -n Press Enter to continue \; read x"
2593        #}
2594        if {$wait && $expgui(autoiconify)} {wm iconify .}
2595        catch {eval exec xterm $termopts -title [list $title] \
2596                -e /bin/sh -c [list $command] $suffix} errmsg
2597        if $expgui(debug) {puts "xterm result = $errmsg"}
2598        if {$wait} {
2599            if {$expgui(autoiconify)} {wm deiconify .}
2600            # check for changes in the .EXP file immediately
2601            whenidle
2602        }
2603    }
2604}
2605
2606# modify resource fork info for a .EXP file on the Mac
2607proc MacSetResourceFork {expfile} {
2608    global expgui tcl_platform
2609    if {$tcl_platform(os) != "Darwin"} {return}
2610    set expnative [file nativename $expfile]
2611    #
2612    # assign an app to the data file, if the app and the
2613    # required tool (Rez) are installed
2614    set app [file join $expgui(gsasdir) expgui.app]
2615    if {[file exists /Developer/Tools/Rez]} {
2616        set RezApp /Developer/Tools/Rez
2617    } elseif {[file exists [file join $expgui(gsasdir) Rez]]} {
2618        set RezApp [file join $expgui(gsasdir) Rez]
2619    } else {
2620        set RezApp {}
2621    }
2622    if {[file exists /Developer/Tools/SetFile]} {
2623        set SetFileApp /Developer/Tools/SetFile
2624    } elseif {[file exists [file join $expgui(gsasdir) SetFile]]} {
2625        set SetFileApp [file join $expgui(gsasdir) SetFile]
2626    } else {
2627        set SetFileApp {}
2628    }
2629    if {[file exists $app] && $RezApp != ""} {
2630        # make a resource file
2631        set l [string length $app]; incr l
2632        set str "data 'usro' (0) {\n"
2633        append str {  $"}
2634        append str [format %.8X $l]
2635        foreach char [split $app {}] {
2636           append str [format %.2X [scan $char %c]]   
2637        }
2638        append str {00"}
2639        append str " \t/* ....$app. */\n};"
2640        set fp [open setapp.r w]
2641        puts $fp $str
2642        close $fp
2643        exec $RezApp setapp.r -o $expnative -a
2644        file delete -force setapp.r
2645    }
2646
2647    # assign an icon to the data file, if it and the required tools exist
2648    set icon [file join $expgui(gsasdir) gsasicon.r]
2649    if {[file exists $icon] && $RezApp != "" && $SetFileApp != ""} {
2650        exec $RezApp [file nativename $icon] -o $expnative -a
2651        exec $SetFileApp -a C $expnative
2652    }
2653}
Note: See TracBrowser for help on using the repository browser.