source: trunk/gsascmds.tcl @ 130

Last change on this file since 130 was 130, checked in by toby, 14 years ago

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