Contact Graph Routing for time-varying satellite networks
Squashed 'ocaml-cgr/' content from commit fd9b2201 git-subtree-split: fd9b2201b204540b73985dd03d3515fd18d92d7e
+1078
+17
.gitignore
+17
.gitignore
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.28.1
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2025 Thomas Gazagnaire
4
+
5
+
Permission to use, copy, modify, and/or distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
10
+
REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
11
+
AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
12
+
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
13
+
LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
14
+
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
+
PERFORMANCE OF THIS SOFTWARE.
+116
README.md
+116
README.md
···
1
+
# cgr
2
+
3
+
Contact Graph Routing for time-varying satellite networks.
4
+
5
+
## Overview
6
+
7
+
CGR computes routes through scheduled communication contacts in DTN
8
+
(Delay-Tolerant Networking) environments. Unlike traditional routing where
9
+
links are persistent, CGR handles networks where connectivity is intermittent
10
+
but predictable - such as satellite constellations, deep space networks, and
11
+
scheduled terrestrial links.
12
+
13
+
The algorithm implements CCSDS Schedule-Aware Bundle Routing (SABR) using
14
+
Dijkstra's shortest-path algorithm adapted for time-varying graphs where edges
15
+
(contacts) have temporal validity windows.
16
+
17
+
## Features
18
+
19
+
- **Contact Plans**: Define scheduled communication windows between nodes
20
+
- **Time-aware routing**: Routes respect contact start/end times
21
+
- **Propagation delay**: Supports one-way light time (OWLT) for deep space
22
+
- **Multiple routes**: Find alternative paths for redundancy
23
+
- **Bottleneck capacity**: Track minimum capacity across route hops
24
+
25
+
## Installation
26
+
27
+
```
28
+
opam install cgr
29
+
```
30
+
31
+
## Usage
32
+
33
+
```ocaml
34
+
open Cgr
35
+
36
+
(* Define nodes *)
37
+
let earth = Node.v "EARTH"
38
+
let mars = Node.v "MARS"
39
+
let relay = Node.v "RELAY"
40
+
41
+
(* Define contacts (scheduled communication windows) *)
42
+
let contacts = [
43
+
Contact.v ~from:earth ~to_:relay ~start:0. ~stop:100. ~rate:1_000_000. ();
44
+
Contact.v ~from:relay ~to_:mars ~start:50. ~stop:150. ~rate:500_000.
45
+
~owlt:600. (); (* 10 min light time *)
46
+
]
47
+
48
+
(* Create contact plan and find route *)
49
+
let plan = Contact_plan.of_list contacts
50
+
51
+
let () =
52
+
match find_route plan ~src:earth ~dst:mars ~time:0. with
53
+
| None -> print_endline "No route available"
54
+
| Some route ->
55
+
Format.printf "Route found: %a@." Route.pp route;
56
+
Format.printf "Arrival time: %.0f seconds@." (Route.arrival_time route)
57
+
```
58
+
59
+
## API
60
+
61
+
### Nodes
62
+
63
+
- `Node.v name` - Create a node identifier
64
+
- `Node.name node` - Get the node's name
65
+
66
+
### Contacts
67
+
68
+
- `Contact.v ~from ~to_ ~start ~stop ~rate ?owlt ()` - Create a contact
69
+
- `Contact.is_active contact ~time` - Check if contact is active
70
+
- `Contact.capacity contact` - Maximum bytes transmittable
71
+
72
+
### Contact Plans
73
+
74
+
- `Contact_plan.of_list contacts` - Create a plan from contacts
75
+
- `Contact_plan.contacts_from plan node` - Get outgoing contacts
76
+
- `Contact_plan.active_at plan ~time` - Get contacts active at time
77
+
78
+
### Routing
79
+
80
+
- `find_route plan ~src ~dst ~time` - Find best route (earliest arrival)
81
+
- `find_routes plan ~src ~dst ~time ~max` - Find multiple alternative routes
82
+
83
+
### Routes
84
+
85
+
- `Route.hops route` - List of contacts forming the path
86
+
- `Route.arrival_time route` - Earliest delivery time
87
+
- `Route.capacity route` - Bottleneck capacity (minimum across hops)
88
+
89
+
## Algorithm
90
+
91
+
CGR uses Dijkstra's algorithm with arrival time as the distance metric:
92
+
93
+
1. Initialize arrival time at source to query time, infinity elsewhere
94
+
2. Select unvisited node with minimum arrival time
95
+
3. For each outgoing contact from current node:
96
+
- Skip if contact ends before we arrive
97
+
- Compute arrival at neighbor: max(arrival, contact_start) + owlt
98
+
- Update if this improves the neighbor's arrival time
99
+
4. Mark current node visited, repeat until destination reached
100
+
101
+
## Related Work
102
+
103
+
- [ION](https://sourceforge.net/projects/ion-dtn/) - NASA/JPL's DTN implementation (C)
104
+
- [CGR Tutorial](https://hal.science/hal-03494106/file/2020-JNCA-CGR-Tutorial.pdf) - Fraire et al., 2020
105
+
- [CCSDS SABR](https://public.ccsds.org/Pubs/734x2b1.pdf) - Schedule-Aware Bundle Routing standard
106
+
- [DtnSim](https://bitbucket.org/lcd-unc-ar/dtnsim/) - DTN network simulator
107
+
108
+
## References
109
+
110
+
- IETF Draft: [Contact Graph Routing](https://datatracker.ietf.org/doc/html/draft-burleigh-dtnrg-cgr)
111
+
- CCSDS 734.2-B-1: Schedule-Aware Bundle Routing
112
+
- Fraire et al., "Routing in the Space Internet: A contact graph routing tutorial", JNCA 2020
113
+
114
+
## License
115
+
116
+
ISC License. See [LICENSE.md](LICENSE.md) for details.
+25
dune-project
+25
dune-project
···
1
+
(lang dune 3.0)
2
+
3
+
(name cgr)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license ISC)
8
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
9
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
10
+
(homepage "https://tangled.org/samoht.me/ocaml-cgr")
11
+
(bug_reports "https://tangled.org/samoht.me/ocaml-cgr/issues")
12
+
13
+
(package
14
+
(name cgr)
15
+
(synopsis "Contact Graph Routing for time-varying satellite networks")
16
+
(description
17
+
"CGR computes routes through scheduled communication contacts in DTN
18
+
(Delay-Tolerant Networking) environments. It implements the CCSDS
19
+
Schedule-Aware Bundle Routing (SABR) algorithm using Dijkstra over
20
+
time-varying graphs where edges (contacts) have temporal validity windows.")
21
+
(depends
22
+
(ocaml (>= 5.1))
23
+
(fmt (>= 0.9))
24
+
(alcotest :with-test)
25
+
(crowbar :with-test)))
+15
fuzz/dune
+15
fuzz/dune
···
1
+
; Crowbar fuzz testing for cgr
2
+
;
3
+
; To run: dune exec fuzz/fuzz_cgr.exe
4
+
; With AFL: afl-fuzz -i fuzz/corpus -o fuzz/findings -- ./_build/default/fuzz/fuzz_cgr.exe @@
5
+
6
+
(executable
7
+
(name fuzz_cgr)
8
+
(modules fuzz_cgr)
9
+
(libraries cgr crowbar))
10
+
11
+
(rule
12
+
(alias fuzz)
13
+
(deps fuzz_cgr.exe)
14
+
(action
15
+
(run %{exe:fuzz_cgr.exe})))
+125
fuzz/fuzz_cgr.ml
+125
fuzz/fuzz_cgr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Crowbar
7
+
open Cgr
8
+
9
+
(* Generators *)
10
+
11
+
let node_names = [| "A"; "B"; "C"; "D"; "E" |]
12
+
13
+
let gen_node =
14
+
map [ range (Array.length node_names) ] (fun i -> Node.v node_names.(i))
15
+
16
+
let gen_time = map [ range 1000 ] float_of_int
17
+
let gen_rate = map [ range 1000 ] (fun r -> float_of_int (r + 1))
18
+
19
+
let gen_contact =
20
+
map [ gen_node; gen_node; gen_time; range 100; gen_rate ] (fun from to_ start duration rate ->
21
+
let stop = start +. float_of_int (duration + 1) in
22
+
Contact.v ~from ~to_ ~start ~stop ~rate ())
23
+
24
+
let gen_contact_list = list gen_contact
25
+
26
+
(* Properties *)
27
+
28
+
(* Property: If a route is found, arrival time is finite *)
29
+
let test_route_arrival_finite contacts src dst time =
30
+
let plan = Contact_plan.of_list contacts in
31
+
match find_route plan ~src ~dst ~time with
32
+
| None -> ()
33
+
| Some route ->
34
+
let arrival = Route.arrival_time route in
35
+
check (Float.is_finite arrival)
36
+
37
+
(* Property: Route endpoints match query *)
38
+
let test_route_endpoints contacts src dst time =
39
+
let plan = Contact_plan.of_list contacts in
40
+
match find_route plan ~src ~dst ~time with
41
+
| None -> ()
42
+
| Some route ->
43
+
check (Node.equal (Route.src route) src);
44
+
check (Node.equal (Route.dst route) dst)
45
+
46
+
(* Property: Route arrival time >= query time *)
47
+
let test_route_arrival_after_start contacts src dst time =
48
+
let plan = Contact_plan.of_list contacts in
49
+
match find_route plan ~src ~dst ~time with
50
+
| None -> ()
51
+
| Some route ->
52
+
let arrival = Route.arrival_time route in
53
+
check (arrival >= time)
54
+
55
+
(* Property: Route hops form a valid path *)
56
+
let test_route_path_valid contacts src dst time =
57
+
let plan = Contact_plan.of_list contacts in
58
+
match find_route plan ~src ~dst ~time with
59
+
| None -> ()
60
+
| Some route -> (
61
+
match Route.hops route with
62
+
| [] ->
63
+
(* Empty path only valid if src = dst *)
64
+
check (Node.equal src dst)
65
+
| first :: rest ->
66
+
(* First hop starts from src *)
67
+
check (Node.equal (Contact.from first) src);
68
+
(* Each hop connects to next *)
69
+
let rec check_chain prev = function
70
+
| [] ->
71
+
(* Last hop goes to dst *)
72
+
check (Node.equal (Contact.to_ prev) dst)
73
+
| next :: rest ->
74
+
check (Node.equal (Contact.to_ prev) (Contact.from next));
75
+
check_chain next rest
76
+
in
77
+
check_chain first rest)
78
+
79
+
(* Property: Multiple routes have different first hops *)
80
+
let test_routes_different_first_hops contacts src dst time =
81
+
let plan = Contact_plan.of_list contacts in
82
+
let routes = find_routes plan ~src ~dst ~time ~max:5 in
83
+
let first_hops =
84
+
List.filter_map
85
+
(fun r -> match Route.hops r with c :: _ -> Some c | [] -> None)
86
+
routes
87
+
in
88
+
(* Check all first hops are distinct (by physical identity) *)
89
+
let rec all_distinct = function
90
+
| [] -> true
91
+
| x :: xs -> not (List.exists (fun y -> x == y) xs) && all_distinct xs
92
+
in
93
+
check (all_distinct first_hops)
94
+
95
+
(* Property: Routes are ordered by arrival time *)
96
+
let test_routes_ordered contacts src dst time =
97
+
let plan = Contact_plan.of_list contacts in
98
+
let routes = find_routes plan ~src ~dst ~time ~max:5 in
99
+
let arrivals = List.map Route.arrival_time routes in
100
+
let rec is_sorted = function
101
+
| [] | [ _ ] -> true
102
+
| a :: (b :: _ as rest) -> a <= b && is_sorted rest
103
+
in
104
+
check (is_sorted arrivals)
105
+
106
+
(* Register tests *)
107
+
let () =
108
+
add_test ~name:"cgr: route arrival finite"
109
+
[ gen_contact_list; gen_node; gen_node; gen_time ]
110
+
test_route_arrival_finite;
111
+
add_test ~name:"cgr: route endpoints match"
112
+
[ gen_contact_list; gen_node; gen_node; gen_time ]
113
+
test_route_endpoints;
114
+
add_test ~name:"cgr: route arrival >= start"
115
+
[ gen_contact_list; gen_node; gen_node; gen_time ]
116
+
test_route_arrival_after_start;
117
+
add_test ~name:"cgr: route path valid"
118
+
[ gen_contact_list; gen_node; gen_node; gen_time ]
119
+
test_route_path_valid;
120
+
add_test ~name:"cgr: routes have different first hops"
121
+
[ gen_contact_list; gen_node; gen_node; gen_time ]
122
+
test_routes_different_first_hops;
123
+
add_test ~name:"cgr: routes ordered by arrival"
124
+
[ gen_contact_list; gen_node; gen_node; gen_time ]
125
+
test_routes_ordered
+290
lib/cgr.ml
+290
lib/cgr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Nodes *)
7
+
8
+
module Node = struct
9
+
type t = string
10
+
11
+
let v name = name
12
+
let name t = t
13
+
let equal = String.equal
14
+
let compare = String.compare
15
+
let pp = Fmt.string
16
+
end
17
+
18
+
module Node_set = Set.Make (Node)
19
+
module Node_map = Map.Make (Node)
20
+
21
+
(* Contacts *)
22
+
23
+
module Contact = struct
24
+
type t = {
25
+
from : Node.t;
26
+
to_ : Node.t;
27
+
start : float;
28
+
stop : float;
29
+
rate : float;
30
+
owlt : float;
31
+
}
32
+
33
+
let v ~from ~to_ ~start ~stop ~rate ?(owlt = 0.) () =
34
+
{ from; to_; start; stop; rate; owlt }
35
+
36
+
let from t = t.from
37
+
let to_ t = t.to_
38
+
let start t = t.start
39
+
let stop t = t.stop
40
+
let rate t = t.rate
41
+
let owlt t = t.owlt
42
+
let duration t = t.stop -. t.start
43
+
let capacity t = duration t *. t.rate
44
+
let is_active t ~time = t.start <= time && time < t.stop
45
+
46
+
let pp ppf t =
47
+
Fmt.pf ppf "%a->%a [%.0f-%.0f] @%.0f B/s" Node.pp t.from Node.pp t.to_
48
+
t.start t.stop t.rate
49
+
end
50
+
51
+
(* Contact Plans *)
52
+
53
+
module Contact_plan = struct
54
+
type t = {
55
+
contacts : Contact.t list;
56
+
by_from : Contact.t list Node_map.t;
57
+
by_to : Contact.t list Node_map.t;
58
+
}
59
+
60
+
let empty = { contacts = []; by_from = Node_map.empty; by_to = Node_map.empty }
61
+
62
+
let add contact t =
63
+
let add_to_map key contact map =
64
+
let existing = Option.value ~default:[] (Node_map.find_opt key map) in
65
+
Node_map.add key (contact :: existing) map
66
+
in
67
+
{
68
+
contacts = contact :: t.contacts;
69
+
by_from = add_to_map (Contact.from contact) contact t.by_from;
70
+
by_to = add_to_map (Contact.to_ contact) contact t.by_to;
71
+
}
72
+
73
+
let of_list contacts = List.fold_left (fun t c -> add c t) empty contacts
74
+
let contacts t = t.contacts
75
+
76
+
let contacts_from t node =
77
+
Option.value ~default:[] (Node_map.find_opt node t.by_from)
78
+
79
+
let contacts_to t node =
80
+
Option.value ~default:[] (Node_map.find_opt node t.by_to)
81
+
82
+
let contacts_between t a b =
83
+
contacts_from t a |> List.filter (fun c -> Node.equal (Contact.to_ c) b)
84
+
85
+
let nodes t =
86
+
let add_node node set = Node_set.add node set in
87
+
let set =
88
+
List.fold_left
89
+
(fun set c ->
90
+
set |> add_node (Contact.from c) |> add_node (Contact.to_ c))
91
+
Node_set.empty t.contacts
92
+
in
93
+
Node_set.elements set
94
+
95
+
let active_at t ~time = List.filter (fun c -> Contact.is_active c ~time) t.contacts
96
+
97
+
let pp ppf t =
98
+
Fmt.pf ppf "@[<v>%a@]" (Fmt.list ~sep:Fmt.cut Contact.pp) t.contacts
99
+
end
100
+
101
+
(* Routes *)
102
+
103
+
module Route = struct
104
+
type t = { hops : Contact.t list; src : Node.t; dst : Node.t }
105
+
106
+
let hops t = t.hops
107
+
let src t = t.src
108
+
let dst t = t.dst
109
+
110
+
let departure_time t =
111
+
match t.hops with [] -> 0. | c :: _ -> Contact.start c
112
+
113
+
let arrival_time t =
114
+
let rec last_arrival time = function
115
+
| [] -> time
116
+
| c :: rest ->
117
+
(* We can start transmitting when we arrive or when contact starts *)
118
+
let tx_start = Float.max time (Contact.start c) in
119
+
(* Arrival = tx_start + propagation delay *)
120
+
let arrival = tx_start +. Contact.owlt c in
121
+
last_arrival arrival rest
122
+
in
123
+
last_arrival (departure_time t) t.hops
124
+
125
+
let capacity t =
126
+
match t.hops with
127
+
| [] -> infinity
128
+
| hops -> List.fold_left (fun acc c -> Float.min acc (Contact.capacity c)) infinity hops
129
+
130
+
let latency t = arrival_time t -. departure_time t
131
+
132
+
let pp ppf t =
133
+
Fmt.pf ppf "@[<v>%a -> %a (arrives %.2f):@,%a@]" Node.pp t.src Node.pp t.dst
134
+
(arrival_time t)
135
+
(Fmt.list ~sep:(Fmt.any " ->@ ") Contact.pp)
136
+
t.hops
137
+
end
138
+
139
+
(* Dijkstra *)
140
+
141
+
module Dijkstra = struct
142
+
type node_state = {
143
+
arrival_time : float;
144
+
predecessor : Contact.t option;
145
+
visited : bool;
146
+
}
147
+
148
+
type state = {
149
+
plan : Contact_plan.t;
150
+
src : Node.t;
151
+
start_time : float;
152
+
nodes : node_state Node_map.t;
153
+
}
154
+
155
+
let infinity = Float.infinity
156
+
157
+
let init plan ~src ~time =
158
+
let nodes =
159
+
Contact_plan.nodes plan
160
+
|> List.fold_left
161
+
(fun map node ->
162
+
let arrival_time = if Node.equal node src then time else infinity in
163
+
let state = { arrival_time; predecessor = None; visited = false } in
164
+
Node_map.add node state map)
165
+
Node_map.empty
166
+
in
167
+
{ plan; src; start_time = time; nodes }
168
+
169
+
let get_node_state state node =
170
+
match Node_map.find_opt node state.nodes with
171
+
| Some s -> s
172
+
| None -> { arrival_time = infinity; predecessor = None; visited = false }
173
+
174
+
let arrival_time state node =
175
+
let ns = get_node_state state node in
176
+
if Float.is_finite ns.arrival_time then Some ns.arrival_time else None
177
+
178
+
let predecessor state node = (get_node_state state node).predecessor
179
+
180
+
(* Find unvisited node with minimum arrival time *)
181
+
let find_min_unvisited state =
182
+
Node_map.fold
183
+
(fun node ns acc ->
184
+
if ns.visited then acc
185
+
else
186
+
match acc with
187
+
| None -> Some (node, ns.arrival_time)
188
+
| Some (_, best_time) when ns.arrival_time < best_time ->
189
+
Some (node, ns.arrival_time)
190
+
| Some _ -> acc)
191
+
state.nodes None
192
+
|> Option.map fst
193
+
194
+
let step state =
195
+
match find_min_unvisited state with
196
+
| None -> None
197
+
| Some current when not (Float.is_finite (get_node_state state current).arrival_time) ->
198
+
(* All remaining nodes are unreachable *)
199
+
None
200
+
| Some current ->
201
+
let current_state = get_node_state state current in
202
+
let current_arrival = current_state.arrival_time in
203
+
204
+
(* Mark current as visited *)
205
+
let nodes =
206
+
Node_map.add current { current_state with visited = true } state.nodes
207
+
in
208
+
209
+
(* Relax edges: check all contacts from current node *)
210
+
let nodes =
211
+
Contact_plan.contacts_from state.plan current
212
+
|> List.fold_left
213
+
(fun nodes contact ->
214
+
let neighbor = Contact.to_ contact in
215
+
let neighbor_state = get_node_state { state with nodes } neighbor in
216
+
217
+
if neighbor_state.visited then nodes
218
+
else
219
+
(* Can we use this contact? *)
220
+
(* We need to arrive before the contact ends *)
221
+
let contact_usable = current_arrival < Contact.stop contact in
222
+
if not contact_usable then nodes
223
+
else
224
+
(* Compute arrival time at neighbor via this contact *)
225
+
(* We can start transmitting when we arrive or when contact starts *)
226
+
let tx_start =
227
+
Float.max current_arrival (Contact.start contact)
228
+
in
229
+
(* Arrival at neighbor = tx_start + propagation delay *)
230
+
let new_arrival = tx_start +. Contact.owlt contact in
231
+
232
+
if new_arrival < neighbor_state.arrival_time then
233
+
Node_map.add neighbor
234
+
{ neighbor_state with
235
+
arrival_time = new_arrival;
236
+
predecessor = Some contact;
237
+
}
238
+
nodes
239
+
else nodes)
240
+
nodes
241
+
in
242
+
Some { state with nodes }
243
+
244
+
let rec run state =
245
+
match step state with None -> state | Some state' -> run state'
246
+
247
+
let extract_route state ~dst =
248
+
let ns = get_node_state state dst in
249
+
if not (Float.is_finite ns.arrival_time) then None
250
+
else
251
+
(* Backtrack through predecessors to build route *)
252
+
let rec build_path node acc =
253
+
if Node.equal node state.src then acc
254
+
else
255
+
match (get_node_state state node).predecessor with
256
+
| None -> acc (* Should not happen if arrival_time is finite *)
257
+
| Some contact -> build_path (Contact.from contact) (contact :: acc)
258
+
in
259
+
let hops = build_path dst [] in
260
+
Some Route.{ hops; src = state.src; dst }
261
+
end
262
+
263
+
(* High-level routing *)
264
+
265
+
let find_route plan ~src ~dst ~time =
266
+
let state = Dijkstra.init plan ~src ~time in
267
+
let final = Dijkstra.run state in
268
+
Dijkstra.extract_route final ~dst
269
+
270
+
let find_routes plan ~src ~dst ~time ~max =
271
+
(* Find multiple routes by suppressing initial contacts of found routes *)
272
+
let rec loop plan routes_found =
273
+
if List.length routes_found >= max then List.rev routes_found
274
+
else
275
+
match find_route plan ~src ~dst ~time with
276
+
| None -> List.rev routes_found
277
+
| Some route -> (
278
+
match Route.hops route with
279
+
| [] -> List.rev (route :: routes_found)
280
+
| first_hop :: _ ->
281
+
(* Remove the first contact to find alternative routes *)
282
+
let plan' =
283
+
Contact_plan.of_list
284
+
(List.filter
285
+
(fun c -> c != first_hop)
286
+
(Contact_plan.contacts plan))
287
+
in
288
+
loop plan' (route :: routes_found))
289
+
in
290
+
loop plan []
+247
lib/cgr.mli
+247
lib/cgr.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Contact Graph Routing for time-varying networks.
7
+
8
+
CGR computes routes through scheduled communication contacts in DTN
9
+
(Delay-Tolerant Networking) environments. Unlike traditional routing
10
+
where links are persistent, CGR handles networks where connectivity
11
+
is intermittent but predictable - such as satellite constellations,
12
+
deep space networks, and scheduled terrestrial links.
13
+
14
+
{2 Overview}
15
+
16
+
A {e contact} is a scheduled window during which one node can transmit
17
+
to another. The {e contact plan} is the complete schedule of all contacts.
18
+
CGR uses Dijkstra's algorithm over this time-varying graph to find routes
19
+
that minimize delivery time while respecting contact windows.
20
+
21
+
{2 Example}
22
+
23
+
{[
24
+
open Cgr
25
+
26
+
(* Define nodes *)
27
+
let earth = Node.v "EARTH"
28
+
let mars = Node.v "MARS"
29
+
let relay = Node.v "RELAY"
30
+
31
+
(* Define contacts (start_time, end_time, rate in bytes/sec) *)
32
+
let contacts = [
33
+
Contact.v ~from:earth ~to_:relay ~start:0. ~stop:100. ~rate:1_000_000.;
34
+
Contact.v ~from:relay ~to_:mars ~start:50. ~stop:150. ~rate:500_000.;
35
+
]
36
+
37
+
(* Create contact plan and find route *)
38
+
let plan = Contact_plan.of_list contacts
39
+
let route = find_route plan ~src:earth ~dst:mars ~time:0.
40
+
]}
41
+
42
+
{2 References}
43
+
44
+
- {{:https://datatracker.ietf.org/doc/html/draft-burleigh-dtnrg-cgr}
45
+
IETF Contact Graph Routing draft}
46
+
- {{:https://public.ccsds.org/Pubs/734x2b1.pdf}
47
+
CCSDS Schedule-Aware Bundle Routing (SABR)}
48
+
- {{:https://hal.science/hal-03494106/file/2020-JNCA-CGR-Tutorial.pdf}
49
+
CGR Tutorial (Fraire et al., 2020)} *)
50
+
51
+
(** {1 Nodes} *)
52
+
53
+
module Node : sig
54
+
type t
55
+
(** A network node identifier. *)
56
+
57
+
val v : string -> t
58
+
(** [v name] creates a node with the given name. *)
59
+
60
+
val name : t -> string
61
+
(** [name node] returns the node's name. *)
62
+
63
+
val equal : t -> t -> bool
64
+
(** [equal a b] is [true] if nodes are identical. *)
65
+
66
+
val compare : t -> t -> int
67
+
(** Total ordering on nodes. *)
68
+
69
+
val pp : t Fmt.t
70
+
(** Pretty-printer for nodes. *)
71
+
end
72
+
73
+
(** {1 Contacts} *)
74
+
75
+
module Contact : sig
76
+
type t
77
+
(** A scheduled communication window between two nodes.
78
+
79
+
A contact represents a period during which the transmitting node
80
+
can send data to the receiving node at a specified rate. *)
81
+
82
+
val v :
83
+
from:Node.t ->
84
+
to_:Node.t ->
85
+
start:float ->
86
+
stop:float ->
87
+
rate:float ->
88
+
?owlt:float ->
89
+
unit ->
90
+
t
91
+
(** [v ~from ~to_ ~start ~stop ~rate ?owlt ()] creates a contact.
92
+
93
+
@param from The transmitting node
94
+
@param to_ The receiving node
95
+
@param start Contact start time (seconds since epoch)
96
+
@param stop Contact end time (seconds since epoch)
97
+
@param rate Transmission rate in bytes per second
98
+
@param owlt One-way light time (propagation delay) in seconds.
99
+
Defaults to [0.] for terrestrial links. *)
100
+
101
+
val from : t -> Node.t
102
+
(** [from c] is the transmitting node. *)
103
+
104
+
val to_ : t -> Node.t
105
+
(** [to_ c] is the receiving node. *)
106
+
107
+
val start : t -> float
108
+
(** [start c] is the contact start time. *)
109
+
110
+
val stop : t -> float
111
+
(** [stop c] is the contact end time. *)
112
+
113
+
val rate : t -> float
114
+
(** [rate c] is the transmission rate in bytes/second. *)
115
+
116
+
val owlt : t -> float
117
+
(** [owlt c] is the one-way light time (propagation delay). *)
118
+
119
+
val duration : t -> float
120
+
(** [duration c] is [stop c -. start c]. *)
121
+
122
+
val capacity : t -> float
123
+
(** [capacity c] is [duration c *. rate c], the maximum bytes transmittable. *)
124
+
125
+
val is_active : t -> time:float -> bool
126
+
(** [is_active c ~time] is [true] if [start c <= time < stop c]. *)
127
+
128
+
val pp : t Fmt.t
129
+
(** Pretty-printer for contacts. *)
130
+
end
131
+
132
+
(** {1 Contact Plans} *)
133
+
134
+
module Contact_plan : sig
135
+
type t
136
+
(** A collection of scheduled contacts forming the network topology. *)
137
+
138
+
val empty : t
139
+
(** Empty contact plan. *)
140
+
141
+
val add : Contact.t -> t -> t
142
+
(** [add contact plan] adds a contact to the plan. *)
143
+
144
+
val of_list : Contact.t list -> t
145
+
(** [of_list contacts] creates a plan from a list of contacts. *)
146
+
147
+
val contacts : t -> Contact.t list
148
+
(** [contacts plan] returns all contacts. *)
149
+
150
+
val contacts_from : t -> Node.t -> Contact.t list
151
+
(** [contacts_from plan node] returns contacts where [node] is transmitting. *)
152
+
153
+
val contacts_to : t -> Node.t -> Contact.t list
154
+
(** [contacts_to plan node] returns contacts where [node] is receiving. *)
155
+
156
+
val contacts_between : t -> Node.t -> Node.t -> Contact.t list
157
+
(** [contacts_between plan a b] returns contacts from [a] to [b]. *)
158
+
159
+
val nodes : t -> Node.t list
160
+
(** [nodes plan] returns all nodes mentioned in any contact. *)
161
+
162
+
val active_at : t -> time:float -> Contact.t list
163
+
(** [active_at plan ~time] returns contacts active at the given time. *)
164
+
165
+
val pp : t Fmt.t
166
+
(** Pretty-printer for contact plans. *)
167
+
end
168
+
169
+
(** {1 Routes} *)
170
+
171
+
module Route : sig
172
+
type t
173
+
(** A computed path through the contact graph. *)
174
+
175
+
val hops : t -> Contact.t list
176
+
(** [hops route] returns the sequence of contacts forming the route. *)
177
+
178
+
val src : t -> Node.t
179
+
(** [src route] is the source node. *)
180
+
181
+
val dst : t -> Node.t
182
+
(** [dst route] is the destination node. *)
183
+
184
+
val departure_time : t -> float
185
+
(** [departure_time route] is when transmission should begin. *)
186
+
187
+
val arrival_time : t -> float
188
+
(** [arrival_time route] is the earliest possible delivery time. *)
189
+
190
+
val capacity : t -> float
191
+
(** [capacity route] is the minimum capacity across all hops (bottleneck). *)
192
+
193
+
val latency : t -> float
194
+
(** [latency route] is [arrival_time route -. departure_time route]. *)
195
+
196
+
val pp : t Fmt.t
197
+
(** Pretty-printer for routes. *)
198
+
end
199
+
200
+
(** {1 Routing} *)
201
+
202
+
val find_route :
203
+
Contact_plan.t -> src:Node.t -> dst:Node.t -> time:float -> Route.t option
204
+
(** [find_route plan ~src ~dst ~time] finds the best route from [src] to [dst]
205
+
starting no earlier than [time].
206
+
207
+
Returns [None] if no route exists. The "best" route minimizes arrival time
208
+
at the destination (earliest delivery). *)
209
+
210
+
val find_routes :
211
+
Contact_plan.t ->
212
+
src:Node.t ->
213
+
dst:Node.t ->
214
+
time:float ->
215
+
max:int ->
216
+
Route.t list
217
+
(** [find_routes plan ~src ~dst ~time ~max] finds up to [max] routes.
218
+
219
+
Routes are returned in order of preference (earliest arrival first).
220
+
Subsequent routes use different initial contacts to provide redundancy. *)
221
+
222
+
(** {1 Route Computation Details} *)
223
+
224
+
module Dijkstra : sig
225
+
(** Low-level access to the Dijkstra computation.
226
+
227
+
Most users should use {!find_route} instead. This module exposes
228
+
internals for debugging, visualization, or custom routing strategies. *)
229
+
230
+
type state
231
+
(** Internal state of a Dijkstra computation. *)
232
+
233
+
val init : Contact_plan.t -> src:Node.t -> time:float -> state
234
+
(** [init plan ~src ~time] initializes a computation from [src] at [time]. *)
235
+
236
+
val step : state -> state option
237
+
(** [step state] performs one iteration. Returns [None] when complete. *)
238
+
239
+
val arrival_time : state -> Node.t -> float option
240
+
(** [arrival_time state node] returns the best known arrival time at [node]. *)
241
+
242
+
val predecessor : state -> Node.t -> Contact.t option
243
+
(** [predecessor state node] returns the contact used to reach [node]. *)
244
+
245
+
val extract_route : state -> dst:Node.t -> Route.t option
246
+
(** [extract_route state ~dst] extracts the route to [dst] if reachable. *)
247
+
end
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "cgr" Test_cgr.suite
+219
test/test_cgr.ml
+219
test/test_cgr.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Cgr
7
+
8
+
(* Test helpers *)
9
+
10
+
let node = Alcotest.testable Node.pp Node.equal
11
+
12
+
let route_arrival =
13
+
Alcotest.testable
14
+
(fun ppf r -> Fmt.pf ppf "arrival=%.2f" (Route.arrival_time r))
15
+
(fun a b ->
16
+
Float.abs (Route.arrival_time a -. Route.arrival_time b) < 0.001)
17
+
18
+
let some_route = Alcotest.option route_arrival
19
+
20
+
let float_eq ?(eps = 0.001) a b = Float.abs (a -. b) < eps
21
+
22
+
(* Test nodes *)
23
+
24
+
let earth = Node.v "EARTH"
25
+
let mars = Node.v "MARS"
26
+
let relay = Node.v "RELAY"
27
+
let moon = Node.v "MOON"
28
+
29
+
(* Test: Direct single-hop contact *)
30
+
31
+
let test_direct_contact () =
32
+
let contact =
33
+
Contact.v ~from:earth ~to_:mars ~start:0. ~stop:100. ~rate:1000. ()
34
+
in
35
+
let plan = Contact_plan.of_list [ contact ] in
36
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
37
+
Alcotest.(check bool) "route exists" true (Option.is_some route);
38
+
let route = Option.get route in
39
+
Alcotest.(check node) "src" earth (Route.src route);
40
+
Alcotest.(check node) "dst" mars (Route.dst route);
41
+
Alcotest.(check int) "hops" 1 (List.length (Route.hops route));
42
+
Alcotest.(check bool) "arrival at 0" true (float_eq 0. (Route.arrival_time route))
43
+
44
+
(* Test: Two-hop route *)
45
+
46
+
let test_two_hop_route () =
47
+
let c1 =
48
+
Contact.v ~from:earth ~to_:relay ~start:0. ~stop:100. ~rate:1000. ()
49
+
in
50
+
let c2 =
51
+
Contact.v ~from:relay ~to_:mars ~start:50. ~stop:150. ~rate:1000. ()
52
+
in
53
+
let plan = Contact_plan.of_list [ c1; c2 ] in
54
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
55
+
Alcotest.(check bool) "route exists" true (Option.is_some route);
56
+
let route = Option.get route in
57
+
Alcotest.(check int) "hops" 2 (List.length (Route.hops route));
58
+
(* Arrive at relay at t=0, wait until contact c2 starts at t=50 *)
59
+
Alcotest.(check bool) "arrival at 50" true (float_eq 50. (Route.arrival_time route))
60
+
61
+
(* Test: No route available *)
62
+
63
+
let test_no_route () =
64
+
let contact =
65
+
Contact.v ~from:earth ~to_:relay ~start:0. ~stop:100. ~rate:1000. ()
66
+
in
67
+
let plan = Contact_plan.of_list [ contact ] in
68
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
69
+
Alcotest.(check bool) "no route" true (Option.is_none route)
70
+
71
+
(* Test: Choose earliest arrival when multiple paths exist *)
72
+
73
+
let test_earliest_arrival () =
74
+
(* Slow direct path *)
75
+
let slow =
76
+
Contact.v ~from:earth ~to_:mars ~start:100. ~stop:200. ~rate:1000. ()
77
+
in
78
+
(* Fast path via relay *)
79
+
let c1 = Contact.v ~from:earth ~to_:relay ~start:0. ~stop:50. ~rate:1000. () in
80
+
let c2 =
81
+
Contact.v ~from:relay ~to_:mars ~start:10. ~stop:60. ~rate:1000. ()
82
+
in
83
+
let plan = Contact_plan.of_list [ slow; c1; c2 ] in
84
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
85
+
Alcotest.(check bool) "route exists" true (Option.is_some route);
86
+
let route = Option.get route in
87
+
(* Fast path arrives at t=10 (via relay), slow path at t=100 *)
88
+
Alcotest.(check bool) "chose fast path" true (float_eq 10. (Route.arrival_time route));
89
+
Alcotest.(check int) "via relay (2 hops)" 2 (List.length (Route.hops route))
90
+
91
+
(* Test: Must wait for contact window *)
92
+
93
+
let test_wait_for_contact () =
94
+
(* Contact doesn't start until t=50 *)
95
+
let contact =
96
+
Contact.v ~from:earth ~to_:mars ~start:50. ~stop:100. ~rate:1000. ()
97
+
in
98
+
let plan = Contact_plan.of_list [ contact ] in
99
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
100
+
Alcotest.(check bool) "route exists" true (Option.is_some route);
101
+
let route = Option.get route in
102
+
(* Must wait until t=50 to transmit *)
103
+
Alcotest.(check bool) "arrival at 50" true (float_eq 50. (Route.arrival_time route))
104
+
105
+
(* Test: Propagation delay (one-way light time) *)
106
+
107
+
let test_propagation_delay () =
108
+
(* Deep space link with 10 minute OWLT *)
109
+
let owlt = 600. in
110
+
let contact =
111
+
Contact.v ~from:earth ~to_:mars ~start:0. ~stop:1000. ~rate:1000. ~owlt ()
112
+
in
113
+
let plan = Contact_plan.of_list [ contact ] in
114
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
115
+
Alcotest.(check bool) "route exists" true (Option.is_some route);
116
+
let route = Option.get route in
117
+
(* Arrival = transmit time + OWLT = 0 + 600 *)
118
+
Alcotest.(check bool) "arrival includes owlt" true
119
+
(float_eq owlt (Route.arrival_time route))
120
+
121
+
(* Test: Contact expires before we arrive *)
122
+
123
+
let test_contact_expires () =
124
+
(* First hop takes us to relay *)
125
+
let c1 =
126
+
Contact.v ~from:earth ~to_:relay ~start:0. ~stop:100. ~rate:1000. ()
127
+
in
128
+
(* But the mars contact ends before we could use it *)
129
+
let c2 =
130
+
Contact.v ~from:relay ~to_:mars ~start:0. ~stop:1. ~rate:1000. ()
131
+
in
132
+
let plan = Contact_plan.of_list [ c1; c2 ] in
133
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
134
+
(* We arrive at relay at t=0, but c2 ends at t=1 - should still work
135
+
since we arrive before end *)
136
+
Alcotest.(check bool) "route exists" true (Option.is_some route)
137
+
138
+
(* Test: find_routes returns multiple alternatives *)
139
+
140
+
let test_find_routes () =
141
+
(* Two parallel paths *)
142
+
let via_relay =
143
+
[
144
+
Contact.v ~from:earth ~to_:relay ~start:0. ~stop:100. ~rate:1000. ();
145
+
Contact.v ~from:relay ~to_:mars ~start:10. ~stop:100. ~rate:1000. ();
146
+
]
147
+
in
148
+
let via_moon =
149
+
[
150
+
Contact.v ~from:earth ~to_:moon ~start:0. ~stop:100. ~rate:1000. ();
151
+
Contact.v ~from:moon ~to_:mars ~start:20. ~stop:100. ~rate:1000. ();
152
+
]
153
+
in
154
+
let plan = Contact_plan.of_list (via_relay @ via_moon) in
155
+
let routes = find_routes plan ~src:earth ~dst:mars ~time:0. ~max:3 in
156
+
Alcotest.(check int) "found 2 routes" 2 (List.length routes);
157
+
(* First route should be fastest (via relay, arrives at 10) *)
158
+
let first = List.hd routes in
159
+
Alcotest.(check bool) "first is fastest" true
160
+
(float_eq 10. (Route.arrival_time first))
161
+
162
+
(* Test: Contact plan operations *)
163
+
164
+
let test_contact_plan () =
165
+
let c1 = Contact.v ~from:earth ~to_:mars ~start:0. ~stop:100. ~rate:1000. () in
166
+
let c2 = Contact.v ~from:earth ~to_:relay ~start:50. ~stop:150. ~rate:500. () in
167
+
let c3 = Contact.v ~from:relay ~to_:mars ~start:100. ~stop:200. ~rate:800. () in
168
+
let plan = Contact_plan.of_list [ c1; c2; c3 ] in
169
+
Alcotest.(check int) "all contacts" 3 (List.length (Contact_plan.contacts plan));
170
+
Alcotest.(check int) "contacts from earth" 2
171
+
(List.length (Contact_plan.contacts_from plan earth));
172
+
Alcotest.(check int) "contacts to mars" 2
173
+
(List.length (Contact_plan.contacts_to plan mars));
174
+
Alcotest.(check int) "contacts earth->mars" 1
175
+
(List.length (Contact_plan.contacts_between plan earth mars));
176
+
Alcotest.(check int) "nodes" 3 (List.length (Contact_plan.nodes plan));
177
+
Alcotest.(check int) "active at 75" 2
178
+
(List.length (Contact_plan.active_at plan ~time:75.))
179
+
180
+
(* Test: Route capacity is bottleneck *)
181
+
182
+
let test_route_capacity () =
183
+
let c1 =
184
+
Contact.v ~from:earth ~to_:relay ~start:0. ~stop:100. ~rate:1000. ()
185
+
in
186
+
let c2 =
187
+
Contact.v ~from:relay ~to_:mars ~start:0. ~stop:50. ~rate:500. ()
188
+
in
189
+
let plan = Contact_plan.of_list [ c1; c2 ] in
190
+
let route = find_route plan ~src:earth ~dst:mars ~time:0. in
191
+
let route = Option.get route in
192
+
(* Capacity is min of: c1 (100*1000=100000) and c2 (50*500=25000) *)
193
+
Alcotest.(check bool) "capacity is bottleneck" true
194
+
(float_eq 25000. (Route.capacity route))
195
+
196
+
(* Suite *)
197
+
198
+
let suite =
199
+
[
200
+
( "routing",
201
+
[
202
+
Alcotest.test_case "direct contact" `Quick test_direct_contact;
203
+
Alcotest.test_case "two hop route" `Quick test_two_hop_route;
204
+
Alcotest.test_case "no route" `Quick test_no_route;
205
+
Alcotest.test_case "earliest arrival" `Quick test_earliest_arrival;
206
+
Alcotest.test_case "wait for contact" `Quick test_wait_for_contact;
207
+
Alcotest.test_case "propagation delay" `Quick test_propagation_delay;
208
+
Alcotest.test_case "contact expires" `Quick test_contact_expires;
209
+
Alcotest.test_case "find routes" `Quick test_find_routes;
210
+
] );
211
+
( "contact plan",
212
+
[
213
+
Alcotest.test_case "operations" `Quick test_contact_plan;
214
+
] );
215
+
( "route",
216
+
[
217
+
Alcotest.test_case "capacity" `Quick test_route_capacity;
218
+
] );
219
+
]