Merge branch 'master' of git://factorcode.org/git/factor

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 <array> ] map concat ;

basis/images/authors.txt

@@ -1 +1,2 @@
-Doug Coleman
+Doug Coleman
+Daniel Ehrenberg

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
+combinators compression.run-length endian fry grouping images
-kernel macros math math.bitwise math.functions namespaces sequences
+images.loader io io.binary io.encodings.binary io.files kernel
-strings images endian summary locals ;
+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
 <PRIVATE
 
 : 8bit>buffer ( bitmap -- array )
-    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-palette>> 4 <sliced-groups> [ 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 )
     <sliced-groups> <reversed> 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 * ]

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

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
+    <image>
+        over [ first length ] [ length ] bi 2array >>dim
+        RGBA >>component-order
+        swap concat concat B{ } like >>bitmap ;
+
+<PRIVATE
+
+: pixel@ ( x y image -- start end bitmap )
+    [ dim>> first * + ]
+    [ component-order>> bytes-per-pixel [ * dup ] keep + ]
+    [ bitmap>> ] tri ;
+
+: set-subseq ( new-value from to victim -- )
+    <slice> 0 swap copy ; inline
+
+PRIVATE>
+
+: pixel-at ( x y image -- pixel )
+    pixel@ subseq ;
+
+: set-pixel-at ( pixel x y image -- )
+    pixel@ set-subseq ;

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

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
+accessors images io.pathnames namespaces assocs ;
-images.png ;
 IN: images.loader
 
 ERROR: unknown-image-extension extension ;
 
+<PRIVATE
+SYMBOL: types
+types [ H{ } clone ] initialize
+
 : image-class ( path -- class )
-    file-extension >lower {
+    file-extension >lower types get ?at
-        { "bmp" [ bitmap-image ] }
+    [ unknown-image-extension ] unless ;
-        { "tif" [ tiff-image ] }
+PRIVATE>
-        { "tiff" [ tiff-image ] }
+
-        ! { "jpg" [ jpeg-image ] }
+: register-image-class ( extension class -- )
-        ! { "jpeg" [ jpeg-image ] }
+    swap types get set-at ;
-        { "png" [ png-image ] }
-        [ unknown-image-extension ]
-    } case ;
 
 : load-image ( path -- image )
     dup image-class new load-image* ;

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

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

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." } ;

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 <bits> >array unbits ] unit-test

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 )
+    <reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;

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>> ;
+    cached-image dim>> ;