basis/images/png/png.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors images io io.binary io.encodings.ascii
   4 io.encodings.binary io.encodings.string io.files io.files.info kernel
   5 sequences io.streams.limited fry combinators arrays math checksums
   6 checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
   7 IN: images.png
   8
   9 SINGLETON: png-image
  10 "png" png-image register-image-class
  11
  12 TUPLE: loading-png
  13     chunks
  14     width height bit-depth color-type compression-method
  15     filter-method interlace-method uncompressed ;
  16
  17 : <loading-png> ( -- image )
  18     loading-png new
  19     V{ } clone >>chunks ;
  20
  21 TUPLE: png-chunk length type data ;
  22
  23 : <png-chunk> ( -- png-chunk )
  24     png-chunk new ; inline
  25
  26 CONSTANT: png-header
  27     B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
  28
  29 ERROR: bad-png-header header ;
  30
  31 : read-png-header ( -- )
  32     8 read dup png-header sequence= [
  33         bad-png-header
  34     ] unless drop ;
  35
  36 ERROR: bad-checksum ;
  37
  38 : read-png-chunks ( loading-png -- loading-png )
  39     <png-chunk>
  40     4 read be> [ >>length ] [ 4 + ] bi
  41     read dup crc32 checksum-bytes
  42     4 read = [ bad-checksum ] unless
  43     4 cut-slice
  44     [ ascii decode >>type ] [ B{ } like >>data ] bi*
  45     [ over chunks>> push ]
  46     [ type>> ] bi "IEND" =
  47     [ read-png-chunks ] unless ;
  48
  49 : find-chunk ( loading-png string -- chunk )
  50     [ chunks>> ] dip '[ type>> _ = ] find nip ;
  51
  52 : parse-ihdr-chunk ( loading-png -- loading-png )
  53     dup "IHDR" find-chunk data>> {
  54         [ [ 0 4 ] dip subseq be> >>width ]
  55         [ [ 4 8 ] dip subseq be> >>height ]
  56         [ [ 8 ] dip nth >>bit-depth ]
  57         [ [ 9 ] dip nth >>color-type ]
  58         [ [ 10 ] dip nth >>compression-method ]
  59         [ [ 11 ] dip nth >>filter-method ]
  60         [ [ 12 ] dip nth >>interlace-method ]
  61     } cleave ;
  62
  63 : find-compressed-bytes ( loading-png -- bytes )
  64     chunks>> [ type>> "IDAT" = ] filter
  65     [ data>> ] map concat ;
  66
  67
  68 : zlib-data ( loading-png -- bytes )
  69     chunks>> [ type>> "IDAT" = ] find nip data>> ;
  70
  71 ERROR: unknown-color-type n ;
  72 ERROR: unimplemented-color-type image ;
  73
  74 : inflate-data ( loading-png -- bytes )
  75     zlib-data zlib-inflate ;
  76
  77 : decode-greyscale ( loading-png -- loading-png )
  78     unimplemented-color-type ;
  79
  80 : png-image-bytes ( loading-png -- byte-array )
  81     [ inflate-data ] [ width>> 3 * 1 + ] bi group
  82     reverse-png-filter ;
  83
  84 : decode-truecolor ( loading-png -- loading-png )
  85     [ <image> ] dip {
  86         [ png-image-bytes >>bitmap ]
  87         [ [ width>> ] [ height>> ] bi 2array >>dim ]
  88         [ drop RGB >>component-order ubyte-components >>component-type ]
  89     } cleave ;
  90
  91 : decode-indexed-color ( loading-png -- loading-png )
  92     unimplemented-color-type ;
  93
  94 : decode-greyscale-alpha ( loading-png -- loading-png )
  95     unimplemented-color-type ;
  96
  97 : decode-truecolor-alpha ( loading-png -- loading-png )
  98     [ <image> ] dip {
  99         [ png-image-bytes >>bitmap ]
 100         [ [ width>> ] [ height>> ] bi 2array >>dim ]
 101         [ drop RGBA >>component-order ubyte-components >>component-type ]
 102     } cleave ;
 103
 104 : decode-png ( loading-png -- loading-png )
 105     dup color-type>> {
 106         { 0 [ decode-greyscale ] }
 107         { 2 [ decode-truecolor ] }
 108         { 3 [ decode-indexed-color ] }
 109         { 4 [ decode-greyscale-alpha ] }
 110         { 6 [ decode-truecolor-alpha ] }
 111         [ unknown-color-type ]
 112     } case ;
 113
 114 M: png-image stream>image
 115     drop [
 116         <loading-png>
 117         read-png-header
 118         read-png-chunks
 119         parse-ihdr-chunk
 120         decode-png
 121     ] with-input-stream ;