extra/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 combinators
   4 combinators.short-circuit compression.lzw endian grouping
   5 images images.loader io io.encodings.ascii
   6 io.encodings.string io.encodings.utf8 io.streams.throwing kernel
   7 math math.bitwise math.vectors pack sequences ;
   8 IN: images.tiff
   9
  10 SINGLETON: tiff-image
  11
  12 TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
  13
  14 : <loading-tiff> ( -- tiff )
  15     loading-tiff new
  16         H{ } clone >>ifds ; inline
  17
  18 ! offset, next-offset, and count are not strictly necessary here
  19 ! count is just the length of ifd-entries
  20 TUPLE: ifd offset next-offset count
  21 ifd-entries processed-tags strips bitmap ;
  22
  23 : <ifd> ( offset count ifd-entries next-offset -- ifd )
  24     ifd new
  25         swap >>next-offset
  26         swap >>ifd-entries
  27         swap >>count
  28         swap >>offset ;
  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 : store-ifd ( tiff ifd -- tiff )
 246     dup offset>> pick ifds>> set-at ;
 247
 248 : read-ifd-entry ( -- ifd )
 249     2 read endian>
 250     2 read endian>
 251     4 read endian>
 252     4 read endian> <ifd-entry> ;
 253
 254 : read-ifd ( offset -- ifd )
 255     dup seek-absolute seek-input
 256     2 read endian>
 257     dup [ read-ifd-entry ] replicate
 258
 259     ! next ifd offset, 0 for stop
 260     4 read endian>
 261     <ifd> ;
 262
 263 : read-ifds ( tiff offset -- tiff )
 264     read-ifd
 265     [ store-ifd ]
 266     [
 267         next-offset>> dup { [ 0 > ] [ pick ifds>> key? not ] } 1&& [
 268             read-ifds
 269         ] [
 270             drop
 271         ] if
 272     ] bi ;
 273
 274 ERROR: no-tag class ;
 275
 276 : find-tag* ( ifd class -- tag/class ? )
 277     swap processed-tags>> ?at ;
 278
 279 : find-tag ( ifd class -- tag )
 280     find-tag* [ no-tag ] unless ;
 281
 282 : tag? ( ifd class -- tag )
 283     swap processed-tags>> key? ;
 284
 285 : read-strips ( ifd -- ifd )
 286     dup
 287     [ strip-byte-counts find-tag ]
 288     [ strip-offsets find-tag ] bi
 289     2dup [ integer? ] both? [
 290         seek-absolute seek-input read 1array
 291     ] [
 292         [ seek-absolute seek-input read ] { } 2map-as
 293     ] if >>strips ;
 294
 295 ERROR: unknown-ifd-type n where ;
 296
 297 : bytes>bits ( n/byte-array -- n )
 298     dup byte-array? [ le> ] when ;
 299
 300 ! TODO: Should skip entire ifd-entry instead of throwing
 301 ! if type is unknown (e.g. type 0 from the AFL american fuzzy loop test cases)
 302 : value-length ( ifd-entry -- n )
 303     [ count>> ] [ type>> ] bi {
 304         { 1 [ ] }
 305         { 2 [ ] }
 306         { 3 [ 2 * ] }
 307         { 4 [ 4 * ] }
 308         { 5 [ 8 * ] }
 309         { 6 [ ] }
 310         { 7 [ ] }
 311         { 8 [ 2 * ] }
 312         { 9 [ 4 * ] }
 313         { 10 [ 8 * ] }
 314         { 11 [ 4 * ] }
 315         { 12 [ 8 * ] }
 316         { 13 [ 4 * ] }
 317         [ "value-length" unknown-ifd-type ]
 318     } case ;
 319
 320 ERROR: bad-small-ifd-type n ;
 321
 322 : adjust-offset/value ( ifd-entry -- obj )
 323     [ offset/value>> 4 >endian ] [ type>> ] bi
 324     {
 325         { 1 [ 1 head endian> ] }
 326         { 3 [ 2 head endian> ] }
 327         { 4 [ endian> ] }
 328         { 6 [ 1 head endian> 8 >signed ] }
 329         { 8 [ 2 head endian> 16 >signed ] }
 330         { 9 [ endian> 32 >signed ] }
 331         { 11 [ endian> bits>float ] }
 332         { 13 [ endian> 32 >signed ] }
 333         [ bad-small-ifd-type ]
 334     } case ;
 335
 336 : offset-bytes>obj ( bytes type -- obj )
 337     {
 338         { 1 [ ] } ! blank
 339         { 2 [ ] } ! read c strings here
 340         { 3 [ 2 <groups> [ endian> ] map ] }
 341         { 4 [ 4 <groups> [ endian> ] map ] }
 342         { 5 [ 8 <groups> [ "II" unpack first2 / ] map ] }
 343         { 6 [ [ 8 >signed ] map ] }
 344         { 7 [ ] } ! blank
 345         { 8 [ 2 <groups> [ endian> 16 >signed ] map ] }
 346         { 9 [ 4 <groups> [ endian> 32 >signed ] map ] }
 347         { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
 348         { 11 [ 4 group [ "f" unpack ] map ] }
 349         { 12 [ 8 group [ "d" unpack ] map ] }
 350         [ "offset-bytes>obj" unknown-ifd-type ]
 351     } case ;
 352
 353 : ifd-entry-value ( ifd-entry -- n )
 354     dup value-length 4 <= [
 355         adjust-offset/value
 356     ] [
 357         [ offset/value>> seek-absolute seek-input ]
 358         [ value-length read ]
 359         [ type>> ] tri offset-bytes>obj
 360     ] if ;
 361
 362 : process-ifd-entry ( ifd-entry -- value class )
 363     [ ifd-entry-value ] [ tag>> ] bi {
 364         { 254 [ new-subfile-type ] }
 365         { 255 [ subfile-type ] }
 366         { 256 [ image-width ] }
 367         { 257 [ image-length ] }
 368         { 258 [ bits-per-sample ] }
 369         { 259 [ lookup-compression compression ] }
 370         { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
 371         { 263 [ threshholding ] }
 372         { 264 [ cell-width ] }
 373         { 265 [ cell-length ] }
 374         { 266 [ fill-order ] }
 375         { 269 [ ascii decode document-name ] }
 376         { 270 [ ascii decode image-description ] }
 377         { 271 [ ascii decode tiff-make ] }
 378         { 272 [ ascii decode tiff-model ] }
 379         { 273 [ strip-offsets ] }
 380         { 274 [ orientation ] }
 381         { 277 [ samples-per-pixel ] }
 382         { 278 [ rows-per-strip ] }
 383         { 279 [ strip-byte-counts ] }
 384         { 280 [ min-sample-value ] }
 385         { 281 [ max-sample-value ] }
 386         { 282 [ first x-resolution ] }
 387         { 283 [ first y-resolution ] }
 388         { 284 [ lookup-planar-configuration planar-configuration ] }
 389         { 285 [ page-name ] }
 390         { 286 [ x-position ] }
 391         { 287 [ y-position ] }
 392         { 288 [ free-offsets ] }
 393         { 289 [ free-byte-counts ] }
 394         { 290 [ gray-response-unit ] }
 395         { 291 [ gray-response-curve ] }
 396         { 292 [ t4-options ] }
 397         { 296 [ lookup-resolution-unit resolution-unit ] }
 398         { 297 [ page-number ] }
 399         { 305 [ ascii decode software ] }
 400         { 306 [ ascii decode date-time ] }
 401         { 315 [ ascii decode artist ] }
 402         { 316 [ ascii decode host-computer ] }
 403         { 317 [ lookup-predictor predictor ] }
 404         { 320 [ color-map ] }
 405         { 321 [ halftone-hints ] }
 406         { 322 [ tile-width ] }
 407         { 323 [ tile-length ] }
 408         { 324 [ tile-offsets ] }
 409         { 325 [ tile-byte-counts ] }
 410         { 326 [ bad-fax-lines ] }
 411         { 327 [ clean-fax-data ] }
 412         { 328 [ consecutive-bad-fax-lines ] }
 413         { 330 [ sub-ifd ] }
 414         { 338 [ lookup-extra-samples extra-samples ] }
 415         { 339 [ lookup-sample-format sample-format ] }
 416         { 347 [ jpeg-tables ] }
 417         { 512 [ lookup-jpeg-proc jpeg-proc ] }
 418         { 513 [ jpeg-interchange-format ] }
 419         { 514 [ jpeg-interchange-format-length ] }
 420         { 515 [ jpeg-restart-interval ] }
 421         { 519 [ jpeg-qtables ] }
 422         { 520 [ jpeg-dctables ] }
 423         { 521 [ jpeg-actables ] }
 424         { 529 [ ycbcr-coefficients ] }
 425         { 530 [ ycbcr-subsampling ] }
 426         { 531 [ ycbcr-positioning ] }
 427         { 532 [ reference-black-white ] }
 428         { 700 [ utf8 decode xmp ] }
 429         { 32995 [ matteing ] }
 430         { 32996 [ data-type ] }
 431         { 32997 [ image-depth ] }
 432         { 32998 [ tile-depth ] }
 433         { 33432 [ copyright ] }
 434         { 33723 [ iptc ] }
 435         { 34377 [ photoshop ] }
 436         { 34665 [ exif-ifd ] }
 437         { 34675 [ inter-color-profile ] }
 438         { 37439 [ sto-nits ] }
 439         { 42112 [ gdal-metadata ] }
 440         { 50341 [ print-image-matching-info ] }
 441         [ nip unhandled-ifd-entry swap ]
 442     } case ;
 443
 444 : process-ifds ( loading-tiff -- loading-tiff )
 445     [
 446         [
 447             dup ifd-entries>>
 448             [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags
 449         ] assoc-map
 450     ] change-ifds ;
 451
 452 ERROR: unhandled-compression compression ;
 453
 454 : (uncompress-strips) ( strips compression -- uncompressed-strips )
 455     {
 456         { compression-none [ ] }
 457         { compression-lzw [ [ tiff-lzw-uncompress ] map ] }
 458         [ unhandled-compression ]
 459     } case ;
 460
 461 : uncompress-strips ( ifd -- ifd )
 462     dup '[
 463         _ compression find-tag (uncompress-strips)
 464     ] change-strips ;
 465
 466 : strips>bitmap ( ifd -- ifd )
 467     dup strips>> concat >>bitmap ;
 468
 469 : (strips-predictor) ( ifd -- ifd )
 470     [ ]
 471     [ image-width find-tag ]
 472     [ samples-per-pixel find-tag ] tri
 473     [ * ] keep
 474     '[
 475         _ group
 476         [ _ [ group ] [ 0 <array> ] bi [ v+ ] accumulate* concat ] map
 477         B{ } concat-as
 478     ] change-bitmap ;
 479
 480 : strips-predictor ( ifd -- ifd )
 481     dup predictor tag? [
 482         dup predictor find-tag
 483         {
 484             { predictor-none [ ] }
 485             { predictor-horizontal-differencing [ (strips-predictor) ] }
 486             [ bad-predictor ]
 487         } case
 488     ] when ;
 489
 490 ERROR: unknown-component-order ifd ;
 491
 492 : fix-bitmap-endianness ( ifd -- ifd )
 493     dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
 494     {
 495         { { 32 32 32 32 } [ 4 seq>native-endianness ] }
 496         { { 32 32 32 } [ 4 seq>native-endianness ] }
 497         { { 16 16 16 16 } [ 2 seq>native-endianness ] }
 498         { { 16 16 16 } [ 2 seq>native-endianness ] }
 499         { { 8 8 8 8 } [ ] }
 500         { { 8 8 8 } [ ] }
 501         { 8 [ ] }
 502         [ unknown-component-order ]
 503     } case >>bitmap ;
 504
 505 : ifd-component-order ( ifd -- component-order component-type )
 506     bits-per-sample find-tag {
 507         { { 32 32 32 32 } [ RGBA float-components ] }
 508         { { 32 32 32 } [ RGB float-components ] }
 509         { { 16 16 16 16 } [ RGBA ushort-components ] }
 510         { { 16 16 16 } [ RGB ushort-components ] }
 511         { { 8 8 8 8 } [ RGBA ubyte-components ] }
 512         { { 8 8 8 } [ RGB ubyte-components ] }
 513         { 8 [ LA ubyte-components ] }
 514         [ unknown-component-order ]
 515     } case ;
 516
 517 : handle-alpha-data ( ifd -- ifd )
 518     dup extra-samples find-tag {
 519         { extra-samples-associated-alpha-data [ ] }
 520         { extra-samples-unspecified-alpha-data [ ] }
 521         { extra-samples-unassociated-alpha-data [ ] }
 522         [ bad-extra-samples ]
 523     } case ;
 524
 525 : ifd>image ( ifd -- image )
 526     [ <image> ] dip {
 527         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
 528         [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ]
 529         [ bitmap>> >>bitmap ]
 530     } cleave ;
 531
 532 : tiff>image ( image -- image )
 533     ifds>> values [ ifd>image ] map first ;
 534
 535 : with-tiff-endianness ( loading-tiff quot -- )
 536     [ dup endianness>> ] dip with-endianness ; inline
 537
 538 : load-tiff-ifds ( -- loading-tiff )
 539     <loading-tiff>
 540     read-header [
 541         dup ifd-offset>> read-ifds
 542         process-ifds
 543     ] with-tiff-endianness ;
 544
 545 : process-chunky-ifd ( ifd -- )
 546     read-strips
 547     uncompress-strips
 548     strips>bitmap
 549     fix-bitmap-endianness
 550     strips-predictor
 551     dup extra-samples tag? [ handle-alpha-data ] when
 552     drop ;
 553
 554 : process-planar-ifd ( ifd -- )
 555     "planar ifd not supported" throw ;
 556
 557 : dispatch-planar-configuration ( ifd planar-configuration -- )
 558     {
 559         { planar-configuration-chunky [ process-chunky-ifd ] }
 560         { planar-configuration-planar [ process-planar-ifd ] }
 561     } case ;
 562
 563 : process-ifd ( ifd -- )
 564     dup planar-configuration find-tag* [
 565         dispatch-planar-configuration
 566     ] [
 567         drop "no planar configuration" throw
 568     ] if ;
 569
 570 : process-tif-ifds ( loading-tiff -- )
 571     ifds>> values [ process-ifd ] each ;
 572
 573 : load-tiff ( -- loading-tiff )
 574     load-tiff-ifds dup
 575     0 seek-absolute seek-input
 576     [ process-tif-ifds ] with-tiff-endianness ;
 577
 578 ! tiff files can store several images -- we just take the first for now
 579 M: tiff-image stream>image* ( stream tiff-image -- image )
 580     drop [ [ load-tiff tiff>image ] throw-on-eof ] with-input-stream ;
 581
 582 { "tif" "tiff" } [ tiff-image ?register-image-class ] each