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