basis/bit-arrays/bit-arrays.factor

   1 ! Copyright (C) 2007, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors byte-arrays io.binary
   4 kernel kernel.private math math.bitwise parser sequences
   5 sequences.private vocabs.loader ;
   6 IN: bit-arrays
   7
   8 TUPLE: bit-array
   9     { length array-capacity read-only }
  10     { underlying byte-array read-only } ;
  11
  12 <PRIVATE
  13
  14 : n>byte ( m -- n ) -3 shift ; inline
  15
  16 : bit/byte ( n -- bit byte ) [ 7 bitand ] [ n>byte ] bi ; inline
  17
  18 : bit-index ( n bit-array -- bit# byte# byte-array )
  19     [ { integer-array-capacity } declare integer>fixnum bit/byte ]
  20     [ underlying>> ] bi* ; inline
  21
  22 : bits>cells ( m -- n ) 31 + -5 shift ; inline
  23
  24 : bits>bytes ( m -- n ) 7 + n>byte ; inline
  25
  26 : (set-bits) ( bit-array n -- )
  27     [ [ length bits>cells ] keep ] dip swap underlying>>
  28     '[ [ _ _ ] dip 4 * set-alien-unsigned-4 ] each-integer ; inline
  29
  30 : zero-end-bits ( bit-array -- bit-array )
  31     ! Zero bits after the end.
  32     dup underlying>> [ ] [
  33         [
  34             length 8 * over length -
  35             8 swap - -1 swap shift bitnot
  36         ]
  37         [ last bitand ]
  38         [ set-last ]
  39         tri
  40     ] if-empty ; inline
  41
  42 :: toggle-bit ( ? n x -- y )
  43     x n ? [ set-bit ] [ clear-bit ] if ; inline
  44
  45 PRIVATE>
  46
  47 ERROR: bad-array-length n ;
  48
  49 : <bit-array> ( n -- bit-array )
  50     dup 0 < [ bad-array-length ] when
  51     dup bits>bytes <byte-array>
  52     bit-array boa ; inline
  53
  54 M: bit-array length length>> ; inline
  55
  56 M: bit-array nth-unsafe
  57     bit-index nth-unsafe swap bit? ; inline
  58
  59 M: bit-array set-nth-unsafe
  60     bit-index [ toggle-bit ] change-nth-unsafe ; inline
  61
  62 GENERIC: clear-bits ( bit-array -- )
  63
  64 M: bit-array clear-bits 0 (set-bits) ; inline
  65
  66 GENERIC: set-bits ( bit-array -- )
  67
  68 M: bit-array set-bits -1 (set-bits) ; inline
  69
  70 M: bit-array clone
  71     [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
  72
  73 : >bit-array ( seq -- bit-array )
  74     T{ bit-array f 0 B{ } } clone-like ; inline
  75
  76 M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
  77
  78 M: bit-array new-sequence drop <bit-array> ; inline
  79
  80 M: bit-array equal?
  81     over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
  82
  83 M: bit-array resize
  84     dupd [ bits>bytes ] [ underlying>> ] bi*
  85     resize-byte-array bit-array boa zero-end-bits ; inline
  86
  87 M: bit-array byte-length length bits>bytes ; inline
  88
  89 SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
  90
  91 : integer>bit-array ( n -- bit-array )
  92     dup 0 =
  93     [ <bit-array> ]
  94     [ dup log2 1 + [ nip ] [ bits>bytes >le ] 2bi bit-array boa ] if ;
  95
  96 : bit-array>integer ( bit-array -- n )
  97     underlying>> le> ;
  98
  99 INSTANCE: bit-array sequence
 100
 101 { "bit-arrays" "prettyprint" } "bit-arrays.prettyprint" require-when