source: trunk/gsascmds.tcl @ 450

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

# on 2001/09/25 23:31:59, toby did:
Add error highlight into ShowBigMessage?
look more closely at histogram types for liveplot, etc (this still may need
more attention)
Set Histogram Flag dialog and some nice scrollable table code

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