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

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