source: trunk/gsascmds.tcl @ 182

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

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