extra/images/tiff/tiff.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators io io.encodings.binary io.files
   4 kernel pack endian constructors sequences arrays
   5 sorting.slots math.order math.parser prettyprint classes
   6 io.binary assocs math math.bitwise byte-arrays grouping
   7 images.backend ;
   8 IN: images.tiff
   9
  10 TUPLE: tiff-image < image ;
  11
  12 TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
  13 CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
  14
  15 TUPLE: ifd count ifd-entries next
  16 processed-tags strips bitmap ;
  17 CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
  18
  19 TUPLE: ifd-entry tag type count offset/value ;
  20 CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
  21
  22 SINGLETONS: photometric-interpretation
  23 photometric-interpretation-white-is-zero
  24 photometric-interpretation-black-is-zero
  25 photometric-interpretation-rgb
  26 photometric-interpretation-palette-color ;
  27 ERROR: bad-photometric-interpretation n ;
  28 : lookup-photometric-interpretation ( n -- singleton )
  29     {
  30         { 0 [ photometric-interpretation-white-is-zero ] }
  31         { 1 [ photometric-interpretation-black-is-zero ] }
  32         { 2 [ photometric-interpretation-rgb ] }
  33         { 3 [ photometric-interpretation-palette-color ] }
  34         [ bad-photometric-interpretation ]
  35     } case ;
  36
  37 SINGLETONS: compression
  38 compression-none
  39 compression-CCITT-2
  40 compression-lzw
  41 compression-pack-bits ;
  42 ERROR: bad-compression n ;
  43 : lookup-compression ( n -- compression )
  44     {
  45         { 1 [ compression-none ] }
  46         { 2 [ compression-CCITT-2 ] }
  47         { 5 [ compression-lzw ] }
  48         { 32773 [ compression-pack-bits ] }
  49         [ bad-compression ]
  50     } case ;
  51
  52 SINGLETONS: resolution-unit
  53 resolution-unit-none
  54 resolution-unit-inch
  55 resolution-unit-centimeter ;
  56 ERROR: bad-resolution-unit n ;
  57 : lookup-resolution-unit ( n -- object )
  58     {
  59         { 1 [ resolution-unit-none ] }
  60         { 2 [ resolution-unit-inch ] }
  61         { 3 [ resolution-unit-centimeter ] }
  62         [ bad-resolution-unit ]
  63     } case ;
  64
  65 SINGLETONS: predictor
  66 predictor-none
  67 predictor-horizontal-differencing ;
  68 ERROR: bad-predictor n ;
  69 : lookup-predictor ( n -- object )
  70     {
  71         { 1 [ predictor-none ] }
  72         { 2 [ predictor-horizontal-differencing ] }
  73         [ bad-predictor ]
  74     } case ;
  75
  76 SINGLETONS: planar-configuration
  77 planar-configuration-chunky
  78 planar-configuration-planar ;
  79 ERROR: bad-planar-configuration n ;
  80 : lookup-planar-configuration ( n -- object )
  81     {
  82         { 1 [ planar-configuration-chunky ] }
  83         { 2 [ planar-configuration-planar ] }
  84         [ bad-planar-configuration ]
  85     } case ;
  86
  87 SINGLETONS: sample-format
  88 sample-format-unsigned-integer
  89 sample-format-signed-integer
  90 sample-format-ieee-float
  91 sample-format-undefined-data ;
  92 ERROR: bad-sample-format n ;
  93 : lookup-sample-format ( sequence -- object )
  94     [
  95         {
  96             { 1 [ sample-format-unsigned-integer ] }
  97             { 2 [ sample-format-signed-integer ] }
  98             { 3 [ sample-format-ieee-float ] }
  99             { 4 [ sample-format-undefined-data ] }
 100             [ bad-sample-format ]
 101         } case
 102     ] map ;
 103
 104 SINGLETONS: extra-samples
 105 extra-samples-unspecified-alpha-data
 106 extra-samples-associated-alpha-data
 107 extra-samples-unassociated-alpha-data ;
 108 ERROR: bad-extra-samples n ;
 109 : lookup-extra-samples ( sequence -- object )
 110     {
 111         { 0 [ extra-samples-unspecified-alpha-data ] }
 112         { 1 [ extra-samples-associated-alpha-data ] }
 113         { 2 [ extra-samples-unassociated-alpha-data ] }
 114         [ bad-extra-samples ]
 115     } case ;
 116
 117 SINGLETONS: image-length image-width x-resolution y-resolution
 118 rows-per-strip strip-offsets strip-byte-counts bits-per-sample
 119 samples-per-pixel new-subfile-type orientation
 120 unhandled-ifd-entry ;
 121
 122 ERROR: bad-tiff-magic bytes ;
 123 : tiff-endianness ( byte-array -- ? )
 124     {
 125         { B{ CHAR: M CHAR: M } [ big-endian ] }
 126         { B{ CHAR: I CHAR: I } [ little-endian ] }
 127         [ bad-tiff-magic ]
 128     } case ;
 129
 130 : read-header ( tiff -- tiff )
 131     2 read tiff-endianness [ >>endianness ] keep
 132     [
 133         2 read endian> >>the-answer
 134         4 read endian> >>ifd-offset
 135     ] with-endianness ;
 136
 137 : push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
 138
 139 : read-ifd ( -- ifd )
 140     2 read endian>
 141     2 read endian>
 142     4 read endian>
 143     4 read endian> <ifd-entry> ;
 144
 145 : read-ifds ( tiff -- tiff )
 146     dup ifd-offset>> seek-absolute seek-input
 147     2 read endian>
 148     dup [ read-ifd ] replicate
 149     4 read endian>
 150     [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
 151
 152 ERROR: no-tag class ;
 153
 154 : ?at ( key assoc -- value/key ? )
 155     dupd at* [ nip t ] [ drop f ] if ; inline
 156
 157 : find-tag ( idf class -- tag )
 158     swap processed-tags>> ?at [ no-tag ] unless ;
 159
 160 : read-strips ( ifd -- ifd )
 161     dup
 162     [ strip-byte-counts find-tag ]
 163     [ strip-offsets find-tag ] bi
 164     2dup [ integer? ] both? [
 165         seek-absolute seek-input read 1array
 166     ] [
 167         [ seek-absolute seek-input read ] { } 2map-as
 168     ] if >>strips ;
 169
 170 ERROR: unknown-ifd-type n ;
 171
 172 : bytes>bits ( n/byte-array -- n )
 173     dup byte-array? [ byte-array>bignum ] when ;
 174
 175 : value-length ( ifd-entry -- n )
 176     [ count>> ] [ type>> ] bi {
 177         { 1 [ ] }
 178         { 2 [ ] }
 179         { 3 [ 2 * ] }
 180         { 4 [ 4 * ] }
 181         { 5 [ 8 * ] }
 182         { 6 [ ] }
 183         { 7 [ ] }
 184         { 8 [ 2 * ] }
 185         { 9 [ 4 * ] }
 186         { 10 [ 8 * ] }
 187         { 11 [ 4 * ] }
 188         { 12 [ 8 * ] }
 189         [ unknown-ifd-type ]
 190     } case ;
 191
 192 ERROR: bad-small-ifd-type n ;
 193
 194 : adjust-offset/value ( ifd-entry -- obj )
 195     [ offset/value>> 4 >endian ] [ type>> ] bi
 196     {
 197         { 1 [ 1 head endian> ] }
 198         { 3 [ 2 head endian> ] }
 199         { 4 [ endian> ] }
 200         { 6 [ 1 head endian> 8 >signed ] }
 201         { 8 [ 2 head endian> 16 >signed ] }
 202         { 9 [ endian> 32 >signed ] }
 203         { 11 [ endian> bits>float ] }
 204         [ bad-small-ifd-type ]
 205     } case ;
 206
 207 : offset-bytes>obj ( bytes type -- obj )
 208     {
 209         { 1 [ ] } ! blank
 210         { 2 [ ] } ! read c strings here
 211         { 3 [ 2 <sliced-groups> [ endian> ] map ] }
 212         { 4 [ 4 <sliced-groups> [ endian> ] map ] }
 213         { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
 214         { 6 [ [ 8 >signed ] map ] }
 215         { 7 [ ] } ! blank
 216         { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
 217         { 9 [ 4 <sliced-groups> [ endian> 32 >signed ] map ] }
 218         { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
 219         { 11 [ 4 group [ "f" unpack ] map ] }
 220         { 12 [ 8 group [ "d" unpack ] map ] }
 221         [ unknown-ifd-type ]
 222     } case ;
 223
 224 : ifd-entry-value ( ifd-entry -- n )
 225     dup value-length 4 <= [
 226         adjust-offset/value
 227     ] [
 228         [ offset/value>> seek-absolute seek-input ]
 229         [ value-length read ]
 230         [ type>> ] tri offset-bytes>obj
 231     ] if ;
 232
 233 : process-ifd-entry ( ifd-entry -- value class )
 234     [ ifd-entry-value ] [ tag>> ] bi {
 235         { 254 [ new-subfile-type ] }
 236         { 256 [ image-width ] }
 237         { 257 [ image-length ] }
 238         { 258 [ bits-per-sample ] }
 239         { 259 [ lookup-compression compression ] }
 240         { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
 241         { 273 [ strip-offsets ] }
 242         { 274 [ orientation ] }
 243         { 277 [ samples-per-pixel ] }
 244         { 278 [ rows-per-strip ] }
 245         { 279 [ strip-byte-counts ] }
 246         { 282 [ x-resolution ] }
 247         { 283 [ y-resolution ] }
 248         { 284 [ planar-configuration ] }
 249         { 296 [ lookup-resolution-unit resolution-unit ] }
 250         { 317 [ lookup-predictor predictor ] }
 251         { 338 [ lookup-extra-samples extra-samples ] }
 252         { 339 [ lookup-sample-format sample-format ] }
 253         [ nip unhandled-ifd-entry ]
 254     } case ;
 255
 256 : process-ifd ( ifd -- ifd )
 257     dup ifd-entries>>
 258     [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
 259
 260 : strips>bitmap ( ifd -- ifd )
 261     dup strips>> concat >>bitmap ;
 262
 263 ERROR: unknown-component-order ifd ;
 264
 265 : ifd-component-order ( ifd -- byte-order )
 266     bits-per-sample find-tag sum {
 267         { 32 [ RGBA ] }
 268         { 24 [ RGB ] }
 269         [ unknown-component-order ]
 270     } case ;
 271
 272 M: ifd >image ( ifd -- image )
 273     {
 274         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
 275         [ ifd-component-order ]
 276         [ bitmap>> ]
 277     } cleave tiff-image new-image ;
 278
 279 M: parsed-tiff >image ( image -- image )
 280     ifds>> [ >image ] map first ;
 281
 282 : load-tiff ( path -- parsed-tiff )
 283     binary [
 284         <parsed-tiff>
 285         read-header dup endianness>> [
 286             read-ifds
 287             dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each
 288         ] with-endianness
 289     ] with-file-reader ;
 290
 291 ! tiff files can store several images -- we just take the first for now
 292 M: tiff-image load-image* ( path tiff-image -- image )
 293     drop load-tiff >image ;