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

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

Support setting initial camera view by extent

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