Commit e463865a authored by Steffen Michels's avatar Steffen Michels
Browse files

Merge branch '285-leaflet-maps-extended-interaction-possibilities' into 'master'

Resolve "Leaflet maps: extended interaction possibilities"

Closes #285

See merge request !281
parents 41d2eb6d 950eaf60
Pipeline #26038 passed with stage
in 5 minutes and 12 seconds
......@@ -94,7 +94,7 @@ where
eqBounds _ _ = False
gDefault{|ContactMapPerspective|}
= {ContactMapPerspective|center = (52.948300, 4.776007), zoom = 7, cursor = Nothing, bounds = Nothing} //(Full coast centered on Den Helder)
= {ContactMapPerspective|center = (52.948300, 4.776007), zoom = 7, bounds = Nothing, cursor = Nothing} //(Full coast centered on Den Helder)
contactToMapMarker :: Bool Bool Contact -> ContactMapMarker
......@@ -142,8 +142,8 @@ where
tilesUrls layers = [url \\ {ContactMapLayer|def=CMTileLayer url} <- layers]
convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers | hasLatLng position]
conv {ContactMapMarker|markerId,title,position,heading,type,selected}
= Marker {LeafletMarker|markerId = markerId, title = title, position = pos position, icon = Nothing /* fmap (\t -> iconIndex heading t selected) type */, selected = selected, popup = Nothing}
conv {ContactMapMarker|markerId,title,position,heading,type}
= Marker {LeafletMarker|markerId = markerId, title = title, position = pos position, icon = Nothing /* fmap (\t -> iconIndex heading t selected) type */, popup = Nothing}
pos (PositionLatLng (lat,lng)) = {LeafletLatLng|lat=lat,lng=lng}
pos (PositionDescription _ (Just(lat,lng))) = {LeafletLatLng|lat=lat,lng=lng}
......@@ -183,7 +183,7 @@ where
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
toLeafletPerspective {ContactMapPerspective|center,zoom,cursor,bounds}
= {LeafletPerspective|center=toLeafletLatLng center,zoom=zoom,cursor=fmap toLeafletLatLng cursor,bounds=fmap toLeafletBounds bounds}
= {LeafletPerspective|center=toLeafletLatLng center,zoom=zoom,bounds=fmap toLeafletBounds bounds}
toLeafletLatLng :: !(!Real,!Real) -> LeafletLatLng
toLeafletLatLng (lat,lng) = {LeafletLatLng|lat=lat,lng=lng}
......@@ -199,8 +199,8 @@ fromLeafletMap contactMap leafletMap
}
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
fromLeafletPerspective {LeafletPerspective|center,cursor,zoom,bounds}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=fmap fromLeafletLatLng cursor,bounds=fmap fromLeafletBounds bounds}
fromLeafletPerspective {LeafletPerspective|center,zoom,bounds}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=Nothing,bounds=fmap fromLeafletBounds bounds}
/*
fromLeafletLayer :: ContactMapLayer LeafletLayer -> ContactMapLayer
......@@ -216,8 +216,8 @@ fromLeafletLayer cl ll = cl
*/
selectionFromLeafletMap :: LeafletMap -> [LeafletObjectID]
selectionFromLeafletMap {LeafletMap|objects} =
[markerId \\ Marker {LeafletMarker|markerId,selected} <- objects | selected]
selectionFromLeafletMap {LeafletMap|objects} = []
//[markerId \\ Marker {LeafletMarker|markerId} <- objects | selected]
fromLeafletLatLng :: !LeafletLatLng -> (!Real,!Real)
fromLeafletLatLng {LeafletLatLng|lat,lng} = (lat,lng)
......
......@@ -96,9 +96,9 @@ mapView` currentUser es = (updateSharedInformation () [UpdateAs toMap fromMap] (
# mid = toInt contactMarker.ContactMapMarker.markerId
= case 'DIS'.get mid markers of
Just m
# st = if contactMarker.ContactMapMarker.selected
{st & selection = mid}
st
//# st = if contactMarker.ContactMapMarker.selected
// {st & selection = mid}
// st
//= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) // TODO FIXME
= (markers, st)
_ = (markers, st)
......@@ -120,9 +120,9 @@ mapView sh radarWorks currentUser es = (updateSharedInformation () [UpdateAs toM
# mid = toInt contactMarker.ContactMapMarker.markerId
= case 'DIS'.get mid markers of
Just m
# st = if contactMarker.ContactMapMarker.selected
{st & selection = mid}
st
//# st = if contactMarker.ContactMapMarker.selected
// {st & selection = mid}
// st
//= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) TODO FIXME
= (markers, st)
_ = (markers, st)
......
......@@ -116,15 +116,15 @@ toLeafletMap {ContactMap|perspective,markers}
}
where
convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers]
conv {ContactMapMarker|markerId,title,position,heading,type,selected}
= Marker {LeafletMarker|markerId = LeafletObjectID markerId, title = title, position = toLeafletLatLng position, icon = fmap (\t -> LeafletIconID (iconIndex heading t selected)) type, selected = selected, popup = Nothing}
conv {ContactMapMarker|markerId,title,position,heading,type}
= Marker {LeafletMarker|markerId = LeafletObjectID markerId, title = title, position = toLeafletLatLng position, icon = fmap (\t -> LeafletIconID (iconIndex heading t False)) type,popup = Nothing}
icon i = {LeafletIcon|iconId=LeafletIconID (toString i),iconUrl ="/ship-icons/"+++toString i+++".png",iconSize=(24,24)}
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,cursor=fmap toLeafletLatLng cursor,bounds=Nothing}
= {LeafletPerspective|center=toLeafletLatLng center,zoom=zoom,bounds=Nothing}
toLeafletLatLng :: !LatLng -> LeafletLatLng
toLeafletLatLng (lat,lng) = {LeafletLatLng | lat = toDeg lat, lng = toDeg lng}
......@@ -138,11 +138,11 @@ fromLeafletMap {LeafletMap|perspective,objects}
,markers=toMarkers objects}
where
toMarkers objects
= [{ContactMapMarker|markerId=markerId,title=Nothing,position = fromLeafletLatLng position, type=Nothing,heading=Nothing,selected=selected}
\\ Marker {LeafletMarker|markerId = LeafletObjectID markerId,position,selected} <- 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,cursor,zoom}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=fmap fromLeafletLatLng cursor}
fromLeafletPerspective {LeafletPerspective|center,zoom}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=Nothing}
......@@ -3,29 +3,39 @@ import iTasks
import iTasks.Extensions.GIS.Leaflet
import iTasks.Extensions.GIS.LeafletNavalIcons
import iTasks.UI.Definition
import Data.List, Text.HTML
import StdFunctions, Data.List, Text.HTML
playWithMaps :: Task ()
playWithMaps = withShared {defaultValue & icons = shipIcons} (\m ->
(allTasks [managePerspective m, manageMapObjects m])
playWithMaps = withShared ({defaultValue & icons = shipIcons, tilesUrls = ["/tiles/{z}/{x}/{y}.png"]},defaultValue) (\m ->
((allTasks [managePerspective m, manageState m, manageMapObjects m]) <<@ ScrollContent)
-&&-
manipulateMap m
) <<@ ArrangeWithSideBar 0 LeftSide True @! ()
manipulateMap :: (Shared sds LeafletMap) -> Task () | RWShared sds
manipulateMap m = updateSharedInformation () [] m
manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manipulateMap m = updateSharedInformation () [UpdateUsing id (flip const) (customLeafletEditor eventHandlers)] m
<<@ ApplyLayout (layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))) @! ()
where
eventHandlers = {simpleStateEventHandlers & onHtmlEvent = onHtmlEvent}
onHtmlEvent "closewindows" (l,s) = ({LeafletMap|l & objects = [o \\ o <- l.LeafletMap.objects | not (o =: (Window _))]},s)
onHtmlEvent _ (l,s) = (l,s)
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) @! ()
managePerspective :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
managePerspective m = updateSharedInformation (Title "Perspective") []
(mapReadWrite (\(x,s) -> x.LeafletMap.perspective, \p (x,s) -> Just ({x & perspective = p},s)) Nothing m) @! ()
manageState :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manageState m = updateSharedInformation (Title "State") []
(mapReadWrite (\(x,s) -> s, \sn (x,s) -> Just (x,sn)) 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 :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manageMapObjects m = viewSharedInformation (Title "View objects") [ViewAs toPrj] m
-|| addDemoObjects m
@! ()
where
toPrj m = m.LeafletMap.objects
toPrj (m,_) = m.LeafletMap.objects
addDemoObjects m
= enterChoiceAs "Add objects:" [ChooseFromCheckGroup fst] options snd
......@@ -43,10 +53,10 @@ where
addRandomMarker m
= get randomInt -&&- get randomInt @ toRandomMarker
>>- \marker -> upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [marker]}) m
>>- \marker -> upd (\(l=:{LeafletMap|objects},s) -> ({LeafletMap|l & objects = objects ++ [marker]},s)) m
toRandomMarker (rLat,rLng)
= Marker {markerId = LeafletObjectID markerId, position= {LeafletLatLng|lat = lat, lng = lng}, title = Just markerId, icon = Just icon, selected = False, popup = Nothing}
= Marker {markerId = LeafletObjectID markerId, position= {LeafletLatLng|lat = lat, lng = lng}, title = Just markerId, icon = Just icon, popup = Nothing}
where
lat = 52.0 + (toReal (500 + (rLat rem 1000)) / 1000.0)
lng = 6.0 + (toReal (500 + (rLng rem 1000)) / 1000.0)
......@@ -54,7 +64,7 @@ where
icon = shipIconId (Just (rLat rem 360)) OrangeShip False
addMarkerConnectingLine m
= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [line objects]}) m
= upd (\(l=:{LeafletMap|objects},s) -> ({LeafletMap|l & objects = objects ++ [line objects]},s)) m
where
line objects = Polyline { polylineId = LeafletObjectID "markerConnection"
, style = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)]
......@@ -64,7 +74,7 @@ where
points objects = [position \\ Marker {LeafletMarker|position} <- objects]
addMarkerConnectingPolygon m
= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [polygon objects]}) m
= upd (\(l=:{LeafletMap|objects},s) -> ({LeafletMap|l & objects = objects ++ [polygon objects]},s)) m
where
polygon objects = Polygon { polygonId = LeafletObjectID "markerConnection"
, style = [ Style (AreaLineStrokeColor "#000")
......@@ -77,31 +87,34 @@ where
points objects = [position \\ Marker {LeafletMarker|position} <- objects]
addMarkerAtCursor m
= upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withMarkerFromCursor cursor objects}) m
= upd (\(l=:{LeafletMap|objects},s=:{LeafletSimpleState|cursor}) -> ({LeafletMap|l & objects = withMarkerFromCursor cursor objects},s)) m
where
withMarkerFromCursor Nothing objects = objects
withMarkerFromCursor (Just position) objects = objects ++ [Marker {markerId = LeafletObjectID "CURSOR", position= position, title = Nothing, icon = Nothing, selected = False, popup = Nothing}]
withMarkerFromCursor (Just position) objects = objects ++ [Marker {markerId = LeafletObjectID "CURSOR", position= position, title = Nothing, icon = Nothing, popup = Nothing}]
addCircleAtCursor m
= upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withCircleFromCursor cursor objects}) m
= upd (\(l=:{LeafletMap|objects},s=:{LeafletSimpleState|cursor}) -> ({LeafletMap|l & objects = withCircleFromCursor cursor objects},s)) 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
= upd (\(l=:{LeafletMap|perspective={LeafletPerspective|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 = []}]
addWindow m
= upd (\l=:{LeafletMap|objects} -> {LeafletMap| l & objects = [Window window:objects]}) m
= upd (\(l=:{LeafletMap|objects},s) -> ({LeafletMap| l & objects = [Window window:objects]},s)) m
where
window =
{ windowId = LeafletObjectID "WINDOW"
, initPosition = {x = 100, y = 100}
, title = "Test Window"
, content = H1Tag [] [Text "This is test content!"]
, content = DivTag []
[H1Tag [] [Text "This is test content!"]
,ATag [HrefAttr "#",OnclickAttr "itasks.htmlEvent(event, 'closewindows')"] [Text "Close windows"]
]
, relatedMarkers = [(LeafletObjectID "home", [])]
}
......
......@@ -2,20 +2,24 @@ definition module iTasks.Extensions.GIS.Leaflet
import iTasks
from Text.HTML import :: SVGElt
from Data.Set import :: Set
leafletEditor :: Editor LeafletMap
//Customization of editors
customLeafletEditor :: (LeafletEventHandlers s) -> Editor (LeafletMap, s) | iTask s
:: LeafletMap =
{ perspective :: !LeafletPerspective
, tilesUrls :: ![String]
, objects :: ![LeafletObject] //Markers, lines and polygon
, icons :: ![LeafletIcon] //Custom icons used by markers. They are indexed by 'iconId' string and cannot be changed once the map is loaded
, icons :: ![LeafletIcon] //Custom icons used by markers. They are referenced using their 'iconId' string.
}
:: LeafletPerspective =
{ center :: !LeafletLatLng
, zoom :: !Int
, cursor :: !Maybe LeafletLatLng
, bounds :: !Maybe LeafletBounds
}
......@@ -51,9 +55,8 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
{ markerId :: !LeafletObjectID
, position :: !LeafletLatLng
, title :: !Maybe String
, icon :: !Maybe LeafletIconID// Id of the list of icons defined for the map
, icon :: !Maybe LeafletIconID //Reference to an icon defined for this map
, popup :: !Maybe HtmlTag
, selected :: !Bool
}
:: LeafletPolyline =
......@@ -90,7 +93,7 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
, initPosition :: !LeafletWindowPos
, title :: !String
, content :: !HtmlTag
, relatedMarkers :: ![(!LeafletObjectID, ![LeafletStyleDef LeafletLineStyle])] // connecting lines are drawn between the window and the markers
, relatedMarkers :: ![(LeafletObjectID, [LeafletStyleDef LeafletLineStyle])] // connecting lines are drawn between the window and the markers
// to visualise the relation
}
......@@ -114,16 +117,35 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
:: LeafletWindowPos = { x :: !Int, y :: !Int }
//Event handlers allow the customization of the map editor behaviour
:: LeafletEventHandlers s =
{ onMapClick :: LeafletLatLng (LeafletMap,s) -> (LeafletMap,s)
, onMarkerClick :: LeafletObjectID (LeafletMap,s) -> (LeafletMap,s)
, onHtmlEvent :: String (LeafletMap,s) -> (LeafletMap,s)
}
//A minimal state for tracking a set of selected markers
//and the last place that the map was clicked
:: LeafletSimpleState =
{ cursor :: Maybe LeafletLatLng
, selection :: [LeafletObjectID]
}
simpleStateEventHandlers :: LeafletEventHandlers LeafletSimpleState
//Inline SVG based icons can be encoded as 'data uri's' which can be used instead of a url to an external icon image
svgIconURL :: !SVGElt !(!Int,!Int) -> String
//Public tileserver of openstreetmaps
openStreetMapTiles :: String
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
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID, LeafletSimpleState
......@@ -4,7 +4,8 @@ import iTasks
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.JavaScript
import StdMisc, Data.Tuple, Data.Error, Data.Func, Text, Data.Functor
import qualified Data.Map as DM
from Text.HTML import instance toString HtmlTag, instance toString SVGElt
//from Text.HTML import instance toString HtmlTag, instance toString SVGElt
import Text.HTML
from Text.Encodings.Base64 import base64Encode
from iTasks.UI.Editor.Common import diffChildren, :: ChildUpdate (..)
import StdArray
......@@ -25,17 +26,11 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
, zoomControl :: !Bool
, editable :: !Bool
}
:: CursorOptions =
{ color :: !String
, opacity :: !Real
, radius :: !Int
}
derive JSONEncode IconOptions
derive gToJS CursorOptions, MapOptions, LeafletLatLng
derive gToJS MapOptions, LeafletLatLng
CURSOR_OPTIONS :== {color = "#00f", opacity = 1.0, radius = 3}
MAP_OPTIONS :== {attributionControl = False, zoomControl = True, editable = True}
leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
......@@ -50,13 +45,14 @@ leafletObjectIdOf (Window w) = w.windowId
//Perspective
= LDSetZoom !Int
| LDSetCenter !LeafletLatLng
| LDSetCursor !LeafletLatLng
| LDSetBounds !LeafletBounds
//Updating markers
| LDSelectMarker !LeafletObjectID
//Updating windows
| LDRemoveWindow !LeafletObjectID
| LDUpdateObject !LeafletObjectID !LeafletObjectUpdate
//Events
| LDMapClick !LeafletLatLng
| LDMarkerClick !LeafletObjectID
| LDHtmlEvent !String
:: LeafletObjectUpdate
= UpdatePolyline ![LeafletLatLng]
......@@ -74,7 +70,10 @@ openStreetMapTiles :: String
openStreetMapTiles = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
leafletEditor :: Editor LeafletMap
leafletEditor = leafEditorToEditor
leafletEditor = leafEditorToEditor leafletEditor`
leafletEditor` :: LeafEditor [LeafletEdit] LeafletMap LeafletMap
leafletEditor` =
{ LeafEditor
| genUI = withClientSideInit initUI genUI
, onEdit = onEdit
......@@ -83,12 +82,11 @@ leafletEditor = leafEditorToEditor
}
where
genUI attr dp mode world
# val=:{LeafletMap|perspective={center,zoom,cursor},tilesUrls,objects,icons} =
# val=:{LeafletMap|perspective={center,zoom},tilesUrls,objects,icons} =
fromMaybe gDefault{|*|} $ editModeValue mode
# mapAttr = 'DM'.fromList
[("zoom", JSONInt zoom)
,("center", JSONArray [JSONReal center.LeafletLatLng.lat, JSONReal center.LeafletLatLng.lng])
,("cursor", maybe JSONNull toJSON cursor)
,("tilesUrls", toJSON tilesUrls)
,("icons", JSONArray [toJSON (iconId,{IconOptions|iconUrl=iconUrl,iconSize=[w,h]}) \\ {iconId,iconUrl,iconSize=(w,h)} <- icons])
]
......@@ -145,10 +143,7 @@ where
//Set perspective
# (center,world) = me .# "attributes.center" .? world
# (zoom,world) = me .# "attributes.zoom" .? world
# (cursor,world) = me .# "attributes.cursor" .? world
# world = (mapObj .# "setView" .$! (center,zoom)) world
//Set initial cursor
# world = setMapCursor me mapObj cursor world
//Add icons
# world = setMapIcons me mapObj (me .# "attributes.icons") world
//Create tile layer
......@@ -185,6 +180,8 @@ where
# world = (vp .# "addChangeListener" .$! me) world
# (cb,world) = jsWrapFun (\a w -> beforeRemove me w) me world
# world = (me .# "beforeRemove" .= cb) world
# (cb,world) = jsWrapFun (\a w -> onHtmlEvent me a w) me world
# world = (me .# "onHtmlEvent" .= cb) world
# world = case viewMode of
True
= world
......@@ -233,17 +230,15 @@ where
# (editorId,world) = me .# "attributes.editorId" .? world
# (mapObj,world) = args.[0] .# "target" .? world
# (clickPos,world) = args.[0] .# "latlng" .? world
# (cursor,world) = toLatLng clickPos world
# edit = toJSON [LDSetCursor cursor]
# (position,world) = toLatLng clickPos world
# edit = toJSON [LDMapClick position]
# world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
//Update cursor position on the map
# world = setMapCursor me mapObj (toJS cursor) world
= world
onMarkerClick me markerId args world
# (taskId,world) = me .# "attributes.taskId" .? world
# (editorId,world) = me .# "attributes.editorId" .? world
# edit = toJSON [LDSelectMarker markerId]
# edit = toJSON [LDMarkerClick markerId]
# world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
= world
......@@ -252,9 +247,20 @@ where
= case jsValToString args.[0] of
Just "center" = setMapCenter mapObj args.[1] world
Just "zoom" = setMapZoom mapObj args.[1] world
Just "cursor" = setMapCursor me mapObj args.[1] world
Just "icons" = setMapIcons me mapObj args.[1] world
_ = world
onHtmlEvent me args world
# (taskId,world) = me .# "attributes.taskId" .? world
# (editorId,world) = me .# "attributes.editorId" .? world
= case (jsValToString args.[0]) of
Just event
# edit = toJSON [LDHtmlEvent event]
# world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
= world
_ = world
onAfterChildInsert viewMode me args world
# (l, world) = jsGlobal "L" .? world
# (mapObj,world) = me .# "map" .? world
......@@ -338,28 +344,6 @@ where
# world = (mapObj .# "panTo" .$! center) world
= world
setMapCursor me mapObj position world
# (cursor,world) = me .# "cursor" .? world
| jsIsUndefined cursor
| jsIsNull position //Nothing to do
= world
| otherwise
//Create the cursor
# (l, world) = jsGlobal "L" .? world
# (cursor,world) = (l .# "circleMarker" .$ (position, CURSOR_OPTIONS)) world
# world = (cursor .# "addTo" .$! mapObj) world
# world = (me .# "cursor" .= cursor) world
= world
| otherwise //Update the position
| jsIsNull position
//Destroy the cursor
# world = (mapObj .# "removeLayer" .$! cursor) world
# world = jsDelete (me .# "cursor") world
= world
| otherwise
# world = (cursor .# "setLatLng" .$! position) world
= world
addMapTilesLayer me mapObj _ tilesUrl world
| jsIsNull tilesUrl = world
# (l, world) = jsGlobal "L" .? world
......@@ -645,12 +629,7 @@ where
where
app m (LDSetZoom zoom) = {LeafletMap|m & perspective = {m.perspective & zoom = zoom}}
app m (LDSetCenter center) = {LeafletMap|m & perspective = {LeafletPerspective| m.perspective & center = center}}
app m (LDSetCursor cursor) = {LeafletMap|m & perspective = {m.perspective & cursor = Just cursor}}
app m (LDSetBounds bounds) = {LeafletMap|m & perspective = {LeafletPerspective| m.perspective & bounds = Just bounds}}
app m (LDSelectMarker markerId) = {LeafletMap|m & objects = map (sel markerId) m.LeafletMap.objects}
where
sel x (Marker m=:{LeafletMarker|markerId}) = Marker {LeafletMarker|m & selected = markerId === x}
sel x o = o
app m (LDRemoveWindow idToRemove) = {LeafletMap|m & objects = filter notToRemove m.LeafletMap.objects}
where
notToRemove (Window {windowId}) = windowId =!= idToRemove
......@@ -679,15 +658,15 @@ where
# childChanges = diffChildren oldMap.LeafletMap.objects newMap.LeafletMap.objects updateFromOldToNew encodeUI
= (Ok (ChangeUI attrChanges childChanges, newMap),vst)
where
//Only center, zoom and cursor are synced to the client, bounds are only synced from client to server
diffAttributes {LeafletMap|perspective=p1} {LeafletMap|perspective=p2}
//Only center and zoom are synced to the client, bounds are only synced from client to server
diffAttributes {LeafletMap|perspective=p1,icons=i1} {LeafletMap|perspective=p2,icons=i2}
//Center
# center = if (p2.LeafletPerspective.center === p1.LeafletPerspective.center) [] [SetAttribute "center" (toJSON p2.LeafletPerspective.center)]
//Zoom
# zoom = if (p2.LeafletPerspective.zoom === p1.LeafletPerspective.zoom) [] [SetAttribute "zoom" (toJSON p2.LeafletPerspective.zoom)]
//Cursor
# cursor = if (p2.LeafletPerspective.cursor === p1.LeafletPerspective.cursor) [] [SetAttribute "cursor" (maybe JSONNull toJSON p2.LeafletPerspective.cursor)]
= center ++ zoom ++ cursor
//Icons
# icons = if (i2 === i1) [] [SetAttribute "icons" (JSONArray [toJSON (iconId,{IconOptions|iconUrl=iconUrl,iconSize=[w,h]}) \\ {iconId,iconUrl,iconSize=(w,h)} <- i2])]
= center ++ zoom ++ icons
updateFromOldToNew :: !LeafletObject !LeafletObject -> ChildUpdate
updateFromOldToNew (Window old) (Window new) | old.windowId === new.windowId && not (isEmpty changes) =
......@@ -714,18 +693,93 @@ gEditor{|LeafletMap|} = leafletEditor
gDefault{|LeafletMap|}
= {LeafletMap|perspective=defaultValue, tilesUrls = [openStreetMapTiles], objects = [Marker homeMarker], icons = []}
where
homeMarker = {markerId = LeafletObjectID "home", position= {LeafletLatLng|lat = 51.82, lng = 5.86}, title = Just "HOME", icon = Nothing, popup = Nothing, selected = False}
homeMarker = {markerId = LeafletObjectID "home", position= {LeafletLatLng|lat = 51.82, lng = 5.86}, title = Just "HOME", icon = Nothing, popup = Nothing}
gDefault{|LeafletPerspective|}
= {LeafletPerspective|center = {LeafletLatLng|lat = 51.82, lng = 5.86}, zoom = 7, cursor = Nothing, bounds = Nothing}
= {LeafletPerspective|center = {LeafletLatLng|lat = 51.82, lng = 5.86}, zoom = 7, bounds = Nothing}
//Comparing reals may have unexpected results, especially when comparing constants to previously stored ones
gEq{|LeafletLatLng|} x y = (toString x.lat == toString y.lat) && (toString x.lng == toString y.lng)
simpleStateEventHandlers :: LeafletEventHandlers LeafletSimpleState
simpleStateEventHandlers =
{ onMapClick = \position (l,s) -> (addCursorMarker position l,{LeafletSimpleState|s & cursor = Just position})
, onMarkerClick = \markerId (l,s) -> (l,{LeafletSimpleState|s & selection = toggle markerId s.LeafletSimpleState.selection})
, onHtmlEvent = \msg (l,s) -> (l,s)
}