diff --git a/CHANGES.md b/CHANGES.md index c579de20..88e0c9ad 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,6 @@ + - [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/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..d4463aa4 --- /dev/null +++ b/examples/show_search.ml @@ -0,0 +1,143 @@ + +(** 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.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 +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,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 + if i < n && j < m then set i j (rotate grid.(i).(j)) + ) + done 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..14401cc9 --- /dev/null +++ b/src/search.ml @@ -0,0 +1,209 @@ +(**************************************************************************) +(* *) +(* 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 T = Hashtbl.Make(G.V) + + let search g start = + 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 + | (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 T = Hashtbl.Make(G.V) + + let search g start = + let visited = T.create 128 in + let push path e next = + let v = G.E.dst e 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; + 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 + T.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 when n < max -> + dfs + (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 + 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 + +(** Graphs with cost *) + +module Dijkstra + (G: G) + (C: Sig.WEIGHT with type edge = G.E.t) = +struct + 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,_) = C.compare w2 w1 (* max heap! *) + end + module PQ = Heap.Imperative(Elt) + + let search g start = + 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 + if G.success g s then + s, List.rev path, d + else ( + if not (memo s) then + G.fold_succ_e (fun e () -> relax d path e) g s (); + loop () + ) in + 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 h2 h1 (* max heap! *) + 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 new file mode 100644 index 00000000..987d591e --- /dev/null +++ b/src/search.mli @@ -0,0 +1,188 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** {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. + + 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} + + 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 + ]} +*) +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. + + 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 (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 DFS. +*) + +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. + + Complexity: time O(E) and space O(V). Constant stack space. *) + +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, while using much less memory. + + Caveat: It runs forever if there is no successful path and + 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, 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. *) + +end + +(** {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 + (** [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 + +(** {2 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..fe9967ba --- /dev/null +++ b/tests/test_search.ml @@ -0,0 +1,174 @@ + +(* 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.DFS(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 + +(* 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 + | | ^ + 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) + +(* 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.@."