Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
I
iTasks-SDK
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
74
Issues
74
List
Boards
Labels
Service Desk
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
clean-and-itasks
iTasks-SDK
Commits
36a5b36e
Commit
36a5b36e
authored
Mar 26, 2019
by
Steffen Michels
Committed by
Bas Lijnse
Mar 26, 2019
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Leaflet: add circle/rectangle & editable objects
parent
d18c0bfa
Changes
4
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
2166 additions
and
67 deletions
+2166
-67
Examples/GIS/LeafletMapExample.icl
Examples/GIS/LeafletMapExample.icl
+21
-5
Libraries/iTasks/Extensions/GIS/Leaflet.dcl
Libraries/iTasks/Extensions/GIS/Leaflet.dcl
+34
-13
Libraries/iTasks/Extensions/GIS/Leaflet.icl
Libraries/iTasks/Extensions/GIS/Leaflet.icl
+165
-49
Libraries/iTasks/Extensions/GIS/WebPublic/Leaflet.Editable.js
...aries/iTasks/Extensions/GIS/WebPublic/Leaflet.Editable.js
+1946
-0
No files found.
Examples/GIS/LeafletMapExample.icl
View file @
36a5b36e
...
...
@@ -19,13 +19,13 @@ manipulateMap m = updateSharedInformation () [] m
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
)
@!
()
// objects can currently only be viewed, as the editor for `HtmlTag` only works in view mode
manageMapObjects
::
(
Shared
sds
LeafletMap
)
->
Task
()
|
RWShared
sds
manageMapObjects
m
=
updateSharedInformation
(
Title
"Manage objects"
)
[
UpdateAs
toPrj
from
Prj
]
m
manageMapObjects
m
=
viewSharedInformation
(
Title
"View objects"
)
[
ViewAs
to
Prj
]
m
-||
addDemoObjects
m
@!
()
where
toPrj
m
=
m
.
LeafletMap
.
objects
fromPrj
m
objects
=
{
m
&
objects
=
objects
}
addDemoObjects
m
=
enterChoiceAs
"Add objects:"
[
ChooseFromCheckGroup
fst
]
options
snd
...
...
@@ -36,6 +36,8 @@ where
,(
"Marker at cursor position"
,
addMarkerAtCursor
m
)
,(
"Line connecting current markers"
,
addMarkerConnectingLine
m
)
,(
"Polygon from current markers"
,
addMarkerConnectingPolygon
m
)
,(
"Circle at cursor position"
,
addCircleAtCursor
m
)
,(
"Rectangle around current perspective"
,
addRectangleAroundCurrentPerspective
m
)
]
addRandomMarker
m
...
...
@@ -56,6 +58,7 @@ where
line
objects
=
Polyline
{
polylineId
=
LeafletObjectID
"markerConnection"
,
style
=
[
Style
(
LineStrokeColor
"#f0f"
),
Style
(
LineStrokeWidth
4
)]
,
points
=
points
objects
,
editable
=
True
}
points
objects
=
[
position
\\
Marker
{
LeafletMarker
|
position
}
<-
objects
]
...
...
@@ -63,11 +66,12 @@ where
=
upd
(\
l
=:{
LeafletMap
|
objects
}
->
{
LeafletMap
|
l
&
objects
=
objects
++
[
polygon
objects
]})
m
where
polygon
objects
=
Polygon
{
polygonId
=
LeafletObjectID
"markerConnection"
,
style
=
[
Style
(
Polygon
LineStrokeColor
"#000"
)
,
Style
(
Polygon
LineStrokeWidth
2
)
,
Style
(
Polygon
FillColor
"#0f0"
)
,
style
=
[
Style
(
Area
LineStrokeColor
"#000"
)
,
Style
(
Area
LineStrokeWidth
2
)
,
Style
(
Area
FillColor
"#0f0"
)
]
,
points
=
points
objects
,
editable
=
True
}
points
objects
=
[
position
\\
Marker
{
LeafletMarker
|
position
}
<-
objects
]
...
...
@@ -77,4 +81,16 @@ 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
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
where
withRectangleAroundCurrentPerspective
Nothing
objects
=
objects
withRectangleAroundCurrentPerspective
(
Just
bounds
)
objects
=
objects
++
[
Rectangle
{
rectangleId
=
LeafletObjectID
"RECT_PERSPECTIVE"
,
bounds
=
bounds
,
editable
=
True
,
style
=
[]}]
Start
world
=
doTasks
playWithMaps
world
Libraries/iTasks/Extensions/GIS/Leaflet.dcl
View file @
36a5b36e
...
...
@@ -36,10 +36,14 @@ leafletEditor :: Editor LeafletMap
}
::
LeafletObject
=
Marker
!
LeafletMarker
|
Polyline
!
LeafletPolyline
|
Polygon
!
LeafletPolygon
|
Window
!
LeafletWindow
=
Marker
!
LeafletMarker
|
Polyline
!
LeafletPolyline
|
Polygon
!
LeafletPolygon
|
Circle
!
LeafletCircle
|
Rectangle
!
LeafletRectangle
|
Window
!
LeafletWindow
leafletObjectIdOf
::
!
LeafletObject
->
LeafletObjectID
::
LeafletObjectID
=:
LeafletObjectID
String
::
LeafletMarker
=
...
...
@@ -55,12 +59,29 @@ leafletEditor :: Editor LeafletMap
{
polylineId
::
!
LeafletObjectID
,
points
::
![
LeafletLatLng
]
,
style
::
![
LeafletStyleDef
LeafletLineStyle
]
,
editable
::
!
Bool
}
::
LeafletPolygon
=
{
polygonId
::
!
LeafletObjectID
,
points
::
![
LeafletLatLng
]
,
style
::
![
LeafletStyleDef
LeafletPolygonStyle
]
,
style
::
![
LeafletStyleDef
LeafletAreaStyle
]
,
editable
::
!
Bool
}
::
LeafletCircle
=
{
circleId
::
!
LeafletObjectID
,
center
::
!
LeafletLatLng
,
radius
::
!
Real
//* the radius (in meters)
,
style
::
![
LeafletStyleDef
LeafletAreaStyle
]
,
editable
::
!
Bool
}
::
LeafletRectangle
=
{
rectangleId
::
!
LeafletObjectID
,
bounds
::
!
LeafletBounds
,
style
::
![
LeafletStyleDef
LeafletAreaStyle
]
,
editable
::
!
Bool
}
::
LeafletWindow
=
...
...
@@ -77,13 +98,13 @@ leafletEditor :: Editor LeafletMap
|
LineOpacity
!
Real
// between 0.0 and 1.0
|
LineDashArray
!
String
// a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
::
Leaflet
PolygonStyle
=
Polygon
LineStrokeColor
!
String
// html/css color definition
|
Polygon
LineStrokeWidth
!
Int
|
Polygon
LineOpacity
!
Real
// between 0.0 and 1.0
|
Polygon
LineDashArray
!
String
// a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
|
Polygon
NoFill
// inside of polygone is not filled, all other fill options are ignored
|
Polygon
FillColor
!
String
// html/css color definition
|
Polygon
FillOpacity
!
Real
::
Leaflet
AreaStyle
=
Area
LineStrokeColor
!
String
// html/css color definition
|
Area
LineStrokeWidth
!
Int
|
Area
LineOpacity
!
Real
// between 0.0 and 1.0
|
Area
LineDashArray
!
String
// a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
|
Area
NoFill
// inside of polygone is not filled, all other fill options are ignored
|
Area
FillColor
!
String
// html/css color definition
|
Area
FillOpacity
!
Real
::
CSSClass
=:
CSSClass
String
::
LeafletStyleDef
style
=
Style
style
...
...
@@ -101,4 +122,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
,
Leaflet
PolygonStyle
derive
class
iTask
LeafletIcon
,
LeafletBounds
,
LeafletObject
,
LeafletMarker
,
LeafletPolyline
,
LeafletPolygon
,
LeafletWindow
,
LeafletWindowPos
,
LeafletLineStyle
,
LeafletStyleDef
,
Leaflet
AreaStyle
,
LeafletObjectID
Libraries/iTasks/Extensions/GIS/Leaflet.icl
View file @
36a5b36e
...
...
@@ -8,10 +8,12 @@ from Text.HTML import instance toString HtmlTag
from
iTasks
.
UI
.
Editor
.
Common
import
diffChildren
,
::
ChildUpdate
(..)
from
StdArray
import
class
Array
(
uselect
),
instance
Array
{}
a
LEAFLET_JS
:==
"/leaflet-1.3.4/leaflet.js"
LEAFLET_JS_WINDOW
:==
"leaflet-window.js"
LEAFLET_CSS
:==
"/leaflet-1.3.4/leaflet.css"
LEAFLET_CSS_WINDOW
:==
"leaflet-window.css"
LEAFLET_JS
:==
"/leaflet-1.3.4/leaflet.js"
LEAFLET_JS_WINDOW
:==
"leaflet-window.js"
// https://github.com/Leaflet/Leaflet.Editable
LEAFLET_JS_EDITABLE
:==
"Leaflet.Editable.js"
LEAFLET_CSS
:==
"/leaflet-1.3.4/leaflet.css"
LEAFLET_CSS_WINDOW
:==
"leaflet-window.css"
::
IconOptions
=
{
iconUrl
::
!
String
...
...
@@ -20,6 +22,7 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
::
MapOptions
=
{
attributionControl
::
!
Bool
,
zoomControl
::
!
Bool
,
editable
::
!
Bool
}
::
CursorOptions
=
{
color
::
!
String
...
...
@@ -29,11 +32,19 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
derive
JSONEncode
IconOptions
derive
JSEncode
LeafletEdit
,
LeafletBounds
,
LeafletLatLng
,
LeafletObjectID
derive
JSDecode
LeafletEdit
,
LeafletBounds
,
LeafletLatLng
,
LeafletObjectID
derive
JSEncode
LeafletEdit
,
LeafletBounds
,
LeafletLatLng
,
LeafletObjectID
,
LeafletObjectUpdate
derive
JSDecode
LeafletEdit
,
LeafletBounds
,
LeafletLatLng
,
LeafletObjectID
,
LeafletObjectUpdate
CURSOR_OPTIONS
:==
{
color
=
"#00f"
,
opacity
=
1.0
,
radius
=
3
}
MAP_OPTIONS
:==
{
attributionControl
=
False
,
zoomControl
=
True
}
MAP_OPTIONS
:==
{
attributionControl
=
False
,
zoomControl
=
True
,
editable
=
True
}
leafletObjectIdOf
::
!
LeafletObject
->
LeafletObjectID
leafletObjectIdOf
(
Marker
m
)
=
m
.
markerId
leafletObjectIdOf
(
Polyline
p
)
=
p
.
polylineId
leafletObjectIdOf
(
Polygon
p
)
=
p
.
polygonId
leafletObjectIdOf
(
Circle
c
)
=
c
.
circleId
leafletObjectIdOf
(
Rectangle
r
)
=
r
.
rectangleId
leafletObjectIdOf
(
Window
w
)
=
w
.
windowId
::
LeafletEdit
//Perspective
...
...
@@ -45,6 +56,13 @@ MAP_OPTIONS :== {attributionControl = False, zoomControl = True}
|
LDSelectMarker
!
LeafletObjectID
//Updating windows
|
LDRemoveWindow
!
LeafletObjectID
|
LDUpdateObject
!
LeafletObjectID
!
LeafletObjectUpdate
::
LeafletObjectUpdate
=
UpdatePolyline
![
LeafletLatLng
]
|
UpdatePolygon
![
LeafletLatLng
]
|
UpdateCircle
!
LeafletLatLng
!
Real
|
UpdateRectangle
!
LeafletBounds
openStreetMapTiles
::
String
openStreetMapTiles
=
"http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
...
...
@@ -85,6 +103,8 @@ where
in
uia
UIData
dataMap`
encodeUI
(
Polyline
o
)
=
let
(
JSONObject
attr
)
=
toJSON
o
in
uia
UIData
('
DM
'.
fromList
[(
"type"
,
JSONString
"polyline"
):
attr
])
encodeUI
(
Polygon
o
)
=
let
(
JSONObject
attr
)
=
toJSON
o
in
uia
UIData
('
DM
'.
fromList
[(
"type"
,
JSONString
"polygon"
)
:
attr
])
encodeUI
(
Circle
o
)
=
let
(
JSONObject
attr
)
=
toJSON
o
in
uia
UIData
('
DM
'.
fromList
[(
"type"
,
JSONString
"circle"
):
attr
])
encodeUI
(
Rectangle
o
)
=
let
(
JSONObject
attr
)
=
toJSON
o
in
uia
UIData
('
DM
'.
fromList
[(
"type"
,
JSONString
"rectangle"
)
:
attr
])
encodeUI
(
Window
o
)
=
let
(
JSONObject
attr
)
=
toJSON
o
dataMap
=
'
DM
'.
fromList
[(
"type"
,
JSONString
"window"
):
attr
]
// translate HtmlTag to HTML code
...
...
@@ -101,6 +121,7 @@ where
#
world
=
addCSSFromUrl
LEAFLET_CSS
world
#
world
=
addCSSFromUrl
LEAFLET_CSS_WINDOW
world
#
world
=
addJSFromUrl
LEAFLET_JS
Nothing
world
#
world
=
addJSFromUrl
LEAFLET_JS_EDITABLE
Nothing
world
#
world
=
addJSFromUrl
LEAFLET_JS_WINDOW
(
Just
jsInitDOM
)
world
=
world
|
otherwise
...
...
@@ -264,14 +285,17 @@ where
#
(
lng
,
world
)
=
.?
(
obj
.#
"lng"
)
world
=
({
LeafletLatLng
|
lat
=
jsValToReal
lat
,
lng
=
jsValToReal
lng
},
world
)
getMapBounds
mapObj
env
#
(
bounds
,
env
)
=
(
mapObj
.#
"getBounds"
.$
())
env
toBounds
bounds
env
#
(
sw
,
env
)
=
(
bounds
.#
"getSouthWest"
.$
())
env
#
(
ne
,
env
)
=
(
bounds
.#
"getNorthEast"
.$
())
env
#
(
swpos
,
env
)
=
toLatLng
sw
env
#
(
nepos
,
env
)
=
toLatLng
ne
env
=
({
southWest
=
swpos
,
northEast
=
nepos
},
env
)
getMapBounds
mapObj
env
#
(
bounds
,
env
)
=
(
mapObj
.#
"getBounds"
.$
())
env
=
toBounds
bounds
env
getMapZoom
mapObj
world
#
(
zoom
,
world
)
=
(
mapObj
.#
"getZoom"
.$
())
world
=
(
jsValToInt
zoom
,
world
)
...
...
@@ -337,11 +361,13 @@ where
createMapObject
viewMode
me
mapObj
l
object
world
#
(
type
,
world
)
=
.?
(
object
.#
"attributes.type"
)
world
=
case
jsValToString
type
of
"marker"
=
createMarker
me
mapObj
l
object
world
"polyline"
=
createPolyline
me
mapObj
l
object
world
"polygon"
=
createPolygon
me
mapObj
l
object
world
"window"
=
createWindow
viewMode
me
mapObj
l
object
world
_
=
world
"marker"
=
createMarker
me
mapObj
l
object
world
"polyline"
=
createPolyline
me
mapObj
l
object
world
"polygon"
=
createPolygon
me
mapObj
l
object
world
"circle"
=
createCircle
me
mapObj
l
object
world
"rectangle"
=
createRectangle
me
mapObj
l
object
world
"window"
=
createWindow
viewMode
me
mapObj
l
object
world
_
=
world
createMarker
me
mapObj
l
object
world
#
(
markerId
,
world
)
=
.?
(
object
.#
"attributes.markerId"
)
world
...
...
@@ -392,46 +418,123 @@ where
createPolyline
me
mapObj
l
object
world
//Set options
#
(
options
,
world
)
=
jsEmptyObject
world
#
(
style
,
world
)
=
.?
(
object
.#
"attributes.style"
)
world
#
world
=
forall
(
applyLineStyle
options
)
style
world
#
(
options
,
world
)
=
jsEmptyObject
world
#
(
style
,
world
)
=
.?
(
object
.#
"attributes.style"
)
world
#
world
=
forall
(
applyLineStyle
options
)
style
world
#
(
points
,
world
)
=
.?
(
object
.#
"attributes.points"
)
world
#
(
layer
,
world
)
=
(
l
.#
"polyline"
.$
(
points
,
options
))
world
#
(_,
world
)
=
(
layer
.#
"addTo"
.$
(
toJSArg
mapObj
))
world
#
(
layer
,
world
)
=
(
l
.#
"polyline"
.$
(
points
,
options
))
world
#
(_,
world
)
=
(
layer
.#
"addTo"
.$
(
toJSArg
mapObj
))
world
#
world
=
enableEdit
"polylineId"
me
mapObj
layer
object
getUpdate
world
#
world
=
(
object
.#
"layer"
.=
layer
)
world
=
world
createPolygon
me
mapObj
l
object
world
where
getUpdate
layer
world
#
(
points
,
world
)
=
(
layer
.#
"getLatLngs"
.$
())
world
#
(
points
,
world
)
=
fromJSArray
points
id
world
#
(
points
,
world
)
=
foldl
(\(
res
,
world
)
point
=
appFst
(\
latLng
->
[
latLng
:
res
])
$
toLatLng
point
world
)
([],
world
)
points
=
(
UpdatePolyline
$
reverse
points
,
world
)
createPolygon
me
mapObj
l
object
world
//Set options
#
(
options
,
world
)
=
jsEmptyObject
world
#
(
options
,
world
)
=
jsEmptyObject
world
#
(
style
,
world
)
=
.?
(
object
.#
"attributes.style"
)
world
#
world
=
forall
(
apply
Style
options
)
style
world
#
world
=
forall
(
applyArea
Style
options
)
style
world
#
(
points
,
world
)
=
.?
(
object
.#
"attributes.points"
)
world
#
(
layer
,
world
)
=
(
l
.#
"polygon"
.$
(
points
,
options
))
world
#
(_,
world
)
=
(
layer
.#
"addTo"
.$
(
toJSArg
mapObj
))
world
#
(
layer
,
world
)
=
(
l
.#
"polygon"
.$
(
points
,
options
))
world
#
(_,
world
)
=
(
layer
.#
"addTo"
.$
(
toJSArg
mapObj
))
world
#
world
=
enableEdit
"polygonId"
me
mapObj
layer
object
getUpdate
world
#
world
=
(
object
.#
"layer"
.=
layer
)
world
=
world
where
applyStyle
options
_
style
world
#
(
styleType
,
world
)
=
.?
(
style
.#
0
)
world
#
styleType
=
jsValToString
styleType
|
styleType
==
"Style"
#
(
directStyle
,
world
)
=
.?
(
style
.#
1
)
world
#
(
directStyleType
,
world
)
=
.?
(
directStyle
.#
0
)
world
#
(
directStyleVal
,
world
)
=
.?
(
directStyle
.#
1
)
world
#
directStyleType
=
jsValToString
directStyleType
|
directStyleType
==
"PolygonLineStrokeColor"
=
(
options
.#
"color"
.=
directStyleVal
)
world
|
directStyleType
==
"PolygonLineStrokeWidth"
=
(
options
.#
"weight"
.=
directStyleVal
)
world
|
directStyleType
==
"PolygonLineOpacity"
=
(
options
.#
"opacity"
.=
directStyleVal
)
world
|
directStyleType
==
"PolygonLineDashArray"
=
(
options
.#
"dashArray"
.=
directStyleVal
)
world
|
directStyleType
==
"PolygonNoFill"
=
(
options
.#
"fill"
.=
False
)
world
|
directStyleType
==
"PolygonFillColor"
=
(
options
.#
"fillColor"
.=
directStyleVal
)
world
|
directStyleType
==
"PolygonFillOpacity"
=
(
options
.#
"fillOpacity"
.=
directStyleVal
)
world
=
abort
"unknown style"
|
styleType
==
"Class"
#
(
cls
,
world
)
=
.?
(
style
.#
1
)
world
=
(
options
.#
"className"
.=
cls
)
world
=
abort
"unknown style"
where
getUpdate
layer
world
#
(
points
,
world
)
=
(
layer
.#
"getLatLngs"
.$
())
world
#
(
points
,
world
)
=
.?
(
points
.#
0
)
world
#
(
points
,
world
)
=
fromJSArray
points
id
world
#
(
points
,
world
)
=
foldl
(\(
res
,
world
)
point
=
appFst
(\
latLng
->
[
latLng
:
res
])
$
toLatLng
point
world
)
([],
world
)
points
=
(
UpdatePolygon
$
reverse
points
,
world
)
createCircle
me
mapObj
l
object
world
//Set options
#
(
options
,
world
)
=
jsEmptyObject
world
#
(
style
,
world
)
=
.?
(
object
.#
"attributes.style"
)
world
#
world
=
forall
(
applyAreaStyle
options
)
style
world
#
(
center
,
world
)
=
.?
(
object
.#
"attributes.center"
)
world
#
(
radius
,
world
)
=
.?
(
object
.#
"attributes.radius"
)
world
#
world
=
(
options
.#
"radius"
.=
radius
)
world
#
(
layer
,
world
)
=
(
l
.#
"circle"
.$
(
center
,
options
))
world
#
(_,
world
)
=
(
layer
.#
"addTo"
.$
(
toJSArg
mapObj
))
world
#
world
=
enableEdit
"circleId"
me
mapObj
layer
object
getUpdate
world
#
world
=
(
object
.#
"layer"
.=
layer
)
world
=
world
where
getUpdate
layer
world
#
(
radius
,
world
)
=
(
layer
.#
"getRadius"
.$
())
world
#
(
center
,
world
)
=
(
layer
.#
"getLatLng"
.$
())
world
#
(
center
,
world
)
=
toLatLng
center
world
=
(
UpdateCircle
center
$
jsValToReal
radius
,
world
)
createRectangle
me
mapObj
l
object
world
//Set options
#
(
options
,
world
)
=
jsEmptyObject
world
#
(
style
,
world
)
=
.?
(
object
.#
"attributes.style"
)
world
#
world
=
forall
(
applyAreaStyle
options
)
style
world
#
(
sw
,
world
)
=
.?
(
object
.#
"attributes.bounds.southWest"
)
world
#
(
ne
,
world
)
=
.?
(
object
.#
"attributes.bounds.northEast"
)
world
#
(
layer
,
world
)
=
(
l
.#
"rectangle"
.$
([
sw
,
ne
],
options
))
world
#
(_,
world
)
=
(
layer
.#
"addTo"
.$
(
toJSArg
mapObj
))
world
#
world
=
enableEdit
"rectangleId"
me
mapObj
layer
object
getUpdate
world
#
world
=
(
object
.#
"layer"
.=
layer
)
world
=
world
where
getUpdate
layer
world
#
(
bounds
,
world
)
=
(
layer
.#
"getBounds"
.$
())
world
#
(
bounds
,
world
)
=
toBounds
bounds
world
=
(
UpdateRectangle
bounds
,
world
)
enableEdit
idFieldName
me
mapObj
layer
object
getUpdate
world
#
(
isEditable
,
world
)
=
.?
(
object
.#
"attributes.editable"
)
world
|
not
$
jsValToBool
isEditable
=
world
#
(_,
world
)
=
(
layer
.#
"enableEdit"
.$
())
world
#
(
cb
,
world
)
=
jsWrapFun
(
onEditing
layer
)
world
#
(_,
world
)
=
(
layer
.#
"addEventListener"
.$
(
"editable:vertex:dragend"
,
cb
))
world
#
(_,
world
)
=
(
layer
.#
"addEventListener"
.$
(
"editable:vertex:new"
,
cb
))
world
#
(_,
world
)
=
(
layer
.#
"addEventListener"
.$
(
"editable:vertex:deleted"
,
cb
))
world
=
world
where
onEditing
layer
_
world
#
(
update
,
world
)
=
getUpdate
layer
world
#
(
objectId
,
world
)
=
.?
(
object
.#
"attributes."
+++
idFieldName
)
world
#
(
edit
,
world
)
=
encodeOnClient
[
LDUpdateObject
(
LeafletObjectID
(
jsValToString
objectId
))
update
]
world
#
(
taskId
,
world
)
=
.?
(
me
.#
"attributes.taskId"
)
world
#
(
editorId
,
world
)
=
.?
(
me
.#
"attributes.editorId"
)
world
#
(_,
world
)
=
((
me
.#
"doEditEvent"
)
.$
(
taskId
,
editorId
,
edit
))
world
=
(
jsNull
,
world
)
applyAreaStyle
options
_
style
world
#
(
styleType
,
world
)
=
.?
(
style
.#
0
)
world
#
styleType
=
jsValToString
styleType
|
styleType
==
"Style"
#
(
directStyle
,
world
)
=
.?
(
style
.#
1
)
world
#
(
directStyleType
,
world
)
=
.?
(
directStyle
.#
0
)
world
#
(
directStyleVal
,
world
)
=
.?
(
directStyle
.#
1
)
world
#
directStyleType
=
jsValToString
directStyleType
|
directStyleType
==
"AreaLineStrokeColor"
=
(
options
.#
"color"
.=
directStyleVal
)
world
|
directStyleType
==
"AreaLineStrokeWidth"
=
(
options
.#
"weight"
.=
directStyleVal
)
world
|
directStyleType
==
"AreaLineOpacity"
=
(
options
.#
"opacity"
.=
directStyleVal
)
world
|
directStyleType
==
"AreaLineDashArray"
=
(
options
.#
"dashArray"
.=
directStyleVal
)
world
|
directStyleType
==
"AreaNoFill"
=
(
options
.#
"fill"
.=
False
)
world
|
directStyleType
==
"AreaFillColor"
=
(
options
.#
"fillColor"
.=
directStyleVal
)
world
|
directStyleType
==
"AreaFillOpacity"
=
(
options
.#
"fillOpacity"
.=
directStyleVal
)
world
=
abort
"unknown style"
|
styleType
==
"Class"
#
(
cls
,
world
)
=
.?
(
style
.#
1
)
world
=
(
options
.#
"className"
.=
cls
)
world
=
abort
"unknown style"
createWindow
viewMode
me
mapObj
l
object
world
#
(
layer
,
world
)
=
l
.#
"window"
.$
()
$
world
...
...
@@ -514,9 +617,9 @@ where
onEdit
dp
([],
diffs
)
m
vst
=
(
Ok
(
NoChange
,
foldl
app
m
diffs
),
vst
)
where
app
m
(
LDSetZoom
zoom
)
=
{
LeafletMap
|
m
&
perspective
=
{
m
.
perspective
&
zoom
=
zoom
}}
app
m
(
LDSetCenter
center
)
=
{
LeafletMap
|
m
&
perspective
=
{
m
.
perspective
&
center
=
center
}}
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
=
{
m
.
perspective
&
bounds
=
Just
bounds
}}
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
}
...
...
@@ -525,6 +628,19 @@ where
where
notToRemove
(
Window
{
windowId
})
=
windowId
=!=
idToRemove
notToRemove
_
=
True
app
m
(
LDUpdateObject
objectId
upd
)
=
{
LeafletMap
|
m
&
objects
=
withUpdatedObject
<$>
m
.
LeafletMap
.
objects
}
where
withUpdatedObject
::
!
LeafletObject
->
LeafletObject
withUpdatedObject
obj
|
leafletObjectIdOf
obj
===
objectId
=
case
(
obj
,
upd
)
of
(
Polyline
polyline
,
UpdatePolyline
points
)
=
Polyline
{
LeafletPolyline
|
polyline
&
points
=
points
}
(
Polygon
polygon
,
UpdatePolygon
points
)
=
Polygon
{
LeafletPolygon
|
polygon
&
points
=
points
}
(
Circle
circle
,
UpdateCircle
center
radius
)
=
Circle
{
LeafletCircle
|
circle
&
center
=
center
,
radius
=
radius
}
(
Rectangle
rect
,
UpdateRectangle
bounds
)
=
Rectangle
{
LeafletRectangle
|
rect
&
bounds
=
bounds
}
withUpdatedObject
obj
=
obj
app
m
_
=
m
onEdit
_
_
msk
ust
=
(
Ok
(
NoChange
,
msk
),
ust
)
...
...
@@ -585,4 +701,4 @@ 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
,
Leaflet
PolygonStyle
,
LeafletObjectID
,
CSSClass
,
LeafletIconID
derive
class
iTask
LeafletIcon
,
LeafletBounds
,
LeafletObject
,
LeafletMarker
,
LeafletPolyline
,
LeafletPolygon
,
LeafletEdit
,
LeafletWindow
,
LeafletWindowPos
,
LeafletLineStyle
,
LeafletStyleDef
,
Leaflet
AreaStyle
,
LeafletObjectID
,
CSSClass
,
LeafletIconID
,
LeafletCircle
,
LeafletObjectUpdate
,
LeafletRectangle
Libraries/iTasks/Extensions/GIS/WebPublic/Leaflet.Editable.js
0 → 100644
View file @
36a5b36e
This diff is collapsed.
Click to expand it.
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment