source: trunk/gsascmds.tcl @ 867

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

# on 2006/02/22 00:28:44, toby did:
Allow composition to work on Magnetic phases

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