source: trunk/gsascmds.tcl @ 216

Last change on this file since 216 was 201, checked in by toby, 13 years ago

# on 2000/06/09 03:52:16, toby did:
Add warning when PGPLOT font file is not found
  • Property rcs:author set to toby
  • Property rcs:date set to 2000/06/09 03:52:16
  • Property rcs:lines set to +7 -1
  • Property rcs:rev set to 1.19
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 55.6 KB
Line 
1# $Id: gsascmds.tcl 201 2009-12-04 23:02:05Z toby $
2# platform-specific code
3if {$tcl_platform(platform) == "windows"} {
4    if [catch {package require winexec}] {
5        tk_dialog .err "WINEXEC Error" \
6                "Error -- Unable to load the WINEXEC package. This is needed in Win95 machines" \
7                error 0 Quit
8        destroy .
9    }
10    if ![file exists [file join $expgui(gsasdir) fonts grfont.dat]] {
11        tk_dialog .err "PGPLOT Error" \
12                "Warning -- Unable to find file GRFONT.DAT. GSAS graphics will not work. Is GSAS correctly installed?" \
13                warning 0 "Limp Ahead"
14    }
15
16    if {$tcl_platform(os) == "Windows 95" || $tcl_platform(os) == "Windows 98" } {
17        # this creates a DOS box to run a program in
18        proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
19            global env expgui
20            # Windows environment variables
21            # -95 does not seem to be able to use these
22            set env(GSAS) [file nativename $expgui(gsasdir)]
23            # PGPLOT_FONT is needed by PGPLOT
24            set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
25            # this is the number of lines/page in the .LST (etc.) file
26            set env(LENPAGE) 60
27            set pwd [file nativename [pwd]]
28
29            # check the path -- can DOS use it?
30            if {[string first // [pwd]] != -1} {
31                tk_dialog .braindead "Invalid Path" \
32                {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) \
33                Win-95 can't directly access a network drive in DOS} error 0 OK
34                return
35            }
36            # all winexec commands are background commands
37            #   if $background
38
39            # pause is hard coded in the .BAT file
40            #if $wait  {
41            #   append command " pause"
42            #}
43
44            # replace the forward slashes with backward
45            regsub -all / $command \\ command
46            # Win95 does not seem to inherit the environment from Tcl env vars
47            # so define it in the .BAT file
48            winexec -d [file nativename [pwd]] \
49                [file join $expgui(scriptdir) gsastcl.bat] \
50                "[file nativename $expgui(gsasdir)] $command"
51        }
52    } else {
53        # now for - brain-dead Windows-NT
54        # this creates a DOS box to run a program in
55        proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
56            global env expgui
57            # Windows environment variables
58            set env(GSAS) [file nativename $expgui(gsasdir)]
59            # PGPLOT_FONT is needed by PGPLOT
60            set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
61            # this is the number of lines/page in the .LST (etc.) file
62            set env(LENPAGE) 60
63            # all winexec commands are background commands -- ignore background arg
64            # can't get pause to work! -- ignore wait
65
66            set prevcmd {}
67            foreach cmd $command {
68                if {$prevcmd != ""} {
69                    tk_dialog .done_yet Confirm "Press OK to start command $cmd" "" 0 OK
70                }
71                # replace the forward slashes with backward
72                regsub -all / $cmd \\ cmd
73                # cmd.exe must be in the path -- lets hope that at least works!
74                winexec -d [file nativename [pwd]] cmd.exe "/c $cmd"
75                set prevcmd $cmd
76            }
77        }
78    }
79} else {
80    if [catch {set env(GSASBACKSPACE)}] {set env(GSASBACKSPACE) 1}
81
82    # this creates a xterm window to run a program in
83    proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
84        global env expgui
85        # UNIX environment variables
86        set env(GSASEXE) $expgui(gsasexe)
87        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
88        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
89        # PGPLOT_DIR is needed by PGPLOT
90        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
91        # this is the number of lines/page in the .LST (etc.) file
92        set env(LENPAGE) 60
93        set termopts {}
94        if $env(GSASBACKSPACE) {
95            append termopts \
96                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
97        }
98        if $scrollbar {
99            append termopts " -sb"
100        } else {
101            append termopts " +sb"
102        }
103        if $background {
104            set suffix {&}
105        } else {
106            set suffix {}
107        }
108        #
109        if $wait  {
110            append command "\; echo -n Press Enter to continue \; read x"
111        }
112        if !$background {wm iconify .}
113        catch {eval exec xterm $termopts -title [list $title] \
114                -e /bin/sh -c [list $command] $suffix} errmsg
115        if $expgui(debug) {puts "xterm result = $errmsg"}
116        if !$background {wm deiconify .}
117    }
118}
119
120# get a value in a modal toplevel
121proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
122    global expgui expmap
123    set w .global
124    catch {destroy $w}
125    toplevel $w -bg beige
126    wm title $w "Input $what"
127    set expgui(temp) {}
128    pack [frame $w.0 -bd 6 -relief groove -bg beige] \
129            -side top -expand yes -fill both
130    grid [label $w.0.a -text "Input a value for the $what" \
131            -bg beige] \
132            -row 0 -column 0 -columnspan 10
133    grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
134            -row 1 -column 0 
135
136    set expgui(temp) $initvalue
137    pack [frame $w.b] -side top
138    pack [button $w.b.2 -text Set -command "destroy $w"] -side left
139    if $quit {
140        pack [button $w.b.3 -text Quit \
141                -command "set expgui(temp) {}; destroy $w"] -side left
142    }
143    bind $w <Return> "destroy $w"
144
145    # force the window to stay on top
146    putontop $w
147
148    focus $w.b.2
149    tkwait window $w
150    afterputontop
151
152    return $expgui(temp)
153}
154
155# run a GSAS program that does not require an experiment file
156proc runGSASprog {proglist} {
157    global expgui tcl_platform
158    set cmd {}
159    foreach prog $proglist {
160        if {$tcl_platform(platform) == "windows"} {
161            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
162        } else {
163            if {$cmd != ""} {append cmd "\;"}
164            append cmd "[file join $expgui(gsasexe) $prog]"
165        }
166    }
167    forknewterm $prog $cmd 0 1 1
168}
169
170# run a GSAS program that requires an experiment file for input/output
171proc runGSASwEXP {proglist "concurrent 0"} {
172    global expgui tcl_platform
173    # Save the current exp file
174    savearchiveexp
175    # load the changed .EXP file automatically?
176    if {$expgui(autoexpload)} {
177        # disable the file changed monitor
178        set expgui(expModifiedLast) 0
179    }
180    set cmd {}
181    set expnam [file root [file tail $expgui(expfile)]]
182    foreach prog $proglist {
183        if {$prog == "expedt" && $expgui(archive)} archiveexp
184        if {$tcl_platform(platform) == "windows"} {
185            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
186        } else {
187            if {$cmd != ""} {append cmd "\;"}
188            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
189        }
190    }
191    forknewterm "$prog -- $expnam" $cmd $concurrent 1 1
192    # load the changed .EXP file automatically?
193    if {$expgui(autoexpload)} {
194        # load the revised exp file
195        loadexp $expgui(expfile)
196    }
197}
198
199# run liveplot
200proc liveplot {} {
201    global expgui liveplot wishshell
202    set expnam [file root [file tail $expgui(expfile)]]
203    exec $wishshell [file join $expgui(scriptdir) liveplot] \
204            $expnam $liveplot(hst) $liveplot(legend) &
205}
206
207# run lstview
208proc lstview {} {
209    global expgui wishshell
210    set expnam [file root [file tail $expgui(expfile)]]
211    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
212}
213
214# run widplt
215proc widplt {} {
216    global expgui wishshell
217    exec $wishshell [file join $expgui(scriptdir) widplt] \
218            $expgui(expfile) &
219}
220
221# show help information
222proc showhelp {} {
223    global expgui_helplist helpmsg
224    set helpmsg {}
225    set frm .help
226    catch {destroy $frm}
227    toplevel $frm
228    wm title $frm "Command Help"
229    pack [message $frm.0 -text \
230            "Click on an entry below to see help on a GSAS command" ] \
231            -side top
232    pack [frame $frm.a -width 20 -height 15] \
233            -side top -expand yes -fill both
234    pack [message $frm.help -textvariable helpmsg -relief groove] \
235            -side left -fill both -expand yes
236    set lst [array names expgui_helplist]
237    listbox $frm.a.cmds -relief raised -bd 2 -yscrollcommand \
238            "$frm.a.scroll set" -height 15 -width 0
239    scrollbar $frm.a.scroll -command "$frm.a.cmds yview"
240    foreach item [lsort $lst] {
241        $frm.a.cmds insert end $item 
242    }
243    if {[$frm.a.cmds curselection] == ""} {$frm.a.cmds selection set 0}
244    button $frm.a.done -text Done -command "destroy $frm"
245    bind $frm.a.cmds <ButtonRelease-1> \
246            "+set helpmsg \$expgui_helplist(\[$frm.a.cmds get \[$frm.a.cmds curselection\]\])"
247    pack $frm.a.scroll -side left -fill y
248    pack $frm.a.cmds -side left -expand yes -anchor w
249    pack $frm.a.done -side right -expand no
250    # get the size of the window and expand the message boxes to match
251    update
252    set width [lindex [split [wm geometry $frm] x+] 0]
253    $frm.0 config -width $width
254    $frm.help config -width $width
255    # waitdone $frm
256}
257
258# compute the composition for each phase and display in a toplevel
259proc composition {} {
260    global expmap expgui
261    set Z 1
262    foreach phase $expmap(phaselist) type $expmap(phasetype) {
263        if {$type > 2} continue
264        catch {unset total}
265        foreach atom $expmap(atomlist_$phase) {
266            set type [atominfo $phase $atom type]
267            set mult [atominfo $phase $atom mult]
268            if [catch {set total($type)}] {
269                set total($type) [expr \
270                        $mult * [atominfo $phase $atom frac]]
271            } else {
272                set total($type) [expr $total($type) + \
273                        $mult * [atominfo $phase $atom frac]]
274            }
275            if {$mult > $Z} {set Z $mult}
276        }
277        append text "\nPhase $phase\n"
278        append text "  Unit cell contents\n"
279        foreach type [lsort [array names total]] {
280            append text "   $type[format %8.3f $total($type)]"
281        }
282        append text "\n\n"
283       
284        append text "  Asymmetric Unit contents (Z=$Z)\n"
285        foreach type [lsort [array names total]] {
286            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
287        }
288        append text "\n"
289    }
290   
291    catch {destroy .comp}
292    toplevel .comp
293    wm title .comp Composition
294    pack [label .comp.results -text $text \
295            -font $expgui(coordfont) -justify left] -side top
296    pack [frame .comp.box]  -side top
297    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
298    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
299    pack [button .comp.box.2 -text "Save to $lstnam file" \
300            -command "writelst [list $text] ; destroy .comp"] -side left
301}
302
303# write text to the .LST file
304proc writelst {text} {
305    global expgui
306    set lstnam [file rootname $expgui(expfile)].LST
307    set fp [open $lstnam a]
308    puts $fp "\n-----------------------------------------------------------------"
309    puts $fp $text
310    puts $fp "-----------------------------------------------------------------\n"
311    close $fp
312}
313
314# save coordinates in an MSI .xtl file
315proc exp2xtl {} {
316    global expmap expgui
317    catch {destroy .export}
318    toplevel .export
319    wm title .export "Export coordinates"
320    pack [label .export.lbl -text "Export coordinates in MSI .xtl format"\
321            ] -side top -anchor center
322    pack [frame .export.ps] -side top -anchor w
323    pack [label .export.ps.lbl -text "Select phase: "] -side left
324    foreach num $expmap(phaselist) type $expmap(phasetype) {
325        pack [button .export.ps.$num -text $num \
326                    -command "SetExportPhase $num"] -side left
327        if {$type == 4} {
328            .export.ps.$num config -state disabled
329        }
330    }
331    pack [frame .export.sg] -side top
332    pack [label .export.sg.1 -text "Space Group: "] -side left
333    pack [entry .export.sg.2 -textvariable expgui(export_sg) -width 8] -side left
334    pack [checkbutton .export.sg.3 -variable expgui(export_orig) -text "Origin 2"] -side left
335    pack [frame .export.but] -side top
336    if {[llength $expmap(phaselist)] > 0} {
337        pack [button .export.but.1 -text Write -command writextl] -side left
338        SetExportPhase [lindex $expmap(phaselist) 0]
339    }
340    pack [button .export.but.2 -text Quit -command "destroy .export"] -side left
341}
342
343proc SetExportPhase {phase} {
344    global expmap expgui
345    foreach n $expmap(phaselist) type $expmap(phasetype) {
346        if {$n == $phase && $type != 4} {
347            .export.ps.$n config -relief sunken
348            set expgui(export_phase) $phase
349            # remove spaces from space group
350            set spacegroup [phaseinfo $phase spacegroup]
351            if {[string toupper [string range $spacegroup end end]] == "R"} {
352                set spacegroup [string range $spacegroup 0 \
353                        [expr [string length $spacegroup]-2]] 
354            }
355            regsub -all " " $spacegroup "" expgui(export_sg)   
356        } else { 
357            .export.ps.$n config -relief raised
358        }
359    }
360}
361
362
363proc writextl {} {
364    global expgui expmap
365    if ![catch {
366        set phase $expgui(export_phase)
367        set origin $expgui(export_orig)
368        set spsymbol $expgui(export_sg)
369    } errmsg] {
370        set errmsg {}
371        if {$phase == ""} {
372            set errmsg "Error: invalid phase number $phase"
373        } elseif {$spsymbol == ""} {
374            set errmsg "Error: invalid Space Group: $spsymbol"
375        }
376    }
377    if {$errmsg != ""} {
378        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
379        return
380    }
381
382    if [catch {
383        set filnam [file rootname $expgui(expfile)]_${phase}.xtl
384        set spacegroup [phaseinfo $phase spacegroup]
385        set fp [open $filnam w]
386        puts $fp "TITLE from $expgui(expfile)"
387        puts $fp "TITLE history [string trim [lindex [exphistory last] 1]]"
388        puts $fp "TITLE phase [phaseinfo $phase name]"
389        puts $fp "CELL"
390        puts $fp "  [phaseinfo $phase a] [phaseinfo $phase b] [phaseinfo $phase c] [phaseinfo $phase alpha] [phaseinfo $phase beta] [phaseinfo $phase gamma]"
391       
392        puts $fp "Symmetry Label $spsymbol"
393        set rhomb 0
394        if {[string toupper [string range $spacegroup end end]] == "R"} {
395            set rhomb 1
396        }
397        if $origin {
398            puts $fp "Symmetry Qualifier origin_2"
399        }
400        if $rhomb {
401            puts $fp "Symmetry Qualifier rhombohedral"
402        }
403       
404        # are there anisotropic atoms?
405        set aniso 0
406        foreach atom $expmap(atomlist_$phase) {
407            if {[atominfo $phase $atom temptype] == "A"} {set aniso 1}
408        }
409        puts $fp "ATOMS"
410        if $aniso {
411            puts $fp "NAME       X          Y          Z    OCCUP U11 U22 U33 U12 U13 U23"
412            foreach atom $expmap(atomlist_$phase) {
413                set label [atominfo $phase $atom label]
414                # remove () characters
415                if {[atominfo $phase $atom temptype] == "A"} {
416                    puts $fp "$label [atominfo $phase $atom x] \
417                            [atominfo $phase $atom y] [atominfo $phase $atom z] \
418                            [atominfo $phase $atom frac] \
419                            [atominfo $phase $atom U11] \
420                            [atominfo $phase $atom U22] \
421                            [atominfo $phase $atom U33] \
422                            [atominfo $phase $atom U12] \
423                            [atominfo $phase $atom U13] \
424                            [atominfo $phase $atom U23]"
425                } else {
426                    puts $fp "$label [atominfo $phase $atom x] \
427                            [atominfo $phase $atom y] [atominfo $phase $atom z] \
428                            [atominfo $phase $atom frac] \
429                            [atominfo $phase $atom Uiso] \
430                            [atominfo $phase $atom Uiso] \
431                            [atominfo $phase $atom Uiso] \
432                            0 0 0 "
433                }
434            }
435        } else {
436            puts $fp "NAME       X          Y          Z    UISO      OCCUP"
437            foreach atom $expmap(atomlist_$phase) {
438                set label [atominfo $phase $atom label]
439                # remove () characters
440                regsub -all "\[()\]" $label "" label
441                puts $fp "$label [atominfo $phase $atom x] \
442                        [atominfo $phase $atom y] [atominfo $phase $atom z] \
443                        [atominfo $phase $atom Uiso]  [atominfo $phase $atom frac]"
444            }
445        }
446    } errmsg] {
447        catch {close $fp}
448        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
449    } else {
450        catch {close $fp}
451        tk_dialog .ok "Done" \
452                "File [file tail $filnam] written in directory [file dirname $filnam]" \
453                warning 0 "OK"
454    }
455    if {[llength $expmap(phaselist)] == 1} {destroy .export}
456}
457
458
459# convert a file
460proc convfile {} {
461    global tcl_platform
462    if {$tcl_platform(platform) == "windows"} {
463        convwin
464    } else {
465        convunix
466    }
467}
468
469# file conversions for UNIX (convstod convdtos)
470proc convunix {} {
471    global expgui infile outfile
472    set frm .file
473    catch {destroy $frm}
474    toplevel $frm
475    wm title $frm "Convert File"
476
477    pack [frame [set frm0 $frm.0] -bd 2 -relief groove] \
478            -padx 3 -pady 3 -side top -fill x
479    pack [frame $frm.mid] -side top
480    pack [frame [set frmA $frm.mid.1] -bd 2 -relief groove] \
481            -padx 3 -pady 3 -side left
482    pack [label $frmA.0 -text "Select an input file"] -side top -anchor center
483    pack [frame [set frmB $frm.mid.2] -bd 2 -relief groove] \
484            -padx 3 -pady 3 -side left
485    pack [label $frmB.0 -text "Enter an output file"] -side top -anchor center
486    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side top
487
488    pack [label $frm0.1 -text "Convert to:"] -side top -anchor center
489    pack [frame $frm0.2] -side top -anchor center
490    pack [radiobutton $frm0.2.d -text "direct access" -value convstod \
491            -command setoutfile \
492            -variable outfile(type)] -side left -anchor center
493    pack [radiobutton $frm0.2.s -text "sequential" -value convdtos \
494            -command setoutfile \
495            -variable outfile(type)] -side right -anchor center
496    set outfile(type) ""
497
498    pack [button $frmC.b -text Convert -command "valid_conv_unix"] -side left
499    pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side left
500
501   
502    unixcnvbox $frmA infile 1 
503    unixcnvbox $frmB outfile 0 
504    set infile(done) 0
505    bind $frm <Return> "valid_conv_unix"
506    # force the window to stay on top
507    putontop $frm
508    focus $frmC.q 
509    update
510    tkwait variable infile(done)
511    destroy $frm
512    afterputontop
513}
514
515# validate the files and make the conversion -- unix
516proc valid_conv_unix {} {
517    global infile outfile expgui
518    set error {}
519    if {$outfile(type) == "convstod" || $outfile(type) == "convdtos"} {
520        set convtype $outfile(type)
521    } else {
522        append error "You must specify a conversion method: to direct access or to sequential.\n"
523    }
524    if {$infile(name) == ""} {
525        append error "You must specify an input file to convert.\n"
526    }
527    if {$outfile(name) == ""} {
528        append error "You must specify an output file name for the converted file.\n"
529    }
530    if {$error != ""} {
531        tk_dialog .warn Notify $error warning 0 OK
532        return
533    }
534
535    if {$infile(name) == $outfile(name)} {
536        tk_dialog .warn Notify "Sorry, filenames must differ" warning 0 OK
537        return
538    }
539    if ![file exists [file join $infile(dir) $infile(name)]] {
540        tk_dialog .warn Notify \
541                "Sorry, file $infile(name) not found in $infile(dir)" warning 0 OK
542        return
543    }
544    if [file exists [file join $outfile(dir) $outfile(name)]] {
545        if [tk_dialog .warn Notify \
546                "Warning: file $outfile(name) exists in $outfile(dir). OK to overwrite?" \
547                warning 0 OK No] return
548    }
549    if [catch {
550        exec [file join $expgui(gsasexe) $convtype] < \
551                [file join $infile(dir) $infile(name)] > \
552                [file join $outfile(dir) $outfile(name)]
553    } errmsg] {
554        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
555    } else {
556        if [tk_dialog .converted Notify \
557                "File converted. Convert more files?" \
558                ""  0 Yes No] {set infile(done) 1}
559    }
560}
561
562# create a file box for UNIX conversions
563proc unixcnvbox {bx filvar diropt} {
564    global ${filvar} expgui
565    pack [frame $bx.top] -side top
566    pack [label $bx.top.a -text "Directory" ] -side left
567    set ${filvar}(FileDirButtonMenu) [tk_optionMenu $bx.top.d ${filvar}(dir) [pwd] ]
568    pack $bx.top.d -side left
569    set ${filvar}(dir) [pwd]
570
571#    pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top
572#    set ${filvar}(dir) [pwd]
573
574    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
575    listbox $bx.a.files -relief raised -bd 2 -yscrollcommand "$bx.a.scroll set" \
576            -height 15 -width 0
577    scrollbar $bx.a.scroll -command "$bx.a.files yview"
578    unixFilChoose $bx $bx.a.files $filvar $diropt
579    if {$filvar == "infile"} {
580        bind $bx.a.files <ButtonRelease-1> \
581                "unixFilChoose $bx $bx.a.files $filvar $diropt; setoutfile"
582    } else {
583        bind $bx.a.files <ButtonRelease-1> \
584                "unixFilChoose $bx $bx.a.files $filvar $diropt"
585    }
586    pack $bx.a.scroll -side left -fill y
587    pack $bx.a.files -side left -fill both -expand yes
588    pack [entry $bx.c -textvariable ${filvar}(name)] -side top
589}
590
591# select a file or directory, also called when box is created to fill it
592proc unixFilChoose {frm box filvar {dironly 1}} {
593    global $filvar
594    set select [$box curselection]
595    if {$select == ""} {
596        set file .
597    } else {
598        set file [string trim [$box get $select]]
599    }
600    if [file isdirectory [file join [set ${filvar}(dir)] $file]] {
601        if {$file == ".."} {
602            set ${filvar}(dir) [file dirname [set ${filvar}(dir)] ]
603        } elseif {$file != "."} {
604            set ${filvar}(dir) [file join [set ${filvar}(dir)] $file]
605        }
606        [set ${filvar}(FileDirButtonMenu)] delete 0 end
607        set list ""
608        set dir ""
609        foreach subdir [file split [set ${filvar}(dir)]] {
610            set dir [file join $dir $subdir]
611            lappend list $dir
612        }
613        foreach path $list {
614            [set ${filvar}(FileDirButtonMenu)] add command -label $path \
615                -command "[list set ${filvar}(dir) $path]; \
616                unixFilChoose $frm $box $filvar $dironly"
617        }
618        set ${filvar}(name) {}
619        $box delete 0 end
620        $box insert end {..   }
621        foreach file [lsort [glob -nocomplain \
622                [file join [set ${filvar}(dir)] *] ] ] {
623            if {[file isdirectory $file]} {
624                # is this / needed here? Does it cause a problem in MacGSAS?
625                $box insert end [file tail $file]/
626            } elseif {$dironly == 1} {
627                $box insert end [file tail $file]
628            } elseif {$dironly == 2 && [file extension $file] == ".EXP"} {
629                $box insert end [file tail $file]
630            }
631        }
632        return
633    }
634    set ${filvar}(name) [file tail $file]
635}
636
637# set new file name from old -- used for convunix
638proc setoutfile {} {
639    global infile outfile
640    if {$outfile(type) == "convstod"} {
641        set lfile [string toupper $infile(name)]
642    } elseif {$outfile(type) == "convdtos"} {
643        set lfile [string tolower $infile(name)]
644    } else {
645        set lfile ""
646    }
647    if {$infile(name) == $lfile} {
648        set outfile(name) {}
649    } else {
650        set outfile(name) $lfile
651    }
652}
653
654#------------------------------------------------------------------------------
655# file conversions for Windows
656#------------------------------------------------------------------------------
657proc convwin {} {
658    global expgui
659    set frm .file
660    catch {destroy $frm}
661    toplevel $frm
662    wm title $frm "Convert File"
663    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
664    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
665    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
666            -side top
667    pack [button $frmC.q -text Quit -command "destroy $frm"] -side top
668    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
669    winfilebox $frm
670    bind $frm <Return> "ValidWinCnv $frm"
671
672    # force the window to stay on top
673    putontop $frm
674    focus $frmC.q 
675    tkwait window $frm
676    afterputontop
677}
678
679# validate the files and make the conversion
680proc ValidWinCnv {frm} {
681    global expgui
682    # change backslashes to something sensible
683    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
684    # allow entry of D: for D:/ and D:TEST for d:/TEST
685    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
686            [string first :/ $expgui(FileMenuCnvName)] == -1} {
687        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
688    }
689    if {$expgui(FileMenuCnvName) == "<Parent>"} {
690        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
691        ChooseWinCnv $frm
692        return
693    } elseif [file isdirectory \
694            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
695        if {$expgui(FileMenuCnvName) != "."} {
696            set expgui(FileMenuDir) \
697                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
698        }
699        ChooseWinCnv $frm
700        return
701    }
702 
703    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
704    if ![file exists $file] {
705        tk_dialog .warn "Convert Error" \
706                "File $file does not exist" question 0 "OK"
707        return
708    }
709
710    set tmpname "[file join [file dirname $file] tempfile.xxx]"
711    set oldname "[file rootname $file].org"
712    if [file exists $oldname] {
713        set ans [tk_dialog .warn "OK to overwrite?" \
714                "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" question 0 \
715                "Yes" "No"]
716        if $ans return
717        catch {file delete $oldname}
718    }
719
720    if [catch {
721        set in [open $file r]
722        set out [open $tmpname w]
723        set len [gets $in line]
724        if {$len > 160} {
725            # this is a UNIX file. Hope there are no control characters
726            set i 0
727            set j 79
728            while {$j < $len} {
729                puts $out [string range $line $i $j]
730                incr i 80
731                incr j 80
732            }
733        } else {
734            while {$len >= 0} {
735                append line "                                        "
736                append line "                                        "
737                set line [string range $line 0 79]
738                puts $out $line
739                set len [gets $in line]
740            }
741        }
742        close $in
743        close $out
744        file rename -force $file $oldname
745        file rename -force $tmpname $file
746    } errmsg] {
747        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
748    } else {
749        if [tk_dialog .converted Notify \
750                "File [file tail $file] converted. (Original saved as [file tail $oldname]).\n\n Convert more files?" \
751                ""  0 Yes No] {destroy $frm}
752    }
753}
754
755# create a file box
756proc winfilebox {frm} {
757    global expgui
758    set bx $frm.1
759    pack [frame $bx.top] -side top
760    pack [label $bx.top.a -text "Directory" ] -side left
761    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
762    pack $bx.top.d -side left
763    set expgui(FileMenuDir) [pwd]
764    # the icon below is from tk8.0/tkfbox.tcl
765    set upfolder [image create bitmap -data {
766#define updir_width 28
767#define updir_height 16
768static char updir_bits[] = {
769   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
770   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
771   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
772   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
773   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
774   0xf0, 0xff, 0xff, 0x01};}]
775
776    pack [button $bx.top.b -image $upfolder \
777            -command "updir; ChooseWinCnv $frm" ]
778    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
779    listbox $bx.a.files -relief raised -bd 2 \
780            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
781            -height 15 -width 0
782    listbox $bx.a.dates -relief raised -bd 2 \
783            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
784            -height 15 -width 0 -takefocus 0
785    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
786    ChooseWinCnv $frm
787    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
788    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
789    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
790    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
791    pack $bx.a.scroll -side left -fill y
792    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
793    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
794}
795
796# set the box or file in the selection window
797proc ReleaseWinCnv {frm} {
798    global expgui
799    set files $frm.1.a.files
800    set dates $frm.1.a.dates
801    set select [$files curselection]
802    if {$select == ""} {
803        set select [$dates curselection]
804    }
805    if {$select == ""} {
806        set expgui(FileMenuCnvName) ""
807    } else {
808        set expgui(FileMenuCnvName) [string trim [$files get $select]]
809    }
810    if {$expgui(FileMenuCnvName) == "<Parent>"} {
811        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
812        ChooseWinCnv $frm
813    } elseif [file isdirectory \
814            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
815        if {$expgui(FileMenuCnvName) != "."} {
816            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
817            ChooseWinCnv $frm
818        }
819    }
820    return
821}
822
823# select a file or directory -- called on double click
824proc SelectWinCnv {frm} {
825    global expgui
826    set files $frm.1.a.files
827    set dates $frm.1.a.dates
828    set select [$files curselection]
829    if {$select == ""} {
830        set select [$dates curselection]
831    }
832    if {$select == ""} {
833        set file .
834    } else {
835        set file [string trim [$files get $select]]
836    }
837    if {$file == "<Parent>"} {
838        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
839        ChooseWinCnv $frm
840    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
841        if {$file != "."} {
842            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
843            ChooseWinCnv $frm
844        }
845    } else {
846        set expgui(FileMenuCnvName) [file tail $file]
847        ValidWinCnv $frm
848    }
849}
850
851# fill the files & dates & Directory selection box with current directory,
852# also called when box is created to fill it
853proc ChooseWinCnv {frm} {
854    global expgui
855    set files $frm.1.a.files
856    set dates $frm.1.a.dates
857    set expgui(FileMenuCnvName) {}
858    $files delete 0 end
859    $dates delete 0 end
860    $files insert end {<Parent>}
861    $dates insert end {(Directory)}
862    set filelist [glob -nocomplain \
863            [file join [set expgui(FileMenuDir)] *] ]
864    foreach file [lsort -dictionary $filelist] {
865        if {[file isdirectory $file]} {
866            $files insert end [file tail $file]
867            $dates insert end {(Directory)}
868        }
869    }
870    foreach file [lsort -dictionary $filelist] {
871        if {![file isdirectory $file]} {
872            set modified [clock format [file mtime $file] -format "%T %D"]
873            $files insert end [file tail $file]
874            $dates insert end $modified
875        }
876    }
877    $expgui(FileDirButtonMenu)  delete 0 end
878    set list ""
879    set dir ""
880    foreach subdir [file split [set expgui(FileMenuDir)]] {
881        set dir [file join $dir $subdir]
882        lappend list $dir
883    }
884    foreach path $list {
885        $expgui(FileDirButtonMenu) add command -label $path \
886                -command "[list set expgui(FileMenuDir) $path]; \
887                ChooseWinCnv $frm"
888    }
889    return
890}
891
892#------------------------------------------------------------------------------
893# set options for liveplot
894proc liveplotopt {} {
895    global liveplot expmap
896    set frm .file
897    catch {destroy $frm}
898    toplevel $frm
899    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
900    set last [lindex [lsort -integer $expmap(powderlist)] end]
901    if {$last == ""} {set last 1}
902    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
903            -length  150 -orient horizontal -variable liveplot(hst)] -side top
904    pack [checkbutton $frmA.2 -text {include plot legend}\
905            -variable liveplot(legend)] -side top
906    pack [button $frm.2 -text OK \
907            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
908            ] -side top
909    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
910   
911    # force the window to stay on top
912    putontop $frm 
913    focus $frm.2
914    tkwait window $frm
915    afterputontop
916}
917
918#------------------------------------------------------------------------------
919# get an experiment file name
920#------------------------------------------------------------------------------
921proc getExpFileName {mode} {
922    global expgui
923    set frm .file
924    catch {destroy $frm}
925    toplevel $frm
926    wm title $frm "Experiment file"
927    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
928    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
929    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
930    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
931            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
932    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
933            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
934    pack [button $frmC.b -text Read \
935            -command "valid_exp_file $frmA $mode"] -side top
936    if {$mode == "new"} {
937        $frmC.b config -text Save
938    }
939    pack [button $frmC.q -text Quit \
940            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side top
941    bind $frm <Return> "$frmC.b invoke"
942
943    if {$mode == "new"} {
944        pack [label $frmA.0 -text "Enter an experiment file to create"] \
945                -side top -anchor center
946    } else {
947        pack [label $frmA.0 -text "Select an experiment file to read"] \
948                -side top -anchor center
949    }
950    expfilebox $frmA $mode
951    # force the window to stay on top
952    putontop $frm
953    focus $frmC.b
954    tkwait window $frm
955    afterputontop
956    if {$expgui(FileMenuEXPNAM) == ""} return
957    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
958}
959
960# validation routine
961proc valid_exp_file {frm mode} {
962    global expgui tcl_platform
963    # windows fixes
964    if {$tcl_platform(platform) == "windows"} {
965        # change backslashes to something sensible
966        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
967        # allow entry of D: for D:/ and D:TEST for d:/TEST
968        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
969                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
970            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
971        }
972    }
973    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
974        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
975        ChooseExpFil $frm
976        return
977    } elseif [file isdirectory \
978            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
979        if {$expgui(FileMenuEXPNAM) != "."} {
980            set expgui(FileMenuDir) \
981                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
982        }
983        ChooseExpFil $frm
984        return
985    }
986    # append a .EXP if not present
987    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
988        append expgui(FileMenuEXPNAM) ".EXP"
989    }
990    # flag files that end in something other than .EXP .exp or .Exp...
991    if {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
992        tk_dialog .expFileErrorMsg "File Open Error" \
993            "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
994            error 0 OK
995        return
996    }
997    # check on the file status
998    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
999    if {$mode == "new" && [file exists $file]} {
1000        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
1001            "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" question 0 \
1002             "Select other name" "Overwrite"]
1003        if $ans {destroy .file}
1004        return
1005    }
1006    # if file does not exist in case provided, set the name to all
1007    # upper case letters, since that is the best choice.
1008    # if it does exist, read from it as is. For UNIX we will force uppercase later.
1009    if {![file exists $file]} {
1010        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
1011        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1012    }
1013    if {$mode == "old" && ![file exists $file]} {
1014        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
1015            "File [file tail $file] does not exist in [file dirname $file]. OK to create?" question 0 \
1016             "Select other name" "Create"]
1017        if $ans {destroy .file}
1018        return
1019    }
1020    destroy .file
1021}
1022
1023proc updir {} {
1024    global expgui
1025    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1026}
1027
1028# create a file box
1029proc expfilebox {bx mode} {
1030    global expgui
1031    pack [frame $bx.top] -side top
1032    pack [label $bx.top.a -text "Directory" ] -side left
1033    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1034    pack $bx.top.d -side left
1035    set expgui(FileMenuDir) [pwd]
1036    # the icon below is from tk8.0/tkfbox.tcl
1037    set upfolder [image create bitmap -data {
1038#define updir_width 28
1039#define updir_height 16
1040static char updir_bits[] = {
1041   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1042   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1043   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1044   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1045   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1046   0xf0, 0xff, 0xff, 0x01};}]
1047
1048    pack [button $bx.top.b -image $upfolder \
1049            -command "updir; ChooseExpFil $bx" ]
1050    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1051    listbox $bx.a.files -relief raised -bd 2 \
1052            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
1053            -height 15 -width 0
1054    listbox $bx.a.dates -relief raised -bd 2 \
1055            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
1056            -height 15 -width 0 -takefocus 0
1057    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1058    ChooseExpFil $bx
1059    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1060    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1061    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1062    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1063    pack $bx.a.scroll -side left -fill y
1064    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1065    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1066}
1067proc sync2boxes {master slave scroll args} {
1068    $slave yview moveto [lindex [$master yview] 0]
1069    eval $scroll set $args
1070}
1071proc move2boxesY {boxlist args} {
1072    foreach listbox $boxlist { 
1073        eval $listbox yview $args
1074    }
1075}
1076
1077# set the box or file in the selection window
1078proc ReleaseExpFil {frm} {
1079    global expgui
1080    set files $frm.a.files
1081    set dates $frm.a.dates
1082    set select [$files curselection]
1083    if {$select == ""} {
1084        set select [$dates curselection]
1085    }
1086    if {$select == ""} {
1087        set expgui(FileMenuEXPNAM) ""
1088    } else {
1089        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
1090    }
1091    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1092        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1093        ChooseExpFil $frm
1094    } elseif [file isdirectory \
1095            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
1096        if {$expgui(FileMenuEXPNAM) != "."} {
1097            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1098            ChooseExpFil $frm
1099        }
1100    }
1101    return
1102}
1103
1104# select a file or directory -- called on double click
1105proc SelectExpFil {frm mode} {
1106    global expgui
1107    set files $frm.a.files
1108    set dates $frm.a.dates
1109    set select [$files curselection]
1110    if {$select == ""} {
1111        set select [$dates curselection]
1112    }
1113    if {$select == ""} {
1114        set file .
1115    } else {
1116        set file [string trim [$files get $select]]
1117    }
1118    if {$file == "<Parent>"} {
1119        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1120        ChooseExpFil $frm
1121    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1122        if {$file != "."} {
1123            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1124            ChooseExpFil $frm
1125        }
1126    } else {
1127        set expgui(FileMenuEXPNAM) [file tail $file]
1128        valid_exp_file $frm $mode
1129    }
1130}
1131
1132# fill the files & dates & Directory selection box with current directory,
1133# also called when box is created to fill it
1134proc ChooseExpFil {frm} {
1135    global expgui
1136    set files $frm.a.files
1137    set dates $frm.a.dates
1138    set expgui(FileMenuEXPNAM) {}
1139    $files delete 0 end
1140    $dates delete 0 end
1141    $files insert end {<Parent>}
1142    $dates insert end {(Directory)}
1143    set filelist [glob -nocomplain \
1144            [file join [set expgui(FileMenuDir)] *] ]
1145    foreach file [lsort -dictionary $filelist] {
1146        if {[file isdirectory $file]} {
1147            $files insert end [file tail $file]
1148            $dates insert end {(Directory)}
1149        }
1150    }
1151    set pairlist {}
1152    foreach file [lsort -dictionary $filelist] {
1153        if {![file isdirectory $file]  && \
1154                [string toupper [file extension $file]] == ".EXP"} {
1155            set modified [file mtime $file]
1156            lappend pairlist [list $file $modified]
1157        }
1158    }
1159    if {$expgui(filesort) == 0} {
1160        foreach pair [lsort -index 1 -integer $pairlist] {
1161            set file [lindex $pair 0]
1162            set modified [clock format [lindex $pair 1] -format "%T %D"]
1163            $files insert end [file tail $file]
1164            $dates insert end $modified
1165        }
1166    } else {
1167        foreach pair [lsort -dictionary -index 0 $pairlist] {
1168            set file [lindex $pair 0]
1169            set modified [clock format [lindex $pair 1] -format "%T %D"]
1170            $files insert end [file tail $file]
1171            $dates insert end $modified
1172        }
1173    }
1174    $expgui(FileDirButtonMenu)  delete 0 end
1175    set list ""
1176    set dir ""
1177    foreach subdir [file split [set expgui(FileMenuDir)]] {
1178        set dir [file join $dir $subdir]
1179        lappend list $dir
1180    }
1181    foreach path $list {
1182        $expgui(FileDirButtonMenu) add command -label $path \
1183                -command "[list set expgui(FileMenuDir) $path]; \
1184                ChooseExpFil $frm"
1185    }
1186    # highlight the current experiment -- if present
1187    for {set i 0} {$i < [$files size]} {incr i} {
1188        set file [$files get $i]
1189        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
1190            $files selection set $i
1191        }
1192    }
1193    return
1194}
1195
1196proc putontop {w} {
1197    # center window $w above its parent and make it stay on top
1198    set wp [winfo parent $w]
1199    wm transient $w [winfo toplevel $wp]
1200    wm withdraw $w
1201    update idletasks
1202    # center the new window in the middle of the parent
1203    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
1204            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
1205    if {$x < 0} {set x 0}
1206    set xborder 10
1207    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
1208        incr x [expr \
1209                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
1210    }
1211    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
1212            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
1213    if {$y < 0} {set y 0}
1214    set yborder 25
1215    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
1216        incr y [expr \
1217                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
1218    }
1219    wm geom $w +$x+$y
1220    wm deiconify $w
1221
1222    global makenew
1223    set makenew(OldFocus) [focus]
1224    catch {
1225        set makenew(OldGrab) [grab current $w]
1226        if {$makenew(OldGrab) != ""} {
1227            set makenew(GrabStatus) [grab status $makenew(OldGrab)]
1228        }
1229        grab $w
1230    }
1231}
1232
1233proc afterputontop {} {
1234    # restore focus
1235    global makenew
1236    catch {focus $makenew(OldFocus)}
1237    if {$makenew(OldGrab) != ""} {
1238        catch {
1239            if {$makenew(GrabStatus) == "global"} {
1240                grab -global $makenew(OldGrab)
1241            } else {
1242                grab $makenew(OldGrab)
1243            }
1244        }
1245    }
1246}
1247
1248proc ShowBigMessage {win labeltext msg "optionlist OK"} {
1249    catch {destroy $win}
1250    toplevel $win
1251
1252    # grab focus, etc.
1253    pack [label $win.l1 -text $labeltext] -side top
1254    pack [frame $win.f1] -side top -expand yes -fill both
1255    grid [text  $win.f1.t  \
1256            -height 20 -width 55  -wrap none -font Courier \
1257            -xscrollcommand "$win.f1.bscr set" \
1258            -yscrollcommand "$win.f1.rscr set" \
1259            ] -row 1 -column 0 -sticky news
1260    grid [scrollbar $win.f1.bscr -orient horizontal \
1261            -command "$win.f1.t xview" \
1262            ] -row 2 -column 0 -sticky ew
1263    grid [scrollbar $win.f1.rscr  -command "$win.f1.t yview" \
1264            ] -row 1 -column 1 -sticky ns
1265    # give extra space to the text box
1266    grid columnconfigure $win.f1 0 -weight 1
1267    grid rowconfigure $win.f1 1 -weight 1
1268    $win.f1.t insert end $msg
1269
1270    global makenew
1271    set makenew(result) 0
1272    bind $win <Return> "destroy $win"
1273    bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
1274    bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
1275    bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
1276    bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
1277    bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
1278    bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
1279    bind $win <KeyPress-Home> "$win.f1.t yview 0"
1280    bind $win <KeyPress-End> "$win.f1.t yview end"
1281    set i 0
1282    foreach item $optionlist {
1283        pack [button $win.q[incr i] \
1284                -command "set makenew(result) $i; destroy $win" -text $item] -side left
1285    }
1286    putontop $win
1287    tkwait window $win
1288
1289    # fix focus...
1290    afterputontop
1291    return $makenew(result)
1292}
1293
1294#       Message box code that centers the message box over the parent.
1295#          or along the edge, if too close,
1296#          but leave a border along +x & +y for reasons I don't remember
1297#       It also allows the button names to be defined using
1298#            -type $list  -- where $list has a list of button names
1299#       larger messages are placed in a scrolled text widget
1300#       capitalization is now ignored for -default
1301#       The command returns the name button in all lower case letters
1302#       otherwise see  tk_messageBox for a description
1303#
1304#       This is a modification of tkMessageBox (msgbox.tcl v1.5)
1305#
1306proc MyMessageBox {args} {
1307    global tkPriv tcl_platform
1308
1309    set w tkPrivMsgBox
1310    upvar #0 $w data
1311
1312    #
1313    # The default value of the title is space (" ") not the empty string
1314    # because for some window managers, a
1315    #           wm title .foo ""
1316    # causes the window title to be "foo" instead of the empty string.
1317    #
1318    set specs {
1319        {-default "" "" ""}
1320        {-icon "" "" "info"}
1321        {-message "" "" ""}
1322        {-parent "" "" .}
1323        {-title "" "" " "}
1324        {-type "" "" "ok"}
1325    }
1326
1327    tclParseConfigSpec $w $specs "" $args
1328
1329    if {[lsearch {info warning error question} $data(-icon)] == -1} {
1330        error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
1331    }
1332    if {![string compare $tcl_platform(platform) "macintosh"]} {
1333      switch -- $data(-icon) {
1334          "error"     {set data(-icon) "stop"}
1335          "warning"   {set data(-icon) "caution"}
1336          "info"      {set data(-icon) "note"}
1337        }
1338    }
1339
1340    if {![winfo exists $data(-parent)]} {
1341        error "bad window path name \"$data(-parent)\""
1342    }
1343
1344    switch -- $data(-type) {
1345        abortretryignore {
1346            set buttons {
1347                {abort  -width 6 -text Abort -under 0}
1348                {retry  -width 6 -text Retry -under 0}
1349                {ignore -width 6 -text Ignore -under 0}
1350            }
1351        }
1352        ok {
1353            set buttons {
1354                {ok -width 6 -text OK -under 0}
1355            }
1356          if {![string compare $data(-default) ""]} {
1357                set data(-default) "ok"
1358            }
1359        }
1360        okcancel {
1361            set buttons {
1362                {ok     -width 6 -text OK     -under 0}
1363                {cancel -width 6 -text Cancel -under 0}
1364            }
1365        }
1366        retrycancel {
1367            set buttons {
1368                {retry  -width 6 -text Retry  -under 0}
1369                {cancel -width 6 -text Cancel -under 0}
1370            }
1371        }
1372        yesno {
1373            set buttons {
1374                {yes    -width 6 -text Yes -under 0}
1375                {no     -width 6 -text No  -under 0}
1376            }
1377        }
1378        yesnocancel {
1379            set buttons {
1380                {yes    -width 6 -text Yes -under 0}
1381                {no     -width 6 -text No  -under 0}
1382                {cancel -width 6 -text Cancel -under 0}
1383            }
1384        }
1385        default {
1386#           error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
1387            foreach item $data(-type) {
1388                lappend buttons [list [string tolower $item] -text $item -under 0]
1389            }
1390        }
1391    }
1392
1393    if {[string compare $data(-default) ""]} {
1394        set valid 0
1395        foreach btn $buttons {
1396            if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
1397                set valid 1
1398                break
1399            }
1400        }
1401        if {!$valid} {
1402            error "invalid default button \"$data(-default)\""
1403        }
1404    }
1405
1406    # 2. Set the dialog to be a child window of $parent
1407    #
1408    #
1409    if {[string compare $data(-parent) .]} {
1410        set w $data(-parent).__tk__messagebox
1411    } else {
1412        set w .__tk__messagebox
1413    }
1414
1415    # 3. Create the top-level window and divide it into top
1416    # and bottom parts.
1417
1418    catch {destroy $w}
1419    toplevel $w -class Dialog
1420    wm title $w $data(-title)
1421    wm iconname $w Dialog
1422    wm protocol $w WM_DELETE_WINDOW { }
1423    wm transient $w $data(-parent)
1424    if {![string compare $tcl_platform(platform) "macintosh"]} {
1425        unsupported1 style $w dBoxProc
1426    }
1427
1428    frame $w.bot
1429    pack $w.bot -side bottom -fill both
1430    frame $w.top
1431    pack $w.top -side top -fill both -expand 1
1432    if {[string compare $tcl_platform(platform) "macintosh"]} {
1433        $w.bot configure -relief raised -bd 1
1434        $w.top configure -relief raised -bd 1
1435    }
1436
1437    # 4. Fill the top part with bitmap and message (use the option
1438    # database for -wraplength and -font so that they can be
1439    # overridden by the caller).
1440
1441    option add *Dialog.msg.wrapLength 3i widgetDefault
1442
1443    if {[string length $data(-message)] > 300} {
1444        if {![string compare $tcl_platform(platform) "macintosh"]} {
1445            option add *Dialog.msg.t.font system widgetDefault
1446        } else {
1447            option add *Dialog.msg.t.font {Times 18} widgetDefault
1448        }
1449        frame $w.msg
1450        grid [text  $w.msg.t  \
1451                -height 20 -width 55 -relief flat -wrap word \
1452                -yscrollcommand "$w.msg.rscr set" \
1453                ] -row 1 -column 0 -sticky news
1454        grid [scrollbar $w.msg.rscr  -command "$w.msg.t yview" \
1455                ] -row 1 -column 1 -sticky ns
1456        # give extra space to the text box
1457        grid columnconfigure $w.msg 0 -weight 1
1458        grid rowconfigure $w.msg 1 -weight 1
1459        $w.msg.t insert end $data(-message)
1460    } else {
1461        if {![string compare $tcl_platform(platform) "macintosh"]} {
1462            option add *Dialog.msg.font system widgetDefault
1463        } else {
1464            option add *Dialog.msg.font {Times 18} widgetDefault
1465        }
1466        label $w.msg -justify left -text $data(-message)
1467    }
1468    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
1469    if {[string compare $data(-icon) ""]} {
1470        label $w.bitmap -bitmap $data(-icon)
1471        pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
1472    }
1473
1474    # 5. Create a row of buttons at the bottom of the dialog.
1475
1476    set i 0
1477    foreach but $buttons {
1478        set name [lindex $but 0]
1479        set opts [lrange $but 1 end]
1480      if {![llength $opts]} {
1481            # Capitalize the first letter of $name
1482          set capName [string toupper \
1483                    [string index $name 0]][string range $name 1 end]
1484            set opts [list -text $capName]
1485        }
1486
1487      eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
1488
1489        if {![string compare $name $data(-default)]} {
1490            $w.$name configure -default active
1491        }
1492      pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
1493
1494        # create the binding for the key accelerator, based on the underline
1495        #
1496        set underIdx [$w.$name cget -under]
1497        if {$underIdx >= 0} {
1498            set key [string index [$w.$name cget -text] $underIdx]
1499          bind $w <Alt-[string tolower $key]>  [list $w.$name invoke]
1500          bind $w <Alt-[string toupper $key]>  [list $w.$name invoke]
1501        }
1502        incr i
1503    }
1504
1505    # 6. Create a binding for <Return> on the dialog if there is a
1506    # default button.
1507
1508    if {[string compare $data(-default) ""]} {
1509      bind $w <Return> [list tkButtonInvoke $w.$data(-default)]
1510    }
1511
1512    # 7. Withdraw the window, then update all the geometry information
1513    # so we know how big it wants to be, then center the window in the
1514    # display and de-iconify it.
1515
1516    wm withdraw $w
1517    update idletasks
1518    set wp $data(-parent)
1519    # center the new window in the middle of the parent
1520    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
1521            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
1522    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
1523            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
1524    # make sure that we can see the entire window
1525    set xborder 10
1526    set yborder 25
1527    if {$x < 0} {set x 0}
1528    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
1529        incr x [expr \
1530                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
1531    }
1532    if {$y < 0} {set y 0}
1533    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
1534        incr y [expr \
1535                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
1536    }
1537    wm geom $w +$x+$y
1538    wm deiconify $w
1539
1540    # 8. Set a grab and claim the focus too.
1541
1542    set oldFocus [focus]
1543    set oldGrab [grab current $w]
1544    if {[string compare $oldGrab ""]} {
1545        set grabStatus [grab status $oldGrab]
1546    }
1547    grab $w
1548    if {[string compare $data(-default) ""]} {
1549        focus $w.$data(-default)
1550    } else {
1551        focus $w
1552    }
1553
1554    # 9. Wait for the user to respond, then restore the focus and
1555    # return the index of the selected button.  Restore the focus
1556    # before deleting the window, since otherwise the window manager
1557    # may take the focus away so we can't redirect it.  Finally,
1558    # restore any grab that was in effect.
1559
1560    tkwait variable tkPriv(button)
1561    catch {focus $oldFocus}
1562    destroy $w
1563    if {[string compare $oldGrab ""]} {
1564      if {![string compare $grabStatus "global"]} {
1565            grab -global $oldGrab
1566        } else {
1567            grab $oldGrab
1568        }
1569    }
1570    return $tkPriv(button)
1571}
1572
1573#------------------------------------------------------------------------------
1574# Delete History Records
1575proc DeleteHistoryRecords {{msg ""}} {
1576    global expgui
1577    set frm .history
1578    catch {destroy $frm}
1579    toplevel $frm
1580    if {[string trim $msg] == ""} {
1581        set msg "There are [CountHistory] history records"
1582    }
1583    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1584    pack [label $frm.1.0 -text $msg] -side top
1585    pack [frame $frm.1.1] -side top
1586    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1587    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1588            ] -side left
1589    set expgui(historyKeep) 10
1590    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1591    set expgui(renumber) 1
1592    pack [frame $frm.2] -padx 3 -pady 3 -side left
1593    pack [button $frm.2.3 -text OK \
1594            -command { 
1595        if ![catch {expr $expgui(historyKeep)}] {
1596            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1597            set expgui(changed) 1
1598            destroy .history
1599        }
1600    }] -side top
1601    pack [button $frm.2.4 -text Quit \
1602            -command {destroy .history}] -side top
1603    bind $frm <Return> "$frm.2.3 invoke"
1604   
1605    # force the window to stay on top
1606    putontop $frm 
1607    focus $frm.2.3
1608    tkwait window $frm
1609    afterputontop
1610}
1611
1612# optionally run disagl as a windowless process, w/results in a separate window
1613proc rundisagl {} {
1614    global expgui txtvw tcl_version tcl_platform
1615    if {$expgui(disaglSeparateBox)} {
1616        set root [file root $expgui(expfile)] 
1617        catch {file delete -force $root.tmp}
1618        catch {file rename -force $root.LST $root.OLS}
1619        # PSW reports this does not happen right away on windows
1620        set i 0
1621        while {$i < 5 && [file exists $root.LST]} {
1622            # debug code
1623            catch {console show}
1624            puts "try $i"
1625            # end debug code
1626            after 100
1627            incr i
1628        }
1629        #run the program
1630        pleasewait "Running DISAGL"     
1631        # create an empty input file
1632        close [open disagl.inp w]
1633        catch {exec [file join $expgui(gsasexe) disagl] \
1634                [file tail $root] < disagl.inp > disagl.out}
1635        catch {file rename -force $root.LST $root.tmp}
1636        catch {file delete -force disagl.inp disagl.out}
1637        catch {file rename -force $root.OLS $root.LST}
1638        donewait
1639        # open a new window
1640        catch {toplevel .disagl}
1641        catch {eval grid forget [grid slaves .disagl]}
1642        text .disagl.txt -width 100 -wrap none \
1643                -yscrollcommand ".disagl.yscroll set" \
1644                -xscrollcommand ".disagl.xscroll set" 
1645        scrollbar .disagl.yscroll -command ".disagl.txt yview"
1646        scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1647        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1648        grid .disagl.txt -column 0 -row 1 -sticky nsew
1649        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1650        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1651        grid columnconfig .disagl.f 2 -weight 1
1652        grid [button .disagl.f.close -text "Close & Delete" \
1653                -command "destroy .disagl; file delete $root.tmp"] \
1654                -column 3 -row 0 -sticky e
1655        grid [button .disagl.f.rename -text "Close & Save as .DIS" \
1656                -command "destroy .disagl; file rename -force $root.tmp $root.DIS"] \
1657                -column 4 -row 0 -sticky e
1658        # allow font changes on the fly
1659        if {$tcl_version >= 8.0} {
1660            .disagl.txt config -font $txtvw(font)
1661            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1662            grid .disagl.f.font -column 1 -row 0 -sticky w
1663            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1664            $fontbut delete 0 end
1665            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1666                $fontbut add command -label "Courier $f" -font "Courier $f"\
1667                        -command "set txtvw(font) \"Courier $f\"; \
1668                        .disagl.txt config -font \$txtvw(font)"
1669            }
1670        }
1671       
1672        grid columnconfigure .disagl 0 -weight 1
1673        grid rowconfigure .disagl 1 -weight 1
1674        wm title .disagl "DISAGL results $expgui(expfile)"
1675        wm iconname .disagl "DISAGL $root"
1676        set in [open $root.tmp r]
1677        .disagl.txt insert end [read $in]
1678        close $in
1679        bind all  {destroy .disagl}
1680        bind .disagl  ".disagl.txt yview scroll -1 page"
1681        bind .disagl  ".disagl.txt yview scroll 1 page"
1682        bind .disagl  ".disagl.txt xview scroll 1 unit"
1683        bind .disagl  ".disagl.txt xview scroll -1 unit"
1684        bind .disagl  ".disagl.txt yview scroll -1 unit"
1685        bind .disagl  ".disagl.txt yview scroll 1 unit"
1686        bind .disagl  ".disagl.txt yview 0"
1687        bind .disagl  ".disagl.txt yview end"
1688        # don't disable in Win as this prevents the highlighting of selected text
1689        if {$tcl_platform(platform) != "windows"} {
1690            .disagl.txt config -state disabled
1691        }
1692    } else {
1693        runGSASwEXP disagl
1694    }
1695}
1696# tell'em what is happening
1697proc pleasewait {{message {}}} {
1698    catch {destroy .msg}
1699    toplevel .msg
1700    wm transient .msg [winfo toplevel .]
1701    pack [frame .msg.f -bd 4 -relief groove]
1702    pack [message .msg.f.m -text "Please wait $message"]
1703    wm withdraw .msg
1704    update idletasks
1705    # place the message on top of the main window
1706    set x [expr [winfo x .] + [winfo width .]/2 - \
1707            [winfo reqwidth .msg]/2 - [winfo vrootx .]]
1708    if {$x < 0} {set x 0}
1709    set y [expr [winfo y .] + [winfo height .]/2 - \
1710            [winfo reqheight .msg]/2 - [winfo vrooty .]]
1711    if {$y < 0} {set y 0}
1712    wm geom .msg +$x+$y
1713    wm deiconify .msg
1714    focus .msg
1715    grab .msg
1716    update
1717}
1718# clear the message
1719proc donewait {} {
1720    catch {destroy .msg}
1721}
Note: See TracBrowser for help on using the repository browser.