Commit da5fe78c authored by Camil Staps's avatar Camil Staps 🙂 Committed by Steffen Michels

Leaflet maps: add possibility to filter objects in view with the FitToBounds perspective

parent 246fd3ba
......@@ -43,11 +43,12 @@ customLeafletEditor :: !MapOptions !(LeafletEventHandlers s) s -> Editor (Leafle
* When the user drags or zooms the map, the perspective of a `LeafletMap` is
* reset to `CenterAndZoom`. This prevents applications from automatically
* moving the view after the user has changed it. It is of course possible to
* programmatically change it back to `FitToBounds`.
* programmatically change it back to `FitToBounds`. The second argument of
* `FitToBounds` can be used to filter the objects that must be in view.
*/
:: LeafletPerspective
= CenterAndZoom !LeafletLatLng !Int
| FitToBounds !FitToBoundsOptions
| FitToBounds !FitToBoundsOptions !(Maybe (Set LeafletObjectID))
:: FitToBoundsOptions =
{ padding :: !(!Int, !Int) //* The horizontal and vertical padding in pixels
......@@ -179,6 +180,8 @@ openStreetMapTiles :: TileLayer
instance == LeafletObjectID
instance == LeafletIconID
instance < LeafletObjectID
derive JSONEncode LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive JSONDecode LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
derive gDefault LeafletMap, LeafletPerspective, LeafletLatLng, FitToBoundsOptions
......
......@@ -4,7 +4,8 @@ import iTasks
import iTasks.UI.Definition, iTasks.UI.Editor
import StdMisc, Data.Tuple, Data.Error, Data.Func, Data.List, Text, Data.Functor
import qualified Data.Map as DM
//from Text.HTML import instance toString HtmlTag, instance toString SVGElt
import qualified Data.Set as Set
import Data.Set.GenJSON
import Text.HTML
from Text.Encodings.Base64 import base64Encode
from iTasks.UI.Editor.Common import diffChildren, :: ChildUpdate (..)
......@@ -106,7 +107,7 @@ where
fromMaybe gDefault{|*|} $ editModeValue mode
# mapAttr = 'DM'.fromList
[("perspective", encodePerspective perspective)
,("fitbounds", encodeBounds (leafletBoundingRectangleOf objects))
,("fitbounds", encodeBounds (leafletBoundingRectangleOf (filteredObjects perspective val)))
,("tilesUrls"
, JSONArray $
(\tile ->
......@@ -128,13 +129,17 @@ 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"
, JSONArray [JSONReal center.lat, JSONReal center.lng]
, JSONInt zoom
]
encodePerspective (FitToBounds options) = JSONArray
encodePerspective (FitToBounds options _) = JSONArray
[ JSONString "FitToBounds"
, toJSON options
]
......@@ -741,7 +746,7 @@ where
# childChanges = diffChildren oldMap.LeafletMap.objects newMap.LeafletMap.objects updateFromOldToNew encodeUI
# attrChanges = if (isEmpty childChanges)
attrChanges
[SetAttribute "fitbounds" (encodeBounds (leafletBoundingRectangleOf newMap.objects)):attrChanges]
[SetAttribute "fitbounds" (encodeBounds (leafletBoundingRectangleOf (filteredObjects newMap.perspective 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
......@@ -877,6 +882,8 @@ where
instance == LeafletObjectID where (==) (LeafletObjectID x) (LeafletObjectID y) = x == y
instance == LeafletIconID where (==) (LeafletIconID x) (LeafletIconID y) = x == y
instance < LeafletObjectID where (<) (LeafletObjectID x) (LeafletObjectID y) = x < y
gDefault{|FitToBoundsOptions|} =
{ padding = (100, 100)
, maxZoom = 10
......
......@@ -6,8 +6,8 @@ from Data.Queue import :: Queue
derive JSONEncode TaskWrapper, AsyncTaskResult
derive JSONDecode TaskWrapper, AsyncTaskResult
derive gEq TaskWrapper
derive gEditor TaskWrapper, Set
derive gText TaskWrapper, Set
derive gEditor TaskWrapper
derive gText TaskWrapper
derive class iTask Queue, Event, AsyncQueueItem
......
......@@ -20,8 +20,6 @@ gText{|TaskWrapper|} tf ma = maybe [] (\_->["TaskWrapper"]) ma
derive JSONEncode AsyncTaskResult
derive JSONDecode AsyncTaskResult
derive class iTask Queue, Event, AsyncQueueItem
derive gEditor Set
gText{|Set|} m tf ms = gText{|*->*|} m tf ('Data.Set'.toList <$> ms)
asyncITasksQueue :: SDSLens () () AsyncQueueItem
asyncITasksQueue = mapReadWrite (\_->(), \task queue->Just (enqueue task queue)) Nothing asyncITasksQueueInt
......
......@@ -63,7 +63,7 @@ gDefault{|TaskMeta|}
gDefault{|ExtendedTaskListFilter|} = fullExtendedTaskListFilter
derive gEq TaskChange
derive gText TaskChange, Set, ExtendedTaskListFilter
derive gText TaskChange, ExtendedTaskListFilter
instance < TaskMeta where
(<) {TaskMeta|taskId=t1} {TaskMeta|taskId=t2} = t1 < t2
......
......@@ -40,8 +40,8 @@ derive JSONEncode TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, T
derive JSONDecode TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, Timespec, ClockParameter
derive gEq TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, Timespec, ClockParameter
derive gText TaskValue, TaskListItem, TaskInstance, ValueStatus, Action
derive gEditor TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, Timespec, ClockParameter
derive gText TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, Set
derive gEditor TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, Timespec, ClockParameter, Set
derive gHash TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, Timespec, ClockParameter
derive gHash Timestamp, TaskChange, ExtendedTaskListFilter
......@@ -11,6 +11,7 @@ import iTasks.Internal.IWorld
import Data.Either
import Data.Error
import Data.Func
import Data.Functor
import qualified Data.Map as Map
import Data.Map.GenJSON
import qualified Data.Set as Set
......@@ -36,11 +37,13 @@ gHash{|Map|} fk fv map = murmurHash_combine [murmurHash_combine2 (fk k) (fv v) \
gHash{|Set|} fx xs = murmurHash_combine [fx x \\ x <- 'Set'.toList xs]
derive gHash JSONNode
gText{|Set|} m tf ms = gText{|*->*|} m tf ('Set'.toList <$> ms)
derive JSONEncode TaskValue, TaskInstance, TaskListItem, ValueStatus, Action, Timespec, ClockParameter
derive JSONDecode TaskValue, TaskInstance, TaskListItem, ValueStatus, Action, Timespec, ClockParameter
derive gEq TaskValue, TaskInstance, TaskListItem, ValueStatus, Action, Timespec, ClockParameter
derive gText TaskValue, TaskInstance, TaskListItem, ValueStatus, Action
derive gEditor TaskValue, TaskInstance, TaskListItem, ValueStatus, Action, Timespec, ClockParameter
derive gEditor TaskValue, TaskInstance, TaskListItem, ValueStatus, Action, Timespec, ClockParameter, Set
derive gHash TaskValue, TaskListItem, TaskInstance, ValueStatus, Action, Timespec, ClockParameter
derive class iTask TaskId, TaskListFilter, AttachmentStatus
......
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