basis/images/tiff/tiff.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-arrays classes combinators
   4 compression.lzw endian fry grouping images io
   5 io.binary io.encodings.ascii io.encodings.binary
   6 io.encodings.string io.encodings.utf8 io.files kernel math
   7 math.bitwise math.order math.parser pack prettyprint sequences
   8 strings math.vectors specialized-arrays.float locals
   9 images.loader ;
  10 IN: images.tiff
  11
  12 SINGLETON: tiff-image
  13
  14 TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
  15
  16 : <loading-tiff> ( -- tiff )
  17     loading-tiff new V{ } clone >>ifds ;
  18
  19 TUPLE: ifd count ifd-entries next
  20 processed-tags strips bitmap ;
  21
  22 : <ifd> ( count ifd-entries next -- ifd )
  23     ifd new
  24         swap >>next
  25         swap >>ifd-entries
  26         swap >>count ;
  27
  28 TUPLE: ifd-entry tag type count offset/value ;
  29
  30 : <ifd-entry> ( tag type count offset/value -- ifd-entry )
  31     ifd-entry new
  32         swap >>offset/value
  33         swap >>count
  34         swap >>type
  35         swap >>tag ;
  36
  37 SINGLETONS: photometric-interpretation
  38 photometric-interpretation-white-is-zero
  39 photometric-interpretation-black-is-zero
  40 photometric-interpretation-rgb
  41 photometric-interpretation-palette-color
  42 photometric-interpretation-transparency-mask
  43 photometric-interpretation-separated
  44 photometric-interpretation-ycbcr
  45 photometric-interpretation-cielab
  46 photometric-interpretation-icclab
  47 photometric-interpretation-itulab
  48 photometric-interpretation-logl
  49 photometric-interpretation-logluv ;
  50
  51 ERROR: bad-photometric-interpretation n ;
  52 : lookup-photometric-interpretation ( n -- singleton )
  53     {
  54         { 0 [ photometric-interpretation-white-is-zero ] }
  55         { 1 [ photometric-interpretation-black-is-zero ] }
  56         { 2 [ photometric-interpretation-rgb ] }
  57         { 3 [ photometric-interpretation-palette-color ] }
  58         { 4 [ photometric-interpretation-transparency-mask ] }
  59         { 5 [ photometric-interpretation-separated ] }
  60         { 6 [ photometric-interpretation-ycbcr ] }
  61         { 8 [ photometric-interpretation-cielab ] }
  62         { 9 [ photometric-interpretation-icclab ] }
  63         { 10 [ photometric-interpretation-itulab ] }
  64         { 32844 [ photometric-interpretation-logl ] }
  65         { 32845 [ photometric-interpretation-logluv ] }
  66         [ bad-photometric-interpretation ]
  67     } case ;
  68
  69 SINGLETONS: compression
  70 compression-none
  71 compression-CCITT-2
  72 compression-CCITT-3
  73 compression-CCITT-4
  74 compression-lzw
  75 compression-jpeg-old
  76 compression-jpeg-new
  77 compression-adobe-deflate
  78 compression-9
  79 compression-10
  80 compression-deflate
  81 compression-next
  82 compression-ccittrlew
  83 compression-pack-bits
  84 compression-thunderscan
  85 compression-it8ctpad
  86 compression-it8lw
  87 compression-it8mp
  88 compression-it8bl
  89 compression-pixarfilm
  90 compression-pixarlog
  91 compression-dcs
  92 compression-jbig
  93 compression-sgilog
  94 compression-sgilog24
  95 compression-jp2000 ;
  96 ERROR: bad-compression n ;
  97 : lookup-compression ( n -- compression )
  98     {
  99         { 1 [ compression-none ] }
 100         { 2 [ compression-CCITT-2 ] }
 101         { 3 [ compression-CCITT-3 ] }
 102         { 4 [ compression-CCITT-4 ] }
 103         { 5 [ compression-lzw ] }
 104         { 6 [ compression-jpeg-old ] }
 105         { 7 [ compression-jpeg-new ] }
 106         { 8 [ compression-adobe-deflate ] }
 107         { 9 [ compression-9 ] }
 108         { 10 [ compression-10 ] }
 109         { 32766 [ compression-next ] }
 110         { 32771 [ compression-ccittrlew ] }
 111         { 32773 [ compression-pack-bits ] }
 112         { 32809 [ compression-thunderscan ] }
 113         { 32895 [ compression-it8ctpad ] }
 114         { 32896 [ compression-it8lw ] }
 115         { 32897 [ compression-it8mp ] }
 116         { 32898 [ compression-it8bl ] }
 117         { 32908 [ compression-pixarfilm ] }
 118         { 32909 [ compression-pixarlog ] }
 119         { 32946 [ compression-deflate ] }
 120         { 32947 [ compression-dcs ] }
 121         { 34661 [ compression-jbig ] }
 122         { 34676 [ compression-sgilog ] }
 123         { 34677 [ compression-sgilog24 ] }
 124         { 34712 [ compression-jp2000 ] }
 125         [ bad-compression ]
 126     } case ;
 127
 128 SINGLETONS: resolution-unit
 129 resolution-unit-none
 130 resolution-unit-inch
 131 resolution-unit-centimeter ;
 132 ERROR: bad-resolution-unit n ;
 133 : lookup-resolution-unit ( n -- object )
 134     {
 135         { 1 [ resolution-unit-none ] }
 136         { 2 [ resolution-unit-inch ] }
 137         { 3 [ resolution-unit-centimeter ] }
 138         [ bad-resolution-unit ]
 139     } case ;
 140
 141 SINGLETONS: predictor
 142 predictor-none
 143 predictor-horizontal-differencing ;
 144 ERROR: bad-predictor n ;
 145 : lookup-predictor ( n -- object )
 146     {
 147         { 1 [ predictor-none ] }
 148         { 2 [ predictor-horizontal-differencing ] }
 149         [ bad-predictor ]
 150     } case ;
 151
 152 SINGLETONS: planar-configuration
 153 planar-configuration-chunky
 154 planar-configuration-planar ;
 155 ERROR: bad-planar-configuration n ;
 156 : lookup-planar-configuration ( n -- object )
 157     {
 158         { 1 [ planar-configuration-chunky ] }
 159         { 2 [ planar-configuration-planar ] }
 160         [ bad-planar-configuration ]
 161     } case ;
 162
 163 SINGLETONS: sample-format
 164 sample-format-none
 165 sample-format-unsigned-integer
 166 sample-format-signed-integer
 167 sample-format-ieee-float
 168 sample-format-undefined-data ;
 169 ERROR: bad-sample-format n ;
 170 : lookup-sample-format ( sequence -- object )
 171     [
 172         {
 173             { 0 [ sample-format-none ] }
 174             { 1 [ sample-format-unsigned-integer ] }
 175             { 2 [ sample-format-signed-integer ] }
 176             { 3 [ sample-format-ieee-float ] }
 177             { 4 [ sample-format-undefined-data ] }
 178             [ bad-sample-format ]
 179         } case
 180     ] map ;
 181
 182 SINGLETONS: extra-samples
 183 extra-samples-unspecified-alpha-data
 184 extra-samples-associated-alpha-data
 185 extra-samples-unassociated-alpha-data ;
 186 ERROR: bad-extra-samples n ;
 187 : lookup-extra-samples ( sequence -- object )
 188     {
 189         { 0 [ extra-samples-unspecified-alpha-data ] }
 190         { 1 [ extra-samples-associated-alpha-data ] }
 191         { 2 [ extra-samples-unassociated-alpha-data ] }
 192         [ bad-extra-samples ]
 193     } case ;
 194
 195 SINGLETONS: image-length image-width x-resolution y-resolution
 196 rows-per-strip strip-offsets strip-byte-counts bits-per-sample
 197 samples-per-pixel new-subfile-type subfile-type orientation
 198 software date-time photoshop exif-ifd sub-ifd inter-color-profile
 199 xmp iptc fill-order document-name page-number page-name
 200 x-position y-position host-computer copyright artist
 201 min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
 202 gray-response-unit gray-response-curve color-map threshholding
 203 image-description free-offsets free-byte-counts tile-width tile-length
 204 matteing data-type image-depth tile-depth
 205 ycbcr-subsampling gdal-metadata
 206 tile-offsets tile-byte-counts jpeg-qtables jpeg-dctables jpeg-actables
 207 ycbcr-positioning ycbcr-coefficients reference-black-white halftone-hints
 208 jpeg-interchange-format
 209 jpeg-interchange-format-length
 210 jpeg-restart-interval jpeg-tables
 211 t4-options clean-fax-data bad-fax-lines consecutive-bad-fax-lines
 212 sto-nits print-image-matching-info
 213 unhandled-ifd-entry ;
 214
 215 SINGLETONS: jpeg-proc
 216 jpeg-proc-baseline
 217 jpeg-proc-lossless ;
 218
 219 ERROR: bad-jpeg-proc n ;
 220
 221 : lookup-jpeg-proc ( sequence -- object )
 222     {
 223         { 1 [ jpeg-proc-baseline ] }
 224         { 14 [ jpeg-proc-lossless ] }
 225         [ bad-jpeg-proc ]
 226     } case ;
 227
 228 ERROR: bad-tiff-magic bytes ;
 229 : tiff-endianness ( byte-array -- ? )
 230     {
 231         { B{ CHAR: M CHAR: M } [ big-endian ] }
 232         { B{ CHAR: I CHAR: I } [ little-endian ] }
 233         [ bad-tiff-magic ]
 234     } case ;
 235
 236 : read-header ( tiff -- tiff )
 237     2 read tiff-endianness [ >>endianness ] keep
 238     [
 239         2 read endian> >>the-answer
 240         4 read endian> >>ifd-offset
 241     ] with-endianness ;
 242
 243 : push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
 244
 245 : read-ifd ( -- ifd )
 246     2 read endian>
 247     2 read endian>
 248     4 read endian>
 249     4 read endian> <ifd-entry> ;
 250
 251 : read-ifds ( tiff offset -- tiff )
 252     seek-absolute seek-input
 253     2 read endian>
 254     dup [ read-ifd ] replicate
 255     4 read endian>
 256     [ <ifd> push-ifd ] [ dup 0 = [ drop ] [ read-ifds ] if ] bi ;
 257
 258 ERROR: no-tag class ;
 259
 260 : find-tag* ( ifd class -- tag/class ? )
 261     swap processed-tags>> ?at ;
 262
 263 : find-tag ( ifd class -- tag )
 264     find-tag* [ no-tag ] unless ;
 265
 266 : tag? ( ifd class -- tag )
 267     swap processed-tags>> key? ;
 268
 269 : read-strips ( ifd -- ifd )
 270     dup
 271     [ strip-byte-counts find-tag ]
 272     [ strip-offsets find-tag ] bi
 273     2dup [ integer? ] both? [
 274         seek-absolute seek-input read 1array
 275     ] [
 276         [ seek-absolute seek-input read ] { } 2map-as
 277     ] if >>strips ;
 278
 279 ERROR: unknown-ifd-type n ;
 280
 281 : bytes>bits ( n/byte-array -- n )
 282     dup byte-array? [ byte-array>bignum ] when ;
 283
 284 : value-length ( ifd-entry -- n )
 285     [ count>> ] [ type>> ] bi {
 286         { 1 [ ] }
 287         { 2 [ ] }
 288         { 3 [ 2 * ] }
 289         { 4 [ 4 * ] }
 290         { 5 [ 8 * ] }
 291         { 6 [ ] }
 292         { 7 [ ] }
 293         { 8 [ 2 * ] }
 294         { 9 [ 4 * ] }
 295         { 10 [ 8 * ] }
 296         { 11 [ 4 * ] }
 297         { 12 [ 8 * ] }
 298         { 13 [ 4 * ] }
 299         [ unknown-ifd-type ]
 300     } case ;
 301
 302 ERROR: bad-small-ifd-type n ;
 303
 304 : adjust-offset/value ( ifd-entry -- obj )
 305     [ offset/value>> 4 >endian ] [ type>> ] bi
 306     {
 307         { 1 [ 1 head endian> ] }
 308         { 3 [ 2 head endian> ] }
 309         { 4 [ endian> ] }
 310         { 6 [ 1 head endian> 8 >signed ] }
 311         { 8 [ 2 head endian> 16 >signed ] }
 312         { 9 [ endian> 32 >signed ] }
 313         { 11 [ endian> bits>float ] }
 314         { 13 [ endian> 32 >signed ] }
 315         [ bad-small-ifd-type ]
 316     } case ;
 317
 318 : offset-bytes>obj ( bytes type -- obj )
 319     {
 320         { 1 [ ] } ! blank
 321         { 2 [ ] } ! read c strings here
 322         { 3 [ 2 <sliced-groups> [ endian> ] map ] }
 323         { 4 [ 4 <sliced-groups> [ endian> ] map ] }
 324         { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
 325         { 6 [ [ 8 >signed ] map ] }
 326         { 7 [ ] } ! blank
 327         { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
 328         { 9 [ 4 <sliced-groups> [ endian> 32 >signed ] map ] }
 329         { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
 330         { 11 [ 4 group [ "f" unpack ] map ] }
 331         { 12 [ 8 group [ "d" unpack ] map ] }
 332         [ unknown-ifd-type ]
 333     } case ;
 334
 335 : ifd-entry-value ( ifd-entry -- n )
 336     dup value-length 4 <= [
 337         adjust-offset/value
 338     ] [
 339         [ offset/value>> seek-absolute seek-input ]
 340         [ value-length read ]
 341         [ type>> ] tri offset-bytes>obj
 342     ] if ;
 343
 344 : process-ifd-entry ( ifd-entry -- value class )
 345     [ ifd-entry-value ] [ tag>> ] bi {
 346         { 254 [ new-subfile-type ] }
 347         { 255 [ subfile-type ] }
 348         { 256 [ image-width ] }
 349         { 257 [ image-length ] }
 350         { 258 [ bits-per-sample ] }
 351         { 259 [ lookup-compression compression ] }
 352         { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
 353         { 263 [ threshholding ] }
 354         { 264 [ cell-width ] }
 355         { 265 [ cell-length ] }
 356         { 266 [ fill-order ] }
 357         { 269 [ ascii decode document-name ] }
 358         { 270 [ ascii decode image-description ] }
 359         { 271 [ ascii decode tiff-make ] }
 360         { 272 [ ascii decode tiff-model ] }
 361         { 273 [ strip-offsets ] }
 362         { 274 [ orientation ] }
 363         { 277 [ samples-per-pixel ] }
 364         { 278 [ rows-per-strip ] }
 365         { 279 [ strip-byte-counts ] }
 366         { 280 [ min-sample-value ] }
 367         { 281 [ max-sample-value ] }
 368         { 282 [ first x-resolution ] }
 369         { 283 [ first y-resolution ] }
 370         { 284 [ lookup-planar-configuration planar-configuration ] }
 371         { 285 [ page-name ] }
 372         { 286 [ x-position ] }
 373         { 287 [ y-position ] }
 374         { 288 [ free-offsets ] }
 375         { 289 [ free-byte-counts ] }
 376         { 290 [ gray-response-unit ] }
 377         { 291 [ gray-response-curve ] }
 378         { 292 [ t4-options ] }
 379         { 296 [ lookup-resolution-unit resolution-unit ] }
 380         { 297 [ page-number ] }
 381         { 305 [ ascii decode software ] }
 382         { 306 [ ascii decode date-time ] }
 383         { 315 [ ascii decode artist ] }
 384         { 316 [ ascii decode host-computer ] }
 385         { 317 [ lookup-predictor predictor ] }
 386         { 320 [ color-map ] }
 387         { 321 [ halftone-hints ] }
 388         { 322 [ tile-width ] }
 389         { 323 [ tile-length ] }
 390         { 324 [ tile-offsets ] }
 391         { 325 [ tile-byte-counts ] }
 392         { 326 [ bad-fax-lines ] }
 393         { 327 [ clean-fax-data ] }
 394         { 328 [ consecutive-bad-fax-lines ] }
 395         { 330 [ sub-ifd ] }
 396         { 338 [ lookup-extra-samples extra-samples ] }
 397         { 339 [ lookup-sample-format sample-format ] }
 398         { 347 [ jpeg-tables ] }
 399         { 512 [ lookup-jpeg-proc jpeg-proc ] }
 400         { 513 [ jpeg-interchange-format ] }
 401         { 514 [ jpeg-interchange-format-length ] }
 402         { 515 [ jpeg-restart-interval ] }
 403         { 519 [ jpeg-qtables ] }
 404         { 520 [ jpeg-dctables ] }
 405         { 521 [ jpeg-actables ] }
 406         { 529 [ ycbcr-coefficients ] }
 407         { 530 [ ycbcr-subsampling ] }
 408         { 531 [ ycbcr-positioning ] }
 409         { 532 [ reference-black-white ] }
 410         { 700 [ utf8 decode xmp ] }
 411         { 32995 [ matteing ] }
 412         { 32996 [ data-type ] }
 413         { 32997 [ image-depth ] }
 414         { 32998 [ tile-depth ] }
 415         { 33432 [ copyright ] }
 416         { 33723 [ iptc ] }
 417         { 34377 [ photoshop ] }
 418         { 34665 [ exif-ifd ] }
 419         { 34675 [ inter-color-profile ] }
 420         { 37439 [ sto-nits ] }
 421         { 42112 [ gdal-metadata ] }
 422         { 50341 [ print-image-matching-info ] }
 423         [ nip unhandled-ifd-entry swap ]
 424     } case ;
 425
 426 : process-ifds ( loading-tiff -- loading-tiff )
 427     [
 428         [
 429             dup ifd-entries>>
 430             [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags
 431         ] map
 432     ] change-ifds ;
 433
 434 ERROR: unhandled-compression compression ;
 435
 436 : (uncompress-strips) ( strips compression -- uncompressed-strips )
 437     {
 438         { compression-none [ ] }
 439         { compression-lzw [ [ lzw-uncompress ] map ] }
 440         [ unhandled-compression ]
 441     } case ;
 442
 443 : uncompress-strips ( ifd -- ifd )
 444     dup '[
 445         _ compression find-tag (uncompress-strips)
 446     ] change-strips ;
 447
 448 : strips>bitmap ( ifd -- ifd )
 449     dup strips>> concat >>bitmap ;
 450
 451 : (strips-predictor) ( ifd -- ifd )
 452     [ ]
 453     [ image-width find-tag ]
 454     [ samples-per-pixel find-tag ] tri
 455     [ * ] keep
 456     '[
 457         _ group
 458         [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
 459         B{ } concat-as
 460     ] change-bitmap ;
 461
 462 : strips-predictor ( ifd -- ifd )
 463     dup predictor tag? [
 464         dup predictor find-tag
 465         {
 466             { predictor-none [ ] }
 467             { predictor-horizontal-differencing [ (strips-predictor) ] }
 468             [ bad-predictor ]
 469         } case
 470     ] when ;
 471
 472 ERROR: unknown-component-order ifd ;
 473
 474 : fix-bitmap-endianness ( ifd -- ifd )
 475     dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
 476     {
 477         { { 32 32 32 32 } [ 4 seq>native-endianness ] }
 478         { { 32 32 32 } [ 4 seq>native-endianness ] }
 479         { { 16 16 16 16 } [ 2 seq>native-endianness ] }
 480         { { 16 16 16 } [ 2 seq>native-endianness ] }
 481         { { 8 8 8 8 } [ ] }
 482         { { 8 8 8 } [ ] }
 483         { 8 [ ] }
 484         [ unknown-component-order ]
 485     } case >>bitmap ;
 486
 487 : ifd-component-order ( ifd -- component-order component-type )
 488     bits-per-sample find-tag {
 489         { { 32 32 32 32 } [ RGBA float-components ] }
 490         { { 32 32 32 } [ RGB float-components ] }
 491         { { 16 16 16 16 } [ RGBA ushort-components ] }
 492         { { 16 16 16 } [ RGB ushort-components ] }
 493         { { 8 8 8 8 } [ RGBA ubyte-components ] }
 494         { { 8 8 8 } [ RGB ubyte-components ] }
 495         { 8 [ LA ubyte-components ] }
 496         [ unknown-component-order ]
 497     } case ;
 498
 499 : handle-alpha-data ( ifd -- ifd )
 500     dup extra-samples find-tag {
 501         { extra-samples-associated-alpha-data [ ] }
 502         { extra-samples-unspecified-alpha-data [ ] }
 503         { extra-samples-unassociated-alpha-data [ ] }
 504         [ bad-extra-samples ]
 505     } case ;
 506
 507 : ifd>image ( ifd -- image )
 508     [ <image> ] dip {
 509         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
 510         [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ]
 511         [ bitmap>> >>bitmap ]
 512     } cleave ;
 513
 514 : tiff>image ( image -- image )
 515     ifds>> [ ifd>image ] map first ;
 516
 517 : with-tiff-endianness ( loading-tiff quot -- )
 518     [ dup endianness>> ] dip with-endianness ; inline
 519
 520 : load-tiff-ifds ( stream -- loading-tiff )
 521     [
 522         <loading-tiff>
 523         read-header [
 524             dup ifd-offset>> read-ifds
 525             process-ifds
 526         ] with-tiff-endianness
 527     ] with-input-stream* ;
 528
 529 : process-chunky-ifd ( ifd -- )
 530     read-strips
 531     uncompress-strips
 532     strips>bitmap
 533     fix-bitmap-endianness
 534     strips-predictor
 535     dup extra-samples tag? [ handle-alpha-data ] when
 536     drop ;
 537
 538 : process-planar-ifd ( ifd -- )
 539     "planar ifd not supported" throw ;
 540
 541 : dispatch-planar-configuration ( ifd planar-configuration -- )
 542     {
 543         { planar-configuration-chunky [ process-chunky-ifd ] }
 544         { planar-configuration-planar [ process-planar-ifd ] }
 545     } case ;
 546
 547 : process-ifd ( ifd -- )
 548     dup planar-configuration find-tag* [
 549         dispatch-planar-configuration
 550     ] [
 551         drop "no planar configuration" throw
 552     ] if ;
 553
 554 : process-tif-ifds ( loading-tiff -- )
 555     ifds>> [ process-ifd ] each ;
 556
 557 : load-tiff ( path -- loading-tiff )
 558     [ load-tiff-ifds dup ]
 559     [
 560         [ [ 0 seek-absolute ] dip stream-seek ]
 561         [
 562             [
 563                 [ process-tif-ifds ] with-tiff-endianness
 564             ] with-input-stream
 565         ] bi
 566     ] bi ;
 567
 568 ! tiff files can store several images -- we just take the first for now
 569 M: tiff-image stream>image ( stream tiff-image -- image )
 570     drop load-tiff tiff>image ;
 571
 572 { "tif" "tiff" } [ tiff-image register-image-class ] each