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