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 namespaces
   4 prettyprint sequences vectors ;
   5 QUALIFIED-WITH: bitstreams bs
   6 IN: compression.lzw
   7
   8 SYMBOL: current-lzw
   9
  10 TUPLE: lzw
  11 input
  12 output
  13 table
  14 code
  15 old-code
  16 initial-code-size
  17 code-size
  18 clear-code
  19 end-of-information-code ;
  20
  21 TUPLE: tiff-lzw < lzw ;
  22 TUPLE: gif-lzw < lzw ;
  23
  24 : initial-uncompress-table ( -- seq )
  25     current-lzw get end-of-information-code>> 1 +
  26     iota [ 1vector ] V{ } map-as ;
  27
  28 : reset-lzw-uncompress ( lzw -- lzw )
  29     initial-uncompress-table >>table
  30     dup initial-code-size>> >>code-size ;
  31
  32 : <lzw-uncompress> ( input code-size class -- obj )
  33     new
  34         swap >>code-size
  35         dup code-size>> >>initial-code-size
  36         dup code-size>> 1 - 2^ >>clear-code
  37         dup clear-code>> 1 + >>end-of-information-code
  38         swap >>input
  39         BV{ } clone >>output ;
  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 M: tiff-lzw code-space-full?
  61     [ table>> length ] [ code-size>> 2^ 1 - ] bi = ;
  62
  63 M: gif-lzw code-space-full?
  64     [ table>> length ] [ code-size>> 2^ ] bi = ;
  65
  66 : maybe-increment-code-size ( lzw -- lzw )
  67     dup code-space-full? [ [ 1 + ] change-code-size ] when ;
  68
  69 : add-to-table ( seq lzw -- )
  70     [ table>> push ]
  71     [ maybe-increment-code-size 2drop ] 2bi ;
  72
  73 : lzw-read ( lzw -- lzw n )
  74     [ ] [ code-size>> ] [ input>> ] tri bs:read ;
  75
  76 DEFER: lzw-uncompress-char
  77 : handle-clear-code ( lzw -- )
  78     reset-lzw-uncompress
  79     lzw-read dup current-lzw get end-of-information-code>> = [
  80         2drop
  81     ] [
  82         >>code
  83         [ write-code ]
  84         [ code>old-code ] bi
  85         lzw-uncompress-char
  86     ] if ;
  87
  88 : handle-uncompress-code ( lzw -- lzw )
  89     dup code-in-table? [
  90         [ write-code ]
  91         [
  92             [
  93                 [ lookup-old-code ]
  94                 [ lookup-code first ] bi suffix
  95             ] [ add-to-table ] bi
  96         ] [ code>old-code ] tri
  97     ] [
  98         [
  99             [ lookup-old-code dup first suffix ] keep
 100             [ output>> push-all ] [ add-to-table ] 2bi
 101         ] [ code>old-code ] bi
 102     ] if ;
 103
 104 : lzw-uncompress-char ( lzw -- )
 105     lzw-read [
 106         >>code
 107         dup code>> current-lzw get end-of-information-code>> = [
 108             drop
 109         ] [
 110             dup code>> current-lzw get clear-code>> = [
 111                 handle-clear-code
 112             ] [
 113                 handle-uncompress-code
 114                 lzw-uncompress-char
 115             ] if
 116         ] if
 117     ] [
 118         drop
 119     ] if* ;
 120
 121 : lzw-uncompress ( bitstream code-size class -- byte-array )
 122     <lzw-uncompress> dup current-lzw [
 123         [ reset-lzw-uncompress drop ] [ lzw-uncompress-char ] [ output>> ] tri
 124     ] with-variable ;
 125
 126 : tiff-lzw-uncompress ( seq -- byte-array )
 127     bs:<msb0-bit-reader> 9 tiff-lzw lzw-uncompress ;
 128
 129 : gif-lzw-uncompress ( seq code-size -- byte-array )
 130     [ bs:<lsb0-bit-reader> ] dip gif-lzw lzw-uncompress ;