From cfe1be2a5c91f9af1763e2547e90702be0dbae3e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Feb 2013 16:14:45 +0100 Subject: [PATCH] source code for containers --- src/cache.ml | 63 ++++++ src/cache.mli | 27 +++ src/containers.mllib | 5 + src/deque.ml | 75 ++++++++ src/deque.mli | 19 ++ src/flatHashtbl.ml | 218 +++++++++++++++++++++ src/flatHashtbl.mli | 61 ++++++ src/graph.ml | 447 +++++++++++++++++++++++++++++++++++++++++++ src/graph.mli | 140 ++++++++++++++ src/leftistheap.ml | 86 +++++++++ src/leftistheap.mli | 55 ++++++ src/vector.ml | 186 ++++++++++++++++++ src/vector.mli | 80 ++++++++ 13 files changed, 1462 insertions(+) create mode 100644 src/cache.ml create mode 100644 src/cache.mli create mode 100644 src/containers.mllib create mode 100644 src/deque.ml create mode 100644 src/deque.mli create mode 100644 src/flatHashtbl.ml create mode 100644 src/flatHashtbl.mli create mode 100644 src/graph.ml create mode 100644 src/graph.mli create mode 100644 src/leftistheap.ml create mode 100644 src/leftistheap.mli create mode 100644 src/vector.ml create mode 100644 src/vector.mli diff --git a/src/cache.ml b/src/cache.ml new file mode 100644 index 00000000..46b2b723 --- /dev/null +++ b/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 diff --git a/src/cache.mli b/src/cache.mli new file mode 100644 index 00000000..188ffe2f --- /dev/null +++ b/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 diff --git a/src/containers.mllib b/src/containers.mllib new file mode 100644 index 00000000..d0b89a18 --- /dev/null +++ b/src/containers.mllib @@ -0,0 +1,5 @@ +Vector +Deque +Graph +Cache +FlatHashtbl diff --git a/src/deque.ml b/src/deque.ml new file mode 100644 index 00000000..37631795 --- /dev/null +++ b/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 + diff --git a/src/deque.mli b/src/deque.mli new file mode 100644 index 00000000..53459eb5 --- /dev/null +++ b/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 diff --git a/src/flatHashtbl.ml b/src/flatHashtbl.ml new file mode 100644 index 00000000..4783b71e --- /dev/null +++ b/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 diff --git a/src/flatHashtbl.mli b/src/flatHashtbl.mli new file mode 100644 index 00000000..218020d1 --- /dev/null +++ b/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 diff --git a/src/graph.ml b/src/graph.ml new file mode 100644 index 00000000..0f274e98 --- /dev/null +++ b/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 "@[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 " @[%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 " @[%a [%a];@]@." pp_vertex v + (Sequence.pp_seq ~sep:"," print_attribute) (Sequence.of_list attributes)) + !vertices; + (* close *) + Format.fprintf formatter "}@]@;"; + () +end diff --git a/src/graph.mli b/src/graph.mli new file mode 100644 index 00000000..739cc240 --- /dev/null +++ b/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 diff --git a/src/leftistheap.ml b/src/leftistheap.ml new file mode 100644 index 00000000..3e315f1e --- /dev/null +++ b/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 + diff --git a/src/leftistheap.mli b/src/leftistheap.mli new file mode 100644 index 00000000..d6e854bb --- /dev/null +++ b/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 diff --git a/src/vector.ml b/src/vector.ml new file mode 100644 index 00000000..eb5fdcb2 --- /dev/null +++ b/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 diff --git a/src/vector.mli b/src/vector.mli new file mode 100644 index 00000000..111dacaf --- /dev/null +++ b/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 +