basis/compression/lzw/lzw.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.accessors assocs byte-arrays combinators
   4 io.encodings.binary io.streams.byte-array kernel math sequences
   5 vectors ;
   6 IN: compression.lzw
   7
   8 QUALIFIED-WITH: bitstreams bs
   9
  10 CONSTANT: clear-code 256
  11 CONSTANT: end-of-information 257
  12
  13 TUPLE: lzw input output table code old-code ;
  14
  15 SYMBOL: table-full
  16
  17 : lzw-bit-width ( n -- n' )
  18     {
  19         { [ dup 510 <= ] [ drop 9 ] }
  20         { [ dup 1022 <= ] [ drop 10 ] }
  21         { [ dup 2046 <= ] [ drop 11 ] }
  22         { [ dup 4094 <= ] [ drop 12 ] }
  23         [ drop table-full ]
  24     } cond ;
  25
  26 : lzw-bit-width-uncompress ( lzw -- n )
  27     table>> length lzw-bit-width ;
  28
  29 : initial-uncompress-table ( -- seq )
  30     258 iota [ 1vector ] V{ } map-as ;
  31
  32 : reset-lzw-uncompress ( lzw -- lzw )
  33     initial-uncompress-table >>table ;
  34
  35 : <lzw-uncompress> ( input -- obj )
  36     lzw new
  37         swap >>input
  38         BV{ } clone >>output
  39         reset-lzw-uncompress ;
  40
  41 ERROR: not-in-table value ;
  42
  43 : lookup-old-code ( lzw -- vector )
  44     [ old-code>> ] [ table>> ] bi nth ;
  45
  46 : lookup-code ( lzw -- vector )
  47     [ code>> ] [ table>> ] bi nth ;
  48
  49 : code-in-table? ( lzw -- ? )
  50     [ code>> ] [ table>> length ] bi < ;
  51
  52 : code>old-code ( lzw -- lzw )
  53     dup code>> >>old-code ;
  54
  55 : write-code ( lzw -- )
  56     [ lookup-code ] [ output>> ] bi push-all ;
  57
  58 : add-to-table ( seq lzw -- ) table>> push ;
  59
  60 : lzw-read ( lzw -- lzw n )
  61     [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
  62
  63 DEFER: lzw-uncompress-char
  64 : handle-clear-code ( lzw -- )
  65     reset-lzw-uncompress
  66     lzw-read dup end-of-information = [
  67         2drop
  68     ] [
  69         >>code
  70         [ write-code ]
  71         [ code>old-code ] bi
  72         lzw-uncompress-char
  73     ] if ;
  74
  75 : handle-uncompress-code ( lzw -- lzw )
  76     dup code-in-table? [
  77         [ write-code ]
  78         [
  79             [
  80                 [ lookup-old-code ]
  81                 [ lookup-code first ] bi suffix
  82             ] [ add-to-table ] bi
  83         ] [ code>old-code ] tri
  84     ] [
  85         [
  86             [ lookup-old-code dup first suffix ] keep
  87             [ output>> push-all ] [ add-to-table ] 2bi
  88         ] [ code>old-code ] bi
  89     ] if ;
  90
  91 : lzw-uncompress-char ( lzw -- )
  92     lzw-read [
  93         >>code
  94         dup code>> end-of-information = [
  95             drop
  96         ] [
  97             dup code>> clear-code = [
  98                 handle-clear-code
  99             ] [
 100                 handle-uncompress-code
 101                 lzw-uncompress-char
 102             ] if
 103         ] if
 104     ] [
 105         drop
 106     ] if* ;
 107
 108 : lzw-uncompress ( seq -- byte-array )
 109     bs:<msb0-bit-reader>
 110     <lzw-uncompress>
 111     [ lzw-uncompress-char ] [ output>> ] bi ;