move unionfind to disjoint-set, clean-ups, add project-euler 186

problem 186 uses the disjoint-set algorithm

extra/disjoint-set/disjoint-set.factor

@@ -0,0 +1,76 @@
+USING: accessors arrays hints kernel locals math sequences ;
+
+IN: disjoint-set
+
+<PRIVATE
+
+TUPLE: disjoint-set parents ranks counts ;
+
+: count ( a disjoint-set -- n )
+    counts>> nth ; inline
+
+: add-count ( p a disjoint-set -- )
+    [ count [ + ] curry ] keep counts>> swap change-nth ; inline
+
+: parent ( a disjoint-set -- p )
+    parents>> nth ; inline
+
+: set-parent ( p a disjoint-set -- )
+    parents>> set-nth ; inline
+
+: link-sets ( p a disjoint-set -- )
+    [ set-parent ]
+    [ add-count ] 3bi ; inline
+
+: rank ( a disjoint-set -- r )
+    ranks>> nth ; inline
+
+: inc-rank ( a disjoint-set -- )
+    ranks>> [ 1+ ] change-nth ; inline
+
+: representative? ( a disjoint-set -- ? )
+    dupd parent = ; inline
+
+: representative ( a disjoint-set -- p )
+    2dup representative? [ drop ] [
+        [ [ parent ] keep representative dup ] 2keep set-parent
+    ] if ;
+
+: representatives ( a b disjoint-set -- r r )
+    [ representative ] curry bi@ ; inline
+
+: ranks ( a b disjoint-set -- r r )
+    [ rank ] curry bi@ ; inline
+
+:: branch ( a b neg zero pos -- )
+    a b 2dup = [
+        2drop zero call
+    ] [
+        < [ neg call ] [ pos call ] if
+    ] if ; inline
+
+PRIVATE>
+
+: <disjoint-set> ( n -- disjoint-set )
+    [ >array ]
+    [ 0 <array> ]
+    [ 1 <array> ] tri
+    disjoint-set construct-boa ;
+
+: equiv-set-size ( a disjoint-set -- n )
+    [ representative ] keep count ;
+
+: equiv? ( a b disjoint-set -- ? )
+    representatives = ; inline
+
+:: equate ( a b disjoint-set -- )
+    a b disjoint-set representatives
+    2dup = [ 2drop ] [
+        2dup disjoint-set ranks
+        [ swap ] [ over disjoint-set inc-rank ] [ ] branch
+        disjoint-set link-sets
+    ] if ;
+
+HINTS: equate disjoint-set ;
+HINTS: representative disjoint-set ;
+HINTS: equiv-set-size disjoint-set ;

extra/disjoint-set/summary.txt

@@ -0,0 +1 @@
+An efficient implementation of the disjoint-set data structure

extra/project-euler/186/186.factor

@@ -0,0 +1,35 @@
+USING: circular disjoint-set kernel math math.ranges
+       sequences sequences.lib ;
+IN: project-euler.186
+
+: (generator) ( k -- n )
+    dup sq 300007 * 200003 - * 100003 + 1000000 rem ;
+
+: <generator> ( -- lag )
+    55 [1,b] [ (generator) ] map <circular> ;
+
+: advance ( lag -- )
+    [ { 0 31 } nths sum 1000000 rem ] keep push-circular ;
+
+: next ( lag -- n )
+    [ first ] [ advance ] bi ;
+
+: 2unless? ( x y ?quot quot -- )
+    >r 2keep rot [ 2drop ] r> if ; inline
+
+: (p186) ( generator counter unionfind -- counter )
+    524287 over equiv-set-size 990000 <
+    [
+        pick [ next ] [ next ] bi
+        [ = ] [
+            pick equate
+            [ 1+ ] dip
+        ] 2unless? (p186)
+    ] [
+        drop nip
+    ] if ;
+
+: euler186 ( -- n )
+    <generator> 0 1000000 <disjoint-set> (p186) ;
+
+MAIN: euler186

extra/project-euler/authors.txt

@@ -1 +1,2 @@
 Aaron Schaefer
+Eric Mertens

extra/unionfind/summary.txt

@@ -1 +0,0 @@
-A efficient implementation of a disjoint-set datastructure

extra/unionfind/unionfind.factor

@@ -1,71 +0,0 @@
-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 ;