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

Last change on this file since 5950 was 5950, checked in by ldelgass, 7 years ago

Add selection callback to map viewer, make public select method notify server
of selections originating from outside the map viewer widget.

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