From e82a94e036fb0eba198dd4f1fcf75acc24ec2e2a Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Thu, 16 Nov 2023 20:45:33 +0100 Subject: [PATCH 1/6] new module Search to solve one-player games many one-player games can be seen as graphs, and then can be solved using graph traversal algorithms such as DFS, BFS, etc. --- CHANGES.md | 3 + src/graph.ml | 1 + src/search.ml | 131 +++++++++++++++++++++++++++++++++++++++++++ src/search.mli | 131 +++++++++++++++++++++++++++++++++++++++++++ tests/dune | 5 ++ tests/test_search.ml | 87 ++++++++++++++++++++++++++++ 6 files changed, 358 insertions(+) create mode 100644 src/search.ml create mode 100644 src/search.mli create mode 100644 tests/test_search.ml diff --git a/CHANGES.md b/CHANGES.md index c579de20..956b0a47 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,7 @@ + - [Search]: solve one-player games using graph traversal algorithms + (depth-first search, breadth-first search, iterative deepening + depth-first search) - [Traverse.Bfs]: new function `{fold,iter}_component_dist` to perform a breadth-first traversal with the distance from the source diff --git a/src/graph.ml b/src/graph.ml index 5f374dcb..cf88ea6a 100644 --- a/src/graph.ml +++ b/src/graph.ml @@ -12,6 +12,7 @@ module Rand = Rand module Oper = Oper module Components = Components module Path = Path +module Search = Search module Cycles = Cycles module Nonnegative = Nonnegative module Traverse = Traverse diff --git a/src/search.ml b/src/search.ml new file mode 100644 index 00000000..c971b71c --- /dev/null +++ b/src/search.ml @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Search algorithms *) + +(** Minimal graph signature. + Compatible with {!Sig.G}. *) +module type G = sig + type t + module V : Sig.COMPARABLE + type vertex = V.t + module E : sig + type t + val src : t -> V.t + val dst : t -> V.t + end + type edge = E.t + val fold_succ_e: (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val success: t -> vertex -> bool +end + +module Path(G: G) = struct + + let rec final v = function + | [] -> v + | e :: _ when G.V.compare v (G.E.src e) <> 0 -> invalid_arg "final" + | e :: path -> final (G.E.dst e) path + + let valid start path = + try ignore (final start path); true + with Invalid_argument _ -> false + + let solution g start path = + try G.success g (final start path) + with Invalid_argument _ -> false + +end + +module DFS(G: G) = struct + + module H = Hashtbl.Make(G.V) + + let search g start = + let visited = H.create 128 in + let test v = H.mem visited v || (H.add visited v (); false) in + let rec dfs = function + | [] -> + raise Not_found + | (s, path) :: stack -> + if test s then + dfs stack + else if G.success g s then + s, List.rev path + else + dfs + (G.fold_succ_e + (fun e stack -> (G.E.dst e, e :: path) :: stack) + g s stack) + in + dfs [start, []] + +end + +module BFS(G: G) = struct + + module H = Hashtbl.Make(G.V) + + let search g start = + let visited = H.create 128 in + let push path e next = + let v = G.E.dst e in + if H.mem visited v then next + else (H.add visited v (); (v, e :: path) :: next) in + let rec loop next = function + | [] -> + if next = [] then raise Not_found; + loop [] next + | (v, path) :: _ when G.success g v -> + v, List.rev path + | (v, path) :: todo -> + let next = G.fold_succ_e (push path) g v next in + loop next todo in + H.add visited start (); + loop [] [start, []] + +end + +module IDS(G: G) = struct + + let search g start = + let max_reached = ref false in + let depth max = + let rec dfs = function + | [] -> raise Not_found + | (_, path, s) :: _ when G.success g s -> s, List.rev path + | (n, path, s) :: stack -> + dfs + (if n < max then + G.fold_succ_e + (fun e stack -> (n + 1, e :: path, G.E.dst e) :: stack) + g s stack + else ( + max_reached := true; + stack + )) in + dfs [0, [], start] in + let rec try_depth d = + try + max_reached := false; + depth d + with Not_found -> + if !max_reached then try_depth (d + 1) else raise Not_found + in + try_depth 0 + +end diff --git a/src/search.mli b/src/search.mli new file mode 100644 index 00000000..624f174a --- /dev/null +++ b/src/search.mli @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Search algorithms to solve one-player games. + + Many one-player games can be conveniently seen as graphs, and graph + traversal algorithms can then be used to solve them. There is no + need to build the entire graph (though we can in some cases, provided + it fits in memory), as the graph is implicitely described by a + starting vertex (the initial state of the game) and some adjacency + function ([fold_succ_e] below). + + A Boolean function [success] is used to describe winning states. +*) + +(** Minimal graph signature. + Everything apart from [success] is compatible with {!Sig.G}. *) +module type G = sig + type t + module V : Sig.COMPARABLE + type vertex = V.t + module E : sig + type t + val src: t -> V.t + val dst: t -> V.t + end + type edge = E.t + val fold_succ_e: (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val success: t -> vertex -> bool +end + +(** Depth-First Search *) + +module DFS(G: G) : sig + + val search: G.t -> G.vertex -> G.vertex * G.edge list + (** [search g start] searches a solution from vertex [start]. + If a solution is found, it is returned as a final vertex [f] + (for which [success] is true) and a path from [start] to [f]. + If no solution exists, exception [Not_found] is raised when all + reachable vertices are visited. *) + +end + +(** Breadth-First Search + + A breadth-first search from the initial vertex guarantees a + path of minimal length, if any. + + Caveat: Breadth-first search may require a lot of memory. + If this is an issue, consider other implementations below, + such as Iterative Deepening Search. +*) + +module BFS(G: G) : sig + + val search: G.t -> G.vertex -> G.vertex * G.edge list + (** [search g start] searches a solution from vertex [start]. + If a solution is found, it is returned as a final vertex [f] + (for which [success] is true) and a path from [start] to [f]. + If no solution exists, exception [Not_found] is raised when all + reachable vertices are visited. *) + +end + +(** Iterative Deepening Depth-First Search + + An alternative to breadth-first search is to perform depth-first + searches with a maximal depth, that is increased until we find a + solution. In graphs that are tress, this can be asymptotically as + good as breadth-first search, but it uses much less memory. + + Caveat: It runs forever if there are reachable cycles. +*) + +module IDS(G: G) : sig + + val search: G.t -> G.vertex -> G.vertex * G.edge list + (** [search g start] searches a solution from vertex [start]. + If a solution is found, it is returned as a final vertex [f] + (for which [success] is true) and a path from [start] to [f]. + If no solution exists, exception [Not_found] is raised when all + reachable vertices are visited. + + Note: This implementation is not tail recursive. It uses a stack + space proportional to the length of the solution. This is + usually not an issue, as a solution whose length would exhaust + the stack is likely to take too much time to be found. +*) + +end + +(** Auxiliary functions to manipulate paths. *) +module Path(G: G) : sig + + (** A valid path is a list of edges where each destination vertex + is the source vertex of the next edge in the list. + + Caveat: In the following, we do not check that edges belong to + the graph. (And we could not.) *) + + val final: G.vertex -> G.edge list -> G.vertex + (** [final start path] returns the final vertex of a [path] + starting from vertex [start]. + Raises [Invalid_argument] if [path] is not a valid path from [start]. *) + + val valid: G.vertex -> G.edge list -> bool + (** [check start path] returns [true] if and only if [path] is a + valid path from [start].m *) + + val solution: G.t -> G.vertex -> G.edge list -> bool + (** [check g start path] returns [true] if and only if [path] is a + valid path from [start] ending on a success vertex. *) + +end + diff --git a/tests/dune b/tests/dune index 179930e9..4399c536 100644 --- a/tests/dune +++ b/tests/dune @@ -13,6 +13,11 @@ (libraries graph) (modules test_dfs)) +(test + (name test_search) + (libraries graph) + (modules test_search)) + (test (name test_topsort) (libraries graph) diff --git a/tests/test_search.ml b/tests/test_search.ml new file mode 100644 index 00000000..9e832202 --- /dev/null +++ b/tests/test_search.ml @@ -0,0 +1,87 @@ + +(* 0 + ^ + | + | + 1---2---3 + |\ /| + | \ / | + | 4 | 7---->8 + | / \ | ^ | + v / \ v | v + 5 6 10<----9 +*) + +open Format +open Graph +open Pack.Digraph + +let debug = false + +let g = create () +let v = Array.init 11 V.create +let () = Array.iter (add_vertex g) v +let adde x y = add_edge g v.(x) v.(y) +let addu x y = adde x y; adde y x +let () = adde 1 0 +let () = addu 1 2; addu 2 3 +let () = adde 1 5; adde 3 6 +let () = addu 1 4; addu 4 3; addu 5 4; addu 4 6 +let () = adde 7 8; adde 8 9; adde 9 10; adde 10 7 + +let target = v.(4) + +module G = struct + include Pack.Digraph + let success _ v = + V.compare v target = 0 +end + +module P = Search.Path(G) +module D = Search.BFS(G) +module B = Search.BFS(G) + +let test search s b = + let start = v.(s) in + try + let f, path = search g start in + assert b; + assert (P.solution g start path); + assert (V.compare f target = 0) + with Not_found -> + assert (not b) + +let run search = + test search 0 false; + for i = 1 to 6 do test search i true done; + for i = 7 to 10 do test search i false done + +let () = + for i = 1 to 6 do + let _, path = B.search g v.(i) in + assert (List.length path = if i = 2 then 2 else if i = 4 then 0 else 1) + done + +let () = run D.search +let () = run B.search + +module I = Search.IDS(G) + +(* 5 <----- 0 ------> 1 ------> 2 ------> 3 ----> 4 + | | ^ + v | | + 6 +-------------------+ +*) +let () = G.clear g +let () = Array.iter (add_vertex g) v +let () = adde 0 1; adde 1 2; adde 2 3; adde 3 4; adde 0 2 +let () = adde 0 5; adde 5 6 + +let () = + for i = 0 to 4 do test I.search i true done; + for i = 5 to 6 do test I.search i false done +let () = + let _, path = I.search g v.(0) in + assert (List.length path = 3) + +let () = printf "All tests succeeded.@." From 69cab45ca0978a2fe198cc834503269cace7fe42 Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Sat, 18 Nov 2023 11:52:19 +0100 Subject: [PATCH 2/6] Search: added Dijkstra's algorithm --- CHANGES.md | 5 ++--- src/search.ml | 45 ++++++++++++++++++++++++++++++++++++++ src/search.mli | 52 +++++++++++++++++++++++++++++++++----------- tests/test_search.ml | 34 +++++++++++++++++++++++++++-- 4 files changed, 118 insertions(+), 18 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 956b0a47..88e0c9ad 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,7 +1,6 @@ - - [Search]: solve one-player games using graph traversal algorithms - (depth-first search, breadth-first search, iterative deepening - depth-first search) + - [Search]: path search algorithms (DFS, BFS, iterative deepening + DFS, Dijkstra) - [Traverse.Bfs]: new function `{fold,iter}_component_dist` to perform a breadth-first traversal with the distance from the source diff --git a/src/search.ml b/src/search.ml index c971b71c..9f352bd5 100644 --- a/src/search.ml +++ b/src/search.ml @@ -129,3 +129,48 @@ module IDS(G: G) = struct try_depth 0 end + +(** Graphs with cost *) + +module Dijkstra + (G: G) + (C: Sig.WEIGHT with type edge = G.E.t) = +struct + module H = Hashtbl.Make(G.V) + + module Elt = struct + type t = C.t * G.V.t * G.E.t list + let compare (w1,v1,_) (w2,v2,_) = + let cw = C.compare w2 w1 in + if cw != 0 then cw else G.V.compare v1 v2 + end + module PQ = Heap.Imperative(Elt) + + let search g start = + let closed = H.create 128 in + let dist = H.create 128 in + let memo v = H.mem closed v || (H.add closed v (); false) in + let q = PQ.create 128 in + let rec loop () = + if PQ.is_empty q then raise Not_found; + let d,s,path = PQ.pop_maximum q in + if G.success g s then + s, List.rev path, d + else ( + if not (memo s) then + G.fold_succ_e + (fun e () -> + let s' = G.E.dst e in + let d' = C.add d (C.weight e) in + if not (H.mem dist s') || C.compare d' (H.find dist s') < 0 then ( + H.replace dist s' d'; + PQ.add q (d', s', e :: path) + )) + g s (); + loop () + ) in + H.add dist start C.zero; + PQ.add q (C.zero, start, []); + loop () + +end diff --git a/src/search.mli b/src/search.mli index 624f174a..80e4bb3f 100644 --- a/src/search.mli +++ b/src/search.mli @@ -15,20 +15,31 @@ (* *) (**************************************************************************) -(** Search algorithms to solve one-player games. +(** {2 Path Search Algorithms} + + This module implements several algorithms to find paths in graphs, + given a source vertex and a set of target vertices (described by + a Boolean function [success] below). + + Many one-player games can be conveniently seen as graphs, and + these algorithms can then be used to solve them. There is no need + to build the entire graph (though we can in some cases, provided + it fits in memory), as the graph is implicitely described some + adjacency function ([fold_succ_e] below). The graph may even be + infinite in some cases. +*) - Many one-player games can be conveniently seen as graphs, and graph - traversal algorithms can then be used to solve them. There is no - need to build the entire graph (though we can in some cases, provided - it fits in memory), as the graph is implicitely described by a - starting vertex (the initial state of the game) and some adjacency - function ([fold_succ_e] below). +(** {2 Minimal graph signature} - A Boolean function [success] is used to describe winning states. + Everything apart from [success] is compatible with {!Sig.G}. + This way, you can use graph structures from OCamlGraph as follows: + {[ + module G = struct + include Pack.Digraph (* or any other *) + let success g v = ... + end + ]} *) - -(** Minimal graph signature. - Everything apart from [success] is compatible with {!Sig.G}. *) module type G = sig type t module V : Sig.COMPARABLE @@ -85,7 +96,8 @@ end solution. In graphs that are tress, this can be asymptotically as good as breadth-first search, but it uses much less memory. - Caveat: It runs forever if there are reachable cycles. + Caveat: It runs forever if there is no successful path and + reachable cycles. *) module IDS(G: G) : sig @@ -105,7 +117,21 @@ module IDS(G: G) : sig end -(** Auxiliary functions to manipulate paths. *) +(** {2 Graphs with cost} *) + +(** Dijkstra's algorithm + + This is distinct from {!Path.Dijkstra} in that we do not provide + a target vertex, but a [success] function. *) + +module Dijkstra(G: G)(C: Sig.WEIGHT with type edge = G.E.t): sig + + val search: G.t -> G.vertex -> G.vertex * G.edge list * C.t + +end + +(** {2 Auxiliary functions to manipulate paths} *) + module Path(G: G) : sig (** A valid path is a list of edges where each destination vertex diff --git a/tests/test_search.ml b/tests/test_search.ml index 9e832202..a218a2b1 100644 --- a/tests/test_search.ml +++ b/tests/test_search.ml @@ -6,7 +6,7 @@ 1---2---3 |\ /| | \ / | - | 4 | 7---->8 + | 4* | 7---->8 | / \ | ^ | v / \ v | v 5 6 10<----9 @@ -38,7 +38,7 @@ module G = struct end module P = Search.Path(G) -module D = Search.BFS(G) +module D = Search.DFS(G) module B = Search.BFS(G) let test search s b = @@ -65,6 +65,36 @@ let () = let () = run D.search let () = run B.search +(* 0 + ^ + | + | + 1---2---3 + |\ +3/| + | \ / | + | 4* | 7---->8 + | / \ | ^ | + v / \ v | v + 5 6 10<----9 +*) +module C = struct + include Int type edge = G.E.t + let weight e = + let x, y = G.E.src e, G.E.dst e in + if V.compare x v.(3) = 0 && V.compare y v.(4) = 0 then 3 else 1 +end +module Di = Search.Dijkstra(G)(C) + +let () = + let check (i, di) = + let _, path, d = Di.search g v.(i) in + assert (List.length path = d); + assert (d = di) in + List.iter check [1,1; 2,2; 3,2; 4,0; 5,1; 6,1]; + let check i = + try ignore (Di.search g v.(i)); assert false with Not_found -> () in + List.iter check [0; 7; 8; 9; 10] + module I = Search.IDS(G) (* 5 <----- 0 ------> 1 ------> 2 ------> 3 ----> 4 From 4bf0712d67d40d88aef4c12dbf181873e08f224b Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Sat, 18 Nov 2023 16:06:36 +0100 Subject: [PATCH 3/6] Search: added A* algorithm --- src/search.ml | 84 +++++++++++++++++++++++++++++++------------- src/search.mli | 21 +++++++++++ tests/test_search.ml | 57 ++++++++++++++++++++++++++++++ 3 files changed, 137 insertions(+), 25 deletions(-) diff --git a/src/search.ml b/src/search.ml index 9f352bd5..e63e236a 100644 --- a/src/search.ml +++ b/src/search.ml @@ -53,11 +53,11 @@ end module DFS(G: G) = struct - module H = Hashtbl.Make(G.V) + module T = Hashtbl.Make(G.V) let search g start = - let visited = H.create 128 in - let test v = H.mem visited v || (H.add visited v (); false) in + let visited = T.create 128 in + let test v = T.mem visited v || (T.add visited v (); false) in let rec dfs = function | [] -> raise Not_found @@ -78,14 +78,14 @@ end module BFS(G: G) = struct - module H = Hashtbl.Make(G.V) + module T = Hashtbl.Make(G.V) let search g start = - let visited = H.create 128 in + let visited = T.create 128 in let push path e next = let v = G.E.dst e in - if H.mem visited v then next - else (H.add visited v (); (v, e :: path) :: next) in + if T.mem visited v then next + else (T.add visited v (); (v, e :: path) :: next) in let rec loop next = function | [] -> if next = [] then raise Not_found; @@ -95,7 +95,7 @@ module BFS(G: G) = struct | (v, path) :: todo -> let next = G.fold_succ_e (push path) g v next in loop next todo in - H.add visited start (); + T.add visited start (); loop [] [start, []] end @@ -136,21 +136,26 @@ module Dijkstra (G: G) (C: Sig.WEIGHT with type edge = G.E.t) = struct - module H = Hashtbl.Make(G.V) + module T = Hashtbl.Make(G.V) module Elt = struct type t = C.t * G.V.t * G.E.t list - let compare (w1,v1,_) (w2,v2,_) = - let cw = C.compare w2 w1 in - if cw != 0 then cw else G.V.compare v1 v2 + let compare (w1,_v1,_) (w2,_v2,_) = C.compare w2 w1 end module PQ = Heap.Imperative(Elt) let search g start = - let closed = H.create 128 in - let dist = H.create 128 in - let memo v = H.mem closed v || (H.add closed v (); false) in + let closed = T.create 128 in + let dist = T.create 128 in + let memo v = T.mem closed v || (T.add closed v (); false) in let q = PQ.create 128 in + let relax d path e = + let s' = G.E.dst e in + let d' = C.add d (C.weight e) in + if not (T.mem dist s') || C.compare d' (T.find dist s') < 0 then ( + T.replace dist s' d'; + PQ.add q (d', s', e :: path) + ) in let rec loop () = if PQ.is_empty q then raise Not_found; let d,s,path = PQ.pop_maximum q in @@ -158,19 +163,48 @@ struct s, List.rev path, d else ( if not (memo s) then - G.fold_succ_e - (fun e () -> - let s' = G.E.dst e in - let d' = C.add d (C.weight e) in - if not (H.mem dist s') || C.compare d' (H.find dist s') < 0 then ( - H.replace dist s' d'; - PQ.add q (d', s', e :: path) - )) - g s (); + G.fold_succ_e (fun e () -> relax d path e) g s (); loop () ) in - H.add dist start C.zero; + T.add dist start C.zero; PQ.add q (C.zero, start, []); loop () end + +module Astar(G: G)(C: Sig.WEIGHT with type edge = G.E.t) + (H: sig val heuristic: G.V.t -> C.t end) = struct + + module T = Hashtbl.Make(G.V) + + module Elt = struct + type t = C.t * G.V.t * G.E.t list + let compare (h1,_,_) (h2,_,_) = C.compare h1 h2 + end + module PQ = Heap.Imperative(Elt) + + let search g start = + let dist = T.create 128 in + let q = PQ.create 128 in + let add v d path = + T.replace dist v d; + PQ.add q (C.add d (H.heuristic v), v, path) in + add start C.zero []; + let relax path e = + let v = G.E.src e and w = G.E.dst e in + let d = C.add (T.find dist v) (C.weight e) in + if not (T.mem dist w) || C.compare d (T.find dist w) < 0 then + add w d (e :: path) in + let rec loop () = + if PQ.is_empty q then raise Not_found; + let _,s,path = PQ.pop_maximum q in + if G.success g s then + s, List.rev path, T.find dist s + else ( + G.fold_succ_e (fun e () -> relax path e) g s (); + loop () + ) in + loop () + +end + diff --git a/src/search.mli b/src/search.mli index 80e4bb3f..9954fd03 100644 --- a/src/search.mli +++ b/src/search.mli @@ -63,6 +63,7 @@ module DFS(G: G) : sig (** [search g start] searches a solution from vertex [start]. If a solution is found, it is returned as a final vertex [f] (for which [success] is true) and a path from [start] to [f]. + If no solution exists, exception [Not_found] is raised when all reachable vertices are visited. *) @@ -84,6 +85,7 @@ module BFS(G: G) : sig (** [search g start] searches a solution from vertex [start]. If a solution is found, it is returned as a final vertex [f] (for which [success] is true) and a path from [start] to [f]. + If no solution exists, exception [Not_found] is raised when all reachable vertices are visited. *) @@ -106,6 +108,7 @@ module IDS(G: G) : sig (** [search g start] searches a solution from vertex [start]. If a solution is found, it is returned as a final vertex [f] (for which [success] is true) and a path from [start] to [f]. + If no solution exists, exception [Not_found] is raised when all reachable vertices are visited. @@ -127,6 +130,24 @@ end module Dijkstra(G: G)(C: Sig.WEIGHT with type edge = G.E.t): sig val search: G.t -> G.vertex -> G.vertex * G.edge list * C.t + (** [search g start] searches a solution from vertex [start]. + If a solution is found, it is returned as a final vertex [f] + (for which [success] is true), a path from [start] to [f], and + the total cost of that path. + + If no solution exists, exception [Not_found] is raised when all + reachable vertices are visited. *) + +end + +(** {2 Graphs with cost and heuristic} *) + +(** A* algorithm *) + +module Astar(G: G)(C: Sig.WEIGHT with type edge = G.E.t) + (H: sig val heuristic: G.V.t -> C.t end): sig + + val search: G.t -> G.vertex -> G.vertex * G.edge list * C.t end diff --git a/tests/test_search.ml b/tests/test_search.ml index a218a2b1..fe9967ba 100644 --- a/tests/test_search.ml +++ b/tests/test_search.ml @@ -114,4 +114,61 @@ let () = let _, path = I.search g v.(0) in assert (List.length path = 3) +(* on a grid *) + +let n = 10 +let m = 10 +let g, vm = Classic.grid ~n ~m +let start = vm.(0).(0) +let targeti = n-1 and targetj = 5 +let target = vm.(targeti).(targetj) +let distance = targeti + targetj +(* +let () = for i = 0 to n-2 do remove_vertex g vm.(i).(m-2) done +let () = for i = 1 to n-1 do remove_vertex g vm.(i).(m-4) done +*) +module Gr = struct + include Pack.Digraph + let count = ref 0 + let reset () = count := 0 + let print msg = printf "%s: %d@." msg !count; reset () + let fold_succ_e f g v = incr count; fold_succ_e f g v + let success _ v = V.compare v target = 0 +end +module Co = struct + include Int type edge = G.E.t + let weight _e = 1 +end +module He = struct + let heuristic v = + let l = G.V.label v in + let i = l / m and j = l mod m in + n-1-i + m-1-j +end +module Dfs = Search.DFS(Gr) +module Bfs = Search.BFS(Gr) +module Ids = Search.BFS(Gr) +module Dij = Search.Dijkstra(Gr)(Co) +module Astar = Search.Astar(Gr)(Co)(He) + +let () = + let _,path = Dfs.search g start in + Gr.print "DFS"; + assert (List.length path = distance); + let _,path = Bfs.search g start in + Gr.print "BFS"; + assert (List.length path = distance); + let _,path = Ids.search g start in + Gr.print "IDS"; + assert (List.length path = distance); + let _,_path,d = Dij.search g start in + Gr.print "Dij"; + assert (List.length path = distance); + assert (d = distance); + let _,_path,d = Astar.search g start in + Gr.print "A* "; + assert (List.length path = distance); + assert (d = distance); + () + let () = printf "All tests succeeded.@." From 08046de722e0d7331a53ef5c2f7339a191f53906 Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Sun, 19 Nov 2023 11:28:23 +0100 Subject: [PATCH 4/6] new example show_search to visualize search algorithms --- examples/dune | 5 +- examples/show_search.ml | 144 ++++++++++++++++++++++++++++++++++++++++ src/search.ml | 4 +- 3 files changed, 149 insertions(+), 4 deletions(-) create mode 100644 examples/show_search.ml diff --git a/examples/dune b/examples/dune index fd21a657..3f64abbe 100644 --- a/examples/dune +++ b/examples/dune @@ -1,8 +1,9 @@ (executables - (names color compare_prim_kruskal demo_planar demo_prim demo sudoku) + (names color compare_prim_kruskal demo_planar demo_prim demo sudoku + show_search) (libraries graph unix graphics threads)) (alias (name runtest) (deps color.exe compare_prim_kruskal.exe demo_planar.exe demo_prim.exe - demo.exe sudoku.exe)) + demo.exe sudoku.exe show_search.exe)) diff --git a/examples/show_search.ml b/examples/show_search.ml new file mode 100644 index 00000000..42465698 --- /dev/null +++ b/examples/show_search.ml @@ -0,0 +1,144 @@ + +(** A quick hack to visualize search algorithms (see module Search) + + The graph is a grid, where colors meaning is as follows: + - gray : empty cells i.e. graph vertices + - red : start point (always 0,0) + - blue : target points (possibly many) + - black: blocked points i.e. not graph vertices + + Edit the graph by clicking on cells, which rotate Empty->Blocked->Target. + + Each cell is connected to its 8 neighbors. + + Run a search by typing: + - 'd' for DFS + - 'b' for BFS + - 'i' for IDS (typically takes too much time) + - 'j' for Dijkstra + - 'a' for A* +*) + +open Graphics +open Graph + +let n = ref 20 +let m = ref 20 + +let () = + Arg.parse [ + "-n", Arg.Set_int n, " set width (default 20)"; + "-m", Arg.Set_int m, " set height (default 20)"; + ] + (fun _ -> raise (Arg.Bad "")) + "show_search [options]" +let n = !n +let m = !m + +let step = 600 / max n m +let () = open_graph " 800x600" + +let lightgray = rgb 200 200 200 +let draw i j c = + set_color c; + let y = step * j and x = step * i in + fill_rect (x+1) (y+1) (step-2) (step-2) + +type cell = Empty | Start | Target | Blocked +let color = function + | Start -> red + | Empty -> lightgray + | Blocked -> black + | Target -> blue +let rotate = function + | Start -> Start + | Empty -> Blocked + | Blocked -> Target + | Target -> Empty + +let grid = Array.make_matrix n m Empty +let draw_cell i j = draw i j (color grid.(i).(j)) +let redraw () = + for i = 0 to n-1 do for j = 0 to m-1 do draw_cell i j done done + +let show (i,j) = + draw i j magenta; + Unix.sleepf 0.01 + +module G = struct + module I = struct include Int let hash x = x end + include Imperative.Digraph.Concrete(Util.CMPProduct(I)(I)) + let fold_succ_e f g v acc = show v; fold_succ_e f g v acc + let success _ (i,j) = grid.(i).(j) = Target +end +module C = struct + include Int + type edge = G.E.t + let weight _e = 1 +end +module H = struct + let heuristic (si,sj) = + let h = ref (n*m) in + for i = 0 to n-1 do + for j = 0 to m-1 do + if grid.(i).(j) = Target then + h := min !h (abs (i - si) + abs (j - sj)) + done + done; + Format.eprintf "h(%d,%d) = %d@." si sj !h; + !h +end + +let g = G.create () +let add_succ (i,j as v) = + if G.mem_vertex g v then ( + for di = -1 to +1 do for dj = -1 to +1 do + if (di <> 0 || dj <> 0) && G.mem_vertex g (i+di,j+dj) then + G.add_edge g (i,j) (i+di,j+dj) + done done + ) +let () = + for i = 0 to n-1 do for j = 0 to m-1 do G.add_vertex g (i,j) done done; + for i = 0 to n-1 do for j = 0 to m-1 do add_succ (i,j) done done + +module Dfs = Search.DFS(G) +module Bfs = Search.BFS(G) +module Ids = Search.IDS(G) +module Dij = Search.Dijkstra(G)(C) +module Ast = Search.Astar(G)(C)(H) + +let set i j k = + grid.(i).(j) <- k; + draw_cell i j; + match k with + | Blocked -> G.remove_vertex g (i,j) + | _ -> G.add_vertex g (i,j); + add_succ (i-1,j); add_succ (i,j-1); add_succ (i,j) + +let () = set 0 0 Start +let () = set (n-1) (m-1) Target + +let run search = + (try let _ = search g (0,0) in () + with Not_found -> Format.eprintf "no solution@."); + ignore (read_key ()); + redraw () + +let () = + redraw (); + while true do + let st = wait_next_event [Button_down; Key_pressed] in + if st.keypressed then match st.key with + | 'q' -> close_graph (); exit 0 + | 'b' -> run Bfs.search + | 'd' -> run Dfs.search + | 'i' -> run Ids.search + | 'j' -> run Dij.search + | 'a' -> run Ast.search + | _ -> () + else if st.button then ( + let i = st.mouse_x / step in + let j = st.mouse_y / step in + set i j (rotate grid.(i).(j)) + ) + done diff --git a/src/search.ml b/src/search.ml index e63e236a..c33cf834 100644 --- a/src/search.ml +++ b/src/search.ml @@ -140,7 +140,7 @@ struct module Elt = struct type t = C.t * G.V.t * G.E.t list - let compare (w1,_v1,_) (w2,_v2,_) = C.compare w2 w1 + let compare (w1,_v1,_) (w2,_v2,_) = C.compare w2 w1 (* max heap! *) end module PQ = Heap.Imperative(Elt) @@ -179,7 +179,7 @@ module Astar(G: G)(C: Sig.WEIGHT with type edge = G.E.t) module Elt = struct type t = C.t * G.V.t * G.E.t list - let compare (h1,_,_) (h2,_,_) = C.compare h1 h2 + let compare (h1,_,_) (h2,_,_) = C.compare h2 h1 (* max heap! *) end module PQ = Heap.Imperative(Elt) From de59fed9c3da2f8b985ca1c1ad3e2054bc38d294 Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Mon, 4 Dec 2023 09:48:20 +0100 Subject: [PATCH 5/6] fixed example show_search --- examples/show_search.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/examples/show_search.ml b/examples/show_search.ml index 42465698..d4463aa4 100644 --- a/examples/show_search.ml +++ b/examples/show_search.ml @@ -67,7 +67,7 @@ let show (i,j) = module G = struct module I = struct include Int let hash x = x end - include Imperative.Digraph.Concrete(Util.CMPProduct(I)(I)) + include Imperative.Graph.Concrete(Util.CMPProduct(I)(I)) let fold_succ_e f g v acc = show v; fold_succ_e f g v acc let success _ (i,j) = grid.(i).(j) = Target end @@ -85,7 +85,7 @@ module H = struct h := min !h (abs (i - si) + abs (j - sj)) done done; - Format.eprintf "h(%d,%d) = %d@." si sj !h; + (* Format.eprintf "h(%d,%d) = %d@." si sj !h; *) !h end @@ -112,8 +112,7 @@ let set i j k = draw_cell i j; match k with | Blocked -> G.remove_vertex g (i,j) - | _ -> G.add_vertex g (i,j); - add_succ (i-1,j); add_succ (i,j-1); add_succ (i,j) + | _ -> G.add_vertex g (i,j); add_succ (i,j) let () = set 0 0 Start let () = set (n-1) (m-1) Target @@ -139,6 +138,6 @@ let () = else if st.button then ( let i = st.mouse_x / step in let j = st.mouse_y / step in - set i j (rotate grid.(i).(j)) + if i < n && j < m then set i j (rotate grid.(i).(j)) ) done From 1055b0b89b4f10e95421f76b065f0d6ccc8a81f3 Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Thu, 18 Jan 2024 14:49:21 +0100 Subject: [PATCH 6/6] cleaning up --- src/search.ml | 21 ++++++++++----------- src/search.mli | 28 +++++++++++++++++++--------- 2 files changed, 29 insertions(+), 20 deletions(-) diff --git a/src/search.ml b/src/search.ml index c33cf834..14401cc9 100644 --- a/src/search.ml +++ b/src/search.ml @@ -69,8 +69,8 @@ module DFS(G: G) = struct else dfs (G.fold_succ_e - (fun e stack -> (G.E.dst e, e :: path) :: stack) - g s stack) + (fun e stack -> (G.E.dst e, e :: path) :: stack) + g s stack) in dfs [start, []] @@ -108,16 +108,15 @@ module IDS(G: G) = struct let rec dfs = function | [] -> raise Not_found | (_, path, s) :: _ when G.success g s -> s, List.rev path - | (n, path, s) :: stack -> + | (n, path, s) :: stack when n < max -> dfs - (if n < max then - G.fold_succ_e - (fun e stack -> (n + 1, e :: path, G.E.dst e) :: stack) - g s stack - else ( - max_reached := true; - stack - )) in + (G.fold_succ_e + (fun e stack -> (n + 1, e :: path, G.E.dst e) :: stack) + g s stack) + | _ :: stack -> + max_reached := true; + dfs stack + in dfs [0, [], start] in let rec try_depth d = try diff --git a/src/search.mli b/src/search.mli index 9954fd03..987d591e 100644 --- a/src/search.mli +++ b/src/search.mli @@ -27,6 +27,13 @@ it fits in memory), as the graph is implicitely described some adjacency function ([fold_succ_e] below). The graph may even be infinite in some cases. + + See examples/show_search.ml for a small program to visualize + these search algorithms on a grid. + + In the following, when the complexity is given, V and E stand for + the numbers of reachable vertices and edges from the source + vertex. *) (** {2 Minimal graph signature} @@ -65,18 +72,20 @@ module DFS(G: G) : sig (for which [success] is true) and a path from [start] to [f]. If no solution exists, exception [Not_found] is raised when all - reachable vertices are visited. *) + reachable vertices are visited. + + Complexity: time and space O(E). Constant stack space. *) end (** Breadth-First Search A breadth-first search from the initial vertex guarantees a - path of minimal length, if any. + path of minimal length (in number of edges), if any. Caveat: Breadth-first search may require a lot of memory. If this is an issue, consider other implementations below, - such as Iterative Deepening Search. + such as Iterative Deepening DFS. *) module BFS(G: G) : sig @@ -87,7 +96,9 @@ module BFS(G: G) : sig (for which [success] is true) and a path from [start] to [f]. If no solution exists, exception [Not_found] is raised when all - reachable vertices are visited. *) + reachable vertices are visited. + + Complexity: time O(E) and space O(V). Constant stack space. *) end @@ -96,7 +107,7 @@ end An alternative to breadth-first search is to perform depth-first searches with a maximal depth, that is increased until we find a solution. In graphs that are tress, this can be asymptotically as - good as breadth-first search, but it uses much less memory. + good as breadth-first search, while using much less memory. Caveat: It runs forever if there is no successful path and reachable cycles. @@ -109,14 +120,13 @@ module IDS(G: G) : sig If a solution is found, it is returned as a final vertex [f] (for which [success] is true) and a path from [start] to [f]. - If no solution exists, exception [Not_found] is raised when all - reachable vertices are visited. + If no solution exists, and if no cycle is reachable, exception + [Not_found] is raised when all reachable vertices are visited. Note: This implementation is not tail recursive. It uses a stack space proportional to the length of the solution. This is usually not an issue, as a solution whose length would exhaust - the stack is likely to take too much time to be found. -*) + the stack is likely to take too much time to be found. *) end