images.*: fix all image>stream words in extra so that they work with the added parameter

db4
Björn Lindqvist 2014-03-09 13:08:23 +01:00 committed by John Benediktsson
parent 944718c817
commit 13dc01dbc4
5 changed files with 22 additions and 23 deletions

View File

@ -428,5 +428,4 @@ M: bmp-image stream>image* ( stream bmp-image -- bitmap )
] bi ; ] bi ;
M: bmp-image image>stream M: bmp-image image>stream
drop BGR reorder-components output-bmp ; 2drop BGR reorder-components output-bmp ;

View File

@ -76,7 +76,7 @@ M: pbm-image stream>image*
drop [ [ read-pbm ] throw-on-eof ] with-input-stream ; drop [ [ read-pbm ] throw-on-eof ] with-input-stream ;
M: pbm-image image>stream M: pbm-image image>stream
drop { 2drop {
[ drop "P4\n" ascii encode write ] [ drop "P4\n" ascii encode write ]
[ dim>> first number>string " " append ascii encode write ] [ dim>> first number>string " " append ascii encode write ]
[ dim>> second number>string "\n" append ascii encode write ] [ dim>> second number>string "\n" append ascii encode write ]

View File

@ -38,7 +38,7 @@ SINGLETON: ppm-image
{ "P3" [ [ 0 npixels read-numbers ] B{ } make ] } { "P3" [ [ 0 npixels read-numbers ] B{ } make ] }
{ "P6" [ npixels read ] } { "P6" [ npixels read ] }
} case :> data } case :> data
image new image new
RGB >>component-order RGB >>component-order
{ width height } >>dim { width height } >>dim
@ -50,7 +50,7 @@ M: ppm-image stream>image*
drop [ [ read-ppm ] throw-on-eof ] with-input-stream ; drop [ [ read-ppm ] throw-on-eof ] with-input-stream ;
M: ppm-image image>stream M: ppm-image image>stream
drop { 2drop {
[ drop "P6\n" ascii encode write ] [ drop "P6\n" ascii encode write ]
[ dim>> first number>string " " append ascii encode write ] [ dim>> first number>string " " append ascii encode write ]
[ dim>> second number>string "\n" append ascii encode write ] [ dim>> second number>string "\n" append ascii encode write ]

View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Keith Lazuka. ! Copyright (C) 2009 Keith Lazuka.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry images images.loader images.normalization USING: accessors assocs fry images images.loader images.normalization
images.viewer io io.backend io.directories io.encodings.binary images.loader.private images.viewer io io.backend io.directories
io.files io.pathnames io.streams.byte-array kernel locals io.encodings.binary io.files io.pathnames io.streams.byte-array kernel locals
namespaces quotations random sequences serialize tools.test ; namespaces quotations random sequences serialize tools.test ;
IN: images.testing IN: images.testing
@ -42,8 +42,9 @@ PRIVATE>
f verbose-tests? [ f verbose-tests? [
path load-image dup clone normalize-image 1quotation swap path load-image dup clone normalize-image 1quotation swap
'[ '[
binary [ _ image-class image>stream ] with-byte-writer binary [
image-class load-image* normalize-image _ image-class [ types get value-at ] keep image>stream
] with-byte-writer image-class load-image* normalize-image
] unit-test ] unit-test
] with-variable ; ] with-variable ;
@ -53,7 +54,7 @@ PRIVATE>
[ '[ _ load-reference-image ] ] bi [ '[ _ load-reference-image ] ] bi
unit-test unit-test
] with-variable ; ] with-variable ;
: <rgb-image> ( -- image ) : <rgb-image> ( -- image )
<image> <image>
RGB >>component-order RGB >>component-order

View File

@ -21,7 +21,7 @@ ERROR: bad-tga-unsupported ;
: read-color-map-type ( -- byte ) : read-color-map-type ( -- byte )
1 read le> dup 1 read le> dup
{ 0 1 } member? [ bad-tga-header ] unless ; { 0 1 } member? [ bad-tga-header ] unless ;
: read-image-type ( -- byte ) : read-image-type ( -- byte )
1 read le> dup 1 read le> dup
{ 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline { 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
@ -167,7 +167,7 @@ ERROR: bad-tga-unsupported ;
[ first ] [ first ]
[ dup third second seek-absolute seek-input read ] bi 2array [ dup third second seek-absolute seek-input read ] bi 2array
] map >hashtable ; inline ] map >hashtable ; inline
:: read-tga ( -- image ) :: read-tga ( -- image )
#! Read header #! Read header
read-id-length :> id-length read-id-length :> id-length
@ -185,7 +185,7 @@ ERROR: bad-tga-unsupported ;
id-length read-image-id :> image-id id-length read-image-id :> image-id
map-type map-length map-entry-size read-color-map :> color-map-data map-type map-length map-entry-size read-color-map :> color-map-data
image-width image-height pixel-depth read-image-data :> image-data image-width image-height pixel-depth read-image-data :> image-data
[ [
#! Read optional footer #! Read optional footer
26 seek-end seek-input 26 seek-end seek-input
@ -208,11 +208,11 @@ ERROR: bad-tga-unsupported ;
read-key-color :> key-color read-key-color :> key-color
read-pixel-aspect-ratio :> aspect-ratio read-pixel-aspect-ratio :> aspect-ratio
read-gamma-value :> gamma-value read-gamma-value :> gamma-value
read-color-correction-offset :> color-correction-offset read-color-correction-offset :> color-correction-offset
read-postage-stamp-offset :> postage-stamp-offset read-postage-stamp-offset :> postage-stamp-offset
read-scan-line-offset :> scan-line-offset read-scan-line-offset :> scan-line-offset
read-premultiplied-alpha :> premultiplied-alpha read-premultiplied-alpha :> premultiplied-alpha
color-correction-offset 0 = color-correction-offset 0 =
[ [
color-correction-offset seek-absolute seek-input color-correction-offset seek-absolute seek-input
@ -224,10 +224,10 @@ ERROR: bad-tga-unsupported ;
postage-stamp-offset seek-absolute seek-input postage-stamp-offset seek-absolute seek-input
pixel-depth read-postage-stamp-image :> postage-data pixel-depth read-postage-stamp-image :> postage-data
] unless ] unless
scan-line-offset seek-absolute seek-input scan-line-offset seek-absolute seek-input
image-height read-scan-line-table :> scan-offsets image-height read-scan-line-table :> scan-offsets
#! Read optional developer section #! Read optional developer section
directory-offset 0 = directory-offset 0 =
[ f ] [ f ]
@ -240,11 +240,11 @@ ERROR: bad-tga-unsupported ;
#! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported. #! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
#! Other formats would need to be converted to work within the image class. #! Other formats would need to be converted to work within the image class.
map-type 0 = [ bad-tga-unsupported ] unless map-type 0 = [ bad-tga-unsupported ] unless
image-type 2 = [ bad-tga-unsupported ] unless image-type 2 = [ bad-tga-unsupported ] unless
pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
#! Create image instance #! Create image instance
image new image new
alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
@ -252,12 +252,12 @@ ERROR: bad-tga-unsupported ;
pixel-order 0 = >>upside-down? pixel-order 0 = >>upside-down?
image-data >>bitmap image-data >>bitmap
ubyte-components >>component-type ; ubyte-components >>component-type ;
M: tga-image stream>image* M: tga-image stream>image*
drop [ [ read-tga ] throw-on-eof ] with-input-stream ; drop [ [ read-tga ] throw-on-eof ] with-input-stream ;
M: tga-image image>stream M: tga-image image>stream
drop 2drop
[ [
component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
] keep ] keep
@ -287,4 +287,3 @@ M: tga-image image>stream
] ]
[ bitmap>> write ] [ bitmap>> write ]
} cleave ; } cleave ;