basis/compression/huffman/huffman.factor

   1 ! Copyright (C) 2009 Marc Fauconneau.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors arrays assocs fry\r
   4 hashtables io kernel locals math math.order math.parser\r
   5 math.ranges multiline sequences bitstreams bit-arrays ;\r
   6 IN: compression.huffman\r
   7 \r
   8 QUALIFIED-WITH: bitstreams bs\r
   9 \r
  10 <PRIVATE\r
  11 \r
  12 TUPLE: huffman-code\r
  13     { value fixnum }\r
  14     { size fixnum }\r
  15     { code fixnum } ;\r
  16 \r
  17 : <huffman-code> ( -- huffman-code )\r
  18     0 0 0 huffman-code boa ; inline\r
  19 \r
  20 : next-size ( huffman-code -- )\r
  21     [ 1 + ] change-size\r
  22     [ 2 * ] change-code drop ; inline\r
  23 \r
  24 : next-code ( huffman-code -- )\r
  25     [ 1 + ] change-code drop ; inline\r
  26 \r
  27 :: all-patterns ( huffman-code n -- seq )\r
  28     n log2 huffman-code size>> - :> free-bits\r
  29     free-bits 0 >\r
  30     [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]\r
  31     [ huffman-code code>> free-bits neg 2^ /i 1array ] if ;\r
  32 \r
  33 :: huffman-each ( tdesc quot: ( huffman-code -- ) -- )\r
  34     <huffman-code> :> code\r
  35     tdesc\r
  36     [\r
  37         code next-size\r
  38         [ code (>>value) code clone quot call code next-code ] each\r
  39     ] each ; inline\r
  40 \r
  41 : update-reverse-table ( huffman-code n table -- )\r
  42     [ drop all-patterns ]\r
  43     [ nip '[ _ swap _ set-at ] each ] 3bi ;\r
  44 \r
  45 :: reverse-table ( tdesc n -- rtable )\r
  46    n f <array> <enum> :> table\r
  47    tdesc [ n table update-reverse-table ] huffman-each\r
  48    table seq>> ;\r
  49 \r
  50 PRIVATE>\r
  51 \r
  52 TUPLE: huffman-decoder\r
  53     { bs bit-reader }\r
  54     { tdesc array }\r
  55     { rtable array }\r
  56     { bits/level fixnum } ;\r
  57 \r
  58 : <huffman-decoder> ( bs tdesc -- huffman-decoder )\r
  59     huffman-decoder new\r
  60         swap >>tdesc\r
  61         swap >>bs\r
  62         16 >>bits/level\r
  63         dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline\r
  64 \r
  65 : read1-huff ( huffman-decoder -- elt )\r
  66     16 over [ bs>> bs:peek ] [ rtable>> nth ] bi\r
  67     [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline\r
  68 \r
  69 : reverse-bits ( value bits -- value' )\r
  70     [ integer>bit-array ] dip\r
  71     f pad-tail reverse bit-array>integer ; inline\r
  72 \r
  73 : read1-huff2 ( huffman-decoder -- elt )\r
  74     16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi\r
  75     [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline\r