basis/nibble-arrays/nibble-arrays.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math kernel sequences sequences.private byte-arrays
   4 alien.c-types prettyprint.custom parser accessors ;
   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 : nibble BIN: 1111 ; inline
  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     nibble pick shift bitnot bitand -rot shift bitor ; inline
  25
  26 : nibble@ ( n nibble-array -- shift n' byte-array )
  27     [ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline
  28
  29 PRIVATE>
  30
  31 : <nibble-array> ( n -- nibble-array )
  32     dup nibbles>bytes <byte-array> nibble-array boa ; inline
  33
  34 M: nibble-array length length>> ;
  35
  36 M: nibble-array nth-unsafe
  37     nibble@ nth-unsafe get-nibble ;
  38
  39 M: nibble-array set-nth-unsafe
  40     nibble@ [ nth-unsafe set-nibble ] 2keep set-nth-unsafe ;
  41
  42 M: nibble-array clone
  43     [ length>> ] [ underlying>> clone ] bi nibble-array boa ;
  44
  45 : >nibble-array ( seq -- nibble-array )
  46     T{ nibble-array } clone-like ; inline
  47
  48 M: nibble-array like
  49     drop dup nibble-array? [ >nibble-array ] unless ;
  50
  51 M: nibble-array new-sequence drop <nibble-array> ;
  52
  53 M: nibble-array equal?
  54     over nibble-array? [ sequence= ] [ 2drop f ] if ;
  55
  56 M: nibble-array resize
  57     [ drop ] [
  58         [ nibbles>bytes ] [ underlying>> ] bi*
  59         resize-byte-array
  60     ] 2bi
  61     nibble-array boa ;
  62
  63 M: nibble-array byte-length length nibbles>bytes ;
  64
  65 : N{ \ } [ >nibble-array ] parse-literal ; parsing
  66
  67 INSTANCE: nibble-array sequence
  68
  69 M: nibble-array pprint-delims drop \ N{ \ } ;
  70 M: nibble-array >pprint-sequence ;
  71 M: nibble-array pprint* pprint-object ;