source: trunk/gsascmds.tcl @ 805

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

# on 2004/09/20 15:32:20, toby did:
force all output to instfile to be in ASCII

this might solve bugs where non-ascii chars invalidate .EXP file

  • Property rcs:author set to toby
  • Property rcs:date set to 2004/09/20 15:32:20
  • Property rcs:lines set to +2 -2
  • Property rcs:rev set to 1.58
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 86.5 KB
Line 
1# $Id: gsascmds.tcl 805 2009-12-04 23:12:20Z 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    # Save the current exp file
1121    savearchiveexp
1122    # disable the file change monitor if we will reload the .EXP file automatically
1123    if {$expgui(autoexpload)} {set expgui(expModifiedLast) 0}
1124    if {$expgui(autoiconify)} {wm iconify .}
1125    exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1126            $expnam $hst $liveplot(legend)
1127    if {$expgui(autoiconify)} {wm deiconify .}
1128    # load the changed .EXP file automatically?
1129    if {$expgui(autoexpload)} {
1130        # load the revised exp file
1131        loadexp $expgui(expfile)
1132    } else {
1133        # check for changes in the .EXP file immediately
1134        whenidle
1135    }
1136}
1137
1138# run excledt
1139proc excledit {} {
1140    global expgui liveplot wishshell expmap
1141    set expnam [file root [file tail $expgui(expfile)]]
1142    # which histograms are ready for use?
1143    set validlist {}
1144    foreach ihist $expmap(powderlist) {
1145        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1146                [string range $expmap(htype_$ihist) 3 3] == "*" || \
1147                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1148            lappend validlist $ihist
1149        }
1150    }
1151    if {[llength $validlist] == 0} {
1152        MyMessageBox -parent . -title "No Valid Histograms" \
1153                -message "No histograms are ready to plot. Run POWPREF and try again" \
1154                -icon warning -helplink "expguierr.html NoValidHist"
1155        return
1156    }
1157    #if {$expgui(autoiconify)} {wm iconify .}
1158    StartExcl 
1159    #if {$expgui(autoiconify)} {wm deiconify .}
1160}
1161
1162# compute the composition for each phase and display in a dialog
1163proc composition {} {
1164    global expmap expgui
1165    set Z 1
1166    foreach phase $expmap(phaselist) type $expmap(phasetype) {
1167        if {$type > 2} continue
1168        catch {unset total}
1169        foreach atom $expmap(atomlist_$phase) {
1170            set type [atominfo $phase $atom type]
1171            set mult [atominfo $phase $atom mult]
1172            if [catch {set total($type)}] {
1173                set total($type) [expr \
1174                        $mult * [atominfo $phase $atom frac]]
1175            } else {
1176                set total($type) [expr $total($type) + \
1177                        $mult * [atominfo $phase $atom frac]]
1178            }
1179            if {$mult > $Z} {set Z $mult}
1180        }
1181        append text "\nPhase $phase\n"
1182        append text "  Unit cell contents\n"
1183        foreach type [lsort [array names total]] {
1184            append text "   $type[format %8.3f $total($type)]"
1185        }
1186        append text "\n\n"
1187       
1188        append text "  Asymmetric Unit contents (Z=$Z)\n"
1189        foreach type [lsort [array names total]] {
1190            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
1191        }
1192        append text "\n"
1193    }
1194   
1195    catch {destroy .comp}
1196    toplevel .comp -class MonoSpc
1197    bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1198    wm title .comp Composition
1199    pack [label .comp.results -text $text \
1200            -justify left] -side top
1201    pack [frame .comp.box]  -side top -expand y -fill x
1202    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1203
1204    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1205    pack [button .comp.box.2 -text "Save to $lstnam file" \
1206            -command "writelst [list $text] ; destroy .comp"] -side left
1207    pack [button .comp.box.help -text Help -bg yellow \
1208            -command "MakeWWWHelp expgui.html Composition"] \
1209            -side right
1210}
1211
1212# Delete History Records
1213proc DeleteHistoryRecords {{msg ""}} {
1214    global expgui
1215    set frm .history
1216    catch {destroy $frm}
1217    toplevel $frm
1218    bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1219    if {[string trim $msg] == ""} {
1220        set msg "There are [CountHistory] history records"
1221    }
1222    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1223    pack [label $frm.1.0 -text $msg] -side top
1224    pack [frame $frm.1.1] -side top
1225    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1226    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1227            ] -side left
1228    set expgui(historyKeep) 10
1229    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1230    set expgui(renumber) 1
1231    pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1232    pack [button $frm.2.help -text Help -bg yellow \
1233            -command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1234    pack [button $frm.2.4 -text Quit \
1235            -command {destroy .history}] -side bottom
1236    pack [button $frm.2.3 -text OK \
1237            -command { 
1238        if ![catch {expr $expgui(historyKeep)}] {
1239            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1240            set expgui(changed) 1
1241            destroy .history
1242        }
1243    }] -side bottom
1244    bind $frm <Return> "$frm.2.3 invoke"
1245   
1246    # force the window to stay on top
1247    putontop $frm 
1248    focus $frm.2.3
1249    tkwait window $frm
1250    afterputontop
1251}
1252
1253proc archiveexp {} {
1254    global expgui tcl_platform
1255    # is there a file to archive?
1256    if {![file exists $expgui(expfile)]} return
1257    set expnam [file rootname $expgui(expfile)]
1258    # get the last archived version
1259    set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1260    if {$lastf == ""} {
1261        set num 01
1262    } else {
1263        regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1264        scan $num %x num
1265        if {$num >= 255} {
1266            set num FF
1267        } else {
1268            set num [string toupper [format %.2x [incr num]]]
1269        }
1270    }
1271    catch {
1272        set file $expnam.O$num
1273        file copy -force $expgui(expfile) $file
1274        set fp [open $expnam.LST a+]
1275        puts $fp "\n----------------------------------------------"
1276        puts $fp "     Archiving [file tail $expnam.EXP] as [file tail $file]"
1277        puts $fp "----------------------------------------------\n"
1278        close $fp
1279    } errmsg
1280    if {$errmsg != ""} {
1281        tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1282    }
1283}
1284
1285# save and optionally archive the expfile
1286proc savearchiveexp {} {
1287    global expgui expmap
1288    if {$expgui(expfile) == ""} {
1289        SaveAsFile
1290        return
1291    }
1292    if !$expgui(changed) return
1293    if {$expgui(archive)} archiveexp
1294    # add a history record
1295    exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds] -format {%D %T}]"
1296    # now save the file
1297    expwrite $expgui(expfile)
1298    # change the icon and assign an app to this .EXP file
1299    global tcl_platform
1300    if {$tcl_platform(os) == "Darwin" && $expgui(MacAssignApp)} {
1301        MacSetResourceFork $expgui(expfile)
1302    }
1303    set expgui(changed) 0
1304    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1305    set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1306    wm title . $expgui(expfile)
1307    set expgui(titleunchanged) 1
1308    # set convergence criterion
1309    InitLSvars
1310}
1311
1312#------------------------------------------------------------------------------
1313# GSAS interface routines
1314#------------------------------------------------------------------------------
1315# run a GSAS program that does not require an experiment file
1316proc runGSASprog {proglist "concurrent 1"} {
1317    # if concurrent is 0, EXPGUI runs the GSAS program in background
1318    # -- this is not currently needed anywhere where the .EXP file is not.
1319    global expgui tcl_platform
1320    set cmd {}
1321    foreach prog $proglist {
1322        StartGRWND $prog
1323        if {$tcl_platform(platform) == "windows"} {
1324            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1325        } else {
1326            if {$cmd != ""} {append cmd "\;"}
1327            append cmd "[file join $expgui(gsasexe) $prog]"
1328        }
1329    }
1330    forknewterm $prog $cmd [expr !$concurrent] 1
1331}
1332
1333# dummy routine, overridden if needed
1334proc StartGRWND {prog} {
1335}
1336
1337# run a GSAS program that requires an experiment file for input/output
1338proc runGSASwEXP {proglist "concurrent 0"} {
1339    # most programs that require the .EXP file change it and
1340    # cannot be run concurrently
1341    global expgui tcl_platform
1342    # Save the current exp file
1343    savearchiveexp
1344    # load the changed .EXP file automatically?
1345    if {$expgui(autoexpload)} {
1346        # disable the file changed monitor
1347        set expgui(expModifiedLast) 0
1348    }
1349    set cmd {}
1350    set expnam [file root [file tail $expgui(expfile)]]
1351    foreach prog $proglist {
1352        if {$prog == "powpref"} {
1353            set expgui(needpowpref) 0
1354            set expgui(needpowpref_why) ""
1355        } elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1356            set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1357            set ans [MyMessageBox -parent . -title "Run POWPREF" \
1358                    -message $msg -icon warning -type "Yes No" -default yes \
1359                    -helplink "expguierr.html RunPowpref"]
1360            if {$ans == "yes"} {
1361                set expgui(needpowpref) 0
1362                set expgui(needpowpref_why) ""
1363                if {$tcl_platform(platform) == "windows"} {
1364                    append cmd " \"$expgui(gsasexe)/powpref.exe $expnam \" "
1365                } else {
1366                    if {$cmd != ""} {append cmd "\;"}
1367                    append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1368                }
1369            }
1370        }
1371        StartGRWND $prog
1372        if {$tcl_platform(platform) == "windows"} {
1373            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1374        } else {
1375            if {$cmd != ""} {append cmd "\;"}
1376            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1377        }
1378    }
1379    forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1380    # load the changed .EXP file automatically?
1381    if {$expgui(autoexpload)} {
1382        # load the revised exp file
1383        loadexp $expgui(expfile)
1384    }
1385}
1386
1387# write text to the .LST file
1388proc writelst {text} {
1389    global expgui
1390    set lstnam [file rootname $expgui(expfile)].LST
1391    set fp [open $lstnam a]
1392    puts $fp "\n-----------------------------------------------------------------"
1393    puts $fp $text
1394    puts $fp "-----------------------------------------------------------------\n"
1395    close $fp
1396}
1397
1398
1399# rename file current to suggested,
1400#   delete window if supplied
1401#   use parent, if supplied or .
1402proc RenameAsFile {current suggested "window {}" "parent {}"} {
1403    if {$parent == "" && $window != ""} {set parent $window}
1404    if {$parent == ""} {set parent .}
1405    set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1406    if {$newfile == ""} return
1407    if {[catch {
1408        file rename -force $current $newfile
1409    }]} {
1410        file copy -force $current $newfile
1411        file delete -force $current
1412    }
1413    if {$window != ""} {destroy $window}
1414}
1415
1416# optionally run disagl as a windowless process, w/results in a separate window
1417proc rundisagl {} {
1418    global expgui txtvw tcl_version tcl_platform
1419    if {$expgui(disaglSeparateBox)} {
1420        set root [file root $expgui(expfile)] 
1421        catch {file delete -force $root.tmp}
1422        if {[catch {file rename -force $root.LST $root.OLS}]} {
1423            file copy -force $root.LST $root.OLS
1424            file delete -force $root.OLS
1425        }
1426        # PSW reports this does not happen right away on windows
1427        set i 0
1428        while {$i < 10 && [file exists $root.LST]} {
1429            # debug code
1430            #catch {console show}
1431            #puts "try $i"
1432            # end debug code
1433            after 100
1434            incr i
1435        }
1436        if {[file exists $root.LST]} {
1437            # it was not possible to rename the file
1438            MyMessageBox -parent . -title "Rename Problem" \
1439                -message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1440                -icon warning -helplink "expguierr.html NoRename"
1441            return
1442        }
1443
1444        #run the program
1445        pleasewait "Running DISAGL"     
1446        # create an empty input file
1447        close [open disagl.inp w]
1448        catch {exec [file join $expgui(gsasexe) disagl] \
1449                [file tail $root] < disagl.inp > disagl.out}
1450        if {[catch {file rename -force $root.LST $root.tmp}]} {
1451            file copy -force $root.LST $root.tmp
1452            file delete -force $root.LST
1453        }
1454        catch {file delete -force disagl.inp disagl.out}
1455        if {[catch {file rename -force $root.OLS $root.LST}]} {
1456            file copy -force $root.OLS $root.LST
1457            file delete -force $root.OLS
1458        }
1459        donewait
1460        # open a new window
1461        catch {toplevel .disagl}
1462        catch {eval grid forget [grid slaves .disagl]}
1463        text .disagl.txt -width 100 -wrap none \
1464                -yscrollcommand ".disagl.yscroll set" \
1465                -xscrollcommand ".disagl.xscroll set" 
1466        scrollbar .disagl.yscroll -command ".disagl.txt yview"
1467        scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1468        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1469        grid .disagl.txt -column 0 -row 1 -sticky nsew
1470        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1471        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1472        grid columnconfig .disagl.f 2 -weight 1
1473        grid [button .disagl.f.close -text "Close & Delete" \
1474                -command "destroy .disagl; file delete $root.tmp"] \
1475                -column 3 -row 0 -sticky e
1476        grid [button .disagl.f.rename \
1477                -command "RenameAsFile $root.tmp $root.DIS .disagl" \
1478                -text "Close & Save as..."] \
1479                -column 4 -row 0 -sticky e
1480        # allow font changes on the fly
1481        if {$tcl_version >= 8.0} {
1482            .disagl.txt config -font $txtvw(font)
1483            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1484            grid .disagl.f.font -column 1 -row 0 -sticky w
1485            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1486            $fontbut delete 0 end
1487            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1488                $fontbut add command -label "Courier $f" -font "Courier $f"\
1489                        -command "set txtvw(font) \"Courier $f\"; \
1490                        .disagl.txt config -font \$txtvw(font)"
1491            }
1492        }
1493       
1494        grid columnconfigure .disagl 0 -weight 1
1495        grid rowconfigure .disagl 1 -weight 1
1496        wm title .disagl "DISAGL results $expgui(expfile)"
1497        wm iconname .disagl "DISAGL $root"
1498        set in [open $root.tmp r]
1499        .disagl.txt insert end [read $in]
1500        close $in
1501        bind all  {destroy .disagl}
1502        bind .disagl  ".disagl.txt yview scroll -1 page"
1503        bind .disagl  ".disagl.txt yview scroll 1 page"
1504        bind .disagl  ".disagl.txt xview scroll 1 unit"
1505        bind .disagl  ".disagl.txt xview scroll -1 unit"
1506        bind .disagl  ".disagl.txt yview scroll -1 unit"
1507        bind .disagl  ".disagl.txt yview scroll 1 unit"
1508        bind .disagl  ".disagl.txt yview 0"
1509        bind .disagl  ".disagl.txt yview end"
1510        # don't disable in Win as this prevents the highlighting of selected text
1511        if {$tcl_platform(platform) != "windows"} {
1512            .disagl.txt config -state disabled
1513        }
1514    } else {
1515        runGSASwEXP disagl
1516    }
1517}
1518
1519#------------------------------------------------------------------------------
1520# file conversions
1521#------------------------------------------------------------------------------
1522proc convfile {} {
1523    global expgui
1524    set frm .file
1525    catch {destroy $frm}
1526    toplevel $frm
1527    wm title $frm "Convert File"
1528    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1529    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1530    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1531            -side left -fill y -expand yes
1532    pack [button $frmC.help -text Help -bg yellow \
1533            -command "MakeWWWHelp expgui.html ConvertWin"] -side top
1534    pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1535    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1536            -side bottom
1537    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1538    winfilebox $frm
1539    bind $frm <Return> "ValidWinCnv $frm"
1540
1541    # force the window to stay on top
1542    putontop $frm
1543    focus $frmC.q 
1544    tkwait window $frm
1545    afterputontop
1546}
1547
1548# validate the files and make the conversion
1549proc ValidWinCnv {frm} {
1550    global expgui
1551    # change backslashes to something sensible
1552    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1553    # allow entry of D: for D:/ and D:TEST for d:/TEST
1554    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1555            [string first :/ $expgui(FileMenuCnvName)] == -1} {
1556        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1557    }
1558    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1559        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1560        ChooseWinCnv $frm
1561        return
1562    } elseif [file isdirectory \
1563            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1564        if {$expgui(FileMenuCnvName) != "."} {
1565            set expgui(FileMenuDir) \
1566                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1567        }
1568        ChooseWinCnv $frm
1569        return
1570    }
1571 
1572    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1573    if ![file exists $file] {
1574        MyMessageBox -parent $frm -title "Convert Error" \
1575                -message "File $file does not exist" -icon error
1576        return
1577    }
1578
1579    set tmpname "[file join [file dirname $file] tempfile.xxx]"
1580    set oldname "[file rootname $file].org"
1581    if [file exists $oldname] {
1582        set ans [MyMessageBox -parent . -title "Overwrite?" \
1583                -message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1584                -icon warning -type {Overwrite Cancel} -default Overwrite \
1585                -helplink "expguierr.html OverwriteCnv"]
1586        if {[string tolower $ans] == "cancel"} return
1587        catch {file delete $oldname}
1588    }
1589
1590    if [catch {
1591        set in [open $file r]
1592        set out [open $tmpname w]
1593        fconfigure $out -translation crlf -encoding ascii
1594        set len [gets $in line]
1595        if {$len > 160} {
1596            # this is a UNIX file. Hope there are no control characters
1597            set i 0
1598            set j 79
1599            while {$j < $len} {
1600                puts $out [string range $line $i $j]
1601                incr i 80
1602                incr j 80
1603            }
1604        } else {
1605            while {$len >= 0} {
1606                append line "                                        "
1607                append line "                                        "
1608                set line [string range $line 0 79]
1609                puts $out $line
1610                set len [gets $in line]
1611            }
1612        }
1613        close $in
1614        close $out
1615        file rename -force $file $oldname
1616        file rename -force $tmpname $file
1617    } errmsg] {
1618        MyMessageBox -parent $frm -title "Conversion error" \
1619                -message "Error in conversion:\n$errmsg" -icon warning
1620    } else {
1621        set ans [MyMessageBox -parent $frm -title "More?" \
1622                -message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1623                -type yesno -default no]
1624        if {$ans == "no"} {destroy $frm}
1625    }
1626}
1627
1628# create a file box
1629proc winfilebox {frm} {
1630    global expgui
1631    set bx $frm.1
1632    pack [frame $bx.top] -side top
1633    pack [label $bx.top.a -text "Directory" ] -side left
1634    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1635    pack $bx.top.d -side left
1636    set expgui(FileMenuDir) [pwd]
1637    # the icon below is from tk8.0/tkfbox.tcl
1638    set upfolder [image create bitmap -data {
1639#define updir_width 28
1640#define updir_height 16
1641static char updir_bits[] = {
1642   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1643   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1644   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1645   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1646   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1647   0xf0, 0xff, 0xff, 0x01};}]
1648
1649    pack [button $bx.top.b -image $upfolder \
1650            -command "updir; ChooseWinCnv $frm" ]
1651    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1652    listbox $bx.a.files -relief raised -bd 2 \
1653            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1654            -height 15 -width 0 -exportselection 0 
1655    listbox $bx.a.dates -relief raised -bd 2 \
1656            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1657            -height 15 -width 0 -takefocus 0 -exportselection 0 
1658    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1659    ChooseWinCnv $frm
1660    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1661    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1662    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1663    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1664    pack $bx.a.scroll -side left -fill y
1665    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1666    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1667}
1668
1669# set the box or file in the selection window
1670proc ReleaseWinCnv {frm} {
1671    global expgui
1672    set files $frm.1.a.files
1673    set dates $frm.1.a.dates
1674    set select [$files curselection]
1675    if {$select == ""} {
1676        set select [$dates curselection]
1677    }
1678    if {$select == ""} {
1679        set expgui(FileMenuCnvName) ""
1680    } else {
1681        set expgui(FileMenuCnvName) [string trim [$files get $select]]
1682    }
1683    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1684        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1685        ChooseWinCnv $frm
1686    } elseif [file isdirectory \
1687            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1688        if {$expgui(FileMenuCnvName) != "."} {
1689            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1690            ChooseWinCnv $frm
1691        }
1692    }
1693    return
1694}
1695
1696# select a file or directory -- called on double click
1697proc SelectWinCnv {frm} {
1698    global expgui
1699    set files $frm.1.a.files
1700    set dates $frm.1.a.dates
1701    set select [$files curselection]
1702    if {$select == ""} {
1703        set select [$dates curselection]
1704    }
1705    if {$select == ""} {
1706        set file .
1707    } else {
1708        set file [string trim [$files get $select]]
1709    }
1710    if {$file == "<Parent>"} {
1711        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1712        ChooseWinCnv $frm
1713    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1714        if {$file != "."} {
1715            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1716            ChooseWinCnv $frm
1717        }
1718    } else {
1719        set expgui(FileMenuCnvName) [file tail $file]
1720        ValidWinCnv $frm
1721    }
1722}
1723
1724# fill the files & dates & Directory selection box with current directory,
1725# also called when box is created to fill it
1726proc ChooseWinCnv {frm} {
1727    global expgui
1728    set files $frm.1.a.files
1729    set dates $frm.1.a.dates
1730    set expgui(FileMenuCnvName) {}
1731    $files delete 0 end
1732    $dates delete 0 end
1733    $files insert end {<Parent>}
1734    $dates insert end {(Directory)}
1735    set filelist [glob -nocomplain \
1736            [file join [set expgui(FileMenuDir)] *] ]
1737    foreach file [lsort -dictionary $filelist] {
1738        if {[file isdirectory $file]} {
1739            $files insert end [file tail $file]
1740            $dates insert end {(Directory)}
1741        }
1742    }
1743    foreach file [lsort -dictionary $filelist] {
1744        if {![file isdirectory $file]} {
1745            set modified [clock format [file mtime $file] -format "%T %D"]
1746            $files insert end [file tail $file]
1747            $dates insert end $modified
1748        }
1749    }
1750    $expgui(FileDirButtonMenu)  delete 0 end
1751    set list ""
1752    global tcl_version
1753    if {$tcl_version > 8.0} {
1754        catch {set list [string tolower [file volume]]}
1755    }
1756    set dir ""
1757    foreach subdir [file split [set expgui(FileMenuDir)]] {
1758        set dir [string tolower [file join $dir $subdir]]
1759        if {[lsearch $list $dir] == -1} {lappend list $dir}
1760    }
1761    foreach path $list {
1762        $expgui(FileDirButtonMenu) add command -label $path \
1763                -command "[list set expgui(FileMenuDir) $path]; \
1764                ChooseWinCnv $frm"
1765    }
1766    return
1767}
1768
1769#------------------------------------------------------------------------------
1770# set options for liveplot
1771proc liveplotopt {} {
1772    global liveplot expmap
1773    set frm .file
1774    catch {destroy $frm}
1775    toplevel $frm
1776    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1777    set last [lindex [lsort -integer $expmap(powderlist)] end]
1778    if {$last == ""} {set last 1}
1779    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
1780            -length  150 -orient horizontal -variable liveplot(hst)] -side top
1781    pack [checkbutton $frmA.2 -text {include plot legend}\
1782            -variable liveplot(legend)] -side top
1783    pack [button $frm.2 -text OK \
1784            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1785            ] -side top
1786    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1787   
1788    # force the window to stay on top
1789    putontop $frm 
1790    focus $frm.2
1791    tkwait window $frm
1792    afterputontop
1793}
1794
1795#------------------------------------------------------------------------------
1796# get an experiment file name
1797#------------------------------------------------------------------------------
1798proc getExpFileName {mode} {
1799    global expgui tcl_platform
1800    set frm .file
1801    catch {destroy $frm}
1802    toplevel $frm
1803    wm title $frm "Experiment file"
1804    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1805    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1806    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1807            -fill y -expand yes
1808    pack [button $frmC.help -text Help -bg yellow \
1809            -command "MakeWWWHelp expguierr.html open"] \
1810            -side top -anchor e
1811    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1812    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1813            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1814    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1815            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1816
1817    set expgui(includearchived) 0
1818    set expgui(FileInfoBox) $frmC.info
1819    if {$mode == "old"} {
1820        pack [checkbutton $frmC.ar -text "Include Archived Files" \
1821                -variable expgui(includearchived) \
1822                -command "ChooseExpFil $frmA"] -side top -pady 10
1823        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1824                -class SmallFont] \
1825                -side top -fill both -expand yes -pady 5
1826    } elseif {$mode != "new"} {
1827        # for initial read, don't access archived files
1828        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1829                -class SmallFont] \
1830                -side top -fill both -expand yes -pady 5
1831        set mode "old"
1832    }
1833    pack [button $frmC.b -text Read \
1834            -command "valid_exp_file $frmA $mode"] -side bottom
1835    if {$mode == "new"} {
1836        $frmC.b config -text Save
1837    }
1838    pack [button $frmC.q -text Quit \
1839            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1840    bind $frm <Return> "$frmC.b invoke"
1841
1842    if {$mode == "new"} {
1843        pack [label $frmA.0 -text "Enter an experiment file to create"] \
1844                -side top -anchor center
1845    } else {
1846        pack [label $frmA.0 -text "Select an experiment file to read"] \
1847                -side top -anchor center
1848    }
1849    expfilebox $frmA $mode
1850    # force the window to stay on top
1851    putontop $frm
1852    focus $frmC.b
1853    tkwait window $frm
1854    afterputontop
1855    if {$expgui(FileMenuEXPNAM) == ""} return
1856    # is there a space in the EXP name?
1857    if {[string first " " [file tail $expgui(FileMenuEXPNAM)]] != -1} {
1858        update
1859        MyMessageBox -parent . -title "File Name Error" \
1860            -message "File name \"$expgui(FileMenuEXPNAM)\" is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1861            -icon warning -type Continue -default continue
1862#               -helplink "expguierr.html OpenErr"
1863        return
1864    }
1865    if {[string first " " $expgui(FileMenuDir)] != -1} {
1866        update
1867        MyMessageBox -parent . -title "Good luck..." \
1868            -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." \
1869            -icon warning -type Continue -default continue
1870#               -helplink "expguierr.html OpenErr"
1871    }
1872    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1873}
1874
1875# validation routine
1876proc valid_exp_file {frm mode} {
1877    global expgui tcl_platform
1878    # windows fixes
1879    if {$tcl_platform(platform) == "windows"} {
1880        # change backslashes to something sensible
1881        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1882        # allow entry of D: for D:/ and D:TEST for d:/TEST
1883        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1884                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1885            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1886        }
1887    }
1888    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1889        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1890        ChooseExpFil $frm
1891        return
1892    } elseif [file isdirectory \
1893            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1894        if {$expgui(FileMenuEXPNAM) != "."} {
1895            set expgui(FileMenuDir) \
1896                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1897        }
1898        ChooseExpFil $frm
1899        return
1900    }
1901    # append a .EXP if not present
1902    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
1903        append expgui(FileMenuEXPNAM) ".EXP"
1904    }
1905    # is there a space in the name?
1906    if {[string first " " $expgui(FileMenuEXPNAM)] != -1} {
1907        MyMessageBox -parent . -title "File Name Error" \
1908                -message "File name $expgui(FileMenuEXPNAM) is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1909                -icon warning -type Continue -default continue
1910#               -helplink "expguierr.html OpenErr"
1911        return
1912    }
1913    # check for archive files
1914    if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
1915            $mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
1916        destroy .file
1917        return
1918    } elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
1919        # check for files that end in something other than .EXP .exp or .Exp...
1920        MyMessageBox -parent . -title "File Open Error" \
1921                -message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
1922                -icon error
1923        return
1924    }
1925    # check on the file status
1926    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1927    if {$mode == "new" && [file exists $file]} {
1928        set ans [
1929        MyMessageBox -parent . -title "File Open Error" \
1930                -message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
1931                -icon question -type {"Select other" "Overwrite"} -default "select other" \
1932                -helplink "expguierr.html OverwriteErr"
1933        ]
1934        if {[string tolower $ans] == "overwrite"} {destroy .file}
1935        return
1936    }
1937    # if file does not exist in case provided, set the name to all
1938    # upper case letters, since that is the best choice.
1939    # if it does exist, read from it as is. For UNIX we will force uppercase later.
1940    if {![file exists $file]} {
1941        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1942        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1943    }
1944    if {$mode == "old" && ![file exists $file]} {
1945        set ans [
1946        MyMessageBox -parent . -title "File Open Error" \
1947                -message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
1948                -icon question -type {"Select other" "Create"} -default "select other" \
1949                -helplink "expguierr.html OpenErr"
1950        ]
1951        if {[string tolower $ans] == "create"} {destroy .file}
1952        return
1953    }
1954    destroy .file
1955}
1956
1957proc updir {} {
1958    global expgui
1959    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1960}
1961
1962# create a file box
1963proc expfilebox {bx mode} {
1964    global expgui
1965    pack [frame $bx.top] -side top
1966    pack [label $bx.top.a -text "Directory" ] -side left
1967    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1968    pack $bx.top.d -side left
1969    set expgui(FileMenuDir) [pwd]
1970    # the icon below is from tk8.0/tkfbox.tcl
1971    set upfolder [image create bitmap -data {
1972#define updir_width 28
1973#define updir_height 16
1974static char updir_bits[] = {
1975   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1976   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1977   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1978   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1979   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1980   0xf0, 0xff, 0xff, 0x01};}]
1981
1982    pack [button $bx.top.b -image $upfolder \
1983            -command "updir; ChooseExpFil $bx" ]
1984    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1985    listbox $bx.a.files -relief raised -bd 2 \
1986            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1987            -height 15 -width 0 -exportselection 0 
1988    listbox $bx.a.dates -relief raised -bd 2 \
1989            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1990            -height 15 -width 0 -takefocus 0 -exportselection 0 
1991    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1992    ChooseExpFil $bx
1993    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1994    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1995    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1996    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1997    pack $bx.a.scroll -side left -fill y
1998    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1999    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2000}
2001proc sync2boxesX {master slave scroll args} {
2002    $slave xview moveto [lindex [$master xview] 0]
2003    eval $scroll set $args
2004}
2005proc move2boxesX {boxlist args} {
2006    foreach listbox $boxlist { 
2007        eval $listbox xview $args
2008    }
2009}
2010proc sync2boxesY {master slave scroll args} {
2011    $slave yview moveto [lindex [$master yview] 0]
2012    eval $scroll set $args
2013}
2014proc move2boxesY {boxlist args} {
2015    foreach listbox $boxlist { 
2016        eval $listbox yview $args
2017    }
2018}
2019
2020# creates a table that is scrollable in both x and y, use ResizeScrollTable
2021# to set sizes after gridding the boxes
2022proc MakeScrollTable {box} {
2023    grid [label $box.0] -column 0 -row 0
2024    grid [set tbox [canvas $box.top \
2025            -scrollregion {0 0 10 10} \
2026            -xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
2027            -width 10 -height 10]] \
2028            -sticky sew -row 0 -column 1
2029    grid [set sbox [canvas $box.side \
2030            -scrollregion {0 0 10 10} \
2031            -yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
2032            -width 10 -height 10]] \
2033            -sticky nes -row 1 -column 0
2034    grid [set bbox [canvas $box.can \
2035            -scrollregion {0 0 10 10} \
2036            -yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
2037            -xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
2038            -width 200 -height 200 -bg lightgrey]] \
2039            -sticky news -row 1 -column 1
2040    grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2041            -command "move2boxesX \" $box.can $box.top \" "]] \
2042            -sticky ew -row 2 -column 1
2043    grid [set sybox [scrollbar $box.yscroll \
2044            -command "move2boxesY \" $box.can $box.side \" "]] \
2045            -sticky ns -row 1 -column 2
2046    frame $tbox.f -bd 0
2047    $tbox create window 0 0 -anchor nw  -window $tbox.f
2048    frame $bbox.f -bd 2
2049    $bbox create window 0 0 -anchor nw  -window $bbox.f
2050    frame $sbox.f -bd 2 -relief raised
2051    $sbox create window 0 0 -anchor nw  -window $sbox.f
2052    grid columnconfig $box 1 -weight 1
2053    grid rowconfig $box 1 -weight 1
2054    return [list  $tbox.f  $bbox.f $sbox.f $box.0]
2055}
2056
2057proc ResizeScrollTable {box} {
2058    update idletasks
2059    for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2060        set x1 [lindex [grid bbox $box.can.f $i 0] 2]
2061        set x2 [lindex [grid bbox $box.top.f $i 0] 2]
2062        if {$x2 > $x1} {set x1 $x2}
2063        grid columnconfigure $box.top.f $i -minsize $x1
2064        grid columnconfigure $box.can.f $i -minsize $x1
2065    }
2066    for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2067        set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2068        set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2069        if {$x2 > $x1} {set x1 $x2}
2070        grid rowconfigure $box.can.f $i -minsize $x1
2071        grid rowconfigure $box.side.f $i -minsize $x1
2072    }
2073    update idletasks
2074    set sizes [grid bbox $box.can.f]
2075    $box.can config -scrollregion $sizes
2076    $box.side config -scrollregion $sizes
2077    $box.top config -scrollregion $sizes
2078    $box.top config -height [lindex [grid bbox $box.top.f] 3]
2079    $box.side config -width [lindex [grid bbox $box.side.f] 2]
2080}
2081proc ExpandScrollTable {box} {
2082    # set height & width of central box
2083    $box.can config -width \
2084            [expr [winfo width [winfo toplevel $box]] \
2085            - [winfo width $box.side] - [winfo width $box.yscroll]-20]
2086    $box.can config -height \
2087            [expr [winfo height [winfo toplevel $box]] \
2088            - [winfo height $box.top] - [winfo height $box.scroll]-25]
2089}
2090
2091
2092# support routine for SetHistUseFlags
2093proc InitHistUseFlags {} {
2094    global expmap expgui
2095    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2096#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2097            set expgui(useflag_$i) [histinfo $i use]
2098#       }
2099    }
2100}
2101
2102# show all Powder histograms; set use/do not use flags
2103proc SetHistUseFlags {} {
2104    set box .test
2105    catch {toplevel $box}
2106    eval destroy [winfo children $box]
2107    grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2108    grid [frame $box.a] -row 1 -column 0 -columnspan 2
2109    grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2110    grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2111    grid columnconfig $box 0 -weight 1
2112    grid columnconfig $box 1 -weight 1
2113    foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2114    $cbox config -text "Use\nFlag"
2115    [winfo parent $bbox] config -height 250 -width 400
2116    global expmap expgui
2117    set px 5
2118    set row -1
2119    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2120        if {[string range $expmap(htype_$i) 2 2] == "T"} {
2121            set det [format %8.2f [histinfo $i tofangle]]
2122        } elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2123            set det [format %8.5f [histinfo $i lam1]]
2124        } elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2125            set det [format %8.2f [histinfo $i lam1]]
2126        } else {
2127            set det {}
2128        }
2129        incr row
2130#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2131            grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0 
2132            set expgui(useflag_$i) [histinfo $i use]
2133#       }
2134        grid [label $bbox.0$i \
2135                -text [string range $expmap(htype_$i) 0 3] \
2136                ] -row $row -column 0 -padx $px
2137        grid [label $bbox.1$i -text [histinfo $i bank] \
2138                ] -row $row -column 1 -padx $px
2139        grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2140        grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2141                ] -row $row -column 3 -padx $px -sticky ew
2142    }
2143    grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2144    grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2145    grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2146    grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2147    ResizeScrollTable $box.a
2148    InitHistUseFlags
2149    putontop $box
2150    tkwait window $box
2151    afterputontop
2152    set prevchages $expgui(changed)
2153    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2154#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2155            if {$expgui(useflag_$i) != [histinfo $i use]} {
2156                histinfo $i use set $expgui(useflag_$i)
2157                incr expgui(changed)
2158            }
2159#       }
2160    }
2161    if {$prevchages != $expgui(changed)} {
2162        set msg "You have changed [expr $expgui(changed)-$prevchages] "
2163        append msg "histogram flag(s). You must run POWPREF "
2164        append msg "to include/remove these histograms. Do you want to "
2165        append msg "run POWPREF?"
2166        set ans [MyMessageBox -parent . -message $msg \
2167                -title "Process changes?"\
2168                -helplink "expguierr.html ProcessUse" \
2169                -default {Run POWPREF} \
2170                -type {{Run POWPREF} Skip}]
2171       
2172        if {$ans == "skip"} {
2173            # save and reload the experiment file
2174            savearchiveexp
2175            loadexp $expgui(expfile)
2176        } else {
2177            # run powpref and force a reload
2178            set saveautoload $expgui(autoexpload)
2179            set expgui(autoexpload) 1
2180            runGSASwEXP powpref
2181            set expgui(autoexpload) $saveautoload
2182        }
2183    }
2184}
2185
2186# set the box or file in the selection window
2187proc ReleaseExpFil {frm} {
2188    global expgui
2189    set files $frm.a.files
2190    set dates $frm.a.dates
2191    set select [$files curselection]
2192    if {$select == ""} {
2193        set select [$dates curselection]
2194    }
2195    if {$select == ""} {
2196        set expgui(FileMenuEXPNAM) ""
2197    } else {
2198        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2199        after idle UpdateInfoBox
2200    }
2201    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2202        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2203        ChooseExpFil $frm
2204    } elseif [file isdirectory \
2205            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2206        if {$expgui(FileMenuEXPNAM) != "."} {
2207            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2208            ChooseExpFil $frm
2209        }
2210    }
2211    return
2212}
2213proc UpdateInfoBox {} {
2214    global expgui
2215    if {![winfo exists $expgui(FileInfoBox)]} return
2216    eval destroy [winfo children $expgui(FileInfoBox)]
2217    set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2218    if [file isdirectory $file] return
2219    if [file exists $file] {
2220        pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2221                -side top
2222        catch {
2223            set fp [open $file r]
2224            global testline
2225            set testline [read $fp]
2226            close $fp
2227            update
2228            regexp {GNLS  RUN on (.*) +Total.*run *([0-9]+) } \
2229                    $testline a last cycles
2230            pack [label $expgui(FileInfoBox).2 -justify left \
2231                    -text "last GENLES run:\n  $last\n  total cycles: $cycles"] \
2232                -side top -anchor w
2233            regexp {REFN GDNFT.*= *([0-9]*\.[0-9]*) +for *([0-9]+) variables} \
2234                    $testline a chi2 vars
2235            pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
2236                    -side top -anchor w
2237            pack [label $expgui(FileInfoBox).3.a -justify left \
2238                    -text "c" -font symbol] \
2239                    -side left -anchor w
2240            pack [label $expgui(FileInfoBox).3.b -justify left \
2241                    -text "2: $chi2, $vars vars"] \
2242                    -side top -anchor w
2243            # check first 9 histograms
2244            set lbl "h  Rwp     R(F2)"
2245            set n 0
2246            foreach k {1 2 3 4 5 6 7 8 9} {
2247                set key "HST  $k"
2248                append key { RPOWD +([0-9]*\.[0-9]*) }
2249                set i [regexp $key $testline a Rwp]
2250                set key "HST  $k"
2251                append key { R-FAC +[0-9]+ +([0-9]*\.[0-9]*) }
2252                set j [regexp $key $testline a Rb]
2253                if {$i || $j} {
2254                    incr n
2255                    append lbl "\n$k  "
2256                    if {$i} {
2257                        append lbl [string range $Rwp 0 5]
2258                    } else {
2259                        append lbl "    "
2260                    }
2261                }
2262                if {$j} {
2263                    append lbl " [string range $Rb 0 5]"
2264                }
2265                # stick 1st 3 entries in box
2266                if {$n >= 3} break
2267            }
2268            pack [label $expgui(FileInfoBox).4 -justify left \
2269                    -text $lbl] \
2270                    -side top -anchor w     
2271        }
2272    }
2273}
2274
2275# select a file or directory -- called on double click
2276proc SelectExpFil {frm mode} {
2277    global expgui
2278    set files $frm.a.files
2279    set dates $frm.a.dates
2280    set select [$files curselection]
2281    if {$select == ""} {
2282        set select [$dates curselection]
2283    }
2284    if {$select == ""} {
2285        set file .
2286    } else {
2287        set file [string trim [$files get $select]]
2288    }
2289    if {$file == "<Parent>"} {
2290        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2291        ChooseExpFil $frm
2292    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2293        if {$file != "."} {
2294            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2295            ChooseExpFil $frm
2296        }
2297    } else {
2298        set expgui(FileMenuEXPNAM) [file tail $file]
2299        valid_exp_file $frm $mode
2300    }
2301}
2302
2303# fill the files & dates & Directory selection box with current directory,
2304# also called when box is created to fill it
2305proc ChooseExpFil {frm} {
2306    global expgui
2307    set files $frm.a.files
2308    set dates $frm.a.dates
2309    set expgui(FileMenuEXPNAM) {}
2310    $files delete 0 end
2311    $dates delete 0 end
2312    $files insert end {<Parent>}
2313    $dates insert end {(Directory)}
2314    set filelist [glob -nocomplain \
2315            [file join [set expgui(FileMenuDir)] *] ]
2316    foreach file [lsort -dictionary $filelist] {
2317        if {[file isdirectory $file]} {
2318            $files insert end [file tail $file]
2319            $dates insert end {(Directory)}
2320        }
2321    }
2322    set pairlist {}
2323    foreach file [lsort -dictionary $filelist] {
2324        if {![file isdirectory $file]  && \
2325                [string toupper [file extension $file]] == ".EXP"} {
2326            set modified [file mtime $file]
2327            lappend pairlist [list $file $modified]
2328        } elseif {![file isdirectory $file] && $expgui(includearchived) && \
2329                [string match {*.O[0-9A-F][0-9A-F]} $file]} {
2330            set modified [file mtime $file]
2331            lappend pairlist [list $file $modified]
2332        }
2333    }
2334    if {$expgui(filesort) == 0} {
2335        foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
2336            set file [lindex $pair 0]
2337            set modified [clock format [lindex $pair 1] -format "%T %D"]
2338            $files insert end [file tail $file]
2339            $dates insert end $modified
2340        }
2341    } else {
2342        foreach pair [lsort -dictionary -index 0 $pairlist] {
2343            set file [lindex $pair 0]
2344            set modified [clock format [lindex $pair 1] -format "%T %D"]
2345            $files insert end [file tail $file]
2346            $dates insert end $modified
2347        }
2348    }
2349    $expgui(FileDirButtonMenu)  delete 0 end
2350    set list ""
2351    global tcl_platform tcl_version
2352    if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2353        catch {set list [string tolower [file volume]]}
2354    }
2355    set dir ""
2356    foreach subdir [file split [set expgui(FileMenuDir)]] {
2357        set dir [file join $dir $subdir]
2358        if {$tcl_platform(platform) == "windows"} {
2359            set dir [string tolower $dir]
2360            if {[lsearch $list $dir] == -1} {lappend list $dir}
2361        } else {
2362            lappend list $dir
2363        }
2364    }
2365    foreach path $list {
2366        $expgui(FileDirButtonMenu) add command -label $path \
2367                -command "[list set expgui(FileMenuDir) $path]; \
2368                ChooseExpFil $frm"
2369    }
2370    # highlight the current experiment -- if present
2371    for {set i 0} {$i < [$files size]} {incr i} {
2372        set file [$files get $i]
2373        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2374            $files selection set $i
2375        }
2376    }
2377    return
2378}
2379
2380
2381#------------------------------------------------------------------------------
2382# platform-specific definitions
2383if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2384    # windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2385    # DOS box synchronously, so we create a "lock" file that is deleted
2386    # at the end of the DOS run so we can tell when the run is done.
2387    # We create a window to force the deleting of the file so that if
2388    # the DOS process crashes, the user can continue anyway.
2389    #
2390    # procedure to check if the lock file is still there (Win-9x/me only)
2391    proc checklockfile {file window} {
2392        if [file exists $file] {
2393            after 500 checklockfile $file $window
2394        } else {
2395            catch {destroy $window}
2396        }
2397    }
2398    # this procedure starts the GRWND program, if needed for program $prog
2399    proc StartGRWND {prog} {
2400        global expgui
2401        if {!$expgui(autoGRWND)} return
2402        # at some point we might want to have a real list
2403        if {$prog != "genles" && $prog != "powpref"} {
2404            # get a list of running jobs
2405            exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
2406            set fp [open tlist.tlist r]
2407            set text [read $fp]
2408            close $fp
2409            file delete -force tlist.tlist
2410            # if GRWND.EXE is not currently running, start it
2411            if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
2412                exec [file join $expgui(gsasexe) grwnd.exe] &
2413                # give grwnd a 1 second head start
2414                after 1000
2415            }
2416        }
2417    }
2418    # this creates a DOS box to run a program in
2419    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2420        global env expgui
2421        # Windows environment variables
2422        set env(GSAS) [file nativename $expgui(gsasdir)]
2423        # PGPLOT_FONT is needed by PGPLOT
2424        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2425        # this is the number of lines/page in the .LST (etc.) file
2426        set env(LENPAGE) 60
2427        set pwd [file nativename [pwd]]
2428       
2429        # check the .EXP path -- can DOS use it?
2430        if {[string first // [pwd]] != -1} {
2431            MyMessageBox -parent . -title "Invalid Path" \
2432                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2433                    -icon error -type ok -default ok \
2434                    -helplink "expgui_Win_readme.html NetPath"
2435            return
2436        }
2437        # pause is hard coded in the .BAT file
2438        #
2439        # loop over multiple commands
2440        foreach cmd $command {
2441            # simulate the wait with a lock file
2442            if {$wait} {
2443                if {$expgui(autoiconify)} {wm iconify .}
2444                # create a blank lock file and a message window
2445                close [open expgui.lck w]
2446                toplevel .lock
2447                grid [button .lock.0 -text Help -bg yellow \
2448                        -command "MakeWWWHelp expguierr.html lock"] \
2449                        -column 1 -row 0
2450                grid [label .lock.1 \
2451                        -text "Please wait while the GSAS program finishes."] \
2452                        -column 0 -row 0
2453                grid [label .lock.2 -text \
2454                        "In case a problem occurs, close the DOS box"] \
2455                        -column 0 -columnspan 2 -row 1
2456                grid [label .lock.3 -text \
2457                        "and press the \"Continue\" button (below)"] \
2458                        -column 0 -columnspan 2 -row 2
2459                grid [button .lock.b -text "Continue" \
2460                        -command "destroy .lock; wm deiconify ."] \
2461                        -column 0 -columnspan 2 -row 3
2462                putontop .lock
2463                update
2464                checklockfile expgui.lck .lock
2465            }
2466            # replace the forward slashes with backward
2467            regsub -all / $cmd \\ cmd
2468            winexec -d [file nativename [pwd]] \
2469                    [file join $expgui(scriptdir) gsastcl.bat] $cmd
2470            if {$wait} {
2471                tkwait window .lock
2472                file delete -force expgui.lck
2473            }
2474        }
2475        if {$expgui(autoiconify) && $wait} {wm deiconify .}
2476        # check for changes in the .EXP file immediately
2477        whenidle
2478    }
2479} elseif {$tcl_platform(platform) == "windows"} {
2480    # now for Windows-NT, where we can run synchronously
2481    #
2482    # this creates a DOS box to run a program in
2483    proc forknewterm {title command  "wait 1" "scrollbar 1"} {
2484        global env expgui
2485        # Windows environment variables
2486        set env(GSAS) [file nativename $expgui(gsasdir)]
2487        # PGPLOT_FONT is needed by PGPLOT
2488        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2489        # this is the number of lines/page in the .LST (etc.) file
2490        set env(LENPAGE) 60
2491        set pwd [file nativename [pwd]]
2492        # check the path -- can DOS use it?
2493        if {[string first // [pwd]] != -1} {
2494            MyMessageBox -parent . -title "Invalid Path" \
2495                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2496                    -icon error -type ok -default ok \
2497                    -helplink "expgui_Win_readme.html NetPath"
2498            return
2499        }
2500        # pause is hard coded in the .BAT file
2501
2502        if {$wait} {
2503            if {$expgui(autoiconify)} {wm iconify .}
2504            # create a blank lock file (keep liveplot from running)
2505            close [open expgui.lck w]
2506            # loop over commands
2507            foreach cmd $command {
2508                # replace the forward slashes with backward
2509                regsub -all / $cmd \\ cmd
2510                exec $env(COMSPEC) /c \
2511                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd"
2512            }
2513            file delete -force expgui.lck
2514            if {$expgui(autoiconify)} {wm deiconify .}
2515            # check for changes in the .EXP file immediately
2516            whenidle
2517        } else {
2518            # loop over commands
2519            foreach cmd $command {
2520                # replace the forward slashes with backward
2521                regsub -all / $cmd \\ cmd
2522                # run in background
2523                exec $env(COMSPEC) /c \
2524                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd" &
2525            }
2526        }
2527    }
2528} else {
2529    # this creates a xterm window to run a program in
2530    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2531        global env expgui
2532        # UNIX environment variables
2533        set env(GSAS) [file nativename $expgui(gsasdir)]
2534        set env(gsas) [file nativename $expgui(gsasdir)]
2535        set env(GSASEXE) $expgui(gsasexe)
2536        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2537        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2538        # PGPLOT_DIR is needed by PGPLOT
2539        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2540        # this is the number of lines/page in the .LST (etc.) file
2541        set env(LENPAGE) 60
2542        set termopts {}
2543        if $env(GSASBACKSPACE) {
2544            append termopts \
2545                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2546        }
2547        if $scrollbar {
2548            append termopts " -sb"
2549        } else {
2550            append termopts " +sb"
2551        }
2552        if {$wait} {
2553            set suffix {}
2554        } else {
2555            set suffix {&}
2556        }
2557        #
2558        #if $wait {
2559            append command "\; echo -n Press Enter to continue \; read x"
2560        #}
2561        if {$wait && $expgui(autoiconify)} {wm iconify .}
2562        catch {eval exec xterm $termopts -title [list $title] \
2563                -e /bin/sh -c [list $command] $suffix} errmsg
2564        if $expgui(debug) {puts "xterm result = $errmsg"}
2565        if {$wait} {
2566            if {$expgui(autoiconify)} {wm deiconify .}
2567            # check for changes in the .EXP file immediately
2568            whenidle
2569        }
2570    }
2571}
2572
2573# modify resource fork info for a .EXP file on the Mac
2574proc MacSetResourceFork {expfile} {
2575    global expgui tcl_platform
2576    if {$tcl_platform(os) != "Darwin"} {return}
2577    set expnative [file nativename $expfile]
2578    #
2579    # assign an app to the data file, if the app and the
2580    # required tool (Rez) are installed
2581    set app [file join $expgui(gsasdir) expgui.app]
2582    if {[file exists $app] && [file exists /Developer/Tools/Rez]} {
2583        # make a resource file
2584        set l [string length $app]; incr l
2585        set str "data 'usro' (0) {\n"
2586        append str {  $"}
2587        append str [format %.8X $l]
2588        foreach char [split $app {}] {
2589           append str [format %.2X [scan $char %c]]   
2590        }
2591        append str {00"}
2592        append str " \t/* ....$app. */\n};"
2593        set fp [open setapp.r w]
2594        puts $fp $str
2595        close $fp
2596        exec /Developer/Tools/Rez setapp.r -o $expnative -a
2597        file delete -force setapp.r
2598    }
2599
2600    # assign an icon to the data file, if it and the required tools exist
2601    set icon [file join $expgui(gsasdir) gsasicon.r]
2602    if {[file exists $icon] && [file exists /Developer/Tools/Rez] && \
2603            [file exists /Developer/Tools/SetFile]} {
2604        exec /Developer/Tools/Rez [file nativename $icon] -o $expnative -a
2605        exec /Developer/Tools/SetFile -a C $expnative
2606    }
2607}
Note: See TracBrowser for help on using the repository browser.