source: trunk/gsascmds.tcl @ 749

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

# on 2003/11/13 17:21:17, toby did:
remove obsolete references to tkButtonInvoke
add code to support URL lookup in OSX & clean up for UNIX
don't allow archived files on initial open
fix parse of .EXP file for >999 LS cycles

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