1 ! Copyright (C) 2010 Daniel Ehrenberg
2 ! Copyright (C) 2005, 2011 John Benediktsson, Slava Pestov.
3 ! See https://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays growable.private hashtables.private
5 kernel kernel.private math math.private sequences
6 sequences.private sets sets.private slots.private vectors ;
10 { count array-capacity }
11 { deleted array-capacity }
16 : hash@ ( key array -- i )
17 [ hashcode >fixnum ] dip wrap ; inline
19 : probe ( array i probe# -- array i probe# )
20 1 fixnum+fast [ fixnum+fast over wrap ] keep ; inline
22 : (key@) ( key array i probe# -- array n ? )
23 [ 3dup swap array-nth ] dip over +empty+ eq?
29 ] if ; inline recursive
31 : key@ ( key hash -- array n ? )
32 array>> dup length>> 0 eq?
33 [ no-key ] [ 2dup hash@ 0 (key@) ] if ; inline
35 : <hash-array> ( n -- array )
36 3 * 1 + 2/ next-power-of-2 +empty+ <array> ; inline
38 : reset-hash ( n hash -- )
39 swap <hash-array> >>array init-hash ; inline
41 : (new-key@) ( array key i probe# j -- array i j empty? )
42 [ 2dup swap array-nth ] 2dip pick tombstone?
45 [ nip [ drop ] 3dip t ]
46 [ pick or [ probe ] dip (new-key@) ]
50 [ nip [ drop ] 3dip f ]
51 [ [ probe ] dip (new-key@) ]
53 ] if ; inline recursive
55 : new-key@ ( key hash -- array n ? )
56 [ array>> 2dup hash@ 0 f (new-key@) ] keep swap
57 [ over [ hash-deleted- ] [ hash-count+ ] if swap or t ] [ 2drop f ] if ; inline
59 : set-nth-item ( key array n -- )
60 2 fixnum+fast set-slot ; inline
62 : (adjoin) ( key hash -- ? )
63 dupd new-key@ [ set-nth-item ] dip ; inline
65 : (delete) ( key hash -- ? )
66 [ nip ] [ key@ ] 2bi [
67 [ +tombstone+ ] 2dip set-nth-item
73 : (rehash) ( seq hash -- )
74 '[ _ (adjoin) drop ] each ; inline
76 : hash-large? ( hash -- ? )
77 [ count>> 1 fixnum+fast 3 fixnum*fast ]
78 [ array>> length>> 1 fixnum-shift-fast ] bi fixnum>= ; inline
80 : each-member ( ... array quot: ( ... elt -- ... ) -- ... )
81 '[ dup tombstone? [ drop ] _ if ] each ; inline
83 : grow-hash ( hash -- )
84 { hash-set } declare [
88 ] keep [ (adjoin) drop ] curry each-member ;
90 : ?grow-hash ( hash -- )
91 dup hash-large? [ grow-hash ] [ drop ] if ; inline
95 : <hash-set> ( capacity -- hash-set )
97 [ 0 0 ] dip <hash-array> hash-set boa ; inline
102 M: hash-set clear-set
103 [ init-hash ] [ array>> [ drop +empty+ ] map! drop ] bi ;
111 M: hash-set cardinality
112 [ count>> ] [ deleted>> ] bi - ; inline
114 : rehash ( hash-set -- )
115 [ members ] [ clear-set ] [ (rehash) ] tri ;
118 dup ?grow-hash (adjoin) drop ;
121 dup ?grow-hash (adjoin) ;
124 [ array>> 0 swap ] [ cardinality f <array> ] bi [
125 [ overd set-nth-unsafe 1 + ] curry each-member
129 (clone) [ clone ] change-array ; inline
132 over hash-set? [ set= ] [ 2drop f ] if ;
134 : >hash-set ( members -- hash-set )
135 dup length <hash-set> [ (rehash) ] keep ; inline
138 drop dup hash-set? [ ?members >hash-set ] unless ; inline
140 : intern ( obj hash-set -- obj' )
141 2dup key@ [ swap nth 2nip ] [ 2drop [ adjoin ] keepd ] if ;
143 INSTANCE: hash-set set
145 ! Overrides for performance
149 : and-tombstones ( quot: ( elt -- ? ) -- quot: ( elt -- ? ) )
150 '[ dup tombstone? [ drop t ] _ if ] ; inline
152 : not-tombstones ( quot: ( elt -- ? ) -- quot: ( elt -- ? ) )
153 '[ dup tombstone? [ drop f ] _ if ] ; inline
155 : array/tester ( hash-set1 hash-set2 -- array quot )
156 [ array>> ] dip '[ _ in? ] ; inline
158 : filter-members ( hash-set array quot: ( elt -- ? ) -- accum )
159 rot cardinality <vector> [
160 '[ dup @ [ _ push-unsafe ] [ drop ] if ] each
165 M: hash-set intersect
167 small/large dupd array/tester not-tombstones
168 filter-members >hash-set
169 ] [ (intersect) >hash-set ] if ;
171 M: hash-set intersects?
173 small/large array/tester not-tombstones any?
174 ] [ small/large sequence/tester any? ] if ;
178 small/large [ array>> ] [ clone ] bi*
179 [ [ adjoin ] curry each-member ] keep
180 ] [ (union) >hash-set ] if ;
184 dupd array/tester [ not ] compose not-tombstones
185 filter-members >hash-set
186 ] [ (diff) >hash-set ] if ;
190 2dup [ cardinality ] bi@ > [ 2drop f ] [
191 array/tester and-tombstones all?
193 ] [ call-next-method ] if ;
197 2dup [ cardinality ] bi@ eq? [
198 array/tester and-tombstones all?
200 ] [ call-next-method ] if ;
202 M: hash-set hashcode*
204 dup cardinality 1 eq?
205 [ members hashcode* ] [ nip cardinality ] if
206 ] recursive-hashcode ;
210 M: f fast-set drop 0 <hash-set> ;
212 M: sequence fast-set >hash-set ;
214 M: sequence duplicates
215 dup length <hash-set> '[ _ ?adjoin ] reject ;
217 M: sequence all-unique?
218 dup length <hash-set> '[ _ ?adjoin ] all? ;