diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor new file mode 100644 index 0000000000..d281b0718a --- /dev/null +++ b/basis/compression/run-length/run-length.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays grouping sequences ; +IN: compression.run-length + +: run-length-uncompress8 ( byte-array -- byte-array' ) + 2 group [ first2 ] map concat ; diff --git a/basis/images/authors.txt b/basis/images/authors.txt index b4bd0e7b35..a4a77d97e9 100644 --- a/basis/images/authors.txt +++ b/basis/images/authors.txt @@ -1 +1,2 @@ -Doug Coleman \ No newline at end of file +Doug Coleman +Daniel Ehrenberg diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 48095bb26b..8bf8d59944 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns -combinators fry grouping io io.binary io.encodings.binary io.files -kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary locals ; +combinators compression.run-length endian fry grouping images +images.loader io io.binary io.encodings.binary io.files kernel +locals macros math math.bitwise math.functions namespaces +sequences strings summary ; IN: images.bitmap : assert-sequence= ( a b -- ) @@ -21,7 +22,8 @@ TUPLE: bitmap-image < image ; TUPLE: loading-bitmap size reserved offset header-length width height planes bit-count compression size-image -x-pels y-pels color-used color-important rgb-quads color-index ; +x-pels y-pels color-used color-important color-palette color-index +uncompressed-bytes ; ERROR: bitmap-magic magic ; @@ -31,7 +33,7 @@ M: bitmap-magic summary buffer ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-palette>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; ERROR: bmp-not-supported n ; @@ -39,7 +41,7 @@ ERROR: bmp-not-supported n ; : reverse-lines ( byte-array width -- byte-array ) concat ; inline -: raw-bitmap>seq ( loading-bitmap -- array ) +: bitmap>bytes ( loading-bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } @@ -48,6 +50,21 @@ ERROR: bmp-not-supported n ; [ bmp-not-supported ] } case >byte-array ; +ERROR: unsupported-bitmap-compression compression ; + +: uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) + dup compression>> { + { 0 [ ] } + { 1 [ [ run-length-uncompress8 ] change-color-index ] } + { 2 [ "run-length encoding 4" unsupported-bitmap-compression ] } + { 3 [ "bitfields" unsupported-bitmap-compression ] } + { 4 [ "jpeg" unsupported-bitmap-compression ] } + { 5 [ "png" unsupported-bitmap-compression ] } + } case ; + +: loading-bitmap>bytes ( loading-bitmap -- byte-array ) + uncompress-bitmap bitmap>bytes ; + : parse-file-header ( loading-bitmap -- loading-bitmap ) 2 read "BM" assert-sequence= read4 >>size @@ -67,7 +84,7 @@ ERROR: bmp-not-supported n ; read4 >>color-used read4 >>color-important ; -: rgb-quads-length ( loading-bitmap -- n ) +: color-palette-length ( loading-bitmap -- n ) [ offset>> 14 - ] [ header-length>> ] bi - ; : color-index-length ( loading-bitmap -- n ) @@ -98,11 +115,11 @@ ERROR: bmp-not-supported n ; ] when ; : parse-bitmap ( loading-bitmap -- loading-bitmap ) - dup rgb-quads-length read >>rgb-quads + dup color-palette-length read >>color-palette dup color-index-length read >>color-index fixup-color-index ; -: load-bitmap-data ( path -- loading-bitmap ) +: load-bitmap ( path -- loading-bitmap ) binary [ loading-bitmap new parse-file-header parse-bitmap-header parse-bitmap @@ -120,14 +137,16 @@ ERROR: unknown-component-order bitmap ; : loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) { - [ raw-bitmap>seq >>bitmap ] + [ loading-bitmap>bytes >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] [ height>> 0 < [ t >>upside-down? ] when ] [ bitmap>component-order >>component-order ] } cleave ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - swap load-bitmap-data loading-bitmap>bitmap-image ; + swap load-bitmap loading-bitmap>bitmap-image ; + +"bmp" bitmap-image register-image-class PRIVATE> @@ -183,7 +202,7 @@ PRIVATE> ! color-important [ drop 0 write4 ] - ! rgb-quads + ! color-palette [ [ bitmap>color-index ] [ dim>> first 3 * ] diff --git a/basis/images/images-tests.factor b/basis/images/images-tests.factor new file mode 100644 index 0000000000..8918dcb38c --- /dev/null +++ b/basis/images/images-tests.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: images tools.test kernel accessors ; +IN: images.tests + +[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{ + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 57 57 57 255 + 0 0 0 0 + 0 0 0 0 +} } pixel-at ] unit-test + +[ B{ + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 57 57 57 255 + 0 0 0 0 + 0 0 0 0 +} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{ + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 +} } [ set-pixel-at ] keep bitmap>> ] unit-test diff --git a/basis/images/images.factor b/basis/images/images.factor index 178b91ab52..62c4f7e2ed 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2009 Doug Coleman. +! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel accessors ; +USING: combinators kernel accessors sequences math arrays ; IN: images SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR @@ -35,3 +35,28 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; GENERIC: load-image* ( path tuple -- image ) + +: make-image ( bitmap -- image ) + ! bitmap is a sequence of sequences of pixels which are RGBA + + over [ first length ] [ length ] bi 2array >>dim + RGBA >>component-order + swap concat concat B{ } like >>bitmap ; + +> first * + ] + [ component-order>> bytes-per-pixel [ * dup ] keep + ] + [ bitmap>> ] tri ; + +: set-subseq ( new-value from to victim -- ) + 0 swap copy ; inline + +PRIVATE> + +: pixel-at ( x y image -- pixel ) + pixel@ subseq ; + +: set-pixel-at ( pixel x y image -- ) + pixel@ set-subseq ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 648923704a..9d44aa1187 100755 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -6,7 +6,7 @@ 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 ; +sequences sequences.deep images.loader ; IN: images.jpeg QUALIFIED-WITH: bitstreams bs @@ -302,3 +302,5 @@ PRIVATE> M: jpeg-image load-image* ( path jpeg-image -- bitmap ) drop load-jpeg ; + +{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index d86b275635..19f2fd12c8 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,22 +1,22 @@ -! Copyright (C) 2009 Doug Coleman. +! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images io.pathnames -images.png ; +accessors images io.pathnames namespaces assocs ; IN: images.loader ERROR: unknown-image-extension extension ; +lower { - { "bmp" [ bitmap-image ] } - { "tif" [ tiff-image ] } - { "tiff" [ tiff-image ] } - ! { "jpg" [ jpeg-image ] } - ! { "jpeg" [ jpeg-image ] } - { "png" [ png-image ] } - [ unknown-image-extension ] - } case ; + file-extension >lower types get ?at + [ unknown-image-extension ] unless ; +PRIVATE> + +: register-image-class ( extension class -- ) + swap types get set-at ; : load-image ( path -- image ) dup image-class new load-image* ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index c5b84de221..d4b284142f 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -3,7 +3,8 @@ 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 compression.inflate grouping byte-arrays ; +checksums checksums.crc32 compression.inflate grouping byte-arrays +images.loader ; IN: images.png TUPLE: png-image < image chunks @@ -115,3 +116,5 @@ ERROR: unimplemented-color-type image ; M: png-image load-image* drop load-png ; + +"png" png-image register-image-class diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 27dc25de73..c98f737b11 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,8 @@ compression.lzw constructors endian fry grouping images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences -strings math.vectors specialized-arrays.float locals ; +strings math.vectors specialized-arrays.float locals +images.loader ; IN: images.tiff TUPLE: tiff-image < image ; @@ -561,3 +562,5 @@ ERROR: unknown-component-order ifd ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) drop load-tiff tiff>image ; + +{ "tif" "tiff" } [ tiff-image register-image-class ] each diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor index 6ae83f7af0..36043a5576 100644 --- a/basis/math/bits/bits-docs.factor +++ b/basis/math/bits/bits-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup math ; +USING: help.syntax help.markup math sequences ; IN: math.bits ABOUT: "math.bits" @@ -24,3 +24,7 @@ HELP: make-bits { $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" } { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" } } ; + +HELP: unbits +{ $values { "seq" sequence } { "number" integer } } +{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ; diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor index b17d9d8b6e..c6f4c6e8fa 100644 --- a/basis/math/bits/bits-tests.factor +++ b/basis/math/bits/bits-tests.factor @@ -29,3 +29,6 @@ IN: math.bits.tests [ t ] [ 1067811677921310779 >bignum make-bits last ] unit-test + +[ 6 ] [ 6 make-bits unbits ] unit-test +[ 6 ] [ 6 3 >array unbits ] unit-test diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 72b83a991f..0fbfdf0bd9 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -14,3 +14,6 @@ M: bits length length>> ; M: bits nth-unsafe number>> swap bit? ; INSTANCE: bits immutable-sequence + +: unbits ( seq -- number ) + 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ; diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor index 2b1caa8ab9..519217a644 100755 --- a/basis/ui/images/images.factor +++ b/basis/ui/images/images.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces cache images images.loader accessors assocs kernel opengl opengl.gl opengl.textures ui.gadgets.worlds -memoize ; +memoize images.tiff ; IN: ui.images TUPLE: image-name path ; @@ -29,4 +29,4 @@ PRIVATE> rendered-image draw-scaled-texture ; : image-dim ( image-name -- dim ) - cached-image dim>> ; \ No newline at end of file + cached-image dim>> ;