Commit ecf76300 authored by Steffen Michels's avatar Steffen Michels

Merge branch 'add-SpecificRegion-option-for-FitToBounds-perspective-of-leaflet-maps' into 'master'

Add SpecificRegion option for FitToBounds perspective of leaflet maps

See merge request !445
parents c2766121 28debab1
Pipeline #44423 passed with stage
in 8 minutes and 56 seconds
......@@ -48,13 +48,18 @@ customLeafletEditor :: !MapOptions !(LeafletEventHandlers s) s -> Editor (Leafle
*/
:: LeafletPerspective
= CenterAndZoom !LeafletLatLng !Int
| FitToBounds !FitToBoundsOptions !(Maybe (Set LeafletObjectID))
| FitToBounds !FitToBoundsOptions !FitToBoundsRegion
:: FitToBoundsOptions =
{ padding :: !(!Int, !Int) //* The horizontal and vertical padding in pixels
, maxZoom :: !Int //* The maximum zoom level
}
:: FitToBoundsRegion
= SpecificRegion !LeafletBounds //* Fits the view to the specified bounds.
| SelectedObjects !(Set LeafletObjectID) //* Fits the view s.t. the given object IDs are visible.
| AllObjects //* Fits the view s.t. all `objects` are visible.
:: TileLayer = {url :: !String, attribution :: !Maybe HtmlTag}
:: LeafletIconID =: LeafletIconID String
......@@ -182,10 +187,15 @@ instance == LeafletIconID
instance < LeafletObjectID
derive JSONEncode LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive JSONDecode LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive gDefault LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive gEq LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive gText LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive gEditor LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID, LeafletSimpleState
derive JSONEncode LeafletMap, LeafletLatLng
derive JSONDecode LeafletMap, LeafletLatLng
derive gDefault LeafletMap, LeafletLatLng
derive gEq LeafletMap, LeafletLatLng
derive gText LeafletMap, LeafletLatLng
derive gEditor LeafletMap, LeafletLatLng
derive class iTask
LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline,
LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle,
LeafletStyleDef, LeafletAreaStyle, LeafletObjectID, CSSClass,
LeafletIconID, LeafletCircle, LeafletRectangle, LeafletSimpleState,
LeafletPerspective, FitToBoundsOptions, FitToBoundsRegion
......@@ -118,9 +118,7 @@ where
tilesUrls
)
,("icons", JSONArray [toJSON (iconId,{IconOptions|iconUrl=iconUrl,iconSize=[w,h]}) \\ {iconId,iconUrl,iconSize=(w,h)} <- icons])
:if (perspective=:FitToBounds _ _)
[("fitbounds", encodeBounds (leafletBoundingRectangleOf (filteredObjects perspective val)))]
[]
:[("fitbounds", attr) \\ attr <- fitBoundsAttribute val]
]
# attr = 'DM'.unions
[ mapAttr
......@@ -131,10 +129,6 @@ where
# children = map encodeUI objects
= (Ok (uiac UIHtmlView attr children, val), world)
filteredObjects :: !LeafletPerspective !LeafletMap -> [LeafletObject]
filteredObjects (FitToBounds _ (Just ids)) m = [o \\ o <- m.objects | 'Set'.member (leafletObjectIdOf o) ids]
filteredObjects _ m = m.objects
encodePerspective :: !LeafletPerspective -> JSONNode
encodePerspective (CenterAndZoom center zoom) = JSONArray
[ JSONString "CenterAndZoom"
......@@ -146,12 +140,6 @@ where
, toJSON options
]
encodeBounds :: !LeafletBounds -> JSONNode
encodeBounds {southWest=sw,northEast=ne} = JSONArray
[ JSONArray [JSONReal sw.lat, JSONReal sw.lng]
, JSONArray [JSONReal ne.lat, JSONReal ne.lng]
]
encodeUI (Marker o) = let (JSONObject attr) = toJSON o
dataMap = 'DM'.fromList [("type",JSONString "marker"):attr]
// translate HtmlTag of popup to HTML code
......@@ -752,9 +740,9 @@ where
# attrChanges = diffAttributes oldMap newMap
//Determine object changes
# childChanges = diffChildren oldMap.LeafletMap.objects newMap.LeafletMap.objects updateFromOldToNew encodeUI
# attrChanges = if (isEmpty childChanges || not (newMap.perspective=:FitToBounds _ _))
# attrChanges = if (isEmpty childChanges)
attrChanges
[SetAttribute "fitbounds" (encodeBounds (leafletBoundingRectangleOf (filteredObjects newMap.perspective newMap))):attrChanges]
([SetAttribute "fitbounds" attr \\ attr <- fitBoundsAttribute newMap] ++ attrChanges)
= (Ok (ChangeUI attrChanges childChanges, newMap),vst)
where
//Only center and zoom are synced to the client, bounds are only synced from client to server
......@@ -785,6 +773,20 @@ where
valueFromState m = Just m
fitBoundsAttribute :: !LeafletMap -> [JSONNode]
fitBoundsAttribute {perspective=p=:FitToBounds _ region,objects} = [encodeBounds (bounds region)]
where
bounds (SpecificRegion bounds) = bounds
bounds (SelectedObjects ids) = leafletBoundingRectangleOf [o \\ o <- objects | 'Set'.member (leafletObjectIdOf o) ids]
bounds AllObjects = leafletBoundingRectangleOf objects
encodeBounds :: !LeafletBounds -> JSONNode
encodeBounds {southWest=sw,northEast=ne} = JSONArray
[ JSONArray [JSONReal sw.lat, JSONReal sw.lng]
, JSONArray [JSONReal ne.lat, JSONReal ne.lng]
]
fitBoundsAttribute _ = []
gEditor{|LeafletMap|} = leafletEditor
gDefault{|LeafletMap|} =
......@@ -897,10 +899,16 @@ gDefault{|FitToBoundsOptions|} =
, maxZoom = 10
}
derive JSONEncode LeafletMap, LeafletPerspective, LeafletLatLng, TileLayer, FitToBoundsOptions
derive JSONDecode LeafletMap, LeafletPerspective, LeafletLatLng, TileLayer, FitToBoundsOptions
derive JSONEncode LeafletMap, LeafletLatLng, TileLayer
derive JSONDecode LeafletMap, LeafletLatLng, TileLayer
derive gDefault LeafletLatLng
derive gEq LeafletMap, LeafletPerspective, TileLayer, FitToBoundsOptions
derive gText LeafletMap, LeafletPerspective, LeafletLatLng, TileLayer, FitToBoundsOptions
derive gEditor LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletEdit, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID, CSSClass, LeafletIconID, LeafletCircle, LeafletObjectUpdate, LeafletRectangle, LeafletSimpleState
derive gEq LeafletMap, TileLayer
derive gText LeafletMap, LeafletLatLng, TileLayer
derive gEditor LeafletLatLng
derive class iTask
LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline,
LeafletPolygon, LeafletEdit, LeafletWindow, LeafletWindowPos,
LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID,
CSSClass, LeafletIconID, LeafletCircle, LeafletObjectUpdate,
LeafletRectangle, LeafletSimpleState, LeafletPerspective,
FitToBoundsOptions, FitToBoundsRegion
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