From 639871900a65a25617fed0ee19342e6cd4971dac Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@galois.com>
Date: Tue, 8 Apr 2008 23:22:28 -0700
Subject: [PATCH] Import extra/unionfind, a disjoint set datastructure

---
 extra/unionfind/authors.txt      |  1 +
 extra/unionfind/summary.txt      |  1 +
 extra/unionfind/unionfind.factor | 71 ++++++++++++++++++++++++++++++++
 3 files changed, 73 insertions(+)
 create mode 100644 extra/unionfind/authors.txt
 create mode 100644 extra/unionfind/summary.txt
 create mode 100644 extra/unionfind/unionfind.factor

diff --git a/extra/unionfind/authors.txt b/extra/unionfind/authors.txt
new file mode 100644
index 0000000000..16e1588016
--- /dev/null
+++ b/extra/unionfind/authors.txt
@@ -0,0 +1 @@
+Eric Mertens
diff --git a/extra/unionfind/summary.txt b/extra/unionfind/summary.txt
new file mode 100644
index 0000000000..c282cc29bb
--- /dev/null
+++ b/extra/unionfind/summary.txt
@@ -0,0 +1 @@
+A efficient implementation of a disjoint-set datastructure
diff --git a/extra/unionfind/unionfind.factor b/extra/unionfind/unionfind.factor
new file mode 100644
index 0000000000..1f0d8be927
--- /dev/null
+++ b/extra/unionfind/unionfind.factor
@@ -0,0 +1,71 @@
+USING: accessors arrays combinators kernel math sequences namespaces ;
+
+IN: unionfind
+
+<PRIVATE
+
+TUPLE: unionfind parents ranks counts ;
+
+SYMBOL: uf
+
+: count ( a -- n )
+    uf get counts>> nth ;
+
+: add-count ( p a -- )
+    count [ + ] curry uf get counts>> swap change-nth ;
+
+: parent ( a -- p )
+    uf get parents>> nth ;
+
+: set-parent ( p a -- )
+    uf get parents>> set-nth ;
+
+: link-sets ( p a -- )
+    [ set-parent ]
+    [ add-count ] 2bi ;
+
+: rank ( a -- r )
+    uf get ranks>> nth ;
+
+: inc-rank ( a -- )
+    uf get ranks>> [ 1+ ] change-nth ;
+
+: topparent ( a -- p )
+    [ parent ] keep
+    2dup = [
+        [ topparent ] dip
+        2dup set-parent
+    ] unless drop ;
+
+PRIVATE>
+
+: <unionfind> ( n -- unionfind )
+    [ >array ]
+    [ 0 <array> ]
+    [ 1 <array> ] tri
+    unionfind construct-boa ;
+
+: equiv-set-size ( a uf -- n )
+    uf [ topparent count ] with-variable ;
+
+: equiv? ( a b uf -- ? )
+    uf [ [ topparent ] bi@ = ] with-variable ;
+
+: equate ( a b uf -- )
+    uf [
+        [ topparent ] bi@
+        2dup [ rank ] compare sgn
+        {
+            { -1 [ swap link-sets ] }
+            {  1 [ link-sets ] }
+            {  0 [
+                    2dup =
+                    [ 2drop ]
+                    [
+                        [ link-sets ]
+                        [ drop inc-rank ] 2bi
+                    ] if
+                 ]
+            }
+        } case
+    ] with-variable ;