core/bit-arrays/bit-arrays.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math alien.accessors kernel kernel.private sequences
   4 sequences.private ;
   5 IN: bit-arrays
   6
   7 <PRIVATE
   8
   9 : n>byte -3 shift ; inline
  10
  11 : byte/bit ( n alien -- byte bit )
  12     over n>byte alien-unsigned-1 swap 7 bitand ; inline
  13
  14 : set-bit ( ? byte bit -- byte )
  15     2^ rot [ bitor ] [ bitnot bitand ] if ; inline
  16
  17 : bits>cells 31 + -5 shift ; inline
  18
  19 : (set-bits) ( bit-array n -- )
  20     over length bits>cells -rot [
  21         spin 4 * set-alien-unsigned-4
  22     ] 2curry each ; inline
  23
  24 PRIVATE>
  25
  26 M: bit-array length array-capacity ;
  27
  28 M: bit-array nth-unsafe
  29     >r >fixnum r> byte/bit bit? ;
  30
  31 M: bit-array set-nth-unsafe
  32     >r >fixnum r>
  33     [ byte/bit set-bit ] 2keep
  34     swap n>byte set-alien-unsigned-1 ;
  35
  36 : clear-bits ( bit-array -- ) 0 (set-bits) ;
  37
  38 : set-bits ( bit-array -- ) -1 (set-bits) ;
  39
  40 M: bit-array clone (clone) ;
  41
  42 : >bit-array ( seq -- bit-array ) ?{ } clone-like ; inline
  43
  44 M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
  45
  46 M: bit-array new-sequence drop <bit-array> ;
  47
  48 M: bit-array equal?
  49     over bit-array? [ sequence= ] [ 2drop f ] if ;
  50
  51 M: bit-array resize
  52     resize-bit-array ;
  53
  54 : integer>bit-array ( int -- bit-array )
  55     [ log2 1+ <bit-array> 0 ] keep
  56     [ dup zero? not ] [
  57         [ -8 shift ] [ 255 bitand ] bi
  58         -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip
  59     ] [ ] while
  60     2drop ;
  61
  62 : bit-array>integer ( bit-array -- int )
  63     dup >r length 7 + n>byte 0 r> [
  64         swap alien-unsigned-1 swap 8 shift bitor
  65     ] curry reduce ;
  66
  67 INSTANCE: bit-array sequence