Commit 5eb576e7 authored by POTTIER Francois's avatar POTTIER Francois

Some work to bring [Dijstra] and A* closer to one another.

parent 822ce6f6
......@@ -52,7 +52,7 @@ module ForwardAutomaton = struct
(* The sources are the entry states. *)
ProductionMap.iter (fun _ s -> f s) Lr1.entry
let successors edge s =
let successors s edge =
SymbolMap.iter (fun sym s' ->
(* The weight of the edge from [s] to [s'] is given by the function
[Grammar.Analysis.minimal_symbol]. *)
......@@ -65,6 +65,22 @@ let approximate : Lr1.node -> int =
let module D = Dijkstra.Make(ForwardAutomaton) in
D.search (fun (_, _, _) -> ())
let approx : Lr1.node -> int =
let module A = Astar.Make(struct
include ForwardAutomaton
let estimate _ = 0
type node = vertex
end) in
let distance, _ = A.search (fun (_, _) -> ()) in
distance
(* Debugging. TEMPORARY *)
let approximate s =
let d1 = approximate s
and d2 = approx s in
assert (d1 = d2);
d1
(* Test. TEMPORARY *)
let () =
......@@ -390,7 +406,7 @@ let backward (s', z) : P.property =
(* Backward search from the single source [s', z]. *)
let sources f = f (s', z)
let successors edge (s', z) =
let successors (s', z) edge =
match Lr1.incoming_symbol s' with
| None ->
(* An entry state has no predecessor states. *)
......
......@@ -41,9 +41,6 @@ module Make (G : sig
val sources: (node -> unit) -> unit
(* Whether a node is a goal node. *)
val is_goal: node -> bool
(* [successors n f] presents each of [n]'s successors, in
an arbitrary order, to [f], together with the cost of
the edge that was followed. *)
......@@ -59,24 +56,24 @@ end) = struct
type cost = int
type priority = cost (* Nodes with low priorities are dealt with first. *)
(* Nodes with low priorities are dealt with first. *)
type priority = cost
type inode = {
this: G.node; (* Graph node associated with this internal record. *)
mutable cost: cost; (* Cost of the best known path from a source node to this node. (ghat) *)
estimate: cost; (* Estimated cost of the best path from this node to a goal node. (hhat) *)
mutable father: inode; (* Last node on the best known path from a source node to this node. *)
mutable prev: inode; (* Previous node on doubly linked priority list *)
mutable next: inode; (* Next node on doubly linked priority list *)
mutable priority: priority; (* The node's priority, if the node is in the queue; -1 otherwise *)
(* Graph node associated with this internal record. *)
this: G.node;
(* Cost of the best known path from a source node to this node. (ghat) *)
mutable cost: cost;
(* Estimated cost of the best path from this node to a goal node. (hhat) *)
estimate: cost;
(* Best known path from a source node to this node. *)
mutable path: G.label list;
(* Previous node on doubly linked priority list *)
mutable prev: inode;
(* Next node on doubly linked priority list *)
mutable next: inode;
(* The node's priority, if the node is in the queue; -1 otherwise *)
mutable priority: priority;
}
(* This auxiliary module maintains a mapping of graph nodes
......@@ -120,9 +117,8 @@ end) = struct
can only decrease. *)
val add_or_decrease: inode -> priority -> unit
(* Retrieve a node with lowest priority of the queue.
Raises [Not_found] if the queue is empty. *)
val get: unit -> inode
(* Retrieve a node with lowest priority of the queue. *)
val get: unit -> inode option
end = struct
......@@ -167,18 +163,18 @@ end) = struct
let get () =
if !best = max then
raise Not_found (* queue is empty *)
None
else
match a.(!best) with
| None ->
assert false
| Some inode ->
| Some inode as result ->
remove inode;
(* look for next nonempty bucket *)
while (!best < max) && (a.(!best) = None) do
incr best
done;
inode
result
let add_or_decrease inode priority =
if inode.priority >= 0 then
......@@ -195,7 +191,7 @@ end) = struct
this = node;
cost = 0;
estimate = G.estimate node;
father = inode;
path = [];
prev = inode;
next = inode;
priority = -1
......@@ -207,91 +203,78 @@ end) = struct
let expanded =
ref 0
(* Search. *)
let rec search () =
(* Pick the open node that currently has lowest fhat, (* TEMPORARY resolve ties in favor of goal nodes *)
that is, lowest estimated distance to a goal node. *)
(* Access to the search results (after the search is over). *)
let inode = P.get () in (* may raise Not_found; then, no goal node is reachable *)
let node = inode.this in
let distance node =
try (M.get node).cost with Not_found -> max_int
(* If it is a goal node, we are done. *)
if G.is_goal node then
inode
else begin
let path node =
(M.get node).path (* let [Not_found] escape if no path was found *)
(* Monitoring. *)
incr expanded;
(* Otherwise, examine its successors. *)
G.successors node (fun _ edge_cost son ->
(* Determine the cost of the best known path from the
start node, through this node, to this son. *)
let new_cost = inode.cost + edge_cost in
(* Search. *)
try
let ison = M.get son in
if new_cost < ison.cost then begin
let rec search f =
(* This son has been visited before, but this new
path to it is shorter. If it was already open
and waiting in the priority queue, increase its
priority; otherwise, mark it as open and insert
it into the queue. *)
(* Pick the open node that currently has lowest fhat,
that is, lowest estimated distance to a goal node. *)
let new_fhat = new_cost + ison.estimate in
P.add_or_decrease ison new_fhat;
ison.cost <- new_cost;
ison.father <- inode
match P.get() with
| None ->
(* Finished. *)
distance, path
end
with Not_found ->
| Some inode ->
let node = inode.this in
(* This son was never visited before. Allocate a new
status record for it and mark it as open. *)
(* Let the user know about this newly discovered node. *)
f (node, inode.path);
let e = G.estimate son in
let rec ison = {
this = son;
cost = new_cost;
estimate = e;
father = inode;
prev = ison;
next = ison;
priority = -1
} in
M.add son ison;
P.add ison (new_cost + e)
(* Monitoring. *)
incr expanded;
);
(* Otherwise, examine its successors. *)
G.successors node (fun label edge_cost son ->
search()
(* Determine the cost of the best known path from the
start node, through this node, to this son. *)
let new_cost = inode.cost + edge_cost in
end
try
let ison = M.get son in
if new_cost < ison.cost then begin
(* Main function. *)
(* This son has been visited before, but this new
path to it is shorter. If it was already open
and waiting in the priority queue, increase its
priority; otherwise, mark it as open and insert
it into the queue. *)
let path () =
let new_fhat = new_cost + ison.estimate in
P.add_or_decrease ison new_fhat;
ison.cost <- new_cost;
ison.path <- label :: inode.path
(* Find the nearest goal node. *)
end
with Not_found ->
let goal = search() in
(* This son was never visited before. Allocate a new
status record for it and mark it as open. *)
(* Build the shortest path back to the start node. *)
let e = G.estimate son in
let rec ison = {
this = son;
cost = new_cost;
estimate = e;
path = label :: inode.path;
prev = ison;
next = ison;
priority = -1
} in
M.add son ison;
P.add ison (new_cost + e)
let rec build path inode =
let path = inode.this :: path in
let father = inode.father in
if father == inode then
path
else
build path father
);
in
let path = build [] goal in
path
search f
end
......@@ -23,9 +23,6 @@ module Make (G : sig
the edge that was followed. *)
val successors: node -> (label -> int -> node -> unit) -> unit
(* Whether a node is a goal node. *)
val is_goal: node -> bool
(* An estimate of the cost of the shortest path from the
supplied node to some goal node. This estimate must
be a correct under-approximation of the actual cost. *)
......@@ -33,9 +30,10 @@ module Make (G : sig
end) : sig
(* This function produces a shortest path from the start
node to some goal node. It raises [Not_found] if no
such path exists. *)
val path: unit -> G.node list
(* Search. Newly discovered nodes are presented to the user, in order of
increasing distance from the source nodes, by invoking the user-supplied
function [f]. At the end, a mapping of nodes to distances to the source
nodes and a mapping of nodes to shortest paths are returned. *)
val search: (G.node * G.label list -> unit) -> (G.node -> int) * (G.node -> G.label list)
end
......@@ -18,7 +18,7 @@ module Make (G : sig
(* The weighted outgoing edges of a vertex. *)
val successors: (label -> int -> vertex -> unit) -> vertex -> unit
val successors: vertex -> (label -> int -> vertex -> unit) -> unit
end) = struct
open G
......@@ -67,14 +67,14 @@ end) = struct
(* Let the client know about it. *)
f (w, v, p);
(* Examine its outgoing edges. *)
successors (fun label weight v' ->
successors v (fun label weight v' ->
let w' = weight + w in
if w' < distance v' then begin
assert (not (H.mem fixed v'));
H.replace dist v' w';
PQ.add queue (w', v', label :: p)
end
) v
)
end
done;
distance
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment