basis/bit-sets/bit-sets.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors bit-arrays fry kernel math math.bitwise
   4 sequences sequences.private sets ;
   5 IN: bit-sets
   6
   7 TUPLE: bit-set { table bit-array read-only } ;
   8
   9 : <bit-set> ( capacity -- bit-set )
  10     <bit-array> bit-set boa ; inline
  11
  12 INSTANCE: bit-set unordered-set
  13
  14 M: bit-set in?
  15     over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
  16
  17 M: bit-set adjoin
  18     ! This is allowed to throw an error when the elt couldn't
  19     ! go in the set
  20     [ t ] 2dip table>> set-nth ;
  21
  22 M: bit-set delete
  23     ! This isn't allowed to throw an error if the elt wasn't
  24     ! in the set
  25     over integer? [ [ f ] 2dip table>> ?set-nth ] [ 2drop ] if ;
  26
  27 ! If you do binary set operations with a bit-set, it's expected
  28 ! that the other thing can also be represented as a bit-set
  29 ! of the same length.
  30 <PRIVATE
  31
  32 ERROR: check-bit-set-failed ;
  33
  34 : check-bit-set ( bit-set -- bit-set )
  35     dup bit-set? [ check-bit-set-failed ] unless ; inline
  36
  37 : bit-set-map ( seq1 seq2 quot -- seq )
  38     [ drop [ length ] bi@ [ assert= ] keep ]
  39     [ [ [ underlying>> ] bi@ ] dip 2map ] 3bi
  40     bit-array boa ; inline
  41
  42 : (bit-set-op) ( set1 set2 -- table1 table2 )
  43     [ set-like ] keep [ table>> ] bi@ ; inline
  44
  45 : bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set )
  46     [ (bit-set-op) ] dip bit-set-map bit-set boa ; inline
  47
  48 PRIVATE>
  49
  50 M: bit-set union
  51     [ bitor ] bit-set-op ;
  52
  53 M: bit-set intersect
  54     [ bitand ] bit-set-op ;
  55
  56 M: bit-set diff
  57     [ bitnot bitand ] bit-set-op ;
  58
  59 M: bit-set subset?
  60     [ intersect ] keep = ;
  61
  62 M: bit-set members
  63     table>> [ length iota ] keep '[ _ nth-unsafe ] filter ;
  64
  65 <PRIVATE
  66
  67 : bit-set-like ( set bit-set -- bit-set' )
  68     ! Throws an error if there are keys that can't be put
  69     ! in the bit set
  70     over bit-set? [ 2dup [ table>> length ] same? ] [ f ] if
  71     [ drop ] [
  72         [ members ] dip table>> length <bit-set>
  73         [ adjoin-all ] keep
  74     ] if ;
  75
  76 PRIVATE>
  77
  78 M: bit-set set-like
  79     bit-set-like check-bit-set ; inline
  80
  81 M: bit-set clone
  82     table>> clone bit-set boa ;
  83
  84 M: bit-set cardinality
  85     table>> bit-count ;