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 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
  10 QUALIFIED: math
  11 IN: images.png
  12
  13 SINGLETON: png-image
  14 "png" png-image register-image-class
  15
  16 TUPLE: loading-png
  17     chunks
  18     width height bit-depth color-type compression-method
  19     filter-method interlace-method uncompressed ;
  20
  21 CONSTANT: filter-none 0
  22 CONSTANT: filter-sub 1
  23 CONSTANT: filter-up 2
  24 CONSTANT: filter-average 3
  25 CONSTANT: filter-paeth 4
  26
  27 CONSTANT: greyscale 0
  28 CONSTANT: truecolor 2
  29 CONSTANT: indexed-color 3
  30 CONSTANT: greyscale-alpha 4
  31 CONSTANT: truecolor-alpha 6
  32
  33 CONSTANT: interlace-none 0
  34 CONSTANT: interlace-adam7 1
  35
  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 }
  42
  43 : <loading-png> ( -- image )
  44     loading-png new
  45     V{ } clone >>chunks ;
  46
  47 TUPLE: png-chunk length type data ;
  48
  49 : <png-chunk> ( -- png-chunk )
  50     png-chunk new ; inline
  51
  52 CONSTANT: png-header
  53     B{ 0x89 0x50 0x4e 0x47 0x0d 0x0a 0x1a 0x0a }
  54
  55 ERROR: bad-png-header header ;
  56
  57 : read-png-header ( -- )
  58     8 read dup png-header sequence= [
  59         bad-png-header
  60     ] unless drop ;
  61
  62 ERROR: bad-checksum ;
  63
  64 : read-png-chunks ( loading-png -- loading-png )
  65     <png-chunk>
  66     4 read be> [ >>length ] [ 4 + ] bi
  67     read dup crc32 checksum-bytes
  68     4 read = [ bad-checksum ] unless
  69     4 cut-slice
  70     [ ascii decode >>type ] [ B{ } like >>data ] bi*
  71     [ over chunks>> push ]
  72     [ type>> ] bi "IEND" =
  73     [ read-png-chunks ] unless ;
  74
  75 : find-chunk ( loading-png string -- chunk )
  76     [ chunks>> ] dip '[ type>> _ = ] find nip ;
  77
  78 : find-chunks ( loading-png string -- chunk )
  79     [ chunks>> ] dip '[ type>> _ = ] filter ;
  80
  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 ]
  90     } cleave ;
  91
  92 : find-compressed-bytes ( loading-png -- bytes )
  93     "IDAT" find-chunks [ data>> ] map concat ;
  94
  95 ERROR: unknown-color-type n ;
  96 ERROR: unimplemented-color-type image ;
  97
  98 : inflate-data ( loading-png -- bytes )
  99     find-compressed-bytes zlib-inflate ;
 100
 101 : png-components-per-pixel ( loading-png -- n )
 102     color-type>> {
 103         { greyscale [ 1 ] }
 104         { truecolor [ 3 ] }
 105         { greyscale-alpha [ 2 ] }
 106         { indexed-color [ 1 ] }
 107         { truecolor-alpha [ 4 ] }
 108         [ unknown-color-type ]
 109     } case ; inline
 110
 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 + ;
 115
 116 :: paeth ( a b c -- p )
 117     a b + c - { a b c } [ [ - abs ] keep 2array ] with map
 118     sort-keys first second ;
 119
 120 ERROR: bad-filter n ;
 121
 122 :: png-unfilter-line ( width prev curr filter -- curr' )
 123     prev :> c
 124     prev width tail-slice :> b
 125     curr :> a
 126     curr width tail-slice :> x
 127     x length iota
 128     filter {
 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 ] }
 134         [ bad-filter ]
 135     } case
 136     curr width tail ;
 137
 138 :: reverse-png-filter ( lines n -- byte-array )
 139     lines dup first length 0 <array> prefix
 140     [ n 1 - 0 <array> prepend ] map
 141     2 clump [
 142         n swap first2
 143         [ ]
 144         [ n 1 - swap nth ]
 145         [ [ 0 n 1 - ] dip set-nth ] tri
 146         png-unfilter-line
 147     ] map B{ } concat-as ;
 148
 149 :: visit ( row col height width pixel image -- )
 150     row image nth :> irow
 151     pixel col irow set-nth ;
 152
 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
 156     bit-depth :> depth!
 157     #components width * :> count!
 158
 159     #components bit-depth * width * 8 math:align 8 /i :> stride
 160
 161     height [
 162         stride 1 + byte-reader stream-read
 163     ] replicate
 164     #components bit-depth 16 = [ 2 * ] when reverse-png-filter
 165
 166     ! Only read up to 8 bits at a time
 167     bit-depth 16 = [
 168         8 depth!
 169         count 2 * count!
 170     ] when
 171
 172     bs:<msb0-bit-reader> :> br
 173     height [
 174         count [ depth br bs:read ] B{ } replicate-as
 175         8 br bs:align
 176     ] replicate concat ;
 177
 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 ;
 183
 184 :: adam7-subimage-height ( png-height pass -- subimage-height )
 185     pass starting-row nth png-height >= [
 186         0
 187     ] [
 188         png-height 1 -
 189         pass block-height nth +
 190         pass row-increment nth /i
 191     ] if ;
 192
 193 :: adam7-subimage-width ( png-width pass -- subimage-width )
 194     pass starting-col nth png-width >= [
 195         0
 196     ] [
 197         png-width 1 -
 198         pass block-width nth +
 199         pass col-increment nth /i
 200     ] if ;
 201
 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
 205
 206     height width * zero? [
 207         B{ } clone
 208     ] [
 209         byte-reader loading-png width height read-scanlines
 210     ] if ;
 211
 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
 219
 220     bit-depth 16 = [
 221         #bytes 2 * #bytes!
 222     ] when
 223
 224     0 :> row!
 225     0 :> col!
 226
 227     0 :> pass!
 228     [ pass 7 < ] [
 229       ba loading-png pass read-adam7-subimage
 230
 231       #bytes <sliced-groups>
 232
 233       pass starting-row nth row!
 234       pass starting-col nth col!
 235       [
 236           [ row col f f ] dip image visit
 237
 238           col pass col-increment nth + col!
 239           col width >= [
 240               pass starting-col nth col!
 241               row pass row-increment nth + row!
 242           ] when
 243       ] each
 244
 245       pass 1 + pass!
 246     ] while
 247     image concat B{ } concat-as ;
 248
 249 ERROR: unimplemented-interlace ;
 250
 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 ]
 256     } case ;
 257
 258 ERROR: unknown-component-type n ;
 259
 260 : png-component ( loading-png -- obj )
 261     bit-depth>> {
 262         { 1 [ ubyte-components ] }
 263         { 2 [ ubyte-components ] }
 264         { 4 [ ubyte-components ] }
 265         { 8 [ ubyte-components ] }
 266         { 16 [ ushort-components ] }
 267         [ unknown-component-type ]
 268     } case ;
 269
 270 : scale-factor ( n -- n' )
 271     {
 272         { 1 [ 255 ] }
 273         { 2 [ 85 ] }
 274         { 4 [ 17 ] }
 275     } case ;
 276
 277 : scale-greyscale ( byte-array loading-png -- byte-array' )
 278     bit-depth>> {
 279         { 8 [ ] }
 280         { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
 281         [ scale-factor '[ _ * ] B{ } map-as ]
 282     } case ;
 283
 284 : decode-greyscale ( loading-png -- byte-array )
 285     [ uncompress-bytes ] keep scale-greyscale ;
 286
 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
 290     ] when ;
 291
 292 ERROR: invalid-PLTE array ;
 293
 294 : verify-PLTE ( seq -- seq )
 295     dup length 3 divisor? [ invalid-PLTE ] unless ;
 296
 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 ;
 301
 302 ERROR: invalid-color-type/bit-depth loading-png ;
 303
 304 : validate-bit-depth ( loading-png seq -- loading-png )
 305     [ dup bit-depth>> ] dip member?
 306     [ invalid-color-type/bit-depth ] unless ;
 307
 308 : validate-greyscale ( loading-png -- loading-png )
 309     { 1 2 4 8 16 } validate-bit-depth ;
 310
 311 : validate-truecolor ( loading-png -- loading-png )
 312     { 8 16 } validate-bit-depth ;
 313
 314 : validate-indexed-color ( loading-png -- loading-png )
 315     { 1 2 4 8 } validate-bit-depth ;
 316
 317 : validate-greyscale-alpha ( loading-png -- loading-png )
 318     { 8 16 } validate-bit-depth ;
 319
 320 : validate-truecolor-alpha ( loading-png -- loading-png )
 321     { 8 16 } validate-bit-depth ;
 322
 323 : loading-png>bitmap ( loading-png -- bytes component-order )
 324     dup color-type>> {
 325         { greyscale [
 326             validate-greyscale decode-greyscale L
 327         ] }
 328         { truecolor [
 329             validate-truecolor uncompress-bytes RGB
 330         ] }
 331         { indexed-color [
 332             validate-indexed-color decode-indexed-color RGB
 333         ] }
 334         { greyscale-alpha [
 335             validate-greyscale-alpha decode-greyscale-alpha LA
 336         ] }
 337         { truecolor-alpha [
 338             validate-truecolor-alpha uncompress-bytes RGBA
 339         ] }
 340         [ unknown-color-type ]
 341     } case ;
 342
 343 : loading-png>image ( loading-png -- image )
 344     [ image new ] dip {
 345         [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
 346         [ [ width>> ] [ height>> ] bi 2array >>dim ]
 347         [ png-component >>component-type ]
 348     } cleave ;
 349
 350 : load-png ( stream -- loading-png )
 351     [
 352         [
 353             <loading-png>
 354             read-png-header
 355             read-png-chunks
 356             parse-ihdr-chunk
 357         ] throw-on-eof
 358     ] with-input-stream ;
 359
 360 M: png-image stream>image
 361     drop load-png loading-png>image ;