forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Add typed Leaflet_map wrapper, use in Zarr notebook
Leaflet_map provides a type-safe OCaml interface to the Leaflet widget:
- Leaflet_map.create: typed config (center, zoom, height) + typed callbacks
(on_click receives latlng, on_bbox_drawn receives bounds)
- Leaflet_map.add_image_overlay: typed bounds + url + opacity
- Leaflet_map.add_marker: typed latlng + optional color/label
- All JSON serialization hidden inside the wrapper
The notebook no longer uses raw Widget.command/Scanf.sscanf for map
interaction. Compare:
Before: Widget.command ~id "addImageOverlay" (Printf.sprintf {|{...}|} ...)
After: Leaflet_map.add_image_overlay map ~url ~bounds ~opacity:0.7 ()
Before: Scanf.sscanf json {|{"lat":%f,"lng":%f}|} (fun a b -> ...)
After: on_click:(fun pt -> ... pt.lat ... pt.lng ...)
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
+264
-90
+1
-1
js_top_worker/widget-leaflet/dune
+1
-1
js_top_worker/widget-leaflet/dune
+109
js_top_worker/widget-leaflet/leaflet_map.ml
+109
js_top_worker/widget-leaflet/leaflet_map.ml
···
1
+
type t = { id : string }
2
+
3
+
type latlng = { lat : float; lng : float }
4
+
type bounds = { south : float; west : float; north : float; east : float }
5
+
type move_info = { center : latlng; zoom : int; bounds : bounds }
6
+
7
+
let id t = t.id
8
+
9
+
let cmd t name data =
10
+
Widget.command ~id:t.id name data
11
+
12
+
let parse_latlng json =
13
+
Scanf.sscanf json {| {"lat":%f,"lng":%f}|} (fun lat lng -> { lat; lng })
14
+
15
+
let parse_bounds json =
16
+
Scanf.sscanf json {| {"south":%f,"west":%f,"north":%f,"east":%f}|}
17
+
(fun s w n e -> { south = s; west = w; north = n; east = e })
18
+
19
+
let parse_move json =
20
+
(* moveend sends: {"center":[lat,lng],"zoom":z,"bounds":{"south":...}} *)
21
+
let j = Yojson.Safe.from_string json in
22
+
let member k = function
23
+
| `Assoc l -> (try List.assoc k l with Not_found -> `Null)
24
+
| _ -> `Null in
25
+
let to_float = function `Float f -> f | `Int i -> Float.of_int i | _ -> 0.0 in
26
+
let center = match member "center" j with
27
+
| `List [lat; lng] -> { lat = to_float lat; lng = to_float lng }
28
+
| _ -> { lat = 0.0; lng = 0.0 } in
29
+
let zoom = match member "zoom" j with
30
+
| `Int z -> z | _ -> 0 in
31
+
let b = member "bounds" j in
32
+
let bounds = {
33
+
south = to_float (member "south" b);
34
+
west = to_float (member "west" b);
35
+
north = to_float (member "north" b);
36
+
east = to_float (member "east" b);
37
+
} in
38
+
{ center; zoom; bounds }
39
+
40
+
let create ?(id = "leaflet-map") ?tile_url ?(height = "500px")
41
+
~center:(clat, clng) ~zoom
42
+
?on_click ?on_bbox_drawn ?on_move () =
43
+
let t = { id } in
44
+
let config_parts =
45
+
[ Printf.sprintf {|"center":[%f,%f]|} clat clng;
46
+
Printf.sprintf {|"zoom":%d|} zoom;
47
+
Printf.sprintf {|"height":"%s"|} height ]
48
+
@ (match tile_url with
49
+
| Some url -> [Printf.sprintf {|"tileUrl":"%s"|} url]
50
+
| None -> [])
51
+
in
52
+
let config = "{" ^ String.concat "," config_parts ^ "}" in
53
+
let handlers = List.filter_map Fun.id [
54
+
(match on_click with
55
+
| Some f -> Some ("click", (fun v ->
56
+
match v with Some j -> f (parse_latlng j) | None -> ()))
57
+
| None -> None);
58
+
(match on_bbox_drawn with
59
+
| Some f -> Some ("bbox_drawn", (fun v ->
60
+
match v with Some j -> f (parse_bounds j) | None -> ()))
61
+
| None -> None);
62
+
(match on_move with
63
+
| Some f -> Some ("moveend", (fun v ->
64
+
match v with Some j -> f (parse_move j) | None -> ()))
65
+
| None -> None);
66
+
] in
67
+
Widget.display_managed ~id ~kind:"leaflet-map" ~config ~handlers;
68
+
t
69
+
70
+
let fly_to t { lat; lng } ?zoom () =
71
+
let data = match zoom with
72
+
| Some z -> Printf.sprintf {|{"lat":%f,"lng":%f,"zoom":%d}|} lat lng z
73
+
| None -> Printf.sprintf {|{"lat":%f,"lng":%f}|} lat lng
74
+
in
75
+
cmd t "flyTo" data
76
+
77
+
let fit_bounds t { south; west; north; east } =
78
+
cmd t "fitBounds"
79
+
(Printf.sprintf {|[[%f,%f],[%f,%f]]|} south west north east)
80
+
81
+
let set_data t geojson =
82
+
cmd t "setData" geojson
83
+
84
+
let invalidate_size t =
85
+
cmd t "invalidateSize" ""
86
+
87
+
let enable_bbox_draw t =
88
+
cmd t "enableBboxDraw" ""
89
+
90
+
let add_image_overlay t ~url ~bounds ?(opacity = 0.7) () =
91
+
cmd t "addImageOverlay"
92
+
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":%f}|}
93
+
url bounds.south bounds.west bounds.north bounds.east opacity)
94
+
95
+
let remove_image_overlay t =
96
+
cmd t "removeImageOverlay" ""
97
+
98
+
let add_marker t { lat; lng } ?(color = "#ff0000") ?label () =
99
+
let data = match label with
100
+
| Some l ->
101
+
Printf.sprintf {|{"lat":%f,"lng":%f,"color":"%s","label":"%s"}|}
102
+
lat lng color l
103
+
| None ->
104
+
Printf.sprintf {|{"lat":%f,"lng":%f,"color":"%s"}|} lat lng color
105
+
in
106
+
cmd t "addMarker" data
107
+
108
+
let clear_markers t =
109
+
cmd t "clearMarkers" ""
+93
js_top_worker/widget-leaflet/leaflet_map.mli
+93
js_top_worker/widget-leaflet/leaflet_map.mli
···
1
+
(** Type-safe interface to the Leaflet map widget.
2
+
3
+
Wraps the string-based [Widget.command] and handler protocol with
4
+
typed OCaml functions. All JSON serialization is handled internally.
5
+
6
+
{2 Example}
7
+
8
+
{[
9
+
let map = Leaflet_map.create ~center:(52.2, 0.12) ~zoom:13 () in
10
+
Leaflet_map.on_bbox_drawn map (fun bbox ->
11
+
Printf.printf "Selected: %f,%f to %f,%f\n"
12
+
bbox.south bbox.west bbox.north bbox.east);
13
+
Leaflet_map.enable_bbox_draw map;
14
+
Leaflet_map.add_image_overlay map ~url ~bounds ~opacity:0.7
15
+
]} *)
16
+
17
+
(** {1 Types} *)
18
+
19
+
type t
20
+
(** A Leaflet map widget. *)
21
+
22
+
type latlng = { lat : float; lng : float }
23
+
(** A geographic point. *)
24
+
25
+
type bounds = { south : float; west : float; north : float; east : float }
26
+
(** A geographic bounding box. *)
27
+
28
+
type move_info = {
29
+
center : latlng;
30
+
zoom : int;
31
+
bounds : bounds;
32
+
}
33
+
(** Information sent on map move events. *)
34
+
35
+
(** {1 Creating a map} *)
36
+
37
+
val create :
38
+
?id:string ->
39
+
?tile_url:string ->
40
+
?height:string ->
41
+
center:float * float ->
42
+
zoom:int ->
43
+
?on_click:(latlng -> unit) ->
44
+
?on_bbox_drawn:(bounds -> unit) ->
45
+
?on_move:(move_info -> unit) ->
46
+
unit -> t
47
+
(** Create and display a Leaflet map widget.
48
+
49
+
@param id Widget ID (default: ["leaflet-map"])
50
+
@param tile_url Tile server URL (default: OpenStreetMap)
51
+
@param height CSS height (default: ["500px"])
52
+
@param center Initial center as [(lat, lng)]
53
+
@param zoom Initial zoom level
54
+
@param on_click Called when the map is clicked
55
+
@param on_bbox_drawn Called when a bounding box is drawn
56
+
@param on_move Called when the map view changes *)
57
+
58
+
(** {1 Map ID} *)
59
+
60
+
val id : t -> string
61
+
(** The widget ID of this map. *)
62
+
63
+
(** {1 Commands} *)
64
+
65
+
val fly_to : t -> latlng -> ?zoom:int -> unit -> unit
66
+
(** Smoothly pan/zoom to a location. *)
67
+
68
+
val fit_bounds : t -> bounds -> unit
69
+
(** Fit the map view to a bounding box. *)
70
+
71
+
val set_data : t -> string -> unit
72
+
(** Set GeoJSON data on the map. [data] is a GeoJSON string. *)
73
+
74
+
val invalidate_size : t -> unit
75
+
(** Notify the map that its container size changed. *)
76
+
77
+
val enable_bbox_draw : t -> unit
78
+
(** Enter bounding-box drawing mode. The user draws a rectangle
79
+
by clicking and dragging. Fires the [on_bbox_drawn] callback. *)
80
+
81
+
val add_image_overlay : t -> url:string -> bounds:bounds ->
82
+
?opacity:float -> unit -> unit
83
+
(** Add (or replace) an image overlay on the map. *)
84
+
85
+
val remove_image_overlay : t -> unit
86
+
(** Remove the current image overlay. *)
87
+
88
+
val add_marker : t -> latlng -> ?color:string -> ?label:string ->
89
+
unit -> unit
90
+
(** Add a circle marker at a location. *)
91
+
92
+
val clear_markers : t -> unit
93
+
(** Remove all markers. *)
+61
-89
site/notebooks/interactive_map_zarr.mld
+61
-89
site/notebooks/interactive_map_zarr.mld
···
14
14
#require "tessera-tfjs";;
15
15
#require "js_top_worker-widget-leaflet";;
16
16
Widget_leaflet.register ();;
17
-
(* Load TensorFlow.js and fzstd (Zstd decompressor) *)
17
+
(* Load fzstd (Zstd decompressor) and TensorFlow.js *)
18
18
let () =
19
19
let open Js_of_ocaml in
20
20
let import url = Js.Unsafe.fun_call
···
32
32
updates the overlay.
33
33
34
34
{@ocaml x[
35
-
(* --- Configuration --- *)
36
-
37
-
let map_id = "tessera-map"
38
35
let class_colors = [| "#2196F3"; "#4CAF50"; "#FF9800"; "#9C27B0"; "#F44336";
39
36
"#00BCD4"; "#795548"; "#607D8B" |]
40
37
···
47
44
48
45
let () = Widget.display ~id:"status" ~handlers:[] (status_view "Draw a rectangle on the map.")
49
46
50
-
(* --- Signals: bbox from map draw events --- *)
47
+
(* --- FRP signals --- *)
51
48
52
49
let bbox_signal, set_bbox =
53
50
Note.S.create ~eq:(fun a b -> a = b) (None : Geotessera.bbox option)
54
-
55
-
(* --- Signals: training points from map clicks --- *)
56
51
57
52
let current_class_signal, set_current_class = Note.S.create ~eq:Int.equal 0
58
53
let class_names_signal, set_class_names =
···
60
55
let training_points_signal, set_training_points =
61
56
Note.S.create ~eq:(fun _ _ -> false) ([] : (float * float * int) list)
62
57
63
-
(* --- Map widget --- *)
58
+
(* --- Map widget (typed interface) --- *)
64
59
65
-
let () =
66
-
Widget.display_managed ~id:map_id
67
-
~kind:"leaflet-map"
68
-
~config:{| {"center": [52.2, 0.12], "zoom": 13, "height": "500px"} |}
69
-
~handlers:[
70
-
"bbox_drawn", (fun v ->
71
-
match v with
72
-
| Some json ->
73
-
let b = Scanf.sscanf json
74
-
{| {"south":%f,"west":%f,"north":%f,"east":%f}|}
75
-
(fun s w n e -> Geotessera.{ min_lat = s; min_lon = w;
76
-
max_lat = n; max_lon = e }) in
77
-
set_bbox (Some b)
78
-
| None -> ());
79
-
"click", (fun v ->
80
-
match v with
81
-
| Some json ->
82
-
let lat, lng = Scanf.sscanf json
83
-
{| {"lat":%f,"lng":%f}|} (fun a b -> (a, b)) in
84
-
let cls = Note.S.value current_class_signal in
85
-
let points = Note.S.value training_points_signal in
86
-
set_training_points ((lat, lng, cls) :: points);
87
-
let color = class_colors.(cls mod Array.length class_colors) in
88
-
let names = Note.S.value class_names_signal in
89
-
let label = names.(cls) in
90
-
Widget.command ~id:map_id "addMarker"
91
-
(Printf.sprintf {|{"lat":%f,"lng":%f,"color":"%s","label":"%s"}|}
92
-
lat lng color label)
93
-
| None -> ());
94
-
]
60
+
let map = Leaflet_map.create
61
+
~center:(52.2, 0.12) ~zoom:13 ~height:"500px"
62
+
~on_bbox_drawn:(fun b ->
63
+
set_bbox (Some Geotessera.{
64
+
min_lat = b.south; min_lon = b.west;
65
+
max_lat = b.north; max_lon = b.east }))
66
+
~on_click:(fun pt ->
67
+
let cls = Note.S.value current_class_signal in
68
+
let points = Note.S.value training_points_signal in
69
+
set_training_points ((pt.lat, pt.lng, cls) :: points);
70
+
let color = class_colors.(cls mod Array.length class_colors) in
71
+
let names = Note.S.value class_names_signal in
72
+
Leaflet_map.add_marker map pt ~color ~label:names.(cls) ())
73
+
()
95
74
96
-
let () = Widget.command ~id:map_id "enableBboxDraw" ""
75
+
let () = Leaflet_map.enable_bbox_draw map
97
76
98
77
(* --- Async pipeline: bbox → fetch → mosaic --- *)
99
78
···
101
80
mat : Linalg.mat;
102
81
h : int;
103
82
w : int;
104
-
bounds : Geotessera.bbox;
83
+
bounds : Leaflet_map.bounds;
105
84
}
106
85
107
-
(* Downsample helper *)
108
86
let downsample mat ~h ~w ~max_pixels =
109
87
let n = h * w in
110
88
if n <= max_pixels then (mat, h, w)
···
125
103
done;
126
104
(out, h', w')
127
105
128
-
(* The core reactive pipeline: bbox changes → async fetch → mosaic state *)
129
106
let mosaic_signal : mosaic_data Tessera_zarr_jsoo.Frp_async.state Note.signal =
130
107
Tessera_zarr_jsoo.Frp_async.async_bind bbox_signal
131
108
(fun bbox progress ->
132
109
progress "Opening Zarr store...";
133
110
let open Lwt.Syntax in
134
111
let* store = Tessera_zarr_jsoo.open_store () in
135
-
let* (mat_full, h_full, w_full, bounds) =
112
+
let* (mat_full, h_full, w_full, geo_bounds) =
136
113
Tessera_zarr.fetch_region ~progress ~store bbox in
137
114
progress (Printf.sprintf "Fetched %d×%d. Downsampling..." h_full w_full);
138
115
let (mat, h, w) = downsample mat_full ~h:h_full ~w:w_full ~max_pixels:50_000 in
116
+
let bounds = Leaflet_map.{
117
+
south = geo_bounds.Geotessera.min_lat;
118
+
north = geo_bounds.Geotessera.max_lat;
119
+
west = geo_bounds.Geotessera.min_lon;
120
+
east = geo_bounds.Geotessera.max_lon;
121
+
} in
139
122
Lwt.return { mat; h; w; bounds })
140
123
141
-
(* PCA: runs synchronously when mosaic becomes Ready *)
124
+
(* PCA: runs when mosaic becomes Ready *)
142
125
let pca_signal : Linalg.mat option Note.signal =
143
126
Note.S.map (function
144
127
| Tessera_zarr_jsoo.Frp_async.Ready m ->
···
146
129
| _ -> None
147
130
) mosaic_signal
148
131
149
-
(* --- Overlay: update map when PCA result changes --- *)
150
-
151
-
let _overlay_logr = Note.Logr.create (
152
-
Note.Logr.app (Note.Logr.const (fun pca_opt ->
153
-
match pca_opt, Note.S.value mosaic_signal with
154
-
| Some proj, Tessera_zarr_jsoo.Frp_async.Ready m ->
155
-
let pca_img = Viz.pca_to_rgba ~width:m.w ~height:m.h proj in
156
-
let url = Viz_jsoo.to_data_url pca_img in
157
-
Widget.command ~id:map_id "addImageOverlay"
158
-
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
159
-
url m.bounds.min_lat m.bounds.min_lon
160
-
m.bounds.max_lat m.bounds.max_lon)
161
-
| _ -> ()
162
-
)) (Note.S.obs pca_signal))
132
+
(* Overlay: update map when PCA result changes *)
133
+
let _overlay_logr =
134
+
let logr = Note.Logr.create (
135
+
Note.Logr.app (Note.Logr.const (fun pca_opt ->
136
+
match pca_opt, Note.S.value mosaic_signal with
137
+
| Some proj, Tessera_zarr_jsoo.Frp_async.Ready m ->
138
+
let img = Viz.pca_to_rgba ~width:m.w ~height:m.h proj in
139
+
let url = Viz_jsoo.to_data_url img in
140
+
Leaflet_map.add_image_overlay map ~url ~bounds:m.bounds ~opacity:0.7 ()
141
+
| _ -> ()
142
+
)) (Note.S.obs pca_signal))
143
+
in Note.Logr.hold logr
163
144
164
-
let () = Note.Logr.hold _overlay_logr
165
-
166
-
(* --- Status: update status display reactively --- *)
167
-
168
-
let _status_logr = Note.Logr.create (
169
-
Note.Logr.app (Note.Logr.const (fun state ->
170
-
let text = match state with
171
-
| Tessera_zarr_jsoo.Frp_async.Idle ->
172
-
"Draw a rectangle on the map."
173
-
| Tessera_zarr_jsoo.Frp_async.Loading msg ->
174
-
Printf.sprintf "Loading: %s" msg
175
-
| Tessera_zarr_jsoo.Frp_async.Ready m ->
176
-
Printf.sprintf "Ready: %d×%d mosaic. Click to add training points."
177
-
m.h m.w
178
-
| Tessera_zarr_jsoo.Frp_async.Error msg ->
179
-
Printf.sprintf "Error: %s" msg
180
-
in
181
-
Widget.update ~id:"status" (status_view text)
182
-
)) (Note.S.obs mosaic_signal))
183
-
184
-
let () = Note.Logr.hold _status_logr
145
+
(* Status: update display reactively *)
146
+
let _status_logr =
147
+
let logr = Note.Logr.create (
148
+
Note.Logr.app (Note.Logr.const (fun state ->
149
+
let text = match state with
150
+
| Tessera_zarr_jsoo.Frp_async.Idle ->
151
+
"Draw a rectangle on the map."
152
+
| Loading msg -> Printf.sprintf "Loading: %s" msg
153
+
| Ready m ->
154
+
Printf.sprintf "Ready: %d×%d mosaic. Click to add training points." m.h m.w
155
+
| Error msg -> Printf.sprintf "Error: %s" msg
156
+
in
157
+
Widget.update ~id:"status" (status_view text)
158
+
)) (Note.S.obs mosaic_signal))
159
+
in Note.Logr.hold logr
185
160
]}
186
161
187
162
{1 Label training points}
188
163
189
164
Click on the map to add training points. Use the buttons below to
190
-
switch between classes.
165
+
switch classes, classify, or clear.
191
166
192
167
{@ocaml x[
193
168
let make_class_buttons () =
···
258
233
let train_mat = Linalg.create_mat ~rows:n_train ~cols:m.mat.Linalg.cols in
259
234
let train_labels = Array.make n_train 0 in
260
235
List.iteri (fun i (lat, lng, cls) ->
261
-
let row = int_of_float ((m.bounds.max_lat -. lat) /.
262
-
(m.bounds.max_lat -. m.bounds.min_lat) *. float_of_int m.h) in
263
-
let col = int_of_float ((lng -. m.bounds.min_lon) /.
264
-
(m.bounds.max_lon -. m.bounds.min_lon) *. float_of_int m.w) in
236
+
let row = int_of_float ((m.bounds.north -. lat) /.
237
+
(m.bounds.north -. m.bounds.south) *. float_of_int m.h) in
238
+
let col = int_of_float ((lng -. m.bounds.west) /.
239
+
(m.bounds.east -. m.bounds.west) *. float_of_int m.w) in
265
240
let row = max 0 (min (m.h - 1) row) in
266
241
let col = max 0 (min (m.w - 1) col) in
267
242
let src = (row * m.w + col) * m.mat.Linalg.cols in
···
282
257
~predictions:result.Linalg.predictions
283
258
~colors ~width:m.w ~height:m.h () in
284
259
let url = Viz_jsoo.to_data_url img in
285
-
Widget.command ~id:map_id "addImageOverlay"
286
-
(Printf.sprintf {|{"url":"%s","bounds":[[%f,%f],[%f,%f]],"opacity":0.7}|}
287
-
url m.bounds.min_lat m.bounds.min_lon
288
-
m.bounds.max_lat m.bounds.max_lon);
260
+
Leaflet_map.add_image_overlay map ~url ~bounds:m.bounds ~opacity:0.7 ();
289
261
Widget.update ~id:"status"
290
262
(status_view (Printf.sprintf "Classification complete! %d classes, %d points."
291
263
n_classes n_train))
···
293
265
Widget.update ~id:"status" (status_view "Need mosaic + training points first.")));
294
266
"clear_points", (fun _v ->
295
267
set_training_points [];
296
-
Widget.command ~id:map_id "clearMarkers" "";
268
+
Leaflet_map.clear_markers map;
297
269
Widget.update ~id:"status" (status_view "Cleared all training points."));
298
270
]
299
271
in