Skip to content

GitLab

Commit cfdb08bd authored by Bas Lijnse's avatar Bas Lijnse
Browse files
Options

Added a customizable map editor with a separate state

parent 41d2eb6d
Hide whitespace changes
Inline Side-by-side
Showing with 121 additions and 26 deletions
Examples/GIS/LeafletMapExample.icl
View file @ cfdb08bd
......@@ -3,29 +3,34 @@ 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},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 simpleStateEventHandlers)] m
<<@ ApplyLayout (layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))) @! ()
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,7 +48,7 @@ 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}
......@@ -54,7 +59,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 +69,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,25 +82,25 @@ 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|perspective={LeafletPerspective|cursor},objects},s) -> ({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}]
addCircleAtCursor m
= upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withCircleFromCursor cursor objects}) m
= upd (\(l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects},s) -> ({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"
......
Libraries/iTasks/Extensions/GIS/Leaflet.dcl
View file @ cfdb08bd
......@@ -2,6 +2,7 @@ definition module iTasks.Extensions.GIS.Leaflet
import iTasks
from Text.HTML import :: SVGElt
from Data.Set import :: Set
leafletEditor :: Editor LeafletMap
......@@ -114,6 +115,23 @@ 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)
}
//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
//Customization of editors
customLeafletEditor :: (LeafletEventHandlers s) -> Editor (LeafletMap, s) | iTask s
//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
......@@ -126,4 +144,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, LeafletAreaStyle, LeafletObjectID
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID, LeafletSimpleState
Libraries/iTasks/Extensions/GIS/Leaflet.icl
View file @ cfdb08bd
......@@ -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
......@@ -57,6 +58,8 @@ leafletObjectIdOf (Window w) = w.windowId
//Updating windows
| LDRemoveWindow !LeafletObjectID
| LDUpdateObject !LeafletObjectID !LeafletObjectUpdate
//Events
| LDMapClick !LeafletLatLng
:: LeafletObjectUpdate
= UpdatePolyline ![LeafletLatLng]
......@@ -74,7 +77,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
......@@ -233,11 +239,11 @@ 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,LDSetCursor position]
# world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
//Update cursor position on the map
# world = setMapCursor me mapObj (toJS cursor) world
# world = setMapCursor me mapObj (toJS position) world
= world
onMarkerClick me markerId args world
......@@ -253,6 +259,7 @@ where
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
onAfterChildInsert viewMode me args world
......@@ -645,7 +652,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 (LDSetCursor cursor) = {LeafletMap|m & perspective = {LeafletPerspective| 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
......@@ -680,14 +687,16 @@ where
= (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}
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 ++ cursor ++ icons
updateFromOldToNew :: !LeafletObject !LeafletObject -> ChildUpdate
updateFromOldToNew (Window old) (Window new) | old.windowId === new.windowId && not (isEmpty changes) =
......@@ -722,10 +731,73 @@ gDefault{|LeafletPerspective|}
//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})
}
where
addCursorMarker position l=:{LeafletMap|objects,icons} = {l & objects = addCursorObject objects, icons=addCursorIcon icons}
where
addCursorObject [] = [cursor position]
addCursorObject [o=:(Marker {LeafletMarker|markerId}):os]
| markerId =: (LeafletObjectID "cursor") = [cursor position:os]
| otherwise = [o:addCursorObject os]
addCursorIcon [] = [icon]
addCursorIcon [i=:{iconId}:is]
| iconId =: (LeafletIconID "cursor") = [i:is]
| otherwise = [i:addCursorIcon is]
cursor position = Marker {LeafletMarker|markerId=LeafletObjectID "cursor", position= position, icon = Just (LeafletIconID "cursor"),title=Nothing,popup=Nothing,selected=False}
icon = {LeafletIcon|iconId=LeafletIconID "cursor", iconUrl= svgIconURL (CircleElt hattrs sattrs) (10,10), iconSize = (10,10)}
where
sattrs = [CxAttr ("5",PX),CyAttr ("5",PX),RAttr ("3",PX)]
hattrs = [StyleAttr "fill:none;stroke:#00;stroke-width:2"]
customLeafletEditor :: (LeafletEventHandlers s) -> Editor (LeafletMap, s) | iTask s
customLeafletEditor handlers = leafEditorToEditor (customLeafletEditor` handlers)
customLeafletEditor` ::(LeafletEventHandlers s) -> LeafEditor [LeafletEdit] (LeafletMap,s) (LeafletMap,s) | iTask s
customLeafletEditor` handlers =
{ LeafEditor
| genUI = genUI
, onEdit = onEdit
, onRefresh = onRefresh
, valueFromState = valueFromState
}
where
genUI attributes datapath mode vst = case leafletEditor`.LeafEditor.genUI attributes datapath (mapEditMode fst mode) vst of
(Error e, vst) = (Error e, vst)
(Ok (ui,mapState),vst) = (Ok (ui,(mapState,defaultValue)),vst)
onEdit datapath edit (mapState,customState) vst = case leafletEditor`.LeafEditor.onEdit datapath edit mapState vst of
(Error e, vst) = (Error e, vst)
(Ok (mapChange,mapState), vst)
//Apply event handlers
# (newMapState,customState) = updateCustomState handlers datapath edit (mapState,customState)
//Determine the change to the map
= case leafletEditor`.LeafEditor.onRefresh datapath newMapState mapState vst of
(Error e, vst) = (Error e, vst)
(Ok (mapRefreshChange,mapState),vst)
= (Ok (mergeUIChanges mapChange mapRefreshChange, (mapState,customState)),vst)
onRefresh datapath (newMapState,newCustomState) (curMapState,curCustomState) vst
= case leafletEditor`.LeafEditor.onRefresh datapath newMapState curMapState vst of
(Error e, vst) = (Error e, vst)
(Ok (mapChange,mapState),vst) = (Ok (mapChange,(mapState,newCustomState)),vst)
valueFromState s = Just s
updateCustomState {onMapClick} datapath (target,edits) state
| target <> datapath = state
| otherwise = foldl update state edits
where
update state (LDMapClick position) = onMapClick position state
update state _ = state
derive JSONEncode LeafletMap, LeafletPerspective, LeafletLatLng
derive JSONDecode LeafletMap, LeafletPerspective, LeafletLatLng
derive gDefault LeafletLatLng
derive gEq LeafletMap, LeafletPerspective
derive gText LeafletMap, LeafletPerspective, LeafletLatLng
derive gEditor LeafletPerspective, LeafletLatLng
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletEdit, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID, CSSClass, LeafletIconID, LeafletCircle, LeafletObjectUpdate, LeafletRectangle
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletEdit, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID, CSSClass, LeafletIconID, LeafletCircle, LeafletObjectUpdate, LeafletRectangle, LeafletSimpleState
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