From 1c89045f0ec02c15c51fa16d6bd6ac376e3f5cc3 Mon Sep 17 00:00:00 2001 From: prunedtree Date: Thu, 4 Jun 2009 20:42:29 -0700 Subject: [PATCH 1/8] m^n binary exponentiation of matrices --- basis/math/matrices/matrices.factor | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) mode change 100755 => 100644 basis/math/matrices/matrices.factor diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor old mode 100755 new mode 100644 index cfdbe17c06..61e98ee444 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order math.vectors -sequences sequences.private accessors columns ; +USING: accessors arrays columns kernel math math.bits +math.order math.vectors sequences sequences.private ; IN: math.matrices ! Matrices @@ -60,4 +60,9 @@ PRIVATE> gram-schmidt [ normalize ] map ; : cross-zip ( seq1 seq2 -- seq1xseq2 ) - [ [ 2array ] with map ] curry map ; \ No newline at end of file + [ [ 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 ; + From 5e31d6266e86ab68c827adae9b8f2a1c82946659 Mon Sep 17 00:00:00 2001 From: Marc Fauconneau Date: Fri, 5 Jun 2009 15:29:36 +0900 Subject: [PATCH 2/8] ML-style (* nested (* comments *) *) --- extra/nested-comments/nested-comments.factor | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 extra/nested-comments/nested-comments.factor diff --git a/extra/nested-comments/nested-comments.factor b/extra/nested-comments/nested-comments.factor new file mode 100644 index 0000000000..94daffec2d --- /dev/null +++ b/extra/nested-comments/nested-comments.factor @@ -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-(* ; \ No newline at end of file From 9612b430343a8a9fc503edfb420ffe003c9feece Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 5 Jun 2009 03:26:50 -0700 Subject: [PATCH 3/8] bit alignement and absolute positionning for bit-reader --- basis/bitstreams/bitstreams.factor | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 4718f137e4..032e851a79 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -56,13 +56,20 @@ TUPLE: lsb0-bit-writer < bit-writer ; GENERIC: peek ( n bitstream -- value ) 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 -- ) - { - [ byte-pos>> 8 * ] - [ bit-pos>> + + 8 /mod ] - [ (>>bit-pos) ] - [ (>>byte-pos) ] - } cleave ; inline + [ get-abp + ] [ set-abp ] bi ; inline + +: (align) ( n m -- n' ) + [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline + +: align ( n bitstream -- ) + [ get-abp swap (align) ] [ set-abp ] bi ; inline : read ( n bitstream -- value ) [ peek ] [ seek ] 2bi ; inline From f09a2807fa0c9dc0407517e055b5300e6f7be95b Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 5 Jun 2009 03:29:12 -0700 Subject: [PATCH 4/8] implemented inflate-raw (uncompressed chunks) --- basis/compression/inflate/inflate.factor | 433 ++++++++++++----------- 1 file changed, 221 insertions(+), 212 deletions(-) mode change 100755 => 100644 basis/compression/inflate/inflate.factor diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor old mode 100755 new mode 100644 index 7cb43ac68f..ce352827ea --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -1,212 +1,221 @@ -! 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 - -seq ( assoc -- seq ) - dup keys [ ] [ max ] map-reduce 1 + f - [ '[ 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 :> 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 clone - [ '[ _ 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 - [ 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 append ] bi* ] [ suffix ] if ] reduce - [ dup array? [ second 0 ] [ 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 258 - } - -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 :> 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 ] 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 - { - { 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: - [ check-zlib-header ] [ inflate-loop ] bi - inflate-lz77 ; +! 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 + +seq ( assoc -- seq ) + dup keys [ ] [ max ] map-reduce 1 + f + [ '[ 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 :> 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 clone + [ '[ _ 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 + [ 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 append ] bi* ] [ suffix ] if ] reduce + [ dup array? [ second 0 ] [ 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 258 + } + +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 :> 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 ] 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 ) + 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>> + len 8 * bitstream bs:seek ; + +: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; + +:: inflate-loop ( bitstream -- bytes ) + [ 1 bitstream bs:read 0 = ] + [ + bitstream + 2 bitstream bs:read + { + { 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: + [ check-zlib-header ] [ inflate-loop ] bi + inflate-lz77 ; From 011abaa079169c370ed874917669436066144f64 Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 5 Jun 2009 05:28:18 -0700 Subject: [PATCH 5/8] images.jpeg: added support for yuv444 and black and white images --- basis/images/jpeg/jpeg.factor | 665 ++++++++++++++++++---------------- 1 file changed, 359 insertions(+), 306 deletions(-) mode change 100755 => 100644 basis/images/jpeg/jpeg.factor diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor old mode 100755 new mode 100644 index 2cdc32e9df..b66aed043d --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -1,306 +1,359 @@ -! 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 images.loader ; -QUALIFIED-WITH: bitstreams bs -IN: images.jpeg - -SINGLETON: jpeg-image -{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each - -TUPLE: loading-jpeg < image - { headers } - { bitstream } - { color-info initial: { f f f f } } - { quant-tables initial: { f f } } - { huff-tables initial: { f f f f } } - { components } ; - -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 ) loading-jpeg 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 - 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 - ] [ 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 :> 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 >>bitmap - drop ; - -: baseline-decompress ( -- ) - jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> (>>bitstream) - jpeg> [ bitstream>> ] [ [ [ ] 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 - ] with-file-reader - dup loading-jpeg [ - baseline-parse - baseline-decompress - jpeg> bitmap>> 3 [ color-transform ] change-each - jpeg> [ >byte-array ] change-bitmap drop - ] with-variable ; - -M: jpeg-image load-image* ( path jpeg-image -- bitmap ) - drop load-jpeg ; +! 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 } ; + +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 + 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 + ] [ 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 ; + +! : blocks ( component -- seq ) +! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ; + +: 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-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 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 ( color -- pixels ) + color dc-huff-table>> read1-jpeg-dc color apply-diff + 64 0 :> 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 ; + +:: 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 pos 1 jpeg> draw-block + 64 0 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 first2 * iota ] + [ [ decode-block ] curry replicate ] bi + ] map concat ; + +: 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 >>bitmap + drop ; + +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: jpeg> (>>bitstream) + jpeg> + [ bitstream>> ] + [ [ [ ] 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 [ 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 + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; + From 88f8af4b697f8ff271854685be894869412fd2f4 Mon Sep 17 00:00:00 2001 From: Marc Fauconneau Date: Fri, 5 Jun 2009 21:33:04 +0900 Subject: [PATCH 6/8] images.jpeg: added support for yuv444 and black and white images --- basis/images/jpeg/jpeg.factor | 665 ++++++++++++++++++---------------- 1 file changed, 359 insertions(+), 306 deletions(-) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 2cdc32e9df..b66aed043d 100755 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -1,306 +1,359 @@ -! 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 images.loader ; -QUALIFIED-WITH: bitstreams bs -IN: images.jpeg - -SINGLETON: jpeg-image -{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each - -TUPLE: loading-jpeg < image - { headers } - { bitstream } - { color-info initial: { f f f f } } - { quant-tables initial: { f f } } - { huff-tables initial: { f f f f } } - { components } ; - -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 ) loading-jpeg 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 - 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 - ] [ 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 :> 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 >>bitmap - drop ; - -: baseline-decompress ( -- ) - jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> (>>bitstream) - jpeg> [ bitstream>> ] [ [ [ ] 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 - ] with-file-reader - dup loading-jpeg [ - baseline-parse - baseline-decompress - jpeg> bitmap>> 3 [ color-transform ] change-each - jpeg> [ >byte-array ] change-bitmap drop - ] with-variable ; - -M: jpeg-image load-image* ( path jpeg-image -- bitmap ) - drop load-jpeg ; +! 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 } ; + +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 + 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 + ] [ 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 ; + +! : blocks ( component -- seq ) +! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ; + +: 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-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 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 ( color -- pixels ) + color dc-huff-table>> read1-jpeg-dc color apply-diff + 64 0 :> 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 ; + +:: 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 pos 1 jpeg> draw-block + 64 0 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 first2 * iota ] + [ [ decode-block ] curry replicate ] bi + ] map concat ; + +: 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 >>bitmap + drop ; + +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: jpeg> (>>bitstream) + jpeg> + [ bitstream>> ] + [ [ [ ] 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 [ 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 + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; + From 6a67f02f69a3bb6446715bb7b23deea735672142 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Jun 2009 02:43:05 -0500 Subject: [PATCH 7/8] fix load error --- basis/math/matrices/matrices.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 3a3b470ac8..d6bee78c14 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays columns kernel math math.bits -math.order math.vectors sequences sequences.private ; +math.order math.vectors sequences sequences.private fry ; IN: math.matrices ! Matrices From c5a5e943812f1e35dd85f7a6f5714dac1bc85556 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Jun 2009 02:43:13 -0500 Subject: [PATCH 8/8] fix destructors docs --- core/destructors/destructors-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index 536ee19c8b..40482fce05 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -8,16 +8,16 @@ HELP: dispose $nl "No further operations can be performed on a disposable object after this call." $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." $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* { $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." } { $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