source: trunk/gsascmds.tcl @ 112

Last change on this file since 112 was 102, checked in by toby, 16 years ago

# on 1999/09/09 19:08:11, toby did:
hide grab fail error messages
,
  • Property rcs:author set to toby
  • Property rcs:date set to 1999/09/09 19:08:11
  • Property rcs:lines set to +13 -17
  • Property rcs:rev set to 1.14
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 41.3 KB
Line 
1# $Id: gsascmds.tcl 102 2009-12-04 23:00:26Z 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    destroy $frm
509    afterputontop
510}
511
512# validate the files and make the conversion -- unix
513proc valid_conv_unix {} {
514    global infile outfile expgui
515    set error {}
516    if {$outfile(type) == "convstod" || $outfile(type) == "convdtos"} {
517        set convtype $outfile(type)
518    } else {
519        append error "You must specify a conversion method: to direct access or to sequential.\n"
520    }
521    if {$infile(name) == ""} {
522        append error "You must specify an input file to convert.\n"
523    }
524    if {$outfile(name) == ""} {
525        append error "You must specify an output file name for the converted file.\n"
526    }
527    if {$error != ""} {
528        tk_dialog .warn Notify $error warning 0 OK
529        return
530    }
531
532    if {$infile(name) == $outfile(name)} {
533        tk_dialog .warn Notify "Sorry, filenames must differ" warning 0 OK
534        return
535    }
536    if ![file exists [file join $infile(dir) $infile(name)]] {
537        tk_dialog .warn Notify \
538                "Sorry, file $infile(name) not found in $infile(dir)" warning 0 OK
539        return
540    }
541    if [file exists [file join $outfile(dir) $outfile(name)]] {
542        if [tk_dialog .warn Notify \
543                "Warning: file $outfile(name) exists in $outfile(dir). OK to overwrite?" \
544                warning 0 OK No] return
545    }
546    if [catch {
547        exec [file join $expgui(gsasexe) $convtype] < \
548                [file join $infile(dir) $infile(name)] > \
549                [file join $outfile(dir) $outfile(name)]
550    } errmsg] {
551        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
552    } else {
553        if [tk_dialog .converted Notify \
554                "File converted. Convert more files?" \
555                ""  0 Yes No] {set infile(done) 1}
556    }
557}
558
559# create a file box for UNIX conversions
560proc unixcnvbox {bx filvar diropt} {
561    global ${filvar} expgui
562    pack [frame $bx.top] -side top
563    pack [label $bx.top.a -text "Directory" ] -side left
564    set ${filvar}(FileDirButtonMenu) [tk_optionMenu $bx.top.d ${filvar}(dir) [pwd] ]
565    pack $bx.top.d -side left
566    set ${filvar}(dir) [pwd]
567
568#    pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top
569#    set ${filvar}(dir) [pwd]
570
571    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
572    listbox $bx.a.files -relief raised -bd 2 -yscrollcommand "$bx.a.scroll set" \
573            -height 15 -width 0
574    scrollbar $bx.a.scroll -command "$bx.a.files yview"
575    unixFilChoose $bx $bx.a.files $filvar $diropt
576    if {$filvar == "infile"} {
577        bind $bx.a.files <ButtonRelease-1> \
578                "unixFilChoose $bx $bx.a.files $filvar $diropt; setoutfile"
579    } else {
580        bind $bx.a.files <ButtonRelease-1> \
581                "unixFilChoose $bx $bx.a.files $filvar $diropt"
582    }
583    pack $bx.a.scroll -side left -fill y
584    pack $bx.a.files -side left -fill both -expand yes
585    pack [entry $bx.c -textvariable ${filvar}(name)] -side top
586}
587
588# select a file or directory, also called when box is created to fill it
589proc unixFilChoose {frm box filvar {dironly 1}} {
590    global $filvar
591    set select [$box curselection]
592    if {$select == ""} {
593        set file .
594    } else {
595        set file [string trim [$box get $select]]
596    }
597    if [file isdirectory [file join [set ${filvar}(dir)] $file]] {
598        if {$file == ".."} {
599            set ${filvar}(dir) [file dirname [set ${filvar}(dir)] ]
600        } elseif {$file != "."} {
601            set ${filvar}(dir) [file join [set ${filvar}(dir)] $file]
602        }
603        [set ${filvar}(FileDirButtonMenu)] delete 0 end
604        set list ""
605        set dir ""
606        foreach subdir [file split [set ${filvar}(dir)]] {
607            set dir [file join $dir $subdir]
608            lappend list $dir
609        }
610        foreach path $list {
611            [set ${filvar}(FileDirButtonMenu)] add command -label $path \
612                -command "[list set ${filvar}(dir) $path]; \
613                unixFilChoose $frm $box $filvar $dironly"
614        }
615        set ${filvar}(name) {}
616        $box delete 0 end
617        $box insert end {..   }
618        foreach file [lsort [glob -nocomplain \
619                [file join [set ${filvar}(dir)] *] ] ] {
620            if {[file isdirectory $file]} {
621                # is this / needed here? Does it cause a problem in MacGSAS?
622                $box insert end [file tail $file]/
623            } elseif {$dironly == 1} {
624                $box insert end [file tail $file]
625            } elseif {$dironly == 2 && [file extension $file] == ".EXP"} {
626                $box insert end [file tail $file]
627            }
628        }
629        return
630    }
631    set ${filvar}(name) [file tail $file]
632}
633
634# set new file name from old -- used for convunix
635proc setoutfile {} {
636    global infile outfile
637    if {$outfile(type) == "convstod"} {
638        set lfile [string toupper $infile(name)]
639    } elseif {$outfile(type) == "convdtos"} {
640        set lfile [string tolower $infile(name)]
641    } else {
642        set lfile ""
643    }
644    if {$infile(name) == $lfile} {
645        set outfile(name) {}
646    } else {
647        set outfile(name) $lfile
648    }
649}
650
651#------------------------------------------------------------------------------
652# file conversions for Windows
653#------------------------------------------------------------------------------
654proc convwin {} {
655    global expgui
656    set frm .file
657    catch {destroy $frm}
658    toplevel $frm
659    wm title $frm "Convert File"
660    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
661    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
662    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
663            -side top
664    pack [button $frmC.q -text Quit -command "destroy $frm"] -side top
665    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
666    winfilebox $frm
667    bind $frm <Return> "ValidWinCnv $frm"
668
669    # force the window to stay on top
670    putontop $frm
671    focus $frmC.q 
672    tkwait window $frm
673    afterputontop
674}
675
676# validate the files and make the conversion
677proc ValidWinCnv {frm} {
678    global expgui
679    # change backslashes to something sensible
680    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
681    # allow entry of D: for D:/ and D:TEST for d:/TEST
682    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
683            [string first :/ $expgui(FileMenuCnvName)] == -1} {
684        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
685    }
686    if {$expgui(FileMenuCnvName) == "<Parent>"} {
687        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
688        ChooseWinCnv $frm
689        return
690    } elseif [file isdirectory \
691            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
692        if {$expgui(FileMenuCnvName) != "."} {
693            set expgui(FileMenuDir) \
694                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
695        }
696        ChooseWinCnv $frm
697        return
698    }
699 
700    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
701    if ![file exists $file] {
702        tk_dialog .warn "Convert Error" \
703                "File $file does not exist" question 0 "OK"
704        return
705    }
706
707    set tmpname "[file join [file dirname $file] tempfile.xxx]"
708    set oldname "[file rootname $file].org"
709    if [file exists $oldname] {
710        set ans [tk_dialog .warn "OK to overwrite?" \
711                "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" question 0 \
712                "Yes" "No"]
713        if $ans return
714        catch {file delete $oldname}
715    }
716
717    if [catch {
718        set in [open $file r]
719        set out [open $tmpname w]
720        set len [gets $in line]
721        if {$len > 160} {
722            # this is a UNIX file. Hope there are no control characters
723            set i 0
724            set j 79
725            while {$j < $len} {
726                puts $out [string range $line $i $j]
727                incr i 80
728                incr j 80
729            }
730        } else {
731            while {$len >= 0} {
732                append line "                                        "
733                append line "                                        "
734                set line [string range $line 0 79]
735                puts $out $line
736                set len [gets $in line]
737            }
738        }
739        close $in
740        close $out
741        file rename $file $oldname
742        file rename $tmpname $file
743    } errmsg] {
744        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
745    } else {
746        if [tk_dialog .converted Notify \
747                "File [file tail $file] converted. (Original saved as [file tail $oldname]).\n\n Convert more files?" \
748                ""  0 Yes No] {destroy $frm}
749    }
750}
751
752# create a file box
753proc winfilebox {frm} {
754    global expgui
755    set bx $frm.1
756    pack [frame $bx.top] -side top
757    pack [label $bx.top.a -text "Directory" ] -side left
758    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
759    pack $bx.top.d -side left
760    set expgui(FileMenuDir) [pwd]
761    # the icon below is from tk8.0/tkfbox.tcl
762    set upfolder [image create bitmap -data {
763#define updir_width 28
764#define updir_height 16
765static char updir_bits[] = {
766   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
767   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
768   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
769   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
770   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
771   0xf0, 0xff, 0xff, 0x01};}]
772
773    pack [button $bx.top.b -image $upfolder \
774            -command "updir; ChooseWinCnv $frm" ]
775    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
776    listbox $bx.a.files -relief raised -bd 2 \
777            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
778            -height 15 -width 0
779    listbox $bx.a.dates -relief raised -bd 2 \
780            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
781            -height 15 -width 0 -takefocus 0
782    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
783    ChooseWinCnv $frm
784    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
785    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
786    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
787    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
788    pack $bx.a.scroll -side left -fill y
789    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
790    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
791}
792
793# set the box or file in the selection window
794proc ReleaseWinCnv {frm} {
795    global expgui
796    set files $frm.1.a.files
797    set dates $frm.1.a.dates
798    set select [$files curselection]
799    if {$select == ""} {
800        set select [$dates curselection]
801    }
802    if {$select == ""} {
803        set expgui(FileMenuCnvName) ""
804    } else {
805        set expgui(FileMenuCnvName) [string trim [$files get $select]]
806    }
807    if {$expgui(FileMenuCnvName) == "<Parent>"} {
808        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
809        ChooseWinCnv $frm
810    } elseif [file isdirectory \
811            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
812        if {$expgui(FileMenuCnvName) != "."} {
813            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
814            ChooseWinCnv $frm
815        }
816    }
817    return
818}
819
820# select a file or directory -- called on double click
821proc SelectWinCnv {frm} {
822    global expgui
823    set files $frm.1.a.files
824    set dates $frm.1.a.dates
825    set select [$files curselection]
826    if {$select == ""} {
827        set select [$dates curselection]
828    }
829    if {$select == ""} {
830        set file .
831    } else {
832        set file [string trim [$files get $select]]
833    }
834    if {$file == "<Parent>"} {
835        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
836        ChooseWinCnv $frm
837    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
838        if {$file != "."} {
839            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
840            ChooseWinCnv $frm
841        }
842    } else {
843        set expgui(FileMenuCnvName) [file tail $file]
844        ValidWinCnv $frm
845    }
846}
847
848# fill the files & dates & Directory selection box with current directory,
849# also called when box is created to fill it
850proc ChooseWinCnv {frm} {
851    global expgui
852    set files $frm.1.a.files
853    set dates $frm.1.a.dates
854    set expgui(FileMenuCnvName) {}
855    $files delete 0 end
856    $dates delete 0 end
857    $files insert end {<Parent>}
858    $dates insert end {(Directory)}
859    set filelist [glob -nocomplain \
860            [file join [set expgui(FileMenuDir)] *] ]
861    foreach file [lsort -dictionary $filelist] {
862        if {[file isdirectory $file]} {
863            $files insert end [file tail $file]
864            $dates insert end {(Directory)}
865        }
866    }
867    foreach file [lsort -dictionary $filelist] {
868        if {![file isdirectory $file]} {
869            set modified [clock format [file mtime $file] -format "%T %D"]
870            $files insert end [file tail $file]
871            $dates insert end $modified
872        }
873    }
874    $expgui(FileDirButtonMenu)  delete 0 end
875    set list ""
876    set dir ""
877    foreach subdir [file split [set expgui(FileMenuDir)]] {
878        set dir [file join $dir $subdir]
879        lappend list $dir
880    }
881    foreach path $list {
882        $expgui(FileDirButtonMenu) add command -label $path \
883                -command "[list set expgui(FileMenuDir) $path]; \
884                ChooseWinCnv $frm"
885    }
886    return
887}
888
889#------------------------------------------------------------------------------
890# set options for liveplot
891proc liveplotopt {} {
892    global liveplot expmap
893    set frm .file
894    catch {destroy $frm}
895    toplevel $frm
896    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
897    set last [lindex [lsort -integer $expmap(powderlist)] end]
898    if {$last == ""} {set last 1}
899    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
900            -length  150 -orient horizontal -variable liveplot(hst)] -side top
901    pack [checkbutton $frmA.2 -text {include plot legend}\
902            -variable liveplot(legend)] -side top
903    pack [button $frm.2 -text OK \
904            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
905            ] -side top
906    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
907   
908    # force the window to stay on top
909    putontop $frm 
910    focus $frm.2
911    tkwait window $frm
912    afterputontop
913}
914
915#------------------------------------------------------------------------------
916# get an experiment file name
917#------------------------------------------------------------------------------
918proc getExpFileName {mode} {
919    global expgui
920    set frm .file
921    catch {destroy $frm}
922    toplevel $frm
923    wm title $frm "Experiment file"
924    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
925    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
926    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
927    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
928            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
929    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
930            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
931    pack [button $frmC.b -text Read \
932            -command "valid_exp_file $frmA $mode"] -side top
933    if {$mode == "new"} {
934        $frmC.b config -text Save
935    }
936    pack [button $frmC.q -text Quit \
937            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side top
938    bind $frm <Return> "$frmC.b invoke"
939
940    if {$mode == "new"} {
941        pack [label $frmA.0 -text "Enter an experiment file to create"] \
942                -side top -anchor center
943    } else {
944        pack [label $frmA.0 -text "Select an experiment file to read"] \
945                -side top -anchor center
946    }
947    expfilebox $frmA $mode
948    # force the window to stay on top
949    putontop $frm
950    focus $frmC.b
951    tkwait window $frm
952    afterputontop
953    if {$expgui(FileMenuEXPNAM) == ""} return
954    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
955}
956
957# validation routine
958proc valid_exp_file {frm mode} {
959    global expgui tcl_platform
960    # windows fixes
961    if {$tcl_platform(platform) == "windows"} {
962        # change backslashes to something sensible
963        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
964        # allow entry of D: for D:/ and D:TEST for d:/TEST
965        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
966                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
967            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
968        }
969    }
970    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
971        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
972        ChooseExpFil $frm
973        return
974    } elseif [file isdirectory \
975            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
976        if {$expgui(FileMenuEXPNAM) != "."} {
977            set expgui(FileMenuDir) \
978                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
979        }
980        ChooseExpFil $frm
981        return
982    }
983    set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
984    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
985        append expgui(FileMenuEXPNAM) ".EXP"
986    }
987    if {[file extension $expgui(FileMenuEXPNAM)] != ".EXP"} {
988        tk_dialog .expFileErrorMsg "File Open Error" \
989            "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
990            error 0 OK
991        return
992    }
993    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
994    if {$mode == "new" && [file exists $file]} {
995        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
996            "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" question 0 \
997             "Select other name" "Overwrite"]
998        if $ans {destroy .file}
999        return
1000    }
1001    if {$mode == "old" && ![file exists $file]} {
1002        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
1003            "File [file tail $file] does not exist in [file dirname $file]. OK to create?" question 0 \
1004             "Select other name" "Create"]
1005        if $ans {destroy .file}
1006        return
1007    }
1008    destroy .file
1009}
1010
1011proc updir {} {
1012    global expgui
1013    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1014}
1015
1016# create a file box
1017proc expfilebox {bx mode} {
1018    global expgui
1019    pack [frame $bx.top] -side top
1020    pack [label $bx.top.a -text "Directory" ] -side left
1021    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1022    pack $bx.top.d -side left
1023    set expgui(FileMenuDir) [pwd]
1024    # the icon below is from tk8.0/tkfbox.tcl
1025    set upfolder [image create bitmap -data {
1026#define updir_width 28
1027#define updir_height 16
1028static char updir_bits[] = {
1029   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1030   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1031   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1032   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1033   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1034   0xf0, 0xff, 0xff, 0x01};}]
1035
1036    pack [button $bx.top.b -image $upfolder \
1037            -command "updir; ChooseExpFil $bx" ]
1038    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1039    listbox $bx.a.files -relief raised -bd 2 \
1040            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
1041            -height 15 -width 0
1042    listbox $bx.a.dates -relief raised -bd 2 \
1043            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
1044            -height 15 -width 0 -takefocus 0
1045    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1046    ChooseExpFil $bx
1047    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1048    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1049    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1050    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1051    pack $bx.a.scroll -side left -fill y
1052    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1053    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1054}
1055proc sync2boxes {master slave scroll args} {
1056    $slave yview moveto [lindex [$master yview] 0]
1057    eval $scroll set $args
1058}
1059proc move2boxesY {boxlist args} {
1060    foreach listbox $boxlist { 
1061        eval $listbox yview $args
1062    }
1063}
1064
1065# set the box or file in the selection window
1066proc ReleaseExpFil {frm} {
1067    global expgui
1068    set files $frm.a.files
1069    set dates $frm.a.dates
1070    set select [$files curselection]
1071    if {$select == ""} {
1072        set select [$dates curselection]
1073    }
1074    if {$select == ""} {
1075        set expgui(FileMenuEXPNAM) ""
1076    } else {
1077        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
1078    }
1079    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1080        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1081        ChooseExpFil $frm
1082    } elseif [file isdirectory \
1083            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
1084        if {$expgui(FileMenuEXPNAM) != "."} {
1085            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1086            ChooseExpFil $frm
1087        }
1088    }
1089    return
1090}
1091
1092# select a file or directory -- called on double click
1093proc SelectExpFil {frm mode} {
1094    global expgui
1095    set files $frm.a.files
1096    set dates $frm.a.dates
1097    set select [$files curselection]
1098    if {$select == ""} {
1099        set select [$dates curselection]
1100    }
1101    if {$select == ""} {
1102        set file .
1103    } else {
1104        set file [string trim [$files get $select]]
1105    }
1106    if {$file == "<Parent>"} {
1107        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1108        ChooseExpFil $frm
1109    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1110        if {$file != "."} {
1111            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1112            ChooseExpFil $frm
1113        }
1114    } else {
1115        set expgui(FileMenuEXPNAM) [file tail $file]
1116        valid_exp_file $frm $mode
1117    }
1118}
1119
1120# fill the files & dates & Directory selection box with current directory,
1121# also called when box is created to fill it
1122proc ChooseExpFil {frm} {
1123    global expgui
1124    set files $frm.a.files
1125    set dates $frm.a.dates
1126    set expgui(FileMenuEXPNAM) {}
1127    $files delete 0 end
1128    $dates delete 0 end
1129    $files insert end {<Parent>}
1130    $dates insert end {(Directory)}
1131    set filelist [glob -nocomplain \
1132            [file join [set expgui(FileMenuDir)] *] ]
1133    foreach file [lsort -dictionary $filelist] {
1134        if {[file isdirectory $file]} {
1135            $files insert end [file tail $file]
1136            $dates insert end {(Directory)}
1137        }
1138    }
1139    set pairlist {}
1140    foreach file [lsort -dictionary $filelist] {
1141        if {![file isdirectory $file]  && \
1142                [string toupper [file extension $file]] == ".EXP"} {
1143            set modified [file mtime $file]
1144            lappend pairlist [list $file $modified]
1145        }
1146    }
1147    if {$expgui(filesort) == 0} {
1148        foreach pair [lsort -index 1 -integer $pairlist] {
1149            set file [lindex $pair 0]
1150            set modified [clock format [lindex $pair 1] -format "%T %D"]
1151            $files insert end [file tail $file]
1152            $dates insert end $modified
1153        }
1154    } else {
1155        foreach pair [lsort -index 0 $pairlist] {
1156            set file [lindex $pair 0]
1157            set modified [clock format [lindex $pair 1] -format "%T %D"]
1158            $files insert end [file tail $file]
1159            $dates insert end $modified
1160        }
1161    }
1162    $expgui(FileDirButtonMenu)  delete 0 end
1163    set list ""
1164    set dir ""
1165    foreach subdir [file split [set expgui(FileMenuDir)]] {
1166        set dir [file join $dir $subdir]
1167        lappend list $dir
1168    }
1169    foreach path $list {
1170        $expgui(FileDirButtonMenu) add command -label $path \
1171                -command "[list set expgui(FileMenuDir) $path]; \
1172                ChooseExpFil $frm"
1173    }
1174    # highlight the current experiment -- if present
1175    for {set i 0} {$i < [$files size]} {incr i} {
1176        set file [$files get $i]
1177        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
1178            $files selection set $i
1179        }
1180    }
1181    return
1182}
1183
1184proc putontop {w} {
1185    # center window $w above its parent and make it stay on top
1186    set wp [winfo parent $w]
1187    wm transient $w [winfo toplevel $wp]
1188    wm withdraw $w
1189    update idletasks
1190    # center the new window in the middle of the parent
1191    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
1192            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
1193    if {$x < 0} {set x 0}
1194    set xborder 10
1195    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
1196        incr x [expr \
1197                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
1198    }
1199    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
1200            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
1201    if {$y < 0} {set y 0}
1202    set yborder 25
1203    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
1204        incr y [expr \
1205                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
1206    }
1207    wm geom $w +$x+$y
1208    wm deiconify $w
1209
1210    global makenew
1211    set makenew(OldFocus) [focus]
1212    catch {
1213        set makenew(OldGrab) [grab current $w]
1214        if {$makenew(OldGrab) != ""} {
1215            set makenew(GrabStatus) [grab status $makenew(OldGrab)]
1216        }
1217        grab $w
1218    }
1219}
1220
1221proc afterputontop {} {
1222    # restore focus
1223    global makenew
1224    catch {focus $makenew(OldFocus)}
1225    if {$makenew(OldGrab) != ""} {
1226        catch {
1227            if {$makenew(GrabStatus) == "global"} {
1228                grab -global $makenew(OldGrab)
1229            } else {
1230                grab $makenew(OldGrab)
1231            }
1232        }
1233    }
1234}
1235
1236proc ShowBigMessage {win labeltext msg "optionlist OK"} {
1237    catch {destroy $win}
1238    toplevel $win
1239
1240    # grab focus, etc.
1241    pack [label $win.l1 -text $labeltext] -side top
1242    pack [frame $win.f1] -side top -expand yes -fill both
1243    grid [text  $win.f1.t  \
1244            -height 20 -width 55  -wrap none -font Courier \
1245            -xscrollcommand "$win.f1.bscr set" \
1246            -yscrollcommand "$win.f1.rscr set" \
1247            ] -row 1 -column 0 -sticky news
1248    grid [scrollbar $win.f1.bscr -orient horizontal \
1249            -command "$win.f1.t xview" \
1250            ] -row 2 -column 0 -sticky ew
1251    grid [scrollbar $win.f1.rscr  -command "$win.f1.t yview" \
1252            ] -row 1 -column 1 -sticky ns
1253    # give extra space to the text box
1254    grid columnconfigure $win.f1 0 -weight 1
1255    grid rowconfigure $win.f1 1 -weight 1
1256    $win.f1.t insert end $msg
1257
1258    global makenew
1259    set makenew(result) 0
1260    bind $win <Return> "destroy $win"
1261    bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
1262    bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
1263    bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
1264    bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
1265    bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
1266    bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
1267    bind $win <KeyPress-Home> "$win.f1.t yview 0"
1268    bind $win <KeyPress-End> "$win.f1.t yview end"
1269    set i 0
1270    foreach item $optionlist {
1271        pack [button $win.q[incr i] \
1272                -command "set makenew(result) $i; destroy $win" -text $item] -side left
1273    }
1274    putontop $win
1275    tkwait window $win
1276
1277    # fix focus...
1278    afterputontop
1279    return $makenew(result)
1280}
Note: See TracBrowser for help on using the repository browser.