source: branches/blt4/gui/scripts/heightmapviewer.tcl @ 1985

Last change on this file since 1985 was 1985, checked in by gah, 13 years ago
File size: 44.4 KB
Line 
1
2# ----------------------------------------------------------------------
3#  Component: heightmapviewer - 3D surface rendering
4#
5#  This widget performs surface rendering on 3D scalar/vector datasets.
6#  It connects to the Nanovis server running on a rendering farm,
7#  transmits data, and displays the results.
8# ======================================================================
9#  AUTHOR:  Michael McLennan, Purdue University
10#  Copyright (c) 2004-2005  Purdue Research Foundation
11#
12#  See the file "license.terms" for information on usage and
13#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14# ======================================================================
15
16package require Itk
17package require BLT
18#package require Img
19
20option add *HeightmapViewer.width 4i widgetDefault
21option add *HeightmapViewer.height 4i widgetDefault
22option add *HeightmapViewer.foreground black widgetDefault
23option add *HeightmapViewer.plotBackground black widgetDefault
24option add *HeightmapViewer.plotForeground white widgetDefault
25option add *HeightmapViewer.plotOutline white widgetDefault
26option add *HeightmapViewer.font -*-helvetica-medium-r-normal-*-12-* widgetDefault
27
28# must use this name -- plugs into Rappture::resources::load
29proc HeightmapViewer_init_resources {} {
30    Rappture::resources::register \
31        nanovis_server Rappture::HeightmapViewer::SetServerList
32}
33
34itcl::class Rappture::HeightmapViewer {
35    inherit Rappture::VisViewer
36
37    itk_option define -plotforeground plotForeground Foreground ""
38    itk_option define -plotbackground plotBackground Background ""
39    itk_option define -plotoutline plotOutline PlotOutline ""
40
41    constructor { hostlist args } {
42        Rappture::VisViewer::constructor $hostlist
43    } {
44        # defined below
45    }
46    destructor {
47        # defined below
48    }
49
50    public proc SetServerList { namelist } {
51        Rappture::VisViewer::SetServerList "nanovis" $namelist
52    }
53    public method add {dataobj {settings ""}}
54    public method get {args}
55    public method delete {args}
56    public method scale {args}
57    public method snap { w h }
58    public method download {option args}
59    public method parameters {title args} {
60        # do nothing
61    }
62    public method camera {option args}
63    protected method Connect {}
64    protected method Disconnect {}
65    public method isconnected {}
66
67    protected method SendCmd {string}
68    protected method ReceiveImage { args }
69    private method ReceiveLegend {tf vmin vmax size}
70    private method BuildViewTab {}
71    private method BuildCameraTab {}
72    private method PanCamera {}
73    protected method CurrentSurfaces {{what -all}}
74    protected method Rebuild {}
75    protected method Zoom {option}
76    protected method Pan {option x y}
77    protected method Rotate {option x y}
78
79    protected method State {comp}
80    protected method FixSettings {what {value ""}}
81    protected method GetTransfuncData {dataobj comp}
82    protected method Resize {}
83    private method EventuallyResize { w h }
84
85    private variable _outbuf       ;# buffer for outgoing commands
86
87    private variable _dlist ""     ;# list of data objects
88    private variable _obj2style    ;# maps dataobj => style settings
89    private variable _obj2ovride   ;# maps dataobj => style override
90    private variable _click        ;# info used for Rotate operations
91    private variable _limits       ;# autoscale min/max for all axes
92    private variable _view         ;# view params for 3D view
93    private common _settings       ;# Array of used for global variables
94                                    # for checkbuttons and radiobuttons.
95    private variable _serverObjs   ;# contains all the dataobj-component
96                                   ;# to heightmaps in the server
97    private variable _location ""
98    private variable _first ""
99    private variable _width 0
100    private variable _height 0
101    private common _hardcopy
102    private variable _buffering 0
103    private variable _resizePending 0
104    private variable _resizeLegendPending 0
105    private variable _frame 0;          # Current frame number.
106}
107
108itk::usual HeightmapViewer {
109    keep -background -foreground -cursor -font
110    keep -plotbackground -plotforeground
111}
112itk::usual TkPushbutton {
113}
114
115# ----------------------------------------------------------------------
116# CONSTRUCTOR
117# ----------------------------------------------------------------------
118itcl::body Rappture::HeightmapViewer::constructor {hostlist args} {
119    # Draw legend event
120    $_dispatcher register !legend
121    $_dispatcher dispatch $this !legend \
122        "[itcl::code $this FixSettings legend]; list"
123
124    # Rebuild event
125    $_dispatcher register !rebuild
126    $_dispatcher dispatch $this !rebuild "[itcl::code $this Rebuild]; list"
127
128    # Resize event.
129    $_dispatcher register !resize
130    $_dispatcher dispatch $this !resize "[itcl::code $this Resize]; list"
131
132    set _outbuf ""
133
134    #
135    # Populate parser with commands handle incoming requests
136    #
137    $_parser alias image [itcl::code $this ReceiveImage]
138    $_parser alias legend [itcl::code $this ReceiveLegend]
139
140    # Initialize the view to some default parameters.
141    array set _view {
142        theta   45
143        phi     45
144        psi     0
145        zoom    1.0
146        pan-x   0
147        pan-y   0
148    }
149    foreach val {xmin xmax ymin ymax zmin zmax vmin vmax} {
150        set _limits($val) ""
151    }
152    array set _settings [subst {
153        $this-pan-x             $_view(pan-x)
154        $this-pan-y             $_view(pan-y)
155        $this-phi               $_view(phi)
156        $this-psi               $_view(psi)
157        $this-theta             $_view(theta)
158        $this-surface           1
159        $this-xcutplane         0
160        $this-xcutposition      0
161        $this-ycutplane         0
162        $this-ycutposition      0
163        $this-zcutplane         0
164        $this-zcutposition      0
165        $this-zoom              $_view(zoom)
166    }]
167
168    itk_component add 3dview {
169        canvas $itk_component(plotarea).vol \
170            -highlightthickness 0 -borderwidth 0
171    } {
172        usual
173        ignore -highlightthickness -borderwidth  -background
174    }
175    $_image(plot) configure -data ""
176    $itk_component(3dview) create image 0 0 -anchor nw -image $_image(plot)
177    set f [$itk_component(main) component controls]
178    itk_component add zoom {
179        frame $f.zoom
180    }
181    pack $itk_component(zoom) -side top
182
183    itk_component add reset {
184        button $f.reset -borderwidth 1 -padx 1 -pady 1 \
185            -highlightthickness 0 \
186            -image [Rappture::icon reset-view] \
187            -command [itcl::code $this Zoom reset]
188    } {
189        usual
190        ignore -highlightthickness
191    }
192    pack $itk_component(reset) -side top -padx 1 -pady { 4 0 }
193    Rappture::Tooltip::for $itk_component(reset) \
194        "Reset the view to the default zoom level"
195
196    itk_component add zoomin {
197        button $f.zin -borderwidth 1 -padx 1 -pady 1 \
198            -highlightthickness 0 \
199            -image [Rappture::icon zoom-in] \
200            -command [itcl::code $this Zoom in]
201    } {
202        usual
203        ignore -highlightthickness
204    }
205    pack $itk_component(zoomin) -side top -padx 1 -pady { 4 0 }
206    Rappture::Tooltip::for $itk_component(zoomin) "Zoom in"
207
208    itk_component add zoomout {
209        button $f.zout -borderwidth 1 -padx 1 -pady 1 \
210            -highlightthickness 0 \
211            -image [Rappture::icon zoom-out] \
212            -command [itcl::code $this Zoom out]
213    } {
214        usual
215        ignore -highlightthickness
216    }
217    pack $itk_component(zoomout) -side top -padx 1 -pady { 4 }
218    Rappture::Tooltip::for $itk_component(zoomout) "Zoom out"
219
220    itk_component add surface {
221        blt::tk::pushbutton $f.surface \
222            -onimage [Rappture::icon volume-on] \
223            -offimage [Rappture::icon volume-off] \
224            -command [itcl::code $this FixSettings surface] \
225            -variable [itcl::scope _settings($this-surface)]
226    }
227    $itk_component(surface) select
228    Rappture::Tooltip::for $itk_component(surface) \
229        "Toggle surfaces on/off"
230    pack $itk_component(surface) -padx 2 -pady 2
231
232    BuildViewTab
233    BuildCameraTab
234
235    set w [expr [winfo reqwidth $itk_component(hull)] - 80]
236    pack forget $itk_component(3dview)
237    pack $itk_component(3dview) -side left -fill both -expand yes
238
239
240    # Bindings for rotation via mouse
241    bind $itk_component(3dview) <ButtonPress-1> \
242        [itcl::code $this Rotate click %x %y]
243    bind $itk_component(3dview) <B1-Motion> \
244        [itcl::code $this Rotate drag %x %y]
245    bind $itk_component(3dview) <ButtonRelease-1> \
246        [itcl::code $this Rotate release %x %y]
247    bind $itk_component(3dview) <Configure> \
248        [itcl::code $this EventuallyResize %w %h]
249
250    # Bindings for panning via mouse
251    bind $itk_component(3dview) <ButtonPress-2> \
252        [itcl::code $this Pan click %x %y]
253    bind $itk_component(3dview) <B2-Motion> \
254        [itcl::code $this Pan drag %x %y]
255    bind $itk_component(3dview) <ButtonRelease-2> \
256        [itcl::code $this Pan release %x %y]
257
258    # Bindings for panning via keyboard
259    bind $itk_component(3dview) <KeyPress-Left> \
260        [itcl::code $this Pan set -10 0]
261    bind $itk_component(3dview) <KeyPress-Right> \
262        [itcl::code $this Pan set 10 0]
263    bind $itk_component(3dview) <KeyPress-Up> \
264        [itcl::code $this Pan set 0 -10]
265    bind $itk_component(3dview) <KeyPress-Down> \
266        [itcl::code $this Pan set 0 10]
267    bind $itk_component(3dview) <Shift-KeyPress-Left> \
268        [itcl::code $this Pan set -2 0]
269    bind $itk_component(3dview) <Shift-KeyPress-Right> \
270        [itcl::code $this Pan set 2 0]
271    bind $itk_component(3dview) <Shift-KeyPress-Up> \
272        [itcl::code $this Pan set 0 -2]
273    bind $itk_component(3dview) <Shift-KeyPress-Down> \
274        [itcl::code $this Pan set 0 2]
275
276    # Bindings for zoom via keyboard
277    bind $itk_component(3dview) <KeyPress-Prior> \
278        [itcl::code $this Zoom out]
279    bind $itk_component(3dview) <KeyPress-Next> \
280        [itcl::code $this Zoom in]
281
282    bind $itk_component(3dview) <Enter> "focus $itk_component(3dview)"
283
284    if {[string equal "x11" [tk windowingsystem]]} {
285        # Bindings for zoom via mouse
286        bind $itk_component(3dview) <4> [itcl::code $this Zoom out]
287        bind $itk_component(3dview) <5> [itcl::code $this Zoom in]
288    }
289
290    set _image(download) [image create picture]
291    eval itk_initialize $args
292    Connect
293}
294
295# ----------------------------------------------------------------------
296# DESTRUCTOR
297# ----------------------------------------------------------------------
298itcl::body Rappture::HeightmapViewer::destructor {} {
299    $_dispatcher cancel !rebuild
300    image delete $_image(plot)
301    image delete $_image(legend)
302    image delete $_image(download)
303}
304
305# ----------------------------------------------------------------------
306# USAGE: add <dataobj> ?<settings>?
307#
308# Clients use this to add a data object to the plot.  The optional
309# <settings> are used to configure the plot.  Allowed settings are
310# -color, -brightness, -width, -linestyle, and -raise.
311# ----------------------------------------------------------------------
312itcl::body Rappture::HeightmapViewer::add {dataobj {settings ""}} {
313    array set params {
314        -color auto
315        -width 1
316        -linestyle solid
317        -brightness 0
318        -raise 0
319        -description ""
320        -param ""
321    }
322    foreach {opt val} $settings {
323        if {![info exists params($opt)]} {
324            error "bad setting \"$opt\": should be [join [lsort [array names params]] {, }]"
325        }
326        set params($opt) $val
327    }
328    if {$params(-color) == "auto" || $params(-color) == "autoreset"} {
329        # can't handle -autocolors yet
330        set params(-color) black
331    }
332    set pos [lsearch -exact $dataobj $_dlist]
333    if {$pos < 0} {
334        lappend _dlist $dataobj
335        set _obj2ovride($dataobj-color) $params(-color)
336        set _obj2ovride($dataobj-width) $params(-width)
337        set _obj2ovride($dataobj-raise) $params(-raise)
338        set _obj2ovride($dataobj-brightness) $params(-brightness)
339        $_dispatcher event -idle !rebuild
340    }
341    scale $dataobj
342}
343
344# ----------------------------------------------------------------------
345# USAGE: get ?-objects?
346# USAGE: get ?-image 3dview|legend?
347#
348# Clients use this to query the list of objects being plotted, in
349# order from bottom to top of this result.  The optional "-image"
350# flag can also request the internal images being shown.
351# ----------------------------------------------------------------------
352itcl::body Rappture::HeightmapViewer::get { args } {
353    if {[llength $args] == 0} {
354        set args "-objects"
355    }
356
357    set op [lindex $args 0]
358    switch -- $op {
359      -objects {
360        # put the dataobj list in order according to -raise options
361        set dlist $_dlist
362        foreach obj $dlist {
363            if { [info exists _obj2ovride($obj-raise)] &&
364                 $_obj2ovride($obj-raise)} {
365                set i [lsearch -exact $dlist $obj]
366                if {$i >= 0} {
367                    set dlist [lreplace $dlist $i $i]
368                    lappend dlist $obj
369                }
370            }
371        }
372        return $dlist
373      }
374      -image {
375        if {[llength $args] != 2} {
376            error "wrong # args: should be \"get -image 3dview|legend\""
377        }
378        switch -- [lindex $args end] {
379            3dview {
380                return $_image(plot)
381            }
382            legend {
383                return $_image(legend)
384            }
385            default {
386                error "bad image name \"[lindex $args end]\": should be 3dview or legend"
387            }
388        }
389      }
390      default {
391        error "bad option \"$op\": should be -objects or -image"
392      }
393    }
394}
395
396# ----------------------------------------------------------------------
397# USAGE: delete ?<dataobj1> <dataobj2> ...?
398#
399# Clients use this to delete a dataobj from the plot.  If no dataobjs
400# are specified, then all dataobjs are deleted.
401# ----------------------------------------------------------------------
402itcl::body Rappture::HeightmapViewer::delete { args } {
403    if {[llength $args] == 0} {
404        set args $_dlist
405    }
406
407    # delete all specified dataobjs
408    set changed 0
409    foreach dataobj $args {
410        set pos [lsearch -exact $_dlist $dataobj]
411        if {$pos >= 0} {
412            set _dlist [lreplace $_dlist $pos $pos]
413            foreach key [array names _obj2ovride $dataobj-*] {
414                unset _obj2ovride($key)
415            }
416            array unset _serverObjs $dataobj-*
417            set changed 1
418        }
419    }
420
421    # if anything changed, then rebuild the plot
422    if {$changed} {
423        $_dispatcher event -idle !rebuild
424    }
425}
426
427# ----------------------------------------------------------------------
428# USAGE: scale ?<data1> <data2> ...?
429#
430# Sets the default limits for the overall plot according to the
431# limits of the data for all of the given <data> objects.  This
432# accounts for all objects--even those not showing on the screen.
433# Because of this, the limits are appropriate for all objects as
434# the user scans through data in the ResultSet viewer.
435# ----------------------------------------------------------------------
436itcl::body Rappture::HeightmapViewer::scale { args } {
437    if 0 {
438    foreach val {xmin xmax ymin ymax zmin zmax vmin vmax} {
439        set _limits($val) ""
440    }
441    }
442    foreach obj $args {
443        foreach axis {x y z v} {
444            foreach {min max} [$obj limits $axis] break
445            if {"" != $min && "" != $max} {
446                if {"" == $_limits(${axis}min)} {
447                    set _limits(${axis}min) $min
448                    set _limits(${axis}max) $max
449                } else {
450                    if {$min < $_limits(${axis}min)} {
451                        set _limits(${axis}min) $min
452                    }
453                    if {$max > $_limits(${axis}max)} {
454                        set _limits(${axis}max) $max
455                    }
456                }
457                set _limits(${axis}range) [expr {$max - $min}]
458            }
459        }
460    }
461}
462
463# ----------------------------------------------------------------------
464# USAGE: download coming
465# USAGE: download controls <downloadCommand>
466# USAGE: download now
467#
468# Clients use this method to create a downloadable representation
469# of the plot.  Returns a list of the form {ext string}, where
470# "ext" is the file extension (indicating the type of data) and
471# "string" is the data itself.
472# ----------------------------------------------------------------------
473itcl::body Rappture::HeightmapViewer::download {option args} {
474    switch $option {
475        coming {
476            if {[catch {$_image(download) snap $itk_component(plotarea)}]} {
477                $_image(download) blank #000000
478            }
479        }
480        controls {
481            # no controls for this download yet
482            return ""
483        }
484        now {
485            $_image(download) export jpg -quality 100 -data bytes
486            return [list .jpg $bytes]
487        }
488        default {
489            error "bad option \"$option\": should be coming, controls, now"
490        }
491    }
492}
493
494#
495# isconnected --
496#
497#       Indicates if we are currently connected to the visualization server.
498#
499itcl::body Rappture::HeightmapViewer::isconnected {} {
500    return [VisViewer::IsConnected]
501}
502
503# ----------------------------------------------------------------------
504# USAGE: Connect ?<host:port>,<host:port>...?
505#
506# Clients use this method to establish a connection to a new
507# server, or to reestablish a connection to the previous server.
508# Any existing connection is automatically closed.
509# ----------------------------------------------------------------------
510itcl::body Rappture::HeightmapViewer::Connect {} {
511    global readyForNextFrame
512    set readyForNextFrame 1
513    Disconnect
514    set _hosts [GetServerList "nanovis"]
515    if { "" == $_hosts } {
516        return 0
517    }
518    catch {unset _serverObjs}
519    set result [VisViewer::Connect $_hosts]
520    return $result
521}
522
523# ----------------------------------------------------------------------
524# USAGE: Disconnect
525#
526# Clients use this method to disconnect from the current rendering
527# server.
528# ----------------------------------------------------------------------
529itcl::body Rappture::HeightmapViewer::Disconnect {} {
530    VisViewer::Disconnect
531
532    set _outbuf ""
533    # disconnected -- no more data sitting on server
534    global readyForNextFrame
535    set readyForNextFrame 1
536}
537
538#
539# SendCmd
540#
541#       Send commands off to the rendering server.  If we're currently
542#       sending data objects to the server, buffer the commands to be
543#       sent later.
544#
545itcl::body Rappture::HeightmapViewer::SendCmd {string} {
546    if { $_buffering } {
547        append _outbuf $string "\n"
548    } else {
549        foreach line [split $string \n] {
550            SendEcho >>line $line
551        }
552        SendBytes "$string\n"
553    }
554}
555
556# ----------------------------------------------------------------------
557# USAGE: ReceiveImage -bytes <size>
558#
559# Invoked automatically whenever the "image" command comes in from
560# the rendering server.  Indicates that binary image data with the
561# specified <size> will follow.
562# ----------------------------------------------------------------------
563itcl::body Rappture::HeightmapViewer::ReceiveImage { args } {
564    global readyForNextFrame
565    set readyForNextFrame 1
566    if {![IsConnected]} {
567        return
568    }
569    array set info {
570        -type image
571    }
572    array set info $args
573    set bytes [ReceiveBytes $info(-bytes)]
574    ReceiveEcho <<line "<read $info(-bytes) bytes args=$args"
575 puts stderr "<read $info(-bytes) bytes"
576    if { $info(-type) == "image" } {
577        $_image(plot) configure -data $bytes
578        ReceiveEcho <<line "<read for [image width $_image(plot)]x[image height $_image(plot)] image>"
579 puts stderr "<read for [image width $_image(plot)]x[image height $_image(plot)] image>"
580    } elseif { $info(type) == "print" } {
581        set tag $this-print-$info(-token)
582        set _hardcopy($tag) $bytes
583    }
584}
585
586# ----------------------------------------------------------------------
587# USAGE: ReceiveLegend <tf> <vmin> <vmax> <size>
588#
589# Invoked automatically whenever the "legend" command comes in from
590# the rendering server.  Indicates that binary image data with the
591# specified <size> will follow.
592# ----------------------------------------------------------------------
593itcl::body Rappture::HeightmapViewer::ReceiveLegend {obj vmin vmax size} {
594    if { [IsConnected] } {
595        set bytes [ReceiveBytes $size]
596        if { ![info exists _image(legend)] } {
597            set _image(legend) [image create picture]
598        }
599        ReceiveEcho <<line "<read $size bytes for [image width $_image(legend)]x[image height $_image(legend)] legend>"
600        set src [image create picture -data $bytes]
601        $_image(legend) rotate $src 90
602        image delete $src
603
604        set c $itk_component(3dview)
605        set w [winfo width $c]
606        set h [winfo height $c]
607        set lineht [font metrics $itk_option(-font) -linespace]
608
609        if { $_settings($this-legend) } {
610            if { [$c find withtag "legend"] == "" } {
611                $c create image [expr {$w-2}] [expr {$lineht+2}] -anchor ne \
612                    -image $_image(legend) -tags "transfunc legend"
613                $c create text [expr {$w-2}] 2 -anchor ne \
614                    -fill $itk_option(-plotforeground) -tags "vmax legend" \
615                    -font "Arial 8 bold"
616                $c create text [expr {$w-2}] [expr {$h-2}] -anchor se \
617                    -fill $itk_option(-plotforeground) -tags "vmin legend" \
618                    -font "Arial 8 bold"
619            }
620            # Reset the item coordinates according the current size of the plot.
621            $c coords transfunc [expr {$w-2}] [expr {$lineht+2}]
622            $c itemconfigure vmin -text $vmin
623            $c itemconfigure vmax -text $vmax
624            $c coords vmin [expr {$w-2}] [expr {$h-2}]
625            $c coords vmax [expr {$w-2}] 2
626        }
627    }
628}
629
630# ----------------------------------------------------------------------
631# USAGE: Rebuild
632#
633# Called automatically whenever something changes that affects the
634# data in the widget.  Clears any existing data and rebuilds the
635# widget to display new data.
636# ----------------------------------------------------------------------
637itcl::body Rappture::HeightmapViewer::Rebuild {} {
638
639    # Turn on buffering of commands to the server.  We don't want to
640    # be preempted by a server disconnect/reconnect (which automatically
641    # generates a new call to Rebuild).   
642    set _buffering 1
643
644    # Reset the overall limits
645    set _limits(vmin) ""
646    set _limits(vmax) ""
647
648    set _first ""
649    # Turn on buffering of commands to the server.  We don't want to
650    # be preempted by a server disconnect/reconnect (which automatically
651    # generates a new call to Rebuild).   
652    set _buffering 1
653
654    set w [winfo width $itk_component(3dview)]
655    set h [winfo height $itk_component(3dview)]
656    EventuallyResize $w $h
657
658    foreach dataobj [get] {
659        foreach comp [$dataobj components] {
660            # Tell the engine to expect some data
661            set tag $dataobj-$comp
662            if { ![info exists _serverObjs($tag)] } {
663                set data [$dataobj blob $comp]
664                set nbytes [string length $data]
665                append _outbuf "heightmap data follows $nbytes $dataobj-$comp\n"
666                append _outbuf $data
667               
668                set _serverObjs($tag) $tag
669               
670                # Determine the transfer function needed for this surface
671                # and make sure that it's defined on the server.
672                foreach {sname cmap wmap} [GetTransfuncData $dataobj $comp] break
673                SendCmd [list "transfunc" "define" $sname $cmap $wmap]
674                set _obj2style($tag) $sname
675            }
676        }
677    }
678
679    # Nothing to send -- activate the proper surface
680    set _first [lindex [get] 0]
681    if {"" != $_first} {
682        set axis [$_first hints updir]
683        if {"" != $axis} {
684            SendCmd "up $axis"
685        }
686        # This is where the initial camera position is set.
687        set location [$_first hints camera]
688        if { $_location == "" && $location != "" } {
689            array set _view $location
690            set _location $location
691        }
692    }
693    SendCmd "heightmap data visible 0"
694    set heightmaps [CurrentSurfaces]
695    if { $heightmaps != ""  && $_settings($this-surface) } {
696        SendCmd "heightmap data visible 1 $heightmaps"
697    }
698    set heightmaps [CurrentSurfaces -raise]
699    if { $heightmaps != "" } {
700        SendCmd "heightmap opacity 0.25"
701        SendCmd "heightmap opacity 0.95 $heightmaps"
702    } else {
703        SendCmd "heightmap opacity 0.85"
704    }
705    foreach key $heightmaps {
706        if {[info exists _obj2style($key)]} {
707            SendCmd "heightmap transfunc $_obj2style($key) $key"
708        }
709    }
710    $_dispatcher event -idle !legend
711
712    if {"" == $itk_option(-plotoutline)} {
713        SendCmd "grid linecolor [Color2RGB $itk_option(-plotoutline)]"
714    }
715    # Reset the camera and other view parameters
716    set _settings($this-theta) $_view(theta)
717    set _settings($this-phi)   $_view(phi)
718    set _settings($this-psi)   $_view(psi)
719    set _settings($this-pan-x) $_view(pan-x)
720    set _settings($this-pan-y) $_view(pan-y)
721    set _settings($this-zoom)  $_view(zoom)
722
723    set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
724    SendCmd "camera angle $xyz"
725    PanCamera
726    SendCmd "camera zoom $_view(zoom)"
727
728    FixSettings wireframe
729    FixSettings grid
730    FixSettings axes
731    FixSettings contourlines
732
733    # Actually write the commands to the server socket.  If it fails, we don't
734    # care.  We're finished here.
735    blt::busy hold $itk_component(hull)
736    SendBytes $_outbuf;                 
737    blt::busy release $itk_component(hull)
738
739    # The "readyForNextFrame" variable throttles the sequence play rate.
740    global readyForNextFrame
741    set readyForNextFrame 0;            # Don't advance to the next frame
742                                        # until we get an image.
743    set _buffering 0;                   # Turn off buffering.
744    set _outbuf "";                     # Clear the buffer.             
745}
746
747# ----------------------------------------------------------------------
748# USAGE: Zoom in
749# USAGE: Zoom out
750# USAGE: Zoom reset
751#
752# Called automatically when the user clicks on one of the zoom
753# controls for this widget.  Changes the zoom for the current view.
754# ----------------------------------------------------------------------
755itcl::body Rappture::HeightmapViewer::Zoom {option} {
756    switch -- $option {
757        "in" {
758            set _view(zoom) [expr {$_view(zoom)*1.25}]
759            set _settings($this-zoom) $_view(zoom)
760        }
761        "out" {
762            set _view(zoom) [expr {$_view(zoom)*0.8}]
763            set _settings($this-zoom) $_view(zoom)
764        }
765        "reset" {
766            array set _view {
767                theta   45
768                phi     45
769                psi     0
770                zoom    1.0
771                pan-x   0
772                pan-y   0
773            }
774            if { $_first != "" } {
775                set location [$_first hints camera]
776                if { $location != "" } {
777                    array set _view $location
778                }
779            }
780            set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
781            SendCmd "camera angle $xyz"
782            PanCamera
783            set _settings($this-theta) $_view(theta)
784            set _settings($this-phi) $_view(phi)
785            set _settings($this-psi) $_view(psi)
786            set _settings($this-pan-x) $_view(pan-x)
787            set _settings($this-pan-y) $_view(pan-y)
788            set _settings($this-zoom) $_view(zoom)
789        }
790    }
791    SendCmd "camera zoom $_view(zoom)"
792}
793
794# ----------------------------------------------------------------------
795# USAGE: $this Pan click x y
796#        $this Pan drag x y
797#        $this Pan release x y
798#
799# Called automatically when the user clicks on one of the zoom
800# controls for this widget.  Changes the zoom for the current view.
801# ----------------------------------------------------------------------
802itcl::body Rappture::HeightmapViewer::Pan {option x y} {
803    # Experimental stuff
804    set w [winfo width $itk_component(3dview)]
805    set h [winfo height $itk_component(3dview)]
806    if { $option == "set" } {
807        set x [expr ($x / double($w)) * $_limits(xrange)]
808        set y [expr ($y / double($h)) * $_limits(yrange)]
809        set _view(pan-x) [expr $_view(pan-x) + $x]
810        set _view(pan-y) [expr $_view(pan-y) + $y]
811        PanCamera
812        set _settings($this-pan-x) $_view(pan-x)
813        set _settings($this-pan-y) $_view(pan-y)
814        return
815    }
816    if { $option == "click" } {
817        set _click(x) $x
818        set _click(y) $y
819        $itk_component(3dview) configure -cursor hand1
820    }
821    if { $option == "drag" || $option == "release" } {
822        set dx [expr (($_click(x) - $x)/double($w)) * $_limits(xrange)]
823        set dy [expr (($_click(y) - $y)/double($h)) * $_limits(yrange)]
824        set _click(x) $x
825        set _click(y) $y
826        set _view(pan-x) [expr $_view(pan-x) - $dx]
827        set _view(pan-y) [expr $_view(pan-y) - $dy]
828        PanCamera
829        set _settings($this-pan-x) $_view(pan-x)
830        set _settings($this-pan-y) $_view(pan-y)
831    }
832    if { $option == "release" } {
833        $itk_component(3dview) configure -cursor ""
834    }
835}
836
837itcl::body Rappture::HeightmapViewer::PanCamera {} {
838    set x [expr ($_view(pan-x)) / $_limits(xrange)]
839    set y [expr ($_view(pan-y)) / $_limits(yrange)]
840    SendCmd "camera pan $x $y"
841}
842
843# ----------------------------------------------------------------------
844# USAGE: Rotate click <x> <y>
845# USAGE: Rotate drag <x> <y>
846# USAGE: Rotate release <x> <y>
847#
848# Called automatically when the user clicks/drags/releases in the
849# plot area.  Moves the plot according to the user's actions.
850# ----------------------------------------------------------------------
851itcl::body Rappture::HeightmapViewer::Rotate {option x y} {
852    switch -- $option {
853        click {
854            $itk_component(3dview) configure -cursor fleur
855            array set _click [subst {
856                x       $x
857                y       $y
858                theta   $_view(theta)
859                phi     $_view(phi)
860            }]
861        }
862        drag {
863            if {[array size _click] == 0} {
864                Rotate click $x $y
865            } else {
866                set w [winfo width $itk_component(3dview)]
867                set h [winfo height $itk_component(3dview)]
868                if {$w <= 0 || $h <= 0} {
869                    return
870                }
871
872                if {[catch {
873                    # this fails sometimes for no apparent reason
874                    set dx [expr {double($x-$_click(x))/$w}]
875                    set dy [expr {double($y-$_click(y))/$h}]
876                }] != 0 } {
877                    return
878                }
879
880                #
881                # Rotate the camera in 3D
882                #
883                if {$_view(psi) > 90 || $_view(psi) < -90} {
884                    # when psi is flipped around, theta moves backwards
885                    set dy [expr {-$dy}]
886                }
887                set theta [expr {$_view(theta) - $dy*180}]
888                while {$theta < 0} { set theta [expr {$theta+180}] }
889                while {$theta > 180} { set theta [expr {$theta-180}] }
890
891                if {abs($theta) >= 30 && abs($theta) <= 160} {
892                    set phi [expr {$_view(phi) - $dx*360}]
893                    while {$phi < 0} { set phi [expr {$phi+360}] }
894                    while {$phi > 360} { set phi [expr {$phi-360}] }
895                    set psi $_view(psi)
896                } else {
897                    set phi $_view(phi)
898                    set psi [expr {$_view(psi) - $dx*360}]
899                    while {$psi < -180} { set psi [expr {$psi+360}] }
900                    while {$psi > 180} { set psi [expr {$psi-360}] }
901                }
902
903                set _view(theta)        $theta
904                set _view(phi)          $phi
905                set _view(psi)          $psi
906                set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
907                set _settings($this-theta) $_view(theta)
908                set _settings($this-phi) $_view(phi)
909                set _settings($this-psi) $_view(psi)
910                SendCmd "camera angle $xyz"
911                set _click(x) $x
912                set _click(y) $y
913            }
914        }
915        release {
916            Rotate drag $x $y
917            $itk_component(3dview) configure -cursor ""
918            catch {unset _click}
919        }
920        default {
921            error "bad option \"$option\": should be click, drag, release"
922        }
923    }
924}
925
926# ----------------------------------------------------------------------
927# USAGE: State <component>
928#
929# Used internally to determine the state of a toggle button.
930# The <component> is the itk component name of the button.
931# Returns on/off for the state of the button.
932# ----------------------------------------------------------------------
933itcl::body Rappture::HeightmapViewer::State {comp} {
934    if {[$itk_component($comp) cget -relief] == "sunken"} {
935        return "on"
936    }
937    return "off"
938}
939
940# ----------------------------------------------------------------------
941# USAGE: FixSettings <what> ?<value>?
942#
943# Used internally to update rendering settings whenever parameters
944# change in the popup settings panel.  Sends the new settings off
945# to the back end.
946# ----------------------------------------------------------------------
947itcl::body Rappture::HeightmapViewer::FixSettings { what {value ""} } {
948    switch -- $what {
949        "legend" {
950            if { !$_settings($this-legend) } {
951                $itk_component(3dview) delete "legend"
952            }
953            set lineht [font metrics $itk_option(-font) -linespace]
954            set w [winfo height $itk_component(3dview)]
955            set h [winfo width $itk_component(3dview)]
956            set w [expr {$w - 2*$lineht - 4}]
957            set h 12
958            set tag ""
959            if {"" != $_first} {
960                set comp [lindex [$_first components] 0]
961                set tag $_first-$comp
962            }
963            if {$w > 0 && $h > 0 && "" != $tag} {
964                SendCmd "heightmap legend $tag $w $h"
965            } else {
966                #$itk_component(legend) delete all
967            }
968        }
969        "surface" {
970            if { [isconnected] } {
971                SendCmd "heightmap data visible $_settings($this-surface)"
972            }
973        }
974        "grid" {
975            if { [IsConnected] } {
976                SendCmd "grid visible $_settings($this-grid)"
977            }
978        }
979        "axes" {
980            if { [IsConnected] } {
981                SendCmd "axis visible $_settings($this-axes)"
982            }
983        }
984        "wireframe" {
985            if { [IsConnected] } {
986                SendCmd "heightmap polygon $_settings($this-wireframe)"
987            }
988        }
989        "contourlines" {
990            if {[IsConnected]} {
991                if {"" != $_first} {
992                    set comp [lindex [$_first components] 0]
993                    if { $comp != "" } {
994                        set tag $_first-$comp
995                        set bool $_settings($this-contourlines)
996                        SendCmd "heightmap linecontour visible $bool $tag"
997                    }
998                }
999            }
1000        }
1001        default {
1002            error "don't know how to fix $what: should be grid, axes, contourlines, or legend"
1003        }
1004    }
1005}
1006
1007# ----------------------------------------------------------------------
1008# USAGE: GetTransfuncData <dataobj> <comp>
1009#
1010# Used internally to compute the colormap and alpha map used to define
1011# a transfer function for the specified component in a data object.
1012# Returns: name {v r g b ...} {v w ...}
1013# ----------------------------------------------------------------------
1014itcl::body Rappture::HeightmapViewer::GetTransfuncData {dataobj comp} {
1015    array set style {
1016        -color rainbow
1017        -levels 6
1018        -opacity 0.5
1019    }
1020    array set style [lindex [$dataobj components -style $comp] 0]
1021    set sname "$style(-color):$style(-levels):$style(-opacity)"
1022
1023    if {$style(-color) == "rainbow"} {
1024        set style(-color) "white:yellow:green:cyan:blue:magenta"
1025    }
1026    if { [info exists style(-nonuniformcolors)] } {
1027        foreach { value color } $style(-nonuniformcolors) {
1028            append cmap "$value [Color2RGB $color] "
1029        }
1030    } else {
1031        set clist [split $style(-color) :]
1032        set cmap "0.0 [Color2RGB white] "
1033        for {set i 0} {$i < [llength $clist]} {incr i} {
1034            set x [expr {double($i+1)/([llength $clist]+1)}]
1035            set color [lindex $clist $i]
1036            append cmap "$x [Color2RGB $color] "
1037        }
1038        append cmap "1.0 [Color2RGB $color]"
1039    }
1040    set opacity $style(-opacity)
1041    set levels $style(-levels)
1042    set wmap {}
1043    if {[string is int $levels]} {
1044        lappend wmap 0.0 0.0
1045        set delta [expr {0.125/($levels+1)}]
1046        for {set i 1} {$i <= $levels} {incr i} {
1047            # add spikes in the middle
1048            set xval [expr {double($i)/($levels+1)}]
1049            lappend wmap [expr {$xval-$delta-0.01}] 0.0
1050            lappend wmap [expr {$xval-$delta}] $opacity
1051            lappend wmap [expr {$xval+$delta}] $opacity
1052            lappend wmap [expr {$xval+$delta+0.01}] 0.0
1053        }
1054        lappend wmap 1.0 0.0
1055    } else {
1056        lappend wmap 0.0 0.0
1057        set delta 0.05
1058        foreach xval [split $levels ,] {
1059            lappend wmap [expr {$xval-$delta}] 0.0
1060            lappend $xval $opacity
1061            lappend [expr {$xval+$delta}] 0.0
1062        }
1063        lappend wmap 1.0 0.0
1064    }
1065    return [list $sname $cmap $wmap]
1066}
1067
1068# ----------------------------------------------------------------------
1069# CONFIGURATION OPTION: -plotbackground
1070# ----------------------------------------------------------------------
1071itcl::configbody Rappture::HeightmapViewer::plotbackground {
1072    foreach {r g b} [Color2RGB $itk_option(-plotbackground)] break
1073    #fix this!
1074    #SendCmd "color background $r $g $b"
1075}
1076
1077# ----------------------------------------------------------------------
1078# CONFIGURATION OPTION: -plotforeground
1079# ----------------------------------------------------------------------
1080itcl::configbody Rappture::HeightmapViewer::plotforeground {
1081    foreach {r g b} [Color2RGB $itk_option(-plotforeground)] break
1082    #fix this!
1083    #SendCmd "color background $r $g $b"
1084}
1085
1086# ----------------------------------------------------------------------
1087# CONFIGURATION OPTION: -plotoutline
1088# ----------------------------------------------------------------------
1089itcl::configbody Rappture::HeightmapViewer::plotoutline {
1090    if {[IsConnected]} {
1091        SendCmd "grid linecolor [Color2RGB $itk_option(-plotoutline)]"
1092    }
1093}
1094
1095
1096
1097#  camera --
1098#
1099itcl::body Rappture::HeightmapViewer::camera {option args} {
1100    switch -- $option {
1101        "show" {
1102            puts [array get _view]
1103        }
1104        "set" {
1105            set who [lindex $args 0]
1106            set x $_settings($this-$who)
1107            set code [catch { string is double $x } result]
1108            if { $code != 0 || !$result } {
1109                set _settings($this-$who) $_view($who)
1110                return
1111            }
1112            switch -- $who {
1113                "pan-x" - "pan-y" {
1114                    set _view($who) $_settings($this-$who)
1115                    PanCamera
1116                }
1117                "phi" - "theta" - "psi" {
1118                    set _view($who) $_settings($this-$who)
1119                    set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
1120                    SendCmd "camera angle $xyz"
1121                }
1122                "zoom" {
1123                    set _view($who) $_settings($this-$who)
1124                    SendCmd "camera zoom $_view(zoom)"
1125                }
1126            }
1127        }
1128    }
1129}
1130
1131itcl::body Rappture::HeightmapViewer::BuildViewTab {} {
1132    set fg [option get $itk_component(hull) font Font]
1133
1134    set tab [$itk_component(main) insert end \
1135        -title "View Settings" \
1136        -icon [Rappture::icon wrench]]
1137    blt::scrollset $tab.ss \
1138        -xscrollbar $tab.ss.xs \
1139        -yscrollbar $tab.ss.ys \
1140        -window $tab.ss.frame
1141    pack $tab.ss -fill both -expand yes
1142    blt::tk::scrollbar $tab.ss.xs               
1143    blt::tk::scrollbar $tab.ss.ys               
1144    set inner [blt::tk::frame $tab.ss.frame]
1145    $inner configure -borderwidth 4
1146
1147    foreach { key value } {
1148        grid            1
1149        axes            0
1150        contourlines    1
1151        wireframe       fill
1152        legend          1
1153    } {
1154        set _settings($this-$key) $value
1155    }
1156
1157    checkbutton $inner.surface \
1158        -text "surface" \
1159        -variable [itcl::scope _settings($this-surface)] \
1160        -command [itcl::code $this FixSettings surface] \
1161        -font "Arial 9"
1162    checkbutton $inner.grid \
1163        -text "grid" \
1164        -variable [itcl::scope _settings($this-grid)] \
1165        -command [itcl::code $this FixSettings grid] \
1166        -font "Arial 9"
1167    checkbutton $inner.axes \
1168        -text "axes" \
1169        -variable ::Rappture::HeightmapViewer::_settings($this-axes) \
1170        -command [itcl::code $this FixSettings axes] \
1171        -font "Arial 9"
1172    checkbutton $inner.contourlines \
1173        -text "contour lines" \
1174        -variable ::Rappture::HeightmapViewer::_settings($this-contourlines) \
1175        -command [itcl::code $this FixSettings contourlines]\
1176        -font "Arial 9"
1177    checkbutton $inner.wireframe \
1178        -text "wireframe" \
1179        -onvalue "wireframe" -offvalue "fill" \
1180        -variable ::Rappture::HeightmapViewer::_settings($this-wireframe) \
1181        -command [itcl::code $this FixSettings wireframe]\
1182        -font "Arial 9"
1183    checkbutton $inner.legend \
1184        -text "legend" \
1185        -variable ::Rappture::HeightmapViewer::_settings($this-legend) \
1186        -command [itcl::code $this FixSettings legend]\
1187        -font "Arial 9"
1188
1189    blt::table $inner \
1190        0,1 $inner.surface -anchor w  \
1191        1,1 $inner.grid -anchor w  \
1192        2,1 $inner.axes -anchor w \
1193        3,1 $inner.contourlines -anchor w \
1194        4,1 $inner.wireframe -anchor w \
1195        5,1 $inner.legend -anchor w
1196
1197    blt::table configure $inner c2 -resize expand
1198    blt::table configure $inner c1 -resize none
1199    blt::table configure $inner r* -resize none
1200    blt::table configure $inner r6 -resize expand
1201}
1202
1203itcl::body Rappture::HeightmapViewer::BuildCameraTab {} {
1204    set fg [option get $itk_component(hull) font Font]
1205
1206    set tab [$itk_component(main) insert end \
1207        -title "Camera Settings" \
1208        -icon [Rappture::icon camera]]
1209    blt::scrollset $tab.ss \
1210        -xscrollbar $tab.ss.xs \
1211        -yscrollbar $tab.ss.ys \
1212        -window $tab.ss.frame
1213    pack $tab.ss -fill both -expand yes
1214    blt::tk::scrollbar $tab.ss.xs               
1215    blt::tk::scrollbar $tab.ss.ys               
1216    set inner [blt::tk::frame $tab.ss.frame]
1217    $inner configure -borderwidth 4
1218
1219    set labels { phi theta psi pan-x pan-y zoom }
1220    set row 1
1221    foreach tag $labels {
1222        label $inner.${tag}label -text $tag -font "Arial 9"
1223        entry $inner.${tag} -font "Arial 9" -bg white -width 10 \
1224            -textvariable [itcl::scope _settings($this-$tag)]
1225        bind $inner.${tag} <KeyPress-Return> \
1226            [itcl::code $this camera set ${tag}]
1227        blt::table $inner \
1228            $row,1 $inner.${tag}label -anchor e \
1229            $row,2 $inner.${tag} -anchor w
1230        blt::table configure $inner r$row -resize none
1231        incr row
1232    }
1233    blt::table configure $inner c1 c2 -resize none
1234    blt::table configure $inner c3 -resize expand
1235    blt::table configure $inner r$row -resize expand
1236}
1237
1238itcl::body Rappture::HeightmapViewer::Resize {} {
1239    SendCmd "screen $_width $_height"
1240    set _resizePending 0
1241    $_dispatcher event -idle !legend
1242}
1243
1244itcl::body Rappture::HeightmapViewer::EventuallyResize { w h } {
1245    set _width $w
1246    set _height $h
1247    if { !$_resizePending } {
1248        $_dispatcher event -after 200 !resize
1249        set _resizePending 1
1250    }
1251}
1252
1253# ----------------------------------------------------------------------
1254# USAGE: CurrentVolumes ?-cutplanes?
1255#
1256# Returns a list of volume server IDs for the current volume being
1257# displayed.  This is normally a single ID, but it might be a list
1258# of IDs if the current data object has multiple components.
1259# ----------------------------------------------------------------------
1260itcl::body Rappture::HeightmapViewer::CurrentSurfaces {{what -all}} {
1261    set list {}
1262    if { $what == "-all" } {
1263        foreach key [array names _serverObjs] {
1264            foreach {dataobj comp} [split $key -] break
1265            if { [info exists _obj2ovride($dataobj-raise)] } {
1266                lappend list $dataobj-$comp
1267            }
1268        }
1269    } else {
1270        foreach key [array names _serverObjs] {
1271            foreach {dataobj comp} [split $key -] break
1272            if { [info exists _obj2ovride($dataobj$what)] &&
1273                 $_obj2ovride($dataobj$what) } {
1274                lappend list $dataobj-$comp
1275            }
1276        }
1277    }
1278    return $list
1279}
1280
1281itcl::body Rappture::HeightmapViewer::snap { w h } {
1282    if { $w <= 0 || $h <= 0 } {
1283        set w [image width $_image(plot)]
1284        set h [image height $_image(plot)]
1285    }
1286    set img [image create picture -width $w -height $h]
1287    $img resample $_image(plot)
1288    return $img
1289}
Note: See TracBrowser for help on using the repository browser.