source: trunk/gsascmds.tcl @ 772

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

# on 2004/01/30 00:41:47, toby did:
update putontop to match new version of CIF routines

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