| 1 | # implement next |
|---|
| 2 | |
|---|
| 3 | # platform-specific code |
|---|
| 4 | if {$tcl_platform(platform) == "windows"} { |
|---|
| 5 | if [catch {package require winexec}] { |
|---|
| 6 | tk_dialog .err "WINEXEC Error" \ |
|---|
| 7 | "Error -- Unable to load the WINEXEC package. This is needed in Win95 machines" \ |
|---|
| 8 | error 0 Quit |
|---|
| 9 | destroy . |
|---|
| 10 | } |
|---|
| 11 | # this is a compress program used for archiving of .EXP files |
|---|
| 12 | set compressprog "pkzip -m" |
|---|
| 13 | if {$tcl_platform(os) == "Windows 95" || $tcl_platform(os) == "Windows 98" } { |
|---|
| 14 | proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} { |
|---|
| 15 | global expgui |
|---|
| 16 | set pwd [file nativename [pwd]] |
|---|
| 17 | |
|---|
| 18 | # check the path -- can DOS use it? |
|---|
| 19 | if {[string first // [pwd]] != -1} { |
|---|
| 20 | tk_dialog .braindead "Invalid Path" \ |
|---|
| 21 | {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) \ |
|---|
| 22 | Win-95 can't directly access a network drive in DOS} error 0 OK |
|---|
| 23 | return |
|---|
| 24 | } |
|---|
| 25 | # all winexec commands are background commands |
|---|
| 26 | # if $background |
|---|
| 27 | |
|---|
| 28 | # pause is hard coded in the .BAT file |
|---|
| 29 | #if $wait { |
|---|
| 30 | # append command " pause" |
|---|
| 31 | #} |
|---|
| 32 | |
|---|
| 33 | # replace the forward slashes with backward |
|---|
| 34 | regsub -all / $command \\ command |
|---|
| 35 | # Win95 does not seem to inherit the environment from Tcl env vars |
|---|
| 36 | # so define it in the .BAT file |
|---|
| 37 | winexec -d [file nativename [pwd]] \ |
|---|
| 38 | [file join $expgui(scriptdir) gsastcl.bat] \ |
|---|
| 39 | "[file nativename $expgui(gsasdir)] $command" |
|---|
| 40 | } |
|---|
| 41 | } else { |
|---|
| 42 | # now for - brain-dead Windows-NT |
|---|
| 43 | proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} { |
|---|
| 44 | # all winexec commands are background commands -- ignore background |
|---|
| 45 | |
|---|
| 46 | # can't get pause to work! -- ignore wait |
|---|
| 47 | |
|---|
| 48 | set prevcmd {} |
|---|
| 49 | foreach cmd $command { |
|---|
| 50 | if {$prevcmd != ""} { |
|---|
| 51 | tk_dialog .done_yet Confirm "Press OK to start command $cmd" "" 0 OK |
|---|
| 52 | } |
|---|
| 53 | # replace the forward slashes with backward |
|---|
| 54 | regsub -all / $cmd \\ cmd |
|---|
| 55 | # cmd.exe must be in the path -- lets hope that at least works! |
|---|
| 56 | winexec -d [file nativename [pwd]] cmd.exe "/c $cmd" |
|---|
| 57 | set prevcmd $cmd |
|---|
| 58 | } |
|---|
| 59 | } |
|---|
| 60 | # Windows environment variables |
|---|
| 61 | # -95 does not seem to be able to use these |
|---|
| 62 | set env(GSAS) [file nativename $expgui(gsasexe)] |
|---|
| 63 | # PGPLOT_FONT is needed by PGPLOT |
|---|
| 64 | set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]] |
|---|
| 65 | # this is the number of lines/page in the .LST (etc.) file |
|---|
| 66 | set env(LENPAGE) 60 |
|---|
| 67 | } |
|---|
| 68 | } else { |
|---|
| 69 | # UNIX environment variables |
|---|
| 70 | set env(GSASEXE) $expgui(gsasexe) |
|---|
| 71 | set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat] |
|---|
| 72 | set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat] |
|---|
| 73 | # PGPLOT_DIR is needed by PGPLOT |
|---|
| 74 | set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl] |
|---|
| 75 | # this is the number of lines/page in the .LST (etc.) file |
|---|
| 76 | set env(LENPAGE) 60 |
|---|
| 77 | if [catch {set env(GSASBACKSPACE)}] {set env(GSASBACKSPACE) 1} |
|---|
| 78 | |
|---|
| 79 | # this is a compress program used for archiving of .EXP files |
|---|
| 80 | set compressprog gzip |
|---|
| 81 | proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} { |
|---|
| 82 | global env |
|---|
| 83 | set termopts {} |
|---|
| 84 | if $env(GSASBACKSPACE) { |
|---|
| 85 | append termopts \ |
|---|
| 86 | {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"} |
|---|
| 87 | } |
|---|
| 88 | if $scrollbar { |
|---|
| 89 | append termopts " -sb" |
|---|
| 90 | } else { |
|---|
| 91 | append termopts " +sb" |
|---|
| 92 | } |
|---|
| 93 | if $background { |
|---|
| 94 | set suffix {&} |
|---|
| 95 | } else { |
|---|
| 96 | set suffix {} |
|---|
| 97 | } |
|---|
| 98 | # |
|---|
| 99 | if $wait { |
|---|
| 100 | append command "\; echo -n Press Enter to continue \; read x" |
|---|
| 101 | } |
|---|
| 102 | if !$background {wm iconify .} |
|---|
| 103 | eval exec xterm $termopts -title [list $title] \ |
|---|
| 104 | -e /bin/sh -c [list $command] $suffix |
|---|
| 105 | if !$background {wm deiconify .} |
|---|
| 106 | } |
|---|
| 107 | } |
|---|
| 108 | |
|---|
| 109 | |
|---|
| 110 | proc newexp {} { |
|---|
| 111 | global infile outfile |
|---|
| 112 | set frm .file |
|---|
| 113 | catch {destroy $frm} |
|---|
| 114 | toplevel $frm |
|---|
| 115 | pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left |
|---|
| 116 | pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left |
|---|
| 117 | pack [button $frmC.b -text Create -command "valid_new_exp_file"] -side top |
|---|
| 118 | bind $frm <Return> "valid_new_exp_file" |
|---|
| 119 | pack [button $frmC.q -text Quit -command "set infile(done) 2"] -side top |
|---|
| 120 | |
|---|
| 121 | pack [label $frmA.0 -text "Enter an experiment file"] -side top -anchor center |
|---|
| 122 | expfilebox $frmA infile 2 |
|---|
| 123 | set infile(done) 0 |
|---|
| 124 | # force the window to stay on top |
|---|
| 125 | wm transient $frm [winfo toplevel [winfo parent $frm]] |
|---|
| 126 | |
|---|
| 127 | wm withdraw $frm |
|---|
| 128 | update idletasks |
|---|
| 129 | # center the new window in the middle of the parent |
|---|
| 130 | set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \ |
|---|
| 131 | [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]] |
|---|
| 132 | set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \ |
|---|
| 133 | [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]] |
|---|
| 134 | wm geom $frm +$x+$y |
|---|
| 135 | wm deiconify $frm |
|---|
| 136 | |
|---|
| 137 | set oldFocus [focus] |
|---|
| 138 | set oldGrab [grab current $frm] |
|---|
| 139 | if {$oldGrab != ""} { |
|---|
| 140 | set grabStatus [grab status $oldGrab] |
|---|
| 141 | } |
|---|
| 142 | grab $frm |
|---|
| 143 | focus $frmC.b |
|---|
| 144 | tkwait variable infile(done) |
|---|
| 145 | destroy $frm |
|---|
| 146 | catch {focus $oldFocus} |
|---|
| 147 | if {$oldGrab != ""} { |
|---|
| 148 | if {$grabStatus == "global"} { |
|---|
| 149 | grab -global $oldGrab |
|---|
| 150 | } else { |
|---|
| 151 | grab $oldGrab |
|---|
| 152 | } |
|---|
| 153 | } |
|---|
| 154 | if {$infile(done) == 2} return |
|---|
| 155 | return [file join $infile(dir) $infile(name)] |
|---|
| 156 | } |
|---|
| 157 | |
|---|
| 158 | proc getstring {what "chars 40" "quit 1" "initvalue {}"} { |
|---|
| 159 | global expgui expmap |
|---|
| 160 | set w .global |
|---|
| 161 | catch {destroy $w} |
|---|
| 162 | toplevel $w -bg beige |
|---|
| 163 | wm title $w "Input $what" |
|---|
| 164 | set expgui(temp) {} |
|---|
| 165 | pack [frame $w.0 -bd 6 -relief groove -bg beige] \ |
|---|
| 166 | -side top -expand yes -fill both |
|---|
| 167 | grid [label $w.0.a -text "Input a value for the $what" \ |
|---|
| 168 | -bg beige] \ |
|---|
| 169 | -row 0 -column 0 -columnspan 10 |
|---|
| 170 | grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \ |
|---|
| 171 | -row 1 -column 0 |
|---|
| 172 | |
|---|
| 173 | set expgui(temp) $initvalue |
|---|
| 174 | pack [frame $w.b] -side top |
|---|
| 175 | pack [button $w.b.2 -text Set -command "destroy $w"] -side left |
|---|
| 176 | if $quit { |
|---|
| 177 | pack [button $w.b.3 -text Quit \ |
|---|
| 178 | -command "set expgui(temp) {}; destroy $w"] -side left |
|---|
| 179 | } |
|---|
| 180 | # force the window to stay on top |
|---|
| 181 | wm transient $w [winfo toplevel [winfo parent $w]] |
|---|
| 182 | |
|---|
| 183 | bind $w <Return> "destroy $w" |
|---|
| 184 | wm withdraw $w |
|---|
| 185 | update idletasks |
|---|
| 186 | # center the new window in the middle of the parent |
|---|
| 187 | set x [expr [winfo x [winfo parent $w]] + [winfo width .]/2 - \ |
|---|
| 188 | [winfo reqwidth $w]/2 - [winfo vrootx [winfo parent $w]]] |
|---|
| 189 | set y [expr [winfo y [winfo parent $w]] + [winfo height .]/2 - \ |
|---|
| 190 | [winfo reqheight $w]/2 - [winfo vrooty [winfo parent $w]]] |
|---|
| 191 | wm geom $w +$x+$y |
|---|
| 192 | wm deiconify $w |
|---|
| 193 | |
|---|
| 194 | set oldFocus [focus] |
|---|
| 195 | set oldGrab [grab current $w] |
|---|
| 196 | if {$oldGrab != ""} { |
|---|
| 197 | set grabStatus [grab status $oldGrab] |
|---|
| 198 | } |
|---|
| 199 | grab $w |
|---|
| 200 | focus $w.b.2 |
|---|
| 201 | tkwait window $w |
|---|
| 202 | catch {focus $oldFocus} |
|---|
| 203 | if {$oldGrab != ""} { |
|---|
| 204 | if {$grabStatus == "global"} { |
|---|
| 205 | grab -global $oldGrab |
|---|
| 206 | } else { |
|---|
| 207 | grab $oldGrab |
|---|
| 208 | } |
|---|
| 209 | } |
|---|
| 210 | return $expgui(temp) |
|---|
| 211 | } |
|---|
| 212 | |
|---|
| 213 | |
|---|
| 214 | proc next {direction} { |
|---|
| 215 | global |
|---|
| 216 | set filelist [lsort [glob *.EXP]] |
|---|
| 217 | set ind [lsearch $filelist $expnam.EXP] |
|---|
| 218 | if {$ind == -1 && $expnam != ""} return |
|---|
| 219 | if $direction { # true positive |
|---|
| 220 | incr ind |
|---|
| 221 | } { |
|---|
| 222 | incr ind -1 |
|---|
| 223 | } |
|---|
| 224 | if {$ind < 0} {set ind [expr [llength $filelist]-1]} |
|---|
| 225 | if {$ind >= [llength $filelist] } {set ind 0} |
|---|
| 226 | set expnam [string toupper [file root [lindex $filelist $ind]]] |
|---|
| 227 | showexp |
|---|
| 228 | } |
|---|
| 229 | |
|---|
| 230 | proc runGSASprog {proglist} { |
|---|
| 231 | global expgui tcl_platform |
|---|
| 232 | set cmd {} |
|---|
| 233 | foreach prog $proglist { |
|---|
| 234 | if {$tcl_platform(platform) == "windows"} { |
|---|
| 235 | append cmd " \"$expgui(gsasexe)/${prog}.exe \" " |
|---|
| 236 | } else { |
|---|
| 237 | if {$cmd != ""} {append cmd "\;"} |
|---|
| 238 | append cmd "[file join $expgui(gsasexe) $prog]" |
|---|
| 239 | } |
|---|
| 240 | } |
|---|
| 241 | forknewterm $prog $cmd 0 1 1 |
|---|
| 242 | } |
|---|
| 243 | |
|---|
| 244 | proc runGSASwEXP {proglist} { |
|---|
| 245 | global expgui tcl_platform |
|---|
| 246 | # Save the current exp file |
|---|
| 247 | savearchiveexp |
|---|
| 248 | set cmd {} |
|---|
| 249 | set expnam [file root [file tail $expgui(expfile)]] |
|---|
| 250 | foreach prog $proglist { |
|---|
| 251 | if {$prog == "expedt" && $expgui(archive)} archiveexp |
|---|
| 252 | if {$tcl_platform(platform) == "windows"} { |
|---|
| 253 | append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" " |
|---|
| 254 | } else { |
|---|
| 255 | if {$cmd != ""} {append cmd "\;"} |
|---|
| 256 | append cmd "[file join $expgui(gsasexe) $prog] $expnam" |
|---|
| 257 | } |
|---|
| 258 | } |
|---|
| 259 | forknewterm "$prog -- $expnam" $cmd 0 1 1 |
|---|
| 260 | wm deiconify . |
|---|
| 261 | } |
|---|
| 262 | |
|---|
| 263 | proc liveplot {} { |
|---|
| 264 | global expgui liveplot wishshell |
|---|
| 265 | set expnam [file root [file tail $expgui(expfile)]] |
|---|
| 266 | exec $wishshell [file join $expgui(scriptdir) liveplot] \ |
|---|
| 267 | $expnam $expgui(gsasexe) $liveplot(hst) $liveplot(legend) & |
|---|
| 268 | } |
|---|
| 269 | |
|---|
| 270 | proc lstview {} { |
|---|
| 271 | global expgui wishshell |
|---|
| 272 | set expnam [file root [file tail $expgui(expfile)]] |
|---|
| 273 | exec $wishshell [file join $expgui(scriptdir) lstview] $expnam & |
|---|
| 274 | } |
|---|
| 275 | |
|---|
| 276 | proc widplt {} { |
|---|
| 277 | global expgui wishshell |
|---|
| 278 | set expnam [file root [file tail $expgui(expfile)]] |
|---|
| 279 | exec $wishshell [file join $expgui(scriptdir) widplt] $expgui(gsasexe) $expnam & |
|---|
| 280 | } |
|---|
| 281 | |
|---|
| 282 | |
|---|
| 283 | proc showhelp {} { |
|---|
| 284 | global expgui_helplist helpmsg |
|---|
| 285 | set helpmsg {} |
|---|
| 286 | set frm .help |
|---|
| 287 | catch {destroy $frm} |
|---|
| 288 | toplevel $frm |
|---|
| 289 | wm title $frm "Command Help" |
|---|
| 290 | pack [message $frm.0 -text \ |
|---|
| 291 | "Click on an entry below to see help on a GSAS command" ] \ |
|---|
| 292 | -side top |
|---|
| 293 | pack [frame $frm.a -width 20 -height 15] \ |
|---|
| 294 | -side top -expand yes -fill both |
|---|
| 295 | pack [message $frm.help -textvariable helpmsg -relief groove] \ |
|---|
| 296 | -side left -fill both -expand yes |
|---|
| 297 | set lst [array names expgui_helplist] |
|---|
| 298 | listbox $frm.a.cmds -relief raised -bd 2 -yscrollcommand \ |
|---|
| 299 | "$frm.a.scroll set" -height 15 -width 0 |
|---|
| 300 | scrollbar $frm.a.scroll -command "$frm.a.cmds yview" |
|---|
| 301 | foreach item [lsort $lst] { |
|---|
| 302 | $frm.a.cmds insert end $item |
|---|
| 303 | } |
|---|
| 304 | if {[$frm.a.cmds curselection] == ""} {$frm.a.cmds selection set 0} |
|---|
| 305 | button $frm.a.done -text Done -command "destroy $frm" |
|---|
| 306 | bind $frm.a.cmds <ButtonRelease-1> \ |
|---|
| 307 | "+set helpmsg \$expgui_helplist(\[$frm.a.cmds get \[$frm.a.cmds curselection\]\])" |
|---|
| 308 | pack $frm.a.scroll -side left -fill y |
|---|
| 309 | pack $frm.a.cmds -side left -expand yes -anchor w |
|---|
| 310 | pack $frm.a.done -side right -expand no |
|---|
| 311 | # get the size of the window and expand the message boxes to match |
|---|
| 312 | update |
|---|
| 313 | set width [lindex [split [wm geometry $frm] x+] 0] |
|---|
| 314 | $frm.0 config -width $width |
|---|
| 315 | $frm.help config -width $width |
|---|
| 316 | # waitdone $frm |
|---|
| 317 | } |
|---|
| 318 | |
|---|
| 319 | proc convfile {} { |
|---|
| 320 | global tcl_platform |
|---|
| 321 | if {$tcl_platform(platform) == "windows"} { |
|---|
| 322 | convwin |
|---|
| 323 | } else { |
|---|
| 324 | convunix |
|---|
| 325 | } |
|---|
| 326 | } |
|---|
| 327 | |
|---|
| 328 | # file conversions for UNIX (convstod convdtos) |
|---|
| 329 | proc convunix {} { |
|---|
| 330 | global expgui infile outfile |
|---|
| 331 | set frm .file |
|---|
| 332 | catch {destroy $frm} |
|---|
| 333 | toplevel $frm |
|---|
| 334 | wm title $frm "Convert File" |
|---|
| 335 | pack [frame [set frm0 $frm.0] -bd 2 -relief groove] -padx 3 -pady 3 -side top |
|---|
| 336 | pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left |
|---|
| 337 | pack [frame [set frmB $frm.2] -bd 2 -relief groove] -padx 3 -pady 3 -side left |
|---|
| 338 | pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left |
|---|
| 339 | pack [button $frmC.b -text Convert -command "valid_conv_file"] -side top |
|---|
| 340 | pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side top |
|---|
| 341 | |
|---|
| 342 | pack [label $frmA.0 -text "Select an input file"] -side top -anchor center |
|---|
| 343 | pack [label $frmB.0 -text "Enter an output file"] -side top -anchor center |
|---|
| 344 | |
|---|
| 345 | pack [label $frm0.1 -text "Convert to:"] -side top -anchor w |
|---|
| 346 | pack [radiobutton $frm0.2 -text "direct access" -value convstod \ |
|---|
| 347 | -command setoutfile \ |
|---|
| 348 | -variable outfile(type)] -side top -anchor w |
|---|
| 349 | pack [radiobutton $frm0.3 -text "sequential" -value convdtos \ |
|---|
| 350 | -command setoutfile \ |
|---|
| 351 | -variable outfile(type)] -side top -anchor w |
|---|
| 352 | set outfile(type) "" |
|---|
| 353 | cnvfilebox $frmA infile 1 |
|---|
| 354 | cnvfilebox $frmB outfile 0 |
|---|
| 355 | set infile(done) 0 |
|---|
| 356 | # force the window to stay on top |
|---|
| 357 | wm transient $frm [winfo toplevel [winfo parent $frm]] |
|---|
| 358 | |
|---|
| 359 | bind $frm <Return> "valid_conv_file" |
|---|
| 360 | wm withdraw $frm |
|---|
| 361 | update idletasks |
|---|
| 362 | # center the new window in the middle of the parent |
|---|
| 363 | set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \ |
|---|
| 364 | [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]] |
|---|
| 365 | set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \ |
|---|
| 366 | [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]] |
|---|
| 367 | wm geom $frm +$x+$y |
|---|
| 368 | wm deiconify $frm |
|---|
| 369 | |
|---|
| 370 | set oldFocus [focus] |
|---|
| 371 | set oldGrab [grab current $frm] |
|---|
| 372 | if {$oldGrab != ""} { |
|---|
| 373 | set grabStatus [grab status $oldGrab] |
|---|
| 374 | } |
|---|
| 375 | grab $frm |
|---|
| 376 | focus $frmC.q |
|---|
| 377 | update |
|---|
| 378 | tkwait variable infile(done) |
|---|
| 379 | catch {focus $oldFocus} |
|---|
| 380 | if {$oldGrab != ""} { |
|---|
| 381 | if {$grabStatus == "global"} { |
|---|
| 382 | grab -global $oldGrab |
|---|
| 383 | } else { |
|---|
| 384 | grab $oldGrab |
|---|
| 385 | } |
|---|
| 386 | } |
|---|
| 387 | destroy $frm |
|---|
| 388 | } |
|---|
| 389 | |
|---|
| 390 | # validate the files and make the conversion |
|---|
| 391 | proc valid_conv_file {} { |
|---|
| 392 | global infile outfile expgui |
|---|
| 393 | if {$outfile(type) == "convstod" || $outfile(type) == "convdtos"} { |
|---|
| 394 | set convtype $outfile(type) |
|---|
| 395 | } else { |
|---|
| 396 | return |
|---|
| 397 | } |
|---|
| 398 | if {$infile(name) == ""} return |
|---|
| 399 | if {$outfile(name) == ""} return |
|---|
| 400 | if {$infile(name) == $outfile(name)} { |
|---|
| 401 | tk_dialog .warn Notify "Sorry, filenames must differ" warning 0 OK |
|---|
| 402 | return |
|---|
| 403 | } |
|---|
| 404 | if ![file exists [file join $infile(dir) $infile(name)]] { |
|---|
| 405 | tk_dialog .warn Notify \ |
|---|
| 406 | "Sorry, file $infile(name) not found in $infile(dir)" warning 0 OK |
|---|
| 407 | return |
|---|
| 408 | } |
|---|
| 409 | if [file exists [file join $outfile(dir) $outfile(name)]] { |
|---|
| 410 | if [tk_dialog .warn Notify \ |
|---|
| 411 | "Warning: file $outfile(name) exists in $outfile(dir). OK to overwrite?" \ |
|---|
| 412 | warning 0 OK No] return |
|---|
| 413 | } |
|---|
| 414 | if [catch { |
|---|
| 415 | exec [file join $expgui(gsasexe) $convtype] < \ |
|---|
| 416 | [file join $infile(dir) $infile(name)] > \ |
|---|
| 417 | [file join $outfile(dir) $outfile(name)] |
|---|
| 418 | } errmsg] { |
|---|
| 419 | tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK |
|---|
| 420 | } else { |
|---|
| 421 | if [tk_dialog .converted Notify \ |
|---|
| 422 | "File converted. Convert more files?" \ |
|---|
| 423 | "" 0 Yes No] {set infile(done) 1} |
|---|
| 424 | } |
|---|
| 425 | } |
|---|
| 426 | |
|---|
| 427 | # file conversions for Windows |
|---|
| 428 | proc convwin {} { |
|---|
| 429 | global expgui infile outfile |
|---|
| 430 | set frm .file |
|---|
| 431 | catch {destroy $frm} |
|---|
| 432 | toplevel $frm |
|---|
| 433 | wm title $frm "Convert File" |
|---|
| 434 | pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left |
|---|
| 435 | pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left |
|---|
| 436 | pack [button $frmC.b -text Convert -command "valid_conv_win"] -side top |
|---|
| 437 | pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side top |
|---|
| 438 | pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center |
|---|
| 439 | cnvfilebox $frmA outfile 1 |
|---|
| 440 | set infile(done) 0 |
|---|
| 441 | # force the window to stay on top |
|---|
| 442 | wm transient $frm [winfo toplevel [winfo parent $frm]] |
|---|
| 443 | |
|---|
| 444 | bind $frm <Return> "valid_conv_file" |
|---|
| 445 | wm withdraw $frm |
|---|
| 446 | update idletasks |
|---|
| 447 | # center the new window in the middle of the parent |
|---|
| 448 | set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \ |
|---|
| 449 | [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]] |
|---|
| 450 | set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \ |
|---|
| 451 | [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]] |
|---|
| 452 | wm geom $frm +$x+$y |
|---|
| 453 | wm deiconify $frm |
|---|
| 454 | |
|---|
| 455 | set oldFocus [focus] |
|---|
| 456 | set oldGrab [grab current $frm] |
|---|
| 457 | if {$oldGrab != ""} { |
|---|
| 458 | set grabStatus [grab status $oldGrab] |
|---|
| 459 | } |
|---|
| 460 | grab $frm |
|---|
| 461 | focus $frmC.q |
|---|
| 462 | update |
|---|
| 463 | tkwait variable infile(done) |
|---|
| 464 | if {$oldGrab != ""} { |
|---|
| 465 | if {$grabStatus == "global"} { |
|---|
| 466 | grab -global $oldGrab |
|---|
| 467 | } else { |
|---|
| 468 | grab $oldGrab |
|---|
| 469 | } |
|---|
| 470 | } |
|---|
| 471 | destroy $frm |
|---|
| 472 | } |
|---|
| 473 | |
|---|
| 474 | # validate the files and make the conversion |
|---|
| 475 | proc valid_conv_win {} { |
|---|
| 476 | global infile outfile expgui |
|---|
| 477 | if {$outfile(name) == ""} return |
|---|
| 478 | if ![file exists $outfile(dir)/$outfile(name)] { |
|---|
| 479 | tk_dialog .warn Notify \ |
|---|
| 480 | "Sorry, file $outfile(name) not found in $outfile(dir)" warning 0 OK |
|---|
| 481 | return |
|---|
| 482 | } |
|---|
| 483 | if [catch { |
|---|
| 484 | set newname "[file rootname $outfile(name)].tmp" |
|---|
| 485 | set oldname "[file rootname $outfile(name)].seq" |
|---|
| 486 | set in [open $outfile(dir)/$outfile(name) r] |
|---|
| 487 | set out [open $outfile(dir)/$newname w] |
|---|
| 488 | set len [gets $in line] |
|---|
| 489 | if {$len > 160} { |
|---|
| 490 | # this is a UNIX file. Hope there are no control characters |
|---|
| 491 | set i 0 |
|---|
| 492 | set j 79 |
|---|
| 493 | while {$j < $len} { |
|---|
| 494 | puts $out [string range $line $i $j] |
|---|
| 495 | incr i 80 |
|---|
| 496 | incr j 80 |
|---|
| 497 | } |
|---|
| 498 | } else { |
|---|
| 499 | while {$len >= 0} { |
|---|
| 500 | append line " " |
|---|
| 501 | append line " " |
|---|
| 502 | set line [string range $line 0 79] |
|---|
| 503 | puts $out $line |
|---|
| 504 | set len [gets $in line] |
|---|
| 505 | } |
|---|
| 506 | } |
|---|
| 507 | close $in |
|---|
| 508 | close $out |
|---|
| 509 | file rename $outfile(dir)/$outfile(name) $oldname |
|---|
| 510 | file rename $newname $outfile(dir)/$outfile(name) |
|---|
| 511 | } errmsg] { |
|---|
| 512 | tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK |
|---|
| 513 | } else { |
|---|
| 514 | if [tk_dialog .converted Notify \ |
|---|
| 515 | "File converted. Convert more files?" \ |
|---|
| 516 | "" 0 Yes No] {set infile(done) 1} |
|---|
| 517 | } |
|---|
| 518 | } |
|---|
| 519 | |
|---|
| 520 | # validate the files and make the conversion |
|---|
| 521 | proc valid_new_exp_file {} { |
|---|
| 522 | global infile |
|---|
| 523 | if {$infile(name) == ""} return |
|---|
| 524 | set infile(name) [file root [string toupper $infile(name)]].EXP |
|---|
| 525 | if [file exists [file join $infile(dir) $infile(name)]] { |
|---|
| 526 | tk_dialog .warn Notify \ |
|---|
| 527 | "Sorry, file $infile(name) found in $infile(dir)" warning 0 OK |
|---|
| 528 | return |
|---|
| 529 | } |
|---|
| 530 | set infile(done) 1 |
|---|
| 531 | } |
|---|
| 532 | |
|---|
| 533 | # create a file box |
|---|
| 534 | proc expfilebox {bx filvar diropt} { |
|---|
| 535 | global ${filvar} |
|---|
| 536 | pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top |
|---|
| 537 | set ${filvar}(dir) [pwd] |
|---|
| 538 | pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both |
|---|
| 539 | listbox $bx.a.files -relief raised -bd 2 -yscrollcommand "$bx.a.scroll set" \ |
|---|
| 540 | -height 15 -width 0 |
|---|
| 541 | scrollbar $bx.a.scroll -command "$bx.a.files yview" |
|---|
| 542 | filchoose $bx $bx.a.files $filvar $diropt |
|---|
| 543 | bind $bx.a.files <ButtonRelease-1> \ |
|---|
| 544 | "filchoose $bx $bx.a.files $filvar $diropt" |
|---|
| 545 | pack $bx.a.scroll -side left -fill y |
|---|
| 546 | pack $bx.a.files -side left -fill both -expand yes |
|---|
| 547 | pack [entry $bx.c -textvariable ${filvar}(name)] -side top |
|---|
| 548 | } |
|---|
| 549 | |
|---|
| 550 | # create a file box for conversions |
|---|
| 551 | proc cnvfilebox {bx filvar diropt} { |
|---|
| 552 | global ${filvar} |
|---|
| 553 | pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top |
|---|
| 554 | set ${filvar}(dir) [pwd] |
|---|
| 555 | pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both |
|---|
| 556 | listbox $bx.a.files -relief raised -bd 2 -yscrollcommand "$bx.a.scroll set" \ |
|---|
| 557 | -height 15 -width 0 |
|---|
| 558 | scrollbar $bx.a.scroll -command "$bx.a.files yview" |
|---|
| 559 | filchoose $bx $bx.a.files $filvar $diropt |
|---|
| 560 | if {$filvar == "infile"} { |
|---|
| 561 | bind $bx.a.files <ButtonRelease-1> \ |
|---|
| 562 | "filchoose $bx $bx.a.files $filvar $diropt; setoutfile" |
|---|
| 563 | } else { |
|---|
| 564 | bind $bx.a.files <ButtonRelease-1> \ |
|---|
| 565 | "filchoose $bx $bx.a.files $filvar $diropt" |
|---|
| 566 | } |
|---|
| 567 | pack $bx.a.scroll -side left -fill y |
|---|
| 568 | pack $bx.a.files -side left -fill both -expand yes |
|---|
| 569 | pack [entry $bx.c -textvariable ${filvar}(name)] -side top |
|---|
| 570 | } |
|---|
| 571 | |
|---|
| 572 | # select a file or directory, also called when box is created to fill it |
|---|
| 573 | proc filchoose {frm box filvar {dironly 1}} { |
|---|
| 574 | global expnam $filvar |
|---|
| 575 | set select [$box curselection] |
|---|
| 576 | if {$select == ""} { |
|---|
| 577 | set file . |
|---|
| 578 | } else { |
|---|
| 579 | set file [string trim [$box get $select]] |
|---|
| 580 | } |
|---|
| 581 | if [file isdirectory [file join [set ${filvar}(dir)] $file]] { |
|---|
| 582 | if {$file == ".."} { |
|---|
| 583 | set ${filvar}(dir) [file dirname [set ${filvar}(dir)] ] |
|---|
| 584 | } elseif {$file != "."} { |
|---|
| 585 | set ${filvar}(dir) [file join [set ${filvar}(dir)] $file] |
|---|
| 586 | } |
|---|
| 587 | set ${filvar}(name) {} |
|---|
| 588 | $box delete 0 end |
|---|
| 589 | $box insert end {.. } |
|---|
| 590 | foreach file [lsort [glob -nocomplain \ |
|---|
| 591 | [file join [set ${filvar}(dir)] *] ] ] { |
|---|
| 592 | if {[file isdirectory $file]} { |
|---|
| 593 | # is this / needed here? Does it cause a problem in MacGSAS? |
|---|
| 594 | $box insert end [file tail $file]/ |
|---|
| 595 | } elseif {$dironly == 1} { |
|---|
| 596 | $box insert end [file tail $file] |
|---|
| 597 | } elseif {$dironly == 2 && [file extension $file] == ".EXP"} { |
|---|
| 598 | $box insert end [file tail $file] |
|---|
| 599 | } |
|---|
| 600 | } |
|---|
| 601 | return |
|---|
| 602 | } |
|---|
| 603 | set ${filvar}(name) [file tail $file] |
|---|
| 604 | } |
|---|
| 605 | |
|---|
| 606 | # set new file name from old |
|---|
| 607 | proc setoutfile {} { |
|---|
| 608 | global infile outfile |
|---|
| 609 | if {$outfile(type) == "convstod"} { |
|---|
| 610 | set lfile [string toupper $infile(name)] |
|---|
| 611 | } elseif {$outfile(type) == "convdtos"} { |
|---|
| 612 | set lfile [string tolower $infile(name)] |
|---|
| 613 | } else { |
|---|
| 614 | set lfile "" |
|---|
| 615 | } |
|---|
| 616 | if {$infile(name) == $lfile} { |
|---|
| 617 | set outfile(name) {} |
|---|
| 618 | } else { |
|---|
| 619 | set outfile(name) $lfile |
|---|
| 620 | } |
|---|
| 621 | } |
|---|
| 622 | |
|---|
| 623 | proc liveplotopt {} { |
|---|
| 624 | global liveplot |
|---|
| 625 | set frm .file |
|---|
| 626 | catch {destroy $frm} |
|---|
| 627 | toplevel $frm |
|---|
| 628 | pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left |
|---|
| 629 | pack [scale $frmA.1 -label "Histogram number" -from 1 -to 9 \ |
|---|
| 630 | -length 150 -orient horizontal -variable liveplot(hst)] -side top |
|---|
| 631 | pack [checkbutton $frmA.2 -text {include plot legend}\ |
|---|
| 632 | -variable liveplot(legend)] -side top |
|---|
| 633 | pack [button $frm.2 -text OK \ |
|---|
| 634 | -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \ |
|---|
| 635 | ] -side top |
|---|
| 636 | bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"} |
|---|
| 637 | # force the window to stay on top |
|---|
| 638 | wm transient $frm [winfo toplevel [winfo parent $frm]] |
|---|
| 639 | wm withdraw $frm |
|---|
| 640 | update idletasks |
|---|
| 641 | # center the new window in the middle of the parent |
|---|
| 642 | set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \ |
|---|
| 643 | [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]] |
|---|
| 644 | set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \ |
|---|
| 645 | [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]] |
|---|
| 646 | wm geom $frm +$x+$y |
|---|
| 647 | wm deiconify $frm |
|---|
| 648 | |
|---|
| 649 | set oldFocus [focus] |
|---|
| 650 | set oldGrab [grab current $frm] |
|---|
| 651 | if {$oldGrab != ""} { |
|---|
| 652 | set grabStatus [grab status $oldGrab] |
|---|
| 653 | } |
|---|
| 654 | grab $frm |
|---|
| 655 | focus $frm.2 |
|---|
| 656 | tkwait window $frm |
|---|
| 657 | catch {focus $oldFocus} |
|---|
| 658 | if {$oldGrab != ""} { |
|---|
| 659 | if {$grabStatus == "global"} { |
|---|
| 660 | grab -global $oldGrab |
|---|
| 661 | } else { |
|---|
| 662 | grab $oldGrab |
|---|
| 663 | } |
|---|
| 664 | } |
|---|
| 665 | } |
|---|
