Commit 36a5b36e authored by Steffen Michels's avatar Steffen Michels Committed by Bas Lijnse

Leaflet: add circle/rectangle & editable objects

parent d18c0bfa
......@@ -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
......@@ -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
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment