Merge branch 'master' of git://github.com/prunedtree/factor

Conflicts:
	basis/compression/inflate/inflate.factor
	basis/math/matrices/matrices.factor
db4
Doug Coleman 2009-06-12 02:33:49 -05:00
commit 7134236e46
5 changed files with 618 additions and 526 deletions

View File

@ -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

432
basis/compression/inflate/inflate.factor Executable file → Normal file
View File

@ -1,212 +1,220 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays USING: accessors arrays assocs byte-arrays
byte-vectors combinators constructors fry grouping hashtables byte-vectors combinators constructors fry grouping hashtables
compression.huffman images io.binary kernel locals compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences math math.bitwise math.order math.ranges multiline sequences
sorting ; sorting ;
IN: compression.inflate IN: compression.inflate
QUALIFIED-WITH: bitstreams bs QUALIFIED-WITH: bitstreams bs
<PRIVATE <PRIVATE
: enum>seq ( assoc -- seq ) : enum>seq ( assoc -- seq )
dup keys [ ] [ max ] map-reduce 1 + f <array> dup keys [ ] [ max ] map-reduce 1 + f <array>
[ '[ swap _ set-nth ] assoc-each ] keep ; [ '[ swap _ set-nth ] assoc-each ] keep ;
ERROR: zlib-unimplemented ; ERROR: zlib-unimplemented ;
ERROR: bad-zlib-data ; ERROR: bad-zlib-data ;
ERROR: bad-zlib-header ; ERROR: bad-zlib-header ;
:: check-zlib-header ( data -- ) :: check-zlib-header ( data -- )
16 data bs:peek 2 >le be> 31 mod ! checksum 16 data bs:peek 2 >le be> 31 mod ! checksum
0 assert= 0 assert=
4 data bs:read 8 assert= ! compression method: deflate 4 data bs:read 8 assert= ! compression method: deflate
4 data bs:read ! log2(max length)-8, 32K max 4 data bs:read ! log2(max length)-8, 32K max
7 <= [ bad-zlib-header ] unless 7 <= [ bad-zlib-header ] unless
5 data bs:seek ! drop check bits 5 data bs:seek ! drop check bits
1 data bs:read 0 assert= ! dictionnary - not allowed in png 1 data bs:read 0 assert= ! dictionnary - not allowed in png
2 data bs:seek ! compression level; ignore 2 data bs:seek ! compression level; ignore
; ;
:: default-table ( -- table ) :: default-table ( -- table )
0 <hashtable> :> table 0 <hashtable> :> table
0 143 [a,b] 280 287 [a,b] append 8 table set-at 0 143 [a,b] 280 287 [a,b] append 8 table set-at
144 255 [a,b] >array 9 table set-at 144 255 [a,b] >array 9 table set-at
256 279 [a,b] >array 7 table set-at 256 279 [a,b] >array 7 table set-at
table enum>seq 1 tail ; 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 } 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 ) : get-table ( values size -- table )
16 f <array> clone <enum> 16 f <array> clone <enum>
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ; [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
:: decode-huffman-tables ( bitstream -- tables ) :: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 + 5 bitstream bs:read 257 +
5 bitstream bs:read 1 + 5 bitstream bs:read 1 +
4 bitstream bs:read 4 + 4 bitstream bs:read 4 +
clen-shuffle swap head clen-shuffle swap head
dup [ drop 3 bitstream bs:read ] map dup [ drop 3 bitstream bs:read ] map
get-table get-table
bitstream swap <huffman-decoder> bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k! [ 2dup + ] dip swap :> k!
'[ '[
_ read1-huff2 _ read1-huff2
{ {
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] } { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] } { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] } { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
[ ] [ ]
} cond } cond
dup array? [ dup second ] [ 1 ] if dup array? [ dup second ] [ 1 ] if
k swap - dup k! 0 > k swap - dup k! 0 >
] ]
[ ] produce swap suffix [ ] produce swap suffix
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce { } [ 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 [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ; nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
CONSTANT: length-table CONSTANT: length-table
{ {
3 4 5 6 7 8 9 10 3 4 5 6 7 8 9 10
11 13 15 17 11 13 15 17
19 23 27 31 19 23 27 31
35 43 51 59 35 43 51 59
67 83 99 115 67 83 99 115
131 163 195 227 258 131 163 195 227 258
} }
CONSTANT: dist-table CONSTANT: dist-table
{ {
1 2 3 4 1 2 3 4
5 7 9 13 5 7 9 13
17 25 33 49 17 25 33 49
65 97 129 193 65 97 129 193
257 385 513 769 257 385 513 769
1025 1537 2049 3073 1025 1537 2049 3073
4097 6145 8193 12289 4097 6145 8193 12289
16385 24577 16385 24577
} }
: nth* ( n seq -- elt ) : nth* ( n seq -- elt )
[ length 1- swap - ] [ nth ] bi ; [ length 1- swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes ) :: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes 1000 <byte-vector> :> bytes
seq seq
[ [
dup array? dup array?
[ first2 '[ _ 1- bytes nth* bytes push ] times ] [ first2 '[ _ 1- bytes nth* bytes push ] times ]
[ bytes push ] if [ bytes push ] if
] each ] each
bytes ; bytes ;
:: inflate-dynamic ( bitstream -- bytes ) :: inflate-dynamic ( bitstream -- bytes )
bitstream decode-huffman-tables bitstream decode-huffman-tables
bitstream '[ _ swap <huffman-decoder> ] map :> tables bitstream '[ _ swap <huffman-decoder> ] map :> tables
[ [
tables first read1-huff2 tables first read1-huff2
dup 256 > dup 256 >
[ [
dup 285 = dup 285 =
[ ] [ ]
[ [
dup 264 > dup 264 >
[ [
dup 261 - 4 /i dup 5 > dup 261 - 4 /i dup 5 >
[ bad-zlib-data ] when [ bad-zlib-data ] when
bitstream bs:read 2array bitstream bs:read 2array
] ]
when when
] if ] if
! 5 bitstream read-bits ! distance ! 5 bitstream read-bits ! distance
tables second read1-huff2 tables second read1-huff2
dup 3 > dup 3 >
[ [
dup 2 - 2 /i dup 13 > dup 2 - 2 /i dup 13 >
[ bad-zlib-data ] when [ bad-zlib-data ] when
bitstream bs:read 2array bitstream bs:read 2array
] ]
when when
2array 2array
] ]
when when
dup 256 = not dup 256 = not
] ]
[ ] produce nip [ ] produce nip
[ [
dup array? [ dup array? [
first2 first2
[ [
dup array? [ first2 ] [ 0 ] if dup array? [ first2 ] [ 0 ] if
[ 257 - length-table nth ] [ + ] bi* [ 257 - length-table nth ] [ + ] bi*
] ]
[ [
dup array? [ first2 ] [ 0 ] if dup array? [ first2 ] [ 0 ] if
[ dist-table nth ] [ + ] bi* [ dist-table nth ] [ + ] bi*
] bi* ] bi*
2array 2array
] when ] when
] map ; ] map ;
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ; :: inflate-raw ( bitstream -- bytes )
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; 8 bitstream bs:align
16 bitstream bs:read :> len
:: inflate-loop ( bitstream -- bytes ) 16 bitstream bs:read :> nlen
[ 1 bitstream bs:read 0 = ] len nlen + 16 >signed -1 assert= ! len + ~len = -1
[ bitstream byte-pos>>
bitstream bitstream byte-pos>> len +
2 bitstream bs:read bitstream bytes>> <slice>
{ len 8 * bitstream bs:seek ;
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] } : inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
{ 2 [ inflate-dynamic ] }
{ 3 [ bad-zlib-data f ] } :: inflate-loop ( bitstream -- bytes )
} [ 1 bitstream bs:read 0 = ]
case [
] bitstream
[ produce ] keep call suffix concat ; 2 bitstream bs:read
{
! [ produce ] keep dip swap suffix { 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
:: paeth ( a b c -- p ) { 2 [ inflate-dynamic ] }
a b + c - { a b c } [ [ - abs ] keep 2array ] with map { 3 [ bad-zlib-data f ] }
sort-keys first second ; }
case
:: png-unfilter-line ( prev curr filter -- curr' ) ]
prev :> c [ produce ] keep call suffix concat ;
prev 3 tail-slice :> b
curr :> a ! [ produce ] keep dip swap suffix
curr 3 tail-slice :> x
x length [0,b) :: paeth ( a b c -- p )
filter a b + c - { a b c } [ [ - abs ] keep 2array ] with map
{ sort-keys first second ;
{ 0 [ drop ] }
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } :: png-unfilter-line ( prev curr filter -- curr' )
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } prev :> c
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } prev 3 tail-slice :> b
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } curr :> a
curr 3 tail-slice :> x
} case x length [0,b)
curr 3 tail ; filter
{
PRIVATE> { 0 [ drop ] }
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
! for debug -- shows residual values { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
: reverse-png-filter' ( lines -- byte-array ) { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
concat [ 128 + ] B{ } map-as ;
} case
: reverse-png-filter ( lines -- byte-array ) curr 3 tail ;
dup first [ 0 ] replicate prefix
[ { 0 0 } prepend ] map PRIVATE>
2 clump [
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line : reverse-png-filter' ( lines -- byte-array )
] map B{ } concat-as ; [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
concat [ 128 + ] B{ } map-as ;
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader> : reverse-png-filter ( lines -- byte-array )
[ check-zlib-header ] [ inflate-loop ] bi dup first [ 0 ] replicate prefix
inflate-lz77 ; [ { 0 0 } prepend ] map
2 clump [
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
] map B{ } concat-as ;
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
[ check-zlib-header ] [ inflate-loop ] bi
inflate-lz77 ;

665
basis/images/jpeg/jpeg.factor Executable file → Normal file
View File

@ -1,306 +1,359 @@
! Copyright (C) 2009 Marc Fauconneau. ! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators USING: accessors arrays byte-arrays combinators
constructors grouping compression.huffman images constructors grouping compression.huffman images
images.processing io io.binary io.encodings.binary io.files 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
QUALIFIED-WITH: bitstreams bs
SINGLETON: jpeg-image
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each TUPLE: jpeg-image < image
{ headers }
TUPLE: loading-jpeg < image { bitstream }
{ headers } { color-info initial: { f f f f } }
{ bitstream } { quant-tables initial: { f f } }
{ color-info initial: { f f f f } } { huff-tables initial: { f f f f } }
{ quant-tables initial: { f f } } { components } ;
{ huff-tables initial: { f f f f } }
{ components } ; <PRIVATE
<PRIVATE CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ; SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
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 )
! ISO/IEC 10918-1 Table B.1 byte
:: >marker ( byte -- marker ) {
byte { [ dup HEX: CC = ] [ { DAC } ] }
{ { [ dup HEX: C4 = ] [ { DHT } ] }
{ [ dup HEX: CC = ] [ { DAC } ] } { [ dup HEX: C9 = ] [ { JPG } ] }
{ [ dup HEX: C4 = ] [ { DHT } ] } { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
{ [ dup HEX: C9 = ] [ { JPG } ] }
{ [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] } { [ dup HEX: D8 = ] [ { SOI } ] }
{ [ dup HEX: D9 = ] [ { EOI } ] }
{ [ dup HEX: D8 = ] [ { SOI } ] } { [ dup HEX: DA = ] [ { SOS } ] }
{ [ dup HEX: D9 = ] [ { EOI } ] } { [ dup HEX: DB = ] [ { DQT } ] }
{ [ dup HEX: DA = ] [ { SOS } ] } { [ dup HEX: DC = ] [ { DNL } ] }
{ [ dup HEX: DB = ] [ { DQT } ] } { [ dup HEX: DD = ] [ { DRI } ] }
{ [ dup HEX: DC = ] [ { DNL } ] } { [ dup HEX: DE = ] [ { DHP } ] }
{ [ dup HEX: DD = ] [ { DRI } ] } { [ dup HEX: DF = ] [ { EXP } ] }
{ [ dup HEX: DE = ] [ { DHP } ] } { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
{ [ 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: E = ] [ APP byte 4 bits 2array ] } { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
{ [ dup HEX: FE = ] [ { COM } ] }
{ [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] } { [ dup HEX: 01 = ] [ { TEM } ] }
[ { RES } ]
{ [ dup HEX: 01 = ] [ { TEM } ] } }
[ { RES } ] cond nip ;
}
cond nip ; TUPLE: jpeg-chunk length type data ;
TUPLE: jpeg-chunk length type data ; CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
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 ;
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 ) ;
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ; : jpeg> ( -- jpeg-image ) jpeg-image get ;
: jpeg> ( -- jpeg-image ) loading-jpeg get ; : apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ;
: apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ; : fetch-tables ( component -- )
[ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
: fetch-tables ( component -- ) [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
[ [ jpeg> quant-tables>> nth ] change-quant-table drop ] [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
[ [ 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 ;
: read4/4 ( -- a b ) read1 16 /mod ; ! headers
: decode-frame ( header -- )
! headers data>>
binary
: decode-frame ( header -- ) [
data>> read1 8 assert=
binary 2 read be>
[ 2 read be>
read1 8 assert= swap 2array jpeg> (>>dim)
2 read be> read1
2 read be> [
swap 2array jpeg> (>>dim) read1 read4/4 read1 <jpeg-color-info>
read1 swap [ >>id ] keep jpeg> color-info>> set-nth
[ ] times
read1 read4/4 read1 <jpeg-color-info> ] with-byte-reader ;
swap [ >>id ] keep jpeg> color-info>> set-nth
] times : decode-quant-table ( chunk -- )
] with-byte-reader ; dup data>>
binary
: decode-quant-table ( chunk -- ) [
dup data>> length>>
binary 2 - 65 /
[ [
length>> read4/4 [ 0 assert= ] dip
2 - 65 / 64 read
[ swap jpeg> quant-tables>> set-nth
read4/4 [ 0 assert= ] dip ] times
64 read ] with-byte-reader ;
swap jpeg> quant-tables>> set-nth
] times : decode-huff-table ( chunk -- )
] with-byte-reader ; data>>
binary
: decode-huff-table ( chunk -- ) [
data>> 1 ! %fixme: Should handle multiple tables at once
binary [
[ read4/4 swap 2 * +
1 ! %fixme: Should handle multiple tables at once 16 read
[ dup [ ] [ + ] map-reduce read
read4/4 swap 2 * + binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
16 read swap jpeg> huff-tables>> set-nth
dup [ ] [ + ] map-reduce read ] times
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader ] with-byte-reader ;
swap jpeg> huff-tables>> set-nth
] times : decode-scan ( chunk -- )
] with-byte-reader ; data>>
binary
: decode-scan ( chunk -- ) [
data>> read1 [0,b)
binary [ drop
[ read1 jpeg> color-info>> nth clone
read1 [0,b) read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
[ drop ] map jpeg> (>>components)
read1 jpeg> color-info>> nth clone read1 0 assert=
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi* read1 63 assert=
] map jpeg> (>>components) read1 16 /mod [ 0 assert= ] bi@
read1 0 assert= ] with-byte-reader ;
read1 63 assert=
read1 16 /mod [ 0 assert= ] bi@ : singleton-first ( seq -- elt )
] with-byte-reader ; [ length 1 assert= ] [ first ] bi ;
: singleton-first ( seq -- elt ) : baseline-parse ( -- )
[ length 1 assert= ] [ first ] bi ; jpeg> headers>>
{
: baseline-parse ( -- ) [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
jpeg> headers>> [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
{ [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
[ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ] [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
[ [ type>> { DQT } = ] filter [ decode-quant-table ] each ] } cleave ;
[ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
[ [ type>> { SOS } = ] filter singleton-first decode-scan ] : parse-marker ( -- marker )
} cleave ; read1 HEX: FF assert=
read1 >marker ;
: parse-marker ( -- marker )
read1 HEX: FF assert= : parse-headers ( -- chunks )
read1 >marker ; [ parse-marker dup { SOS } = not ]
[
: parse-headers ( -- chunks ) 2 read be>
[ parse-marker dup { SOS } = not ] dup 2 - read <jpeg-chunk>
[ ] [ produce ] keep dip swap suffix ;
2 read be>
dup 2 - read <jpeg-chunk> MEMO: zig-zag ( -- zz )
] [ produce ] keep dip swap suffix ; {
{ 0 1 5 6 14 15 27 28 }
MEMO: zig-zag ( -- zz ) { 2 4 7 13 16 26 29 42 }
{ { 3 8 12 17 25 30 41 43 }
{ 0 1 5 6 14 15 27 28 } { 9 11 18 24 31 40 44 53 }
{ 2 4 7 13 16 26 29 42 } { 10 19 23 32 39 45 52 54 }
{ 3 8 12 17 25 30 41 43 } { 20 22 33 38 46 51 55 60 }
{ 9 11 18 24 31 40 44 53 } { 21 34 37 47 50 56 59 61 }
{ 10 19 23 32 39 45 52 54 } { 35 36 48 49 57 58 62 63 }
{ 20 22 33 38 46 51 55 60 } } flatten ;
{ 21 34 37 47 50 56 59 61 }
{ 35 36 48 49 57 58 62 63 } MEMO: yuv>bgr-matrix ( -- m )
} flatten ; {
{ 1 2.03211 0 }
MEMO: yuv>bgr-matrix ( -- m ) { 1 -0.39465 -0.58060 }
{ { 1 0 1.13983 }
{ 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 )
: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ; { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
:: dct-vect ( u v -- basis )
{ 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2 MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;
MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
! : blocks ( component -- seq )
: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ; ! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
: all-macroblocks ( quot: ( mb -- ) -- ) : all-macroblocks ( quot: ( mb -- ) -- )
[ [
jpeg> jpeg>
[ dim>> 8 v/n ] [ dim>> 8 v/n ]
[ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
[ ceiling ] map [ ceiling ] map
coord-matrix flip concat coord-matrix flip concat
] ]
[ each ] bi* ; inline [ each ] bi* ; inline
: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ; : reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
: idct-factor ( b -- b' ) dct-matrix v.m ; : idct-factor ( b -- b' ) dct-matrix v.m ;
USE: math.blas.vectors USE: math.blas.vectors
USE: math.blas.matrices USE: math.blas.matrices
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ; : V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ; : idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
: 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' )
swap [ ] [ 1- 2^ < ] 2bi swap [ ] [ 1- 2^ < ] 2bi
[ -1 swap shift 1+ + ] [ drop ] if ; [ -1 swap shift 1+ + ] [ drop ] if ;
: read1-jpeg-dc ( decoder -- dc ) : read1-jpeg-dc ( decoder -- dc )
[ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ; [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
: 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
0 :> k! 0 :> k!
[ [
color ac-huff-table>> read1-jpeg-ac color ac-huff-table>> read1-jpeg-ac
[ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
{ 0 0 } = not { 0 0 } = not
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 :: draw-macroblock-yuv420 ( mb blocks -- )
color h>> 2 = mb { 16 16 } v* :> pos
[ 8 group 2 matrix-zoom concat ] unless 0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
pos { 8 8 } v* color 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
: decode-macroblock ( mb -- ) 3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
jpeg> components>> 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 ;
[ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
[ [ decode-block ] curry each ] bi :: draw-macroblock-yuv444 ( mb blocks -- )
] with each ; mb { 8 8 } v* :> pos
3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
: cleanup-bitstream ( bytes -- bytes' )
binary [ :: draw-macroblock-y ( mb blocks -- )
[ mb { 8 8 } v* :> pos
{ HEX: FF } read-until 0 blocks nth pos 0 jpeg> draw-block
read1 tuck HEX: 00 = and 64 0 <array> pos 1 jpeg> draw-block
] 64 0 <array> pos 2 jpeg> draw-block ;
[ drop ] produce
swap >marker { EOI } assert= ! %fixme: color hack
swap suffix ! color h>> 2 =
{ HEX: FF } join ! [ 8 group 2 matrix-zoom concat ] unless
] with-byte-reader ; ! pos { 8 8 } v* color jpeg> draw-block ;
: setup-bitmap ( image -- ) : decode-macroblock ( -- blocks )
dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim jpeg> components>>
BGR >>component-order [
f >>upside-down? [ mb-dim first2 * iota ]
dup dim>> first2 * 3 * 0 <array> >>bitmap [ [ decode-block ] curry replicate ] bi
drop ; ] map concat ;
: baseline-decompress ( -- ) : cleanup-bitstream ( bytes -- bytes' )
jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append binary [
>byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream) [
jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi { HEX: FF } read-until
jpeg> components>> [ fetch-tables ] each read1 tuck HEX: 00 = and
jpeg> setup-bitmap ]
[ decode-macroblock ] all-macroblocks ; [ drop ] produce
swap >marker { EOI } assert=
! this eats ~25% cpu time swap suffix
: color-transform ( yuv -- rgb ) { HEX: FF } join
{ 128 0 0 } v+ yuv>bgr-matrix swap m.v ] with-byte-reader ;
[ 0 max 255 min >fixnum ] map ;
: setup-bitmap ( image -- )
PRIVATE> dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
BGR >>component-order
: load-jpeg ( path -- image ) f >>upside-down?
binary [ dup dim>> first2 * 3 * 0 <array> >>bitmap
parse-marker { SOI } assert= drop ;
parse-headers
contents <loading-jpeg> ERROR: unsupported-colorspace ;
] with-file-reader SINGLETONS: YUV420 YUV444 Y MAGIC! ;
dup loading-jpeg [
baseline-parse :: detect-colorspace ( jpeg-image -- csp )
baseline-decompress jpeg-image color-info>> sift :> colors
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each MAGIC!
jpeg> [ >byte-array ] change-bitmap drop colors length 1 = [ drop Y ] when
] with-variable ; colors length 3 =
[
M: jpeg-image load-image* ( path jpeg-image -- bitmap ) colors [ mb-dim { 1 1 } = ] all?
drop load-jpeg ; [ 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 } = [ not-a-jpeg-image ] unless
parse-headers
contents <jpeg-image>
] with-file-reader
dup jpeg-image [
baseline-parse
baseline-decompress
] with-variable ;
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;

8
basis/math/matrices/matrices.factor Executable file → Normal file
View File

@ -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 ;
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 ;

View File

@ -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-(* ;