source: trunk/gsascmds.tcl @ 1166

Last change on this file since 1166 was 1166, checked in by toby, 9 years ago

bring sandbox changes over to main release

  • Property svn:keywords set to Author Date Revision Id
File size: 134.1 KB
Line 
1# $Id: gsascmds.tcl 1166 2011-08-17 23:17:04Z 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# format numbers & errors in crystallographic notation
469proc formatSU {num err} {
470    # errors less or equal to t are expressed as 2 digits
471    set T 19
472    set lnT [expr { log10($T) }] 
473    # error is zero
474    if {$err == 0} {
475        # is this an integer?
476        if {int($num) == $num} {
477            return [format %d [expr int($num)]]
478        }
479        # allow six sig figs with a zero error (except for 0.0)
480        set dec [expr int(5.999999-log10( abs($num) ))]
481        if {$dec < -2 || $dec > 9} {
482            return [format %.5E $num]
483        } elseif {$dec <= 0} {
484            return [format %d [expr int($num)]]
485        } else {
486            return [format %.${dec}f $num]
487        }
488    } else {
489        #set sigfigs [expr log10( abs(10) / abs(.012/$T) ) + 1]
490        # should the number be expressed in scientific notation?
491        if {$err > $T || abs($num) < 0.0001} {
492            # get the exponent
493            set exp [lindex [split [format %E $num] E] end]
494            # strip leading zeros
495            regsub {([-\+])0+} $exp {\1} exp
496            # number of decimals in exponetial notation
497            set dec [expr int($lnT - log10( abs($err) ) + $exp)]
498            # should the error be displayed?
499            if {$err < 0} {
500                return [format "%.${dec}E" $num]
501            } else {
502                # scale the error into a decimal number
503                set serr [expr int(0.5 + $err * pow(10,$dec-$exp))]
504                return [format "%.${dec}E(%d)" $num $serr]
505            }
506        } else {
507            # number of digits
508            set dec [expr int($lnT - log10( abs($err) ))]
509            # should the error be displayed?
510            if {$err < 0} {
511                return [format "%.${dec}f" $num]
512            } else {
513                set serr [expr int(0.5 + $err * pow(10,$dec))]
514                return [format "%.${dec}f(%d)" $num $serr]
515            }
516        }
517    }
518}
519
520# place a window on a selected part of the screen
521# xfrac specifies the hozontal position with 0 to the left and 100 to the right
522# yfrac specifies the vertical position with 0 to the top and 100 to the bottom
523# loc chooses the part of the window to place at that location: N: upper, S: lower, W: left, E: right
524# use NSEW for center
525proc LocateWindow {win {xfrac 50} {yfrac 50} {loc c}} {
526    wm withdraw $win
527    set maxx [winfo screenwidth $win]
528    set maxy [winfo screenheight $win]
529    set reqx [winfo reqwidth $win]
530    set reqy [winfo reqheight $win]
531    set x [expr {$maxx*$xfrac/100.}]
532    set y [expr {$maxy*$yfrac/100.}]
533    if {[string match -nocase "*e*" $loc] && [string match -nocase "*w*" $loc]} {
534        # EW: center
535        set x [expr {$x - $reqx/2. }]
536    } elseif {[string match -nocase "*e*" $loc]} {
537        # right corner
538        set x [expr {$x - $reqx}]
539    } elseif {[string match -nocase "*w*" $loc]} {     
540        # left corner -- do nothing
541    } else {
542        # center
543        set x [expr {$x - $reqx/2. }]
544    }
545    if {[string match -nocase "*n*" $loc] && [string match -nocase "*s*" $loc]} {
546        # NS: center
547        set y [expr {$y - $reqy/2 }]
548    } elseif {[string match -nocase "*n*" $loc]} {
549        # upper corner -- do nothing
550    } elseif {[string match -nocase "*s*" $loc]} {
551        # lower corner
552        set y [expr {$y - $reqy}]
553    } else {
554        # center
555        set y [expr {$y - $reqy/2 }]
556    }
557    set x [expr {int($x + 0.5)}]
558    set y [expr {int($y + 0.5)}]
559    if {$x < 0} {set x 0}
560    if {$x > $maxx-$reqx} {set x [expr {$maxx-$reqx}]}
561    if {$y < 0} {set y 0}
562    if {$y > $maxy-$reqy} {set y [expr {$maxy-$reqy}]}
563    wm geom $win +$x+$y
564    wm deiconify $win
565}
566
567# get a value in a modal dialog
568proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
569    global expgui expmap
570    set w .global
571    catch {destroy $w}
572    toplevel $w -bg beige
573    bind $w <Key-F1> "MakeWWWHelp expguierr.html Input[lindex $what 0]"
574    wm title $w "Input $what"
575    set expgui(temp) {}
576    pack [frame $w.0 -bd 6 -relief groove -bg beige] \
577            -side top -expand yes -fill both
578    grid [label $w.0.a -text "Input a value for the $what" \
579            -bg beige] \
580            -row 0 -column 0 -columnspan 10
581    grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
582            -row 1 -column 0 
583
584    set expgui(temp) $initvalue
585    pack [frame $w.b -bg beige] -side top -fill x -expand yes
586    pack [button $w.b.2 -text Continue -command "destroy $w"] -side left
587    if $quit {
588        pack [button $w.b.3 -text Cancel \
589                -command "set expgui(temp) {}; destroy $w"] -side left
590    }
591    bind $w <Return> "destroy $w"
592    pack [button $w.b.help -text Help -bg yellow \
593            -command "MakeWWWHelp expguierr.html Input[lindex $what 0]"] \
594            -side right
595
596    # force the window to stay on top
597    putontop $w
598
599    focus $w.b.2
600    tkwait window $w
601    afterputontop
602
603    return $expgui(temp)
604}
605
606#------------------------------------------------------------------------------
607# profile/symmetry routines
608#------------------------------------------------------------------------------
609# profile terms
610array set expgui {
611    prof-T-names {"Von Dreele-Jorgensen-Windsor" \
612                      "David-Ikeda-Carpenter" "Exponential pseudo-Voigt" \
613                      "Exponential p-V+Stephens aniso strain" \
614                      "Exponential p-V+macro strain"
615    }
616    prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
617            rsca s1ec s2ec }
618    prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
619            gam-2 ptec stec difc difa zero }
620    prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
621            gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
622    prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
623            rstr rsta rsca eta}
624    prof-T-5 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
625            gam-2 gsf g1ec g2ec rstr rsta rsca D1 D2 D3 D4 D5 D6 }
626    prof-C-names {"Gaussian only" "Pseudo-Voigt" \
627                      "pseudo-Voigt/FCJ Asym" "p-V/FCJ+Stephens aniso strain" \
628                      "p-V/FCJ+macro strain"
629    }
630    prof-C-1 {GU GV GW asym F1 F2 }
631    prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
632            L11 L22 L33 L12 L13 L23 }
633    prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
634            L11 L22 L33 L12 L13 L23 }
635    prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta} 
636    prof-C-5 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
637            D1 D2 D3 D4 D5 D6 }
638    prof-E-names {Gaussian "Otto pseudo-Voigt"}
639    prof-E-1 {A B C ds cds}
640    prof-E-2 {A B C ds cds LX LY ptec stec}
641}
642
643# number of profile terms depends on the histogram type
644# the LAUE symmetry and the profile number
645proc GetProfileTerms {phase hist ptype} {
646    global expmap expgui
647    if {$hist == "C" || $hist == "T" || $hist == "E"} {
648        set htype $hist
649    } else {
650        set htype [string range $expmap(htype_$hist) 2 2]
651    }
652    # get the cached copy of the profile term labels, when possible
653    set lbls {}
654    catch {
655        set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
656    }
657    if {$lbls != ""} {return $lbls}
658
659    catch {set lbls $expgui(prof-$htype-$ptype)}
660    if {$lbls == ""} {return}
661    # add terms based on the Laue symmetry
662    if {($htype == "C" || $htype == "T") && $ptype == 4} {
663        set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
664        eval lappend lbls [Profile4Terms $laueaxis]
665    }
666    set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
667    return $lbls
668}
669
670proc Profile4Terms {laueaxis} {
671# GSAS Laue classes by number vs spacegrp labeling
672#   1    2    3    4     5      6     7       8     9      10     11     12   13  14
673# 1bar, 2/m, mmm, 4/m, 4/mmm, 3bar, 3bar m, 3bar, 3barm1, 3bar1m, 6/m, 6/mmm, m 3, m3m
674#                              R      R      H      H       H
675# (R=Rhombohedral setting; H=Hexagonal setting)
676    switch -exact $laueaxis {
677        1bar {return \
678                "S400 S040 S004 S220 S202 S022 S310 S103 S031 \
679                S130 S301 S013 S211 S121 S112"}
680        2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
681        2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
682        2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
683        mmm  {return "S400 S040 S004 S220 S202 S022"}
684        4/{return "S400 S004 S220 S202 S310"}
685        4/mmm {return "S400 S004 S220 S202"}
686        3barR     {return "S400 S220 S310 S301 S211"}
687        "3bar mR" {return "S400 S220 S310 S211"}
688        3bar    {return "S400 S004 S202 S310 S211"}
689        3barm1 {return "S400 S004 S202 S301"}
690        3bar1m  {return "S400 S004 S202 S211"}
691        6/m    {return "S400 S004 S202"}
692        6/mmm  {return "S400 S004 S202"}
693        "m 3"  {return "S400 S220"}
694        m3m    {return "S400 S220"}
695        default {return ""}
696    }
697}
698
699proc GetLaue {spg} {
700    global tcl_platform expgui
701    # check the space group
702    set fp [open spg.in w]
703    puts $fp "N"
704    puts $fp "N"
705    puts $fp $spg
706    puts $fp "Q"
707    close $fp
708    catch {
709        if {$tcl_platform(platform) == "windows"} {
710            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
711        } else {
712            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
713        }
714    }
715    set fp [open spg.out r]
716    set laue {}
717    set uniqueaxis {}
718    while {[gets $fp line] >= 0} {
719        regexp {Laue symmetry (.*)} $line junk laue
720        regexp {The unique axis is (.*)} $line junk uniqueaxis
721    }
722    close $fp
723    catch {file delete -force spg.in spg.out}
724    set laue [string trim $laue]
725    # add a R suffix for rhombohedral settings
726    if {[string range [string trim $spg] end end] == "R"} {
727        return "${laue}${uniqueaxis}R"
728    }
729    return "${laue}$uniqueaxis"
730}
731
732# set up to change the profile type for a series of histogram/phase entries
733# (histlist & phaselist should be lists of the same length)
734#
735proc ChangeProfileType {histlist phaselist} {
736    global expgui expmap
737    set w .profile
738    catch {destroy $w}
739    toplevel $w -bg beige
740    wm title $w "Change Profile Function"
741   
742    # all histogram/phases better be the same type, so we can just use the 1st
743    set hist [lindex $histlist 0]
744    set phase [lindex $phaselist 0]
745    set ptype [string trim [hapinfo $hist $phase proftype]]
746
747    # get list of allowed profile terms for the current histogram type
748    set i 1
749    while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
750        lappend lbllist $lbls
751        incr i
752    }
753    # labels for the current type
754    set i $ptype
755    set oldlbls [lindex $lbllist [incr i -1]]
756   
757    if {[llength $histlist] == 1} {
758        pack [label $w.a -bg beige \
759                -text "Change profile function for Histogram #$hist Phase #$phase" \
760                ] -side top
761    } else {
762        # make a list of histograms by phase
763        foreach h $histlist p $phaselist {
764            lappend phlist($p) $h
765        }
766        set num 0
767        pack [frame $w.a -bg beige] -side top
768        pack [label $w.a.$num -bg beige \
769                -text "Change profile function for:" \
770                ] -side top -anchor w
771        foreach i [lsort [array names phlist]] {
772            incr num
773            pack [label $w.a.$num -bg beige -text \
774                    "\tPhase #$i, Histograms [CompressList $phlist($i)]" \
775                    ] -side top -anchor w
776        }
777    }
778    pack [label $w.e1 \
779            -text "Current function is type $ptype." \
780            -bg beige] -side top -anchor w
781    pack [frame $w.e -bg beige] -side top -expand yes -fill both
782    pack [label $w.e.1 \
783            -text "Set function to type" \
784            -bg beige] -side left
785    set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
786    pack $w.e.2 -side left -anchor w
787
788    pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
789            -command "set expgui(newpeaktype) $ptype; \
790            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
791            -value 1 -text "Current value overrides"] -side right
792    pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
793            -command \
794            "set expgui(newpeaktype) $ptype; \
795            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
796            -value 0 -text "Default value overrides"] -side right
797
798    $w.e.2 config -bg beige
799    pack [frame $w.c -bg beige] -side top -expand yes -fill both
800    pack [frame $w.d -bg beige] -side top -expand yes -fill both
801    pack [button $w.d.2 -text Continue  \
802              -command "SaveChangeProfileType $w.c [list $histlist] [list $phaselist]; destroy $w"\
803            ] -side left
804    pack [button $w.d.3 -text Cancel \
805            -command "destroy $w"] -side left
806    pack [button $w.d.help -text Help -bg yellow \
807            -command "MakeWWWHelp expgui5.html ChangeType"] \
808            -side right
809    bind $w <Key-F1> "MakeWWWHelp expgui5.html ChangeType"
810    bind $w <Return> "destroy $w"
811
812    $menu delete 0 end
813    set i 0
814    foreach lbls $lbllist {
815        incr i
816        set j $i
817        # determine if negative profiles are allowed
818        if {[string range $expmap(htype_$hist) 2 2] == "T"} {
819            if {[histinfo $hist proftbl] > 0 && $i > 2} {
820                set j -$i
821            }
822        }
823        $menu add command -label $j -command \
824                "set expgui(newpeaktype) $j; \
825                FillChangeProfileType $w.c $hist $phase $j [list $lbls] [list $oldlbls]"
826    }
827    set expgui(newpeaktype) $ptype
828    FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
829
830    # force the window to stay on top
831    putontop $w
832    focus $w.e.2
833    tkwait window $w
834    afterputontop
835    sethistlist
836}
837
838# save the changes to the profile
839proc SaveChangeProfileType {w histlist phaselist} {
840    global expgui
841    foreach phase $phaselist hist $histlist {
842        hapinfo $hist $phase proftype set $expgui(newpeaktype)
843        RecordMacroEntry "hapinfo $hist $phase proftype set $expgui(newpeaktype)" 0
844        hapinfo $hist $phase profterms set $expgui(newProfileTerms)
845        RecordMacroEntry "hapinfo $hist $phase profterms set $expgui(newProfileTerms)" 0
846        for {set i 1} {$i <=  $expgui(newProfileTerms)} {incr i} {
847            hapinfo $hist $phase pterm$i set [$w.ent${i} get]
848            RecordMacroEntry "hapinfo $hist $phase pterm$i set [$w.ent${i} get]" 0
849            hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
850            RecordMacroEntry "hapinfo $hist $phase pref$i set $expgui(ProfRef$i)" 0
851        }
852        set i [expr 1+$expgui(newProfileTerms)]
853        hapinfo $hist $phase pcut set [$w.ent$i get]
854        RecordMacroEntry "hapinfo $hist $phase pcut set [$w.ent$i get]" 0
855        incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
856        RecordMacroEntry "incr expgui(changed)" 0
857    }
858}
859
860# file the contents of the "Change Profile Type" Menu
861proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
862    global expgui expmap
863    set ptype [string trim [hapinfo $hist $phase proftype]]
864    catch {unset oldval}
865    # loop through the old terms and set up an array of starting values
866    set num 0
867    foreach term $oldlbls {
868        incr num
869        set oldval($term) [hapinfo $hist $phase pterm$num]
870    }
871    set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
872
873    # is the new type the same as the current?
874    if {$ptype == $newtype} {
875        set nterms [hapinfo $hist $phase profterms]
876    } else {
877        set nterms [llength $lbls]
878    }
879    set expgui(newProfileTerms) $nterms
880    set expgui(CurrentProfileTerms) $nterms
881    # which default profile set matches the new type
882    set setnum {}
883    foreach j {" " 1 2 3 4 5 6 7 8 9} {
884        set i [profdefinfo $hist $j proftype]
885        if {$i == ""} continue
886        if {$i == $newtype} {
887            set setnum $j
888            break
889        }
890    }
891
892    eval destroy [winfo children $w]
893
894    set colstr 0
895    set row 2
896    set maxrow [expr $row + $nterms/2]
897    for { set num 1 } { $num <= $nterms + 1} { incr num } {
898        # get the default value (originally from the in .INS file)
899        set val {}
900        if {$setnum != ""} {
901            set val 0.0
902            catch {
903                set val [profdefinfo $hist $setnum pterm$num]
904                # pretty up the number
905                if {$val == 0.0} {
906                    set val 0.0
907                } elseif {abs($val) < 1e-2 || abs($val) > 1e6} {
908                    set val [format %.3e $val]
909                } elseif {abs($val) > 1e-2 && abs($val) < 10} {
910                    set val [format %.5f $val]
911                } elseif {abs($val) < 9999} {
912                    set val [format %.2f $val]
913                } elseif {abs($val) < 1e6} {
914                    set val [format %.0f $val]
915                }
916            }
917        }
918        # heading
919        if {$row == 2} {
920            set col $colstr
921            grid [label $w.h0${num} -text "lbl" -bg beige] \
922                -row $row -column $col
923            grid [label $w.h2${num} -text "ref" -bg beige] \
924                -row $row -column [incr col]
925            grid [label $w.h3${num} -text "next value" -bg beige] \
926                -row $row -column [incr col]
927            grid [label $w.h4${num} -text "default" -bg beige] \
928                -row $row -column [incr col]
929            grid [label $w.h5${num} -text "current" -bg beige] \
930                -row $row -column [incr col]
931        }
932        set col $colstr
933        incr row
934        set term {}
935        catch {set term [lindex $lbls [expr $num-1]]}
936        if {$term == ""} {set term $num}
937        if {$num == $nterms + 1} {
938            set term "Peak\nCutoff"
939            set val {}
940            if {$setnum != ""} {
941                set val 0.0
942                catch {set val [profdefinfo $hist $setnum pcut]}
943            }
944        }
945
946        grid [label $w.l${num} -text "$term" -bg beige] \
947                -row $row -column $col
948        grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
949                -bg beige -activebackground beige] -row $row -column [incr col]
950        grid [entry $w.ent${num} \
951                -width 12] -row $row -column [incr col]
952        if {$val != ""} {
953            grid [button $w.def${num} -text $val -command \
954                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
955                    ] -row $row -column [incr col] -sticky ew
956        } else {
957            grid [label $w.def${num} -text (none) \
958                    ] -row $row -column [incr col]
959        }
960        set curval {}
961        catch {
962            set curval [expr $oldval($term)]
963            # pretty up the number
964            if {$curval == 0.0} {
965                set curval 0.0
966            } elseif {abs($curval) < 1e-2 || abs($curval) > 1e6} {
967                set curval [format %.3e $curval]
968            } elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
969                set curval [format %.5f $curval]
970            } elseif {abs($curval) < 9999} {
971                set curval [format %.2f $curval]
972            } elseif {abs($curval) < 1e6} {
973                set curval [format %.0f $curval]
974            }
975            grid [button $w.cur${num} -text $curval -command  \
976                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
977                    ] -row $row -column [incr col] -sticky ew
978        }
979        # set default values for flag and value
980        set ref 0
981        if {$setnum != ""} {
982            catch {
983                if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
984            }
985        }
986        set expgui(ProfRef$num) $ref
987       
988        $w.ent${num} delete 0 end
989        if {!$expgui(DefaultPeakType) && $val != ""} {
990            $w.ent${num} insert end $val
991        } elseif {$curval != ""} {
992            $w.ent${num} insert end $curval
993        } elseif {$val != ""} {
994            $w.ent${num} insert end $val
995        } else {
996            $w.ent${num} insert end 0.0
997        }
998        if {$row > $maxrow} {
999            set row 2
1000            incr colstr 5
1001        }
1002    }
1003    if {$::tcl_platform(os) == "Darwin"} {
1004        # on OS X force a window resize
1005        wm geometry [winfo toplevel $w] {}
1006    }
1007}
1008
1009#------------------------------------------------------------------------------
1010# WWW/help routines
1011#------------------------------------------------------------------------------
1012# browse a WWW page with URL. The URL may contain a #anchor
1013# On UNIX assume netscape or mozilla is in the path or env(BROWSER) is loaded.
1014# On Windows search the registry for a browser. Mac branch not tested.
1015# This is taken from http://mini.net/cgi-bin/wikit/557.html with many thanks
1016# to the contributers
1017proc urlOpen {url} {
1018    global env tcl_platform
1019    if {$tcl_platform(os) == "Darwin"} {
1020        # if this is an external URL or does not contain an anchor, take the
1021        # easy approach
1022        if {[string range $url 0 4] == "http:" || \
1023                [string first "#" $url] == -1} {
1024            if {![catch {exec open $url}]} {
1025                return
1026            }
1027        }
1028        # so sorry, have to use Safari, even if not default
1029        set url [file nativename $url]; # replace ~/ if present
1030        if {[file pathtype $url] == "relative"} {
1031            set url [file join [pwd] $url]
1032        }
1033        exec osascript -e "tell application \"Safari\" to open location \"file://$url\""
1034    } elseif {$tcl_platform(platform) == "unix"} {
1035        set browserlist {}
1036        if {[info exists env(BROWSER)]} {
1037            set browserlist $env(BROWSER)
1038        }
1039        lappend browserlist netscape mozilla
1040        foreach p $browserlist {
1041            set progs [auto_execok $p]
1042            if {[llength $progs]} {
1043                if {[catch {exec $progs -remote openURL($url)}]} {
1044                    # perhaps browser doesn't understand -remote flag
1045                    if {[catch {exec $env(BROWSER) $url &} emsg]} {
1046                        error "Error displaying $url in browser\n$emsg"
1047                    }
1048                }
1049                return
1050            }
1051        }
1052        MyMessageBox -parent . -title "No Browser" \
1053            -message "Could not find a browser. Netscape & Mozilla not found. Define environment variable BROWSER to be full path name of browser." \
1054            -icon warning
1055    } elseif {$tcl_platform(platform) == "windows"} {
1056        package require registry
1057        # Look for the application under
1058        # HKEY_CLASSES_ROOT
1059        set root HKEY_CLASSES_ROOT
1060       
1061        # Get the application key for HTML files
1062        set appKey [registry get $root\\.html ""]
1063       
1064        # Get the command for opening HTML files
1065        set appCmd [registry get \
1066                        $root\\$appKey\\shell\\open\\command ""]
1067
1068        # Substitute the HTML filename into the command for %1
1069        # or stick it on the end
1070        if {[string first %1 $appCmd] != -1} {
1071            regsub %1 $appCmd $url appCmd
1072        } else {
1073            append appCmd " " $url
1074        }
1075       
1076        # Double up the backslashes for eval (below)
1077        regsub -all {\\} $appCmd  {\\\\} appCmd
1078       
1079        # Invoke the command
1080        eval exec $appCmd &
1081    } elseif {$tcl_platform(platform) == "macintosh"} {
1082        # preOSX -- this is not used
1083        if {0 == [info exists env(BROWSER)]} {
1084            set env(BROWSER) "Browse the Internet"
1085        }
1086        if {[catch {
1087            AppleScript execute\
1088                "tell application \"$env(BROWSER)\"
1089                         open url \"$url\"
1090                     end tell
1091                "} emsg]
1092        } then {
1093            error "Error displaying $url in browser\n$emsg"
1094        }
1095    }
1096}
1097
1098proc NetHelp {file anchor localloc netloc} {
1099    # use the file on-line, if it exists
1100    if {[file exists [file join $localloc $file]]} {
1101        set url "[file join $localloc $file]"
1102    } else {
1103        set url "http://$netloc/$file"
1104    }
1105    catch {
1106        pleasewait "Starting web browser..."
1107        after 2000 donewait
1108    }
1109    if {$anchor != ""} {
1110        append url # $anchor
1111    }
1112    urlOpen $url
1113}
1114
1115proc MakeWWWHelp {"topic {}" "anchor {}"} {
1116    global expgui
1117    if {$topic == ""} {
1118        foreach item $expgui(notebookpagelist) {
1119            if {[lindex $item 0] == $expgui(pagenow)} {
1120                NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
1121                return
1122            }
1123        }
1124        # this should not happen
1125        NetHelp expgui.html "" $expgui(docdir) $expgui(website)
1126    } elseif {$topic == "menu"} {
1127        NetHelp expguic.html "" $expgui(docdir) $expgui(website)
1128    } else {
1129        NetHelp $topic $anchor $expgui(docdir) $expgui(website)
1130    }
1131}
1132
1133# show help information
1134proc showhelp {} {
1135    global expgui_helplist helpmsg
1136    set helpmsg {}
1137    set frm .help
1138    catch {destroy $frm}
1139    toplevel $frm
1140    wm title $frm "Help Summary"
1141    grid [label $frm.0 -text \
1142            "Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
1143        -column 0 -columnspan 4 -row 0
1144#    grid [message $frm.help -textvariable helpmsg -relief groove] \
1145#          -column 0 -columnspan 4 -row 2 -sticky nsew
1146    grid [text $frm.help -relief groove -bg beige -width 0\
1147            -height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
1148           -column 0 -columnspan 3 -row 2 -sticky nsew
1149    grid [scrollbar $frm.escroll -command "$frm.help yview"] \
1150            -column 4 -row 2 -sticky nsew
1151    grid rowconfig $frm 1 -weight 1 -minsize 50
1152    grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
1153    grid columnconfig $frm 0 -weight 1
1154    grid columnconfig $frm 2 -weight 1
1155    set lst [array names expgui_helplist]
1156    grid [listbox $frm.cmds -relief raised -bd 2 \
1157            -yscrollcommand "$frm.scroll set" \
1158            -height 8 -width 0 -exportselection 0 ] \
1159            -column 0 -row 1 -sticky nse
1160    grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
1161            -column 1 -row 1 -sticky nsew
1162    foreach item [lsort -dictionary $lst] {
1163        $frm.cmds insert end $item 
1164    }
1165    if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
1166    grid [button $frm.done -text Done -command "destroy $frm"] \
1167            -column 2 -row 1
1168#    bind $frm.cmds <ButtonRelease-1> \
1169#           "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
1170    bind $frm.cmds <ButtonRelease-1> \
1171            "+$frm.help config -state normal; $frm.help delete 0.0 end; \
1172             $frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
1173             $frm.help config -state disabled"
1174
1175    # get the size of the window and expand the message boxes to match
1176#    update
1177#    $frm.help config -width [winfo width $frm.help ]
1178}
1179
1180
1181#------------------------------------------------------------------------------
1182# utilities
1183#------------------------------------------------------------------------------
1184# run liveplot
1185proc liveplot {} {
1186    global expgui liveplot wishshell expmap
1187    set expnam [file root [file tail $expgui(expfile)]]
1188    # which histograms are ready for use?
1189    set validlist {}
1190    foreach ihist $expmap(powderlist) {
1191        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1192                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1193            lappend validlist $ihist
1194        }
1195    }
1196    if {[llength $validlist] == 0} {
1197        MyMessageBox -parent . -title "No Valid Histograms" \
1198                -message "No histograms are ready to plot. Run GENLES and try again" \
1199                -icon warning -helplink "expguierr.html NoValidHist"
1200        return
1201    }
1202    # use $liveplot(hst) if valid, the 1st entry otherwise
1203    if {[lsearch $validlist $liveplot(hst)] != -1} {
1204        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1205                $expnam $liveplot(hst) $liveplot(legend) &
1206    } else {
1207        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1208                $expnam [lindex $validlist 0] $liveplot(legend) &
1209    }
1210}
1211
1212# run lstview
1213proc lstview {} {
1214    global expgui wishshell
1215    set expnam [file root [file tail $expgui(expfile)]]
1216    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1217}
1218
1219# run widplt
1220proc widplt {"prog widplt"} {
1221    global expgui wishshell
1222    exec $wishshell [file join $expgui(scriptdir) $prog] \
1223            $expgui(expfile) &
1224}
1225
1226# run bkgedit
1227proc bkgedit {"hst {}"} {
1228    global expgui liveplot wishshell expmap
1229    set expnam [file root [file tail $expgui(expfile)]]
1230    if {$hst == ""} {
1231        # which histograms are ready for use?
1232        set validlist {}
1233        foreach ihist $expmap(powderlist) {
1234            if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1235                    [string range $expmap(htype_$ihist) 3 3] == "*"} {
1236                lappend validlist $ihist
1237            }
1238        }
1239        if {[llength $validlist] == 0} {
1240            MyMessageBox -parent . -title "No Valid Histograms" \
1241                    -message "No histograms are ready to plot. Run POWPREF and try again" \
1242                    -icon warning -helplink "expguierr.html NoValidHist"
1243            return
1244        }
1245        # use $liveplot(hst) if valid, the 1st entry otherwise
1246        if {[lsearch $validlist $liveplot(hst)] != -1} {
1247            set hst $liveplot(hst)
1248        } else {
1249            set hst [lindex $validlist 0]
1250        }
1251    }
1252    # Save the current exp file
1253    savearchiveexp
1254    CantRecordMacroEntry "bkgedit"
1255    # disable the file change monitor if we will reload the .EXP file automatically
1256    if {$expgui(autoexpload)} {set expgui(expModifiedLast) 0}
1257    if {$expgui(autoiconify)} {wm iconify .}
1258    exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1259            $expnam $hst $liveplot(legend)
1260    if {$expgui(autoiconify)} {wm deiconify .}
1261    # load the changed .EXP file automatically?
1262    if {$expgui(autoexpload)} {
1263        # load the revised exp file
1264        loadexp $expgui(expfile)
1265    } else {
1266        # check for changes in the .EXP file immediately
1267        whenidle
1268    }
1269}
1270
1271# run excledt
1272proc excledit {} {
1273    global expgui liveplot expmap
1274    set expnam [file root [file tail $expgui(expfile)]]
1275    # which histograms are ready for use?
1276    set validlist {}
1277    foreach ihist $expmap(powderlist) {
1278        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1279                [string range $expmap(htype_$ihist) 3 3] == "*" || \
1280                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1281            lappend validlist $ihist
1282        }
1283    }
1284    if {[llength $validlist] == 0} {
1285        MyMessageBox -parent . -title "No Valid Histograms" \
1286                -message "No histograms are ready to plot. Run POWPREF and try again" \
1287                -icon warning -helplink "expguierr.html NoValidHist"
1288        return
1289    }
1290    #if {$expgui(autoiconify)} {wm iconify .}
1291    StartExcl 
1292    #if {$expgui(autoiconify)} {wm deiconify .}
1293}
1294
1295# compute the composition for each phase and display in a dialog
1296proc composition {} {
1297    global expmap expgui
1298    set Z 1
1299    foreach phase $expmap(phaselist) type $expmap(phasetype) {
1300        if {$type == 4} continue
1301        ResetMultiplicities $phase {}
1302        catch {unset total}
1303        foreach atom $expmap(atomlist_$phase) {
1304            set type [atominfo $phase $atom type]
1305            set mult [atominfo $phase $atom mult]
1306            if [catch {set total($type)}] {
1307                set total($type) [expr \
1308                        $mult * [atominfo $phase $atom frac]]
1309            } else {
1310                set total($type) [expr $total($type) + \
1311                        $mult * [atominfo $phase $atom frac]]
1312            }
1313            if {$mult > $Z} {set Z $mult}
1314        }
1315        append text "\nPhase $phase\n"
1316        append text "  Unit cell contents\n"
1317        foreach type [lsort [array names total]] {
1318            append text "   $type[format %8.3f $total($type)]"
1319        }
1320        append text "\n\n"
1321       
1322        append text "  Asymmetric Unit contents (Z=$Z)\n"
1323        foreach type [lsort [array names total]] {
1324            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
1325        }
1326        append text "\n"
1327    }
1328   
1329    catch {destroy .comp}
1330    toplevel .comp -class MonoSpc
1331    bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1332    wm title .comp Composition
1333    pack [label .comp.results -text $text \
1334            -justify left] -side top
1335    pack [frame .comp.box]  -side top -expand y -fill x
1336    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1337
1338    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1339    pack [button .comp.box.2 -text "Save to $lstnam file" \
1340            -command "writelst [list $text] ; destroy .comp"] -side left
1341    pack [button .comp.box.help -text Help -bg yellow \
1342            -command "MakeWWWHelp expgui.html Composition"] \
1343            -side right
1344}
1345
1346# Delete History Records
1347proc DeleteHistoryRecords {{msg ""}} {
1348    global expgui
1349    set frm .history
1350    catch {destroy $frm}
1351    toplevel $frm
1352    bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1353    if {[string trim $msg] == ""} {
1354        set msg "There are [CountHistory] history records"
1355    }
1356    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1357    pack [label $frm.1.0 -text $msg] -side top
1358    pack [frame $frm.1.1] -side top
1359    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1360    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1361            ] -side left
1362    set expgui(historyKeep) 10
1363    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1364    set expgui(renumber) 1
1365    pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1366    pack [button $frm.2.help -text Help -bg yellow \
1367            -command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1368    pack [button $frm.2.4 -text Cancel \
1369            -command {destroy .history}] -side bottom
1370    pack [button $frm.2.3 -text OK \
1371            -command { 
1372        if ![catch {expr $expgui(historyKeep)}] {
1373            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1374            set expgui(changed) 1
1375            destroy .history
1376        }
1377    }] -side bottom
1378    bind $frm <Return> "$frm.2.3 invoke"
1379   
1380    # force the window to stay on top
1381    putontop $frm 
1382    focus $frm.2.3
1383    tkwait window $frm
1384    afterputontop
1385}
1386
1387proc archiveexp {} {
1388    global expgui tcl_platform
1389    # is there a file to archive?
1390    if {![file exists $expgui(expfile)]} return
1391    set expnam [file rootname $expgui(expfile)]
1392    # get the last archived version
1393    set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1394    if {$lastf == ""} {
1395        set num 01
1396    } else {
1397        regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1398        scan $num %x num
1399        if {$num >= 255} {
1400            set num FF
1401        } else {
1402            set num [string toupper [format %.2x [incr num]]]
1403        }
1404    }
1405    catch {
1406        set file $expnam.O$num
1407        file copy -force $expgui(expfile) $file
1408        set fp [open $expnam.LST a+]
1409        puts $fp "\n----------------------------------------------"
1410        puts $fp "     Archiving [file tail $expnam.EXP] as [file tail $file]"
1411        puts $fp "----------------------------------------------\n"
1412        close $fp
1413    } errmsg
1414    if {$errmsg != ""} {
1415        tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1416    }
1417}
1418
1419# save and optionally archive the expfile
1420proc savearchiveexp {} {
1421    global expgui expmap
1422    if {$expgui(expfile) == ""} {
1423        SaveAsFile
1424        return
1425    }
1426    if !$expgui(changed) return
1427    if {$expgui(archive)} archiveexp
1428    # add a history record
1429    exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds] -format {%D %T}]"
1430    # now save the file
1431    expwrite $expgui(expfile)
1432    # change the icon and assign an app to this .EXP file
1433    global tcl_platform
1434    if {$tcl_platform(os) == "Darwin" && $expgui(MacAssignApp)} {
1435        MacSetResourceFork $expgui(expfile)
1436    }
1437    set expgui(changed) 0
1438    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1439    set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1440    wm title . $expgui(expfile)
1441    set expgui(titleunchanged) 1
1442    # set convergence criterion
1443    InitLSvars
1444}
1445
1446#------------------------------------------------------------------------------
1447# GSAS interface routines
1448#------------------------------------------------------------------------------
1449# run a GSAS program that does not require an experiment file
1450proc runGSASprog {proglist "concurrent 1"} {
1451    # save call to Macro file
1452    RecordMacroEntry "runGSASprog [list $proglist] $concurrent" 0
1453    # if concurrent is 0, EXPGUI runs the GSAS program in background
1454    # -- this is not currently needed anywhere where the .EXP file is not.
1455    global expgui tcl_platform
1456    set cmd {}
1457    foreach prog $proglist {
1458        StartGRWND $prog
1459        if {$tcl_platform(platform) == "windows"} {
1460            append cmd " \"[file attributes $expgui(gsasexe)/${prog}.exe -shortname]\" "
1461        } else {
1462            if {$cmd != ""} {append cmd "\;"}
1463            append cmd "[file join $expgui(gsasexe) $prog]"
1464        }
1465    }
1466    forknewterm $prog $cmd [expr !$concurrent] 1
1467}
1468
1469# dummy routine, overridden if needed
1470proc StartGRWND {prog} {
1471}
1472
1473# run a GSAS program that requires an experiment file for input/output
1474proc runGSASwEXP {proglist "concurrent 0"} {
1475    # save call to Macro file
1476    RecordMacroEntry "runGSASwEXP [list $proglist] $concurrent" 0
1477    # most programs that require the .EXP file change it and
1478    # cannot be run concurrently
1479    global expgui tcl_platform
1480    # Save the current exp file
1481    savearchiveexp
1482    # load the changed .EXP file automatically?
1483    if {$expgui(autoexpload)} {
1484        # disable the file changed monitor
1485        set expgui(expModifiedLast) 0
1486    }
1487    set cmd {}
1488    set expnam [file root [file tail $expgui(expfile)]]
1489    foreach prog $proglist {
1490        if {$prog == "powpref"} {
1491            set expgui(needpowpref) 0
1492            set expgui(needpowpref_why) ""
1493        } elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1494            set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1495            set ans [MyMessageBox -parent . -title "Run POWPREF" \
1496                    -message $msg -icon warning -type "Yes No" -default yes \
1497                    -helplink "expguierr.html RunPowpref"]
1498            if {$ans == "yes"} {
1499                set expgui(needpowpref) 0
1500                set expgui(needpowpref_why) ""
1501                if {$tcl_platform(platform) == "windows"} {
1502                    append cmd " \"[file attributes $expgui(gsasexe)/powpref.exe -shortname] $expnam \" "
1503                } else {
1504                    if {$cmd != ""} {append cmd "\;"}
1505                    append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1506                }
1507            }
1508        }
1509        StartGRWND $prog
1510        if {$tcl_platform(platform) == "windows"} {
1511            append cmd " \"[file attributes $expgui(gsasexe)/${prog}.exe -shortname] $expnam \" "
1512        } elseif {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1513            append cmd " \" [file join $expgui(gsasexe) $prog] $expnam \" "
1514        } else {
1515            if {$cmd != ""} {append cmd "\;"}
1516            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1517        }
1518    }
1519    if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
1520        set outfile ${expnam}_macout.LST
1521        runnoterm $cmd $outfile
1522    } else {
1523        forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1524    }
1525    # load the changed .EXP file automatically?
1526    if {$expgui(autoexpload)} {
1527        # load the revised exp file
1528        loadexp $expgui(expfile)
1529    }
1530    if {$expgui(MacroRunning)} {
1531        if {[file exists  abort_${expnam}_macro.flag]} {
1532            file delete abort_${expnam}_macro.flag
1533            error "User requested to abort the macro"
1534        }
1535        update idletasks
1536    }
1537}
1538
1539# write text to the .LST file
1540proc writelst {text} {
1541    global expgui
1542    set lstnam [file rootname $expgui(expfile)].LST
1543    set fp [open $lstnam a]
1544    puts $fp "\n-----------------------------------------------------------------"
1545    puts $fp $text
1546    puts $fp "-----------------------------------------------------------------\n"
1547    close $fp
1548}
1549
1550
1551# rename file current to suggested,
1552#   delete window if supplied
1553#   use parent, if supplied or .
1554proc RenameAsFile {current suggested "window {}" "parent {}"} {
1555    if {$parent == "" && $window != ""} {set parent $window}
1556    if {$parent == ""} {set parent .}
1557    set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1558    if {$newfile == ""} return
1559    if {[catch {
1560        file rename -force $current $newfile
1561    }]} {
1562        file copy -force $current $newfile
1563        file delete -force $current
1564    }
1565    if {$window != ""} {destroy $window}
1566}
1567
1568# optionally run disagl as a windowless process, w/results in a separate window
1569proc rundisagl {} {
1570    global expgui txtvw tcl_version tcl_platform
1571    # call up new DISAGL parm edit box
1572    if {[DA_Control_Panel 1]} {return}
1573    # Save the current exp file if needed
1574    savearchiveexp
1575    if {$expgui(disaglSeparateBox)} {
1576        set root [file root $expgui(expfile)] 
1577        catch {file delete -force $root.tmp}
1578        if {[catch {file rename -force $root.LST $root.OLS}]} {
1579            file copy -force $root.LST $root.OLS
1580            file delete -force $root.OLS
1581        }
1582        # PSW reports this does not happen right away on windows
1583        set i 0
1584        while {$i < 10 && [file exists $root.LST]} {
1585            # debug code
1586            #catch {console show}
1587            #puts "try $i"
1588            # end debug code
1589            after 100
1590            incr i
1591        }
1592        if {[file exists $root.LST]} {
1593            # it was not possible to rename the file
1594            MyMessageBox -parent . -title "Rename Problem" \
1595                -message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1596                -icon warning -helplink "expguierr.html NoRename"
1597            return
1598        }
1599
1600        #run the program
1601        pleasewait "Running DISAGL"     
1602        # create an empty input file
1603        close [open disagl.inp w]
1604        catch {exec [file join $expgui(gsasexe) disagl] \
1605                [file tail $root] < disagl.inp > disagl.out}
1606        if {[catch {file rename -force $root.LST $root.tmp}]} {
1607            file copy -force $root.LST $root.tmp
1608            file delete -force $root.LST
1609        }
1610        catch {file delete -force disagl.inp disagl.out}
1611        if {[catch {file rename -force $root.OLS $root.LST}]} {
1612            file copy -force $root.OLS $root.LST
1613            file delete -force $root.OLS
1614        }
1615        donewait
1616        # open a new window
1617        catch {toplevel .disagl}
1618        eval destroy [winfo child .disagl]
1619        set txt .disagl.txt
1620        catch {eval grid forget [grid slaves .disagl]}
1621        text $txt -width 100 -wrap none \
1622                -yscrollcommand ".disagl.yscroll set" \
1623                -xscrollcommand ".disagl.xscroll set" 
1624        scrollbar .disagl.yscroll -command "$txt yview"
1625        scrollbar .disagl.xscroll -command "$txt xview" -orient horizontal
1626        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1627        grid $txt -column 0 -row 1 -sticky nsew
1628        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1629        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1630        grid columnconfig .disagl.f 2 -weight 1
1631        grid [button .disagl.f.close -text "Close & Delete" \
1632                  -command "destroy .disagl; file delete \[list $root.tmp\]"] \
1633                -column 3 -row 0 -sticky e
1634        grid [button .disagl.f.rename \
1635                  -command "RenameAsFile \[list $root.tmp\] \[list $root.DIS\] .disagl" \
1636                -text "Close & Save as..."] \
1637                -column 4 -row 0 -sticky e
1638        # allow font changes on the fly
1639        if {$tcl_version >= 8.0} {
1640            $txt config -font $txtvw(font)
1641            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1642            grid .disagl.f.font -column 1 -row 0 -sticky w
1643            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1644            $fontbut delete 0 end
1645            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1646                $fontbut add command -label "Courier $f" -font "Courier $f"\
1647                        -command "set txtvw(font) \"Courier $f\"; \
1648                        $txt config -font \$txtvw(font)"
1649            }
1650        }
1651       
1652        grid columnconfigure .disagl 0 -weight 1
1653        grid rowconfigure .disagl 1 -weight 1
1654        wm title .disagl "DISAGL results $expgui(expfile)"
1655        wm iconname .disagl "DISAGL $root"
1656        set in [open $root.tmp r]
1657        $txt insert end [read $in]
1658        close $in
1659        bind all  {destroy .disagl}
1660        bind .disagl  "$txt yview scroll -1 page"
1661        bind .disagl  "$txt yview scroll 1 page"
1662        bind .disagl  "$txt xview scroll 1 unit"
1663        bind .disagl  "$txt xview scroll -1 unit"
1664        bind .disagl  "$txt yview scroll -1 unit"
1665        bind .disagl  "$txt yview scroll 1 unit"
1666        bind .disagl  "$txt yview 0"
1667        bind .disagl  "$txt yview end"
1668        # don't disable in Win as this prevents the highlighting of selected text
1669        if {$tcl_platform(platform) != "windows"} {
1670            $txt config -state disabled
1671        }
1672        # find the beginning of the disagl text
1673
1674        set pos 1.0
1675        set nph 0
1676        while {[set loc [$txt search "Program DISAGL Version" $pos end]] != ""} {
1677            set pos [expr {$loc + 1}]
1678            incr nph
1679        }
1680        #puts "Found $nph DISAGL run(s)"
1681        # count phases
1682        set l {}
1683        while {[set loc [$txt search "Lattice constants are" $pos end]] != ""} {
1684            lappend l $loc
1685            set pos [expr {$loc + 1}]
1686}
1687        catch {unset phaseloc}
1688       
1689        set j 0
1690        foreach pos $l {
1691            if {$j == 0} {
1692                set prev $pos
1693                incr j
1694                continue
1695            }
1696            set phaseloc($j) [list $prev $pos]
1697            incr j
1698        }
1699        set phaseloc($j) [list $pos end]
1700        if {$nph >= 1 && $j >= 2} {
1701            grid [menubutton .disagl.f.copy \
1702                      -menu .disagl.f.copy.menu \
1703                      -text "Copy phase..." -bd 2 -relief raised] \
1704                -column 2 -row 0 -sticky nse
1705            menu .disagl.f.copy.menu
1706            for {set i 1} {$i <= $j} {incr i} {
1707                .disagl.f.copy.menu add command \
1708                    -command "seldisaglphase $txt [list $phaseloc($i)]" \
1709                    -label "Copy phase $i to clipboard"
1710            }
1711        } elseif {$nph >= 1} {
1712            grid [button .disagl.f.copy \
1713                      -command "seldisaglphase $txt [list $phaseloc($j)]" \
1714                -text "Copy phase $j to clipboard"] \
1715                -column 2 -row 0 -sticky e
1716        }
1717    } else {
1718        runGSASwEXP disagl
1719    }
1720}
1721
1722proc seldisaglphase {txt phaselist} {
1723    # clear selection
1724    $txt tag remove sel 1.1 end
1725    eval $txt tag add sel $phaselist
1726    clipboard clear
1727    clipboard append "               |         Program DISAGL Version MacOSX        |\n"
1728    clipboard append [eval $txt get [$txt tag ranges sel]]
1729} 
1730#------------------------------------------------------------------------------
1731# file conversions
1732#------------------------------------------------------------------------------
1733proc convfile {} {
1734    global expgui
1735    set frm .file
1736    catch {destroy $frm}
1737    toplevel $frm
1738    wm title $frm "Convert File"
1739    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1740    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1741    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1742            -side left -fill y -expand yes
1743    pack [button $frmC.help -text Help -bg yellow \
1744            -command "MakeWWWHelp expgui.html ConvertWin"] -side top
1745    pack [button $frmC.q -text Cancel -command "destroy $frm"] -side bottom
1746    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1747            -side bottom
1748    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1749    winfilebox $frm
1750    bind $frm <Return> "ValidWinCnv $frm"
1751
1752    # force the window to stay on top
1753    putontop $frm
1754    focus $frmC.q 
1755    tkwait window $frm
1756    afterputontop
1757}
1758
1759# validate the files and make the conversion
1760proc ValidWinCnv {frm} {
1761    global expgui
1762    # change backslashes to something sensible
1763    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1764    # allow entry of D: for D:/ and D:TEST for d:/TEST
1765    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1766            [string first :/ $expgui(FileMenuCnvName)] == -1} {
1767        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1768    }
1769    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1770        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1771        ChooseWinCnv $frm
1772        return
1773    } elseif [file isdirectory \
1774            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1775        if {$expgui(FileMenuCnvName) != "."} {
1776            set expgui(FileMenuDir) \
1777                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1778        }
1779        ChooseWinCnv $frm
1780        return
1781    }
1782 
1783    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1784    if ![file exists $file] {
1785        MyMessageBox -parent $frm -title "Convert Error" \
1786                -message "File $file does not exist" -icon error
1787        return
1788    }
1789
1790    set tmpname "[file join [file dirname $file] tempfile.xxx]"
1791    set oldname "[file rootname $file].org"
1792    if [file exists $oldname] {
1793        set ans [MyMessageBox -parent . -title "Overwrite?" \
1794                -message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1795                -icon warning -type {Overwrite Cancel} -default Overwrite \
1796                -helplink "expguierr.html OverwriteCnv"]
1797        if {[string tolower $ans] == "cancel"} return
1798        catch {file delete $oldname}
1799    }
1800
1801    if [catch {
1802        set in [open $file r]
1803        set out [open $tmpname w]
1804        fconfigure $out -translation crlf -encoding ascii
1805        set len [gets $in line]
1806        if {$len > 160} {
1807            # this is a UNIX file. Hope there are no control characters
1808            set i 0
1809            set j 79
1810            while {$j < $len} {
1811                puts $out [string range $line $i $j]
1812                incr i 80
1813                incr j 80
1814            }
1815        } else {
1816            while {$len >= 0} {
1817                append line "                                        "
1818                append line "                                        "
1819                set line [string range $line 0 79]
1820                puts $out $line
1821                set len [gets $in line]
1822            }
1823        }
1824        close $in
1825        close $out
1826        file rename -force $file $oldname
1827        file rename -force $tmpname $file
1828    } errmsg] {
1829        MyMessageBox -parent $frm -title "Conversion error" \
1830                -message "Error in conversion:\n$errmsg" -icon warning
1831    } else {
1832        set ans [MyMessageBox -parent $frm -title "More?" \
1833                -message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1834                -type yesno -default no]
1835        if {$ans == "no"} {destroy $frm}
1836    }
1837}
1838
1839# create a file box
1840proc winfilebox {frm} {
1841    global expgui
1842    set bx $frm.1
1843    pack [frame $bx.top] -side top
1844    pack [label $bx.top.a -text "Directory" ] -side left
1845    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1846    pack $bx.top.d -side left
1847    set expgui(FileMenuDir) [pwd]
1848    # the icon below is from tk8.0/tkfbox.tcl
1849    set upfolder [image create bitmap -data {
1850#define updir_width 28
1851#define updir_height 16
1852static char updir_bits[] = {
1853   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1854   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1855   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1856   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1857   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1858   0xf0, 0xff, 0xff, 0x01};}]
1859
1860    pack [button $bx.top.b -image $upfolder \
1861            -command "updir; ChooseWinCnv $frm" ]
1862    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1863    listbox $bx.a.files -relief raised -bd 2 \
1864            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1865            -height 15 -width 0 -exportselection 0 
1866    listbox $bx.a.dates -relief raised -bd 2 \
1867            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1868            -height 15 -width 0 -takefocus 0 -exportselection 0 
1869    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1870    ChooseWinCnv $frm
1871    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1872    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1873    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1874    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1875    pack $bx.a.scroll -side left -fill y
1876    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1877    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1878}
1879
1880# set the box or file in the selection window
1881proc ReleaseWinCnv {frm} {
1882    global expgui
1883    set files $frm.1.a.files
1884    set dates $frm.1.a.dates
1885    set select [$files curselection]
1886    if {$select == ""} {
1887        set select [$dates curselection]
1888    }
1889    if {$select == ""} {
1890        set expgui(FileMenuCnvName) ""
1891    } else {
1892        set expgui(FileMenuCnvName) [string trim [$files get $select]]
1893    }
1894    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1895        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1896        ChooseWinCnv $frm
1897    } elseif [file isdirectory \
1898            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1899        if {$expgui(FileMenuCnvName) != "."} {
1900            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1901            ChooseWinCnv $frm
1902        }
1903    }
1904    return
1905}
1906
1907# select a file or directory -- called on double click
1908proc SelectWinCnv {frm} {
1909    global expgui
1910    set files $frm.1.a.files
1911    set dates $frm.1.a.dates
1912    set select [$files curselection]
1913    if {$select == ""} {
1914        set select [$dates curselection]
1915    }
1916    if {$select == ""} {
1917        set file .
1918    } else {
1919        set file [string trim [$files get $select]]
1920    }
1921    if {$file == "<Parent>"} {
1922        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1923        ChooseWinCnv $frm
1924    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1925        if {$file != "."} {
1926            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1927            ChooseWinCnv $frm
1928        }
1929    } else {
1930        set expgui(FileMenuCnvName) [file tail $file]
1931        ValidWinCnv $frm
1932    }
1933}
1934
1935# fill the files & dates & Directory selection box with current directory,
1936# also called when box is created to fill it
1937proc ChooseWinCnv {frm} {
1938    global expgui
1939    set files $frm.1.a.files
1940    set dates $frm.1.a.dates
1941    set expgui(FileMenuCnvName) {}
1942    $files delete 0 end
1943    $dates delete 0 end
1944    $files insert end {<Parent>}
1945    $dates insert end {(Directory)}
1946    set filelist [glob -nocomplain \
1947            [file join [set expgui(FileMenuDir)] *] ]
1948    foreach file [lsort -dictionary $filelist] {
1949        if {[file isdirectory $file]} {
1950            $files insert end [file tail $file]
1951            $dates insert end {(Directory)}
1952        }
1953    }
1954    foreach file [lsort -dictionary $filelist] {
1955        if {![file isdirectory $file]} {
1956            set modified [clock format [file mtime $file] -format "%T %D"]
1957            $files insert end [file tail $file]
1958            $dates insert end $modified
1959        }
1960    }
1961    $expgui(FileDirButtonMenu)  delete 0 end
1962    set list ""
1963    global tcl_version
1964    if {$tcl_version > 8.0} {
1965        catch {set list [string tolower [file volume]]}
1966    }
1967    set dir ""
1968    foreach subdir [file split [set expgui(FileMenuDir)]] {
1969        set dir [string tolower [file join $dir $subdir]]
1970        if {[lsearch $list $dir] == -1} {lappend list $dir}
1971    }
1972    foreach path $list {
1973        $expgui(FileDirButtonMenu) add command -label $path \
1974                -command "[list set expgui(FileMenuDir) $path]; \
1975                ChooseWinCnv $frm"
1976    }
1977    return
1978}
1979
1980#------------------------------------------------------------------------------
1981# set options for liveplot
1982proc liveplotopt {} {
1983    global liveplot expmap
1984    set frm .file
1985    catch {destroy $frm}
1986    toplevel $frm
1987    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1988    set last [lindex [lsort -integer $expmap(powderlist)] end]
1989    if {$last == ""} {set last 1}
1990    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
1991            -length  150 -orient horizontal -variable liveplot(hst)] -side top
1992    pack [checkbutton $frmA.2 -text {include plot legend}\
1993            -variable liveplot(legend)] -side top
1994    pack [button $frm.2 -text OK \
1995            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1996            ] -side top
1997    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1998   
1999    # force the window to stay on top
2000    putontop $frm 
2001    focus $frm.2
2002    tkwait window $frm
2003    afterputontop
2004}
2005
2006#------------------------------------------------------------------------------
2007# get/validate an experiment file name
2008#------------------------------------------------------------------------------
2009# validate and store the EXP file name. Create a new .EXP file if it does not
2010# exist and set the wd to the location of the .EXP file.
2011proc SetEXPfile {expfile "newOK 0"} {
2012    global expgui tcl_platform
2013    if {[string trim $expfile] == ""} return
2014
2015    # break up the file name and directory
2016    set dirname [file dirname $expfile]
2017    set expname [string toupper [file tail $expfile]]
2018
2019    # check the directory exists
2020    if {(! [file exists $dirname]) || (! [file isdir $dirname])} {
2021        update
2022        MyMessageBox -parent . -title "Directory not found" \
2023            -message "Experiment file location \"$dirname\" is invalid -- no such directory exists" \
2024            -icon warning -type Continue -default continue
2025        set expgui(resize) 1
2026        return
2027    }
2028
2029    # is there a space in the directory name? On windows, try to fix it
2030    set origdir $dirname
2031    if {[string first " " $dirname] != -1} {
2032        set warn 1
2033        catch {set warn $expgui(warnonspaceonce)}
2034        if {$tcl_platform(platform) == "windows"} {
2035            set dirname [file attributes $dirname -shortname]
2036            # was the fix successful?
2037            if {[string first " " $dirname] == -1} {
2038                if {$warn} {
2039                    update
2040                    MyMessageBox -parent . -title "Still debugging..." \
2041                        -message "You are using a directory with a space in the name ($origdir) that will be translated for Windows (to $dirname) -- This should obliviate bugs in EXPGUI, but if still you encounter any please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2042                    -icon warning -type Continue -default continue
2043                    set expgui(resize) 1
2044                }
2045            } else {
2046                if {$warn} {
2047                    update
2048                    MyMessageBox -parent . -title "Can't fix dir" \
2049                        -message "You are using a directory with a space in the name ($origdir) in Windows that cannot be translated to a name without spaces (is this a network drive?) -- this could cause problems in EXPGUI. Please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2050                        -icon warning -type Continue -default continue
2051                    set expgui(resize) 1
2052                }
2053            }
2054        } elseif {$warn} {
2055            if {$warn} {
2056                update
2057                MyMessageBox -parent . -title "Still debugging..." \
2058                    -message "You are using a directory with a space in the name ($origdir). This is not perhaps a wise idea, but I am trying to catch any bugs this causes in EXPGUI. If you encounter any, please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2059                    -icon warning -type Continue -default continue
2060                set expgui(resize) 1
2061            }
2062        }
2063        set expgui(warnonspaceonce) 0
2064    }
2065
2066    # force exp files to be upper case, set to force save if name changes
2067    set origexp $expname
2068    if {$expname != [file tail $expfile] && $tcl_platform(platform) != "windows"} {
2069        set expgui(changed) 1
2070    }
2071    #puts $expgui(expfile)
2072    if {[string match {.O[0-9A-F][0-9A-F]} [file extension $expname]]} {
2073        set expname [ArchiveChoice $expname]
2074        set dirname ""
2075        if {$expname == ""} return
2076    } elseif {[file extension $expname] != ".EXP"} {
2077        append expname ".EXP"
2078    }
2079    if {$dirname == "." || $dirname == ""} {
2080        set newexpfile $expname
2081    } else {
2082        set newexpfile [file join $dirname $expname]
2083    }
2084    # is there a space in the EXP name?
2085    if {[string first " " $expname] != -1} {
2086        # If the file exists in windows, see if there is an equivalent name available.
2087        # if not, we could try to create it and then see, but that is too much
2088        # work.
2089        if {$tcl_platform(platform) == "windows"} { 
2090            if {[file exists $newexpfile]} {
2091                # try to translate it, if possible
2092                set expname [file tail [file attributes $newexpfile -shortname]]
2093                set newexpfile [file join $dirname $expname]
2094                # fixed?
2095                if {[string first " " $expname] == -1} {
2096                    set warn 1
2097                    catch {set warn $expgui(warnonexpspaceonce)}
2098                    if {$warn} {
2099                        update
2100                        MyMessageBox -parent . -title "Still debugging..." \
2101                            -message "You are using an EXP file name with a space in the name ($origexp) that will be translated for Windows (to $expname) -- This should obliviate bugs in EXPGUI, but if you still do encounter any please e-mail bug details to Brian.Toby@ANL.gov so they can be fixed." \
2102                            -icon warning -type Continue -default continue
2103                    set expgui(resize) 1
2104                    }
2105                    set expgui(warnonexpspaceonce) 0
2106                }
2107            } 
2108            if {[string first " " $expname] != -1} {
2109                # not fixed (file does not exist or shortname not supported)
2110                update
2111                MyMessageBox -parent . -title "Can't fix name" \
2112                    -message "You are using an EXP file name with a space in the name ($origexp) in Windows that cannot be translated without spaces (is this a network drive?) -- this will cause problems in EXPGUI. Sorry." \
2113                    -icon warning -type Continue -default continue
2114                set expgui(resize) 1
2115                return
2116            }
2117        } else {
2118            update
2119            MyMessageBox -parent . -title "Space in name" \
2120                -message "You are using an EXP file name with a space in the name ($origexp). This is likely to cause problems. Please rename the file or create one with another name. Sorry." \
2121                -icon warning -type Continue -default continue
2122            set expgui(resize) 1
2123            return
2124        }
2125    }
2126
2127    if {(! $newOK) && (! [file exists $newexpfile])} {
2128        update
2129        set ans [
2130                 MyMessageBox -parent . -title "File Open Error" \
2131                     -message "File $expname does not exist in ${dirname}. OK to create?" \
2132                     -icon question -type {"Select other" "Create"} -default "select other" \
2133                     -helplink "expguierr.html OpenErr"
2134                ]
2135        set expgui(resize) 1
2136        if {[string tolower $ans] == "create"} {
2137            # you've been warned this .EXP does not exist!
2138            if [CreateMTexpfile $newexpfile] return
2139        } else {
2140            return
2141        }
2142    }
2143    catch {cd [string trim [file dirname $newexpfile]]}
2144    return $newexpfile
2145}
2146
2147proc ArchiveChoice {expfile} {
2148    set expnam [file rootname $expfile]
2149    set ans [MyMessageBox -parent . -title "Load Archived File" \
2150        -message "Loading archived version of $expnam. Do you want to continue using the same experiment name or work with the archived version under a new name?" \
2151        -icon question -type "{Use New Name} {Continue with current}" \
2152        -default {Use New Name} \
2153        -helplink "expguierr.html LoadArchived"
2154    ]
2155    # archive the current .EXP file
2156    if {$ans != "use new name" && [file exists $expfile]} {
2157        # get the last archived version
2158        set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
2159        if {$lastf == ""} {
2160            set num 01
2161        } else {
2162            regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
2163            scan $num %x num
2164            if {$num >= 255} {
2165                set num FF
2166            } else {
2167                set num [string toupper [format %.2x [incr num]]]
2168            }
2169        }
2170        catch {
2171            set newfile $expnam.O$num
2172            file rename -force $expnam.EXP $newfile
2173            set fp [open $expnam.LST a+]
2174            puts $fp "\n----------------------------------------------"
2175            puts $fp "     Regressing to archive file [file tail $expfile]"
2176            puts $fp "     but first archiving [file tail $expnam.EXP] as [file tail $newfile]"
2177            puts $fp "----------------------------------------------\n"
2178            close $fp
2179        }
2180        file copy -force $expfile $expnam.EXP
2181        set expfile $expnam.EXP
2182    }
2183    if {$ans == "use new name"} {
2184        set newexpfile [getExpFileName new]
2185        if {$newexpfile == ""} {
2186            set expgui(FileMenuEXPNAM) ""
2187            return 
2188        }
2189        file copy -force $expfile $newexpfile
2190        set expgui(needpowpref) 2
2191        set expgui(needpowpref_why) "\tA new .EXP file was created\n" 
2192        return $newexpfile
2193    } else {
2194        return $expfile
2195    }
2196}
2197
2198# create an "empty" exp file
2199proc CreateMTexpfile {newexpfile} {
2200    set expname [file tail $newexpfile]
2201    createexp $newexpfile \
2202        [getstring "title for experiment $expname" 60 0]
2203    if {! [file exists $newexpfile]} {
2204        update
2205        MyMessageBox -parent . -title "File Creation Error" \
2206            -message "Experiment file name \"$expname\" was not created -- This is unexpected, please try a different name" \
2207            -icon warning -type Continue -default continue
2208        set ::expgui(resize) 1
2209        return 1
2210    }
2211    return 0
2212}
2213
2214proc getExpFileName {mode} {
2215    global expgui tcl_platform
2216    set frm .file
2217    catch {destroy $frm}
2218    toplevel $frm
2219    wm title $frm "Experiment file"
2220    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
2221    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
2222    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
2223            -fill y -expand yes
2224    pack [button $frmC.help -text Help -bg yellow \
2225            -command "MakeWWWHelp expguierr.html open"] \
2226            -side top -anchor e
2227    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
2228    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
2229            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
2230    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
2231            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
2232
2233    set expgui(includearchived) 0
2234    set expgui(FileInfoBox) $frmC.info
2235    if {$mode == "old"} {
2236        pack [checkbutton $frmC.ar -text "Include Archived Files" \
2237                -variable expgui(includearchived) \
2238                -command "ChooseExpFil $frmA"] -side top -pady 10
2239        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
2240                -class SmallFont] \
2241                -side top -fill both -expand yes -pady 5
2242    } elseif {$mode != "new"} {
2243        # for initial read, don't offer access to archived files
2244        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
2245                -class SmallFont] \
2246                -side top -fill both -expand yes -pady 5
2247        set mode "old"
2248    }
2249    pack [button $frmC.b -text Read \
2250            -command "valid_exp_file $frmA $mode"] -side bottom
2251    if {$mode == "new"} {
2252        $frmC.b config -text Save
2253    }
2254    pack [button $frmC.q -text Cancel \
2255            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
2256    bind $frm <Return> "$frmC.b invoke"
2257
2258    if {$mode == "new"} {
2259        pack [label $frmA.0 -text "Enter an experiment file to create"] \
2260                -side top -anchor center
2261    } else {
2262        pack [label $frmA.0 -text "Select an experiment file to read"] \
2263                -side top -anchor center
2264    }
2265    expfilebox $frmA $mode
2266    # force the window to stay on top
2267    putontop $frm
2268    focus $frmC.b
2269    tkwait window $frm
2270    afterputontop
2271    if {$expgui(FileMenuEXPNAM) == ""} return
2272    #puts "end getexp $expgui(expfile)"
2273    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2274}
2275
2276# validation routine
2277# called from getExpFileName, either from Read button or from SelectExpFil (see expfilebox)
2278proc valid_exp_file {frm mode} {
2279    global expgui tcl_platform
2280    # windows fixes
2281    if {$tcl_platform(platform) == "windows"} {
2282        # change backslashes to something sensible
2283        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
2284        # allow entry of D: for D:/ and D:TEST for d:/TEST
2285        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
2286                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
2287            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
2288        }
2289    }
2290    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2291        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2292        ChooseExpFil $frm
2293        return
2294    } elseif [file isdirectory \
2295            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
2296        if {$expgui(FileMenuEXPNAM) != "."} {
2297            set expgui(FileMenuDir) \
2298                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2299        }
2300        ChooseExpFil $frm
2301        return
2302    }
2303    set ext [string toupper [file extension $expgui(FileMenuEXPNAM)]]
2304    if {$ext == ""} {
2305        # append a .EXP if not present
2306        append expgui(FileMenuEXPNAM) ".EXP"
2307    } elseif {[string match {*.O[0-9A-F][0-9A-F]} $ext] && \
2308            $mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
2309        # check for archive files
2310        destroy .file
2311        return
2312    } elseif {$ext != ".EXP"} {
2313        # check for files that end in something other than .EXP .exp or .Exp...
2314        MyMessageBox -parent . -title "File Open Error" \
2315                -message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
2316                -icon error
2317        return
2318    }
2319    # check on the file status
2320    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2321    if {$mode == "new" && [file exists $file]} {
2322        set ans [
2323        MyMessageBox -parent . -title "File Open Error" \
2324                -message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
2325                -icon question -type {"Select other" "Overwrite"} -default "select other" \
2326                -helplink "expguierr.html OverwriteErr"
2327        ]
2328        if {[string tolower $ans] == "overwrite"} {destroy .file}
2329        return
2330    }
2331    # if file does not exist in case provided, set the name to all
2332    # upper case letters, since that is the best choice.
2333    # if it does exist, read from it as is. For UNIX we will force uppercase later.
2334    if {![file exists $file]} {
2335        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
2336        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2337    }
2338    if {$mode == "old" && ![file exists $file]} {
2339        set ans [
2340        MyMessageBox -parent . -title "File Open Error" \
2341                -message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
2342                -icon question -type {"Select other" "Create"} -default "select other" \
2343                -helplink "expguierr.html OpenErr"
2344        ]
2345        if {[string tolower $ans] == "create"} {
2346            if [CreateMTexpfile $file] return
2347            destroy .file
2348        }
2349        return
2350    }
2351    destroy .file
2352}
2353
2354proc updir {} {
2355    global expgui
2356    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
2357}
2358
2359# create a file box
2360proc expfilebox {bx mode} {
2361    global expgui
2362    pack [frame $bx.top] -side top
2363    pack [label $bx.top.a -text "Directory" ] -side left
2364    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
2365    pack $bx.top.d -side left
2366    set expgui(FileMenuDir) [pwd]
2367    # the icon below is from tk8.0/tkfbox.tcl
2368    set upfolder [image create bitmap -data {
2369#define updir_width 28
2370#define updir_height 16
2371static char updir_bits[] = {
2372   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
2373   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
2374   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
2375   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
2376   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
2377   0xf0, 0xff, 0xff, 0x01};}]
2378
2379    pack [button $bx.top.b -image $upfolder \
2380            -command "updir; ChooseExpFil $bx" ]
2381    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2382    listbox $bx.a.files -relief raised -bd 2 \
2383            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
2384            -height 15 -width 0 -exportselection 0 
2385    listbox $bx.a.dates -relief raised -bd 2 \
2386            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
2387            -height 15 -width 0 -takefocus 0 -exportselection 0 
2388    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2389    ChooseExpFil $bx
2390    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2391    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2392    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
2393    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
2394    pack $bx.a.scroll -side left -fill y
2395    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2396    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2397}
2398proc sync2boxesX {master slave scroll args} {           
2399    $slave xview moveto [lindex [$master xview] 0]               
2400    eval $scroll set $args               
2401}               
2402proc move2boxesX {boxlist args} {               
2403    foreach listbox $boxlist {                   
2404        eval $listbox xview $args               
2405    }           
2406}
2407proc sync2boxesY {master slave scroll args} {
2408    $slave yview moveto [lindex [$master yview] 0]
2409    eval $scroll set $args
2410}
2411proc move2boxesY {boxlist args} {
2412    foreach listbox $boxlist { 
2413        eval $listbox yview $args
2414    }
2415}
2416
2417# creates a table that is scrollable in both x and y, use ResizeScrollTable
2418# to set sizes after gridding the widgets
2419proc MakeScrollTable {box} {
2420    proc sync2boxes {cmd master slave scroll args} {
2421        $slave $cmd moveto [lindex [$master $cmd] 0]
2422        eval $scroll set $args
2423    }
2424    proc move2boxes {cmd box1 box2 args} {
2425        eval $box1 $cmd $args
2426        eval $box2 $cmd $args
2427    }
2428    grid [label $box.0] -column 0 -row 0
2429    grid [canvas $box.top -scrollregion {0 0 10 10} \
2430            -xscrollcommand "sync2boxes xview $box.top $box.can $box.scroll" \
2431            -width 10 -height 10] -sticky sew -row 0 -column 1
2432    grid [canvas $box.side -scrollregion {0 0 10 10} \
2433            -yscrollcommand "sync2boxes yview $box.side $box.can $box.yscroll" \
2434            -width 10 -height 10] -sticky nes -row 1 -column 0
2435    grid [canvas $box.can -scrollregion {0 0 10 10} \
2436            -yscrollcommand "sync2boxes yview $box.can $box.side $box.yscroll" \
2437            -xscrollcommand "sync2boxes xview $box.can $box.top $box.scroll" \
2438            -width 200 -height 200 -bg lightgrey] -sticky news -row 1 -column 1
2439    grid [set sxbox [scrollbar $box.scroll -orient horizontal \
2440                         -command "move2boxes xview $box.can $box.top"]] \
2441            -sticky ew -row 2 -column 1
2442    grid [set sybox [scrollbar $box.yscroll \
2443                         -command "move2boxes yview $box.can $box.side"]] \
2444            -sticky ns -row 1 -column 2
2445
2446    $box.top create window 0 0 -anchor nw  -window [frame $box.top.f -bd 0]
2447    $box.can create window 0 0 -anchor nw  -window [frame $box.can.f -bd 2]
2448    $box.side create window 0 0 -anchor nw  -window [frame $box.side.f -bd 2]
2449    grid columnconfig $box 1 -weight 1
2450    grid rowconfig $box 1 -weight 1
2451    return [list  $box.top.f  $box.can.f $box.side.f $box.0]
2452}
2453
2454proc ResizeScrollTable {box} {
2455    update idletasks
2456    for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2457        set x1 [lindex [grid bbox $box.can.f $i 0] 2]
2458        set x2 [lindex [grid bbox $box.top.f $i 0] 2]
2459        if {$x2 > $x1} {set x1 $x2}
2460        grid columnconfigure $box.top.f $i -minsize $x1
2461        grid columnconfigure $box.can.f $i -minsize $x1
2462    }
2463    for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2464        set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2465        set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2466        if {$x2 > $x1} {set x1 $x2}
2467        grid rowconfigure $box.can.f $i -minsize $x1
2468        grid rowconfigure $box.side.f $i -minsize $x1
2469    }
2470    update idletasks
2471    set sizes [grid bbox $box.can.f]
2472    $box.can config -scrollregion $sizes
2473    $box.side config -scrollregion $sizes
2474    $box.top config -scrollregion $sizes
2475    $box.side config -width [lindex [grid bbox $box.side.f] 2]
2476    $box.top config -height [lindex [grid bbox $box.top.f] 3]
2477    # remove the scroll when not needed
2478    if {[lindex $sizes 3] > [winfo height $box.can]} {
2479        grid $box.yscroll -sticky ns -column 2 -row 1
2480    } else {
2481        grid forget $box.yscroll
2482    }
2483    if {[lindex $sizes 2] > [winfo width $box.can]} {
2484        grid $box.scroll -sticky ew -column 1 -row 2
2485    } else {
2486        grid forget $box.scroll
2487    }
2488}
2489
2490proc MouseWheelScrollTable {box} {
2491     # causes mouse wheel to operate scroll for main canvas in ScrollTable
2492     # mousewheel can be operated anywhere in parent window
2493    bind [winfo toplevel $box] <MouseWheel> "$box.can yview scroll \[expr {-abs(%D)/%D}\] unit"
2494}
2495
2496
2497# this is used in cifselect -- not sure why anymore
2498proc ExpandScrollTable {box} {
2499    # set height & width of central box
2500    $box.can config -width \
2501            [expr [winfo width [winfo toplevel $box]] \
2502            - [winfo width $box.side] - [winfo width $box.yscroll]-20]
2503    $box.can config -height \
2504            [expr [winfo height [winfo toplevel $box]] \
2505            - [winfo height $box.top] - [winfo height $box.scroll]-25]
2506}
2507proc RevertExpFile {} {
2508    global expgui tcl_platform
2509    set frm .file
2510    catch {destroy $frm}
2511    toplevel $frm
2512    wm title $frm "Experiment file"
2513    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
2514    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
2515    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
2516            -fill y -expand yes
2517    pack [button $frmC.help -text Help -bg yellow \
2518            -command "MakeWWWHelp expguierr.html open"] \
2519            -side top -anchor e
2520    set expgui(filesort) 0
2521    set expgui(includearchived) 1
2522    set expgui(FileInfoBox) $frmC.info
2523    pack [label $frmC.ar -text "(Showing Archived Files Only)"] -side top -pady 10
2524    pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
2525              -class SmallFont] \
2526        -side top -fill both -expand yes -pady 5
2527
2528    pack [button $frmC.b -text Read \
2529            -command "valid_exp_file $frmA old"] -side bottom
2530    pack [button $frmC.q -text Cancel \
2531            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
2532    bind $frm <Return> "$frmC.b invoke"
2533
2534    pack [label $frmA.0 -text "Select an archived experiment file to read"] \
2535                -side top -anchor center
2536    set bx $frmA 
2537    pack [frame $bx.top] -side top
2538    #pack [label $bx.top.a -text "Directory" ] -side left
2539    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
2540    #pack $bx.top.d -side left
2541    #set expgui(FileMenuDir) [pwd]
2542    # the icon below is from tk8.0/tkfbox.tcl
2543    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2544    listbox $bx.a.files -relief raised -bd 2 \
2545            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
2546            -height 15 -width 0 -exportselection 0 
2547    listbox $bx.a.dates -relief raised -bd 2 \
2548            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
2549            -height 15 -width 0 -takefocus 0 -exportselection 0 
2550    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2551    ChooseExpFil $bx 1
2552    if {[llength [$bx.a.files get 0 end]] == 0} {
2553        destroy $frm
2554        MyMessageBox -parent . -title "No Archives" \
2555            -message "Sorry no archived versions of $::expgui(expfile) are present" \
2556                    -icon warning -type ok -default ok
2557        return
2558    }
2559    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2560    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2561    bind $bx.a.files <Double-1> "SelectExpFil $bx old"
2562    bind $bx.a.dates <Double-1> "SelectExpFil $bx old"
2563    pack $bx.a.scroll -side left -fill y
2564    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2565    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2566    # force the window to stay on top
2567    putontop $frm
2568    focus $frmC.b
2569    tkwait window $frm
2570    afterputontop
2571    if {$expgui(FileMenuEXPNAM) == ""} return
2572    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2573}
2574
2575# support routine for SetHistUseFlags
2576proc InitHistUseFlags {} {
2577    global expmap expgui
2578    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2579#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2580            set expgui(useflag_$i) [histinfo $i use]
2581#       }
2582    }
2583}
2584
2585# show all Powder histograms; set use/do not use flags
2586proc SetHistUseFlags {} {
2587    set box .test
2588    catch {toplevel $box}
2589    eval destroy [winfo children $box]
2590    grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2591    grid [frame $box.a] -row 1 -column 0 -columnspan 2
2592    grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2593    grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2594    grid columnconfig $box 0 -weight 1
2595    grid columnconfig $box 1 -weight 1
2596    foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2597    $cbox config -text "Use\nFlag"
2598    [winfo parent $bbox] config -height 250 -width 400
2599    global expmap expgui
2600    set px 5
2601    set row -1
2602    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2603        if {[string range $expmap(htype_$i) 2 2] == "T"} {
2604            set det [format %8.2f [histinfo $i tofangle]]
2605        } elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2606            set det [format %8.5f [histinfo $i lam1]]
2607        } elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2608            set det [format %8.2f [histinfo $i lam1]]
2609        } else {
2610            set det {}
2611        }
2612        incr row
2613#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2614            grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0 
2615            set expgui(useflag_$i) [histinfo $i use]
2616#       }
2617        grid [label $bbox.0$i \
2618                -text [string range $expmap(htype_$i) 0 3] \
2619                ] -row $row -column 0 -padx $px
2620        grid [label $bbox.1$i -text [histinfo $i bank] \
2621                ] -row $row -column 1 -padx $px
2622        grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2623        grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2624                ] -row $row -column 3 -padx $px -sticky ew
2625    }
2626    grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2627    grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2628    grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2629    grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2630    ResizeScrollTable $box.a
2631    InitHistUseFlags
2632    putontop $box
2633    tkwait window $box
2634    afterputontop
2635    set prevchages $expgui(changed)
2636    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2637#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2638            if {$expgui(useflag_$i) != [histinfo $i use]} {
2639                histinfo $i use set $expgui(useflag_$i)
2640                RecordMacroEntry "histinfo $i use set $expgui(useflag_$i)" 0
2641                incr expgui(changed)
2642                RecordMacroEntry "incr expgui(changed)" 0
2643            }
2644#       }
2645    }
2646    if {$prevchages != $expgui(changed)} {
2647        set msg "You have changed [expr $expgui(changed)-$prevchages] "
2648        append msg "histogram flag(s). You must run POWPREF "
2649        append msg "to include/remove these histograms. Do you want to "
2650        append msg "run POWPREF?"
2651        set ans [MyMessageBox -parent . -message $msg \
2652                -title "Process changes?"\
2653                -helplink "expguierr.html ProcessUse" \
2654                -default {Run POWPREF} \
2655                -type {{Run POWPREF} Skip}]
2656       
2657        if {$ans == "skip"} {
2658            # save and reload the experiment file
2659            savearchiveexp
2660            loadexp $expgui(expfile)
2661        } else {
2662            # run powpref and force a reload
2663            set saveautoload $expgui(autoexpload)
2664            set expgui(autoexpload) 1
2665            runGSASwEXP powpref
2666            set expgui(autoexpload) $saveautoload
2667        }
2668    }
2669}
2670
2671# set the box or file in the selection window
2672proc ReleaseExpFil {frm} {
2673    global expgui
2674    set files $frm.a.files
2675    set dates $frm.a.dates
2676    set select [$files curselection]
2677    if {$select == ""} {
2678        set select [$dates curselection]
2679    }
2680    if {$select == ""} {
2681        set expgui(FileMenuEXPNAM) ""
2682    } else {
2683        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2684        after idle UpdateInfoBox
2685    }
2686    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2687        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2688        ChooseExpFil $frm
2689    } elseif [file isdirectory \
2690            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2691        if {$expgui(FileMenuEXPNAM) != "."} {
2692            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2693            ChooseExpFil $frm
2694        }
2695    }
2696    return
2697}
2698
2699proc ScanEXPforError {"ns {}"} {
2700    # record types to ignore
2701    set ignorelist {DESCR HSTRY PNAM HNAM "REFN STATS"}
2702    set warn {}
2703    set badkeylist {}
2704    # scan file for warnings
2705    foreach key [array names ${ns}::exparray] {
2706        if {[string first "***" [set ${ns}::exparray($key)]] != -1 || 
2707            [string first "#IN" [set ${ns}::exparray($key)]] != -1 ||
2708            [string first "nan" [set ${ns}::exparray($key)]] != -1 ||
2709            [string first "NAN" [set ${ns}::exparray($key)]] != -1 
2710        } {
2711            #puts [set ${ns}::exparray($key)]
2712            set OK 0
2713            foreach i $ignorelist {
2714                if {[string first $i $key] != -1} {
2715                    set OK 1
2716                    break
2717                }
2718            }
2719            # ignore atom name section of Atom records
2720            if {(! $OK) && [string match  "CRS*AT*A" $key]} {
2721                foreach str [list [string range [set ${ns}::exparray($key)] 0 49] 
2722                             [string range [set ${ns}::exparray($key)] 58 end]] {
2723                    if {[string first "***" $str] || 
2724                        [string first "#INF" $str] || 
2725                        [string first "nan" $str] || 
2726                        [string first "NAN" $str]} {
2727                        append warn "  Record \"$key\": [set ${ns}::exparray($key)]\n"
2728                        lappend badkeylist $key
2729                        break
2730                    }
2731                }
2732                continue
2733            }
2734            if {! $OK} {
2735                append warn "  Record \"$key\": [set ${ns}::exparray($key)]\n"
2736                lappend badkeylist $key
2737            }
2738        }
2739    }
2740    if {$warn == ""} return
2741    set hint ""
2742    set unknown ""
2743    foreach key $badkeylist {
2744        if {[string match  "CRS*AT*" $key]} {
2745            if {[string first "atomic parameter" $hint] == -1} {
2746                append hint "\t* An atomic parameter (coordinate, occupancy or U) appears out of range\n"
2747            }
2748        } elseif {[string match  "CRS*ABC*" $key] || 
2749                  [string match  "CRS*ANGLES*" $key] || 
2750                  [string match  "CRS*CELVOL*" $key]} {
2751            if {[string first "cell parameter" $hint] == -1} {
2752                append hint "\t* A unit cell parameter appears out of range\n"
2753            }
2754        } elseif {[string match  "CRS*ODF*" $key]} {
2755            if {[string first "spherical harmonic" $hint] == -1} {
2756                append hint "\t* A spherical harmonic (ODF) parameter appears out of range\n"
2757            }
2758        } elseif {[string match  "HST*ICONS" $key]} {
2759            if {[string first "diffractometer constant" $hint] == -1} {
2760                append hint "\t* A diffractometer constant (wave, DIFC,...) appears out of range\n"
2761            }
2762        } elseif {[string match  "HST*TRNGE" $key]} {
2763            if {[string first "histogram data range" $hint] == -1} {
2764                append hint "\t* A histogram data range value appears out of range\n"
2765            }
2766        } elseif {[string match "*GNLS  RUN*" $key] || 
2767                  [string match "*GNLS SHFTS" $key] ||
2768                  [string match "HST*RPOWD" $key] ||
2769                  [string match " REFN RPOWD " $key] ||
2770                  [string match " REFN GDNFT " $key]
2771              } {
2772            if {[string first "refinement statistics" $hint] == -1} {
2773                append hint "\t* The refinement statistics imply the last refinement diverged\n"
2774            }
2775        } else {
2776            lappend unknown $key
2777        }
2778    }
2779    if {$unknown != ""} {
2780        append hint "\t* The following less common problem record(s) appear out of range:\n\t\t"
2781        foreach key $unknown {
2782            append hint "\"" [string trim $key] "\" "
2783        }
2784    }
2785    return "Likely error(s) noted:\n$hint\nDetails of problem(s):\n$warn"
2786}
2787
2788proc ExplainEXPerror {parent message file} {
2789    if {$parent == "."} {
2790        set w .experr
2791    } else {
2792        set w $parent.experr
2793    }
2794    catch {destroy $w}
2795    toplevel $w -class Dialog
2796    wm title $w "Corrupt .EXP file"
2797    wm iconname $w Dialog
2798    wm protocol $w WM_DELETE_WINDOW { }
2799    # Make the message box transient if the parent is viewable.
2800    if {[winfo viewable [winfo toplevel $parent]] } {
2801        wm transient $w $parent
2802    } 
2803    frame $w.bot
2804    pack $w.bot -side bottom -fill both
2805    frame $w.top
2806    pack $w.top -side top -fill both -expand 1
2807    frame $w.msg
2808    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
2809    set txt {Likely errors were noted when reading this file}
2810    append txt " ([file tail $file]). "
2811    append txt "These problems probably\narose from the last refinement, "
2812    append txt "based on settings applied in the previous saved file.\n"
2813    append txt "It is probably not possible to continue with this file.\n"
2814    append txt "You likely need to revert at least two archived versions back."
2815    grid [label $w.msg.s -text $txt -justify left] -row 0 -column 0 -sticky nws
2816    grid [button $w.msg.1 -text Help -bg yellow \
2817              -command "MakeWWWHelp expgui.html badexp"] -row 0 -column 1 -columnspan 2 -sticky ne
2818    bind $w <Key-F1> "MakeWWWHelp expgui.html badexp"
2819    set filelist [lsort -dictionary -decreasing \
2820                      [glob -nocomplain \
2821                           [file root $file.O* ]]]
2822    grid [text  $w.msg.t -font {Times 12} \
2823              -height 10 -width 90 -relief flat -wrap word \
2824              -yscrollcommand "$w.msg.rscr set" \
2825             ] -row 1 -column 0  -columnspan 2 -sticky news
2826    grid [scrollbar $w.msg.rscr  -command "$w.msg.t yview" \
2827             ] -row 1 -column 2 -sticky ns
2828    # give extra space to the text box
2829    grid columnconfigure $w.msg 0 -weight 1
2830    grid rowconfigure $w.msg 1 -weight 1
2831    $w.msg.t insert end $message
2832    button $w.ok -command [list destroy $w] -text OK -default active
2833    pack $w.ok -in $w.bot -side left -expand 1 -padx 3m -pady 2m
2834    putontop $w
2835    tkwait window $w
2836    afterputontop
2837}
2838
2839proc UpdateInfoBox {} {
2840    global expgui
2841    if {![winfo exists $expgui(FileInfoBox)]} return
2842    eval destroy [winfo children $expgui(FileInfoBox)]
2843    set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2844    if [file isdirectory $file] return
2845    if [file exists $file] {   
2846        pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2847                -side top
2848        catch {
2849            # load the EXP file into a namespace & scan for errors
2850            expload $file scan
2851            set warnings [ScanEXPforError scan]
2852            if {$warnings != ""} {
2853                pack [frame $expgui(FileInfoBox).1a -bg yellow -padx 4 -pady 4] -side top
2854                pack [label $expgui(FileInfoBox).1a.err -justify left \
2855                          -text "WARNING: Likely corrupt" -bg yellow] \
2856                    -side left -anchor w -fill both
2857                pack [button $expgui(FileInfoBox).1a.show \
2858                          -text "More..." -padx 0 \
2859                          -command "ExplainEXPerror $expgui(FileInfoBox) [list $warnings] $file"\
2860                         ] -side right -anchor w
2861            }
2862            set fp [open $file r]
2863            global testline
2864            set testline [read $fp]
2865            close $fp
2866            update
2867            regexp {GNLS  RUN on (.*) +Total.*run *([0-9]+) } \
2868                    $testline a last cycles
2869            pack [label $expgui(FileInfoBox).2 -justify left \
2870                    -text "last GENLES run:\n  $last\n  total cycles: $cycles"] \
2871                -side top -anchor w
2872            set chi2 ?
2873            set vars ?
2874            regexp {REFN GDNFT.*= *([0-9]*\.[0-9]*) +for *([0-9]+) variables} \
2875                    $testline a chi2 vars
2876            pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
2877                    -side top -anchor w
2878            pack [label $expgui(FileInfoBox).3.a -justify left \
2879                    -text "c" -font symbol] \
2880                    -side left -anchor w
2881            pack [label $expgui(FileInfoBox).3.b -justify left \
2882                    -text "2: $chi2, $vars vars"] \
2883                    -side top -anchor w
2884            # check first 9 histograms
2885            set lbl "h  Rwp     R(F2)"
2886            set n 0
2887            foreach k {1 2 3 4 5 6 7 8 9} {
2888                set key "HST  $k"
2889                append key { RPOWD +([0-9]*\.[0-9]*) }
2890                set i [regexp $key $testline a Rwp]
2891                set key "HST  $k"
2892                append key { R-FAC +[0-9]+ +([0-9]*\.[0-9]*) }
2893                set j [regexp $key $testline a Rb]
2894                if {$i || $j} {
2895                    incr n
2896                    append lbl "\n$k  "
2897                    if {$i} {
2898                        append lbl [string range $Rwp 0 5]
2899                    } else {
2900                        append lbl "    "
2901                    }
2902                }
2903                if {$j} {
2904                    append lbl " [string range $Rb 0 5]"
2905                }
2906                # stick 1st 3 entries in box
2907                if {$n >= 3} break
2908            }
2909            pack [label $expgui(FileInfoBox).4 -justify left \
2910                    -text $lbl] \
2911                    -side top -anchor w     
2912        } err
2913    }
2914}
2915
2916# select a file or directory -- called on double click
2917proc SelectExpFil {frm mode} {
2918    global expgui
2919    set files $frm.a.files
2920    set dates $frm.a.dates
2921    set select [$files curselection]
2922    if {$select == ""} {
2923        set select [$dates curselection]
2924    }
2925    if {$select == ""} {
2926        set file .
2927    } else {
2928        set file [string trim [$files get $select]]
2929    }
2930    if {$file == "<Parent>"} {
2931        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2932        ChooseExpFil $frm
2933    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2934        if {$file != "."} {
2935            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2936            ChooseExpFil $frm
2937        }
2938    } else {
2939        set expgui(FileMenuEXPNAM) [file tail $file]
2940        valid_exp_file $frm $mode
2941    }
2942}
2943
2944# fill the files & dates & Directory selection box with current directory,
2945# also called when box is created to fill it
2946proc ChooseExpFil {frm "archiveonly 0"} {
2947    global expgui
2948    set files $frm.a.files
2949    set dates $frm.a.dates
2950    set expgui(FileMenuEXPNAM) {}
2951    $files delete 0 end
2952    $dates delete 0 end
2953    if {$archiveonly == 0} {
2954        $files insert end {<Parent>}
2955        $dates insert end {(Directory)}
2956        set filelist [glob -nocomplain \
2957                          [file join [set expgui(FileMenuDir)] *] ]
2958        foreach file [lsort -dictionary $filelist] {
2959            if {[file isdirectory $file]} {
2960                $files insert end [file tail $file]
2961                $dates insert end {(Directory)}
2962            }
2963        }
2964    } else {   
2965        set filelist [glob -nocomplain \
2966                          [file root $expgui(expfile)].O* ]
2967    }
2968    set pairlist {}
2969    foreach file [lsort -dictionary $filelist] {
2970        if {![file isdirectory $file]  && \
2971                [string toupper [file extension $file]] == ".EXP" \
2972                && $archiveonly == 0} {
2973            set modified [file mtime $file]
2974            lappend pairlist [list $file $modified]
2975        } elseif {![file isdirectory $file] && $expgui(includearchived) && \
2976                [string match {*.O[0-9A-F][0-9A-F]} $file]} {
2977            set modified [file mtime $file]
2978            lappend pairlist [list $file $modified]
2979        }
2980    }
2981    if {$expgui(filesort) == 0} {
2982        foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
2983            set file [lindex $pair 0]
2984            set modified [clock format [lindex $pair 1] -format "%T %D"]
2985            $files insert end [file tail $file]
2986            $dates insert end $modified
2987        }
2988    } else {
2989        foreach pair [lsort -dictionary -index 0 $pairlist] {
2990            set file [lindex $pair 0]
2991            set modified [clock format [lindex $pair 1] -format "%T %D"]
2992            $files insert end [file tail $file]
2993            $dates insert end $modified
2994        }
2995    }
2996    $expgui(FileDirButtonMenu)  delete 0 end
2997    set list ""
2998    global tcl_platform tcl_version
2999    if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
3000        catch {set list [string tolower [file volume]]}
3001    }
3002    set dir ""
3003    foreach subdir [file split [set expgui(FileMenuDir)]] {
3004        set dir [file join $dir $subdir]
3005        if {$tcl_platform(platform) == "windows"} {
3006            set dir [string tolower $dir]
3007            if {[lsearch $list $dir] == -1} {lappend list $dir}
3008        } else {
3009            lappend list $dir
3010        }
3011    }
3012    foreach path $list {
3013        $expgui(FileDirButtonMenu) add command -label $path \
3014                -command "[list set expgui(FileMenuDir) $path]; \
3015                ChooseExpFil $frm"
3016    }
3017    # highlight the current experiment -- if present
3018    for {set i 0} {$i < [$files size]} {incr i} {
3019        set file [$files get $i]
3020        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
3021            $files selection set $i
3022            set expgui(FileMenuEXPNAM) $file
3023            UpdateInfoBox
3024        }
3025    }
3026    return
3027}
3028
3029
3030#------------------------------------------------------------------------------
3031# platform-specific definitions
3032if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
3033    # windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
3034    # DOS box synchronously, so we create a "lock" file that is deleted
3035    # at the end of the DOS run so we can tell when the run is done.
3036    # We create a window to force the deleting of the file so that if
3037    # the DOS process crashes, the user can continue anyway.
3038    #
3039    # procedure to check if the lock file is still there (Win-9x/me only)
3040    proc checklockfile {file window} {
3041        if [file exists $file] {
3042            after 500 checklockfile $file $window
3043        } else {
3044            catch {destroy $window}
3045        }
3046    }
3047    # this procedure starts the GRWND program, if needed for program $prog
3048    proc StartGRWND {prog} {
3049        global expgui
3050        if {!$expgui(autoGRWND)} return
3051        # at some point we might want to have a real list
3052        if {$prog != "genles" && $prog != "powpref"} {
3053            # get a list of running jobs
3054            exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
3055            set fp [open tlist.tlist r]
3056            set text [read $fp]
3057            close $fp
3058            file delete -force tlist.tlist
3059            # if GRWND.EXE is not currently running, start it
3060            if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
3061                exec [file join $expgui(gsasexe) grwnd.exe] &
3062                # give grwnd a 1 second head start
3063                after 1000
3064            }
3065        }
3066    }
3067    # this creates a DOS box to run a program in
3068    proc forknewterm {title command "wait 1" "scrollbar 1"} {
3069        global env expgui
3070        # Windows environment variables
3071        set env(GSAS) [file nativename $expgui(gsasdir)]
3072        # PGPLOT_FONT is needed by PGPLOT
3073        set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
3074        # this is the number of lines/page in the .LST (etc.) file
3075        set env(LENPAGE) 60
3076        set pwd [file nativename [pwd]]
3077       
3078        # check the .EXP path -- can DOS use it?
3079        if {[string first // [pwd]] != -1} {
3080            MyMessageBox -parent . -title "Invalid Path" \
3081                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
3082                    -icon error -type ok -default ok \
3083                    -helplink "expgui_Win_readme.html NetPath"
3084            return
3085        }
3086        if {[info command winutils::shell] == "" && \
3087                [info command winexec] == ""} {
3088            MyMessageBox -parent . -title "Setup error" \
3089                -message {Error -- Use "Neither WINEXEC not WINTILS were found. Can't do anything!"} \
3090                -icon error -type darn -default darn \
3091                -helplink "expgui_Win_readme.html Winexec"
3092            return
3093        }
3094        # loop over multiple commands
3095        foreach cmd $command {
3096            # simulate the wait with a lock file
3097            if {$wait} {
3098                if {$expgui(autoiconify)} {wm iconify .}
3099                # create a blank lock file and a message window
3100                close [open expgui.lck w]
3101                toplevel .lock
3102                grid [button .lock.0 -text Help -bg yellow \
3103                        -command "MakeWWWHelp expguierr.html lock"] \
3104                        -column 1 -row 0
3105                grid [label .lock.1 \
3106                        -text "Please wait while the GSAS program finishes."] \
3107                        -column 0 -row 0
3108                grid [label .lock.2 -text \
3109                        "In case a problem occurs, close the DOS box"] \
3110                        -column 0 -columnspan 2 -row 1
3111                grid [label .lock.3 -text \
3112                        "and press the \"Continue\" button (below)"] \
3113                        -column 0 -columnspan 2 -row 2
3114                grid [button .lock.b -text "Continue" \
3115                        -command "destroy .lock; wm deiconify ."] \
3116                        -column 0 -columnspan 2 -row 3
3117                putontop .lock
3118                update
3119                checklockfile expgui.lck .lock
3120            }
3121
3122            # pause is hard coded in the GSASTCL.BAT file
3123            if {$expgui(execprompt)} {
3124                set script gsastcl.bat
3125            } else {
3126                set script gsasnowt.bat
3127            }
3128
3129            # replace the forward slashes with backward
3130            regsub -all / $cmd \\ cmd
3131            if {[info command winutils::shell] != ""} {
3132                winutils::shell [file join $expgui(scriptdir) $script] $cmd
3133            } else {
3134                winexec -d [file nativename [pwd]] \
3135                    [file join $expgui(scriptdir) $script] $cmd
3136            }
3137            if {$expgui(MacroRunning)} {
3138                update 
3139                update idletasks
3140            }
3141            if {$wait} {
3142                tkwait window .lock
3143                file delete -force expgui.lck
3144            }
3145        }
3146        if {$expgui(autoiconify) && $wait} {wm deiconify .}
3147        # check for changes in the .EXP file immediately
3148        whenidle
3149    }
3150} elseif {$tcl_platform(platform) == "windows"} {
3151    # now for Windows-NT, where we can run synchronously
3152    #
3153    # this creates a DOS box to run a program in
3154    proc forknewterm {title command  "wait 1" "scrollbar 1"} {
3155        global env expgui
3156        # Windows environment variables
3157        set env(GSAS) [file nativename $expgui(gsasdir)]
3158        # PGPLOT_FONT is needed by PGPLOT
3159        set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
3160        set env(PGPLOT_DIR) $expgui(pgplotdir)
3161        # this is the number of lines/page in the .LST (etc.) file
3162        set env(LENPAGE) 60
3163        set pwd [file nativename [pwd]]
3164        # check the path -- can DOS use it?
3165        if {[string first // [pwd]] != -1} {
3166            MyMessageBox -parent . -title "Invalid Path" \
3167                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
3168                    -icon error -type ok -default ok \
3169                    -helplink "expgui_Win_readme.html NetPath"
3170            return
3171        }
3172        # pause is hard coded in the .BAT file
3173        if {$expgui(execprompt)} {
3174            set script gsastcl.bat
3175        } else {
3176            set script gsasnowt.bat
3177        }
3178
3179        if {$wait} {
3180            if {$expgui(autoiconify)} {wm iconify .}
3181            # create a blank lock file (keep liveplot from running)
3182            close [open expgui.lck w]
3183            # loop over commands
3184            foreach cmd $command {
3185                # replace the forward slashes with backward
3186                regsub -all / $cmd \\ cmd
3187                # use of file attributes -shortname & normalize and nativename
3188                # might help here
3189                exec $env(COMSPEC) /c \
3190                        "start [file attributes [file join $expgui(scriptdir) $script] -shortname] $cmd"
3191            }
3192            file delete -force expgui.lck
3193            if {$expgui(autoiconify)} {wm deiconify .}
3194            # check for changes in the .EXP file immediately
3195            whenidle
3196        } else {
3197            # loop over commands
3198            foreach cmd $command {
3199                # replace the forward slashes with backward
3200                regsub -all / $cmd \\ cmd
3201                # run in background
3202                exec $env(COMSPEC) /c \
3203                        "start [file attributes [file join $expgui(scriptdir) $script] -shortname] $cmd"
3204                if {$expgui(MacroRunning)} {
3205                    update 
3206                    update idletasks
3207                }
3208            }
3209        }
3210    }
3211} else {
3212    # UNIX-based machines
3213    if {[auto_execok xterm] != ""} {
3214        # this creates a xterm window for running programs inside
3215        proc forknewterm {title command "wait 1" "scrollbar 1"} {
3216            global env expgui
3217            # UNIX environment variables
3218            set env(GSAS) [file nativename $expgui(gsasdir)]
3219            set env(gsas) [file nativename $expgui(gsasdir)]
3220            set env(GSASEXE) $expgui(gsasexe)
3221            set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
3222            set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
3223            # PGPLOT_DIR is needed by PGPLOT
3224            set env(PGPLOT_DIR) $expgui(pgplotdir)
3225            # this is the number of lines/page in the .LST (etc.) file
3226            set env(LENPAGE) 60
3227            set termopts {}
3228            if $env(GSASBACKSPACE) {
3229                append termopts \
3230                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
3231            }
3232            if $scrollbar {
3233                append termopts " -sb"
3234            } else {
3235                append termopts " +sb"
3236            }
3237            if {$wait} {
3238                set suffix {}
3239            } else {
3240                set suffix {&}
3241            }
3242           
3243            # hold window open after commands finish
3244            if {$expgui(execprompt)} {
3245                append command "\; echo -n Press Enter to continue \; read x"
3246            }
3247            if {$wait && $expgui(autoiconify)} {wm iconify .}
3248            catch {eval exec xterm $termopts -title [list $title] \
3249                       -e /bin/sh -c [list $command] $suffix} errmsg
3250            if $expgui(debug) {puts "xterm result = $errmsg"}
3251            if {$expgui(MacroRunning)} {
3252                update 
3253                update idletasks
3254            }
3255            if {$wait} {
3256                if {$expgui(autoiconify)} {wm deiconify .}
3257                # check for changes in the .EXP file immediately
3258                whenidle
3259            }
3260        }
3261    } elseif {[auto_execok gnome-terminal] != ""} {
3262        # this creates a xterm window for running programs inside
3263        proc forknewterm {title command "wait 1" "scrollbar 1"} {
3264            global env expgui
3265            # UNIX environment variables
3266            set env(GSAS) [file nativename $expgui(gsasdir)]
3267            set env(gsas) [file nativename $expgui(gsasdir)]
3268            set env(GSASEXE) $expgui(gsasexe)
3269            set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
3270            set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
3271            # PGPLOT_DIR is needed by PGPLOT
3272            set env(PGPLOT_DIR) $expgui(pgplotdir)
3273            # this is the number of lines/page in the .LST (etc.) file
3274            set env(LENPAGE) 60
3275            if {$wait} {
3276                set suffix {}
3277            } else {
3278                set suffix {&}
3279            }
3280           
3281            # hold window open after commands finish
3282            if {$expgui(execprompt)} {
3283                append command "\; echo -n Press Enter to continue \; read x"
3284            }
3285            if {$wait && $expgui(autoiconify)} {wm iconify .}
3286            catch {exec gnome-terminal --title $title \
3287                       -e " /bin/sh -c \" $command \" " $suffix} errmsg
3288            if $expgui(debug) {puts "gnome-terminal result = $errmsg"}
3289            if {$expgui(MacroRunning)} {
3290                update 
3291                update idletasks
3292            }
3293            if {$wait} {
3294                if {$expgui(autoiconify)} {wm deiconify .}
3295                # check for changes in the .EXP file immediately
3296                whenidle
3297            }
3298        }
3299    } else {
3300        MyMessageBox -parent . -title "Error: no terminal program" \
3301            -message "Error, the xterm or gnome-terminal utility programs could not be found. It is not possible to run the GSAS programs without this." \
3302            -icon error -type NOT-OK -default not-ok
3303    }
3304}
3305
3306# run commands without a terminal window
3307proc runnoterm {command outfile} {
3308    global env expgui tcl_platform
3309    if {$tcl_platform(platform) == "windows"} {
3310        # Windows environment variables
3311        set env(GSAS) [file nativename $expgui(gsasdir)]
3312        # PGPLOT_FONT is needed by PGPLOT
3313        set env(PGPLOT_FONT) [file nativename [file join $expgui(pgplotdir) grfont.dat]]
3314        # this is the number of lines/page in the .LST (etc.) file
3315        set env(LENPAGE) 60
3316        set pwd [file nativename [pwd]]
3317        # loop over multiple commands
3318        foreach cmd $command {
3319            # replace the forward slashes with backward
3320            regsub -all / $cmd \\ cmd
3321            exec $cmd >>& $outfile
3322            update
3323            update idletasks
3324        }
3325    } else { 
3326        # UNIX environment variables
3327        set env(GSAS) [file nativename $expgui(gsasdir)]
3328        set env(gsas) [file nativename $expgui(gsasdir)]
3329        set env(GSASEXE) $expgui(gsasexe)
3330        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
3331        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
3332        # PGPLOT_DIR is needed by PGPLOT
3333        set env(PGPLOT_DIR) $expgui(pgplotdir)
3334        # this is the number of lines/page in the .LST (etc.) file
3335        set env(LENPAGE) 60
3336        foreach cmd $command {
3337            catch {eval exec $cmd >>& $outfile} errmsg
3338        }
3339        update
3340        update idletasks
3341    }
3342    # check for changes in the .EXP file immediately
3343    #whenidle
3344}
3345
3346proc MacMakeResource {file app} {
3347    # make a resource file. Note that OS X has gotten picky about the length of this
3348    set l [string length $app]
3349    if $::expgui(debug) {puts "$l bytes"}
3350    incr l
3351    if $::expgui(debug) {puts "$l bytes after incr"}
3352    set str "data 'usro' (0) {\n"
3353    append str "  $\""
3354    append str [format %.8X $l]
3355    set bytes 4
3356    foreach char [split $app {}] {
3357        append str [format %.2X [scan $char %c]]   
3358    }
3359    incr bytes $l
3360    set newline 1
3361    for {set i 0} {$i < [expr 1028-$bytes]} {incr i} {
3362        if $newline {
3363            append str "\" \n"
3364            append str "  $\""
3365            set newline 0
3366            set j 0
3367        }
3368        append str {0000 }
3369        incr bytes
3370        incr j 2
3371        if {$j > 15} {set newline 1}
3372    }
3373    if {$l % 2} {
3374        append str "\"\n "
3375    } else {
3376        # even lengths need one more byte
3377        append str "00\"\n "
3378    }
3379    append str "/* $app */\n};\n"
3380    set fp [open $file w]
3381    puts $fp $str
3382    close $fp
3383}
3384
3385# modify resource fork info for a .EXP file on the Mac
3386proc MacSetResourceFork {expfile} {
3387    global expgui tcl_platform
3388    if {$tcl_platform(os) != "Darwin"} {return}
3389    set expnative [file nativename $expfile]
3390    #
3391    # assign an app to the data file, if the app and the
3392    # required tool (Rez) are installed
3393    set app [file nativename [file join $expgui(gsasdir) expgui.app]]
3394    set RezApp {}
3395    foreach pth "/usr/bin  /Developer/Tools $expgui(gsasexe)" {
3396        if [file exists [set tst [file join $pth Rez]]] {
3397            set RezApp $tst
3398            break
3399        }
3400    }
3401    set SetFileApp {}
3402    foreach pth "/usr/bin  /Developer/Tools $expgui(gsasexe)" {
3403        if [file exists [set tst [file join $pth SetFile]]] {
3404            set SetFileApp $tst
3405            break
3406        }
3407    }
3408    if $::expgui(debug) {puts "found app=$app Rez=$RezApp and SetFile=$SetFileApp"}
3409    if {[file exists $app] && $RezApp != ""} {
3410        # make resource file
3411        MacMakeResource setapp.r $app
3412        if $::expgui(debug) {puts "$RezApp setapp.r -o $expnative -a"}
3413        exec $RezApp setapp.r -o $expnative -a
3414        if {! $::expgui(debug)} {
3415            file delete -force setapp.r
3416        }
3417    }
3418
3419    # assign an icon to the data file, if it and the required tools exist
3420    set icon [file join $expgui(gsasexe) gsasicon.r]
3421    if {[file exists $icon] && $RezApp != "" && $SetFileApp != ""} {
3422        exec $RezApp [file nativename $icon] -o $expnative -a
3423        exec $SetFileApp -a C $expnative
3424        if {$::expgui(debug)} {
3425            puts "$RezApp [file nativename $icon] -o $expnative -a"
3426            puts "$SetFileApp -a C $expnative"
3427        }
3428    } elseif {$::expgui(debug)} {
3429        puts "icon=$icon missing?"
3430    }
3431}
3432
3433#-------------------------------------------------------------------------------
3434# Macro Recording
3435#-------------------------------------------------------------------------------
3436set expgui(MacroBufferedCommand) ""
3437set expgui(fpMacroFile) ""
3438set expgui(MacroFile) ""
3439# Turn on/off mode to save commands in MacroFile
3440proc SetRecordMacroOnOff {args} {
3441    global expgui
3442    if {$expgui(RecordMacro)} {
3443        set expgui(fpMacroFile) ""
3444        set expgui(MacroBufferedCommand) ""
3445        while {$expgui(fpMacroFile) == ""} {
3446            set expgui(MacroFile) [tk_getSaveFile -initialdir [pwd] \
3447                                       -parent . \
3448                                       -filetypes {{"EXPGUI Macro file" .expmac}} \
3449                                       -defaultextension .expmac  \
3450                                       -initialfile EXPGUI.expmac \
3451                                       -title "Choose location to save macro"]
3452            if {$expgui(MacroFile) == ""} {
3453                # respond to cancel
3454                set expgui(fpMacroFile) ""
3455                set expgui(MacroFile) ""
3456                set expgui(RecordMacro) 0
3457                return
3458            }
3459            if {[catch {
3460                set expgui(fpMacroFile) [open $expgui(MacroFile) w]
3461                puts $expgui(fpMacroFile) "# [clock format [clock seconds] -format %Y-%m-%dT%T]"
3462            } errmsg]} {
3463                MyMessageBox -parent . -title "Error opening selected file" \
3464                    -message "Error opening macro file:\n$errmsg" \
3465                    -icon warning -type TryAgain -default tryagain
3466                catch {close $expgui(fpMacroFile)}
3467                set expgui(fpMacroFile) ""
3468                set expgui(MacroFile) ""
3469                set expgui(RecordMacro) 0
3470            }
3471        }
3472    } else {
3473        if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3474            puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3475        }
3476        catch {close $expgui(fpMacroFile)}
3477        set expgui(fpMacroFile) ""
3478        set expgui(MacroFile) ""
3479        set expgui(MacroBufferedCommand) ""
3480    }
3481}
3482
3483# record a command in the Macro File
3484proc RecordMacroEntry {command buffer} {
3485    global expgui
3486    if {! $expgui(RecordMacro)} return
3487    # in buffered mode: hold the last command in memory and compare to the
3488    # next. If two commands differ only in the final argument, then the
3489    # second command makes the previous redundant so only the latter version
3490    # is retained (This will happen when a user types a string into a box).
3491    # When the commands differ, then the previous is written to file
3492    # and the next is retained in memory.
3493    if {$buffer} {
3494        if {[string trim $expgui(MacroBufferedCommand)] == ""} {
3495            set expgui(MacroBufferedCommand) $command
3496            return
3497        }
3498        set diff 0
3499        # is command a repeat of previous?
3500        foreach a $command b $expgui(MacroBufferedCommand) {
3501            if {$diff} {
3502                # found a difference, other than in the last arg
3503                puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3504                break
3505            }
3506            if {$a != $b} {set diff 1}
3507        }
3508        set expgui(MacroBufferedCommand) $command
3509    } else {
3510        # no buffering on current command; write the old and new to file.
3511        if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3512            puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3513        }
3514        puts $expgui(fpMacroFile) $command
3515        set expgui(MacroBufferedCommand) ""
3516    }
3517}
3518
3519proc CantRecordMacroEntry {comment} {
3520    global expgui
3521    if {! $expgui(RecordMacro)} return
3522
3523    # no buffering on current command; write the old and new to file.
3524    if {[string trim $expgui(MacroBufferedCommand)] != ""} {
3525        puts $expgui(fpMacroFile) $expgui(MacroBufferedCommand)
3526    }
3527    puts $expgui(fpMacroFile) "# unrecorded: $comment"
3528    set expgui(MacroBufferedCommand) ""
3529    MyMessageBox -parent . -title "No command record" \
3530        -message "EXPGUI is not able to record this action in the macro file: $comment" \
3531        -icon warning
3532}
3533
3534
3535# Play back commands in Macro File
3536proc ReplayMacroFile {"lineatatime 0"} {
3537    global expgui
3538    set expnam [file root [file tail $expgui(expfile)]]
3539    file delete abort_${expnam}_macro.flag
3540    set expgui(MacroRunning) 0
3541    set MacroFile [tk_getOpenFile -initialdir [pwd] \
3542                       -parent . \
3543                       -filetypes {{"EXPGUI Macro file" .expmac} {Everything .*}} \
3544                       -defaultextension .expmac  \
3545                       -title "Choose location to read macro"]
3546    if {$MacroFile == ""} return
3547    set expgui(MacroRunning) 1
3548    if {$lineatatime} {
3549        set expgui(MacroChanged) 0
3550        set top1 .macro
3551        catch {destroy $top1}
3552        toplevel $top1
3553        set txt $top1.t
3554        grid [text $txt -width 30 -height 20 -yscrollcommand "$top1.s set"] \
3555            -column 0 -row 0 -sticky news
3556        wm title $top1 "File $MacroFile"
3557        grid [scrollbar $top1.s -command "$txt yview"] \
3558            -column 1 -row 0 -sticky ns
3559        grid [frame $top1.b] -column 0 -columnspan 2 -row 1 -sticky ew
3560        grid columnconfig $top1 0 -weight 1
3561        grid rowconfig $top1 0 -weight 1
3562        grid [button $top1.b.e -text "Execute line" \
3563                  -command "MacroExecuteCurrentLine $txt"] \
3564            -column 0 -row 0 -sticky w
3565        grid columnconfig $top1.b 1 -weight 1
3566        grid [button $top1.b.s -text "Save As" -state disabled \
3567                  -command "MacroResave $txt"] -column 1 -row 0
3568        set expgui(MacroSaveButton) $top1.b.s 
3569        grid [button $top1.b.c -text "Close " \
3570                  -command "MacroCloseWindow $txt"] -column 2 -row 0
3571        $txt delete 0.0 end
3572        set fp [open $MacroFile r]
3573        $txt insert 0.0 [read $fp]
3574        close $fp
3575        MacroHighlightText $txt 1
3576        # deal with editing in the box
3577        $txt configure -undo 1
3578        $txt edit modified 0
3579        bind $txt <<Modified>> {
3580            $expgui(MacroSaveButton) configure -state normal
3581            set expgui(MacroChanged) 1
3582        }
3583    } else {
3584        close [open running_${expnam}_macro.flag w]
3585        set saveprompt $expgui(execprompt)
3586        set saveautold $expgui(autoexpload)
3587        set expgui(execprompt) 0
3588        set expgui(autoexpload) 1
3589        set expnam [file root [file tail $expgui(expfile)]]
3590        if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
3591            set outfile ${expnam}_macout.LST
3592            # create an empty file
3593            catch {file delete $outfile}
3594            close [open $outfile w]
3595            # view it with LSTVIEW
3596            set outfile ${expnam}_macout
3597            exec $::wishshell [file join $expgui(scriptdir) lstview] $outfile &
3598        } else {
3599            # show status, offer abort with MACROMON
3600            exec $::wishshell [file join $expgui(scriptdir) macromon] $expnam &
3601        }
3602
3603        set  expgui(MacroStatus) "starting script"
3604        pleasewait "\nrunning macro\n\nStatus:" expgui(MacroStatus) 
3605
3606        if {[catch {
3607            source $MacroFile
3608        } errmsg]} {
3609            set txt $::errorInfo
3610            catch {
3611                set fp [open error.txt a]
3612                puts $fp "#  [clock format [clock seconds] -format %Y-%m-%dT%T]"
3613                puts $fp $txt
3614                close $fp
3615            }
3616            donewait
3617            MyMessageBox -parent . -title "Error running Macro file" \
3618                -message "Error running macro file:\n$errmsg\n(details in file error.txt)" \
3619                -icon error -type OK -default ok
3620        } else {
3621            donewait
3622        }
3623        file delete running_${expnam}_macro.flag
3624        set expgui(execprompt) $saveprompt
3625        set expgui(autoexpload) $saveautold
3626        set expgui(MacroRunning) 0
3627        # show changes
3628        PaintEXPGUIpages
3629        # put comment in output file
3630        if {$expgui(MacroRunning) && !$expgui(ShowGENLES)} {
3631            set outfile ${expnam}_macout.LST
3632            set fp [open $outfile a]
3633            puts $fp "\n**** Macro ended ****" 
3634            close $fp
3635        }
3636    }
3637}
3638
3639# highlight a line in the Macro file display
3640proc MacroHighlightText {txt line} {
3641    $txt tag delete next
3642    $txt tag add next $line.0 $line.end
3643    $txt see $line.0
3644    $txt tag configure next -background yellow
3645    # tag all text
3646    $txt tag delete all
3647    $txt tag add all 0.0 end
3648    # double-click moves the current line
3649    $txt tag bind all <Double-1> "after idle [list MacroDoubleClick $txt]"
3650}
3651
3652# respond to a double click by moving the next line to be executed to
3653# the line where the double click occurred
3654proc MacroDoubleClick {txt} {
3655    set line [lindex [split [$txt tag ranges sel] "."] 0]
3656    MacroHighlightText $txt $line
3657}
3658
3659# respond to Execute button: execute the current line
3660# close window after last command
3661proc MacroExecuteCurrentLine {txt} {
3662    global expgui
3663    set linenum [lindex [split [$txt tag ranges next] "."] 0]
3664    if {$linenum == ""} {return}
3665    set line [$txt get $linenum.0 $linenum.end]
3666    # is this continued (ends with \)?
3667    while {[string range $line end end] == "\\" } {
3668        incr linenum
3669        # get rid of trailing backslash
3670        set line [string range $line 0 end-1]
3671        #append next line
3672        append line [$txt get $linenum.0 $linenum.end]
3673    }
3674     if {[catch $line errmsg]} {
3675        MyMessageBox -parent $txt -title "Error on line" \
3676            -message "Error on line $linenum:\n$errmsg" \
3677            -icon warning -type Continue -default continue
3678    }
3679    # show changes
3680    PaintEXPGUIpages
3681    # move forward in macrofile
3682    incr linenum
3683    MacroHighlightText $txt $linenum
3684    set linenum [lindex [split [$txt tag ranges next] "."] 0]
3685    # at end?
3686    if {$linenum == ""} {MacroCloseWindow $txt}
3687}
3688
3689# Save a modified macro file
3690proc MacroResave {txt} {
3691    global expgui
3692    set MacroFile [tk_getSaveFile -initialdir [pwd] \
3693                       -parent $txt \
3694                       -filetypes {{"EXPGUI Macro file" .expmac}} \
3695                       -defaultextension .expmac  \
3696                       -initialfile $expgui(MacroFile) \
3697                       -title "Choose location to save macro"]
3698    if {[string trim $MacroFile] == ""} {return}
3699    if {[catch {
3700        set fp [open $MacroFile w]
3701        puts $fp [string trim [$txt get 0.0 end]]
3702        close $fp
3703    } errmsg]} {
3704        MyMessageBox -parent $txt -title "Error writing to file" \
3705            -message "Error writing macro file:\n$errmsg" \
3706            -icon warning -type TryAgain -default tryagain
3707        return
3708    }
3709    set expgui(MacroChanged) 0
3710    # gray out the button
3711    $expgui(MacroSaveButton) configure -state disabled
3712}
3713
3714# close the window, but provide a chance to save the file first, if modified
3715proc MacroCloseWindow {txt} {
3716    global expgui
3717    if {$expgui(MacroChanged)} {
3718
3719        set ans [MyMessageBox -parent $txt -title "Save macro file?" \
3720                     -message "Macro file has been changed, do you want to save it?" \
3721                     -icon warning -type "Yes No" -default no]
3722        if {$ans != "no"} {MacroResave $txt}
3723    }
3724    set expgui(MacroRunning) 0
3725    destroy [winfo toplevel $txt]
3726}
3727
3728# Add a comment to a macro file
3729proc AddCommentMacroFile {} {
3730    global expgui
3731    if {! $expgui(RecordMacro)} return
3732    RecordMacroEntry "# [getstring "comment for macro file"]" 0
3733}
3734
3735#------------------------------------------------------------------------------
3736# Subversion support routines
3737#------------------------------------------------------------------------------
3738
3739proc GetSVNVersion {scriptdir} {
3740    if {[CheckSVNinstalled]} {
3741        set SVN [auto_execok svn]
3742        if {! [catch {set res [eval exec $SVN info [list $scriptdir]]} err]} {
3743            set infolist [split $res]
3744            set pos [lsearch $infolist "Revision:"]
3745            return "GSAS/EXPGUI SVN version [lindex $infolist [incr pos]]"
3746        }
3747    }
3748    return "EXPGUI version: [lindex $::expgui(Revision) 1] ([lindex $::expgui(Revision) 4])"
3749}
3750
3751# can we find the svn program?
3752proc CheckSVNinstalled {} {
3753    # can we find svn in the path?
3754    if {[auto_execok svn] != ""} {return 1}
3755    # add a locally supplied svn version and add to path
3756    if {$::tcl_platform(platform) == "windows"} {
3757        set s [file attributes $::expgui(gsasdir) -shortname]
3758    } else {
3759        set s $::expgui(gsasdir) 
3760    }
3761    # look for svn
3762    set localsvn [file join $s svn bin]
3763    if {[file exists $localsvn]} {
3764        if {$::tcl_platform(platform) == "windows"} {
3765            set localsvn [file nativename $localsvn]
3766            set sep {;}
3767        } else {
3768            set sep {:}
3769        }
3770        if {[lsearch [split $::env(PATH) $sep] $localsvn] == -1} {
3771            append ::env(PATH) $sep $localsvn
3772            # note that auto_reset breaks the tkcon package in Windows -- not sure why
3773            auto_reset
3774        }
3775    }
3776    if {[auto_execok svn] != ""} {return 1}
3777    return 0
3778}
3779
3780proc CheckAndDoUpdate { } {
3781    if {! [CheckSVNinstalled]} {
3782        MyMessageBox -parent . -title "SVN not found" \
3783            -message "Unable to upgrade: Could not locate a copy of the subversion program. It does not appear that one of self-updating GSAS/EXPGUI releases was installed" \
3784            -icon error
3785        return
3786    }
3787    #is there a svn directory in the source?
3788    if {! [file exists [file join $::expgui(gsasdir)  .svn]]} {
3789        MyMessageBox -parent . -title "No .svn directory" \
3790            -message "Unable to upgrade: It does not appear that one of self-updating GSAS/EXPGUI releases was installed" \
3791            -icon error
3792        return
3793    }
3794    # check for updates
3795    set SVN [auto_execok svn]
3796    if [catch {set res [eval exec $SVN status [list $::expgui(gsasdir)] -u]} err] {
3797        set ans [MyMessageBox -parent . -title "Error checking status" \
3798                     -message "Error checking for updates: $err\n\nTry to update manually?" \
3799                     -icon error -type "Yes No" -default yes]
3800        if {$ans != "no"} {
3801            forknewterm "manually update in subversion" \
3802                "$SVN update [file normalize $::expgui(gsasdir)]"
3803        }
3804        return
3805     } else {
3806        if {[string first "*" $res] == -1} {
3807            MyMessageBox -parent . -title "No updates" \
3808                -message "GSAS & EXPGUI appear up-to-date" \
3809                -icon info
3810            return
3811        }
3812    }
3813
3814    if {[MyMessageBox -parent . -title "Ready to Update" \
3815             -message {
3816Updates to GSAS/EXPGUI found on server.
3817                 
3818Press the "Update & Restart" button to begin the update process. After the update completes, EXPGUI will be restarted.} \
3819             -type {Cancel "Update & Restart"} -default cancel -icon warning
3820        ] == "cancel"} {return}
3821
3822    if {[confirmBeforeSave] == "Cancel"} return
3823
3824    # special upgrade for windows, where the wish exec blocks upgrade of the exe directory
3825    if {$::tcl_platform(platform) == "windows" && $::tcl_platform(os) != "Windows 95"} {
3826        if {![file exists [file join $::expgui(gsasdir) update.bat]]} {
3827            MyMessageBox -parent . -title "No update.bat" \
3828                -message "File update.bat was not found. This should not happen. Will try to create it now." 
3829            set fp [open [file join $::expgui(gsasdir) update.bat] w]
3830            puts $fp {@REM this script must be run from the GSAS installation directory
3831@REM This is run to update the installation, the name of the EXP file is
3832@REM expected as an argument
3833@echo ****************************
3834@echo Press return to start update
3835@echo ****************************
3836@pause
3837.\svn\bin\svn cleanup .
3838.\svn\bin\svn update .
3839@if (%1)==() goto Install2
3840@echo ****************************************************
3841@echo Update has completed. Press return to restart EXPGUI
3842@echo ****************************************************
3843@pause
3844%COMSPEC% /c "start exe\ncnrpack.exe expgui\expgui %1"
3845exit
3846:Install2
3847@echo ****************************************************
3848@echo Update has completed. EXPGUI starting w/o .EXP file
3849@echo ****************************************************
3850@pause
3851%COMSPEC% /c "start exe\ncnrpack.exe expgui\expgui"
3852exit
3853            }
3854            close $fp
3855        }
3856        # split the directory and EXP file and get rid os spaces in the directory name
3857        set exp [file normalize $::expgui(expfile)]
3858        set dir [file attributes [file dirname $exp] -shortname]
3859        cd $::expgui(gsasdir)
3860        #run the batch file
3861        exec $::env(COMSPEC) /c {start .\update.bat [file join $dir [file tail $exp]]} &
3862        exit
3863    }
3864
3865    # do a quiet cleanup. Sometimes needed after install, and never hurts
3866    if [catch {set res [eval exec $SVN cleanup [list $::expgui(gsasdir)]]} err] {
3867        MyMessageBox -parent . -title "Error in cleanup" \
3868            -message "Error performing cleanup. Will try to continue anyway. Error:\n$err" \
3869            -icon error
3870    }
3871    if [catch {set res [exec $SVN up $::expgui(gsasdir)]} err] {
3872        MyMessageBox -parent . -title "Error updating" \
3873            -message "Error performing update:\n$err" \
3874            -icon error
3875        return
3876    } else {
3877        MyMessageBox -parent . -title "Updating done" \
3878            -message "Results from update:\n$res\n\nPress OK to restart EXPGUI" \
3879            -icon info
3880    }
3881    exec [info nameofexecutable] [file normalize $::expgui(script)] [file normalize $::expgui(expfile)] &
3882    exit
3883}
Note: See TracBrowser for help on using the repository browser.