source: trunk/gsascmds.tcl @ 870

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

# on 2006/02/22 01:45:29, toby did:
Recompute Multiplicities prior to Composition computation

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