new module Search for path search algorithms

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
 

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))

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, "<int> set width (default 20)";
+      "-m", Arg.Set_int m, "<int> 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

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

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
+