extra/images/png/png.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs checksums checksums.crc32 combinators
   4 compression.inflate fry grouping images images.loader io io.binary
   5 io.encodings.8-bit.latin1 io.encodings.ascii io.encodings.binary
   6 io.encodings.string io.streams.byte-array io.streams.throwing kernel
   7 locals math math.bitwise math.functions sequences sorting splitting ;
   8 QUALIFIED: bitstreams
   9 IN: images.png
  10
  11 SINGLETON: png-image
  12 "png" png-image ?register-image-class
  13
  14 TUPLE: icc-profile name data ;
  15
  16 TUPLE: itext keyword language translated-keyword text ;
  17
  18 TUPLE: loading-png
  19     chunks
  20     width height bit-depth color-type compression-method
  21     filter-method interlace-method icc-profile itexts ;
  22
  23 CONSTANT: filter-none 0
  24 CONSTANT: filter-sub 1
  25 CONSTANT: filter-up 2
  26 CONSTANT: filter-average 3
  27 CONSTANT: filter-paeth 4
  28
  29 CONSTANT: greyscale 0
  30 CONSTANT: truecolor 2
  31 CONSTANT: indexed-color 3
  32 CONSTANT: greyscale-alpha 4
  33 CONSTANT: truecolor-alpha 6
  34
  35 CONSTANT: interlace-none 0
  36 CONSTANT: interlace-adam7 1
  37
  38 CONSTANT: starting-row  { 0 0 4 0 2 0 1 }
  39 CONSTANT: starting-col  { 0 4 0 2 0 1 0 }
  40 CONSTANT: row-increment { 8 8 8 4 4 2 2 }
  41 CONSTANT: col-increment { 8 8 4 4 2 2 1 }
  42 CONSTANT: block-height  { 8 8 4 4 2 2 1 }
  43 CONSTANT: block-width   { 8 4 4 2 2 1 1 }
  44
  45 : <loading-png> ( -- image )
  46     loading-png new
  47     V{ } clone >>chunks ;
  48
  49 TUPLE: png-chunk type data ;
  50
  51 : <png-chunk> ( -- png-chunk )
  52     png-chunk new ; inline
  53
  54 CONSTANT: png-header
  55     B{ 0x89 0x50 0x4e 0x47 0x0d 0x0a 0x1a 0x0a }
  56
  57 ERROR: bad-png-header header ;
  58
  59 : read-png-header ( -- )
  60     8 read dup png-header sequence= [
  61         bad-png-header
  62     ] unless drop ;
  63
  64 ERROR: bad-checksum ;
  65
  66 : read-png-chunks ( loading-png -- loading-png )
  67     <png-chunk>
  68     4 read be> 4 +
  69     read dup crc32 checksum-bytes
  70     4 read = [ bad-checksum ] unless
  71     4 cut-slice
  72     [ ascii decode >>type ] [ B{ } like >>data ] bi*
  73     [ over chunks>> push ]
  74     [ type>> ] bi "IEND" =
  75     [ read-png-chunks ] unless ;
  76
  77 : find-chunk ( loading-png string -- chunk )
  78     [ chunks>> ] dip '[ type>> _ = ] find nip ;
  79
  80 : find-chunks ( loading-png string -- chunk )
  81     [ chunks>> ] dip '[ type>> _ = ] filter ;
  82
  83 : read-png-string ( -- str )
  84     { 0 } read-until drop latin1 decode ;
  85
  86 : parse-ihdr-chunk ( loading-png -- loading-png )
  87     dup "IHDR" find-chunk data>> {
  88         [ [ 0 4 ] dip subseq be> >>width ]
  89         [ [ 4 8 ] dip subseq be> >>height ]
  90         [ [ 8 ] dip nth >>bit-depth ]
  91         [ [ 9 ] dip nth >>color-type ]
  92         [ [ 10 ] dip nth >>compression-method ]
  93         [ [ 11 ] dip nth >>filter-method ]
  94         [ [ 12 ] dip nth >>interlace-method ]
  95     } cleave ;
  96
  97 : <icc-profile> ( byte-array -- icc-profile )
  98     binary [
  99         read-png-string read1 drop contents zlib-inflate
 100     ] with-byte-reader icc-profile boa ;
 101
 102 : <itext> ( byte-array -- itext )
 103     binary [
 104         read-png-string
 105         ! Skip compression flag and method
 106         read1 read1 2drop
 107         read-png-string read-png-string read-png-string
 108     ] with-byte-reader itext boa ;
 109
 110 : parse-iccp-chunk ( loading-png -- loading-png )
 111     dup "iCCP" find-chunk [
 112         data>> <icc-profile> >>icc-profile
 113     ] when* ;
 114
 115 : parse-itext-chunks ( loading-png -- loading-png )
 116     dup "iTXt" find-chunks [ data>> <itext> ] map >>itexts ;
 117
 118 : find-compressed-bytes ( loading-png -- bytes )
 119     "IDAT" find-chunks [ data>> ] map concat ;
 120
 121 ERROR: unknown-color-type n ;
 122 ERROR: unimplemented-color-type image ;
 123
 124 : inflate-data ( loading-png -- bytes )
 125     find-compressed-bytes zlib-inflate ;
 126
 127 : png-components-per-pixel ( loading-png -- n )
 128     color-type>> {
 129         { greyscale [ 1 ] }
 130         { truecolor [ 3 ] }
 131         { greyscale-alpha [ 2 ] }
 132         { indexed-color [ 1 ] }
 133         { truecolor-alpha [ 4 ] }
 134         [ unknown-color-type ]
 135     } case ; inline
 136
 137 : png-group-width ( loading-png -- n )
 138     ! 1 + is for the filter type, 1 byte preceding each line
 139     [ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
 140     [ width>> ] bi * 1 + ;
 141
 142 :: paeth ( a b c -- p )
 143     a b + c - { a b c } [ [ - abs ] keep 2array ] with map
 144     sort-keys first second ;
 145
 146 ERROR: bad-filter n ;
 147
 148 :: png-unfilter-line ( width prev curr filter -- curr' )
 149     prev :> c
 150     prev width tail-slice :> b
 151     curr :> a
 152     curr width tail-slice :> x
 153     x length <iota>
 154     filter {
 155         { filter-none [ drop ] }
 156         { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
 157         { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
 158         { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
 159         { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
 160         [ bad-filter ]
 161     } case
 162     curr width tail ;
 163
 164 :: reverse-png-filter ( lines n -- byte-array )
 165     lines dup first length 0 <array> prefix
 166     [ n 1 - 0 <array> prepend ] map
 167     2 clump [
 168         n swap first2
 169         [ ]
 170         [ n 1 - swap nth ]
 171         [ [ 0 n 1 - ] dip set-nth ] tri
 172         png-unfilter-line
 173     ] map B{ } concat-as ;
 174
 175 :: visit ( row col height width pixel image -- )
 176     row image nth :> irow
 177     pixel col irow set-nth ;
 178
 179 :: read-scanlines ( byte-reader loading-png width height -- array )
 180     loading-png png-components-per-pixel :> #components
 181     loading-png bit-depth>> :> bit-depth
 182     bit-depth :> depth!
 183     #components width * :> count!
 184
 185     #components bit-depth * width * 8 math:align 8 /i :> stride
 186
 187     height [
 188         stride 1 + byte-reader stream-read
 189     ] replicate
 190     #components bit-depth 16 = [ 2 * ] when reverse-png-filter
 191
 192     ! Only read up to 8 bits at a time
 193     bit-depth 16 = [
 194         8 depth!
 195         count 2 * count!
 196     ] when
 197
 198     bitstreams:<msb0-bit-reader> :> br
 199     height [
 200         count [ depth br bitstreams:read ] B{ } replicate-as
 201         8 br bitstreams:align
 202     ] replicate concat ;
 203
 204 :: reverse-interlace-none ( bytes loading-png -- array )
 205     bytes binary <byte-reader> :> br
 206     loading-png width>> :> width
 207     loading-png height>> :> height
 208     br loading-png width height read-scanlines ;
 209
 210 :: adam7-subimage-height ( png-height pass -- subimage-height )
 211     pass starting-row nth png-height >= [
 212         0
 213     ] [
 214         png-height 1 -
 215         pass block-height nth +
 216         pass row-increment nth /i
 217     ] if ;
 218
 219 :: adam7-subimage-width ( png-width pass -- subimage-width )
 220     pass starting-col nth png-width >= [
 221         0
 222     ] [
 223         png-width 1 -
 224         pass block-width nth +
 225         pass col-increment nth /i
 226     ] if ;
 227
 228 :: read-adam7-subimage ( byte-reader loading-png pass -- lines )
 229     loading-png height>> pass adam7-subimage-height :> height
 230     loading-png width>> pass adam7-subimage-width :> width
 231
 232     height width * zero? [
 233         B{ }
 234     ] [
 235         byte-reader loading-png width height read-scanlines
 236     ] if ;
 237
 238 :: reverse-interlace-adam7 ( byte-array loading-png -- byte-array )
 239     byte-array binary <byte-reader> :> ba
 240     loading-png height>> :> height
 241     loading-png width>> :> width
 242     loading-png bit-depth>> :> bit-depth
 243     loading-png png-components-per-pixel :> #bytes!
 244     width height * f <array> width <groups> :> image
 245
 246     bit-depth 16 = [
 247         #bytes 2 * #bytes!
 248     ] when
 249
 250     0 :> row!
 251     0 :> col!
 252
 253     0 :> pass!
 254     [ pass 7 < ] [
 255       ba loading-png pass read-adam7-subimage
 256
 257       #bytes <groups>
 258
 259       pass starting-row nth row!
 260       pass starting-col nth col!
 261       [
 262           [ row col f f ] dip image visit
 263
 264           col pass col-increment nth + col!
 265           col width >= [
 266               pass starting-col nth col!
 267               row pass row-increment nth + row!
 268           ] when
 269       ] each
 270
 271       pass 1 + pass!
 272     ] while
 273     image concat B{ } concat-as ;
 274
 275 ERROR: unimplemented-interlace ;
 276
 277 : uncompress-bytes ( loading-png -- bitstream )
 278     [ inflate-data ] [ ] [ interlace-method>> ] tri {
 279         { interlace-none [ reverse-interlace-none ] }
 280         { interlace-adam7 [ reverse-interlace-adam7 ] }
 281         [ unimplemented-interlace ]
 282     } case ;
 283
 284 ERROR: unknown-component-type n ;
 285
 286 : png-component ( loading-png -- obj )
 287     bit-depth>> {
 288         { 1 [ ubyte-components ] }
 289         { 2 [ ubyte-components ] }
 290         { 4 [ ubyte-components ] }
 291         { 8 [ ubyte-components ] }
 292         { 16 [ ushort-components ] }
 293         [ unknown-component-type ]
 294     } case ;
 295
 296 : scale-factor ( n -- n' )
 297     {
 298         { 1 [ 255 ] }
 299         { 2 [ 85 ] }
 300         { 4 [ 17 ] }
 301     } case ;
 302
 303 : scale-greyscale ( byte-array loading-png -- byte-array' )
 304     bit-depth>> {
 305         { 8 [ ] }
 306         { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
 307         [ scale-factor '[ _ * ] B{ } map-as ]
 308     } case ;
 309
 310 : decode-greyscale ( loading-png -- byte-array )
 311     [ uncompress-bytes ] keep scale-greyscale ;
 312
 313 : decode-greyscale-alpha ( loading-image -- byte-array )
 314     [ uncompress-bytes ] [ bit-depth>> ] bi 16 = [
 315         4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
 316     ] when ;
 317
 318 ERROR: invalid-PLTE array ;
 319
 320 : verify-PLTE ( seq -- seq )
 321     dup length 3 divisor? [ invalid-PLTE ] unless ;
 322
 323 : decode-indexed-color ( loading-image -- byte-array )
 324     [ uncompress-bytes ] keep
 325     "PLTE" find-chunk data>> verify-PLTE
 326     3 group '[ _ nth ] { } map-as B{ } concat-as ;
 327
 328 ERROR: invalid-color-type/bit-depth loading-png ;
 329
 330 : validate-bit-depth ( loading-png seq -- loading-png )
 331     [ dup bit-depth>> ] dip member?
 332     [ invalid-color-type/bit-depth ] unless ;
 333
 334 : validate-greyscale ( loading-png -- loading-png )
 335     { 1 2 4 8 16 } validate-bit-depth ;
 336
 337 : validate-truecolor ( loading-png -- loading-png )
 338     { 8 16 } validate-bit-depth ;
 339
 340 : validate-indexed-color ( loading-png -- loading-png )
 341     { 1 2 4 8 } validate-bit-depth ;
 342
 343 : validate-greyscale-alpha ( loading-png -- loading-png )
 344     { 8 16 } validate-bit-depth ;
 345
 346 : validate-truecolor-alpha ( loading-png -- loading-png )
 347     { 8 16 } validate-bit-depth ;
 348
 349 : loading-png>bitmap ( loading-png -- bytes component-order )
 350     dup color-type>> {
 351         { greyscale [
 352             validate-greyscale decode-greyscale L
 353         ] }
 354         { truecolor [
 355             validate-truecolor uncompress-bytes RGB
 356         ] }
 357         { indexed-color [
 358             validate-indexed-color decode-indexed-color RGB
 359         ] }
 360         { greyscale-alpha [
 361             validate-greyscale-alpha decode-greyscale-alpha LA
 362         ] }
 363         { truecolor-alpha [
 364             validate-truecolor-alpha uncompress-bytes RGBA
 365         ] }
 366         [ unknown-color-type ]
 367     } case ;
 368
 369 : loading-png>image ( loading-png -- image )
 370     [ image new ] dip {
 371         [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
 372         [ [ width>> ] [ height>> ] bi 2array >>dim ]
 373         [ png-component >>component-type ]
 374     } cleave ;
 375
 376 : load-png ( stream -- loading-png )
 377     [
 378         [
 379             <loading-png>
 380             read-png-header
 381             read-png-chunks
 382             parse-ihdr-chunk
 383             parse-iccp-chunk
 384             parse-itext-chunks
 385         ] throw-on-eof
 386     ] with-input-stream ;
 387
 388 M: png-image stream>image*
 389     drop load-png loading-png>image ;