images.testing: switched from PAM reference image to Factor serialized image (.fig)
Keith Lazuka
parent
3a13c59da2
commit
f56320b142
|
|
@ -1,43 +1,11 @@
|
|||
USING: images.bitmap images.viewer io.encodings.binary
|
||||
io.files io.files.unique kernel tools.test images.loader
|
||||
literals sequences checksums.md5 checksums ;
|
||||
USING: images.bitmap images.testing kernel ;
|
||||
IN: images.bitmap.tests
|
||||
|
||||
CONSTANT: test-bitmap24 "vocab:images/testing/bmp/thiswayup24.bmp"
|
||||
! "vocab:images/testing/bmp/1bit.bmp" decode-test
|
||||
! "vocab:images/testing/bmp/rgb_4bit.bmp" decode-test
|
||||
|
||||
CONSTANT: test-bitmap8 "vocab:images/testing/bmp/rgb8bit.bmp"
|
||||
"vocab:images/testing/bmp/rgb_8bit.bmp"
|
||||
[ decode-test ] [ bmp-image encode-test ] bi
|
||||
|
||||
CONSTANT: test-bitmap4 "vocab:images/testing/bmp/rgb4bit.bmp"
|
||||
|
||||
CONSTANT: test-bitmap1 "vocab:images/testing/bmp/1bit.bmp"
|
||||
|
||||
CONSTANT: test-40 "vocab:images/testing/bmp/40red24bit.bmp"
|
||||
CONSTANT: test-41 "vocab:images/testing/bmp/41red24bit.bmp"
|
||||
CONSTANT: test-42 "vocab:images/testing/bmp/42red24bit.bmp"
|
||||
CONSTANT: test-43 "vocab:images/testing/bmp/43red24bit.bmp"
|
||||
|
||||
${
|
||||
test-bitmap8
|
||||
test-bitmap24
|
||||
"vocab:ui/render/test/reference.bmp"
|
||||
} [ [ ] swap [ load-image drop ] curry unit-test ] each
|
||||
|
||||
|
||||
: test-bitmap-save ( path -- ? )
|
||||
[ md5 checksum-file ]
|
||||
[ load-image ] bi
|
||||
"bitmap-save-test" ".bmp" make-unique-file
|
||||
[ save-bitmap ]
|
||||
[ md5 checksum-file ] bi = ;
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
${
|
||||
test-40
|
||||
test-41
|
||||
test-42
|
||||
test-43
|
||||
test-bitmap24
|
||||
} [ test-bitmap-save ] all?
|
||||
] unit-test
|
||||
"vocab:images/testing/bmp/42red_24bit.bmp"
|
||||
[ decode-test ] [ bmp-image encode-test ] bi
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: images.png images.testing namespaces tools.test
|
||||
images.pam ;
|
||||
USING: images.testing ;
|
||||
IN: images.png.tests
|
||||
|
||||
"vocab:images/testing/png/rgb.png" decode-test
|
||||
|
|
|
|||
Binary file not shown.
|
Before Width: | Height: | Size: 4.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.9 KiB |
|
Before Width: | Height: | Size: 5.1 KiB After Width: | Height: | Size: 5.1 KiB |
Binary file not shown.
Binary file not shown.
|
Before 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 |
Binary file not shown.
Binary file not shown.
|
Before Width: | Height: | Size: 59 KiB |
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -1,33 +1,39 @@
|
|||
! 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 namespaces
|
||||
quotations sequences tools.test ;
|
||||
USING: fry images.loader images.normalization io
|
||||
io.encodings.binary io.files io.pathnames io.streams.byte-array
|
||||
kernel locals namespaces quotations sequences serialize
|
||||
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 )
|
||||
: fig-name ( path -- newpath )
|
||||
[ parent-directory canonicalize-path ]
|
||||
[ file-stem ".pam" append ] bi
|
||||
[ file-stem ".fig" append ] bi
|
||||
append-path ;
|
||||
|
||||
: save-as-reference-image ( path -- )
|
||||
[ load-image ] [ pam-name ] bi save-graphic-image ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: save-as-reference-image ( path -- )
|
||||
[ load-image ] [ fig-name ] bi
|
||||
binary [ serialize ] with-file-writer ;
|
||||
|
||||
: load-reference-image ( path -- image )
|
||||
fig-name binary [ deserialize ] with-file-reader ;
|
||||
|
||||
:: encode-test ( path image-class -- )
|
||||
f verbose-tests? [
|
||||
path load-image dup clone normalize-image 1quotation swap
|
||||
'[
|
||||
binary [ _ image-class image>stream ] with-byte-writer
|
||||
image-class load-image* normalize-image
|
||||
] unit-test
|
||||
] with-variable ;
|
||||
|
||||
: decode-test ( path -- )
|
||||
f verbose-tests? [
|
||||
[ load-image 1quotation ]
|
||||
[ '[ _ pam-name load-image ] ] bi
|
||||
[ '[ _ load-reference-image ] ] bi
|
||||
unit-test
|
||||
] with-variable ;
|
||||
|
|
|
|||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors images.testing images.tiff images.viewer io
|
||||
io.encodings.binary io.files namespaces sequences tools.test
|
||||
images.pam ;
|
||||
USING: images.testing ;
|
||||
IN: images.tiff.tests
|
||||
|
||||
"vocab:images/testing/tiff/octagon.tiff" decode-test
|
||||
"vocab:images/testing/tiff/elephants.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
|
||||
"vocab:images/testing/tiff/rgb.tiff" decode-test
|
||||
|
|
|
|||
|
|
@ -1,21 +1,16 @@
|
|||
! Copyright (C) 2009 Keith Lazuka.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
USING: accessors compression.lzw images.gif images.testing io
|
||||
io.encodings.binary io.files kernel math math.bitwise
|
||||
namespaces sequences tools.test ;
|
||||
IN: images.gif.tests
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -1,57 +0,0 @@
|
|||
! 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
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
! 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 ;
|
||||
Loading…
Reference in New Issue