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 sequences sequences.private byte-arrays
   5 parser prettyprint.custom fry ;
   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 : 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 ( 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     '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
  29
  30 : clean-up ( bit-array -- )
  31     ! Zero bits after the end.
  32     dup underlying>> empty? [ drop ] [
  33         [
  34             [ underlying>> length 8 * ] [ length ] bi -
  35             8 swap - -1 swap shift bitnot
  36         ]
  37         [ underlying>> last bitand ]
  38         [ underlying>> set-last ]
  39         tri
  40     ] if ; inline
  41
  42 PRIVATE>
  43
  44 : <bit-array> ( n -- bit-array )
  45     dup bits>bytes <byte-array> bit-array boa ; inline
  46
  47 M: bit-array length length>> ;
  48
  49 M: bit-array nth-unsafe
  50     [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
  51
  52 M: bit-array set-nth-unsafe
  53     [ >fixnum ] [ underlying>> ] bi*
  54     [ byte/bit set-bit ] 2keep
  55     swap n>byte set-alien-unsigned-1 ;
  56
  57 GENERIC: clear-bits ( bit-array -- )
  58
  59 M: bit-array clear-bits 0 (set-bits) ;
  60
  61 GENERIC: set-bits ( bit-array -- )
  62
  63 M: bit-array set-bits -1 (set-bits) ;
  64
  65 M: bit-array clone
  66     [ length>> ] [ underlying>> clone ] bi bit-array boa ;
  67
  68 : >bit-array ( seq -- bit-array )
  69     T{ bit-array f 0 B{ } } clone-like ; inline
  70
  71 M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
  72
  73 M: bit-array new-sequence drop <bit-array> ;
  74
  75 M: bit-array equal?
  76     over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
  77
  78 M: bit-array resize
  79     [ drop ] [
  80         [ bits>bytes ] [ underlying>> ] bi*
  81         resize-byte-array
  82     ] 2bi
  83     bit-array boa
  84     dup clean-up ;
  85
  86 M: bit-array byte-length length 7 + -3 shift ;
  87
  88 SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
  89
  90 : integer>bit-array ( n -- bit-array )
  91     dup 0 = [
  92         <bit-array>
  93     ] [
  94         [ log2 1 + <bit-array> 0 ] keep
  95         [ dup 0 = ] [
  96             [ pick underlying>> pick set-alien-unsigned-1 ] keep
  97             [ 1 + ] [ -8 shift ] bi*
  98         ] until 2drop
  99     ] if ;
 100
 101 : bit-array>integer ( bit-array -- n )
 102     0 swap underlying>> dup length <reversed> [
 103         alien-unsigned-1 swap 8 shift bitor
 104     ] with each ;
 105
 106 INSTANCE: bit-array sequence
 107
 108 M: bit-array pprint-delims drop \ ?{ \ } ;
 109 M: bit-array >pprint-sequence ;
 110 M: bit-array pprint* pprint-object ;