source: trunk/gsascmds.tcl @ 783

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

# on 2004/04/27 14:12:04, toby did:
update non-modal dialogs to match newer versions of Tk
add window resize for OS X

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