source: trunk/gui/scripts/heightmapviewer.tcl @ 2417

Last change on this file since 2417 was 1984, checked in by gah, 13 years ago

Clean up debugging/printing traces
File size: 44.1 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
18package 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 photo]
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 {
474                blt::winop snap $itk_component(plotarea) $_image(download)
475            }]} {
476                $_image(download) configure -width 1 -height 1
477                $_image(download) put #000000
478            }
479        }
480        controls {
481            # no controls for this download yet
482            return ""
483        }
484        now {
485            # Get the image data (as base64) and decode it back to binary.
486            # This is better than writing to temporary files.  When we switch
487            # to the BLT picture image it won't be necessary to decode the
488            # image data.
489            set bytes [$_image(download) data -format "jpeg -quality 100"]
490            set bytes [Rappture::encoding::decode -as b64 $bytes]
491            return [list .jpg $bytes]
492        }
493        default {
494            error "bad option \"$option\": should be coming, controls, now"
495        }
496    }
497}
498
499#
500# isconnected --
501#
502#       Indicates if we are currently connected to the visualization server.
503#
504itcl::body Rappture::HeightmapViewer::isconnected {} {
505    return [VisViewer::IsConnected]
506}
507
508# ----------------------------------------------------------------------
509# USAGE: Connect ?<host:port>,<host:port>...?
510#
511# Clients use this method to establish a connection to a new
512# server, or to reestablish a connection to the previous server.
513# Any existing connection is automatically closed.
514# ----------------------------------------------------------------------
515itcl::body Rappture::HeightmapViewer::Connect {} {
516    global readyForNextFrame
517    set readyForNextFrame 1
518    Disconnect
519    set _hosts [GetServerList "nanovis"]
520    if { "" == $_hosts } {
521        return 0
522    }
523    catch {unset _serverObjs}
524    set result [VisViewer::Connect $_hosts]
525    return $result
526}
527
528# ----------------------------------------------------------------------
529# USAGE: Disconnect
530#
531# Clients use this method to disconnect from the current rendering
532# server.
533# ----------------------------------------------------------------------
534itcl::body Rappture::HeightmapViewer::Disconnect {} {
535    VisViewer::Disconnect
536
537    set _outbuf ""
538    # disconnected -- no more data sitting on server
539    global readyForNextFrame
540    set readyForNextFrame 1
541}
542
543#
544# SendCmd
545#
546#       Send commands off to the rendering server.  If we're currently
547#       sending data objects to the server, buffer the commands to be
548#       sent later.
549#
550itcl::body Rappture::HeightmapViewer::SendCmd {string} {
551    if { $_buffering } {
552        append _outbuf $string "\n"
553    } else {
554        foreach line [split $string \n] {
555            SendEcho >>line $line
556        }
557        SendBytes "$string\n"
558    }
559}
560
561# ----------------------------------------------------------------------
562# USAGE: ReceiveImage -bytes <size>
563#
564# Invoked automatically whenever the "image" command comes in from
565# the rendering server.  Indicates that binary image data with the
566# specified <size> will follow.
567# ----------------------------------------------------------------------
568itcl::body Rappture::HeightmapViewer::ReceiveImage { args } {
569    global readyForNextFrame
570    set readyForNextFrame 1
571    if {![IsConnected]} {
572        return
573    }
574    array set info {
575        -type image
576    }
577    array set info $args
578    set bytes [ReceiveBytes $info(-bytes)]
579    ReceiveEcho <<line "<read $info(-bytes) bytes"
580    if { $info(-type) == "image" } {
581        $_image(plot) configure -data $bytes
582        ReceiveEcho <<line "<read for [image width $_image(plot)]x[image height $_image(plot)] image>"
583    } elseif { $info(type) == "print" } {
584        set tag $this-print-$info(-token)
585        set _hardcopy($tag) $bytes
586    }
587}
588
589# ----------------------------------------------------------------------
590# USAGE: ReceiveLegend <tf> <vmin> <vmax> <size>
591#
592# Invoked automatically whenever the "legend" command comes in from
593# the rendering server.  Indicates that binary image data with the
594# specified <size> will follow.
595# ----------------------------------------------------------------------
596itcl::body Rappture::HeightmapViewer::ReceiveLegend {obj vmin vmax size} {
597    if { [IsConnected] } {
598        set bytes [ReceiveBytes $size]
599        if { ![info exists _image(legend)] } {
600            set _image(legend) [image create photo]
601        }
602        ReceiveEcho <<line "<read $size bytes for [image width $_image(legend)]x[image height $_image(legend)] legend>"
603        set src [image create photo -data $bytes]
604        blt::winop image rotate $src $_image(legend) 90
605        set dst $_image(legend)
606
607        set c $itk_component(3dview)
608        set w [winfo width $c]
609        set h [winfo height $c]
610        set lineht [font metrics $itk_option(-font) -linespace]
611
612        if { $_settings($this-legend) } {
613            if { [$c find withtag "legend"] == "" } {
614                $c create image [expr {$w-2}] [expr {$lineht+2}] -anchor ne \
615                    -image $_image(legend) -tags "transfunc legend"
616                $c create text [expr {$w-2}] 2 -anchor ne \
617                    -fill $itk_option(-plotforeground) -tags "vmax legend" \
618                    -font "Arial 8 bold"
619                $c create text [expr {$w-2}] [expr {$h-2}] -anchor se \
620                    -fill $itk_option(-plotforeground) -tags "vmin legend" \
621                    -font "Arial 8 bold"
622            }
623            # Reset the item coordinates according the current size of the plot.
624            $c coords transfunc [expr {$w-2}] [expr {$lineht+2}]
625            $c itemconfigure vmin -text $vmin
626            $c itemconfigure vmax -text $vmax
627            $c coords vmin [expr {$w-2}] [expr {$h-2}]
628            $c coords vmax [expr {$w-2}] 2
629        }
630    }
631}
632
633# ----------------------------------------------------------------------
634# USAGE: Rebuild
635#
636# Called automatically whenever something changes that affects the
637# data in the widget.  Clears any existing data and rebuilds the
638# widget to display new data.
639# ----------------------------------------------------------------------
640itcl::body Rappture::HeightmapViewer::Rebuild {} {
641
642    # Turn on buffering of commands to the server.  We don't want to
643    # be preempted by a server disconnect/reconnect (which automatically
644    # generates a new call to Rebuild).   
645    set _buffering 1
646
647    # Reset the overall limits
648    set _limits(vmin) ""
649    set _limits(vmax) ""
650
651    set _first ""
652    # Turn on buffering of commands to the server.  We don't want to
653    # be preempted by a server disconnect/reconnect (which automatically
654    # generates a new call to Rebuild).   
655    set _buffering 1
656
657    set w [winfo width $itk_component(3dview)]
658    set h [winfo height $itk_component(3dview)]
659    EventuallyResize $w $h
660
661    foreach dataobj [get] {
662        foreach comp [$dataobj components] {
663            # Tell the engine to expect some data
664            set tag $dataobj-$comp
665            if { ![info exists _serverObjs($tag)] } {
666                set data [$dataobj blob $comp]
667                set nbytes [string length $data]
668                append _outbuf "heightmap data follows $nbytes $dataobj-$comp\n"
669                append _outbuf $data
670               
671                set _serverObjs($tag) $tag
672               
673                # Determine the transfer function needed for this surface
674                # and make sure that it's defined on the server.
675                foreach {sname cmap wmap} [GetTransfuncData $dataobj $comp] break
676                SendCmd [list "transfunc" "define" $sname $cmap $wmap]
677                set _obj2style($tag) $sname
678            }
679        }
680    }
681
682    # Nothing to send -- activate the proper surface
683    set _first [lindex [get] 0]
684    if {"" != $_first} {
685        set axis [$_first hints updir]
686        if {"" != $axis} {
687            SendCmd "up $axis"
688        }
689        # This is where the initial camera position is set.
690        set location [$_first hints camera]
691        if { $_location == "" && $location != "" } {
692            array set _view $location
693            set _location $location
694        }
695    }
696    SendCmd "heightmap data visible 0"
697    set heightmaps [CurrentSurfaces]
698    if { $heightmaps != ""  && $_settings($this-surface) } {
699        SendCmd "heightmap data visible 1 $heightmaps"
700    }
701    set heightmaps [CurrentSurfaces -raise]
702    if { $heightmaps != "" } {
703        SendCmd "heightmap opacity 0.25"
704        SendCmd "heightmap opacity 0.95 $heightmaps"
705    } else {
706        SendCmd "heightmap opacity 0.85"
707    }
708    foreach key $heightmaps {
709        if {[info exists _obj2style($key)]} {
710            SendCmd "heightmap transfunc $_obj2style($key) $key"
711        }
712    }
713    $_dispatcher event -idle !legend
714
715    if {"" == $itk_option(-plotoutline)} {
716        SendCmd "grid linecolor [Color2RGB $itk_option(-plotoutline)]"
717    }
718    # Reset the camera and other view parameters
719    set _settings($this-theta) $_view(theta)
720    set _settings($this-phi)   $_view(phi)
721    set _settings($this-psi)   $_view(psi)
722    set _settings($this-pan-x) $_view(pan-x)
723    set _settings($this-pan-y) $_view(pan-y)
724    set _settings($this-zoom)  $_view(zoom)
725
726    set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
727    SendCmd "camera angle $xyz"
728    PanCamera
729    SendCmd "camera zoom $_view(zoom)"
730
731    FixSettings wireframe
732    FixSettings grid
733    FixSettings axes
734    FixSettings contourlines
735
736    # Actually write the commands to the server socket.  If it fails, we don't
737    # care.  We're finished here.
738    blt::busy hold $itk_component(hull)
739    SendBytes $_outbuf;                 
740    blt::busy release $itk_component(hull)
741
742    # The "readyForNextFrame" variable throttles the sequence play rate.
743    global readyForNextFrame
744    set readyForNextFrame 0;            # Don't advance to the next frame
745                                        # until we get an image.
746    set _buffering 0;                   # Turn off buffering.
747    set _outbuf "";                     # Clear the buffer.             
748}
749
750# ----------------------------------------------------------------------
751# USAGE: Zoom in
752# USAGE: Zoom out
753# USAGE: Zoom reset
754#
755# Called automatically when the user clicks on one of the zoom
756# controls for this widget.  Changes the zoom for the current view.
757# ----------------------------------------------------------------------
758itcl::body Rappture::HeightmapViewer::Zoom {option} {
759    switch -- $option {
760        "in" {
761            set _view(zoom) [expr {$_view(zoom)*1.25}]
762            set _settings($this-zoom) $_view(zoom)
763        }
764        "out" {
765            set _view(zoom) [expr {$_view(zoom)*0.8}]
766            set _settings($this-zoom) $_view(zoom)
767        }
768        "reset" {
769            array set _view {
770                theta   45
771                phi     45
772                psi     0
773                zoom    1.0
774                pan-x   0
775                pan-y   0
776            }
777            if { $_first != "" } {
778                set location [$_first hints camera]
779                if { $location != "" } {
780                    array set _view $location
781                }
782            }
783            set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
784            SendCmd "camera angle $xyz"
785            PanCamera
786            set _settings($this-theta) $_view(theta)
787            set _settings($this-phi) $_view(phi)
788            set _settings($this-psi) $_view(psi)
789            set _settings($this-pan-x) $_view(pan-x)
790            set _settings($this-pan-y) $_view(pan-y)
791            set _settings($this-zoom) $_view(zoom)
792        }
793    }
794    SendCmd "camera zoom $_view(zoom)"
795}
796
797# ----------------------------------------------------------------------
798# USAGE: $this Pan click x y
799#        $this Pan drag x y
800#        $this Pan release x y
801#
802# Called automatically when the user clicks on one of the zoom
803# controls for this widget.  Changes the zoom for the current view.
804# ----------------------------------------------------------------------
805itcl::body Rappture::HeightmapViewer::Pan {option x y} {
806    # Experimental stuff
807    set w [winfo width $itk_component(3dview)]
808    set h [winfo height $itk_component(3dview)]
809    if { $option == "set" } {
810        set x [expr ($x / double($w)) * $_limits(xrange)]
811        set y [expr ($y / double($h)) * $_limits(yrange)]
812        set _view(pan-x) [expr $_view(pan-x) + $x]
813        set _view(pan-y) [expr $_view(pan-y) + $y]
814        PanCamera
815        set _settings($this-pan-x) $_view(pan-x)
816        set _settings($this-pan-y) $_view(pan-y)
817        return
818    }
819    if { $option == "click" } {
820        set _click(x) $x
821        set _click(y) $y
822        $itk_component(3dview) configure -cursor hand1
823    }
824    if { $option == "drag" || $option == "release" } {
825        set dx [expr (($_click(x) - $x)/double($w)) * $_limits(xrange)]
826        set dy [expr (($_click(y) - $y)/double($h)) * $_limits(yrange)]
827        set _click(x) $x
828        set _click(y) $y
829        set _view(pan-x) [expr $_view(pan-x) - $dx]
830        set _view(pan-y) [expr $_view(pan-y) - $dy]
831        PanCamera
832        set _settings($this-pan-x) $_view(pan-x)
833        set _settings($this-pan-y) $_view(pan-y)
834    }
835    if { $option == "release" } {
836        $itk_component(3dview) configure -cursor ""
837    }
838}
839
840itcl::body Rappture::HeightmapViewer::PanCamera {} {
841    set x [expr ($_view(pan-x)) / $_limits(xrange)]
842    set y [expr ($_view(pan-y)) / $_limits(yrange)]
843    SendCmd "camera pan $x $y"
844}
845
846# ----------------------------------------------------------------------
847# USAGE: Rotate click <x> <y>
848# USAGE: Rotate drag <x> <y>
849# USAGE: Rotate release <x> <y>
850#
851# Called automatically when the user clicks/drags/releases in the
852# plot area.  Moves the plot according to the user's actions.
853# ----------------------------------------------------------------------
854itcl::body Rappture::HeightmapViewer::Rotate {option x y} {
855    switch -- $option {
856        click {
857            $itk_component(3dview) configure -cursor fleur
858            array set _click [subst {
859                x       $x
860                y       $y
861                theta   $_view(theta)
862                phi     $_view(phi)
863            }]
864        }
865        drag {
866            if {[array size _click] == 0} {
867                Rotate click $x $y
868            } else {
869                set w [winfo width $itk_component(3dview)]
870                set h [winfo height $itk_component(3dview)]
871                if {$w <= 0 || $h <= 0} {
872                    return
873                }
874
875                if {[catch {
876                    # this fails sometimes for no apparent reason
877                    set dx [expr {double($x-$_click(x))/$w}]
878                    set dy [expr {double($y-$_click(y))/$h}]
879                }] != 0 } {
880                    return
881                }
882
883                #
884                # Rotate the camera in 3D
885                #
886                if {$_view(psi) > 90 || $_view(psi) < -90} {
887                    # when psi is flipped around, theta moves backwards
888                    set dy [expr {-$dy}]
889                }
890                set theta [expr {$_view(theta) - $dy*180}]
891                while {$theta < 0} { set theta [expr {$theta+180}] }
892                while {$theta > 180} { set theta [expr {$theta-180}] }
893
894                if {abs($theta) >= 30 && abs($theta) <= 160} {
895                    set phi [expr {$_view(phi) - $dx*360}]
896                    while {$phi < 0} { set phi [expr {$phi+360}] }
897                    while {$phi > 360} { set phi [expr {$phi-360}] }
898                    set psi $_view(psi)
899                } else {
900                    set phi $_view(phi)
901                    set psi [expr {$_view(psi) - $dx*360}]
902                    while {$psi < -180} { set psi [expr {$psi+360}] }
903                    while {$psi > 180} { set psi [expr {$psi-360}] }
904                }
905
906                set _view(theta)        $theta
907                set _view(phi)          $phi
908                set _view(psi)          $psi
909                set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
910                set _settings($this-theta) $_view(theta)
911                set _settings($this-phi) $_view(phi)
912                set _settings($this-psi) $_view(psi)
913                SendCmd "camera angle $xyz"
914                set _click(x) $x
915                set _click(y) $y
916            }
917        }
918        release {
919            Rotate drag $x $y
920            $itk_component(3dview) configure -cursor ""
921            catch {unset _click}
922        }
923        default {
924            error "bad option \"$option\": should be click, drag, release"
925        }
926    }
927}
928
929# ----------------------------------------------------------------------
930# USAGE: State <component>
931#
932# Used internally to determine the state of a toggle button.
933# The <component> is the itk component name of the button.
934# Returns on/off for the state of the button.
935# ----------------------------------------------------------------------
936itcl::body Rappture::HeightmapViewer::State {comp} {
937    if {[$itk_component($comp) cget -relief] == "sunken"} {
938        return "on"
939    }
940    return "off"
941}
942
943# ----------------------------------------------------------------------
944# USAGE: FixSettings <what> ?<value>?
945#
946# Used internally to update rendering settings whenever parameters
947# change in the popup settings panel.  Sends the new settings off
948# to the back end.
949# ----------------------------------------------------------------------
950itcl::body Rappture::HeightmapViewer::FixSettings { what {value ""} } {
951    switch -- $what {
952        "legend" {
953            if { !$_settings($this-legend) } {
954                $itk_component(3dview) delete "legend"
955            }
956            set lineht [font metrics $itk_option(-font) -linespace]
957            set w [winfo height $itk_component(3dview)]
958            set h [winfo width $itk_component(3dview)]
959            set w [expr {$w - 2*$lineht - 4}]
960            set h 12
961            set tag ""
962            if {"" != $_first} {
963                set comp [lindex [$_first components] 0]
964                set tag $_first-$comp
965            }
966            if {$w > 0 && $h > 0 && "" != $tag} {
967                SendCmd "heightmap legend $tag $w $h"
968            } else {
969                #$itk_component(legend) delete all
970            }
971        }
972        "surface" {
973            if { [isconnected] } {
974                SendCmd "heightmap data visible $_settings($this-surface)"
975            }
976        }
977        "grid" {
978            if { [IsConnected] } {
979                SendCmd "grid visible $_settings($this-grid)"
980            }
981        }
982        "axes" {
983            if { [IsConnected] } {
984                SendCmd "axis visible $_settings($this-axes)"
985            }
986        }
987        "wireframe" {
988            if { [IsConnected] } {
989                SendCmd "heightmap polygon $_settings($this-wireframe)"
990            }
991        }
992        "contourlines" {
993            if {[IsConnected]} {
994                if {"" != $_first} {
995                    set comp [lindex [$_first components] 0]
996                    if { $comp != "" } {
997                        set tag $_first-$comp
998                        set bool $_settings($this-contourlines)
999                        SendCmd "heightmap linecontour visible $bool $tag"
1000                    }
1001                }
1002            }
1003        }
1004        default {
1005            error "don't know how to fix $what: should be grid, axes, contourlines, or legend"
1006        }
1007    }
1008}
1009
1010# ----------------------------------------------------------------------
1011# USAGE: GetTransfuncData <dataobj> <comp>
1012#
1013# Used internally to compute the colormap and alpha map used to define
1014# a transfer function for the specified component in a data object.
1015# Returns: name {v r g b ...} {v w ...}
1016# ----------------------------------------------------------------------
1017itcl::body Rappture::HeightmapViewer::GetTransfuncData {dataobj comp} {
1018    array set style {
1019        -color rainbow
1020        -levels 6
1021        -opacity 0.5
1022    }
1023    array set style [lindex [$dataobj components -style $comp] 0]
1024    set sname "$style(-color):$style(-levels):$style(-opacity)"
1025
1026    if {$style(-color) == "rainbow"} {
1027        set style(-color) "white:yellow:green:cyan:blue:magenta"
1028    }
1029    if { [info exists style(-nonuniformcolors)] } {
1030        foreach { value color } $style(-nonuniformcolors) {
1031            append cmap "$value [Color2RGB $color] "
1032        }
1033    } else {
1034        set clist [split $style(-color) :]
1035        set cmap "0.0 [Color2RGB white] "
1036        for {set i 0} {$i < [llength $clist]} {incr i} {
1037            set x [expr {double($i+1)/([llength $clist]+1)}]
1038            set color [lindex $clist $i]
1039            append cmap "$x [Color2RGB $color] "
1040        }
1041        append cmap "1.0 [Color2RGB $color]"
1042    }
1043    set opacity $style(-opacity)
1044    set levels $style(-levels)
1045    set wmap {}
1046    if {[string is int $levels]} {
1047        lappend wmap 0.0 0.0
1048        set delta [expr {0.125/($levels+1)}]
1049        for {set i 1} {$i <= $levels} {incr i} {
1050            # add spikes in the middle
1051            set xval [expr {double($i)/($levels+1)}]
1052            lappend wmap [expr {$xval-$delta-0.01}] 0.0
1053            lappend wmap [expr {$xval-$delta}] $opacity
1054            lappend wmap [expr {$xval+$delta}] $opacity
1055            lappend wmap [expr {$xval+$delta+0.01}] 0.0
1056        }
1057        lappend wmap 1.0 0.0
1058    } else {
1059        lappend wmap 0.0 0.0
1060        set delta 0.05
1061        foreach xval [split $levels ,] {
1062            lappend wmap [expr {$xval-$delta}] 0.0
1063            lappend $xval $opacity
1064            lappend [expr {$xval+$delta}] 0.0
1065        }
1066        lappend wmap 1.0 0.0
1067    }
1068    return [list $sname $cmap $wmap]
1069}
1070
1071# ----------------------------------------------------------------------
1072# CONFIGURATION OPTION: -plotbackground
1073# ----------------------------------------------------------------------
1074itcl::configbody Rappture::HeightmapViewer::plotbackground {
1075    foreach {r g b} [Color2RGB $itk_option(-plotbackground)] break
1076    #fix this!
1077    #SendCmd "color background $r $g $b"
1078}
1079
1080# ----------------------------------------------------------------------
1081# CONFIGURATION OPTION: -plotforeground
1082# ----------------------------------------------------------------------
1083itcl::configbody Rappture::HeightmapViewer::plotforeground {
1084    foreach {r g b} [Color2RGB $itk_option(-plotforeground)] break
1085    #fix this!
1086    #SendCmd "color background $r $g $b"
1087}
1088
1089# ----------------------------------------------------------------------
1090# CONFIGURATION OPTION: -plotoutline
1091# ----------------------------------------------------------------------
1092itcl::configbody Rappture::HeightmapViewer::plotoutline {
1093    if {[IsConnected]} {
1094        SendCmd "grid linecolor [Color2RGB $itk_option(-plotoutline)]"
1095    }
1096}
1097
1098
1099
1100#  camera --
1101#
1102itcl::body Rappture::HeightmapViewer::camera {option args} {
1103    switch -- $option {
1104        "show" {
1105            puts [array get _view]
1106        }
1107        "set" {
1108            set who [lindex $args 0]
1109            set x $_settings($this-$who)
1110            set code [catch { string is double $x } result]
1111            if { $code != 0 || !$result } {
1112                set _settings($this-$who) $_view($who)
1113                return
1114            }
1115            switch -- $who {
1116                "pan-x" - "pan-y" {
1117                    set _view($who) $_settings($this-$who)
1118                    PanCamera
1119                }
1120                "phi" - "theta" - "psi" {
1121                    set _view($who) $_settings($this-$who)
1122                    set xyz [Euler2XYZ $_view(theta) $_view(phi) $_view(psi)]
1123                    SendCmd "camera angle $xyz"
1124                }
1125                "zoom" {
1126                    set _view($who) $_settings($this-$who)
1127                    SendCmd "camera zoom $_view(zoom)"
1128                }
1129            }
1130        }
1131    }
1132}
1133
1134itcl::body Rappture::HeightmapViewer::BuildViewTab {} {
1135    set fg [option get $itk_component(hull) font Font]
1136
1137    set inner [$itk_component(main) insert end \
1138        -title "View Settings" \
1139        -icon [Rappture::icon wrench]]
1140    $inner configure -borderwidth 4
1141
1142    foreach { key value } {
1143        grid            1
1144        axes            0
1145        contourlines    1
1146        wireframe       fill
1147        legend          1
1148    } {
1149        set _settings($this-$key) $value
1150    }
1151
1152    checkbutton $inner.surface \
1153        -text "surface" \
1154        -variable [itcl::scope _settings($this-surface)] \
1155        -command [itcl::code $this FixSettings surface] \
1156        -font "Arial 9"
1157    checkbutton $inner.grid \
1158        -text "grid" \
1159        -variable [itcl::scope _settings($this-grid)] \
1160        -command [itcl::code $this FixSettings grid] \
1161        -font "Arial 9"
1162    checkbutton $inner.axes \
1163        -text "axes" \
1164        -variable ::Rappture::HeightmapViewer::_settings($this-axes) \
1165        -command [itcl::code $this FixSettings axes] \
1166        -font "Arial 9"
1167    checkbutton $inner.contourlines \
1168        -text "contour lines" \
1169        -variable ::Rappture::HeightmapViewer::_settings($this-contourlines) \
1170        -command [itcl::code $this FixSettings contourlines]\
1171        -font "Arial 9"
1172    checkbutton $inner.wireframe \
1173        -text "wireframe" \
1174        -onvalue "wireframe" -offvalue "fill" \
1175        -variable ::Rappture::HeightmapViewer::_settings($this-wireframe) \
1176        -command [itcl::code $this FixSettings wireframe]\
1177        -font "Arial 9"
1178    checkbutton $inner.legend \
1179        -text "legend" \
1180        -variable ::Rappture::HeightmapViewer::_settings($this-legend) \
1181        -command [itcl::code $this FixSettings legend]\
1182        -font "Arial 9"
1183
1184    blt::table $inner \
1185        0,1 $inner.surface -anchor w  \
1186        1,1 $inner.grid -anchor w  \
1187        2,1 $inner.axes -anchor w \
1188        3,1 $inner.contourlines -anchor w \
1189        4,1 $inner.wireframe -anchor w \
1190        5,1 $inner.legend -anchor w
1191
1192    blt::table configure $inner c2 -resize expand
1193    blt::table configure $inner c1 -resize none
1194    blt::table configure $inner r* -resize none
1195    blt::table configure $inner r6 -resize expand
1196}
1197
1198itcl::body Rappture::HeightmapViewer::BuildCameraTab {} {
1199    set fg [option get $itk_component(hull) font Font]
1200
1201    set inner [$itk_component(main) insert end \
1202        -title "Camera Settings" \
1203        -icon [Rappture::icon camera]]
1204    $inner configure -borderwidth 4
1205
1206    set labels { phi theta psi pan-x pan-y zoom }
1207    set row 1
1208    foreach tag $labels {
1209        label $inner.${tag}label -text $tag -font "Arial 9"
1210        entry $inner.${tag} -font "Arial 9" -bg white -width 10 \
1211            -textvariable [itcl::scope _settings($this-$tag)]
1212        bind $inner.${tag} <KeyPress-Return> \
1213            [itcl::code $this camera set ${tag}]
1214        blt::table $inner \
1215            $row,1 $inner.${tag}label -anchor e \
1216            $row,2 $inner.${tag} -anchor w
1217        blt::table configure $inner r$row -resize none
1218        incr row
1219    }
1220    blt::table configure $inner c1 c2 -resize none
1221    blt::table configure $inner c3 -resize expand
1222    blt::table configure $inner r$row -resize expand
1223}
1224
1225itcl::body Rappture::HeightmapViewer::Resize {} {
1226    SendCmd "screen $_width $_height"
1227    set _resizePending 0
1228    $_dispatcher event -idle !legend
1229}
1230
1231itcl::body Rappture::HeightmapViewer::EventuallyResize { w h } {
1232    set _width $w
1233    set _height $h
1234    if { !$_resizePending } {
1235        $_dispatcher event -after 200 !resize
1236        set _resizePending 1
1237    }
1238}
1239
1240# ----------------------------------------------------------------------
1241# USAGE: CurrentVolumes ?-cutplanes?
1242#
1243# Returns a list of volume server IDs for the current volume being
1244# displayed.  This is normally a single ID, but it might be a list
1245# of IDs if the current data object has multiple components.
1246# ----------------------------------------------------------------------
1247itcl::body Rappture::HeightmapViewer::CurrentSurfaces {{what -all}} {
1248    set list {}
1249    if { $what == "-all" } {
1250        foreach key [array names _serverObjs] {
1251            foreach {dataobj comp} [split $key -] break
1252            if { [info exists _obj2ovride($dataobj-raise)] } {
1253                lappend list $dataobj-$comp
1254            }
1255        }
1256    } else {
1257        foreach key [array names _serverObjs] {
1258            foreach {dataobj comp} [split $key -] break
1259            if { [info exists _obj2ovride($dataobj$what)] &&
1260                 $_obj2ovride($dataobj$what) } {
1261                lappend list $dataobj-$comp
1262            }
1263        }
1264    }
1265    return $list
1266}
1267
1268itcl::body Rappture::HeightmapViewer::snap { w h } {
1269    if { $w <= 0 || $h <= 0 } {
1270        set w [image width $_image(plot)]
1271        set h [image height $_image(plot)]
1272    }
1273    set img [image create picture -width $w -height $h]
1274    $img resample $_image(plot)
1275    return $img
1276}
Note: See TracBrowser for help on using the repository browser.