source: trunk/gsascmds.tcl @ 742

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

# on 2003/11/05 22:16:55, toby did:
add mozilla to browser list
fix missing browser error msg
fix bug in Chinese Windows where history record gets corrupted

  • Property rcs:author set to toby
  • Property rcs:date set to 2003/11/05 22:16:55
  • Property rcs:lines set to +10 -4
  • Property rcs:rev set to 1.52
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 83.2 KB
Line 
1# $Id: gsascmds.tcl 742 2009-12-04 23:11:15Z 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 tkButtonInvoke $w.[string tolower $data(-default)]]
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    switch $tcl_platform(platform) {
861        "unix" {
862            if {![info exists env(BROWSER)]} {
863                set progs [auto_execok netscape]
864                if {[llength $progs]} {
865                    set env(BROWSER) [list $progs]
866                }
867            }
868            if {![info exists env(BROWSER)]} {
869                set progs [auto_execok mozilla]
870                if {[llength $progs]} {
871                    set env(BROWSER) [list $progs]
872                }
873            }
874            if {[info exists env(BROWSER)]} {
875                if {[catch {exec $env(BROWSER) -remote openURL($url)}]} {
876                    # perhaps browser doesn't understand -remote flag
877                    if {[catch {exec $env(BROWSER) $url &} emsg]} {
878                        error "Error displaying $url in browser\n$emsg"
879                    }
880                }
881            } else {
882                MyMessageBox -parent . -title "No Browser" \
883                        -message "Could not find a browser. Netscape is not in path. Define environment variable BROWSER to be full path name of browser." \
884                        -icon warning
885            }
886        }
887        "windows" {
888            package require registry
889            # Look for the application under
890            # HKEY_CLASSES_ROOT
891            set root HKEY_CLASSES_ROOT
892
893            # Get the application key for HTML files
894            set appKey [registry get $root\\.html ""]
895
896            # Get the command for opening HTML files
897            set appCmd [registry get \
898                    $root\\$appKey\\shell\\open\\command ""]
899
900            # Substitute the HTML filename into the command for %1
901            # or stick it on the end
902            if {[string first %1 $appCmd] != -1} {
903                regsub %1 $appCmd $url appCmd
904            } else {
905                append appCmd " " $url
906            }
907           
908            # Double up the backslashes for eval (below)
909            regsub -all {\\} $appCmd  {\\\\} appCmd
910           
911            # Invoke the command
912            eval exec $appCmd &
913        }
914        "macintosh" {
915            if {0 == [info exists env(BROWSER)]} {
916                set env(BROWSER) "Browse the Internet"
917            }
918            if {[catch {
919                AppleScript execute\
920                    "tell application \"$env(BROWSER)\"
921                         open url \"$url\"
922                     end tell
923                "} emsg]
924            } then {
925                error "Error displaying $url in browser\n$emsg"
926            }
927        }
928    }
929}
930
931proc NetHelp {file anchor localloc netloc} {
932    if {[file exists [file join $localloc $file]]} {
933        set url "[file join $localloc $file]"
934    } else {
935        set url "http://$netloc/$file"
936    }
937    catch {
938        pleasewait "Starting web browser..."
939        after 2000 donewait
940    }
941    if {$anchor != ""} {
942        append url # $anchor
943    }
944    urlOpen $url
945}
946
947proc MakeWWWHelp {"topic {}" "anchor {}"} {
948    global expgui
949    if {$topic == ""} {
950        foreach item $expgui(notebookpagelist) {
951            if {[lindex $item 0] == $expgui(pagenow)} {
952                NetHelp [lindex $item 5] [lindex $item 6] $expgui(docdir) $expgui(website)
953                return
954            }
955        }
956        # this should not happen
957        NetHelp expgui.html "" $expgui(docdir) $expgui(website)
958    } elseif {$topic == "menu"} {
959        NetHelp expguic.html "" $expgui(docdir) $expgui(website)
960    } else {
961        NetHelp $topic $anchor $expgui(docdir) $expgui(website)
962    }
963}
964
965# show help information
966proc showhelp {} {
967    global expgui_helplist helpmsg
968    set helpmsg {}
969    set frm .help
970    catch {destroy $frm}
971    toplevel $frm
972    wm title $frm "Help Summary"
973    grid [label $frm.0 -text \
974            "Click on an entry below to see information on the EXPGUI/GSAS topic" ] \
975        -column 0 -columnspan 4 -row 0
976#    grid [message $frm.help -textvariable helpmsg -relief groove] \
977#          -column 0 -columnspan 4 -row 2 -sticky nsew
978    grid [text $frm.help -relief groove -bg beige -width 0\
979            -height 0 -wrap word -yscrollcommand "$frm.escroll set"] \
980           -column 0 -columnspan 3 -row 2 -sticky nsew
981    grid [scrollbar $frm.escroll -command "$frm.help yview"] \
982            -column 4 -row 2 -sticky nsew
983    grid rowconfig $frm 1 -weight 1 -minsize 50
984    grid rowconfig $frm 2 -weight 2 -pad 20 -minsize 150
985    grid columnconfig $frm 0 -weight 1
986    grid columnconfig $frm 2 -weight 1
987    set lst [array names expgui_helplist]
988    grid [listbox $frm.cmds -relief raised -bd 2 \
989            -yscrollcommand "$frm.scroll set" \
990            -height 8 -width 0 -exportselection 0 ] \
991            -column 0 -row 1 -sticky nse
992    grid [scrollbar $frm.scroll -command "$frm.cmds yview"] \
993            -column 1 -row 1 -sticky nsew
994    foreach item [lsort -dictionary $lst] {
995        $frm.cmds insert end $item 
996    }
997    if {[$frm.cmds curselection] == ""} {$frm.cmds selection set 0}
998    grid [button $frm.done -text Done -command "destroy $frm"] \
999            -column 2 -row 1
1000#    bind $frm.cmds <ButtonRelease-1> \
1001#           "+set helpmsg \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\])"
1002    bind $frm.cmds <ButtonRelease-1> \
1003            "+$frm.help config -state normal; $frm.help delete 0.0 end; \
1004             $frm.help insert end \$expgui_helplist(\[$frm.cmds get \[$frm.cmds curselection\]\]); \
1005             $frm.help config -state disabled"
1006
1007    # get the size of the window and expand the message boxes to match
1008#    update
1009#    $frm.help config -width [winfo width $frm.help ]
1010}
1011
1012
1013#------------------------------------------------------------------------------
1014# utilities
1015#------------------------------------------------------------------------------
1016# run liveplot
1017proc liveplot {} {
1018    global expgui liveplot wishshell expmap
1019    set expnam [file root [file tail $expgui(expfile)]]
1020    # which histograms are ready for use?
1021    set validlist {}
1022    foreach ihist $expmap(powderlist) {
1023        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1024                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1025            lappend validlist $ihist
1026        }
1027    }
1028    if {[llength $validlist] == 0} {
1029        MyMessageBox -parent . -title "No Valid Histograms" \
1030                -message "No histograms are ready to plot. Run GENLES and try again" \
1031                -icon warning -helplink "expguierr.html NoValidHist"
1032        return
1033    }
1034    # use $liveplot(hst) if valid, the 1st entry otherwise
1035    if {[lsearch $validlist $liveplot(hst)] != -1} {
1036        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1037                $expnam $liveplot(hst) $liveplot(legend) &
1038    } else {
1039        exec $wishshell [file join $expgui(scriptdir) liveplot] \
1040                $expnam [lindex $validlist 0] $liveplot(legend) &
1041    }
1042}
1043
1044# run lstview
1045proc lstview {} {
1046    global expgui wishshell
1047    set expnam [file root [file tail $expgui(expfile)]]
1048    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1049}
1050
1051# run widplt
1052proc widplt {"prog widplt"} {
1053    global expgui wishshell
1054    exec $wishshell [file join $expgui(scriptdir) $prog] \
1055            $expgui(expfile) &
1056}
1057
1058# run bkgedit
1059proc bkgedit {"hst {}"} {
1060    global expgui liveplot wishshell expmap
1061    set expnam [file root [file tail $expgui(expfile)]]
1062    if {$hst == ""} {
1063        # which histograms are ready for use?
1064        set validlist {}
1065        foreach ihist $expmap(powderlist) {
1066            if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1067                    [string range $expmap(htype_$ihist) 3 3] == "*"} {
1068                lappend validlist $ihist
1069            }
1070        }
1071        if {[llength $validlist] == 0} {
1072            MyMessageBox -parent . -title "No Valid Histograms" \
1073                    -message "No histograms are ready to plot. Run POWPREF and try again" \
1074                    -icon warning -helplink "expguierr.html NoValidHist"
1075            return
1076        }
1077        # use $liveplot(hst) if valid, the 1st entry otherwise
1078        if {[lsearch $validlist $liveplot(hst)] != -1} {
1079            set hst $liveplot(hst)
1080        } else {
1081            set hst [lindex $validlist 0]
1082        }
1083    }
1084    if {$expgui(autoiconify)} {wm iconify .}
1085    exec $wishshell [file join $expgui(scriptdir) bkgedit] \
1086            $expnam $hst $liveplot(legend)
1087    if {$expgui(autoiconify)} {wm deiconify .}
1088    # check for changes in the .EXP file immediately
1089    whenidle
1090}
1091
1092# run excledt
1093proc excledit {} {
1094    global expgui liveplot wishshell expmap
1095    set expnam [file root [file tail $expgui(expfile)]]
1096    # which histograms are ready for use?
1097    set validlist {}
1098    foreach ihist $expmap(powderlist) {
1099        if {[string trim [string range $expmap(htype_$ihist) 3 3]] == "" || \
1100                [string range $expmap(htype_$ihist) 3 3] == "*" || \
1101                [string range $expmap(htype_$ihist) 3 3] == "D"} {
1102            lappend validlist $ihist
1103        }
1104    }
1105    if {[llength $validlist] == 0} {
1106        MyMessageBox -parent . -title "No Valid Histograms" \
1107                -message "No histograms are ready to plot. Run POWPREF and try again" \
1108                -icon warning -helplink "expguierr.html NoValidHist"
1109        return
1110    }
1111    #if {$expgui(autoiconify)} {wm iconify .}
1112    StartExcl 
1113    #if {$expgui(autoiconify)} {wm deiconify .}
1114}
1115
1116# compute the composition for each phase and display in a dialog
1117proc composition {} {
1118    global expmap expgui
1119    set Z 1
1120    foreach phase $expmap(phaselist) type $expmap(phasetype) {
1121        if {$type > 2} continue
1122        catch {unset total}
1123        foreach atom $expmap(atomlist_$phase) {
1124            set type [atominfo $phase $atom type]
1125            set mult [atominfo $phase $atom mult]
1126            if [catch {set total($type)}] {
1127                set total($type) [expr \
1128                        $mult * [atominfo $phase $atom frac]]
1129            } else {
1130                set total($type) [expr $total($type) + \
1131                        $mult * [atominfo $phase $atom frac]]
1132            }
1133            if {$mult > $Z} {set Z $mult}
1134        }
1135        append text "\nPhase $phase\n"
1136        append text "  Unit cell contents\n"
1137        foreach type [lsort [array names total]] {
1138            append text "   $type[format %8.3f $total($type)]"
1139        }
1140        append text "\n\n"
1141       
1142        append text "  Asymmetric Unit contents (Z=$Z)\n"
1143        foreach type [lsort [array names total]] {
1144            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
1145        }
1146        append text "\n"
1147    }
1148   
1149    catch {destroy .comp}
1150    toplevel .comp -class MonoSpc
1151    bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1152    wm title .comp Composition
1153    pack [label .comp.results -text $text \
1154            -justify left] -side top
1155    pack [frame .comp.box]  -side top -expand y -fill x
1156    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1157
1158    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1159    pack [button .comp.box.2 -text "Save to $lstnam file" \
1160            -command "writelst [list $text] ; destroy .comp"] -side left
1161    pack [button .comp.box.help -text Help -bg yellow \
1162            -command "MakeWWWHelp expgui.html Composition"] \
1163            -side right
1164}
1165
1166# Delete History Records
1167proc DeleteHistoryRecords {{msg ""}} {
1168    global expgui
1169    set frm .history
1170    catch {destroy $frm}
1171    toplevel $frm
1172    bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1173    if {[string trim $msg] == ""} {
1174        set msg "There are [CountHistory] history records"
1175    }
1176    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1177    pack [label $frm.1.0 -text $msg] -side top
1178    pack [frame $frm.1.1] -side top
1179    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1180    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1181            ] -side left
1182    set expgui(historyKeep) 10
1183    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1184    set expgui(renumber) 1
1185    pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1186    pack [button $frm.2.help -text Help -bg yellow \
1187            -command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1188    pack [button $frm.2.4 -text Quit \
1189            -command {destroy .history}] -side bottom
1190    pack [button $frm.2.3 -text OK \
1191            -command { 
1192        if ![catch {expr $expgui(historyKeep)}] {
1193            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1194            set expgui(changed) 1
1195            destroy .history
1196        }
1197    }] -side bottom
1198    bind $frm <Return> "$frm.2.3 invoke"
1199   
1200    # force the window to stay on top
1201    putontop $frm 
1202    focus $frm.2.3
1203    tkwait window $frm
1204    afterputontop
1205}
1206
1207proc archiveexp {} {
1208    global expgui tcl_platform
1209    # is there a file to archive?
1210    if {![file exists $expgui(expfile)]} return
1211    set expnam [file rootname $expgui(expfile)]
1212    # get the last archived version
1213    set lastf [lindex [lsort [glob -nocomplain $expnam.{O\[0-9A-F\]\[0-9A-F\]}]] end]
1214    if {$lastf == ""} {
1215        set num 01
1216    } else {
1217        regexp {.*\.O([0-9A-F][0-9A-F])$} $lastf a num
1218        scan $num %x num
1219        if {$num >= 255} {
1220            set num FF
1221        } else {
1222            set num [string toupper [format %.2x [incr num]]]
1223        }
1224    }
1225    catch {
1226        set file $expnam.O$num
1227        file copy -force $expgui(expfile) $file
1228        set fp [open $expnam.LST a+]
1229        puts $fp "\n----------------------------------------------"
1230        puts $fp "     Archiving [file tail $expnam.EXP] as [file tail $file]"
1231        puts $fp "----------------------------------------------\n"
1232        close $fp
1233    } errmsg
1234    if {$errmsg != ""} {
1235        tk_dialog .warn Confirm "Error archiving the current .EXP file: $errmsg" warning 0 OK
1236    }
1237}
1238
1239# save and optionally archive the expfile
1240proc savearchiveexp {} {
1241    global expgui expmap
1242    if {$expgui(expfile) == ""} {
1243        SaveAsFile
1244        return
1245    }
1246    if !$expgui(changed) return
1247    if {$expgui(archive)} archiveexp
1248    # add a history record
1249    exphistory add " EXPGUI [lindex $expgui(Revision) 1] [lindex $expmap(Revision) 1] ($expgui(changed) changes) -- [clock format [clock seconds] -format {%D %T}]"
1250    # now save the file
1251    expwrite $expgui(expfile)
1252    set expgui(changed) 0
1253    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
1254    set expgui(last_History) [string range [string trim [lindex [exphistory last] 1]] 0 50 ]
1255    wm title . $expgui(expfile)
1256    set expgui(titleunchanged) 1
1257    # set convergence criterion
1258    InitLSvars
1259}
1260
1261#------------------------------------------------------------------------------
1262# GSAS interface routines
1263#------------------------------------------------------------------------------
1264# run a GSAS program that does not require an experiment file
1265proc runGSASprog {proglist "concurrent 1"} {
1266    # if concurrent is 0, EXPGUI runs the GSAS program in background
1267    # -- this is not currently needed anywhere where the .EXP file is not.
1268    global expgui tcl_platform
1269    set cmd {}
1270    foreach prog $proglist {
1271        StartGRWND $prog
1272        if {$tcl_platform(platform) == "windows"} {
1273            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1274        } else {
1275            if {$cmd != ""} {append cmd "\;"}
1276            append cmd "[file join $expgui(gsasexe) $prog]"
1277        }
1278    }
1279    forknewterm $prog $cmd [expr !$concurrent] 1
1280}
1281
1282# dummy routine, overridden if needed
1283proc StartGRWND {prog} {
1284}
1285
1286# run a GSAS program that requires an experiment file for input/output
1287proc runGSASwEXP {proglist "concurrent 0"} {
1288    # most programs that require the .EXP file change it and
1289    # cannot be run concurrently
1290    global expgui tcl_platform
1291    # Save the current exp file
1292    savearchiveexp
1293    # load the changed .EXP file automatically?
1294    if {$expgui(autoexpload)} {
1295        # disable the file changed monitor
1296        set expgui(expModifiedLast) 0
1297    }
1298    set cmd {}
1299    set expnam [file root [file tail $expgui(expfile)]]
1300    foreach prog $proglist {
1301        if {$prog == "powpref"} {
1302            set expgui(needpowpref) 0
1303            set expgui(needpowpref_why) ""
1304        } elseif {$prog == "genles" && $expgui(needpowpref) != 0} {
1305            set msg "You are attempting to run GENLES, after making changes that require POWPREF:\n\n$expgui(needpowpref_why) \nRun POWPREF first?"
1306            set ans [MyMessageBox -parent . -title "Run POWPREF" \
1307                    -message $msg -icon warning -type "Yes No" -default yes \
1308                    -helplink "expguierr.html RunPowpref"]
1309            if {$ans == "yes"} {
1310                set expgui(needpowpref) 0
1311                set expgui(needpowpref_why) ""
1312                if {$tcl_platform(platform) == "windows"} {
1313                    append cmd " \"$expgui(gsasexe)/powpref.exe $expnam \" "
1314                } else {
1315                    if {$cmd != ""} {append cmd "\;"}
1316                    append cmd "[file join $expgui(gsasexe) powpref] $expnam"
1317                }
1318            }
1319        }
1320        StartGRWND $prog
1321        if {$tcl_platform(platform) == "windows"} {
1322            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1323        } else {
1324            if {$cmd != ""} {append cmd "\;"}
1325            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1326        }
1327    }
1328    forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1329    # load the changed .EXP file automatically?
1330    if {$expgui(autoexpload)} {
1331        # load the revised exp file
1332        loadexp $expgui(expfile)
1333    }
1334}
1335
1336# write text to the .LST file
1337proc writelst {text} {
1338    global expgui
1339    set lstnam [file rootname $expgui(expfile)].LST
1340    set fp [open $lstnam a]
1341    puts $fp "\n-----------------------------------------------------------------"
1342    puts $fp $text
1343    puts $fp "-----------------------------------------------------------------\n"
1344    close $fp
1345}
1346
1347
1348# rename file current to suggested,
1349#   delete window if supplied
1350#   use parent, if supplied or .
1351proc RenameAsFile {current suggested "window {}" "parent {}"} {
1352    if {$parent == "" && $window != ""} {set parent $window}
1353    if {$parent == ""} {set parent .}
1354    set newfile [tk_getSaveFile -initialfile $suggested -parent $parent]
1355    if {$newfile == ""} return
1356    if {[catch {
1357        file rename -force $current $newfile
1358    }]} {
1359        file copy -force $current $newfile
1360        file delete -force $current
1361    }
1362    if {$window != ""} {destroy $window}
1363}
1364
1365# optionally run disagl as a windowless process, w/results in a separate window
1366proc rundisagl {} {
1367    global expgui txtvw tcl_version tcl_platform
1368    if {$expgui(disaglSeparateBox)} {
1369        set root [file root $expgui(expfile)] 
1370        catch {file delete -force $root.tmp}
1371        if {[catch {file rename -force $root.LST $root.OLS}]} {
1372            file copy -force $root.LST $root.OLS
1373            file delete -force $root.OLS
1374        }
1375        # PSW reports this does not happen right away on windows
1376        set i 0
1377        while {$i < 10 && [file exists $root.LST]} {
1378            # debug code
1379            #catch {console show}
1380            #puts "try $i"
1381            # end debug code
1382            after 100
1383            incr i
1384        }
1385        if {[file exists $root.LST]} {
1386            # it was not possible to rename the file
1387            MyMessageBox -parent . -title "Rename Problem" \
1388                -message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1389                -icon warning -helplink "expguierr.html NoRename"
1390            return
1391        }
1392
1393        #run the program
1394        pleasewait "Running DISAGL"     
1395        # create an empty input file
1396        close [open disagl.inp w]
1397        catch {exec [file join $expgui(gsasexe) disagl] \
1398                [file tail $root] < disagl.inp > disagl.out}
1399        if {[catch {file rename -force $root.LST $root.tmp}]} {
1400            file copy -force $root.LST $root.tmp
1401            file delete -force $root.LST
1402        }
1403        catch {file delete -force disagl.inp disagl.out}
1404        if {[catch {file rename -force $root.OLS $root.LST}]} {
1405            file copy -force $root.OLS $root.LST
1406            file delete -force $root.OLS
1407        }
1408        donewait
1409        # open a new window
1410        catch {toplevel .disagl}
1411        catch {eval grid forget [grid slaves .disagl]}
1412        text .disagl.txt -width 100 -wrap none \
1413                -yscrollcommand ".disagl.yscroll set" \
1414                -xscrollcommand ".disagl.xscroll set" 
1415        scrollbar .disagl.yscroll -command ".disagl.txt yview"
1416        scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1417        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1418        grid .disagl.txt -column 0 -row 1 -sticky nsew
1419        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1420        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1421        grid columnconfig .disagl.f 2 -weight 1
1422        grid [button .disagl.f.close -text "Close & Delete" \
1423                -command "destroy .disagl; file delete $root.tmp"] \
1424                -column 3 -row 0 -sticky e
1425        grid [button .disagl.f.rename \
1426                -command "RenameAsFile $root.tmp $root.DIS .disagl" \
1427                -text "Close & Save as..."] \
1428                -column 4 -row 0 -sticky e
1429        # allow font changes on the fly
1430        if {$tcl_version >= 8.0} {
1431            .disagl.txt config -font $txtvw(font)
1432            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1433            grid .disagl.f.font -column 1 -row 0 -sticky w
1434            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1435            $fontbut delete 0 end
1436            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1437                $fontbut add command -label "Courier $f" -font "Courier $f"\
1438                        -command "set txtvw(font) \"Courier $f\"; \
1439                        .disagl.txt config -font \$txtvw(font)"
1440            }
1441        }
1442       
1443        grid columnconfigure .disagl 0 -weight 1
1444        grid rowconfigure .disagl 1 -weight 1
1445        wm title .disagl "DISAGL results $expgui(expfile)"
1446        wm iconname .disagl "DISAGL $root"
1447        set in [open $root.tmp r]
1448        .disagl.txt insert end [read $in]
1449        close $in
1450        bind all  {destroy .disagl}
1451        bind .disagl  ".disagl.txt yview scroll -1 page"
1452        bind .disagl  ".disagl.txt yview scroll 1 page"
1453        bind .disagl  ".disagl.txt xview scroll 1 unit"
1454        bind .disagl  ".disagl.txt xview scroll -1 unit"
1455        bind .disagl  ".disagl.txt yview scroll -1 unit"
1456        bind .disagl  ".disagl.txt yview scroll 1 unit"
1457        bind .disagl  ".disagl.txt yview 0"
1458        bind .disagl  ".disagl.txt yview end"
1459        # don't disable in Win as this prevents the highlighting of selected text
1460        if {$tcl_platform(platform) != "windows"} {
1461            .disagl.txt config -state disabled
1462        }
1463    } else {
1464        runGSASwEXP disagl
1465    }
1466}
1467
1468#------------------------------------------------------------------------------
1469# file conversions
1470#------------------------------------------------------------------------------
1471proc convfile {} {
1472    global expgui
1473    set frm .file
1474    catch {destroy $frm}
1475    toplevel $frm
1476    wm title $frm "Convert File"
1477    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1478    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1479    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1480            -side left -fill y -expand yes
1481    pack [button $frmC.help -text Help -bg yellow \
1482            -command "MakeWWWHelp expgui.html ConvertWin"] -side top
1483    pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1484    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1485            -side bottom
1486    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1487    winfilebox $frm
1488    bind $frm <Return> "ValidWinCnv $frm"
1489
1490    # force the window to stay on top
1491    putontop $frm
1492    focus $frmC.q 
1493    tkwait window $frm
1494    afterputontop
1495}
1496
1497# validate the files and make the conversion
1498proc ValidWinCnv {frm} {
1499    global expgui
1500    # change backslashes to something sensible
1501    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1502    # allow entry of D: for D:/ and D:TEST for d:/TEST
1503    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1504            [string first :/ $expgui(FileMenuCnvName)] == -1} {
1505        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1506    }
1507    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1508        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1509        ChooseWinCnv $frm
1510        return
1511    } elseif [file isdirectory \
1512            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1513        if {$expgui(FileMenuCnvName) != "."} {
1514            set expgui(FileMenuDir) \
1515                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1516        }
1517        ChooseWinCnv $frm
1518        return
1519    }
1520 
1521    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1522    if ![file exists $file] {
1523        MyMessageBox -parent $frm -title "Convert Error" \
1524                -message "File $file does not exist" -icon error
1525        return
1526    }
1527
1528    set tmpname "[file join [file dirname $file] tempfile.xxx]"
1529    set oldname "[file rootname $file].org"
1530    if [file exists $oldname] {
1531        set ans [MyMessageBox -parent . -title "Overwrite?" \
1532                -message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1533                -icon warning -type {Overwrite Cancel} -default Overwrite \
1534                -helplink "expguierr.html OverwriteCnv"]
1535        if {[string tolower $ans] == "cancel"} return
1536        catch {file delete $oldname}
1537    }
1538
1539    if [catch {
1540        set in [open $file r]
1541        set out [open $tmpname w]
1542        fconfigure $out -translation crlf
1543        set len [gets $in line]
1544        if {$len > 160} {
1545            # this is a UNIX file. Hope there are no control characters
1546            set i 0
1547            set j 79
1548            while {$j < $len} {
1549                puts $out [string range $line $i $j]
1550                incr i 80
1551                incr j 80
1552            }
1553        } else {
1554            while {$len >= 0} {
1555                append line "                                        "
1556                append line "                                        "
1557                set line [string range $line 0 79]
1558                puts $out $line
1559                set len [gets $in line]
1560            }
1561        }
1562        close $in
1563        close $out
1564        file rename -force $file $oldname
1565        file rename -force $tmpname $file
1566    } errmsg] {
1567        MyMessageBox -parent $frm -title "Conversion error" \
1568                -message "Error in conversion:\n$errmsg" -icon warning
1569    } else {
1570        set ans [MyMessageBox -parent $frm -title "More?" \
1571                -message "File [file tail $file] converted.\n(Original saved as [file tail $oldname]).\n\n Convert more files?" \
1572                -type yesno -default no]
1573        if {$ans == "no"} {destroy $frm}
1574    }
1575}
1576
1577# create a file box
1578proc winfilebox {frm} {
1579    global expgui
1580    set bx $frm.1
1581    pack [frame $bx.top] -side top
1582    pack [label $bx.top.a -text "Directory" ] -side left
1583    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1584    pack $bx.top.d -side left
1585    set expgui(FileMenuDir) [pwd]
1586    # the icon below is from tk8.0/tkfbox.tcl
1587    set upfolder [image create bitmap -data {
1588#define updir_width 28
1589#define updir_height 16
1590static char updir_bits[] = {
1591   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1592   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1593   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1594   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1595   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1596   0xf0, 0xff, 0xff, 0x01};}]
1597
1598    pack [button $bx.top.b -image $upfolder \
1599            -command "updir; ChooseWinCnv $frm" ]
1600    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1601    listbox $bx.a.files -relief raised -bd 2 \
1602            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1603            -height 15 -width 0 -exportselection 0 
1604    listbox $bx.a.dates -relief raised -bd 2 \
1605            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1606            -height 15 -width 0 -takefocus 0 -exportselection 0 
1607    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1608    ChooseWinCnv $frm
1609    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1610    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1611    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1612    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1613    pack $bx.a.scroll -side left -fill y
1614    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1615    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1616}
1617
1618# set the box or file in the selection window
1619proc ReleaseWinCnv {frm} {
1620    global expgui
1621    set files $frm.1.a.files
1622    set dates $frm.1.a.dates
1623    set select [$files curselection]
1624    if {$select == ""} {
1625        set select [$dates curselection]
1626    }
1627    if {$select == ""} {
1628        set expgui(FileMenuCnvName) ""
1629    } else {
1630        set expgui(FileMenuCnvName) [string trim [$files get $select]]
1631    }
1632    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1633        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1634        ChooseWinCnv $frm
1635    } elseif [file isdirectory \
1636            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1637        if {$expgui(FileMenuCnvName) != "."} {
1638            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1639            ChooseWinCnv $frm
1640        }
1641    }
1642    return
1643}
1644
1645# select a file or directory -- called on double click
1646proc SelectWinCnv {frm} {
1647    global expgui
1648    set files $frm.1.a.files
1649    set dates $frm.1.a.dates
1650    set select [$files curselection]
1651    if {$select == ""} {
1652        set select [$dates curselection]
1653    }
1654    if {$select == ""} {
1655        set file .
1656    } else {
1657        set file [string trim [$files get $select]]
1658    }
1659    if {$file == "<Parent>"} {
1660        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1661        ChooseWinCnv $frm
1662    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1663        if {$file != "."} {
1664            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1665            ChooseWinCnv $frm
1666        }
1667    } else {
1668        set expgui(FileMenuCnvName) [file tail $file]
1669        ValidWinCnv $frm
1670    }
1671}
1672
1673# fill the files & dates & Directory selection box with current directory,
1674# also called when box is created to fill it
1675proc ChooseWinCnv {frm} {
1676    global expgui
1677    set files $frm.1.a.files
1678    set dates $frm.1.a.dates
1679    set expgui(FileMenuCnvName) {}
1680    $files delete 0 end
1681    $dates delete 0 end
1682    $files insert end {<Parent>}
1683    $dates insert end {(Directory)}
1684    set filelist [glob -nocomplain \
1685            [file join [set expgui(FileMenuDir)] *] ]
1686    foreach file [lsort -dictionary $filelist] {
1687        if {[file isdirectory $file]} {
1688            $files insert end [file tail $file]
1689            $dates insert end {(Directory)}
1690        }
1691    }
1692    foreach file [lsort -dictionary $filelist] {
1693        if {![file isdirectory $file]} {
1694            set modified [clock format [file mtime $file] -format "%T %D"]
1695            $files insert end [file tail $file]
1696            $dates insert end $modified
1697        }
1698    }
1699    $expgui(FileDirButtonMenu)  delete 0 end
1700    set list ""
1701    global tcl_version
1702    if {$tcl_version > 8.0} {
1703        catch {set list [string tolower [file volume]]}
1704    }
1705    set dir ""
1706    foreach subdir [file split [set expgui(FileMenuDir)]] {
1707        set dir [string tolower [file join $dir $subdir]]
1708        if {[lsearch $list $dir] == -1} {lappend list $dir}
1709    }
1710    foreach path $list {
1711        $expgui(FileDirButtonMenu) add command -label $path \
1712                -command "[list set expgui(FileMenuDir) $path]; \
1713                ChooseWinCnv $frm"
1714    }
1715    return
1716}
1717
1718#------------------------------------------------------------------------------
1719# set options for liveplot
1720proc liveplotopt {} {
1721    global liveplot expmap
1722    set frm .file
1723    catch {destroy $frm}
1724    toplevel $frm
1725    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1726    set last [lindex [lsort -integer $expmap(powderlist)] end]
1727    if {$last == ""} {set last 1}
1728    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
1729            -length  150 -orient horizontal -variable liveplot(hst)] -side top
1730    pack [checkbutton $frmA.2 -text {include plot legend}\
1731            -variable liveplot(legend)] -side top
1732    pack [button $frm.2 -text OK \
1733            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1734            ] -side top
1735    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1736   
1737    # force the window to stay on top
1738    putontop $frm 
1739    focus $frm.2
1740    tkwait window $frm
1741    afterputontop
1742}
1743
1744#------------------------------------------------------------------------------
1745# get an experiment file name
1746#------------------------------------------------------------------------------
1747proc getExpFileName {mode} {
1748    global expgui tcl_platform
1749    set frm .file
1750    catch {destroy $frm}
1751    toplevel $frm
1752    wm title $frm "Experiment file"
1753    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1754    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1755    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1756            -fill y -expand yes
1757    pack [button $frmC.help -text Help -bg yellow \
1758            -command "MakeWWWHelp expguierr.html open"] \
1759            -side top -anchor e
1760    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1761    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1762            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1763    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1764            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1765
1766    set expgui(includearchived) 0
1767    set expgui(FileInfoBox) $frmC.info
1768    if {$mode == "old"} {
1769        pack [checkbutton $frmC.ar -text "Include Archived Files" \
1770                -variable expgui(includearchived) \
1771                -command "ChooseExpFil $frmA"] -side top -pady 10
1772        pack [frame $expgui(FileInfoBox) -bd 4 -relief groove \
1773                -class SmallFont] \
1774                -side top -fill both -expand yes -pady 5
1775    }
1776    pack [button $frmC.b -text Read \
1777            -command "valid_exp_file $frmA $mode"] -side bottom
1778    if {$mode == "new"} {
1779        $frmC.b config -text Save
1780    }
1781    pack [button $frmC.q -text Quit \
1782            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1783    bind $frm <Return> "$frmC.b invoke"
1784
1785    if {$mode == "new"} {
1786        pack [label $frmA.0 -text "Enter an experiment file to create"] \
1787                -side top -anchor center
1788    } else {
1789        pack [label $frmA.0 -text "Select an experiment file to read"] \
1790                -side top -anchor center
1791    }
1792    expfilebox $frmA $mode
1793    # force the window to stay on top
1794    putontop $frm
1795    focus $frmC.b
1796    tkwait window $frm
1797    afterputontop
1798    if {$expgui(FileMenuEXPNAM) == ""} return
1799    # is there a space in the EXP name?
1800    if {[string first " " [file tail $expgui(FileMenuEXPNAM)]] != -1} {
1801        update
1802        MyMessageBox -parent . -title "File Name Error" \
1803            -message "File name \"$expgui(FileMenuEXPNAM)\" is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1804            -icon warning -type Continue -default continue
1805#               -helplink "expguierr.html OpenErr"
1806        return
1807    }
1808    if {[string first " " $expgui(FileMenuDir)] != -1} {
1809        update
1810        MyMessageBox -parent . -title "Good luck..." \
1811            -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." \
1812            -icon warning -type Continue -default continue
1813#               -helplink "expguierr.html OpenErr"
1814    }
1815    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1816}
1817
1818# validation routine
1819proc valid_exp_file {frm mode} {
1820    global expgui tcl_platform
1821    # windows fixes
1822    if {$tcl_platform(platform) == "windows"} {
1823        # change backslashes to something sensible
1824        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1825        # allow entry of D: for D:/ and D:TEST for d:/TEST
1826        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1827                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1828            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1829        }
1830    }
1831    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1832        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1833        ChooseExpFil $frm
1834        return
1835    } elseif [file isdirectory \
1836            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1837        if {$expgui(FileMenuEXPNAM) != "."} {
1838            set expgui(FileMenuDir) \
1839                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1840        }
1841        ChooseExpFil $frm
1842        return
1843    }
1844    # append a .EXP if not present
1845    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
1846        append expgui(FileMenuEXPNAM) ".EXP"
1847    }
1848    # is there a space in the name?
1849    if {[string first " " $expgui(FileMenuEXPNAM)] != -1} {
1850        MyMessageBox -parent . -title "File Name Error" \
1851                -message "File name $expgui(FileMenuEXPNAM) is invalid -- EXPGUI cannot process experiment files with spaces in the name" \
1852                -icon warning -type Continue -default continue
1853#               -helplink "expguierr.html OpenErr"
1854        return
1855    }
1856    # check for archive files
1857    if {[string match {*.O[0-9A-F][0-9A-F]} $expgui(FileMenuEXPNAM)] && \
1858            $mode == "old" && [file exists $expgui(FileMenuEXPNAM)]} {
1859        destroy .file
1860        return
1861    } elseif {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
1862        # check for files that end in something other than .EXP .exp or .Exp...
1863        MyMessageBox -parent . -title "File Open Error" \
1864                -message "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
1865                -icon error
1866        return
1867    }
1868    # check on the file status
1869    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1870    if {$mode == "new" && [file exists $file]} {
1871        set ans [
1872        MyMessageBox -parent . -title "File Open Error" \
1873                -message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
1874                -icon question -type {"Select other" "Overwrite"} -default "select other" \
1875                -helplink "expguierr.html OverwriteErr"
1876        ]
1877        if {[string tolower $ans] == "overwrite"} {destroy .file}
1878        return
1879    }
1880    # if file does not exist in case provided, set the name to all
1881    # upper case letters, since that is the best choice.
1882    # if it does exist, read from it as is. For UNIX we will force uppercase later.
1883    if {![file exists $file]} {
1884        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1885        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1886    }
1887    if {$mode == "old" && ![file exists $file]} {
1888        set ans [
1889        MyMessageBox -parent . -title "File Open Error" \
1890                -message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
1891                -icon question -type {"Select other" "Create"} -default "select other" \
1892                -helplink "expguierr.html OpenErr"
1893        ]
1894        if {[string tolower $ans] == "create"} {destroy .file}
1895        return
1896    }
1897    destroy .file
1898}
1899
1900proc updir {} {
1901    global expgui
1902    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1903}
1904
1905# create a file box
1906proc expfilebox {bx mode} {
1907    global expgui
1908    pack [frame $bx.top] -side top
1909    pack [label $bx.top.a -text "Directory" ] -side left
1910    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1911    pack $bx.top.d -side left
1912    set expgui(FileMenuDir) [pwd]
1913    # the icon below is from tk8.0/tkfbox.tcl
1914    set upfolder [image create bitmap -data {
1915#define updir_width 28
1916#define updir_height 16
1917static char updir_bits[] = {
1918   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1919   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1920   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1921   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1922   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1923   0xf0, 0xff, 0xff, 0x01};}]
1924
1925    pack [button $bx.top.b -image $upfolder \
1926            -command "updir; ChooseExpFil $bx" ]
1927    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1928    listbox $bx.a.files -relief raised -bd 2 \
1929            -yscrollcommand "sync2boxesY $bx.a.files $bx.a.dates $bx.a.scroll" \
1930            -height 15 -width 0 -exportselection 0 
1931    listbox $bx.a.dates -relief raised -bd 2 \
1932            -yscrollcommand "sync2boxesY $bx.a.dates $bx.a.files $bx.a.scroll" \
1933            -height 15 -width 0 -takefocus 0 -exportselection 0 
1934    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1935    ChooseExpFil $bx
1936    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1937    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1938    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1939    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1940    pack $bx.a.scroll -side left -fill y
1941    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1942    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1943}
1944proc sync2boxesX {master slave scroll args} {
1945    $slave xview moveto [lindex [$master xview] 0]
1946    eval $scroll set $args
1947}
1948proc move2boxesX {boxlist args} {
1949    foreach listbox $boxlist { 
1950        eval $listbox xview $args
1951    }
1952}
1953proc sync2boxesY {master slave scroll args} {
1954    $slave yview moveto [lindex [$master yview] 0]
1955    eval $scroll set $args
1956}
1957proc move2boxesY {boxlist args} {
1958    foreach listbox $boxlist { 
1959        eval $listbox yview $args
1960    }
1961}
1962
1963# creates a table that is scrollable in both x and y, use ResizeScrollTable
1964# to set sizes after gridding the boxes
1965proc MakeScrollTable {box} {
1966    grid [label $box.0] -column 0 -row 0
1967    grid [set tbox [canvas $box.top \
1968            -scrollregion {0 0 10 10} \
1969            -xscrollcommand "sync2boxesX $box.top $box.can $box.scroll" \
1970            -width 10 -height 10]] \
1971            -sticky sew -row 0 -column 1
1972    grid [set sbox [canvas $box.side \
1973            -scrollregion {0 0 10 10} \
1974            -yscrollcommand "sync2boxesY $box.side $box.can $box.yscroll" \
1975            -width 10 -height 10]] \
1976            -sticky nes -row 1 -column 0
1977    grid [set bbox [canvas $box.can \
1978            -scrollregion {0 0 10 10} \
1979            -yscrollcommand "sync2boxesY $box.can $box.side $box.yscroll" \
1980            -xscrollcommand "sync2boxesX $box.can $box.top $box.scroll" \
1981            -width 200 -height 200 -bg lightgrey]] \
1982            -sticky news -row 1 -column 1
1983    grid [set sxbox [scrollbar $box.scroll -orient horizontal \
1984            -command "move2boxesX \" $box.can $box.top \" "]] \
1985            -sticky ew -row 2 -column 1
1986    grid [set sybox [scrollbar $box.yscroll \
1987            -command "move2boxesY \" $box.can $box.side \" "]] \
1988            -sticky ns -row 1 -column 2
1989    frame $tbox.f -bd 0
1990    $tbox create window 0 0 -anchor nw  -window $tbox.f
1991    frame $bbox.f -bd 2
1992    $bbox create window 0 0 -anchor nw  -window $bbox.f
1993    frame $sbox.f -bd 2 -relief raised
1994    $sbox create window 0 0 -anchor nw  -window $sbox.f
1995    grid columnconfig $box 1 -weight 1
1996    grid rowconfig $box 1 -weight 1
1997    return [list  $tbox.f  $bbox.f $sbox.f $box.0]
1998}
1999
2000proc ResizeScrollTable {box} {
2001    update idletasks
2002    for {set i 0} {$i < [lindex [grid size $box.can.f] 0]} {incr i} {
2003        set x1 [lindex [grid bbox $box.can.f $i 0] 2]
2004        set x2 [lindex [grid bbox $box.top.f $i 0] 2]
2005        if {$x2 > $x1} {set x1 $x2}
2006        grid columnconfigure $box.top.f $i -minsize $x1
2007        grid columnconfigure $box.can.f $i -minsize $x1
2008    }
2009    for {set i 0} {$i < [lindex [grid size $box.can.f] 1]} {incr i} {
2010        set x1 [lindex [grid bbox $box.can.f 0 $i] 3]
2011        set x2 [lindex [grid bbox $box.side.f 0 $i] 3]
2012        if {$x2 > $x1} {set x1 $x2}
2013        grid rowconfigure $box.can.f $i -minsize $x1
2014        grid rowconfigure $box.side.f $i -minsize $x1
2015    }
2016    update idletasks
2017    set sizes [grid bbox $box.can.f]
2018    $box.can config -scrollregion $sizes
2019    $box.side config -scrollregion $sizes
2020    $box.top config -scrollregion $sizes
2021    $box.top config -height [lindex [grid bbox $box.top.f] 3]
2022    $box.side config -width [lindex [grid bbox $box.side.f] 2]
2023}
2024proc ExpandScrollTable {box} {
2025    # set height & width of central box
2026    $box.can config -width \
2027            [expr [winfo width [winfo toplevel $box]] \
2028            - [winfo width $box.side] - [winfo width $box.yscroll]-20]
2029    $box.can config -height \
2030            [expr [winfo height [winfo toplevel $box]] \
2031            - [winfo height $box.top] - [winfo height $box.scroll]-25]
2032}
2033
2034
2035# support routine for SetHistUseFlags
2036proc InitHistUseFlags {} {
2037    global expmap expgui
2038    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2039#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2040            set expgui(useflag_$i) [histinfo $i use]
2041#       }
2042    }
2043}
2044
2045# show all Powder histograms; set use/do not use flags
2046proc SetHistUseFlags {} {
2047    set box .test
2048    catch {toplevel $box}
2049    eval destroy [winfo children $box]
2050    grid [label $box.0 -text "Set histogram \"Use/Do Not Use\" flags" -bg white] -row 0 -column 0 -columnspan 2
2051    grid [frame $box.a] -row 1 -column 0 -columnspan 2
2052    grid [button $box.b -text Save -command "destroy $box"] -row 2 -column 0 -sticky e
2053    grid [button $box.c -text Cancel -command "InitHistUseFlags;destroy $box"] -row 2 -column 1 -sticky w
2054    grid columnconfig $box 0 -weight 1
2055    grid columnconfig $box 1 -weight 1
2056    foreach a [MakeScrollTable $box.a] b {tbox bbox sbox cbox} {set $b $a}
2057    $cbox config -text "Use\nFlag"
2058    [winfo parent $bbox] config -height 250 -width 400
2059    global expmap expgui
2060    set px 5
2061    set row -1
2062    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2063        if {[string range $expmap(htype_$i) 2 2] == "T"} {
2064            set det [format %8.2f [histinfo $i tofangle]]
2065        } elseif {[string range $expmap(htype_$i) 2 2] == "C"} {
2066            set det [format %8.5f [histinfo $i lam1]]
2067        } elseif {[string range $expmap(htype_$i) 2 2] == "E"} {
2068            set det [format %8.2f [histinfo $i lam1]]
2069        } else {
2070            set det {}
2071        }
2072        incr row
2073#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2074            grid [checkbutton $sbox.$i -text $i -variable expgui(useflag_$i)] -row $row -column 0 
2075            set expgui(useflag_$i) [histinfo $i use]
2076#       }
2077        grid [label $bbox.0$i \
2078                -text [string range $expmap(htype_$i) 0 3] \
2079                ] -row $row -column 0 -padx $px
2080        grid [label $bbox.1$i -text [histinfo $i bank] \
2081                ] -row $row -column 1 -padx $px
2082        grid [label $bbox.2$i -text $det] -row $row -column 2 -padx $px
2083        grid [label $bbox.3$i -text [string range [histinfo $i title] 0 66] \
2084                ] -row $row -column 3 -padx $px -sticky ew
2085    }
2086    grid [label $tbox.0 -text type -bd 2 -relief raised] -row 0 -column 0 -padx $px
2087    grid [label $tbox.1 -text bank -bd 2 -relief raised] -row 0 -column 1 -padx $px
2088    grid [label $tbox.2 -text "ang/wave" -bd 2 -relief raised] -row 0 -column 2 -padx $px
2089    grid [label $tbox.3 -text "histogram title" -bd 2 -relief raised] -row 0 -column 3 -sticky w -padx $px
2090    ResizeScrollTable $box.a
2091    InitHistUseFlags
2092    putontop $box
2093    tkwait window $box
2094    afterputontop
2095    set prevchages $expgui(changed)
2096    for {set i 1} {$i <= $expmap(nhst)} {incr i} {
2097#       if {[string range $expmap(htype_$i) 0 0] == "P"} {
2098            if {$expgui(useflag_$i) != [histinfo $i use]} {
2099                histinfo $i use set $expgui(useflag_$i)
2100                incr expgui(changed)
2101            }
2102#       }
2103    }
2104    if {$prevchages != $expgui(changed)} {
2105        set msg "You have changed [expr $expgui(changed)-$prevchages] "
2106        append msg "histogram flag(s). You must run POWPREF "
2107        append msg "to include/remove these histograms. Do you want to "
2108        append msg "run POWPREF?"
2109        set ans [MyMessageBox -parent . -message $msg \
2110                -title "Process changes?"\
2111                -helplink "expguierr.html ProcessUse" \
2112                -default {Run POWPREF} \
2113                -type {{Run POWPREF} Skip}]
2114       
2115        if {$ans == "skip"} {
2116            # save and reload the experiment file
2117            savearchiveexp
2118            loadexp $expgui(expfile)
2119        } else {
2120            # run powpref and force a reload
2121            set saveautoload $expgui(autoexpload)
2122            set expgui(autoexpload) 1
2123            runGSASwEXP powpref
2124            set expgui(autoexpload) $saveautoload
2125        }
2126    }
2127}
2128
2129# set the box or file in the selection window
2130proc ReleaseExpFil {frm} {
2131    global expgui
2132    set files $frm.a.files
2133    set dates $frm.a.dates
2134    set select [$files curselection]
2135    if {$select == ""} {
2136        set select [$dates curselection]
2137    }
2138    if {$select == ""} {
2139        set expgui(FileMenuEXPNAM) ""
2140    } else {
2141        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2142        after idle UpdateInfoBox
2143    }
2144    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2145        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2146        ChooseExpFil $frm
2147    } elseif [file isdirectory \
2148            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2149        if {$expgui(FileMenuEXPNAM) != "."} {
2150            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2151            ChooseExpFil $frm
2152        }
2153    }
2154    return
2155}
2156proc UpdateInfoBox {} {
2157    global expgui
2158    if {![winfo exists $expgui(FileInfoBox)]} return
2159    eval destroy [winfo children $expgui(FileInfoBox)]
2160    set file [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]
2161    if [file isdirectory $file] return
2162    if [file exists $file] {
2163        pack [label $expgui(FileInfoBox).1 -text $expgui(FileMenuEXPNAM)] \
2164                -side top
2165        catch {
2166            set fp [open $file r]
2167            global testline
2168            set testline [read $fp]
2169            close $fp
2170            update
2171            regexp {GNLS  RUN on (.*) +Total.*run +([0-9]+) } \
2172                    $testline a last cycles
2173            pack [label $expgui(FileInfoBox).2 -justify left \
2174                    -text "last GENLES run:\n  $last\n  total cycles: $cycles"] \
2175                -side top -anchor w
2176            regexp {REFN GDNFT.*= *([0-9]*\.[0-9]*) +for *([0-9]+) variables} \
2177                    $testline a chi2 vars
2178            pack [frame $expgui(FileInfoBox).3 -class SmallFont] \
2179                    -side top -anchor w
2180            pack [label $expgui(FileInfoBox).3.a -justify left \
2181                    -text "c" -font symbol] \
2182                    -side left -anchor w
2183            pack [label $expgui(FileInfoBox).3.b -justify left \
2184                    -text "2: $chi2, $vars vars"] \
2185                    -side top -anchor w
2186            # check first 9 histograms
2187            set lbl "h  Rwp     R(F2)"
2188            set n 0
2189            foreach k {1 2 3 4 5 6 7 8 9} {
2190                set key "HST  $k"
2191                append key { RPOWD +([0-9]*\.[0-9]*) }
2192                set i [regexp $key $testline a Rwp]
2193                set key "HST  $k"
2194                append key { R-FAC +[0-9]+ +([0-9]*\.[0-9]*) }
2195                set j [regexp $key $testline a Rb]
2196                if {$i || $j} {
2197                    incr n
2198                    append lbl "\n$k  "
2199                    if {$i} {
2200                        append lbl [string range $Rwp 0 5]
2201                    } else {
2202                        append lbl "    "
2203                    }
2204                }
2205                if {$j} {
2206                    append lbl " [string range $Rb 0 5]"
2207                }
2208                # stick 1st 3 entries in box
2209                if {$n >= 3} break
2210            }
2211            pack [label $expgui(FileInfoBox).4 -justify left \
2212                    -text $lbl] \
2213                    -side top -anchor w     
2214        }
2215    }
2216}
2217
2218# select a file or directory -- called on double click
2219proc SelectExpFil {frm mode} {
2220    global expgui
2221    set files $frm.a.files
2222    set dates $frm.a.dates
2223    set select [$files curselection]
2224    if {$select == ""} {
2225        set select [$dates curselection]
2226    }
2227    if {$select == ""} {
2228        set file .
2229    } else {
2230        set file [string trim [$files get $select]]
2231    }
2232    if {$file == "<Parent>"} {
2233        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2234        ChooseExpFil $frm
2235    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2236        if {$file != "."} {
2237            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2238            ChooseExpFil $frm
2239        }
2240    } else {
2241        set expgui(FileMenuEXPNAM) [file tail $file]
2242        valid_exp_file $frm $mode
2243    }
2244}
2245
2246# fill the files & dates & Directory selection box with current directory,
2247# also called when box is created to fill it
2248proc ChooseExpFil {frm} {
2249    global expgui
2250    set files $frm.a.files
2251    set dates $frm.a.dates
2252    set expgui(FileMenuEXPNAM) {}
2253    $files delete 0 end
2254    $dates delete 0 end
2255    $files insert end {<Parent>}
2256    $dates insert end {(Directory)}
2257    set filelist [glob -nocomplain \
2258            [file join [set expgui(FileMenuDir)] *] ]
2259    foreach file [lsort -dictionary $filelist] {
2260        if {[file isdirectory $file]} {
2261            $files insert end [file tail $file]
2262            $dates insert end {(Directory)}
2263        }
2264    }
2265    set pairlist {}
2266    foreach file [lsort -dictionary $filelist] {
2267        if {![file isdirectory $file]  && \
2268                [string toupper [file extension $file]] == ".EXP"} {
2269            set modified [file mtime $file]
2270            lappend pairlist [list $file $modified]
2271        } elseif {![file isdirectory $file] && $expgui(includearchived) && \
2272                [string match {*.O[0-9A-F][0-9A-F]} $file]} {
2273            set modified [file mtime $file]
2274            lappend pairlist [list $file $modified]
2275        }
2276    }
2277    if {$expgui(filesort) == 0} {
2278        foreach pair [lsort -index 1 -integer -decreasing $pairlist] {
2279            set file [lindex $pair 0]
2280            set modified [clock format [lindex $pair 1] -format "%T %D"]
2281            $files insert end [file tail $file]
2282            $dates insert end $modified
2283        }
2284    } else {
2285        foreach pair [lsort -dictionary -index 0 $pairlist] {
2286            set file [lindex $pair 0]
2287            set modified [clock format [lindex $pair 1] -format "%T %D"]
2288            $files insert end [file tail $file]
2289            $dates insert end $modified
2290        }
2291    }
2292    $expgui(FileDirButtonMenu)  delete 0 end
2293    set list ""
2294    global tcl_platform tcl_version
2295    if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2296        catch {set list [string tolower [file volume]]}
2297    }
2298    set dir ""
2299    foreach subdir [file split [set expgui(FileMenuDir)]] {
2300        set dir [file join $dir $subdir]
2301        if {$tcl_platform(platform) == "windows"} {
2302            set dir [string tolower $dir]
2303            if {[lsearch $list $dir] == -1} {lappend list $dir}
2304        } else {
2305            lappend list $dir
2306        }
2307    }
2308    foreach path $list {
2309        $expgui(FileDirButtonMenu) add command -label $path \
2310                -command "[list set expgui(FileMenuDir) $path]; \
2311                ChooseExpFil $frm"
2312    }
2313    # highlight the current experiment -- if present
2314    for {set i 0} {$i < [$files size]} {incr i} {
2315        set file [$files get $i]
2316        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2317            $files selection set $i
2318        }
2319    }
2320    return
2321}
2322
2323
2324#------------------------------------------------------------------------------
2325# platform-specific definitions
2326if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2327    # windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2328    # DOS box synchronously, so we create a "lock" file that is deleted
2329    # at the end of the DOS run so we can tell when the run is done.
2330    # We create a window to force the deleting of the file so that if
2331    # the DOS process crashes, the user can continue anyway.
2332    #
2333    # procedure to check if the lock file is still there (Win-9x/me only)
2334    proc checklockfile {file window} {
2335        if [file exists $file] {
2336            after 500 checklockfile $file $window
2337        } else {
2338            catch {destroy $window}
2339        }
2340    }
2341    # this procedure starts the GRWND program, if needed for program $prog
2342    proc StartGRWND {prog} {
2343        global expgui
2344        if {!$expgui(autoGRWND)} return
2345        # at some point we might want to have a real list
2346        if {$prog != "genles" && $prog != "powpref"} {
2347            # get a list of running jobs
2348            exec [file join $expgui(scriptdir) win9xbin tlist.exe] > tlist.tlist
2349            set fp [open tlist.tlist r]
2350            set text [read $fp]
2351            close $fp
2352            file delete -force tlist.tlist
2353            # if GRWND.EXE is not currently running, start it
2354            if {[lsearch [string toupper $text] GRWND.EXE] == -1} {
2355                exec [file join $expgui(gsasexe) grwnd.exe] &
2356                # give grwnd a 1 second head start
2357                after 1000
2358            }
2359        }
2360    }
2361    # this creates a DOS box to run a program in
2362    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2363        global env expgui
2364        # Windows environment variables
2365        set env(GSAS) [file nativename $expgui(gsasdir)]
2366        # PGPLOT_FONT is needed by PGPLOT
2367        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2368        # this is the number of lines/page in the .LST (etc.) file
2369        set env(LENPAGE) 60
2370        set pwd [file nativename [pwd]]
2371       
2372        # check the .EXP path -- can DOS use it?
2373        if {[string first // [pwd]] != -1} {
2374            MyMessageBox -parent . -title "Invalid Path" \
2375                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2376                    -icon error -type ok -default ok \
2377                    -helplink "expgui_Win_readme.html NetPath"
2378            return
2379        }
2380        # pause is hard coded in the .BAT file
2381        #
2382        # loop over multiple commands
2383        foreach cmd $command {
2384            # simulate the wait with a lock file
2385            if {$wait} {
2386                if {$expgui(autoiconify)} {wm iconify .}
2387                # create a blank lock file and a message window
2388                close [open expgui.lck w]
2389                toplevel .lock
2390                grid [button .lock.0 -text Help -bg yellow \
2391                        -command "MakeWWWHelp expguierr.html lock"] \
2392                        -column 1 -row 0
2393                grid [label .lock.1 \
2394                        -text "Please wait while the GSAS program finishes."] \
2395                        -column 0 -row 0
2396                grid [label .lock.2 -text \
2397                        "In case a problem occurs, close the DOS box"] \
2398                        -column 0 -columnspan 2 -row 1
2399                grid [label .lock.3 -text \
2400                        "and press the \"Continue\" button (below)"] \
2401                        -column 0 -columnspan 2 -row 2
2402                grid [button .lock.b -text "Continue" \
2403                        -command "destroy .lock; wm deiconify ."] \
2404                        -column 0 -columnspan 2 -row 3
2405                putontop .lock
2406                update
2407                checklockfile expgui.lck .lock
2408            }
2409            # replace the forward slashes with backward
2410            regsub -all / $cmd \\ cmd
2411            winexec -d [file nativename [pwd]] \
2412                    [file join $expgui(scriptdir) gsastcl.bat] $cmd
2413            if {$wait} {
2414                tkwait window .lock
2415                file delete -force expgui.lck
2416            }
2417        }
2418        if {$expgui(autoiconify) && $wait} {wm deiconify .}
2419        # check for changes in the .EXP file immediately
2420        whenidle
2421    }
2422} elseif {$tcl_platform(platform) == "windows"} {
2423    # now for Windows-NT, where we can run synchronously
2424    #
2425    # this creates a DOS box to run a program in
2426    proc forknewterm {title command  "wait 1" "scrollbar 1"} {
2427        global env expgui
2428        # Windows environment variables
2429        set env(GSAS) [file nativename $expgui(gsasdir)]
2430        # PGPLOT_FONT is needed by PGPLOT
2431        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) pgl grfont.dat]]
2432        # this is the number of lines/page in the .LST (etc.) file
2433        set env(LENPAGE) 60
2434        set pwd [file nativename [pwd]]
2435        # check the path -- can DOS use it?
2436        if {[string first // [pwd]] != -1} {
2437            MyMessageBox -parent . -title "Invalid Path" \
2438                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2439                    -icon error -type ok -default ok \
2440                    -helplink "expgui_Win_readme.html NetPath"
2441            return
2442        }
2443        # pause is hard coded in the .BAT file
2444
2445        if {$wait} {
2446            if {$expgui(autoiconify)} {wm iconify .}
2447            # create a blank lock file (keep liveplot from running)
2448            close [open expgui.lck w]
2449            # loop over commands
2450            foreach cmd $command {
2451                # replace the forward slashes with backward
2452                regsub -all / $cmd \\ cmd
2453                exec $env(COMSPEC) /c \
2454                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd"
2455            }
2456            file delete -force expgui.lck
2457            if {$expgui(autoiconify)} {wm deiconify .}
2458            # check for changes in the .EXP file immediately
2459            whenidle
2460        } else {
2461            # loop over commands
2462            foreach cmd $command {
2463                # replace the forward slashes with backward
2464                regsub -all / $cmd \\ cmd
2465                # run in background
2466                exec $env(COMSPEC) /c \
2467                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd" &
2468            }
2469        }
2470    }
2471} else {
2472    # this creates a xterm window to run a program in
2473    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2474        global env expgui
2475        # UNIX environment variables
2476        set env(GSAS) [file nativename $expgui(gsasdir)]
2477        set env(gsas) [file nativename $expgui(gsasdir)]
2478        set env(GSASEXE) $expgui(gsasexe)
2479        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2480        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2481        # PGPLOT_DIR is needed by PGPLOT
2482        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2483        # this is the number of lines/page in the .LST (etc.) file
2484        set env(LENPAGE) 60
2485        set termopts {}
2486        if $env(GSASBACKSPACE) {
2487            append termopts \
2488                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2489        }
2490        if $scrollbar {
2491            append termopts " -sb"
2492        } else {
2493            append termopts " +sb"
2494        }
2495        if {$wait} {
2496            set suffix {}
2497        } else {
2498            set suffix {&}
2499        }
2500        #
2501        #if $wait {
2502            append command "\; echo -n Press Enter to continue \; read x"
2503        #}
2504        if {$wait && $expgui(autoiconify)} {wm iconify .}
2505        catch {eval exec xterm $termopts -title [list $title] \
2506                -e /bin/sh -c [list $command] $suffix} errmsg
2507        if $expgui(debug) {puts "xterm result = $errmsg"}
2508        if {$wait} {
2509            if {$expgui(autoiconify)} {wm deiconify .}
2510            # check for changes in the .EXP file immediately
2511            whenidle
2512        }
2513    }
2514}
Note: See TracBrowser for help on using the repository browser.