steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compression.lzw: supports both TIFF and GIF

db4
Keith Lazuka 2009-09-25 16:51:47 -04:00
parent 64c93d873f
commit 8dec2070e5
5 changed files with 46 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
basis/compression/lzw/lzw.factor
View File

@ -5,28 +5,38 @@ prettyprint sequences vectors ;
QUALIFIED-WITH: bitstreams bs QUALIFIED-WITH: bitstreams bs
IN: compression.lzw IN: compression.lzw
SYMBOL: clear-code SYMBOL: current-lzw
4 clear-code set-global
SYMBOL: end-of-information TUPLE: lzw
5 end-of-information set-global input
output
table
code
old-code
initial-code-size
code-size
clear-code
end-of-information-code ;
TUPLE: lzw input output table code old-code initial-code-size code-size ; TUPLE: tiff-lzw < lzw ;
TUPLE: gif-lzw < lzw ;
: initial-uncompress-table ( -- seq ) : initial-uncompress-table ( -- seq )
end-of-information get 1 + iota [ 1vector ] V{ } map-as ; current-lzw get end-of-information-code>> 1 +
iota [ 1vector ] V{ } map-as ;
: reset-lzw-uncompress ( lzw -- lzw ) : reset-lzw-uncompress ( lzw -- lzw )
initial-uncompress-table >>table initial-uncompress-table >>table
dup initial-code-size>> >>code-size ; dup initial-code-size>> >>code-size ;
: <lzw-uncompress> ( input code-size -- obj ) : <lzw-uncompress> ( input code-size class -- obj )
lzw new new
swap >>initial-code-size swap >>code-size
dup initial-code-size>> >>code-size dup code-size>> >>initial-code-size
dup code-size>> 1 - 2^ >>clear-code
dup clear-code>> 1 + >>end-of-information-code
swap >>input swap >>input
BV{ } clone >>output BV{ } clone >>output ;
reset-lzw-uncompress ;
ERROR: not-in-table value ; ERROR: not-in-table value ;
@ -45,15 +55,16 @@ ERROR: not-in-table value ;
: write-code ( lzw -- ) : write-code ( lzw -- )
[ lookup-code ] [ output>> ] bi push-all ; [ lookup-code ] [ output>> ] bi push-all ;
: kdebug ( lzw -- lzw ) GENERIC: code-space-full? ( lzw -- ? )
dup "TIFF: incrementing code size " write
[ code-size>> pprint ] M: tiff-lzw code-space-full?
[ " table length " write table>> length pprint ] bi [ table>> length ] [ code-size>> 2^ 1 - ] bi = ;
nl ;
M: gif-lzw code-space-full?
[ table>> length ] [ code-size>> 2^ ] bi = ;
: maybe-increment-code-size ( lzw -- lzw ) : maybe-increment-code-size ( lzw -- lzw )
dup [ table>> length ] [ code-size>> 2^ 1 - ] bi = dup code-space-full? [ [ 1 + ] change-code-size ] when ;
[ kdebug [ 1 + ] change-code-size ] when ;
: add-to-table ( seq lzw -- ) : add-to-table ( seq lzw -- )
[ table>> push ] [ table>> push ]
@ -64,9 +75,8 @@ ERROR: not-in-table value ;
DEFER: lzw-uncompress-char DEFER: lzw-uncompress-char
: handle-clear-code ( lzw -- ) : handle-clear-code ( lzw -- )
"CLEAR CODE" print
reset-lzw-uncompress reset-lzw-uncompress
lzw-read dup end-of-information get = [ lzw-read dup current-lzw get end-of-information-code>> = [
2drop 2drop
] [ ] [
>>code >>code
@ -94,10 +104,10 @@ DEFER: lzw-uncompress-char
: lzw-uncompress-char ( lzw -- ) : lzw-uncompress-char ( lzw -- )
lzw-read [ lzw-read [
>>code >>code
dup code>> end-of-information get = [ dup code>> current-lzw get end-of-information-code>> = [
drop drop
] [ ] [
dup code>> clear-code get = [ dup code>> current-lzw get clear-code>> = [
handle-clear-code handle-clear-code
] [ ] [
handle-uncompress-code handle-uncompress-code
@ -108,19 +118,13 @@ DEFER: lzw-uncompress-char
drop drop
] if* ; ] if* ;
: register-special-codes ( first-code-size -- first-code-size ) : lzw-uncompress ( bitstream code-size class -- byte-array )
[ <lzw-uncompress> dup current-lzw [
1 - 2^ dup clear-code set [ reset-lzw-uncompress drop ] [ lzw-uncompress-char ] [ output>> ] tri
1 + end-of-information set ] with-variable ;
] keep ;
: lzw-uncompress ( bitstream code-size -- byte-array ) : tiff-lzw-uncompress ( seq -- byte-array )
register-special-codes bs:<msb0-bit-reader> 9 tiff-lzw lzw-uncompress ;
<lzw-uncompress>
[ lzw-uncompress-char ] [ output>> ] bi ;
: lzw-uncompress-msb0 ( seq code-size -- byte-array ) : gif-lzw-uncompress ( seq code-size -- byte-array )
[ bs:<msb0-bit-reader> ] dip lzw-uncompress ; [ bs:<lsb0-bit-reader> ] dip gif-lzw lzw-uncompress ;
: lzw-uncompress-lsb0 ( seq code-size -- byte-array )
[ bs:<lsb0-bit-reader> ] dip lzw-uncompress ;

5
basis/images/tiff/tiff.factor
View File

@ -434,13 +434,10 @@ ERROR: bad-small-ifd-type n ;
ERROR: unhandled-compression compression ; ERROR: unhandled-compression compression ;
: lzw-tiff-uncompress ( seq -- byte-array )
9 lzw-uncompress-msb0 ;
: (uncompress-strips) ( strips compression -- uncompressed-strips ) : (uncompress-strips) ( strips compression -- uncompressed-strips )
{ {
{ compression-none [ ] } { compression-none [ ] }
{ compression-lzw [ [ lzw-tiff-uncompress ] map ] } { compression-lzw [ [ tiff-lzw-uncompress ] map ] }
[ unhandled-compression ] [ unhandled-compression ]
} case ; } case ;

126
extra/compression/lzw-gif/lzw-gif.factor
View File

@ -1,126 +0,0 @@
! Copyright (C) 2009 Doug Coleman, Keith Lazuka
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io kernel math namespaces
prettyprint sequences vectors ;
QUALIFIED-WITH: bitstreams bs
IN: compression.lzw-gif
SYMBOL: clear-code
4 clear-code set-global
SYMBOL: end-of-information
5 end-of-information set-global
TUPLE: lzw input output table code old-code initial-code-size code-size ;
: initial-uncompress-table ( -- seq )
end-of-information get 1 + iota [ 1vector ] V{ } map-as ;
: reset-lzw-uncompress ( lzw -- lzw )
initial-uncompress-table >>table
dup initial-code-size>> >>code-size ;
: <lzw-uncompress> ( input code-size -- obj )
lzw new
swap >>initial-code-size
dup initial-code-size>> >>code-size
swap >>input
BV{ } clone >>output
reset-lzw-uncompress ;
ERROR: not-in-table value ;
: lookup-old-code ( lzw -- vector )
[ old-code>> ] [ table>> ] bi nth ;
: lookup-code ( lzw -- vector )
[ code>> ] [ table>> ] bi nth ;
: code-in-table? ( lzw -- ? )
[ code>> ] [ table>> length ] bi < ;
: code>old-code ( lzw -- lzw )
dup code>> >>old-code ;
: write-code ( lzw -- )
[ lookup-code ] [ output>> ] bi push-all ;
: kdebug ( lzw -- lzw )
dup "GIF: incrementing code size " write
[ code-size>> pprint ]
[ " table length " write table>> length pprint ] bi
nl ;
: maybe-increment-code-size ( lzw -- lzw )
dup [ table>> length ] [ code-size>> 2^ ] bi =
[ kdebug [ 1 + ] change-code-size ] when ;
: add-to-table ( seq lzw -- )
[ table>> push ]
[ maybe-increment-code-size 2drop ] 2bi ;
: lzw-read ( lzw -- lzw n )
[ ] [ code-size>> ] [ input>> ] tri bs:read ;
DEFER: lzw-uncompress-char
: handle-clear-code ( lzw -- )
"CLEAR CODE" print
reset-lzw-uncompress
lzw-read dup end-of-information get = [
2drop
] [
>>code
[ write-code ]
[ code>old-code ] bi
lzw-uncompress-char
] if ;
: handle-uncompress-code ( lzw -- lzw )
dup code-in-table? [
[ write-code ]
[
[
[ lookup-old-code ]
[ lookup-code first ] bi suffix
] [ add-to-table ] bi
] [ code>old-code ] tri
] [
[
[ lookup-old-code dup first suffix ] keep
[ output>> push-all ] [ add-to-table ] 2bi
] [ code>old-code ] bi
] if ;
: lzw-uncompress-char ( lzw -- )
lzw-read [
>>code
dup code>> end-of-information get = [
drop
] [
dup code>> clear-code get = [
handle-clear-code
] [
handle-uncompress-code
lzw-uncompress-char
] if
] if
] [
drop
] if* ;
: register-special-codes ( first-code-size -- first-code-size )
[
1 - 2^ dup clear-code set
1 + end-of-information set
] keep ;
: lzw-uncompress ( bitstream code-size -- byte-array )
register-special-codes
<lzw-uncompress>
[ lzw-uncompress-char ] [ output>> ] bi ;
: lzw-uncompress-msb0 ( seq code-size -- byte-array )
[ bs:<msb0-bit-reader> ] dip lzw-uncompress ;
: lzw-uncompress-lsb0 ( seq code-size -- byte-array )
[ bs:<lsb0-bit-reader> ] dip lzw-uncompress ;

4
extra/images/gif/gif-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Keith Lazuka. ! Copyright (C) 2009 Keith Lazuka.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors bitstreams compression.lzw-gif images.gif io USING: accessors bitstreams compression.lzw images.gif io
io.encodings.binary io.files kernel math math.bitwise io.encodings.binary io.files kernel math math.bitwise
math.parser namespaces prettyprint sequences tools.test images.viewer ; math.parser namespaces prettyprint sequences tools.test images.viewer ;
QUALIFIED-WITH: bitstreams bs QUALIFIED-WITH: bitstreams bs
@ -49,7 +49,7 @@ IN: images.gif.tests
: >index-stream ( gif -- seq ) : >index-stream ( gif -- seq )
[ compressed-bytes>> ] [ compressed-bytes>> ]
[ image-descriptor>> first-code-size>> ] bi [ image-descriptor>> first-code-size>> ] bi
lzw-uncompress-lsb0 ; gif-lzw-uncompress ;
[ [
BV{ BV{

4
extra/images/gif/gif.factor
View File

@ -1,6 +1,6 @@
! Copyrigt (C) 2009 Doug Coleman. ! Copyrigt (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators compression.lzw-gif USING: accessors arrays assocs combinators compression.lzw
constructors destructors grouping images images.loader io constructors destructors grouping images images.loader io
io.binary io.buffers io.encodings.binary io.encodings.string io.binary io.buffers io.encodings.binary io.encodings.string
io.encodings.utf8 io.files io.files.info io.ports io.encodings.utf8 io.files io.files.info io.ports
@ -227,7 +227,7 @@ ERROR: unhandled-data byte ;
: decompress ( loading-gif -- indexes ) : decompress ( loading-gif -- indexes )
[ compressed-bytes>> ] [ compressed-bytes>> ]
[ image-descriptor>> first-code-size>> ] bi [ image-descriptor>> first-code-size>> ] bi
lzw-uncompress-lsb0 ; gif-lzw-uncompress ;
: colorize ( index palette transparent-index/f -- seq ) : colorize ( index palette transparent-index/f -- seq )
pick = [ 2drop B{ 0 0 0 0 } ] [ nth 255 suffix ] if ; pick = [ 2drop B{ 0 0 0 0 } ] [ nth 255 suffix ] if ;