images.bitmap: now conforms to image encode protocol. images.normalization: added several component-order shuffle words

basis/images/bitmap/bitmap.factor

@@ -2,57 +2,61 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays byte-arrays columns
 combinators compression.run-length endian fry grouping images
-images.bitmap.loading images.loader io io.binary
+images.loader images.normalization io io.binary
 io.encodings.binary io.encodings.string io.files
 io.streams.limited kernel locals macros math math.bitwise
 math.functions namespaces sequences specialized-arrays
-strings summary ;
+specialized-arrays.instances.uint
-SPECIALIZED-ARRAY: uint
+specialized-arrays.instances.ushort strings summary ;
-SPECIALIZED-ARRAY: ushort
 IN: images.bitmap
 
+SINGLETON: bmp-image
+"bmp" bmp-image register-image-class
+
 : write2 ( n -- ) 2 >le write ;
 : write4 ( n -- ) 4 >le write ;
 
-: save-bitmap ( image path -- )
+: output-bmp ( image -- )
-    binary [
+    B{ CHAR: B CHAR: M } write
-        B{ CHAR: B CHAR: M } write
+    [
-        [
+        bitmap>> length 14 + 40 + write4
-            bitmap>> length 14 + 40 + write4
+        0 write4
-            0 write4
+        54 write4
-            54 write4
+        40 write4
-            40 write4
+    ] [
-        ] [
+        {
-            {
+            ! width height
-                ! width height
+            [ dim>> first2 [ write4 ] bi@ ]
-                [ dim>> first2 [ write4 ] bi@ ]
 
-                ! planes
+            ! planes
-                [ drop 1 write2 ]
+            [ drop 1 write2 ]
 
-                ! bit-count
+            ! bit-count
-                [ drop 24 write2 ]
+            [ drop 24 write2 ]
 
-                ! compression
+            ! compression
-                [ drop 0 write4 ]
+            [ drop 0 write4 ]
 
-                ! image-size
+            ! image-size
-                [ bitmap>> length write4 ]
+            [ bitmap>> length write4 ]
 
-                ! x-pels
+            ! x-pels
-                [ drop 0 write4 ]
+            [ drop 0 write4 ]
 
-                ! y-pels
+            ! y-pels
-                [ drop 0 write4 ]
+            [ drop 0 write4 ]
 
-                ! color-used
+            ! color-used
-                [ drop 0 write4 ]
+            [ drop 0 write4 ]
 
-                ! color-important
+            ! color-important
-                [ drop 0 write4 ]
+            [ drop 0 write4 ]
+
+            ! color-palette
+            [ bitmap>> write ]
+        } cleave
+    ] bi ;
+
+M: bmp-image image>stream
+    drop BGR reorder-colors output-bmp ;
 
-                ! color-palette
-                [ bitmap>> write ]
-            } cleave
-        ] bi
-    ] with-file-writer ;

basis/images/bitmap/loading/loading.factor

@@ -4,14 +4,11 @@ USING: accessors alien.c-types arrays byte-arrays combinators
 compression.run-length fry grouping images images.loader io
 io.binary io.encodings.8-bit io.encodings.binary
 io.encodings.string io.streams.limited kernel math math.bitwise
-sequences specialized-arrays summary ;
+sequences specialized-arrays summary images.bitmap ;
 QUALIFIED-WITH: bitstreams b
 SPECIALIZED-ARRAY: ushort
 IN: images.bitmap.loading
 
-SINGLETON: bitmap-image
-"bmp" bitmap-image register-image-class
-
 ! http://www.fileformat.info/format/bmp/egff.htm
 ! http://www.digicamsoft.com/bmp/bmp.html
 
@@ -364,7 +361,7 @@ ERROR: unsupported-bitmap-file magic ;
 : loading-bitmap>bytes ( loading-bitmap -- byte-array )
     uncompress-bitmap bitmap>bytes ;
 
-M: bitmap-image stream>image ( stream bitmap-image -- bitmap )
+M: bmp-image stream>image ( stream bmp-image -- bitmap )
     drop load-bitmap
     [ image new ] dip
     {

basis/images/loader/loader.factor

@@ -53,3 +53,4 @@ GENERIC: image>stream ( image class -- )
 : save-graphic-image ( image path -- )
     [ image-class ] [ ] bi
     binary [ image>stream ] with-file-writer ;
+

extra/images/normalization/normalization-tests.factor

@@ -0,0 +1,76 @@
+! BSD License. Copyright 2009 Keith Lazuka
+USING: images.normalization images.normalization.private
+sequences tools.test ;
+IN: images.normalization.tests
+
+! RGB
+
+[ B{ 0 1 2 255 3 4 5 255 } ]
+[ B{ 0 1 2 3 4 5 } RGB>RGBA ] unit-test
+
+[ B{ 2 1 0 5 4 3 } ]
+[ B{ 0 1 2 3 4 5 } RGB>BGR ] unit-test
+
+[ B{ 2 1 0 255 5 4 3 255 } ]
+[ B{ 0 1 2 3 4 5 } RGB>BGRA ] unit-test
+
+[ B{ 255 0 1 2 255 3 4 5 } ]
+[ B{ 0 1 2 3 4 5 } RGB>ARGB ] unit-test
+
+! RGBA
+
+[ B{ 0 1 2 4 5 6 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA>RGB ] unit-test
+
+[ B{ 2 1 0 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA>BGR ] unit-test
+
+[ B{ 2 1 0 3 6 5 4 7 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA>BGRA ] unit-test
+
+[ B{ 3 0 1 2 7 4 5 6 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA>ARGB ] unit-test
+
+! BGR
+
+[ B{ 2 1 0 5 4 3 } ]
+[ B{ 0 1 2 3 4 5 } BGR>RGB ] unit-test
+
+[ B{ 2 1 0 255 5 4 3 255 } ]
+[ B{ 0 1 2 3 4 5 } BGR>RGBA ] unit-test
+
+[ B{ 0 1 2 255 3 4 5 255 } ]
+[ B{ 0 1 2 3 4 5 } BGR>BGRA ] unit-test
+
+[ B{ 255 2 1 0 255 5 4 3 } ]
+[ B{ 0 1 2 3 4 5 } BGR>ARGB ] unit-test
+
+! BGRA
+
+[ B{ 2 1 0 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } BGRA>RGB ] unit-test
+
+[ B{ 0 1 2 4 5 6 } ]
+[ B{ 0 1 2 3 4 5 6 7 } BGRA>BGR ] unit-test
+
+[ B{ 2 1 0 3 6 5 4 7 } ]
+[ B{ 0 1 2 3 4 5 6 7 } BGRA>RGBA ] unit-test
+
+[ B{ 3 2 1 0 7 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } BGRA>ARGB ] unit-test
+
+! ARGB
+
+[ B{ 1 2 3 5 6 7 } ]
+[ B{ 0 1 2 3 4 5 6 7 } ARGB>RGB ] unit-test
+
+[ B{ 3 2 1 7 6 5 } ]
+[ B{ 0 1 2 3 4 5 6 7 } ARGB>BGR ] unit-test
+
+[ B{ 3 2 1 0 7 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } ARGB>BGRA ] unit-test
+
+[ B{ 1 2 3 0 5 6 7 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } ARGB>RGBA ] unit-test
+
+

extra/images/normalization/normalization.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Doug Coleman
+! Copyright (C) 2009 Doug Coleman, Keith Lazuka
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel accessors grouping sequences
 combinators math byte-arrays fry images half-floats
@@ -12,21 +12,158 @@ IN: images.normalization
 
 <PRIVATE
 
+! Helpers
 : add-dummy-alpha ( seq -- seq' )
     3 <groups> [ 255 suffix ] map concat ;
 
 : normalize-floats ( float-array -- byte-array )
     [ 255.0 * >integer ] B{ } map-as ;
 
+: fix-XBGR ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
+
+: fix-BGRX ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
+
+! Bitmap Conversions
+
+! TODO RGBX, XRGB, BGRX, XBGR conversions
+
+! BGR>
+: BGR>RGB ( bitmap -- bitmap' )
+    3 <sliced-groups> [ <reversed> ] map concat ; inline
+
+: BGR>BGRA ( bitmap -- bitmap' ) add-dummy-alpha ; inline
+
+: BGR>RGBA ( bitmap -- bitmap' ) BGR>RGB add-dummy-alpha ; inline
+
+: BGR>ARGB ( bitmap -- bitmap' )
+    3 <sliced-groups> [ 255 suffix <reversed> ] map concat ; inline
+
+! BGRA>
+: BGRA>BGR ( bitmap -- bitmap' )
+    4 <sliced-groups> [ but-last-slice ] map concat ; inline
+
+: BGRA>RGBA ( bitmap -- bitmap' )
+    4 <sliced-groups>
+    [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
+
+: BGRA>RGB ( bitmap -- bitmap' )
+    4 <sliced-groups> [ but-last-slice <reversed> ] map concat ; inline
+
+: BGRA>ARGB ( bitmap -- bitmap' )
+    4 <sliced-groups> [ <reversed> ] map concat ; inline
+
+! RGB>
+: RGB>BGR ( bitmap -- bitmap' ) BGR>RGB ; inline
+
+: RGB>RGBA ( bitmap -- bitmap' ) add-dummy-alpha ; inline
+
+: RGB>BGRA ( bitmap -- bitmap' )
+    3 <sliced-groups> [ <reversed> add-dummy-alpha ] map concat ; inline
+
+: RGB>ARGB ( bitmap -- bitmap' )
+    3 <sliced-groups> [ 255 prefix ] map concat ; inline
+
+! RGBA>
+
+: RGBA>BGR ( bitmap -- bitmap' ) BGRA>RGB ; inline
+
+: RGBA>BGRA ( bitmap -- bitmap' ) BGRA>RGBA ; inline
+
+: RGBA>RGB ( bitmap -- bitmap' ) BGRA>BGR ; inline
+
+: RGBA>ARGB ( bitmap -- bitmap' )
+    4 <sliced-groups> [ unclip-last-slice prefix ] map concat ; inline
+
+! ARGB>
+
+: ARGB>RGB ( bitmap -- bitmap' )
+    4 <sliced-groups> [ rest-slice ] map concat ; inline
+
+: ARGB>RGBA ( bitmap -- bitmap' )
+    4 <sliced-groups> [ unclip-slice suffix ] map concat ; inline
+
+: ARGB>BGR ( bitmap -- bitmap' )
+    4 <sliced-groups> [ rest-slice <reversed> ] map concat ; inline
+
+: ARGB>BGRA ( bitmap -- bitmap' )
+    4 <sliced-groups>
+    [ unclip-slice [ <reversed> ] dip suffix ] map concat ; inline
+
+! Dispatch
+GENERIC# convert-component-order 1 ( image src-order dest-order -- image )
+
+M: RGB convert-component-order
+    nip [ >>component-order ] keep {
+        { RGB  [ ] }
+        { RGBA [ [ RGB>RGBA ] change-bitmap ] }
+        { BGRA [ [ BGR>BGRA ] change-bitmap ] }
+        { ARGB [ [ RGB>RGBA RGBA>ARGB ] change-bitmap ] }
+        { BGR  [ [ RGB>BGR ] change-bitmap ] }
+        [ "Cannot convert from RGB to desired component order!" throw ]
+    } case ;
+
+M: RGBA convert-component-order
+    nip [ >>component-order ] keep {
+        { RGBA [ ] }
+        { BGRA [ [ RGBA>BGRA ] change-bitmap ] }
+        { BGR  [ [ RGBA>BGR ] change-bitmap ] }
+        { RGB  [ [ RGBA>RGB ] change-bitmap ] }
+        { ARGB [ [ RGBA>ARGB ] change-bitmap ] }
+        [ "Cannot convert from RGBA to desired component order!" throw ]
+    } case ;
+
+M: BGR convert-component-order
+    nip [ >>component-order ] keep {
+        { BGR  [ ] }
+        { BGRA [ [ BGR>BGRA ] change-bitmap ] }
+        { RGB  [ [ BGR>RGB ] change-bitmap ] }
+        { RGBA [ [ BGR>RGBA ] change-bitmap ] }
+        { ARGB [ [ BGR>ARGB ] change-bitmap ] }
+        [ "Cannot convert from BGR to desired component order!" throw ]
+    } case ;
+
+M: BGRA convert-component-order
+    nip [ >>component-order ] keep {
+        { BGRA [ ] }
+        { BGR  [ [ BGRA>BGR ] change-bitmap ] }
+        { RGB  [ [ BGRA>RGB ] change-bitmap ] }
+        { RGBA [ [ BGRA>RGBA ] change-bitmap ] }
+        { ARGB [ [ BGRA>ARGB ] change-bitmap ] }
+        [ "Cannot convert from BGRA to desired component order!" throw ]
+    } case ;
+
+M: ARGB convert-component-order
+    nip [ >>component-order ] keep {
+        { ARGB [ ] }
+        { BGR  [ [ ARGB>BGR ] change-bitmap ] }
+        { RGB  [ [ ARGB>RGB ] change-bitmap ] }
+        { RGBA [ [ ARGB>RGBA ] change-bitmap ] }
+        { BGRA [ [ ARGB>BGRA ] change-bitmap ] }
+        [ "Cannot convert from ARGB to desired component order!" throw ]
+    } case ;
+
+PRIVATE>
+
+! asserts that component-type must be ubyte-components
+: reorder-colors ( image component-order -- image )
+    [
+        [ component-type>> ubyte-components assert= ]
+        [ dup component-order>> ] bi
+    ] dip convert-component-order ;
+
+<PRIVATE
+
 GENERIC: normalize-component-type* ( image component-type -- image )
-GENERIC: normalize-component-order* ( image component-order -- image )
 
 : normalize-component-order ( image -- image )
     dup component-type>> '[ _ normalize-component-type* ] change-bitmap
-    dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
+    RGBA reorder-colors ;
 
 M: float-components normalize-component-type*
     drop byte-array>float-array normalize-floats ;
+
 M: half-components normalize-component-type*
     drop byte-array>half-array normalize-floats ;
 
@@ -39,45 +176,6 @@ M: ushort-components normalize-component-type*
 M: ubyte-components normalize-component-type*
     drop ;
 
-M: RGBA normalize-component-order* drop ;
-
-: BGR>RGB ( bitmap -- pixels )
-    3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
-
-: BGRA>RGBA ( bitmap -- pixels )
-    4 <sliced-groups>
-    [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
-
-M: BGRA normalize-component-order*
-    drop BGRA>RGBA ;
-
-M: RGB normalize-component-order*
-    drop add-dummy-alpha ;
-
-M: BGR normalize-component-order*
-    drop BGR>RGB add-dummy-alpha ;
-
-: ARGB>RGBA ( bitmap -- bitmap' )
-    4 <groups> [ unclip suffix ] map B{ } join ; inline
-
-M: ARGB normalize-component-order*
-    drop ARGB>RGBA ;
-
-M: ABGR normalize-component-order*
-    drop ARGB>RGBA BGRA>RGBA ;
-
-: fix-XBGR ( bitmap -- bitmap' )
-    dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
-
-M: XBGR normalize-component-order*
-    drop fix-XBGR ABGR normalize-component-order* ;
-
-: fix-BGRX ( bitmap -- bitmap' )
-    dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
-
-M: BGRX normalize-component-order*
-    drop fix-BGRX BGRA normalize-component-order* ;
-
 : normalize-scan-line-order ( image -- image )
     dup upside-down?>> [
         dup dim>> first 4 * '[
@@ -93,3 +191,4 @@ PRIVATE>
     normalize-component-order
     normalize-scan-line-order
     RGBA >>component-order ;
+