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 BIN: 1111
  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 : <nibble-array> ( n -- nibble-array )
  34     dup nibbles>bytes <byte-array> nibble-array boa ; inline
  35
  36 M: nibble-array length length>> ;
  37
  38 M: nibble-array nth-unsafe
  39     nibble@ nth-unsafe get-nibble ;
  40
  41 M: nibble-array set-nth-unsafe
  42     nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ;
  43
  44 M: nibble-array clone
  45     [ length>> ] [ underlying>> clone ] bi nibble-array boa ;
  46
  47 : >nibble-array ( seq -- nibble-array )
  48     T{ nibble-array } clone-like ; inline
  49
  50 M: nibble-array like
  51     drop dup nibble-array? [ >nibble-array ] unless ;
  52
  53 M: nibble-array new-sequence drop <nibble-array> ;
  54
  55 M: nibble-array equal?
  56     over nibble-array? [ sequence= ] [ 2drop f ] if ;
  57
  58 M: nibble-array resize
  59     [ drop ] [
  60         [ nibbles>bytes ] [ underlying>> ] bi*
  61         resize-byte-array
  62     ] 2bi
  63     nibble-array boa ;
  64
  65 M: nibble-array byte-length length nibbles>bytes ;
  66
  67 SYNTAX: N{ \ } [ >nibble-array ] parse-literal ;
  68
  69 INSTANCE: nibble-array sequence
  70
  71 M: nibble-array pprint-delims drop \ N{ \ } ;
  72 M: nibble-array >pprint-sequence ;
  73 M: nibble-array pprint* pprint-object ;