Reusable 3D Earth globe widget (pure OCaml + WebGL)
Unified Satellite.v with optional ~propagate
+150
-117
+49
README.md
+49
README.md
···
1
+
# globe
2
+
3
+
Reusable 3D Earth globe widget (pure OCaml + WebGL).
4
+
5
+
Interactive 3D globe with dot-cloud Earth rendering, satellite orbits, ground coverage footprints, coordinate grid, and star background. Pure OCaml compiled to JavaScript via js_of_ocaml, using WebGL2 for rendering and Brr for DOM interaction.
6
+
7
+
## Installation
8
+
9
+
```
10
+
opam install globe
11
+
```
12
+
13
+
## Usage
14
+
15
+
```ocaml
16
+
(* Initialize a globe scene on a canvas element *)
17
+
let scene = Globe_webgl.Scene.v canvas_el in
18
+
19
+
(* Add satellites from J2000 state vectors *)
20
+
let sat =
21
+
Globe.Satellite.v ~pos ~vel ~color:(Globe.Color.v 0.2 0.8 1.0 1.0)
22
+
~epoch_unix:t0 ()
23
+
in
24
+
Globe_webgl.Scene.set_satellites scene [ sat ];
25
+
26
+
(* Render loop *)
27
+
let frame = Globe_webgl.Scene.begin_frame scene dt in
28
+
Globe_webgl.Scene.update_time scene current_unix;
29
+
Globe_webgl.Scene.draw scene frame Globe_webgl.Scene.default_layers
30
+
```
31
+
32
+
## API Overview
33
+
34
+
### Core (`Globe`)
35
+
- **`Sphere`** -- Dot-cloud generation via golden spiral with continent/coast brightness
36
+
- **`Satellite`** -- Satellite state: cached Kepler elements, ghost orbits, trail positions
37
+
- **`Math.Vec3`** -- 3D vector operations
38
+
- **`Color`** -- RGBA color type
39
+
- **`Geometry`**, **`Raycast`**, **`Visibility`** -- Spatial computations
40
+
41
+
### WebGL (`Globe_webgl`)
42
+
- **`Scene`** -- Canvas setup, satellite management, layer compositing, interaction
43
+
- **`Camera`** -- Orbit camera with smooth zoom/pan
44
+
- **`Earth`**, **`Stars`**, **`Grid`**, **`Orbit`**, **`Coverage`** -- Rendering layers
45
+
- **`Shader`** -- WebGL2 shader compilation
46
+
47
+
## License
48
+
49
+
ISC
+1
-1
lib/project.ml
+1
-1
lib/project.ml
···
40
40
Some (sx, sy, depth)
41
41
42
42
(** Project multiple positions, returning only visible ones with indices. *)
43
-
let project_visible ~projection ~view ~width ~height positions =
43
+
let visible ~projection ~view ~width ~height positions =
44
44
List.filter_map
45
45
(fun (i, pos) ->
46
46
match to_screen ~projection ~view ~width ~height pos with
+3
-3
lib/project.mli
+3
-3
lib/project.mli
···
12
12
(** [to_screen ~projection ~view ~width ~height pos] returns
13
13
[(screen_x, screen_y, depth)] or [None] if behind camera. *)
14
14
15
-
val project_visible :
15
+
val visible :
16
16
projection:float array ->
17
17
view:float array ->
18
18
width:int ->
19
19
height:int ->
20
20
(int * Math.Vec3.t) list ->
21
21
(int * float * float * float) list
22
-
(** [project_visible ~projection ~view ~width ~height positions] projects
23
-
indexed positions, keeping only visible ones. Returns
22
+
(** [visible ~projection ~view ~width ~height positions] projects indexed
23
+
positions, keeping only visible ones. Returns
24
24
[(index, screen_x, screen_y, depth)]. *)
+40
-48
lib/satellite.ml
+40
-48
lib/satellite.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Satellite state management for globe rendering.
7
-
8
-
Propagation-agnostic: takes a [propagator] function that maps dt → position.
9
-
The default constructor uses Kepler; [of_propagator] accepts any backend. *)
10
-
11
6
type propagator = dt:float -> Kepler.Vec3.t
12
7
13
8
type t = {
···
17
12
epoch_unix : float;
18
13
ghost_points : Math.Vec3.t option array;
19
14
trail_length : int;
20
-
(* Kepler-specific, optional *)
21
15
elements : Kepler.Analytic.elements option;
22
16
pos0 : Kepler.Vec3.t;
23
17
vel0 : Kepler.Vec3.t;
24
18
}
25
19
26
-
(* ── Safe GL coordinate conversion ─────────────────────────────────── *)
20
+
(* ── Helpers ───────────────────────────────────────────────────────── *)
27
21
28
22
let safe_gl (fallback : Math.Vec3.t) (p : Kepler.Vec3.t) =
29
23
if Float.is_finite p.x && Float.is_finite p.y && Float.is_finite p.z then
30
24
Gl_coord.of_kepler p
31
25
else fallback
32
26
33
-
let make_ghost propagate ~period ~ghost_duration ~fallback =
27
+
let make_ghost propagate ~dur ~fallback =
34
28
let n = 120 in
35
-
let dur =
36
-
if Float.is_finite ghost_duration && ghost_duration > 0. then ghost_duration
37
-
else if Float.is_finite period && period > 0. then period
38
-
else 5400.
39
-
in
40
29
Array.init n (fun i ->
41
30
let t = Float.of_int i *. dur /. Float.of_int n in
42
31
Some (safe_gl fallback (propagate ~dt:t)))
43
32
44
-
(* ── Constructors ──────────────────────────────────────────────────── *)
33
+
(* ── Propagator builders ───────────────────────────────────────────── *)
45
34
46
-
let v ~pos ~vel ~color ?(epoch_unix = 0.) ?(trail_length = 50) () =
47
-
let elements = Kepler.Analytic.precompute ~pos ~vel in
48
-
let period = Kepler.Analytic.period elements in
49
-
let propagate ~dt = Kepler.Analytic.at_precomputed elements ~dt in
50
-
let fallback = Gl_coord.of_kepler pos in
51
-
let ghost_points =
52
-
make_ghost propagate ~period ~ghost_duration:period ~fallback
53
-
in
54
-
{
55
-
propagate;
56
-
color;
57
-
period;
58
-
epoch_unix;
59
-
ghost_points;
60
-
trail_length;
61
-
elements = Some elements;
62
-
pos0 = pos;
63
-
vel0 = vel;
64
-
}
35
+
let kepler ~pos ~vel =
36
+
let el = Kepler.Analytic.precompute ~pos ~vel in
37
+
fun ~dt -> Kepler.Analytic.at_precomputed el ~dt
38
+
39
+
(* ── Constructor ───────────────────────────────────────────────────── *)
65
40
66
-
let of_propagator ~propagate ~color ?(epoch_unix = 0.) ?(period = 5400.)
41
+
let v ?propagate ?pos ?vel ~color ?(epoch_unix = 0.) ?(period = 0.)
67
42
?(ghost_duration = 0.) ?(trail_length = 50) () =
68
-
let ghost_dur = if ghost_duration > 0. then ghost_duration else period in
69
-
let fallback = safe_gl Math.Vec3.zero (propagate ~dt:0.) in
70
-
let ghost_points =
71
-
make_ghost propagate ~period ~ghost_duration:ghost_dur ~fallback
43
+
let propagate, elements, pos0, vel0, auto_period =
44
+
match (propagate, pos, vel) with
45
+
| Some p, _, _ ->
46
+
let pos0 = match pos with Some p -> p | None -> Kepler.Vec3.zero in
47
+
let vel0 = match vel with Some v -> v | None -> Kepler.Vec3.zero in
48
+
(p, None, pos0, vel0, 5400.)
49
+
| None, Some pos, Some vel ->
50
+
let el = Kepler.Analytic.precompute ~pos ~vel in
51
+
let p = Kepler.Analytic.period el in
52
+
let prop ~dt = Kepler.Analytic.at_precomputed el ~dt in
53
+
(prop, Some el, pos, vel, p)
54
+
| None, _, _ ->
55
+
let pos0 = match pos with Some p -> p | None -> Kepler.Vec3.zero in
56
+
((fun ~dt:_ -> pos0), None, pos0, Kepler.Vec3.zero, 5400.)
57
+
in
58
+
let period =
59
+
if period > 0. then period
60
+
else if Float.is_finite auto_period && auto_period > 0. then auto_period
61
+
else 5400.
72
62
in
63
+
let ghost_dur = if ghost_duration > 0. then ghost_duration else period in
64
+
let fallback = Gl_coord.of_kepler pos0 in
65
+
let ghost_points = make_ghost propagate ~dur:ghost_dur ~fallback in
73
66
{
74
67
propagate;
75
68
color;
···
77
70
epoch_unix;
78
71
ghost_points;
79
72
trail_length;
80
-
elements = None;
81
-
pos0 = Kepler.Vec3.zero;
82
-
vel0 = Kepler.Vec3.zero;
73
+
elements;
74
+
pos0;
75
+
vel0;
83
76
}
84
77
85
78
(* ── Accessors ─────────────────────────────────────────────────────── *)
···
91
84
92
85
(* ── Rendering ─────────────────────────────────────────────────────── *)
93
86
94
-
let position_at t ~dt =
95
-
let fallback = Gl_coord.of_kepler t.pos0 in
96
-
safe_gl fallback (t.propagate ~dt)
87
+
let position_at t ~dt = safe_gl (Gl_coord.of_kepler t.pos0) (t.propagate ~dt)
97
88
98
89
let trail_positions t ~dt =
99
90
let n = t.trail_length in
···
109
100
110
101
let dot t ~dt = (position_at t ~dt, t.color)
111
102
112
-
(* ── Orbital elements (Kepler only) ───────────────────────────────── *)
103
+
(* ── Orbital elements ──────────────────────────────────────────────── *)
113
104
114
105
let eccentricity t =
115
106
match t.elements with
···
117
108
| None -> 0.
118
109
119
110
let inclination t =
120
-
let hx = (t.pos0.y *. t.vel0.z) -. (t.pos0.z *. t.vel0.y) in
121
-
let hy = (t.pos0.z *. t.vel0.x) -. (t.pos0.x *. t.vel0.z) in
122
-
let hz = (t.pos0.x *. t.vel0.y) -. (t.pos0.y *. t.vel0.x) in
111
+
let p = t.pos0 and v = t.vel0 in
112
+
let hx = (p.y *. v.z) -. (p.z *. v.y) in
113
+
let hy = (p.z *. v.x) -. (p.x *. v.z) in
114
+
let hz = (p.x *. v.y) -. (p.y *. v.x) in
123
115
let h_mag = sqrt ((hx *. hx) +. (hy *. hy) +. (hz *. hz)) in
124
116
if h_mag < 1e-12 then 0.
125
117
else acos (Float.max (-1.) (Float.min 1. (hz /. h_mag)))
+47
-54
lib/satellite.mli
+47
-54
lib/satellite.mli
···
1
1
(** Satellite state management for globe rendering.
2
2
3
-
Supports multiple propagation backends: Kepler (two-body), SGP4 (TLE), or
4
-
ephemeris interpolation (OEM). The propagation is abstracted behind a
5
-
[propagator] function — the rendering code doesn't know which method is
6
-
used.
7
-
8
-
{2 Propagation backends}
9
-
10
-
{b Kepler} (default): Fast two-body analytical propagation from a J2000
11
-
state vector. Accurate within ±1 orbit of epoch. Use for CDM visualization.
12
-
13
-
{b SGP4}: Standard TLE propagation with J2/drag. Accurate for days. Pass an
14
-
SGP4 propagator via {!of_propagator}.
15
-
16
-
{b OEM}: Interpolate time-tagged ephemeris. Exact at provider precision.
17
-
Pass an interpolation function via {!of_propagator}.
18
-
19
-
{2 Quick start}
3
+
Supports multiple propagation backends via the optional [~propagate]
4
+
parameter. Default: Kepler two-body from [~pos] and [~vel].
20
5
21
6
{[
22
-
(* From CDM state vector (Kepler): *)
23
-
let sat = Satellite.v ~pos ~vel ~color ~epoch_unix ()
24
-
25
-
(* From custom propagator (SGP4, OEM, etc.): *)
26
-
let sat =
27
-
Satellite.of_propagator ~propagate ~color ~epoch_unix ~period
28
-
~ghost_duration ()
7
+
(* Kepler (default — needs pos + vel): *)
8
+
Satellite.v ~pos ~vel ~color ~epoch_unix ()
9
+
(* SGP4 from TLE: *)
10
+
Satellite.v
11
+
~propagate:(Satellite.sgp4 tle state)
12
+
~color ~epoch_unix ~period ()
13
+
(* Custom propagator: *)
14
+
Satellite.v
15
+
~propagate:(fun ~dt -> my_interp dt)
16
+
~color ~epoch_unix ~period ()
29
17
]} *)
30
18
31
19
type t
32
20
(** Satellite state with cached ghost orbit. *)
33
21
34
-
(** {1 Propagator type} *)
22
+
type propagator = dt:float -> Kepler.Vec3.t
23
+
(** Position at [dt] seconds from epoch, in J2000 km. *)
24
+
25
+
(** {1 Propagator builders} *)
35
26
36
-
type propagator = dt:float -> Kepler.Vec3.t
37
-
(** A propagation function: given [dt] seconds from epoch, returns the J2000
38
-
position in km. This is the abstraction that allows swapping Kepler, SGP4,
39
-
or OEM interpolation. *)
27
+
val kepler : pos:Kepler.Vec3.t -> vel:Kepler.Vec3.t -> propagator
28
+
(** [kepler ~pos ~vel] builds a two-body Kepler propagator. Uses
29
+
{!Kepler.Analytic.precompute} internally — fast, ~20 FLOPs per call.
30
+
Accurate within ±1 orbit of epoch. *)
40
31
41
-
(** {1 Constructors} *)
32
+
(** {1 Constructor} *)
42
33
43
34
val v :
44
-
pos:Kepler.Vec3.t ->
45
-
vel:Kepler.Vec3.t ->
46
-
color:Color.t ->
47
-
?epoch_unix:float ->
48
-
?trail_length:int ->
49
-
unit ->
50
-
t
51
-
(** [v ~pos ~vel ~color ?epoch_unix ?trail_length ()] creates a satellite using
52
-
Kepler (two-body) propagation from a J2000 state vector. *)
53
-
54
-
val of_propagator :
55
-
propagate:propagator ->
35
+
?propagate:propagator ->
36
+
?pos:Kepler.Vec3.t ->
37
+
?vel:Kepler.Vec3.t ->
56
38
color:Color.t ->
57
39
?epoch_unix:float ->
58
40
?period:float ->
···
60
42
?trail_length:int ->
61
43
unit ->
62
44
t
63
-
(** [of_propagator ~propagate ~color ?epoch_unix ?period ?ghost_duration
64
-
?trail_length ()] creates a satellite from any propagation backend.
45
+
(** [v ~color ()] creates a satellite.
65
46
66
-
- [propagate]: position at dt seconds from epoch (J2000 km)
67
-
- [period]: orbital period in seconds (for ghost orbit and trail spacing;
68
-
default 5400s)
69
-
- [ghost_duration]: duration of ghost orbit arc in seconds (default: period)
47
+
Propagation is chosen by:
48
+
- [~propagate:p] — use propagator [p] (from {!kepler}, {!sgp4}, or custom)
49
+
- [~pos] + [~vel] without [~propagate] — auto-builds Kepler propagator
50
+
- [~propagate] without [~pos]/[~vel] — propagator-only (no orbital elements)
51
+
52
+
Optional parameters:
53
+
- [period]: orbital period in seconds (auto-detected for Kepler/SGP4)
54
+
- [ghost_duration]: ghost orbit arc in seconds (default: [period])
70
55
- [trail_length]: number of trail points (default 50) *)
71
56
72
57
(** {1 Accessors} *)
73
58
74
59
val color : t -> Color.t
60
+
(** Satellite color. *)
61
+
75
62
val epoch_unix : t -> float
63
+
(** Unix timestamp of the propagation epoch. *)
64
+
76
65
val period : t -> float
66
+
(** Orbital period in seconds. *)
77
67
78
68
(** {1 Rendering} *)
79
69
···
81
71
(** Precomputed ghost orbit (GL coords). Computed once at creation. *)
82
72
83
73
val position_at : t -> dt:float -> Math.Vec3.t
84
-
(** GL position at [dt] seconds from epoch. *)
74
+
(** [position_at t ~dt] returns the GL position at [dt] seconds from epoch. *)
85
75
86
76
val trail_positions : t -> dt:float -> Math.Vec3.t option array
87
-
(** Trail points for {!Globe_webgl.Orbit.add_trail}. *)
77
+
(** Trail points for orbit rendering. *)
88
78
89
79
val dot : t -> dt:float -> Math.Vec3.t * Color.t
90
-
(** Current position + color for dot rendering. *)
80
+
(** Current position and color for dot rendering. *)
91
81
92
-
(** {1 Orbital elements (Kepler only)} *)
82
+
(** {1 Orbital elements (Kepler only, 0. otherwise)} *)
93
83
94
84
val eccentricity : t -> float
95
-
(** Eccentricity. Returns [0.] for non-Kepler propagators. *)
85
+
(** [eccentricity t] returns the orbital eccentricity. Returns [0.] for
86
+
non-Kepler propagators. *)
96
87
97
88
val inclination : t -> float
98
-
(** Inclination in radians. Returns [0.] for non-Kepler propagators. *)
89
+
(** [inclination t] returns the orbital inclination in radians. Returns [0.] for
90
+
non-Kepler propagators. *)
99
91
100
92
val pp : t Fmt.t
93
+
(** Pretty-print a satellite. *)
+4
-4
lib/webgl/label.ml
+4
-4
lib/webgl/label.ml
···
21
21
container;
22
22
{ container; entries = [] }
23
23
24
-
let make_label text =
24
+
let create text =
25
25
let el = El.div [] in
26
26
El.set_at (Jstr.of_string "style")
27
27
(Some
···
37
37
match List.assoc_opt idx t.entries with
38
38
| Some entry -> entry
39
39
| None ->
40
-
let el = make_label text in
40
+
let el = create text in
41
41
El.append_children t.container [ el ];
42
42
let entry = { el; visible = false } in
43
43
t.entries <- (idx, entry) :: t.entries;
···
63
63
entry.visible <- false
64
64
end
65
65
66
-
type label_info = { idx : int; text : string; pos : Globe.Math.Vec3.t }
66
+
type info = { idx : int; text : string; pos : Globe.Math.Vec3.t }
67
67
68
68
let update t ~projection ~view ~width ~height labels =
69
69
(* Hide all first *)
70
70
List.iter (fun (_, e) -> hide e) t.entries;
71
71
(* Project and show visible labels *)
72
72
List.iter
73
-
(fun (info : label_info) ->
73
+
(fun (info : info) ->
74
74
match
75
75
Globe.Project.to_screen ~projection ~view ~width ~height info.pos
76
76
with
+2
-2
lib/webgl/label.mli
+2
-2
lib/webgl/label.mli
···
11
11
(** [v container] creates a label manager inside [container]. The container
12
12
should be a fixed-position overlay div. *)
13
13
14
-
type label_info = { idx : int; text : string; pos : Globe.Math.Vec3.t }
14
+
type info = { idx : int; text : string; pos : Globe.Math.Vec3.t }
15
15
(** A label to display: satellite index, text, GL position. *)
16
16
17
17
val update :
···
20
20
view:float array ->
21
21
width:int ->
22
22
height:int ->
23
-
label_info list ->
23
+
info list ->
24
24
unit
25
25
(** [update t ~projection ~view ~width ~height labels] positions label elements
26
26
at projected screen coordinates. Labels not in the list are hidden. *)
+1
-1
lib/webgl/shader.ml
+1
-1
lib/webgl/shader.ml
+2
-2
lib/webgl/shader.mli
+2
-2
lib/webgl/shader.mli
···
1
1
(** GLSL shader compilation utilities and globe shader sources. *)
2
2
3
-
type shader_kind = Vertex | Fragment (** The kind of GLSL shader. *)
3
+
type kind = Vertex | Fragment (** The kind of GLSL shader. *)
4
4
5
-
val compile : Brr_canvas.Gl.t -> shader_kind -> string -> Brr_canvas.Gl.shader
5
+
val compile : Brr_canvas.Gl.t -> kind -> string -> Brr_canvas.Gl.shader
6
6
(** [compile gl kind src] compiles a GLSL shader from source. *)
7
7
8
8
val program :
+1
-2
test/test_project.ml
+1
-2
test/test_project.ml
···
81
81
]
82
82
in
83
83
let visible =
84
-
Project.project_visible ~projection:proj ~view ~width:800 ~height:600
85
-
positions
84
+
Project.visible ~projection:proj ~view ~width:800 ~height:600 positions
86
85
in
87
86
Alcotest.(check int) "2 of 3 visible" 2 (List.length visible);
88
87
let indices = List.map (fun (i, _, _, _) -> i) visible in