From af2f62ae62721481c66b63dcadb81d1fdf4b6a13 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 23:33:00 -0500 Subject: [PATCH] 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