1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays checksums checksums.crc32 combinators
4 compression.inflate fry grouping images images.loader io
5 io.binary io.encodings.ascii io.encodings.string kernel locals
6 math math.bitwise math.ranges sequences sorting ;
10 "png" png-image register-image-class
14 width height bit-depth color-type compression-method
15 filter-method interlace-method uncompressed ;
17 CONSTANT: filter-none 0
18 CONSTANT: filter-sub 1
20 CONSTANT: filter-average 3
21 CONSTANT: filter-paeth 4
25 CONSTANT: indexed-color 3
26 CONSTANT: greyscale-alpha 4
27 CONSTANT: truecolor-alpha 6
29 : <loading-png> ( -- image )
33 TUPLE: png-chunk length type data ;
35 : <png-chunk> ( -- png-chunk )
36 png-chunk new ; inline
39 B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
41 ERROR: bad-png-header header ;
43 : read-png-header ( -- )
44 8 read dup png-header sequence= [
50 : read-png-chunks ( loading-png -- loading-png )
52 4 read be> [ >>length ] [ 4 + ] bi
53 read dup crc32 checksum-bytes
54 4 read = [ bad-checksum ] unless
56 [ ascii decode >>type ] [ B{ } like >>data ] bi*
57 [ over chunks>> push ]
58 [ type>> ] bi "IEND" =
59 [ read-png-chunks ] unless ;
61 : find-chunk ( loading-png string -- chunk )
62 [ chunks>> ] dip '[ type>> _ = ] find nip ;
64 : parse-ihdr-chunk ( loading-png -- loading-png )
65 dup "IHDR" find-chunk data>> {
66 [ [ 0 4 ] dip subseq be> >>width ]
67 [ [ 4 8 ] dip subseq be> >>height ]
68 [ [ 8 ] dip nth >>bit-depth ]
69 [ [ 9 ] dip nth >>color-type ]
70 [ [ 10 ] dip nth >>compression-method ]
71 [ [ 11 ] dip nth >>filter-method ]
72 [ [ 12 ] dip nth >>interlace-method ]
75 : find-compressed-bytes ( loading-png -- bytes )
76 chunks>> [ type>> "IDAT" = ] filter
77 [ data>> ] map concat ;
79 ERROR: unknown-color-type n ;
80 ERROR: unimplemented-color-type image ;
82 : inflate-data ( loading-png -- bytes )
83 find-compressed-bytes zlib-inflate ;
85 : scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
87 : png-bytes-per-pixel ( loading-png -- n )
89 { 2 [ scale-bit-depth 3 * ] }
90 { 6 [ scale-bit-depth 4 * ] }
91 [ unknown-color-type ]
94 : png-group-width ( loading-png -- n )
95 ! 1 + is for the filter type, 1 byte preceding each line
96 [ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
98 :: paeth ( a b c -- p )
99 a b + c - { a b c } [ [ - abs ] keep 2array ] with map
100 sort-keys first second ;
102 :: png-unfilter-line ( width prev curr filter -- curr' )
104 prev width tail-slice :> b
106 curr width tail-slice :> x
109 { filter-none [ drop ] }
110 { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
111 { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
112 { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
113 { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
117 :: reverse-png-filter ( n lines -- byte-array )
118 lines dup first length 0 <array> prefix
119 [ n 1 - 0 <array> prepend ] map
121 n swap first2 [ ] [ n 1 - swap nth ] [ [ 0 n 1 - ] dip set-nth ] tri
123 ] map B{ } concat-as ;
125 : png-image-bytes ( loading-png -- byte-array )
126 [ png-bytes-per-pixel ] [ inflate-data ] [ png-group-width ] tri group reverse-png-filter ;
128 : decode-greyscale ( loading-png -- image )
129 unimplemented-color-type ;
131 : decode-truecolor ( loading-png -- image )
133 [ png-image-bytes >>bitmap ]
134 [ [ width>> ] [ height>> ] bi 2array >>dim ]
135 [ drop RGB >>component-order ubyte-components >>component-type ]
138 : decode-indexed-color ( loading-png -- image )
139 unimplemented-color-type ;
141 : decode-greyscale-alpha ( loading-png -- image )
142 unimplemented-color-type ;
144 : decode-truecolor-alpha ( loading-png -- image )
146 [ png-image-bytes >>bitmap ]
147 [ [ width>> ] [ height>> ] bi 2array >>dim ]
148 [ drop RGBA >>component-order ubyte-components >>component-type ]
151 ERROR: invalid-color-type/bit-depth loading-png ;
153 : validate-bit-depth ( loading-png seq -- loading-png )
154 [ dup bit-depth>> ] dip member?
155 [ invalid-color-type/bit-depth ] unless ;
157 : validate-greyscale ( loading-png -- loading-png )
158 { 1 2 4 8 16 } validate-bit-depth ;
160 : validate-truecolor ( loading-png -- loading-png )
161 { 8 16 } validate-bit-depth ;
163 : validate-indexed-color ( loading-png -- loading-png )
164 { 1 2 4 8 } validate-bit-depth ;
166 : validate-greyscale-alpha ( loading-png -- loading-png )
167 { 8 16 } validate-bit-depth ;
169 : validate-truecolor-alpha ( loading-png -- loading-png )
170 { 8 16 } validate-bit-depth ;
172 : png>image ( loading-png -- image )
174 { greyscale [ validate-greyscale decode-greyscale ] }
175 { truecolor [ validate-truecolor decode-truecolor ] }
176 { indexed-color [ validate-indexed-color decode-indexed-color ] }
177 { greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
178 { truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
179 [ unknown-color-type ]
182 : load-png ( stream -- loading-png )
188 ] with-input-stream ;
190 M: png-image stream>image
191 drop load-png png>image ;