Merge branch 'feature/update-union-find' into 'dev'

Update union find

See merge request ligolang/ligo!307

src/passes/4-typer-new/dune

@@ -7,7 +7,7 @@
     ast_simplified
     ast_typed
     operators
-    union_find
+    UnionFind
   )
   (preprocess
     (pps ppx_let)

src/passes/4-typer-new/solver.ml

@@ -355,7 +355,7 @@ struct
 
 end
 
-module UF = Union_find.Partition0.Make(TypeVariable)
+module UF = UnionFind.Partition0.Make(TypeVariable)
 
 type unionfind = UF.t
 

src/union_find/Partition3.ml

@@ -1,86 +0,0 @@
-(* Destructive implementation of union/find with height-balanced
-   forests but without path compression: O(n*log(n)). *)
-
-module Make (Item: Partition.Item) =
-  struct
-
-    type item = Item.t
-    type repr = item   (** Class representatives *)
-
-    let equal i j = Item.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 node = {item: item; mutable height: int; mutable parent: node}
-
-    module ItemMap = Map.Make (Item)
-
-    (** 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 partition = node ItemMap.t
-
-    type t = partition
-
-    let empty = ItemMap.empty
-
-    (** The function [repr] is faster than a persistent implementation
-        in the worst case because, in the latter case, the cost is O(log n)
-        for accessing each node in the path to the root, whereas, in the
-        former, only the access to the first node in the path incurs a cost
-        of O(log n) -- the other nodes are accessed in constant time by
-        following the [next] field of type [node]. *)
-   let seek (i: item) (p: partition) : node =
-     let rec find_root node =
-       if node.parent == node then node else find_root node.parent
-     in find_root (ItemMap.find i p)
-
-   let repr item partition = (seek item partition).item
-
-   let is_equiv (i: item) (j: item) (p: partition) =
-     equal (repr i p) (repr j p)
-
-   let get_or_set item (p: partition) =
-     try seek item p, p with
-       Not_found -> let rec loop = {item; height=0; parent=loop}
-                    in loop, ItemMap.add item loop p
-
-   let link src dst = src.parent <- dst
-
-   let equiv (i: item) (j: item) (p: partition) : partition =
-     let ni,p  = get_or_set i p in
-     let nj,p  = get_or_set j p in
-     let hi,hj = ni.height, nj.height in
-     let () =
-       if   not (equal ni.item nj.item)
-       then if   hi > hj
-            then link nj ni
-            else (link ni nj; nj.height <- max hj (hi+1))
-     in p
-
-   let alias (i: item) (j: item) (p: partition) : partition =
-     let ni,p  = get_or_set i p in
-     let nj,p  = get_or_set j p in
-     let hi,hj = ni.height, nj.height in
-     let () =
-      if   not (equal ni.item nj.item)
-      then if   hi = hj || equal ni.item i
-           then (link ni nj; nj.height <- max hj (hi+1))
-           else if hi < hj then link ni nj
-                           else link nj ni
-     in p
-
-   (* Printing *)
-
-    let print p =
-      let print _ node =
-        Printf.printf "%s,%d -> %s,%d\n"
-          (Item.to_string node.item) node.height
-          (Item.to_string node.parent.item) node.parent.height
-      in ItemMap.iter print p
-
-  end

src/union_find/dune

@@ -1,17 +0,0 @@
-(library
-  (name union_find)
-  (public_name ligo.union_find)
-  (wrapped false) ;; TODO: do we need this?
-  (modules Partition0 Partition1 Partition2 Partition3 Partition Union_find)
-  (modules_without_implementation Partition)
-;;   (preprocess
-;;     (pps simple-utils.ppx_let_generalized)
-;;   )
-;;   (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
-  )
-
-;;; TODO test does not test anything, only prints
-; (test
-;  (modules PartitionMain)
-;  (libraries union_find)
-;  (name PartitionMain))

vendors/UnionFind/Partition.mli

@@ -43,21 +43,29 @@ module type S =
 
     (** {1 Projection} *)
 
-    (** The value of the call [repr i p] is the representative of item
+    (** The value of the call [repr i p] is [j] if the item [i] is in
-        [i] in the partition [p]. The built-in exception [Not_found]
+        the partition [p] and its representative is [j]. If [i] is not
-        is raised if [i] is not in [p]. *)
+        in [p], then the value is [i]. *)
     val repr : item -> partition -> item
 
-    (** The side-effect of the call [print p] is the printing of the
+    (** The value of the call [mem i p] is [Some j] if the item [i] is
-        partition [p] on standard output, based on [Ord.to_string]. *)
+        in the partition [p] and its representative is [j]. If [i] is
-    val print : partition -> unit
+        not in [p], then the value is [None]. *)
+    val mem : item -> partition -> item option
+
+    (** The call [print p] is a value of type [Buffer.t] containing
+        strings denoting the partition [p], based on
+        [Ord.to_string]. *)
+    val print : partition -> Buffer.t
 
     (** {1 Predicates} *)
 
     (** The value of [is_equiv i j p] is [true] if, and only if, the
         items [i] and [j] belong to the same equivalence class in the
         partition [p], that is, [i] and [j] have the same
-        representative. *)
+        representative. In particular, if either [i] or [j] do not
+        belong to [p], the value of [is_equiv i j p] is [false]. See
+        [mem] above. *)
     val is_equiv : item -> item -> partition -> bool
   end
 

vendors/UnionFind/Partition0.ml

@@ -2,34 +2,34 @@
 
 module Make (Item: Partition.Item) =
   struct
-
     type item = Item.t
-    type repr = item   (** Class representatives *)
 
     let equal i j = Item.compare i j = 0
 
     module ItemMap = Map.Make (Item)
 
-    type height = int
-
     type partition = item ItemMap.t
     type t = partition
 
     let empty = ItemMap.empty
 
-    let rec repr item partition =
+    let rec repr item partition : item =
       let parent = ItemMap.find item partition in
       if   equal parent item
       then item
       else repr parent partition
 
-    let is_equiv (i: item) (j: item) (p: partition) =
+    let is_equiv (i: item) (j: item) (p: partition) : bool =
-      equal (repr i p) (repr j p)
+      try equal (repr i p) (repr j p) with Not_found -> false
 
     let get_or_set (i: item) (p: partition) : item * partition =
       try repr i p, p with Not_found -> i, ItemMap.add i i p
 
-    let equiv (i: item) (j :item) (p: partition) : partition =
+    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: partition) : partition =
       let ri, p = get_or_set i p in
       let rj, p = get_or_set j p in
       if equal ri rj then p else ItemMap.add ri rj p
@@ -38,10 +38,12 @@ module Make (Item: Partition.Item) =
 
    (* Printing *)
 
-    let print p =
+    let print (p: partition) =
+      let buffer = Buffer.create 80 in
       let print src dst =
-        Printf.printf "%s -> %s\n"
+        let link =
+          Printf.sprintf "%s -> %s\n"
                          (Item.to_string src) (Item.to_string dst)
-      in ItemMap.iter print p
+        in Buffer.add_string buffer link
-
+      in (ItemMap.iter print p; buffer)
   end

vendors/UnionFind/Partition1.ml

@@ -1,5 +1,5 @@
 (* Persistent implementation of Union/Find with height-balanced
-   forests and without path compression: O(n*log(n)).
+   forests and no path compression: O(n*log(n)).
 
    In the definition of type [t], the height component is that of the
    source, that is, if [ItemMap.find i m = (j,h)], then [h] is the
@@ -10,7 +10,6 @@ module Make (Item: Partition.Item) =
   struct
 
     type item = Item.t
-    type repr = item   (** Class representatives *)
 
     let equal i j = Item.compare i j = 0
 
@@ -23,18 +22,22 @@ module Make (Item: Partition.Item) =
 
     let empty = ItemMap.empty
 
-    let rec seek (i: item) (p: partition) : repr * height =
+    let rec seek (i: item) (p: partition) : item * height =
       let j, _ as i' = ItemMap.find i p in
       if equal i j then i' else seek j p
 
-    let repr item partition = fst (seek item partition)
+    let repr i p = fst (seek i p)
 
-    let is_equiv (i: item) (j: item) (p: partition) =
+    let is_equiv (i: item) (j: item) (p: partition) : bool =
-      equal (repr i p) (repr j p)
+      try equal (repr i p) (repr j p) with Not_found -> false
 
     let get_or_set (i: item) (p: partition) =
       try seek i p, p with
-        Not_found -> let i' = i,0 in (i', ItemMap.add i i' p)
+        Not_found -> let i' = i,0 in i', ItemMap.add i i' 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: partition) : partition =
       let (ri,hi), p = get_or_set i p in
@@ -60,10 +63,13 @@ module Make (Item: Partition.Item) =
     (* Printing *)
 
     let print (p: partition) =
+      let buffer = Buffer.create 80 in
       let print i (j,hi) =
         let _,hj = ItemMap.find j p in
-        Printf.printf "%s,%d -> %s,%d\n"
+        let link =
+          Printf.sprintf "%s,%d -> %s,%d\n"
                          (Item.to_string i) hi (Item.to_string j) hj
-      in ItemMap.iter print p
+        in Buffer.add_string buffer link
+      in ItemMap.iter print p; buffer
 
   end

vendors/UnionFind/Partition2.ml

@@ -1,11 +1,10 @@
 (** Persistent implementation of the Union/Find algorithm with
-    height-balanced forests and without path compression. *)
+    height-balanced forests and no path compression. *)
 
 module Make (Item: Partition.Item) =
   struct
 
     type item = Item.t
-    type repr = item   (** Class representatives *)
 
     let equal i j = Item.compare i j = 0
 
@@ -55,20 +54,25 @@ module Make (Item: Partition.Item) =
 
     let link (src, height) dst = ItemMap.add src (Link (dst, height))
 
-    let rec seek (i: item) (p: partition) : repr * height =
+    let rec seek (i: item) (p: partition) : item * height =
       match ItemMap.find i p with
            Root hi -> i,hi
       | Link (j,_) -> seek j p
 
-    let repr item partition = fst (seek item partition)
+    let repr i p = fst (seek i p)
 
-    let is_equiv (i: item) (j: item) (p: partition) =
+    let is_equiv (i: item) (j: item) (p: partition) : bool =
-      equal (repr i p) (repr j p)
+      try equal (repr i p) (repr j p) with
+        Not_found -> false
 
     let get_or_set (i: item) (p: 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: partition) : 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
@@ -101,6 +105,7 @@ module Make (Item: Partition.Item) =
     (** {1 Printing} *)
 
     let print (p: partition) =
+      let buffer = Buffer.create 80 in
       let print i node =
         let hi, hj, j =
           match node with
@@ -108,8 +113,10 @@ module Make (Item: Partition.Item) =
           | Link (j,hi) ->
               match ItemMap.find j p with
                 Root hj | Link (_,hj) -> hi,hj,j in
-        Printf.printf "%s,%d -> %s,%d\n"
+        let link =
+          Printf.sprintf "%s,%d -> %s,%d\n"
                          (Item.to_string i) hi (Item.to_string j) hj
-      in ItemMap.iter print p
+        in Buffer.add_string buffer link
+      in ItemMap.iter print p; buffer
 
   end

vendors/UnionFind/Partition3.ml

@@ -0,0 +1,99 @@
+(* Destructive implementation of union/find with height-balanced
+   forests but without path compression: O(n*log(n)). *)
+
+module Make (Item: Partition.Item) =
+  struct
+
+    type item = Item.t
+
+    let equal i j = Item.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 node = {
+                item : item;
+      mutable height : int;
+      mutable parent : node
+    }
+
+    module ItemMap = Map.Make (Item)
+
+    (** 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 partition = node ItemMap.t
+
+    type t = partition
+
+    let empty = ItemMap.empty
+
+    (** The impure function [repr] is faster than a pure
+        implementation in the worst case because, in the latter case,
+        the cost is O(log n) for accessing each node in the path to
+        the root, whereas, in the former, only the access to the first
+        node in the path incurs a cost of O(log n) -- the other nodes
+        are accessed in constant time by following the [next] field of
+        type [node]. *)
+    let seek (i: item) (p: partition) : node =
+      let rec find_root node =
+        if node.parent == node then node else find_root node.parent
+      in find_root (ItemMap.find i p)
+
+    let repr i p = (seek i p).item
+
+    let is_equiv (i: item) (j: item) (p: partition) : bool =
+      try equal (repr i p) (repr j p) with
+        Not_found -> false
+
+    let get_or_set item (p: partition) =
+      try seek item p, p with
+        Not_found ->
+          let rec loop = {item; height=0; parent=loop}
+          in loop, ItemMap.add item loop 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 link src dst = src.parent <- dst
+
+    let equiv (i: item) (j: item) (p: partition) : partition =
+      let ni,p  = get_or_set i p in
+      let nj,p  = get_or_set j p in
+      let hi,hj = ni.height, nj.height in
+      let () =
+        if   not (equal ni.item nj.item)
+        then if   hi > hj
+             then link nj ni
+             else (link ni nj; nj.height <- max hj (hi+1))
+      in p
+
+    let alias (i: item) (j: item) (p: partition) : partition =
+      let ni,p  = get_or_set i p in
+      let nj,p  = get_or_set j p in
+      let hi,hj = ni.height, nj.height in
+      let () =
+        if   not (equal ni.item nj.item)
+        then if   hi = hj || equal ni.item i
+             then (link ni nj; nj.height <- max hj (hi+1))
+             else if hi < hj then link ni nj
+                             else link nj ni
+      in p
+
+    (* Printing *)
+
+    let print (p: partition) =
+      let buffer = Buffer.create 80 in
+      let print _ node =
+        let link =
+          Printf.sprintf "%s,%d -> %s,%d\n"
+            (Item.to_string node.item) node.height
+            (Item.to_string node.parent.item) node.parent.height
+        in Buffer.add_string buffer link
+      in ItemMap.iter print p; buffer
+
+  end

vendors/UnionFind/PartitionMain.ml

@@ -9,7 +9,8 @@ module Test (Part: Partition.S with type item = Int.t) =
   struct
     open Part
 
-    let () = empty
+    let () =
+      empty
       |> equiv 4 3
       |> equiv 3 8
       |> equiv 6 5
@@ -25,6 +26,8 @@ module Test (Part: Partition.S with type item = Int.t) =
       |> equiv 7 7
       |> equiv 10 10
       |> print
+      |> Buffer.contents
+      |> print_string
   end
 
 

vendors/UnionFind/UnionFind.opam

@@ -0,0 +1,19 @@
+opam-version : "2.0"
+version      : "1.0"
+maintainer   : "rinderknecht@free.fr"
+authors      : [ "Christian Rinderknecht" ]
+homepage     : "https://gitlab.com/rinderknecht/UnionFind"
+bug-reports  : "https://gitlab.com/rinderknecht/UnionFind/issues"
+dev-repo     : "git+https://gitlab.com/rinderknecht/UnionFind.git"
+license      : "MIT"
+
+depends      : [ "dune" ]
+
+build        : [
+                [ "sh" "-c" "printf 'let version = \"%s\"' \"$(git describe --always --dirty --abbrev=0)\" > Version.ml" ]
+                [ "dune" "build" "-p" name "-j" jobs ]
+               ]
+
+url {
+  src: "https://gitlab.com/rinderknecht/UnionFind/-/archive/master/UnionFind.tar.gz"
+}

vendors/UnionFind/dune

@@ -0,0 +1,11 @@
+(library
+  (name UnionFind)
+  (public_name UnionFind)
+  (wrapped false)
+  (modules Partition0 Partition1 Partition2 Partition3 Partition UnionFind)
+  (modules_without_implementation Partition))
+
+(test
+ (modules PartitionMain)
+ (libraries UnionFind)
+ (name PartitionMain))

vendors/UnionFind/dune-project

@@ -0,0 +1 @@
+(lang dune 1.7)