source: trunk/gsascmds.tcl @ 325

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

# on 2000/10/17 15:20:45, toby did:
snapshot with revisions for WWW help

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