Merge branch 'master' of factorcode.org:/git/factor
Joe Groff
commit
5a1452b72c
|
|
@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
|
|||
io.streams.byte-array ;
|
||||
IN: bitstreams.tests
|
||||
|
||||
[ 1 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
|
||||
|
||||
[ 254 8 t ]
|
||||
[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 4095 12 t ]
|
||||
[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
|
||||
[ B{ 254 } ]
|
||||
[ BIN: 1111111111 ]
|
||||
[
|
||||
binary <byte-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
10 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 t ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
[ BIN: 111111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
9 swap peek
|
||||
] unit-test
|
||||
|
||||
[ 255 8 f ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
|
||||
[ BIN: 11111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
8 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 1111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
7 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 111111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
6 swap peek
|
||||
] unit-test
|
||||
|
||||
[ BIN: 11111 ]
|
||||
[
|
||||
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
|
||||
2 >>byte-pos 6 >>bit-pos
|
||||
5 swap peek
|
||||
] unit-test
|
||||
|
||||
[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
|
||||
[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
|
||||
|
||||
[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,96 +1,157 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays destructors fry io kernel locals
|
||||
math sequences ;
|
||||
USING: accessors alien.accessors assocs byte-arrays combinators
|
||||
constructors destructors fry io io.binary io.encodings.binary
|
||||
io.streams.byte-array kernel locals macros math math.ranges
|
||||
multiline sequences sequences.private vectors byte-vectors
|
||||
combinators.short-circuit math.bitwise ;
|
||||
IN: bitstreams
|
||||
|
||||
TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
|
||||
TUPLE: bitstream-reader < bitstream ;
|
||||
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
|
||||
|
||||
: reset-bitstream ( stream -- stream )
|
||||
0 >>#bits 0 >>current-bits ; inline
|
||||
ERROR: invalid-widthed bits #bits ;
|
||||
|
||||
: new-bitstream ( stream class -- bitstream )
|
||||
: check-widthed ( bits #bits -- bits #bits )
|
||||
dup 0 < [ invalid-widthed ] when
|
||||
2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when
|
||||
over 0 = [
|
||||
2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when
|
||||
] unless ;
|
||||
|
||||
: <widthed> ( bits #bits -- widthed )
|
||||
check-widthed
|
||||
widthed boa ;
|
||||
|
||||
: zero-widthed ( -- widthed ) 0 0 <widthed> ;
|
||||
: zero-widthed? ( widthed -- ? ) zero-widthed = ;
|
||||
|
||||
TUPLE: bit-reader
|
||||
{ bytes byte-array }
|
||||
{ byte-pos array-capacity initial: 0 }
|
||||
{ bit-pos array-capacity initial: 0 } ;
|
||||
|
||||
TUPLE: bit-writer
|
||||
{ bytes byte-vector }
|
||||
{ widthed widthed } ;
|
||||
|
||||
TUPLE: msb0-bit-reader < bit-reader ;
|
||||
TUPLE: lsb0-bit-reader < bit-reader ;
|
||||
CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
|
||||
CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
|
||||
|
||||
TUPLE: msb0-bit-writer < bit-writer ;
|
||||
TUPLE: lsb0-bit-writer < bit-writer ;
|
||||
|
||||
: new-bit-writer ( class -- bs )
|
||||
new
|
||||
swap >>stream
|
||||
reset-bitstream ; inline
|
||||
BV{ } clone >>bytes
|
||||
0 0 <widthed> >>widthed ; inline
|
||||
|
||||
M: bitstream-reader dispose ( stream -- )
|
||||
stream>> dispose ;
|
||||
: <msb0-bit-writer> ( -- bs )
|
||||
msb0-bit-writer new-bit-writer ;
|
||||
|
||||
: <bitstream-reader> ( stream -- bitstream )
|
||||
bitstream-reader new-bitstream ; inline
|
||||
: <lsb0-bit-writer> ( -- bs )
|
||||
lsb0-bit-writer new-bit-writer ;
|
||||
|
||||
: read-next-byte ( bitstream -- bitstream )
|
||||
dup stream>> stream-read1 [
|
||||
>>current-bits 8 >>#bits
|
||||
GENERIC: peek ( n bitstream -- value )
|
||||
GENERIC: poke ( value n bitstream -- )
|
||||
|
||||
: seek ( n bitstream -- )
|
||||
{
|
||||
[ byte-pos>> 8 * ]
|
||||
[ bit-pos>> + + 8 /mod ]
|
||||
[ (>>bit-pos) ]
|
||||
[ (>>byte-pos) ]
|
||||
} cleave ; inline
|
||||
|
||||
: read ( n bitstream -- value )
|
||||
[ peek ] [ seek ] 2bi ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: not-enough-bits widthed n ;
|
||||
|
||||
: widthed-bits ( widthed n -- bits )
|
||||
dup 0 < [ not-enough-bits ] when
|
||||
2dup [ #bits>> ] dip < [ not-enough-bits ] when
|
||||
[ [ bits>> ] [ #bits>> ] bi ] dip
|
||||
[ - neg shift ] keep <widthed> ;
|
||||
|
||||
: split-widthed ( widthed n -- widthed1 widthed2 )
|
||||
2dup [ #bits>> ] dip < [
|
||||
drop zero-widthed
|
||||
] [
|
||||
0 >>#bits
|
||||
t >>end-of-stream?
|
||||
] if* ;
|
||||
|
||||
: maybe-read-next-byte ( bitstream -- bitstream )
|
||||
dup #bits>> 0 = [ read-next-byte ] when ; inline
|
||||
|
||||
: shift-one-bit ( bitstream -- n )
|
||||
[ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
|
||||
|
||||
: next-bit ( bitstream -- n/f ? )
|
||||
maybe-read-next-byte
|
||||
dup end-of-stream?>> [
|
||||
drop f
|
||||
] [
|
||||
[ shift-one-bit ]
|
||||
[ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
|
||||
] if dup >boolean ;
|
||||
|
||||
: read-bit ( bitstream -- n ? )
|
||||
dup #bits>> 1 = [
|
||||
[ current-bits>> 1 bitand ]
|
||||
[ read-next-byte drop ] bi t
|
||||
] [
|
||||
next-bit
|
||||
] if ; inline
|
||||
|
||||
: bits>integer ( seq -- n )
|
||||
0 [ [ 1 shift ] dip bitor ] reduce ; inline
|
||||
|
||||
: read-bits ( width bitstream -- n width ? )
|
||||
[
|
||||
'[ _ read-bit drop ] replicate
|
||||
[ f = ] trim-tail
|
||||
[ bits>integer ] [ length ] bi
|
||||
] 2keep drop over = ;
|
||||
|
||||
TUPLE: bitstream-writer < bitstream ;
|
||||
|
||||
: <bitstream-writer> ( stream -- bitstream )
|
||||
bitstream-writer new-bitstream ; inline
|
||||
|
||||
: write-bit ( n bitstream -- )
|
||||
[ 1 shift bitor ] change-current-bits
|
||||
[ 1+ ] change-#bits
|
||||
dup #bits>> 8 = [
|
||||
[ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
|
||||
[ reset-bitstream drop ] bi
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
ERROR: invalid-bit-width n ;
|
||||
|
||||
:: write-bits ( n width bitstream -- )
|
||||
n 0 < [ n invalid-bit-width ] when
|
||||
n 0 = [
|
||||
width [ 0 bitstream write-bit ] times
|
||||
] [
|
||||
width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
|
||||
n-length [
|
||||
n-length swap - 1- neg n swap shift 1 bitand
|
||||
bitstream write-bit
|
||||
] each
|
||||
[ widthed-bits ]
|
||||
[ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
|
||||
] if ;
|
||||
|
||||
: flush-bits ( bitstream -- ) stream>> stream-flush ;
|
||||
: widthed>bytes ( widthed -- bytes widthed )
|
||||
[ 8 split-widthed dup zero-widthed? not ]
|
||||
[ swap bits>> ] B{ } produce-as nip swap ;
|
||||
|
||||
: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
|
||||
:: |widthed ( widthed1 widthed2 -- widthed3 )
|
||||
widthed1 bits>> :> bits1
|
||||
widthed1 #bits>> :> #bits1
|
||||
widthed2 bits>> :> bits2
|
||||
widthed2 #bits>> :> #bits2
|
||||
bits1 #bits2 shift bits2 bitor
|
||||
#bits1 #bits2 + <widthed> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M:: lsb0-bit-writer poke ( value n bs -- )
|
||||
value n <widthed> :> widthed
|
||||
widthed
|
||||
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
|
||||
byte bs widthed>> |widthed :> new-byte
|
||||
new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [
|
||||
new-byte bits>> bs bytes>> push
|
||||
zero-widthed bs (>>widthed)
|
||||
remainder widthed>bytes
|
||||
[ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
|
||||
] [
|
||||
byte bs (>>widthed)
|
||||
] if ;
|
||||
|
||||
: enough-bits? ( n bs -- ? )
|
||||
[ bytes>> length ]
|
||||
[ byte-pos>> - 8 * ]
|
||||
[ bit-pos>> - ] tri <= ;
|
||||
|
||||
ERROR: not-enough-bits n bit-reader ;
|
||||
|
||||
: #bits>#bytes ( #bits -- #bytes )
|
||||
8 /mod 0 = [ 1 + ] unless ; inline
|
||||
|
||||
:: subseq>bits ( bignum n bs -- bits )
|
||||
bignum
|
||||
8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
|
||||
neg shift n bits ;
|
||||
|
||||
:: adjust-bits ( n bs -- )
|
||||
n 8 /mod :> #bits :> #bytes
|
||||
bs [ #bytes + ] change-byte-pos
|
||||
bit-pos>> #bits + dup 8 >= [
|
||||
8 - bs (>>bit-pos)
|
||||
bs [ 1 + ] change-byte-pos drop
|
||||
] [
|
||||
bs (>>bit-pos)
|
||||
] if ;
|
||||
|
||||
:: (peek) ( n bs word -- bits )
|
||||
n bs enough-bits? [ n bs not-enough-bits ] unless
|
||||
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
|
||||
bs bytes>> subseq word execute( seq -- x ) :> bignum
|
||||
bignum n bs subseq>bits ;
|
||||
|
||||
M: lsb0-bit-reader peek ( n bs -- bits ) \ le> (peek) ;
|
||||
|
||||
M: msb0-bit-reader peek ( n bs -- bits ) \ be> (peek) ;
|
||||
|
||||
:: bit-writer-bytes ( writer -- bytes )
|
||||
writer widthed>> #bits>> :> n
|
||||
n 0 = [
|
||||
writer widthed>> bits>> 8 n - shift
|
||||
writer bytes>> swap push
|
||||
] unless
|
||||
writer bytes>> ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,88 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs constructors fry
|
||||
hashtables io kernel locals math math.order math.parser
|
||||
math.ranges multiline sequences ;
|
||||
IN: compression.huffman
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! huffman codes
|
||||
|
||||
TUPLE: huffman-code
|
||||
{ value }
|
||||
{ size }
|
||||
{ code } ;
|
||||
|
||||
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;
|
||||
: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;
|
||||
: next-code ( code -- ) [ 1+ ] change-code drop ;
|
||||
|
||||
:: all-patterns ( huff n -- seq )
|
||||
n log2 huff size>> - :> free-bits
|
||||
free-bits 0 >
|
||||
[ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]
|
||||
[ huff code>> free-bits neg 2^ /i 1array ] if ;
|
||||
|
||||
:: huffman-each ( tdesc quot: ( huff -- ) -- )
|
||||
<huffman-code> :> code
|
||||
tdesc
|
||||
[
|
||||
code next-size
|
||||
[ code (>>value) code clone quot call code next-code ] each
|
||||
] each ; inline
|
||||
|
||||
: update-reverse-table ( huff n table -- )
|
||||
[ drop all-patterns ]
|
||||
[ nip '[ _ swap _ set-at ] each ] 3bi ;
|
||||
|
||||
:: reverse-table ( tdesc n -- rtable )
|
||||
n f <array> <enum> :> table
|
||||
tdesc [ n table update-reverse-table ] huffman-each
|
||||
table seq>> ;
|
||||
|
||||
:: huffman-table ( tdesc max -- table )
|
||||
max f <array> :> table
|
||||
tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each
|
||||
table ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! decoder
|
||||
|
||||
TUPLE: huffman-decoder
|
||||
{ bs }
|
||||
{ tdesc }
|
||||
{ rtable }
|
||||
{ bits/level } ;
|
||||
|
||||
CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
|
||||
16 >>bits/level
|
||||
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
|
||||
|
||||
: read1-huff ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
|
||||
! %remove
|
||||
: reverse-bits ( value bits -- value' )
|
||||
[ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;
|
||||
|
||||
: read1-huff2 ( decoder -- elt )
|
||||
16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last
|
||||
[ size>> swap bs>> bs:seek ] [ value>> ] bi ;
|
||||
|
||||
/*
|
||||
: huff>string ( code -- str )
|
||||
[ value>> number>string ]
|
||||
[ [ code>> ] [ size>> bits>string ] bi ] bi
|
||||
" = " glue ;
|
||||
|
||||
: huff. ( code -- ) huff>string print ;
|
||||
|
||||
:: rtable. ( rtable -- )
|
||||
rtable length>> log2 :> n
|
||||
rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;
|
||||
*/
|
||||
|
|
@ -0,0 +1,209 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs byte-arrays
|
||||
byte-vectors combinators constructors fry grouping hashtables
|
||||
compression.huffman images io.binary kernel locals
|
||||
math math.bitwise math.order math.ranges multiline sequences
|
||||
sorting ;
|
||||
IN: compression.inflate
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: enum>seq ( assoc -- seq )
|
||||
dup keys [ ] [ max ] map-reduce 1 + f <array>
|
||||
[ '[ swap _ set-nth ] assoc-each ] keep ;
|
||||
|
||||
ERROR: zlib-unimplemented ;
|
||||
ERROR: bad-zlib-data ;
|
||||
ERROR: bad-zlib-header ;
|
||||
|
||||
:: check-zlib-header ( data -- )
|
||||
16 data bs:peek 2 >le be> 31 mod ! checksum
|
||||
0 assert=
|
||||
4 data bs:read 8 assert= ! compression method: deflate
|
||||
4 data bs:read ! log2(max length)-8, 32K max
|
||||
7 <= [ bad-zlib-header ] unless
|
||||
5 data bs:seek ! drop check bits
|
||||
1 data bs:read 0 assert= ! dictionnary - not allowed in png
|
||||
2 data bs:seek ! compression level; ignore
|
||||
;
|
||||
|
||||
:: default-table ( -- table )
|
||||
0 <hashtable> :> table
|
||||
0 143 [a,b] 280 287 [a,b] append 8 table set-at
|
||||
144 255 [a,b] >array 9 table set-at
|
||||
256 279 [a,b] >array 7 table set-at
|
||||
table enum>seq 1 tail ;
|
||||
|
||||
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
||||
|
||||
: get-table ( values size -- table )
|
||||
16 f <array> clone <enum>
|
||||
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
|
||||
|
||||
:: decode-huffman-tables ( bitstream -- tables )
|
||||
5 bitstream bs:read 257 +
|
||||
5 bitstream bs:read 1 +
|
||||
4 bitstream bs:read 4 +
|
||||
clen-shuffle swap head
|
||||
dup [ drop 3 bitstream bs:read ] map
|
||||
get-table
|
||||
bitstream swap <huffman-decoder>
|
||||
[ 2dup + ] dip swap :> k!
|
||||
'[
|
||||
_ read1-huff2
|
||||
{
|
||||
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
|
||||
[ ]
|
||||
} cond
|
||||
dup array? [ dup second ] [ 1 ] if
|
||||
k swap - dup k! 0 >
|
||||
]
|
||||
[ ] produce swap suffix
|
||||
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
|
||||
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
|
||||
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
|
||||
|
||||
CONSTANT: length-table
|
||||
{
|
||||
3 4 5 6 7 8 9 10
|
||||
11 13 15 17
|
||||
19 23 27 31
|
||||
35 43 51 59
|
||||
67 83 99 115
|
||||
131 163 195 227
|
||||
}
|
||||
|
||||
CONSTANT: dist-table
|
||||
{ 1 2 3 4
|
||||
5 7 9 13
|
||||
17 25 33 49
|
||||
65 97 129 193
|
||||
257 385 513 769
|
||||
1025 1537 2049 3073
|
||||
4097 6145 8193 12289
|
||||
16385 24577 }
|
||||
|
||||
: nth* ( n seq -- elt )
|
||||
[ length 1- swap - ] [ nth ] bi ;
|
||||
|
||||
:: inflate-lz77 ( seq -- bytes )
|
||||
1000 <byte-vector> :> bytes
|
||||
seq
|
||||
[
|
||||
dup array?
|
||||
[ first2 '[ _ 1- bytes nth* bytes push ] times ]
|
||||
[ bytes push ] if
|
||||
] each
|
||||
bytes ;
|
||||
|
||||
:: inflate-dynamic ( bitstream -- bytes )
|
||||
bitstream decode-huffman-tables
|
||||
bitstream '[ _ swap <huffman-decoder> ] map :> tables
|
||||
[
|
||||
tables first read1-huff2
|
||||
dup 256 >
|
||||
[
|
||||
dup 285 =
|
||||
[ ]
|
||||
[
|
||||
dup 264 >
|
||||
[
|
||||
dup 261 - 4 /i dup 5 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
] if
|
||||
! 5 bitstream read-bits ! distance
|
||||
tables second read1-huff2
|
||||
dup 3 >
|
||||
[
|
||||
dup 2 - 2 /i dup 13 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
2array
|
||||
]
|
||||
when
|
||||
dup 256 = not
|
||||
]
|
||||
[ ] produce nip
|
||||
[
|
||||
dup array? [
|
||||
first2
|
||||
[
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ 257 - length-table nth ] [ + ] bi*
|
||||
]
|
||||
[
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ dist-table nth ] [ + ] bi*
|
||||
] bi*
|
||||
2array
|
||||
] when
|
||||
] map ;
|
||||
|
||||
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
|
||||
:: inflate-loop ( bitstream -- bytes )
|
||||
[ 1 bitstream bs:read 0 = ]
|
||||
[
|
||||
bitstream
|
||||
2 bitstream bs:read ! B
|
||||
{
|
||||
{ 0 [ inflate-raw ] }
|
||||
{ 1 [ inflate-static ] }
|
||||
{ 2 [ inflate-dynamic ] }
|
||||
{ 3 [ bad-zlib-data f ] }
|
||||
}
|
||||
case
|
||||
]
|
||||
[ produce ] keep call suffix concat ;
|
||||
|
||||
! [ produce ] keep dip swap suffix
|
||||
|
||||
:: paeth ( a b c -- p )
|
||||
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
|
||||
sort-keys first second ;
|
||||
|
||||
:: png-unfilter-line ( prev curr filter -- curr' )
|
||||
prev :> c
|
||||
prev 3 tail-slice :> b
|
||||
curr :> a
|
||||
curr 3 tail-slice :> x
|
||||
x length [0,b)
|
||||
filter
|
||||
{
|
||||
{ 0 [ drop ] }
|
||||
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
|
||||
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
|
||||
|
||||
} case
|
||||
curr 3 tail ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! for debug -- shows residual values
|
||||
: reverse-png-filter' ( lines -- filtered )
|
||||
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
|
||||
concat [ 128 + 256 wrap ] map ;
|
||||
|
||||
: reverse-png-filter ( lines -- filtered )
|
||||
dup first [ 0 ] replicate prefix
|
||||
[ { 0 0 } prepend ] map
|
||||
2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ;
|
||||
|
||||
: zlib-inflate ( bytes -- bytes )
|
||||
bs:<lsb0-bit-reader>
|
||||
[ check-zlib-header ]
|
||||
[ inflate-loop ] bi
|
||||
inflate-lz77 ;
|
||||
|
|
@ -1,20 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs bitstreams byte-vectors combinators io
|
||||
USING: accessors alien.accessors assocs byte-arrays combinators
|
||||
io.encodings.binary io.streams.byte-array kernel math sequences
|
||||
vectors ;
|
||||
IN: compression.lzw
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
CONSTANT: clear-code 256
|
||||
CONSTANT: end-of-information 257
|
||||
|
||||
TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
|
||||
code old-code ;
|
||||
TUPLE: lzw input output table code old-code ;
|
||||
|
||||
SYMBOL: table-full
|
||||
|
||||
ERROR: index-too-big n ;
|
||||
|
||||
: lzw-bit-width ( n -- n' )
|
||||
{
|
||||
{ [ dup 510 <= ] [ drop 9 ] }
|
||||
|
|
@ -24,36 +23,14 @@ ERROR: index-too-big n ;
|
|||
[ drop table-full ]
|
||||
} cond ;
|
||||
|
||||
: lzw-bit-width-compress ( lzw -- n )
|
||||
count>> lzw-bit-width ;
|
||||
|
||||
: lzw-bit-width-uncompress ( lzw -- n )
|
||||
table>> length lzw-bit-width ;
|
||||
|
||||
: initial-compress-table ( -- assoc )
|
||||
258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
|
||||
|
||||
: initial-uncompress-table ( -- seq )
|
||||
258 iota [ 1vector ] V{ } map-as ;
|
||||
|
||||
: reset-lzw ( lzw -- lzw )
|
||||
257 >>count
|
||||
V{ } clone >>omega
|
||||
V{ } clone >>omega-k
|
||||
9 >>#bits ;
|
||||
|
||||
: reset-lzw-compress ( lzw -- lzw )
|
||||
f >>k
|
||||
initial-compress-table >>table reset-lzw ;
|
||||
|
||||
: reset-lzw-uncompress ( lzw -- lzw )
|
||||
initial-uncompress-table >>table reset-lzw ;
|
||||
|
||||
: <lzw-compress> ( input -- obj )
|
||||
lzw new
|
||||
swap >>input
|
||||
binary <byte-writer> <bitstream-writer> >>output
|
||||
reset-lzw-compress ;
|
||||
initial-uncompress-table >>table ;
|
||||
|
||||
: <lzw-uncompress> ( input -- obj )
|
||||
lzw new
|
||||
|
|
@ -61,79 +38,8 @@ ERROR: index-too-big n ;
|
|||
BV{ } clone >>output
|
||||
reset-lzw-uncompress ;
|
||||
|
||||
: push-k ( lzw -- lzw )
|
||||
[ ]
|
||||
[ k>> ]
|
||||
[ omega>> clone [ push ] keep ] tri >>omega-k ;
|
||||
|
||||
: omega-k-in-table? ( lzw -- ? )
|
||||
[ omega-k>> ] [ table>> ] bi key? ;
|
||||
|
||||
ERROR: not-in-table value ;
|
||||
|
||||
: write-output ( lzw -- )
|
||||
[
|
||||
[ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
|
||||
] [
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
] bi ;
|
||||
|
||||
: omega-k>omega ( lzw -- lzw )
|
||||
dup omega-k>> clone >>omega ;
|
||||
|
||||
: k>omega ( lzw -- lzw )
|
||||
dup k>> 1vector >>omega ;
|
||||
|
||||
: add-omega-k ( lzw -- )
|
||||
[ [ 1+ ] change-count count>> ]
|
||||
[ omega-k>> clone ]
|
||||
[ table>> ] tri set-at ;
|
||||
|
||||
: lzw-compress-char ( lzw k -- )
|
||||
>>k push-k dup omega-k-in-table? [
|
||||
omega-k>omega drop
|
||||
] [
|
||||
[ write-output ]
|
||||
[ add-omega-k ]
|
||||
[ k>omega drop ] tri
|
||||
] if ;
|
||||
|
||||
: (lzw-compress-chars) ( lzw -- )
|
||||
dup lzw-bit-width-compress table-full = [
|
||||
drop
|
||||
] [
|
||||
dup input>> stream-read1
|
||||
[ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
|
||||
[ t >>end-of-input? drop ] if*
|
||||
] if ;
|
||||
|
||||
: lzw-compress-chars ( lzw -- )
|
||||
{
|
||||
! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
|
||||
[
|
||||
[ clear-code ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
]
|
||||
[ (lzw-compress-chars) ]
|
||||
[
|
||||
[ k>> ]
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] tri
|
||||
]
|
||||
[
|
||||
[ end-of-information ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
]
|
||||
[ ]
|
||||
} cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
|
||||
|
||||
: lzw-compress ( byte-array -- seq )
|
||||
binary <byte-reader> <lzw-compress>
|
||||
[ lzw-compress-chars ] [ output>> stream>> ] bi ;
|
||||
|
||||
: lookup-old-code ( lzw -- vector )
|
||||
[ old-code>> ] [ table>> ] bi nth ;
|
||||
|
||||
|
|
@ -152,7 +58,7 @@ ERROR: not-in-table value ;
|
|||
: add-to-table ( seq lzw -- ) table>> push ;
|
||||
|
||||
: lzw-read ( lzw -- lzw n )
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
|
||||
|
||||
DEFER: lzw-uncompress-char
|
||||
: handle-clear-code ( lzw -- )
|
||||
|
|
@ -200,5 +106,6 @@ DEFER: lzw-uncompress-char
|
|||
] if* ;
|
||||
|
||||
: lzw-uncompress ( seq -- byte-array )
|
||||
binary <byte-reader> <bitstream-reader>
|
||||
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
bs:<msb0-bit-reader>
|
||||
<lzw-uncompress>
|
||||
[ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,304 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays combinators
|
||||
constructors grouping compression.huffman images
|
||||
images.processing io io.binary io.encodings.binary io.files
|
||||
io.streams.byte-array kernel locals math math.bitwise
|
||||
math.constants math.functions math.matrices math.order
|
||||
math.ranges math.vectors memoize multiline namespaces
|
||||
sequences sequences.deep ;
|
||||
IN: images.jpeg
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
TUPLE: jpeg-image < image
|
||||
{ headers }
|
||||
{ bitstream }
|
||||
{ color-info initial: { f f f f } }
|
||||
{ quant-tables initial: { f f } }
|
||||
{ huff-tables initial: { f f f f } }
|
||||
{ components } ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
|
||||
|
||||
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
|
||||
APP JPG COM TEM RES ;
|
||||
|
||||
! ISO/IEC 10918-1 Table B.1
|
||||
:: >marker ( byte -- marker )
|
||||
byte
|
||||
{
|
||||
{ [ dup HEX: CC = ] [ { DAC } ] }
|
||||
{ [ dup HEX: C4 = ] [ { DHT } ] }
|
||||
{ [ dup HEX: C9 = ] [ { JPG } ] }
|
||||
{ [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
|
||||
|
||||
{ [ dup HEX: D8 = ] [ { SOI } ] }
|
||||
{ [ dup HEX: D9 = ] [ { EOI } ] }
|
||||
{ [ dup HEX: DA = ] [ { SOS } ] }
|
||||
{ [ dup HEX: DB = ] [ { DQT } ] }
|
||||
{ [ dup HEX: DC = ] [ { DNL } ] }
|
||||
{ [ dup HEX: DD = ] [ { DRI } ] }
|
||||
{ [ dup HEX: DE = ] [ { DHP } ] }
|
||||
{ [ dup HEX: DF = ] [ { EXP } ] }
|
||||
{ [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
|
||||
|
||||
{ [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
|
||||
{ [ dup HEX: FE = ] [ { COM } ] }
|
||||
{ [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
|
||||
|
||||
{ [ dup HEX: 01 = ] [ { TEM } ] }
|
||||
[ { RES } ]
|
||||
}
|
||||
cond nip ;
|
||||
|
||||
TUPLE: jpeg-chunk length type data ;
|
||||
|
||||
CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
|
||||
|
||||
TUPLE: jpeg-color-info
|
||||
h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
|
||||
|
||||
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
|
||||
|
||||
: jpeg> ( -- jpeg-image ) jpeg-image get ;
|
||||
|
||||
: apply-diff ( dc color -- dc' )
|
||||
[ diff>> + dup ] [ (>>diff) ] bi ;
|
||||
|
||||
: fetch-tables ( component -- )
|
||||
[ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
|
||||
[ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
|
||||
[ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
|
||||
|
||||
: read4/4 ( -- a b ) read1 16 /mod ;
|
||||
|
||||
|
||||
! headers
|
||||
|
||||
: decode-frame ( header -- )
|
||||
data>>
|
||||
binary
|
||||
[
|
||||
read1 8 assert=
|
||||
2 read be>
|
||||
2 read be>
|
||||
swap 2array jpeg> (>>dim)
|
||||
read1
|
||||
[
|
||||
read1 read4/4 read1 <jpeg-color-info>
|
||||
swap [ >>id ] keep jpeg> color-info>> set-nth
|
||||
] times
|
||||
] with-byte-reader ;
|
||||
|
||||
: decode-quant-table ( chunk -- )
|
||||
dup data>>
|
||||
binary
|
||||
[
|
||||
length>>
|
||||
2 - 65 /
|
||||
[
|
||||
read4/4 [ 0 assert= ] dip
|
||||
64 read
|
||||
swap jpeg> quant-tables>> set-nth
|
||||
] times
|
||||
] with-byte-reader ;
|
||||
|
||||
: decode-huff-table ( chunk -- )
|
||||
data>>
|
||||
binary
|
||||
[
|
||||
1 ! %fixme: Should handle multiple tables at once
|
||||
[
|
||||
read4/4 swap 2 * +
|
||||
16 read
|
||||
dup [ ] [ + ] map-reduce read
|
||||
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
|
||||
swap jpeg> huff-tables>> set-nth
|
||||
] times
|
||||
] with-byte-reader ;
|
||||
|
||||
: decode-scan ( chunk -- )
|
||||
data>>
|
||||
binary
|
||||
[
|
||||
read1 [0,b)
|
||||
[ drop
|
||||
read1 jpeg> color-info>> nth clone
|
||||
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
|
||||
] map jpeg> (>>components)
|
||||
read1 0 assert=
|
||||
read1 63 assert=
|
||||
read1 16 /mod [ 0 assert= ] bi@
|
||||
] with-byte-reader ;
|
||||
|
||||
: singleton-first ( seq -- elt )
|
||||
[ length 1 assert= ] [ first ] bi ;
|
||||
|
||||
: baseline-parse ( -- )
|
||||
jpeg> headers>>
|
||||
{
|
||||
[ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
|
||||
[ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
|
||||
[ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
|
||||
[ [ type>> { SOS } = ] filter singleton-first decode-scan ]
|
||||
} cleave ;
|
||||
|
||||
: parse-marker ( -- marker )
|
||||
read1 HEX: FF assert=
|
||||
read1 >marker ;
|
||||
|
||||
: parse-headers ( -- chunks )
|
||||
[ parse-marker dup { SOS } = not ]
|
||||
[
|
||||
2 read be>
|
||||
dup 2 - read <jpeg-chunk>
|
||||
] [ produce ] keep dip swap suffix ;
|
||||
|
||||
MEMO: zig-zag ( -- zz )
|
||||
{
|
||||
{ 0 1 5 6 14 15 27 28 }
|
||||
{ 2 4 7 13 16 26 29 42 }
|
||||
{ 3 8 12 17 25 30 41 43 }
|
||||
{ 9 11 18 24 31 40 44 53 }
|
||||
{ 10 19 23 32 39 45 52 54 }
|
||||
{ 20 22 33 38 46 51 55 60 }
|
||||
{ 21 34 37 47 50 56 59 61 }
|
||||
{ 35 36 48 49 57 58 62 63 }
|
||||
} flatten ;
|
||||
|
||||
MEMO: yuv>bgr-matrix ( -- m )
|
||||
{
|
||||
{ 1 2.03211 0 }
|
||||
{ 1 -0.39465 -0.58060 }
|
||||
{ 1 0 1.13983 }
|
||||
} ;
|
||||
|
||||
: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
|
||||
|
||||
:: dct-vect ( u v -- basis )
|
||||
{ 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
|
||||
1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
|
||||
|
||||
MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
|
||||
|
||||
: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
|
||||
|
||||
: all-macroblocks ( quot: ( mb -- ) -- )
|
||||
[
|
||||
jpeg>
|
||||
[ dim>> 8 v/n ]
|
||||
[ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
|
||||
[ ceiling ] map
|
||||
coord-matrix flip concat
|
||||
]
|
||||
[ each ] bi* ; inline
|
||||
|
||||
: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
|
||||
|
||||
: idct-factor ( b -- b' ) dct-matrix v.m ;
|
||||
|
||||
USE: math.blas.vectors
|
||||
USE: math.blas.matrices
|
||||
|
||||
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
|
||||
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
|
||||
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
|
||||
|
||||
: idct ( b -- b' ) idct-blas ;
|
||||
|
||||
:: draw-block ( block x,y color jpeg-image -- )
|
||||
block dup length>> sqrt >fixnum group flip
|
||||
dup matrix-dim coord-matrix flip
|
||||
[
|
||||
[ first2 spin nth nth ]
|
||||
[ x,y v+ color id>> 1- jpeg-image draw-color ] bi
|
||||
] with each^2 ;
|
||||
|
||||
: sign-extend ( bits v -- v' )
|
||||
swap [ ] [ 1- 2^ < ] 2bi
|
||||
[ -1 swap shift 1+ + ] [ drop ] if ;
|
||||
|
||||
: read1-jpeg-dc ( decoder -- dc )
|
||||
[ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
|
||||
|
||||
: read1-jpeg-ac ( decoder -- run/ac )
|
||||
[ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
|
||||
|
||||
:: decode-block ( pos color -- )
|
||||
color dc-huff-table>> read1-jpeg-dc color apply-diff
|
||||
64 0 <array> :> coefs
|
||||
0 coefs set-nth
|
||||
0 :> k!
|
||||
[
|
||||
color ac-huff-table>> read1-jpeg-ac
|
||||
[ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
|
||||
{ 0 0 } = not
|
||||
k 63 < and
|
||||
] loop
|
||||
coefs color quant-table>> v*
|
||||
reverse-zigzag idct
|
||||
! %fixme: color hack
|
||||
! this eat 50% cpu time
|
||||
color h>> 2 =
|
||||
[ 8 group 2 matrix-zoom concat ] unless
|
||||
pos { 8 8 } v* color jpeg> draw-block ;
|
||||
|
||||
: decode-macroblock ( mb -- )
|
||||
jpeg> components>>
|
||||
[
|
||||
[ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
|
||||
[ [ decode-block ] curry each ] bi
|
||||
] with each ;
|
||||
|
||||
: cleanup-bitstream ( bytes -- bytes' )
|
||||
binary [
|
||||
[
|
||||
{ HEX: FF } read-until
|
||||
read1 tuck HEX: 00 = and
|
||||
]
|
||||
[ drop ] produce
|
||||
swap >marker { EOI } assert=
|
||||
swap suffix
|
||||
{ HEX: FF } join
|
||||
] with-byte-reader ;
|
||||
|
||||
: setup-bitmap ( image -- )
|
||||
dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
|
||||
BGR >>component-order
|
||||
f >>upside-down?
|
||||
dup dim>> first2 * 3 * 0 <array> >>bitmap
|
||||
drop ;
|
||||
|
||||
: baseline-decompress ( -- )
|
||||
jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
|
||||
>byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
|
||||
jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
|
||||
jpeg> components>> [ fetch-tables ] each
|
||||
jpeg> setup-bitmap
|
||||
[ decode-macroblock ] all-macroblocks ;
|
||||
|
||||
! this eats ~25% cpu time
|
||||
: color-transform ( yuv -- rgb )
|
||||
{ 128 0 0 } v+ yuv>bgr-matrix swap m.v
|
||||
[ 0 max 255 min >fixnum ] map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: load-jpeg ( path -- image )
|
||||
binary [
|
||||
parse-marker { SOI } assert=
|
||||
parse-headers
|
||||
contents <jpeg-image>
|
||||
] with-file-reader
|
||||
dup jpeg-image [
|
||||
baseline-parse
|
||||
baseline-decompress
|
||||
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
|
||||
jpeg> [ >byte-array ] change-bitmap drop
|
||||
] with-variable ;
|
||||
|
||||
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
||||
drop load-jpeg ;
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: constructors kernel splitting unicode.case combinators
|
||||
accessors images.bitmap images.tiff images io.pathnames ;
|
||||
accessors images.bitmap images.tiff images io.pathnames
|
||||
images.jpeg images.png ;
|
||||
IN: images.loader
|
||||
|
||||
ERROR: unknown-image-extension extension ;
|
||||
|
|
@ -11,6 +12,9 @@ ERROR: unknown-image-extension extension ;
|
|||
{ "bmp" [ bitmap-image ] }
|
||||
{ "tif" [ tiff-image ] }
|
||||
{ "tiff" [ tiff-image ] }
|
||||
{ "jpg" [ jpeg-image ] }
|
||||
{ "jpeg" [ jpeg-image ] }
|
||||
{ "png" [ png-image ] }
|
||||
[ unknown-image-extension ]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors constructors images io io.binary io.encodings.ascii
|
||||
io.encodings.binary io.encodings.string io.files io.files.info kernel
|
||||
sequences io.streams.limited fry combinators arrays math
|
||||
checksums checksums.crc32 ;
|
||||
checksums checksums.crc32 compression.inflate grouping byte-arrays ;
|
||||
IN: images.png
|
||||
|
||||
TUPLE: png-image < image chunks
|
||||
|
|
@ -17,7 +17,8 @@ TUPLE: png-chunk length type data ;
|
|||
|
||||
CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
|
||||
|
||||
CONSTANT: png-header B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
|
||||
CONSTANT: png-header
|
||||
B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
|
||||
|
||||
ERROR: bad-png-header header ;
|
||||
|
||||
|
|
@ -61,6 +62,18 @@ ERROR: bad-checksum ;
|
|||
: fill-image-data ( image -- image )
|
||||
dup [ width>> ] [ height>> ] bi 2array >>dim ;
|
||||
|
||||
: zlib-data ( png-image -- bytes )
|
||||
chunks>> [ type>> "IDAT" = ] find nip data>> ;
|
||||
|
||||
: decode-png ( image -- image )
|
||||
{
|
||||
[ zlib-data zlib-inflate ]
|
||||
[ dim>> first 3 * 1 + group reverse-png-filter ]
|
||||
[ swap >byte-array >>bitmap drop ]
|
||||
[ RGB >>component-order drop ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
: load-png ( path -- image )
|
||||
[ binary <file-reader> ] [ file-info size>> ] bi
|
||||
stream-throws <limited-stream> [
|
||||
|
|
@ -69,4 +82,8 @@ ERROR: bad-checksum ;
|
|||
read-png-chunks
|
||||
parse-ihdr-chunk
|
||||
fill-image-data
|
||||
decode-png
|
||||
] with-input-stream ;
|
||||
|
||||
M: png-image load-image*
|
||||
drop load-png ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays combinators grouping images
|
||||
kernel locals math math.order
|
||||
math.ranges math.vectors sequences sequences.deep fry ;
|
||||
IN: images.processing
|
||||
|
||||
: coord-matrix ( dim -- m )
|
||||
[ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;
|
||||
|
||||
: map^2 ( m quot -- m' ) '[ _ map ] map ; inline
|
||||
: each^2 ( m quot -- m' ) '[ _ each ] each ; inline
|
||||
|
||||
: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ;
|
||||
|
||||
: matrix>image ( m -- image )
|
||||
<image> over matrix-dim >>dim
|
||||
swap flip flatten
|
||||
[ 128 * 128 + 0 max 255 min >fixnum ] map
|
||||
>byte-array >>bitmap L >>component-order ;
|
||||
|
||||
:: matrix-zoom ( m f -- m' )
|
||||
m matrix-dim f v*n coord-matrix
|
||||
[ [ f /i ] map first2 swap m nth nth ] map^2 ;
|
||||
|
||||
:: image-offset ( x,y image -- xy )
|
||||
image dim>> first
|
||||
x,y second * x,y first + ;
|
||||
|
||||
:: draw-grey ( value x,y image -- )
|
||||
x,y image image-offset 3 * { 0 1 2 }
|
||||
[
|
||||
+ value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth
|
||||
] with each ;
|
||||
|
||||
:: draw-color ( value x,y color-id image -- )
|
||||
x,y image image-offset 3 * color-id + value >fixnum
|
||||
swap image bitmap>> set-nth ;
|
||||
|
||||
! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ;
|
||||
|
|
@ -25,6 +25,7 @@ M: gesture-logger user-input*
|
|||
: gesture-logger ( -- )
|
||||
[
|
||||
<pane> t >>scrolls? dup <scroller>
|
||||
{ 450 500 } >>pref-dim
|
||||
"Gesture log" open-window
|
||||
<pane-stream> <gesture-logger>
|
||||
"Gesture input" open-window
|
||||
|
|
|
|||
Loading…
Reference in New Issue