use singletons instead of subclassing the image class

db4
Doug Coleman 2009-06-04 16:09:38 -05:00
parent a0b01a51b7
commit a3f0c6c057
6 changed files with 26 additions and 44 deletions

View File

@ -15,7 +15,8 @@ IN: images.bitmap
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
TUPLE: bitmap-image < image ;
SINGLETON: bitmap-image
"bmp" bitmap-image register-image-class
TUPLE: loading-bitmap
magic size reserved1 reserved2 offset header-length width
@ -247,7 +248,9 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
: loading-bitmap>image ( image loading-bitmap -- bitmap-image )
M: bitmap-image load-image* ( path bitmap-image -- bitmap )
drop load-bitmap
[ image new ] dip
{
[ loading-bitmap>bytes >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
@ -256,11 +259,6 @@ ERROR: unknown-component-order bitmap ;
[ bitmap>component-order >>component-order ]
} cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
swap load-bitmap loading-bitmap>image ;
"bmp" bitmap-image register-image-class
PRIVATE>
: bitmap>color-index ( bitmap -- byte-array )

View File

@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path tuple -- image )
: make-image ( bitmap -- image )
! bitmap is a sequence of sequences of pixels which are RGBA
<image>
over [ first length ] [ length ] bi 2array >>dim
RGBA >>component-order
swap concat concat B{ } like >>bitmap ;
GENERIC: load-image* ( path class -- image )
<PRIVATE

View File

@ -7,11 +7,13 @@ io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep images.loader ;
QUALIFIED-WITH: bitstreams bs
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
SINGLETON: jpeg-image
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
TUPLE: jpeg-image < image
TUPLE: loading-jpeg < image
{ headers }
{ bitstream }
{ color-info initial: { f f f f } }
@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
<PRIVATE
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
@ -63,7 +65,7 @@ TUPLE: jpeg-color-info
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
: jpeg> ( -- jpeg-image ) jpeg-image get ;
: jpeg> ( -- jpeg-image ) loading-jpeg get ;
: apply-diff ( dc color -- dc' )
[ diff>> + dup ] [ (>>diff) ] bi ;
@ -291,9 +293,9 @@ PRIVATE>
binary [
parse-marker { SOI } assert=
parse-headers
contents <jpeg-image>
contents <loading-jpeg>
] with-file-reader
dup jpeg-image [
dup loading-jpeg [
baseline-parse
baseline-decompress
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
@ -302,5 +304,3 @@ PRIVATE>
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each

View File

@ -7,16 +7,18 @@ IN: images.loader
ERROR: unknown-image-extension extension ;
<PRIVATE
SYMBOL: types
types [ H{ } clone ] initialize
: image-class ( path -- class )
file-extension >lower types get ?at
[ unknown-image-extension ] unless ;
PRIVATE>
: register-image-class ( extension class -- )
swap types get set-at ;
: load-image ( path -- image )
dup image-class new load-image* ;
dup image-class load-image* ;

View File

@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays
images.loader ;
IN: images.png
TUPLE: png-image < image chunks
SINGLETON: png-image
"png" png-image register-image-class
TUPLE: loading-png < image chunks
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
CONSTRUCTOR: png-image ( -- image )
V{ } clone >>chunks ;
CONSTRUCTOR: loading-png ( -- image )
V{ } clone >>chunks ;
TUPLE: png-chunk length type data ;
@ -105,7 +108,7 @@ ERROR: unimplemented-color-type image ;
: load-png ( path -- image )
binary stream-throws <limited-file-reader> [
<png-image>
<loading-png>
read-png-header
read-png-chunks
parse-ihdr-chunk
@ -115,5 +118,3 @@ ERROR: unimplemented-color-type image ;
M: png-image load-image*
drop load-png ;
"png" png-image register-image-class

View File

@ -9,7 +9,7 @@ strings math.vectors specialized-arrays.float locals
images.loader ;
IN: images.tiff
TUPLE: tiff-image < image ;
SINGLETON: tiff-image
TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ]
} case ;
: normalize-alpha-data ( seq -- byte-array )
B{ } like dup
byte-array>float-array
4 <sliced-groups>
[
dup fourth dup 0 = [
2drop
] [
[ 3 head-slice ] dip '[ _ / ] change-each
] if
] each ;
: handle-alpha-data ( ifd -- ifd )
dup extra-samples find-tag {
{ extra-samples-associated-alpha-data [ ] }
@ -508,7 +496,7 @@ ERROR: unknown-component-order ifd ;
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order f ]
[ bitmap>> ]
} cleave tiff-image boa ;
} cleave image boa ;
: tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ;