1 ! Copyright (C) 2008 Eric Mertens.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays hints kernel locals math hashtables
8 { parents hashtable read-only }
9 { ranks hashtable read-only }
10 { counts hashtable read-only } ;
14 : count ( a disjoint-set -- n )
17 : add-count ( p a disjoint-set -- )
18 [ count [ + ] curry ] keep counts>> swap change-at ; inline
20 : parent ( a disjoint-set -- p )
23 : set-parent ( p a disjoint-set -- )
24 parents>> set-at ; inline
26 : link-sets ( p a disjoint-set -- )
27 [ set-parent ] [ add-count ] 3bi ; inline
29 : rank ( a disjoint-set -- r )
32 : inc-rank ( a disjoint-set -- )
33 ranks>> [ 1+ ] change-at ; inline
35 : representative? ( a disjoint-set -- ? )
36 dupd parent = ; inline
40 GENERIC: representative ( a disjoint-set -- p )
42 M: disjoint-set representative
43 2dup representative? [ drop ] [
44 [ [ parent ] keep representative dup ] 2keep set-parent
49 : representatives ( a b disjoint-set -- r r )
50 [ representative ] curry bi@ ; inline
52 : ranks ( a b disjoint-set -- r r )
53 [ rank ] curry bi@ ; inline
55 :: branch ( a b neg zero pos -- )
56 a b = zero [ a b < neg pos if ] if ; inline
60 : <disjoint-set> ( -- disjoint-set )
61 H{ } clone H{ } clone H{ } clone disjoint-set boa ;
63 GENERIC: add-atom ( a disjoint-set -- )
65 M: disjoint-set add-atom
66 [ dupd parents>> set-at ]
67 [ [ 0 ] 2dip ranks>> set-at ]
68 [ [ 1 ] 2dip counts>> set-at ]
71 : add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;
73 GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
75 M: disjoint-set disjoint-set-member? parents>> key? ;
77 GENERIC: equiv-set-size ( a disjoint-set -- n )
79 M: disjoint-set equiv-set-size [ representative ] keep count ;
81 GENERIC: equiv? ( a b disjoint-set -- ? )
83 M: disjoint-set equiv? representatives = ;
85 GENERIC: equate ( a b disjoint-set -- )
87 M:: disjoint-set equate ( a b disjoint-set -- )
88 a b disjoint-set representatives
90 2dup disjoint-set ranks
91 [ swap ] [ over disjoint-set inc-rank ] [ ] branch
92 disjoint-set link-sets
95 : equate-all-with ( seq a disjoint-set -- )
96 '[ _ _ equate ] each ;
98 : equate-all ( seq disjoint-set -- )
99 over empty? [ 2drop ] [
100 [ unclip-slice ] dip equate-all-with
103 M: disjoint-set clone
104 [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
107 : assoc>disjoint-set ( assoc -- disjoint-set )
109 [ '[ drop _ add-atom ] assoc-each ]
110 [ '[ _ equate ] assoc-each ]