core/hash-sets/hash-sets.factor

   1 ! Copyright (C) 2010 Daniel Ehrenberg
   2 ! Copyright (C) 2005, 2011 John Benediktsson, Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors arrays combinators growable.private hash-sets
   5 hashtables.private kernel kernel.private math math.private
   6 sequences sequences.private sets sets.private slots.private
   7 vectors ;
   8 IN: hash-sets
   9
  10 TUPLE: hash-set
  11     { count array-capacity }
  12     { deleted array-capacity }
  13     { array array } ;
  14
  15 <PRIVATE
  16
  17 : hash@ ( key array -- i )
  18     [ hashcode >fixnum ] dip wrap ; inline
  19
  20 : probe ( array i probe# -- array i probe# )
  21     1 fixnum+fast [ fixnum+fast over wrap ] keep ; inline
  22
  23 : no-key ( key array -- array n ? ) nip f f ; inline
  24
  25 : (key@) ( key array i probe# -- array n ? )
  26     [ 3dup swap array-nth ] dip over +empty+ eq?
  27     [ 4drop no-key ] [
  28         [ = ] dip swap
  29         [ drop rot drop t ]
  30         [ probe (key@) ]
  31         if
  32     ] if ; inline recursive
  33
  34 : key@ ( key hash -- array n ? )
  35     array>> dup length>> 0 eq?
  36     [ no-key ] [ 2dup hash@ 0 (key@) ] if ; inline
  37
  38 : <hash-array> ( n -- array )
  39     3 * 1 + 2/ next-power-of-2 +empty+ <array> ; inline
  40
  41 : reset-hash ( n hash -- )
  42     swap <hash-array> >>array init-hash ; inline
  43
  44 : (new-key@) ( key array i probe# j -- array i j empty? )
  45     [ 2dup swap array-nth ] 2dip pick tombstone?
  46     [
  47         rot +empty+ eq?
  48         [ nip [ drop ] 3dip t ]
  49         [ pick or [ probe ] dip (new-key@) ]
  50         if
  51     ] [
  52         [ [ pick ] dip = ] 2dip rot
  53         [ nip [ drop ] 3dip f ]
  54         [ [ probe ] dip (new-key@) ]
  55         if
  56     ] if ; inline recursive
  57
  58 : new-key@ ( key hash -- array n ? )
  59     [ array>> 2dup hash@ 0 f (new-key@) ] keep swap
  60     [ over [ hash-deleted- ] [ hash-count+ ] if swap or t ] [ 2drop f ] if ; inline
  61
  62 : set-nth-item ( key array n -- )
  63     2 fixnum+fast set-slot ; inline
  64
  65 : (adjoin) ( key hash -- ? )
  66     dupd new-key@ [ set-nth-item ] dip ; inline
  67
  68 : (delete) ( key hash -- ? )
  69     [ nip ] [ key@ ] 2bi [
  70         [ +tombstone+ ] 2dip set-nth-item
  71         hash-deleted+ t
  72     ] [
  73         3drop f
  74     ] if ; inline
  75
  76 : (rehash) ( seq hash -- )
  77     [ (adjoin) drop ] curry each ; inline
  78
  79 : hash-large? ( hash -- ? )
  80     [ count>> 1 fixnum+fast 3 fixnum*fast ]
  81     [ array>> length>> 1 fixnum-shift-fast ] bi fixnum>= ; inline
  82
  83 : each-member ( ... array quot: ( ... elt -- ... ) -- ... )
  84     [ if ] curry [ dup tombstone? [ drop ] ] prepose each ; inline
  85
  86 : grow-hash ( hash -- )
  87     { hash-set } declare [
  88         [ array>> ]
  89         [ cardinality 1 + ]
  90         [ reset-hash ] tri
  91     ] keep [ (adjoin) drop ] curry each-member ;
  92
  93 : ?grow-hash ( hash -- )
  94     dup hash-large? [ grow-hash ] [ drop ] if ; inline
  95
  96 PRIVATE>
  97
  98 : <hash-set> ( capacity -- hash-set )
  99     integer>fixnum-strict
 100     [ 0 0 ] dip <hash-array> hash-set boa ; inline
 101
 102 M: hash-set in?
 103      key@ 2nip ;
 104
 105 M: hash-set clear-set
 106     [ init-hash ] [ array>> [ drop +empty+ ] map! drop ] bi ;
 107
 108 M: hash-set delete
 109     (delete) drop ;
 110
 111 M: hash-set ?delete
 112     (delete) ;
 113
 114 M: hash-set cardinality
 115     [ count>> ] [ deleted>> ] bi - ; inline
 116
 117 : rehash ( hash-set -- )
 118     [ members ] [ clear-set ] [ (rehash) ] tri ;
 119
 120 M: hash-set adjoin
 121     dup ?grow-hash (adjoin) drop ;
 122
 123 M: hash-set ?adjoin
 124     dup ?grow-hash (adjoin) ;
 125
 126 M: hash-set members
 127     [ array>> 0 swap ] [ cardinality f <array> ] bi [
 128         [ [ over ] dip set-nth-unsafe 1 + ] curry each-member
 129     ] keep nip ;
 130
 131 M: hash-set clone
 132     (clone) [ clone ] change-array ; inline
 133
 134 M: hash-set equal?
 135     over hash-set? [ set= ] [ 2drop f ] if ;
 136
 137 : >hash-set ( members -- hash-set )
 138     dup length <hash-set> [ (rehash) ] keep ; inline
 139
 140 M: hash-set set-like
 141     drop dup hash-set? [ ?members >hash-set ] unless ; inline
 142
 143 INSTANCE: hash-set set
 144
 145 ! Overrides for performance
 146
 147 <PRIVATE
 148
 149 : and-tombstones ( quot: ( elt -- ? ) -- quot: ( elt -- ? ) )
 150     [ if ] curry [ dup tombstone? [ drop t ] ] prepose ; inline
 151
 152 : not-tombstones ( quot: ( elt -- ? ) -- quot: ( elt -- ? ) )
 153     [ if ] curry [ dup tombstone? [ drop f ] ] prepose ; inline
 154
 155 : array/tester ( hash-set1 hash-set2 -- array quot )
 156     [ array>> ] dip [ in? ] curry ; inline
 157
 158 : filter-members ( hash-set array quot: ( elt -- ? ) -- accum )
 159     [ dup ] prepose rot cardinality <vector> [
 160         [ push-unsafe ] curry [ [ drop ] if ] curry
 161         compose each
 162     ] keep ; inline
 163
 164 PRIVATE>
 165
 166 M: hash-set intersect
 167     over hash-set? [
 168         small/large dupd array/tester not-tombstones
 169         filter-members >hash-set
 170     ] [ (intersect) >hash-set ] if ;
 171
 172 M: hash-set intersects?
 173     over hash-set? [
 174         small/large array/tester not-tombstones any?
 175     ] [ small/large sequence/tester any? ] if ;
 176
 177 M: hash-set union
 178     over hash-set? [
 179         small/large [ array>> ] [ clone ] bi*
 180         [ [ adjoin ] curry each-member ] keep
 181     ] [ (union) >hash-set ] if ;
 182
 183 M: hash-set diff
 184     over hash-set? [
 185         dupd array/tester [ not ] compose not-tombstones
 186         filter-members >hash-set
 187     ] [ (diff) >hash-set ] if ;
 188
 189 M: hash-set subset?
 190     over hash-set? [
 191         2dup [ cardinality ] bi@ > [ 2drop f ] [
 192             array/tester and-tombstones all?
 193         ] if
 194     ] [ call-next-method ] if ;
 195
 196 M: hash-set set=
 197     over hash-set? [
 198         2dup [ cardinality ] bi@ eq? [
 199             array/tester and-tombstones all?
 200         ] [ 2drop f ] if
 201     ] [ call-next-method ] if ;
 202
 203 M: hash-set hashcode*
 204     [
 205         dup cardinality 1 eq?
 206         [ members hashcode* ] [ nip cardinality ] if
 207     ] recursive-hashcode ;
 208
 209 ! Default methods
 210
 211 M: f fast-set drop 0 <hash-set> ;
 212
 213 M: sequence fast-set >hash-set ;
 214
 215 M: sequence duplicates
 216     dup length <hash-set> [ ?adjoin ] curry reject ;
 217
 218 M: sequence all-unique?
 219     dup length <hash-set> [ ?adjoin ] curry all? ;