swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

use leaflet lib

Browse source
This commit is contained in:
Swrup 2022-04-08 10:39:20 +02:00
parent ce7bb9d386
commit ccba00b2e7
5 changed files with 78 additions and 117 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.ocamlformat
View file

@ -1,4 +1,4 @@
version=0.21.0
version=0.24.1
assignment-operator=end-line
break-cases=fit
break-fun-decl=wrap

2
src/image.ml
View file

@ -115,7 +115,7 @@ let make_thumbnail content =
Cmd.(
v "convert" % "-define" % "jpeg:size=700x700" % p image_file
% "-auto-orient" % "-thumbnail" % "300x300>" % "-unsharp" % "0x.5"
% "-format" % "jpg" % p thumb_file)
% "-format" % "jpg" % p thumb_file )
in
let* () = OS.Cmd.run cmd in
let* thumbnail = OS.File.read thumb_file in

4
src/js/dune
View file

@ -15,7 +15,7 @@
(library
(name js_map)
(modules js_map)
(libraries js_of_ocaml brr)
(libraries js_of_ocaml brr leaflet)
(js_of_ocaml
(javascript_files leaflet/leaflet.js))
(preprocess
@ -32,7 +32,7 @@
(executable
(name js_babillard)
(modules js_babillard)
(libraries js_of_ocaml brr js_map js_post_form js_pretty_post)
(libraries js_of_ocaml brr js_map js_post_form js_pretty_post leaflet)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))

36
src/js/js_babillard.ml
View file

@ -32,7 +32,7 @@ module Visibility = struct
set_visible return_button;
set_invisible thread_preview_div;
Option.iter set_invisible new_thread_button;
ignore @@ Jv.call Leaflet.map "closePopup" [||]
Leaflet.Map.close_popup ~popup:None map
let to_babillard_mode _event =
log "change_page_mode@\n";
@ -41,7 +41,7 @@ module Visibility = struct
set_invisible return_button;
set_visible thread_preview_div;
Option.iter set_visible new_thread_button;
ignore @@ Jv.call Leaflet.map "closePopup" [||]
Leaflet.Map.close_popup ~popup:None map
let () =
log "add events on return/new thread button@\n";
@ -71,15 +71,14 @@ module Marker = struct
log "on_each_feature@\n";
let feature_properties = Jv.get feature "properties" in
let thread_preview = Jv.get feature_properties "content" in
ignore
@@ Jv.call layer "on"
[| Jv.of_string "click"; Jv.repr (marker_on_click thread_preview) |]
Leaflet.Layer.on Leaflet.Event.Click (marker_on_click thread_preview) layer
let handle_geojson geojson =
log "handle_geojson@\n";
let dict = Jv.obj [| ("onEachFeature", Jv.repr on_each_feature) |] in
let layer = Jv.call Leaflet.leaflet "geoJSON" [| geojson; dict |] in
let _marker_layer = Jv.call layer "addTo" [| Leaflet.map |] in
let layer =
Leaflet.Layer.create_geojson geojson [ On_each_feature on_each_feature ]
in
let _marker_layer = Leaflet.Layer.add_to map layer in
()
let markers_handle_response response =
@ -104,22 +103,19 @@ let button = Jv.get Jv.global "submit-new-thread-button"
let on_click_set_latlng e =
log "on_click_set_latlng@\n";
if !Visibility.is_in_new_thread_mode then (
let lat_lng = Jv.get e "latlng" in
ignore @@ Jv.call Leaflet.popup "setLatLng" [| lat_lng |];
ignore
@@ Jv.call Leaflet.popup "setContent"
[| Jv.of_string "create thread here" |];
ignore @@ Jv.call Leaflet.popup "openOn" [| Leaflet.map |];
let latlng = Leaflet.Event.latlng e in
let popup =
Leaflet.Popup.create ~content:(Some "create thread here")
~latlng:(Some latlng) []
in
Leaflet.Map.open_popup popup map;
let lat = Jv.get lat_lng "lat" in
let lng = Jv.get lat_lng "lng" in
let lat = Leaflet.Latlng.lat latlng |> Jv.of_float in
let lng = Leaflet.Latlng.lng latlng |> Jv.of_float in
ignore @@ Jv.call lat_input "setAttribute" [| Jv.of_string "value"; lat |];
ignore @@ Jv.call lng_input "setAttribute" [| Jv.of_string "value"; lng |];
ignore @@ Jv.call button "removeAttribute" [| Jv.of_string "disabled" |] )
(*add on_click callback to map*)
let () =
ignore
@@ Jv.call Leaflet.map "on"
[| Jv.of_string "click"; Jv.repr on_click_set_latlng |]
let () = Leaflet.Map.on Leaflet.Event.Click on_click_set_latlng map

151
src/js/js_map.ml
View file

@ -1,101 +1,68 @@
let log = Format.printf
module Leaflet = struct
(* get the leaflet object *)
let leaflet =
match Jv.(find global "L") with
| Some l -> l
| None -> failwith "can't load leaflet"
let map = Leaflet.Map.create_on "map"
(* get popup object *)
let popup = Jv.call leaflet "popup" [||]
let () =
let osm_layer = Leaflet.Layer.create_tile_osm None in
Leaflet.Layer.add_to map osm_layer
(* create a map *)
let map =
log "creating map@\n";
let open Brr in
let _container = El.div ~at:At.[ id (Jstr.v "map") ] [] in
Jv.call leaflet "map" [| Jv.of_string "map" |]
let storage = Brr_io.Storage.local Brr.G.window
(* create map tile layer *)
let tile_layer =
log "creating tile layer@\n";
Jv.call leaflet "tileLayer"
[| Jv.of_string "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
; Jv.obj
[| ( "attribution"
, Jv.of_string
{|&copy; <a href="https://.www.openstreetmap.org/copyright">OpenStreetMap</a> contributors|}
)
|]
|]
(* set map's view *)
(* try to set map's view to last position viewed by using web storage *)
let () =
log "setting view@\n";
let lat = Brr_io.Storage.get_item storage (Jstr.of_string "lat") in
let lng = Brr_io.Storage.get_item storage (Jstr.of_string "lng") in
let zoom = Brr_io.Storage.get_item storage (Jstr.of_string "zoom") in
match (lat, lng, zoom) with
| Some lat, Some lng, Some zoom ->
let lat = Jstr.to_float lat in
let lng = Jstr.to_float lng in
let zoom =
match Jstr.to_int zoom with
| None -> failwith "view storage bug"
| Some zoom -> Some zoom
in
let latlng = Leaflet.Latlng.create lat lng in
ignore @@ Leaflet.Map.set_view latlng ~zoom map
| _ ->
let latlng = Leaflet.Latlng.create 51.505 (-0.09) in
ignore @@ Leaflet.Map.set_view latlng ~zoom:(Some 13) map
(* add tile layer *)
let () =
log "adding tile layer@\n";
let _map : Jv.t = Jv.call tile_layer "addTo" [| map |] in
()
let storage = Brr_io.Storage.local Brr.G.window
(* set map's view *)
(* try to set map's view to last position viewed by using web storage *)
let () =
log "setting view@\n";
let lat = Brr_io.Storage.get_item storage (Jstr.of_string "lat") in
let lng = Brr_io.Storage.get_item storage (Jstr.of_string "lng") in
let zoom = Brr_io.Storage.get_item storage (Jstr.of_string "zoom") in
match (lat, lng, zoom) with
| Some lat, Some lng, Some zoom ->
let latlng =
Jv.call leaflet "latLng" [| Jv.of_jstr lat; Jv.of_jstr lng |]
in
ignore @@ Jv.call map "setView" [| latlng; Jv.of_jstr zoom |]
| _ ->
let latlng =
Jv.call leaflet "latLng" [| Jv.of_float 51.505; Jv.of_float (-0.09) |]
in
ignore @@ Jv.call map "setView" [| latlng; Jv.of_int 13 |]
let on_moveend _event =
log "on moveend event@\n";
let latlng = Jv.call map "getCenter" [||] in
(*we need to wrap coordinates so we don't drift into a parralel universe and lose track of markers :^) *)
let wrapped_latlng = Jv.call map "wrapLatLng" [| latlng |] in
let lat = Jv.get wrapped_latlng "lat" in
let lng = Jv.get wrapped_latlng "lng" in
match
Brr_io.Storage.set_item storage (Jstr.of_string "lat") (Jv.to_jstr lat)
with
let on_moveend _event =
log "on moveend event@\n";
let latlng = Leaflet.Map.get_center map in
(*we need to wrap coordinates so we don't drift into a parralel universe and lose track of markers :^) *)
let wrapped_latlng = Leaflet.Map.wrap_latlng latlng map in
let lat = Leaflet.Latlng.lat latlng |> Jv.of_float |> Jv.to_jstr in
let lng = Leaflet.Latlng.lng latlng |> Jv.of_float |> Jv.to_jstr in
match Brr_io.Storage.set_item storage (Jstr.of_string "lat") lat with
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> (
match Brr_io.Storage.set_item storage (Jstr.of_string "lng") lng with
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> (
match
Brr_io.Storage.set_item storage (Jstr.of_string "lng") (Jv.to_jstr lng)
with
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () ->
let is_wrapped =
not @@ Jv.to_bool @@ Jv.call latlng "equals" [| wrapped_latlng |]
in
if is_wrapped then (
log "setView to wrapped coordinate@\n";
(* warning: calling setView in on_moveend can cause recursion *)
ignore @@ Jv.call map "setView" [| wrapped_latlng |] ) )
| Ok () ->
let is_wrapped = not @@ Leaflet.Latlng.equals latlng wrapped_latlng in
if is_wrapped then (
log "setView to wrapped coordinate@\n";
(* warning: calling setView in on_moveend can cause recursion *)
Leaflet.Map.set_view wrapped_latlng ~zoom:None map ) )
let on_zoomend _event =
log "on zoomend event@\n";
let zoom = Jv.call map "getZoom" [||] in
match
Brr_io.Storage.set_item storage (Jstr.of_string "zoom") (Jv.to_jstr zoom)
with
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> ()
let on_zoomend _event =
log "on zoomend event@\n";
let zoom = Leaflet.Map.get_zoom map in
match
Brr_io.Storage.set_item storage (Jstr.of_string "zoom")
(Jv.to_jstr @@ Jv.of_int zoom)
with
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> ()
let () =
log "add on (move/zoom)end event@\n";
ignore @@ Jv.call map "on" [| Jv.of_string "moveend"; Jv.repr on_moveend |];
ignore @@ Jv.call map "on" [| Jv.of_string "zoomend"; Jv.repr on_zoomend |]
end
let () =
log "add on (move/zoom)end event@\n";
Leaflet.Map.on Leaflet.Event.Move_end on_moveend map;
Leaflet.Map.on Leaflet.Event.Zoom_end on_zoomend map
module Geolocalize = struct
let update_location geo =
@ -105,10 +72,8 @@ module Geolocalize = struct
| Ok geo ->
let lat = Brr_io.Geolocation.Pos.latitude geo in
let lng = Brr_io.Geolocation.Pos.longitude geo in
let latlng =
Jv.call Leaflet.leaflet "latLng" [| Jv.of_float lat; Jv.of_float lng |]
in
ignore @@ Jv.call Leaflet.map "setView" [| latlng; Jv.of_int 13 |]
let latlng = Leaflet.Latlng.create lat lng in
Leaflet.Map.set_view latlng ~zoom:(Some 13) map
let geolocalize _ =
log "geolocalize@\n";