source: trunk/gui/scripts/vtksurfaceviewer.tcl @ 5092

Last change on this file since 5092 was 5092, checked in by ldelgass, 6 years ago

Add update in Rebuild to allow initial canvas size to be set. We don't want to
do this in the constructor since that can cause an error when the add method is
called before the constructor returns.

File size: 77.9 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: vtksurfaceviewer - Vtk 3D boundary surface viewer
4#
5#  It connects to the Vtk server running on a rendering farm,
6#  transmits data, and displays the results.
7# ======================================================================
8#  AUTHOR:  Michael McLennan, Purdue University
9#  Copyright (c) 2004-2014  HUBzero Foundation, LLC
10#
11#  See the file "license.terms" for information on usage and
12#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13# ======================================================================
14package require Itk
15package require BLT
16#package require Img
17
18option add *VtkSurfaceViewer.width 4i widgetDefault
19option add *VtkSurfaceViewer*cursor crosshair widgetDefault
20option add *VtkSurfaceViewer.height 4i widgetDefault
21option add *VtkSurfaceViewer.foreground black widgetDefault
22option add *VtkSurfaceViewer.controlBackground gray widgetDefault
23option add *VtkSurfaceViewer.controlDarkBackground #999999 widgetDefault
24option add *VtkSurfaceViewer.plotBackground black widgetDefault
25option add *VtkSurfaceViewer.plotForeground white widgetDefault
26option add *VtkSurfaceViewer.font \
27    -*-helvetica-medium-r-normal-*-12-* widgetDefault
28
29# must use this name -- plugs into Rappture::resources::load
30proc VtkSurfaceViewer_init_resources {} {
31    Rappture::resources::register \
32        vtkvis_server Rappture::VtkSurfaceViewer::SetServerList
33}
34
35itcl::class Rappture::VtkSurfaceViewer {
36    inherit Rappture::VisViewer
37
38    itk_option define -plotforeground plotForeground Foreground ""
39    itk_option define -plotbackground plotBackground Background ""
40
41    constructor { hostlist args } {
42        Rappture::VisViewer::constructor $hostlist
43    } {
44        # defined below
45    }
46    destructor {
47        # defined below
48    }
49    public proc SetServerList { namelist } {
50        Rappture::VisViewer::SetServerList "vtkvis" $namelist
51    }
52    public method add {dataobj {settings ""}}
53    public method camera {option args}
54    public method delete {args}
55    public method disconnect {}
56    public method download {option args}
57    public method get {args}
58    public method isconnected {}
59    public method parameters {title args} {
60        # do nothing
61    }
62    public method scale {args}
63
64    # The following methods are only used by this class.
65    private method AdjustSetting {what {value ""}}
66    private method BuildAxisTab {}
67    private method BuildCameraTab {}
68    private method BuildColormap { name }
69    private method BuildDownloadPopup { widget command }
70    private method BuildSurfaceTab {}
71    private method Combo { option }
72    private method Connect {}
73    private method CurrentDatasets {args}
74    private method Disconnect {}
75    private method DoResize {}
76    private method DoRotate {}
77    private method DrawLegend {}
78    private method EnterLegend { x y }
79    private method EventuallyRequestLegend {}
80    private method EventuallyResize { w h }
81    private method EventuallyRotate { q }
82    private method GetImage { args }
83    private method GetVtkData { args }
84    private method InitSettings { args  }
85    private method IsValidObject { dataobj }
86    private method LeaveLegend {}
87    private method MotionLegend { x y }
88    private method Pan {option x y}
89    private method PanCamera {}
90    private method Pick {x y}
91    private method QuaternionToView { q } {
92        foreach { _view(-qw) _view(-qx) _view(-qy) _view(-qz) } $q break
93    }
94    private method Rebuild {}
95    private method ReceiveDataset { args }
96    private method ReceiveImage { args }
97    private method ReceiveLegend { colormap title vmin vmax size }
98    private method RequestLegend {}
99    private method Rotate {option x y}
100    private method SetCurrentColormap { color }
101    private method SetLegendTip { x y }
102    private method SetObjectStyle { dataobj comp }
103    private method SetOrientation { side }
104    private method UpdateContourList {}
105    private method ViewToQuaternion {} {
106        return [list $_view(-qw) $_view(-qx) $_view(-qy) $_view(-qz)]
107    }
108    private method Zoom {option}
109
110    private variable _arcball ""
111
112    private variable _dlist ""     ;    # list of data objects
113    private variable _obj2datasets
114    private variable _obj2ovride   ;    # maps dataobj => style override
115    private variable _datasets     ;    # contains all the dataobj-component
116                                   ;    # datasets in the server
117    private variable _colormaps    ;    # contains all the colormaps
118                                   ;    # in the server.
119    # The name of the current colormap used.  The colormap is global to all
120    # heightmaps displayed.
121    private variable _currentColormap ""
122    private variable _currentNumContours -1
123
124    private variable _dataset2style    ;# maps dataobj-component to transfunc
125
126    private variable _click        ;    # info used for rotate operations
127    private variable _limits       ;    # autoscale min/max for all axes
128    private variable _view         ;    # view params for 3D view
129    private variable _settings
130    private variable _style;            # Array of current component styles.
131    private variable _changed
132    private variable _initialStyle;     # Array of initial component styles.
133    private variable _reset 1;          # indicates if camera needs to be reset
134                                        # to starting position.
135
136    private variable _first ""     ;    # This is the topmost dataset.
137    private variable _start 0
138    private variable _title ""
139    private variable _isolines
140    private variable _contourList ""
141
142    common _downloadPopup;              # download options from popup
143    private common _hardcopy
144    private variable _width 0
145    private variable _height 0
146    private variable _resizePending 0
147    private variable _rotatePending 0
148    private variable _legendPending 0
149    private variable _field      ""
150    private variable _colorMode "scalar";        #  Mode of colormap (vmag or scalar)
151    private variable _fieldNames {}
152    private variable _fields
153    private variable _curFldName ""
154    private variable _curFldLabel ""
155}
156
157itk::usual VtkSurfaceViewer {
158    keep -background -foreground -cursor -font
159    keep -plotbackground -plotforeground
160}
161
162# ----------------------------------------------------------------------
163# CONSTRUCTOR
164# ----------------------------------------------------------------------
165itcl::body Rappture::VtkSurfaceViewer::constructor {hostlist args} {
166    package require vtk
167    set _serverType "vtkvis"
168
169    # Rebuild event
170    $_dispatcher register !rebuild
171    $_dispatcher dispatch $this !rebuild "[itcl::code $this Rebuild]; list"
172
173    # Resize event
174    $_dispatcher register !resize
175    $_dispatcher dispatch $this !resize "[itcl::code $this DoResize]; list"
176
177    # Rotate event
178    $_dispatcher register !rotate
179    $_dispatcher dispatch $this !rotate "[itcl::code $this DoRotate]; list"
180
181    # Legend event
182    $_dispatcher register !legend
183    $_dispatcher dispatch $this !legend "[itcl::code $this RequestLegend]; list"
184
185    #
186    # Populate parser with commands handle incoming requests
187    #
188    $_parser alias image [itcl::code $this ReceiveImage]
189    $_parser alias dataset [itcl::code $this ReceiveDataset]
190    $_parser alias legend [itcl::code $this ReceiveLegend]
191
192    # Initialize the view to some default parameters.
193    array set _view {
194        -ortho           0
195        -qw              0.853553
196        -qx              -0.353553
197        -qy              0.353553
198        -qz              0.146447
199        -xpan            0
200        -ypan            0
201        -zoom            1.0
202    }
203    set _arcball [blt::arcball create 100 100]
204    $_arcball quaternion [ViewToQuaternion]
205
206    array set _settings {
207        -axesvisible                1
208        -axislabels                 1
209        -axisminorticks             1
210        -axismode                   "static"
211        -background                 black
212        -colormap                   BCGYR
213        -colormapvisible            1
214        -field                      "Default"
215        -isolinecolor               white
216        -isolinesvisible            0
217        -legendvisible              1
218        -numcontours                10
219        -surfaceedges               0
220        -surfacelighting            1
221        -surfaceopacity             100
222        -outline                    0
223        -surfacevisible             1
224        -surfacewireframe           0
225        -xgrid                      0
226        -ygrid                      0
227        -zgrid                      0
228    }
229    array set _changed {
230        -colormap                0
231        -numcontours             0
232        -surfaceopacity          0
233    }
234
235    itk_component add view {
236        canvas $itk_component(plotarea).view \
237            -highlightthickness 0 -borderwidth 0
238    } {
239        usual
240        ignore -highlightthickness -borderwidth  -background
241    }
242
243    itk_component add fieldmenu {
244        menu $itk_component(plotarea).menu -bg black -fg white -relief flat \
245            -tearoff 0
246    } {
247        usual
248        ignore -background -foreground -relief -tearoff
249    }
250    set c $itk_component(view)
251    bind $c <Configure> [itcl::code $this EventuallyResize %w %h]
252    bind $c <4> [itcl::code $this Zoom in 0.25]
253    bind $c <5> [itcl::code $this Zoom out 0.25]
254    bind $c <KeyPress-Left>  [list %W xview scroll 10 units]
255    bind $c <KeyPress-Right> [list %W xview scroll -10 units]
256    bind $c <KeyPress-Up>    [list %W yview scroll 10 units]
257    bind $c <KeyPress-Down>  [list %W yview scroll -10 units]
258    bind $c <Enter> "focus %W"
259    bind $c <Control-F1> [itcl::code $this ToggleConsole]
260
261    # Fix the scrollregion in case we go off screen
262    $c configure -scrollregion [$c bbox all]
263
264    set _map(id) [$c create image 0 0 -anchor nw -image $_image(plot)]
265    set _map(cwidth) -1
266    set _map(cheight) -1
267    set _map(zoom) 1.0
268    set _map(original) ""
269
270    set f [$itk_component(main) component controls]
271    itk_component add reset {
272        button $f.reset -borderwidth 1 -padx 1 -pady 1 \
273            -highlightthickness 0 \
274            -image [Rappture::icon reset-view] \
275            -command [itcl::code $this Zoom reset]
276    } {
277        usual
278        ignore -highlightthickness
279    }
280    pack $itk_component(reset) -side top -padx 2 -pady 2
281    Rappture::Tooltip::for $itk_component(reset) \
282        "Reset the view to the default zoom level"
283
284    itk_component add zoomin {
285        button $f.zin -borderwidth 1 -padx 1 -pady 1 \
286            -highlightthickness 0 \
287            -image [Rappture::icon zoom-in] \
288            -command [itcl::code $this Zoom in]
289    } {
290        usual
291        ignore -highlightthickness
292    }
293    pack $itk_component(zoomin) -side top -padx 2 -pady 2
294    Rappture::Tooltip::for $itk_component(zoomin) "Zoom in"
295
296    itk_component add zoomout {
297        button $f.zout -borderwidth 1 -padx 1 -pady 1 \
298            -highlightthickness 0 \
299            -image [Rappture::icon zoom-out] \
300            -command [itcl::code $this Zoom out]
301    } {
302        usual
303        ignore -highlightthickness
304    }
305    pack $itk_component(zoomout) -side top -padx 2 -pady 2
306    Rappture::Tooltip::for $itk_component(zoomout) "Zoom out"
307
308    itk_component add surface {
309        Rappture::PushButton $f.surface \
310            -onimage [Rappture::icon volume-on] \
311            -offimage [Rappture::icon volume-off] \
312            -variable [itcl::scope _settings(-surfacevisible)] \
313            -command [itcl::code $this AdjustSetting -surfacevisible]
314    }
315    $itk_component(surface) select
316    Rappture::Tooltip::for $itk_component(surface) \
317        "Hide the surface"
318    pack $itk_component(surface) -padx 2 -pady 2
319
320    if { [catch {
321        BuildSurfaceTab
322        BuildAxisTab
323        BuildCameraTab
324    } errs] != 0 } {
325        puts stderr errs=$errs
326    }
327
328    # Legend
329    set _image(legend) [image create photo]
330    itk_component add legend {
331        canvas $itk_component(plotarea).legend -width 50 -highlightthickness 0
332    } {
333        usual
334        ignore -highlightthickness
335        rename -background -plotbackground plotBackground Background
336    }
337
338    # Hack around the Tk panewindow.  The problem is that the requested
339    # size of the 3d view isn't set until an image is retrieved from
340    # the server.  So the panewindow uses the tiny size.
341    set w 10000
342    pack forget $itk_component(view)
343    blt::table $itk_component(plotarea) \
344        0,0 $itk_component(view) -fill both -reqwidth $w
345    blt::table configure $itk_component(plotarea) c1 -resize none
346
347    # Bindings for rotation via mouse
348    bind $itk_component(view) <ButtonPress-1> \
349        [itcl::code $this Rotate click %x %y]
350    bind $itk_component(view) <B1-Motion> \
351        [itcl::code $this Rotate drag %x %y]
352    bind $itk_component(view) <ButtonRelease-1> \
353        [itcl::code $this Rotate release %x %y]
354
355    # Bindings for panning via mouse
356    bind $itk_component(view) <ButtonPress-2> \
357        [itcl::code $this Pan click %x %y]
358    bind $itk_component(view) <B2-Motion> \
359        [itcl::code $this Pan drag %x %y]
360    bind $itk_component(view) <ButtonRelease-2> \
361        [itcl::code $this Pan release %x %y]
362
363    #bind $itk_component(view) <ButtonRelease-3> \
364    #    [itcl::code $this Pick %x %y]
365
366    # Bindings for panning via keyboard
367    bind $itk_component(view) <KeyPress-Left> \
368        [itcl::code $this Pan set -10 0]
369    bind $itk_component(view) <KeyPress-Right> \
370        [itcl::code $this Pan set 10 0]
371    bind $itk_component(view) <KeyPress-Up> \
372        [itcl::code $this Pan set 0 -10]
373    bind $itk_component(view) <KeyPress-Down> \
374        [itcl::code $this Pan set 0 10]
375    bind $itk_component(view) <Shift-KeyPress-Left> \
376        [itcl::code $this Pan set -2 0]
377    bind $itk_component(view) <Shift-KeyPress-Right> \
378        [itcl::code $this Pan set 2 0]
379    bind $itk_component(view) <Shift-KeyPress-Up> \
380        [itcl::code $this Pan set 0 -2]
381    bind $itk_component(view) <Shift-KeyPress-Down> \
382        [itcl::code $this Pan set 0 2]
383
384    # Bindings for zoom via keyboard
385    bind $itk_component(view) <KeyPress-Prior> \
386        [itcl::code $this Zoom out]
387    bind $itk_component(view) <KeyPress-Next> \
388        [itcl::code $this Zoom in]
389
390    bind $itk_component(view) <Enter> "focus $itk_component(view)"
391
392    if {[string equal "x11" [tk windowingsystem]]} {
393        # Bindings for zoom via mouse
394        bind $itk_component(view) <4> [itcl::code $this Zoom out]
395        bind $itk_component(view) <5> [itcl::code $this Zoom in]
396    }
397
398    set _image(download) [image create photo]
399
400    eval itk_initialize $args
401
402    EnableWaitDialog 500
403    Connect
404}
405
406# ----------------------------------------------------------------------
407# DESTRUCTOR
408# ----------------------------------------------------------------------
409itcl::body Rappture::VtkSurfaceViewer::destructor {} {
410    Disconnect
411    image delete $_image(plot)
412    image delete $_image(download)
413    catch { blt::arcball destroy $_arcball }
414}
415
416itcl::body Rappture::VtkSurfaceViewer::DoResize {} {
417    if { $_width < 2 } {
418        set _width 500
419    }
420    if { $_height < 2 } {
421        set _height 500
422    }
423    set _start [clock clicks -milliseconds]
424    SendCmd "screen size $_width $_height"
425
426    EventuallyRequestLegend
427    set _resizePending 0
428}
429
430itcl::body Rappture::VtkSurfaceViewer::DoRotate {} {
431    SendCmd "camera orient [ViewToQuaternion]"
432    set _rotatePending 0
433}
434
435itcl::body Rappture::VtkSurfaceViewer::EventuallyRequestLegend {} {
436    if { !$_legendPending } {
437        set _legendPending 1
438        $_dispatcher event -idle !legend
439    }
440}
441
442itcl::body Rappture::VtkSurfaceViewer::EventuallyResize { w h } {
443    set _width $w
444    set _height $h
445    $_arcball resize $w $h
446    if { !$_resizePending } {
447        set _resizePending 1
448        $_dispatcher event -after 400 !resize
449    }
450}
451
452set rotate_delay 100
453
454itcl::body Rappture::VtkSurfaceViewer::EventuallyRotate { q } {
455    QuaternionToView $q
456    if { !$_rotatePending } {
457        set _rotatePending 1
458        global rotate_delay
459        $_dispatcher event -after $rotate_delay !rotate
460    }
461}
462
463# ----------------------------------------------------------------------
464# USAGE: add <dataobj> ?<settings>?
465#
466# Clients use this to add a data object to the plot.  The optional
467# <settings> are used to configure the plot.  Allowed settings are
468# -color, -brightness, -width, -linestyle, and -raise.
469# ----------------------------------------------------------------------
470itcl::body Rappture::VtkSurfaceViewer::add {dataobj {settings ""}} {
471    if { ![$dataobj isvalid] } {
472        return;                         # Object doesn't contain valid data.
473    }
474    array set params {
475        -color auto
476        -width 1
477        -linestyle solid
478        -brightness 0
479        -raise 0
480        -description ""
481        -param ""
482        -type ""
483    }
484    array set params $settings
485    set params(-description) ""
486    set params(-param) ""
487    array set params $settings
488
489    if {$params(-color) == "auto" || $params(-color) == "autoreset"} {
490        # can't handle -autocolors yet
491        set params(-color) black
492    }
493    set pos [lsearch -exact $_dlist $dataobj]
494    if {$pos < 0} {
495        lappend _dlist $dataobj
496    }
497    set _obj2ovride($dataobj-color) $params(-color)
498    set _obj2ovride($dataobj-width) $params(-width)
499    set _obj2ovride($dataobj-raise) $params(-raise)
500    $_dispatcher event -idle !rebuild
501}
502
503# ----------------------------------------------------------------------
504# USAGE: delete ?<dataobj1> <dataobj2> ...?
505#
506#       Clients use this to delete a dataobj from the plot.  If no dataobjs
507#       are specified, then all dataobjs are deleted.  No data objects are
508#       deleted.  They are only removed from the display list.
509#
510# ----------------------------------------------------------------------
511itcl::body Rappture::VtkSurfaceViewer::delete {args} {
512    if { [llength $args] == 0} {
513        set args $_dlist
514    }
515    # Delete all specified dataobjs
516    set changed 0
517    foreach dataobj $args {
518        set pos [lsearch -exact $_dlist $dataobj]
519        if { $pos < 0 } {
520            continue;                   # Don't know anything about it.
521        }
522        # Remove it from the dataobj list.
523        set _dlist [lreplace $_dlist $pos $pos]
524        array unset _obj2ovride $dataobj-*
525        array unset _settings $dataobj-*
526        set changed 1
527    }
528    # If anything changed, then rebuild the plot
529    if { $changed } {
530        $_dispatcher event -idle !rebuild
531    }
532}
533
534# ----------------------------------------------------------------------
535# USAGE: get ?-objects?
536# USAGE: get ?-visible?
537# USAGE: get ?-image view?
538#
539# Clients use this to query the list of objects being plotted, in
540# order from bottom to top of this result.  The optional "-image"
541# flag can also request the internal images being shown.
542# ----------------------------------------------------------------------
543itcl::body Rappture::VtkSurfaceViewer::get {args} {
544    if {[llength $args] == 0} {
545        set args "-objects"
546    }
547
548    set op [lindex $args 0]
549    switch -- $op {
550        "-objects" {
551            # put the dataobj list in order according to -raise options
552            set dlist {}
553            foreach dataobj $_dlist {
554                if { ![IsValidObject $dataobj] } {
555                    continue
556                }
557                if {[info exists _obj2ovride($dataobj-raise)] &&
558                    $_obj2ovride($dataobj-raise)} {
559                    set dlist [linsert $dlist 0 $dataobj]
560                } else {
561                    lappend dlist $dataobj
562                }
563            }
564            return $dlist
565        }
566        "-visible" {
567            set dlist {}
568            foreach dataobj $_dlist {
569                if { ![IsValidObject $dataobj] } {
570                    continue
571                }
572                if { ![info exists _obj2ovride($dataobj-raise)] } {
573                    # No setting indicates that the object isn't visible.
574                    continue
575                }
576                # Otherwise use the -raise parameter to put the object to
577                # the front of the list.
578                if { $_obj2ovride($dataobj-raise) } {
579                    set dlist [linsert $dlist 0 $dataobj]
580                } else {
581                    lappend dlist $dataobj
582                }
583            }
584            return $dlist
585        }
586        -image {
587            if {[llength $args] != 2} {
588                error "wrong # args: should be \"get -image view\""
589            }
590            switch -- [lindex $args end] {
591                view {
592                    return $_image(plot)
593                }
594                default {
595                    error "bad image name \"[lindex $args end]\": should be view"
596                }
597            }
598        }
599        default {
600            error "bad option \"$op\": should be -objects or -image"
601        }
602    }
603}
604
605# ----------------------------------------------------------------------
606# USAGE: scale ?<data1> <data2> ...?
607#
608# Sets the default limits for the overall plot according to the
609# limits of the data for all of the given <data> objects.  This
610# accounts for all objects--even those not showing on the screen.
611# Because of this, the limits are appropriate for all objects as
612# the user scans through data in the ResultSet viewer.
613# ----------------------------------------------------------------------
614itcl::body Rappture::VtkSurfaceViewer::scale { args } {
615    foreach dataobj $args {
616        if { ![$dataobj isvalid] } {
617            continue;                   # Object doesn't contain valid data.
618        }
619        foreach axis { x y z } {
620            set lim [$dataobj limits $axis]
621            if { ![info exists _limits($axis)] } {
622                set _limits($axis) $lim
623                continue
624            }
625            foreach {min max} $lim break
626            foreach {amin amax} $_limits($axis) break
627            if { $amin > $min } {
628                set amin $min
629            }
630            if { $amax < $max } {
631                set amax $max
632            }
633            set _limits($axis) [list $amin $amax]
634        }
635        foreach { fname lim } [$dataobj fieldlimits] {
636            if { ![info exists _limits($fname)] } {
637                set _limits($fname) $lim
638                continue
639            }
640            foreach {min max} $lim break
641            foreach {fmin fmax} $_limits($fname) break
642            if { $fmin > $min } {
643                set fmin $min
644            }
645            if { $fmax < $max } {
646                set fmax $max
647            }
648            set _limits($fname) [list $fmin $fmax]
649        }
650    }
651}
652
653# ----------------------------------------------------------------------
654# USAGE: download coming
655# USAGE: download controls <downloadCommand>
656# USAGE: download now
657#
658# Clients use this method to create a downloadable representation
659# of the plot.  Returns a list of the form {ext string}, where
660# "ext" is the file extension (indicating the type of data) and
661# "string" is the data itself.
662# ----------------------------------------------------------------------
663itcl::body Rappture::VtkSurfaceViewer::download {option args} {
664    switch $option {
665        coming {
666            if {[catch {
667                blt::winop snap $itk_component(plotarea) $_image(download)
668            }]} {
669                $_image(download) configure -width 1 -height 1
670                $_image(download) put #000000
671            }
672        }
673        controls {
674            set popup .vtkviewerdownload
675            if { ![winfo exists .vtkviewerdownload] } {
676                set inner [BuildDownloadPopup $popup [lindex $args 0]]
677            } else {
678                set inner [$popup component inner]
679            }
680            set _downloadPopup(image_controls) $inner.image_frame
681            set num [llength [get]]
682            set num [expr {($num == 1) ? "1 result" : "$num results"}]
683            set word [Rappture::filexfer::label downloadWord]
684            $inner.summary configure -text "$word $num in the following format:"
685            update idletasks            ;# Fix initial sizes
686            return $popup
687        }
688        now {
689            set popup .vtkviewerdownload
690            if {[winfo exists .vtkviewerdownload]} {
691                $popup deactivate
692            }
693            switch -- $_downloadPopup(format) {
694                "image" {
695                    return [$this GetImage [lindex $args 0]]
696                }
697                "vtk" {
698                    return [$this GetVtkData [lindex $args 0]]
699                }
700            }
701            return ""
702        }
703        default {
704            error "bad option \"$option\": should be coming, controls, now"
705        }
706    }
707}
708
709# ----------------------------------------------------------------------
710# USAGE: Connect ?<host:port>,<host:port>...?
711#
712# Clients use this method to establish a connection to a new
713# server, or to reestablish a connection to the previous server.
714# Any existing connection is automatically closed.
715# ----------------------------------------------------------------------
716itcl::body Rappture::VtkSurfaceViewer::Connect {} {
717    set _hosts [GetServerList "vtkvis"]
718    if { "" == $_hosts } {
719        return 0
720    }
721    set result [VisViewer::Connect $_hosts]
722    if { $result } {
723        if { $_reportClientInfo }  {
724            # Tell the server the viewer, hub, user and session.
725            # Do this immediately on connect before buffering any commands
726            global env
727
728            set info {}
729            set user "???"
730            if { [info exists env(USER)] } {
731                set user $env(USER)
732            }
733            set session "???"
734            if { [info exists env(SESSION)] } {
735                set session $env(SESSION)
736            }
737            lappend info "version" "$Rappture::version"
738            lappend info "build" "$Rappture::build"
739            lappend info "svnurl" "$Rappture::svnurl"
740            lappend info "installdir" "$Rappture::installdir"
741            lappend info "hub" [exec hostname]
742            lappend info "client" "vtksurfaceviewer"
743            lappend info "user" $user
744            lappend info "session" $session
745            SendCmd "clientinfo [list $info]"
746        }
747
748        set w [winfo width $itk_component(view)]
749        set h [winfo height $itk_component(view)]
750        EventuallyResize $w $h
751    }
752    return $result
753}
754
755#
756# isconnected --
757#
758#       Indicates if we are currently connected to the visualization server.
759#
760itcl::body Rappture::VtkSurfaceViewer::isconnected {} {
761    return [VisViewer::IsConnected]
762}
763
764#
765# disconnect --
766#
767itcl::body Rappture::VtkSurfaceViewer::disconnect {} {
768    Disconnect
769    set _reset 1
770}
771
772#
773# Disconnect --
774#
775#       Clients use this method to disconnect from the current rendering
776#       server.
777#
778itcl::body Rappture::VtkSurfaceViewer::Disconnect {} {
779    VisViewer::Disconnect
780
781    $_dispatcher cancel !rebuild
782    $_dispatcher cancel !resize
783    $_dispatcher cancel !rotate
784    $_dispatcher cancel !legend
785    # disconnected -- no more data sitting on server
786    set _outbuf ""
787    array unset _datasets
788    array unset _data
789    array unset _colormaps
790    array unset _dataset2style
791    array unset _obj2datasets
792}
793
794# ----------------------------------------------------------------------
795# USAGE: ReceiveImage -bytes <size> -type <type> -token <token>
796#
797# Invoked automatically whenever the "image" command comes in from
798# the rendering server.  Indicates that binary image data with the
799# specified <size> will follow.
800# ----------------------------------------------------------------------
801itcl::body Rappture::VtkSurfaceViewer::ReceiveImage { args } {
802    array set info {
803        -token "???"
804        -bytes 0
805        -type image
806    }
807    array set info $args
808    set bytes [ReceiveBytes $info(-bytes)]
809    if { $info(-type) == "image" } {
810        if 0 {
811            set f [open "last.ppm" "w"]
812            fconfigure $f -encoding binary
813            puts -nonewline $f $bytes
814            close $f
815        }
816        $_image(plot) configure -data $bytes
817        #set time [clock seconds]
818        #set date [clock format $time]
819        #set w [image width $_image(plot)]
820        #set h [image height $_image(plot)]
821        #puts stderr "$date: received image ${w}x${h} image"
822        if { $_start > 0 } {
823            set finish [clock clicks -milliseconds]
824            #puts stderr "round trip time [expr $finish -$_start] milliseconds"
825            set _start 0
826        }
827    } elseif { $info(type) == "print" } {
828        set tag $this-print-$info(-token)
829        set _hardcopy($tag) $bytes
830    }
831}
832
833#
834# ReceiveDataset --
835#
836itcl::body Rappture::VtkSurfaceViewer::ReceiveDataset { args } {
837    if { ![isconnected] } {
838        return
839    }
840    set option [lindex $args 0]
841    switch -- $option {
842        "scalar" {
843            set option [lindex $args 1]
844            switch -- $option {
845                "world" {
846                    foreach { x y z value tag } [lrange $args 2 end] break
847                }
848                "pixel" {
849                    foreach { x y value tag } [lrange $args 2 end] break
850                }
851            }
852        }
853        "vector" {
854            set option [lindex $args 1]
855            switch -- $option {
856                "world" {
857                    foreach { x y z vx vy vz tag } [lrange $args 2 end] break
858                }
859                "pixel" {
860                    foreach { x y vx vy vz tag } [lrange $args 2 end] break
861                }
862            }
863        }
864        "names" {
865            foreach { name } [lindex $args 1] {
866                #puts stderr "Dataset: $name"
867            }
868        }
869        default {
870            error "unknown dataset option \"$option\" from server"
871        }
872    }
873}
874
875# ----------------------------------------------------------------------
876# USAGE: Rebuild
877#
878# Called automatically whenever something changes that affects the
879# data in the widget.  Clears any existing data and rebuilds the
880# widget to display new data.
881# ----------------------------------------------------------------------
882itcl::body Rappture::VtkSurfaceViewer::Rebuild {} {
883    set w [winfo width $itk_component(view)]
884    set h [winfo height $itk_component(view)]
885    if { $w < 2 || $h < 2 } {
886        update
887        $_dispatcher event -idle !rebuild
888        return
889    }
890
891    # Turn on buffering of commands to the server.  We don't want to
892    # be preempted by a server disconnect/reconnect (which automatically
893    # generates a new call to Rebuild).
894    StartBufferingCommands
895
896    if { $_reset } {
897        set _width $w
898        set _height $h
899        $_arcball resize $w $h
900        DoResize
901        # Reset the camera and other view parameters
902        $_arcball quaternion [ViewToQuaternion]
903        if {$_view(-ortho)} {
904            SendCmd "camera mode ortho"
905        } else {
906            SendCmd "camera mode persp"
907        }
908        DoRotate
909        PanCamera
910        set _first ""
911        InitSettings -xgrid -ygrid -zgrid -axismode \
912            -axesvisible -axislabels -axisminorticks
913        #SendCmd "axis lformat all %g"
914        StopBufferingCommands
915        SendCmd "imgflush"
916        StartBufferingCommands
917    }
918    set _first ""
919    SendCmd "dataset visible 0"
920    foreach dataobj [get -objects] {
921        if { [info exists _obj2ovride($dataobj-raise)] &&  $_first == "" } {
922            set _first $dataobj
923        }
924        set _obj2datasets($dataobj) ""
925        foreach comp [$dataobj components] {
926            set tag $dataobj-$comp
927            if { ![info exists _datasets($tag)] } {
928                set bytes [$dataobj vtkdata $comp]
929                if 0 {
930                    set f [open "/tmp/surface.vtk" "w"]
931                    fconfigure $f -translation binary -encoding binary
932                    puts -nonewline $f $bytes
933                    close $f
934                }
935                set length [string length $bytes]
936                if { $_reportClientInfo }  {
937                    set info {}
938                    lappend info "tool_id"       [$dataobj hints toolid]
939                    lappend info "tool_name"     [$dataobj hints toolname]
940                    lappend info "tool_title"    [$dataobj hints tooltitle]
941                    lappend info "tool_command"  [$dataobj hints toolcommand]
942                    lappend info "tool_revision" [$dataobj hints toolrevision]
943                    lappend info "dataset_label" [$dataobj hints label]
944                    lappend info "dataset_size"  $length
945                    lappend info "dataset_tag"   $tag
946                    SendCmd "clientinfo [list $info]"
947                }
948                SendCmd "dataset add $tag data follows $length"
949                append _outbuf $bytes
950                set _datasets($tag) 1
951                SetObjectStyle $dataobj $comp
952            }
953            lappend _obj2datasets($dataobj) $tag
954            if { [info exists _obj2ovride($dataobj-raise)] } {
955                # Setting dataset visible enables outline
956                # and contour2d
957                SendCmd "dataset visible 1 $tag"
958            }
959        }
960    }
961
962    if { $_first != "" } {
963        $itk_component(field) choices delete 0 end
964        $itk_component(fieldmenu) delete 0 end
965        array unset _fields
966        set _curFldName ""
967        foreach cname [$_first components] {
968            foreach fname [$_first fieldnames $cname] {
969                if { [info exists _fields($fname)] } {
970                    continue
971                }
972                foreach { label units components } \
973                    [$_first fieldinfo $fname] break
974                $itk_component(field) choices insert end "$fname" "$label"
975                $itk_component(fieldmenu) add radiobutton -label "$label" \
976                    -value $label -variable [itcl::scope _curFldLabel] \
977                    -selectcolor red \
978                    -activebackground $itk_option(-plotbackground) \
979                    -activeforeground $itk_option(-plotforeground) \
980                    -font "Arial 8" \
981                    -command [itcl::code $this Combo invoke]
982                set _fields($fname) [list $label $units $components]
983                if { $_curFldName == "" } {
984                    set _curFldName $fname
985                    set _curFldLabel $label
986                }
987            }
988        }
989        $itk_component(field) value $_curFldLabel
990    }
991    InitSettings -isolinesvisible -surfacevisible -outline
992    if { $_reset } {
993        # These are settings that rely on a dataset being loaded.
994        InitSettings \
995            -surfacelighting \
996            -field \
997            -surfaceedges -surfacelighting -surfaceopacity \
998            -surfacewireframe \
999            -numcontours
1000
1001        Zoom reset
1002        foreach axis { x y z } {
1003            # Another problem fixed by a <view>. We looking into a data
1004            # object for the name of the axes. This should be global to
1005            # the viewer itself.
1006            set label [$_first hints ${axis}label]
1007            if { $label == "" } {
1008                set label [string toupper $axis]
1009            }
1010            # May be a space in the axis label.
1011            SendCmd [list axis name $axis $label]
1012        }
1013        if { [array size _fields] < 2 } {
1014            catch {blt::table forget $itk_component(field) $itk_component(field_l)}
1015        }
1016        set _reset 0
1017    }
1018
1019    # Actually write the commands to the server socket.  If it fails, we don't
1020    # care.  We're finished here.
1021    blt::busy hold $itk_component(hull)
1022    StopBufferingCommands;              # Turn off buffering and send commands.
1023    blt::busy release $itk_component(hull)
1024}
1025
1026# ----------------------------------------------------------------------
1027# USAGE: CurrentDatasets ?-all -visible? ?dataobjs?
1028#
1029# Returns a list of server IDs for the current datasets being displayed.  This
1030# is normally a single ID, but it might be a list of IDs if the current data
1031# object has multiple components.
1032# ----------------------------------------------------------------------
1033itcl::body Rappture::VtkSurfaceViewer::CurrentDatasets {args} {
1034    set flag [lindex $args 0]
1035    switch -- $flag {
1036        "-all" {
1037            if { [llength $args] > 1 } {
1038                error "CurrentDatasets: can't specify dataobj after \"-all\""
1039            }
1040            set dlist [get -objects]
1041        }
1042        "-visible" {
1043            if { [llength $args] > 1 } {
1044                set dlist {}
1045                set args [lrange $args 1 end]
1046                foreach dataobj $args {
1047                    if { [info exists _obj2ovride($dataobj-raise)] } {
1048                        lappend dlist $dataobj
1049                    }
1050                }
1051            } else {
1052                set dlist [get -visible]
1053            }
1054        }
1055        default {
1056            set dlist $args
1057        }
1058    }
1059    set rlist ""
1060    foreach dataobj $dlist {
1061        foreach comp [$dataobj components] {
1062            set tag $dataobj-$comp
1063            if { [info exists _datasets($tag)] && $_datasets($tag) } {
1064                lappend rlist $tag
1065            }
1066        }
1067    }
1068    return $rlist
1069}
1070
1071# ----------------------------------------------------------------------
1072# USAGE: Zoom in
1073# USAGE: Zoom out
1074# USAGE: Zoom reset
1075#
1076# Called automatically when the user clicks on one of the zoom
1077# controls for this widget.  Changes the zoom for the current view.
1078# ----------------------------------------------------------------------
1079itcl::body Rappture::VtkSurfaceViewer::Zoom {option} {
1080    switch -- $option {
1081        "in" {
1082            set _view(-zoom) [expr {$_view(-zoom)*1.25}]
1083            SendCmd "camera zoom $_view(-zoom)"
1084        }
1085        "out" {
1086            set _view(-zoom) [expr {$_view(-zoom)*0.8}]
1087            SendCmd "camera zoom $_view(-zoom)"
1088        }
1089        "reset" {
1090            array set _view {
1091                -qw      0.853553
1092                -qx      -0.353553
1093                -qy      0.353553
1094                -qz      0.146447
1095                -xpan    0
1096                -ypan    0
1097                -zoom    1.0
1098            }
1099            if { $_first != "" } {
1100                set location [$_first hints camera]
1101                if { $location != "" } {
1102                    array set _view $location
1103                }
1104            }
1105            $_arcball quaternion [ViewToQuaternion]
1106            DoRotate
1107            SendCmd "camera reset"
1108        }
1109    }
1110}
1111
1112itcl::body Rappture::VtkSurfaceViewer::PanCamera {} {
1113    set x $_view(-xpan)
1114    set y $_view(-ypan)
1115    SendCmd "camera pan $x $y"
1116}
1117
1118# ----------------------------------------------------------------------
1119# USAGE: Rotate click <x> <y>
1120# USAGE: Rotate drag <x> <y>
1121# USAGE: Rotate release <x> <y>
1122#
1123# Called automatically when the user clicks/drags/releases in the
1124# plot area.  Moves the plot according to the user's actions.
1125# ----------------------------------------------------------------------
1126itcl::body Rappture::VtkSurfaceViewer::Rotate {option x y} {
1127    switch -- $option {
1128        "click" {
1129            $itk_component(view) configure -cursor fleur
1130            set _click(x) $x
1131            set _click(y) $y
1132        }
1133        "drag" {
1134            if {[array size _click] == 0} {
1135                Rotate click $x $y
1136            } else {
1137                set w [winfo width $itk_component(view)]
1138                set h [winfo height $itk_component(view)]
1139                if {$w <= 0 || $h <= 0} {
1140                    return
1141                }
1142
1143                if {[catch {
1144                    # this fails sometimes for no apparent reason
1145                    set dx [expr {double($x-$_click(x))/$w}]
1146                    set dy [expr {double($y-$_click(y))/$h}]
1147                }]} {
1148                    return
1149                }
1150                if { $dx == 0 && $dy == 0 } {
1151                    return
1152                }
1153                set q [$_arcball rotate $x $y $_click(x) $_click(y)]
1154                EventuallyRotate $q
1155                set _click(x) $x
1156                set _click(y) $y
1157            }
1158        }
1159        "release" {
1160            Rotate drag $x $y
1161            $itk_component(view) configure -cursor ""
1162            catch {unset _click}
1163        }
1164        default {
1165            error "bad option \"$option\": should be click, drag, release"
1166        }
1167    }
1168}
1169
1170itcl::body Rappture::VtkSurfaceViewer::Pick {x y} {
1171    foreach tag [CurrentDatasets -visible] {
1172        SendCmd "dataset getscalar pixel $x $y $tag"
1173    }
1174}
1175
1176# ----------------------------------------------------------------------
1177# USAGE: $this Pan click x y
1178#        $this Pan drag x y
1179#        $this Pan release x y
1180#
1181# Called automatically when the user clicks on one of the zoom
1182# controls for this widget.  Changes the zoom for the current view.
1183# ----------------------------------------------------------------------
1184itcl::body Rappture::VtkSurfaceViewer::Pan {option x y} {
1185    switch -- $option {
1186        "set" {
1187            set w [winfo width $itk_component(view)]
1188            set h [winfo height $itk_component(view)]
1189            set x [expr $x / double($w)]
1190            set y [expr $y / double($h)]
1191            set _view(-xpan) [expr $_view(-xpan) + $x]
1192            set _view(-ypan) [expr $_view(-ypan) + $y]
1193            PanCamera
1194            return
1195        }
1196        "click" {
1197            set _click(x) $x
1198            set _click(y) $y
1199            $itk_component(view) configure -cursor hand1
1200        }
1201        "drag" {
1202            if { ![info exists _click(x)] } {
1203                set _click(x) $x
1204            }
1205            if { ![info exists _click(y)] } {
1206                set _click(y) $y
1207            }
1208            set w [winfo width $itk_component(view)]
1209            set h [winfo height $itk_component(view)]
1210            set dx [expr ($_click(x) - $x)/double($w)]
1211            set dy [expr ($_click(y) - $y)/double($h)]
1212            set _click(x) $x
1213            set _click(y) $y
1214            set _view(-xpan) [expr $_view(-xpan) - $dx]
1215            set _view(-ypan) [expr $_view(-ypan) - $dy]
1216            PanCamera
1217        }
1218        "release" {
1219            Pan drag $x $y
1220            $itk_component(view) configure -cursor ""
1221        }
1222        default {
1223            error "unknown option \"$option\": should set, click, drag, or release"
1224        }
1225    }
1226}
1227
1228# ----------------------------------------------------------------------
1229# USAGE: InitSettings <what> ?<value>?
1230#
1231# Used internally to update rendering settings whenever parameters
1232# change in the popup settings panel.  Sends the new settings off
1233# to the back end.
1234# ----------------------------------------------------------------------
1235itcl::body Rappture::VtkSurfaceViewer::InitSettings { args } {
1236    foreach spec $args {
1237        if { [info exists _settings($_first-$spec)] } {
1238            # Reset global setting with dataobj specific setting
1239            set _settings($spec) $_settings($_first-$spec)
1240        }
1241        AdjustSetting $spec
1242    }
1243}
1244
1245#
1246# AdjustSetting --
1247#
1248#       Changes/updates a specific setting in the widget.  There are
1249#       usually user-setable option.  Commands are sent to the render
1250#       server.
1251#
1252itcl::body Rappture::VtkSurfaceViewer::AdjustSetting {what {value ""}} {
1253    if { ![isconnected] } {
1254        return
1255    }
1256    switch -- $what {
1257        "-axesvisible" {
1258            set bool $_settings($what)
1259            SendCmd "axis visible all $bool"
1260        }
1261        "-axislabels" {
1262            set bool $_settings($what)
1263            SendCmd "axis labels all $bool"
1264        }
1265        "-axisminorticks" {
1266            set bool $_settings($what)
1267            SendCmd "axis minticks all $bool"
1268        }
1269        "-axismode" {
1270            set mode [$itk_component(axisMode) value]
1271            set mode [$itk_component(axisMode) translate $mode]
1272            set _settings($what) $mode
1273            SendCmd "axis flymode $mode"
1274        }
1275        "-background" {
1276            set bgcolor [$itk_component(background) value]
1277            array set fgcolors {
1278                "black" "white"
1279                "white" "black"
1280                "grey"  "black"
1281            }
1282            configure -plotbackground $bgcolor \
1283                -plotforeground $fgcolors($bgcolor)
1284            $itk_component(view) delete "legend"
1285            DrawLegend
1286        }
1287        "-colormap" {
1288            set _changed($what) 1
1289            StartBufferingCommands
1290            set color [$itk_component(colormap) value]
1291            set _settings($what) $color
1292            if { $color == "none" } {
1293                if { $_settings(-colormapvisible) } {
1294                    SendCmd "contour2d colormode constant {}"
1295                    SendCmd "polydata colormode constant {}"
1296                    set _settings(-colormapvisible) 0
1297                }
1298            } else {
1299                if { !$_settings(-colormapvisible) } {
1300                    #SendCmd "contour2d colormode $_colorMode $_curFldName"
1301                    SendCmd "polydata colormode $_colorMode $_curFldName"
1302                    set _settings(-colormapvisible) 1
1303                }
1304                SetCurrentColormap $color
1305                if {$_settings(-colormapdiscrete)} {
1306                    set numColors [expr $_settings(-numcontours) + 1]
1307                    SendCmd "colormap res $numColors $color"
1308                }
1309            }
1310            StopBufferingCommands
1311            EventuallyRequestLegend
1312        }
1313        "-colormapdiscrete" {
1314            set bool $_settings($what)
1315            set numColors [expr $_settings(-numcontours) + 1]
1316            StartBufferingCommands
1317            if {$bool} {
1318                SendCmd "colormap res $numColors"
1319                # Discrete colormap requires preinterp on
1320                SendCmd "polydata preinterp on"
1321            } else {
1322                SendCmd "colormap res default"
1323                # FIXME: add setting for preinterp (default on)
1324                SendCmd "polydata preinterp on"
1325            }
1326            StopBufferingCommands
1327            EventuallyRequestLegend
1328        }
1329        "-field" {
1330            set label [$itk_component(field) value]
1331            set fname [$itk_component(field) translate $label]
1332            set _settings($what) $fname
1333            if { [info exists _fields($fname)] } {
1334                foreach { label units components } $_fields($fname) break
1335                if { $components > 1 } {
1336                    set _colorMode vmag
1337                } else {
1338                    set _colorMode scalar
1339                }
1340                set _curFldName $fname
1341                set _curFldLabel $label
1342            } else {
1343                puts stderr "unknown field \"$fname\""
1344                return
1345            }
1346            SendCmd "dataset scalar $_curFldName"
1347            if { ![info exists _limits($_curFldName)] } {
1348                SendCmd "dataset maprange all"
1349            } else {
1350                SendCmd "dataset maprange explicit $_limits($_curFldName) $_curFldName"
1351            }
1352            #SendCmd "contour2d colormode $_colorMode $_curFldName"
1353            SendCmd "polydata colormode $_colorMode $_curFldName"
1354            SendCmd "camera reset"
1355            UpdateContourList
1356            DrawLegend
1357        }
1358        "-isolinecolor" {
1359            set color [$itk_component(isolineColor) value]
1360            set _settings($what) $color
1361            SendCmd "contour2d linecolor [Color2RGB $color]"
1362            DrawLegend
1363        }
1364        "-isolinesvisible" {
1365            set bool $_settings($what)
1366            SendCmd "contour2d visible $bool"
1367            DrawLegend
1368        }
1369        "-legendvisible" {
1370            if { !$_settings($what) } {
1371                $itk_component(view) delete legend
1372            }
1373            DrawLegend
1374        }
1375        "-numcontours" {
1376            set _settings($what) [$itk_component(numcontours) value]
1377            set _currentNumContours $_settings($what)
1378            UpdateContourList
1379            set _changed($what) 1
1380            SendCmd "contour2d contourlist [list $_contourList]"
1381            if {$_settings(-colormapdiscrete)} {
1382                set numColors [expr $_settings($what) + 1]
1383                SendCmd "colormap res $numColors"
1384                EventuallyRequestLegend
1385            } else {
1386                DrawLegend
1387            }
1388        }
1389        "-outline" {
1390            set bool $_settings($what)
1391            SendCmd "outline visible $bool"
1392        }
1393        "-surfaceedges" {
1394            set bool $_settings($what)
1395            SendCmd "polydata edges $bool"
1396        }
1397        "-surfacelighting" {
1398            set bool $_settings($what)
1399            SendCmd "polydata lighting $bool"
1400        }
1401        "-surfaceopacity" {
1402            set val $_settings($what)
1403            set sval [expr { 0.01 * double($val) }]
1404            SendCmd "polydata opacity $sval"
1405        }
1406        "-surfacevisible" {
1407            set bool $_settings($what)
1408            SendCmd "polydata visible $bool"
1409            if { $bool } {
1410                Rappture::Tooltip::for $itk_component(surface) \
1411                    "Hide the surface"
1412            } else {
1413                Rappture::Tooltip::for $itk_component(surface) \
1414                    "Show the surface"
1415            }
1416            DrawLegend
1417        }
1418        "-surfacewireframe" {
1419            set bool $_settings($what)
1420            SendCmd "polydata wireframe $bool"
1421        }
1422        "-xgrid" - "-ygrid" - "-zgrid" {
1423            set axis [string tolower [string range $what 1 1]]
1424            set bool $_settings($what)
1425            SendCmd "axis grid $axis $bool"
1426        }
1427        default {
1428            error "don't know how to fix $what"
1429        }
1430    }
1431}
1432
1433#
1434# RequestLegend --
1435#
1436#       Request a new legend from the server.  The size of the legend
1437#       is determined from the height of the canvas.
1438#
1439# This should be called when
1440#        1.  A new current colormap is set.
1441#        2.  Window is resized.
1442#        3.  The limits of the data have changed.  (Just need a redraw).
1443#        4.  Number of isolines have changed. (Just need a redraw).
1444#        5.  Legend becomes visible (Just need a redraw).
1445#
1446itcl::body Rappture::VtkSurfaceViewer::RequestLegend {} {
1447    set _legendPending 0
1448    if { ![info exists _fields($_curFldName)] } {
1449        return
1450    }
1451    set fname $_curFldName
1452    set font "Arial 8"
1453    set lineht [font metrics $font -linespace]
1454    set w 12
1455    set h [expr {$_height - 2 * ($lineht + 2)}]
1456    if { $h < 1 } {
1457        return
1458    }
1459    if { [string match "component*" $fname] } {
1460        set title ""
1461    } else {
1462        if { [info exists _fields($fname)] } {
1463            foreach { title units } $_fields($fname) break
1464            if { $units != "" } {
1465                set title [format "%s (%s)" $title $units]
1466            }
1467        } else {
1468            set title $fname
1469        }
1470    }
1471    # If there's a title too, subtract one more line
1472    if { $title != "" } {
1473        incr h -$lineht
1474    }
1475    # Set the legend on the first heightmap dataset.
1476    if { $_currentColormap != ""  } {
1477        set cmap $_currentColormap
1478        SendCmd "legend $cmap scalar $_curFldName {} $w $h 0"
1479    }
1480}
1481
1482# ----------------------------------------------------------------------
1483# CONFIGURATION OPTION: -plotbackground
1484# ----------------------------------------------------------------------
1485itcl::configbody Rappture::VtkSurfaceViewer::plotbackground {
1486    if { [isconnected] } {
1487        set rgb [Color2RGB $itk_option(-plotbackground)]
1488        SendCmd "screen bgcolor $rgb"
1489    }
1490}
1491
1492# ----------------------------------------------------------------------
1493# CONFIGURATION OPTION: -plotforeground
1494# ----------------------------------------------------------------------
1495itcl::configbody Rappture::VtkSurfaceViewer::plotforeground {
1496    if { [isconnected] } {
1497        set rgb [Color2RGB $itk_option(-plotforeground)]
1498        SendCmd "axis color all $rgb"
1499        SendCmd "outline color $rgb"
1500    }
1501}
1502
1503itcl::body Rappture::VtkSurfaceViewer::BuildSurfaceTab {} {
1504
1505    set fg [option get $itk_component(hull) font Font]
1506    #set bfg [option get $itk_component(hull) boldFont Font]
1507
1508    set inner [$itk_component(main) insert end \
1509        -title "Surface Settings" \
1510        -icon [Rappture::icon volume-on]]
1511    $inner configure -borderwidth 4
1512
1513    checkbutton $inner.surface \
1514        -text "Surface" \
1515        -variable [itcl::scope _settings(-surfacevisible)] \
1516        -command [itcl::code $this AdjustSetting -surfacevisible] \
1517        -font "Arial 9"
1518
1519    checkbutton $inner.isolines \
1520        -text "Isolines" \
1521        -variable [itcl::scope _settings(-isolinesvisible)] \
1522        -command [itcl::code $this AdjustSetting -isolinesvisible] \
1523        -font "Arial 9"
1524
1525    checkbutton $inner.colormapDiscrete \
1526        -text "Discrete Colormap" \
1527        -variable [itcl::scope _settings(-colormapdiscrete)] \
1528        -command [itcl::code $this AdjustSetting -colormapdiscrete] \
1529        -font "Arial 9"
1530
1531    checkbutton $inner.wireframe \
1532        -text "Wireframe" \
1533        -variable [itcl::scope _settings(-surfacewireframe)] \
1534        -command [itcl::code $this AdjustSetting -surfacewireframe] \
1535        -font "Arial 9"
1536
1537    checkbutton $inner.lighting \
1538        -text "Enable Lighting" \
1539        -variable [itcl::scope _settings(-surfacelighting)] \
1540        -command [itcl::code $this AdjustSetting -surfacelighting] \
1541        -font "Arial 9"
1542
1543    checkbutton $inner.edges \
1544        -text "Edges" \
1545        -variable [itcl::scope _settings(-surfaceedges)] \
1546        -command [itcl::code $this AdjustSetting -surfaceedges] \
1547        -font "Arial 9"
1548
1549    checkbutton $inner.outline \
1550        -text "Outline" \
1551        -variable [itcl::scope _settings(-outline)] \
1552        -command [itcl::code $this AdjustSetting -outline] \
1553        -font "Arial 9"
1554
1555    checkbutton $inner.legend \
1556        -text "Legend" \
1557        -variable [itcl::scope _settings(-legendvisible)] \
1558        -command [itcl::code $this AdjustSetting -legendvisible] \
1559        -font "Arial 9"
1560
1561    label $inner.linecolor_l -text "Isolines" -font "Arial 9"
1562    itk_component add isolineColor {
1563        Rappture::Combobox $inner.linecolor -width 10 -editable 0
1564    }
1565    $inner.linecolor choices insert end \
1566        "black"              "black"            \
1567        "blue"               "blue"             \
1568        "cyan"               "cyan"             \
1569        "green"              "green"            \
1570        "grey"               "grey"             \
1571        "magenta"            "magenta"          \
1572        "orange"             "orange"           \
1573        "red"                "red"              \
1574        "white"              "white"            \
1575        "none"               "none"
1576
1577    $itk_component(isolineColor) value "white"
1578    bind $inner.linecolor <<Value>> \
1579        [itcl::code $this AdjustSetting -isolinecolor]
1580
1581    label $inner.background_l -text "Background" -font "Arial 9"
1582    itk_component add background {
1583        Rappture::Combobox $inner.background -width 10 -editable 0
1584    }
1585    $inner.background choices insert end \
1586        "black"              "black"            \
1587        "white"              "white"            \
1588        "grey"               "grey"
1589
1590    $itk_component(background) value $_settings(-background)
1591    bind $inner.background <<Value>> \
1592        [itcl::code $this AdjustSetting -background]
1593
1594    label $inner.opacity_l -text "Opacity" -font "Arial 9"
1595    ::scale $inner.opacity -from 0 -to 100 -orient horizontal \
1596        -variable [itcl::scope _settings(-surfaceopacity)] \
1597        -width 10 \
1598        -showvalue off \
1599        -command [itcl::code $this AdjustSetting -surfaceopacity]
1600
1601    itk_component add field_l {
1602        label $inner.field_l -text "Field" -font "Arial 9"
1603    } {
1604        ignore -font
1605    }
1606    itk_component add field {
1607        Rappture::Combobox $inner.field -width 10 -editable 0
1608    }
1609    bind $inner.field <<Value>> \
1610        [itcl::code $this AdjustSetting -field]
1611
1612    label $inner.colormap_l -text "Colormap" -font "Arial 9"
1613    itk_component add colormap {
1614        Rappture::Combobox $inner.colormap -width 10 -editable 0
1615    }
1616    $inner.colormap choices insert end [GetColormapList]
1617
1618    $itk_component(colormap) value "BCGYR"
1619    bind $inner.colormap <<Value>> \
1620        [itcl::code $this AdjustSetting -colormap]
1621
1622    label $inner.numcontours_l -text "Number of Isolines" -font "Arial 9"
1623    itk_component add numcontours {
1624        Rappture::Spinint $inner.numcontours \
1625            -min 0 -max 50 -font "arial 9"
1626    }
1627    $itk_component(numcontours) value $_settings(-numcontours)
1628    bind $itk_component(numcontours) <<Value>> \
1629        [itcl::code $this AdjustSetting -numcontours]
1630
1631    blt::table $inner \
1632        0,0 $inner.field_l   -anchor w -pady 2  \
1633        0,1 $inner.field     -anchor w -pady 2  -fill x \
1634        1,0 $inner.colormap_l -anchor w -pady 2  \
1635        1,1 $inner.colormap   -anchor w -pady 2  -fill x \
1636        2,0 $inner.linecolor_l  -anchor w -pady 2  \
1637        2,1 $inner.linecolor    -anchor w -pady 2 -fill x  \
1638        3,0 $inner.background_l -anchor w -pady 2 \
1639        3,1 $inner.background -anchor w -pady 2  -fill x \
1640        4,0 $inner.numcontours_l -anchor w -pady 2 \
1641        4,1 $inner.numcontours -anchor w -pady 2 \
1642        5,0 $inner.colormapDiscrete -anchor w -pady 2 -cspan 2 \
1643        6,0 $inner.isolines  -anchor w -pady 2 -cspan 2 \
1644        7,0 $inner.wireframe -anchor w -pady 2 -cspan 2 \
1645        8,0 $inner.lighting  -anchor w -pady 2 -cspan 2 \
1646        9,0 $inner.edges     -anchor w -pady 2 -cspan 2 \
1647        10,0 $inner.outline   -anchor w -pady 2 -cspan 2 \
1648        11,0 $inner.legend    -anchor w -pady 2 \
1649        12,0 $inner.opacity_l -anchor w -pady 2 \
1650        12,1 $inner.opacity   -fill x   -pady 2 -fill x \
1651
1652    blt::table configure $inner r* c* -resize none
1653    blt::table configure $inner r13 c1 -resize expand
1654}
1655
1656itcl::body Rappture::VtkSurfaceViewer::BuildAxisTab {} {
1657
1658    set fg [option get $itk_component(hull) font Font]
1659    #set bfg [option get $itk_component(hull) boldFont Font]
1660
1661    set inner [$itk_component(main) insert end \
1662        -title "Axis Settings" \
1663        -icon [Rappture::icon axis2]]
1664    $inner configure -borderwidth 4
1665
1666    checkbutton $inner.visible \
1667        -text "Axes" \
1668        -variable [itcl::scope _settings(-axesvisible)] \
1669        -command [itcl::code $this AdjustSetting -axesvisible] \
1670        -font "Arial 9"
1671
1672    checkbutton $inner.labels \
1673        -text "Axis Labels" \
1674        -variable [itcl::scope _settings(-axislabels)] \
1675        -command [itcl::code $this AdjustSetting -axislabels] \
1676        -font "Arial 9"
1677    label $inner.grid_l -text "Grid" -font "Arial 9"
1678    checkbutton $inner.xgrid \
1679        -text "X" \
1680        -variable [itcl::scope _settings(-xgrid)] \
1681        -command [itcl::code $this AdjustSetting -xgrid] \
1682        -font "Arial 9"
1683    checkbutton $inner.ygrid \
1684        -text "Y" \
1685        -variable [itcl::scope _settings(-ygrid)] \
1686        -command [itcl::code $this AdjustSetting -ygrid] \
1687        -font "Arial 9"
1688    checkbutton $inner.zgrid \
1689        -text "Z" \
1690        -variable [itcl::scope _settings(-zgrid)] \
1691        -command [itcl::code $this AdjustSetting -zgrid] \
1692        -font "Arial 9"
1693    checkbutton $inner.minorticks \
1694        -text "Minor Ticks" \
1695        -variable [itcl::scope _settings(-axisminorticks)] \
1696        -command [itcl::code $this AdjustSetting -axisminorticks] \
1697        -font "Arial 9"
1698
1699    label $inner.mode_l -text "Mode" -font "Arial 9"
1700
1701    itk_component add axisMode {
1702        Rappture::Combobox $inner.mode -width 10 -editable 0
1703    }
1704    $inner.mode choices insert end \
1705        "static_triad"    "static" \
1706        "closest_triad"   "closest" \
1707        "furthest_triad"  "farthest" \
1708        "outer_edges"     "outer"
1709    $itk_component(axisMode) value $_settings(-axismode)
1710    bind $inner.mode <<Value>> [itcl::code $this AdjustSetting -axismode]
1711
1712    blt::table $inner \
1713        0,0 $inner.visible -anchor w -cspan 4 \
1714        1,0 $inner.labels  -anchor w -cspan 4 \
1715        2,0 $inner.minorticks  -anchor w -cspan 4 \
1716        4,0 $inner.grid_l  -anchor w \
1717        4,1 $inner.xgrid   -anchor w \
1718        4,2 $inner.ygrid   -anchor w \
1719        4,3 $inner.zgrid   -anchor w \
1720        5,0 $inner.mode_l  -anchor w -padx { 2 0 } \
1721        5,1 $inner.mode    -fill x   -cspan 3
1722
1723    blt::table configure $inner r* c* -resize none
1724    blt::table configure $inner r7 c6 -resize expand
1725    blt::table configure $inner r3 -height 0.125i
1726}
1727
1728itcl::body Rappture::VtkSurfaceViewer::BuildCameraTab {} {
1729    set inner [$itk_component(main) insert end \
1730        -title "Camera Settings" \
1731        -icon [Rappture::icon camera]]
1732    $inner configure -borderwidth 4
1733
1734    label $inner.view_l -text "view" -font "Arial 9"
1735    set f [frame $inner.view]
1736    foreach side { front back left right top bottom } {
1737        button $f.$side  -image [Rappture::icon view$side] \
1738            -command [itcl::code $this SetOrientation $side]
1739        Rappture::Tooltip::for $f.$side "Change the view to $side"
1740        pack $f.$side -side left
1741    }
1742
1743    blt::table $inner \
1744        0,0 $inner.view_l -anchor e -pady 2 \
1745        0,1 $inner.view -anchor w -pady 2
1746    blt::table configure $inner r0 -resize none
1747
1748    set labels { qx qy qz qw xpan ypan zoom }
1749    set row 1
1750    foreach tag $labels {
1751        label $inner.${tag}label -text $tag -font "Arial 9"
1752        entry $inner.${tag} -font "Arial 9"  -bg white \
1753            -textvariable [itcl::scope _view(-$tag)]
1754        bind $inner.${tag} <Return> \
1755            [itcl::code $this camera set -${tag}]
1756        bind $inner.${tag} <KP_Enter> \
1757            [itcl::code $this camera set -${tag}]
1758        blt::table $inner \
1759            $row,0 $inner.${tag}label -anchor e -pady 2 \
1760            $row,1 $inner.${tag} -anchor w -pady 2
1761        blt::table configure $inner r$row -resize none
1762        incr row
1763    }
1764    checkbutton $inner.ortho \
1765        -text "Orthographic Projection" \
1766        -variable [itcl::scope _view(-ortho)] \
1767        -command [itcl::code $this camera set -ortho] \
1768        -font "Arial 9"
1769    blt::table $inner \
1770            $row,0 $inner.ortho -cspan 2 -anchor w -pady 2
1771    blt::table configure $inner r$row -resize none
1772    incr row
1773
1774    blt::table configure $inner c* -resize none
1775    blt::table configure $inner c2 -resize expand
1776    blt::table configure $inner r$row -resize expand
1777}
1778
1779#
1780#  camera --
1781#
1782itcl::body Rappture::VtkSurfaceViewer::camera {option args} {
1783    switch -- $option {
1784        "show" {
1785            puts [array get _view]
1786        }
1787        "set" {
1788            set what [lindex $args 0]
1789            set x $_view($what)
1790            set code [catch { string is double $x } result]
1791            if { $code != 0 || !$result } {
1792                return
1793            }
1794            switch -- $what {
1795                "-ortho" {
1796                    if {$_view($what)} {
1797                        SendCmd "camera mode ortho"
1798                    } else {
1799                        SendCmd "camera mode persp"
1800                    }
1801                }
1802                "-xpan" - "-ypan" {
1803                    PanCamera
1804                }
1805                "-qx" - "-qy" - "-qz" - "-qw" {
1806                    set q [ViewToQuaternion]
1807                    $_arcball quaternion $q
1808                    EventuallyRotate $q
1809                }
1810                "-zoom" {
1811                    SendCmd "camera zoom $_view($what)"
1812                }
1813             }
1814        }
1815    }
1816}
1817
1818itcl::body Rappture::VtkSurfaceViewer::GetVtkData { args } {
1819    set bytes ""
1820    foreach dataobj [get] {
1821        foreach cname [$dataobj components] {
1822            set tag $dataobj-$cname
1823            set contents [$dataobj vtkdata $cname]
1824            append bytes "$contents\n"
1825        }
1826    }
1827    return [list .vtk $bytes]
1828}
1829
1830itcl::body Rappture::VtkSurfaceViewer::GetImage { args } {
1831    if { [image width $_image(download)] > 0 &&
1832         [image height $_image(download)] > 0 } {
1833        set bytes [$_image(download) data -format "jpeg -quality 100"]
1834        set bytes [Rappture::encoding::decode -as b64 $bytes]
1835        return [list .jpg $bytes]
1836    }
1837    return ""
1838}
1839
1840itcl::body Rappture::VtkSurfaceViewer::BuildDownloadPopup { popup command } {
1841    Rappture::Balloon $popup \
1842        -title "[Rappture::filexfer::label downloadWord] as..."
1843    set inner [$popup component inner]
1844    label $inner.summary -text "" -anchor w
1845    radiobutton $inner.vtk_button -text "VTK data file" \
1846        -variable [itcl::scope _downloadPopup(format)] \
1847        -font "Arial 9 " \
1848        -value vtk
1849    Rappture::Tooltip::for $inner.vtk_button "Save as VTK data file."
1850    radiobutton $inner.image_button -text "Image File" \
1851        -variable [itcl::scope _downloadPopup(format)] \
1852        -font "Arial 9 " \
1853        -value image
1854    Rappture::Tooltip::for $inner.image_button \
1855        "Save as digital image."
1856
1857    button $inner.ok -text "Save" \
1858        -highlightthickness 0 -pady 2 -padx 3 \
1859        -command $command \
1860        -compound left \
1861        -image [Rappture::icon download]
1862
1863    button $inner.cancel -text "Cancel" \
1864        -highlightthickness 0 -pady 2 -padx 3 \
1865        -command [list $popup deactivate] \
1866        -compound left \
1867        -image [Rappture::icon cancel]
1868
1869    blt::table $inner \
1870        0,0 $inner.summary -cspan 2  \
1871        1,0 $inner.vtk_button -anchor w -cspan 2 -padx { 4 0 } \
1872        2,0 $inner.image_button -anchor w -cspan 2 -padx { 4 0 } \
1873        4,1 $inner.cancel -width .9i -fill y \
1874        4,0 $inner.ok -padx 2 -width .9i -fill y
1875    blt::table configure $inner r3 -height 4
1876    blt::table configure $inner r4 -pady 4
1877    raise $inner.image_button
1878    $inner.vtk_button invoke
1879    return $inner
1880}
1881
1882itcl::body Rappture::VtkSurfaceViewer::SetObjectStyle { dataobj comp } {
1883    # Parse style string.
1884    set tag $dataobj-$comp
1885    array set style {
1886        -color BCGYR
1887        -edgecolor black
1888        -edges 0
1889        -isolinecolor white
1890        -isolinesvisible 0
1891        -levels 10
1892        -lighting 1
1893        -linewidth 1.0
1894        -opacity 1.0
1895        -outline 0
1896        -surfacevisible 1
1897        -wireframe 0
1898    }
1899    array set style [$dataobj style $comp]
1900    if { $dataobj != $_first || $style(-levels) == 1 } {
1901        set style(-opacity) 1.0
1902    }
1903
1904    # This is too complicated.  We want to set the colormap, number of
1905    # isolines and opacity for the dataset.  They can be the default values,
1906    # the style hints loaded with the dataset, or set by user controls.  As
1907    # datasets get loaded, they first use the defaults that are overidden
1908    # by the style hints.  If the user changes the global controls, then that
1909    # overrides everything else.  I don't know what it means when global
1910    # controls are specified as style hints by each dataset.  It complicates
1911    # the code to handle aberrant cases.
1912
1913    if { $_changed(-surfaceopacity) } {
1914        set style(-opacity) [expr $_settings(-surfaceopacity) * 0.01]
1915    }
1916    if { $_changed(-numcontours) } {
1917        set style(-levels) $_settings(-numcontours)
1918    }
1919    if { $_changed(-colormap) } {
1920        set style(-color) $_settings(-colormap)
1921    }
1922    if { $_currentColormap == "" } {
1923        SetCurrentColormap $style(-color)
1924        $itk_component(colormap) value $style(-color)
1925    }
1926    if { $_currentNumContours != $style(-levels) } {
1927        set _currentNumContours $style(-levels)
1928        set _settings(-numcontours) $_currentNumContours
1929        $itk_component(numcontours) value $_currentNumContours
1930        UpdateContourList
1931        DrawLegend
1932    }
1933    set _settings(-isolinesvisible) $style(-isolinesvisible)
1934    set _settings(-surfacevisible) $style(-surfacevisible)
1935
1936    SendCmd "outline add $tag"
1937    SendCmd "outline color [Color2RGB $itk_option(-plotforeground)] $tag"
1938    SendCmd "outline visible $style(-outline) $tag"
1939    set _settings(-outline) $style(-outline)
1940
1941    SendCmd "polydata add $tag"
1942    SendCmd "polydata edges $style(-edges) $tag"
1943    set _settings(-surfaceedges) $style(-edges)
1944    #SendCmd "polydata color [Color2RGB $settings(-color)] $tag"
1945    SendCmd "polydata lighting $style(-lighting) $tag"
1946    set _settings(-surfacelighting) $style(-lighting)
1947    SendCmd "polydata linecolor [Color2RGB $style(-edgecolor)] $tag"
1948    SendCmd "polydata linewidth $style(-linewidth) $tag"
1949    SendCmd "polydata opacity $style(-opacity) $tag"
1950    set _settings(-surfaceopacity) [expr $style(-opacity) * 100.0]
1951    SetCurrentColormap $style(-color)
1952    SendCmd "polydata wireframe $style(-wireframe) $tag"
1953    set _settings(-surfacewireframe) $style(-wireframe)
1954
1955    SendCmd [list contour2d add contourlist $_contourList $tag]
1956    SendCmd "contour2d colormode constant {} $tag"
1957    SendCmd "contour2d color [Color2RGB $style(-isolinecolor)] $tag"
1958}
1959
1960itcl::body Rappture::VtkSurfaceViewer::IsValidObject { dataobj } {
1961    if {[catch {$dataobj isa Rappture::Field} valid] != 0 || !$valid} {
1962        return 0
1963    }
1964    return 1
1965}
1966
1967#
1968# EnterLegend --
1969#
1970itcl::body Rappture::VtkSurfaceViewer::EnterLegend { x y } {
1971    SetLegendTip $x $y
1972}
1973
1974#
1975# MotionLegend --
1976#
1977itcl::body Rappture::VtkSurfaceViewer::MotionLegend { x y } {
1978    Rappture::Tooltip::tooltip cancel
1979    set c $itk_component(view)
1980    set cw [winfo width $c]
1981    set ch [winfo height $c]
1982    if { $x >= 0 && $x < $cw && $y >= 0 && $y < $ch } {
1983        SetLegendTip $x $y
1984    }
1985}
1986
1987#
1988# LeaveLegend --
1989#
1990itcl::body Rappture::VtkSurfaceViewer::LeaveLegend { } {
1991    Rappture::Tooltip::tooltip cancel
1992    .rappturetooltip configure -icon ""
1993}
1994
1995#
1996# SetLegendTip --
1997#
1998itcl::body Rappture::VtkSurfaceViewer::SetLegendTip { x y } {
1999    set fname $_curFldName
2000    set c $itk_component(view)
2001    set w [winfo width $c]
2002    set h [winfo height $c]
2003
2004    set font "Arial 8"
2005    set lineht [font metrics $font -linespace]
2006
2007    set ih [image height $_image(legend)]
2008    set iy [expr $y - ($lineht + 2)]
2009
2010    if { [string match "component*" $fname] } {
2011        set title ""
2012    } else {
2013        if { [info exists _fields($fname)] } {
2014            foreach { title units } $_fields($fname) break
2015            if { $units != "" } {
2016                set title [format "%s (%s)" $title $units]
2017            }
2018        } else {
2019            set title $fname
2020        }
2021    }
2022    # If there's a legend title, increase the offset by the line height.
2023    if { $title != "" } {
2024        incr iy -$lineht
2025    }
2026    # Make a swatch of the selected color
2027    if { [catch { $_image(legend) get 10 $iy } pixel] != 0 } {
2028        return
2029    }
2030    if { ![info exists _image(swatch)] } {
2031        set _image(swatch) [image create photo -width 24 -height 24]
2032    }
2033    set color [eval format "\#%02x%02x%02x" $pixel]
2034    $_image(swatch) put black  -to 0 0 23 23
2035    $_image(swatch) put $color -to 1 1 22 22
2036    .rappturetooltip configure -icon $_image(swatch)
2037
2038    # Compute the value of the point
2039    if { [info exists _limits($_curFldName)] } {
2040        foreach { vmin vmax } $_limits($_curFldName) break
2041        set t [expr 1.0 - (double($iy) / double($ih-1))]
2042        set value [expr $t * ($vmax - $vmin) + $vmin]
2043    } else {
2044        set value 0.0
2045    }
2046    set tx [expr $x + 15]
2047    set ty [expr $y - 5]
2048    if { [info exists _isolines($y)] } {
2049        Rappture::Tooltip::text $c [format "$title %g (isoline)" $_isolines($y)]
2050    } else {
2051        Rappture::Tooltip::text $c [format "$title %g" $value]
2052    }
2053    Rappture::Tooltip::tooltip show $c +$tx,+$ty
2054}
2055
2056#
2057# ReceiveLegend --
2058#
2059#        Invoked automatically whenever the "legend" command comes in from
2060#        the rendering server.  Indicates that binary image data with the
2061#        specified <size> will follow.
2062#
2063itcl::body Rappture::VtkSurfaceViewer::ReceiveLegend { colormap title min max size } {
2064    #puts stderr "ReceiveLegend colormap=$colormap title=$title range=$min,$max size=$size"
2065    set _title $title
2066    regsub {\(mag\)} $title "" _title
2067    if { [IsConnected] } {
2068        set bytes [ReceiveBytes $size]
2069        if { ![info exists _image(legend)] } {
2070            set _image(legend) [image create photo]
2071        }
2072        $_image(legend) configure -data $bytes
2073        #puts stderr "read $size bytes for [image width $_image(legend)]x[image height $_image(legend)] legend>"
2074        if { [catch {DrawLegend} errs] != 0 } {
2075            global errorInfo
2076            puts stderr "errs=$errs errorInfo=$errorInfo"
2077        }
2078    }
2079}
2080
2081#
2082# DrawLegend --
2083#
2084#       Draws the legend in the own canvas on the right side of the plot area.
2085#
2086itcl::body Rappture::VtkSurfaceViewer::DrawLegend {} {
2087    set fname $_curFldName
2088    set c $itk_component(view)
2089    set w [winfo width $c]
2090    set h [winfo height $c]
2091    set font "Arial 8"
2092    set lineht [font metrics $font -linespace]
2093
2094    if { [string match "component*" $fname] } {
2095        set title ""
2096    } else {
2097        if { [info exists _fields($fname)] } {
2098            foreach { title units } $_fields($fname) break
2099            if { $units != "" } {
2100                set title [format "%s (%s)" $title $units]
2101            }
2102        } else {
2103            set title $fname
2104        }
2105    }
2106    set x [expr $w - 2]
2107    if { !$_settings(-legendvisible) } {
2108        $c delete legend
2109        return
2110    }
2111    if { [$c find withtag "legend"] == "" } {
2112        set y 2
2113        # If there's a legend title, create a text item for the title.
2114        $c create text $x $y \
2115            -anchor ne \
2116            -fill $itk_option(-plotforeground) -tags "title legend" \
2117            -font $font
2118        if { $title != "" } {
2119            incr y $lineht
2120        }
2121        $c create text $x $y \
2122            -anchor ne \
2123            -fill $itk_option(-plotforeground) -tags "vmax legend" \
2124            -font $font
2125        incr y $lineht
2126        $c create image $x $y \
2127            -anchor ne \
2128            -image $_image(legend) -tags "colormap legend"
2129        $c create rectangle $x $y 1 1 \
2130            -fill "" -outline "" -tags "sensor legend"
2131        $c create text $x [expr {$h-2}] \
2132            -anchor se \
2133            -fill $itk_option(-plotforeground) -tags "vmin legend" \
2134            -font $font
2135        $c bind sensor <Enter> [itcl::code $this EnterLegend %x %y]
2136        $c bind sensor <Leave> [itcl::code $this LeaveLegend]
2137        $c bind sensor <Motion> [itcl::code $this MotionLegend %x %y]
2138    }
2139    $c delete isoline
2140    set x2 $x
2141    set iw [image width $_image(legend)]
2142    set ih [image height $_image(legend)]
2143    set x1 [expr $x2 - ($iw*12)/10]
2144    set color $_settings(-isolinecolor)
2145    # Draw the isolines on the legend.
2146    array unset _isolines
2147    if { $color != "none"  && [info exists _limits($_curFldName)] &&
2148         $_settings(-isolinesvisible) && $_settings(-numcontours) > 0 } {
2149
2150        foreach { vmin vmax } $_limits($_curFldName) break
2151        set range [expr double($vmax - $vmin)]
2152        if { $range <= 0.0 } {
2153            set range 1.0;              # Min is greater or equal to max.
2154        }
2155        set tags "isoline legend"
2156        set offset [expr 2 + $lineht]
2157        if { $title != "" } {
2158            incr offset $lineht
2159        }
2160        foreach value $_contourList {
2161            set norm [expr 1.0 - (($value - $vmin) / $range)]
2162            set y1 [expr int(round(($norm * $ih) + $offset))]
2163            for { set off 0 } { $off < 3 } { incr off } {
2164                set _isolines([expr $y1 + $off]) $value
2165                set _isolines([expr $y1 - $off]) $value
2166            }
2167            $c create line $x1 $y1 $x2 $y1 -fill $color -tags $tags
2168        }
2169    }
2170
2171    $c bind title <ButtonPress> [itcl::code $this Combo post]
2172    $c bind title <Enter> [itcl::code $this Combo activate]
2173    $c bind title <Leave> [itcl::code $this Combo deactivate]
2174    # Reset the item coordinates according the current size of the plot.
2175    $c itemconfigure title -text $title
2176    if { [info exists _limits($_curFldName)] } {
2177        foreach { vmin vmax } $_limits($_curFldName) break
2178        $c itemconfigure vmin -text [format %g $vmin]
2179        $c itemconfigure vmax -text [format %g $vmax]
2180    }
2181    set y 2
2182    # If there's a legend title, move the title to the correct position
2183    if { $title != "" } {
2184        $c itemconfigure title -text $title
2185        $c coords title $x $y
2186        incr y $lineht
2187        $c raise title
2188    }
2189    $c coords vmax $x $y
2190    incr y $lineht
2191    $c coords colormap $x $y
2192    $c coords sensor [expr $x - $iw] $y $x [expr $y + $ih]
2193    $c raise sensor
2194    $c coords vmin $x [expr {$h - 2}]
2195}
2196
2197# ----------------------------------------------------------------------
2198# USAGE: _dropdown post
2199# USAGE: _dropdown unpost
2200# USAGE: _dropdown select
2201#
2202# Used internally to handle the dropdown list for this combobox.  The
2203# post/unpost options are invoked when the list is posted or unposted
2204# to manage the relief of the controlling button.  The select option
2205# is invoked whenever there is a selection from the list, to assign
2206# the value back to the gauge.
2207# ----------------------------------------------------------------------
2208itcl::body Rappture::VtkSurfaceViewer::Combo {option} {
2209    set c $itk_component(view)
2210    switch -- $option {
2211        post {
2212            foreach { x1 y1 x2 y2 } [$c bbox title] break
2213            set cw [winfo width $itk_component(view)]
2214            set mw [winfo reqwidth $itk_component(fieldmenu)]
2215            set x1 [expr $cw - $mw]
2216            set x [expr $x1 + [winfo rootx $itk_component(view)]]
2217            set y [expr $y2 + [winfo rooty $itk_component(view)]]
2218            tk_popup $itk_component(fieldmenu) $x $y
2219        }
2220        activate {
2221            $c itemconfigure title -fill red
2222        }
2223        deactivate {
2224            $c itemconfigure title -fill $itk_option(-plotforeground)
2225        }
2226        invoke {
2227            $itk_component(field) value $_curFldLabel
2228            AdjustSetting -field
2229        }
2230        default {
2231            error "bad option \"$option\": should be post, unpost, select"
2232        }
2233    }
2234}
2235
2236#
2237# SetCurrentColormap --
2238#
2239itcl::body Rappture::VtkSurfaceViewer::SetCurrentColormap { name } {
2240    # Keep track of the colormaps that we build.
2241    if { ![info exists _colormaps($name)] } {
2242        BuildColormap $name
2243        set _colormaps($name) 1
2244    }
2245    set _currentColormap $name
2246    SendCmd "contour2d colormap $_currentColormap"
2247    SendCmd "polydata colormap $_currentColormap"
2248}
2249
2250#
2251# BuildColormap --
2252#
2253#       Build the designated colormap on the server.
2254#
2255itcl::body Rappture::VtkSurfaceViewer::BuildColormap { name } {
2256    set cmap [ColorsToColormap $name]
2257    if { [llength $cmap] == 0 } {
2258        set cmap "0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0"
2259    }
2260    set wmap "0.0 1.0 1.0 1.0"
2261    SendCmd "colormap add $name { $cmap } { $wmap }"
2262}
2263
2264itcl::body Rappture::VtkSurfaceViewer::SetOrientation { side } {
2265    array set positions {
2266        front "1 0 0 0"
2267        back  "0 0 1 0"
2268        left  "0.707107 0 -0.707107 0"
2269        right "0.707107 0 0.707107 0"
2270        top   "0.707107 -0.707107 0 0"
2271        bottom "0.707107 0.707107 0 0"
2272    }
2273    foreach name { -qw -qx -qy -qz } value $positions($side) {
2274        set _view($name) $value
2275    }
2276    set q [ViewToQuaternion]
2277    $_arcball quaternion $q
2278    SendCmd "camera orient $q"
2279    SendCmd "camera reset"
2280    set _view(-xpan) 0
2281    set _view(-ypan) 0
2282    set _view(-zoom) 1.0
2283}
2284
2285itcl::body Rappture::VtkSurfaceViewer::UpdateContourList {} {
2286    if { ![info exists _limits($_curFldName)] } {
2287        return
2288    }
2289    if { $_currentNumContours < 1 } {
2290        set _contourList ""
2291        return
2292    }
2293    foreach { vmin vmax } $_limits($_curFldName) break
2294    set v [blt::vector create \#auto]
2295    $v seq $vmin $vmax [expr $_currentNumContours+2]
2296    $v delete end 0
2297    set _contourList [$v range 0 end]
2298    blt::vector destroy $v
2299}
Note: See TracBrowser for help on using the repository browser.