use singletons instead of subclassing the image class
parent
a0b01a51b7
commit
a3f0c6c057
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue