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 ;\r
   6 IN: compression.huffman\r
   7 \r
   8 QUALIFIED-WITH: bitstreams bs\r
   9 \r
  10 <PRIVATE\r
  11 \r
  12 ! huffman codes\r
  13 \r
  14 TUPLE: huffman-code\r
  15     { value }\r
  16     { size }\r
  17     { code } ;\r
  18 \r
  19 : <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;\r
  20 : next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ;\r
  21 : next-code ( code -- ) [ 1 + ] change-code drop ;\r
  22 \r
  23 :: all-patterns ( huff n -- seq )\r
  24     n log2 huff size>> - :> free-bits\r
  25     free-bits 0 >\r
  26     [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]\r
  27     [ huff code>> free-bits neg 2^ /i 1array ] if ;\r
  28 \r
  29 :: huffman-each ( tdesc quot: ( huff -- ) -- )\r
  30     <huffman-code> :> code\r
  31     tdesc\r
  32     [\r
  33         code next-size\r
  34         [ code (>>value) code clone quot call code next-code ] each\r
  35     ] each ; inline\r
  36 \r
  37 : update-reverse-table ( huff n table -- )\r
  38     [ drop all-patterns ]\r
  39     [ nip '[ _ swap _ set-at ] each ] 3bi ;\r
  40 \r
  41 :: reverse-table ( tdesc n -- rtable )\r
  42    n f <array> <enum> :> table\r
  43    tdesc [ n table update-reverse-table ] huffman-each\r
  44    table seq>> ;\r
  45 \r
  46 :: huffman-table ( tdesc max -- table )\r
  47    max f <array> :> table\r
  48    tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each\r
  49    table ;\r
  50 \r
  51 PRIVATE>\r
  52 \r
  53 ! decoder\r
  54 \r
  55 TUPLE: huffman-decoder\r
  56     { bs }\r
  57     { tdesc }\r
  58     { rtable }\r
  59     { bits/level } ;\r
  60 \r
  61 : <huffman-decoder> ( bs tdesc -- decoder )\r
  62     huffman-decoder new\r
  63     swap >>tdesc\r
  64     swap >>bs\r
  65     16 >>bits/level\r
  66     [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;\r
  67 \r
  68 : read1-huff ( decoder -- elt )\r
  69     16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last\r
  70     [ size>> swap bs>> bs:seek ] [ value>> ] bi ;\r
  71 \r
  72 ! %remove\r
  73 : reverse-bits ( value bits -- value' )\r
  74     [ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;\r
  75 \r
  76 : read1-huff2 ( decoder -- elt )\r
  77     16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last\r
  78     [ size>> swap bs>> bs:seek ] [ value>> ] bi ;\r
  79 \r
  80 /*\r
  81 : huff>string ( code -- str )\r
  82     [ value>> number>string ]\r
  83     [ [ code>> ] [ size>> bits>string ] bi ] bi\r
  84     " = " glue ;\r
  85 \r
  86 : huff. ( code -- ) huff>string print ;\r
  87 \r
  88 :: rtable. ( rtable -- )\r
  89     rtable length>> log2 :> n\r
  90     rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;\r
  91 */\r