Merge branch 'feature-poly-maps-and-set-and-unionfind' into 'dev'

Polymorfic maps, sets and Union-Find

See merge request ligolang/ligo!560

ligo.opam

@@ -23,6 +23,8 @@ depends: [
   "getopt"
   "terminal_size"
   "pprint"
+  "UnionFind"
+  "RedBlackTrees"
   # work around upstream in-place update
   "ocaml-migrate-parsetree" { = "1.4.0" }
 ]

vendors/Red-Black_Trees/.gitignore

@@ -0,0 +1 @@
+/RedBlackTrees.install

vendors/Red-Black_Trees/.links

@@ -0,0 +1 @@
+../OCaml-build/Makefile

vendors/Red-Black_Trees/LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2018 Christian Rinderknecht
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

vendors/Red-Black_Trees/Makefile.cfg

@@ -0,0 +1,4 @@
+SHELL := dash
+BFLAGS := -strict-sequence -w +A-48-4
+#OCAMLC := ocamlcp
+#OCAMLOPT := ocamloptp

vendors/Red-Black_Trees/PolyMap.ml

@@ -0,0 +1,37 @@
+(* Polymorphic maps *)
+
+module RB = RedBlack
+
+type ('key, 'value) t = {
+  tree : ('key * 'value) RB.t;
+  cmp  : 'key -> 'key -> int
+}
+
+type ('key, 'value) map = ('key, 'value) t
+
+let create ~cmp = {tree = RB.empty; cmp}
+
+let empty = {tree = RB.empty; cmp=Pervasives.compare}
+
+let is_empty map = RB.is_empty map.tree
+
+let add key value map =
+  let cmp (k1,_) (k2,_) = map.cmp k1 k2 in
+  {map with tree = RB.add ~cmp RB.New (key, value) map.tree}
+
+exception Not_found
+
+let find key map =
+  let cmp k1 (k2,_) = map.cmp k1 k2 in
+  try snd (RB.find ~cmp key map.tree) with
+    RB.Not_found -> raise Not_found
+
+let find_opt key map =
+  try Some (find key map) with Not_found -> None
+
+let bindings map =
+  RB.fold_dec (fun ~elt ~acc -> elt::acc) ~init:[] map.tree
+
+let iter f map = RB.iter (fun (k,v) -> f k v) map.tree
+
+let fold_inc f map = RB.fold_inc (fun ~elt:(k,v) -> f k v) map.tree

vendors/Red-Black_Trees/PolyMap.mli

@@ -0,0 +1,70 @@
+(* Polymorphic maps
+
+   This module does not provide a function to merge polymorphic
+   maps. Use the functorial interface of the module [Map] of the OCaml
+   standard library instead, at the cost of the polymorphism on the
+   keys.
+
+   No deletion is provided.
+*)
+
+type ('key, 'value) t
+type ('key, 'value) map = ('key, 'value) t
+
+(* The value of the call [create ~cmp] is an empty map with [cmp]
+   being the comparison over the (future) keys.
+
+   The value [empty] is identical to the value of the call [create
+   ~cmp:Pervasives.compare].
+*)
+
+val create : cmp:('key -> 'key -> int) -> ('key, 'value) t
+
+val empty : ('key, 'value) t
+
+(* Emptiness *)
+
+val is_empty : ('key, 'value) t -> bool
+
+(* The value of the call [add key value map] is a map containing all
+   the bindings of the map [map], extended by the binding of [key] to
+   [value]. If there is a binding for [key] in [map], its value is
+   lost (and replaced by [value]). *)
+
+val add : 'key -> 'value -> ('key, 'value) t -> ('key, 'value) t
+
+(* The value of the call [find key map] is the value associated to the
+   [key] in the map [map]. If [key] is not bound in [map], the
+   exception [Not_found] is raised. *)
+
+exception Not_found
+
+val find : 'key -> ('key, 'value) t -> 'value
+
+(* The value of the call [find_opt key map] is [Some value] if the key
+   [key] is bound to [value] in the map [map], and [None]
+   otherwise. *)
+
+val find_opt : 'key -> ('key, 'value) t -> 'value option
+
+(* The value of the call [bindings map] is the association list
+   containing the bindings of the map [map], sorted by increasing keys
+   (with respect to the total comparison function used to create the
+   map). *)
+
+val bindings : ('key, 'value) t -> ('key * 'value) list
+
+(* The side-effect of evaluating the call [iter f map] is the
+   successive side-effects of the calls [f key value], for all
+   bindings [(key, value)] belonging to the map [map], sorted in
+   increasing order of the keys (with respect to the total comparison
+   function used to create the map). *)
+
+val iter : ('key -> 'value -> unit) -> ('key, 'value) t -> unit
+
+(* The call [fold_inc f map ~init] computes [(f k_n v_n ~acc:(... (f
+   k_1 v_1 ~acc:init)...)], where [k_1], ..., [k_n] are the keys of
+   all bindings in the map [map] in increasing order, and [v_1], ...,
+   [v_n] are the associated values. *)
+
+val fold_inc : ('key -> 'value -> acc:'a -> 'a) -> ('key, 'value) t -> init:'a -> 'a

vendors/Red-Black_Trees/PolyMapMain.ml

@@ -0,0 +1,59 @@
+(* Unit testing of module [PolyMap] *)
+
+let () = Printf.printf "Testing polymorphic maps... "
+
+let cmp = Pervasives.compare
+
+let in_assoc =
+  ["c", 2;
+   "g", -1;
+   "a", 0;
+   "e", 4;
+   "f", 5;
+   "g", -1;
+   "b", -1;
+   "b", 1;
+   "d", 3;
+   "j", 9;
+   "g", 6;
+   "h", 7;
+   "i", 8]
+
+(* Insertion sort which keeps the last duplicate of any item.
+   WARNING: Quadratic cost! *)
+
+let rec ins cmp x = function
+         [] -> [x]
+| y::s as l ->
+    let diff = cmp x y in
+    if diff = 0 then l else if diff > 0 then y :: ins cmp x s else x::l
+
+let rec isort cmp = function
+    [] -> []
+| x::s -> ins cmp x (isort cmp s)
+
+
+let sorted_in_assoc = isort (fun (k1,_) (k2,_) -> cmp k1 k2) in_assoc
+
+(*
+let () = Printf.printf "\nInput map:\n"
+let () = List.iter (fun (k,v) -> Printf.printf "%s -> %d\n" k v) in_assoc
+let () = Printf.printf "\nSorted map:\n"
+let () = List.iter (fun (k,v) -> Printf.printf "%s -> %d\n" k v) sorted_in_assoc
+*)
+
+let empty_map = PolyMap.create ~cmp
+let out_map =
+  List.fold_left (fun m (k,v) -> PolyMap.add k v m) empty_map in_assoc
+
+let out_bindings = PolyMap.bindings out_map
+
+(*
+let () = Printf.printf "\nOutput map:\n"
+let () = List.iter (fun (k,v) -> Printf.printf "%s -> %d\n" k v) out_bindings
+*)
+
+let () =
+  if sorted_in_assoc = out_bindings then
+    Printf.printf "PASS.\n%!"
+  else Printf.printf "FAILED.\n%!"

vendors/Red-Black_Trees/PolySet.ml

@@ -0,0 +1,32 @@
+(* Polymorphic sets *)
+
+module RB = RedBlack
+
+type 'elt t = {
+  tree : 'elt RB.t;
+  cmp  : 'elt -> 'elt -> int
+}
+
+type 'elt set = 'elt t
+
+let create ~cmp = {tree = RB.empty; cmp}
+
+let empty = {tree = RB.empty; cmp=Pervasives.compare}
+
+let is_empty set = RB.is_empty set.tree
+
+let add elt set = {set with tree = RB.add ~cmp:set.cmp RB.New elt set.tree}
+
+exception Not_found
+
+let find elt set =
+  try RB.find ~cmp:set.cmp elt set.tree with
+    RB.Not_found -> raise Not_found
+
+let find_opt elt set = RB.find_opt ~cmp:set.cmp elt set.tree
+
+let elements set = RB.elements set.tree
+
+let iter f set = RB.iter f set.tree
+
+let fold_inc f set = RB.fold_inc (fun ~elt -> f elt) set.tree

vendors/Red-Black_Trees/PolySet.mli

@@ -0,0 +1,70 @@
+(* Polymorphic ordered sets
+
+   This module does not provide a function to merge polymorphic
+   sets. Use the functorial interface of the module [Set] of the OCaml
+   standard library instead.
+
+   No deletion is provided.
+*)
+
+type 'elt t
+type 'elt set = 'elt t
+
+(* The value of the call [create ~cmp] is an empty set with [cmp]
+   being the comparison over the (future) keys.
+
+   The value [empty] is identical to the value of the call [create
+   ~cmp:Pervasives.compare].
+ *)
+
+val create : cmp:('elt -> 'elt -> int) -> 'elt t
+
+val empty : 'elt t
+
+(* Emptiness *)
+
+val is_empty : 'elt t -> bool
+
+(* The value of the call [add elt set] is the union of the set [set]
+   and the singleton set containing [elt]. If there is an element [y]
+   in [set] such that [cmp y elt = true], where [cmp] is the
+   comparison function of the set [set] (see [create]), then [y] is
+   replaced by [elt]. *)
+
+val add : 'elt -> 'elt t -> 'elt t
+
+(* The value of the call [find elt set] is the element [y] of set
+   [set] such that [cmp y elt = true], where [cmp] is the comparison
+   function of [set] (see [create]). If [elt] is not in [set], then
+   the exception [Not_found] is raised. *)
+
+exception Not_found
+
+val find : 'elt -> 'elt t -> 'elt
+
+(* The call [find_opt elt set] is similar to [find elt set], except
+   that [None] is returned instead of the [Not_found] exception being
+   raised, otherwise it is an optional element. *)
+
+val find_opt : 'elt -> 'elt t -> 'elt option
+
+(* The value of the call [element set] is the list of elements of the
+   set [set] in increasing order (with respect to the total comparison
+   function used to create the set). *)
+
+val elements : 'elt t -> 'elt list
+
+(* The side-effect of evaluating the call [iter f set] is the
+   successive side-effects of the calls [f elt], for all the elements
+   [elt] of the set [set], sorted in increasing order (with respect to
+   the total comparison function used to create the set). *)
+
+val iter : ('elt -> unit) -> 'elt t -> unit
+
+(* The value of the call [fold_inc f set ~init] is the result of
+   iterating the function [f] on all the elements of the set [set] in
+   increasing order (with respect to the total comparison function
+   used to create the set), accumulating partial results from the
+   initial value [init]. *)
+
+val fold_inc : ('elt -> acc:'a -> 'a) -> 'elt t -> init:'a -> 'a

vendors/Red-Black_Trees/PolySetMain.ml

@@ -0,0 +1,34 @@
+(* Unit testing of module [PolySet] *)
+
+open PolySet;;
+
+let () = Printf.printf "Testing polymorphic sets... "
+
+let cmp = Pervasives.compare
+
+let in_items = [6;7;9;1;0;3;6;1;8;5;4;2]
+let sorted_in_items = List.sort_uniq cmp in_items
+
+(*
+let () = Printf.printf "\nInput items:  "
+let () = List.iter (fun x -> Printf.printf "%d " x) in_items
+let () = Printf.printf "\nSorted input: "
+let () = List.iter (fun x -> Printf.printf "%d " x) sorted_in_items
+*)
+
+let empty_set = create ~cmp
+
+let set = List.fold_right add in_items empty_set
+let out_items = elements set
+
+(*
+let () = Printf.printf "\nOutput items: "
+let () = List.iter (fun x -> Printf.printf "%d " x) out_items
+let () = Printf.printf "\n%!"
+*)
+
+let () =
+  if sorted_in_items = out_items then
+    Printf.printf "PASS.\n%!"
+  else Printf.printf "FAILED.\n%!"
+

vendors/Red-Black_Trees/README.md

@@ -0,0 +1,5 @@
+# Read-Black trees a la Okasaki and polymorphic sets and maps based on them
+
+This implementation is based on the classic paper by Chris Okasaki,
+*Red-Black Trees in a Functional Setting*. J. Funct. Program. 9(4):
+471-477 (1999).

vendors/Red-Black_Trees/RedBlack.ml

@@ -0,0 +1,86 @@
+(* Red-black trees according to the following classic paper:
+
+   Chris Okasaki, Red-Black Trees in a Functional
+   Setting. J. Funct. Program. 9(4): 471-477 (1999)
+*)
+
+type colour = Red | Black
+
+type 'a t =
+  Ext
+| Int of colour * 'a t * 'a * 'a t
+
+let empty = Ext
+
+let is_empty m = (m = empty)
+
+let blacken = function
+                         Ext -> Ext
+| Int (_, left, root, right) -> Int (Black, left, root, right)
+
+let balance colour left root right =
+  match colour, left, root, right with
+    Black, Int (Red, Int (Red, a, x, b), y, c), z, d
+  | Black, Int (Red, a, x, Int (Red, b, y, c)), z, d
+  | Black, a, x, Int (Red, Int (Red, b, y, c), z, d)
+  | Black, a, x, Int (Red, b, y, Int (Red, c, z, d)) ->
+      Int (Red, Int (Black, a, x, b), y, Int (Black, c, z, d))
+  | _ -> Int (colour, left, root, right)
+
+type choice = Old | New
+
+let choose ~old ~new' = function
+  Old -> old
+| New -> new'
+
+exception Physical_equality
+
+let add ~cmp choice elt tree =
+  let rec insert = function
+    Ext -> Int (Red, Ext, elt, Ext)  (* A leaf *)
+  | Int (colour, left, root, right) ->
+      let diff = cmp elt root in
+      if diff = 0 then
+        let root' = choose ~new':elt ~old:root choice
+        in if root == root' then raise Physical_equality
+           else Int (colour, left, root', right)
+      else if diff < 0 then
+             balance colour (insert left) root right
+           else balance colour left root (insert right)
+  in try blacken (insert tree) with
+       Physical_equality -> tree
+
+exception Not_found
+
+let rec find ~cmp elt = function
+  Ext -> raise Not_found
+| Int (_, left, root, right) ->
+    let diff = cmp elt root in
+    if diff = 0 then root
+    else if diff < 0 then find ~cmp elt left
+         else find ~cmp elt right
+
+let find_opt ~cmp elt tree =
+  try Some (find ~cmp elt tree) with Not_found -> None
+
+(* Inorder iterators *)
+
+let rec iter f = function
+                         Ext -> ()
+| Int (_, left, root, right) -> iter f left; f root; iter f right
+
+let rec inorder acc = function
+                         Ext -> acc
+| Int (_, left, root, right) -> inorder (root :: inorder acc right) left
+
+let elements t = inorder [] t
+
+let rec fold_inc f ~init = function
+                         Ext -> init
+| Int (_, left, root, right) ->
+    fold_inc f ~init:(f ~elt:root ~acc:(fold_inc f ~init left)) right
+
+let rec fold_dec f ~init = function
+                         Ext -> init
+| Int (_, left, root, right) ->
+    fold_dec f ~init:(f ~elt:root ~acc:(fold_dec f ~init right)) left

vendors/Red-Black_Trees/RedBlack.mli

@@ -0,0 +1,66 @@
+(* Red-black trees according to the following classic paper:
+
+   Chris Okasaki, Red-Black Trees in a Functional
+   Setting. J. Funct. Program. 9(4): 471-477 (1999)
+*)
+
+type colour = Red | Black
+
+type 'a t = private
+  Ext
+| Int of colour * 'a t * 'a * 'a t
+
+val empty: 'a t
+
+val is_empty: 'a t -> bool
+
+(* The value of the call [add ~cmp choice x t] is a red-black tree
+   augmenting the tree [t] with a node containing the element [x],
+   using the comparison function [cmp] (following the same convention
+   as [Pervasives.compare]) and, if a value [y] such that [x = y] is
+   already present in a node of [t], then the value [choice] denotes
+   whether [x] ([New]) or [y] ([Old]) remains in the value of the
+   call. Moreover, if [x == y], then [add ~cmp choice x t == t]. *)
+
+type choice = Old | New
+
+val add: cmp:('a -> 'a -> int) -> choice -> 'a -> 'a t -> 'a t
+
+(* The value of the call [find ~cmp x t] is the element [y] belonging
+   to a node of the tree [t], such that [cmp x y = true]. If none, the
+   exception [Not_found] is raised. *)
+
+exception Not_found
+
+val find: cmp:('a -> 'b -> int) -> 'a -> 'b t -> 'b
+
+(* The value of call [find_opt ~cmp x t] is [Some y] if there is an
+   element [y] in a node of the tree [t] such that [cmp x y = true],
+   and [None] otherwise. *)
+
+val find_opt: cmp:('a -> 'b -> int) -> 'a -> 'b t -> 'b option
+
+(* The value of the call [elements t] is the list of elements in the
+   nodes of the tree [t], sorted by increasing order. *)
+
+val elements: 'a t -> 'a list
+
+(* The side-effect of evaluating the call [iter f t] is the successive
+   side-effects of the calls [f x], for all elements [x] belonging to
+   the nodes of [t], visited in increasing order. *)
+
+val iter: ('a -> unit) -> 'a t -> unit
+
+(* The value of the call [fold_inc f ~init t] is the iteration of the
+   function [f] on increasing elements of the nodes of tree [t],
+   accumulating the partial results from the initial value of
+   [init]. *)
+
+val fold_inc: (elt:'a -> acc:'b -> 'b) -> init:'b -> 'a t -> 'b
+
+(* The value of the call [fold_dec f ~init t] is the iteration of the
+   function [f] on decreasing elements of the nodes of tree [t],
+   accumulating the partial results from the initial value of
+   [init]. *)
+
+val fold_dec: (elt:'a -> acc:'b -> 'b) -> init:'b -> 'a t -> 'b

vendors/Red-Black_Trees/RedBlackMain.ml

@@ -0,0 +1,88 @@
+(* Unit testing of module [RedBlack] *)
+
+open RedBlack;;
+
+let () = Printf.printf "Testing Red-black trees... "
+
+let cmp = Pervasives.compare
+
+let in_items = [6;7;9;1;0;3;6;1;8;5;4;2]
+let sorted_in_items = List.sort_uniq cmp in_items
+
+let () = Printf.printf "\nInput items:  "
+let () = List.iter (fun x -> Printf.printf "%d " x) in_items
+let () = Printf.printf "\nSorted input: "
+let () = List.iter (fun x -> Printf.printf "%d " x) sorted_in_items
+
+let t = List.fold_right (add ~cmp Old) in_items empty
+let out_items = elements t
+
+let () = Printf.printf "\nOutput items: "
+let () = List.iter (fun x -> Printf.printf "%d " x) out_items
+let () = Printf.printf "\n%!"
+
+let () =
+  if sorted_in_items = out_items then
+    Printf.printf "PASS.\n%!"
+  else Printf.printf "FAILED.\n%!"
+
+let rec draw ~pad:(pd,pc) = function
+  Ext -> ()
+| Int (colour, left, root, right) ->
+    let app i sub =
+      let pad =
+        (pc ^ (if i = 1 then "`-- " else "|-- "),
+         pc ^ (if i = 1 then "    " else "|   "))
+      in draw ~pad sub in
+    begin
+      Printf.printf "%s%s(%d)\n" pd (if colour = Red then "R" else "B") root;
+      List.iteri app [left; right]
+    end
+
+let () = draw ~pad:("","") t
+
+let rec to_string buffer ~pad:(pd,pc) = function
+  Ext -> ()
+| Int (colour, left, root, right) ->
+    let root_str =
+      Printf.sprintf "%s%s(%d)\n" pd
+        (if colour = Red then "R" else "B") root in
+    let app rank sub =
+      let pad =
+        (pc ^ (if rank = 1 then "`-- " else "|-- "),
+         pc ^ (if rank = 1 then "    " else "|   "))
+      in to_string buffer ~pad sub in
+    begin
+      Buffer.add_string buffer root_str;
+      List.iteri app [left; right]
+    end
+
+let to_string tree =
+  let buffer = Buffer.create 131 in
+  let     () = to_string buffer ~pad:("","") tree
+  in Buffer.contents buffer
+
+let () = to_string t |> print_string |> print_newline
+
+let rec pretty buffer ~pad:(pd,pc) = function
+  Ext -> Buffer.add_string buffer (pd ^ "Ext\n")
+| Int (colour, left, root, right) ->
+    let root_str =
+      Printf.sprintf "%sInt (%s,%d)\n" pd
+        (if colour = Red then "Red" else "Black") root in
+    let app rank sub =
+      let pad =
+        pc ^ (if rank = 0 then "|-- " else "`-- "),
+        pc ^ (if rank = 0 then "|   " else "    ")
+      in pretty buffer ~pad sub in
+    begin
+      Buffer.add_string buffer root_str;
+      List.iteri app [left; right]
+    end
+
+let pretty tree =
+  let buffer = Buffer.create 131 in
+  let     () = pretty buffer ~pad:("","") tree
+  in Buffer.contents buffer
+
+let () = pretty t |> print_string |> print_newline

vendors/Red-Black_Trees/RedBlackTrees.ml

@@ -0,0 +1,3 @@
+module PolyMap = PolyMap
+module PolySet = PolySet
+module RedBlack = RedBlack

vendors/Red-Black_Trees/RedBlackTrees.opam

@@ -0,0 +1,18 @@
+opam-version : "2.0"
+version      : "1.0"
+maintainer   : "rinderknecht@free.fr"
+authors      : [ "Christian Rinderknecht" ]
+homepage     : "https://gitlab.com/rinderknecht/Red-Black_Trees"
+bug-reports  : "https://gitlab.com/rinderknecht/Red-Black_Trees/issues"
+dev-repo     : "git+https://gitlab.com/rinderknecht/Red-Black_Trees.git"
+license      : "MIT"
+
+depends      : [ "dune" ]
+
+build        : [
+                [ "dune" "build" "-p" name "-j" jobs ]
+               ]
+
+url {
+  src: "https://gitlab.com/rinderknecht/Red-Black_Trees/-/archive/98b11312810d979ee1b0dacee6900228574e41e7/Red-Black_Trees.tar.gz"
+}

vendors/Red-Black_Trees/URL

@@ -0,0 +1 @@
+https://github.com/rinderknecht/Red-Black_Trees/commit/98b11312810d979ee1b0dacee6900228574e41e7

vendors/Red-Black_Trees/build.sh

@@ -0,0 +1,17 @@
+#!/bin/sh
+set -x
+ocamlfind ocamlc -strict-sequence -w +A-48-4 -c RedBlack.mli
+ocamlfind ocamlc -strict-sequence -w +A-48-4 -c PolyMap.mli
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c RedBlack.ml
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PolyMapMain.ml
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PolyMap.ml
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PolyMapMain.ml
+ocamlfind ocamlopt -o PolyMapMain.opt RedBlack.cmx PolyMap.cmx PolyMapMain.cmx
+ocamlfind ocamlc -strict-sequence -w +A-48-4 -c PolySet.mli
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PolySet.ml
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PolySetMain.ml
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c PolySetMain.ml
+ocamlfind ocamlopt -o PolySetMain.opt RedBlack.cmx PolySet.cmx PolySetMain.cmx
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c RedBlackMain.ml
+ocamlfind ocamlopt -strict-sequence -w +A-48-4 -c RedBlackMain.ml
+ocamlfind ocamlopt -o RedBlackMain.opt RedBlack.cmx RedBlackMain.cmx

vendors/Red-Black_Trees/clean.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+\rm -f *.cm* *.o *.byte *.opt

vendors/Red-Black_Trees/dune

@@ -0,0 +1,6 @@
+(library
+  (name RedBlackTrees)
+  (public_name RedBlackTrees)
+  (wrapped false)
+  (modules PolyMap PolySet RedBlack RedBlackTrees) ; PolyMapMain PolySetMain RedBlackMain
+)

vendors/Red-Black_Trees/dune-project

@@ -0,0 +1,2 @@
+(lang dune 1.11)
+(name RedBlackTrees)

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

vendors/UnionFind/UnionFind.opam

@@ -9,7 +9,7 @@ bug-reports  : "https://github.com/rinderknecht/UnionFind/issues"
 dev-repo     : "git+https://github.com/rinderknecht/UnionFind.git"
 license      : "MIT"
 
-depends      : [ "dune" ]
+depends      : [ "dune" "RedBlackTrees" ]
 
 build        : [
                 [ "sh" "-c" "printf 'let version = \"%s\"' \"$(git describe --always --dirty --abbrev=0)\" > Version.ml" ]

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

vendors/UnionFind/dune-project

@@ -1 +1,2 @@
-(lang dune 1.7)
+(lang dune 1.11)
+(name UnionFind)

vendors/UnionFind/unionFind.ml

@@ -1,2 +1,3 @@
 module Partition = Partition
 module Partition0 = Partition0
+module Poly2 = Poly2