1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs byte-arrays checksums
4 checksums.crc32 combinators compression.inflate fry grouping
5 images images.loader io io.binary io.encodings.ascii
6 io.encodings.binary io.encodings.string io.streams.byte-array
7 io.streams.throwing kernel locals math math.bitwise
8 math.functions math.order math.ranges sequences sorting ;
9 QUALIFIED-WITH: bitstreams bs
14 "png" png-image register-image-class
18 width height bit-depth color-type compression-method
19 filter-method interlace-method uncompressed ;
21 CONSTANT: filter-none 0
22 CONSTANT: filter-sub 1
24 CONSTANT: filter-average 3
25 CONSTANT: filter-paeth 4
29 CONSTANT: indexed-color 3
30 CONSTANT: greyscale-alpha 4
31 CONSTANT: truecolor-alpha 6
33 CONSTANT: interlace-none 0
34 CONSTANT: interlace-adam7 1
36 CONSTANT: starting-row { 0 0 4 0 2 0 1 }
37 CONSTANT: starting-col { 0 4 0 2 0 1 0 }
38 CONSTANT: row-increment { 8 8 8 4 4 2 2 }
39 CONSTANT: col-increment { 8 8 4 4 2 2 1 }
40 CONSTANT: block-height { 8 8 4 4 2 2 1 }
41 CONSTANT: block-width { 8 4 4 2 2 1 1 }
43 : <loading-png> ( -- image )
47 TUPLE: png-chunk length type data ;
49 : <png-chunk> ( -- png-chunk )
50 png-chunk new ; inline
53 B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
55 ERROR: bad-png-header header ;
57 : read-png-header ( -- )
58 8 read dup png-header sequence= [
64 : read-png-chunks ( loading-png -- loading-png )
66 4 read be> [ >>length ] [ 4 + ] bi
67 read dup crc32 checksum-bytes
68 4 read = [ bad-checksum ] unless
70 [ ascii decode >>type ] [ B{ } like >>data ] bi*
71 [ over chunks>> push ]
72 [ type>> ] bi "IEND" =
73 [ read-png-chunks ] unless ;
75 : find-chunk ( loading-png string -- chunk )
76 [ chunks>> ] dip '[ type>> _ = ] find nip ;
78 : find-chunks ( loading-png string -- chunk )
79 [ chunks>> ] dip '[ type>> _ = ] filter ;
81 : parse-ihdr-chunk ( loading-png -- loading-png )
82 dup "IHDR" find-chunk data>> {
83 [ [ 0 4 ] dip subseq be> >>width ]
84 [ [ 4 8 ] dip subseq be> >>height ]
85 [ [ 8 ] dip nth >>bit-depth ]
86 [ [ 9 ] dip nth >>color-type ]
87 [ [ 10 ] dip nth >>compression-method ]
88 [ [ 11 ] dip nth >>filter-method ]
89 [ [ 12 ] dip nth >>interlace-method ]
92 : find-compressed-bytes ( loading-png -- bytes )
93 "IDAT" find-chunks [ data>> ] map concat ;
95 ERROR: unknown-color-type n ;
96 ERROR: unimplemented-color-type image ;
98 : inflate-data ( loading-png -- bytes )
99 find-compressed-bytes zlib-inflate ;
101 : png-components-per-pixel ( loading-png -- n )
105 { greyscale-alpha [ 2 ] }
106 { indexed-color [ 1 ] }
107 { truecolor-alpha [ 4 ] }
108 [ unknown-color-type ]
111 : png-group-width ( loading-png -- n )
112 ! 1 + is for the filter type, 1 byte preceding each line
113 [ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
114 [ width>> ] bi * 1 + ;
116 :: paeth ( a b c -- p )
117 a b + c - { a b c } [ [ - abs ] keep 2array ] with map
118 sort-keys first second ;
120 ERROR: bad-filter n ;
122 :: png-unfilter-line ( width prev curr filter -- curr' )
124 prev width tail-slice :> b
126 curr width tail-slice :> x
129 { filter-none [ drop ] }
130 { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
131 { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
132 { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
133 { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
138 :: reverse-png-filter ( lines n -- byte-array )
139 lines dup first length 0 <array> prefix
140 [ n 1 - 0 <array> prepend ] map
145 [ [ 0 n 1 - ] dip set-nth ] tri
147 ] map B{ } concat-as ;
149 :: visit ( row col height width pixel image -- )
150 row image nth :> irow
151 pixel col irow set-nth ;
153 :: read-scanlines ( byte-reader loading-png width height -- array )
154 loading-png png-components-per-pixel :> #components
155 loading-png bit-depth>> :> bit-depth
157 #components width * :> count!
159 #components bit-depth * width * 8 math:align 8 /i :> stride
162 stride 1 + byte-reader stream-read
164 #components bit-depth 16 = [ 2 * ] when reverse-png-filter
166 ! Only read up to 8 bits at a time
172 bs:<msb0-bit-reader> :> br
174 count [ depth br bs:read ] B{ } replicate-as
178 :: reverse-interlace-none ( bytes loading-png -- array )
179 bytes binary <byte-reader> :> br
180 loading-png width>> :> width
181 loading-png height>> :> height
182 br loading-png width height read-scanlines ;
184 :: adam7-subimage-height ( png-height pass -- subimage-height )
185 pass starting-row nth png-height >= [
189 pass block-height nth +
190 pass row-increment nth /i
193 :: adam7-subimage-width ( png-width pass -- subimage-width )
194 pass starting-col nth png-width >= [
198 pass block-width nth +
199 pass col-increment nth /i
202 :: read-adam7-subimage ( byte-reader loading-png pass -- lines )
203 loading-png height>> pass adam7-subimage-height :> height
204 loading-png width>> pass adam7-subimage-width :> width
206 height width * zero? [
209 byte-reader loading-png width height read-scanlines
212 :: reverse-interlace-adam7 ( byte-array loading-png -- byte-array )
213 byte-array binary <byte-reader> :> ba
214 loading-png height>> :> height
215 loading-png width>> :> width
216 loading-png bit-depth>> :> bit-depth
217 loading-png png-components-per-pixel :> #bytes!
218 width height * f <array> width <sliced-groups> :> image
229 ba loading-png pass read-adam7-subimage
231 #bytes <sliced-groups>
233 pass starting-row nth row!
234 pass starting-col nth col!
236 [ row col f f ] dip image visit
238 col pass col-increment nth + col!
240 pass starting-col nth col!
241 row pass row-increment nth + row!
247 image concat B{ } concat-as ;
249 ERROR: unimplemented-interlace ;
251 : uncompress-bytes ( loading-png -- bitstream )
252 [ inflate-data ] [ ] [ interlace-method>> ] tri {
253 { interlace-none [ reverse-interlace-none ] }
254 { interlace-adam7 [ reverse-interlace-adam7 ] }
255 [ unimplemented-interlace ]
258 ERROR: unknown-component-type n ;
260 : png-component ( loading-png -- obj )
262 { 1 [ ubyte-components ] }
263 { 2 [ ubyte-components ] }
264 { 4 [ ubyte-components ] }
265 { 8 [ ubyte-components ] }
266 { 16 [ ushort-components ] }
267 [ unknown-component-type ]
270 : scale-factor ( n -- n' )
277 : scale-greyscale ( byte-array loading-png -- byte-array' )
280 { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
281 [ scale-factor '[ _ * ] B{ } map-as ]
284 : decode-greyscale ( loading-png -- byte-array )
285 [ uncompress-bytes ] keep scale-greyscale ;
287 : decode-greyscale-alpha ( loading-image -- byte-array )
288 [ uncompress-bytes ] [ bit-depth>> ] bi 16 = [
289 4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
292 ERROR: invalid-PLTE array ;
294 : verify-PLTE ( seq -- seq )
295 dup length 3 divisor? [ invalid-PLTE ] unless ;
297 : decode-indexed-color ( loading-image -- byte-array )
298 [ uncompress-bytes ] keep
299 "PLTE" find-chunk data>> verify-PLTE
300 3 group '[ _ nth ] { } map-as B{ } concat-as ;
302 ERROR: invalid-color-type/bit-depth loading-png ;
304 : validate-bit-depth ( loading-png seq -- loading-png )
305 [ dup bit-depth>> ] dip member?
306 [ invalid-color-type/bit-depth ] unless ;
308 : validate-greyscale ( loading-png -- loading-png )
309 { 1 2 4 8 16 } validate-bit-depth ;
311 : validate-truecolor ( loading-png -- loading-png )
312 { 8 16 } validate-bit-depth ;
314 : validate-indexed-color ( loading-png -- loading-png )
315 { 1 2 4 8 } validate-bit-depth ;
317 : validate-greyscale-alpha ( loading-png -- loading-png )
318 { 8 16 } validate-bit-depth ;
320 : validate-truecolor-alpha ( loading-png -- loading-png )
321 { 8 16 } validate-bit-depth ;
323 : loading-png>bitmap ( loading-png -- bytes component-order )
326 validate-greyscale decode-greyscale L
329 validate-truecolor uncompress-bytes RGB
332 validate-indexed-color decode-indexed-color RGB
335 validate-greyscale-alpha decode-greyscale-alpha LA
338 validate-truecolor-alpha uncompress-bytes RGBA
340 [ unknown-color-type ]
343 : loading-png>image ( loading-png -- image )
345 [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
346 [ [ width>> ] [ height>> ] bi 2array >>dim ]
347 [ png-component >>component-type ]
350 : load-png ( stream -- loading-png )
358 ] with-input-stream ;
360 M: png-image stream>image
361 drop load-png loading-png>image ;