source: trunk/gsascmds.tcl @ 249

Last change on this file since 249 was 249, checked in by toby, 11 years ago

# on 2000/07/28 20:28:25, toby did:
remove unneeded ref to Win98 for tcl_platform(os) (98 is reported as 95)

  • Property rcs:author set to toby
  • Property rcs:date set to 2000/07/28 20:28:25
  • Property rcs:lines set to +1 -1
  • Property rcs:rev set to 1.23
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 65.8 KB
Line 
1# $Id: gsascmds.tcl 249 2009-12-04 23:02:53Z 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 ![file exists [file join $expgui(gsasdir) fonts grfont.dat]] {
11        tk_dialog .err "PGPLOT Error" \
12                "Warning -- Unable to find file GRFONT.DAT. GSAS graphics will not work. Is GSAS correctly installed?" \
13                warning 0 "Limp Ahead"
14    }
15
16    if {$tcl_platform(os) == "Windows 95"} {
17        # this creates a DOS box to run a program in
18        proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
19            global env expgui
20            # Windows environment variables
21            # -95 does not seem to be able to use these
22            set env(GSAS) [file nativename $expgui(gsasdir)]
23            # PGPLOT_FONT is needed by PGPLOT
24            set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
25            # this is the number of lines/page in the .LST (etc.) file
26            set env(LENPAGE) 60
27            set pwd [file nativename [pwd]]
28
29            # check the path -- can DOS use it?
30            if {[string first // [pwd]] != -1} {
31                tk_dialog .braindead "Invalid Path" \
32                {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) \
33                Win-95 can't directly access a network drive in DOS} error 0 OK
34                return
35            }
36            # all winexec commands are background commands
37            #   if $background
38
39            # pause is hard coded in the .BAT file
40            #if $wait  {
41            #   append command " pause"
42            #}
43
44            # replace the forward slashes with backward
45            regsub -all / $command \\ command
46            # Win95 does not seem to inherit the environment from Tcl env vars
47            # so define it in the .BAT file
48            winexec -d [file nativename [pwd]] \
49                [file join $expgui(scriptdir) gsastcl.bat] \
50                "[file nativename $expgui(gsasdir)] $command"
51        }
52    } else {
53        # now for - brain-dead Windows-NT
54        # this creates a DOS box to run a program in
55        proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
56            global env expgui
57            # Windows environment variables
58            set env(GSAS) [file nativename $expgui(gsasdir)]
59            # PGPLOT_FONT is needed by PGPLOT
60            set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
61            # this is the number of lines/page in the .LST (etc.) file
62            set env(LENPAGE) 60
63            # all winexec commands are background commands -- ignore background arg
64            # can't get pause to work! -- ignore wait
65
66            set prevcmd {}
67            foreach cmd $command {
68                if {$prevcmd != ""} {
69                    tk_dialog .done_yet Confirm "Press OK to start command $cmd" "" 0 OK
70                }
71                # replace the forward slashes with backward
72                regsub -all / $cmd \\ cmd
73                # cmd.exe must be in the path -- lets hope that at least works!
74                winexec -d [file nativename [pwd]] cmd.exe "/c $cmd"
75                set prevcmd $cmd
76            }
77        }
78    }
79} else {
80    if [catch {set env(GSASBACKSPACE)}] {set env(GSASBACKSPACE) 1}
81
82    # this creates a xterm window to run a program in
83    proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
84        global env expgui
85        # UNIX environment variables
86        set env(GSASEXE) $expgui(gsasexe)
87        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
88        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
89        # PGPLOT_DIR is needed by PGPLOT
90        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
91        # this is the number of lines/page in the .LST (etc.) file
92        set env(LENPAGE) 60
93        set termopts {}
94        if $env(GSASBACKSPACE) {
95            append termopts \
96                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
97        }
98        if $scrollbar {
99            append termopts " -sb"
100        } else {
101            append termopts " +sb"
102        }
103        if $background {
104            set suffix {&}
105        } else {
106            set suffix {}
107        }
108        #
109        if $wait  {
110            append command "\; echo -n Press Enter to continue \; read x"
111        }
112        if !$background {wm iconify .}
113        catch {eval exec xterm $termopts -title [list $title] \
114                -e /bin/sh -c [list $command] $suffix} errmsg
115        if $expgui(debug) {puts "xterm result = $errmsg"}
116        if !$background {wm deiconify .}
117    }
118}
119
120# get a value in a modal toplevel
121proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
122    global expgui expmap
123    set w .global
124    catch {destroy $w}
125    toplevel $w -bg beige
126    wm title $w "Input $what"
127    set expgui(temp) {}
128    pack [frame $w.0 -bd 6 -relief groove -bg beige] \
129            -side top -expand yes -fill both
130    grid [label $w.0.a -text "Input a value for the $what" \
131            -bg beige] \
132            -row 0 -column 0 -columnspan 10
133    grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
134            -row 1 -column 0 
135
136    set expgui(temp) $initvalue
137    pack [frame $w.b] -side top
138    pack [button $w.b.2 -text Set -command "destroy $w"] -side left
139    if $quit {
140        pack [button $w.b.3 -text Quit \
141                -command "set expgui(temp) {}; destroy $w"] -side left
142    }
143    bind $w <Return> "destroy $w"
144
145    # force the window to stay on top
146    putontop $w
147
148    focus $w.b.2
149    tkwait window $w
150    afterputontop
151
152    return $expgui(temp)
153}
154
155# run a GSAS program that does not require an experiment file
156proc runGSASprog {proglist} {
157    global expgui tcl_platform
158    set cmd {}
159    foreach prog $proglist {
160        if {$tcl_platform(platform) == "windows"} {
161            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
162        } else {
163            if {$cmd != ""} {append cmd "\;"}
164            append cmd "[file join $expgui(gsasexe) $prog]"
165        }
166    }
167    forknewterm $prog $cmd 0 1 1
168}
169
170# run a GSAS program that requires an experiment file for input/output
171proc runGSASwEXP {proglist "concurrent 0"} {
172    global expgui tcl_platform
173    # Save the current exp file
174    savearchiveexp
175    # load the changed .EXP file automatically?
176    if {$expgui(autoexpload)} {
177        # disable the file changed monitor
178        set expgui(expModifiedLast) 0
179    }
180    set cmd {}
181    set expnam [file root [file tail $expgui(expfile)]]
182    foreach prog $proglist {
183        if {$prog == "expedt" && $expgui(archive)} archiveexp
184        if {$tcl_platform(platform) == "windows"} {
185            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
186        } else {
187            if {$cmd != ""} {append cmd "\;"}
188            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
189        }
190    }
191    forknewterm "$prog -- $expnam" $cmd $concurrent 1 1
192    # load the changed .EXP file automatically?
193    if {$expgui(autoexpload)} {
194        # load the revised exp file
195        loadexp $expgui(expfile)
196    }
197}
198
199# run liveplot
200proc liveplot {} {
201    global expgui liveplot wishshell
202    set expnam [file root [file tail $expgui(expfile)]]
203    exec $wishshell [file join $expgui(scriptdir) liveplot] \
204            $expnam $liveplot(hst) $liveplot(legend) &
205}
206
207# run lstview
208proc lstview {} {
209    global expgui wishshell
210    set expnam [file root [file tail $expgui(expfile)]]
211    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
212}
213
214# run widplt
215proc widplt {} {
216    global expgui wishshell
217    exec $wishshell [file join $expgui(scriptdir) widplt] \
218            $expgui(expfile) &
219}
220
221# show help information
222proc showhelp {} {
223    global expgui_helplist helpmsg
224    set helpmsg {}
225    set frm .help
226    catch {destroy $frm}
227    toplevel $frm
228    wm title $frm "Command Help"
229    pack [message $frm.0 -text \
230            "Click on an entry below to see help on a GSAS command" ] \
231            -side top
232    pack [frame $frm.a -width 20 -height 15] \
233            -side top -expand yes -fill both
234    pack [message $frm.help -textvariable helpmsg -relief groove] \
235            -side left -fill both -expand yes
236    set lst [array names expgui_helplist]
237    listbox $frm.a.cmds -relief raised -bd 2 -yscrollcommand \
238            "$frm.a.scroll set" -height 15 -width 0
239    scrollbar $frm.a.scroll -command "$frm.a.cmds yview"
240    foreach item [lsort $lst] {
241        $frm.a.cmds insert end $item 
242    }
243    if {[$frm.a.cmds curselection] == ""} {$frm.a.cmds selection set 0}
244    button $frm.a.done -text Done -command "destroy $frm"
245    bind $frm.a.cmds <ButtonRelease-1> \
246            "+set helpmsg \$expgui_helplist(\[$frm.a.cmds get \[$frm.a.cmds curselection\]\])"
247    pack $frm.a.scroll -side left -fill y
248    pack $frm.a.cmds -side left -expand yes -anchor w
249    pack $frm.a.done -side right -expand no
250    # get the size of the window and expand the message boxes to match
251    update
252    set width [lindex [split [wm geometry $frm] x+] 0]
253    $frm.0 config -width $width
254    $frm.help config -width $width
255    # waitdone $frm
256}
257
258# compute the composition for each phase and display in a toplevel
259proc composition {} {
260    global expmap expgui
261    set Z 1
262    foreach phase $expmap(phaselist) type $expmap(phasetype) {
263        if {$type > 2} continue
264        catch {unset total}
265        foreach atom $expmap(atomlist_$phase) {
266            set type [atominfo $phase $atom type]
267            set mult [atominfo $phase $atom mult]
268            if [catch {set total($type)}] {
269                set total($type) [expr \
270                        $mult * [atominfo $phase $atom frac]]
271            } else {
272                set total($type) [expr $total($type) + \
273                        $mult * [atominfo $phase $atom frac]]
274            }
275            if {$mult > $Z} {set Z $mult}
276        }
277        append text "\nPhase $phase\n"
278        append text "  Unit cell contents\n"
279        foreach type [lsort [array names total]] {
280            append text "   $type[format %8.3f $total($type)]"
281        }
282        append text "\n\n"
283       
284        append text "  Asymmetric Unit contents (Z=$Z)\n"
285        foreach type [lsort [array names total]] {
286            append text "   $type[format %8.3f [expr $total($type)/$Z]]"
287        }
288        append text "\n"
289    }
290   
291    catch {destroy .comp}
292    toplevel .comp
293    wm title .comp Composition
294    pack [label .comp.results -text $text \
295            -font $expgui(coordfont) -justify left] -side top
296    pack [frame .comp.box]  -side top
297    pack [button .comp.box.1 -text Close -command "destroy .comp"] -side left
298    set lstnam [string toupper [file tail [file rootname $expgui(expfile)].LST]]
299    pack [button .comp.box.2 -text "Save to $lstnam file" \
300            -command "writelst [list $text] ; destroy .comp"] -side left
301}
302
303# write text to the .LST file
304proc writelst {text} {
305    global expgui
306    set lstnam [file rootname $expgui(expfile)].LST
307    set fp [open $lstnam a]
308    puts $fp "\n-----------------------------------------------------------------"
309    puts $fp $text
310    puts $fp "-----------------------------------------------------------------\n"
311    close $fp
312}
313
314# save coordinates in an MSI .xtl file
315proc exp2xtl {} {
316    global expmap expgui
317    catch {destroy .export}
318    toplevel .export
319    wm title .export "Export coordinates"
320    pack [label .export.lbl -text "Export coordinates in MSI .xtl format"\
321            ] -side top -anchor center
322    pack [frame .export.ps] -side top -anchor w
323    pack [label .export.ps.lbl -text "Select phase: "] -side left
324    foreach num $expmap(phaselist) type $expmap(phasetype) {
325        pack [button .export.ps.$num -text $num \
326                    -command "SetExportPhase $num"] -side left
327        if {$type == 4} {
328            .export.ps.$num config -state disabled
329        }
330    }
331    pack [frame .export.sg] -side top
332    pack [label .export.sg.1 -text "Space Group: "] -side left
333    pack [entry .export.sg.2 -textvariable expgui(export_sg) -width 8] -side left
334    pack [checkbutton .export.sg.3 -variable expgui(export_orig) -text "Origin 2"] -side left
335    pack [frame .export.but] -side top
336    if {[llength $expmap(phaselist)] > 0} {
337        pack [button .export.but.1 -text Write -command writextl] -side left
338        SetExportPhase [lindex $expmap(phaselist) 0]
339    }
340    pack [button .export.but.2 -text Quit -command "destroy .export"] -side left
341}
342
343proc SetExportPhase {phase} {
344    global expmap expgui
345    foreach n $expmap(phaselist) type $expmap(phasetype) {
346        if {$n == $phase && $type != 4} {
347            .export.ps.$n config -relief sunken
348            set expgui(export_phase) $phase
349            # remove spaces from space group
350            set spacegroup [phaseinfo $phase spacegroup]
351            if {[string toupper [string range $spacegroup end end]] == "R"} {
352                set spacegroup [string range $spacegroup 0 \
353                        [expr [string length $spacegroup]-2]] 
354            }
355            regsub -all " " $spacegroup "" expgui(export_sg)   
356        } else { 
357            .export.ps.$n config -relief raised
358        }
359    }
360}
361
362
363proc writextl {} {
364    global expgui expmap
365    if ![catch {
366        set phase $expgui(export_phase)
367        set origin $expgui(export_orig)
368        set spsymbol $expgui(export_sg)
369    } errmsg] {
370        set errmsg {}
371        if {$phase == ""} {
372            set errmsg "Error: invalid phase number $phase"
373        } elseif {$spsymbol == ""} {
374            set errmsg "Error: invalid Space Group: $spsymbol"
375        }
376    }
377    if {$errmsg != ""} {
378        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
379        return
380    }
381
382    if [catch {
383        set filnam [file rootname $expgui(expfile)]_${phase}.xtl
384        set spacegroup [phaseinfo $phase spacegroup]
385        set fp [open $filnam w]
386        puts $fp "TITLE from $expgui(expfile)"
387        puts $fp "TITLE history [string trim [lindex [exphistory last] 1]]"
388        puts $fp "TITLE phase [phaseinfo $phase name]"
389        puts $fp "CELL"
390        puts $fp "  [phaseinfo $phase a] [phaseinfo $phase b] [phaseinfo $phase c] [phaseinfo $phase alpha] [phaseinfo $phase beta] [phaseinfo $phase gamma]"
391       
392        puts $fp "Symmetry Label $spsymbol"
393        set rhomb 0
394        if {[string toupper [string range $spacegroup end end]] == "R"} {
395            set rhomb 1
396        }
397        if $origin {
398            puts $fp "Symmetry Qualifier origin_2"
399        }
400        if $rhomb {
401            puts $fp "Symmetry Qualifier rhombohedral"
402        }
403       
404        puts $fp "ATOMS"
405        puts $fp "NAME       X          Y          Z    UISO      OCCUP"
406        foreach atom $expmap(atomlist_$phase) {
407            set label [atominfo $phase $atom label]
408            # remove () characters
409            regsub -all "\[()\]" $label "" label
410            # are there anisotropic atoms?
411            if {[atominfo $phase $atom temptype] == "A"} {
412                set uiso [expr \
413                        ([atominfo $phase $atom U11] + \
414                        [atominfo $phase $atom U22] + \
415                        [atominfo $phase $atom U33]) / 3.]
416            } else {
417                set uiso [atominfo $phase $atom Uiso]
418            }
419            puts $fp "$label [atominfo $phase $atom x] \
420                        [atominfo $phase $atom y] [atominfo $phase $atom z] \
421                        $uiso  [atominfo $phase $atom frac]"
422        }
423    } errmsg] {
424        catch {close $fp}
425        tk_dialog .errorMsg "Export error" $errmsg warning 0 "OK"
426    } else {
427        catch {close $fp}
428        tk_dialog .ok "Done" \
429                "File [file tail $filnam] written in directory [file dirname $filnam]" \
430                warning 0 "OK"
431    }
432    if {[llength $expmap(phaselist)] == 1} {destroy .export}
433}
434
435
436# convert a file
437proc convfile {} {
438    global tcl_platform
439    if {$tcl_platform(platform) == "windows"} {
440        convwin
441    } else {
442        convunix
443    }
444}
445
446# file conversions for UNIX (convstod convdtos)
447proc convunix {} {
448    global expgui infile outfile
449    set frm .file
450    catch {destroy $frm}
451    toplevel $frm
452    wm title $frm "Convert File"
453
454    pack [frame [set frm0 $frm.0] -bd 2 -relief groove] \
455            -padx 3 -pady 3 -side top -fill x
456    pack [frame $frm.mid] -side top
457    pack [frame [set frmA $frm.mid.1] -bd 2 -relief groove] \
458            -padx 3 -pady 3 -side left
459    pack [label $frmA.0 -text "Select an input file"] -side top -anchor center
460    pack [frame [set frmB $frm.mid.2] -bd 2 -relief groove] \
461            -padx 3 -pady 3 -side left
462    pack [label $frmB.0 -text "Enter an output file"] -side top -anchor center
463    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side top
464
465    pack [label $frm0.1 -text "Convert to:"] -side top -anchor center
466    pack [frame $frm0.2] -side top -anchor center
467    pack [radiobutton $frm0.2.d -text "direct access" -value convstod \
468            -command setoutfile \
469            -variable outfile(type)] -side left -anchor center
470    pack [radiobutton $frm0.2.s -text "sequential" -value convdtos \
471            -command setoutfile \
472            -variable outfile(type)] -side right -anchor center
473    set outfile(type) ""
474
475    pack [button $frmC.b -text Convert -command "valid_conv_unix"] -side left
476    pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side left
477
478   
479    unixcnvbox $frmA infile 1 
480    unixcnvbox $frmB outfile 0 
481    set infile(done) 0
482    bind $frm <Return> "valid_conv_unix"
483    # force the window to stay on top
484    putontop $frm
485    focus $frmC.q 
486    update
487    tkwait variable infile(done)
488    destroy $frm
489    afterputontop
490}
491
492# validate the files and make the conversion -- unix
493proc valid_conv_unix {} {
494    global infile outfile expgui
495    set error {}
496    if {$outfile(type) == "convstod" || $outfile(type) == "convdtos"} {
497        set convtype $outfile(type)
498    } else {
499        append error "You must specify a conversion method: to direct access or to sequential.\n"
500    }
501    if {$infile(name) == ""} {
502        append error "You must specify an input file to convert.\n"
503    }
504    if {$outfile(name) == ""} {
505        append error "You must specify an output file name for the converted file.\n"
506    }
507    if {$error != ""} {
508        tk_dialog .warn Notify $error warning 0 OK
509        return
510    }
511
512    if {$infile(name) == $outfile(name)} {
513        tk_dialog .warn Notify "Sorry, filenames must differ" warning 0 OK
514        return
515    }
516    if ![file exists [file join $infile(dir) $infile(name)]] {
517        tk_dialog .warn Notify \
518                "Sorry, file $infile(name) not found in $infile(dir)" warning 0 OK
519        return
520    }
521    if [file exists [file join $outfile(dir) $outfile(name)]] {
522        if [tk_dialog .warn Notify \
523                "Warning: file $outfile(name) exists in $outfile(dir). OK to overwrite?" \
524                warning 0 OK No] return
525    }
526    if [catch {
527        exec [file join $expgui(gsasexe) $convtype] < \
528                [file join $infile(dir) $infile(name)] > \
529                [file join $outfile(dir) $outfile(name)]
530    } errmsg] {
531        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
532    } else {
533        if [tk_dialog .converted Notify \
534                "File converted. Convert more files?" \
535                ""  0 Yes No] {set infile(done) 1}
536    }
537}
538
539# create a file box for UNIX conversions
540proc unixcnvbox {bx filvar diropt} {
541    global ${filvar} expgui
542    pack [frame $bx.top] -side top
543    pack [label $bx.top.a -text "Directory" ] -side left
544    set ${filvar}(FileDirButtonMenu) [tk_optionMenu $bx.top.d ${filvar}(dir) [pwd] ]
545    pack $bx.top.d -side left
546    set ${filvar}(dir) [pwd]
547
548#    pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top
549#    set ${filvar}(dir) [pwd]
550
551    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
552    listbox $bx.a.files -relief raised -bd 2 -yscrollcommand "$bx.a.scroll set" \
553            -height 15 -width 0
554    scrollbar $bx.a.scroll -command "$bx.a.files yview"
555    unixFilChoose $bx $bx.a.files $filvar $diropt
556    if {$filvar == "infile"} {
557        bind $bx.a.files <ButtonRelease-1> \
558                "unixFilChoose $bx $bx.a.files $filvar $diropt; setoutfile"
559    } else {
560        bind $bx.a.files <ButtonRelease-1> \
561                "unixFilChoose $bx $bx.a.files $filvar $diropt"
562    }
563    pack $bx.a.scroll -side left -fill y
564    pack $bx.a.files -side left -fill both -expand yes
565    pack [entry $bx.c -textvariable ${filvar}(name)] -side top
566}
567
568# select a file or directory, also called when box is created to fill it
569proc unixFilChoose {frm box filvar {dironly 1}} {
570    global $filvar
571    set select [$box curselection]
572    if {$select == ""} {
573        set file .
574    } else {
575        set file [string trim [$box get $select]]
576    }
577    if [file isdirectory [file join [set ${filvar}(dir)] $file]] {
578        if {$file == ".."} {
579            set ${filvar}(dir) [file dirname [set ${filvar}(dir)] ]
580        } elseif {$file != "."} {
581            set ${filvar}(dir) [file join [set ${filvar}(dir)] $file]
582        }
583        [set ${filvar}(FileDirButtonMenu)] delete 0 end
584        set list ""
585        set dir ""
586        foreach subdir [file split [set ${filvar}(dir)]] {
587            set dir [file join $dir $subdir]
588            lappend list $dir
589        }
590        foreach path $list {
591            [set ${filvar}(FileDirButtonMenu)] add command -label $path \
592                -command "[list set ${filvar}(dir) $path]; \
593                unixFilChoose $frm $box $filvar $dironly"
594        }
595        set ${filvar}(name) {}
596        $box delete 0 end
597        $box insert end {..   }
598        foreach file [lsort [glob -nocomplain \
599                [file join [set ${filvar}(dir)] *] ] ] {
600            if {[file isdirectory $file]} {
601                # is this / needed here? Does it cause a problem in MacGSAS?
602                $box insert end [file tail $file]/
603            } elseif {$dironly == 1} {
604                $box insert end [file tail $file]
605            } elseif {$dironly == 2 && [file extension $file] == ".EXP"} {
606                $box insert end [file tail $file]
607            }
608        }
609        return
610    }
611    set ${filvar}(name) [file tail $file]
612}
613
614# set new file name from old -- used for convunix
615proc setoutfile {} {
616    global infile outfile
617    if {$outfile(type) == "convstod"} {
618        set lfile [string toupper $infile(name)]
619    } elseif {$outfile(type) == "convdtos"} {
620        set lfile [string tolower $infile(name)]
621    } else {
622        set lfile ""
623    }
624    if {$infile(name) == $lfile} {
625        set outfile(name) {}
626    } else {
627        set outfile(name) $lfile
628    }
629}
630
631#------------------------------------------------------------------------------
632# file conversions for Windows
633#------------------------------------------------------------------------------
634proc convwin {} {
635    global expgui
636    set frm .file
637    catch {destroy $frm}
638    toplevel $frm
639    wm title $frm "Convert File"
640    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
641    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
642    pack [button $frmC.b -text Convert -command "ValidWinCnv $frm"] \
643            -side top
644    pack [button $frmC.q -text Quit -command "destroy $frm"] -side top
645    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
646    winfilebox $frm
647    bind $frm <Return> "ValidWinCnv $frm"
648
649    # force the window to stay on top
650    putontop $frm
651    focus $frmC.q 
652    tkwait window $frm
653    afterputontop
654}
655
656# validate the files and make the conversion
657proc ValidWinCnv {frm} {
658    global expgui
659    # change backslashes to something sensible
660    regsub -all {\\} $expgui(FileMenuCnvName) / expgui(FileMenuCnvName)
661    # allow entry of D: for D:/ and D:TEST for d:/TEST
662    if {[string first : $expgui(FileMenuCnvName)] != -1 && \
663            [string first :/ $expgui(FileMenuCnvName)] == -1} {
664        regsub : $expgui(FileMenuCnvName) :/ expgui(FileMenuCnvName)
665    }
666    if {$expgui(FileMenuCnvName) == "<Parent>"} {
667        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
668        ChooseWinCnv $frm
669        return
670    } elseif [file isdirectory \
671            [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]] {
672        if {$expgui(FileMenuCnvName) != "."} {
673            set expgui(FileMenuDir) \
674                [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
675        }
676        ChooseWinCnv $frm
677        return
678    }
679 
680    set file [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
681    if ![file exists $file] {
682        tk_dialog .warn "Convert Error" \
683                "File $file does not exist" question 0 "OK"
684        return
685    }
686
687    set tmpname "[file join [file dirname $file] tempfile.xxx]"
688    set oldname "[file rootname $file].org"
689    if [file exists $oldname] {
690        set ans [tk_dialog .warn "OK to overwrite?" \
691                "File [file tail $oldname] exists in [file dirname $oldname]. OK to overwrite?" question 0 \
692                "Yes" "No"]
693        if $ans return
694        catch {file delete $oldname}
695    }
696
697    if [catch {
698        set in [open $file r]
699        set out [open $tmpname w]
700        set len [gets $in line]
701        if {$len > 160} {
702            # this is a UNIX file. Hope there are no control characters
703            set i 0
704            set j 79
705            while {$j < $len} {
706                puts $out [string range $line $i $j]
707                incr i 80
708                incr j 80
709            }
710        } else {
711            while {$len >= 0} {
712                append line "                                        "
713                append line "                                        "
714                set line [string range $line 0 79]
715                puts $out $line
716                set len [gets $in line]
717            }
718        }
719        close $in
720        close $out
721        file rename -force $file $oldname
722        file rename -force $tmpname $file
723    } errmsg] {
724        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
725    } else {
726        if [tk_dialog .converted Notify \
727                "File [file tail $file] converted. (Original saved as [file tail $oldname]).\n\n Convert more files?" \
728                ""  0 Yes No] {destroy $frm}
729    }
730}
731
732# create a file box
733proc winfilebox {frm} {
734    global expgui
735    set bx $frm.1
736    pack [frame $bx.top] -side top
737    pack [label $bx.top.a -text "Directory" ] -side left
738    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
739    pack $bx.top.d -side left
740    set expgui(FileMenuDir) [pwd]
741    # the icon below is from tk8.0/tkfbox.tcl
742    set upfolder [image create bitmap -data {
743#define updir_width 28
744#define updir_height 16
745static char updir_bits[] = {
746   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
747   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
748   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
749   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
750   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
751   0xf0, 0xff, 0xff, 0x01};}]
752
753    pack [button $bx.top.b -image $upfolder \
754            -command "updir; ChooseWinCnv $frm" ]
755    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
756    listbox $bx.a.files -relief raised -bd 2 \
757            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
758            -height 15 -width 0
759    listbox $bx.a.dates -relief raised -bd 2 \
760            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
761            -height 15 -width 0 -takefocus 0
762    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
763    ChooseWinCnv $frm
764    bind $bx.a.files <ButtonRelease-1> "ReleaseWinCnv $frm"
765    bind $bx.a.dates <ButtonRelease-1> "ReleaseWinCnv $frm"
766    bind $bx.a.files <Double-1> "SelectWinCnv $frm"
767    bind $bx.a.dates <Double-1> "SelectWinCnv $frm"
768    pack $bx.a.scroll -side left -fill y
769    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
770    pack [entry $bx.c -textvariable expgui(FileMenuCnvName)] -side top
771}
772
773# set the box or file in the selection window
774proc ReleaseWinCnv {frm} {
775    global expgui
776    set files $frm.1.a.files
777    set dates $frm.1.a.dates
778    set select [$files curselection]
779    if {$select == ""} {
780        set select [$dates curselection]
781    }
782    if {$select == ""} {
783        set expgui(FileMenuCnvName) ""
784    } else {
785        set expgui(FileMenuCnvName) [string trim [$files get $select]]
786    }
787    if {$expgui(FileMenuCnvName) == "<Parent>"} {
788        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
789        ChooseWinCnv $frm
790    } elseif [file isdirectory \
791            [file join [set expgui(FileMenuDir)] $expgui(FileMenuCnvName)]] {
792        if {$expgui(FileMenuCnvName) != "."} {
793            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuCnvName)]
794            ChooseWinCnv $frm
795        }
796    }
797    return
798}
799
800# select a file or directory -- called on double click
801proc SelectWinCnv {frm} {
802    global expgui
803    set files $frm.1.a.files
804    set dates $frm.1.a.dates
805    set select [$files curselection]
806    if {$select == ""} {
807        set select [$dates curselection]
808    }
809    if {$select == ""} {
810        set file .
811    } else {
812        set file [string trim [$files get $select]]
813    }
814    if {$file == "<Parent>"} {
815        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
816        ChooseWinCnv $frm
817    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
818        if {$file != "."} {
819            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
820            ChooseWinCnv $frm
821        }
822    } else {
823        set expgui(FileMenuCnvName) [file tail $file]
824        ValidWinCnv $frm
825    }
826}
827
828# fill the files & dates & Directory selection box with current directory,
829# also called when box is created to fill it
830proc ChooseWinCnv {frm} {
831    global expgui
832    set files $frm.1.a.files
833    set dates $frm.1.a.dates
834    set expgui(FileMenuCnvName) {}
835    $files delete 0 end
836    $dates delete 0 end
837    $files insert end {<Parent>}
838    $dates insert end {(Directory)}
839    set filelist [glob -nocomplain \
840            [file join [set expgui(FileMenuDir)] *] ]
841    foreach file [lsort -dictionary $filelist] {
842        if {[file isdirectory $file]} {
843            $files insert end [file tail $file]
844            $dates insert end {(Directory)}
845        }
846    }
847    foreach file [lsort -dictionary $filelist] {
848        if {![file isdirectory $file]} {
849            set modified [clock format [file mtime $file] -format "%T %D"]
850            $files insert end [file tail $file]
851            $dates insert end $modified
852        }
853    }
854    $expgui(FileDirButtonMenu)  delete 0 end
855    set list ""
856    set dir ""
857    foreach subdir [file split [set expgui(FileMenuDir)]] {
858        set dir [file join $dir $subdir]
859        lappend list $dir
860    }
861    foreach path $list {
862        $expgui(FileDirButtonMenu) add command -label $path \
863                -command "[list set expgui(FileMenuDir) $path]; \
864                ChooseWinCnv $frm"
865    }
866    return
867}
868
869#------------------------------------------------------------------------------
870# set options for liveplot
871proc liveplotopt {} {
872    global liveplot expmap
873    set frm .file
874    catch {destroy $frm}
875    toplevel $frm
876    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
877    set last [lindex [lsort -integer $expmap(powderlist)] end]
878    if {$last == ""} {set last 1}
879    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to $last \
880            -length  150 -orient horizontal -variable liveplot(hst)] -side top
881    pack [checkbutton $frmA.2 -text {include plot legend}\
882            -variable liveplot(legend)] -side top
883    pack [button $frm.2 -text OK \
884            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
885            ] -side top
886    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
887   
888    # force the window to stay on top
889    putontop $frm 
890    focus $frm.2
891    tkwait window $frm
892    afterputontop
893}
894
895#------------------------------------------------------------------------------
896# get an experiment file name
897#------------------------------------------------------------------------------
898proc getExpFileName {mode} {
899    global expgui
900    set frm .file
901    catch {destroy $frm}
902    toplevel $frm
903    wm title $frm "Experiment file"
904    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
905    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
906    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
907    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
908            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
909    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
910            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
911    pack [button $frmC.b -text Read \
912            -command "valid_exp_file $frmA $mode"] -side top
913    if {$mode == "new"} {
914        $frmC.b config -text Save
915    }
916    pack [button $frmC.q -text Quit \
917            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side top
918    bind $frm <Return> "$frmC.b invoke"
919
920    if {$mode == "new"} {
921        pack [label $frmA.0 -text "Enter an experiment file to create"] \
922                -side top -anchor center
923    } else {
924        pack [label $frmA.0 -text "Select an experiment file to read"] \
925                -side top -anchor center
926    }
927    expfilebox $frmA $mode
928    # force the window to stay on top
929    putontop $frm
930    focus $frmC.b
931    tkwait window $frm
932    afterputontop
933    if {$expgui(FileMenuEXPNAM) == ""} return
934    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
935}
936
937# validation routine
938proc valid_exp_file {frm mode} {
939    global expgui tcl_platform
940    # windows fixes
941    if {$tcl_platform(platform) == "windows"} {
942        # change backslashes to something sensible
943        regsub -all {\\} $expgui(FileMenuEXPNAM) / expgui(FileMenuEXPNAM)
944        # allow entry of D: for D:/ and D:TEST for d:/TEST
945        if {[string first : $expgui(FileMenuEXPNAM)] != -1 && \
946                [string first :/ $expgui(FileMenuEXPNAM)] == -1} {
947            regsub : $expgui(FileMenuEXPNAM) :/ expgui(FileMenuEXPNAM)
948        }
949    }
950    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
951        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
952        ChooseExpFil $frm
953        return
954    } elseif [file isdirectory \
955            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
956        if {$expgui(FileMenuEXPNAM) != "."} {
957            set expgui(FileMenuDir) \
958                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
959        }
960        ChooseExpFil $frm
961        return
962    }
963    # append a .EXP if not present
964    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
965        append expgui(FileMenuEXPNAM) ".EXP"
966    }
967    # flag files that end in something other than .EXP .exp or .Exp...
968    if {[string toupper [file extension $expgui(FileMenuEXPNAM)]] != ".EXP"} {
969        tk_dialog .expFileErrorMsg "File Open Error" \
970            "File [file tail $expgui(FileMenuEXPNAM)] is not a valid name. Experiment files must end in \".EXP\"" \
971            error 0 OK
972        return
973    }
974    # check on the file status
975    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
976    if {$mode == "new" && [file exists $file]} {
977        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
978            "File [file tail $file] already exists in [file dirname $file]. OK to overwrite?" question 0 \
979             "Select other name" "Overwrite"]
980        if $ans {destroy .file}
981        return
982    }
983    # if file does not exist in case provided, set the name to all
984    # upper case letters, since that is the best choice.
985    # if it does exist, read from it as is. For UNIX we will force uppercase later.
986    if {![file exists $file]} {
987        set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
988        set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
989    }
990    if {$mode == "old" && ![file exists $file]} {
991        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
992            "File [file tail $file] does not exist in [file dirname $file]. OK to create?" question 0 \
993             "Select other name" "Create"]
994        if $ans {destroy .file}
995        return
996    }
997    destroy .file
998}
999
1000proc updir {} {
1001    global expgui
1002    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
1003}
1004
1005# create a file box
1006proc expfilebox {bx mode} {
1007    global expgui
1008    pack [frame $bx.top] -side top
1009    pack [label $bx.top.a -text "Directory" ] -side left
1010    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
1011    pack $bx.top.d -side left
1012    set expgui(FileMenuDir) [pwd]
1013    # the icon below is from tk8.0/tkfbox.tcl
1014    set upfolder [image create bitmap -data {
1015#define updir_width 28
1016#define updir_height 16
1017static char updir_bits[] = {
1018   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
1019   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
1020   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
1021   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
1022   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
1023   0xf0, 0xff, 0xff, 0x01};}]
1024
1025    pack [button $bx.top.b -image $upfolder \
1026            -command "updir; ChooseExpFil $bx" ]
1027    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
1028    listbox $bx.a.files -relief raised -bd 2 \
1029            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
1030            -height 15 -width 0
1031    listbox $bx.a.dates -relief raised -bd 2 \
1032            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
1033            -height 15 -width 0 -takefocus 0
1034    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
1035    ChooseExpFil $bx
1036    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
1037    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
1038    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
1039    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
1040    pack $bx.a.scroll -side left -fill y
1041    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
1042    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
1043}
1044proc sync2boxes {master slave scroll args} {
1045    $slave yview moveto [lindex [$master yview] 0]
1046    eval $scroll set $args
1047}
1048proc move2boxesY {boxlist args} {
1049    foreach listbox $boxlist { 
1050        eval $listbox yview $args
1051    }
1052}
1053
1054# set the box or file in the selection window
1055proc ReleaseExpFil {frm} {
1056    global expgui
1057    set files $frm.a.files
1058    set dates $frm.a.dates
1059    set select [$files curselection]
1060    if {$select == ""} {
1061        set select [$dates curselection]
1062    }
1063    if {$select == ""} {
1064        set expgui(FileMenuEXPNAM) ""
1065    } else {
1066        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
1067    }
1068    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
1069        set expgui(FileMenuDir) [file dirname $expgui(FileMenuDir)]
1070        ChooseExpFil $frm
1071    } elseif [file isdirectory \
1072            [file join [set expgui(FileMenuDir)] $expgui(FileMenuEXPNAM)]] {
1073        if {$expgui(FileMenuEXPNAM) != "."} {
1074            set expgui(FileMenuDir) [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
1075            ChooseExpFil $frm
1076        }
1077    }
1078    return
1079}
1080
1081# select a file or directory -- called on double click
1082proc SelectExpFil {frm mode} {
1083    global expgui
1084    set files $frm.a.files
1085    set dates $frm.a.dates
1086    set select [$files curselection]
1087    if {$select == ""} {
1088        set select [$dates curselection]
1089    }
1090    if {$select == ""} {
1091        set file .
1092    } else {
1093        set file [string trim [$files get $select]]
1094    }
1095    if {$file == "<Parent>"} {
1096        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
1097        ChooseExpFil $frm
1098    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
1099        if {$file != "."} {
1100            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
1101            ChooseExpFil $frm
1102        }
1103    } else {
1104        set expgui(FileMenuEXPNAM) [file tail $file]
1105        valid_exp_file $frm $mode
1106    }
1107}
1108
1109# fill the files & dates & Directory selection box with current directory,
1110# also called when box is created to fill it
1111proc ChooseExpFil {frm} {
1112    global expgui
1113    set files $frm.a.files
1114    set dates $frm.a.dates
1115    set expgui(FileMenuEXPNAM) {}
1116    $files delete 0 end
1117    $dates delete 0 end
1118    $files insert end {<Parent>}
1119    $dates insert end {(Directory)}
1120    set filelist [glob -nocomplain \
1121            [file join [set expgui(FileMenuDir)] *] ]
1122    foreach file [lsort -dictionary $filelist] {
1123        if {[file isdirectory $file]} {
1124            $files insert end [file tail $file]
1125            $dates insert end {(Directory)}
1126        }
1127    }
1128    set pairlist {}
1129    foreach file [lsort -dictionary $filelist] {
1130        if {![file isdirectory $file]  && \
1131                [string toupper [file extension $file]] == ".EXP"} {
1132            set modified [file mtime $file]
1133            lappend pairlist [list $file $modified]
1134        }
1135    }
1136    if {$expgui(filesort) == 0} {
1137        foreach pair [lsort -index 1 -integer $pairlist] {
1138            set file [lindex $pair 0]
1139            set modified [clock format [lindex $pair 1] -format "%T %D"]
1140            $files insert end [file tail $file]
1141            $dates insert end $modified
1142        }
1143    } else {
1144        foreach pair [lsort -dictionary -index 0 $pairlist] {
1145            set file [lindex $pair 0]
1146            set modified [clock format [lindex $pair 1] -format "%T %D"]
1147            $files insert end [file tail $file]
1148            $dates insert end $modified
1149        }
1150    }
1151    $expgui(FileDirButtonMenu)  delete 0 end
1152    set list ""
1153    set dir ""
1154    foreach subdir [file split [set expgui(FileMenuDir)]] {
1155        set dir [file join $dir $subdir]
1156        lappend list $dir
1157    }
1158    foreach path $list {
1159        $expgui(FileDirButtonMenu) add command -label $path \
1160                -command "[list set expgui(FileMenuDir) $path]; \
1161                ChooseExpFil $frm"
1162    }
1163    # highlight the current experiment -- if present
1164    for {set i 0} {$i < [$files size]} {incr i} {
1165        set file [$files get $i]
1166        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
1167            $files selection set $i
1168        }
1169    }
1170    return
1171}
1172
1173proc putontop {w} {
1174    # center window $w above its parent and make it stay on top
1175    set wp [winfo parent $w]
1176    wm transient $w [winfo toplevel $wp]
1177    wm withdraw $w
1178    update idletasks
1179    # center the new window in the middle of the parent
1180    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
1181            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
1182    if {$x < 0} {set x 0}
1183    set xborder 10
1184    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
1185        incr x [expr \
1186                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
1187    }
1188    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
1189            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
1190    if {$y < 0} {set y 0}
1191    set yborder 25
1192    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
1193        incr y [expr \
1194                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
1195    }
1196    wm geom $w +$x+$y
1197    wm deiconify $w
1198
1199    global makenew
1200    set makenew(OldFocus) [focus]
1201    catch {
1202        set makenew(OldGrab) [grab current $w]
1203        if {$makenew(OldGrab) != ""} {
1204            set makenew(GrabStatus) [grab status $makenew(OldGrab)]
1205        }
1206        grab $w
1207    }
1208}
1209
1210proc afterputontop {} {
1211    # restore focus
1212    global makenew
1213    catch {focus $makenew(OldFocus)}
1214    if {$makenew(OldGrab) != ""} {
1215        catch {
1216            if {$makenew(GrabStatus) == "global"} {
1217                grab -global $makenew(OldGrab)
1218            } else {
1219                grab $makenew(OldGrab)
1220            }
1221        }
1222    }
1223}
1224
1225proc ShowBigMessage {win labeltext msg "optionlist OK"} {
1226    catch {destroy $win}
1227    toplevel $win
1228
1229    # grab focus, etc.
1230    pack [label $win.l1 -text $labeltext] -side top
1231    pack [frame $win.f1] -side top -expand yes -fill both
1232    grid [text  $win.f1.t  \
1233            -height 20 -width 55  -wrap none -font Courier \
1234            -xscrollcommand "$win.f1.bscr set" \
1235            -yscrollcommand "$win.f1.rscr set" \
1236            ] -row 1 -column 0 -sticky news
1237    grid [scrollbar $win.f1.bscr -orient horizontal \
1238            -command "$win.f1.t xview" \
1239            ] -row 2 -column 0 -sticky ew
1240    grid [scrollbar $win.f1.rscr  -command "$win.f1.t yview" \
1241            ] -row 1 -column 1 -sticky ns
1242    # give extra space to the text box
1243    grid columnconfigure $win.f1 0 -weight 1
1244    grid rowconfigure $win.f1 1 -weight 1
1245    $win.f1.t insert end $msg
1246
1247    global makenew
1248    set makenew(result) 0
1249    bind $win <Return> "destroy $win"
1250    bind $win <KeyPress-Prior> "$win.f1.t yview scroll -1 page"
1251    bind $win <KeyPress-Next> "$win.f1.t yview scroll 1 page"
1252    bind $win <KeyPress-Right> "$win.f1.t xview scroll 1 unit"
1253    bind $win <KeyPress-Left> "$win.f1.t xview scroll -1 unit"
1254    bind $win <KeyPress-Up> "$win.f1.t yview scroll -1 unit"
1255    bind $win <KeyPress-Down> "$win.f1.t yview scroll 1 unit"
1256    bind $win <KeyPress-Home> "$win.f1.t yview 0"
1257    bind $win <KeyPress-End> "$win.f1.t yview end"
1258    set i 0
1259    foreach item $optionlist {
1260        pack [button $win.q[incr i] \
1261                -command "set makenew(result) $i; destroy $win" -text $item] -side left
1262    }
1263    putontop $win
1264    tkwait window $win
1265
1266    # fix focus...
1267    afterputontop
1268    return $makenew(result)
1269}
1270
1271#       Message box code that centers the message box over the parent.
1272#          or along the edge, if too close,
1273#          but leave a border along +x & +y for reasons I don't remember
1274#       It also allows the button names to be defined using
1275#            -type $list  -- where $list has a list of button names
1276#       larger messages are placed in a scrolled text widget
1277#       capitalization is now ignored for -default
1278#       The command returns the name button in all lower case letters
1279#       otherwise see  tk_messageBox for a description
1280#
1281#       This is a modification of tkMessageBox (msgbox.tcl v1.5)
1282#
1283proc MyMessageBox {args} {
1284    global tkPriv tcl_platform
1285
1286    set w tkPrivMsgBox
1287    upvar #0 $w data
1288
1289    #
1290    # The default value of the title is space (" ") not the empty string
1291    # because for some window managers, a
1292    #           wm title .foo ""
1293    # causes the window title to be "foo" instead of the empty string.
1294    #
1295    set specs {
1296        {-default "" "" ""}
1297        {-icon "" "" "info"}
1298        {-message "" "" ""}
1299        {-parent "" "" .}
1300        {-title "" "" " "}
1301        {-type "" "" "ok"}
1302    }
1303
1304    tclParseConfigSpec $w $specs "" $args
1305
1306    if {[lsearch {info warning error question} $data(-icon)] == -1} {
1307        error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
1308    }
1309    if {![string compare $tcl_platform(platform) "macintosh"]} {
1310      switch -- $data(-icon) {
1311          "error"     {set data(-icon) "stop"}
1312          "warning"   {set data(-icon) "caution"}
1313          "info"      {set data(-icon) "note"}
1314        }
1315    }
1316
1317    if {![winfo exists $data(-parent)]} {
1318        error "bad window path name \"$data(-parent)\""
1319    }
1320
1321    switch -- $data(-type) {
1322        abortretryignore {
1323            set buttons {
1324                {abort  -width 6 -text Abort -under 0}
1325                {retry  -width 6 -text Retry -under 0}
1326                {ignore -width 6 -text Ignore -under 0}
1327            }
1328        }
1329        ok {
1330            set buttons {
1331                {ok -width 6 -text OK -under 0}
1332            }
1333          if {![string compare $data(-default) ""]} {
1334                set data(-default) "ok"
1335            }
1336        }
1337        okcancel {
1338            set buttons {
1339                {ok     -width 6 -text OK     -under 0}
1340                {cancel -width 6 -text Cancel -under 0}
1341            }
1342        }
1343        retrycancel {
1344            set buttons {
1345                {retry  -width 6 -text Retry  -under 0}
1346                {cancel -width 6 -text Cancel -under 0}
1347            }
1348        }
1349        yesno {
1350            set buttons {
1351                {yes    -width 6 -text Yes -under 0}
1352                {no     -width 6 -text No  -under 0}
1353            }
1354        }
1355        yesnocancel {
1356            set buttons {
1357                {yes    -width 6 -text Yes -under 0}
1358                {no     -width 6 -text No  -under 0}
1359                {cancel -width 6 -text Cancel -under 0}
1360            }
1361        }
1362        default {
1363#           error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
1364            foreach item $data(-type) {
1365                lappend buttons [list [string tolower $item] -text $item -under 0]
1366            }
1367        }
1368    }
1369
1370    if {[string compare $data(-default) ""]} {
1371        set valid 0
1372        foreach btn $buttons {
1373            if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
1374                set valid 1
1375                break
1376            }
1377        }
1378        if {!$valid} {
1379            error "invalid default button \"$data(-default)\""
1380        }
1381    }
1382
1383    # 2. Set the dialog to be a child window of $parent
1384    #
1385    #
1386    if {[string compare $data(-parent) .]} {
1387        set w $data(-parent).__tk__messagebox
1388    } else {
1389        set w .__tk__messagebox
1390    }
1391
1392    # 3. Create the top-level window and divide it into top
1393    # and bottom parts.
1394
1395    catch {destroy $w}
1396    toplevel $w -class Dialog
1397    wm title $w $data(-title)
1398    wm iconname $w Dialog
1399    wm protocol $w WM_DELETE_WINDOW { }
1400    wm transient $w $data(-parent)
1401    if {![string compare $tcl_platform(platform) "macintosh"]} {
1402        unsupported1 style $w dBoxProc
1403    }
1404
1405    frame $w.bot
1406    pack $w.bot -side bottom -fill both
1407    frame $w.top
1408    pack $w.top -side top -fill both -expand 1
1409    if {[string compare $tcl_platform(platform) "macintosh"]} {
1410        $w.bot configure -relief raised -bd 1
1411        $w.top configure -relief raised -bd 1
1412    }
1413
1414    # 4. Fill the top part with bitmap and message (use the option
1415    # database for -wraplength and -font so that they can be
1416    # overridden by the caller).
1417
1418    option add *Dialog.msg.wrapLength 3i widgetDefault
1419
1420    if {[string length $data(-message)] > 300} {
1421        if {![string compare $tcl_platform(platform) "macintosh"]} {
1422            option add *Dialog.msg.t.font system widgetDefault
1423        } else {
1424            option add *Dialog.msg.t.font {Times 18} widgetDefault
1425        }
1426        frame $w.msg
1427        grid [text  $w.msg.t  \
1428                -height 20 -width 55 -relief flat -wrap word \
1429                -yscrollcommand "$w.msg.rscr set" \
1430                ] -row 1 -column 0 -sticky news
1431        grid [scrollbar $w.msg.rscr  -command "$w.msg.t yview" \
1432                ] -row 1 -column 1 -sticky ns
1433        # give extra space to the text box
1434        grid columnconfigure $w.msg 0 -weight 1
1435        grid rowconfigure $w.msg 1 -weight 1
1436        $w.msg.t insert end $data(-message)
1437    } else {
1438        if {![string compare $tcl_platform(platform) "macintosh"]} {
1439            option add *Dialog.msg.font system widgetDefault
1440        } else {
1441            option add *Dialog.msg.font {Times 18} widgetDefault
1442        }
1443        label $w.msg -justify left -text $data(-message)
1444    }
1445    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
1446    if {[string compare $data(-icon) ""]} {
1447        label $w.bitmap -bitmap $data(-icon)
1448        pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
1449    }
1450
1451    # 5. Create a row of buttons at the bottom of the dialog.
1452
1453    set i 0
1454    foreach but $buttons {
1455        set name [lindex $but 0]
1456        set opts [lrange $but 1 end]
1457      if {![llength $opts]} {
1458            # Capitalize the first letter of $name
1459          set capName [string toupper \
1460                    [string index $name 0]][string range $name 1 end]
1461            set opts [list -text $capName]
1462        }
1463
1464      eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
1465
1466        if {![string compare $name $data(-default)]} {
1467            $w.$name configure -default active
1468        }
1469      pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
1470
1471        # create the binding for the key accelerator, based on the underline
1472        #
1473        set underIdx [$w.$name cget -under]
1474        if {$underIdx >= 0} {
1475            set key [string index [$w.$name cget -text] $underIdx]
1476          bind $w <Alt-[string tolower $key]>  [list $w.$name invoke]
1477          bind $w <Alt-[string toupper $key]>  [list $w.$name invoke]
1478        }
1479        incr i
1480    }
1481
1482    # 6. Create a binding for <Return> on the dialog if there is a
1483    # default button.
1484
1485    if {[string compare $data(-default) ""]} {
1486      bind $w <Return> [list tkButtonInvoke $w.$data(-default)]
1487    }
1488
1489    # 7. Withdraw the window, then update all the geometry information
1490    # so we know how big it wants to be, then center the window in the
1491    # display and de-iconify it.
1492
1493    wm withdraw $w
1494    update idletasks
1495    set wp $data(-parent)
1496    # center the new window in the middle of the parent
1497    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
1498            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
1499    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
1500            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
1501    # make sure that we can see the entire window
1502    set xborder 10
1503    set yborder 25
1504    if {$x < 0} {set x 0}
1505    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
1506        incr x [expr \
1507                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
1508    }
1509    if {$y < 0} {set y 0}
1510    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
1511        incr y [expr \
1512                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
1513    }
1514    wm geom $w +$x+$y
1515    wm deiconify $w
1516
1517    # 8. Set a grab and claim the focus too.
1518
1519    set oldFocus [focus]
1520    set oldGrab [grab current $w]
1521    if {[string compare $oldGrab ""]} {
1522        set grabStatus [grab status $oldGrab]
1523    }
1524    grab $w
1525    if {[string compare $data(-default) ""]} {
1526        focus $w.$data(-default)
1527    } else {
1528        focus $w
1529    }
1530
1531    # 9. Wait for the user to respond, then restore the focus and
1532    # return the index of the selected button.  Restore the focus
1533    # before deleting the window, since otherwise the window manager
1534    # may take the focus away so we can't redirect it.  Finally,
1535    # restore any grab that was in effect.
1536
1537    tkwait variable tkPriv(button)
1538    catch {focus $oldFocus}
1539    destroy $w
1540    if {[string compare $oldGrab ""]} {
1541      if {![string compare $grabStatus "global"]} {
1542            grab -global $oldGrab
1543        } else {
1544            grab $oldGrab
1545        }
1546    }
1547    return $tkPriv(button)
1548}
1549
1550#------------------------------------------------------------------------------
1551# Delete History Records
1552proc DeleteHistoryRecords {{msg ""}} {
1553    global expgui
1554    set frm .history
1555    catch {destroy $frm}
1556    toplevel $frm
1557    if {[string trim $msg] == ""} {
1558        set msg "There are [CountHistory] history records"
1559    }
1560    pack [frame $frm.1 -bd 2 -relief groove] -padx 3 -pady 3 -side left
1561    pack [label $frm.1.0 -text $msg] -side top
1562    pack [frame $frm.1.1] -side top
1563    pack [label $frm.1.1.1 -text "Number of entries to keep"] -side left
1564    pack [entry $frm.1.1.2 -width 3 -textvariable expgui(historyKeep)\
1565            ] -side left
1566    set expgui(historyKeep) 10
1567    pack [checkbutton $frm.1.2 -text renumber -variable expgui(renumber)] -side top
1568    set expgui(renumber) 1
1569    pack [frame $frm.2] -padx 3 -pady 3 -side left
1570    pack [button $frm.2.3 -text OK \
1571            -command { 
1572        if ![catch {expr $expgui(historyKeep)}] {
1573            DeleteHistory $expgui(historyKeep) $expgui(renumber)
1574            set expgui(changed) 1
1575            destroy .history
1576        }
1577    }] -side top
1578    pack [button $frm.2.4 -text Quit \
1579            -command {destroy .history}] -side top
1580    bind $frm <Return> "$frm.2.3 invoke"
1581   
1582    # force the window to stay on top
1583    putontop $frm 
1584    focus $frm.2.3
1585    tkwait window $frm
1586    afterputontop
1587}
1588
1589# optionally run disagl as a windowless process, w/results in a separate window
1590proc rundisagl {} {
1591    global expgui txtvw tcl_version tcl_platform
1592    if {$expgui(disaglSeparateBox)} {
1593        set root [file root $expgui(expfile)] 
1594        catch {file delete -force $root.tmp}
1595        catch {file rename -force $root.LST $root.OLS}
1596        # PSW reports this does not happen right away on windows
1597        set i 0
1598        while {$i < 5 && [file exists $root.LST]} {
1599            # debug code
1600            catch {console show}
1601            puts "try $i"
1602            # end debug code
1603            after 100
1604            incr i
1605        }
1606        #run the program
1607        pleasewait "Running DISAGL"     
1608        # create an empty input file
1609        close [open disagl.inp w]
1610        catch {exec [file join $expgui(gsasexe) disagl] \
1611                [file tail $root] < disagl.inp > disagl.out}
1612        catch {file rename -force $root.LST $root.tmp}
1613        catch {file delete -force disagl.inp disagl.out}
1614        catch {file rename -force $root.OLS $root.LST}
1615        donewait
1616        # open a new window
1617        catch {toplevel .disagl}
1618        catch {eval grid forget [grid slaves .disagl]}
1619        text .disagl.txt -width 100 -wrap none \
1620                -yscrollcommand ".disagl.yscroll set" \
1621                -xscrollcommand ".disagl.xscroll set" 
1622        scrollbar .disagl.yscroll -command ".disagl.txt yview"
1623        scrollbar .disagl.xscroll -command ".disagl.txt xview" -orient horizontal
1624        grid .disagl.xscroll -column 0 -row 2 -sticky ew
1625        grid .disagl.txt -column 0 -row 1 -sticky nsew
1626        grid .disagl.yscroll -column 1 -row 1 -sticky ns
1627        grid [frame .disagl.f] -column 0 -columnspan 2 -row 3 -sticky ew
1628        grid columnconfig .disagl.f 2 -weight 1
1629        grid [button .disagl.f.close -text "Close & Delete" \
1630                -command "destroy .disagl; file delete $root.tmp"] \
1631                -column 3 -row 0 -sticky e
1632        grid [button .disagl.f.rename -text "Close & Save as .DIS" \
1633                -command "destroy .disagl; file rename -force $root.tmp $root.DIS"] \
1634                -column 4 -row 0 -sticky e
1635        # allow font changes on the fly
1636        if {$tcl_version >= 8.0} {
1637            .disagl.txt config -font $txtvw(font)
1638            set fontbut [tk_optionMenu .disagl.f.font txtvw(font) ""]
1639            grid .disagl.f.font -column 1 -row 0 -sticky w
1640            grid [label .disagl.f.t -text font:] -column 0 -row 0 -sticky w
1641            $fontbut delete 0 end
1642            foreach f {5 6 7 8 9 10 11 12 13 14 15 16} {
1643                $fontbut add command -label "Courier $f" -font "Courier $f"\
1644                        -command "set txtvw(font) \"Courier $f\"; \
1645                        .disagl.txt config -font \$txtvw(font)"
1646            }
1647        }
1648       
1649        grid columnconfigure .disagl 0 -weight 1
1650        grid rowconfigure .disagl 1 -weight 1
1651        wm title .disagl "DISAGL results $expgui(expfile)"
1652        wm iconname .disagl "DISAGL $root"
1653        set in [open $root.tmp r]
1654        .disagl.txt insert end [read $in]
1655        close $in
1656        bind all  {destroy .disagl}
1657        bind .disagl  ".disagl.txt yview scroll -1 page"
1658        bind .disagl  ".disagl.txt yview scroll 1 page"
1659        bind .disagl  ".disagl.txt xview scroll 1 unit"
1660        bind .disagl  ".disagl.txt xview scroll -1 unit"
1661        bind .disagl  ".disagl.txt yview scroll -1 unit"
1662        bind .disagl  ".disagl.txt yview scroll 1 unit"
1663        bind .disagl  ".disagl.txt yview 0"
1664        bind .disagl  ".disagl.txt yview end"
1665        # don't disable in Win as this prevents the highlighting of selected text
1666        if {$tcl_platform(platform) != "windows"} {
1667            .disagl.txt config -state disabled
1668        }
1669    } else {
1670        runGSASwEXP disagl
1671    }
1672}
1673# tell'em what is happening
1674proc pleasewait {{message {}}} {
1675    catch {destroy .msg}
1676    toplevel .msg
1677    wm transient .msg [winfo toplevel .]
1678    pack [frame .msg.f -bd 4 -relief groove]
1679    pack [message .msg.f.m -text "Please wait $message"]
1680    wm withdraw .msg
1681    update idletasks
1682    # place the message on top of the main window
1683    set x [expr [winfo x .] + [winfo width .]/2 - \
1684            [winfo reqwidth .msg]/2 - [winfo vrootx .]]
1685    if {$x < 0} {set x 0}
1686    set y [expr [winfo y .] + [winfo height .]/2 - \
1687            [winfo reqheight .msg]/2 - [winfo vrooty .]]
1688    if {$y < 0} {set y 0}
1689    wm geom .msg +$x+$y
1690    wm deiconify .msg
1691    focus .msg
1692    grab .msg
1693    update
1694}
1695# clear the message
1696proc donewait {} {
1697    catch {destroy .msg}
1698}
1699
1700
1701# profile terms
1702array set expgui {
1703    prof-T-1 {alp-0 alp-1 bet-0 bet-1 sig-0 sig-1 sig-2 rstr rsta \
1704            rsca s1ec s2ec }
1705    prof-T-2 {alp-0 alp-1 beta switch sig-0 sig-1 sig-2 gam-0 gam-1 \
1706            gam-2 ptec stec difc difa zero }
1707    prof-T-3 {alp bet-0 bet-1 sig-0 sig-1 sig-2 gam-0 gam-1 \
1708            gam-2 gsf g1ec g2ec rstr rsta rsca L11 L22 L33 L12 L13 L23 }
1709    prof-T-4 {alp bet-0 bet-1 sig-1 sig-2 gam-2 g2ec gsf \
1710            rstr rsta rsca eta}
1711    prof-C-1 {GU GV GW asym F1 F2 }
1712    prof-C-2 {GU GV GW LX LY trns asym shft GP stec ptec sfec \
1713            L11 L22 L33 L12 L13 L23 }
1714    prof-C-3 {GU GV GW GP LX LY S/L H/L trns shft stec ptec sfec \
1715            L11 L22 L33 L12 L13 L23 }
1716    prof-C-4 {GU GV GW GP LX ptec trns shft sfec S/L H/L eta} 
1717    prof-E-1 {A B C ds cds}
1718}
1719
1720# number of profile terms depends on the histogram type
1721# the LAUE symmetry and the profile number
1722proc GetProfileTerms {phase hist ptype} {
1723    global expmap expgui
1724    if {$hist == "C" || $hist == "T" || $hist == "E"} {
1725        set htype $hist
1726    } else {
1727        set htype [string range $expmap(htype_$hist) 2 2]
1728    }
1729    # get the cached copy of the profile term labels, when possible
1730    catch {
1731        set lbls $expmap(ProfileTerms${phase}_${ptype}_${htype})
1732        return
1733    }
1734    set lbls {}
1735    catch {set lbls $expgui(prof-$htype-$ptype)}
1736    if {$lbls == ""} {return}
1737    # add terms based on the Laue symmetry
1738    if {($htype == "C" || $htype == "T") && $ptype == 4} {
1739        set laueaxis [GetLaue [phaseinfo $phase spacegroup]]
1740        eval lappend lbls [Profile4Terms $laueaxis]
1741    }
1742    set expmap(ProfileTerms${phase}_${ptype}_${htype}) $lbls
1743    return $lbls
1744}
1745
1746proc Profile4Terms {laueaxis} {
1747    switch -exact $laueaxis {
1748        1bar {return \
1749                "S400 S040 S004 S220 S202 S022 S310 S103 S031 \
1750                S130 S301 S013 S211 S121 S112"}
1751        2/ma {return "S400 S040 S004 S220 S202 S022 S013 S031 S211"}
1752        2/mb {return "S400 S040 S004 S220 S202 S022 S301 S103 S121"}
1753        2/mc {return "S400 S040 S004 S220 S202 S022 S130 S310 S112"}
1754        mmm  {return "S400 S040 S004 S220 S202 S022"}
1755        4/{return "S400 S004 S220 S202"}
1756        4/mmm {return "S400 S004 S220 S202"}
1757        3barR     {return "S400 S220 S310 S211"}
1758        "3bar mR" {return "S400 S220 S310 S211"}
1759        3bar    {return "S400 S004 S202 S211"}
1760        3barm1 {return "S400 S004 S202"}
1761        3bar1m  {return "S400 S004 S202 S211"}
1762        6/m    {return "S400 S004 S202"}
1763        6/mmm  {return "S400 S004 S202"}
1764        "m 3"  {return "S400 S220"}
1765        m3m    {return "S400 S220"}
1766        default {return ""}
1767    }
1768}
1769
1770proc GetLaue {spg} {
1771    global tcl_platform expgui
1772    # check the space group
1773    set fp [open spg.in w]
1774    puts $fp "N"
1775    puts $fp "N"
1776    puts $fp $spg
1777    puts $fp "Q"
1778    close $fp
1779    catch {
1780        if {$tcl_platform(platform) == "windows"} {
1781            exec [file join $expgui(gsasexe) spcgroup.exe] < spg.in >& spg.out
1782        } else {
1783            exec [file join $expgui(gsasexe) spcgroup] < spg.in >& spg.out
1784        }
1785    }
1786    set fp [open spg.out r]
1787    set laue {}
1788    set uniqueaxis {}
1789    while {[gets $fp line] >= 0} {
1790        regexp {Laue symmetry (.*)} $line junk laue
1791        regexp {The unique axis is (.*)} $line junk uniqueaxis
1792    }
1793    close $fp
1794    catch {file delete -force spg.in spg.out}
1795    set laue [string trim $laue]
1796    # add a R suffix for rhombohedral settings
1797    if {[string range [string trim $spg] end end] == "R"} {
1798        return "${laue}${uniqueaxis}R"
1799    }
1800    return "${laue}$uniqueaxis"
1801}
1802
1803
1804# set up to change the profile type for a series of histogram/phase entries
1805# (histlist & phaselist should be lists of the same length)
1806#
1807proc ChangeProfileType {histlist phaselist} {
1808    global expgui expmap
1809    set w .profile
1810    catch {destroy $w}
1811    toplevel $w -bg beige
1812    wm title $w "Change Profile Function"
1813   
1814    # all histogram/phases better be the same type, so we can just use the 1st
1815    set hist [lindex $histlist 0]
1816    set phase [lindex $phaselist 0]
1817    set ptype [string trim [hapinfo $hist $phase proftype]]
1818
1819    # get list of allowed profile terms for the current histogram type
1820    set i 1
1821    while {[set lbls [GetProfileTerms $phase $hist $i]] != ""} {
1822        lappend lbllist $lbls
1823        incr i
1824    }
1825    # labels for the current type
1826    set i $ptype
1827    set oldlbls [lindex $lbllist [incr i -1]]
1828   
1829    if {[llength $histlist] == 1} {
1830        pack [label $w.a -bg beige \
1831                -text "Change profile function for Histogram #$hist Phase #$phase" \
1832                ] -side top
1833    } else {
1834        # make a list of histograms by phase
1835        foreach h $histlist p $phaselist {
1836            lappend phlist($p) $h
1837        }
1838        set num 0
1839        pack [frame $w.a -bg beige] -side top
1840        pack [label $w.a.$num -bg beige \
1841                -text "Change profile function for:" \
1842                ] -side top -anchor w
1843        foreach i [lsort [array names phlist]] {
1844            incr num
1845            pack [label $w.a.$num -bg beige -text \
1846                    "\tPhase #$i, Histograms [CompressList $phlist($i)]" \
1847                    ] -side top -anchor w
1848        }
1849    }
1850    pack [label $w.e1 \
1851            -text "Current function is type $ptype." \
1852            -bg beige] -side top -anchor w
1853    pack [frame $w.e -bg beige] -side top -expand yes -fill both
1854    pack [label $w.e.1 \
1855            -text "Set function to type" \
1856            -bg beige] -side left
1857    set menu [tk_optionMenu $w.e.2 expgui(newpeaktype) junk]
1858    pack $w.e.2 -side left -anchor w
1859
1860    pack [radiobutton $w.e.4 -bg beige -variable expgui(DefaultPeakType) \
1861            -command "set expgui(newpeaktype) $ptype; \
1862            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
1863            -value 1 -text "Current value overrides"] -side right
1864    pack [radiobutton $w.e.3 -bg beige -variable expgui(DefaultPeakType) \
1865            -command \
1866            "set expgui(newpeaktype) $ptype; \
1867            FillChangeProfileType $w.c $hist $phase $ptype [list $oldlbls] [list $oldlbls]" \
1868            -value 0 -text "Default value overrides"] -side right
1869
1870    $w.e.2 config -bg beige
1871    pack [frame $w.c -bg beige] -side top -expand yes -fill both
1872    pack [frame $w.d -bg beige] -side top -expand yes -fill both
1873    pack [button $w.d.2 -text Set -bg beige \
1874            -command "SaveChangeProfileType $w.c $histlist $phaselist; destroy $w"\
1875            ] -side left
1876    pack [button $w.d.3 -text Quit -bg beige \
1877            -command "destroy $w"] -side left
1878    bind $w <Return> "destroy $w"
1879
1880    $menu delete 0 end
1881    set i 0
1882    foreach lbls $lbllist {
1883        incr i
1884        $menu add command -label $i -command \
1885                "set expgui(newpeaktype) $i; \
1886                FillChangeProfileType $w.c $hist $phase $i [list $lbls] [list $oldlbls]"
1887    }
1888    set expgui(newpeaktype) $ptype
1889    FillChangeProfileType $w.c $hist $phase $ptype $oldlbls $oldlbls
1890
1891    # force the window to stay on top
1892    putontop $w
1893    focus $w.e.2
1894    tkwait window $w
1895    afterputontop
1896    sethistlist
1897}
1898
1899# save the changes to the profile
1900proc SaveChangeProfileType {w histlist phaselist} {
1901    global expgui
1902    foreach phase $phaselist hist $histlist {
1903        hapinfo $hist $phase proftype set $expgui(newpeaktype)
1904        hapinfo $hist $phase profterms set $expgui(newProfileTerms)
1905        for {set i 1} {$i <=  $expgui(newProfileTerms)} {incr i} {
1906            hapinfo $hist $phase pterm$i set [$w.ent${i} get]
1907            hapinfo $hist $phase pref$i set $expgui(ProfRef$i)
1908        }
1909        set i [expr 1+$expgui(newProfileTerms)]
1910        hapinfo $hist $phase pcut set [$w.ent$i get]
1911        incr expgui(changed) [expr 3 + $expgui(newProfileTerms)]
1912    }
1913}
1914
1915# file the contents of the "Change Profile Type" Menu
1916proc FillChangeProfileType {w hist phase newtype lbls oldlbls} {
1917    global expgui expmap
1918    set ptype [string trim [hapinfo $hist $phase proftype]]
1919    catch {unset oldval}
1920    # loop through the old terms and set up an array of starting values
1921    set num 0
1922    foreach term $oldlbls {
1923        incr num
1924        set oldval($term) [hapinfo $hist $phase pterm$num]
1925    }
1926    set oldval(Peak\nCutoff) [hapinfo $hist $phase pcut]
1927
1928    # is the new type the same as the current?
1929    if {$ptype == $newtype} {
1930        set nterms [hapinfo $hist $phase profterms]
1931    } else {
1932        set nterms [llength $lbls]
1933    }
1934    set expgui(newProfileTerms) $nterms
1935    set expgui(CurrentProfileTerms) $nterms
1936    # which default profile set matches the new type
1937    set setnum {}
1938    foreach j {" " 1 2 3 4 5 6 7 8 9} {
1939        set i [profdefinfo $hist $j proftype]
1940        if {$i == ""} continue
1941        if {$i == $newtype} {
1942            set setnum $j
1943            break
1944        }
1945    }
1946
1947    eval destroy [winfo children $w]
1948
1949    set colstr 0
1950    set row 2
1951    set maxrow [expr $row + $nterms/2]
1952    for { set num 1 } { $num <= $nterms + 1} { incr num } {
1953        # get the default value (originally from the in .INS file)
1954        set val {}
1955        if {$setnum != ""} {
1956            set val 0.0
1957            catch {
1958                set val [profdefinfo $hist $setnum pterm$num]
1959                # pretty up the number
1960                if {$val == 0.0} {
1961                    set val 0.0
1962                } elseif {abs($val) < 1e-2 || abs($val) > 1e6} {
1963                    set val [format %.3e $val]
1964                } elseif {abs($val) > 1e-2 && abs($val) < 10} {
1965                    set val [format %.5f $val]
1966                } elseif {abs($val) < 9999} {
1967                    set val [format %.2f $val]
1968                } elseif {abs($val) < 1e6} {
1969                    set val [format %.0f $val]
1970                }
1971            }
1972        }
1973        # heading
1974        if {$row == 2} {
1975            set col $colstr
1976            grid [label $w.h0${num} -text "lbl" -bg beige] \
1977                -row $row -column $col
1978            grid [label $w.h2${num} -text "ref" -bg beige] \
1979                -row $row -column [incr col]
1980            grid [label $w.h3${num} -text "next value" -bg beige] \
1981                -row $row -column [incr col]
1982            grid [label $w.h4${num} -text "default" -bg beige] \
1983                -row $row -column [incr col]
1984            grid [label $w.h5${num} -text "current" -bg beige] \
1985                -row $row -column [incr col]
1986        }
1987        set col $colstr
1988        incr row
1989        set term {}
1990        catch {set term [lindex $lbls [expr $num-1]]}
1991        if {$term == ""} {set term $num}
1992        if {$num == $nterms + 1} {
1993            set term "Peak\nCutoff"
1994            set val {}
1995            if {$setnum != ""} {
1996                set val 0.0
1997                catch {set val [profdefinfo $hist $setnum pcut]}
1998            }
1999        }
2000
2001        grid [label $w.l${num} -text "$term" -bg beige] \
2002                -row $row -column $col
2003        grid [checkbutton $w.chk${num} -variable expgui(ProfRef$num) \
2004                -bg beige -activebackground beige] -row $row -column [incr col]
2005        grid [entry $w.ent${num} \
2006                -width 12] -row $row -column [incr col]
2007        if {$val != ""} {
2008            grid [button $w.def${num} -text $val -command \
2009                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $val" \
2010                    ] -row $row -column [incr col] -sticky ew
2011        } else {
2012            grid [label $w.def${num} -text (none) \
2013                    ] -row $row -column [incr col]
2014        }
2015        set curval {}
2016        catch {
2017            set curval [expr $oldval($term)]
2018            # pretty up the number
2019            if {$curval == 0.0} {
2020                set curval 0.0
2021            } elseif {abs($curval) < 1e-2 || abs($curval) > 1e6} {
2022                set curval [format %.3e $curval]
2023            } elseif {abs($curval) > 1e-2 && abs($curval) < 10} {
2024                set curval [format %.5f $curval]
2025            } elseif {abs($curval) < 9999} {
2026                set curval [format %.2f $curval]
2027            } elseif {abs($curval) < 1e6} {
2028                set curval [format %.0f $curval]
2029            }
2030            grid [button $w.cur${num} -text $curval -command  \
2031                    "$w.ent${num} delete 0 end; $w.ent${num} insert end $curval" \
2032                    ] -row $row -column [incr col] -sticky ew
2033        }
2034        # set default values for flag and value
2035        set ref 0
2036        if {$setnum != ""} {
2037            catch {
2038                if {[profdefinfo $hist $setnum pref$num] == "Y"} {set ref 1}
2039            }
2040        }
2041        set expgui(ProfRef$num) $ref
2042       
2043        $w.ent${num} delete 0 end
2044        if {!$expgui(DefaultPeakType) && $val != ""} {
2045            $w.ent${num} insert end $val
2046        } elseif {$curval != ""} {
2047            $w.ent${num} insert end $curval
2048        } elseif {$val != ""} {
2049            $w.ent${num} insert end $val
2050        } else {
2051            $w.ent${num} insert end 0.0
2052        }
2053        if {$row > $maxrow} {
2054            set row 2
2055            incr colstr 5
2056        }
2057    }
2058}
Note: See TracBrowser for help on using the repository browser.