steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

disjoint-sets: some cleanup.

db4
John Benediktsson 2015-07-28 18:14:20 -07:00
parent 663fba1d7d
commit 194e0cc598
1 changed files with 19 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
basis/disjoint-sets/disjoint-sets.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Eric Mertens. ! Copyright (C) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hints kernel locals math hashtables USING: accessors assocs fry hashtables kernel locals math
assocs fry sequences ; sequences ;
FROM: assocs => change-at ; FROM: assocs => change-at ;
IN: disjoint-sets IN: disjoint-sets
@ -12,14 +12,8 @@ TUPLE: disjoint-set
<PRIVATE <PRIVATE
: count ( a disjoint-set -- n )
counts>> at ; inline
: add-count ( p a disjoint-set -- ) : add-count ( p a disjoint-set -- )
[ count [ + ] curry ] keep counts>> swap change-at ; inline counts>> [ at '[ _ + ] ] [ swap change-at ] bi ; inline
: parent ( a disjoint-set -- p )
parents>> at ; inline
: set-parent ( p a disjoint-set -- ) : set-parent ( p a disjoint-set -- )
parents>> set-at ; inline parents>> set-at ; inline
@ -27,31 +21,28 @@ TUPLE: disjoint-set
: link-sets ( p a disjoint-set -- ) : link-sets ( p a disjoint-set -- )
[ set-parent ] [ add-count ] 3bi ; inline [ set-parent ] [ add-count ] 3bi ; inline
: rank ( a disjoint-set -- r )
ranks>> at ; inline
: inc-rank ( a disjoint-set -- ) : inc-rank ( a disjoint-set -- )
ranks>> [ 1 + ] change-at ; inline ranks>> [ 1 + ] change-at ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
PRIVATE> PRIVATE>
GENERIC: representative ( a disjoint-set -- p ) GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative M:: disjoint-set representative ( a disjoint-set -- p )
2dup representative? [ drop ] [ a disjoint-set parents>> at :> p
[ [ parent ] keep representative dup ] 2keep set-parent a p = [ a ] [
p disjoint-set representative [
a disjoint-set set-parent
] keep
] if ; ] if ;
<PRIVATE <PRIVATE
: representatives ( a b disjoint-set -- r r ) : representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline '[ _ representative ] bi@ ; inline
: ranks ( a b disjoint-set -- r r ) : ranks ( a b disjoint-set -- r r )
[ rank ] curry bi@ ; inline '[ _ ranks>> at ] bi@ ; inline
:: branch ( a b neg zero pos -- ) :: branch ( a b neg zero pos -- )
a b = zero [ a b < neg pos if ] if ; inline a b = zero [ a b < neg pos if ] if ; inline
@ -81,7 +72,8 @@ M: disjoint-set disjoint-set-members parents>> keys ;
GENERIC: equiv-set-size ( a disjoint-set -- n ) GENERIC: equiv-set-size ( a disjoint-set -- n )
M: disjoint-set equiv-set-size [ representative ] keep count ; M: disjoint-set equiv-set-size
[ representative ] keep counts>> at ;
GENERIC: equiv? ( a b disjoint-set -- ? ) GENERIC: equiv? ( a b disjoint-set -- ? )
@ -106,12 +98,11 @@ M:: disjoint-set equate ( a b disjoint-set -- )
] if ; ] if ;
M: disjoint-set clone M: disjoint-set clone
[ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@ [ parents>> ] [ ranks>> ] [ counts>> ] tri
disjoint-set boa ; [ clone ] tri@ disjoint-set boa ;
: assoc>disjoint-set ( assoc -- disjoint-set ) : assoc>disjoint-set ( assoc -- disjoint-set )
<disjoint-set> <disjoint-set> [
[ '[ drop _ add-atom ] assoc-each ] [ '[ drop _ add-atom ] assoc-each ]
[ '[ _ equate ] assoc-each ] [ '[ _ equate ] assoc-each ] 2bi
[ nip ] ] keep ;
2tri ;