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 ;
   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 CONSTANT: filter-none 0
  18 CONSTANT: filter-sub 1
  19 CONSTANT: filter-up 2
  20 CONSTANT: filter-average 3
  21 CONSTANT: filter-paeth 4
  22
  23 CONSTANT: greyscale 0
  24 CONSTANT: truecolor 2
  25 CONSTANT: indexed-color 3
  26 CONSTANT: greyscale-alpha 4
  27 CONSTANT: truecolor-alpha 6
  28
  29 : <loading-png> ( -- image )
  30     loading-png new
  31     V{ } clone >>chunks ;
  32
  33 TUPLE: png-chunk length type data ;
  34
  35 : <png-chunk> ( -- png-chunk )
  36     png-chunk new ; inline
  37
  38 CONSTANT: png-header
  39     B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
  40
  41 ERROR: bad-png-header header ;
  42
  43 : read-png-header ( -- )
  44     8 read dup png-header sequence= [
  45         bad-png-header
  46     ] unless drop ;
  47
  48 ERROR: bad-checksum ;
  49
  50 : read-png-chunks ( loading-png -- loading-png )
  51     <png-chunk>
  52     4 read be> [ >>length ] [ 4 + ] bi
  53     read dup crc32 checksum-bytes
  54     4 read = [ bad-checksum ] unless
  55     4 cut-slice
  56     [ ascii decode >>type ] [ B{ } like >>data ] bi*
  57     [ over chunks>> push ]
  58     [ type>> ] bi "IEND" =
  59     [ read-png-chunks ] unless ;
  60
  61 : find-chunk ( loading-png string -- chunk )
  62     [ chunks>> ] dip '[ type>> _ = ] find nip ;
  63
  64 : parse-ihdr-chunk ( loading-png -- loading-png )
  65     dup "IHDR" find-chunk data>> {
  66         [ [ 0 4 ] dip subseq be> >>width ]
  67         [ [ 4 8 ] dip subseq be> >>height ]
  68         [ [ 8 ] dip nth >>bit-depth ]
  69         [ [ 9 ] dip nth >>color-type ]
  70         [ [ 10 ] dip nth >>compression-method ]
  71         [ [ 11 ] dip nth >>filter-method ]
  72         [ [ 12 ] dip nth >>interlace-method ]
  73     } cleave ;
  74
  75 : find-compressed-bytes ( loading-png -- bytes )
  76     chunks>> [ type>> "IDAT" = ] filter
  77     [ data>> ] map concat ;
  78
  79 ERROR: unknown-color-type n ;
  80 ERROR: unimplemented-color-type image ;
  81
  82 : inflate-data ( loading-png -- bytes )
  83     find-compressed-bytes zlib-inflate ;
  84
  85 : scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
  86
  87 : png-bytes-per-pixel ( loading-png -- n )
  88     dup color-type>> {
  89         { 2 [ scale-bit-depth 3 * ] }
  90         { 6 [ scale-bit-depth 4 * ] }
  91         [ unknown-color-type ]
  92     } case ; inline
  93
  94 : png-group-width ( loading-png -- n )
  95     ! 1 + is for the filter type, 1 byte preceding each line
  96     [ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
  97
  98 :: paeth ( a b c -- p )
  99     a b + c - { a b c } [ [ - abs ] keep 2array ] with map
 100     sort-keys first second ;
 101
 102 :: png-unfilter-line ( prev curr filter -- curr' )
 103     prev :> c
 104     prev 3 tail-slice :> b
 105     curr :> a
 106     curr 3 tail-slice :> x
 107     x length [0,b)
 108     filter {
 109         { filter-none [ drop ] }
 110         { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
 111         { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
 112         { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
 113         { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
 114     } case
 115     curr 3 tail ;
 116
 117 : reverse-png-filter ( lines -- byte-array )
 118     dup first length 0 <array> prefix
 119     [ { 0 0 } prepend ] map
 120     2 clump [
 121         first2 dup [ third ] [ [ 0 2 ] dip set-nth ] bi
 122         png-unfilter-line
 123     ] map B{ } concat-as ;
 124
 125 : png-image-bytes ( loading-png -- byte-array )
 126     [ inflate-data ] [ png-group-width ] bi group reverse-png-filter ;
 127
 128 : decode-greyscale ( loading-png -- image )
 129     unimplemented-color-type ;
 130
 131 : decode-truecolor ( loading-png -- image )
 132     [ <image> ] dip {
 133         [ png-image-bytes >>bitmap ]
 134         [ [ width>> ] [ height>> ] bi 2array >>dim ]
 135         [ drop RGB >>component-order ubyte-components >>component-type ]
 136     } cleave ;
 137
 138 : decode-indexed-color ( loading-png -- image )
 139     unimplemented-color-type ;
 140
 141 : decode-greyscale-alpha ( loading-png -- image )
 142     unimplemented-color-type ;
 143
 144 : decode-truecolor-alpha ( loading-png -- image )
 145     [ <image> ] dip {
 146         [ png-image-bytes >>bitmap ]
 147         [ [ width>> ] [ height>> ] bi 2array >>dim ]
 148         [ drop RGBA >>component-order ubyte-components >>component-type ]
 149     } cleave ;
 150
 151 ERROR: invalid-color-type/bit-depth loading-png ;
 152
 153 : validate-bit-depth ( loading-png seq -- loading-png )
 154     [ dup bit-depth>> ] dip member?
 155     [ invalid-color-type/bit-depth ] unless ;
 156
 157 : validate-greyscale ( loading-png -- loading-png )
 158     { 1 2 4 8 16 } validate-bit-depth ;
 159
 160 : validate-truecolor ( loading-png -- loading-png )
 161     { 8 16 } validate-bit-depth ;
 162
 163 : validate-indexed-color ( loading-png -- loading-png )
 164     { 1 2 4 8 } validate-bit-depth ;
 165
 166 : validate-greyscale-alpha ( loading-png -- loading-png )
 167     { 8 16 } validate-bit-depth ;
 168
 169 : validate-truecolor-alpha ( loading-png -- loading-png )
 170     { 8 16 } validate-bit-depth ;
 171
 172 : png>image ( loading-png -- image )
 173     dup color-type>> {
 174         { greyscale [ validate-greyscale decode-greyscale ] }
 175         { truecolor [ validate-truecolor decode-truecolor ] }
 176         { indexed-color [ validate-indexed-color decode-indexed-color ] }
 177         { greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
 178         { truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
 179         [ unknown-color-type ]
 180     } case ;
 181
 182 : load-png ( stream -- loading-png )
 183     [
 184         <loading-png>
 185         read-png-header
 186         read-png-chunks
 187         parse-ihdr-chunk
 188     ] with-input-stream ;
 189
 190 M: png-image stream>image
 191     drop load-png png>image ;