diff --git a/extra/unionfind/authors.txt b/extra/disjoint-set/authors.txt similarity index 100% rename from extra/unionfind/authors.txt rename to extra/disjoint-set/authors.txt diff --git a/extra/disjoint-set/disjoint-set.factor b/extra/disjoint-set/disjoint-set.factor new file mode 100644 index 0000000000..7ce0cceb2b --- /dev/null +++ b/extra/disjoint-set/disjoint-set.factor @@ -0,0 +1,76 @@ +USING: accessors arrays hints kernel locals math sequences ; + +IN: disjoint-set + +> 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> + +: ( n -- disjoint-set ) + [ >array ] + [ 0 ] + [ 1 ] 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 ; diff --git a/extra/disjoint-set/summary.txt b/extra/disjoint-set/summary.txt new file mode 100644 index 0000000000..ec7ec73417 --- /dev/null +++ b/extra/disjoint-set/summary.txt @@ -0,0 +1 @@ +An efficient implementation of the disjoint-set data structure diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor new file mode 100644 index 0000000000..acec27c51f --- /dev/null +++ b/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 ; + +: ( -- lag ) + 55 [1,b] [ (generator) ] map ; + +: 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 ) + 0 1000000 (p186) ; + +MAIN: euler186 diff --git a/extra/project-euler/authors.txt b/extra/project-euler/authors.txt index 4eec9c9a08..d280bffce6 100644 --- a/extra/project-euler/authors.txt +++ b/extra/project-euler/authors.txt @@ -1 +1,2 @@ Aaron Schaefer +Eric Mertens diff --git a/extra/unionfind/summary.txt b/extra/unionfind/summary.txt deleted file mode 100644 index c282cc29bb..0000000000 --- a/extra/unionfind/summary.txt +++ /dev/null @@ -1 +0,0 @@ -A efficient implementation of a disjoint-set datastructure diff --git a/extra/unionfind/unionfind.factor b/extra/unionfind/unionfind.factor deleted file mode 100644 index 1f0d8be927..0000000000 --- a/extra/unionfind/unionfind.factor +++ /dev/null @@ -1,71 +0,0 @@ -USING: accessors arrays combinators kernel math sequences namespaces ; - -IN: unionfind - -> 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> - -: ( n -- unionfind ) - [ >array ] - [ 0 ] - [ 1 ] 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 ;