source: trunk/liveplot @ 46

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

# on 1999/01/21 22:55:47, toby did:
move & consolidate sourcing

  • Property rcs:author set to toby
  • Property rcs:date set to 1999/01/21 22:55:47
  • Property rcs:lines set to +17 -19
  • Property rcs:rev set to 1.3
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 15.4 KB
Line 
1#!/usr/local/bin/wish
2set Revision {$Revision: 46 $ $Date: 2009-12-04 22:59:29 +0000 (Fri, 04 Dec 2009) $}
3bind all <Control-KeyPress-c> {destroy .}
4# process command line arguments
5set exitstat 0
6set expnam [lindex $argv 0]
7if {$expnam == ""} {puts "error -- no experiment name"; set exitstat 1}
8if $exitstat {
9    puts "usage: $argv0 expnam \[hist #\] \[legend\]"
10    destroy .
11}
12if {[lindex $argv 1] == ""} {
13    set hst 1
14} else {
15    set hst [lindex $argv 1]
16}
17if {[lindex $argv 2] == ""} {
18    set graph(legend) 1
19} else {
20    set graph(legend) [lindex $argv 2]
21}
22
23
24if {$tcl_platform(platform) == "windows"} {
25    set graph(printout) 1
26} else {
27    set graph(printout) 0
28}
29
30# default values
31set graph(outname) out.ps
32set graph(outcmd) lpr
33
34if [catch {package require BLT} errmsg] {
35    tk_dialog .err "BLT Error" "Error -- Unable to load the BLT package" \
36            error 0 Quit
37    destroy .
38}
39# handle Tcl/Tk v8+ where BLT is in a namespace
40#  use the command so that it is loaded
41catch {blt::graph}
42catch {
43    namespace import blt::graph
44    namespace import blt::vector
45}
46# old versions of blt don't report a version number
47if [catch {set blt_version}] {set blt_version 0}
48# option for coloring markers: note that GH keeps changing how to do this!
49if {$blt_version < 2.3 || $blt_version >= 8.0} {
50    set graph(MarkerColorOpt) -fg
51} elseif {$blt_version >= 2.4} {
52    set graph(MarkerColorOpt) -outline
53} else {
54    set graph(MarkerColorOpt) -color
55}
56
57proc waitmsg {message} {
58    set w .wait
59    # kill any window/frame with this name
60    catch {destroy $w}
61    pack [frame $w]
62    frame $w.bot -relief raised -bd 1
63    pack $w.bot -side bottom -fill both
64    frame $w.top -relief raised -bd 1
65    pack $w.top -side top -fill both -expand 1
66    label $w.msg -justify left -text $message -wrap 3i
67    catch {$w.msg configure -font \
68                -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
69    }
70    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
71    label $w.bitmap -bitmap info
72    pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
73    update
74}
75
76proc donewait {} {
77    catch {destroy .wait}
78    update
79}
80
81waitmsg "Loading histogram, Please wait"
82
83#--------------------------------------------------------------
84# define constants
85array set peakinfo {
86    color1 magenta
87    color2 cyan
88    color3 yellow
89    color4 sienna
90    color5 orange
91    color6 DarkViolet
92    color7 HotPink
93    color8 salmon
94    color9 LimeGreen
95}
96set cycle -1
97set modtime 0
98
99#----------------------------------------------------------------
100# where are we?
101set expgui(script) [info script]
102# translate links -- go six levels deep
103foreach i {1 2 3 4 5 6} {
104    if {[file type $expgui(script)] == "link"} {
105        set link [file readlink $expgui(script)]
106        if { [file  pathtype  $link] == "absolute" } {
107h           set expgui(script) $link
108        } {
109            set expgui(script) [file dirname $expgui(script)]/$link
110        }
111    } else {
112        break
113    }
114}
115
116# fixup relative paths
117if {[file pathtype $expgui(script)] == "relative"} {
118    set expgui(script) [file join [pwd] $expgui(script)]
119}
120set expgui(scriptdir) [file dirname $expgui(script) ]
121set expgui(gsasdir) [file dirname $expgui(scriptdir)]
122set expgui(gsasexe) [file join $expgui(gsasdir) exe]
123
124
125proc readdata {box} {
126    global expgui expnam reflns
127    global lasthst
128    global hst peakinfo units
129    $box config -title "(Histogram update in progress)"
130    update
131    # parse the output of a file
132    if [catch {
133        set lasthst $hst
134###########################################################################
135#       set input [open histdump.inp w]
136#       puts $input "$hst"
137#       close $input
138#       set input [open "| $expgui(gsasexe)/hstdump $expnam  < histdump.inp" w+]
139###########################################################################
140        # use histdump for right now
141        set input [open histdump$hst.inp w]
142        puts $input "$expnam"
143        puts $input "L"
144        puts $input "$hst"
145        puts $input "0"
146        close $input
147        # use hstdmp without an experiment name so that output
148        # is not sent to the .LST file
149        set input [open "| $expgui(gsasexe)/hstdmp < histdump$hst.inp" r]
150       
151        # initalize arrays
152        set num -1
153        set xlist {}
154        set obslist {}
155        set calclist {}
156        set bcklist {}
157        set units {}
158        # define a list of reflection positions for each phase
159        for {set i 1} {$i < 10} {incr i} {
160            set reflns($i) {}
161            #   set flag$i 0
162        }
163        set i 0
164        while {[gets $input line] >= 0} {
165            incr i
166            # run update every 50th line
167            if {$i > 50} {set i 0; update}
168            if [scan $line %d num] {
169                if {$num > 0} {
170                    set Ispec 0
171                    scan [string range $line 8 end] %e%e%e%e%e%e \
172                            X Iobs Icalc Ispec fixB fitB
173                    #puts $line
174                    #    puts "[string range $line 6 6]"
175                    # is this 6 or 7; 6 on win & 7 on SGI
176                    set pointflag [string range $line 6 7]
177                    # eliminate excluded points
178                    if {$Ispec > 0.0} {
179                        lappend xlist $X
180                        lappend obslist $Iobs
181                        lappend calclist $Icalc
182                        lappend bcklist [expr $fixB + $fitB]
183                    }
184                    # add peaks to peak lists
185                    if [regexp {[1-9]} $pointflag ph] {
186                        lappend reflns($ph) $X
187                    }
188                }
189            } else {
190                regexp {Time|Theta|keV} $line units
191            }
192        }
193        if {$units == "Theta"} {set units "2-Theta"}
194        close $input
195        file delete histdump$hst.inp
196        xvec set $xlist
197        obsvec set $obslist
198        calcvec set $calclist
199        bckvec set $bcklist
200        diffvec set [obsvec - calcvec]
201        global obsvec calcvec diffvec
202        set maxdiff  [set diffvec(max)]
203        set ymin1 [expr [set calcvec(min)] - 1.1*$maxdiff]
204        set ymin2 [expr [set obsvec(min)] - 1.1*$maxdiff]
205        if {$ymin1 < $ymin2} {
206            diffvec set [diffvec + $ymin1]
207        } {
208            diffvec set [diffvec + $ymin2]
209        }
210        plotdata $box
211    } errmsg] {
212        $box config -title "(Error reading Histogram -- not ready or invalid)"
213        puts "error message: $errmsg"
214        update
215    }   
216}
217
218proc plotdata {box} {
219    global expnam hst peakinfo units cycle reflns modtime
220    global lasthst graph
221
222    # is there a new histogram to load?
223    if {$hst != $lasthst} {
224        xvec set {}
225        xvec notify now
226        set cycle -1
227        set modtime 0
228        $box config -title "Please wait: loading histogram $hst"
229        update
230        return
231    }
232    xvec notify now
233    obsvec notify now
234    calcvec notify now
235    bckvec notify now
236    diffvec notify now
237    $box config -title "$expnam cycle $cycle Hist $hst"
238    $box xaxis config -title $units
239    setlegend $box $graph(legend)
240    # now deal with peaks
241    set j 0
242    for {set i 1} {$i < 10} {incr i} {
243        if [set peakinfo(flag$i)] {
244            foreach X $reflns($i) {
245                incr j
246                catch {
247                    $box marker create line -name peaks${i}_$j
248                }
249                $box marker config peaks${i}_$j  -under 1 \
250                        -coords "$X $peakinfo(min$i) $X $peakinfo(max$i)"
251                $box marker config peaks${i}_$j \
252                        $graph(MarkerColorOpt) $peakinfo(color$i)
253                if $peakinfo(dashes$i) {
254                    catch {
255                        $box marker config peaks${i}_$j -dashes "5 5"
256                    }
257                }
258            }
259            # $box element config phase$i -mapped  1
260            catch {$box element create phase$i}
261            catch {
262                $box element config phase$i -color $peakinfo(color$i)
263            }
264        } else {
265            eval $box marker delete [$box marker names peaks${i}_*]
266            eval $box element delete [$box element names phase$i]
267        }
268    }
269    # force an update of the plot as BLT may not
270    $box config -title [$box cget -title]
271    update
272}
273
274proc setlegend {box legend} {
275    global blt_version
276    if {$blt_version >= 2.3 && $blt_version < 8.0} {
277        if $legend {
278            $box legend config -hide no
279        } else {
280            $box legend config -hide yes
281        }
282    } else {
283        if $legend {
284            $box legend config -mapped yes
285        } else {
286            $box legend config -mapped no
287        }
288    }
289}
290
291proc minioptionsbox {num} {
292    set bx .opt$num
293    catch {destroy $bx}
294    toplevel $bx
295    wm iconname $bx "Phase $num options"
296    wm title $bx "Phase $num options"
297
298    set i $num
299        pack [label $bx.0 -text "Phase $i reflns" ] -side top
300        pack [checkbutton $bx.1 -text "Show reflections" \
301                -variable peakinfo(flag$i)] -side top
302        pack [checkbutton $bx.2 -text "Use dashed line" \
303                -variable peakinfo(dashes$i)] -side top
304        pack [frame $bx.p$i -bd 2 -relief groove] -side top
305#       pack [checkbutton $bx.p$i.0 -text "Show phase $i reflns" \
306#               -variable peakinfo(flag$i)] -side left -anchor w
307        pack [label $bx.p$i.1 -text "  Y min:"] -side left
308        pack [entry $bx.p$i.2 -textvariable peakinfo(min$i) -width 5] \
309                -side left
310        pack [label $bx.p$i.3 -text "  Y max:"] -side left
311        pack [entry $bx.p$i.4 -textvariable peakinfo(max$i) -width 5] \
312                -side left
313        pack [frame $bx.c$i -bd 2 -relief groove] -side top
314
315        pack [label $bx.c$i.5 -text " color:"] -side left
316        pack [entry $bx.c$i.6 -textvariable peakinfo(color$i) -width 12] \
317                -side left
318        pack [button $bx.c$i.1 -text "Color menu" \
319                -command "setcolor $i"] -side left
320
321    pack [frame $bx.b] -side top
322    pack [button $bx.b.1 -command {plotdata $box} -text "Update Plot"] \
323            -side left
324    pack [button $bx.b.4 -command "destroy $bx" -text Close ] -side right
325}
326
327proc setcolor {num} {
328    global peakinfo
329    set color [tk_chooseColor -initialcolor $peakinfo(color$num) -title "Choose color"]
330    if {$color == ""} return
331    set peakinfo(color$num) $color
332}
333proc makepostscriptout {} {
334    global graph box
335    if !$graph(printout) {
336        set out [open "| $graph(outcmd) >& liveplot.msg" w]
337        catch {
338            puts $out [$box postscript output -landscape 1 \
339                -decorations no -height 7.i -width 9.5i]
340            close $out
341        } msg
342        catch {
343            set out [open liveplot.msg r]
344            if {$msg != ""} {append msg "\n"}
345            append msg [read $out]
346            close $out
347            file delete liveplot.msg
348        }
349        if {$msg != ""} {
350            tk_dialog .msg "file created" \
351                    "Postscript file processed with command \
352                    $graph(outcmd). Result: $msg" "" 0 OK
353        } else {
354            tk_dialog .msg "file created" \
355                    "Postscript file processed with command \
356                    $graph(outcmd)" "" 0 OK
357        }
358    } else {
359        $box postscript output $graph(outname) -landscape 1 \
360                -decorations no -height 7.i -width 9.5i   
361        tk_dialog .msg "file created" \
362                "Postscript file $graph(outname) created" "" 0 OK
363    }
364}
365
366proc setprintopt {page} {
367    global graph
368    if $graph(printout) {
369        $page.4.1 config -fg black
370        $page.4.2 config -fg black -state normal
371        $page.6.1 config -fg #888
372        $page.6.2 config -fg #888 -state disabled
373    } else {
374        $page.4.1 config -fg #888
375        $page.4.2 config -fg #888 -state disabled
376        $page.6.1 config -fg black
377        $page.6.2 config -fg black -state normal
378    }
379}
380
381proc setpostscriptout {} {
382    global graph tcl_platform
383    set box .out
384    catch {destroy $box}
385    toplevel $box
386    focus $box
387    pack [frame $box.4] -side top -anchor w -fill x
388    pack [checkbutton $box.4.a -text "Write PostScript files" \
389            -variable graph(printout) -offvalue 0 -onvalue 1 \
390            -command "setprintopt $box"] -side left -anchor w
391    pack [entry $box.4.2 -textvariable graph(outname)] -side right -anchor w
392    pack [label $box.4.1 -text "PostScript file name:"] -side right -anchor w
393    pack [frame $box.6] -side top -anchor w -fill x
394    pack [checkbutton $box.6.a -text "Print PostScript files" \
395            -variable graph(printout) -offvalue 1 -onvalue 0 \
396            -command "setprintopt $box" ] -side left -anchor w
397    pack [entry $box.6.2 -textvariable graph(outcmd)] -side right -anchor w
398    pack [label $box.6.1 -text "Command to print files:"] -side right -anchor w
399
400    pack [button $box.a -text "Close" -command "destroy $box"] -side top
401    if {$tcl_platform(platform) == "windows"} {
402        set graph(printout) 1
403        $box.4.a config -state disabled
404        $box.6.a config -fg #888 -state disabled
405    }
406    setprintopt $box
407}
408
409# save some of the global options in ~/.gsas_config
410proc SaveOptions {} {
411    global graph
412    set fp [open [file join ~ .gsas_config] a]
413    puts $fp "set graph(legend) $graph(legend)"
414    puts $fp "set graph(printout) $graph(printout)"
415    puts $fp "set graph(outname) $graph(outname)"
416    puts $fp "set graph(outcmd) $graph(outcmd)"
417    close $fp
418}
419
420proc aboutliveplot {} {
421    global Revision
422    tk_dialog .warn About "
423GSAS\n\
424A. C. Larson and\n R. B. Von Dreele,\n LANSCE, Los Alamos\n\n\
425LIVEPLOT\nB. Toby, NIST\nNot subject to copyright\n\n\
426$Revision\n\
427" {} 0 OK
428}
429
430proc getcycle {} {
431    global expnam
432    set cycle -1
433    catch {
434        set fp [open $expnam.EXP r]
435        set text [read $fp]
436        close $fp
437        regexp {GNLS  RUN.*Total cycles run *([0-9]*) } $text x cycle
438    }
439    return $cycle
440}
441
442proc updateifnew {} {
443    global cycle modtime expnam
444    if {[file mtime $expnam.EXP] != $modtime} {
445        set modtime [file mtime $expnam.EXP]
446        set newcycle [getcycle]
447        if {$newcycle != $cycle} {
448            set cycle $newcycle
449            # delay one second
450            # after 1000
451            readdata .g
452        }
453    }
454    # check every second
455#    after 10000 updateifnew
456    after 1000 updateifnew
457}
458
459# fetch EXP file processing routines
460source [file join $expgui(scriptdir) readexp.tcl]
461
462set fl [file join $expgui(scriptdir) icddcmd.tcl]
463if [file exists $fl] {source $fl}
464set fl [file join $expgui(scriptdir) cellgen.tcl]
465if [file exists $fl] {source $fl}
466
467# override options with locally defined values
468if [file exists [file join $expgui(scriptdir) localconfig]] {
469    source [file join $expgui(scriptdir) localconfig]
470}
471if [file exists [file join ~ .gsas_config]] {
472    source [file join ~ .gsas_config]
473}
474
475# vectors
476vector xvec
477xvec notify never
478vector obsvec
479obsvec notify never
480vector calcvec
481calcvec notify never
482vector bckvec
483bckvec notify never
484vector diffvec
485diffvec notify never
486# create the graph
487set box [graph .g]
488Blt_ZoomStack $box
489$box element create obs -color black -symbol scross -linewidth 0
490$box element create calc -color red  -symbol none 
491#$box element create bckg -color green  -symbol none 
492$box element create diff -color blue  -symbol none 
493$box element config obs -xdata xvec -ydata obsvec
494$box element config calc -xdata xvec -ydata calcvec
495#$box element config bckg -xdata xvec -ydata bckvec
496$box element config diff -xdata xvec -ydata diffvec
497$box yaxis config -title {}
498setlegend $box $graph(legend)
499# create a set of markers for each phase
500for {set i 1} {$i < 10} {incr i} {
501    set peakinfo(flag$i) 0
502    set peakinfo(max$i) Inf
503    set peakinfo(min$i) -Inf
504    set peakinfo(dashes$i) 1
505}
506
507updateifnew
508frame .a -bd 3 -relief groove
509pack [menubutton .a.file -text File -underline 0 -menu .a.file.menu] -side left
510menu .a.file.menu
511.a.file.menu add cascade -label "Histogram" -menu .a.file.menu.hist
512menu .a.file.menu.hist
513foreach num {1 2 3 4 5 6 7 8 9} {
514    .a.file.menu.hist add radiobutton -label $num -value $num -variable hst \
515            -command {plotdata $box}
516}
517.a.file.menu add cascade -label Tickmarks -menu .a.file.menu.tick
518menu .a.file.menu.tick
519foreach num {1 2 3 4 5 6 7 8 9} {
520    .a.file.menu.tick add checkbutton -label "Phase $num" \
521            -variable  peakinfo(flag$num) \
522            -command {plotdata $box}
523}
524.a.file.menu add command -label "Update Plot" \
525        -command {set cycle [getcycle];readdata .g}
526.a.file.menu add command -label "Make PostScript" -command makepostscriptout
527.a.file.menu add command -label Quit -command "destroy ."
528
529pack [menubutton .a.options -text Options -underline 0 -menu .a.options.menu] \
530        -side left   
531menu .a.options.menu
532.a.options.menu add cascade -label "Configure Tickmarks" -menu .a.options.menu.tick
533menu .a.options.menu.tick
534foreach num {1 2 3 4 5 6 7 8 9} {
535    .a.options.menu.tick add command -label "Phase $num" \
536            -command "minioptionsbox $num"
537}
538.a.options.menu add checkbutton -label "Include legend" \
539        -variable graph(legend) \
540        -command {setlegend $box $graph(legend)}
541.a.options.menu add command -label "Set PS output" -command setpostscriptout
542.a.options.menu add command -label "Save Options" -underline 1 \
543        -command "SaveOptions"
544
545pack [menubutton .a.help -text Help -underline 0 -menu .a.help.menu] -side right
546menu .a.help.menu -tearoff 0
547.a.help.menu add command -command aboutliveplot -label About
548
549pack .a -side top -fill both
550pack $box -fill both -expand yes
551donewait
Note: See TracBrowser for help on using the repository browser.