From b4ca3d2af570d0b54489febbaa9338f8b657d03d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 14:08:51 -0500 Subject: [PATCH 1/6] handle resize on key-down instead of key-up --- extra/terrain/terrain.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d6905144bb..fb326ef534 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -134,7 +134,7 @@ M: terrain-world tick-length terrain-world H{ - { T{ key-up { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } + { T{ key-down { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } } set-gestures :: handle-input ( world -- ) From dc107aa26c1bca423279d50f8231f77a3d478d08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:43:51 -0500 Subject: [PATCH 2/6] larger default window size for gesture-logger --- extra/gesture-logger/gesture-logger.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index e03204dc35..0dc0f05205 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -25,6 +25,7 @@ M: gesture-logger user-input* : gesture-logger ( -- ) [ t >>scrolls? dup + { 450 500 } >>pref-dim "Gesture log" open-window "Gesture input" open-window From ac32822b116a1e9451401a4ffe26fb26ef3fe938 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:44:57 -0500 Subject: [PATCH 3/6] replace my bitstream-reader with marc's bitstreams. implement a minimal bit-writer --- basis/bitstreams/bitstreams.factor | 217 ++++++++++++++++++----------- basis/compression/lzw/lzw.factor | 26 ++-- 2 files changed, 149 insertions(+), 94 deletions(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 7113b650fd..d7d13cf17c 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -1,96 +1,147 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays destructors fry io kernel locals -math sequences ; +USING: accessors alien.accessors assocs byte-arrays combinators +constructors destructors fry io io.binary io.encodings.binary +io.streams.byte-array kernel locals macros math math.ranges +multiline sequences sequences.private vectors byte-vectors +combinators.short-circuit math.bitwise ; IN: bitstreams -TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ; -TUPLE: bitstream-reader < bitstream ; +TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; -: reset-bitstream ( stream -- stream ) - 0 >>#bits 0 >>current-bits ; inline +ERROR: invalid-widthed bits #bits ; -: new-bitstream ( stream class -- bitstream ) - new - swap >>stream - reset-bitstream ; inline +: check-widthed ( bits #bits -- bits #bits ) + dup 0 < [ invalid-widthed ] when + 2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when + over 0 = [ + 2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when + ] unless ; -M: bitstream-reader dispose ( stream -- ) - stream>> dispose ; +: ( bits #bits -- widthed ) + check-widthed + widthed boa ; -: ( stream -- bitstream ) - bitstream-reader new-bitstream ; inline +: zero-widthed ( -- widthed ) 0 0 ; +: zero-widthed? ( widthed -- ? ) zero-widthed = ; -: read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 [ - >>current-bits 8 >>#bits +TUPLE: bit-reader + { bytes byte-array } + { byte-pos array-capacity initial: 0 } + { bit-pos array-capacity initial: 0 } ; + +TUPLE: bit-writer + { bytes byte-vector } + { widthed widthed } ; + +TUPLE: msb0-bit-reader < bit-reader ; +TUPLE: lsb0-bit-reader < bit-reader ; +CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ; +CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; + +TUPLE: msb0-bit-writer < bit-writer ; +TUPLE: lsb0-bit-writer < bit-writer ; +CONSTRUCTOR: msb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; +CONSTRUCTOR: lsb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; + +! interface + +GENERIC: peek ( n bitstream -- value ) +GENERIC: poke ( value n bitstream -- ) + +: seek ( n bitstream -- ) + { + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] + [ (>>byte-pos) ] + } cleave ; inline + +: read ( n bitstream -- value ) + [ peek ] [ seek ] 2bi ; inline + + +! reading + +quot ; + +GENERIC: fetch3-le-unsafe ( n byte-array -- value ) +GENERIC: fetch3-be-unsafe ( n byte-array -- value ) + +: fetch3-unsafe ( byte-array n offsets -- value ) + multi-alien-unsigned-1 8 2^ * + 8 2^ * + ; inline + +M: byte-array fetch3-le-unsafe ( n byte-array -- value ) + swap { 0 1 2 } fetch3-unsafe ; inline +M: byte-array fetch3-be-unsafe ( n byte-array -- value ) + swap { 2 1 0 } fetch3-unsafe ; inline + +: fetch3 ( n byte-array -- value ) + [ 3 [0,b) [ + ] with map ] dip [ nth ] curry map ; + +: fetch3-le ( n byte-array -- value ) fetch3 le> ; +: fetch3-be ( n byte-array -- value ) fetch3 be> ; + +GENERIC: peek16 ( n bitstream -- value ) + +M:: lsb0-bit-reader peek16 ( n bs -- v ) + bs byte-pos>> bs bytes>> fetch3-le + bs bit-pos>> 2^ /i + n 2^ mod ; + +M:: msb0-bit-reader peek16 ( n bs -- v ) + bs byte-pos>> bs bytes>> fetch3-be + 24 n bs bit-pos>> + - 2^ /i + n 2^ mod ; + +PRIVATE> + +M: lsb0-bit-reader peek ( n bs -- v ) peek16 ; +M: msb0-bit-reader peek ( n bs -- v ) peek16 ; + +! writing + +> ] dip < [ not-enough-bits ] when + [ [ bits>> ] [ #bits>> ] bi ] dip + [ - neg shift ] keep ; + +: split-widthed ( widthed n -- widthed1 widthed2 ) + 2dup [ #bits>> ] dip < [ + drop zero-widthed ] [ - 0 >>#bits - t >>end-of-stream? - ] if* ; - -: maybe-read-next-byte ( bitstream -- bitstream ) - dup #bits>> 0 = [ read-next-byte ] when ; inline - -: shift-one-bit ( bitstream -- n ) - [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline - -: next-bit ( bitstream -- n/f ? ) - maybe-read-next-byte - dup end-of-stream?>> [ - drop f - ] [ - [ shift-one-bit ] - [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi - ] if dup >boolean ; - -: read-bit ( bitstream -- n ? ) - dup #bits>> 1 = [ - [ current-bits>> 1 bitand ] - [ read-next-byte drop ] bi t - ] [ - next-bit - ] if ; inline - -: bits>integer ( seq -- n ) - 0 [ [ 1 shift ] dip bitor ] reduce ; inline - -: read-bits ( width bitstream -- n width ? ) - [ - '[ _ read-bit drop ] replicate - [ f = ] trim-tail - [ bits>integer ] [ length ] bi - ] 2keep drop over = ; - -TUPLE: bitstream-writer < bitstream ; - -: ( stream -- bitstream ) - bitstream-writer new-bitstream ; inline - -: write-bit ( n bitstream -- ) - [ 1 shift bitor ] change-current-bits - [ 1+ ] change-#bits - dup #bits>> 8 = [ - [ [ current-bits>> ] [ stream>> stream-write1 ] bi ] - [ reset-bitstream drop ] bi - ] [ - drop - ] if ; inline - -ERROR: invalid-bit-width n ; - -:: write-bits ( n width bitstream -- ) - n 0 < [ n invalid-bit-width ] when - n 0 = [ - width [ 0 bitstream write-bit ] times - ] [ - width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times - n-length [ - n-length swap - 1- neg n swap shift 1 bitand - bitstream write-bit - ] each + [ widthed-bits ] + [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep ] 2bi ] if ; -: flush-bits ( bitstream -- ) stream>> stream-flush ; +: widthed>bytes ( widthed -- bytes widthed ) + [ 8 split-widthed dup zero-widthed? not ] + [ swap bits>> ] B{ } produce-as nip swap ; -: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ; +PRIVATE> + +M:: lsb0-bit-writer poke ( value n bs -- ) + value n :> widthed + widthed + bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte + + byte #bits>> 8 = [ + byte bits>> bs bytes>> push + zero-widthed bs (>>widthed) + remainder widthed>bytes + [ bs bytes>> push-all ] [ B bs (>>widthed) ] bi* + ] [ + byte bs (>>widthed) + ] if ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 29cbe96d69..592a0efb6c 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bitstreams byte-vectors combinators io -io.encodings.binary io.streams.byte-array kernel math sequences -vectors ; -IN: compression.lzw +USING: accessors alien.accessors byte-arrays combinators +constructors destructors fry io io.binary kernel locals macros +math math.ranges multiline sequences sequences.private ; +IN: bitstreams + +QUALIFIED-WITH: bitstreams bs CONSTANT: clear-code 256 CONSTANT: end-of-information 257 @@ -52,7 +54,8 @@ ERROR: index-too-big n ; : ( input -- obj ) lzw new swap >>input - binary >>output + ! binary >>output + V{ } clone >>output ! TODO reset-lzw-compress ; : ( input -- obj ) @@ -76,7 +79,7 @@ ERROR: not-in-table value ; [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless ] [ [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] bi ; : omega-k>omega ( lzw -- lzw ) @@ -114,18 +117,18 @@ ERROR: not-in-table value ; [ [ clear-code ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ (lzw-compress-chars) ] [ [ k>> ] [ lzw-bit-width-compress ] - [ output>> write-bits ] tri + [ output>> bs:poke ] tri ] [ [ end-of-information ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ ] } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; @@ -152,7 +155,7 @@ ERROR: not-in-table value ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) @@ -200,5 +203,6 @@ DEFER: lzw-uncompress-char ] if* ; : lzw-uncompress ( seq -- byte-array ) - binary + + ! binary ! [ lzw-uncompress-char ] [ output>> ] bi ; From c443d6d8159bce11eef509d806d564d6ef32b41e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:46:10 -0500 Subject: [PATCH 4/6] check in marc's jpeg loader, png decoder, huffman, inflate, and image-processing vocabularies --- basis/compression/huffman/huffman.factor | 88 +++++++ basis/compression/inflate/inflate.factor | 209 +++++++++++++++ basis/images/jpeg/jpeg.factor | 304 ++++++++++++++++++++++ basis/images/loader/loader.factor | 6 +- basis/images/png/png.factor | 21 +- basis/images/processing/processing.factor | 40 +++ 6 files changed, 665 insertions(+), 3 deletions(-) create mode 100755 basis/compression/huffman/huffman.factor create mode 100755 basis/compression/inflate/inflate.factor create mode 100755 basis/images/jpeg/jpeg.factor create mode 100755 basis/images/processing/processing.factor diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor new file mode 100755 index 0000000000..60b3a1d5a1 --- /dev/null +++ b/basis/compression/huffman/huffman.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alt.bitstreams arrays assocs constructors fry +hashtables io kernel locals math math.order math.parser +math.ranges multiline sequences ; +IN: compression.huffman + +QUALIFIED-WITH: alt.bitstreams bs + + ( -- code ) 0 0 0 huffman-code boa ; +: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ; +: next-code ( code -- ) [ 1+ ] change-code drop ; + +:: all-patterns ( huff n -- seq ) + n log2 huff size>> - :> free-bits + free-bits 0 > + [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ] + [ huff code>> free-bits neg 2^ /i 1array ] if ; + +:: huffman-each ( tdesc quot: ( huff -- ) -- ) + :> code + tdesc + [ + code next-size + [ code (>>value) code clone quot call code next-code ] each + ] each ; inline + +: update-reverse-table ( huff n table -- ) + [ drop all-patterns ] + [ nip '[ _ swap _ set-at ] each ] 3bi ; + +:: reverse-table ( tdesc n -- rtable ) + n f :> table + tdesc [ n table update-reverse-table ] huffman-each + table seq>> ; + +:: huffman-table ( tdesc max -- table ) + max f :> table + tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each + table ; + +PRIVATE> + +! decoder + +TUPLE: huffman-decoder + { bs } + { tdesc } + { rtable } + { bits/level } ; + +CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder ) + 16 >>bits/level + [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; + +: read1-huff ( decoder -- elt ) + 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; + +! %remove +: reverse-bits ( value bits -- value' ) + [ >bin ] [ CHAR: 0 pad-head bin> ] bi* ; + +: read1-huff2 ( decoder -- elt ) + 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; + +/* +: huff>string ( code -- str ) + [ value>> number>string ] + [ [ code>> ] [ size>> bits>string ] bi ] bi + " = " glue ; + +: huff. ( code -- ) huff>string print ; + +:: rtable. ( rtable -- ) + rtable length>> log2 :> n + rtable [ swap n bits. [ huff. ] each ] assoc-each ; +*/ diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor new file mode 100755 index 0000000000..a828718f75 --- /dev/null +++ b/basis/compression/inflate/inflate.factor @@ -0,0 +1,209 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs byte-arrays +byte-vectors combinators constructors fry grouping hashtables +compression.huffman images io.binary kernel locals +math math.bitwise math.order math.ranges multiline sequences +sorting ; +IN: compression.inflate + +QUALIFIED-WITH: alt.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 + } + +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 ! B + { + { 0 [ inflate-raw ] } + { 1 [ inflate-static ] } + { 2 [ inflate-dynamic ] } + { 3 [ bad-zlib-data f ] } + } + case + ] + [ produce ] keep call suffix concat ; + + ! [ produce ] keep dip swap suffix + +:: paeth ( a b c -- p ) + a b + c - { a b c } [ [ - abs ] keep 2array ] with map + sort-keys first second ; + +:: png-unfilter-line ( prev curr filter -- curr' ) + prev :> c + prev 3 tail-slice :> b + curr :> a + curr 3 tail-slice :> x + x length [0,b) + filter + { + { 0 [ drop ] } + { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } + { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } + { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } + { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } + + } case + curr 3 tail ; + +PRIVATE> + +! for debug -- shows residual values +: reverse-png-filter' ( lines -- filtered ) + [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip + concat [ 128 + 256 wrap ] map ; + +: reverse-png-filter ( lines -- filtered ) + dup first [ 0 ] replicate prefix + [ { 0 0 } prepend ] map + 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; + +: zlib-inflate ( bytes -- bytes ) + bs: + [ check-zlib-header ] + [ inflate-loop ] bi + inflate-lz77 ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor new file mode 100755 index 0000000000..0588e5c365 --- /dev/null +++ b/basis/images/jpeg/jpeg.factor @@ -0,0 +1,304 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators +constructors grouping compression.huffman images +images.processing io io.binary io.encodings.binary io.files +io.streams.byte-array kernel locals math math.bitwise +math.constants math.functions math.matrices math.order +math.ranges math.vectors memoize multiline namespaces +sequences sequences.deep ; +IN: images.jpeg + +QUALIFIED-WITH: alt.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 ; + +: 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 jpeg-image [ + 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 ; diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index fe33cc8f00..27b726f3c0 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images io.pathnames ; +accessors images.bitmap images.tiff images io.pathnames +images.jpeg images.png ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -11,6 +12,9 @@ ERROR: unknown-image-extension extension ; { "bmp" [ bitmap-image ] } { "tif" [ tiff-image ] } { "tiff" [ tiff-image ] } + { "jpg" [ jpeg-image ] } + { "jpeg" [ jpeg-image ] } + { "png" [ png-image ] } [ unknown-image-extension ] } case ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b027362977..bf13c43546 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -3,7 +3,7 @@ USING: accessors constructors images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.files io.files.info kernel sequences io.streams.limited fry combinators arrays math -checksums checksums.crc32 ; +checksums checksums.crc32 compression.inflate grouping byte-arrays ; IN: images.png TUPLE: png-image < image chunks @@ -17,7 +17,8 @@ TUPLE: png-chunk length type data ; CONSTRUCTOR: png-chunk ( -- png-chunk ) ; -CONSTANT: png-header B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a } +CONSTANT: png-header + B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a } ERROR: bad-png-header header ; @@ -61,6 +62,18 @@ ERROR: bad-checksum ; : fill-image-data ( image -- image ) dup [ width>> ] [ height>> ] bi 2array >>dim ; +: zlib-data ( png-image -- bytes ) + chunks>> [ type>> "IDAT" = ] find nip data>> ; + +: decode-png ( image -- image ) + { + [ zlib-data zlib-inflate ] + [ dim>> first 3 * 1 + group reverse-png-filter ] + [ swap >byte-array >>bitmap drop ] + [ RGB >>component-order drop ] + [ ] + } cleave ; + : load-png ( path -- image ) [ binary ] [ file-info size>> ] bi stream-throws [ @@ -69,4 +82,8 @@ ERROR: bad-checksum ; read-png-chunks parse-ihdr-chunk fill-image-data + decode-png ] with-input-stream ; + +M: png-image load-image* + drop load-png ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor new file mode 100755 index 0000000000..2304c56171 --- /dev/null +++ b/basis/images/processing/processing.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators grouping images +images.loader images.viewer kernel locals math math.order +math.ranges math.vectors sequences sequences.deep fry ; +IN: images.processing + +: coord-matrix ( dim -- m ) + [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ; + +: map^2 ( m quot -- m' ) '[ _ map ] map ; inline +: each^2 ( m quot -- m' ) '[ _ each ] each ; inline + +: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ; + +: matrix>image ( m -- image ) + over matrix-dim >>dim + swap flip flatten + [ 128 * 128 + 0 max 255 min >fixnum ] map + >byte-array >>bitmap L >>component-order ; + +:: matrix-zoom ( m f -- m' ) + m matrix-dim f v*n coord-matrix + [ [ f /i ] map first2 swap m nth nth ] map^2 ; + +:: image-offset ( x,y image -- xy ) + image dim>> first + x,y second * x,y first + ; + +:: draw-grey ( value x,y image -- ) + x,y image image-offset 3 * { 0 1 2 } + [ + + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth + ] with each ; + +:: draw-color ( value x,y color-id image -- ) + x,y image image-offset 3 * color-id + value >fixnum + swap image bitmap>> set-nth ; + +! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ; From af2f62ae62721481c66b63dcadb81d1fdf4b6a13 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 23:33:00 -0500 Subject: [PATCH 5/6] remove all the compress code from lzw until it works, fix bitstreams --- basis/bitstreams/bitstreams-tests.factor | 58 +++++++--- basis/bitstreams/bitstreams.factor | 128 ++++++++++++---------- basis/compression/lzw/lzw.factor | 117 ++------------------ basis/images/processing/processing.factor | 2 +- 4 files changed, 123 insertions(+), 182 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 769efcbb04..a5b1b43acd 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary io.streams.byte-array ; IN: bitstreams.tests -[ 1 t ] -[ B{ 254 } binary read-bit ] unit-test -[ 254 8 t ] -[ B{ 254 } binary 8 swap read-bits ] unit-test - -[ 4095 12 t ] -[ B{ 255 255 } binary 12 swap read-bits ] unit-test - -[ B{ 254 } ] +[ BIN: 1111111111 ] [ - binary 254 8 rot - [ write-bits ] keep stream>> >byte-array + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 10 swap peek ] unit-test -[ 255 8 t ] -[ B{ 255 } binary 8 swap read-bits ] unit-test +[ BIN: 111111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 9 swap peek +] unit-test -[ 255 8 f ] -[ B{ 255 } binary 9 swap read-bits ] unit-test +[ BIN: 11111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 8 swap peek +] unit-test + +[ BIN: 1111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 7 swap peek +] unit-test + +[ BIN: 111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 6 swap peek +] unit-test + +[ BIN: 11111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 5 swap peek +] unit-test + +[ B{ } 5 swap peek ] must-fail +[ B{ } 1 swap peek ] must-fail +[ B{ } 8 swap peek ] must-fail + +[ 0 ] [ B{ } 0 swap peek ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index d7d13cf17c..997daa2c5d 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -23,7 +23,7 @@ ERROR: invalid-widthed bits #bits ; widthed boa ; : zero-widthed ( -- widthed ) 0 0 ; -: zero-widthed? ( widthed -- ? ) zero-widthed = ; +: zero-widthed? ( widthed -- ? ) zero-widthed = ; TUPLE: bit-reader { bytes byte-array } @@ -41,73 +41,32 @@ CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; TUPLE: msb0-bit-writer < bit-writer ; TUPLE: lsb0-bit-writer < bit-writer ; -CONSTRUCTOR: msb0-bit-writer ( -- bs ) - BV{ } clone >>bytes - 0 0 >>widthed ; -CONSTRUCTOR: lsb0-bit-writer ( -- bs ) - BV{ } clone >>bytes - 0 0 >>widthed ; -! interface +: new-bit-writer ( class -- bs ) + new + BV{ } clone >>bytes + 0 0 >>widthed ; inline + +: ( -- bs ) + msb0-bit-writer new-bit-writer ; + +: ( -- bs ) + lsb0-bit-writer new-bit-writer ; GENERIC: peek ( n bitstream -- value ) GENERIC: poke ( value n bitstream -- ) : seek ( n bitstream -- ) { - [ byte-pos>> 8 * ] - [ bit-pos>> + + 8 /mod ] - [ (>>bit-pos) ] + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] [ (>>byte-pos) ] } cleave ; inline : read ( n bitstream -- value ) [ peek ] [ seek ] 2bi ; inline - -! reading - -quot ; - -GENERIC: fetch3-le-unsafe ( n byte-array -- value ) -GENERIC: fetch3-be-unsafe ( n byte-array -- value ) - -: fetch3-unsafe ( byte-array n offsets -- value ) - multi-alien-unsigned-1 8 2^ * + 8 2^ * + ; inline - -M: byte-array fetch3-le-unsafe ( n byte-array -- value ) - swap { 0 1 2 } fetch3-unsafe ; inline -M: byte-array fetch3-be-unsafe ( n byte-array -- value ) - swap { 2 1 0 } fetch3-unsafe ; inline - -: fetch3 ( n byte-array -- value ) - [ 3 [0,b) [ + ] with map ] dip [ nth ] curry map ; - -: fetch3-le ( n byte-array -- value ) fetch3 le> ; -: fetch3-be ( n byte-array -- value ) fetch3 be> ; - -GENERIC: peek16 ( n bitstream -- value ) - -M:: lsb0-bit-reader peek16 ( n bs -- v ) - bs byte-pos>> bs bytes>> fetch3-le - bs bit-pos>> 2^ /i - n 2^ mod ; - -M:: msb0-bit-reader peek16 ( n bs -- v ) - bs byte-pos>> bs bytes>> fetch3-be - 24 n bs bit-pos>> + - 2^ /i - n 2^ mod ; - -PRIVATE> - -M: lsb0-bit-reader peek ( n bs -- v ) peek16 ; -M: msb0-bit-reader peek ( n bs -- v ) peek16 ; - -! writing - > ] B{ } produce-as nip swap ; +:: |widthed ( widthed1 widthed2 -- widthed3 ) + widthed1 bits>> :> bits1 + widthed1 #bits>> :> #bits1 + widthed2 bits>> :> bits2 + widthed2 #bits>> :> #bits2 + bits1 #bits2 shift bits2 bitor + #bits1 #bits2 + ; + PRIVATE> M:: lsb0-bit-writer poke ( value n bs -- ) value n :> widthed widthed bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte - - byte #bits>> 8 = [ - byte bits>> bs bytes>> push + byte bs widthed>> |widthed :> new-byte + new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [ + new-byte bits>> bs bytes>> push zero-widthed bs (>>widthed) remainder widthed>bytes - [ bs bytes>> push-all ] [ B bs (>>widthed) ] bi* + [ bs bytes>> push-all ] [ bs (>>widthed) ] bi* ] [ byte bs (>>widthed) ] if ; + +: enough-bits? ( n bs -- ? ) + [ bytes>> length ] + [ byte-pos>> - 8 * ] + [ bit-pos>> - ] tri <= ; + +ERROR: not-enough-bits n bit-reader ; + +: #bits>#bytes ( #bits -- #bytes ) + 8 /mod 0 = [ 1 + ] unless ; inline + +:: subseq>bits ( bignum n bs -- bits ) + bignum + 8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when + neg shift n bits ; + +:: adjust-bits ( n bs -- ) + n 8 /mod :> #bits :> #bytes + bs [ #bytes + ] change-byte-pos + bit-pos>> #bits + dup 8 >= [ + 8 - bs (>>bit-pos) + bs [ 1 + ] change-byte-pos drop + ] [ + bs (>>bit-pos) + ] if ; + +:: (peek) ( n bs word -- bits ) + n bs enough-bits? [ n bs not-enough-bits ] unless + bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd + + bs bytes>> subseq word execute( seq -- x ) :> bignum + bignum n bs subseq>bits ; + +M: lsb0-bit-reader peek ( n bs -- bits ) \ le> (peek) ; + +M: msb0-bit-reader peek ( n bs -- bits ) \ be> (peek) ; + +:: bit-writer-bytes ( writer -- bytes ) + writer widthed>> #bits>> :> n + n 0 = [ + writer widthed>> bits>> 8 n - shift + writer bytes>> swap push + ] unless + writer bytes>> ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 592a0efb6c..46a319662e 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,22 +1,19 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.accessors byte-arrays combinators -constructors destructors fry io io.binary kernel locals macros -math math.ranges multiline sequences sequences.private ; -IN: bitstreams +USING: accessors alien.accessors assocs byte-arrays combinators +io.encodings.binary io.streams.byte-array kernel math sequences +vectors ; +IN: compression.lzw QUALIFIED-WITH: bitstreams bs CONSTANT: clear-code 256 CONSTANT: end-of-information 257 -TUPLE: lzw input output end-of-input? table count k omega omega-k #bits -code old-code ; +TUPLE: lzw input output table code old-code ; SYMBOL: table-full -ERROR: index-too-big n ; - : lzw-bit-width ( n -- n' ) { { [ dup 510 <= ] [ drop 9 ] } @@ -26,37 +23,14 @@ ERROR: index-too-big n ; [ drop table-full ] } cond ; -: lzw-bit-width-compress ( lzw -- n ) - count>> lzw-bit-width ; - : lzw-bit-width-uncompress ( lzw -- n ) table>> length lzw-bit-width ; -: initial-compress-table ( -- assoc ) - 258 iota [ [ 1vector ] keep ] H{ } map>assoc ; - : initial-uncompress-table ( -- seq ) 258 iota [ 1vector ] V{ } map-as ; -: reset-lzw ( lzw -- lzw ) - 257 >>count - V{ } clone >>omega - V{ } clone >>omega-k - 9 >>#bits ; - -: reset-lzw-compress ( lzw -- lzw ) - f >>k - initial-compress-table >>table reset-lzw ; - : reset-lzw-uncompress ( lzw -- lzw ) - initial-uncompress-table >>table reset-lzw ; - -: ( input -- obj ) - lzw new - swap >>input - ! binary >>output - V{ } clone >>output ! TODO - reset-lzw-compress ; + initial-uncompress-table >>table ; : ( input -- obj ) lzw new @@ -64,79 +38,8 @@ ERROR: index-too-big n ; BV{ } clone >>output reset-lzw-uncompress ; -: push-k ( lzw -- lzw ) - [ ] - [ k>> ] - [ omega>> clone [ push ] keep ] tri >>omega-k ; - -: omega-k-in-table? ( lzw -- ? ) - [ omega-k>> ] [ table>> ] bi key? ; - ERROR: not-in-table value ; -: write-output ( lzw -- ) - [ - [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless - ] [ - [ lzw-bit-width-compress ] - [ output>> bs:poke ] bi - ] bi ; - -: omega-k>omega ( lzw -- lzw ) - dup omega-k>> clone >>omega ; - -: k>omega ( lzw -- lzw ) - dup k>> 1vector >>omega ; - -: add-omega-k ( lzw -- ) - [ [ 1+ ] change-count count>> ] - [ omega-k>> clone ] - [ table>> ] tri set-at ; - -: lzw-compress-char ( lzw k -- ) - >>k push-k dup omega-k-in-table? [ - omega-k>omega drop - ] [ - [ write-output ] - [ add-omega-k ] - [ k>omega drop ] tri - ] if ; - -: (lzw-compress-chars) ( lzw -- ) - dup lzw-bit-width-compress table-full = [ - drop - ] [ - dup input>> stream-read1 - [ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ] - [ t >>end-of-input? drop ] if* - ] if ; - -: lzw-compress-chars ( lzw -- ) - { - ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ] - [ - [ clear-code ] dip - [ lzw-bit-width-compress ] - [ output>> bs:poke ] bi - ] - [ (lzw-compress-chars) ] - [ - [ k>> ] - [ lzw-bit-width-compress ] - [ output>> bs:poke ] tri - ] - [ - [ end-of-information ] dip - [ lzw-bit-width-compress ] - [ output>> bs:poke ] bi - ] - [ ] - } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; - -: lzw-compress ( byte-array -- seq ) - binary - [ lzw-compress-chars ] [ output>> stream>> ] bi ; - : lookup-old-code ( lzw -- vector ) [ old-code>> ] [ table>> ] bi nth ; @@ -155,7 +58,7 @@ ERROR: not-in-table value ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) @@ -203,6 +106,6 @@ DEFER: lzw-uncompress-char ] if* ; : lzw-uncompress ( seq -- byte-array ) - - ! binary ! - [ lzw-uncompress-char ] [ output>> ] bi ; + bs: + + [ lzw-uncompress-char ] [ output>> ] bi ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor index 2304c56171..fc463731b3 100755 --- a/basis/images/processing/processing.factor +++ b/basis/images/processing/processing.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays combinators grouping images -images.loader images.viewer kernel locals math math.order +kernel locals math math.order math.ranges math.vectors sequences sequences.deep fry ; IN: images.processing From 451a13c740d3cf82f881b78a8937c13563b783ed Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 01:27:00 -0500 Subject: [PATCH 6/6] oops, i was using alt.bitstreams in some places --- basis/compression/huffman/huffman.factor | 4 ++-- basis/compression/inflate/inflate.factor | 4 ++-- basis/images/jpeg/jpeg.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 60b3a1d5a1..6ef9c2fabc 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alt.bitstreams arrays assocs constructors fry +USING: accessors arrays assocs constructors fry hashtables io kernel locals math math.order math.parser math.ranges multiline sequences ; IN: compression.huffman -QUALIFIED-WITH: alt.bitstreams bs +QUALIFIED-WITH: bitstreams bs 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; : zlib-inflate ( bytes -- bytes ) - bs: + bs: [ check-zlib-header ] [ inflate-loop ] bi inflate-lz77 ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 0588e5c365..648923704a 100755 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -9,7 +9,7 @@ math.ranges math.vectors memoize multiline namespaces sequences sequences.deep ; IN: images.jpeg -QUALIFIED-WITH: alt.bitstreams bs +QUALIFIED-WITH: bitstreams bs TUPLE: jpeg-image < image { headers } @@ -274,7 +274,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; : baseline-decompress ( -- ) jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> (>>bitstream) + >byte-array bs: jpeg> (>>bitstream) jpeg> [ bitstream>> ] [ [ [ ] with map ] change-huff-tables drop ] bi jpeg> components>> [ fetch-tables ] each jpeg> setup-bitmap