basis/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 ;
   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 [0,b)
 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 :: reverse-interlace-none ( byte-array loading-png -- array )
 151     byte-array bs:<msb0-bit-reader> :> bs
 152     loading-png width>> :> width
 153     loading-png height>> :> height
 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     ! Only read up to 8 bits at a time
 160     bit-depth 16 = [
 161         8 depth!
 162         count 2 * count!
 163     ] when
 164
 165     height [
 166         8 bs bs:read dup 0 4 between? [ bad-filter ] unless
 167         count [ depth bs bs:read ] replicate swap prefix
 168         8 bs bs:align
 169     ] replicate
 170     #components bit-depth 16 = [ 2 * ] when reverse-png-filter ;
 171
 172 :: reverse-interlace-adam7 ( byte-array loading-png -- byte-array )
 173     byte-array bs:<msb0-bit-reader> :> bs
 174     loading-png height>> :> height
 175     loading-png width>> :> width
 176     loading-png bit-depth>> :> bit-depth
 177     loading-png png-components-per-pixel :> #bytes
 178     width height #bytes * * <byte-array> width <sliced-groups> :> image
 179
 180     0 :> row!
 181     0 :> col!
 182
 183     0 :> pass!
 184     [ pass 7 < ] [
 185         pass starting-row nth row!
 186         [
 187             row height <
 188         ] [
 189             pass starting-col nth col!
 190             [
 191                 col width <
 192             ] [
 193                 row
 194                 col
 195
 196                 pass block-height nth
 197                 height row - min
 198
 199                 pass block-width nth
 200                 width col - min
 201
 202                 bit-depth bs bs:read
 203                 image
 204                 visit
 205
 206                 col pass col-increment nth + col!
 207             ] while
 208             row pass row-increment nth + row!
 209         ] while
 210         pass 1 + pass!
 211     ] while
 212     bit-depth 16 = [
 213         image { } concat-as
 214         [ 2 >be ] map B{ } concat-as
 215     ] [
 216         image B{ } concat-as
 217     ] if ;
 218
 219 ERROR: unimplemented-interlace ;
 220
 221 : uncompress-bytes ( loading-png -- bitstream )
 222     [ inflate-data ] [ ] [ interlace-method>> ] tri {
 223         { interlace-none [ reverse-interlace-none ] }
 224         { interlace-adam7 [ "adam7 is broken" throw reverse-interlace-adam7 ] }
 225         [ unimplemented-interlace ]
 226     } case ;
 227
 228 ERROR: unknown-component-type n ;
 229
 230 : png-component ( loading-png -- obj )
 231     bit-depth>> {
 232         { 1 [ ubyte-components ] }
 233         { 2 [ ubyte-components ] }
 234         { 4 [ ubyte-components ] }
 235         { 8 [ ubyte-components ] }
 236         { 16 [ ushort-components ] }
 237         [ unknown-component-type ]
 238     } case ;
 239
 240 : scale-factor ( n -- n' )
 241     {
 242         { 1 [ 255 ] }
 243         { 2 [ 127 ] }
 244         { 4 [ 17 ] }
 245     } case ;
 246
 247 : scale-greyscale ( byte-array loading-png -- byte-array' )
 248     bit-depth>> {
 249         { 8 [ ] }
 250         { 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
 251         [ scale-factor '[ _ * ] B{ } map-as ]
 252     } case ;
 253
 254 : decode-greyscale ( loading-png -- byte-array )
 255     [ uncompress-bytes ] keep scale-greyscale ;
 256
 257 : decode-greyscale-alpha ( loading-image -- byte-array )
 258     [ uncompress-bytes ] [ bit-depth>> ] bi 16 = [
 259         4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
 260     ] when ;
 261
 262 ERROR: invalid-PLTE array ;
 263
 264 : verify-PLTE ( seq -- seq )
 265     dup length 3 divisor? [ invalid-PLTE ] unless ;
 266
 267 : decode-indexed-color ( loading-image -- byte-array )
 268     [ uncompress-bytes ] keep
 269     "PLTE" find-chunk data>> verify-PLTE
 270     3 group '[ _ nth ] { } map-as B{ } concat-as ;
 271
 272 ERROR: invalid-color-type/bit-depth loading-png ;
 273
 274 : validate-bit-depth ( loading-png seq -- loading-png )
 275     [ dup bit-depth>> ] dip member?
 276     [ invalid-color-type/bit-depth ] unless ;
 277
 278 : validate-greyscale ( loading-png -- loading-png )
 279     { 1 2 4 8 16 } validate-bit-depth ;
 280
 281 : validate-truecolor ( loading-png -- loading-png )
 282     { 8 16 } validate-bit-depth ;
 283
 284 : validate-indexed-color ( loading-png -- loading-png )
 285     { 1 2 4 8 } validate-bit-depth ;
 286
 287 : validate-greyscale-alpha ( loading-png -- loading-png )
 288     { 8 16 } validate-bit-depth ;
 289
 290 : validate-truecolor-alpha ( loading-png -- loading-png )
 291     { 8 16 } validate-bit-depth ;
 292
 293 : pad-bitmap ( image -- image )
 294     dup dim>> first 4 divisor? [
 295         dup [ bytes-per-pixel ]
 296         [ dim>> first * ]
 297         [ dim>> first 4 mod ] tri
 298         '[ _ group [ _ 0 <array> append ] map B{ } concat-as ] change-bitmap
 299     ] unless ;
 300
 301 : loading-png>bitmap ( loading-png -- bytes component-order )
 302     dup color-type>> {
 303         { greyscale [
 304             validate-greyscale decode-greyscale L
 305         ] }
 306         { truecolor [
 307             validate-truecolor uncompress-bytes RGB
 308         ] }
 309         { indexed-color [
 310             validate-indexed-color decode-indexed-color RGB
 311         ] }
 312         { greyscale-alpha [
 313             validate-greyscale-alpha decode-greyscale-alpha LA
 314         ] }
 315         { truecolor-alpha [
 316             validate-truecolor-alpha uncompress-bytes RGBA
 317         ] }
 318         [ unknown-color-type ]
 319     } case ;
 320
 321 : loading-png>image ( loading-png -- image )
 322     [ image new ] dip {
 323         [ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
 324         [ [ width>> ] [ height>> ] bi 2array >>dim ]
 325         [ png-component >>component-type ]
 326     } cleave pad-bitmap ;
 327
 328 : load-png ( stream -- loading-png )
 329     [
 330         <loading-png>
 331         read-png-header
 332         read-png-chunks
 333         parse-ihdr-chunk
 334     ] with-input-stream ;
 335
 336 M: png-image stream>image
 337     drop load-png loading-png>image ;