From 3171001395a5f1d87d7212451d42f6a328e5d3fe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 9 Apr 2020 14:28:04 +0200 Subject: [PATCH] Added a polymorphic version of one of the UnionFind implementations --- vendors/UnionFind/Poly2.ml | 131 +++++++++++++++++++++++++++++++++ vendors/UnionFind/dune | 3 +- vendors/UnionFind/unionFind.ml | 1 + 3 files changed, 134 insertions(+), 1 deletion(-) create mode 100644 vendors/UnionFind/Poly2.ml diff --git a/vendors/UnionFind/Poly2.ml b/vendors/UnionFind/Poly2.ml new file mode 100644 index 000000000..dd3660b14 --- /dev/null +++ b/vendors/UnionFind/Poly2.ml @@ -0,0 +1,131 @@ +(** Persistent implementation of the Union/Find algorithm with + height-balanced forests and no path compression. *) + +(* type item = Item.t *) + +let equal compare i j = compare i j = 0 + +type height = int + +(** Each equivalence class is implemented by a Catalan tree linked + upwardly and otherwise is a link to another node. Those trees + are height-balanced. The type [node] implements nodes in those + trees. *) +type 'item node = + Root of height +(** The value of [Root h] denotes the root of a tree, that is, + the representative of the associated class. The height [h] + is that of the tree, so a tree reduced to its root alone has + heigh 0. *) + +| Link of 'item * height +(** If not a root, a node is a link to another node. Because the + links are upward, that is, bottom-up, and we seek a purely + functional implementation, we need to uncouple the nodes and + the items here, so the first component of [Link] is an item, + not a node. That is why the type [node] is not recursive, + and called [node], not [tree]: to become a traversable tree, + it needs to be complemented by the type [partition] below to + associate items back to nodes. In order to follow a path + upward in the tree until the root, we start from a link node + giving us the next item, then find the node corresponding to + the item thanks to [partition], and again until we arrive at + the root. + + The height component is that of the source of the link, that + is, [h] is the height of the node linking to the node [Link + (j,h)], _not_ of [j], except when [equal i j]. *) + +(* module ItemMap = Map.Make (Item) *) + +type ('item, 'value) map = ('item, 'value) RedBlackTrees.PolyMap.t +let map_empty (compare : 'item -> 'item -> int) : ('item, 'value) map = RedBlackTrees.PolyMap.create ~cmp:compare +let map_find : 'item 'value . 'item -> ('item, 'value) map -> 'value = RedBlackTrees.PolyMap.find +let map_iter : 'item 'value . ('item -> 'value -> unit) -> ('item, 'value) map -> unit = RedBlackTrees.PolyMap.iter +let map_add : 'item 'value . 'item -> 'value -> ('item, 'value) map -> ('item, 'value) map = RedBlackTrees.PolyMap.add + +(** The type [partition] implements a partition of classes of + equivalent items by means of a map from items to nodes of type + [node] in trees. *) +type 'item partition = { + to_string : 'item -> string ; + compare : 'item -> 'item -> int ; + map : ('item, 'item node) map ; +} + +type 'item t = 'item partition + +let empty to_string compare = { to_string ; compare ; map = map_empty compare } + +let root : 'item * height -> 'item t -> 'item t = + fun (item, height) { to_string ; compare ; map } -> + { to_string ; compare ; map = map_add item (Root height) map } + +let link : 'item * height -> 'item -> 'item t -> 'item t + = fun (src, height) dst { to_string ; compare ; map } -> + { to_string ; compare ; map = map_add src (Link (dst, height)) map } + +let rec seek (i: 'item) (p: 'item partition) : 'item * height = + match map_find i p.map with + Root hi -> i,hi + | Link (j,_) -> seek j p + +let repr i p = fst (seek i p) + +let is_equiv (i: 'item) (j: 'item) (p: 'item partition) : bool = + try equal p.compare (repr i p) (repr j p) with + Not_found -> false + +let get_or_set (i: 'item) (p: 'item partition) = + try seek i p, p with + Not_found -> let n = i,0 in (n, root n p) + +let mem i p = try Some (repr i p) with Not_found -> None + +let repr i p = try repr i p with Not_found -> i + +let equiv (i: 'item) (j: 'item) (p: 'item partition) : 'item partition = + let (ri,hi as ni), p = get_or_set i p in + let (rj,hj as nj), p = get_or_set j p in + if equal p.compare ri rj + then p + else if hi > hj + then link nj ri p + else link ni rj (if hi < hj then p else root (rj, hj+1) p) + +(** The call [alias i j p] results in the same partition as [equiv + i j p], except that [i] is not the representative of its class + in [alias i j p] (whilst it may be in [equiv i j p]). + + This property is irrespective of the heights of the + representatives of [i] and [j], that is, of the trees + implementing their classes. If [i] is not a representative of + its class before calling [alias], then the height criteria is + applied (which, without the constraint above, would yield a + height-balanced new tree). *) +let alias (i: 'item) (j: 'item) (p: 'item partition) : 'item partition = + let (ri,hi as ni), p = get_or_set i p in + let (rj,hj as nj), p = get_or_set j p in + if equal p.compare ri rj + then p + else if hi = hj || equal p.compare ri i + then link ni rj @@ root (rj, max hj (hi+1)) p + else if hi < hj then link ni rj p + else link nj ri p + +(** {1 Printing} *) + +let print (p: 'item partition) = + let buffer = Buffer.create 80 in + let print i node = + let hi, hj, j = + match node with + Root hi -> hi,hi,i + | Link (j,hi) -> + match map_find j p.map with + Root hj | Link (_,hj) -> hi,hj,j in + let link = + Printf.sprintf "%s,%d -> %s,%d\n" + (p.to_string i) hi (p.to_string j) hj + in Buffer.add_string buffer link + in map_iter print p.map; buffer diff --git a/vendors/UnionFind/dune b/vendors/UnionFind/dune index cec9da6ac..4ba4f4b19 100644 --- a/vendors/UnionFind/dune +++ b/vendors/UnionFind/dune @@ -2,5 +2,6 @@ (name UnionFind) (public_name UnionFind) (wrapped true) - (modules Partition0 Partition1 Partition2 Partition3 Partition UnionFind) + (libraries RedBlackTrees) + (modules Partition0 Partition1 Partition2 Partition3 Partition UnionFind Poly2) (modules_without_implementation Partition)) diff --git a/vendors/UnionFind/unionFind.ml b/vendors/UnionFind/unionFind.ml index 17850f743..e87f01978 100644 --- a/vendors/UnionFind/unionFind.ml +++ b/vendors/UnionFind/unionFind.ml @@ -1,2 +1,3 @@ module Partition = Partition module Partition0 = Partition0 +module Poly2 = Poly2