source: trunk/gsascmds.tcl @ 119

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

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