source: trunk/gsascmds.tcl @ 98

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

# on 1999/07/22 20:07:37, toby did:
Fix resize of ShowBigMessage?
  • Property rcs:author set to toby
  • Property rcs:date set to 1999/07/22 20:07:37
  • Property rcs:lines set to +2 -2
  • Property rcs:rev set to 1.13
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 41.5 KB
Line 
1# $Id: gsascmds.tcl 98 2009-12-04 23:00:22Z 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) {
258        catch {unset total}
259        foreach atom $expmap(atomlist_$phase) {
260            set type [atominfo $phase $atom type]
261            set mult [atominfo $phase $atom mult]
262            if [catch {set total($type)}] {
263                set total($type) [expr \
264                        $mult * [atominfo $phase $atom frac]]
265            } else {
266                set total($type) [expr $total($type) + \
267                        $mult * [atominfo $phase $atom frac]]
268            }
269            if {$mult > $Z} {set Z $mult}
270        }
271    }
272   
273    append text "Unit cell contents\n"
274    foreach phase $expmap(phaselist) {
275        append text "  Phase $phase\t"
276        foreach type [lsort [array names total]] {
277            append text "   $type[format %8.3f $total($type)]"
278        }
279        append text "\n"
280    }
281   
282    append text "\n\nAsymmetric Unit contents\n"
283    foreach phase $expmap(phaselist) {
284        append text "  Phase $phase (Z=$Z)\t"
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) {
325        pack [button .export.ps.$num -text $num \
326                -command "SetExportPhase $num"] -side left
327    }
328    pack [frame .export.sg] -side top
329    pack [label .export.sg.1 -text "Space Group: "] -side left
330    pack [entry .export.sg.2 -textvariable expgui(export_sg) -width 8] -side left
331    pack [checkbutton .export.sg.3 -variable expgui(export_orig) -text "Origin 2"] -side left
332    pack [frame .export.but] -side top
333    if {[llength $expmap(phaselist)] > 0} {
334        pack [button .export.but.1 -text Write -command writextl] -side left
335        SetExportPhase [lindex $expmap(phaselist) 0]
336    }
337    pack [button .export.but.2 -text Quit -command "destroy .export"] -side left
338}
339
340proc SetExportPhase {phase} {
341    global expmap expgui
342    foreach n $expmap(phaselist) {
343        if {$n == $phase} {
344            .export.ps.$n config -relief sunken
345        } else { 
346            .export.ps.$n config -relief raised
347        }
348    }
349    set expgui(export_phase) $phase
350    # remove spaces from space group
351    set spacegroup [phaseinfo $phase spacegroup]
352    if {[string toupper [string range $spacegroup end end]] == "R"} {
353        set spacegroup [string range $spacegroup 0 \
354                [expr [string length $spacegroup]-2]] 
355    }
356    regsub -all " " $spacegroup "" expgui(export_sg)   
357}
358
359
360proc writextl {} {
361    global expgui expmap
362    if ![catch {
363        set phase $expgui(export_phase)
364        set origin $expgui(export_orig)
365        set spsymbol $expgui(export_sg)
366    } errmsg] {
367        set errmsg {}
368        if {$phase == ""} {
369            set errmsg "Error: invalid phase number $phase"
370        } elseif {$spsymbol == ""} {
371            set errmsg "Error: invalid Space Group: $spsymbol"
372        }
373    }
374    if {$errmsg != ""} {
375        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
376        return
377    }
378
379    if [catch {
380        set filnam [file rootname $expgui(expfile)]_${phase}.xtl
381        set spacegroup [phaseinfo $phase spacegroup]
382        set fp [open $filnam w]
383        puts $fp "TITLE from $expgui(expfile)"
384        puts $fp "TITLE history [string trim [lindex [exphistory last] 1]]"
385        puts $fp "TITLE phase [phaseinfo $phase name]"
386        puts $fp "CELL"
387        puts $fp "  [phaseinfo $phase a] [phaseinfo $phase b] [phaseinfo $phase c] [phaseinfo $phase alpha] [phaseinfo $phase beta] [phaseinfo $phase gamma]"
388       
389        puts $fp "Symmetry Label $spsymbol"
390        set rhomb 0
391        if {[string toupper [string range $spacegroup end end]] == "R"} {
392            set rhomb 1
393        }
394        if $origin {
395            puts $fp "Symmetry Qualifier origin_2"
396        }
397        if $rhomb {
398            puts $fp "Symmetry Qualifier rhombohedral"
399        }
400       
401        # are there anisotropic atoms?
402        set aniso 0
403        foreach atom $expmap(atomlist_$phase) {
404            if {[atominfo $phase $atom temptype] == "A"} {set aniso 1}
405        }
406        puts $fp "ATOMS"
407        if $aniso {
408            puts $fp "NAME       X          Y          Z    OCCUP U11 U22 U33 U12 U13 U23"
409            foreach atom $expmap(atomlist_$phase) {
410                set label [atominfo $phase $atom label]
411                # remove () characters
412                if {[atominfo $phase $atom temptype] == "A"} {
413                    puts $fp "$label [atominfo $phase $atom x] \
414                            [atominfo $phase $atom y] [atominfo $phase $atom z] \
415                            [atominfo $phase $atom frac] \
416                            [atominfo $phase $atom U11] \
417                            [atominfo $phase $atom U22] \
418                            [atominfo $phase $atom U33] \
419                            [atominfo $phase $atom U12] \
420                            [atominfo $phase $atom U13] \
421                            [atominfo $phase $atom U23]"
422                } else {
423                    puts $fp "$label [atominfo $phase $atom x] \
424                            [atominfo $phase $atom y] [atominfo $phase $atom z] \
425                            [atominfo $phase $atom frac] \
426                            [atominfo $phase $atom Uiso] \
427                            [atominfo $phase $atom Uiso] \
428                            [atominfo $phase $atom Uiso] \
429                            0 0 0 "
430                }
431            }
432        } else {
433            puts $fp "NAME       X          Y          Z    UISO      OCCUP"
434            foreach atom $expmap(atomlist_$phase) {
435                set label [atominfo $phase $atom label]
436                # remove () characters
437                regsub -all "\[()\]" $label "" label
438                puts $fp "$label [atominfo $phase $atom x] \
439                        [atominfo $phase $atom y] [atominfo $phase $atom z] \
440                        [atominfo $phase $atom Uiso]  [atominfo $phase $atom frac]"
441            }
442        }
443    } errmsg] {
444        catch {close $fp}
445        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
446    } else {
447        catch {close $fp}
448        tk_dialog .ok "Done" \
449                "File [file tail $filnam] written in directory [file dirname $filnam]" \
450                warning 0 "OK"
451    }
452    if {[llength $expmap(phaselist)] == 1} {destroy .export}
453}
454
455
456# convert a file
457proc convfile {} {
458    global tcl_platform
459    if {$tcl_platform(platform) == "windows"} {
460        convwin
461    } else {
462        convunix
463    }
464}
465
466# file conversions for UNIX (convstod convdtos)
467proc convunix {} {
468    global expgui infile outfile
469    set frm .file
470    catch {destroy $frm}
471    toplevel $frm
472    wm title $frm "Convert File"
473
474    pack [frame [set frm0 $frm.0] -bd 2 -relief groove] \
475            -padx 3 -pady 3 -side top -fill x
476    pack [frame $frm.mid] -side top
477    pack [frame [set frmA $frm.mid.1] -bd 2 -relief groove] \
478            -padx 3 -pady 3 -side left
479    pack [label $frmA.0 -text "Select an input file"] -side top -anchor center
480    pack [frame [set frmB $frm.mid.2] -bd 2 -relief groove] \
481            -padx 3 -pady 3 -side left
482    pack [label $frmB.0 -text "Enter an output file"] -side top -anchor center
483    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side top
484
485    pack [label $frm0.1 -text "Convert to:"] -side top -anchor center
486    pack [frame $frm0.2] -side top -anchor center
487    pack [radiobutton $frm0.2.d -text "direct access" -value convstod \
488            -command setoutfile \
489            -variable outfile(type)] -side left -anchor center
490    pack [radiobutton $frm0.2.s -text "sequential" -value convdtos \
491            -command setoutfile \
492            -variable outfile(type)] -side right -anchor center
493    set outfile(type) ""
494
495    pack [button $frmC.b -text Convert -command "valid_conv_unix"] -side left
496    pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side left
497
498   
499    unixcnvbox $frmA infile 1 
500    unixcnvbox $frmB outfile 0 
501    set infile(done) 0
502    bind $frm <Return> "valid_conv_unix"
503    # force the window to stay on top
504    putontop $frm
505    focus $frmC.q 
506    update
507    tkwait variable infile(done)
508    catch {focus $oldFocus}
509    if {$oldGrab != ""} {
510        if {$grabStatus == "global"} {
511            grab -global $oldGrab
512        } else {
513            grab $oldGrab
514        }
515    }
516    destroy $frm
517    afterputontop
518}
519
520# validate the files and make the conversion -- unix
521proc valid_conv_unix {} {
522    global infile outfile expgui
523    set error {}
524    if {$outfile(type) == "convstod" || $outfile(type) == "convdtos"} {
525        set convtype $outfile(type)
526    } else {
527        append error "You must specify a conversion method: to direct access or to sequential.\n"
528    }
529    if {$infile(name) == ""} {
530        append error "You must specify an input file to convert.\n"
531    }
532    if {$outfile(name) == ""} {
533        append error "You must specify an output file name for the converted file.\n"
534    }
535    if {$error != ""} {
536        tk_dialog .warn Notify $error warning 0 OK
537        return
538    }
539
540    if {$infile(name) == $outfile(name)} {
541        tk_dialog .warn Notify "Sorry, filenames must differ" warning 0 OK
542        return
543    }
544    if ![file exists [file join $infile(dir) $infile(name)]] {
545        tk_dialog .warn Notify \
546                "Sorry, file $infile(name) not found in $infile(dir)" warning 0 OK
547        return
548    }
549    if [file exists [file join $outfile(dir) $outfile(name)]] {
550        if [tk_dialog .warn Notify \
551                "Warning: file $outfile(name) exists in $outfile(dir). OK to overwrite?" \
552                warning 0 OK No] return
553    }
554    if [catch {
555        exec [file join $expgui(gsasexe) $convtype] < \
556                [file join $infile(dir) $infile(name)] > \
557                [file join $outfile(dir) $outfile(name)]
558    } errmsg] {
559        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
560    } else {
561        if [tk_dialog .converted Notify \
562                "File converted. Convert more files?" \
563                ""  0 Yes No] {set infile(done) 1}
564    }
565}
566
567# create a file box for UNIX conversions
568proc unixcnvbox {bx filvar diropt} {
569    global ${filvar} expgui
570    pack [frame $bx.top] -side top
571    pack [label $bx.top.a -text "Directory" ] -side left
572    set ${filvar}(FileDirButtonMenu) [tk_optionMenu $bx.top.d ${filvar}(dir) [pwd] ]
573    pack $bx.top.d -side left
574    set ${filvar}(dir) [pwd]
575
576#    pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top
577#    set ${filvar}(dir) [pwd]
578
579    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
580    listbox $bx.a.files -relief raised -bd 2 -yscrollcommand "$bx.a.scroll set" \
581            -height 15 -width 0
582    scrollbar $bx.a.scroll -command "$bx.a.files yview"
583    unixFilChoose $bx $bx.a.files $filvar $diropt
584    if {$filvar == "infile"} {
585        bind $bx.a.files <ButtonRelease-1> \
586                "unixFilChoose $bx $bx.a.files $filvar $diropt; setoutfile"
587    } else {
588        bind $bx.a.files <ButtonRelease-1> \
589                "unixFilChoose $bx $bx.a.files $filvar $diropt"
590    }
591    pack $bx.a.scroll -side left -fill y
592    pack $bx.a.files -side left -fill both -expand yes
593    pack [entry $bx.c -textvariable ${filvar}(name)] -side top
594}
595
596# select a file or directory, also called when box is created to fill it
597proc unixFilChoose {frm box filvar {dironly 1}} {
598    global $filvar
599    set select [$box curselection]
600    if {$select == ""} {
601        set file .
602    } else {
603        set file [string trim [$box get $select]]
604    }
605    if [file isdirectory [file join [set ${filvar}(dir)] $file]] {
606        if {$file == ".."} {
607            set ${filvar}(dir) [file dirname [set ${filvar}(dir)] ]
608        } elseif {$file != "."} {
609            set ${filvar}(dir) [file join [set ${filvar}(dir)] $file]
610        }
611        [set ${filvar}(FileDirButtonMenu)] delete 0 end
612        set list ""
613        set dir ""
614        foreach subdir [file split [set ${filvar}(dir)]] {
615            set dir [file join $dir $subdir]
616            lappend list $dir
617        }
618        foreach path $list {
619            [set ${filvar}(FileDirButtonMenu)] add command -label $path \
620                -command "[list set ${filvar}(dir) $path]; \
621                unixFilChoose $frm $box $filvar $dironly"
622        }
623        set ${filvar}(name) {}
624        $box delete 0 end
625        $box insert end {..   }
626        foreach file [lsort [glob -nocomplain \
627                [file join [set ${filvar}(dir)] *] ] ] {
628            if {[file isdirectory $file]} {
629                # is this / needed here? Does it cause a problem in MacGSAS?
630                $box insert end [file tail $file]/
631            } elseif {$dironly == 1} {
632                $box insert end [file tail $file]
633            } elseif {$dironly == 2 && [file extension $file] == ".EXP"} {
634                $box insert end [file tail $file]
635            }
636        }
637        return
638    }
639    set ${filvar}(name) [file tail $file]
640}
641
642# set new file name from old -- used for convunix
643proc setoutfile {} {
644    global infile outfile
645    if {$outfile(type) == "convstod"} {
646        set lfile [string toupper $infile(name)]
647    } elseif {$outfile(type) == "convdtos"} {
648        set lfile [string tolower $infile(name)]
649    } else {
650        set lfile ""
651    }
652    if {$infile(name) == $lfile} {
653        set outfile(name) {}
654    } else {
655        set outfile(name) $lfile
656    }
657}
658
659#------------------------------------------------------------------------------
660# file conversions for Windows
661#------------------------------------------------------------------------------
662proc convwin {} {
663    global expgui
664    set frm .file
665    catch {destroy $frm}
666    toplevel $frm
667    wm title $frm "Convert File"
668    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
669    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
670    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
671            -side top
672    pack [button $frmC.q -text Quit -command "destroy $frm"] -side top
673    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
674    winfilebox $frm
675    bind $frm <Return> "ValidWinCnv $frm"
676
677    # force the window to stay on top
678    putontop $frm
679    focus $frmC.q 
680    tkwait window $frm
681    afterputontop
682}
683
684# validate the files and make the conversion
685proc ValidWinCnv {frm} {
686    global expgui
687    # change backslashes to something sensible
688    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
689    # allow entry of D: for D:/ and D:TEST for d:/TEST
690    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
691            [string first :/ $expgui(FileMenuCnvName)] == -1} {
692        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
693    }
694    if {$expgui(FileMenuCnvName) == "<Parent>"} {
695        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
696        ChooseWinCnv $frm
697        return
698    } elseif [file isdirectory \
699            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
700        if {$expgui(FileMenuCnvName) != "."} {
701            set expgui(FileMenuDir) \
702                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
703        }
704        ChooseWinCnv $frm
705        return
706    }
707 
708    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
709    if ![file exists $file] {
710        tk_dialog .warn "Convert Error" \
711                "File $file does not exist" question 0 "OK"
712        return
713    }
714
715    set tmpname "[file join [file dirname $file] tempfile.xxx]"
716    set oldname "[file rootname $file].org"
717    if [file exists $oldname] {
718        set ans [tk_dialog .warn "OK to overwrite?" \
719                "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" question 0 \
720                "Yes" "No"]
721        if $ans return
722        catch {file delete $oldname}
723    }
724
725    if [catch {
726        set in [open $file r]
727        set out [open $tmpname w]
728        set len [gets $in line]
729        if {$len > 160} {
730            # this is a UNIX file. Hope there are no control characters
731            set i 0
732            set j 79
733            while {$j < $len} {
734                puts $out [string range $line $i $j]
735                incr i 80
736                incr j 80
737            }
738        } else {
739            while {$len >= 0} {
740                append line "                                        "
741                append line "                                        "
742                set line [string range $line 0 79]
743                puts $out $line
744                set len [gets $in line]
745            }
746        }
747        close $in
748        close $out
749        file rename $file $oldname
750        file rename $tmpname $file
751    } errmsg] {
752        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
753    } else {
754        if [tk_dialog .converted Notify \
755                "File [file tail $file] converted. (Original saved as [file tail $oldname]).\n\n Convert more files?" \
756                ""  0 Yes No] {destroy $frm}
757    }
758}
759
760# create a file box
761proc winfilebox {frm} {
762    global expgui
763    set bx $frm.1
764    pack [frame $bx.top] -side top
765    pack [label $bx.top.a -text "Directory" ] -side left
766    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
767    pack $bx.top.d -side left
768    set expgui(FileMenuDir) [pwd]
769    # the icon below is from tk8.0/tkfbox.tcl
770    set upfolder [image create bitmap -data {
771#define updir_width 28
772#define updir_height 16
773static char updir_bits[] = {
774   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
775   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
776   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
777   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
778   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
779   0xf0, 0xff, 0xff, 0x01};}]
780
781    pack [button $bx.top.b -image $upfolder \
782            -command "updir; ChooseWinCnv $frm" ]
783    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
784    listbox $bx.a.files -relief raised -bd 2 \
785            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
786            -height 15 -width 0
787    listbox $bx.a.dates -relief raised -bd 2 \
788            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
789            -height 15 -width 0 -takefocus 0
790    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
791    ChooseWinCnv $frm
792    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
793    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
794    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
795    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
796    pack $bx.a.scroll -side left -fill y
797    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
798    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
799}
800
801# set the box or file in the selection window
802proc ReleaseWinCnv {frm} {
803    global expgui
804    set files $frm.1.a.files
805    set dates $frm.1.a.dates
806    set select [$files curselection]
807    if {$select == ""} {
808        set select [$dates curselection]
809    }
810    if {$select == ""} {
811        set expgui(FileMenuCnvName) ""
812    } else {
813        set expgui(FileMenuCnvName) [string trim [$files get $select]]
814    }
815    if {$expgui(FileMenuCnvName) == "<Parent>"} {
816        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
817        ChooseWinCnv $frm
818    } elseif [file isdirectory \
819            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
820        if {$expgui(FileMenuCnvName) != "."} {
821            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
822            ChooseWinCnv $frm
823        }
824    }
825    return
826}
827
828# select a file or directory -- called on double click
829proc SelectWinCnv {frm} {
830    global expgui
831    set files $frm.1.a.files
832    set dates $frm.1.a.dates
833    set select [$files curselection]
834    if {$select == ""} {
835        set select [$dates curselection]
836    }
837    if {$select == ""} {
838        set file .
839    } else {
840        set file [string trim [$files get $select]]
841    }
842    if {$file == "<Parent>"} {
843        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
844        ChooseWinCnv $frm
845    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
846        if {$file != "."} {
847            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
848            ChooseWinCnv $frm
849        }
850    } else {
851        set expgui(FileMenuCnvName) [file tail $file]
852        ValidWinCnv $frm
853    }
854}
855
856# fill the files & dates & Directory selection box with current directory,
857# also called when box is created to fill it
858proc ChooseWinCnv {frm} {
859    global expgui
860    set files $frm.1.a.files
861    set dates $frm.1.a.dates
862    set expgui(FileMenuCnvName) {}
863    $files delete 0 end
864    $dates delete 0 end
865    $files insert end {<Parent>}
866    $dates insert end {(Directory)}
867    set filelist [glob -nocomplain \
868            [file join [set expgui(FileMenuDir)] *] ]
869    foreach file [lsort -dictionary $filelist] {
870        if {[file isdirectory $file]} {
871            $files insert end [file tail $file]
872            $dates insert end {(Directory)}
873        }
874    }
875    foreach file [lsort -dictionary $filelist] {
876        if {![file isdirectory $file]} {
877            set modified [clock format [file mtime $file] -format "%T %D"]
878            $files insert end [file tail $file]
879            $dates insert end $modified
880        }
881    }
882    $expgui(FileDirButtonMenu)  delete 0 end
883    set list ""
884    set dir ""
885    foreach subdir [file split [set expgui(FileMenuDir)]] {
886        set dir [file join $dir $subdir]
887        lappend list $dir
888    }
889    foreach path $list {
890        $expgui(FileDirButtonMenu) add command -label $path \
891                -command "[list set expgui(FileMenuDir) $path]; \
892                ChooseWinCnv $frm"
893    }
894    return
895}
896
897#------------------------------------------------------------------------------
898# set options for liveplot
899proc liveplotopt {} {
900    global liveplot expmap
901    set frm .file
902    catch {destroy $frm}
903    toplevel $frm
904    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
905    set last [lindex [lsort -integer $expmap(powderlist)] end]
906    if {$last == ""} {set last 1}
907    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
908            -length  150 -orient horizontal -variable liveplot(hst)] -side top
909    pack [checkbutton $frmA.2 -text {include plot legend}\
910            -variable liveplot(legend)] -side top
911    pack [button $frm.2 -text OK \
912            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
913            ] -side top
914    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
915   
916    # force the window to stay on top
917    putontop $frm 
918    focus $frm.2
919    tkwait window $frm
920    afterputontop
921}
922
923#------------------------------------------------------------------------------
924# get an experiment file name
925#------------------------------------------------------------------------------
926proc getExpFileName {mode} {
927    global expgui
928    set frm .file
929    catch {destroy $frm}
930    toplevel $frm
931    wm title $frm "Experiment file"
932    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
933    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
934    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
935    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
936            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
937    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
938            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
939    pack [button $frmC.b -text Read \
940            -command "valid_exp_file $frmA $mode"] -side top
941    if {$mode == "new"} {
942        $frmC.b config -text Save
943    }
944    pack [button $frmC.q -text Quit \
945            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side top
946    bind $frm <Return> "$frmC.b invoke"
947
948    if {$mode == "new"} {
949        pack [label $frmA.0 -text "Enter an experiment file to create"] \
950                -side top -anchor center
951    } else {
952        pack [label $frmA.0 -text "Select an experiment file to read"] \
953                -side top -anchor center
954    }
955    expfilebox $frmA $mode
956    # force the window to stay on top
957    putontop $frm
958    focus $frmC.b
959    tkwait window $frm
960    afterputontop
961    if {$expgui(FileMenuEXPNAM) == ""} return
962    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
963}
964
965# validation routine
966proc valid_exp_file {frm mode} {
967    global expgui tcl_platform
968    # windows fixes
969    if {$tcl_platform(platform) == "windows"} {
970        # change backslashes to something sensible
971        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
972        # allow entry of D: for D:/ and D:TEST for d:/TEST
973        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
974                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
975            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
976        }
977    }
978    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
979        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
980        ChooseExpFil $frm
981        return
982    } elseif [file isdirectory \
983            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
984        if {$expgui(FileMenuEXPNAM) != "."} {
985            set expgui(FileMenuDir) \
986                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
987        }
988        ChooseExpFil $frm
989        return
990    }
991    set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
992    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
993        append expgui(FileMenuEXPNAM) ".EXP"
994    }
995    if {[file extension $expgui(FileMenuEXPNAM)] != ".EXP"} {
996        tk_dialog .expFileErrorMsg "File Open Error" \
997            "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
998            error 0 OK
999        return
1000    }
1001    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1002    if {$mode == "new" && [file exists $file]} {
1003        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
1004            "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" question 0 \
1005             "Select other name" "Overwrite"]
1006        if $ans {destroy .file}
1007        return
1008    }
1009    if {$mode == "old" && ![file exists $file]} {
1010        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
1011            "File [file tail $file] does not exist in [file dirname $file]. OK to create?" question 0 \
1012             "Select other name" "Create"]
1013        if $ans {destroy .file}
1014        return
1015    }
1016    destroy .file
1017}
1018
1019proc updir {} {
1020    global expgui
1021    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1022}
1023
1024# create a file box
1025proc expfilebox {bx mode} {
1026    global expgui
1027    pack [frame $bx.top] -side top
1028    pack [label $bx.top.a -text "Directory" ] -side left
1029    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1030    pack $bx.top.d -side left
1031    set expgui(FileMenuDir) [pwd]
1032    # the icon below is from tk8.0/tkfbox.tcl
1033    set upfolder [image create bitmap -data {
1034#define updir_width 28
1035#define updir_height 16
1036static char updir_bits[] = {
1037   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1038   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1039   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1040   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1041   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1042   0xf0, 0xff, 0xff, 0x01};}]
1043
1044    pack [button $bx.top.b -image $upfolder \
1045            -command "updir; ChooseExpFil $bx" ]
1046    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1047    listbox $bx.a.files -relief raised -bd 2 \
1048            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
1049            -height 15 -width 0
1050    listbox $bx.a.dates -relief raised -bd 2 \
1051            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
1052            -height 15 -width 0 -takefocus 0
1053    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1054    ChooseExpFil $bx
1055    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1056    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1057    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1058    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1059    pack $bx.a.scroll -side left -fill y
1060    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1061    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1062}
1063proc sync2boxes {master slave scroll args} {
1064    $slave yview moveto [lindex [$master yview] 0]
1065    eval $scroll set $args
1066}
1067proc move2boxesY {boxlist args} {
1068    foreach listbox $boxlist { 
1069        eval $listbox yview $args
1070    }
1071}
1072
1073# set the box or file in the selection window
1074proc ReleaseExpFil {frm} {
1075    global expgui
1076    set files $frm.a.files
1077    set dates $frm.a.dates
1078    set select [$files curselection]
1079    if {$select == ""} {
1080        set select [$dates curselection]
1081    }
1082    if {$select == ""} {
1083        set expgui(FileMenuEXPNAM) ""
1084    } else {
1085        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
1086    }
1087    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1088        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1089        ChooseExpFil $frm
1090    } elseif [file isdirectory \
1091            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
1092        if {$expgui(FileMenuEXPNAM) != "."} {
1093            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1094            ChooseExpFil $frm
1095        }
1096    }
1097    return
1098}
1099
1100# select a file or directory -- called on double click
1101proc SelectExpFil {frm mode} {
1102    global expgui
1103    set files $frm.a.files
1104    set dates $frm.a.dates
1105    set select [$files curselection]
1106    if {$select == ""} {
1107        set select [$dates curselection]
1108    }
1109    if {$select == ""} {
1110        set file .
1111    } else {
1112        set file [string trim [$files get $select]]
1113    }
1114    if {$file == "<Parent>"} {
1115        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1116        ChooseExpFil $frm
1117    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1118        if {$file != "."} {
1119            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1120            ChooseExpFil $frm
1121        }
1122    } else {
1123        set expgui(FileMenuEXPNAM) [file tail $file]
1124        valid_exp_file $frm $mode
1125    }
1126}
1127
1128# fill the files & dates & Directory selection box with current directory,
1129# also called when box is created to fill it
1130proc ChooseExpFil {frm} {
1131    global expgui
1132    set files $frm.a.files
1133    set dates $frm.a.dates
1134    set expgui(FileMenuEXPNAM) {}
1135    $files delete 0 end
1136    $dates delete 0 end
1137    $files insert end {<Parent>}
1138    $dates insert end {(Directory)}
1139    set filelist [glob -nocomplain \
1140            [file join [set expgui(FileMenuDir)] *] ]
1141    foreach file [lsort -dictionary $filelist] {
1142        if {[file isdirectory $file]} {
1143            $files insert end [file tail $file]
1144            $dates insert end {(Directory)}
1145        }
1146    }
1147    set pairlist {}
1148    foreach file [lsort -dictionary $filelist] {
1149        if {![file isdirectory $file]  && \
1150                [string toupper [file extension $file]] == ".EXP"} {
1151            set modified [file mtime $file]
1152            lappend pairlist [list $file $modified]
1153        }
1154    }
1155    if {$expgui(filesort) == 0} {
1156        foreach pair [lsort -index 1 -integer $pairlist] {
1157            set file [lindex $pair 0]
1158            set modified [clock format [lindex $pair 1] -format "%T %D"]
1159            $files insert end [file tail $file]
1160            $dates insert end $modified
1161        }
1162    } else {
1163        foreach pair [lsort -index 0 $pairlist] {
1164            set file [lindex $pair 0]
1165            set modified [clock format [lindex $pair 1] -format "%T %D"]
1166            $files insert end [file tail $file]
1167            $dates insert end $modified
1168        }
1169    }
1170    $expgui(FileDirButtonMenu)  delete 0 end
1171    set list ""
1172    set dir ""
1173    foreach subdir [file split [set expgui(FileMenuDir)]] {
1174        set dir [file join $dir $subdir]
1175        lappend list $dir
1176    }
1177    foreach path $list {
1178        $expgui(FileDirButtonMenu) add command -label $path \
1179                -command "[list set expgui(FileMenuDir) $path]; \
1180                ChooseExpFil $frm"
1181    }
1182    # highlight the current experiment -- if present
1183    for {set i 0} {$i < [$files size]} {incr i} {
1184        set file [$files get $i]
1185        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
1186            $files selection set $i
1187        }
1188    }
1189    return
1190}
1191
1192proc putontop {w} {
1193    # center window $w above its parent and make it stay on top
1194    set wp [winfo parent $w]
1195    wm transient $w [winfo toplevel $wp]
1196    wm withdraw $w
1197    update idletasks
1198    # center the new window in the middle of the parent
1199    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
1200            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
1201    if {$x < 0} {set x 0}
1202    set xborder 10
1203    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
1204        incr x [expr \
1205                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
1206    }
1207    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
1208            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
1209    if {$y < 0} {set y 0}
1210    set yborder 25
1211    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
1212        incr y [expr \
1213                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
1214    }
1215    wm geom $w +$x+$y
1216    wm deiconify $w
1217
1218    global makenew
1219    set makenew(OldFocus) [focus]
1220    set makenew(OldGrab) [grab current $w]
1221    if {$makenew(OldGrab) != ""} {
1222        set makenew(GrabStatus) [grab status $makenew(OldGrab)]
1223    }
1224    grab $w
1225}
1226
1227proc afterputontop {} {
1228    # restore focus
1229    global makenew
1230    catch {focus $makenew(OldFocus)}
1231    if {$makenew(OldGrab) != ""} {
1232        if {$makenew(GrabStatus) == "global"} {
1233            grab -global $makenew(OldGrab)
1234        } else {
1235            grab $makenew(OldGrab)
1236        }
1237    }
1238}
1239
1240proc ShowBigMessage {win labeltext msg "optionlist OK"} {
1241    catch {destroy $win}
1242    toplevel $win
1243
1244    # grab focus, etc.
1245    pack [label $win.l1 -text $labeltext] -side top
1246    pack [frame $win.f1] -side top -expand yes -fill both
1247    grid [text  $win.f1.t  \
1248            -height 20 -width 55  -wrap none -font Courier \
1249            -xscrollcommand "$win.f1.bscr set" \
1250            -yscrollcommand "$win.f1.rscr set" \
1251            ] -row 1 -column 0 -sticky news
1252    grid [scrollbar $win.f1.bscr -orient horizontal \
1253            -command "$win.f1.t xview" \
1254            ] -row 2 -column 0 -sticky ew
1255    grid [scrollbar $win.f1.rscr  -command "$win.f1.t yview" \
1256            ] -row 1 -column 1 -sticky ns
1257    # give extra space to the text box
1258    grid columnconfigure $win.f1 0 -weight 1
1259    grid rowconfigure $win.f1 1 -weight 1
1260    $win.f1.t insert end $msg
1261
1262    global makenew
1263    set makenew(result) 0
1264    bind $win <Return> "destroy $win"
1265    bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
1266    bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
1267    bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
1268    bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
1269    bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
1270    bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
1271    bind $win <KeyPress-Home> "$win.f1.t yview 0"
1272    bind $win <KeyPress-End> "$win.f1.t yview end"
1273    set i 0
1274    foreach item $optionlist {
1275        pack [button $win.q[incr i] \
1276                -command "set makenew(result) $i; destroy $win" -text $item] -side left
1277    }
1278    putontop $win
1279    tkwait window $win
1280
1281    # fix focus...
1282    afterputontop
1283    return $makenew(result)
1284}
Note: See TracBrowser for help on using the repository browser.