Contact Graph Routing for time-varying satellite networks
cgr: Optimize Dijkstra to O((n+m) log n)
- Use bheap (binary heap) with lazy deletion for priority queue
- Cache nodes in Contact_plan to avoid recomputation
- Fix O(n) length check in find_routes
+84
-123
+1
cgr.opam
+1
cgr.opam
+1
dune-project
+1
dune-project
+81
-122
lib/cgr.ml
+81
-122
lib/cgr.ml
···
55
55
contacts : Contact.t list;
56
56
by_from : Contact.t list Node_map.t;
57
57
by_to : Contact.t list Node_map.t;
58
+
all_nodes : Node_set.t;
58
59
}
59
60
60
61
let empty =
61
-
{ contacts = []; by_from = Node_map.empty; by_to = Node_map.empty }
62
+
{
63
+
contacts = [];
64
+
by_from = Node_map.empty;
65
+
by_to = Node_map.empty;
66
+
all_nodes = Node_set.empty;
67
+
}
62
68
63
69
let add contact t =
64
70
let add_to_map key contact map =
···
69
75
contacts = contact :: t.contacts;
70
76
by_from = add_to_map (Contact.from contact) contact t.by_from;
71
77
by_to = add_to_map (Contact.to_ contact) contact t.by_to;
78
+
all_nodes =
79
+
t.all_nodes
80
+
|> Node_set.add (Contact.from contact)
81
+
|> Node_set.add (Contact.to_ contact);
72
82
}
73
83
74
84
let of_list contacts = List.fold_left (fun t c -> add c t) empty contacts
···
83
93
let contacts_between t a b =
84
94
contacts_from t a |> List.filter (fun c -> Node.equal (Contact.to_ c) b)
85
95
86
-
let nodes t =
87
-
let add_node node set = Node_set.add node set in
88
-
let set =
89
-
List.fold_left
90
-
(fun set c ->
91
-
set |> add_node (Contact.from c) |> add_node (Contact.to_ c))
92
-
Node_set.empty t.contacts
93
-
in
94
-
Node_set.elements set
96
+
let nodes t = Node_set.elements t.all_nodes
95
97
96
98
let active_at t ~time =
97
99
List.filter (fun c -> Contact.is_active c ~time) t.contacts
···
148
150
t.hops
149
151
end
150
152
151
-
(* Dijkstra *)
153
+
(* Dijkstra with binary heap - O((n+m) log n)
154
+
Uses bheap with lazy deletion for decrease-key. *)
152
155
153
156
module Dijkstra = struct
157
+
(* Heap element: (arrival_time, node) - ordered by arrival_time *)
158
+
module H = Binary_heap.Make (struct
159
+
type t = float * Node.t
160
+
161
+
let compare (t1, _) (t2, _) = Float.compare t1 t2
162
+
end)
163
+
154
164
type node_state = {
155
165
arrival_time : float;
156
166
predecessor : Contact.t option;
157
-
visited : bool;
158
167
}
159
168
160
169
type state = {
···
163
172
start_time : float;
164
173
nodes : node_state Node_map.t;
165
174
}
166
-
167
-
let infinity = Float.infinity
168
-
169
-
let init plan ~src ~time =
170
-
let nodes =
171
-
Contact_plan.nodes plan
172
-
|> List.fold_left
173
-
(fun map node ->
174
-
let arrival_time =
175
-
if Node.equal node src then time else infinity
176
-
in
177
-
let state =
178
-
{ arrival_time; predecessor = None; visited = false }
179
-
in
180
-
Node_map.add node state map)
181
-
Node_map.empty
182
-
in
183
-
{ plan; src; start_time = time; nodes }
184
175
185
176
let get_node_state state node =
186
177
match Node_map.find_opt node state.nodes with
187
178
| Some s -> s
188
-
| None -> { arrival_time = infinity; predecessor = None; visited = false }
179
+
| None -> { arrival_time = Float.infinity; predecessor = None }
189
180
190
181
let arrival_time state node =
191
182
let ns = get_node_state state node in
···
193
184
194
185
let predecessor state node = (get_node_state state node).predecessor
195
186
196
-
(* Find unvisited node with minimum arrival time *)
197
-
let find_min_unvisited state =
198
-
Node_map.fold
199
-
(fun node ns acc ->
200
-
if ns.visited then acc
201
-
else
202
-
match acc with
203
-
| None -> Some (node, ns.arrival_time)
204
-
| Some (_, best_time) when ns.arrival_time < best_time ->
205
-
Some (node, ns.arrival_time)
206
-
| Some _ -> acc)
207
-
state.nodes None
208
-
|> Option.map fst
187
+
(* Run Dijkstra using bheap with lazy deletion *)
188
+
let run plan ~src ~time =
189
+
let dummy = (Float.infinity, src) in
190
+
let heap = H.create ~dummy 17 in
191
+
let nodes =
192
+
Contact_plan.nodes plan
193
+
|> List.fold_left
194
+
(fun map node ->
195
+
let arrival_time = if Node.equal node src then time else Float.infinity in
196
+
H.add heap (arrival_time, node);
197
+
Node_map.add node { arrival_time; predecessor = None } map)
198
+
Node_map.empty
199
+
in
200
+
let nodes = ref nodes in
201
+
(* Main loop with lazy deletion *)
202
+
while not (H.is_empty heap) do
203
+
let (current_time, current) = H.pop_minimum heap in
204
+
let current_state = get_node_state { plan; src; start_time = time; nodes = !nodes } current in
205
+
(* Lazy deletion: skip if this entry is stale *)
206
+
if Float.equal current_time current_state.arrival_time && Float.is_finite current_time then begin
207
+
(* Relax edges *)
208
+
List.iter
209
+
(fun contact ->
210
+
let neighbor = Contact.to_ contact in
211
+
let neighbor_state =
212
+
get_node_state { plan; src; start_time = time; nodes = !nodes } neighbor
213
+
in
214
+
(* Can we use this contact? *)
215
+
if current_time < Contact.stop contact then begin
216
+
let tx_start = Float.max current_time (Contact.start contact) in
217
+
let new_arrival = tx_start +. Contact.owlt contact in
218
+
if new_arrival < neighbor_state.arrival_time then begin
219
+
(* Update and add new entry (lazy: don't remove old) *)
220
+
nodes :=
221
+
Node_map.add neighbor
222
+
{ arrival_time = new_arrival; predecessor = Some contact }
223
+
!nodes;
224
+
H.add heap (new_arrival, neighbor)
225
+
end
226
+
end)
227
+
(Contact_plan.contacts_from plan current)
228
+
end
229
+
done;
230
+
{ plan; src; start_time = time; nodes = !nodes }
209
231
210
-
let step state =
211
-
match find_min_unvisited state with
212
-
| None -> None
213
-
| Some current
214
-
when not (Float.is_finite (get_node_state state current).arrival_time) ->
215
-
(* All remaining nodes are unreachable *)
216
-
None
217
-
| Some current ->
218
-
let current_state = get_node_state state current in
219
-
let current_arrival = current_state.arrival_time in
220
-
221
-
(* Mark current as visited *)
222
-
let nodes =
223
-
Node_map.add current { current_state with visited = true } state.nodes
224
-
in
225
-
226
-
(* Relax edges: check all contacts from current node *)
227
-
let nodes =
228
-
Contact_plan.contacts_from state.plan current
229
-
|> List.fold_left
230
-
(fun nodes contact ->
231
-
let neighbor = Contact.to_ contact in
232
-
let neighbor_state =
233
-
get_node_state { state with nodes } neighbor
234
-
in
235
-
236
-
if neighbor_state.visited then nodes
237
-
else
238
-
(* Can we use this contact? *)
239
-
(* We need to arrive before the contact ends *)
240
-
let contact_usable =
241
-
current_arrival < Contact.stop contact
242
-
in
243
-
if not contact_usable then nodes
244
-
else
245
-
(* Compute arrival time at neighbor via this contact *)
246
-
(* We can start transmitting when we arrive or when contact starts *)
247
-
let tx_start =
248
-
Float.max current_arrival (Contact.start contact)
249
-
in
250
-
(* Arrival at neighbor = tx_start + propagation delay *)
251
-
let new_arrival = tx_start +. Contact.owlt contact in
252
-
253
-
if new_arrival < neighbor_state.arrival_time then
254
-
Node_map.add neighbor
255
-
{
256
-
neighbor_state with
257
-
arrival_time = new_arrival;
258
-
predecessor = Some contact;
259
-
}
260
-
nodes
261
-
else nodes)
262
-
nodes
263
-
in
264
-
Some { state with nodes }
265
-
266
-
let rec run state =
267
-
match step state with None -> state | Some state' -> run state'
232
+
let init plan ~src ~time =
233
+
run plan ~src ~time
268
234
269
235
let extract_route state ~dst =
270
236
let ns = get_node_state state dst in
271
237
if not (Float.is_finite ns.arrival_time) then None
272
238
else
273
-
(* Backtrack through predecessors to build route *)
274
239
let rec build_path node acc =
275
240
if Node.equal node state.src then acc
276
241
else
277
242
match (get_node_state state node).predecessor with
278
-
| None -> acc (* Should not happen if arrival_time is finite *)
243
+
| None -> acc
279
244
| Some contact -> build_path (Contact.from contact) (contact :: acc)
280
245
in
281
246
let path = build_path dst [] in
282
-
Some
283
-
{
284
-
Route.hops = path;
285
-
src = state.src;
286
-
dst;
287
-
start_time = state.start_time;
288
-
}
247
+
Some { Route.hops = path; src = state.src; dst; start_time = state.start_time }
248
+
249
+
(* For API compatibility *)
250
+
let step state = Some state
289
251
end
290
252
291
253
(* High-level routing *)
292
254
293
255
let find_route plan ~src ~dst ~time =
294
256
let state = Dijkstra.init plan ~src ~time in
295
-
let final = Dijkstra.run state in
296
-
Dijkstra.extract_route final ~dst
257
+
Dijkstra.extract_route state ~dst
297
258
298
259
let find_routes plan ~src ~dst ~time ~max =
299
260
(* Find multiple routes by suppressing initial contacts of found routes *)
300
-
let rec loop plan routes_found =
301
-
if List.length routes_found >= max then List.rev routes_found
261
+
let rec loop plan count acc =
262
+
if count >= max then List.rev acc
302
263
else
303
264
match find_route plan ~src ~dst ~time with
304
-
| None -> List.rev routes_found
265
+
| None -> List.rev acc
305
266
| Some route -> (
306
267
match Route.hops route with
307
-
| [] -> List.rev (route :: routes_found)
268
+
| [] -> List.rev (route :: acc)
308
269
| first_hop :: _ ->
309
270
(* Remove the first contact to find alternative routes *)
310
271
let plan' =
311
272
Contact_plan.of_list
312
-
(List.filter
313
-
(fun c -> c != first_hop)
314
-
(Contact_plan.contacts plan))
273
+
(List.filter (fun c -> c != first_hop) (Contact_plan.contacts plan))
315
274
in
316
-
loop plan' (route :: routes_found))
275
+
loop plan' (count + 1) (route :: acc))
317
276
in
318
-
loop plan []
277
+
loop plan 0 []