basis/bit-arrays/bit-arrays.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types accessors math alien.accessors kernel
   4 kernel.private locals sequences sequences.private byte-arrays
   5 parser prettyprint.backend ;
   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 -3 shift ; inline
  15
  16 : byte/bit ( n alien -- byte bit )
  17     over n>byte alien-unsigned-1 swap 7 bitand ; inline
  18
  19 : set-bit ( ? byte bit -- byte )
  20     2^ rot [ bitor ] [ bitnot bitand ] if ; inline
  21
  22 : bits>cells 31 + -5 shift ; inline
  23
  24 : bits>bytes 7 + n>byte ; inline
  25
  26 : (set-bits) ( bit-array n -- )
  27     [ [ length bits>cells ] keep ] dip
  28     [ -rot underlying>> set-uint-nth ] 2curry
  29     each ; inline
  30
  31 PRIVATE>
  32
  33 : <bit-array> ( n -- bit-array )
  34     dup bits>bytes <byte-array> bit-array boa ; inline
  35
  36 M: bit-array length length>> ;
  37
  38 M: bit-array nth-unsafe
  39     [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
  40
  41 M: bit-array set-nth-unsafe
  42     [ >fixnum ] [ underlying>> ] bi*
  43     [ byte/bit set-bit ] 2keep
  44     swap n>byte set-alien-unsigned-1 ;
  45
  46 : clear-bits ( bit-array -- ) 0 (set-bits) ;
  47
  48 : set-bits ( bit-array -- ) -1 (set-bits) ;
  49
  50 M: bit-array clone
  51     [ length>> ] [ underlying>> clone ] bi bit-array boa ;
  52
  53 : >bit-array ( seq -- bit-array )
  54     T{ bit-array f 0 B{ } } clone-like ; inline
  55
  56 M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
  57
  58 M: bit-array new-sequence drop <bit-array> ;
  59
  60 M: bit-array equal?
  61     over bit-array? [ sequence= ] [ 2drop f ] if ;
  62
  63 M: bit-array resize
  64     [ drop ] [
  65         [ bits>bytes ] [ underlying>> ] bi*
  66         resize-byte-array
  67     ] 2bi
  68     bit-array boa ;
  69
  70 M: bit-array byte-length length 7 + -3 shift ;
  71
  72 : ?{ \ } [ >bit-array ] parse-literal ; parsing
  73
  74 :: integer>bit-array ( n -- bit-array )
  75     n zero? [ 0 <bit-array> ] [
  76         [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
  77             [ n' zero? not ] [
  78                 n' out underlying>> i set-alien-unsigned-1
  79                 n' -8 shift n'!
  80                 i 1+ i!
  81             ] [ ] while
  82             out
  83         ]
  84     ] if ;
  85
  86 : bit-array>integer ( bit-array -- n )
  87     0 swap underlying>> [ length ] keep [
  88         uchar-nth swap 8 shift bitor
  89     ] curry each ;
  90
  91 INSTANCE: bit-array sequence
  92
  93 M: bit-array pprint-delims drop \ ?{ \ } ;
  94 M: bit-array >pprint-sequence ;
  95 M: bit-array pprint* pprint-object ;