Merge branch 'images' of git://github.com/klazuka/factor into klazuka

basis/images/loader/loader.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs byte-arrays combinators images
-io.encodings.binary io.pathnames io.streams.byte-array
+io.encodings.binary io.files io.pathnames io.streams.byte-array
-io.streams.limited kernel namespaces splitting strings
+io.streams.limited kernel namespaces sequences splitting
-unicode.case sequences ;
+strings unicode.case ;
 IN: images.loader
 
 ERROR: unknown-image-extension extension ;
@@ -22,6 +22,8 @@ types [ H{ } clone ] initialize
 
 PRIVATE>
 
+! Image Decode
+
 GENERIC# load-image* 1 ( obj class -- image )
 
 GENERIC: stream>image ( stream class -- image )
@@ -43,3 +45,11 @@ M: limited-stream load-image* stream>image ;
 M: string load-image* [ open-image-file ] dip stream>image ;
 
 M: pathname load-image* [ open-image-file ] dip stream>image ;
+
+! Image Encode
+
+GENERIC: image>stream ( image class -- )
+
+: save-graphic-image ( image path -- )
+    [ image-class ] [ ] bi
+    binary [ image>stream ] with-file-writer ;

basis/images/png/png-tests.factor

@@ -1,7 +1,10 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test images.png ;
+USING: images.png images.testing namespaces tools.test
+tools.test.private ;
 IN: images.png.tests
 
-: png-test-path ( -- path )
+verbose-tests? off
-    "vocab:images/test-images/rgb.png" ;
+"vocab:images/testing/png/rgb.png" decode-test
+"vocab:images/testing/png/yin_yang.png" decode-test
+verbose-tests? on

basis/images/testing/testing.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry images.loader io io.encodings.binary io.files
+io.pathnames io.streams.byte-array kernel locals quotations
+sequences tools.test ;
+IN: images.testing
+
+:: encode-test ( path image-class -- )
+    path binary file-contents 1quotation
+    [
+        binary <byte-writer> dup [
+            path load-image image-class image>stream
+        ] with-output-stream B{ } like
+    ] unit-test ;
+
+<PRIVATE
+
+: pam-name ( path -- newpath )
+    [ parent-directory canonicalize-path ]
+    [ file-stem ".pam" append ] bi
+    append-path ;
+
+: save-as-reference-image ( path -- )
+    [ load-image ] [ pam-name ] bi save-graphic-image ;
+
+PRIVATE>
+
+: decode-test ( path -- )
+    [ load-image 1quotation ]
+    [ '[ _ pam-name load-image ] ] bi
+    unit-test ;

basis/images/tiff/tiff-tests.factor

@@ -1,44 +1,15 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images.tiff images.viewer io
+USING: accessors images.testing images.tiff images.viewer io
-io.encodings.binary io.files namespaces sequences tools.test ;
+io.encodings.binary io.files namespaces sequences tools.test
+tools.test.private ;
 IN: images.tiff.tests
 
-: path>tiff ( path -- tiff )
+verbose-tests? off
-    binary [ input-stream get load-tiff ] with-file-reader ;
+"vocab:images/testing/tiff/octagon.tiff" decode-test
-
+"vocab:images/testing/tiff/elephants.tiff" decode-test
-: tiff-example1 ( -- tiff )
+"vocab:images/testing/tiff/noise.tiff" decode-test
-    "resource:extra/images/testing/square.tiff" path>tiff ;
+"vocab:images/testing/tiff/alpha.tiff" decode-test
-
+"vocab:images/testing/tiff/color_spectrum.tiff" decode-test
-: tiff-example2 ( -- tiff )
+! "vocab:images/testing/tiff/rgb.tiff" decode-test
-    "resource:extra/images/testing/cube.tiff" path>tiff ;
+verbose-tests? on
-
-: tiff-example3 ( -- tiff )
-    "resource:extra/images/testing/bi.tiff" path>tiff ;
-
-: tiff-example4 ( -- tiff )
-    "resource:extra/images/testing/noise.tiff" path>tiff ;
-
-: tiff-example5 ( -- tiff )
-    "resource:extra/images/testing/alpha.tiff" path>tiff ;
-
-: tiff-example6 ( -- tiff )
-    "resource:extra/images/testing/color_spectrum.tiff" path>tiff ;
-
-: tiff-example7 ( -- tiff )
-    "resource:extra/images/testing/small.tiff" path>tiff ;
-
-: tiff-all. ( -- )
-    {
-        tiff-example1 tiff-example2 tiff-example3 tiff-example4 tiff-example5
-        tiff-example6
-    }
-    [ execute( -- gif ) tiff>image image. ] each ;
-
-[ 1024 ] [ tiff-example1 ifds>> first bitmap>> length ] unit-test
-[ 1024 ] [ tiff-example2 ifds>> first bitmap>> length ] unit-test
-[ 131744 ] [ tiff-example3 ifds>> first bitmap>> length ] unit-test
-[ 49152 ] [ tiff-example4 ifds>> first bitmap>> length ] unit-test
-[ 16 ] [ tiff-example5 ifds>> first bitmap>> length ] unit-test
-[ 117504 ] [ tiff-example6 ifds>> first bitmap>> length ] unit-test
-

basis/tools/test/test.factor

@@ -79,8 +79,12 @@ MACRO: <experiment> ( word -- )
     [ name>> experiment-title ] bi
     '[ _ ndup _ narray _ prefix ] ;
 
+SYMBOL: verbose-tests?
+t verbose-tests? set-global
+
 : experiment. ( seq -- )
-    [ first write ": " write ] [ rest . flush ] bi ;
+    [ first write ": " write ]
+    [ rest verbose-tests? get [ . ] [ short. ] if flush ] bi ;
 
 :: experiment ( word: ( -- error ? ) line# -- )
     word <experiment> :> e

extra/images/gif/gif-tests.factor

@@ -1,50 +1,48 @@
 ! Copyright (C) 2009 Keith Lazuka.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors bitstreams compression.lzw images.gif io
+USING: accessors bitstreams compression.lzw fry images.gif
-io.encodings.binary io.files kernel math math.bitwise
+images.loader images.testing images.viewer io
-math.parser namespaces prettyprint sequences tools.test images.viewer ;
+io.encodings.binary io.files io.pathnames kernel math
+math.bitwise math.parser namespaces prettyprint quotations
+sequences tools.test tools.test.private ;
 QUALIFIED-WITH: bitstreams bs
 IN: images.gif.tests
 
-: path>gif ( path -- loading-gif )
+verbose-tests? off
+"vocab:images/testing/gif/circle.gif" decode-test
+"vocab:images/testing/gif/checkmark.gif" decode-test
+"vocab:images/testing/gif/monochrome.gif" decode-test
+"vocab:images/testing/gif/alpha.gif" decode-test
+"vocab:images/testing/gif/noise.gif" decode-test
+"vocab:images/testing/gif/astronaut_animation.gif" decode-test
+verbose-tests? on
+
+: path>gif ( path -- gif )
     binary [ input-stream get load-gif ] with-file-reader ;
 
-: gif-example1 ( -- loading-gif )
+: circle.gif ( -- gif )
-    "resource:extra/images/testing/circle.gif" path>gif ;
+    "vocab:images/testing/gif/circle.gif" path>gif ;
 
-: gif-example2 ( -- loading-gif )
+: checkmark.gif ( -- gif )
-    "resource:extra/images/testing/checkmark.gif" path>gif ;
+    "vocab:images/testing/gif/checkmark.gif" path>gif ;
 
-: gif-example3 ( -- loading-gif )
+: monochrome.gif ( -- gif )
-    "resource:extra/images/testing/monochrome.gif" path>gif ;
+    "vocab:images/testing/gif/monochrome.gif" path>gif ;
 
-: gif-example4 ( -- loading-gif )
+: alpha.gif ( -- gif )
-    "resource:extra/images/testing/noise.gif" path>gif ;
+    "vocab:images/testing/gif/alpha.gif" path>gif ;
-
-: gif-example5 ( -- loading-gif )
-    "resource:extra/images/testing/alpha.gif" path>gif ;
-
-: gif-example6 ( -- loading-gif )
-    "resource:extra/images/testing/astronaut_animation.gif" path>gif ;
-
-: gif-all. ( -- )
-    {
-        gif-example1 gif-example2 gif-example3 gif-example4 gif-example5
-        gif-example6
-    }
-    [ execute( -- gif ) gif>image image. ] each ;
 
 : declared-num-colors ( gif -- n ) flags>> 3 bits 1 + 2^ ;
 : actual-num-colors ( gif -- n ) global-color-table>> length ;
 
-[ 16 ] [ gif-example1 actual-num-colors ] unit-test
+[ 2 ] [ monochrome.gif actual-num-colors ] unit-test
-[ 16 ] [ gif-example1 declared-num-colors ] unit-test
+[ 2 ] [ monochrome.gif declared-num-colors ] unit-test
 
-[ 256 ] [ gif-example2 actual-num-colors ] unit-test
+[ 16 ] [ circle.gif actual-num-colors ] unit-test
-[ 256 ] [ gif-example2 declared-num-colors ] unit-test
+[ 16 ] [ circle.gif declared-num-colors ] unit-test
 
-[ 2 ] [ gif-example3 actual-num-colors ] unit-test
+[ 256 ] [ checkmark.gif actual-num-colors ] unit-test
-[ 2 ] [ gif-example3 declared-num-colors ] unit-test
+[ 256 ] [ checkmark.gif declared-num-colors ] unit-test
 
 : >index-stream ( gif -- seq )
     [ compressed-bytes>> ]
@@ -60,36 +58,11 @@ IN: images.gif.tests
         1 0 1 1 0 1
         1 0 0 0 0 1
     }
-] [ gif-example3 >index-stream ] unit-test
+] [ monochrome.gif >index-stream ] unit-test
-
-[
-    B{
-        255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255
-        0 0 0 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 0 0 255
-        0 0 0 255 0 0 0 255 255 255 255 255 255 255 255 255 0 0 0 255 0 0 0 255
-        0 0 0 255 0 0 0 255 0 0 0 255 0 0 0 255 0 0 0 255 0 0 0 255
-        0 0 0 255 255 255 255 255 0 0 0 255 0 0 0 255 255 255 255 255 0 0 0 255
-        0 0 0 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 0 0 255
-    }
-] [ gif-example3 gif>image bitmap>> ] unit-test
 
 [
     BV{
         0 1
         1 0
     }
-] [ gif-example5 >index-stream ] unit-test
+] [ alpha.gif >index-stream ] unit-test
-
-[
-    B{
-        255 000 000 255     000 000 000 000
-        000 000 000 000     255 000 000 255
-    }
-] [ gif-example5 gif>image bitmap>> ] unit-test
-
-[ 100 ] [ gif-example1 >index-stream length ] unit-test
-[ 870 ] [ gif-example2 >index-stream length ] unit-test
-[ 16384 ] [ gif-example4 >index-stream length ] unit-test
-
-! example6 is a GIF animation and the first frame contains 1768 pixels
-[ 1768 ] [ gif-example6 >index-stream length ] unit-test

extra/images/pam/pam-tests.factor

@@ -0,0 +1,57 @@
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays images.loader images.pam
+images.testing io io.encodings.binary io.files
+io.streams.byte-array kernel quotations tools.test ;
+IN: images.pam.tests
+
+! ----------- Encoder Tests ------------------------------
+
+"vocab:images/testing/pam/rgb1x1.pam" pam-image encode-test
+"vocab:images/testing/pam/rgba1x1.pam" pam-image encode-test
+"vocab:images/testing/pam/rgb2x2.pam" pam-image encode-test
+"vocab:images/testing/pam/rgba2x2.pam" pam-image encode-test
+"vocab:images/testing/pam/rgb3x3.pam" pam-image encode-test
+"vocab:images/testing/pam/rgba3x3.pam" pam-image encode-test
+
+! ----------- Decoder Tests ------------------------------
+
+! 1x1
+
+[ { 1 1 } ] [ "vocab:images/testing/pam/rgb1x1.pam" load-image dim>> ] unit-test
+
+[ B{ 0 0 0 } ]
+[ "vocab:images/testing/pam/rgb1x1.pam" load-image bitmap>> ] unit-test
+
+[ B{ 0 0 0 0 } ]
+[ "vocab:images/testing/pam/rgba1x1.pam" load-image bitmap>> ] unit-test
+
+! 2x2
+
+[ { 2  2 } ] [ "vocab:images/testing/pam/rgb2x2.pam" load-image dim>> ] unit-test
+
+[ B{ 0 0 0 255 255 255 255 255 255 0 0 0 } ]
+[ "vocab:images/testing/pam/rgb2x2.pam" load-image bitmap>> ] unit-test
+
+[ B{ 0 0 0 255 255 255 255 0 255 255 255 0 0 0 0 255 } ]
+[ "vocab:images/testing/pam/rgba2x2.pam" load-image bitmap>> ] unit-test
+
+! 3x3
+
+[
+    B{
+        255   0   0       0 255   0       0   0 255
+          4 252 253     254   1 127     252 253   2
+        255 255 255       0   0   0     255 255 255
+    }
+]
+[ "vocab:images/testing/pam/rgb3x3.pam" load-image bitmap>> ] unit-test
+
+[
+    B{
+        255   0   0 255       0 255   0 255       0   0 255 255
+          4 252 253 255     254   1 127 255     252 253   2 255
+        255 255 255 255       0   0   0 255     255 255 255   0
+    }
+]
+[ "vocab:images/testing/pam/rgba3x3.pam" load-image bitmap>> ] unit-test

extra/images/pam/pam.factor

@@ -0,0 +1,99 @@
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators fry grouping images
+images.loader io io.encodings io.encodings.ascii
+io.encodings.binary io.files io.files.temp kernel math
+math.parser prettyprint sequences splitting ;
+IN: images.pam
+
+SINGLETON: pam-image
+"pam" pam-image register-image-class
+
+: output-pam-header ( note num-channels width height -- )
+    ascii [
+        "P7" print
+        "HEIGHT " write pprint nl
+        "WIDTH " write pprint nl
+        "MAXVAL 255" print
+        "DEPTH " write pprint nl
+        "TUPLTYPE " prepend print
+        "ENDHDR" print
+    ] with-encoded-output ; inline
+
+: output-pam ( note num-channels width height pixels -- )
+    [ output-pam-header ] dip write ;
+
+: verify-bitmap-format ( image -- )
+    [ component-type>> ubyte-components assert= ]
+    [ component-order>> { RGB RGBA } memq? [
+        "PAM encode: component-order must be RGB or RGBA!" throw
+    ] unless ] bi ;
+
+GENERIC: TUPLTYPE ( component-order -- str )
+M: component-order TUPLTYPE name>> ;
+M: RGBA TUPLTYPE drop "RGB_ALPHA" ;
+
+M: pam-image image>stream
+    drop {
+        [ verify-bitmap-format ]
+        [ component-order>> [ TUPLTYPE ] [ component-count ] bi ]
+        [ dim>> first2 ]
+        [ bitmap>> ]
+    } cleave output-pam ;
+
+! PAM Decoder
+
+TUPLE: loading-pam width height depth maxval tupltype bitmap ;
+
+: ?glue ( seq1 seq2 seq3 -- seq )
+    pick empty? [ drop nip ] [ glue ] if ;
+
+: append-tupltype ( pam tupltype -- pam )
+    '[ _ " " ?glue ] change-tupltype ;
+
+: read-header-lines ( pam -- pam )
+    readln " " split unclip swap " " join swap {
+        { "ENDHDR" [ drop ] }
+        { "HEIGHT" [ string>number >>height read-header-lines ] }
+        { "WIDTH" [ string>number >>width read-header-lines ] }
+        { "DEPTH" [ string>number >>depth read-header-lines ] }
+        { "MAXVAL" [ string>number >>maxval read-header-lines ] }
+        { "TUPLTYPE" [ append-tupltype read-header-lines ] }
+        [ 2drop read-header-lines ]
+    } case ;
+
+: read-header ( pam -- pam )
+    ascii [
+        readln "P7" assert=
+        read-header-lines
+    ] with-decoded-input ;
+
+: bytes-per-pixel ( pam -- n )
+    [ depth>> ] [ maxval>> 256 < 1 2 ? ] bi * ;
+
+: bitmap-length ( pam -- num-bytes )
+    [ width>> ] [ height>> ] [ bytes-per-pixel ] tri * * ;
+
+: read-bitmap ( pam -- pam )
+    dup bitmap-length read >>bitmap ;
+
+: load-pam ( stream -- pam )
+    [ loading-pam new read-header read-bitmap ] with-input-stream ;
+
+: tupltype>component-order ( pam -- component-order )
+    tupltype>> dup {
+        { "RGB_ALPHA" [ drop RGBA ] }
+        { "RGBA" [ drop RGBA ] }
+        { "RGB" [ drop RGB ] }
+        [ "Cannot determine component-order from TUPLTYPE " prepend throw ]
+    } case ;
+
+: pam>image ( pam -- image )
+    [ <image> ] dip {
+        [ [ width>> ] [ height>> ] bi 2array >>dim ]
+        [ tupltype>component-order >>component-order ]
+        [ drop ubyte-components >>component-type ]
+        [ bitmap>> >>bitmap ]
+    } cleave ;
+
+M: pam-image stream>image drop load-pam pam>image ;