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 ...@@ -94,7 +94,7 @@ where
eqBounds _ _ = False eqBounds _ _ = False
gDefault{|ContactMapPerspective|} 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 contactToMapMarker :: Bool Bool Contact -> ContactMapMarker
...@@ -142,8 +142,8 @@ where ...@@ -142,8 +142,8 @@ where
tilesUrls layers = [url \\ {ContactMapLayer|def=CMTileLayer url} <- layers] tilesUrls layers = [url \\ {ContactMapLayer|def=CMTileLayer url} <- layers]
convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers | hasLatLng position] convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers | hasLatLng position]
conv {ContactMapMarker|markerId,title,position,heading,type,selected} 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 */, selected = selected, popup = Nothing} = 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 (PositionLatLng (lat,lng)) = {LeafletLatLng|lat=lat,lng=lng}
pos (PositionDescription _ (Just(lat,lng))) = {LeafletLatLng|lat=lat,lng=lng} pos (PositionDescription _ (Just(lat,lng))) = {LeafletLatLng|lat=lat,lng=lng}
...@@ -183,7 +183,7 @@ where ...@@ -183,7 +183,7 @@ where
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
toLeafletPerspective {ContactMapPerspective|center,zoom,cursor,bounds} 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 :: !(!Real,!Real) -> LeafletLatLng
toLeafletLatLng (lat,lng) = {LeafletLatLng|lat=lat,lng=lng} toLeafletLatLng (lat,lng) = {LeafletLatLng|lat=lat,lng=lng}
...@@ -199,8 +199,8 @@ fromLeafletMap contactMap leafletMap ...@@ -199,8 +199,8 @@ fromLeafletMap contactMap leafletMap
} }
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
fromLeafletPerspective {LeafletPerspective|center,cursor,zoom,bounds} fromLeafletPerspective {LeafletPerspective|center,zoom,bounds}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=fmap fromLeafletLatLng cursor,bounds=fmap fromLeafletBounds bounds} = {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=Nothing,bounds=fmap fromLeafletBounds bounds}
/* /*
fromLeafletLayer :: ContactMapLayer LeafletLayer -> ContactMapLayer fromLeafletLayer :: ContactMapLayer LeafletLayer -> ContactMapLayer
...@@ -216,8 +216,8 @@ fromLeafletLayer cl ll = cl ...@@ -216,8 +216,8 @@ fromLeafletLayer cl ll = cl
*/ */
selectionFromLeafletMap :: LeafletMap -> [LeafletObjectID] selectionFromLeafletMap :: LeafletMap -> [LeafletObjectID]
selectionFromLeafletMap {LeafletMap|objects} = selectionFromLeafletMap {LeafletMap|objects} = []
[markerId \\ Marker {LeafletMarker|markerId,selected} <- objects | selected] //[markerId \\ Marker {LeafletMarker|markerId} <- objects | selected]
fromLeafletLatLng :: !LeafletLatLng -> (!Real,!Real) fromLeafletLatLng :: !LeafletLatLng -> (!Real,!Real)
fromLeafletLatLng {LeafletLatLng|lat,lng} = (lat,lng) fromLeafletLatLng {LeafletLatLng|lat,lng} = (lat,lng)
......
...@@ -96,9 +96,9 @@ mapView` currentUser es = (updateSharedInformation () [UpdateAs toMap fromMap] ( ...@@ -96,9 +96,9 @@ mapView` currentUser es = (updateSharedInformation () [UpdateAs toMap fromMap] (
# mid = toInt contactMarker.ContactMapMarker.markerId # mid = toInt contactMarker.ContactMapMarker.markerId
= case 'DIS'.get mid markers of = case 'DIS'.get mid markers of
Just m Just m
# st = if contactMarker.ContactMapMarker.selected //# st = if contactMarker.ContactMapMarker.selected
{st & selection = mid} // {st & selection = mid}
st // st
//= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) // TODO FIXME //= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) // TODO FIXME
= (markers, st) = (markers, st)
_ = (markers, st) _ = (markers, st)
...@@ -120,9 +120,9 @@ mapView sh radarWorks currentUser es = (updateSharedInformation () [UpdateAs toM ...@@ -120,9 +120,9 @@ mapView sh radarWorks currentUser es = (updateSharedInformation () [UpdateAs toM
# mid = toInt contactMarker.ContactMapMarker.markerId # mid = toInt contactMarker.ContactMapMarker.markerId
= case 'DIS'.get mid markers of = case 'DIS'.get mid markers of
Just m Just m
# st = if contactMarker.ContactMapMarker.selected //# st = if contactMarker.ContactMapMarker.selected
{st & selection = mid} // {st & selection = mid}
st // st
//= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) TODO FIXME //= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) TODO FIXME
= (markers, st) = (markers, st)
_ = (markers, st) _ = (markers, st)
......
...@@ -116,15 +116,15 @@ toLeafletMap {ContactMap|perspective,markers} ...@@ -116,15 +116,15 @@ toLeafletMap {ContactMap|perspective,markers}
} }
where where
convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers] convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers]
conv {ContactMapMarker|markerId,title,position,heading,type,selected} conv {ContactMapMarker|markerId,title,position,heading,type}
= Marker {LeafletMarker|markerId = LeafletObjectID markerId, title = title, position = toLeafletLatLng position, icon = fmap (\t -> LeafletIconID (iconIndex heading t selected)) type, selected = selected, popup = Nothing} = 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)} 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) iconIndex heading type selected = toString (cat type + ( (maybe 24 (\d -> toInt d / 15) heading) + (if selected 25 0)) * 5)
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
toLeafletPerspective {ContactMapPerspective|center,zoom,cursor} 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 :: !LatLng -> LeafletLatLng
toLeafletLatLng (lat,lng) = {LeafletLatLng | lat = toDeg lat, lng = toDeg lng} toLeafletLatLng (lat,lng) = {LeafletLatLng | lat = toDeg lat, lng = toDeg lng}
...@@ -138,11 +138,11 @@ fromLeafletMap {LeafletMap|perspective,objects} ...@@ -138,11 +138,11 @@ fromLeafletMap {LeafletMap|perspective,objects}
,markers=toMarkers objects} ,markers=toMarkers objects}
where where
toMarkers objects toMarkers objects
= [{ContactMapMarker|markerId=markerId,title=Nothing,position = fromLeafletLatLng position, type=Nothing,heading=Nothing,selected=selected} = [{ContactMapMarker|markerId=markerId,title=Nothing,position = fromLeafletLatLng position, type=Nothing,heading=Nothing,selected=False}
\\ Marker {LeafletMarker|markerId = LeafletObjectID markerId,position,selected} <- objects] \\ Marker {LeafletMarker|markerId = LeafletObjectID markerId,position} <- objects]
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
fromLeafletPerspective {LeafletPerspective|center,cursor,zoom} fromLeafletPerspective {LeafletPerspective|center,zoom}
= {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=fmap fromLeafletLatLng cursor} = {ContactMapPerspective|center=fromLeafletLatLng center,zoom=zoom,cursor=Nothing}
...@@ -3,29 +3,39 @@ import iTasks ...@@ -3,29 +3,39 @@ import iTasks
import iTasks.Extensions.GIS.Leaflet import iTasks.Extensions.GIS.Leaflet
import iTasks.Extensions.GIS.LeafletNavalIcons import iTasks.Extensions.GIS.LeafletNavalIcons
import iTasks.UI.Definition import iTasks.UI.Definition
import Data.List, Text.HTML import StdFunctions, Data.List, Text.HTML
playWithMaps :: Task () playWithMaps :: Task ()
playWithMaps = withShared {defaultValue & icons = shipIcons} (\m -> playWithMaps = withShared ({defaultValue & icons = shipIcons, tilesUrls = ["/tiles/{z}/{x}/{y}.png"]},defaultValue) (\m ->
(allTasks [managePerspective m, manageMapObjects m]) ((allTasks [managePerspective m, manageState m, manageMapObjects m]) <<@ ScrollContent)
-&&- -&&-
manipulateMap m manipulateMap m
) <<@ ArrangeWithSideBar 0 LeftSide True @! () ) <<@ ArrangeWithSideBar 0 LeftSide True @! ()
manipulateMap :: (Shared sds LeafletMap) -> Task () | RWShared sds manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manipulateMap m = updateSharedInformation () [] m manipulateMap m = updateSharedInformation () [UpdateUsing id (flip const) (customLeafletEditor eventHandlers)] m
<<@ ApplyLayout (layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))) @! () <<@ 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,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) @! ()
managePerspective :: (Shared sds LeafletMap) -> Task () | RWShared sds manageState :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
managePerspective m = updateSharedInformation (Title "Perspective") [] (mapReadWrite (\x -> x.LeafletMap.perspective,\p x -> Just {x & perspective = p}) Nothing m) @! () 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 // 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 manageMapObjects m = viewSharedInformation (Title "View objects") [ViewAs toPrj] m
-|| addDemoObjects m -|| addDemoObjects m
@! () @! ()
where where
toPrj m = m.LeafletMap.objects toPrj (m,_) = m.LeafletMap.objects
addDemoObjects m addDemoObjects m
= enterChoiceAs "Add objects:" [ChooseFromCheckGroup fst] options snd = enterChoiceAs "Add objects:" [ChooseFromCheckGroup fst] options snd
...@@ -43,10 +53,10 @@ where ...@@ -43,10 +53,10 @@ where
addRandomMarker m addRandomMarker m
= get randomInt -&&- get randomInt @ toRandomMarker = 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) 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 where
lat = 52.0 + (toReal (500 + (rLat rem 1000)) / 1000.0) lat = 52.0 + (toReal (500 + (rLat rem 1000)) / 1000.0)
lng = 6.0 + (toReal (500 + (rLng rem 1000)) / 1000.0) lng = 6.0 + (toReal (500 + (rLng rem 1000)) / 1000.0)
...@@ -54,7 +64,7 @@ where ...@@ -54,7 +64,7 @@ where
icon = shipIconId (Just (rLat rem 360)) OrangeShip False icon = shipIconId (Just (rLat rem 360)) OrangeShip False
addMarkerConnectingLine m 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 where
line objects = Polyline { polylineId = LeafletObjectID "markerConnection" line objects = Polyline { polylineId = LeafletObjectID "markerConnection"
, style = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)] , style = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)]
...@@ -64,7 +74,7 @@ where ...@@ -64,7 +74,7 @@ where
points objects = [position \\ Marker {LeafletMarker|position} <- objects] points objects = [position \\ Marker {LeafletMarker|position} <- objects]
addMarkerConnectingPolygon m 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 where
polygon objects = Polygon { polygonId = LeafletObjectID "markerConnection" polygon objects = Polygon { polygonId = LeafletObjectID "markerConnection"
, style = [ Style (AreaLineStrokeColor "#000") , style = [ Style (AreaLineStrokeColor "#000")
...@@ -77,31 +87,34 @@ where ...@@ -77,31 +87,34 @@ where
points objects = [position \\ Marker {LeafletMarker|position} <- objects] points objects = [position \\ Marker {LeafletMarker|position} <- objects]
addMarkerAtCursor m 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 where
withMarkerFromCursor Nothing objects = objects 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 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 where
withCircleFromCursor Nothing objects = objects withCircleFromCursor Nothing objects = objects
withCircleFromCursor (Just position) objects = objects ++ [Circle {circleId = LeafletObjectID "CIRCLE_CURSOR", center = position, radius = 100000.0, editable = True, style = []}] withCircleFromCursor (Just position) objects = objects ++ [Circle {circleId = LeafletObjectID "CIRCLE_CURSOR", center = position, radius = 100000.0, editable = True, style = []}]
addRectangleAroundCurrentPerspective m 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 where
withRectangleAroundCurrentPerspective Nothing objects = objects withRectangleAroundCurrentPerspective Nothing objects = objects
withRectangleAroundCurrentPerspective (Just bounds) objects = objects ++ [Rectangle {rectangleId = LeafletObjectID "RECT_PERSPECTIVE", bounds = bounds, editable = True, style = []}] withRectangleAroundCurrentPerspective (Just bounds) objects = objects ++ [Rectangle {rectangleId = LeafletObjectID "RECT_PERSPECTIVE", bounds = bounds, editable = True, style = []}]
addWindow m 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 where
window = window =
{ windowId = LeafletObjectID "WINDOW" { windowId = LeafletObjectID "WINDOW"
, initPosition = {x = 100, y = 100} , initPosition = {x = 100, y = 100}
, title = "Test Window" , 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", [])] , relatedMarkers = [(LeafletObjectID "home", [])]
} }
......
...@@ -2,20 +2,24 @@ definition module iTasks.Extensions.GIS.Leaflet ...@@ -2,20 +2,24 @@ definition module iTasks.Extensions.GIS.Leaflet
import iTasks import iTasks
from Text.HTML import :: SVGElt from Text.HTML import :: SVGElt
from Data.Set import :: Set
leafletEditor :: Editor LeafletMap leafletEditor :: Editor LeafletMap
//Customization of editors
customLeafletEditor :: (LeafletEventHandlers s) -> Editor (LeafletMap, s) | iTask s
:: LeafletMap = :: LeafletMap =
{ perspective :: !LeafletPerspective { perspective :: !LeafletPerspective
, tilesUrls :: ![String] , tilesUrls :: ![String]
, objects :: ![LeafletObject] //Markers, lines and polygon , 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 = :: LeafletPerspective =
{ center :: !LeafletLatLng { center :: !LeafletLatLng
, zoom :: !Int , zoom :: !Int
, cursor :: !Maybe LeafletLatLng
, bounds :: !Maybe LeafletBounds , bounds :: !Maybe LeafletBounds
} }
...@@ -51,9 +55,8 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID ...@@ -51,9 +55,8 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
{ markerId :: !LeafletObjectID { markerId :: !LeafletObjectID
, position :: !LeafletLatLng , position :: !LeafletLatLng
, title :: !Maybe String , 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 , popup :: !Maybe HtmlTag
, selected :: !Bool
} }
:: LeafletPolyline = :: LeafletPolyline =
...@@ -90,7 +93,7 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID ...@@ -90,7 +93,7 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
, initPosition :: !LeafletWindowPos , initPosition :: !LeafletWindowPos
, title :: !String , title :: !String
, content :: !HtmlTag , 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 // to visualise the relation
} }
...@@ -114,16 +117,35 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID ...@@ -114,16 +117,35 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
:: LeafletWindowPos = { x :: !Int, y :: !Int } :: 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 //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 svgIconURL :: !SVGElt !(!Int,!Int) -> String
//Public tileserver of openstreetmaps //Public tileserver of openstreetmaps
openStreetMapTiles :: String openStreetMapTiles :: String
instance == LeafletObjectID
instance == LeafletIconID
derive JSONEncode LeafletMap, LeafletPerspective, LeafletLatLng derive JSONEncode LeafletMap, LeafletPerspective, LeafletLatLng
derive JSONDecode LeafletMap, LeafletPerspective, LeafletLatLng derive JSONDecode LeafletMap, LeafletPerspective, LeafletLatLng
derive gDefault LeafletMap, LeafletPerspective, LeafletLatLng derive gDefault LeafletMap, LeafletPerspective, LeafletLatLng
derive gEq LeafletMap, LeafletPerspective derive gEq LeafletMap, LeafletPerspective
derive gText LeafletMap, LeafletPerspective, LeafletLatLng derive gText LeafletMap, LeafletPerspective, LeafletLatLng
derive gEditor 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 ...@@ -4,7 +4,8 @@ import iTasks
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.JavaScript import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.JavaScript
import StdMisc, Data.Tuple, Data.Error, Data.Func, Text, Data.Functor import StdMisc, Data.Tuple, Data.Error, Data.Func, Text, Data.Functor
import qualified Data.Map as DM 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 Text.Encodings.Base64 import base64Encode
from iTasks.UI.Editor.Common import diffChildren, :: ChildUpdate (..) from iTasks.UI.Editor.Common import diffChildren, :: ChildUpdate (..)
import StdArray import StdArray
...@@ -25,17 +26,11 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css" ...@@ -25,17 +26,11 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
, zoomControl :: !Bool , zoomControl :: !Bool
, editable :: !Bool , editable :: !Bool
} }
:: CursorOptions =
{ color :: !String
, opacity :: !Real
, radius :: !Int
}
derive JSONEncode IconOptions 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} MAP_OPTIONS :== {attributionControl = False, zoomControl = True, editable = True}
leafletObjectIdOf :: !LeafletObject -> LeafletObjectID leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
...@@ -50,13 +45,14 @@ leafletObjectIdOf (Window w) = w.windowId ...@@ -50,13 +45,14 @@ leafletObjectIdOf (Window w) = w.windowId
//Perspective //Perspective
= LDSetZoom !Int = LDSetZoom !Int
| LDSetCenter !LeafletLatLng | LDSetCenter !LeafletLatLng
| LDSetCursor !LeafletLatLng
| LDSetBounds !LeafletBounds | LDSetBounds !LeafletBounds
//Updating markers
| LDSelectMarker !LeafletObjectID
//Updating windows //Updating windows
| LDRemoveWindow !LeafletObjectID | LDRemoveWindow !LeafletObjectID
| LDUpdateObject !LeafletObjectID !LeafletObjectUpdate | LDUpdateObject !LeafletObjectID !LeafletObjectUpdate
//Events
| LDMapClick !LeafletLatLng
| LDMarkerClick !LeafletObjectID
| LDHtmlEvent !String
:: LeafletObjectUpdate :: LeafletObjectUpdate
= UpdatePolyline ![LeafletLatLng] = UpdatePolyline ![LeafletLatLng]
...@@ -74,7 +70,10 @@ openStreetMapTiles :: String ...@@ -74,7 +70,10 @@ openStreetMapTiles :: String
openStreetMapTiles = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png" openStreetMapTiles = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
leafletEditor :: Editor LeafletMap leafletEditor :: Editor LeafletMap
leafletEditor = leafEditorToEditor leafletEditor = leafEditorToEditor leafletEditor`
leafletEditor` :: LeafEditor [LeafletEdit] LeafletMap LeafletMap
leafletEditor` =
{ LeafEditor { LeafEditor
| genUI = withClientSideInit initUI genUI | genUI = withClientSideInit initUI genUI
, onEdit = onEdit , onEdit = onEdit
...@@ -83,12 +82,11 @@ leafletEditor = leafEditorToEditor ...@@ -83,12 +82,11 @@ leafletEditor = leafEditorToEditor
} }
where where
genUI attr dp mode world genUI attr dp mode world
# val=:{LeafletMap|perspective={