images.jpeg: added support for yuv444 and black and white images

db4
Marc Fauconneau 2009-06-05 21:33:04 +09:00
parent f09a2807fa
commit 88f8af4b69
1 changed files with 359 additions and 306 deletions

View File

@ -6,14 +6,12 @@ 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 images.loader ;
QUALIFIED-WITH: bitstreams bs
sequences sequences.deep ;
IN: images.jpeg
SINGLETON: jpeg-image
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
QUALIFIED-WITH: bitstreams bs
TUPLE: loading-jpeg < image
TUPLE: jpeg-image < image
{ headers }
{ bitstream }
{ color-info initial: { f f f f } }
@ -23,7 +21,7 @@ TUPLE: loading-jpeg < image
<PRIVATE
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
@ -65,7 +63,7 @@ TUPLE: jpeg-color-info
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
: jpeg> ( -- jpeg-image ) loading-jpeg get ;
: jpeg> ( -- jpeg-image ) jpeg-image get ;
: apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ;
@ -77,7 +75,6 @@ CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
: read4/4 ( -- a b ) read1 16 /mod ;
! headers
: decode-frame ( header -- )
@ -188,6 +185,9 @@ MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
! : blocks ( component -- seq )
! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
: all-macroblocks ( quot: ( mb -- ) -- )
[
jpeg>
@ -211,12 +211,12 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: idct ( b -- b' ) idct-blas ;
:: draw-block ( block x,y color jpeg-image -- )
:: draw-block ( block x,y color-id 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
[ x,y v+ color-id jpeg-image draw-color ] bi
] with each^2 ;
: sign-extend ( bits v -- v' )
@ -229,7 +229,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: read1-jpeg-ac ( decoder -- run/ac )
[ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
:: decode-block ( pos color -- )
:: decode-block ( color -- pixels )
color dc-huff-table>> read1-jpeg-dc color apply-diff
64 0 <array> :> coefs
0 coefs set-nth
@ -241,19 +241,38 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
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 ;
reverse-zigzag idct ;
: decode-macroblock ( mb -- )
:: draw-macroblock-yuv420 ( mb blocks -- )
mb { 16 16 } v* :> pos
0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
:: draw-macroblock-yuv444 ( mb blocks -- )
mb { 8 8 } v* :> pos
3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
:: draw-macroblock-y ( mb blocks -- )
mb { 8 8 } v* :> pos
0 blocks nth pos 0 jpeg> draw-block
64 0 <array> pos 1 jpeg> draw-block
64 0 <array> pos 2 jpeg> draw-block ;
! %fixme: color hack
! color h>> 2 =
! [ 8 group 2 matrix-zoom concat ] unless
! pos { 8 8 } v* color jpeg> draw-block ;
: decode-macroblock ( -- blocks )
jpeg> components>>
[
[ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
[ [ decode-block ] curry each ] bi
] with each ;
[ mb-dim first2 * iota ]
[ [ decode-block ] curry replicate ] bi
] map concat ;
: cleanup-bitstream ( bytes -- bytes' )
binary [
@ -274,33 +293,67 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
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 ;
ERROR: unsupported-colorspace ;
SINGLETONS: YUV420 YUV444 Y MAGIC! ;
:: detect-colorspace ( jpeg-image -- csp )
jpeg-image color-info>> sift :> colors
MAGIC!
colors length 1 = [ drop Y ] when
colors length 3 =
[
colors [ mb-dim { 1 1 } = ] all?
[ drop YUV444 ] when
colors unclip
[ [ mb-dim { 1 1 } = ] all? ]
[ mb-dim { 2 2 } = ] bi* and
[ drop YUV420 ] when
] when ;
! this eats ~50% cpu time
: draw-macroblocks ( mbs -- )
jpeg> detect-colorspace
{
{ YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
{ YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
{ Y [ [ first2 draw-macroblock-y ] each ] }
[ unsupported-colorspace ]
} case ;
! 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 ;
: 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
[ decode-macroblock 2array ] accumulator
[ all-macroblocks ] dip
jpeg> setup-bitmap draw-macroblocks
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
jpeg> [ >byte-array ] change-bitmap drop ;
ERROR: not-a-jpeg-image ;
PRIVATE>
: load-jpeg ( path -- image )
binary [
parse-marker { SOI } assert=
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
contents <loading-jpeg>
contents <jpeg-image>
] with-file-reader
dup loading-jpeg [
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 ;