--- /dev/null
+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 ;
--- /dev/null
+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
+++ /dev/null
-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 ;