source: trunk/gsascmds.tcl @ 370

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

# on 2000/12/22 21:31:48, toby did:
produce error message in DISAGL if .LST file is not renamed

  • Property rcs:author set to toby
  • Property rcs:date set to 2000/12/22 21:31:48
  • Property rcs:lines set to +12 -4
  • Property rcs:rev set to 1.29
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 76.1 KB
Line 
1# $Id: gsascmds.tcl 370 2009-12-04 23:05:02Z 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 3i 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                tk_dialog .warn "No Browser" \
864                        "Could not find a browser. Netscape is not in path. Define environment variable BROWSER to be full path name of browser." \
865                        warn 0 OK
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) ""
929                return
930            }
931        }
932        # this should not happen
933        NetHelp expgui.html "" $expgui(docdir) ""       
934    } elseif {$topic == "menu"} {
935        NetHelp expguic.html "" $expgui(docdir) ""
936    } else {
937        NetHelp $topic $anchor $expgui(docdir) ""
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
995    set expnam [file root [file tail $expgui(expfile)]]
996    exec $wishshell [file join $expgui(scriptdir) liveplot] \
997            $expnam $liveplot(hst) $liveplot(legend) &
998}
999
1000# run lstview
1001proc lstview {} {
1002    global expgui wishshell
1003    set expnam [file root [file tail $expgui(expfile)]]
1004    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
1005}
1006
1007# run widplt
1008proc widplt {} {
1009    global expgui wishshell
1010    exec $wishshell [file join $expgui(scriptdir) widplt] \
1011            $expgui(expfile) &
1012}
1013
1014# compute the composition for each phase and display in a dialog
1015proc composition {} {
1016    global expmap expgui
1017    set Z 1
1018    foreach phase $expmap(phaselist) type $expmap(phasetype) {
1019        if {$type > 2} continue
1020        catch {unset total}
1021        foreach atom $expmap(atomlist_$phase) {
1022            set type [atominfo $phase $atom type]
1023            set mult [atominfo $phase $atom mult]
1024            if [catch {set total($type)}] {
1025                set total($type) [expr \
1026                        $mult * [atominfo $phase $atom frac]]
1027            } else {
1028                set total($type) [expr $total($type) + \
1029                        $mult * [atominfo $phase $atom frac]]
1030            }
1031            if {$mult > $Z} {set Z $mult}
1032        }
1033        append text "\nPhase $phase\n"
1034        append text "  Unit cell contents\n"
1035        foreach type [lsort [array names total]] {
1036            append text "   $type[format %8.3f $total($type)]"
1037        }
1038        append text "\n\n"
1039       
1040        append text "  Asymmetric Unit contents (Z=$Z)\n"
1041        foreach type [lsort [array names total]] {
1042            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
1043        }
1044        append text "\n"
1045    }
1046   
1047    catch {destroy .comp}
1048    toplevel .comp
1049    bind .comp <Key-F1> "MakeWWWHelp expgui.html Composition"
1050    wm title .comp Composition
1051    pack [label .comp.results -text $text \
1052            -font $expgui(coordfont) -justify left] -side top
1053    pack [frame .comp.box]  -side top -expand y -fill x
1054    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
1055
1056    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
1057    pack [button .comp.box.2 -text "Save to $lstnam file" \
1058            -command "writelst [list $text] ; destroy .comp"] -side left
1059    pack [button .comp.box.help -text Help -bg yellow \
1060            -command "MakeWWWHelp expgui.html Composition"] \
1061            -side right
1062}
1063
1064# save coordinates in an MSI .xtl file
1065proc exp2xtl {} {
1066    global expmap expgui
1067    catch {destroy .export}
1068    toplevel .export
1069    wm title .export "Export coordinates"
1070    bind .export <Key-F1> "MakeWWWHelp expgui.html ExportMSI"
1071    pack [label .export.lbl -text "Export coordinates in MSI .xtl format"\
1072            ] -side top -anchor center
1073    pack [frame .export.ps] -side top -anchor w
1074    pack [label .export.ps.lbl -text "Select phase: "] -side left
1075    foreach num $expmap(phaselist) type $expmap(phasetype) {
1076        pack [button .export.ps.$num -text $num \
1077                    -command "SetExportPhase $num"] -side left
1078        if {$type == 4} {
1079            .export.ps.$num config -state disabled
1080        }
1081    }
1082    pack [frame .export.sg] -side top
1083    pack [label .export.sg.1 -text "Space Group: "] -side left
1084    pack [entry .export.sg.2 -textvariable expgui(export_sg) -width 8] -side left
1085    pack [checkbutton .export.sg.3 -variable expgui(export_orig) -text "Origin 2"] -side left
1086    pack [frame .export.but] -side top -fill x -expand yes
1087    if {[llength $expmap(phaselist)] > 0} {
1088        pack [button .export.but.1 -text Write -command writextl] -side left
1089        SetExportPhase [lindex $expmap(phaselist) 0]
1090    }
1091    pack [button .export.but.2 -text Quit -command "destroy .export"] -side left
1092    pack [button .export.but.help -text Help -bg yellow \
1093            -command "MakeWWWHelp expgui.html ExportMSI"] \
1094            -side right
1095    # force the window to stay on top
1096    putontop .export
1097    afterputontop
1098}
1099
1100proc SetExportPhase {phase} {
1101    global expmap expgui
1102    foreach n $expmap(phaselist) type $expmap(phasetype) {
1103        if {$n == $phase && $type != 4} {
1104            .export.ps.$n config -relief sunken
1105            set expgui(export_phase) $phase
1106            # remove spaces from space group
1107            set spacegroup [phaseinfo $phase spacegroup]
1108            if {[string toupper [string range $spacegroup end end]] == "R"} {
1109                set spacegroup [string range $spacegroup 0 \
1110                        [expr [string length $spacegroup]-2]] 
1111            }
1112            regsub -all " " $spacegroup "" expgui(export_sg)   
1113        } else { 
1114            .export.ps.$n config -relief raised
1115        }
1116    }
1117}
1118
1119
1120proc writextl {} {
1121    global expgui expmap
1122    if ![catch {
1123        set phase $expgui(export_phase)
1124        set origin $expgui(export_orig)
1125        set spsymbol $expgui(export_sg)
1126    } errmsg] {
1127        set errmsg {}
1128        if {$phase == ""} {
1129            set errmsg "Error: invalid phase number $phase"
1130        } elseif {$spsymbol == ""} {
1131            set errmsg "Error: invalid Space Group: $spsymbol"
1132        }
1133    }
1134    if {$errmsg != ""} {
1135        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
1136        return
1137    }
1138
1139    if [catch {
1140        set filnam [file rootname $expgui(expfile)]_${phase}.xtl
1141        set spacegroup [phaseinfo $phase spacegroup]
1142        set fp [open $filnam w]
1143        puts $fp "TITLE from $expgui(expfile)"
1144        puts $fp "TITLE history [string trim [lindex [exphistory last] 1]]"
1145        puts $fp "TITLE phase [phaseinfo $phase name]"
1146        puts $fp "CELL"
1147        puts $fp "  [phaseinfo $phase a] [phaseinfo $phase b] [phaseinfo $phase c] [phaseinfo $phase alpha] [phaseinfo $phase beta] [phaseinfo $phase gamma]"
1148       
1149        puts $fp "Symmetry Label $spsymbol"
1150        set rhomb 0
1151        if {[string toupper [string range $spacegroup end end]] == "R"} {
1152            set rhomb 1
1153        }
1154        if $origin {
1155            puts $fp "Symmetry Qualifier origin_2"
1156        }
1157        if $rhomb {
1158            puts $fp "Symmetry Qualifier rhombohedral"
1159        }
1160       
1161        puts $fp "ATOMS"
1162        puts $fp "NAME       X          Y          Z    UISO      OCCUP"
1163        foreach atom $expmap(atomlist_$phase) {
1164            set label [atominfo $phase $atom label]
1165            # remove () characters
1166            regsub -all "\[()\]" $label "" label
1167            # are there anisotropic atoms?
1168            if {[atominfo $phase $atom temptype] == "A"} {
1169                set uiso [expr \
1170                        ([atominfo $phase $atom U11] + \
1171                        [atominfo $phase $atom U22] + \
1172                        [atominfo $phase $atom U33]) / 3.]
1173            } else {
1174                set uiso [atominfo $phase $atom Uiso]
1175            }
1176            puts $fp "$label [atominfo $phase $atom x] \
1177                        [atominfo $phase $atom y] [atominfo $phase $atom z] \
1178                        $uiso  [atominfo $phase $atom frac]"
1179        }
1180    } errmsg] {
1181        catch {close $fp}
1182        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
1183    } else {
1184        catch {close $fp}
1185        MyMessageBox -parent . -title "Done" \
1186                -message "File [file tail $filnam] was written in directory [file dirname $filnam]"
1187    }
1188    if {[llength $expmap(phaselist)] == 1} {destroy .export}
1189}
1190
1191# Delete History Records
1192proc DeleteHistoryRecords {{msg ""}} {
1193    global expgui
1194    set frm .history
1195    catch {destroy $frm}
1196    toplevel $frm
1197    bind $frm <Key-F1> "MakeWWWHelp expgui.html DeleteHistoryRecords"
1198    if {[string trim $msg] == ""} {
1199        set msg "There are [CountHistory] history records"
1200    }
1201    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1202    pack [label $frm.1.0 -text $msg] -side top
1203    pack [frame $frm.1.1] -side top
1204    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1205    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1206            ] -side left
1207    set expgui(historyKeep) 10
1208    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1209    set expgui(renumber) 1
1210    pack [frame $frm.2] -padx 3 -pady 3 -side left -fill both -expand yes
1211    pack [button $frm.2.help -text Help -bg yellow \
1212            -command "MakeWWWHelp expgui.html DeleteHistoryRecords"] -side top
1213    pack [button $frm.2.4 -text Quit \
1214            -command {destroy .history}] -side bottom
1215    pack [button $frm.2.3 -text OK \
1216            -command { 
1217        if ![catch {expr $expgui(historyKeep)}] {
1218            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1219            set expgui(changed) 1
1220            destroy .history
1221        }
1222    }] -side bottom
1223    bind $frm <Return> "$frm.2.3 invoke"
1224   
1225    # force the window to stay on top
1226    putontop $frm 
1227    focus $frm.2.3
1228    tkwait window $frm
1229    afterputontop
1230}
1231
1232#------------------------------------------------------------------------------
1233# GSAS interface routines
1234#------------------------------------------------------------------------------
1235# run a GSAS program that does not require an experiment file
1236proc runGSASprog {proglist "concurrent 1"} {
1237    # if concurrent is 0, EXPGUI runs the GSAS program in background
1238    # -- this is not currently needed anywhere where the .EXP file is not.
1239    global expgui tcl_platform
1240    set cmd {}
1241    foreach prog $proglist {
1242        if {$tcl_platform(platform) == "windows"} {
1243            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
1244        } else {
1245            if {$cmd != ""} {append cmd "\;"}
1246            append cmd "[file join $expgui(gsasexe) $prog]"
1247        }
1248    }
1249    forknewterm $prog $cmd [expr !$concurrent] 1
1250}
1251
1252# run a GSAS program that requires an experiment file for input/output
1253proc runGSASwEXP {proglist "concurrent 0"} {
1254    # most programs that require the .EXP file change it and
1255    # cannot be run concurrently
1256    global expgui tcl_platform
1257    # Save the current exp file
1258    savearchiveexp
1259    # load the changed .EXP file automatically?
1260    if {$expgui(autoexpload)} {
1261        # disable the file changed monitor
1262        set expgui(expModifiedLast) 0
1263    }
1264    set cmd {}
1265    set expnam [file root [file tail $expgui(expfile)]]
1266    foreach prog $proglist {
1267        if {$prog == "expedt" && $expgui(archive)} archiveexp
1268        if {$tcl_platform(platform) == "windows"} {
1269            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
1270        } else {
1271            if {$cmd != ""} {append cmd "\;"}
1272            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
1273        }
1274    }
1275    forknewterm "$prog -- $expnam" $cmd [expr !$concurrent] 1
1276    # load the changed .EXP file automatically?
1277    if {$expgui(autoexpload)} {
1278        # load the revised exp file
1279        loadexp $expgui(expfile)
1280    }
1281}
1282
1283# write text to the .LST file
1284proc writelst {text} {
1285    global expgui
1286    set lstnam [file rootname $expgui(expfile)].LST
1287    set fp [open $lstnam a]
1288    puts $fp "\n-----------------------------------------------------------------"
1289    puts $fp $text
1290    puts $fp "-----------------------------------------------------------------\n"
1291    close $fp
1292}
1293
1294
1295# optionally run disagl as a windowless process, w/results in a separate window
1296proc rundisagl {} {
1297    global expgui txtvw tcl_version tcl_platform
1298    if {$expgui(disaglSeparateBox)} {
1299        set root [file root $expgui(expfile)] 
1300        catch {file delete -force $root.tmp}
1301        catch {file rename -force $root.LST $root.OLS}
1302        # PSW reports this does not happen right away on windows
1303        set i 0
1304        while {$i < 10 && [file exists $root.LST]} {
1305            # debug code
1306            #catch {console show}
1307            #puts "try $i"
1308            # end debug code
1309            after 100
1310            incr i
1311        }
1312        if {[file exists $root.LST]} {
1313            # it was not possible to rename the file
1314            MyMessageBox -parent . -title "Rename Problem" \
1315                -message "Unable to rename $root.LST. Please close LSTVIEW and try again" \
1316                -icon warning -helplink "expguierr.html NoRename"
1317            return
1318        }
1319
1320        #run the program
1321        pleasewait "Running DISAGL"     
1322        # create an empty input file
1323        close [open disagl.inp w]
1324        catch {exec [file join $expgui(gsasexe) disagl] \
1325                [file tail $root] < disagl.inp > disagl.out}
1326        catch {file rename -force $root.LST $root.tmp}
1327        catch {file delete -force disagl.inp disagl.out}
1328        catch {file rename -force $root.OLS $root.LST}
1329        donewait
1330        # open a new window
1331        catch {toplevel .disagl}
1332        catch {eval grid forget [grid slaves .disagl]}
1333        text .disagl.txt -width 100 -wrap none \
1334                -yscrollcommand ".disagl.yscroll set" \
1335                -xscrollcommand ".disagl.xscroll set" 
1336        scrollbar .disagl.yscroll -command ".disagl.txt yview"
1337        scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1338        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1339        grid .disagl.txt -column 0 -row 1 -sticky nsew
1340        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1341        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1342        grid columnconfig .disagl.f 2 -weight 1
1343        grid [button .disagl.f.close -text "Close & Delete" \
1344                -command "destroy .disagl; file delete $root.tmp"] \
1345                -column 3 -row 0 -sticky e
1346        grid [button .disagl.f.rename -text "Close & Save as .DIS" \
1347                -command "destroy .disagl; file rename -force $root.tmp $root.DIS"] \
1348                -column 4 -row 0 -sticky e
1349        # allow font changes on the fly
1350        if {$tcl_version >= 8.0} {
1351            .disagl.txt config -font $txtvw(font)
1352            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1353            grid .disagl.f.font -column 1 -row 0 -sticky w
1354            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1355            $fontbut delete 0 end
1356            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1357                $fontbut add command -label "Courier $f" -font "Courier $f"\
1358                        -command "set txtvw(font) \"Courier $f\"; \
1359                        .disagl.txt config -font \$txtvw(font)"
1360            }
1361        }
1362       
1363        grid columnconfigure .disagl 0 -weight 1
1364        grid rowconfigure .disagl 1 -weight 1
1365        wm title .disagl "DISAGL results $expgui(expfile)"
1366        wm iconname .disagl "DISAGL $root"
1367        set in [open $root.tmp r]
1368        .disagl.txt insert end [read $in]
1369        close $in
1370        bind all  {destroy .disagl}
1371        bind .disagl  ".disagl.txt yview scroll -1 page"
1372        bind .disagl  ".disagl.txt yview scroll 1 page"
1373        bind .disagl  ".disagl.txt xview scroll 1 unit"
1374        bind .disagl  ".disagl.txt xview scroll -1 unit"
1375        bind .disagl  ".disagl.txt yview scroll -1 unit"
1376        bind .disagl  ".disagl.txt yview scroll 1 unit"
1377        bind .disagl  ".disagl.txt yview 0"
1378        bind .disagl  ".disagl.txt yview end"
1379        # don't disable in Win as this prevents the highlighting of selected text
1380        if {$tcl_platform(platform) != "windows"} {
1381            .disagl.txt config -state disabled
1382        }
1383    } else {
1384        runGSASwEXP disagl
1385    }
1386}
1387
1388#------------------------------------------------------------------------------
1389# file conversion for UNIX
1390#------------------------------------------------------------------------------
1391# convert a file
1392proc convfile {} {
1393    global tcl_platform
1394    if {$tcl_platform(platform) == "windows"} {
1395        convwin
1396    } else {
1397        convunix
1398    }
1399}
1400
1401# file conversions for UNIX (convstod convdtos)
1402proc convunix {} {
1403    global expgui infile outfile
1404    set frm .file
1405    catch {destroy $frm}
1406    toplevel $frm
1407    wm title $frm "Convert File"
1408    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertUnix"
1409
1410    pack [frame [set frm0 $frm.0] -bd 2 -relief groove] \
1411            -padx 3 -pady 3 -side top -fill x
1412    pack [frame $frm.mid] -side top
1413    pack [frame [set frmA $frm.mid.1] -bd 2 -relief groove] \
1414            -padx 3 -pady 3 -side left
1415    pack [label $frmA.0 -text "Select an input file"] -side top -anchor center
1416    pack [frame [set frmB $frm.mid.2] -bd 2 -relief groove] \
1417            -padx 3 -pady 3 -side left
1418    pack [label $frmB.0 -text "Enter an output file"] -side top -anchor center
1419    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side top -fill x -expand y
1420
1421    pack [label $frm0.1 -text "Convert to:"] -side top -anchor center
1422    pack [frame $frm0.2] -side top -anchor center
1423    pack [radiobutton $frm0.2.d -text "direct access" -value convstod \
1424            -command setoutfile \
1425            -variable outfile(type)] -side left -anchor center
1426    pack [radiobutton $frm0.2.s -text "sequential" -value convdtos \
1427            -command setoutfile \
1428            -variable outfile(type)] -side right -anchor center
1429    set outfile(type) ""
1430
1431    pack [button $frmC.b -text Convert -command "valid_conv_unix"] -side left
1432    pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side left
1433    pack [button $frmC.help -text Help -bg yellow \
1434            -command "MakeWWWHelp expgui.html ConvertUnix"] \
1435            -side right
1436   
1437    unixcnvbox $frmA infile 1 
1438    unixcnvbox $frmB outfile 0 
1439    set infile(done) 0
1440    bind $frm <Return> "valid_conv_unix"
1441    # force the window to stay on top
1442    putontop $frm
1443    focus $frmC.q 
1444    update
1445    tkwait variable infile(done)
1446    destroy $frm
1447    afterputontop
1448}
1449
1450# validate the files and make the conversion -- unix
1451proc valid_conv_unix {} {
1452    global infile outfile expgui
1453    set error {}
1454    if {$outfile(type) == "convstod" || $outfile(type) == "convdtos"} {
1455        set convtype $outfile(type)
1456    } else {
1457        append error "You must specify a conversion method: to direct access or to sequential.\n"
1458    }
1459    if {$infile(name) == ""} {
1460        append error "You must specify an input file to convert.\n"
1461    }
1462    if {$outfile(name) == ""} {
1463        append error "You must specify an output file name for the converted file.\n"
1464    }
1465    if {$error != ""} {
1466        tk_dialog .warn Notify $error warning 0 OK
1467        return
1468    }
1469
1470    if {$infile(name) == $outfile(name)} {
1471        MyMessageBox -parent . -title Notify \
1472                -message "Sorry, filenames must differ" \
1473                -icon warning -helplink "expguierr.html ConvSameName"
1474        tk_dialog .warn Notify "Sorry, filenames must differ" warning 0 OK
1475        return
1476    }
1477    if ![file exists [file join $infile(dir) $infile(name)]] {
1478        MyMessageBox -parent . -title Notify \
1479                -message "Sorry, file $infile(name) not found in $infile(dir)" \
1480                -icon warning -helplink "expguierr.html ConvNotFound"
1481        return
1482    }
1483    if [file exists [file join $outfile(dir) $outfile(name)]] {
1484        set ans [MyMessageBox -parent . -title "Overwrite?" \
1485                -message "Warning: file $outfile(name) exists in $outfile(dir). OK to overwrite?" \
1486                -icon warning -type {Overwrite Cancel} -default Overwrite \
1487                -helplink "expguierr.html OverwriteCnv"]
1488        if {[string tolower $ans] == "cancel"} return
1489    }
1490    if [catch {
1491        exec [file join $expgui(gsasexe) $convtype] < \
1492                [file join $infile(dir) $infile(name)] > \
1493                [file join $outfile(dir) $outfile(name)]
1494    } errmsg] {
1495        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
1496    } else {
1497        if [tk_dialog .converted Notify \
1498                "File converted. Convert more files?" \
1499                ""  0 Yes No] {set infile(done) 1}
1500    }
1501}
1502
1503# create a file box for UNIX conversions
1504proc unixcnvbox {bx filvar diropt} {
1505    global ${filvar} expgui
1506    pack [frame $bx.top] -side top
1507    pack [label $bx.top.a -text "Directory" ] -side left
1508    set ${filvar}(FileDirButtonMenu) [tk_optionMenu $bx.top.d ${filvar}(dir) [pwd] ]
1509    pack $bx.top.d -side left
1510    set ${filvar}(dir) [pwd]
1511
1512#    pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top
1513#    set ${filvar}(dir) [pwd]
1514
1515    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1516    listbox $bx.a.files -relief raised -bd 2 \
1517            -yscrollcommand "$bx.a.scroll set" \
1518            -height 15 -width 0 -exportselection 0 
1519    scrollbar $bx.a.scroll -command "$bx.a.files yview"
1520    unixFilChoose $bx $bx.a.files $filvar $diropt
1521    if {$filvar == "infile"} {
1522        bind $bx.a.files <ButtonRelease-1> \
1523                "unixFilChoose $bx $bx.a.files $filvar $diropt; setoutfile"
1524    } else {
1525        bind $bx.a.files <ButtonRelease-1> \
1526                "unixFilChoose $bx $bx.a.files $filvar $diropt"
1527    }
1528    pack $bx.a.scroll -side left -fill y
1529    pack $bx.a.files -side left -fill both -expand yes
1530    pack [entry $bx.c -textvariable ${filvar}(name)] -side top
1531}
1532
1533# select a file or directory, also called when box is created to fill it
1534proc unixFilChoose {frm box filvar {dironly 1}} {
1535    global $filvar
1536    set select [$box curselection]
1537    if {$select == ""} {
1538        set file .
1539    } else {
1540        set file [string trim [$box get $select]]
1541    }
1542    if [file isdirectory [file join [set ${filvar}(dir)] $file]] {
1543        if {$file == ".."} {
1544            set ${filvar}(dir) [file dirname [set ${filvar}(dir)] ]
1545        } elseif {$file != "."} {
1546            set ${filvar}(dir) [file join [set ${filvar}(dir)] $file]
1547        }
1548        [set ${filvar}(FileDirButtonMenu)] delete 0 end
1549        set list ""
1550        set dir ""
1551        foreach subdir [file split [set ${filvar}(dir)]] {
1552            set dir [file join $dir $subdir]
1553            lappend list $dir
1554        }
1555        foreach path $list {
1556            [set ${filvar}(FileDirButtonMenu)] add command -label $path \
1557                -command "[list set ${filvar}(dir) $path]; \
1558                unixFilChoose $frm $box $filvar $dironly"
1559        }
1560        set ${filvar}(name) {}
1561        $box delete 0 end
1562        $box insert end {..   }
1563        foreach file [lsort -dictionary [glob -nocomplain \
1564                [file join [set ${filvar}(dir)] *] ] ] {
1565            if {[file isdirectory $file]} {
1566                # is this / needed here? Does it cause a problem in MacGSAS?
1567                $box insert end [file tail $file]/
1568            } elseif {$dironly == 1} {
1569                $box insert end [file tail $file]
1570            } elseif {$dironly == 2 && [file extension $file] == ".EXP"} {
1571                $box insert end [file tail $file]
1572            }
1573        }
1574        return
1575    }
1576    set ${filvar}(name) [file tail $file]
1577}
1578
1579# set new file name from old -- used for convunix
1580proc setoutfile {} {
1581    global infile outfile
1582    if {$outfile(type) == "convstod"} {
1583        set lfile [string toupper $infile(name)]
1584    } elseif {$outfile(type) == "convdtos"} {
1585        set lfile [string tolower $infile(name)]
1586    } else {
1587        set lfile ""
1588    }
1589    if {$infile(name) == $lfile} {
1590        set outfile(name) {}
1591    } else {
1592        set outfile(name) $lfile
1593    }
1594}
1595
1596#------------------------------------------------------------------------------
1597# file conversions for Windows
1598#------------------------------------------------------------------------------
1599proc convwin {} {
1600    global expgui
1601    set frm .file
1602    catch {destroy $frm}
1603    toplevel $frm
1604    wm title $frm "Convert File"
1605    bind $frm <Key-F1> "MakeWWWHelp expgui.html ConvertWin"
1606    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1607    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 \
1608            -side left -fill y -expand yes
1609    pack [button $frmC.help -text Help -bg yellow \
1610            -command "MakeWWWHelp expgui.html ConvertWin"] -side top
1611    pack [button $frmC.q -text Quit -command "destroy $frm"] -side bottom
1612    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
1613            -side bottom
1614    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
1615    winfilebox $frm
1616    bind $frm <Return> "ValidWinCnv $frm"
1617
1618    # force the window to stay on top
1619    putontop $frm
1620    focus $frmC.q 
1621    tkwait window $frm
1622    afterputontop
1623}
1624
1625# validate the files and make the conversion
1626proc ValidWinCnv {frm} {
1627    global expgui
1628    # change backslashes to something sensible
1629    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
1630    # allow entry of D: for D:/ and D:TEST for d:/TEST
1631    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
1632            [string first :/ $expgui(FileMenuCnvName)] == -1} {
1633        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
1634    }
1635    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1636        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1637        ChooseWinCnv $frm
1638        return
1639    } elseif [file isdirectory \
1640            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
1641        if {$expgui(FileMenuCnvName) != "."} {
1642            set expgui(FileMenuDir) \
1643                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1644        }
1645        ChooseWinCnv $frm
1646        return
1647    }
1648 
1649    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1650    if ![file exists $file] {
1651        tk_dialog .warn "Convert Error" \
1652                "File $file does not exist" question 0 "OK"
1653        return
1654    }
1655
1656    set tmpname "[file join [file dirname $file] tempfile.xxx]"
1657    set oldname "[file rootname $file].org"
1658    if [file exists $oldname] {
1659        set ans [MyMessageBox -parent . -title "Overwrite?" \
1660                -message "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" \
1661                -icon warning -type {Overwrite Cancel} -default Overwrite \
1662                -helplink "expguierr.html OverwriteCnv"]
1663        if {[string tolower $ans] == "cancel"} return
1664        catch {file delete $oldname}
1665    }
1666
1667    if [catch {
1668        set in [open $file r]
1669        set out [open $tmpname w]
1670        set len [gets $in line]
1671        if {$len > 160} {
1672            # this is a UNIX file. Hope there are no control characters
1673            set i 0
1674            set j 79
1675            while {$j < $len} {
1676                puts $out [string range $line $i $j]
1677                incr i 80
1678                incr j 80
1679            }
1680        } else {
1681            while {$len >= 0} {
1682                append line "                                        "
1683                append line "                                        "
1684                set line [string range $line 0 79]
1685                puts $out $line
1686                set len [gets $in line]
1687            }
1688        }
1689        close $in
1690        close $out
1691        file rename -force $file $oldname
1692        file rename -force $tmpname $file
1693    } errmsg] {
1694        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
1695    } else {
1696        if [tk_dialog .converted Notify \
1697                "File [file tail $file] converted. (Original saved as [file tail $oldname]).\n\n Convert more files?" \
1698                ""  0 Yes No] {destroy $frm}
1699    }
1700}
1701
1702# create a file box
1703proc winfilebox {frm} {
1704    global expgui
1705    set bx $frm.1
1706    pack [frame $bx.top] -side top
1707    pack [label $bx.top.a -text "Directory" ] -side left
1708    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1709    pack $bx.top.d -side left
1710    set expgui(FileMenuDir) [pwd]
1711    # the icon below is from tk8.0/tkfbox.tcl
1712    set upfolder [image create bitmap -data {
1713#define updir_width 28
1714#define updir_height 16
1715static char updir_bits[] = {
1716   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1717   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1718   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1719   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1720   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1721   0xf0, 0xff, 0xff, 0x01};}]
1722
1723    pack [button $bx.top.b -image $upfolder \
1724            -command "updir; ChooseWinCnv $frm" ]
1725    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1726    listbox $bx.a.files -relief raised -bd 2 \
1727            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
1728            -height 15 -width 0 -exportselection 0 
1729    listbox $bx.a.dates -relief raised -bd 2 \
1730            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
1731            -height 15 -width 0 -takefocus 0 -exportselection 0 
1732    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1733    ChooseWinCnv $frm
1734    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
1735    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
1736    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
1737    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
1738    pack $bx.a.scroll -side left -fill y
1739    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1740    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
1741}
1742
1743# set the box or file in the selection window
1744proc ReleaseWinCnv {frm} {
1745    global expgui
1746    set files $frm.1.a.files
1747    set dates $frm.1.a.dates
1748    set select [$files curselection]
1749    if {$select == ""} {
1750        set select [$dates curselection]
1751    }
1752    if {$select == ""} {
1753        set expgui(FileMenuCnvName) ""
1754    } else {
1755        set expgui(FileMenuCnvName) [string trim [$files get $select]]
1756    }
1757    if {$expgui(FileMenuCnvName) == "<Parent>"} {
1758        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1759        ChooseWinCnv $frm
1760    } elseif [file isdirectory \
1761            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
1762        if {$expgui(FileMenuCnvName) != "."} {
1763            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
1764            ChooseWinCnv $frm
1765        }
1766    }
1767    return
1768}
1769
1770# select a file or directory -- called on double click
1771proc SelectWinCnv {frm} {
1772    global expgui
1773    set files $frm.1.a.files
1774    set dates $frm.1.a.dates
1775    set select [$files curselection]
1776    if {$select == ""} {
1777        set select [$dates curselection]
1778    }
1779    if {$select == ""} {
1780        set file .
1781    } else {
1782        set file [string trim [$files get $select]]
1783    }
1784    if {$file == "<Parent>"} {
1785        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1786        ChooseWinCnv $frm
1787    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1788        if {$file != "."} {
1789            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1790            ChooseWinCnv $frm
1791        }
1792    } else {
1793        set expgui(FileMenuCnvName) [file tail $file]
1794        ValidWinCnv $frm
1795    }
1796}
1797
1798# fill the files & dates & Directory selection box with current directory,
1799# also called when box is created to fill it
1800proc ChooseWinCnv {frm} {
1801    global expgui
1802    set files $frm.1.a.files
1803    set dates $frm.1.a.dates
1804    set expgui(FileMenuCnvName) {}
1805    $files delete 0 end
1806    $dates delete 0 end
1807    $files insert end {<Parent>}
1808    $dates insert end {(Directory)}
1809    set filelist [glob -nocomplain \
1810            [file join [set expgui(FileMenuDir)] *] ]
1811    foreach file [lsort -dictionary $filelist] {
1812        if {[file isdirectory $file]} {
1813            $files insert end [file tail $file]
1814            $dates insert end {(Directory)}
1815        }
1816    }
1817    foreach file [lsort -dictionary $filelist] {
1818        if {![file isdirectory $file]} {
1819            set modified [clock format [file mtime $file] -format "%T %D"]
1820            $files insert end [file tail $file]
1821            $dates insert end $modified
1822        }
1823    }
1824    $expgui(FileDirButtonMenu)  delete 0 end
1825    set list ""
1826    global tcl_version
1827    if {$tcl_version > 8.0} {
1828        catch {set list [string tolower [file volume]]}
1829    }
1830    set dir ""
1831    foreach subdir [file split [set expgui(FileMenuDir)]] {
1832        set dir [string tolower [file join $dir $subdir]]
1833        if {[lsearch $list $dir] == -1} {lappend list $dir}
1834    }
1835    foreach path $list {
1836        $expgui(FileDirButtonMenu) add command -label $path \
1837                -command "[list set expgui(FileMenuDir) $path]; \
1838                ChooseWinCnv $frm"
1839    }
1840    return
1841}
1842
1843#------------------------------------------------------------------------------
1844# set options for liveplot
1845proc liveplotopt {} {
1846    global liveplot expmap
1847    set frm .file
1848    catch {destroy $frm}
1849    toplevel $frm
1850    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1851    set last [lindex [lsort -integer $expmap(powderlist)] end]
1852    if {$last == ""} {set last 1}
1853    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
1854            -length  150 -orient horizontal -variable liveplot(hst)] -side top
1855    pack [checkbutton $frmA.2 -text {include plot legend}\
1856            -variable liveplot(legend)] -side top
1857    pack [button $frm.2 -text OK \
1858            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
1859            ] -side top
1860    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
1861   
1862    # force the window to stay on top
1863    putontop $frm 
1864    focus $frm.2
1865    tkwait window $frm
1866    afterputontop
1867}
1868
1869#------------------------------------------------------------------------------
1870# get an experiment file name
1871#------------------------------------------------------------------------------
1872proc getExpFileName {mode} {
1873    global expgui
1874    set frm .file
1875    catch {destroy $frm}
1876    toplevel $frm
1877    wm title $frm "Experiment file"
1878    bind $frm <Key-F1> "MakeWWWHelp expguierr.html open"
1879    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
1880    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left \
1881            -fill y -expand yes
1882    pack [button $frmC.help -text Help -bg yellow \
1883            -command "MakeWWWHelp expguierr.html open"] \
1884            -side top -anchor e
1885    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
1886    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
1887            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1888    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
1889            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
1890    pack [button $frmC.b -text Read \
1891            -command "valid_exp_file $frmA $mode"] -side bottom
1892    if {$mode == "new"} {
1893        $frmC.b config -text Save
1894    }
1895    pack [button $frmC.q -text Quit \
1896            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side bottom
1897    bind $frm <Return> "$frmC.b invoke"
1898
1899    if {$mode == "new"} {
1900        pack [label $frmA.0 -text "Enter an experiment file to create"] \
1901                -side top -anchor center
1902    } else {
1903        pack [label $frmA.0 -text "Select an experiment file to read"] \
1904                -side top -anchor center
1905    }
1906    expfilebox $frmA $mode
1907    # force the window to stay on top
1908    putontop $frm
1909    focus $frmC.b
1910    tkwait window $frm
1911    afterputontop
1912    if {$expgui(FileMenuEXPNAM) == ""} return
1913    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1914}
1915
1916# validation routine
1917proc valid_exp_file {frm mode} {
1918    global expgui tcl_platform
1919    # windows fixes
1920    if {$tcl_platform(platform) == "windows"} {
1921        # change backslashes to something sensible
1922        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
1923        # allow entry of D: for D:/ and D:TEST for d:/TEST
1924        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
1925                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
1926            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
1927        }
1928    }
1929    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1930        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1931        ChooseExpFil $frm
1932        return
1933    } elseif [file isdirectory \
1934            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
1935        if {$expgui(FileMenuEXPNAM) != "."} {
1936            set expgui(FileMenuDir) \
1937                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1938        }
1939        ChooseExpFil $frm
1940        return
1941    }
1942    # append a .EXP if not present
1943    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
1944        append expgui(FileMenuEXPNAM) ".EXP"
1945    }
1946    # flag files that end in something other than .EXP .exp or .Exp...
1947    if {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
1948        tk_dialog .expFileErrorMsg "File Open Error" \
1949            "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
1950            error 0 OK
1951        return
1952    }
1953    # check on the file status
1954    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1955    if {$mode == "new" && [file exists $file]} {
1956        set ans [
1957        MyMessageBox -parent . -title "File Open Error" \
1958                -message "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" \
1959                -icon question -type {"Select other" "Overwrite"} -default "select other" \
1960                -helplink "expguierr.html OverwriteErr"
1961        ]
1962        if {[string tolower $ans] == "overwrite"} {destroy .file}
1963        if $ans {destroy .file}
1964        return
1965    }
1966    # if file does not exist in case provided, set the name to all
1967    # upper case letters, since that is the best choice.
1968    # if it does exist, read from it as is. For UNIX we will force uppercase later.
1969    if {![file exists $file]} {
1970        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1971        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1972    }
1973    if {$mode == "old" && ![file exists $file]} {
1974        set ans [
1975        MyMessageBox -parent . -title "File Open Error" \
1976                -message "File [file tail $file] does not exist in [file dirname $file]. OK to create?" \
1977                -icon question -type {"Select other" "Create"} -default "select other" \
1978                -helplink "expguierr.html OpenErr"
1979        ]
1980        if {[string tolower $ans] == "create"} {destroy .file}
1981        return
1982    }
1983    destroy .file
1984}
1985
1986proc updir {} {
1987    global expgui
1988    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1989}
1990
1991# create a file box
1992proc expfilebox {bx mode} {
1993    global expgui
1994    pack [frame $bx.top] -side top
1995    pack [label $bx.top.a -text "Directory" ] -side left
1996    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1997    pack $bx.top.d -side left
1998    set expgui(FileMenuDir) [pwd]
1999    # the icon below is from tk8.0/tkfbox.tcl
2000    set upfolder [image create bitmap -data {
2001#define updir_width 28
2002#define updir_height 16
2003static char updir_bits[] = {
2004   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
2005   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
2006   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
2007   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
2008   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
2009   0xf0, 0xff, 0xff, 0x01};}]
2010
2011    pack [button $bx.top.b -image $upfolder \
2012            -command "updir; ChooseExpFil $bx" ]
2013    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
2014    listbox $bx.a.files -relief raised -bd 2 \
2015            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
2016            -height 15 -width 0 -exportselection 0 
2017    listbox $bx.a.dates -relief raised -bd 2 \
2018            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
2019            -height 15 -width 0 -takefocus 0 -exportselection 0 
2020    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
2021    ChooseExpFil $bx
2022    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
2023    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
2024    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
2025    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
2026    pack $bx.a.scroll -side left -fill y
2027    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
2028    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
2029}
2030proc sync2boxes {master slave scroll args} {
2031    $slave yview moveto [lindex [$master yview] 0]
2032    eval $scroll set $args
2033}
2034proc move2boxesY {boxlist args} {
2035    foreach listbox $boxlist { 
2036        eval $listbox yview $args
2037    }
2038}
2039
2040# set the box or file in the selection window
2041proc ReleaseExpFil {frm} {
2042    global expgui
2043    set files $frm.a.files
2044    set dates $frm.a.dates
2045    set select [$files curselection]
2046    if {$select == ""} {
2047        set select [$dates curselection]
2048    }
2049    if {$select == ""} {
2050        set expgui(FileMenuEXPNAM) ""
2051    } else {
2052        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
2053    }
2054    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
2055        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
2056        ChooseExpFil $frm
2057    } elseif [file isdirectory \
2058            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
2059        if {$expgui(FileMenuEXPNAM) != "."} {
2060            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
2061            ChooseExpFil $frm
2062        }
2063    }
2064    return
2065}
2066
2067# select a file or directory -- called on double click
2068proc SelectExpFil {frm mode} {
2069    global expgui
2070    set files $frm.a.files
2071    set dates $frm.a.dates
2072    set select [$files curselection]
2073    if {$select == ""} {
2074        set select [$dates curselection]
2075    }
2076    if {$select == ""} {
2077        set file .
2078    } else {
2079        set file [string trim [$files get $select]]
2080    }
2081    if {$file == "<Parent>"} {
2082        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
2083        ChooseExpFil $frm
2084    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
2085        if {$file != "."} {
2086            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
2087            ChooseExpFil $frm
2088        }
2089    } else {
2090        set expgui(FileMenuEXPNAM) [file tail $file]
2091        valid_exp_file $frm $mode
2092    }
2093}
2094
2095# fill the files & dates & Directory selection box with current directory,
2096# also called when box is created to fill it
2097proc ChooseExpFil {frm} {
2098    global expgui
2099    set files $frm.a.files
2100    set dates $frm.a.dates
2101    set expgui(FileMenuEXPNAM) {}
2102    $files delete 0 end
2103    $dates delete 0 end
2104    $files insert end {<Parent>}
2105    $dates insert end {(Directory)}
2106    set filelist [glob -nocomplain \
2107            [file join [set expgui(FileMenuDir)] *] ]
2108    foreach file [lsort -dictionary $filelist] {
2109        if {[file isdirectory $file]} {
2110            $files insert end [file tail $file]
2111            $dates insert end {(Directory)}
2112        }
2113    }
2114    set pairlist {}
2115    foreach file [lsort -dictionary $filelist] {
2116        if {![file isdirectory $file]  && \
2117                [string toupper [file extension $file]] == ".EXP"} {
2118            set modified [file mtime $file]
2119            lappend pairlist [list $file $modified]
2120        }
2121    }
2122    if {$expgui(filesort) == 0} {
2123        foreach pair [lsort -index 1 -integer $pairlist] {
2124            set file [lindex $pair 0]
2125            set modified [clock format [lindex $pair 1] -format "%T %D"]
2126            $files insert end [file tail $file]
2127            $dates insert end $modified
2128        }
2129    } else {
2130        foreach pair [lsort -dictionary -index 0 $pairlist] {
2131            set file [lindex $pair 0]
2132            set modified [clock format [lindex $pair 1] -format "%T %D"]
2133            $files insert end [file tail $file]
2134            $dates insert end $modified
2135        }
2136    }
2137    $expgui(FileDirButtonMenu)  delete 0 end
2138    set list ""
2139    global tcl_platform tcl_version
2140    if {$tcl_platform(platform) == "windows" && $tcl_version > 8.0} {
2141        catch {set list [string tolower [file volume]]}
2142    }
2143    set dir ""
2144    foreach subdir [file split [set expgui(FileMenuDir)]] {
2145        set dir [file join $dir $subdir]
2146        if {$tcl_platform(platform) == "windows"} {
2147            set dir [string tolower $dir]
2148            if {[lsearch $list $dir] == -1} {lappend list $dir}
2149        } else {
2150            lappend list $dir
2151        }
2152    }
2153    foreach path $list {
2154        $expgui(FileDirButtonMenu) add command -label $path \
2155                -command "[list set expgui(FileMenuDir) $path]; \
2156                ChooseExpFil $frm"
2157    }
2158    # highlight the current experiment -- if present
2159    for {set i 0} {$i < [$files size]} {incr i} {
2160        set file [$files get $i]
2161        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
2162            $files selection set $i
2163        }
2164    }
2165    return
2166}
2167
2168
2169#------------------------------------------------------------------------------
2170# platform-specific definitions
2171if {$tcl_platform(platform) == "windows" && $tcl_platform(os) == "Windows 95"} {
2172    # windows-95, -98 and presumably -me do not allow Tcl/Tk to run the
2173    # DOS box synchronously, so we create a "lock" file that is deleted
2174    # at the end of the DOS run so we can tell when the run is done.
2175    # We create a window to force the deleting of the file so that if
2176    # the DOS process crashes, the user can continue anyway.
2177    #
2178    # procedure to check if the lock file is still there (Win-9x/me only)
2179    proc checklockfile {file window} {
2180        if [file exists $file] {
2181            after 500 checklockfile $file $window
2182        } else {
2183            catch {destroy $window}
2184        }
2185    }
2186    # this creates a DOS box to run a program in
2187    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2188        global env expgui
2189        # Windows environment variables
2190        set env(GSAS) [file nativename $expgui(gsasdir)]
2191        # PGPLOT_FONT is needed by PGPLOT
2192        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
2193        # this is the number of lines/page in the .LST (etc.) file
2194        set env(LENPAGE) 60
2195        set pwd [file nativename [pwd]]
2196       
2197        # check the .EXP path -- can DOS use it?
2198        if {[string first // [pwd]] != -1} {
2199            MyMessageBox -parent . -title "Invalid Path" \
2200                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2201                    -icon error -type ok -default ok \
2202                    -helplink "expgui_Win_readme.html NetPath"
2203            return
2204        }
2205        # pause is hard coded in the .BAT file
2206        #
2207        # loop over multiple commands
2208        foreach cmd $command {
2209            # simulate the wait with a lock file
2210            if {$wait} {
2211                if {$expgui(autoiconify)} {wm iconify .}
2212                # create a blank lock file and a message window
2213                close [open expgui.lck w]
2214                toplevel .lock
2215                grid [button .lock.0 -text Help -bg yellow \
2216                        -command "MakeWWWHelp expguierr.html lock"] \
2217                        -column 1 -row 0
2218                grid [label .lock.1 \
2219                        -text "Please wait while the GSAS program finishes."] \
2220                        -column 0 -row 0
2221                grid [label .lock.2 -text \
2222                        "In case a problem occurs, close the DOS box"] \
2223                        -column 0 -columnspan 2 -row 1
2224                grid [label .lock.3 -text \
2225                        "and press the \"Continue\" button (below)"] \
2226                        -column 0 -columnspan 2 -row 2
2227                grid [button .lock.b -text "Continue" \
2228                        -command "destroy .lock; wm deiconify ."] \
2229                        -column 0 -columnspan 2 -row 3
2230                putontop .lock
2231                update
2232                checklockfile expgui.lck .lock
2233            }
2234            # replace the forward slashes with backward
2235            regsub -all / $cmd \\ cmd
2236            winexec -d [file nativename [pwd]] \
2237                    [file join $expgui(scriptdir) gsastcl.bat] $cmd
2238            if {$wait} {
2239                tkwait window .lock
2240                file delete -force expgui.lck
2241            }
2242        }
2243        if {$expgui(autoiconify) && $wait} {wm deiconify .}
2244        # check for changes in the .EXP file immediately
2245        whenidle
2246    }
2247} elseif {$tcl_platform(platform) == "windows"} {
2248    # now for Windows-NT, where we can run synchronously
2249    #
2250    # this creates a DOS box to run a program in
2251    proc forknewterm {title command  "wait 1" "scrollbar 1"} {
2252        global env expgui
2253        # Windows environment variables
2254        set env(GSAS) [file nativename $expgui(gsasdir)]
2255        # PGPLOT_FONT is needed by PGPLOT
2256        set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
2257        # this is the number of lines/page in the .LST (etc.) file
2258        set env(LENPAGE) 60
2259        set pwd [file nativename [pwd]]
2260        # check the path -- can DOS use it?
2261        if {[string first // [pwd]] != -1} {
2262            MyMessageBox -parent . -title "Invalid Path" \
2263                    -message {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) GSAS can't directly access a network drive} \
2264                    -icon error -type ok -default ok \
2265                    -helplink "expgui_Win_readme.html NetPath"
2266            return
2267        }
2268        # pause is hard coded in the .BAT file
2269
2270        if {$wait} {
2271            if {$expgui(autoiconify)} {wm iconify .}
2272            # create a blank lock file (keep liveplot from running)
2273            close [open expgui.lck w]
2274            # loop over commands
2275            foreach cmd $command {
2276                # replace the forward slashes with backward
2277                regsub -all / $cmd \\ cmd
2278                exec $env(COMSPEC) /c \
2279                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd"
2280            }
2281            file delete -force expgui.lck
2282            if {$expgui(autoiconify)} {wm deiconify .}
2283            # check for changes in the .EXP file immediately
2284            whenidle
2285        } else {
2286            # loop over commands
2287            foreach cmd $command {
2288                # replace the forward slashes with backward
2289                regsub -all / $cmd \\ cmd
2290                # run in background
2291                exec $env(COMSPEC) /c \
2292                        "start [file join $expgui(scriptdir) gsastcl.bat] $cmd" &
2293            }
2294        }
2295    }
2296} else {
2297    # this creates a xterm window to run a program in
2298    proc forknewterm {title command "wait 1" "scrollbar 1"} {
2299        global env expgui
2300        # UNIX environment variables
2301        set env(GSASEXE) $expgui(gsasexe)
2302        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
2303        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
2304        # PGPLOT_DIR is needed by PGPLOT
2305        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
2306        # this is the number of lines/page in the .LST (etc.) file
2307        set env(LENPAGE) 60
2308        set termopts {}
2309        if $env(GSASBACKSPACE) {
2310            append termopts \
2311                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
2312        }
2313        if $scrollbar {
2314            append termopts " -sb"
2315        } else {
2316            append termopts " +sb"
2317        }
2318        if {$wait} {
2319            set suffix {}
2320        } else {
2321            set suffix {&}
2322        }
2323        #
2324        #if $wait {
2325            append command "\; echo -n Press Enter to continue \; read x"
2326        #}
2327        if {$wait && $expgui(autoiconify)} {wm iconify .}
2328        catch {eval exec xterm $termopts -title [list $title] \
2329                -e /bin/sh -c [list $command] $suffix} errmsg
2330        if $expgui(debug) {puts "xterm result = $errmsg"}
2331        if {$wait && $expgui(autoiconify)} {wm deiconify .}
2332    }
2333}
Note: See TracBrowser for help on using the repository browser.