source: trunk/gsascmds.tcl @ 324

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

# on 2000/10/12 22:12:21, toby did:
fix html bugs for Windows

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