source code for containers

src/cache.ml

@@ -0,0 +1,63 @@
+(** an imperative cache for memoization of pairs *)
+
+module type S =
+  sig 
+    type key
+
+    type 'a t
+
+    (** create a cache with given size *)
+    val create : int -> (key -> key -> 'a) -> 'a t
+
+    (** find a value in the cache *)
+    val lookup : 'a t -> key -> key -> 'a
+
+    (** clear the cache from its content *)
+    val clear : 'a t -> unit
+  end
+
+module type CachedType =
+  sig
+    type t
+    val hash : t -> int
+    val equal : t -> t -> bool
+  end
+
+
+module Make(HType : CachedType) =
+  struct
+    type key = HType.t
+
+    (** A slot of the array contains a (key, value, true)
+        if key->value is stored there (at index hash(key) % length),
+        (null, null, false) otherwise.
+        
+        The first slot in the array contains the function
+        used to produce the value upon a cache miss. *)
+    type 'a t = (key * key * 'a * bool) array
+
+    let my_null = (Obj.magic None, Obj.magic None, Obj.magic None, false)
+
+    let set_fun c f = c.(0) <- Obj.magic f
+
+    let create size f =
+      let c = Array.create (size+1) my_null in
+      c.(0) <- Obj.magic f;
+      c
+
+    let lookup c k1 k2 =
+      let i = (((HType.hash k1 + 17) lxor HType.hash k2) mod (Array.length c -1)) + 1 in
+      match c.(i) with
+      | (_, _, _, false) ->
+        let v = ((Obj.magic c.(0)) : key -> key -> 'a) k1 k2 in
+        c.(i) <- (k1, k2, v, true); v
+      | (k1', k2', _, true) when not (HType.equal k1 k1') || not (HType.equal k2 k2')->
+        let v = ((Obj.magic c.(0)) : key -> key -> 'a) k1 k2 in
+        c.(i) <- (k1, k2, v, true); v
+      | (_, _, v, true) -> v
+
+    let clear c =
+      let f = c.(0) in
+      Array.iteri (fun i _ -> c.(i) <- my_null) c;
+      c.(0) <- f
+  end

src/cache.mli

@@ -0,0 +1,27 @@
+(** An imperative cache of fixed size for memoization of pairs *)
+
+module type S =
+  sig 
+    type key
+
+    type 'a t
+
+    (** create a cache with given size *)
+    val create : int -> (key -> key -> 'a) -> 'a t
+
+    (** find a value in the cache *)
+    val lookup : 'a t -> key -> key -> 'a
+
+    (** clear the cache from its content *)
+    val clear : 'a t -> unit
+  end
+
+module type CachedType =
+  sig
+    type t
+    val hash : t -> int
+    val equal : t -> t -> bool
+  end
+
+(** functorial implementation *)
+module Make(CType : CachedType) : S with type key = CType.t

src/containers.mllib

@@ -0,0 +1,5 @@
+Vector
+Deque
+Graph
+Cache
+FlatHashtbl

src/deque.ml

@@ -0,0 +1,75 @@
+(** Imperative deque *)
+
+type 'a elt = {
+  content : 'a;
+  mutable prev : 'a elt;
+  mutable next : 'a elt;
+}
+
+type 'a t = {
+  mutable first : 'a elt;
+  mutable length : int;
+}
+
+exception Empty
+
+let create () = {
+  first = Obj.magic None;
+  length = 0;
+}
+
+let is_empty d = d.length = 0
+
+let length d = d.length
+
+let mk_elt x =
+  let rec elt = {
+    content = x;
+    prev = elt;
+    next = elt;
+  } in elt
+
+let push_front d x =
+  let elt = mk_elt x in
+  (if d.length > 0
+    then begin 
+      d.first.prev <- elt;
+      let last = d.first.prev in
+      last.next <- elt;
+      elt.next <- d.first;
+      elt.prev <- last;
+    end);
+  d.first <- elt;
+  d.length <- d.length + 1
+
+let push_back d x =
+  let elt = mk_elt x in
+  (if d.length > 0
+    then begin 
+      let last = d.first.prev in
+      last.next <- elt;
+      d.first.prev <- elt;
+      elt.prev <- last;
+      elt.next <- d.first;
+    end else d.first <- elt);
+  d.length <- d.length + 1
+
+let take_back d =
+  (if d.length = 0 then raise Empty);
+  let elt = d.first.prev in
+  let new_last = elt.prev in
+  d.length <- d.length - 1;
+  new_last.next <- d.first;
+  d.first.next <- new_last;
+  elt.content
+
+let take_front d =
+  (if d.length = 0 then raise Empty);
+  let elt = d.first in
+  let new_first = elt.next in
+  d.length <- d.length - 1;
+  let last = d.first.prev in
+  new_first.prev <- last;
+  last.next <- new_first;
+  elt.content
+

src/deque.mli

@@ -0,0 +1,19 @@
+(** Imperative deque *)
+
+type 'a t
+
+exception Empty
+
+val create : unit -> 'a t
+
+val is_empty : 'a t -> bool
+
+val length : 'a t -> int
+
+val push_front : 'a t -> 'a -> unit
+
+val push_back : 'a t -> 'a -> unit
+
+val take_back : 'a t -> 'a
+
+val take_front : 'a t -> 'a

src/flatHashtbl.ml

@@ -0,0 +1,218 @@
+(** Open addressing hashtable, with linear probing. *)
+
+module type S =
+  sig
+    type key
+
+    type 'a t
+
+    val create : ?max_load:float -> int -> 'a t
+      (** Create a hashtable.  [max_load] is (number of items / size of table).
+          Must be in ]0, 1[ *)
+
+    val clear : 'a t -> unit
+      (** Clear the content of the hashtable *)
+
+    val find : 'a t -> key -> 'a
+      (** Find the value for this key, or raise Not_found *)
+
+    val replace : 'a t -> key -> 'a -> unit
+      (** Add/replace the binding for this key. O(1) amortized. *)
+
+    val remove : 'a t -> key -> unit
+      (** Remove the binding for this key, if any *)
+
+    val length : 'a t -> int
+      (** Number of bindings in the table *)
+
+    val mem : 'a t -> key -> bool
+      (** Is the key present in the hashtable? *)
+
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+      (** Iterate on bindings *)
+
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+      (** Fold on bindings *)
+
+    val stats : 'a t -> int * int * int * int * int * int
+      (** Cf Weak.S *)
+  end
+
+module Make(H : Hashtbl.HashedType) =
+  struct
+    type key = H.t
+
+    (** A hashtable is an array of (key, value) buckets that have a state, plus the
+        size of the table *)
+    type 'a t = {
+      mutable buckets : (key * 'a * state) array;
+      mutable size : int;
+      max_load : float;
+    }
+    (* state of a bucket *)
+    and state = Used | Empty | Deleted
+
+    let my_null = (Obj.magic None, Obj.magic None, Empty)
+    let my_deleted = (Obj.magic None, Obj.magic None, Deleted)
+
+    (** Create a table. Size will be >= 2 *)
+    let create ?(max_load=0.8) size =
+      let size = max 2 size in
+      { buckets = Array.make size my_null;
+        size = 0;
+        max_load; }
+
+    (** clear the table, by resetting all states to Empty *)
+    let clear t =
+      Array.fill t.buckets 0 (Array.length t.buckets) my_null;
+      t.size <- 0
+
+    (** Index of slot, for i-th probing starting from hash [h] in
+        a table of length [n] *)
+    let addr h n i = (h + i) mod n
+      
+    (** Insert (key -> value) in buckets, starting with the hash. *)
+    let insert buckets h key value =
+      let n = Array.length buckets in
+      (* lookup an empty slot to insert the key->value in. *)
+      let rec lookup h n i =
+        let j = addr h n i in
+        match buckets.(j) with
+        | (_, _, Empty) -> buckets.(j) <- (key, value, Used)
+        | (key', _, _) when H.equal key key' -> ()
+        | _ -> lookup h n (i+1)
+      in
+      lookup h n 0
+
+    (** Resize the array, by inserting its content into twice as large an array *)
+    let resize buckets =
+      let buckets' = Array.make (Array.length buckets * 2) my_null in
+      for i = 0 to Array.length buckets - 1 do
+        match buckets.(i) with
+        | (key, value, Used) ->
+          insert buckets' (H.hash key) key value  (* insert key -> value into new array *)
+        | _ -> ()
+      done;
+      buckets'
+
+    (** Lookup [key] in the table *)
+    let find t key =
+      let n = Array.length t.buckets in
+      let h = H.hash key in
+      let buckets = t.buckets in
+      let rec probe h n i num =
+        if num = n then raise Not_found
+        else
+        let j = addr h n i in
+        match buckets.(j) with
+        | (key', value, Used) when H.equal key key' ->
+          value  (* found value for this key *)
+        | (_, _, Deleted) | (_, _, Used) ->
+          probe h n (i+1) (num + 1) (* try next bucket *)
+        | (_, _, Empty) -> raise Not_found
+      in
+      probe h n 0 0
+
+    (** put [key] -> [value] in the hashtable *)
+    let replace t key value =
+      let load = float_of_int t.size /. float_of_int (Array.length t.buckets) in
+      (if load > t.max_load then t.buckets <- resize t.buckets);
+      let n = Array.length t.buckets in
+      let h = H.hash key in
+      let buckets = t.buckets in
+      let rec probe h n i =
+        let j = addr h n i in
+        match buckets.(j) with
+        | (key', _, Used) when H.equal key key' ->
+          buckets.(j) <- (key, value, Used)  (* replace value *)
+        | (_, _, Deleted) |(_, _, Empty) ->
+          buckets.(j) <- (key, value, Used);
+          t.size <- t.size + 1 (* insert and increment size *)
+        | (_, _, Used) ->
+          probe h n (i+1) (* go further *)
+      in
+      probe h n 0
+
+    (** alias for replace *)
+    let add t key value = replace t key value
+
+    (** Remove the key from the table *)
+    let remove t key =
+      let n = Array.length t.buckets in
+      let h = H.hash key in
+      let buckets = t.buckets in
+      let rec probe h n i =
+        let j = addr h n i in
+        match buckets.(j) with
+        | (key', _, Used) when H.equal key key' ->
+          buckets.(i) <- my_deleted; t.size <- t.size - 1  (* remove slot *)
+        | (_, _, Deleted) | (_, _, Used) ->
+          probe h n (i+1) (* search further *)
+        | (_, _, Empty) -> ()  (* not present *)
+      in
+      probe h n 0
+
+    (** size of the table *)
+    let length t = t.size
+
+    (** Is the key member of the table? *)
+    let mem t key =
+      try ignore (find t key); true
+      with Not_found -> false
+
+    (** Iterate on key -> value pairs *)
+    let iter k t =
+      let buckets = t.buckets in
+      for i = 0 to Array.length buckets - 1 do
+        match buckets.(i) with
+        | (key, value, Used) -> k key value
+        | _ -> ()
+      done
+
+    (** Fold on key -> value pairs *)
+    let fold f t acc =
+      let acc = ref acc in
+      let buckets = t.buckets in
+      for i = 0 to Array.length buckets - 1 do
+        match buckets.(i) with
+        | (key, value, Used) -> acc := f key value !acc
+        | _ -> ()
+      done;
+      !acc
+
+    (** Statistics on the table *)
+    let stats t = (Array.length t.buckets, t.size, t.size, 0, 0, 1)
+  end
+
+(** Hashconsed type *)
+module type HashconsedType =
+  sig
+    include Hashtbl.HashedType
+    val tag : int -> t -> t
+  end
+
+(** Create a hashconsing module *)
+module Hashcons(H : HashconsedType) =
+  struct
+    module Table = Make(H)
+
+    type t = H.t
+
+    let table = Table.create 5003
+
+    let count = ref 0
+
+    let hashcons x =
+      try Table.find table x
+      with Not_found ->
+        let x' = H.tag !count x in
+        incr count;
+        Table.replace table x' x';
+        x'
+
+    let iter k =
+      Table.iter (fun _ x -> k x) table
+
+    let stats () =
+      Table.stats table
+  end

src/flatHashtbl.mli

@@ -0,0 +1,61 @@
+(** Open addressing hashtable, with linear probing. *)
+
+module type S =
+  sig
+    type key
+
+    type 'a t
+
+    val create : ?max_load:float -> int -> 'a t
+      (** Create a hashtable.  [max_load] is (number of items / size of table).
+          Must be in ]0, 1[ *)
+
+    val clear : 'a t -> unit
+      (** Clear the content of the hashtable *)
+
+    val find : 'a t -> key -> 'a
+      (** Find the value for this key, or raise Not_found *)
+
+    val replace : 'a t -> key -> 'a -> unit
+      (** Add/replace the binding for this key. O(1) amortized. *)
+
+    val remove : 'a t -> key -> unit
+      (** Remove the binding for this key, if any *)
+
+    val length : 'a t -> int
+      (** Number of bindings in the table *)
+
+    val mem : 'a t -> key -> bool
+      (** Is the key present in the hashtable? *)
+
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+      (** Iterate on bindings *)
+
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+      (** Fold on bindings *)
+
+    val stats : 'a t -> int * int * int * int * int * int
+      (** Cf Weak.S *)
+  end
+
+(** Create a hashtable *)
+module Make(H : Hashtbl.HashedType) : S with type key = H.t
+
+(** Hashconsed type *)
+module type HashconsedType =
+  sig
+    include Hashtbl.HashedType
+    val tag : int -> t -> t
+  end
+
+(** Create a hashconsing module *)
+module Hashcons(H : HashconsedType) :
+  sig
+    type t = H.t
+
+    val hashcons : t -> t
+
+    val iter : (t -> unit) -> unit
+
+    val stats : unit -> int * int * int * int * int * int
+  end

src/graph.ml

@@ -0,0 +1,447 @@
+(** {1 A simple persistent directed graph.} *)
+
+module type S = sig
+  (** {2 Basics} *)
+
+  type vertex
+
+  module M : Map.S with type key = vertex
+  module S : Set.S with type elt = vertex
+
+  type 'e t
+    (** Graph parametrized by a type for edges *)
+
+  val empty : 'e t
+    (** Create an empty graph. *)
+
+  val is_empty : 'e t -> bool
+    (** Is the graph empty? *)
+
+  val length : 'e t -> int
+    (** Number of vertices *)
+
+  val add : 'e t -> vertex -> 'e -> vertex -> 'e t
+    (** Add an edge between two vertices *)
+
+  val add_seq : 'e t -> (vertex * 'e * vertex) Sequence.t -> 'e t
+    (** Add the vertices to the graph *)
+
+  val next : 'e t -> vertex -> ('e * vertex) Sequence.t
+    (** Outgoing edges *)
+
+  val prev : 'e t -> vertex -> ('e * vertex) Sequence.t
+    (** Incoming edges *)
+
+  val between : 'e t -> vertex -> vertex -> 'e Sequence.t
+
+  val iter_vertices : 'e t -> (vertex -> unit) -> unit
+  val vertices : 'e t -> vertex Sequence.t
+      (** Iterate on vertices *)
+
+  val iter : 'e t -> (vertex * 'e * vertex -> unit) -> unit 
+  val to_seq : 'e t -> (vertex * 'e * vertex) Sequence.t
+    (** Dump the graph as a sequence of vertices *)
+
+  (** {2 Global operations} *)
+
+  val roots : 'e t -> vertex Sequence.t
+    (** Roots, ie vertices with no incoming edges *)
+
+  val leaves : 'e t -> vertex Sequence.t
+    (** Leaves, ie vertices with no outgoing edges *)
+
+  val choose : 'e t -> vertex
+    (** Pick a vertex, or raise Not_found *)
+
+  val rev_edge : (vertex * 'e * vertex) -> (vertex * 'e * vertex)
+  val rev : 'e t -> 'e t
+    (** Reverse all edges *)
+
+  (** {2 Traversals} *)
+
+  val bfs : 'e t -> vertex -> (vertex -> unit) -> unit
+  val bfs_seq : 'e t -> vertex -> vertex Sequence.t
+    (** Breadth-first search, from given vertex *)
+
+  val dfs_full : 'e t ->
+                 ?labels:int M.t ref ->
+                 ?enter:((vertex * int) list -> unit) ->
+                 ?exit:((vertex * int) list -> unit) ->
+                 ?tree_edge:((vertex * 'e * vertex) -> unit) ->
+                 ?fwd_edge:((vertex * 'e * vertex) -> unit) ->
+                 ?back_edge:((vertex * 'e * vertex) -> unit) ->
+                 vertex -> 
+                 unit
+    (** DFS, with callbacks called on each encountered node and edge *)
+
+  val dfs : 'e t -> vertex -> ((vertex * int) -> unit) -> unit
+    (** Depth-first search, from given vertex. Each vertex is labelled
+        with its index in the traversal order. *)
+
+  val is_dag : 'e t -> bool
+    (** Is the graph acyclic? *)
+
+  (** {2 Path operations} *)
+
+  type 'e path = (vertex * 'e * vertex) list
+
+  val rev_path : 'e path -> 'e path
+    (** Reverse the path *)
+
+  val min_path_full : 'e t ->
+                 ?cost:(vertex -> 'e -> vertex -> int) ->
+                 ?ignore:(vertex -> bool) ->
+                 goal:(vertex -> 'e path -> bool) ->
+                 vertex ->
+                 vertex * int * 'e path
+    (** Find the minimal path, from the given [vertex], that does not contain
+        any vertex satisfying [ignore], and that reaches a vertex
+        that satisfies [goal]. It raises Not_found if no reachable node
+        satisfies [goal]. *)
+
+  val min_path : 'e t -> cost:('e -> int) -> vertex -> vertex -> 'e path
+    (** Minimal path from first vertex to second, given the cost function,
+        or raises Not_found *)
+
+  val diameter : 'e t -> vertex -> int
+    (** Maximal distance between the given vertex, and any other vertex
+        in the graph that is reachable from it. *)
+
+  (** {2 Print to DOT} *)
+
+  type attribute = [
+  | `Color of string
+  | `Shape of string
+  | `Weight of int
+  | `Style of string
+  | `Label of string
+  | `Other of string * string
+  ] (** Dot attribute *)
+
+  type 'e dot_printer
+    (** Helper to print a graph to DOT *)
+
+  val mk_dot_printer : 
+     print_edge:(vertex -> 'e -> vertex -> attribute list) ->
+     print_vertex:(vertex -> attribute list) ->
+     'e dot_printer
+    (** Create a Dot graph printer. Functions to convert edges and vertices
+        to Dot attributes must be provided. *)
+
+  val pp : 'e dot_printer -> ?vertices:S.t -> name:string ->
+            Format.formatter ->
+            (vertex * 'e * vertex) Sequence.t -> unit
+    (** Pretty print the graph in DOT, on given formatter. Using a sequence
+        allows to easily select which edges are important,
+        or to combine several graphs with [Sequence.append].
+        An optional set of additional vertices to print can be given. *)
+end
+
+module Make(V : Map.OrderedType) = struct
+  module M = Map.Make(V)
+  module S = Set.Make(V)
+
+  type vertex = V.t
+
+  type 'e t = 'e node M.t
+    (** Graph parametrized by a type for edges *)
+  and 'e node = {
+    n_vertex : vertex;
+    n_next : ('e * vertex) list;
+    n_prev : ('e * vertex) list;
+  } (** A node of the graph *)
+
+  let empty = M.empty
+
+  let is_empty graph = M.is_empty graph
+
+  let length graph = M.cardinal graph
+
+  let empty_node v = {
+    n_vertex = v;
+    n_next = [];
+    n_prev = [];
+  }
+
+  let add t v1 e v2 =
+    let n1 = try M.find v1 t with Not_found -> empty_node v1
+    and n2 = try M.find v2 t with Not_found -> empty_node v2 in
+    let n1 = { n1 with n_next = (e,v2) :: n1.n_next; }
+    and n2 = { n2 with n_prev = (e,v1) :: n2.n_prev; } in
+    M.add v1 n1 (M.add v2 n2 t)
+
+  let add_seq t seq = Sequence.fold (fun t (v1,e,v2) -> add t v1 e v2) t seq
+
+  let next t v = Sequence.of_list (M.find v t).n_next
+
+  let prev t v = Sequence.of_list (M.find v t).n_prev
+
+  let between t v1 v2 =
+    let edges = Sequence.of_list (M.find v1 t).n_prev in
+    let edges = Sequence.filter (fun (e, v2') -> V.compare v2 v2' = 0) edges in
+    Sequence.map fst edges
+
+  (** Call [k] on every vertex *)
+  let iter_vertices t k = M.iter (fun v _ -> k v) t
+
+  let vertices t = Sequence.from_iter (iter_vertices t)
+
+  (** Call [k] on every edge *)
+  let iter t k =
+    M.iter
+      (fun v1 node -> List.iter (fun (e, v2) -> k (v1, e, v2)) node.n_next)
+      t
+
+  let to_seq t = Sequence.from_iter (iter t)
+
+  (** {2 Global operations} *)
+
+  (** Roots, ie vertices with no incoming edges *)
+  let roots g =
+    let vertices = vertices g in
+    Sequence.filter (fun v -> Sequence.is_empty (prev g v)) vertices
+
+  (** Leaves, ie vertices with no outgoing edges *)
+  let leaves g =
+    let vertices = vertices g in
+    Sequence.filter (fun v -> Sequence.is_empty (next g v)) vertices
+
+  (** Pick a vertex, or raise Not_found *)
+  let choose g = fst (M.choose g)
+
+  let rev_edge (v,e,v') = (v',e,v)
+
+  (** Reverse all edges *)
+  let rev g =
+    M.map
+      (fun node -> {node with n_prev=node.n_next; n_next=node.n_prev})
+      g
+
+  (** {2 Traversals} *)
+
+  (** Breadth-first search *)
+  let bfs graph first k =
+    let q = Queue.create ()
+    and explored = ref (S.singleton first) in
+    Queue.push first q;
+    while not (Queue.is_empty q) do
+      let v = Queue.pop q in
+      (* yield current node *)
+      k v;
+      (* explore children *)
+      Sequence.iter
+        (fun (e, v') -> if not (S.mem v' !explored)
+          then (explored := S.add v' !explored; Queue.push v' q))
+        (next graph v)
+    done
+
+  let bfs_seq graph first = Sequence.from_iter (fun k -> bfs graph first k)
+
+  (** DFS, with callbacks called on each encountered node and edge *)
+  let dfs_full graph ?(labels=ref M.empty)
+  ?(enter=fun _ -> ()) ?(exit=fun _ -> ())
+  ?(tree_edge=fun _ -> ()) ?(fwd_edge=fun _ -> ()) ?(back_edge=fun _ -> ())
+  first
+  =
+    (* next free number for traversal *)
+    let count = ref (-1) in
+    M.iter (fun _ i -> count := max i !count) !labels;
+    (* explore the vertex. trail is the reverse path from v to first *)
+    let rec explore trail v =
+      if M.mem v !labels then () else begin
+        (* first time we explore this node! give it an index, put it in trail *)
+        let n = (incr count; !count) in
+        labels := M.add v n !labels;
+        let trail' = (v, n) :: trail in
+        (* enter the node *)
+        enter trail';
+        (* explore edges *)
+        Sequence.iter
+          (fun (e, v') ->
+            try let n' = M.find v' !labels in
+                if n' < n && List.exists (fun (_,n'') -> n' = n'') trail'
+                  then back_edge (v,e,v')  (* back edge, cycle *)
+                else
+                  fwd_edge (v,e,v')   (* forward or cross edge *)
+            with Not_found ->
+              tree_edge (v,e,v'); (* tree edge *)
+              explore trail' v')  (* explore the subnode *)
+          (next graph v);
+        (* exit the node *)
+        exit trail'
+      end
+    in
+    explore [] first
+
+  (** Depth-first search, from given vertex. Each vertex is labelled
+      with its index in the traversal order. *)
+  let dfs graph first k =
+    (* callback upon entering node *)
+    let enter = function
+    | [] -> assert false
+    | (v,n)::_ -> k (v,n)
+    in
+    dfs_full graph ~enter first
+
+  (** Is the graph acyclic? *)
+  let is_dag g =
+    if is_empty g then true
+    else if Sequence.is_empty (roots g) then false  (* DAGs have roots *)
+    else try
+      let labels = ref M.empty in
+      (* do a DFS from each root; any back edge indicates a cycle *)
+      Sequence.iter
+        (fun v ->
+          dfs_full g ~labels ~back_edge:(fun _ -> raise Exit) v)
+        (roots g);
+      true   (* complete traversal without back edge *)
+    with Exit ->
+      false  (* back edge detected! *)
+
+  (** {2 Path operations} *)
+
+  type 'e path = (vertex * 'e * vertex) list
+
+  (** Reverse the path *)
+  let rev_path p =
+    let rec rev acc p = match p with
+    | [] -> acc
+    | (v,e,v')::p' -> rev ((v',e,v)::acc) p'
+    in rev [] p
+
+  exception ExitBfs
+
+  (** Find the minimal path, from the given [vertex], that does not contain
+      any vertex satisfying [ignore], and that reaches a vertex
+      that satisfies [goal]. It raises Not_found if no reachable node
+      satisfies [goal]. *)
+  let min_path_full (type e) graph ?(cost=fun _ _ _ -> 1) ?(ignore=fun _ -> false) ~goal v =
+    let module HQ = Leftistheap.Make(struct
+      type t = vertex * int * e path
+      let le (_,i,_) (_,j,_) = i <= j
+    end) in
+    let q = ref HQ.empty in
+    let explored = ref S.empty in
+    q := HQ.insert (v, 0, []) !q;
+    let best_path = ref (v,0,[]) in
+    try
+      while not (HQ.is_empty !q) do
+        let (v, cost_v, path), q' = HQ.extract_min !q in
+        q := q';
+        if S.mem v !explored then ()  (* a shorter path is known *)
+        else if ignore v then ()      (* ignore the node. *)
+        else if goal v path           (* shortest path to goal node! *)
+          then (best_path := v, cost_v, path; raise ExitBfs)
+        else begin
+          explored := S.add v !explored;
+          (* explore successors *)
+          Sequence.iter
+            (fun (e, v') ->
+              if S.mem v' !explored || ignore v' then ()
+              else
+                let cost_v' = (cost v e v') + cost_v in
+                let path' = (v',e,v) :: path in
+                q := HQ.insert (v', cost_v', path') !q)
+            (next graph v)
+        end
+      done;
+      (* if a satisfying path was found, Exit would have been raised *)
+      raise Not_found
+    with ExitBfs -> (* found shortest satisfying path *)
+      !best_path
+
+  (** Minimal path from first vertex to second, given the cost function *)
+  let min_path graph ~cost v1 v2 =
+    let cost _ e _ = cost e in
+    let goal v' _ = V.compare v' v2 = 0 in
+    let _,_,path = min_path_full graph ~cost ~goal v1 in
+    path
+
+  (** Maximal distance between the given vertex, and any other vertex
+      in the graph that is reachable from it. *)
+  let diameter graph v =
+    let diameter = ref 0 in
+    (* no path is a goal, but we can use its length to update diameter *)
+    let goal _ path =
+      diameter := max !diameter (List.length path);
+      false
+    in
+    try ignore (min_path_full graph ~goal v); assert false
+    with Not_found ->
+      !diameter  (* explored every shortest path *)
+
+  (** {2 Print to DOT} *)
+
+  type attribute = [
+  | `Color of string
+  | `Shape of string
+  | `Weight of int
+  | `Style of string
+  | `Label of string
+  | `Other of string * string
+  ] (** Dot attribute *)
+
+  type 'e dot_printer = {
+    print_edge : vertex -> 'e -> vertex -> attribute list;
+    print_vertex : vertex -> attribute list;
+  } (** Dot printer for graphs of type ['e G.t] *)
+
+  (** Create a Dot graph printer. Functions to convert edges and vertices
+      to Dot attributes must be provided. *)
+  let mk_dot_printer ~print_edge ~print_vertex = {
+    print_vertex;
+    print_edge;
+  }
+
+  (** Pretty print the graph in DOT, on given formatter. Using a sequence
+      allows to easily select which edges are important,
+      or to combine several graphs with [Sequence.append]. *)
+  let pp printer ?(vertices=S.empty) ~name formatter edges =
+    (* map from vertices to integers *)
+    let get_id =
+      let count_map = ref M.empty
+      and count = ref 0 in
+      fun vertex ->
+        try M.find vertex !count_map
+        with Not_found ->
+          let n = !count in
+          incr count;
+          count_map := M.add vertex n !count_map;
+          n
+    (* accumulate vertices *)
+    and vertices = ref vertices
+    (* print an attribute *)
+    and print_attribute formatter attr =
+      match attr with
+      | `Color c -> Format.fprintf formatter "color=%s" c
+      | `Shape s -> Format.fprintf formatter "shape=%s" s
+      | `Weight w -> Format.fprintf formatter "weight=%d" w
+      | `Style s -> Format.fprintf formatter "style=%s" s
+      | `Label l -> Format.fprintf formatter "label=\"%s\"" l
+      | `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value
+    in
+    (* the name of a vertex *)
+    let pp_vertex formatter v = Format.fprintf formatter "vertex_%d" (get_id v) in
+    (* print preamble *)
+    Format.fprintf formatter "@[<v2>digraph %s {@;" name;
+    (* print edges *)
+    Sequence.iter
+      (fun (v1, e, v2) ->
+        (* add v1 and v2 to set of vertices *)
+        vertices := S.add v1 (S.add v2 !vertices);
+        let attributes = printer.print_edge v1 e v2 in
+        Format.fprintf formatter "  @[<h>%a -> %a [%a];@]@."
+          pp_vertex v1 pp_vertex v2
+          (Sequence.pp_seq ~sep:"," print_attribute) (Sequence.of_list attributes))
+      edges;
+    (* print vertices *)
+    S.iter
+      (fun v ->
+        let attributes = printer.print_vertex v in
+        Format.fprintf formatter "  @[<h>%a [%a];@]@." pp_vertex v
+          (Sequence.pp_seq ~sep:"," print_attribute) (Sequence.of_list attributes))
+      !vertices;
+    (* close *)
+    Format.fprintf formatter "}@]@;";
+    ()
+end

src/graph.mli

@@ -0,0 +1,140 @@
+(** {1 A simple persistent directed graph.} *)
+
+module type S = sig
+  (** {2 Basics} *)
+
+  type vertex
+
+  module M : Map.S with type key = vertex
+  module S : Set.S with type elt = vertex
+
+  type 'e t
+    (** Graph parametrized by a type for edges *)
+
+  val empty : 'e t
+    (** Create an empty graph. *)
+
+  val is_empty : 'e t -> bool
+    (** Is the graph empty? *)
+
+  val length : 'e t -> int
+    (** Number of vertices *)
+
+  val add : 'e t -> vertex -> 'e -> vertex -> 'e t
+    (** Add an edge between two vertices *)
+
+  val add_seq : 'e t -> (vertex * 'e * vertex) Sequence.t -> 'e t
+    (** Add the vertices to the graph *)
+
+  val next : 'e t -> vertex -> ('e * vertex) Sequence.t
+    (** Outgoing edges *)
+
+  val prev : 'e t -> vertex -> ('e * vertex) Sequence.t
+    (** Incoming edges *)
+
+  val between : 'e t -> vertex -> vertex -> 'e Sequence.t
+
+  val iter_vertices : 'e t -> (vertex -> unit) -> unit
+  val vertices : 'e t -> vertex Sequence.t
+      (** Iterate on vertices *)
+
+  val iter : 'e t -> (vertex * 'e * vertex -> unit) -> unit 
+  val to_seq : 'e t -> (vertex * 'e * vertex) Sequence.t
+    (** Dump the graph as a sequence of vertices *)
+
+  (** {2 Global operations} *)
+
+  val roots : 'e t -> vertex Sequence.t
+    (** Roots, ie vertices with no incoming edges *)
+
+  val leaves : 'e t -> vertex Sequence.t
+    (** Leaves, ie vertices with no outgoing edges *)
+
+  val choose : 'e t -> vertex
+    (** Pick a vertex, or raise Not_found *)
+
+  val rev_edge : (vertex * 'e * vertex) -> (vertex * 'e * vertex)
+  val rev : 'e t -> 'e t
+    (** Reverse all edges *)
+
+  (** {2 Traversals} *)
+
+  val bfs : 'e t -> vertex -> (vertex -> unit) -> unit
+  val bfs_seq : 'e t -> vertex -> vertex Sequence.t
+    (** Breadth-first search, from given vertex *)
+
+  val dfs_full : 'e t ->
+                 ?labels:int M.t ref ->
+                 ?enter:((vertex * int) list -> unit) ->
+                 ?exit:((vertex * int) list -> unit) ->
+                 ?tree_edge:((vertex * 'e * vertex) -> unit) ->
+                 ?fwd_edge:((vertex * 'e * vertex) -> unit) ->
+                 ?back_edge:((vertex * 'e * vertex) -> unit) ->
+                 vertex -> 
+                 unit
+    (** DFS, with callbacks called on each encountered node and edge *)
+
+  val dfs : 'e t -> vertex -> ((vertex * int) -> unit) -> unit
+    (** Depth-first search, from given vertex. Each vertex is labelled
+        with its index in the traversal order. *)
+
+  val is_dag : 'e t -> bool
+    (** Is the graph acyclic? *)
+
+  (** {2 Path operations} *)
+
+  type 'e path = (vertex * 'e * vertex) list
+
+  val rev_path : 'e path -> 'e path
+    (** Reverse the path *)
+
+  val min_path_full : 'e t ->
+                 ?cost:(vertex -> 'e -> vertex -> int) ->
+                 ?ignore:(vertex -> bool) ->
+                 goal:(vertex -> 'e path -> bool) ->
+                 vertex ->
+                 vertex * int * 'e path
+    (** Find the minimal path, from the given [vertex], that does not contain
+        any vertex satisfying [ignore], and that reaches a vertex
+        that satisfies [goal]. It raises Not_found if no reachable node
+        satisfies [goal]. *)
+
+  val min_path : 'e t -> cost:('e -> int) -> vertex -> vertex -> 'e path
+    (** Minimal path from first vertex to second, given the cost function,
+        or raises Not_found *)
+
+  val diameter : 'e t -> vertex -> int
+    (** Maximal distance between the given vertex, and any other vertex
+        in the graph that is reachable from it. *)
+
+  (** {2 Print to DOT} *)
+
+  type attribute = [
+  | `Color of string
+  | `Shape of string
+  | `Weight of int
+  | `Style of string
+  | `Label of string
+  | `Other of string * string
+  ] (** Dot attribute *)
+
+  type 'e dot_printer
+    (** Helper to print a graph to DOT *)
+
+  val mk_dot_printer : 
+     print_edge:(vertex -> 'e -> vertex -> attribute list) ->
+     print_vertex:(vertex -> attribute list) ->
+     'e dot_printer
+    (** Create a Dot graph printer. Functions to convert edges and vertices
+        to Dot attributes must be provided. *)
+
+  val pp : 'e dot_printer -> ?vertices:S.t -> name:string ->
+            Format.formatter ->
+            (vertex * 'e * vertex) Sequence.t -> unit
+    (** Pretty print the graph in DOT, on given formatter. Using a sequence
+        allows to easily select which edges are important,
+        or to combine several graphs with [Sequence.append].
+        An optional set of additional vertices to print can be given. *)
+end
+
+module Make(V : Map.OrderedType) : S with type vertex = V.t

src/leftistheap.ml

@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Copyright (C) Jean-Christophe Filliatre                               *)
+(*                                                                        *)
+(*  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.                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Leftist heaps.
+
+   See for instance Chris Okasaki's "Purely Functional Data Structures". *)
+
+exception Empty
+
+(* -----------------------------------------------------------------------------
+  functor interface
+ ----------------------------------------------------------------------------- *)
+
+module type Ordered = sig
+  type t
+  val le: t -> t -> bool
+end
+
+module Make(X : Ordered) :
+sig
+  type t
+  val empty : t
+  val is_empty : t -> bool
+  val insert : X.t -> t -> t
+  val min : t -> X.t
+  val extract_min : t -> X.t * t
+  val merge : t -> t -> t
+  val filter: t -> (X.t -> bool) -> t
+  val remove: t -> X.t list -> t
+end
+=
+struct
+
+  type t = E | T of int * X.t * t * t
+
+  let rank = function E -> 0 | T (r,_,_,_) -> r
+
+  let make x a b =
+    let ra = rank a and rb = rank b in
+    if ra >= rb then T (rb + 1, x, a, b) else T (ra + 1, x, b, a)
+
+  let empty = E
+
+  let is_empty = function E -> true | T _ -> false
+
+  let rec merge h1 h2 = match h1,h2 with
+    | E, h | h, E ->
+	h
+    | T (_,x,a1,b1), T (_,y,a2,b2) ->
+	if X.le x y then make x a1 (merge b1 h2) else make y a2 (merge h1 b2)
+
+  let insert x h = merge (T (1, x, E, E)) h
+
+  let min = function E -> raise Empty | T (_,x,_,_) -> x
+
+  let extract_min = function
+    | E -> raise Empty
+    | T (_,x,a,b) -> x, merge a b
+
+  let rec filter t pred = match t with
+    | E -> E
+    | T (_, x, a, b) when pred x -> insert x (merge (filter a pred) (filter b pred))
+    | T (_, _, a, b) -> merge (filter a pred) (filter b pred)
+
+  let rec remove t l = match t with
+    | E -> E
+    | T (_,x,a,b) when List.exists (fun y -> X.le x y && X.le y x) l ->
+      (* eliminate x, it is in the list if X.le is a total order *)
+      merge (remove a l) (remove b l)
+    | T (_,x,a,b) ->
+      make x (remove a l) (remove b l)
+
+end
+

src/leftistheap.mli

@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Copyright (C) Jean-Christophe Filliatre                               *)
+(*                                                                        *)
+(*  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.                  *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Leftist heaps *)
+
+(* -----------------------------------------------------------------------------
+  functor interface
+ ----------------------------------------------------------------------------- *)
+
+module type Ordered = sig
+  type t
+  val le: t -> t -> bool
+end
+
+exception Empty
+
+module Make(X: Ordered) :
+sig
+  type t
+
+  val empty: t
+
+  val is_empty: t -> bool
+    (* runs in O(1) *)
+
+  val insert: X.t -> t -> t
+    (* runs in O(log n) *)
+
+  val min: t -> X.t
+    (* runs in O(1) *)
+
+  val extract_min: t -> X.t * t
+    (* runs in O(log n) *)
+
+  val merge: t -> t -> t
+    (* runs in O(log max(n1, n2)) *)
+
+  val filter: t -> (X.t -> bool) -> t
+    (* O(n ln(N))? keep only the elements that satisfy the predicate *)
+
+  val remove: t -> X.t list -> t
+    (* runs in O(n), removing all elements in the list (assuming X.le is total) *)
+end

src/vector.ml

@@ -0,0 +1,186 @@
+(** Growable, mutable vector *)
+
+(** a vector of 'a. *)
+type 'a t = {
+  mutable size : int;
+  mutable capacity : int;
+  mutable vec : 'a array;
+}
+
+let create i =
+  assert (i >= 0);
+  { size = 0;
+    capacity = i;
+    vec = if i = 0 then [||] else Array.create i (Obj.magic None);
+  }
+
+(** resize the underlying array so that it can contains the
+    given number of elements *)
+let resize v newcapacity =
+  if newcapacity <= v.capacity
+    then ()  (* already big enough *)
+    else begin
+      assert (newcapacity >= v.size);
+      let new_vec = Array.create newcapacity (Obj.magic None) in
+      Array.blit v.vec 0 new_vec 0 v.size;
+      v.vec <- new_vec;
+      v.capacity <- newcapacity
+    end
+
+let clear v =
+  v.size <- 0;
+  if v.capacity > 1000  (* shrink if too large *)
+    then (v.capacity <- 10;
+          v.vec <- Array.create 10 (Obj.magic None))
+
+let is_empty v = v.size = 0
+
+let push v x =
+  (if v.capacity = v.size
+    then resize v (2 * v.capacity));
+  v.vec.(v.size) <- x;
+  v.size <- v.size + 1
+
+(** add all elements of b to a *)
+let append a b =
+  resize a (a.size + b.size);
+  Array.blit b.vec 0 a.vec a.size b.size;
+  a.size <- a.size + b.size
+
+let append_array a b =
+  resize a (a.size + Array.length b);
+  Array.blit b 0 a.vec a.size (Array.length b);
+  a.size <- a.size + Array.length b
+
+let pop v =
+  (if v.size = 0 then failwith "Vector.pop on empty vector");
+  v.size <- v.size - 1;
+  let x = v.vec.(v.size) in
+  x
+
+let copy v =
+  let v' = create v.size in
+  Array.blit v.vec 0 v'.vec 0 v.size;
+  v'.size <- v.size;
+  v'
+
+let shrink v n =
+  if n > v.size then failwith "cannot shrink to bigger size" else v.size <- n
+
+let member ?(cmp=(=)) v x =
+  let n = v.size in
+  let rec check i =
+    if i = n then false
+    else if cmp x v.vec.(i) then true
+    else check (i+1)
+  in check 0
+
+let sort ?(cmp=compare) v =
+  (* copy array (to avoid junk in it), then sort the array *)
+  let a = Array.sub v.vec 0 v.size in
+  Array.fast_sort cmp a;
+  v.vec <- a
+
+let uniq_sort ?(cmp=compare) v =
+  sort ~cmp v;
+  let n = v.size in
+  (* traverse to remove duplicates. i= current index,
+     j=current append index, j<=i. new_size is the size
+     the vector will have after removing duplicates. *)
+  let rec traverse prev i j =
+    if i >= n then () (* done traversing *)
+    else if cmp prev v.vec.(i) = 0
+      then (v.size <- v.size - 1; traverse prev (i+1) j) (* duplicate, remove it *)
+      else (v.vec.(j) <- v.vec.(i); traverse v.vec.(i) (i+1) (j+1)) (* keep it *)
+  in
+  if v.size > 0
+    then traverse v.vec.(0) 1 1 (* start at 1, to get the first element in hand *)
+
+let iter v k =
+  for i = 0 to v.size -1 do
+    k v.vec.(i)
+  done
+
+let iteri v k =
+  for i = 0 to v.size -1 do
+    k i v.vec.(i)
+  done
+
+let map v f =
+  let v' = create v.size in
+  for i = 0 to v.size - 1 do
+    push v' (f v.vec.(i));
+  done;
+  v'
+
+let filter v f =
+  let v' = create v.size in
+  for i = 0 to v.size - 1 do
+    if f v.vec.(i) then push v' v.vec.(i);
+  done;
+  v'
+
+let fold v acc f =
+  let acc = ref acc in
+  for i = 0 to v.size - 1 do
+    acc := f !acc v.vec.(i);
+  done;
+  !acc
+
+let exists v p =
+  let n = v.size in
+  let rec check i =
+    if i = n then false
+    else if p v.vec.(i) then true
+    else check (i+1)
+  in check 0
+
+let for_all v p =
+  let n = v.size in
+  let rec check i =
+    if i = n then true
+    else if not (p v.vec.(i)) then false
+    else check (i+1)
+  in check 0
+
+let find v p =
+  let n = v.size in
+  let rec check i =
+    if i = n then raise Not_found
+    else if p v.vec.(i) then v.vec.(i)
+    else check (i+1)
+  in check 0
+
+let get v i =
+  (if i < 0 || i >= v.size then failwith "wrong index for vector");
+  v.vec.(i)
+
+let set v i x =
+  (if i < 0 || i >= v.size then failwith "wrong index for vector");
+  v.vec.(i) <- x
+
+let size v = v.size
+
+let from_array a =
+  let c = Array.length a in
+  let v = create c in
+  Array.blit a 0 v.vec 0 c;
+  v.size <- c;
+  v
+
+let from_list l =
+  let v = create 10 in
+  List.iter (push v) l;
+  v
+
+let to_array v =
+  Array.sub v.vec 0 v.size
+
+let get_array v = v.vec
+
+let to_list v =
+  let l = ref [] in
+  for i = 0 to v.size - 1 do
+    l := get v i :: !l;
+  done;
+  List.rev !l

src/vector.mli

@@ -0,0 +1,80 @@
+(** Growable, mutable vector *)
+
+type 'a t
+  (** the type of a vector of 'a *)
+
+val create : int -> 'a t
+  (** create a vector of given initial capacity *)
+
+val clear : 'a t -> unit
+  (** clear the content of the vector *)
+
+val is_empty : 'a t -> bool
+  (** is the vector empty? *)
+
+val push : 'a t -> 'a -> unit
+  (** add an element at the end of the vector *)
+
+val append : 'a t -> 'a t -> unit
+  (** [append a b] adds all elements of b to a *)
+
+val append_array : 'a t -> 'a array -> unit
+  (** same as append, with an array *)
+
+val pop : 'a t -> 'a
+  (** remove last element, or raise a Failure if empty *)
+
+val copy : 'a t -> 'a t
+  (** shallow copy *)
+
+val shrink : 'a t -> int -> unit
+  (** shrink to the given size (remove elements above this size) *)
+
+val member : ?cmp:('a -> 'a -> bool) -> 'a t -> 'a -> bool
+  (** is the element a member of the vector? *)
+
+val sort : ?cmp:('a -> 'a -> int) -> 'a t -> unit
+  (** sort the array in place*)
+
+val uniq_sort : ?cmp:('a -> 'a -> int) -> 'a t -> unit
+  (** sort the array and remove duplicates in place*)
+
+val iter : 'a t -> ('a -> unit) -> unit
+  (** iterate on the vector *)
+
+val iteri : 'a t -> (int -> 'a -> unit) -> unit
+  (** iterate on the vector with indexes *)
+
+val map : 'a t -> ('a -> 'b) -> 'b t
+  (** map elements of the vector *)
+
+val filter : 'a t -> ('a -> bool) -> 'a t
+  (** filter elements from vector *)
+
+val fold : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b
+  (** fold on elements of the vector *)
+
+val exists : 'a t -> ('a -> bool) -> bool
+  (** existential test *)
+
+val for_all : 'a t -> ('a -> bool) -> bool
+  (** universal test *)
+
+val find : 'a t -> ('a -> bool) -> 'a
+  (** find an element that satisfies the predicate, or Not_found *)
+
+val get : 'a t -> int -> 'a
+  (** access element, or Failure if bad index *)
+
+val set : 'a t -> int -> 'a -> unit
+  (** access element, or Failure if bad index *)
+
+val size : 'a t -> int
+  (** number of elements in vector *)
+
+val from_array : 'a array -> 'a t
+val from_list : 'a list -> 'a t
+val to_array : 'a t -> 'a array
+val get_array : 'a t -> 'a array  (*  get underlying *shared* array *)
+val to_list : 'a t -> 'a list
+