basis/nibble-arrays/nibble-arrays.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math kernel sequences sequences.private byte-arrays
   4 alien prettyprint.custom parser accessors locals ;
   5 IN: nibble-arrays
   6
   7 TUPLE: nibble-array
   8 { length array-capacity read-only }
   9 { underlying byte-array read-only } ;
  10
  11 <PRIVATE
  12
  13 CONSTANT: nibble 0b1111
  14
  15 : nibbles>bytes ( m -- n ) 1 + 2/ ; inline
  16
  17 : byte/nibble ( n -- shift n' )
  18     [ 1 bitand 2 shift ] [ -1 shift ] bi ; inline
  19
  20 : get-nibble ( n byte -- nibble )
  21     swap neg shift nibble bitand ; inline
  22
  23 :: set-nibble ( value n byte -- byte' )
  24     byte nibble n shift bitnot bitand
  25     value n shift
  26     bitor ; inline
  27
  28 : nibble@ ( n nibble-array -- shift n' byte-array )
  29     [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline
  30
  31 PRIVATE>
  32
  33 ERROR: bad-array-length n ;
  34
  35 : <nibble-array> ( n -- nibble-array )
  36     dup 0 < [ bad-array-length ] when
  37     dup nibbles>bytes <byte-array> nibble-array boa ; inline
  38
  39 M: nibble-array length length>> ;
  40
  41 M: nibble-array nth-unsafe
  42     nibble@ nth-unsafe get-nibble ;
  43
  44 M: nibble-array set-nth-unsafe
  45     nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ;
  46
  47 M: nibble-array clone
  48     [ length>> ] [ underlying>> clone ] bi nibble-array boa ;
  49
  50 : >nibble-array ( seq -- nibble-array )
  51     T{ nibble-array } clone-like ; inline
  52
  53 M: nibble-array like
  54     drop dup nibble-array? [ >nibble-array ] unless ;
  55
  56 M: nibble-array new-sequence drop <nibble-array> ;
  57
  58 M: nibble-array equal?
  59     over nibble-array? [ sequence= ] [ 2drop f ] if ;
  60
  61 M: nibble-array resize
  62     [ drop ] [
  63         [ nibbles>bytes ] [ underlying>> ] bi*
  64         resize-byte-array
  65     ] 2bi
  66     nibble-array boa ;
  67
  68 M: nibble-array byte-length length nibbles>bytes ;
  69
  70 SYNTAX: N{ \ } [ >nibble-array ] parse-literal ;
  71
  72 INSTANCE: nibble-array sequence
  73
  74 M: nibble-array pprint-delims drop \ N{ \ } ;
  75 M: nibble-array >pprint-sequence ;
  76 M: nibble-array pprint* pprint-object ;