Leaflet: add circle/rectangle & editable objects

Examples/GIS/LeafletMapExample.icl

@@ -19,13 +19,13 @@ manipulateMap m = updateSharedInformation () [] m
 managePerspective :: (Shared sds LeafletMap) -> Task () | RWShared sds
 managePerspective m = updateSharedInformation (Title "Perspective") [] (mapReadWrite (\x -> x.LeafletMap.perspective,\p x -> Just {x & perspective = p}) Nothing m)  @! ()
 
+// objects can currently only be viewed, as the editor for `HtmlTag` only works in view mode
 manageMapObjects :: (Shared sds LeafletMap) -> Task () | RWShared sds
-manageMapObjects m = updateSharedInformation (Title "Manage objects") [UpdateAs toPrj fromPrj] m
+manageMapObjects m = viewSharedInformation (Title "View objects") [ViewAs toPrj] m
 				   -|| addDemoObjects m
 				   @! ()
 where
 	toPrj m = m.LeafletMap.objects
-	fromPrj m objects = {m & objects = objects}
 
 	addDemoObjects m
 		= enterChoiceAs "Add objects:" [ChooseFromCheckGroup fst] options snd
@@ -36,6 +36,8 @@ where
 			,("Marker at cursor position",addMarkerAtCursor m)
 			,("Line connecting current markers",addMarkerConnectingLine m)
 			,("Polygon from current markers",addMarkerConnectingPolygon m)
+			,("Circle at cursor position",addCircleAtCursor m)
+			,("Rectangle around current perspective",addRectangleAroundCurrentPerspective m)
 			]
 
 	addRandomMarker m
@@ -56,6 +58,7 @@ where
 		line objects = Polyline { polylineId = LeafletObjectID "markerConnection"
                                 , style      = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)]
                                 , points     = points objects
+                                , editable   = True
                                 }
 		points objects = [position \\ Marker {LeafletMarker|position} <- objects]
 
@@ -63,11 +66,12 @@ where
 		= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [polygon objects]}) m
 	where
 		polygon objects = Polygon { polygonId = LeafletObjectID "markerConnection"
-                                  , style     = [ Style (PolygonLineStrokeColor "#000")
-                                                , Style (PolygonLineStrokeWidth 2)
-                                                , Style (PolygonFillColor "#0f0")
+                                  , style     = [ Style (AreaLineStrokeColor "#000")
+                                                , Style (AreaLineStrokeWidth 2)
+                                                , Style (AreaFillColor "#0f0")
                                                 ]
                                   , points    = points objects
+                                  , editable  = True
                                   }
 		points objects = [position \\ Marker {LeafletMarker|position} <- objects]
 
@@ -77,4 +81,16 @@ where
 		withMarkerFromCursor Nothing objects = objects
 		withMarkerFromCursor (Just position) objects = objects ++ [Marker {markerId = LeafletObjectID "CURSOR", position= position, title = Nothing, icon = Nothing, selected = False, popup = Nothing}]
 
+	addCircleAtCursor m
+		= upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withCircleFromCursor cursor objects}) m
+	where
+		withCircleFromCursor Nothing objects = objects
+		withCircleFromCursor (Just position) objects = objects ++ [Circle {circleId = LeafletObjectID "CIRCLE_CURSOR", center = position, radius = 100000.0, editable = True, style = []}]
+
+	addRectangleAroundCurrentPerspective m
+		= upd (\l=:{LeafletMap|perspective={LeafletPerspective|bounds},objects} -> {LeafletMap|l & objects = withRectangleAroundCurrentPerspective bounds objects}) m
+	where
+		withRectangleAroundCurrentPerspective Nothing objects = objects
+		withRectangleAroundCurrentPerspective (Just bounds) objects = objects ++ [Rectangle {rectangleId = LeafletObjectID "RECT_PERSPECTIVE", bounds = bounds, editable = True, style = []}]
+
 Start world = doTasks playWithMaps world

Libraries/iTasks/Extensions/GIS/Leaflet.dcl

@@ -36,10 +36,14 @@ leafletEditor :: Editor LeafletMap
     }
 
 :: LeafletObject
-    = Marker   !LeafletMarker
-    | Polyline !LeafletPolyline
-    | Polygon  !LeafletPolygon
-    | Window   !LeafletWindow
+    = Marker    !LeafletMarker
+    | Polyline  !LeafletPolyline
+    | Polygon   !LeafletPolygon
+    | Circle    !LeafletCircle
+    | Rectangle !LeafletRectangle
+    | Window    !LeafletWindow
+
+leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
 
 :: LeafletObjectID =: LeafletObjectID String
 :: LeafletMarker =
@@ -55,12 +59,29 @@ leafletEditor :: Editor LeafletMap
     { polylineId    :: !LeafletObjectID
     , points        :: ![LeafletLatLng]
     , style         :: ![LeafletStyleDef LeafletLineStyle]
+    , editable      :: !Bool
     }
 
 :: LeafletPolygon =
     { polygonId     :: !LeafletObjectID
     , points        :: ![LeafletLatLng]
-    , style         :: ![LeafletStyleDef LeafletPolygonStyle]
+    , style         :: ![LeafletStyleDef LeafletAreaStyle]
+    , editable      :: !Bool
+    }
+
+:: LeafletCircle =
+    { circleId :: !LeafletObjectID
+    , center   :: !LeafletLatLng
+    , radius   :: !Real            //* the radius (in meters)
+    , style    :: ![LeafletStyleDef LeafletAreaStyle]
+    , editable :: !Bool
+    }
+
+:: LeafletRectangle =
+    { rectangleId   :: !LeafletObjectID
+    , bounds        :: !LeafletBounds
+    , style         :: ![LeafletStyleDef LeafletAreaStyle]
+    , editable      :: !Bool
     }
 
 :: LeafletWindow =
@@ -77,13 +98,13 @@ leafletEditor :: Editor LeafletMap
                        | LineOpacity     !Real   // between 0.0 and 1.0
                        | LineDashArray   !String // a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
 
-:: LeafletPolygonStyle = PolygonLineStrokeColor !String // html/css color definition
-                       | PolygonLineStrokeWidth !Int
-                       | PolygonLineOpacity     !Real   // between 0.0 and 1.0
-                       | PolygonLineDashArray   !String // a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
-                       | PolygonNoFill                  // inside of polygone is not filled, all other fill options are ignored
-                       | PolygonFillColor       !String // html/css color definition
-                       | PolygonFillOpacity     !Real
+:: LeafletAreaStyle = AreaLineStrokeColor !String // html/css color definition
+                    | AreaLineStrokeWidth !Int
+                    | AreaLineOpacity     !Real   // between 0.0 and 1.0
+                    | AreaLineDashArray   !String // a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
+                    | AreaNoFill                  // inside of polygone is not filled, all other fill options are ignored
+                    | AreaFillColor       !String // html/css color definition
+                    | AreaFillOpacity     !Real
 
 :: CSSClass =: CSSClass String
 :: LeafletStyleDef style = Style style
@@ -101,4 +122,4 @@ derive gDefault   LeafletMap, LeafletPerspective, LeafletLatLng
 derive gEq        LeafletMap, LeafletPerspective
 derive gText      LeafletMap, LeafletPerspective, LeafletLatLng
 derive gEditor    LeafletMap, LeafletPerspective, LeafletLatLng
-derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletPolygonStyle
+derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID