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