Merge branch 'images' of git://github.com/klazuka/factor into klazuka
Doug Coleman
|
|
@ -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.streams.limited kernel namespaces splitting strings
|
||||
unicode.case sequences ;
|
||||
io.encodings.binary io.files io.pathnames io.streams.byte-array
|
||||
io.streams.limited kernel namespaces sequences splitting
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
"vocab:images/test-images/rgb.png" ;
|
||||
verbose-tests? off
|
||||
"vocab:images/testing/png/rgb.png" decode-test
|
||||
"vocab:images/testing/png/yin_yang.png" decode-test
|
||||
verbose-tests? on
|
||||
|
|
|
|||
|
Before Width: | Height: | Size: 1.6 KiB After Width: | Height: | Size: 1.6 KiB |
|
Before Width: | Height: | Size: 4.7 KiB After Width: | Height: | Size: 4.7 KiB |
|
Before Width: | Height: | Size: 4.9 KiB After Width: | Height: | Size: 4.9 KiB |
|
Before Width: | Height: | Size: 5.1 KiB After Width: | Height: | Size: 5.1 KiB |
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
|
Before Width: | Height: | Size: 59 KiB After Width: | Height: | Size: 59 KiB |
|
Before Width: | Height: | Size: 44 B After Width: | Height: | Size: 44 B |
|
Before Width: | Height: | Size: 10 KiB After Width: | Height: | Size: 10 KiB |
|
Before Width: | Height: | Size: 1.2 KiB After Width: | Height: | Size: 1.2 KiB |
|
Before Width: | Height: | Size: 129 B After Width: | Height: | Size: 129 B |
|
Before Width: | Height: | Size: 51 B After Width: | Height: | Size: 51 B |
|
Before Width: | Height: | Size: 21 KiB After Width: | Height: | Size: 21 KiB |
|
Before Width: | Height: | Size: 4.2 KiB After Width: | Height: | Size: 4.2 KiB |
|
After Width: | Height: | Size: 9.1 KiB |
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
io.encodings.binary io.files namespaces sequences tools.test ;
|
||||
USING: accessors images.testing images.tiff images.viewer io
|
||||
io.encodings.binary io.files namespaces sequences tools.test
|
||||
tools.test.private ;
|
||||
IN: images.tiff.tests
|
||||
|
||||
: path>tiff ( path -- tiff )
|
||||
binary [ input-stream get load-tiff ] with-file-reader ;
|
||||
|
||||
: tiff-example1 ( -- tiff )
|
||||
"resource:extra/images/testing/square.tiff" path>tiff ;
|
||||
|
||||
: tiff-example2 ( -- tiff )
|
||||
"resource:extra/images/testing/cube.tiff" path>tiff ;
|
||||
|
||||
: 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
|
||||
|
||||
verbose-tests? off
|
||||
"vocab:images/testing/tiff/octagon.tiff" decode-test
|
||||
"vocab:images/testing/tiff/elephants.tiff" decode-test
|
||||
"vocab:images/testing/tiff/noise.tiff" decode-test
|
||||
"vocab:images/testing/tiff/alpha.tiff" decode-test
|
||||
"vocab:images/testing/tiff/color_spectrum.tiff" decode-test
|
||||
! "vocab:images/testing/tiff/rgb.tiff" decode-test
|
||||
verbose-tests? on
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
io.encodings.binary io.files kernel math math.bitwise
|
||||
math.parser namespaces prettyprint sequences tools.test images.viewer ;
|
||||
USING: accessors bitstreams compression.lzw fry images.gif
|
||||
images.loader images.testing images.viewer io
|
||||
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 )
|
||||
"resource:extra/images/testing/circle.gif" path>gif ;
|
||||
: circle.gif ( -- gif )
|
||||
"vocab:images/testing/gif/circle.gif" path>gif ;
|
||||
|
||||
: gif-example2 ( -- loading-gif )
|
||||
"resource:extra/images/testing/checkmark.gif" path>gif ;
|
||||
: checkmark.gif ( -- gif )
|
||||
"vocab:images/testing/gif/checkmark.gif" path>gif ;
|
||||
|
||||
: gif-example3 ( -- loading-gif )
|
||||
"resource:extra/images/testing/monochrome.gif" path>gif ;
|
||||
: monochrome.gif ( -- gif )
|
||||
"vocab:images/testing/gif/monochrome.gif" path>gif ;
|
||||
|
||||
: gif-example4 ( -- loading-gif )
|
||||
"resource:extra/images/testing/noise.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 ;
|
||||
: alpha.gif ( -- gif )
|
||||
"vocab:images/testing/gif/alpha.gif" path>gif ;
|
||||
|
||||
: 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
|
||||
[ 16 ] [ gif-example1 declared-num-colors ] unit-test
|
||||
[ 2 ] [ monochrome.gif actual-num-colors ] unit-test
|
||||
[ 2 ] [ monochrome.gif declared-num-colors ] unit-test
|
||||
|
||||
[ 256 ] [ gif-example2 actual-num-colors ] unit-test
|
||||
[ 256 ] [ gif-example2 declared-num-colors ] unit-test
|
||||
[ 16 ] [ circle.gif actual-num-colors ] unit-test
|
||||
[ 16 ] [ circle.gif declared-num-colors ] unit-test
|
||||
|
||||
[ 2 ] [ gif-example3 actual-num-colors ] unit-test
|
||||
[ 2 ] [ gif-example3 declared-num-colors ] unit-test
|
||||
[ 256 ] [ checkmark.gif actual-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
|
||||
|
||||
[
|
||||
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
|
||||
] [ monochrome.gif >index-stream ] unit-test
|
||||
|
||||
[
|
||||
BV{
|
||||
0 1
|
||||
1 0
|
||||
}
|
||||
] [ gif-example5 >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
|
||||
] [ alpha.gif >index-stream ] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
Before Width: | Height: | Size: 48 KiB |