source: trunk/gsascmds.tcl @ 924

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

# on 2008/07/14 01:19:02, toby did:
change Set to Continue for getstring (so that initial window has Continue)
use variable to hold disagl window name
add code to export a phase to clipboard for Andrew Will's VaList? program

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