source: trunk/gsascmds.tcl @ 775

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

# on 2004/01/30 00:50:00, toby did:
Add code to set app/icon in OS X

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