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

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