basis/compression/lzw/lzw.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators io kernel math math.order
   4 namespaces sequences vectors ;
   5 QUALIFIED-WITH: bitstreams bs
   6 IN: compression.lzw
   7
   8 TUPLE: lzw
   9 input
  10 output
  11 table
  12 code
  13 old-code
  14 initial-code-size
  15 code-size
  16 clear-code
  17 end-of-information-code ;
  18
  19 TUPLE: tiff-lzw < lzw ;
  20 TUPLE: gif-lzw < lzw ;
  21
  22 : initial-uncompress-table ( size -- seq )
  23     iota [ 1vector ] V{ } map-as ;
  24
  25 : reset-lzw-uncompress ( lzw -- lzw )
  26     dup end-of-information-code>> 1 + initial-uncompress-table >>table
  27     dup initial-code-size>> >>code-size ;
  28
  29 ERROR: code-size-zero ;
  30
  31 : <lzw-uncompress> ( input code-size class -- obj )
  32     new
  33         swap [ code-size-zero ] when-zero >>code-size
  34         dup code-size>> >>initial-code-size
  35         dup code-size>> 1 - 2^ >>clear-code
  36         dup clear-code>> 1 + >>end-of-information-code
  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 GENERIC: code-space-full? ( lzw -- ? )
  59
  60 : size-and-limit ( lzw -- m n ) [ table>> length ] [ code-size>> 2^ ] bi ;
  61
  62 M: tiff-lzw code-space-full? size-and-limit 1 - = ;
  63 M: gif-lzw code-space-full? size-and-limit = ;
  64
  65 GENERIC: increment-code-size ( lzw -- lzw )
  66
  67 M: lzw increment-code-size [ 1 + ] change-code-size ;
  68 M: gif-lzw increment-code-size [ 1 + 12 min ] change-code-size ;
  69
  70 : maybe-increment-code-size ( lzw -- lzw )
  71     dup code-space-full? [ increment-code-size ] when ;
  72
  73 : add-to-table ( seq lzw -- )
  74     [ table>> push ]
  75     [ maybe-increment-code-size 2drop ] 2bi ;
  76
  77 : lzw-read ( lzw -- lzw n )
  78     [ ] [ code-size>> ] [ input>> ] tri bs:read ;
  79
  80 : end-of-information? ( lzw code -- ? ) swap end-of-information-code>> = ;
  81 : clear-code? ( lzw code -- ? ) swap clear-code>> = ;
  82
  83 DEFER: handle-clear-code
  84 : lzw-process-next-code ( lzw quot: ( lzw code -- ) -- )
  85     [ lzw-read ] dip {
  86         { [ 2over end-of-information? ] [ 3drop ] }
  87         { [ 2over clear-code? ] [ 2drop handle-clear-code ] }
  88         [ call( lzw code -- ) ]
  89     } cond ; inline
  90
  91 DEFER: lzw-uncompress-char
  92 : handle-clear-code ( lzw -- )
  93     reset-lzw-uncompress
  94     [
  95         >>code
  96         [ write-code ]
  97         [ code>old-code ] bi
  98         lzw-uncompress-char
  99     ] lzw-process-next-code ;
 100
 101 : handle-uncompress-code ( lzw -- lzw )
 102     dup code-in-table? [
 103         [ write-code ]
 104         [
 105             [
 106                 [ lookup-old-code ]
 107                 [ lookup-code first ] bi suffix
 108             ] [ add-to-table ] bi
 109         ] [ code>old-code ] tri
 110     ] [
 111         [
 112             [ lookup-old-code dup first suffix ] keep
 113             [ output>> push-all ] [ add-to-table ] 2bi
 114         ] [ code>old-code ] bi
 115     ] if ;
 116
 117 : lzw-uncompress-char ( lzw -- )
 118     [ >>code handle-uncompress-code lzw-uncompress-char ]
 119     lzw-process-next-code ;
 120
 121 : lzw-uncompress ( bitstream code-size class -- byte-array )
 122     <lzw-uncompress>
 123     [ lzw-uncompress-char ] [ output>> ] bi ;
 124
 125 : tiff-lzw-uncompress ( seq -- byte-array )
 126     bs:<msb0-bit-reader> 9 tiff-lzw lzw-uncompress ;
 127
 128 : gif-lzw-uncompress ( seq code-size -- byte-array )
 129     [ bs:<lsb0-bit-reader> ] dip gif-lzw lzw-uncompress ;