Merge branch 'master' of git://factorcode.org/git/factor
commit
2adeecb9a4
|
@ -56,13 +56,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
|
||||||
GENERIC: peek ( n bitstream -- value )
|
GENERIC: peek ( n bitstream -- value )
|
||||||
GENERIC: poke ( value n bitstream -- )
|
GENERIC: poke ( value n bitstream -- )
|
||||||
|
|
||||||
|
: get-abp ( bitstream -- abp )
|
||||||
|
[ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
|
||||||
|
|
||||||
|
: set-abp ( abp bitstream -- )
|
||||||
|
[ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
|
||||||
|
|
||||||
: seek ( n bitstream -- )
|
: seek ( n bitstream -- )
|
||||||
{
|
[ get-abp + ] [ set-abp ] bi ; inline
|
||||||
[ byte-pos>> 8 * ]
|
|
||||||
[ bit-pos>> + + 8 /mod ]
|
: (align) ( n m -- n' )
|
||||||
[ (>>bit-pos) ]
|
[ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
|
||||||
[ (>>byte-pos) ]
|
|
||||||
} cleave ; inline
|
: align ( n bitstream -- )
|
||||||
|
[ get-abp swap (align) ] [ set-abp ] bi ; inline
|
||||||
|
|
||||||
: read ( n bitstream -- value )
|
: read ( n bitstream -- value )
|
||||||
[ peek ] [ seek ] 2bi ; inline
|
[ peek ] [ seek ] 2bi ; inline
|
||||||
|
|
|
@ -151,7 +151,16 @@ CONSTANT: dist-table
|
||||||
] when
|
] when
|
||||||
] map ;
|
] map ;
|
||||||
|
|
||||||
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
|
:: inflate-raw ( bitstream -- bytes )
|
||||||
|
8 bitstream bs:align
|
||||||
|
16 bitstream bs:read :> len
|
||||||
|
16 bitstream bs:read :> nlen
|
||||||
|
len nlen + 16 >signed -1 assert= ! len + ~len = -1
|
||||||
|
bitstream byte-pos>>
|
||||||
|
bitstream byte-pos>> len +
|
||||||
|
bitstream bytes>> <slice>
|
||||||
|
len 8 * bitstream bs:seek ;
|
||||||
|
|
||||||
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
|
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
|
||||||
|
|
||||||
:: inflate-loop ( bitstream -- bytes )
|
:: inflate-loop ( bitstream -- bytes )
|
||||||
|
@ -194,7 +203,6 @@ CONSTANT: dist-table
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
! for debug -- shows residual values
|
|
||||||
: reverse-png-filter' ( lines -- byte-array )
|
: reverse-png-filter' ( lines -- byte-array )
|
||||||
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
|
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
|
||||||
concat [ 128 + ] B{ } map-as ;
|
concat [ 128 + ] B{ } map-as ;
|
||||||
|
|
|
@ -6,14 +6,12 @@ images.processing io io.binary io.encodings.binary io.files
|
||||||
io.streams.byte-array kernel locals math math.bitwise
|
io.streams.byte-array kernel locals math math.bitwise
|
||||||
math.constants math.functions math.matrices math.order
|
math.constants math.functions math.matrices math.order
|
||||||
math.ranges math.vectors memoize multiline namespaces
|
math.ranges math.vectors memoize multiline namespaces
|
||||||
sequences sequences.deep images.loader ;
|
sequences sequences.deep ;
|
||||||
QUALIFIED-WITH: bitstreams bs
|
|
||||||
IN: images.jpeg
|
IN: images.jpeg
|
||||||
|
|
||||||
SINGLETON: jpeg-image
|
QUALIFIED-WITH: bitstreams bs
|
||||||
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
|
|
||||||
|
|
||||||
TUPLE: loading-jpeg < image
|
TUPLE: jpeg-image < image
|
||||||
{ headers }
|
{ headers }
|
||||||
{ bitstream }
|
{ bitstream }
|
||||||
{ color-info initial: { f f f f } }
|
{ color-info initial: { f f f f } }
|
||||||
|
@ -23,7 +21,7 @@ TUPLE: loading-jpeg < image
|
||||||
|
|
||||||
<PRIVATE
|
<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
|
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
|
||||||
APP JPG COM TEM RES ;
|
APP JPG COM TEM RES ;
|
||||||
|
@ -65,7 +63,7 @@ TUPLE: jpeg-color-info
|
||||||
|
|
||||||
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- 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' )
|
: apply-diff ( dc color -- dc' )
|
||||||
[ diff>> + dup ] [ (>>diff) ] bi ;
|
[ 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 ;
|
: read4/4 ( -- a b ) read1 16 /mod ;
|
||||||
|
|
||||||
|
|
||||||
! headers
|
! headers
|
||||||
|
|
||||||
: decode-frame ( header -- )
|
: 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 ;
|
: 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 -- ) -- )
|
: all-macroblocks ( quot: ( mb -- ) -- )
|
||||||
[
|
[
|
||||||
jpeg>
|
jpeg>
|
||||||
|
@ -211,12 +211,12 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
|
||||||
|
|
||||||
: idct ( b -- b' ) idct-blas ;
|
: 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
|
block dup length>> sqrt >fixnum group flip
|
||||||
dup matrix-dim coord-matrix flip
|
dup matrix-dim coord-matrix flip
|
||||||
[
|
[
|
||||||
[ first2 spin nth nth ]
|
[ 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 ;
|
] with each^2 ;
|
||||||
|
|
||||||
: sign-extend ( bits v -- v' )
|
: 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-jpeg-ac ( decoder -- run/ac )
|
||||||
[ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
|
[ 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
|
color dc-huff-table>> read1-jpeg-dc color apply-diff
|
||||||
64 0 <array> :> coefs
|
64 0 <array> :> coefs
|
||||||
0 coefs set-nth
|
0 coefs set-nth
|
||||||
|
@ -241,19 +241,38 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
|
||||||
k 63 < and
|
k 63 < and
|
||||||
] loop
|
] loop
|
||||||
coefs color quant-table>> v*
|
coefs color quant-table>> v*
|
||||||
reverse-zigzag idct
|
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 -- )
|
:: 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>>
|
jpeg> components>>
|
||||||
[
|
[
|
||||||
[ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
|
[ mb-dim first2 * iota ]
|
||||||
[ [ decode-block ] curry each ] bi
|
[ [ decode-block ] curry replicate ] bi
|
||||||
] with each ;
|
] map concat ;
|
||||||
|
|
||||||
: cleanup-bitstream ( bytes -- bytes' )
|
: cleanup-bitstream ( bytes -- bytes' )
|
||||||
binary [
|
binary [
|
||||||
|
@ -274,33 +293,67 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
|
||||||
dup dim>> first2 * 3 * 0 <array> >>bitmap
|
dup dim>> first2 * 3 * 0 <array> >>bitmap
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
: baseline-decompress ( -- )
|
ERROR: unsupported-colorspace ;
|
||||||
jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
|
SINGLETONS: YUV420 YUV444 Y MAGIC! ;
|
||||||
>byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
|
|
||||||
jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
|
:: detect-colorspace ( jpeg-image -- csp )
|
||||||
jpeg> components>> [ fetch-tables ] each
|
jpeg-image color-info>> sift :> colors
|
||||||
jpeg> setup-bitmap
|
MAGIC!
|
||||||
[ decode-macroblock ] all-macroblocks ;
|
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
|
! this eats ~25% cpu time
|
||||||
: color-transform ( yuv -- rgb )
|
: color-transform ( yuv -- rgb )
|
||||||
{ 128 0 0 } v+ yuv>bgr-matrix swap m.v
|
{ 128 0 0 } v+ yuv>bgr-matrix swap m.v
|
||||||
[ 0 max 255 min >fixnum ] map ;
|
[ 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>
|
PRIVATE>
|
||||||
|
|
||||||
: load-jpeg ( path -- image )
|
: load-jpeg ( path -- image )
|
||||||
binary [
|
binary [
|
||||||
parse-marker { SOI } assert=
|
parse-marker { SOI } = [ not-a-jpeg-image ] unless
|
||||||
parse-headers
|
parse-headers
|
||||||
contents <loading-jpeg>
|
contents <jpeg-image>
|
||||||
] with-file-reader
|
] with-file-reader
|
||||||
dup loading-jpeg [
|
dup jpeg-image [
|
||||||
baseline-parse
|
baseline-parse
|
||||||
baseline-decompress
|
baseline-decompress
|
||||||
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
|
|
||||||
jpeg> [ >byte-array ] change-bitmap drop
|
|
||||||
] with-variable ;
|
] with-variable ;
|
||||||
|
|
||||||
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
||||||
drop load-jpeg ;
|
drop load-jpeg ;
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays fry kernel math math.order math.vectors
|
USING: accessors arrays columns kernel math math.bits
|
||||||
sequences sequences.private accessors columns ;
|
math.order math.vectors sequences sequences.private fry ;
|
||||||
IN: math.matrices
|
IN: math.matrices
|
||||||
|
|
||||||
! Matrices
|
! Matrices
|
||||||
|
@ -61,3 +61,7 @@ PRIVATE>
|
||||||
|
|
||||||
: cross-zip ( seq1 seq2 -- seq1xseq2 )
|
: cross-zip ( seq1 seq2 -- seq1xseq2 )
|
||||||
[ [ 2array ] with map ] curry map ;
|
[ [ 2array ] with map ] curry map ;
|
||||||
|
|
||||||
|
: m^n ( m n -- n )
|
||||||
|
make-bits over first length identity-matrix
|
||||||
|
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
|
||||||
|
|
|
@ -8,16 +8,16 @@ HELP: dispose
|
||||||
$nl
|
$nl
|
||||||
"No further operations can be performed on a disposable object after this call."
|
"No further operations can be performed on a disposable object after this call."
|
||||||
$nl
|
$nl
|
||||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
|
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
|
||||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
|
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
|
||||||
$nl
|
$nl
|
||||||
"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
|
"The default implementation assumes the object has a " { $slot "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
|
||||||
|
|
||||||
HELP: dispose*
|
HELP: dispose*
|
||||||
{ $values { "disposable" "a disposable object" } }
|
{ $values { "disposable" "a disposable object" } }
|
||||||
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
|
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
|
||||||
{ $notes
|
{ $notes
|
||||||
"This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
|
"This word should not be called directly. It can be implemented on objects with a " { $slot "disposed" } " slot to ensure that the object is only disposed once."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: with-disposal
|
HELP: with-disposal
|
||||||
|
|
|
@ -0,0 +1,20 @@
|
||||||
|
! by blei on #concatenative
|
||||||
|
USING: kernel sequences math locals make multiline ;
|
||||||
|
IN: nested-comments
|
||||||
|
|
||||||
|
:: (subsequences-at) ( sseq seq n -- )
|
||||||
|
sseq seq n start*
|
||||||
|
[ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]
|
||||||
|
when* ;
|
||||||
|
|
||||||
|
: subsequences-at ( sseq seq -- indices )
|
||||||
|
[ 0 (subsequences-at) ] { } make ;
|
||||||
|
|
||||||
|
: count-subsequences ( sseq seq -- i )
|
||||||
|
subsequences-at length ;
|
||||||
|
|
||||||
|
: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )
|
||||||
|
1 - "*)" parse-multiline-string [ "(*" ] dip
|
||||||
|
count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;
|
||||||
|
|
||||||
|
SYNTAX: (* 1 parse-all-(* ;
|
Loading…
Reference in New Issue