source: trunk/gsascmds.tcl @ 431

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

# on 2001/09/04 22:58:36, toby did:
add excledt

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