source: trunk/gui/scripts/mapviewer.tcl @ 5347

Last change on this file since 5347 was 5347, checked in by ldelgass, 5 years ago

set _downloadPopup to private access

File size: 91.2 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: mapviewer - Map object viewer
4#
5#  It connects to the GeoVis server running on a rendering farm,
6#  transmits data, and displays the results.
7# ======================================================================
8#  AUTHOR:  Michael McLennan, Purdue University
9#  Copyright (c) 2004-2012  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 *MapViewer.width 4i widgetDefault
19option add *MapViewer*cursor crosshair widgetDefault
20option add *MapViewer.height 4i widgetDefault
21option add *MapViewer.foreground black widgetDefault
22option add *MapViewer.controlBackground gray widgetDefault
23option add *MapViewer.controlDarkBackground #999999 widgetDefault
24option add *MapViewer.plotBackground black widgetDefault
25option add *MapViewer.plotForeground white widgetDefault
26option add *MapViewer.font \
27    -*-helvetica-medium-r-normal-*-12-* widgetDefault
28
29# must use this name -- plugs into Rappture::resources::load
30proc MapViewer_init_resources {} {
31    Rappture::resources::register \
32        geovis_server Rappture::MapViewer::SetServerList
33}
34
35itcl::class Rappture::MapViewer {
36    inherit Rappture::VisViewer
37
38    itk_option define -plotforeground plotForeground Foreground ""
39    itk_option define -plotbackground plotBackground Background ""
40
41    private variable _layersFrame "";     # Name of layers frame widget
42    private variable _viewpointsFrame ""; # Name of viewpoints frame widget
43    private variable _mapsettings;        # Global map settings
44
45    constructor { hostlist args } {
46        Rappture::VisViewer::constructor $hostlist
47    } {
48        # defined below
49    }
50    destructor {
51        # defined below
52    }
53    public proc SetServerList { namelist } {
54        Rappture::VisViewer::SetServerList "geovis" $namelist
55    }
56    public method add {dataobj {settings ""}}
57    public method camera {option args}
58    public method delete {args}
59    public method disconnect {}
60    public method download {option args}
61    public method get {args}
62    public method isconnected {}
63    public method parameters {title args} {
64        # do nothing
65    }
66    public method scale {args}
67
68    private method KeyPress { key }
69    private method KeyRelease { key }
70    private method MouseClick { button x y }
71    private method MouseDoubleClick { button x y }
72    private method MouseDrag { button x y }
73    private method MouseMotion {}
74    private method MouseRelease { button x y }
75    private method MouseScroll { direction }
76
77    # The following methods are only used by this class.
78    private method AdjustSetting {what {value ""}}
79    private method BuildCameraTab {}
80    private method BuildDownloadPopup { widget command }
81    private method BuildHelpTab {}
82    private method BuildLayerTab {}
83    private method BuildMapTab {}
84    private method BuildTerrainTab {}
85    private method BuildViewpointsTab {}
86    private method Connect {}
87    private method CurrentLayers {args}
88    private method DisablePanningMouseBindings {}
89    private method DisableRotationMouseBindings {}
90    private method DisableZoomMouseBindings {}
91    private method Disconnect {}
92    private method DoPan {}
93    private method DoResize {}
94    private method DoRotate {}
95    private method DoSelect {}
96    private method DrawLegend { colormap min max }
97    private method EarthFile {}
98    private method EnablePanningMouseBindings {}
99    private method EnableRotationMouseBindings {}
100    private method EnableZoomMouseBindings {}
101    private method EventuallyHandleMotionEvent { x y }
102    private method EventuallyPan { dx dy }
103    private method EventuallyResize { w h }
104    private method EventuallyRotate { dx dy }
105    private method EventuallySelect { x y }
106    private method GetImage { args }
107    private method GetNormalizedMouse { x y }
108    private method GoToViewpoint { dataobj viewpoint }
109    private method InitSettings { args  }
110    private method MapIsGeocentric {}
111    private method Pan {option x y}
112    private method Pin {option x y}
113    private method Rebuild {}
114    private method ReceiveImage { args }
115    private method ReceiveLegend { args }
116    private method ReceiveMapInfo { args }
117    private method ReceiveScreenInfo { args }
118    private method RequestLegend { colormap w h }
119    private method Rotate {option x y}
120    private method Select {option x y}
121    private method SetHeading { {value 0} }
122    private method SetLayerOpacity { dataobj layer {value 100} }
123    private method SetLayerStyle { dataobj layer }
124    private method SetLayerVisibility { dataobj layer }
125    private method SetPitch { {value -89.999} }
126    private method SetTerrainStyle { style }
127    private method ToggleGrid {}
128    private method ToggleLighting {}
129    private method ToggleWireframe {}
130    private method UpdateLayerControls {}
131    private method UpdateViewpointControls {}
132    private method Zoom {option {x 0} {y 0}}
133
134    private variable _dlist "";         # list of data objects
135    private variable _obj2ovride;       # maps dataobj => style override
136    private variable _layers;           # Contains the names of all the
137                                        # layer in the server.
138    private variable _viewpoints;
139    private variable _click;            # info used for rotate operations
140    private variable _view;             # view params for 3D view
141    private variable _pan;
142    private variable _rotate;
143    private variable _select;
144    private variable _motion;
145    private variable _settings
146    private variable _opacity
147    private variable _visibility
148    private variable _reset 1;          # Indicates that server was reset and
149                                        # needs to be reinitialized.
150    private variable _initCamera 1;
151    private variable _haveTerrain 0;
152
153    private variable _first "";         # This is the topmost dataset.
154    private variable _start 0
155    private variable _title ""
156
157    private common _downloadPopup;      # download options from popup
158    private common _hardcopy
159    private variable _width 0
160    private variable _height 0
161    private variable _resizePending 0
162    private variable _sendEarthFile 0
163    private variable _useServerManip 0
164    private variable _labelCount 0
165    private variable _b1mode "pan"
166}
167
168itk::usual MapViewer {
169    keep -background -foreground -cursor -font
170    keep -plotbackground -plotforeground
171}
172
173# ----------------------------------------------------------------------
174# CONSTRUCTOR
175# ----------------------------------------------------------------------
176itcl::body Rappture::MapViewer::constructor {hostlist args} {
177    set _serverType "geovis"
178
179    if { [catch {
180
181    # Rebuild event
182    $_dispatcher register !rebuild
183    $_dispatcher dispatch $this !rebuild "[itcl::code $this Rebuild]; list"
184
185    # Resize event
186    $_dispatcher register !resize
187    $_dispatcher dispatch $this !resize "[itcl::code $this DoResize]; list"
188
189    # Pan event
190    $_dispatcher register !pan
191    $_dispatcher dispatch $this !pan "[itcl::code $this DoPan]; list"
192
193    # Rotate event
194    $_dispatcher register !rotate
195    $_dispatcher dispatch $this !rotate "[itcl::code $this DoRotate]; list"
196
197    # Select event
198    $_dispatcher register !select
199    $_dispatcher dispatch $this !select "[itcl::code $this DoSelect]; list"
200
201    # <Motion> event
202    $_dispatcher register !motion
203    $_dispatcher dispatch $this !motion "[itcl::code $this MouseMotion]; list"
204
205    #
206    # Populate parser with commands handle incoming requests
207    #
208    $_parser alias image    [itcl::code $this ReceiveImage]
209    $_parser alias legend   [itcl::code $this ReceiveLegend]
210    $_parser alias map      [itcl::code $this ReceiveMapInfo]
211    $_parser alias camera   [itcl::code $this camera]
212    $_parser alias screen   [itcl::code $this ReceiveScreenInfo]
213
214    # Millisecond delay before animated wait dialog appears
215    set _waitTimeout 900
216
217    # Settings for mouse motion events: these are required
218    # to update the Lat/Long coordinate display
219    array set _motion {
220        compress        1
221        delay           100
222        enable          1
223        pending         0
224        x               0
225        y               0
226    }
227    array set _pan {
228        compress        1
229        delay           100
230        pending         0
231        x               0
232        y               0
233    }
234    array set _rotate {
235        azimuth         0
236        compress        1
237        delay           100
238        elevation       0
239        pending         0
240    }
241    array set _select {
242        compress        1
243        delay           100
244        pending         0
245        x               0
246        y               0
247    }
248    # This array holds the Viewpoint parameters that the
249    # server sends on "camera get".
250    array set _view {
251        distance        1.0
252        heading         0.0
253        pitch           -89.9
254        srs             ""
255        verticalDatum   ""
256        x               0.0
257        y               0.0
258        z               0.0
259    }
260
261    # Note: grid types are "geodetic", "utm" and "mgrs"
262    # Currently only work in geocentric maps
263    array set _settings [subst {
264        camera-throw           0
265        coords-precision       5
266        coords-units           "latlong_decimal_degrees"
267        coords-visible         1
268        grid                   0
269        grid-type              "geodetic"
270        legend                 1
271        terrain-edges          0
272        terrain-lighting       0
273        terrain-vertscale      1.0
274        terrain-wireframe      0
275        time                   12
276    }]
277
278    set _settings(time) [clock format [clock seconds] -format %k -gmt 1]
279
280    itk_component add view {
281        canvas $itk_component(plotarea).view \
282            -highlightthickness 0 -borderwidth 0
283    } {
284        usual
285        ignore -highlightthickness -borderwidth  -background
286    }
287
288    set c $itk_component(view)
289    bind $c <Enter> "focus %W"
290    bind $c <Control-F1> [itcl::code $this ToggleConsole]
291
292    # Fix the scrollregion in case we go off screen
293    $c configure -scrollregion [$c bbox all]
294
295    set _map(id) [$c create image 0 0 -anchor nw -image $_image(plot)]
296    set _map(cwidth) -1
297    set _map(cheight) -1
298    set _map(zoom) 1.0
299    set _map(original) ""
300
301    set f [$itk_component(main) component controls]
302    itk_component add reset {
303        button $f.reset -borderwidth 1 -padx 1 -pady 1 \
304            -highlightthickness 0 \
305            -image [Rappture::icon reset-view] \
306            -command [itcl::code $this camera reset]
307    } {
308        usual
309        ignore -highlightthickness
310    }
311    pack $itk_component(reset) -side top -padx 2 -pady 2
312    Rappture::Tooltip::for $itk_component(reset) \
313        "Reset the view to the default zoom level"
314
315    itk_component add zoomin {
316        button $f.zin -borderwidth 1 -padx 1 -pady 1 \
317            -highlightthickness 0 \
318            -image [Rappture::icon zoom-in] \
319            -command [itcl::code $this Zoom in]
320    } {
321        usual
322        ignore -highlightthickness
323    }
324    pack $itk_component(zoomin) -side top -padx 2 -pady 2
325    Rappture::Tooltip::for $itk_component(zoomin) "Zoom in"
326
327    itk_component add zoomout {
328        button $f.zout -borderwidth 1 -padx 1 -pady 1 \
329            -highlightthickness 0 \
330            -image [Rappture::icon zoom-out] \
331            -command [itcl::code $this Zoom out]
332    } {
333        usual
334        ignore -highlightthickness
335    }
336    pack $itk_component(zoomout) -side top -padx 2 -pady 2
337    Rappture::Tooltip::for $itk_component(zoomout) "Zoom out"
338
339    BuildLayerTab
340    BuildViewpointsTab
341    BuildMapTab
342    BuildTerrainTab
343    BuildCameraTab
344    BuildHelpTab
345
346    # Legend
347
348    set _image(legend) [image create photo]
349    itk_component add legend {
350        canvas $itk_component(plotarea).legend -width 50 -highlightthickness 0
351    } {
352        usual
353        ignore -highlightthickness
354        rename -background -plotbackground plotBackground Background
355    }
356
357    # Hack around the Tk panewindow.  The problem is that the requested
358    # size of the 3d view isn't set until an image is retrieved from
359    # the server.  So the panewindow uses the tiny size.
360    pack forget $itk_component(view)
361    blt::table $itk_component(plotarea) \
362        0,0 $itk_component(view) -fill both -reqwidth 10000
363    blt::table configure $itk_component(plotarea) c1 -resize none
364
365    bind $itk_component(view) <Configure> \
366        [itcl::code $this EventuallyResize %w %h]
367
368    EnablePanningMouseBindings
369    EnableRotationMouseBindings
370    EnableZoomMouseBindings
371
372    if {$_useServerManip} {
373        # Bindings for keyboard events
374        bind $itk_component(view) <KeyPress> \
375            [itcl::code $this KeyPress %N]
376        bind $itk_component(view) <KeyRelease> \
377            [itcl::code $this KeyRelease %N]
378
379        # Zoom to point
380        bind $itk_component(view) <Double-1> \
381            [itcl::code $this MouseDoubleClick 1 %x %y]
382        bind $itk_component(view) <Double-3> \
383            [itcl::code $this MouseDoubleClick 3 %x %y]
384
385        # Unused
386        bind $itk_component(view) <Double-2> \
387            [itcl::code $this MouseDoubleClick 2 %x %y]
388
389        # Binding for mouse motion events
390        if {$_motion(enable)} {
391            bind $itk_component(view) <Motion> \
392                [itcl::code $this EventuallyHandleMotionEvent %x %y]
393        }
394    } else {
395        # Zoom to point
396        bind $itk_component(view) <Double-1> \
397            [itcl::code $this camera go %x %y 0.4]
398        # Travel to point (no zoom)
399        bind $itk_component(view) <Shift-Double-1> \
400            [itcl::code $this camera go %x %y 1.0]
401        # Zoom out centered on point
402        bind $itk_component(view) <Double-3> \
403            [itcl::code $this camera go %x %y 2.5]
404
405        # Pin placemark annotations
406        bind $itk_component(view) <Control-ButtonPress-1> \
407            [itcl::code $this Pin add %x %y]
408        bind $itk_component(view) <Control-ButtonPress-3> \
409            [itcl::code $this Pin delete %x %y]
410
411        # Draw selection rectangle
412        bind $itk_component(view) <Shift-ButtonPress-1> \
413            [itcl::code $this Select click %x %y]
414        bind $itk_component(view) <B1-Motion> \
415            +[itcl::code $this Select drag %x %y]
416        bind $itk_component(view) <Shift-ButtonRelease-1> \
417            [itcl::code $this Select release %x %y]
418
419        # Update coordinate readout
420        bind $itk_component(view) <ButtonPress-1> \
421            +[itcl::code $this SendCmd "map setpos %x %y"]
422        bind $itk_component(view) <Double-3> \
423            +[itcl::code $this SendCmd "map setpos %x %y"]
424
425        # Bindings for panning via keyboard
426        bind $itk_component(view) <KeyPress-Left> \
427            [itcl::code $this Pan set 10 0]
428        bind $itk_component(view) <KeyPress-Right> \
429            [itcl::code $this Pan set -10 0]
430        bind $itk_component(view) <KeyPress-Up> \
431            [itcl::code $this Pan set 0 -10]
432        bind $itk_component(view) <KeyPress-Down> \
433            [itcl::code $this Pan set 0 10]
434
435        bind $itk_component(view) <Shift-KeyPress-Left> \
436            [itcl::code $this Pan set 2 0]
437        bind $itk_component(view) <Shift-KeyPress-Right> \
438            [itcl::code $this Pan set -2 0]
439        bind $itk_component(view) <Shift-KeyPress-Up> \
440            [itcl::code $this Pan set 0 -2]
441        bind $itk_component(view) <Shift-KeyPress-Down> \
442            [itcl::code $this Pan set 0 2]
443
444        # Bindings for rotation via keyboard
445        bind $itk_component(view) <Control-Left> \
446            [itcl::code $this Rotate set 10 0]
447        bind $itk_component(view) <Control-Right> \
448            [itcl::code $this Rotate set -10 0]
449        bind $itk_component(view) <Control-Up> \
450            [itcl::code $this Rotate set 0 -10]
451        bind $itk_component(view) <Control-Down> \
452            [itcl::code $this Rotate set 0 10]
453
454        bind $itk_component(view) <Control-Shift-Left> \
455            [itcl::code $this Rotate set 2 0]
456        bind $itk_component(view) <Control-Shift-Right> \
457            [itcl::code $this Rotate set -2 0]
458        bind $itk_component(view) <Control-Shift-Up> \
459            [itcl::code $this Rotate set 0 -2]
460        bind $itk_component(view) <Control-Shift-Down> \
461            [itcl::code $this Rotate set 0 2]
462
463        # Bindings for zoom via keyboard
464        bind $itk_component(view) <KeyPress-Prior> \
465            [itcl::code $this Zoom out]
466        bind $itk_component(view) <KeyPress-Next> \
467            [itcl::code $this Zoom in]
468        bind $itk_component(view) <KeyPress-Home> \
469            [itcl::code $this camera reset]
470
471        # Keyboard shortcuts
472        # Reset heading to North
473        bind $itk_component(view) <n> \
474            [itcl::code $this SetHeading]
475        # Reset pitch to top-down (2D) view
476        bind $itk_component(view) <p> \
477            [itcl::code $this SetPitch]
478        bind $itk_component(view) <g> \
479            [itcl::code $this ToggleGrid]
480        bind $itk_component(view) <l> \
481            [itcl::code $this ToggleLighting]
482        bind $itk_component(view) <w> \
483            [itcl::code $this ToggleWireframe]
484
485        # Binding for mouse motion events
486        set _motion(compress) 1
487        if {$_motion(enable)} {
488            bind $itk_component(view) <Motion> \
489                [itcl::code $this EventuallyHandleMotionEvent %x %y]
490        }
491        #bind $itk_component(view) <Motion> \
492        #    +[itcl::code $this SendCmd "map pin hover %x %y"]
493    }
494
495    bind $itk_component(view) <Enter> "focus $itk_component(view)"
496
497    if {[string equal "x11" [tk windowingsystem]]} {
498        # Bindings for zoom via mouse
499        if {$_useServerManip} {
500            bind $itk_component(view) <4> [itcl::code $this MouseScroll up]
501            bind $itk_component(view) <5> [itcl::code $this MouseScroll down]
502        } else {
503            bind $itk_component(view) <4> [itcl::code $this Zoom out]
504            bind $itk_component(view) <5> [itcl::code $this Zoom in]
505        }
506    }
507
508    set _image(download) [image create photo]
509
510    eval itk_initialize $args
511    Connect
512} errs] != 0 } {
513        puts stderr errs=$errs
514    }
515}
516
517# ----------------------------------------------------------------------
518# DESTRUCTOR
519# ----------------------------------------------------------------------
520itcl::body Rappture::MapViewer::destructor {} {
521    Disconnect
522    $_dispatcher cancel !rebuild
523    $_dispatcher cancel !resize
524    $_dispatcher cancel !rotate
525    image delete $_image(plot)
526    image delete $_image(download)
527}
528
529itcl::body Rappture::MapViewer::DoResize {} {
530    set sendResize 1
531    if { $_width < 2 } {
532        set _width 500
533        set sendResize 0
534    }
535    if { $_height < 2 } {
536        set _height 500
537        set sendResize 0
538    }
539    #set _start [clock clicks -milliseconds]
540    if {$sendResize} {
541        SendCmd "screen size $_width $_height"
542    }
543    set _resizePending 0
544}
545
546itcl::body Rappture::MapViewer::DoRotate {} {
547    SendCmd "camera rotate $_rotate(azimuth) $_rotate(elevation)"
548    set _rotate(azimuth) 0
549    set _rotate(elevation) 0
550    set _rotate(pending) 0
551}
552
553itcl::body Rappture::MapViewer::DoSelect {} {
554    SendCmd "map box update $_select(x) $_select(y)"
555    set _select(x) 0
556    set _select(y) 0
557    set _select(pending) 0
558}
559
560itcl::body Rappture::MapViewer::EventuallyResize { w h } {
561    set _width $w
562    set _height $h
563    if { !$_resizePending } {
564        set _resizePending 1
565        $_dispatcher event -after 200 !resize
566    }
567}
568
569itcl::body Rappture::MapViewer::DoPan {} {
570    SendCmd "camera pan $_pan(x) $_pan(y)"
571    set _pan(x) 0
572    set _pan(y) 0
573    set _pan(pending) 0
574}
575
576itcl::body Rappture::MapViewer::EventuallyPan { dx dy } {
577    set _pan(x) [expr $_pan(x) + $dx]
578    set _pan(y) [expr $_pan(y) + $dy]
579    if { !$_pan(compress) } {
580        DoPan
581        return
582    }
583    if { !$_pan(pending) } {
584        set _pan(pending) 1
585        $_dispatcher event -after $_pan(delay) !pan
586    }
587}
588
589itcl::body Rappture::MapViewer::EventuallyRotate { dx dy } {
590    set _rotate(azimuth) [expr $_rotate(azimuth) + $dx]
591    set _rotate(elevation) [expr $_rotate(elevation) + $dy]
592    if { !$_rotate(compress) } {
593        DoRotate
594        return
595    }
596    if { !$_rotate(pending) } {
597        set _rotate(pending) 1
598        $_dispatcher event -after $_rotate(delay) !rotate
599    }
600}
601
602itcl::body Rappture::MapViewer::EventuallySelect { x y } {
603    set _select(x) $x
604    set _select(y) $y
605    if { !$_select(compress) } {
606        DoSelect
607        return
608    }
609    if { !$_select(pending) } {
610        set _select(pending) 1
611        $_dispatcher event -after $_select(delay) !select
612    }
613}
614
615itcl::body Rappture::MapViewer::DrawLegend { colormap min max } {
616    if { [info exists itk_component(legend-$colormap) ] } {
617        $itk_component(legend-$colormap-min) configure -text $min
618        $itk_component(legend-$colormap-max) configure -text $max
619        $itk_component(legend-$colormap) configure -image $_image(legend-$colormap)
620    }
621}
622
623itcl::body Rappture::MapViewer::RequestLegend { colormap w h } {
624    SendCmd "legend $colormap $w $h 0 [Color2RGB #d9d9d9]"
625}
626
627# ----------------------------------------------------------------------
628# USAGE: add <dataobj> ?<settings>?
629#
630# Clients use this to add a data object to the plot.  The optional
631# <settings> are used to configure the plot.  Allowed settings are
632# -color, -brightness, -width, -linestyle, and -raise.
633# ----------------------------------------------------------------------
634itcl::body Rappture::MapViewer::add {dataobj {settings ""}} {
635    array set params {
636        -color auto
637        -width 1
638        -linestyle solid
639        -brightness 0
640        -raise 0
641        -description ""
642        -param ""
643        -type ""
644    }
645    array set params $settings
646    set params(-description) ""
647    set params(-param) ""
648    array set params $settings
649
650    if {$params(-color) == "auto" || $params(-color) == "autoreset"} {
651        # can't handle -autocolors yet
652        set params(-color) black
653    }
654    set pos [lsearch -exact $_dlist $dataobj]
655    if {$pos < 0} {
656        #if {[llength $_dlist] > 0} {
657        #    error "Can't add more than 1 map to mapviewer"
658        #}
659        lappend _dlist $dataobj
660    }
661    set _obj2ovride($dataobj-color) $params(-color)
662    set _obj2ovride($dataobj-width) $params(-width)
663    set _obj2ovride($dataobj-raise) $params(-raise)
664    $_dispatcher event -idle !rebuild
665}
666
667# ----------------------------------------------------------------------
668# USAGE: delete ?<dataobj1> <dataobj2> ...?
669#
670# Clients use this to delete a dataobj from the plot.  If no dataobjs
671# are specified, then all dataobjs are deleted.  No data objects are
672# deleted.  They are only removed from the display list.
673# ----------------------------------------------------------------------
674itcl::body Rappture::MapViewer::delete {args} {
675    if { [llength $args] == 0} {
676        set args $_dlist
677    }
678    # Delete all specified dataobjs
679    set changed 0
680    foreach dataobj $args {
681        set pos [lsearch -exact $_dlist $dataobj]
682        if { $pos < 0 } {
683            continue;                   # Don't know anything about it.
684        }
685        # When a map is marked deleted, we hide its layers.
686        foreach layer [$dataobj layers] {
687            SendCmd "map layer visible 0 $layer"
688            set _visibility($layer) 0
689        }
690        # Remove it from the dataobj list.
691        set _dlist [lreplace $_dlist $pos $pos]
692        array unset _obj2ovride $dataobj-*
693        array unset _settings $dataobj-*
694        set changed 1
695    }
696    # If anything changed, then rebuild the plot
697    if { $changed } {
698        $_dispatcher event -idle !rebuild
699    }
700}
701
702# ----------------------------------------------------------------------
703# USAGE: get ?-objects?
704# USAGE: get ?-visible?
705# USAGE: get ?-image view?
706#
707# Clients use this to query the list of objects being plotted, in
708# order from bottom to top of this result.  The optional "-image"
709# flag can also request the internal images being shown.
710# ----------------------------------------------------------------------
711itcl::body Rappture::MapViewer::get {args} {
712    if {[llength $args] == 0} {
713        set args "-objects"
714    }
715
716    set op [lindex $args 0]
717    switch -- $op {
718        "-objects" {
719            # put the dataobj list in order according to -raise options
720            set dlist {}
721            foreach dataobj $_dlist {
722                if { ![$dataobj isvalid] } {
723                    continue
724                }
725                if {[info exists _obj2ovride($dataobj-raise)] &&
726                    $_obj2ovride($dataobj-raise)} {
727                    set dlist [linsert $dlist 0 $dataobj]
728                } else {
729                    lappend dlist $dataobj
730                }
731            }
732            return $dlist
733        }
734        "-visible" {
735            set dlist {}
736            foreach dataobj $_dlist {
737                if { ![$dataobj isvalid] } {
738                    continue
739                }
740                if { ![info exists _obj2ovride($dataobj-raise)] } {
741                    # No setting indicates that the object isn't visible.
742                    continue
743                }
744                # Otherwise use the -raise parameter to put the object to
745                # the front of the list.
746                if { $_obj2ovride($dataobj-raise) } {
747                    set dlist [linsert $dlist 0 $dataobj]
748                } else {
749                    lappend dlist $dataobj
750                }
751            }
752            return $dlist
753        }
754        -image {
755            if {[llength $args] != 2} {
756                error "wrong # args: should be \"get -image view\""
757            }
758            switch -- [lindex $args end] {
759                view {
760                    return $_image(plot)
761                }
762                default {
763                    error "bad image name \"[lindex $args end]\": should be view"
764                }
765            }
766        }
767        default {
768            error "bad option \"$op\": should be -objects or -image"
769        }
770    }
771}
772
773itcl::body Rappture::MapViewer::MapIsGeocentric {} {
774    if { [info exists _mapsettings(type)] } {
775        return [expr {$_mapsettings(type) eq "geocentric"}]
776    } else {
777        return 0
778    }
779}
780
781# ----------------------------------------------------------------------
782# USAGE: scale ?<data1> <data2> ...?
783#
784# Sets the default limits for the overall plot according to the
785# limits of the data for all of the given <data> objects.  This
786# accounts for all objects--even those not showing on the screen.
787# Because of this, the limits are appropriate for all objects as
788# the user scans through data in the ResultSet viewer.
789# ----------------------------------------------------------------------
790itcl::body Rappture::MapViewer::scale {args} {
791    array unset _mapsettings
792    set _haveTerrain 0
793
794    # Verify that all the maps have the same global settings. For example,
795    # you can't have one map type "geocentric" and the other "projected".
796
797    foreach dataobj $args {
798        if { ![$dataobj isvalid] } {
799            continue
800        }
801        array unset hints
802        array set hints [$dataobj hints]
803        if { ![info exists _mapsettings(label)] } {
804            set _mapsettings(label) $hints(label)
805        }
806        if { ![info exists _mapsettings(style)] } {
807            set _mapsettings(style) $hints(style)
808        }
809        if { ![info exists _mapsettings(type)] } {
810            set _mapsettings(type) $hints(type)
811        } elseif { $hints(type) != $_mapsettings(type) } {
812            error "maps \"$hints(label)\" have differing types"
813        }
814        if { ![info exists _mapsettings(projection)] } {
815            set _mapsettings(projection) $hints(projection)
816        } elseif { $hints(projection) != $_mapsettings(projection) } {
817            error "maps \"$hints(label)\" have differing projections"
818        }
819        if { $hints(extents) != "" } {
820            if { ![info exists _mapsettings(extents)] } {
821                set _mapsettings(extents) $hints(extents)
822            }
823            foreach {x1 y1 x2 y2} $hints(extents) break
824            if { ![info exists _mapsettings(x1)] || $x1 < $_mapsettings(x1) } {
825                set _mapsettings(x1) $x1
826            }
827            if { ![info exists _mapsettings(y1)] || $y1 < $_mapsettings(y1) } {
828                set _mapsettings(y1) $y1
829            }
830            if { ![info exists _mapsettings(x2)] || $x2 > $_mapsettings(x2) } {
831                set _mapsettings(x2) $x2
832            }
833            if { ![info exists _mapsettings(y2)] || $y2 > $_mapsettings(y2) } {
834                set _mapsettings(y2) $y2
835            }
836        }
837        if { [info exists hints(camera)] } {
838            if { ![info exists _mapsettings(camera)] } {
839                set _mapsettings(camera) $hints(camera)
840            }
841        }
842        foreach layer [$dataobj layers] {
843            if { [$dataobj type $layer] == "elevation" } {
844                set _haveTerrain 1
845                break
846            }
847        }
848        foreach viewpoint [$dataobj viewpoints] {
849            set _viewpoints($viewpoint) [$dataobj viewpoint $viewpoint]
850            if 0 {
851                array set vp $_viewpoints($viewpoint)
852                foreach key { label description x y z distance heading pitch srs verticalDatum } {
853                    if { [info exists vp($key)] } {
854                        puts stderr "$viewpoint $key $vp($key)"
855                    }
856                }
857            }
858        }
859    }
860    if { $_haveTerrain } {
861        if { [$itk_component(main) exists "Terrain Settings"] } {
862            # TODO: Enable controls like vertical scale that only have
863            # an effect when terrain is present
864        }
865    }
866}
867
868# ----------------------------------------------------------------------
869# USAGE: download coming
870# USAGE: download controls <downloadCommand>
871# USAGE: download now
872#
873# Clients use this method to create a downloadable representation
874# of the plot.  Returns a list of the form {ext string}, where
875# "ext" is the file extension (indicating the type of data) and
876# "string" is the data itself.
877# ----------------------------------------------------------------------
878itcl::body Rappture::MapViewer::download {option args} {
879    switch $option {
880        coming {
881            if {[catch {
882                blt::winop snap $itk_component(plotarea) $_image(download)
883            }]} {
884                $_image(download) configure -width 1 -height 1
885                $_image(download) put #000000
886            }
887        }
888        controls {
889            set popup .mapviewerdownload
890            if { ![winfo exists .mapviewerdownload] } {
891                set inner [BuildDownloadPopup $popup [lindex $args 0]]
892            } else {
893                set inner [$popup component inner]
894            }
895            set _downloadPopup(image_controls) $inner.image_frame
896            set num [llength [get]]
897            set num [expr {($num == 1) ? "1 result" : "$num results"}]
898            set word [Rappture::filexfer::label downloadWord]
899            $inner.summary configure -text "$word $num in the following format:"
900            update idletasks            ;# Fix initial sizes
901            return $popup
902        }
903        now {
904            set popup .mapviewerdownload
905            if {[winfo exists .mapviewerdownload]} {
906                $popup deactivate
907            }
908            switch -- $_downloadPopup(format) {
909                "image" {
910                    return [$this GetImage [lindex $args 0]]
911                }
912            }
913            return ""
914        }
915        default {
916            error "bad option \"$option\": should be coming, controls, now"
917        }
918    }
919}
920
921# ----------------------------------------------------------------------
922# USAGE: Connect ?<host:port>,<host:port>...?
923#
924# Clients use this method to establish a connection to a new
925# server, or to reestablish a connection to the previous server.
926# Any existing connection is automatically closed.
927# ----------------------------------------------------------------------
928itcl::body Rappture::MapViewer::Connect {} {
929    global readyForNextFrame
930    set readyForNextFrame 1
931    set _reset 1
932    set _hosts [GetServerList "geovis"]
933    if { "" == $_hosts } {
934        return 0
935    }
936    set result [VisViewer::Connect $_hosts]
937    if { $result } {
938        if { $_reportClientInfo }  {
939            # Tell the server the viewer, hub, user and session.
940            # Do this immediately on connect before buffering any commands
941            global env
942
943            set info {}
944            set user "???"
945            if { [info exists env(USER)] } {
946                set user $env(USER)
947            }
948            set session "???"
949            if { [info exists env(SESSION)] } {
950                set session $env(SESSION)
951            }
952            lappend info "version" "$Rappture::version"
953            lappend info "build" "$Rappture::build"
954            lappend info "svnurl" "$Rappture::svnurl"
955            lappend info "installdir" "$Rappture::installdir"
956            lappend info "hub" [exec hostname]
957            lappend info "client" "mapviewer"
958            lappend info "user" $user
959            lappend info "session" $session
960            SendCmd "clientinfo [list $info]"
961        }
962
963        set w [winfo width $itk_component(view)]
964        set h [winfo height $itk_component(view)]
965        EventuallyResize $w $h
966    }
967    return $result
968}
969
970#
971# isconnected --
972#
973#   Indicates if we are currently connected to the visualization server.
974#
975itcl::body Rappture::MapViewer::isconnected {} {
976    return [VisViewer::IsConnected]
977}
978
979#
980# disconnect --
981#
982itcl::body Rappture::MapViewer::disconnect {} {
983    Disconnect
984    set _reset 1
985}
986
987#
988# Disconnect --
989#
990#   Clients use this method to disconnect from the current rendering
991#   server.
992#
993itcl::body Rappture::MapViewer::Disconnect {} {
994    VisViewer::Disconnect
995
996    $_dispatcher cancel !pan
997    $_dispatcher cancel !motion
998    $_dispatcher cancel !rebuild
999    $_dispatcher cancel !resize
1000    $_dispatcher cancel !rotate
1001    # disconnected -- no more data sitting on server
1002    array unset _layers
1003    array unset _layersFrame
1004    global readyForNextFrame
1005    set readyForNextFrame 1
1006}
1007
1008# ----------------------------------------------------------------------
1009# USAGE: ReceiveImage -type <type> -token <token> -bytes <size>
1010#
1011# Invoked automatically whenever the "image" command comes in from
1012# the rendering server.  Indicates that binary image data with the
1013# specified <size> will follow.
1014# ----------------------------------------------------------------------
1015itcl::body Rappture::MapViewer::ReceiveImage { args } {
1016    global readyForNextFrame
1017    set readyForNextFrame 1
1018    array set info {
1019        -bytes 0
1020        -token "???"
1021        -type image
1022    }
1023    array set info $args
1024    set bytes [ReceiveBytes $info(-bytes)]
1025    if { $info(-type) == "image" } {
1026        $_image(plot) configure -data $bytes
1027    } elseif { $info(type) == "print" } {
1028        set tag $this-print-$info(-token)
1029        set _hardcopy($tag) $bytes
1030    }
1031    set _waitTimeout 0
1032}
1033
1034#
1035# ReceiveLegend
1036#
1037# Invoked automatically whenever the "legend" command comes in from
1038# the rendering server.  Indicates that binary image data with the
1039# specified <size> will follow.
1040#
1041itcl::body Rappture::MapViewer::ReceiveLegend { colormap min max size } {
1042    #puts stderr "ReceiveLegend colormap=$colormap range=$min,$max size=$size"
1043    if { [IsConnected] } {
1044        set bytes [ReceiveBytes $size]
1045        if { ![info exists _image(legend)] } {
1046            set _image(legend-$colormap) [image create photo]
1047        }
1048        if 0 {
1049            set f [open "/tmp/legend-${colormap}.ppm" "w"]
1050            fconfigure $f -translation binary -encoding binary
1051            puts $f $bytes
1052            close $f
1053        }
1054        $_image(legend-$colormap) configure -data $bytes
1055        #puts stderr "read $size bytes for [image width $_image(legend-$colormap)]x[image height $_image(legend-$colormap)] legend>"
1056        if { [catch {DrawLegend $colormap $min $max} errs] != 0 } {
1057            global errorInfo
1058            puts stderr "errs=$errs errorInfo=$errorInfo"
1059        }
1060    }
1061}
1062
1063#
1064# ReceiveMapInfo --
1065#
1066itcl::body Rappture::MapViewer::ReceiveMapInfo { args } {
1067    if { ![isconnected] } {
1068        return
1069    }
1070    set timeReceived [clock clicks -milliseconds]
1071    set elapsed [expr $timeReceived - $_start]
1072    set option [lindex $args 0]
1073    switch -- $option {
1074        "coords" {
1075            set len [llength $args]
1076            if {$len < 3} {
1077                error "Bad map coords response"
1078            } else {
1079                set token [lindex $args 1]
1080            }
1081            foreach { x y z } [lindex $args 2] {
1082                puts stderr "\[$token\] Map coords: $x $y $z"
1083            }
1084            if {$len > 3} {
1085                set srs [lindex $args 3]
1086                set vert [lindex $args 4]
1087                puts stderr "\[$token\] {$srs} {$vert}"
1088            }
1089        }
1090        "names" {
1091            foreach { name } [lindex $args 1] {
1092                puts stderr "layer: $name"
1093            }
1094        }
1095        default {
1096            error "unknown map option \"$option\" from server"
1097        }
1098    }
1099}
1100
1101#
1102# ReceiveScreenInfo --
1103#
1104itcl::body Rappture::MapViewer::ReceiveScreenInfo { args } {
1105    if { ![isconnected] } {
1106        return
1107    }
1108    set option [lindex $args 0]
1109    switch -- $option {
1110        "coords" {
1111            set len [llength $args]
1112            if {$len < 3} {
1113                error "Bad screen coords response"
1114            } else {
1115                set token [lindex $args 1]
1116            }
1117            foreach { x y z } [lindex $args 2] {
1118                puts stderr "\[$token\] Screen coords: $x $y $z"
1119            }
1120        }
1121        default {
1122            error "unknown screen option \"$option\" from server"
1123        }
1124    }
1125}
1126
1127# ----------------------------------------------------------------------
1128# USAGE: Rebuild
1129#
1130# Called automatically whenever something changes that affects the
1131# data in the widget.  Clears any existing data and rebuilds the
1132# widget to display new data.
1133# ----------------------------------------------------------------------
1134itcl::body Rappture::MapViewer::Rebuild {} {
1135    set w [winfo width $itk_component(view)]
1136    set h [winfo height $itk_component(view)]
1137    if { $w < 2 || $h < 2 } {
1138        update idletasks
1139        $_dispatcher event -idle !rebuild
1140        return
1141    }
1142
1143    # Turn on buffering of commands to the server.  We don't want to be
1144    # preempted by a server disconnect/reconnect (which automatically
1145    # generates a new call to Rebuild).
1146    StartBufferingCommands
1147
1148    if { $_reset } {
1149        set _width $w
1150        set _height $h
1151        DoResize
1152
1153        if { [info exists _mapsettings(type)] } {
1154            # The map must be reset once before any layers are added This
1155            # should not be done more than once as it is very expensive.
1156            if {$_sendEarthFile} {
1157                set bytes [EarthFile]
1158                if {0} {
1159                    set f [open "/tmp/map.earth" "w"]
1160                    puts $f $bytes
1161                    close $f
1162                }
1163                set length [string length $bytes]
1164                SendCmd "map load data follows $length"
1165                SendData $bytes
1166            } else {
1167                if { [info exists _mapsettings(style)] } {
1168                    array set settings {
1169                        -color white
1170                    }
1171                    array set settings $_mapsettings(style)
1172                }
1173                set bgcolor [Color2RGB $settings(-color)]
1174                if { $_mapsettings(type) == "geocentric" } {
1175                    $itk_component(grid) configure -state normal
1176                    $itk_component(time_l) configure -state normal
1177                    $itk_component(time) configure -state normal
1178                    $itk_component(pitch_slider_l) configure -state normal
1179                    $itk_component(pitch_slider) configure -state normal
1180                    EnableRotationMouseBindings
1181                    SendCmd "map reset geocentric $bgcolor"
1182                }  else {
1183                    $itk_component(grid) configure -state disabled
1184                    $itk_component(time_l) configure -state disabled
1185                    $itk_component(time) configure -state disabled
1186                    $itk_component(pitch_slider_l) configure -state disabled
1187                    $itk_component(pitch_slider) configure -state disabled
1188                    DisableRotationMouseBindings
1189                    set proj $_mapsettings(projection)
1190                    SendCmd "screen bgcolor $bgcolor"
1191                    if { $proj == "" } {
1192                        SendCmd "map reset projected $bgcolor global-mercator"
1193                    } elseif { ![info exists _mapsettings(extents)] || $_mapsettings(extents) == "" } {
1194                        SendCmd "map reset projected $bgcolor [list $proj]"
1195                    } else {
1196                        #foreach {x1 y1 x2 y2} $_mapsettings(extents) break
1197                        foreach key "x1 y1 x2 y2" {
1198                            set $key $_mapsettings($key)
1199                        }
1200                        SendCmd "map reset projected $bgcolor [list $proj] $x1 $y1 $x2 $y2"
1201                    }
1202                }
1203                # XXX: Remove these after implementing batch load of layers with reset
1204                SendCmd "map layer delete base"
1205            }
1206
1207            # Most terrain settings are global to the map and apply even
1208            # if there is no elevation layer.  The exception is the
1209            # vertical scale, which only applies if there is an elevation
1210            # layer
1211            if { [info exists _mapsettings(style)] } {
1212                SetTerrainStyle $_mapsettings(style)
1213            } else {
1214                InitSettings terrain-edges terrain-lighting \
1215                    terrain-vertscale terrain-wireframe
1216            }
1217            InitSettings coords-visible
1218        } else {
1219            error "No map settings on reset"
1220        }
1221    }
1222
1223    set _first ""
1224    set haveTerrain 0
1225    foreach dataobj [get -objects] {
1226        foreach layer [$dataobj layers] {
1227            array unset info
1228            array set info [$dataobj layer $layer]
1229            if { ![info exists _layers($layer)] } {
1230                if { $_reportClientInfo }  {
1231                    set cinfo {}
1232                    lappend cinfo "tool_id"       [$dataobj hints toolid]
1233                    lappend cinfo "tool_name"     [$dataobj hints toolname]
1234                    lappend cinfo "tool_title"    [$dataobj hints tooltitle]
1235                    lappend cinfo "tool_command"  [$dataobj hints toolcommand]
1236                    lappend cinfo "tool_revision" [$dataobj hints toolrevision]
1237                    lappend cinfo "dataset_label" [encoding convertto utf-8 $info(label)]
1238                    lappend cinfo "dataset_tag"   $layer
1239                    SendCmd "clientinfo [list $cinfo]"
1240                }
1241                set _layers($layer) 1
1242                SetLayerStyle $dataobj $layer
1243            }
1244            if {$info(type) == "elevation"} {
1245                set haveTerrain 1
1246            }
1247            # FIXME: This is overriding all layers' initial visibility setting
1248            if { [info exists _obj2ovride($dataobj-raise)] } {
1249                SendCmd "map layer visible 1 $layer"
1250                set _visibility($layer) 1
1251                #SetLayerOpacity $dataobj $layer
1252            }
1253        }
1254    }
1255
1256    if ($haveTerrain) {
1257        $itk_component(vscale_l) configure -state normal
1258        $itk_component(vscale) configure -state normal
1259    } else {
1260        $itk_component(vscale_l) configure -state disabled
1261        $itk_component(vscale) configure -state disabled
1262    }
1263
1264    if {$_reset} {
1265        if {$_initCamera} {
1266            # If this is the first Rebuild, we need to
1267            # set up the initial view settings if there
1268            # are any
1269            if { [info exists _mapsettings(camera)] } {
1270                set location $_mapsettings(camera)
1271                if { $location != "" } {
1272                    array set _view $location
1273                    camera set all
1274                }
1275            }
1276            set _initCamera 0
1277        } else {
1278            # Restore view from before reconnect
1279            camera set all
1280        }
1281    }
1282
1283    UpdateLayerControls
1284    UpdateViewpointControls
1285    set _reset 0
1286    global readyForNextFrame
1287    set readyForNextFrame 0;            # Don't advance to the next frame
1288                                        # until we get an image.
1289
1290    # Actually write the commands to the server socket.  If it fails, we
1291    # don't care.  We're finished here.
1292    blt::busy hold $itk_component(hull)
1293    StopBufferingCommands
1294    blt::busy release $itk_component(hull)
1295}
1296
1297itcl::body Rappture::MapViewer::EnablePanningMouseBindings {} {
1298    if {$_useServerManip} {
1299        bind $itk_component(view) <ButtonPress-1> \
1300            [itcl::code $this MouseClick 1 %x %y]
1301        bind $itk_component(view) <B1-Motion> \
1302            [itcl::code $this MouseDrag 1 %x %y]
1303        bind $itk_component(view) <ButtonRelease-1> \
1304            [itcl::code $this MouseRelease 1 %x %y]
1305    } else {
1306        bind $itk_component(view) <ButtonPress-1> \
1307            [itcl::code $this Pan click %x %y]
1308        bind $itk_component(view) <B1-Motion> \
1309            [itcl::code $this Pan drag %x %y]
1310        bind $itk_component(view) <ButtonRelease-1> \
1311            [itcl::code $this Pan release %x %y]
1312    }
1313}
1314
1315itcl::body Rappture::MapViewer::DisablePanningMouseBindings {} {
1316    bind $itk_component(view) <ButtonPress-1> {}
1317    bind $itk_component(view) <B1-Motion> {}
1318    bind $itk_component(view) <ButtonRelease-1> {}
1319}
1320
1321itcl::body Rappture::MapViewer::EnableRotationMouseBindings {} {
1322    if {$_useServerManip} {
1323        bind $itk_component(view) <ButtonPress-2> \
1324            [itcl::code $this Rotate click %x %y]
1325        bind $itk_component(view) <B2-Motion> \
1326            [itcl::code $this Rotate drag %x %y]
1327        bind $itk_component(view) <ButtonRelease-2> \
1328            [itcl::code $this Rotate release %x %y]
1329    } else {
1330        # Bindings for rotation via mouse
1331        bind $itk_component(view) <ButtonPress-2> \
1332            [itcl::code $this MouseClick 2 %x %y]
1333        bind $itk_component(view) <B2-Motion> \
1334            [itcl::code $this MouseDrag 2 %x %y]
1335        bind $itk_component(view) <ButtonRelease-2> \
1336            [itcl::code $this MouseRelease 2 %x %y]
1337    }
1338}
1339
1340itcl::body Rappture::MapViewer::DisableRotationMouseBindings {} {
1341    bind $itk_component(view) <ButtonPress-2> {}
1342    bind $itk_component(view) <B2-Motion> {}
1343    bind $itk_component(view) <ButtonRelease-2> {}
1344}
1345
1346itcl::body Rappture::MapViewer::EnableZoomMouseBindings {} {
1347    if {$_useServerManip} {
1348        bind $itk_component(view) <ButtonPress-3> \
1349            [itcl::code $this MouseClick 3 %x %y]
1350        bind $itk_component(view) <B3-Motion> \
1351            [itcl::code $this MouseDrag 3 %x %y]
1352        bind $itk_component(view) <ButtonRelease-3> \
1353            [itcl::code $this MouseRelease 3 %x %y]
1354    } else {
1355        bind $itk_component(view) <ButtonPress-3> \
1356            [itcl::code $this Zoom click %x %y]
1357        bind $itk_component(view) <B3-Motion> \
1358            [itcl::code $this Zoom drag %x %y]
1359        bind $itk_component(view) <ButtonRelease-3> \
1360            [itcl::code $this Zoom release %x %y]
1361    }
1362}
1363
1364itcl::body Rappture::MapViewer::DisableZoomMouseBindings {} {
1365    bind $itk_component(view) <ButtonPress-3> {}
1366    bind $itk_component(view) <B3-Motion> {}
1367    bind $itk_component(view) <ButtonRelease-3> {}
1368}
1369# ----------------------------------------------------------------------
1370# USAGE: CurrentLayers ?-all -visible? ?dataobjs?
1371#
1372# Returns a list of server IDs for the current datasets being displayed.
1373# This is normally a single ID, but it might be a list of IDs if the
1374# current data object has multiple components.
1375# ----------------------------------------------------------------------
1376itcl::body Rappture::MapViewer::CurrentLayers {args} {
1377    set flag [lindex $args 0]
1378    switch -- $flag {
1379        "-all" {
1380            if { [llength $args] > 1 } {
1381                error "CurrentLayers: can't specify dataobj after \"-all\""
1382            }
1383            set dlist [get -objects]
1384        }
1385        "-visible" {
1386            if { [llength $args] > 1 } {
1387                set dlist {}
1388                set args [lrange $args 1 end]
1389                foreach dataobj $args {
1390                    if { [info exists _obj2ovride($dataobj-raise)] } {
1391                        lappend dlist $dataobj
1392                    }
1393                }
1394            } else {
1395                set dlist [get -visible]
1396            }
1397        }
1398        default {
1399            set dlist $args
1400        }
1401    }
1402    set rlist ""
1403    foreach dataobj $dlist {
1404        foreach layer [$dataobj layers] {
1405            if { [info exists _layers($layer)] && $_layers($layer) } {
1406                lappend rlist $layer
1407            }
1408        }
1409    }
1410    return $rlist
1411}
1412
1413itcl::body Rappture::MapViewer::KeyPress {k} {
1414    SendCmd "key press $k"
1415}
1416
1417itcl::body Rappture::MapViewer::KeyRelease {k} {
1418    SendCmd "key release $k"
1419}
1420
1421itcl::body Rappture::MapViewer::GetNormalizedMouse {x y} {
1422    set w [winfo width $itk_component(view)]
1423    set h [winfo height $itk_component(view)]
1424    set x [expr {(2.0 * double($x)/$w) - 1.0}]
1425    set y [expr {(2.0 * double($y)/$h) - 1.0}]
1426    return [list $x $y]
1427}
1428
1429itcl::body Rappture::MapViewer::MouseClick {button x y} {
1430    SendCmd "mouse click $button $x $y"
1431}
1432
1433itcl::body Rappture::MapViewer::MouseDoubleClick {button x y} {
1434    SendCmd "mouse dblclick $button $x $y"
1435}
1436
1437itcl::body Rappture::MapViewer::MouseDrag {button x y} {
1438    SendCmd "mouse drag $button $x $y"
1439}
1440
1441itcl::body Rappture::MapViewer::MouseRelease {button x y} {
1442    SendCmd "mouse release $button $x $y"
1443}
1444
1445itcl::body Rappture::MapViewer::MouseMotion {} {
1446    #SendCmd "mouse motion $_motion(x) $_motion(y)"
1447    SendCmd "map pin hover $_motion(x) $_motion(y)"
1448    set _motion(pending) 0
1449}
1450
1451itcl::body Rappture::MapViewer::MouseScroll {direction} {
1452    switch -- $direction {
1453        "up" {
1454            SendCmd "mouse scroll 1"
1455        }
1456        "down" {
1457            SendCmd "mouse scroll -1"
1458        }
1459    }
1460}
1461
1462#
1463# EventuallyHandleMotionEvent --
1464#
1465#   This routine compresses (no button press) motion events.  It
1466#   delivers a server mouse command once every 100 milliseconds (if a
1467#   motion event is pending).
1468#
1469itcl::body Rappture::MapViewer::EventuallyHandleMotionEvent {x y} {
1470    set _motion(x) $x
1471    set _motion(y) $y
1472    if { !$_motion(compress) } {
1473        MouseMotion
1474        return
1475    }
1476    if { !$_motion(pending) } {
1477        set _motion(pending) 1
1478        $_dispatcher event -after $_motion(delay) !motion
1479    }
1480}
1481
1482# ----------------------------------------------------------------------
1483# USAGE: Zoom in
1484# USAGE: Zoom out
1485# USAGE: Zoom reset
1486#        $this Zoom click x y
1487#        $this Zoom drag x y
1488#        $this Zoom release x y
1489#
1490# Called automatically when the user clicks on one of the zoom
1491# controls for this widget.  Changes the zoom for the current view.
1492# Also implements mouse zoom.
1493# ----------------------------------------------------------------------
1494itcl::body Rappture::MapViewer::Zoom {option {x 0} {y 0}} {
1495    switch -- $option {
1496        "in" {
1497            # z here is normalized mouse Y delta
1498            set z -0.25
1499            SendCmd "camera zoom $z"
1500        }
1501        "out" {
1502            # z here is normalized mouse Y delta
1503            set z 0.25
1504            SendCmd "camera zoom $z"
1505        }
1506        "reset" {
1507            SendCmd "camera dist $_view(distance)"
1508        }
1509        "click" {
1510            set _click(x) $x
1511            set _click(y) $y
1512            $itk_component(view) configure -cursor hand1
1513        }
1514        "drag" {
1515            if { ![info exists _click(x)] } {
1516                set _click(x) $x
1517            }
1518            if { ![info exists _click(y)] } {
1519                set _click(y) $y
1520            }
1521            set h [winfo height $itk_component(view)]
1522            set dy [expr ($_click(y) - $y)/double($h)]
1523            set _click(x) $x
1524            set _click(y) $y
1525            if {[expr (abs($dy) > 0.0)]} {
1526                SendCmd "camera zoom $dy"
1527            }
1528        }
1529        "release" {
1530            Zoom drag $x $y
1531            $itk_component(view) configure -cursor ""
1532        }
1533    }
1534}
1535
1536# ----------------------------------------------------------------------
1537# USAGE: Rotate click <x> <y>
1538# USAGE: Rotate drag <x> <y>
1539# USAGE: Rotate release <x> <y>
1540#
1541# Called automatically when the user clicks/drags/releases in the
1542# plot area.  Moves the plot according to the user's actions.
1543# ----------------------------------------------------------------------
1544itcl::body Rappture::MapViewer::Rotate {option x y} {
1545    switch -- $option {
1546        "click" {
1547            $itk_component(view) configure -cursor fleur
1548            set _click(x) $x
1549            set _click(y) $y
1550            set _rotate(azimuth) 0
1551            set _rotate(elevation) 0
1552        }
1553        "drag" {
1554            if {[array size _click] == 0} {
1555                Rotate click $x $y
1556            } else {
1557                set w [winfo width $itk_component(view)]
1558                set h [winfo height $itk_component(view)]
1559                if {$w <= 0 || $h <= 0} {
1560                    return
1561                }
1562                set dx [expr ($x - $_click(x))/double($w)]
1563                set dy [expr ($_click(y) - $y)/double($h)]
1564                set _click(x) $x
1565                set _click(y) $y
1566                if {[expr (abs($dx) > 0.0 || abs($dy) > 0.0)]} {
1567                    #SendCmd "camera rotate $dx $dy"
1568                    EventuallyRotate $dx $dy
1569                }
1570            }
1571        }
1572        "release" {
1573            Rotate drag $x $y
1574            $itk_component(view) configure -cursor ""
1575            catch {unset _click}
1576        }
1577        "set" {
1578            set w [winfo width $itk_component(view)]
1579            set h [winfo height $itk_component(view)]
1580            set dx [expr $x / double($w)]
1581            set dy [expr $y / double($h)]
1582            if {[expr (abs($dx) > 0.0 || abs($dy) > 0.0)]} {
1583                EventuallyRotate $dx $dy
1584            }
1585        }
1586        default {
1587            error "bad option \"$option\": should be click, drag, release"
1588        }
1589    }
1590}
1591
1592itcl::body Rappture::MapViewer::Select {option x y} {
1593    switch -- $option {
1594        "click" {
1595            set _click(x) $x
1596            set _click(y) $y
1597            set _b1mode "select"
1598            SendCmd "map box init $x $y"
1599        }
1600        "drag" {
1601            if {$_b1mode == "select"} {
1602                EventuallySelect $x $y
1603            }
1604        }
1605        "release" {
1606            set _b1mode ""
1607            if {$_click(x) == $x &&
1608                $_click(y) == $y} {
1609                SendCmd "map box clear"
1610            }
1611        }
1612    }
1613}
1614
1615itcl::body Rappture::MapViewer::Pin {option x y} {
1616    set _click(x) $x
1617    set _click(y) $y
1618    switch -- $option {
1619        "add" {
1620            incr _labelCount
1621            set label "Label $_labelCount"
1622            SendCmd [list "map" "pin" "add" $x $y [encoding convertto utf-8 $label]]
1623        }
1624        "delete" {
1625            SendCmd "map pin delete $x $y"
1626        }
1627    }
1628}
1629
1630# ----------------------------------------------------------------------
1631# USAGE: $this Pan set x y
1632#        $this Pan click x y
1633#        $this Pan drag x y
1634#        $this Pan release x y
1635#
1636# Called automatically when the user clicks on one of the zoom
1637# controls for this widget.  Changes the zoom for the current view.
1638# ----------------------------------------------------------------------
1639itcl::body Rappture::MapViewer::Pan {option x y} {
1640    switch -- $option {
1641        "set" {
1642            set w [winfo width $itk_component(view)]
1643            set h [winfo height $itk_component(view)]
1644            set x [expr $x / double($w)]
1645            set y [expr $y / double($h)]
1646            if {[expr (abs($x) > 0.0 || abs($y) > 0.0)]} {
1647                SendCmd "camera pan $x $y"
1648            }
1649            return
1650        }
1651        "click" {
1652            set _click(x) $x
1653            set _click(y) $y
1654            set _pan(x) 0
1655            set _pan(y) 0
1656            $itk_component(view) configure -cursor hand1
1657            set _b1mode "pan"
1658        }
1659        "drag" {
1660            if {$_b1mode != "pan"} {
1661                return
1662            }
1663            if { ![info exists _click(x)] } {
1664                set _click(x) $x
1665            }
1666            if { ![info exists _click(y)] } {
1667                set _click(y) $y
1668            }
1669            set w [winfo width $itk_component(view)]
1670            set h [winfo height $itk_component(view)]
1671            set dx [expr ($x - $_click(x))/double($w)]
1672            set dy [expr ($_click(y) - $y)/double($h)]
1673            set _click(x) $x
1674            set _click(y) $y
1675            if {[expr (abs($dx) > 0.0 || abs($dy) > 0.0)]} {
1676                EventuallyPan $dx $dy
1677                #SendCmd "camera pan $dx $dy"
1678            }
1679        }
1680        "release" {
1681            Pan drag $x $y
1682            $itk_component(view) configure -cursor ""
1683            set _b1mode ""
1684        }
1685        default {
1686            error "unknown option \"$option\": should set, click, drag, or release"
1687        }
1688    }
1689}
1690
1691itcl::body Rappture::MapViewer::SetHeading { {value 0} } {
1692    set _view(heading) $value
1693    camera set heading
1694}
1695
1696itcl::body Rappture::MapViewer::SetPitch { {value -89.999} } {
1697    set _view(pitch) $value
1698    camera set pitch
1699}
1700
1701# ----------------------------------------------------------------------
1702# USAGE: InitSettings <what> ?<value>?
1703#
1704# Used internally to update rendering settings whenever parameters
1705# change in the popup settings panel.  Sends the new settings off
1706# to the back end.
1707# ----------------------------------------------------------------------
1708itcl::body Rappture::MapViewer::InitSettings { args } {
1709    foreach setting $args {
1710        AdjustSetting $setting
1711    }
1712}
1713
1714#
1715# AdjustSetting --
1716#
1717#   Changes/updates a specific setting in the widget.  There are
1718#   usually user-setable option.  Commands are sent to the render
1719#   server.
1720#
1721itcl::body Rappture::MapViewer::AdjustSetting {what {value ""}} {
1722    if { ![isconnected] } {
1723        return
1724    }
1725    switch -- $what {
1726        "coords-visible" - "coords-precision" - "coords-units" {
1727            set bool $_settings(coords-visible)
1728            set units $_settings(coords-units)
1729            set precision $_settings(coords-precision)
1730            SendCmd "map posdisp $bool $units $precision"
1731        }
1732        "grid" - "grid-type" {
1733            set bool $_settings(grid)
1734            set gridType $_settings(grid-type)
1735            SendCmd "map grid $bool $gridType"
1736        }
1737        "camera-throw" {
1738            set bool $_settings($what)
1739            SendCmd "camera throw $bool"
1740        }
1741        "terrain-edges" {
1742            set bool $_settings($what)
1743            SendCmd "map terrain edges $bool"
1744        }
1745        "terrain-lighting" {
1746            set bool $_settings($what)
1747            SendCmd "map terrain lighting $bool"
1748        }
1749        "terrain-palette" {
1750            set cmap [$itk_component(terrainpalette) value]
1751            #SendCmd "map terrain colormap $cmap"
1752        }
1753        "terrain-vertscale" {
1754            set val $_settings($what)
1755            SendCmd "map terrain vertscale $val"
1756        }
1757        "terrain-wireframe" {
1758            set bool $_settings($what)
1759            SendCmd "map terrain wireframe $bool"
1760        }
1761        "time" {
1762            set val $_settings($what)
1763            SendCmd "map time $val"
1764        }
1765        default {
1766            error "don't know how to fix $what"
1767        }
1768    }
1769}
1770
1771# ----------------------------------------------------------------------
1772# CONFIGURATION OPTION: -plotbackground
1773# ----------------------------------------------------------------------
1774itcl::configbody Rappture::MapViewer::plotbackground {
1775    if { [isconnected] } {
1776        set rgb [Color2RGB $itk_option(-plotbackground)]
1777        SendCmd "screen bgcolor $rgb"
1778    }
1779}
1780
1781# ----------------------------------------------------------------------
1782# CONFIGURATION OPTION: -plotforeground
1783# ----------------------------------------------------------------------
1784itcl::configbody Rappture::MapViewer::plotforeground {
1785    if { [isconnected] } {
1786        set rgb [Color2RGB $itk_option(-plotforeground)]
1787        # FIXME: Set font foreground colors
1788    }
1789}
1790
1791itcl::body Rappture::MapViewer::BuildMapTab {} {
1792    set fg [option get $itk_component(hull) font Font]
1793    #set bfg [option get $itk_component(hull) boldFont Font]
1794
1795    set inner [$itk_component(main) insert end \
1796        -title "Map Settings" \
1797        -icon [Rappture::icon wrench]]
1798    $inner configure -borderwidth 4
1799
1800    checkbutton $inner.posdisp \
1801        -text "Show Coordinate Readout" \
1802        -variable [itcl::scope _settings(coords-visible)] \
1803        -command [itcl::code $this AdjustSetting coords-visible] \
1804        -font "Arial 9" -anchor w
1805
1806    itk_component add grid {
1807        checkbutton $inner.grid \
1808        -text "Show Graticule" \
1809        -variable [itcl::scope _settings(grid)] \
1810        -command [itcl::code $this AdjustSetting grid] \
1811        -font "Arial 9" -anchor w
1812    } {
1813        ignore -font
1814    }
1815    Rappture::Tooltip::for $inner.grid "Toggle graticule (grid) display <g>"
1816
1817    checkbutton $inner.wireframe \
1818        -text "Show Wireframe" \
1819        -variable [itcl::scope _settings(terrain-wireframe)] \
1820        -command [itcl::code $this AdjustSetting terrain-wireframe] \
1821        -font "Arial 9" -anchor w
1822    Rappture::Tooltip::for $inner.wireframe "Toggle wireframe rendering of terrain geometry <w>"
1823
1824    checkbutton $inner.lighting \
1825        -text "Enable Lighting" \
1826        -variable [itcl::scope _settings(terrain-lighting)] \
1827        -command [itcl::code $this AdjustSetting terrain-lighting] \
1828        -font "Arial 9" -anchor w
1829    Rappture::Tooltip::for $inner.lighting "Toggle sky lighting of terrain <l>"
1830
1831    checkbutton $inner.edges \
1832        -text "Show Edges" \
1833        -variable [itcl::scope _settings(terrain-edges)] \
1834        -command [itcl::code $this AdjustSetting terrain-edges] \
1835        -font "Arial 9" -anchor w
1836
1837    itk_component add time_l {
1838        label $inner.time_l -text "Time (UTC)" -font "Arial 9"
1839    } {
1840        ignore -font
1841    }
1842    itk_component add time {
1843        ::scale $inner.time -from 0 -to 23.9 -orient horizontal \
1844            -resolution 0.1 \
1845            -variable [itcl::scope _settings(time)] \
1846            -width 10 \
1847            -showvalue on \
1848            -command [itcl::code $this AdjustSetting time]
1849    }
1850
1851    blt::table $inner \
1852        0,0 $inner.posdisp   -cspan 2 -anchor w -pady 2 \
1853        1,0 $inner.grid      -cspan 2 -anchor w -pady 2 \
1854        2,0 $inner.wireframe -cspan 2 -anchor w -pady 2 \
1855        3,0 $inner.lighting  -cspan 2 -anchor w -pady 2 \
1856        4,0 $inner.time_l    -cspan 2 -anchor w -pady 2 \
1857        4,1 $inner.time      -cspan 2 -fill x   -pady 2
1858#        4,0 $inner.edges     -cspan 2  -anchor w -pady 2
1859
1860    blt::table configure $inner r* c* -resize none
1861    blt::table configure $inner r5 c1 -resize expand
1862}
1863
1864itcl::body Rappture::MapViewer::BuildTerrainTab {} {
1865    set fg [option get $itk_component(hull) font Font]
1866    #set bfg [option get $itk_component(hull) boldFont Font]
1867
1868    set inner [$itk_component(main) insert end \
1869        -title "Terrain Settings" \
1870        -icon [Rappture::icon terrain]]
1871    $inner configure -borderwidth 4
1872
1873    label $inner.palette_l -text "Palette" -font "Arial 9" -anchor w
1874    itk_component add terrainpalette {
1875        Rappture::Combobox $inner.palette -width 10 -editable no
1876    }
1877    $inner.palette choices insert end [GetColormapList]
1878
1879    $itk_component(terrainpalette) value "BCGYR"
1880    bind $inner.palette <<Value>> \
1881        [itcl::code $this AdjustSetting terrain-palette]
1882
1883    itk_component add vscale_l {
1884        label $inner.vscale_l -text "Vertical Scale" -font "Arial 9" -anchor w
1885    }
1886    itk_component add vscale {
1887        ::scale $inner.vscale -from 0 -to 10 -orient horizontal \
1888            -variable [itcl::scope _settings(terrain-vertscale)] \
1889            -width 10 \
1890            -resolution 0.1 \
1891            -showvalue on \
1892            -command [itcl::code $this AdjustSetting terrain-vertscale]
1893    }
1894    $inner.vscale set $_settings(terrain-vertscale)
1895
1896    blt::table $inner \
1897        0,0 $inner.vscale_l  -anchor w -pady 2 \
1898        0,1 $inner.vscale    -fill x   -pady 2
1899#        1,0 $inner.palette_l -anchor w -pady 2 \
1900#        1,1 $inner.palette   -fill x   -pady 2
1901
1902    blt::table configure $inner r* c* -resize none
1903    blt::table configure $inner r3 c1 -resize expand
1904}
1905
1906itcl::body Rappture::MapViewer::BuildLayerTab {} {
1907    set fg [option get $itk_component(hull) font Font]
1908    #set bfg [option get $itk_component(hull) boldFont Font]
1909
1910    set inner [$itk_component(main) insert end \
1911        -title "Layers" \
1912        -icon [Rappture::icon layers]]
1913    $inner configure -borderwidth 4
1914    set f [frame $inner.layers]
1915    blt::table $inner \
1916        0,0 $f -fill both
1917    set _layersFrame $inner
1918}
1919
1920itcl::body Rappture::MapViewer::BuildViewpointsTab {} {
1921    set fg [option get $itk_component(hull) font Font]
1922    #set bfg [option get $itk_component(hull) boldFont Font]
1923
1924    set inner [$itk_component(main) insert end \
1925        -title "Places" \
1926        -icon [Rappture::icon placemark16]]
1927    $inner configure -borderwidth 4
1928    set f [frame $inner.viewpoints]
1929    blt::table $inner \
1930        0,0 $f -fill both
1931    set _viewpointsFrame $inner
1932}
1933
1934itcl::body Rappture::MapViewer::BuildCameraTab {} {
1935    set inner [$itk_component(main) insert end \
1936        -title "Camera Settings" \
1937        -icon [Rappture::icon camera]]
1938    $inner configure -borderwidth 4
1939
1940    set row 0
1941
1942    set labels { x y z heading pitch distance }
1943    foreach tag $labels {
1944        label $inner.${tag}label -text $tag -font "Arial 9"
1945        entry $inner.${tag} -font "Arial 9"  -bg white \
1946            -textvariable [itcl::scope _view($tag)]
1947        bind $inner.${tag} <KeyPress-Return> \
1948            [itcl::code $this camera set ${tag}]
1949        bind $inner.${tag} <KP_Enter> \
1950            [itcl::code $this camera set ${tag}]
1951        blt::table $inner \
1952            $row,0 $inner.${tag}label -anchor e -pady 2 \
1953            $row,1 $inner.${tag} -anchor w -pady 2
1954        blt::table configure $inner r$row -resize none
1955        incr row
1956    }
1957    set labels { srs verticalDatum }
1958    foreach tag $labels {
1959        label $inner.${tag}label -text $tag -font "Arial 9"
1960        entry $inner.${tag} -font "Arial 9"  -bg white \
1961            -textvariable [itcl::scope _view($tag)]
1962        bind $inner.${tag} <KeyPress-Return> \
1963            [itcl::code $this camera set ${tag}]
1964        bind $inner.${tag} <KP_Enter> \
1965            [itcl::code $this camera set ${tag}]
1966        blt::table $inner \
1967            $row,0 $inner.${tag}label -anchor e -pady 2 \
1968            $row,1 $inner.${tag} -anchor w -pady 2
1969        blt::table configure $inner r$row -resize none
1970        incr row
1971    }
1972
1973    if {0} {
1974    button $inner.get \
1975        -text "Get Camera Settings" \
1976        -font "Arial 9" \
1977        -command [itcl::code $this SendCmd "camera get"]
1978    blt::table $inner \
1979        $row,0 $inner.get -anchor w -pady 2 -cspan 2
1980    blt::table configure $inner r$row -resize none
1981    incr row
1982
1983    button $inner.set \
1984        -text "Apply Camera Settings" \
1985        -font "Arial 9" \
1986        -command [itcl::code $this camera set all]
1987    blt::table $inner \
1988        $row,0 $inner.set -anchor w -pady 2 -cspan 2
1989    blt::table configure $inner r$row -resize none
1990    incr row
1991    }
1992
1993    if {$_useServerManip} {
1994        checkbutton $inner.throw \
1995            -text "Enable Throw" \
1996            -font "Arial 9" \
1997            -variable [itcl::scope _settings(camera-throw)] \
1998            -command [itcl::code $this AdjustSetting camera-throw]
1999        blt::table $inner \
2000            $row,0 $inner.throw -anchor w -pady 2 -cspan 2
2001        blt::table configure $inner r$row -resize none
2002        incr row
2003    }
2004
2005    label $inner.heading_slider_l -text "Heading" -font "Arial 9"
2006    ::scale $inner.heading_slider -font "Arial 9" \
2007        -from -180 -to 180 -orient horizontal \
2008        -variable [itcl::scope _view(heading)] \
2009        -width 10 \
2010        -showvalue on \
2011        -command [itcl::code $this camera set heading]
2012
2013    blt::table $inner \
2014            $row,0 $inner.heading_slider_l -anchor w -pady 2
2015    blt::table $inner \
2016            $row,1 $inner.heading_slider -fill x -anchor w -pady 2
2017    blt::table configure $inner r$row -resize none
2018    incr row
2019
2020    itk_component add pitch_slider_l {
2021        label $inner.pitch_slider_l -text "Pitch" -font "Arial 9"
2022    }
2023    itk_component add pitch_slider {
2024        ::scale $inner.pitch_slider -font "Arial 9" \
2025            -from -10 -to -90 -orient horizontal \
2026            -variable [itcl::scope _view(pitch)] \
2027            -width 10 \
2028            -showvalue on \
2029            -command [itcl::code $this camera set pitch]
2030    }
2031
2032    blt::table $inner \
2033            $row,0 $inner.pitch_slider_l -anchor w -pady 2
2034    blt::table $inner \
2035            $row,1 $inner.pitch_slider -fill x -anchor w -pady 2
2036    blt::table configure $inner r$row -resize none
2037    incr row
2038
2039    blt::table configure $inner c* r* -resize none
2040    blt::table configure $inner c2 -resize expand
2041    blt::table configure $inner r$row -resize expand
2042}
2043
2044itcl::body Rappture::MapViewer::BuildHelpTab {} {
2045    set fg [option get $itk_component(hull) font Font]
2046    #set bfg [option get $itk_component(hull) boldFont Font]
2047
2048    set inner [$itk_component(main) insert end \
2049        -title "Help" \
2050        -icon [Rappture::icon question_mark12]]
2051    $inner configure -borderwidth 4
2052
2053    set helptext {*************************
2054Mouse bindings:
2055*************************
2056  Left - Panning
2057  Middle - Rotation
2058  Right - Zoom
2059
2060Zoom/travel:
2061  Left double-click:
2062    Zoom to point
2063  Left shift-double:
2064    Travel to point
2065  Right double-click:
2066    Zoom out from point
2067
2068Pins:
2069  Ctl-Left: Drop pin
2070  Ctl-Right: Delete pin
2071
2072Select:
2073  Shift-Left click-drag
2074
2075*************************
2076Keyboard bindings:
2077*************************
2078  g - Toggle graticule
2079  l - Toggle lighting
2080  n - Set North up
2081  p - Reset pitch
2082  w - Toggle wireframe
2083  arrows - panning
2084  Shift-arrows - fine pan
2085  Ctl-arrows - rotation
2086  Ctl-Shift-arrows:
2087    fine rotation
2088  PgUp/PgDown - zoom
2089  Home - Reset camera
2090*************************}
2091
2092    text $inner.info -width 25 -bg white
2093    $inner.info insert end $helptext
2094    $inner.info configure -state disabled
2095    blt::table $inner \
2096        0,0 $inner.info -fill both
2097}
2098
2099#
2100#  camera --
2101#
2102# USAGE: camera get
2103#        This is called by the server to transfer the
2104#        current Viewpoint settings
2105# USAGE: camera reset
2106#        Reset the camera to the default view
2107#
2108itcl::body Rappture::MapViewer::camera {option args} {
2109    switch -- $option {
2110        "get" {
2111            # We got the camera settings from the server
2112            foreach name {x y z heading pitch distance srs verticalDatum} value $args {
2113                set _view($name) $value
2114            }
2115#            puts stderr "view: $_view(x), $_view(y), $_view(z), $_view(heading), $_view(pitch), $_view(distance), {$_view(srs)}, {$_view(verticalDatum)}"
2116        }
2117        "go" {
2118            SendCmd "camera go $args"
2119        }
2120        "reset" {
2121            array set _view {
2122                x               0.0
2123                y               0.0
2124                z               0.0
2125                heading         0.0
2126                pitch           -89.9
2127                distance        1.0
2128                srs             ""
2129                verticalDatum   ""
2130            }
2131            if { [info exists _mapsettings(camera)] } {
2132                # Check if the tool specified a default
2133                set location $_mapsettings(camera)
2134                if { $location != "" } {
2135                    array set _view $location
2136                    set duration 0.0
2137                    SendCmd [list camera set $_view(x) $_view(y) $_view(z) $_view(heading) $_view(pitch) $_view(distance) $duration $_view(srs) $_view(verticalDatum)]
2138                } else {
2139                    SendCmd "camera reset"
2140                    # Retrieve the settings
2141                    #SendCmd "camera get"
2142                }
2143            } else {
2144                SendCmd "camera reset"
2145                # Retrieve the settings
2146               # SendCmd "camera get"
2147            }
2148        }
2149        "set" {
2150            set who [lindex $args 0]
2151            if {$who != "all" && $who != "srs" && $who != "verticalDatum"} {
2152                set val $_view($who)
2153                set code [catch { string is double $val } result]
2154                if { $code != 0 || !$result } {
2155                    return
2156                }
2157            }
2158            switch -- $who {
2159                "distance" {
2160                    SendCmd [list camera dist $_view(distance)]
2161                }
2162                "all" - "x" - "y" - "z" - "heading" - "pitch" - "srs" - "verticalDatum" {
2163                    set duration 0.0
2164                    SendCmd [list camera set $_view(x) $_view(y) $_view(z) $_view(heading) $_view(pitch) $_view(distance) $duration $_view(srs) $_view(verticalDatum)]
2165                }
2166            }
2167        }
2168    }
2169}
2170
2171itcl::body Rappture::MapViewer::GoToViewpoint { dataobj viewpoint } {
2172    array set view [subst {
2173        x 0
2174        y 0
2175        z 0
2176        heading 0
2177        pitch -90
2178        distance $_view(distance)
2179        srs "$_view(srs)"
2180        verticalDatum "$_view(verticalDatum)"
2181    }]
2182    array set view [$dataobj viewpoint $viewpoint]
2183    foreach key {x y z heading pitch distance srs verticalDatum} {
2184        if { [info exists view($key)] } {
2185            set _view($key) $view($key)
2186        }
2187    }
2188    # If map is projected, ignore pitch
2189    if {![MapIsGeocentric]} {
2190        set _view(pitch) -90
2191    }
2192    set duration 2.0
2193    SendCmd [list camera set $_view(x) $_view(y) $_view(z) $_view(heading) $_view(pitch) $_view(distance) $duration $_view(srs) $_view(verticalDatum)]
2194}
2195
2196itcl::body Rappture::MapViewer::GetImage { args } {
2197    if { [image width $_image(download)] > 0 &&
2198         [image height $_image(download)] > 0 } {
2199        set bytes [$_image(download) data -format "jpeg -quality 100"]
2200        set bytes [Rappture::encoding::decode -as b64 $bytes]
2201        return [list .jpg $bytes]
2202    }
2203    return ""
2204}
2205
2206itcl::body Rappture::MapViewer::BuildDownloadPopup { popup command } {
2207    Rappture::Balloon $popup \
2208        -title "[Rappture::filexfer::label downloadWord] as..."
2209    set inner [$popup component inner]
2210    label $inner.summary -text "" -anchor w
2211
2212    radiobutton $inner.image_button -text "Image File" \
2213        -variable [itcl::scope _downloadPopup(format)] \
2214        -value image
2215    Rappture::Tooltip::for $inner.image_button \
2216        "Save as digital image."
2217
2218    button $inner.ok -text "Save" \
2219        -highlightthickness 0 -pady 2 -padx 3 \
2220        -command $command \
2221        -compound left \
2222        -image [Rappture::icon download]
2223
2224    button $inner.cancel -text "Cancel" \
2225        -highlightthickness 0 -pady 2 -padx 3 \
2226        -command [list $popup deactivate] \
2227        -compound left \
2228        -image [Rappture::icon cancel]
2229
2230    blt::table $inner \
2231        0,0 $inner.summary -cspan 2  \
2232        2,0 $inner.image_button -anchor w -cspan 2 -padx { 4 0 } \
2233        4,1 $inner.cancel -width .9i -fill y \
2234        4,0 $inner.ok -padx 2 -width .9i -fill y
2235    blt::table configure $inner r3 -height 4
2236    blt::table configure $inner r4 -pady 4
2237    raise $inner.image_button
2238    $inner.image_button invoke
2239    return $inner
2240}
2241
2242itcl::body Rappture::MapViewer::ToggleGrid {} {
2243    set _settings(grid) [expr !$_settings(grid)]
2244    AdjustSetting grid
2245}
2246
2247itcl::body Rappture::MapViewer::ToggleLighting {} {
2248    set _settings(terrain-lighting) [expr !$_settings(terrain-lighting)]
2249    AdjustSetting terrain-lighting
2250}
2251
2252itcl::body Rappture::MapViewer::ToggleWireframe {} {
2253    set _settings(terrain-wireframe) [expr !$_settings(terrain-wireframe)]
2254    AdjustSetting terrain-wireframe
2255}
2256
2257itcl::body Rappture::MapViewer::SetTerrainStyle { style } {
2258    array set settings {
2259        -color white
2260        -edgecolor black
2261        -edges 0
2262        -lighting 0
2263        -linewidth 1.0
2264        -vertscale 1.0
2265        -wireframe 0
2266    }
2267    array set settings $style
2268
2269    SendCmd "map terrain edges $settings(-edges)"
2270    set _settings(terrain-edges) $settings(-edges)
2271    SendCmd "map terrain color [Color2RGB $settings(-color)]"
2272    #SendCmd "map terrain colormode constant"
2273    SendCmd "map terrain lighting $settings(-lighting)"
2274    set _settings(terrain-lighting) $settings(-lighting)
2275    SendCmd "map terrain linecolor [Color2RGB $settings(-edgecolor)]"
2276    #SendCmd "map terrain linewidth $settings(-linewidth)"
2277    SendCmd "map terrain vertscale $settings(-vertscale)"
2278    set _settings(terrain-vertscale) $settings(-vertscale)
2279    SendCmd "map terrain wireframe $settings(-wireframe)"
2280    set _settings(terrain-wireframe) $settings(-wireframe)
2281}
2282
2283itcl::body Rappture::MapViewer::SetLayerStyle { dataobj layer } {
2284    array set info [$dataobj layer $layer]
2285    set _visibility($layer) 1
2286
2287    switch -- $info(type) {
2288        "image" {
2289            array set settings {
2290                -minlevel 0
2291                -maxlevel 23
2292                -opacity 1.0
2293            }
2294            if { [info exists info(style)] } {
2295                array set settings $info(style)
2296            }
2297            if { [info exists info(opacity)] } {
2298                set settings(-opacity) $info(opacity)
2299                set _opacity($layer) $info(opacity)
2300            }
2301            set _opacity($layer) [expr $settings(-opacity) * 100]
2302            if {!$_sendEarthFile} {
2303                switch -- $info(driver)  {
2304                    "colorramp" {
2305                        set cmapName $layer
2306                        SendCmd [list colormap define $cmapName $info(colorramp.colormap)]
2307                        SendCmd [list map layer add $layer image colorramp \
2308                                     $info(colorramp.url) $info(cache) $info(colorramp.elevdriver) $info(profile)  \
2309                                     $cmapName]
2310                    }
2311                    "debug" {
2312                        SendCmd [list map layer add $layer image debug]
2313                    }
2314                    "gdal" {
2315                        SendCmd [list map layer add $layer image gdal \
2316                                     $info(gdal.url) $info(cache)]
2317                    }
2318                    "tms" {
2319                        SendCmd [list map layer add $layer image tms \
2320                                     $info(tms.url) $info(cache)]
2321                    }
2322                    "wms" {
2323                        SendCmd [list map layer add $layer image wms \
2324                                     $info(wms.url) $info(cache) \
2325                                     $info(wms.layers) \
2326                                     $info(wms.format) \
2327                                     $info(wms.transparent)]
2328                    }
2329                    "xyz" {
2330                        SendCmd [list map layer add $layer image xyz \
2331                                     $info(xyz.url) $info(cache)]
2332                    }
2333                }
2334            }
2335            SendCmd "map layer opacity $settings(-opacity) $layer"
2336        }
2337        "elevation" {
2338            array set settings {
2339                -minlevel 0
2340                -maxlevel 23
2341            }
2342            if { [info exists info(style)] } {
2343                array set settings $info(style)
2344            }
2345            if {!$_sendEarthFile} {
2346                switch -- $info(driver)  {
2347                    "gdal" {
2348                        SendCmd [list map layer add $layer elevation gdal \
2349                                     $info(gdal.url)]
2350                    }
2351                    "tms" {
2352                        SendCmd [list map layer add $layer elevation tms \
2353                                     $info(tms.url)]
2354                    }
2355                }
2356            }
2357        }
2358        "line" {
2359            array set settings {
2360                -color black
2361                -minbias 1000
2362                -opacity 1.0
2363                -width 1
2364            }
2365            if { [info exists info(style)] } {
2366                array set settings $info(style)
2367            }
2368            if { [info exists info(opacity)] } {
2369                set settings(-opacity) $info(opacity)
2370            }
2371            set _opacity($layer) [expr $settings(-opacity) * 100]
2372            foreach {r g b} [Color2RGB $settings(-color)] {}
2373            if {[info exists settings(-minrange)] && [info exists settings(-maxrange)]} {
2374                SendCmd [list map layer add $layer line $info(ogr.url) $r $g $b $settings(-width) $settings(-minrange) $settings(-maxrange)]
2375            } else {
2376                SendCmd [list map layer add $layer line $info(ogr.url) $r $g $b $settings(-width)]
2377            }
2378            SendCmd "map layer opacity $settings(-opacity) $layer"
2379        }
2380        "point" {
2381            array set settings {
2382                -color black
2383                -minbias 1000
2384                -opacity 1.0
2385                -size 1
2386            }
2387            if { [info exists info(style)] } {
2388                array set settings $info(style)
2389            }
2390            if { [info exists info(opacity)] } {
2391                set settings(-opacity) $info(opacity)
2392            }
2393            set _opacity($layer) [expr $settings(-opacity) * 100]
2394            foreach {r g b} [Color2RGB $settings(-color)] {}
2395            SendCmd [list map layer add $layer point $info(ogr.url) $r $g $b $settings(-size)]
2396            SendCmd "map layer opacity $settings(-opacity) $layer"
2397        }
2398        "polygon" {
2399            array set settings {
2400                -color white
2401                -minbias 1000
2402                -opacity 1.0
2403            }
2404            if { [info exists info(style)] } {
2405                array set settings $info(style)
2406            }
2407            if { [info exists info(opacity)] } {
2408                set settings(-opacity) $info(opacity)
2409            }
2410            set _opacity($layer) [expr $settings(-opacity) * 100]
2411            foreach {r g b} [Color2RGB $settings(-color)] {}
2412            SendCmd [list map layer add $layer polygon $info(ogr.url) $r $g $b]
2413            SendCmd "map layer opacity $settings(-opacity) $layer"
2414        }
2415        "label" {
2416            array set settings {
2417                -align "center-center"
2418                -color black
2419                -declutter 1
2420                -font Arial
2421                -fontsize 16.0
2422                -halocolor white
2423                -halowidth 2.0
2424                -layout "left-to-right"
2425                -minbias 1000
2426                -opacity 1.0
2427                -removedupes 1
2428            }
2429            if { [info exists info(style)] } {
2430                array set settings $info(style)
2431            }
2432            if { [info exists info(opacity)] } {
2433                set settings(-opacity) $info(opacity)
2434            }
2435            set _opacity($layer) [expr $settings(-opacity) * 100]
2436            set contentExpr $info(content)
2437            if {[info exists info(priority)]} {
2438                set priorityExpr $info(priority)
2439            } else {
2440                set priorityExpr ""
2441            }
2442            foreach {fgR fgG fgB} [Color2RGB $settings(-color)] {}
2443            foreach {bgR bgG bgB} [Color2RGB $settings(-halocolor)] {}
2444            if {[info exists settings(-minrange)] && [info exists settings(-maxrange)]} {
2445                SendCmd [list map layer add $layer text $info(ogr.url) $contentExpr $priorityExpr $fgR $fgG $fgB $bgR $bgG $bgB $settings(-halowidth) $settings(-fontsize) $settings(-removedupes) $settings(-declutter) $settings(-minrange) $settings(-maxrange)]
2446            } else {
2447                SendCmd [list map layer add $layer text $info(ogr.url) $contentExpr $priorityExpr $fgR $fgG $fgB $bgR $bgG $bgB $settings(-halowidth) $settings(-fontsize) $settings(-removedupes) $settings(-declutter)]
2448            }
2449            SendCmd "map layer opacity $settings(-opacity) $layer"
2450        }
2451    }
2452
2453    if { [info exists info(visible)] } {
2454        if { !$info(visible) } {
2455            set _visibility($layer) 0
2456            SendCmd "map layer visible 0 $layer"
2457        }
2458    }
2459}
2460
2461itcl::body Rappture::MapViewer::SetLayerOpacity { dataobj layer {value 100}} {
2462    set val $_opacity($layer)
2463    set sval [expr { 0.01 * double($val) }]
2464    SendCmd "map layer opacity $sval $layer"
2465}
2466
2467itcl::body Rappture::MapViewer::SetLayerVisibility { dataobj layer } {
2468    set bool $_visibility($layer)
2469    SendCmd "map layer visible $bool $layer"
2470}
2471
2472itcl::body Rappture::MapViewer::UpdateLayerControls {} {
2473    set row 0
2474    set inner $_layersFrame
2475    if { [winfo exists $inner.layers] } {
2476        foreach w [winfo children $inner.layers] {
2477            destroy $w
2478        }
2479    }
2480    set f $inner.layers
2481    set attrib [list]
2482    set imgIdx 0
2483    foreach dataobj [get -objects] {
2484        foreach layer [$dataobj layers] {
2485            array unset info
2486            array set info [$dataobj layer $layer]
2487            checkbutton $f.${layer}_visible \
2488                -text $info(label) \
2489                -font "Arial 9" -anchor w \
2490                -variable [itcl::scope _visibility($layer)] \
2491                -command [itcl::code $this \
2492                              SetLayerVisibility $dataobj $layer]
2493            blt::table $f $row,0 $f.${layer}_visible -anchor w -pady 2 -cspan 2
2494            incr row
2495            if { $info(type) == "image" } {
2496                incr imgIdx
2497                if { $info(driver) == "colorramp" } {
2498                    set colormap $layer
2499                    if { ![info exists _image(legend-$colormap)] } {
2500                        set _image(legend-$colormap) [image create photo]
2501                    }
2502                    itk_component add legend-$colormap-min {
2503                        label $f.${layer}_legend-$colormap-min -text 0
2504                    }
2505                    itk_component add legend-$colormap-max {
2506                        label $f.${layer}_legend-$colormap-max -text 1
2507                    }
2508                    itk_component add legend-$colormap {
2509                        label $f.${layer}_legend-$colormap -image $_image(legend-$colormap)
2510                    }
2511                    blt::table $f $row,0 $f.${layer}_legend-$colormap-min -anchor w -pady 0
2512                    blt::table $f $row,1 $f.${layer}_legend-$colormap-max -anchor e -pady 0
2513                    incr row
2514                    blt::table $f $row,0 $f.${layer}_legend-$colormap -anchor w -pady 2 -cspan 2
2515                    incr row
2516                    RequestLegend $colormap 256 16
2517                }
2518            }
2519            if { $info(type) != "elevation" && ($info(type) != "image" || $imgIdx > 1) } {
2520                label $f.${layer}_opacity_l -text "Opacity" -font "Arial 9"
2521                ::scale $f.${layer}_opacity -from 0 -to 100 \
2522                    -orient horizontal -showvalue off \
2523                    -variable [itcl::scope _opacity($layer)] \
2524                    -width 10 \
2525                    -command [itcl::code $this \
2526                                  SetLayerOpacity $dataobj $layer]
2527                Rappture::Tooltip::for $f.${layer}_opacity "Set opacity of $info(label) layer"
2528                blt::table $f $row,0 $f.${layer}_opacity_l -anchor w -pady 2
2529                blt::table $f $row,1 $f.${layer}_opacity -anchor w -pady 2
2530                incr row
2531            }
2532            set tooltip [list $info(description)]
2533            if { [info exists info(attribution)] &&
2534                 $info(attribution) != ""} {
2535                lappend tooltip $info(attribution)
2536            }
2537            Rappture::Tooltip::for $f.${layer}_visible [join $tooltip \n]
2538        }
2539        set mapAttrib [$dataobj hints "attribution"]
2540        if { $mapAttrib != "" } {
2541            lappend attrib $mapAttrib
2542        }
2543    }
2544    SendCmd "[list map attrib [encoding convertto utf-8 [join $attrib ,]]]"
2545    label $f.map_attrib -text [join $attrib \n] -font "Arial 9"
2546    blt::table $f $row,0 $f.map_attrib -anchor sw -pady 2 -cspan 2
2547    #incr row
2548    if { $row > 0 } {
2549        blt::table configure $f r* c* -resize none
2550        blt::table configure $f r$row c1 -resize expand
2551    }
2552}
2553
2554itcl::body Rappture::MapViewer::UpdateViewpointControls {} {
2555    set row 0
2556    set inner $_viewpointsFrame
2557    if { [winfo exists $inner.viewpoints] } {
2558        foreach w [winfo children $inner.viewpoints] {
2559            destroy $w
2560        }
2561    }
2562    set f $inner.viewpoints
2563    foreach dataobj [get -objects] {
2564        foreach viewpoint [$dataobj viewpoints] {
2565            array unset info
2566            array set info [$dataobj viewpoint $viewpoint]
2567            button $f.${viewpoint}_go \
2568                -relief flat -compound left \
2569                -image [Rappture::icon placemark16] \
2570                -text $info(label) \
2571                -font "Arial 9" -anchor w \
2572                -command [itcl::code $this \
2573                              GoToViewpoint $dataobj $viewpoint]
2574            label $f.${viewpoint}_label \
2575                -text $info(label) \
2576                -font "Arial 9" -anchor w
2577            blt::table $f $row,0 $f.${viewpoint}_go -anchor w -pady 2 -cspan 2
2578            #blt::table $f $row,1 $f.${viewpoint}_label -anchor w -pady 2
2579            Rappture::Tooltip::for $f.${viewpoint}_go $info(description)
2580            incr row
2581        }
2582    }
2583    if { $row > 0 } {
2584        blt::table configure $f r* c* -resize none
2585        blt::table configure $f r$row c1 -resize expand
2586    }
2587}
2588
2589#
2590# Generate an OSG Earth file to send to server.  This is inteneded
2591# as a stopgap and testing tool until the protocol is fleshed out.
2592#
2593# Note that the lighting settings are required to be "hard-coded"
2594# as below for the runtime control to work.  Don't make those user
2595# configurable.
2596#
2597# Also note: Use "true"/"false" for boolean settings.  Not sure if
2598# the parser in OSG Earth accepts all of Tcl's forms of boolean vals.
2599#
2600itcl::body Rappture::MapViewer::EarthFile {} {
2601    append out "<map"
2602    append out " name=\"$_mapsettings(label)\""
2603    append out " type=\"$_mapsettings(type)\""
2604    append out " version=\"2\""
2605    append out ">\n"
2606    append out " <options lighting=\"true\">\n"
2607    # FIXME: convert color setting to hex
2608    # array set style $_mapsettings(style)
2609    # if {[info exists style(-color)]} {
2610    #     set color "?"
2611    # }
2612    set color "#ffffffff"
2613    append out "  <terrain lighting=\"false\" color=\"$color\"/>\n"
2614    if { [info exists _mapsettings(projection)] } {
2615        append out "  <profile"
2616        append out " srs=\"$_mapsettings(projection)\""
2617        if { [info exists _mapsettings(extents)] } {
2618            append out " xmin=\"$_mapsettings(x1)\""
2619            append out " ymin=\"$_mapsettings(y1)\""
2620            append out " xmax=\"$_mapsettings(x2)\""
2621            append out " ymax=\"$_mapsettings(y2)\""
2622        }
2623        append out "/>\n"
2624    }
2625    append out " </options>\n"
2626
2627    foreach dataobj [get -objects] {
2628        foreach layer [$dataobj layers] {
2629            set _layers($layer) 1
2630            array unset info
2631            array set info [$dataobj layer $layer]
2632            switch -- $info(type) {
2633                "image" {
2634                    append out " <image"
2635                    append out " name=\"$layer\""
2636                    append out " driver=\"gdal\""
2637                    if { [info exists info(opacity)] } {
2638                        append out " opacity=\"$info(opacity)\""
2639                    }
2640                    if { $info(visible) } {
2641                        append out " visible=\"true\""
2642                    } else {
2643                        append out " visible=\"false\""
2644                    }
2645                    append out ">\n"
2646                    append out "  <url>$info(url)</url>\n"
2647                    append out " </image>\n"
2648                }
2649                "elevation" {
2650                    append out " <elevation"
2651                    append out " name=\"$layer\""
2652                    append out " driver=\"gdal\""
2653                    if { $info(visible) } {
2654                        append out " visible=\"true\""
2655                    } else {
2656                        append out " visible=\"false\""
2657                    }
2658                    append out ">\n"
2659                    append out "  <url>$info(url)</url>\n"
2660                    append out " </elevation>\n"
2661                }
2662                default {
2663                    puts stderr "Type $info(type) not implemented in MapViewer::EarthFile"
2664                }
2665            }
2666        }
2667    }
2668    append out "</map>\n"
2669    return $out
2670}
Note: See TracBrowser for help on using the repository browser.