Commit c2766121 authored by Steffen Michels's avatar Steffen Michels

Merge branch 'leaflet-zoom-to-area' into 'master'

FitToBounds perspective for leaflet maps

Closes #381

See merge request !441
parents ef729b48 e34c9983
Pipeline #44407 passed with stage
in 8 minutes and 40 seconds
......@@ -69,7 +69,7 @@ toLeafletMap :: ContactMap -> LeafletMap
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
fromLeafletMap :: ContactMap LeafletMap -> ContactMap
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
perspectiveFromLeafletMap :: LeafletMap -> ContactMapPerspective
selectionFromLeafletMap :: LeafletMap -> [LeafletObjectID]
......
......@@ -133,7 +133,8 @@ hasLatLng _ = False
toLeafletMap :: ContactMap -> LeafletMap
toLeafletMap {ContactMap|perspective,layers}
= {LeafletMap|perspective = toLeafletPerspective perspective
= {LeafletMap|defaultValue
&perspective = toLeafletPerspective perspective
,tilesUrls = tilesUrls layers
,icons = shipIcons
,objects = []
......@@ -182,8 +183,8 @@ where
*/
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
toLeafletPerspective {ContactMapPerspective|center,zoom,cursor,bounds}
= {LeafletPerspective|center=toLeafletLatLng center,zoom=zoom,bounds=fmap toLeafletBounds bounds}
toLeafletPerspective {ContactMapPerspective|center,zoom}
= CenterAndZoom (toLeafletLatLng center) zoom
toLeafletLatLng :: !(!Real,!Real) -> LeafletLatLng
toLeafletLatLng (lat,lng) = {LeafletLatLng|lat=lat,lng=lng}
......@@ -194,13 +195,13 @@ toLeafletBounds (sw,ne) = {LeafletBounds|southWest=toLeafletLatLng sw,northEast=
fromLeafletMap :: ContactMap LeafletMap -> ContactMap
fromLeafletMap contactMap leafletMap
= {ContactMap|contactMap
&perspective = fromLeafletPerspective leafletMap.LeafletMap.perspective
&perspective = perspectiveFromLeafletMap leafletMap
/*,layers = [fromLeafletLayer cl ll \\ cl <- contactMap.ContactMap.layers & ll <- leafletMap.LeafletMap.layers]*/
}
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
fromLeafletPerspective {LeafletPerspective|center,zoom,bounds}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=Nothing,bounds=fmap fromLeafletBounds bounds}
perspectiveFromLeafletMap :: LeafletMap -> ContactMapPerspective
perspectiveFromLeafletMap {LeafletMap|center,zoom,bounds}
= {ContactMapPerspective|center=fromLeafletLatLng (fromJust center),zoom=fromJust zoom,cursor=Nothing,bounds=fmap fromLeafletBounds bounds}
/*
fromLeafletLayer :: ContactMapLayer LeafletLayer -> ContactMapLayer
......
......@@ -36,8 +36,8 @@ where
where
toMap baseLayers (perspective,contacts)
= toLeafletMap {ContactMap| perspective = perspective, layers = baseLayers ++ [{title="Contacts",def=CMMarkersLayer [contactGeoToMapMarker False False c \\ c=:{ContactGeo|position=Just _} <- contacts]}]}
fromMap _ {LeafletMap|perspective}
= fromLeafletPerspective perspective
fromMap _ map
= perspectiveFromLeafletMap map
configure "Incident"
= Title title @>> enterChoiceWithSharedAs [ChooseFromList bigLabel] allIncidentsShort (\{IncidentShort|incidentNo} -> WallIncidentSummary (Just incidentNo))
configure "Contact"
......
......@@ -596,8 +596,8 @@ where
toPrj baseLayers (contacts,sel,perspective)
= toLeafletMap {ContactMap|perspective=perspective,layers=[{title="Contacts",def=CMMarkersLayer (toMarkers sel contacts)}:baseLayers]}
fromPrj (contacts,sel,_) map=:{LeafletMap|perspective}
= (maybe sel Just (updateSelection (selectionFromLeafletMap map)),fromLeafletPerspective perspective)
fromPrj (contacts,sel,_) map
= (maybe sel Just (updateSelection (selectionFromLeafletMap map)),perspectiveFromLeafletMap map)
selection (Value (Just no,_) stable) = Value no stable
selection _ = NoValue
......
......@@ -232,7 +232,7 @@ where
\perspective -> (Title "Preview" @>> updateSharedInformation [UpdateSharedAs toPrj fromPrj (const o Just)] (perspective >*| standardMapLayers)) <<@ ApplyLayout flexMap @ fst
where
toPrj (perspective,layers) = toLeafletMap {ContactMap|defaultValue & perspective=perspective,layers=layers}
fromPrj _ {LeafletMap|perspective} = fromLeafletPerspective perspective
fromPrj _ map = perspectiveFromLeafletMap map
flexMap = layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))
configureWebLinks :: Task ()
......
......@@ -11,6 +11,7 @@ import qualified Data.IntMap.Strict as DIS
import qualified Data.Map as DM
import Data.Map.GenJSON
import qualified Data.Set as DS
import Data.Set.GenJSON
import Text.HTML
import Data.Functor
......@@ -25,11 +26,6 @@ derive class iTask ObjectType, ActorStatus, Availability, ActorHealth, ActorEner
derive class iTask Cable, Priority, Network, Device, CableType, DeviceKind, CommandAim, Capability, CapabilityExpr
derive gHash Capability
derive gEditor Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
// std overloading instances
//instance == Object where (==) o1 o2 = o1 === o2
......
......@@ -56,7 +56,7 @@ toLeafletMap :: ContactMap -> LeafletMap
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
fromLeafletMap :: LeafletMap -> ContactMap
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
perspectiveFromLeafletMap :: LeafletMap -> ContactMapPerspective
derive class iTask ContactMap, ContactMapMarker, ContactMapMarkerType
derive JSONEncode ContactMapPerspective
......
......@@ -109,7 +109,8 @@ cat _ = 0
toLeafletMap :: ContactMap -> LeafletMap
toLeafletMap {ContactMap|perspective,markers}
= {LeafletMap|perspective = toLeafletPerspective perspective
= {LeafletMap|defaultValue
&perspective = toLeafletPerspective perspective
,icons = [icon i \\ i <- [1..250]]
,tilesUrls = [{url = TILESERVER, attribution = Nothing}]
,objects = convMarkers markers //Just the baselayer
......@@ -123,8 +124,8 @@ where
iconIndex heading type selected = toString (cat type + ( (maybe 24 (\d -> toInt d / 15) heading) + (if selected 25 0)) * 5)
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
toLeafletPerspective {ContactMapPerspective|center,zoom,cursor}
= {LeafletPerspective|center=toLeafletLatLng center,zoom=zoom,bounds=Nothing}
toLeafletPerspective {ContactMapPerspective|center,zoom}
= CenterAndZoom (toLeafletLatLng center) zoom
toLeafletLatLng :: !LatLng -> LeafletLatLng
toLeafletLatLng (lat,lng) = {LeafletLatLng | lat = toDeg lat, lng = toDeg lng}
......@@ -133,16 +134,14 @@ fromLeafletLatLng :: !LeafletLatLng -> LatLng
fromLeafletLatLng {LeafletLatLng | lat, lng} = (deg lat, deg lng)
fromLeafletMap :: LeafletMap -> ContactMap
fromLeafletMap {LeafletMap|perspective,objects}
= {ContactMap|perspective = fromLeafletPerspective perspective
fromLeafletMap map=:{LeafletMap|objects}
= {ContactMap|perspective = perspectiveFromLeafletMap map
,markers=toMarkers objects}
where
toMarkers objects
= [{ContactMapMarker|markerId=markerId,title=Nothing,position = fromLeafletLatLng position, type=Nothing,heading=Nothing,selected=False}
\\ Marker {LeafletMarker|markerId = LeafletObjectID markerId,position} <- objects]
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
fromLeafletPerspective {LeafletPerspective|center,zoom}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=Nothing}
perspectiveFromLeafletMap :: LeafletMap -> ContactMapPerspective
perspectiveFromLeafletMap {LeafletMap|center,zoom}
= {ContactMapPerspective|center=fromLeafletLatLng (fromJust center),zoom=fromJust zoom,cursor=Nothing}
......@@ -5,6 +5,7 @@ import C2.Framework.Entity
import C2.Apps.ShipAdventure.Scripting, C2.Apps.ShipAdventure.Core, C2.Apps.ShipAdventure.Types, C2.Apps.ShipAdventure.Images, C2.Framework.Logging
from Data.Set import :: Set
import qualified Data.Set as DS
import Data.Set.GenJSON
from Data.IntMap.Strict import instance Functor IntMap
import qualified Data.IntMap.Strict as DIS
import C2.Apps.ShipAdventure.Editor
......@@ -12,11 +13,6 @@ import C2.Apps.ShipAdventure.Types
import Data.Map.GenJSON
import Data.Functor
derive gEditor Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
dOffRegisterEntity :: [User -> Task Entity]
dOffRegisterEntity = []
......
......@@ -26,9 +26,30 @@ managePerspective :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | R
managePerspective m = Title "Perspective" @>> updateSharedInformation []
(mapReadWrite (\(x,s) -> x.LeafletMap.perspective, \p (x,s) -> Just ({x & perspective = p},s)) Nothing m) @! ()
:: ReadOnlyState =
{ bounds :: !Maybe LeafletBounds
, center :: !Maybe LeafletLatLng
, zoom :: !Maybe Int
}
derive class iTask ReadOnlyState
manageState :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manageState m = Title "State" @>> updateSharedInformation []
(mapReadWrite (\(x,s) -> s, \sn (x,s) -> Just (x,sn)) Nothing m) @! ()
manageState m = Title "State" @>>
(
viewSharedInformation []
(mapRead (readOnlyState o fst) m)
-&&-
updateSharedInformation []
(mapReadWrite (\(x,s) -> s, \sn (x,s) -> Just (x,sn)) Nothing m)
) @! ()
where
readOnlyState m =
{ ReadOnlyState
| bounds = m.LeafletMap.bounds
, center = m.LeafletMap.center
, zoom = m.LeafletMap.zoom
}
// objects can currently only be viewed, as the editor for `HtmlTag` only works in view mode
manageMapObjects :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
......@@ -100,7 +121,7 @@ where
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},s) -> ({LeafletMap|l & objects = withRectangleAroundCurrentPerspective bounds objects},s)) m
= upd (\(l=:{LeafletMap|bounds,objects},s) -> ({LeafletMap|l & objects = withRectangleAroundCurrentPerspective bounds objects},s)) m
where
withRectangleAroundCurrentPerspective Nothing objects = objects
withRectangleAroundCurrentPerspective (Just bounds) objects = objects ++ [Rectangle {rectangleId = LeafletObjectID "RECT_PERSPECTIVE", bounds = bounds, editable = True, style = []}]
......
......@@ -23,17 +23,37 @@ customLeafletEditor :: !MapOptions !(LeafletEventHandlers s) s -> Editor (Leafle
}
:: LeafletMap =
{ perspective :: !LeafletPerspective
, tilesUrls :: ![TileLayer]
, objects :: ![LeafletObject] //Markers, lines and polygon
, icons :: ![LeafletIcon] //Custom icons used by markers. They are referenced using their 'iconId' string.
}
{ perspective :: !LeafletPerspective //* How the map should decide what should be in view
, bounds :: !Maybe LeafletBounds //* The actual bounds of the map (updated by the client; writes are ignored)
, center :: !Maybe LeafletLatLng //* The actual center of the map (updated by the client; writes are ignored)
, zoom :: !Maybe Int //* The actual zoom level of the map (updated by the client; writes are ignored)
, tilesUrls :: ![TileLayer]
, objects :: ![LeafletObject] //* Markers, lines and polygon
, icons :: ![LeafletIcon] //* Custom icons used by markers. They are referenced using their 'iconId' string.
}
:: LeafletPerspective =
{ center :: !LeafletLatLng
, zoom :: !Int
, bounds :: !Maybe LeafletBounds
}
/**
* This type describes how the application prefers the map to be drawn.
*
* When the perspective is `FitToBounds`, a view is automatically computed such
* that all objects are visible.
*
* `CenterAndZoom` simply sets the center coordinate and zoom level.
*
* 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`. The second argument of
* `FitToBounds` can be used to filter the objects that must be in view.
*/
:: LeafletPerspective
= CenterAndZoom !LeafletLatLng !Int
| FitToBounds !FitToBoundsOptions !(Maybe (Set LeafletObjectID))
:: FitToBoundsOptions =
{ padding :: !(!Int, !Int) //* The horizontal and vertical padding in pixels
, maxZoom :: !Int //* The maximum zoom level
}
:: TileLayer = {url :: !String, attribution :: !Maybe HtmlTag}
......@@ -63,6 +83,8 @@ customLeafletEditor :: !MapOptions !(LeafletEventHandlers s) s -> Editor (Leafle
| Window !LeafletWindow
leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
leafletPointsOf :: !LeafletObject -> [LeafletLatLng]
leafletBoundingRectangleOf :: ![LeafletObject] -> LeafletBounds
:: LeafletObjectID =: LeafletObjectID String
:: LeafletMarker =
......@@ -158,10 +180,12 @@ openStreetMapTiles :: TileLayer
instance == LeafletObjectID
instance == LeafletIconID
derive JSONEncode LeafletMap, LeafletPerspective, LeafletLatLng
derive JSONDecode LeafletMap, LeafletPerspective, LeafletLatLng
derive gDefault LeafletMap, LeafletPerspective, LeafletLatLng
derive gEq LeafletMap, LeafletPerspective
derive gText LeafletMap, LeafletPerspective, LeafletLatLng
derive gEditor LeafletMap, LeafletPerspective, LeafletLatLng
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
This diff is collapsed.
......@@ -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
......
......@@ -2,7 +2,7 @@ module TestLeafletResize
import iTasks
import iTasks.Extensions.GIS.Leaflet
test = ((Hint "Map resizing" @>> viewInformation [] {LeafletMap|perspective=defaultValue,objects=objects,tilesUrls=[],icons=[]}) <<@ FlexInner <<@ AddCSSClass "itasks-flex-height")
test = ((Hint "Map resizing" @>> viewInformation [] {LeafletMap|defaultValue&perspective=defaultValue,objects=objects,tilesUrls=[],icons=[]}) <<@ FlexInner <<@ AddCSSClass "itasks-flex-height")
-|| ((Hint "List to force resizing" @>> updateInformation [] [1,2,3,4]) <<@ AddCSSClass "itasks-wrap-height")
where
......
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