Add some functionality to support working with GeoTIFF files

JuicyPixels.cabal

@@ -138,7 +138,8 @@ Library
                  vector              >= 0.10    && < 0.13,
                  primitive           >= 0.4,
                  deepseq             >= 1.1     && < 1.5,
-                 containers          >= 0.4.2   && < 0.7
+                 containers          >= 0.4.2   && < 0.7,
+                 half                >= 0.3     && < 0.4
 
   -- Modules not exported by this package.
   Other-modules: Codec.Picture.BitWriter,

README.md

@@ -102,10 +102,10 @@ Status
  - Tiff
     * Reading
         - 2, 4, 8, 16 int bit depth reading (planar and contiguous for each)
-        - 32 bit floating point reading
+        - 16 and 32 bit floating point reading
 
         - CMYK, YCbCr, RGB, RGBA, Paletted, Greyscale
-        - Uncompressed, PackBits, LZW
+        - Uncompressed, PackBits, LZW, Deflate
 
     * Writing
         - 8 and 16 bits

src/Codec/Picture/Metadata/Exif.hs

@@ -199,10 +199,14 @@ data ExifData
   = ExifNone
   | ExifLong      !Word32
   | ExifShort     !Word16
+  | ExifFloat     !Float
+  | ExifDouble    !Double
   | ExifString    !B.ByteString
   | ExifUndefined !B.ByteString
   | ExifShorts    !(V.Vector Word16)
   | ExifLongs     !(V.Vector Word32)
+  | ExifFloats    !(V.Vector Double)
+  | ExifDoubles   !(V.Vector Double)
   | ExifRational  !Word32 !Word32
   | ExifSignedRational  !Int32 !Int32
   | ExifIFD       ![(ExifTag, ExifData)]
@@ -215,4 +219,6 @@ instance NFData ExifData where
   rnf (ExifIFD ifds) = rnf ifds `seq` ()
   rnf (ExifLongs l) = rnf l `seq` ()
   rnf (ExifShorts l) = rnf l `seq` ()
+  rnf (ExifFloats l) = rnf l `seq` ()
+  rnf (ExifDoubles l) = rnf l `seq` ()
   rnf a = a `seq` ()

src/Codec/Picture/Tiff.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -31,14 +32,17 @@ module Codec.Picture.Tiff( decodeTiff
                          , decodeTiffWithPaletteAndMetadata
                          , TiffSaveable
                          , encodeTiff
+                         , encodeTiffWithDeflate
                          , writeTiff
+                         , writeTiffWithDeflate
                          ) where
 
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative( (<$>), (<*>), pure )
 import Data.Monoid( mempty )
 #endif
 
+import Codec.Compression.Zlib( compress, decompress )
 import Control.Arrow( first )
 import Control.Monad( when, foldM_, unless, forM_ )
 import Control.Monad.ST( ST, runST )
@@ -58,6 +62,9 @@ import qualified Data.ByteString.Unsafe as BU
 
 import Foreign.Storable( sizeOf )
 
+import Numeric.Half
+import Unsafe.Coerce
+
 import Codec.Picture.Metadata.Exif
 import Codec.Picture.Metadata( Metadatas )
 import Codec.Picture.InternalHelper
@@ -206,6 +213,14 @@ uncompressAt CompressionLZW =  \str outVec _stride writeIndex (offset, size) ->
     let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str
     runBoolReader $ decodeLzwTiff toDecode outVec writeIndex
     return 0
+uncompressAt CompressionDeflate = \str outVec stride writeIndex (offset,size) ->
+    let decompressed = Lb.toStrict
+                     . decompress
+                     . Lb.fromStrict
+                     . B.take (fromIntegral size)
+                     $ B.drop (fromIntegral offset) str
+        len = fromIntegral $ B.length decompressed
+    in copyByteString decompressed outVec stride writeIndex (0,len)
 uncompressAt _ = error "Unhandled compression"
 
 class Unpackable a where
@@ -782,9 +797,19 @@ unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome
   -- some files are a little bit borked...
   | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =
         pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.singleton 16 && all (TiffSampleFloat ==) format =
+        pure . TrueColorImage . ImageYF . fromHalfToFloat $ gatherStrips (0 :: Word16) file nfo
 
 unpack _ _ = Left "Failure to unpack TIFF file"
 
+fromHalfToFloat :: Image Word16 -> Image Float
+fromHalfToFloat Image { imageWidth = w, imageHeight = h
+                      , imageData = arr } = Image w h transformed
+  where transformed = VS.map (fromHalf . word16ToHalf) arr
+        -- safe under the hood, but CUShort's data constructor isn't exposed
+        word16ToHalf = unsafeCoerce :: Word16 -> Half
+
+
 -- | Decode a tiff encoded image while preserving the underlying
 -- pixel type (except for Y32 which is truncated to 16 bits).
 --
@@ -891,17 +916,15 @@ instance TiffSaveable PixelYCbCr8 where
   colorSpaceOfPixel _ = TiffYCbCr
   subSamplingInfo _ = V.fromListN 2 [1, 1]
 
--- | Transform an image into a Tiff encoded bytestring, ready to be
--- written as a file.
-encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString
-encodeTiff img = runPut $ putP rawPixelData hdr
+encodeTiffWithCompression :: forall px. (TiffSaveable px) => TiffCompression -> Image px -> Lb.ByteString
+encodeTiffWithCompression compressMethod img = runPut $ putP rawPixelData hdr
   where intSampleCount = componentCount (undefined :: px)
         sampleCount = fromIntegral intSampleCount
 
         sampleType = undefined :: PixelBaseComponent px
         pixelData = imageData img
 
-        rawPixelData = toByteString pixelData
+        rawPixelData = tiffCompress compressMethod $ toByteString pixelData
         width = fromIntegral $ imageWidth img
         height = fromIntegral $ imageHeight img
         intSampleSize = sizeOf sampleType
@@ -923,7 +946,7 @@ encodeTiff img = runPut $ putP rawPixelData hdr
             , tiffPlaneConfiguration = PlanarConfigContig
             , tiffSampleFormat       = sampleFormat (undefined :: px)
             , tiffBitsPerSample      = V.replicate intSampleCount bitPerSample
-            , tiffCompression        = CompressionNone
+            , tiffCompression        = compressMethod
             , tiffStripSize          = V.singleton imageSize
             , tiffOffsets            = V.singleton headerSize
             , tiffPalette            = Nothing
@@ -933,9 +956,29 @@ encodeTiff img = runPut $ putP rawPixelData hdr
             , tiffMetadatas          = mempty
             }
 
+        tiffCompress CompressionNone img' = img'
+        tiffCompress CompressionDeflate img' = Lb.toStrict $ compress (Lb.fromStrict img')
+        tiffCompress _ _ = error "encodeTiffWithCompression: unsupported compression format"
+
+-- | Transform an image into a Tiff encoded bytestring, ready to be
+-- written as a file.
+encodeTiff :: (TiffSaveable px) => Image px -> Lb.ByteString
+encodeTiff img = encodeTiffWithCompression CompressionNone img
+{-# INLINE encodeTiff #-}
+
+-- | Transform an image into a Tiff encoded bytestring, ready to be
+-- written as a file. The raw data is compressed via deflate.
+encodeTiffWithDeflate :: (TiffSaveable px) => Image px -> Lb.ByteString
+encodeTiffWithDeflate img = encodeTiffWithCompression CompressionDeflate img
+{-# INLINE encodeTiffWithDeflate #-}
+
 -- | Helper function to directly write an image as a tiff on disk.
 writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO ()
 writeTiff path img = Lb.writeFile path $ encodeTiff img
 
+-- | Helper function to directly write an image as a deflate-compressed tiff on disk.
+writeTiffWithDeflate :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO ()
+writeTiffWithDeflate path img = Lb.writeFile path $ encodeTiff img
+
 {-# ANN module "HLint: ignore Reduce duplication" #-}
 

src/Codec/Picture/Tiff/Internal/Metadata.hs

@@ -44,7 +44,11 @@ typeOfData d = case d of
   ExifLong _l -> TypeLong
   ExifLongs _l -> TypeLong
   ExifShort _s -> TypeShort
+  ExifFloat _f -> TypeFloat
+  ExifDouble _d -> TypeDouble
   ExifShorts _s -> TypeShort
+  ExifFloats _f -> TypeFloat
+  ExifDoubles _d -> TypeDouble
   ExifString _str -> TypeAscii
   ExifUndefined _undef -> TypeUndefined
   ExifRational _r1 _r2 -> TypeRational

src/Codec/Picture/Tiff/Internal/Types.hs

@@ -38,13 +38,17 @@ import Data.Binary( Binary( .. ) )
 import Data.Binary.Get( Get
                       , getWord16le, getWord16be
                       , getWord32le, getWord32be
+                      , getFloatle,  getFloatbe
+                      , getDoublele, getDoublebe
                       , bytesRead
                       , skip
                       , getByteString
                       )
 import Data.Binary.Put( Put
                       , putWord16le, putWord16be
                       , putWord32le, putWord32be
+                      , putFloatle,  putFloatbe
+                      , putDoublele, putDoublebe
                       , putByteString
                       )
 import Data.Function( on )
@@ -105,6 +109,20 @@ instance BinaryParam Endianness Word32 where
   getP EndianLittle = getWord32le
   getP EndianBig = getWord32be
 
+instance BinaryParam Endianness Float where
+  putP EndianLittle = putFloatle
+  putP EndianBig = putFloatbe
+
+  getP EndianLittle = getFloatle
+  getP EndianBig = getFloatbe
+
+instance BinaryParam Endianness Double where
+  putP EndianLittle = putDoublele
+  putP EndianBig = putDoublebe
+
+  getP EndianLittle = getDoublele
+  getP EndianBig = getDoublebe
+
 instance Binary TiffHeader where
   put hdr = do
     let endian = hdrEndianness hdr
@@ -139,6 +157,7 @@ data TiffCompression
   | CompressionModifiedRLE    -- 2
   | CompressionLZW            -- 5
   | CompressionJPEG           -- 6
+  | CompressionDeflate        -- 8
   | CompressionPackBit        -- 32273
 
 data IfdType
@@ -215,12 +234,16 @@ instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where
       dump ExifNone = pure ()
       dump (ExifLong _) = pure ()
       dump (ExifShort _) = pure ()
+      dump (ExifFloat _) = pure ()
+      dump (ExifDouble _) = pure ()
       dump (ExifIFD _) = pure ()
       dump (ExifString bstr) = paddWrite bstr
       dump (ExifUndefined bstr) = paddWrite bstr
       -- wrong if length == 2
       dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts
       dump (ExifLongs longs) = V.mapM_ (putP endianness) longs
+      dump (ExifFloats floats) = V.mapM_ (putP endianness) floats
+      dump (ExifDoubles doubles) = V.mapM_ (putP endianness) doubles
       dump (ExifRational a b) = putP endianness a >> putP endianness b
       dump (ExifSignedRational a b) = putP endianness a >> putP endianness b
 
@@ -282,12 +305,20 @@ instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where
           align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle
       fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } =
           pure . ExifShort . fromIntegral $ ifdOffset ifd
-      fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 =
+      fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 1 =
           align ifd $ ExifShorts <$> getVec count getE
       fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } =
           pure . ExifLong . fromIntegral $ ifdOffset ifd
       fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 =
           align ifd $ ExifLongs <$> getVec count getE
+      fetcher ImageFileDirectory { ifdType = TypeFloat, ifdCount = 1 } =
+          pure . ExifFloat . fromIntegral $ ifdOffset ifd
+      fetcher ImageFileDirectory { ifdType = TypeFloat, ifdCount = count } | count > 1 =
+          align ifd $ ExifFloats <$> getVec count getE
+      fetcher ImageFileDirectory { ifdType = TypeDouble, ifdCount = 1 } =
+          pure . ExifDouble . fromIntegral $ ifdOffset ifd
+      fetcher ImageFileDirectory { ifdType = TypeDouble, ifdCount = count } | count > 1 =
+          align ifd $ ExifDoubles <$> getVec count getE
       fetcher _ = pure ExifNone
 
 cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory
@@ -339,6 +370,10 @@ setupIfdOffsets initialOffset lst = mapAccumL updater startExtended lst
         updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v })
             | V.length v > 2 = ( ix + fromIntegral (V.length v * 2)
                              , ifd { ifdOffset = ix })
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExifFloats v }) =
+            ( ix + fromIntegral (V.length v * 4) , ifd { ifdOffset = ix } )
+        updater ix ifd@(ImageFileDirectory { ifdExtended = ExifDoubles v }) =
+            ( ix + fromIntegral (V.length v * 8) , ifd { ifdOffset = ix } )
         updater ix ifd = (ix, ifd)
 
 instance BinaryParam B.ByteString (TiffHeader, [[ImageFileDirectory]]) where
@@ -477,6 +512,7 @@ unPackCompression v = case v of
   2 -> pure CompressionModifiedRLE
   5 -> pure CompressionLZW
   6 -> pure CompressionJPEG
+  8 -> pure CompressionDeflate
   32773 -> pure CompressionPackBit
   vv -> fail $ "Unknown compression scheme " ++ show vv
 
@@ -486,5 +522,6 @@ packCompression v = case v of
   CompressionModifiedRLE -> 2
   CompressionLZW         -> 5
   CompressionJPEG        -> 6
+  CompressionDeflate     -> 8
   CompressionPackBit     -> 32773
 

src/Codec/Picture/Types.hs

@@ -124,6 +124,7 @@ import Data.Word( Word8, Word16, Word32, Word64 )
 import Data.Vector.Storable ( (!) )
 import qualified Data.Vector.Storable as V
 import qualified Data.Vector.Storable.Mutable as M
+import Numeric.Half
 
 #include "ConvGraph.hs"
 
@@ -1374,6 +1375,40 @@ instance Pixel PixelF where
     {-# INLINE unsafeWritePixel #-}
     unsafeWritePixel = M.unsafeWrite
 
+type PixelH = Half
+
+instance Pixel PixelH where
+    type PixelBaseComponent PixelH = Half
+
+    {-# INLINE pixelOpacity #-}
+    pixelOpacity = const 1.0
+
+    {-# INLINE mixWith #-}
+    mixWith f = f 0
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+    {-# INLINE componentCount #-}
+    componentCount _ = 1
+    {-# INLINE pixelAt #-}
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y =
+        arr ! (x + y * w)
+
+    {-# INLINE readPixel #-}
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    {-# INLINE writePixel #-}
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    {-# INLINE unsafePixelAt #-}
+    unsafePixelAt = V.unsafeIndex
+    {-# INLINE unsafeReadPixel #-}
+    unsafeReadPixel = M.unsafeRead
+    {-# INLINE unsafeWritePixel #-}
+    unsafeWritePixel = M.unsafeWrite
+
 instance ColorConvertible PixelF PixelRGBF where
     {-# INLINE promotePixel #-}
     promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59)  (c / 0.11)

test-src/main.hs

@@ -391,6 +391,7 @@ tiffValidTests =
     ,"other/butique-YA8.tif"
     ,"other/butique-YA16.tif"
     ,"horizontal-difference-lzw.tiff" -- produced by "Grab" on Mac OS X
+    ,"float16deflate.tif"
     ,"rad_YF.tif"
     ,"rad_Y32.tif"
     ]