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