diff --git a/ligo.opam b/ligo.opam index f3815edc8..17160be27 100644 --- a/ligo.opam +++ b/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" } ] diff --git a/vendors/Red-Black_Trees/.PolyMapMain.tag b/vendors/Red-Black_Trees/.PolyMapMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Red-Black_Trees/.PolySetMain.tag b/vendors/Red-Black_Trees/.PolySetMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Red-Black_Trees/.RedBlackMain.tag b/vendors/Red-Black_Trees/.RedBlackMain.tag new file mode 100644 index 000000000..e69de29bb diff --git a/vendors/Red-Black_Trees/.gitignore b/vendors/Red-Black_Trees/.gitignore new file mode 100644 index 000000000..5ea62dee4 --- /dev/null +++ b/vendors/Red-Black_Trees/.gitignore @@ -0,0 +1 @@ +/RedBlackTrees.install diff --git a/vendors/Red-Black_Trees/.links b/vendors/Red-Black_Trees/.links new file mode 100644 index 000000000..b79d096bc --- /dev/null +++ b/vendors/Red-Black_Trees/.links @@ -0,0 +1 @@ +../OCaml-build/Makefile diff --git a/vendors/Red-Black_Trees/LICENSE b/vendors/Red-Black_Trees/LICENSE new file mode 100644 index 000000000..33a225af0 --- /dev/null +++ b/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. diff --git a/vendors/Red-Black_Trees/Makefile.cfg b/vendors/Red-Black_Trees/Makefile.cfg new file mode 100644 index 000000000..13c016eb6 --- /dev/null +++ b/vendors/Red-Black_Trees/Makefile.cfg @@ -0,0 +1,4 @@ +SHELL := dash +BFLAGS := -strict-sequence -w +A-48-4 +#OCAMLC := ocamlcp +#OCAMLOPT := ocamloptp diff --git a/vendors/Red-Black_Trees/PolyMap.ml b/vendors/Red-Black_Trees/PolyMap.ml new file mode 100644 index 000000000..ee485ec40 --- /dev/null +++ b/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 diff --git a/vendors/Red-Black_Trees/PolyMap.mli b/vendors/Red-Black_Trees/PolyMap.mli new file mode 100644 index 000000000..7aafb8ae0 --- /dev/null +++ b/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 diff --git a/vendors/Red-Black_Trees/PolyMapMain.ml b/vendors/Red-Black_Trees/PolyMapMain.ml new file mode 100644 index 000000000..929e3193d --- /dev/null +++ b/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%!" diff --git a/vendors/Red-Black_Trees/PolySet.ml b/vendors/Red-Black_Trees/PolySet.ml new file mode 100644 index 000000000..7e60fc3bd --- /dev/null +++ b/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 diff --git a/vendors/Red-Black_Trees/PolySet.mli b/vendors/Red-Black_Trees/PolySet.mli new file mode 100644 index 000000000..42f85a529 --- /dev/null +++ b/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 diff --git a/vendors/Red-Black_Trees/PolySetMain.ml b/vendors/Red-Black_Trees/PolySetMain.ml new file mode 100644 index 000000000..ade43d1d6 --- /dev/null +++ b/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%!" + diff --git a/vendors/Red-Black_Trees/README.md b/vendors/Red-Black_Trees/README.md new file mode 100644 index 000000000..c12ebace6 --- /dev/null +++ b/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). diff --git a/vendors/Red-Black_Trees/RedBlack.ml b/vendors/Red-Black_Trees/RedBlack.ml new file mode 100644 index 000000000..50bb9659f --- /dev/null +++ b/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 diff --git a/vendors/Red-Black_Trees/RedBlack.mli b/vendors/Red-Black_Trees/RedBlack.mli new file mode 100644 index 000000000..65a45230c --- /dev/null +++ b/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 diff --git a/vendors/Red-Black_Trees/RedBlackMain.ml b/vendors/Red-Black_Trees/RedBlackMain.ml new file mode 100644 index 000000000..9f607e71f --- /dev/null +++ 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 diff --git a/vendors/Red-Black_Trees/RedBlackTrees.ml b/vendors/Red-Black_Trees/RedBlackTrees.ml new file mode 100644 index 000000000..d2397f017 --- /dev/null +++ b/vendors/Red-Black_Trees/RedBlackTrees.ml @@ -0,0 +1,3 @@ +module PolyMap = PolyMap +module PolySet = PolySet +module RedBlack = RedBlack diff --git a/vendors/Red-Black_Trees/RedBlackTrees.opam b/vendors/Red-Black_Trees/RedBlackTrees.opam new file mode 100644 index 000000000..59648c973 --- /dev/null +++ b/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" +} diff --git a/vendors/Red-Black_Trees/URL b/vendors/Red-Black_Trees/URL new file mode 100644 index 000000000..f782590d9 --- /dev/null +++ b/vendors/Red-Black_Trees/URL @@ -0,0 +1 @@ +https://github.com/rinderknecht/Red-Black_Trees/commit/98b11312810d979ee1b0dacee6900228574e41e7 diff --git a/vendors/Red-Black_Trees/build.sh b/vendors/Red-Black_Trees/build.sh new file mode 100755 index 000000000..925ff7626 --- /dev/null +++ b/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 diff --git a/vendors/Red-Black_Trees/clean.sh b/vendors/Red-Black_Trees/clean.sh new file mode 100755 index 000000000..6373ab745 --- /dev/null +++ b/vendors/Red-Black_Trees/clean.sh @@ -0,0 +1,3 @@ +#!/bin/sh + +\rm -f *.cm* *.o *.byte *.opt diff --git a/vendors/Red-Black_Trees/dune b/vendors/Red-Black_Trees/dune new file mode 100644 index 000000000..bb831c2cf --- /dev/null +++ b/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 +) diff --git a/vendors/Red-Black_Trees/dune-project b/vendors/Red-Black_Trees/dune-project new file mode 100644 index 000000000..83dc4db1b --- /dev/null +++ b/vendors/Red-Black_Trees/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name RedBlackTrees) 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/UnionFind.opam b/vendors/UnionFind/UnionFind.opam index dc48cd6c1..59df8f647 100644 --- a/vendors/UnionFind/UnionFind.opam +++ b/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" ] 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/dune-project b/vendors/UnionFind/dune-project index 43a1282a9..45e423e15 100644 --- a/vendors/UnionFind/dune-project +++ b/vendors/UnionFind/dune-project @@ -1 +1,2 @@ -(lang dune 1.7) +(lang dune 1.11) +(name UnionFind) 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