JuicyPixels 3.0 → 3.1

raw patch · 21 files changed

+4658/−2562 lines, 21 filesdep +mmapdep ~binarydep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: mmap

Dependency ranges changed: binary, vector

API changes (from Hackage documentation)

Files

• Codec/Picture.hs +19/−5
• Codec/Picture/BitWriter.hs +128/−111
• Codec/Picture/Bitmap.hs +62/−48
• Codec/Picture/ConvGraph.hs +9/−9
• Codec/Picture/Gif.hs +380/−380
• Codec/Picture/Gif/LZW.hs +120/−56
• Codec/Picture/HDR.hs +462/−449
• Codec/Picture/InternalHelper.hs +33/−29
• Codec/Picture/Jpg.hs +357/−215
• Codec/Picture/Jpg/DefaultTable.hs +45/−3
• Codec/Picture/Jpg/FastDct.hs +19/−25
• Codec/Picture/Jpg/FastIdct.hs +73/−75
• Codec/Picture/Jpg/Types.hs +1/−34
• Codec/Picture/Png.hs +171/−148
• Codec/Picture/Png/Export.hs +69/−13
• Codec/Picture/Png/Type.hs +24/−26
• Codec/Picture/Saving.hs +145/−88
• Codec/Picture/Tiff.hs +943/−0
• Codec/Picture/Types.hs +1574/−839
• Codec/Picture/VectorByteConversion.hs +12/−0
• JuicyPixels.cabal +12/−9

@@ -17,6 +17,7 @@                      , pixelMap
                      , generateImage
                      , generateFoldImage
+                     , withImage
 
                      -- * Generic image writing
                      , saveBmpImage
@@ -54,6 +55,9 @@                      , encodeDynamicPng
                      , writeDynamicPng
 
+                     -- ** Tiff handling
+                     , decodeTiff
+
                      -- ** HDR (Radiance/RGBE) handling
                      , readHDR
                      , decodeHDR
@@ -68,10 +72,19 @@                      , Pixel( .. )
                      -- $graph
                      , Pixel8
+                     , Pixel16
+                     , PixelF
+
                      , PixelYA8( .. )
+                     , PixelYA16( .. )
                      , PixelRGB8( .. )
+                     , PixelRGB16( .. )
+                     , PixelRGBF( .. )
                      , PixelRGBA8( .. )
+                     , PixelRGBA16( .. )
                      , PixelYCbCr8( .. )
+                     , PixelCMYK8( .. )
+                     , PixelCMYK16( .. )
                      ) where
 
 import Control.Applicative( (<$>) )
@@ -88,10 +101,11 @@                         , encodeHDR
                         , writeHDR
                         )
+import Codec.Picture.Tiff( decodeTiff )
 import Codec.Picture.Saving
 import Codec.Picture.Types
-import System.IO ( withFile, IOMode(ReadMode) )
-
+-- import System.IO ( withFile, IOMode(ReadMode) )
+import System.IO.MMap ( mmapFileByteString )
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
@@ -111,8 +125,7 @@                  -> IO (Either String a)
 withImageDecoder decoder path = Exc.catch doit
                     (\e -> return . Left $ show (e :: Exc.IOException))
-    where doit = withFile path ReadMode $ \h ->
-                    force . decoder <$> B.hGetContents h
+    where doit = force . decoder <$> mmapFileByteString path Nothing
           -- force appeared in deepseq 1.3, Haskell Platform
           -- provide 1.1
           force x = x `deepseq` x
@@ -132,6 +145,7 @@                                  ,("Bitmap", decodeBitmap)
                                  ,("GIF", decodeGif)
                                  ,("HDR", decodeHDR)
+                                 ,("Tiff", decodeTiff)
                                  ]
     
 -- | Helper function trying to load a png file from a file on disk.
@@ -178,7 +192,7 @@ -- >    eitherImg <- decodeImage pathIn
 -- >    case eitherImg of
 -- >        Left _ -> return ()
--- >        Right img -> savePngImage img
+-- >        Right img -> savePngImage pathOut img
 --
 savePngImage :: String -> DynamicImage -> IO ()
 savePngImage path img = L.writeFile path $ imageToPng img

@@ -1,216 +1,233 @@ {-# LANGUAGE Rank2Types #-}
 -- | This module implement helper functions to read & write data
 -- at bits level.
-module Codec.Picture.BitWriter( BoolWriter
-                              , BoolReader
-                              , writeBits
+module Codec.Picture.BitWriter( BoolReader
+                              , BoolState( .. )
                               , byteAlignJpg
-                              , getNextBits
+                              , getNextBitsLSBFirst
+                              , getNextBitsMSBFirst 
                               , getNextBitJpg
                               , setDecodedString
                               , setDecodedStringJpg
-                              , pushByte
-                              , runBoolWriter
                               , runBoolReader
+
+                              , BoolWriteStateRef 
+                              , newWriteStateRef
+                              , finalizeBoolWriter
+                              , writeBits'
                               ) where
 
+import Data.STRef
+import Control.Applicative( (<$>), (<*>) )
 import Control.Monad( when )
 import Control.Monad.ST( ST )
 import qualified Control.Monad.Trans.State.Strict as S
-import Control.Monad.Trans.Class( MonadTrans( .. ) )
 import Data.Word( Word8, Word32 )
-import Data.Bits( Bits, (.&.), (.|.), shiftR, shiftL )
+import Data.Bits( Bits, (.&.), (.|.), unsafeShiftR, unsafeShiftL )
 
+import Codec.Picture.VectorByteConversion( blitVector )
 import qualified Data.Vector.Storable.Mutable as M
 import qualified Data.Vector.Storable as VS
 import qualified Data.ByteString as B
-
-{-# INLINE (.>>.) #-}
-{-# INLINE (.<<.) #-}
-(.<<.), (.>>.) :: (Bits a) => a -> Int -> a
-(.<<.) = shiftL
-(.>>.) = shiftR
-
+import qualified Data.ByteString.Lazy as L
 
 --------------------------------------------------
 ----            Reader
 --------------------------------------------------
 -- | Current bit index, current value, string
-type BoolState = (Int, Word8, B.ByteString)
+data BoolState = BoolState {-# UNPACK #-} !Int
+                           {-# UNPACK #-} !Word8
+                           !B.ByteString
 
 -- | Type used to read bits
 type BoolReader s a = S.StateT BoolState (ST s) a
 
 runBoolReader :: BoolReader s a -> ST s a
-runBoolReader action = S.evalStateT action (0, 0, B.empty)
+runBoolReader action = S.evalStateT action $ BoolState 0 0 B.empty
 
 -- | Bitify a list of things to decode.
 setDecodedString :: B.ByteString -> BoolReader s ()
 setDecodedString str = case B.uncons str of
-     Nothing        -> S.put (      0, 0, B.empty)
-     Just (v, rest) -> S.put (       0, v,    rest)
+     Nothing        -> S.put $ BoolState      0 0 B.empty
+     Just (v, rest) -> S.put $ BoolState      0 v    rest
 
 -- | Drop all bit until the bit of indice 0, usefull to parse restart
 -- marker, as they are byte aligned, but Huffman might not.
 byteAlignJpg :: BoolReader s ()
 byteAlignJpg = do
-  (idx, _, chain) <- S.get
+  BoolState idx _ chain <- S.get
   when (idx /= 7) (setDecodedStringJpg chain)
 
 {-# INLINE getNextBitJpg #-}
 getNextBitJpg :: BoolReader s Bool
 getNextBitJpg = do
-    (idx, v, chain) <- S.get
-    let val = (v .&. (1 `shiftL` idx)) /= 0
+    BoolState idx v chain <- S.get
+    let val = (v .&. (1 `unsafeShiftL` idx)) /= 0
     if idx == 0
       then setDecodedStringJpg chain
-      else S.put (idx - 1, v, chain)
+      else S.put $ BoolState (idx - 1) v chain
     return val
 
-{-# INLINE getNextBits #-}
-getNextBits :: Int -> BoolReader s Word32
-getNextBits count = aux 0 count
+{-# INLINE getNextBitMSB #-}
+getNextBitMSB :: BoolReader s Bool
+getNextBitMSB = do
+    BoolState idx v chain <- S.get
+    let val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0
+    if idx == 7
+      then setDecodedString chain
+      else S.put $ BoolState (idx + 1) v chain
+    return val
+
+{-# INLINE getNextBitsMSBFirst #-}
+getNextBitsMSBFirst :: Int -> BoolReader s Word32
+getNextBitsMSBFirst count = aux 0 count
   where aux acc 0 = return acc
         aux acc n = do
+            bit <- getNextBitMSB
+            let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1
+                        | otherwise = acc `unsafeShiftL` 1
+            aux nextVal (n - 1)
+
+{-# INLINE getNextBitsLSBFirst #-}
+getNextBitsLSBFirst :: Int -> BoolReader s Word32
+getNextBitsLSBFirst count = aux 0 count
+  where aux acc 0 = return acc
+        aux acc n = do
             bit <- getNextBit
-            let nextVal | bit = acc .|. (1 .<<. (count - n))
+            let nextVal | bit = acc .|. (1 `unsafeShiftL` (count - n))
                         | otherwise = acc
             aux nextVal (n - 1)
 
 {-# INLINE getNextBit #-}
 getNextBit :: BoolReader s Bool
 getNextBit = do
-    (idx, v, chain) <- S.get
-    let val = (v .&. (1 `shiftL` idx)) /= 0
+    BoolState idx v chain <- S.get
+    let val = (v .&. (1 `unsafeShiftL` idx)) /= 0
     if idx == 7
       then setDecodedString chain
-      else S.put (idx + 1, v, chain)
+      else S.put $ BoolState (idx + 1) v chain
     return val
 
 -- | Bitify a list of things to decode. Handle Jpeg escape
 -- code (0xFF 0x00), thus should be only used in JPEG decoding.
 setDecodedStringJpg :: B.ByteString -> BoolReader s ()
 setDecodedStringJpg str = case B.uncons str of
-     Nothing        -> S.put (maxBound, 0, B.empty)
+     Nothing        -> S.put $ BoolState maxBound 0 B.empty
      Just (0xFF, rest) -> case B.uncons rest of
-            Nothing                  -> S.put (maxBound, 0, B.empty)
-            Just (0x00, afterMarker) -> S.put (7, 0xFF, afterMarker)
+            Nothing                  -> S.put $ BoolState maxBound 0 B.empty
+            Just (0x00, afterMarker) -> S.put $ BoolState 7 0xFF afterMarker
             Just (_   , afterMarker) -> setDecodedStringJpg afterMarker
-     Just (v, rest) -> S.put (       7, v,    rest)
+     Just (v, rest) -> S.put $ BoolState 7 v rest
 
 --------------------------------------------------
 ----            Writer
 --------------------------------------------------
 defaultBufferSize :: Int
-defaultBufferSize = 100 * 1024
+defaultBufferSize = 256 * 1024
 
--- | Run the writer and get the serialized data.
-runBoolWriter :: BoolWriter s b -> ST s B.ByteString
-runBoolWriter writer = do
+data BoolWriteStateRef s = BoolWriteStateRef
+        { bwsCurrBuffer   :: STRef s (M.MVector s Word8)
+        , bwsBufferList   :: STRef s [B.ByteString]
+        , bwsWrittenWords :: STRef s Int
+        , bwsBitAcc       :: STRef s Word8
+        , bwsBitReaded    :: STRef s Int
+        }
+
+newWriteStateRef :: ST s (BoolWriteStateRef s)
+newWriteStateRef = do
     origMv <- M.new defaultBufferSize
-    st <- S.execStateT (writer >> flushWriter) (BoolWriteState origMv [] 0 0 0)
-    st' <- forceBufferFlushing st
-    return . B.concat $ strings st'
+    BoolWriteStateRef <$> newSTRef origMv
+                      <*> newSTRef []
+                      <*> newSTRef 0
+                      <*> newSTRef 0
+                      <*> newSTRef 0
 
--- | Current serializer, bit buffer, bit count
-data BoolWriteState s = BoolWriteState
-        { wordWrite    :: M.MVector s Word8
-        , strings      :: ![B.ByteString]
-        , writtenWords :: {-# UNPACK #-} !Int
-        , bitAcc       :: {-# UNPACK #-} !Word8
-        , bitReaded    :: {-# UNPACK #-} !Int
-        }
+finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString
+finalizeBoolWriter st = do
+    forceBufferFlushing' st
+    L.fromChunks <$> readSTRef (bwsBufferList st)
 
-type BoolWriter s a = S.StateT (BoolWriteState s) (ST s) a
+forceBufferFlushing' :: BoolWriteStateRef s -> ST s ()
+forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer = vecRef
+                                        , bwsWrittenWords = countRef
+                                        , bwsBufferList = lstRef
+                                        }) = do
+    vec <- readSTRef vecRef
+    count <- readSTRef countRef
+    lst <- readSTRef lstRef
 
-forceBufferFlushing :: BoolWriteState s -> ST s (BoolWriteState s)
-forceBufferFlushing st@(BoolWriteState { wordWrite = vec
-                                       , writtenWords = count
-                                       , strings = lst
-                                       }) = do
     nmv <- M.new defaultBufferSize
     str <- byteStringFromVector vec count
-    return $ st { wordWrite = nmv
-                , strings = lst ++ [str]
-                , writtenWords = 0
-                }
 
-flushCurrentBuffer :: BoolWriteState s -> ST s (BoolWriteState s)
-flushCurrentBuffer st | writtenWords st < M.length (wordWrite st) = return st
-flushCurrentBuffer st = forceBufferFlushing st
+    writeSTRef vecRef nmv
+    writeSTRef lstRef $ lst ++ [str]
+    writeSTRef countRef 0
 
--- Data.Vector.Storable.Mutable
--- unsafeToForeignPtr0 :: Storable a => MVector s a -> (ForeignPtr a, Int)
---
--- Data.ByteString.Unsafe
--- unsafePackCStringFinalizer :: Ptr Word8 -> Int -> IO () -> IO ByteString
---
--- Data.Vector.Storable.Internal
--- getPtr :: ForeignPtr a -> Ptr a
+flushCurrentBuffer' :: BoolWriteStateRef s -> ST s ()
+flushCurrentBuffer' st = do
+    count <- readSTRef $ bwsWrittenWords st
+    when (count >= defaultBufferSize)
+         (forceBufferFlushing' st)
+
 byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString
 byteStringFromVector vec size = do
     frozen <- VS.unsafeFreeze vec
-    return . B.pack . take size $ VS.toList frozen
-
-setBitCount :: Word8 -> Int -> BoolWriter s ()
-setBitCount acc count = S.modify $ \s ->
-    s { bitAcc = acc, bitReaded = count }
+    return $ blitVector frozen 0 size
 
-resetBitCount :: BoolWriter s ()
-resetBitCount = setBitCount 0 0
+setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s ()
+{-# INLINE setBitCount' #-}
+setBitCount' st acc count = do
+    writeSTRef (bwsBitAcc st) acc
+    writeSTRef (bwsBitReaded st) count
 
-pushByte :: Word8 -> BoolWriter s ()
-pushByte v = do
-    st <- S.get
-    st'@(BoolWriteState { writtenWords = idx })
-        <- lift $ flushCurrentBuffer st
-    lift $ M.write (wordWrite st') idx v
-    S.put $ st' { writtenWords = idx + 1 }
+resetBitCount' :: BoolWriteStateRef s -> ST s ()
+{-# INLINE resetBitCount' #-}
+resetBitCount' st = setBitCount' st 0 0
 
--- | If some bits are not serialized yet, write
--- them in the MSB of a word.
-flushWriter :: BoolWriter s ()
-flushWriter = do
-    st <- S.get
-    let count = bitReaded st
-    when (count > 0)
-         (do let newContext = st { bitAcc = 0, bitReaded = 0 }
-             S.put newContext
-             pushByte $ bitAcc st `shiftL` (8 - count))
+pushByte' :: BoolWriteStateRef s -> Word8 -> ST s ()
+{-# INLINE pushByte' #-}
+pushByte' st v = do
+    flushCurrentBuffer' st
+    idx <- readSTRef (bwsWrittenWords st)
+    vec <- readSTRef (bwsCurrBuffer st)
+    M.write vec idx v
+    writeSTRef (bwsWrittenWords st) $ idx + 1
 
 -- | Append some data bits to a Put monad.
-writeBits :: Word32     -- ^ The real data to be stored. Actual data should be in the LSB
-          -> Int        -- ^ Number of bit to write from 1 to 32
-          -> BoolWriter s ()
-writeBits d c = do
-    currWord <- S.gets bitAcc
-    currCount <- S.gets bitReaded
+writeBits' :: BoolWriteStateRef s
+           -> Word32     -- ^ The real data to be stored. Actual data should be in the LSB
+           -> Int        -- ^ Number of bit to write from 1 to 32
+           -> ST s ()
+{-# INLINE writeBits' #-}
+writeBits' st d c = do
+    currWord <- readSTRef $ bwsBitAcc st
+    currCount <- readSTRef $  bwsBitReaded st
     serialize d c currWord currCount
-  where dumpByte 0xFF = pushByte 0xFF >> pushByte 0x00
-        dumpByte    i = pushByte i
+  where dumpByte 0xFF = pushByte' st 0xFF >> pushByte' st 0x00
+        dumpByte    i = pushByte' st i
 
         serialize bitData bitCount currentWord count
             | bitCount + count == 8 = do
-                     resetBitCount
-                     dumpByte (fromIntegral $ (currentWord .<<. bitCount) .|.
+                     resetBitCount' st
+                     dumpByte (fromIntegral $ (currentWord `unsafeShiftL` bitCount) .|.
                                                 fromIntegral cleanData)
 
             | bitCount + count < 8 =
-                let newVal = currentWord .<<. bitCount
-                in setBitCount (newVal .|. fromIntegral cleanData) $ count + bitCount
+                let newVal = currentWord `unsafeShiftL` bitCount
+                in setBitCount' st (newVal .|. fromIntegral cleanData) $ count + bitCount
 
             | otherwise =
                 let leftBitCount = 8 - count :: Int
-                    highPart = cleanData .>>. (bitCount - leftBitCount) :: Word32
-                    prevPart = fromIntegral currentWord .<<. leftBitCount :: Word32
+                    highPart = cleanData `unsafeShiftR` (bitCount - leftBitCount) :: Word32
+                    prevPart = fromIntegral currentWord `unsafeShiftL` leftBitCount :: Word32
 
-                    nextMask = (1 .<<. (bitCount - leftBitCount)) - 1 :: Word32
+                    nextMask = (1 `unsafeShiftL` (bitCount - leftBitCount)) - 1 :: Word32
                     newData = cleanData .&. nextMask :: Word32
                     newCount = bitCount - leftBitCount :: Int
 
                     toWrite = fromIntegral $ prevPart .|. highPart :: Word8
-                in resetBitCount >> dumpByte toWrite >> serialize newData newCount 0 0
+                in dumpByte toWrite >> serialize newData newCount 0 0
 
-              where cleanMask = (1 `shiftL` bitCount) - 1 :: Word32
+              where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32
                     cleanData = bitData .&. cleanMask     :: Word32
 

@@ -12,10 +12,8 @@                              -- * Accepted formt in output
                            , BmpEncodable( )
                            ) where
-import Foreign.Storable ( Storable )
 import Control.Monad( when, forM_ )
-import Control.Monad.ST ( runST )
-import Control.Monad.Primitive ( PrimMonad, PrimState )
+import Control.Monad.ST ( ST, runST )
 import qualified Data.Vector.Storable as V
 import qualified Data.Vector.Storable.Mutable as M
 import Data.Binary( Binary( .. ) )
@@ -36,8 +34,8 @@ import qualified Data.ByteString.Lazy as L
 
 import Codec.Picture.InternalHelper
-import Codec.Picture.BitWriter
 import Codec.Picture.Types
+import Codec.Picture.VectorByteConversion
 
 data BmpHeader = BmpHeader
     { magicIdentifier :: !Word16
@@ -146,77 +144,93 @@     defaultPalette :: pixel -> BmpPalette
     defaultPalette _ = BmpPalette []
 
-{-# INLINE (!!!) #-}
-(!!!) :: (Storable e) => V.Vector e -> Int -> e
-(!!!) = V.unsafeIndex
-
+stridePut :: M.STVector s Word8 -> Int -> Int -> ST s ()
 {-# INLINE stridePut #-}
-stridePut :: Int -> BoolWriter s ()
-stridePut 0 = return ()
-stridePut 1 = pushByte 0
-stridePut n = pushByte 0 >> stridePut (n - 1)
+stridePut vec = inner
+ where inner  _ 0 = return ()
+       inner ix n = do
+           (vec `M.unsafeWrite` ix) 0
+           inner (ix + 1) (n - 1)
 
 instance BmpEncodable Pixel8 where
     defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]]
     bitsPerPixel _ = 8
-    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = 
-      putByteString $ runST $ runBoolWriter . putLine $ h - 1
+    bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
+      forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ encodeLine l
         where stride = fromIntegral $ linePadding 8 w
+              putVector vec = putByteString $ blitVector vec 0 lineWidth
+              lineWidth = w + stride
 
-              putLine line | line < 0 = return ()
-              putLine line = do
+              encodeLine line = do
+                  buff <- M.new lineWidth
+
                   let lineIdx = line * w
                       inner col | col >= w = return ()
-                                | otherwise = pushByte (arr !!! (lineIdx + col)) >> inner (col + 1)
+                      inner col = do
+                          let v = (arr `V.unsafeIndex` (lineIdx + col))
+                          (buff `M.unsafeWrite` col) v
+                          inner (col + 1)
+
                   inner 0
-                  stridePut stride
-                  putLine (line - 1)
 
+                  stridePut buff w stride
+                  V.unsafeFreeze buff
+
 instance BmpEncodable PixelRGBA8 where
     bitsPerPixel _ = 32
     bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = 
-        putByteString $ runST $ runBoolWriter . putLine $ h - 1
-      where putLine line | line < 0 = return ()
+      forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l
+      where putVector vec = putByteString . blitVector vec 0 $ w * 4
             putLine line = do
+                buff <- M.new $ 4 * w
                 let initialIndex = line * w * 4
-                    inner col _ | col >= w = return ()
-                    inner col readIdx = do
-                        pushByte (arr !!! (readIdx + 2))
-                        pushByte (arr !!! (readIdx + 1))
-                        pushByte (arr !!! readIdx)
-                        pushByte (arr !!! (readIdx + 3))
-                        inner (col + 1) (readIdx + 4)
-                inner 0 initialIndex
-                putLine (line - 1)
+                    inner col _ _ | col >= w = return ()
+                    inner col writeIdx readIdx = do
+                        let r = arr `V.unsafeIndex` readIdx
+                            g = arr `V.unsafeIndex` (readIdx + 1)
+                            b = arr `V.unsafeIndex` (readIdx + 2)
+                            a = arr `V.unsafeIndex` (readIdx + 3)
 
+                        (buff `M.unsafeWrite` writeIdx) b
+                        (buff `M.unsafeWrite` (writeIdx + 1)) g
+                        (buff `M.unsafeWrite` (writeIdx + 2)) r
+                        (buff `M.unsafeWrite` (writeIdx + 3)) a
+
+                        inner (col + 1) (writeIdx + 4) (readIdx + 4)
+
+                inner 0 0 initialIndex
+                V.unsafeFreeze buff
+
 instance BmpEncodable PixelRGB8 where
     bitsPerPixel _ = 24
     bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) =
-       putByteString $ runST $ runBoolWriter . putLine $ h - 1
+       forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l
         where stride = fromIntegral . linePadding 24 $ w
-              putLine line | line < 0 = return ()
+              putVector vec = putByteString $ blitVector vec 0 (w * 3 + stride)
               putLine line = do
+                  buff <- M.new $ w * 3 + stride
                   let initialIndex = line * w * 3
-                      inner col _ | col >= w = return ()
-                      inner col readIdx = do
-                          pushByte (arr !!! (readIdx + 2))
-                          pushByte (arr !!! (readIdx + 1))
-                          pushByte (arr !!! readIdx)
-                          inner (col + 1) (readIdx + 3)
-                  inner 0 initialIndex
-                  stridePut stride
-                  putLine (line - 1)
+                      inner col _ _ | col >= w = return ()
+                      inner col writeIdx readIdx = do
+                          let r = (arr `V.unsafeIndex` readIdx)
+                              g = (arr `V.unsafeIndex` (readIdx + 1))
+                              b = (arr `V.unsafeIndex` (readIdx + 2))
+                          
+                          (buff `M.unsafeWrite` writeIdx) b
+                          (buff `M.unsafeWrite` (writeIdx + 1)) g
+                          (buff `M.unsafeWrite` (writeIdx + 2)) r
 
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = M.unsafeWrite
+                          inner (col + 1) (writeIdx + 3) (readIdx + 3)
 
+                  inner 0 0 initialIndex
+                  V.unsafeFreeze buff
+
 decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8
 decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray
   where wi = fromIntegral w
         hi = fromIntegral h
         stArray = runST $ do
-            arr <- M.replicate (fromIntegral $ w * h * 3) 128
+            arr <- M.new (fromIntegral $ w * h * 3)
             forM_ [hi - 1, hi - 2 .. 0] (readLine arr)
             V.unsafeFreeze arr
 
@@ -228,9 +242,9 @@ 
                 inner _ writeIdx | writeIdx >= lastIndex = return ()
                 inner readIdx writeIdx = do
-                    (arr .<-.  writeIdx     ) (str `B.index` (readIdx + 2))
-                    (arr .<-. (writeIdx + 1)) (str `B.index` (readIdx + 1))
-                    (arr .<-. (writeIdx + 2)) (str `B.index`  readIdx)
+                    (arr `M.unsafeWrite`  writeIdx     ) (str `B.index` (readIdx + 2))
+                    (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1))
+                    (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index`  readIdx)
                     inner (readIdx + 3) (writeIdx + 3)
 
             in inner readIndex writeIndex

@@ -1,9 +1,9 @@--- $graph------ The following graph describe the differents way to convert between pixel types,------ * Nodes describe pixel type------ * Arrows describe functions------ <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAr8AAAJrAQMAAADTeGmUAAAABlBMVEUAAAD///+l2Z/dAAAcaUlEQVR4Xu3dX4zcxnkAcB6uybXIn23Rh8aRHT70qQ9JGgSNXDjNAA3QlzRtgQJNasGxAyNNDEWSnUY6F7Y856j1vUQ4oCnSII5D9CFKi0qy5caSc2drTxGgQ90mDOJWUnQ+cdVFwrqnO+6asJY0Z/l1eUfucOeb4ZBLCshDDMNa88jfDb/5ZrgzHIoG3J5/4l8k+JdwYBgztwNmIzWYvQ3wagL0SOMwM3eAY43DN9JA06bhFv+zUZhlJe02DPczIGgYXhsfQJqFzTGw1CjMeDK4jcIh+tgQ7HOANQPj849pk7CdA0iTsIU+14ZxKe0m4XxcvQbhOA8MmoUvOPDcxz5qPk4bhRnAdYBzGxvbK23wG4SHI/jKg+fWtxI4ahi+tnFufXgb4AvXNp6756vveo02DTsbF849tnVzT7tx+JpzbmVra715eBTjlzc2N5uHR1lx/aN7bjYbY4b65l/4Jk1zgBuT2wN7RnPwap5abQ4OWlYOWDBoU/DMxFXj7sbgHpm4Sj9htJqB4zmACxwIwHiANgJ3KBhGvn2s0tlaMC9wbLydl3ENetAzG4A7yU65tLAgAFioD8dJTRkm/35sQgzAWrXhDiQw6WVAbyYNvB7WFxgMykgW4gUzjbwW1heYGQCLWSRWZ9LkrgfvFKx/YQSlkYDVNNdma8E9mhjuxeTc0wh0UjEgdeAdDZbcJCgJtEqhl0X3yRpwQHJfYo1W8i8EGRyY08MX81e82EhcYLOAiiyF9SP+MIXTjXcAKnJV+AYf2eQKfiegIleFWxNjg2EKfIzyM5oODlLBEkaOFipyRfji5CU6wqObgEwDx+ZEbMGXjCaPTQP3hMHzQDL+DcgU8KLguLJh+rHqMCMC6MmG6T1aGb4h1pUtHabPVYZbmdNOCUc6AO5UhfkEG0WwlQdaFeEuOnFLPky/UBFuoapqy6eFGFHAukiEOLI+SsvycBcrVDHf1KsE8ypxcZINJ4lWBZhxxcvgHDVpXNDDuHXwLGPKiSxGysNLXLEk5y9Ii6XhmOQRXGNt1A+WhHuSeaZIPUMWm2XhNUk8/YIZsotaGJeAyUa6HjpDHYxntYeyduyikpSDu7IJXq9onH5RDeNk43UWsb3g/Ch3HfLROZaCYyLCQwec67lCh4gxy8D9/IY3vnlp8TeO//dV5+9PPrR9ZvG9j5z87CVvCCgWZeC1PHzroeV7Nw9fPnf/yadPbB9cfv3006eXPYYzvwxsTsCby9c2f2Xvw/d/YOX0dm/lnude/ED7/lgSPj3MKIKPDuadgyN4e2X99Mr2CKZIXkRwcYjh5/tH8OFb5z7zxZUT2zeXXz+5cnqlDRju6+G1SfjpS+t3HH/z6vU3Xnpo+42V937ppYNrbWgjmBEtbE7CvGl7WVfUBkuS/DqYUSk8zMEUHAx3RVgTLFfaJmwMBzp4TQ5HE4ona68a2JTDPtqKg4xhdYhhwP/UzG92i+E+YBiXMZLAQTHsIlgW1RA0QcbwEoJleTAEWZARjOsWR9PBE8o4yBhWXwoi6RU/lsFBEewrYLF3oJogIxg1qVAuEc1dPwSbIjyU39Bsy+A1NcyoCsaFw3Afw+r8ZPI0cGQwU8Nd1Q2FuwDXhbr2MLykmvf/NcHwoKj2MExUt0tnUctX1x6Gcd3xuTF5g0RbBRjVHUosg+J2g+FQBXdVcYsNIiVwhXBYV9f2Lkyl6Y3jxmG0XVb/8QxKWXVaYJhR1UKFWMyKWA7bcjhU1nQ8h6Op2JnDeDOufzzZL4dDOWwr98WTjUQKMzlsKffF0beU+YbhmEj3hY5h3IkIR5FvHNam0OOzAAuoxLYy3zDcl8MzsqwAT5lvGHYLpr17oOneuIFhWz0nggdyAzk8kMFm0ZzIxVL9JkQSOKZFl5sAC/KsxzBDaB6MNf0mRxDcL56As0r1mzGHNfVsK37MFDDFsF28gs4v1W+CBLaKG39Qqt+ENoLlezKlVBpmuusuKdNvgoPgUPdNoY2KVg72dUvznDIdMtgIlieFhw7RdMieAKMSYM3DP9HDuDJwuQZIUMWOw+q8tKDjwVXzfS1ThN2SMFOlpUdhfXv7lgd+lQ6Zw6ES3n9mfevWCI5QIuph9ZkR8A4cXN+KMRyVhG0V3Nk6ePWuS3OmKIUlYUtZ4u3O+suSUAxLwkQJbx1a35DATA+rs627Ax9cv76N4VgPq7OtY7bB2zyz7o3yGMG0FBzKYaPNpZ4wJCsH+wrYzB3SmRHCXwZ2FfD9+cbaM1CHrIFVY2NjZrJ3C/JltnSweq+Fh+eE/jgvOxpYHbBVs2cOhBJyWQsrc6fXgh71xcriz5rYZWCG3Xgk9CEU85YvjvHKwKEkwDTZi+Em3GnxRNLCPg6EKQQ/5HVKOKGDXRwIXmWoCfHCaGEbZQRNkTVUV9mKnkgP4zQOWhnym5lminHSw7x54lUvwaN8ZkA4obAMnB6FV5B0s+FSH1XBUAvjTpt3kEtZkBdR0rASMEMrQPmQpie/qf0kxFoYhetYfswUt6S34VmrDOwrIgzddF0im0PCakz1sKsoMLR2diGPzkgmPVslYBuNyvM59p+GQTuY6BA97KBReT7HnJgm8cBFLoZRw2uJk6BWTKSrYRf0MEGrV/LNuM1G8Bw2vmXq4In6vYgm+EgCz2LDuaCDGb51nW/GlJkQGBKYEQ08RDeY8yGOIRjBM9iwYVEDhwjLh5jtwJJQeNDTwH4eQyEeJr0za8ng2CyG3XxOoBCH0BvBc9IB0sVi2ONYF0fF34H3gswIimGbY0s4KoMkiePHpHBsFsIWnt7kIQYXOnPSC5Ev1DWGuRYACjHYOzCTz7H1C2HKCyFJPGcHjuUwowVwTAuyGMDa3YHKZ1/MAphhLN+BkF2YIHgoFAXBwzyGw013YUsO9wvgUDoo7PKSx4ngyGFG1bCfixrOaJZWnK2YOiNqeJBrpDijhynsKuYxl9Qw52zAUYlSYaCAXTXMOQs3D/BTIVLAvgoWFr2ijHZTIVTMe4ZqmJeTSjLaTuGhYuaVqWGSKwL+6KRwrICBKmEqSeOAxz2DqQJuK+DdIxwvO9ube8FJq+TWHvCAJDBO2GwLfcqOVDBkcJgAW04C2zuwB15MM7gtnSumK54KZt3j79r7zkPLi2a09p6Dl/5utLYNwOx+de+Df/h/Nw8xyGALwV/79I//50PL/7ZHAYcbX/7elX3PLt/r+cubp5cPjNa2QUw3Dl+57yOb+54Nx7F3EHx87yfuO7j8k00FHDmHX7jy6Q8ur7cG5zdf+MrN0do2CME5fO3CkT0vfjAawx6Cn5nfd98DT/3vOxSwn8D7vOVrnjuCz28N5h3oJrBzJFrxBmPYlcKHzt9UxdjdOPy9y/ueff6a7S1vrixv3RqFwoaNwxsbR6J9z3pjeIDgH47gg+cv71fAXvf4C7//xw+8sv5Be23PyqWfvXnVARO6xze6X3rr5iF73Oh8BL/66PqDHzq/oqo8OzsSHEkTtMZwqJq1bitgB8MBB8gYHqpgSwHz7Y7kvjUdkwzBNvdlMD8TC38LYLyssQr2FDDhTRR3+FEOpgrYVcCUw/gbnMth3At53NLCYjTtHNxWwL4cjvMw2tPKJZqlgCMFnE8tMWgxycGOAg71MPr2zfJFshXwUA4zDlN0se7nYU+E3UJ4iGDGo76Yh10FzPSwGDNG8vBAAcd6WBw5dSAPR9XgEMG2OK0X5c8EIzGVwpEI83ydmczroQKGcjAvQI9MwqwmzHhKTMJxTbjPWx2KpRwmejifrgEC6sGOzQNQEm6XgpeyCKxhoBb8bvysmNsIzG9UI9iqAfNZ/xg/M+VUh3kZ2UwGA4LtSnCogIcY9hSwVQLmM3chht06cM+g6Ipqc6gCzE951TD4k+FcqQ13WiO71THVa0H8KeBsGn51lQcWwZEAu4UwywIBk+sobQyHleB4cmL8BtcQPJwG7vELM9rbmg6maV8mXDfaGGYC7JWBTXEGhEqWQVWCdwU2dhhtCia8nLmyxzKYVoLbQnOwUelIJlWEhZ+5vKJEj1SCLeGQEKUWVSxQsIthR4ge43x9mKFZr0jYILvoOcWwLfYCRIS5VAn2eIeYi6RfH3aT/0X7DxCMr6ZWMTwQL5O2ADOeX5Vgf8did8Fb0RJdCgC8cTZHw3Hm0acgEq+mbQXs9Rx4woBoJ1pDD6L5eTo/oLumJ8IrFeABTeBwF946cs+R6E+iT9HdKHjskX86ceP44M+6MHx1Z35tZQ8M9PAb+9975x/t/dSDIzgpkDWCT62fho/A3hS2o9Nf/+bm4cEn7oPwhzvza5c3xaspkcD9E6/vP3Xl3o0RzHZgdtep9etwBB5N4+9E22eXN9822PdZiDZ25te23yFeTakE9k9v7j/56xsXRnC8W+Lha3sSeJ7m4aODffftwofOb0dl4VODDSeB6S58KroeHYk4fPrsN//j8K19fwl+Or+2CaEe7ifwlWtJKICOmARed+b3zmewxR45+93f+eod+z4H/nh+bYim0nHlHdrzxb/aeyWpPCC78JF7nKU/Xcpi3Oa1PnBSQIRBFgreQKAtdAKeEmbVYCu1EIwnXDQwvl2B+wrCAU8BMx3sCb2bpYZpHh7qYFfWH+cIe1p4IFxBqAA7igWKoQ720TWvHBzp4GgyeENOoONIJXg4eYQv/4aFr/++DmaTVzNXhIkCHujgePKe/5KQsYqoALhamObTIiZKGDV9DQwkPzsYgADH08Pt/CKeLoJVi+dtLWzlg9wSNaaCHS1s55aCBFSEhyis3CuCs93nJpYJsRJwWwu7/G9fCkwEh6rl/kQL+3wmcwYQHKlgqoGzQwODBgbBsI8OKw2HkMqJi+CBAo5BCzPcKwzlcfWrwXEh7IE83qwETHkCYdhWwEM9DKQIdhRwWAK2imALYbz0OtgpgtsK2NfAwhATwwTFlRM62OXhxAJVwF4J2C+AYxVsl4DDIlj1dIlTAmaoEENkod9ilYDjAniogttamFeQJ+EiFUzKwEQN+6rnYagW5j9yJfBAAcdQBrblMN+Gi8n0MBcHEthTwMNSsK+GHQUc6mG+ly+BLQXs62EesEiA8ZQYEQQdHFMBZgKFYVcP8wNCDgsJhstvl4MtVQ8RgwJ2ysGeCh6qYKsc7KccKmiogkk5OOQch3l9SgxaDma8pmKgOXiA4fZFOoS4HJzth2EXT2e2N2AIDLRwPmTkzi889OKDR//r7lgxnfnvJ7/wyHs27jsOQz2cXwVyfvM7J5Y3jv7kyhOKCdhLT3/n9Ln79h+GSA/nT/nb0anTyxeOXr76hGIu+kcrp04/9/H5t4FfEk53vJ7AztHLvMQEw+ec+aPgloXD3eM2T514fuPo1y8/QaUtGi4l8P2jUHhlYbYjeHce+JdXHnz7X/x0DINQeS8dOPMNZ1R5TlkYSBrptCiU57dqNKqH+Z4DEQ5Vz6iT0rDLG3AO9hVwTMvAnAhFeKCCoTQcJAATYVcBD0vCvAMSYmgr4LA8DGam52FLAft6WDGl2ea+DHYrwF2+D4ep4sauXQEOxwdwOFbBVgWYJYg7CTNQwKQCDCae/QsVMIMqsI1nWH3FKqmwEtzNJ77DCyiBu5XgIGshHPYUsF0JjkmuVq5yXgKblWCwcjsZ/BAMM1oNXuMnGezCRA73oRrcz+WTwdsHhtcqwowC+HgojGGzIgwmfyXBDE9XBDNaFV7jZ78D+3L4BpSHeZBJDnblb49bqgDzIFu5R7E9KcxIZRjMcY1fyNoHhvtQGU5UPwdbUnhxCrgHEOQWIhEZzMgUcEyytOin7QPDF6AqnFa4mQqKpwhjcyq4m/UWHWMWQhncganggEI3ff6+R3wZPDcdDCYEaS3CMVcC9+iU8EWIqbWbUoGNjbfmYEo4ADCXICaKv7S9Q6eEE21tMeFRn5CGvjyMYtGfha7i3aWr0fRwQFn2cq0Q/axVA45NZqS7xhQFogYMF5mRDcaIEAhaCw4eNz4qHe/2WlALhl817pAN/dks1ICzbgIPbWID6sJBAqPBmEFrwz3j83hCyCDQANxCgy7DhCbhoeDWhYmwZjUeuxDWgNHS0p5BoDE4uAcG5m6bXjAANHC6Hk4PE4gcuOUlcGDMQSl4pSR87eYRD+AJw6Cghb+WrofTwxSi9X1nvTQbtPDxdD1cGTi4Z985M/lQBn4mXQ9XqsTRix/xSsPperhy8L5bMngoDUW6Hq4kfLY0/DX+vKk+K966OW/K4FoNJCbZh4bhhTEMlWG3AF41rdsC91r8/UHVYU8Js1n0cEIzsIGm7SrBtgruEPSStEqwI4XTNxCyD/PcaQDmI90bIQ9YVdjiMAoELGWH29XhNoL5gzGMZC1usTpMpPBqNnYk6Q9JZZjKYNZKy5nuyjozVeEYZPCTu5vGUwBhz6gKMwTzBV7BeObAxTDTwEMOiwWG7njWZymYqQpHGE4KzAdhZoIQVhn2JfCFfC9/MWknEFeGXQwzM78KMiAAcwCVY2xjuDP5CgSjvUABniIVYQfDrckH0gMj2bBkVYTbCO5R2XMC9ppgxBqYIvgYn3pDc+nl4RgEmE8hhJOhCarBQwT3hHzJ4JhWgn0ELwr5ksFAKsGuCPOHrs2JrhnArgTbAswjEVMBdivBlgiv4W5vlketNBwTEebjOBEOqsAMBJhRFH2WwjGtAIcifANHf9xjkgpwV4A5BxaCrUmYFsG2CBO8MiUw0M562BRgRnEnMr4queXhmApwH4UQPXJcCg5BgHmhGIbD8nBXhG0ArNjyPCiCbRHmdRdhGGhp2BTgWLqIzUNXGx3MqAAL67lF2CkL90GAQ665EtgrC68JMDp/IX/dsrApwm4x7JeEGRVhm2u2JNxhSbgPIuwUv+2AlYTXEGxJYV/e2IgSNhFM0jVsCZy9vTRtK15SbhpB3NLCAUUwTdewZfDQmYRJlGslbRXcBRGOH8rWsAFcz95eChD2Lz319FN7Nz6+ZL1y5rvLl+586NKZxT1tJbyE4Z+na9gSOHt7KcBwe/ne0WOSG++ft58/+PT3lzdPLB9c3lTCjGB4O1vDBvCj9O2lCeyNPp78rY0Di97y9srKD25u/6CzPKSWAu4Dgtl2toYNYDt7eykAS+BTg40D824CL3sHl70CeFEC/zxdw5bA6dtL7weIt5ev7X//lZ8e+Lz//PbTK89vnnh+e3kbHDkcEwwPX8/WsPG3lzoj+JFL17514nc/d+Afo1f631155eZDr/RX3qeCeyCBPb7h1kQbi8dtup32I7EKXtTAb+RgksFDDg9BHuOYyGDFgyRt2fBAAfdAA4cCgTsLeR4vymHdA2hU1wkxIoOZYiTgSTEqg2+ABE4xfNau7PRjKdzSwkCkz9RohgrfoHKYaqYewNEMeY+BFAaKakz9VEEoMZipgIn84TAmgyOJccOSwujBJVxPA44MJERLBTuKRCYSzcVEj6pgW/EeTkv2HRQTcyCHhVIs5REMYyMgCliImyv5GBZ1FcdACUeKt6j6sue9cIHV8FBY3IQKygpa9JOggsW9TUBerG54gamExa5wDRePlzPEBVbC4g96RX95jo8KXAjbIM9kG/0GFxW4EO4qXqXuoiSzUYHVMIocvxz4CCbodR+FMFO8Sj3Ao3DhlrsGBiLEQnBUN7VmQQcvTRYE5bQtzbYO1cKuuAZJAD3J8B5YC7RwX1yDJECeLCkWQA8zOrF6JSDCqS8Ys0jomTqYBzOegx7JVx+jmdExxbcxz0IZeG0XyC7lPTpRe3PpdobeCaSF++M8CzKK/0JG0mFcH70TSAszmp1pTPJF9nlTNCeSZwb0cHYYX+TG52IDnuUXOcADoYcvxpQvcuOtNTbHVRZCTFAg9HAQm5OL3GbHQWZZhgTjg2agNBzf2eKL3HJp2ud9nOnz12WVh+Fv51IRSL5hMcofqLBTp2NCBbg3y4TJrrm0VjPPJfwOcwU4MEKhQ+ikt8naKdDjAa4GPyZekIyd7ZROdhwGrQrvRZNBswDxE++bHFGtmlAN7hlZ6KJ8B8bM1YnrSacFlWG8yA0WCJvj/0uTKoaqsHxRhfH4DD8BwifuK8GW5IrJDOOvx0CbGVAVxovcUJ0CfNugU8LBPXCrNTnuY8ZcsvnNweNU6NK0sLDIDTCcbN5eaYMN1WG+yE0Yhwcz3s7maWG+yE2EiZdsPveZEexVh/kit7NoAZaXbD738mu0KiwscgMEJ5v3vrSnXQved0sK7xu8vF4TPiuHz61s1sqKt3hWcDjZPL9yk6rhdsmWRxUv9nXqwujxnZqwpYOtqnDxeMBHxyOEVOuP0QWFqGBaBONFbuj30ClhF527fKiODRUsgAPFYUwJQzGsWuTGByRTwqpFbhYOkVALGjimeQjPObnTwkDQBFkKatpHpIMt+Vs1Q10a+zp4Tf4tlVH+hxQeFMJ8kZshAib/qRT2CmG+yG2hJQBr/L9S2C6E+SK3hVkB6KXjJxXsFMJ8kdsqCrKZ6fpeE8N8kRv+CnwBku1KmGphMGCBSmA2wwcIEqIY5ovceq2iV25jgoEejnEi6z+EZWH24WqwXxr+m2qwWxaOWTXYLgEz3L/pYasUrN5Vn2162K4CMygPu/WyTQ37VeBuBTislxRqmNVLCjUc01pJoYaB1E0KDFdOZL8kXDmR10rBMVROZKskXDWRY1ISrprIAVSCWd12h+GqibxUDQZSL8QYphUTmUFF2KkVYgxDBnv1QqyG3XohVsN+9SzWw4PgEHw/AYbxtCHGMEngqA0vl4NbpeGXf+/4u397z7+eeSm++8evPnwp+udHilxGS8MvvfrlFy5vnjp4/uiVT3zy8HL0ndNFcB9Kw89cOfzC5V892Gkn7z04/JXo1HNF8GJ5eCOBo22v/QcJfD46dXqqZMPwawm8uXWw/cyVfZ/83HL0/pMFcA/Kwz/ce/zsh/dsnmlfv3v9z//h0jtPPV8Ar1WAtzLA1vcXsVkB/lkGeHq4BxXgAZTvLBarwD6U7iwYqQJH/IMOvgFV4JB/0MGtSjDLgKHODWglONZezPiAvhpMsw+1khjDQDKY1kliDuO5Bw08VxV2eNHrVB2GbVR0KXAMqsIulPkuxMzKsI9iIgMuQGU45DGpU2AMMyjxJasD1eG4xJesuFUd5mk2qFVgDuNp6HoFxrCthTswFezqenrWmg72dT39KlSEBXBYr8AYjmlxT/8kTAkDKezpA3Nq2CqEZ2Fq2C26hHTI9LBfcAlhczA9zMYvC8HKKtSAY5KtrVklqObqwGCNFyIeQzVXC17zs44mIJOBoPXgfn9EUjx6CVpQD2YPAFxE460k6jVhMCiYeIS4SmvDq2QM8jTotaA+bPbRwIjNQn14oYWfJlyAJuBZW5yQ6JhNwMYMEXrn3hw0Aa8aPAEIWDzANWCUZVbc4vvUhkMO2EELFkhTcMQBt9NaNaEp2OfAYMFoQWOwy4E3jDloDvaEe5INwr15uNlamptrGLZh0IatwfxjFIadJmEHBi9c3boVJTDMNQufPXfgFoxgBtAo3Dty7ovv7s62GocHg4cPXE9C0Th869zW9m2CD3jztwN+8+rWYGmOwrBRGD+k13yTDm8XHDUKD3AP2nx/3AyMA+s1CjOUILVhNLCxGoWB8E/NwhYKSj0YRzZsBsb51m0YDlDR68H41glpGIYlXvJm4RsoxHVgfMug1SjMh4492jzcI/ypqUZhWDCZQW8HHBsGgWZgDPyCw7+E/x/lljzSQxVrCwAAAABJRU5ErkJggg==>>+-- $graph
+--
+-- The following graph describe the differents way to convert between pixel types,
+--
+-- * Nodes describe pixel type
+--
+-- * Arrows describe functions
+--
+-- <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAABAwAAALbCAAAAABbY00HAACj/UlEQVR42u1ddVxUTRc+dwtYukERRVExMFHsbuzu7lbs7n7t+LA7sDuwOzCxGwtFBRRp2Pn+oHaX3eXG3Lu7MM/3e/3Y3TtnZs6cee7EmTOACAgICBBCQFRAQEBAyICAgICQAQEBASGDXIqEsGfBF4KCAgMPBgVdDn4ZnkxUQkDIIFch8emRFaPbVnS3AHVYeVTtPGHtybcpREkEhAxyOKJOz+5QUgqUa6X2Y5ZsPnL16btfEREIJUdE/Hj3+NLBjQtHtCznAGBWvvuiq7FEXYQMiApyJsK29i4hEhVtMy3wWbzOB//d3zG+aQGQlh92IIqojZABQc5C8oXxZSmrRtNP0+/dYYfGVzcVV551T0HUR8iAIIdAcW2wI1V24pUkxiljTg71BI+Jj4kOCRkQ5AB8m5kPyi3+xDr9symFofjKP0SRhAwIjBs3O0qdJ73iKOTuIAvLQS+IMgkZEBgvbtWHSjviMQj6s7KoqMsrolBCBgTGiRd+UO0CLmEpe70kvcKIUgkZEBgfYqfKyp7FKTBlewGbtcQdiZABgbHhXmHL5UmYZf4bJ6n8nqiWkAGBUWGVSZMvPIh9UsbuBFEuIQMC40FyN/FsfnyF4vpTc4h+CRkQGAsS2lif5034Jsl4omFCBgTGgZSWdsE8ij8km0h0TMiAwCgw3YZf/+GT4n1EyYQMCIwAp8Unec7hPzlxRyRkQGD4iC84jfc82jYgeiZkQGDwWFoogfc8vlmcJoomZEBg4Iix25G1SQEAsjYtpP0C6Q8pP5v+dPonVUwsSzRNyIDAwHFA/k9zk4KmrzO7vfJ/aX+ofKWKZ/BM5fMPonhCBgSGho5tkFYyyOjfGQMFyMIK9MgAec3I+DPlxgQoQRRPyIDA0FBkji4ySO3ioPRRhQxojwxQl5ap///vUC9bkIEXUTwhAwJDg3wr0rVmoE4GyssJAErfqHyZFWN9EEJf/tdISkkBAJoQxRMyIDAwJMAR7U2q1MEhc2SgtKKgNE1Q4wR1zCn0YGZpSixO5Q6qM9E8IQMCQ4PDOp1kAEpzAtUVAnUyQKpsoYqI0iqXr0iaXgp+843ESSRkQGBIKDuJHhmAKhmo7yakk4O2kUHjIgDSDDKQWab+v3WewuVrN+3Q33/6ooDdR88Hv/wcSVqEkAGBnuDvq4sMtO4mqPsZZI4UNK4ZJNpuUgS1lUrSycD/x7v7V08Hblg+d/zAbq3rVSxRwDb9N+v8pao37TJk0sKAfWduvfgWQ5qIkAGBMLhNhQqQy1npL4TQj0UeqcMDk7kanon79e7RjXOB6xdPGdqtec0yHrap5CB1KFS+Xpveo2Ys23LocsjXONJkhAwI8KF2lcm7H6QFQVaUmyRAjq06peV2qYNUQoHJUlqpokKfXDu+c8288f07NKxULI85AACY5ytdp+3ASUu2HL32/HsiaUxCBgRcUAJMRCDK13T81rt/0Xn5Z94zvGL6IePvX/8VAljHSkzi9+fXjm5ZMmlg2zql86VSg1WB8g06DZm6fPuJW69+kpYlZEDAEJNlqRt8JiIAl5oORZ/wnF+U51hVbuh6EIPUuK8hlw9tXDi2T6saJfOYAABIXEvV7zJy3ubjt0PJldCEDAjoYC+lstFnNoTf7BRNvPlfBvz36eH5Xcun9G1euaA5AIB5wcrN+05ZsftiyHcSrp2QAYE2hCjt+EPzNxclS3nlggHWb4StX8zH28c3zxvZpZ63qwQARM4l63QePnvD0VufE0jjEzIgSO8nt/83oIpFmiMgiCifGwihjaJ5/OWY3F1+SY8VDn92ee/KqQNaVi1iCQDg5N2ox6SVB66/J7sShAxyMcLPLexUTAyWVQav90zlArHr7tQA6TvEg+N5yjXSz+qqgSggLvTm4VVTezYp5UwBgG3xut0mrDxy9yuZRRAyyEVIebVvkl9egLx+k/e/VSCEuooBQGo2J2OZ7bBVBX7cDe55uN8zPIUkfrlzdN30fk3LOgOAxK1K2xFLdl97H08shZBBTkbSk81DqliAuFinhefCM75dJAMp1fOb0nOvy9htxH+NSsJMk0a/DFo/8e+v7V4yom0VNwkAOJdrPnzxvptfFcRuCBnksPHAs+3Dq8rBrPLg9ffUdtpOA9QPURtDj5JUC8FcgoEmVPWl+29+STYGbX27e2TlhM5V84kBZAVrdp+y/vQz4gpNyMD4oXi9a3QNSzCpMGjjY023qX7x1BCg9EEFSd+PGAvxsBnlDCCjAMTOFTqMXn7wjlEEO0sKvbZz/iC/klYAYF+2tf+qE8+I0wIhA+PEu8CxdaxBWrZfQLB2Z12N9y2nbC0oG/gBFxW0oXxOoZHpHg0imQxgsFEpMirk+NrxHSo4AoBz5U4TNwS9Ic7PhAyMBr9PTG5gBxLvXmvusNs5S1yfX9z8HPcpc+Le6lD6iAKhTDYAAPholFr99+TYipEtSlsBiN1r9pq7734ksTRCBoaM5Ef/61EEqCLdVtzgNNNNPlibKjLnLbdBwVhXSduLaR8y2UDaw7hV/Ct4/6LBDQtJABwqdZ256xY5CkHIwCAHBHUtwbLe5BO/cYh7NiovVFzK0mlQ8WBGUSg6XensUwYbUK9yhLYT355ZPdKvqAmAjU/HKVtu/CIGSMjAoAYEPQIe4Vuyjx1o39sRPIeeiGKYMGxvTxfwGPtA9dtRqWwgyfcsJ2k+5eP5/41p6S0HcKjaZ9GRV2Q9gZCBHhGJd0CQgSclbPailOB5NSSi4r03Pabnzv/v7spOBUHeeKmGK1bT2KCouHdozmuF0KA1Q+vnp0BatMW4Tdd/ETIgEBoRR0eVE2MeEKSN81eYVkvrs39Oz2hkDZJi7WbsvPZJWz4Jby9umdCsoAhcWi24qmXZchQFIG2SstPDzD+H9paYB3tndipnAWBfpd/yoG+EDAiEwa9DI8qIRKWHH+JjBeuHn2Smcr9PeXlgZrviJgCS/L6NuwybvmBdQEBg4J6AgNULpgzu2NAnDwVgXq7bguMfdEkdRQHcQShhhaPN6qQc3DSfzq8ZVtcFwLb6gFUXfhAyIOATPw4M86bEZUce+c2P/DMuBW5oGi58u7VvsX+ZvNVLFLS3tQUQ29o6FSxVq3WfccsP36fDSaOhFEIIoegJsuI5/kLmX1fWDa7tCGBfa/DaS78IGRDgx/d9g0tQYh//Y5F85ZA4nuqk4zKDBt3Zix59Ie2PN62g0cvc0FzhF1YPrGEP4NJo/O7nyYQMCHAh8sAgL5D4jj3J58UjoZXkW3T97rAMSzaXysqm5BoH37CgZT3KycDUp9+qq38IGRBwRNK1qZXF4koTT//lN5/D9iWf6/r9I1zDVKHlloXO5qYWTHy0w7+uI4BHqxmH3hMyIGCJN2taWIHHgAMRfGeUMIrqo9t38aAoGldmX9pCx1y35P7l1Pz2XmKwqTf+wAdCBgQM+2fQKE+wbrFGiAiC730sdmbzyBxPjPmd8LDZmhvbNOb2ur5lJODQaMqRL4QMCGhONje0tgDviVeE2Ynbb1Mm21W9Xo1w5hg7UtQ0t+7Hx91a1aOEGFybzTj5nZABgW48nlGekjdd90moOe0oGJD9McfqmE8gX/O03ZGL2zj62tIuRSnI127ZrXhCBgQakXJjbCFwH3JSuPC9X6pb7KLxWF7cAdVjhola5nL/3T8XF7VyAZMq/ofCCBkQqL2jgwbmgaIT7woZhe+SS1E68c5iqKPYs77s7naZNHro7mHlJVCw68rgJEIGBGljgisD7aH83OeCZqpYKGlLawP8FTzAn3tkG/H0ZNLyCP27NKeZI5jXmnzyLyEDggdj8kH5JUKf6/vTUvIfvWHIbeDlgtZ1ZtVDSeOn8e3W/iVF4gpjT/whZJCL8WFmMSgyXXg33ceFXelecXIa/vFShJASDheJAWQg4tiosmJxhTHH/xAyyI2ID6wnyjNaH3eN7JLXoL1wtUPGUyFiOkmWESNQmTwdG1VeLPbxPx5JyCB34dkoB2mLE/qYOCePhdH0l6xWOvNWkCXiruTqwyyE4F9eLC4/9kICIYNcgsTdlcFzgX6cbyIamjLZ55/vxV9RguzLfSLGkAVRx/3LUhZNVr0mZJAL2H9BPkmHy3q6zCvEMx+jmcn8QjwW5p13nsfEHjQhbFsXRygw8HAUIYOcjLfDLGzG6O2FeMiiOrNQPPPd+SzOnzpW54lJaEZK8LwaEkmNOXdTCBnkTLzqJCq4XG97yopp1ECG8Xz5JQOU0EW2g1iFVkQfGVgIHLsG/iVkkOMQ2ldSbJ/+vG3+NDNZzzTNan7JACnGUYuIYejCm1UNZaZNAr4RMshJ+D7cxGObHh3v3pVwvcE40VoXvou1ippJbCMbFt/XyVpUecELQgY5ZQq4zjrPWn1uGF1zKM/iLH2ghHf62kBNI+aR7Xzq3GA3KDr+ZgohA+PHs6qS8XoNAbjDpBUbX8KbwH80jk2iKcRAaMyo7k0uCc79g5IJGRg3r0+TVXikV0OaCBNZvVQ+wU3+S7dZPInYCC28XVKVchlxm5CBETehj/lyvfJ5bFvZFnYpkySBApRvCzWfWAlNfJhXCgpOeUbIwDix26qsfq8i/lre4SrbtPmWClHC+aKjxE5oI2SSB5ReGErIwOgQ04capt8IVw/dvN6yTly/ryBlHCS/TUyFwbTvxjBnqtran4QMjIvFi9kf0W8Jjlk04BByfUI57U0OAIDJEJKbO75hZHepWUPuNcrkMz2spe2CUggZGA3+Z6rvKB7rxAO4xNU6IIvV0eT4zCDGt8hfRmSgIffcZpRxO2tSheaHETIwCkS2FU3Rb4Q7xURqHicBv0RBqS9ilPo/lPZGTh0SpHbJjG9TBwrKT6T/rfEJFTMKc+6cZllqSZQTpQvJzDlNioZxQq7AC38HaZszKYQMDB4PC7rqOZxPQnfZNo4ifMandzek1AmVOrNy11T6F9T/zvKEmhkFidejDHEqWYFKIjUZat/lOsTvqU15zPlKyMCwsUNeO1y/JfhbzzKIq4zpRRFS677Kf6WZAgAovaUzf8n8XukJSLchVSuaIn+iOSs1MoC0MYIKIaVLz414PdZJ2vKMgpCBwSJxOOWv5yDYX0vn4e7q9BQeZU8Gau96jSMBlWmFJjJIrlHsHx0yUDJAFULKxUaZsK8uVSwglpCBYSKsmsVePRfhWf7iHzGIKTkiY5qANE4TkOrvoD7xz0IXql1YibwchiKV+YVWMoDM7p/bpwkZpN3X1GHyN0IGBogbeQo/1XMRrtjWwHKL80qb6IwFRKRxAREp/Q7qC4hq6TKf0GBE+0TXlZgmIwkoiVVdLMz1C4jKCJ/lIuv1kpCBoWGNrFmknotw0LQdnnijkRYrWTQ/sDKiFl7xxLLYI36zl6jtfUIGBrVc0Fc0U6HnMmwWj8C14TQ6TywvZKDhka/Wk4llcUHKgXLQ6CohA4NBVH2LY/ouw1JqBjZZPyyEC0a0XvqIGBA3nK0J9W8RMjAMvC/h9lDfZZhKrcAobZrVF6EKrqhVSUFMiCMuVoWmwYQMDAB3nMt81nMRFEPF23DKi/NsJVjZQyS7iA1xxpkKVJs3hAz0jf1mzaL1XISkrqaYz0ZdoP4nWOkHuccQK+KOY8VlQ38SMtArFlJD9R2WKq655QXcMmfIrgtV/HCbWcSMcLwSAlxtFscSMtDf+HyYeJW+y/C3lv0d/BVr6fhcqAosMf9CLAkHoiebFzpByEBPSO4pO6TvMvzyycOHt1NMbSehbkJL8OxFTAkPvnSAFh8IGegDCW3lZ/Vdhp9lCr7nRXBMQ/sbAtVhl+QNMSZMOO9lNieBkIHgiGlsfU3fZQj3LszXVkZ8G5MAYSqRUqwrsSZsb6j55t7BhAwExp8aDvf1XYYfJYryd7BdMVs0ME6QauwVvyT2hA3vakkmxhMyEHiu/lzfZQgr5sXrsbVjViUfCjI08O5MDAoji6+zLH6PkIFwiKrg8V7fZfjmVYzneHgfa8nmC7Fzul/0nJgUznarJ12sIGQg1HpBdTe9h7H/UrTED97f2UtMfe7xXxVF8T7EprAqdLG0QRghA0GQ0MBZ7wvgnwt7CxFk7XlN0eBI3nNZL/tGrAor7nk6nydkIACSW9k90XcZQguVEcb7VLHNyTmA73huCa6TiVnhxd/OkqWEDHhHSldrvV8H9Nmj7C+h8oocKit+nOc8ZttEE8PCjKWSrnGEDHjGIPllfRchvEjZ3wJm96Y1VYtfF6QIDeGVCDjivL1PGCEDXrFMekrfRYjwLi5wUPZb1aABr5e1DylM4hpgx/uSBV8RMuARx8Vr9V2EP76ewodQOF8NGvFIB0/hHLEt/G+Nmo53CRnwhifWw/VdhJhabnrxcQiqCtVP8Pb+rtGKGBd+xLWyOE/IgK/JukdjfccvSGjsqC/v3at+VMltPJ2D2S35TMwLP5L7yy8RMuCnI1b2jtJ367axeay/3EO6S12m8BJ/IMFpOrEvHqDoL79KyIAP9HZ8q++27W6p333NL1NdJG0u8jBbmJAvhRgYHxbTG7fFEDJACKGdEn0fWlYMll/UtxYS91SD4mv+4hb7giwh8jSW7OH4hpABbry2nKfvIkyQnTQETTzqb2455BlmoZVIWAN+kFSnaBQhA8yz2nL19D2QXSvebyDKiFxWBCoHYLWx/8n/ECPjBVHedRIIGWDFCOcwPZfgqP59HJRmLEFdzMy6BOHbXIkwXfL0XlDQscDAoKCrwe+JfzI+fHAcS8gAJ46J9O15eFM+wcDeOAGVIc/4F5yHsSH7Fw5sUNQWVGGSt0KHCesv/Camxx2XJGcIGeDDN/uxei7BE+suhuey+2qqO6fpwouAfj6mIPGo03d2wKGrz95HRMQhFBER9u7eqR3LxrYpZwPg3nzaaTJM4IhpGIe1hAwauSfotwCf3eokGKJiUoK6mJm02M2iu375X0dXsKs/bvfzRO0P/Tq/pGtJsaTy+ItJpEuzR3KNpoQMcOGwWM/HlqO89e7vpL1sWxpJzdruZ3Sfz6v5FSnb1iue0BrsRB4bVY6y734olvRqtgi1OELIAJO55xmp3wIk1HEzaHfdX+vrii06HVENy3tDW/yi6I2VId/QIEbv+s+r60lshgaTbs0S/7n/I2SABQPy63fWquhi/cTQdfR9TQ2RdfeTSnOZ6nBU04PvB1uYdbnCYv3jx1JvKLebTBdYIanUBEIGOHCVOq3fAkyQXTAGPX1Z6ktZddyX5p2YKAIYkOWO5WddJB6rWc94bnaWFFyXQLo2C1w0+UzIgDvii3bRbwE2UTuNZm66oo7EpMn67wihiwAg8Xyo8vPPwRLvXZze7e8GmXoeIl2bBWoOJmTAHUusvus1/+uy+cakrl9bW8pFVRe/9ZcBgET6X+aEIGWFjesmzm6coZ2oWq9J32YxNPhCyICzcdvO0Wv+nx27GZvKYg51twOLVOchUZ30Le6PtWSTsay93ConX0vCpDFG1RGEDLhiZL4YvXassr5xRqi1pB3proRS29R1xMNWJR9gEp44ReIXRXo3Q2yzjSNkwA1vZFv1mb2ivdsXo9TbCkk6G4iogbEILRINw0hqt91KfCTdmxn+We0hZMANbcrp9bDibLPbxqm3+qLMcwaSwo+HS9ZhFf+1vAu5oZEh+tUnZMAJ16nz+sz+iPFsJKgiNpMJZCYAIMYdieFfEzcyNmCG86JfhAy4oHoTfeb+xHKckertBIDYIk9Rnzrt+o6curCLaAr26+BianiSCAiMEGe2l5ABB1yFW3rMPbyQX7KRKi4yXOkkwTOzTTxkEVWiG+ngjNCgLyEDDmhYV4+ZJ9YpliPWzJPKdOZFbohpIOngTLAoPyED9rgL+gxAOsLmTY7Q4ro8kfwIXuJOXJMZLRpABCED1mhRVY+ZH6RO5AglJrjzda1qXN61pIczwGe4TsiALR5TeoxG/N56XM7Q4mZHdQcDAADIaleQ9gukP6T8bPpnFSwuQDwRmcBqIyEDtuhYXo/v0/JVE3OGFv16aLQn0GRmkPG78n/pv2RJ8hbukx7OAD7jCBmwRKhkn/4yH2ofmjO0GGu2TxsZQHoXzxgoQBZW0EkGyGs26eEMUL8/IQOWmJhHf5E0DlAnc4gWn8NT7WSQygeg9FGFDLIbGaC2bUkPZ4DWnQgZsHylOejvtfMupywYIHQesvi9Ka0ZqJOB8nICgMo3GtYM0IhqpIczQA8/QgbssFWmtzgGCeWr5pjwXocgSZs9KfV6ANX3P81pwpTSpIczwKBqhAzYoWx3vWU9xOFTjlHjDfiqgwxAaU6g1PXpkkG/esqfUshNzoQMeMEt/Xki788xCwYIofdwlw4ZgCoZ0NtNQE17ZEys9o4pADGkvxMy4AMdffXWfazH5yA9KvKs0E4GWncT6PkZJNttQAh9PTKlnhVQMiCX/RAy4AW/ZFv0lHNyZd8cFA88JqRZA96EX6N2z23uBGBCAQBARdLdCRnwgZWW//SU82zzHHEk4eetXbN6VHMFyC/jy2PiuzsAZAZREZNTjIQMeEHZPnrK+K40wKgVl/zx/PrxbctaAUgLNxry39GQ2DoDecrqk2yQhYjKvLh5ELmAjZABD3gE1/Q0rPZqaqw6Cz27ckjjIjIAyzJtxv3v/Pv0WAzXpTxdi9a2Hkra7JZBByKg8tUZsPjoc3KWkZABToworKcjMEMdvxudsuJDAud0Lm8O4Fil+8ydt36o/97fi5dl/i3mrxBCievzpNPB9sML+9XKCyD2qD9k2anXiaT3EzLAgATHufrJ+Dx1xJj09PvGxrFNPcUgLuQ3ZsN1bSH2/hVpx0PEptvytPlUwlpnMQBAmkPDv4f75/aq6gQgLdx45Opz74nzASEDTjgk0s+tx9EenY1DQSnvT//Xv6YjgHnZTrMCH8frfvqJdT/sA60ntpnrhfErHcUAJiq//7m3Z1ZXXzsAs7Kd5hx4ToYJhAxYonlD/eQ7xOmnwevmx/mlfXzkAC61Bi4/+5FeJ78q7495u/SOS3Pl0UbsMjvNbga/b20a61dQBNJibSbvfhBLyICQAdPRr2y7XvK9TO03ZLXE3Ns0qp4TgFPdURtvM4ugddayAdZ4jvvNWqktE8Ys7q398dgHuye3KSYFUUG/sZtuRxEyIGRAGxtN/+oj23+FDPZE7q9zCzsVE4Hcp/fSoB+sRvXuRa9j64Tx4ymLoXcYJ0t8fmBOp7JmAHnrDVt3NYqQASEDGqjXRi/ZjnL4YYDKCD06rbk7QF6/KQdeM1uMu346MGDJDP/+7RpU9MorBuiKaarwuJTl6lleUGTWW1bLHe9OLOrtaw3g0WLagbcKQgaEDHThu1gvo/X74h0GpoivhyfVtwNRkfbzz4SzSF4JQCIzkUnT/AD85cVPYyhUeAlR4bsIoXsjnKnKq1lfEhR6Yk77ImKwqDLwfzejCRkQMtCCVZb6OP6WXL6uAb2mos7Pa5kXRMV7rLzK+uKivZnXLYLU4z162woahXAsV8JqBzsAKDz00C+UfKqLhbTZXg6rgjG31w+uZgUiz7azj34gZEDIICuqddFHritMXxlG9ZOCV3XzoiBfm4UXuS2dJDhk3rhY4RdCCF0qK2rJ5WT43yV5TPwjTwKAjKKKjzr+J3pnI7F1z/OcfAkU7w/NaFWIApuawzbciyNkQMhACZ+o43rI9bPlLAOo+98z0+pZgG3DKcfCMEibkj5DEDdNe32nHKkENXeyfJe/GGVn6f8VITQh1clIBqJy48++X+4Decc84lrWP9fXDPA1B0mpXmvvxBMyIGSQiiW2+nBub11M3yYYuntwaTEU6bHhOabpyvcxaUcKqYFKPgGX2plYD73J+F3+83+VodD81A3N5MrpLAMyMP2LXkz1AO8FGA5HprwKHFfHGqTl+294kEjIgJABqtxLD5me1etNbujDpq55QVrZ/xC+kxHBPUzsK0kAACg13+7wpaXBtf9pBuODt8tqii26Xskgqa92mSeXtyGEkOL6IDtRzS1YVgIVr3aNqmEBppWG7XhHyCB3k8FX0THhM030aqe/Cu/s7QHyBvOvYvTPS9xbBUqtjz0NACLxNg29e3FVkaza1KDIbCUlP9/UzQ2c+h5Xmc2fSycDaZOMFYoj7Uwsel7BNKpJfrptqK8MHJvPu/SPkEGuJYPVFnpYRFoi18+dKT8DB3uBSc0Z17DOjMLn5BW3voQQSskHErOzWrI+ONybAtdWM/fdU9ofVFqyTHx7bt0AXznYNFsanGVWMS2VDShL5XCrv1eVh0Kz8Gky/sbSdvlAXHrQ1leEDHIlGdRtL3yeYVZ6WD1MuTujgkhSeXIQZo/9+z1N7MZ9SP17Idg80PHo79ay1sWkANal6nUaNmNhQMCUgYEBASsXjOvVvEoBMYB93VL9QjSeeEyuKQUAoBqrjS2ejHKiamzB6Tjw5YB/VTNwbrP8QTIhg1xGBr8le4XPtIeH0KOR33u7OEKBwSdw+10n7qsG3usz/DR+en/Q9fR+aidCSe8vbJjSv1X14h62tiIAW1uXgj6Nu45cdOB+JEIjHLS4FX13EANIa+Yt9FC9BEdaYpwupMm8/V9ze7BqMu96PCGDXIQtJsKfS7hLHRY0vwdzKotldZa+wD/rmOcmbqmyEqpzTf6l1WDVL6IA1IYpf/Joiz93WQSU5dcfteRZ/TZxTxcQQggpQtZ2zgtmNaZeSiBkkEvQ3E/4PGtVFy4vxc3RBcBtwBEeXHDfDJLbjv1A//mYEhXV+tVaAHVa3EPd0JJ8LsAWhJLGwEQNo4Ano5xE9XZiP7L8fmsfT5A3XHQ/hZBBzke06SbB8zxO3REop5Srw9yg5IzHfMi+0VpUcCWjlfdODuovb29K2lP9qfqltZxvUpT2SR3Lydpq6vSJR1pIrXtfwe/iHbqpsws4tPvfW0IGORyBYsHDiyQVF2ZbMfnCIBcoO+clLyxzsApUDGS2wrZKrL7PcB8AbNWFvDZZqm1S8i1twmBXUfM5qh9LvaHQLB6uqlOELGtqCQUGHIkhZJCD0UP4e303yIR4xzwZ5URVWMCPF03MWk9R86sME92SZdlBGSAFyBqWeprFl2xEvfb00tbjH41yEjc9ysc+QNL1mZXFpg1XvSdkkEORbL9E6Cz/uQ7nPY/fq8qD14KP/Aj/Mc3BtD/j8UZ4vsbqI/h/cgCQjVF/Mi77wJBhpfJrLUBiYD1R3qn8uHGE7+hgC8XGXkwiZJADcQ1eCJ3lAkueJybJJ9uZWPe/yZP0l/1NHaYxD8qS3KDAb/XvNosAAApkefYwle0lFhGVnXUcjn47wUXU5DA/PTbpyriSYN35cCwhg5yGCYWEzvGv/RRe5X+bnIePZfU03Ggu8lzLZuI81STrzSoVU70Ks9JxA59sF+//1XHWNThJPNBQlGfyB5608GFNPbFlxwOxhAxyFEqMFDrHOdYRPEp/3EPmMpM3T+eLtaHyQVabbIHUhizfPUs7bTA/yy9PJRuyX7eo7qb7jsr3k/OIGh7k6yziz/X1JebtA2MIGeQYvBX87GCU7QzeZCtO1QPvLXz5zClOVoF6LNX1UD4s65ejUs8lUz5ZfxruGJmtzD+V3LO57CLxcGORy0TeVmt/bWgolXc4mUzIIGdghbXQp9in2/IVpTdufXGq4Tm+IqmlHCxL+bENWhTuVidrl0mwTjuISGU9Rh3pOIIGr3p7ZxuhLXRqXlH9QN4a+ffm2lSe8S8IGeQENBD6IHGkNU/3uCWszmPS5ylfxU7aVULU5gHrslXx/J31273pF6iKNcwJNkhp9LDPbs2zfy0nH20qdhrP3633b6e6Q+VN0YQMjB1Rsp1CrxjY8HISImljftMRvN3gmrCxkKTrc/bpe1k/0/BtaTAxkUoAAEpoGIiUaUJD8BPrQXTy/zQjH1V3L29HjlKCuphZ9LxHyMC4ESj+LWyGsU6T+BB7qZRsAG+XRcatdpf14TLxXio+oakLrVwweXx7aNC0poOPhmH8eThPQ/QZMT1n8uQTzcVOkz7x1q5RAeWh+qEUQgZGDMHdD9eY8fD6ft8KGvE2DI5e7Gw2jBPRnBUv0vpbMGj152tSjk7fmm5Gd/LydZqruPV5/oLTX24u8lwZTcjAWJHstFDYDJM8BuMfpC4zx3JXiUbELHKwGMONv15bd9X+4xXQ6r70VEzn/svkhgUj6ZYkcU81KLb6D2+t+2aIuc34L4QMjBOCux/ukmA/K/CikmwmX+ft45a7WEzgOJGKKuKrI47LCdB+7LGvO50AMD/dOjEozcN+csshz3hr398L8pjxt3RDyIBPCO5+WLYzbolbzH352kJIWOdmNjqco5Dkhm5fdfy8R4epfTNfQGsWQh1iUqDI/wpTdQ7y5huQsDKP+bhIQgbGB+/hwuZ3GTDHMYjtKhrP05mZpE0FZMO+cjdH+V1dP2+y0rUeYE3rEEdfJ2ZnPVJO+4nyL+Gtw8YudXBYk0TIwMjwDi4Im2H7SnjlhVV0OMtPSRUHvaT9MSy+r6V26/x9pauOH6PpHe/86854vPV2hKXlUN7WXCP9ZWXuEjIwLgjtfhgqwevV8NyjKE+utpd8qU44+spR8XzdD8z31PVrgOwDrVyo64xL9meph6gZb++C13XEo/4RMjAmCO1+ONkV60rfC6dq/HhJPGwEDR7gEHRbnp1P0IRSOqcqhejddVXPh8UOf/LBGlBqM0+eSIpNtoXvEzIwHvwx2S5ofrEOWI8ovXGrwsuu9rvOogp4XplvHLP1Fh6u21p3SGjFUAmRbGVVwOBuMqdp4fy09rfaJisIGRgNjoiEdT/cIf2Gk8q8KvBx4inSX1ZkPx7PnHBP32wP+PZppPPnlBId6Bm9cyS7MoZNcTQf84OX5k6ZLe6ZQMjASDCitLD51W6FcxzaxpkH95akNfhWwmN8C2a/496xje7fD4poXb0e6TyAdTH/c5aP5sc14JRl9V+EDIwDZUYImt076jhGaYskV/AX8XRxmX8kJlkJjRxpLEH6dcuG88o3p5XbbtEN9tO3Za5mI7/x0eQhBbzDCBkYAyJER+gpAQBAXScsNDQlTxJdtWcv/aXJInrtyKDwzxpBqzd07SM7uYou1nR8Kmpmt8J4Gm7TKlJLNw7dOXZFXrPhX9h2FR2q+OxV+CMuWYQMeF0yiKDfNYGzhlLyTUDYyEBRvWIyTeuiW/ifgyVlLzGw2mzkjpDRWoT0GZ/dE9Xq0SpSlLcvlwhkcavcTId+ZkkGOlTxo4znN1yyCBnwuGRQBlAqDacyMkKQRswIANK+gYwGgvSG0sDddHANQlCm9Iy80suQ8VLIlJ6Rr1KyNGySPsr4Jj1ZpikpZ0Cz8Cn/c3DdlJI5FOIqd76Y3m22xbK9jPoy0Luf4aNjU0532cavyWeS9VgBZ1WEl/D+iU+thAx4QrkRap0RpTZGZotk/oEyf8n8jhmGllQVly5RW46aC5X2Hss7BmUpnfq/gFQE6iz8rfKS0X9UR0Kc5K6i1tLTinv2t1bUakhP1H2nOtzixiSsdrWYEJGlI3BUxWdP33hcsggZ8IRks+3KjZGpfuWuCWljBKUBHGQwOLPsXGapvfDV8lLJUcOD6QMEhBBabvUbqY8fMuWB0juGVuF/9hbVfqbe+lzkbqLm01SLzbpsHwkCmjGEXrj7cAwLHbvIwWZ2NMKpCoTeOHZRIJzNRcgAO95AcPZkkMUiVL9jgAvwmhYZaLJB9ZFBrPM0ndalXN7sC5+02sZtL6LTA+jK3SOeRlct0l3ZP+Pbgqawj972XAM7/J1h5bg0Fp8qEELoWuq1cpiai5ABDzgq+gdAgwyU3tNchm7DS2uYdSCVVQtNOaoUKn1ksMEqSvO4E6lWRsW6tBX+elnZ+OhsxsbM5B6S+NMemcPR7B86Tj2hKS6mp2hCHEe7+DVOnvd/CZhUkYot4svYZBEy4APzPZTWCzJWakBp3UZ9OY/Tok6BqWpLSBlNnvZdemkgY+SY9mVmodJzLTck64qU8rsk8xvIrvA/e1INXupaNWMu95RsKG0PxkgIyv4hRemOtNW8xbIoZ/+Lb8NkBbenYFMxQqhHnnBssggZ8ICufkJW84m27XIWZbgNuMKZKLY65N2PuaanTHvR92YOBTo3Qu4XvaIt8bMf1ZuzA9HH3pLi+zFGS/xXrLFCL0ZOyIAeyo0Tsppz8yiwqbpvVUyFelFLNBx3RMCjsl4Mogg9AzozgBSvngxKsNfdYg7nSxBfdhCVP4nxXSBfQMjAgOG0WsjcqvbFJirJYTkWOXHTZOWxx/o/IBvA5B14F2g56O2QfGAgNHaORd6VnOngcTOohs/jO0B6j5CBwSJFtF/A3P5K92KTdZ7CckPC+cIWy7EH59ojGcJoPHwZaB0gTio4jNmsf6Tc9T/OV6Lergv1sXVhv7JJhAwMFT8EvXH1uOgnNlmDfTEICe8KLfHfurJDPJrZ3PgE0OuyKy0imZXk+xhzp0Wcwz1cqEy1xRQ/+6P5EkIGhopn8FzA3EaWwyfLcxqGXuuQ7xj+Wi6mxjNMsZui91y0zWLGdDfB0n4m54AVR0tI+uC5h2mxxUdCBgaKixAuYG7e47CJ+gyXuIoIbSwagv/Gx+QhIsaLGRusaT44xp35KPv3NDvzkRx9ElHKtgJmo3EM65LKNCVkYKAIFAt4Md5fEb738A5Tjm41Kasti17DX8eYFmYHGCdanocuf0l2sCjTv+Xu0u4hHCuWsNLZaiaGAHN3xAcIGRgm1lkLmNkFjMMQru37vKp0Cg9RQH9UdGARXmSmF90nu5ZlVazEbSWpZlyDu0bPsnZawT2CWZ9CiYQMDBJrhSSDuR74ZFUeyiV14mwTn8c81PCae6HXLJL5014MfcB2dqQ4XoFqzXV08HOMWf6tXIeSX8xWEzIgZNCqIzZRKeYbOaR+UMpsMQ9bXIoFkpaRbBL2bUD70VotWJfuaGlR55ccq/i5r6TEEY4yxjn/I2SQ68nAZRk2US8hmHXapJnSmu94qF54E+lSdu627drSfvSIiP2tLorAYpKeXJ2UX7ajKnHbjo6wnUXIILeTwSe4gU3WCWC9DxBS1mwZH6umB1082F4m1qAP/SGR5zAOZUzZUcCas49VcH1oyOlmlAVWPwkZGCIZ2AiX135pHDZZKx3ZDgvmm1R+zUPlvrWmekWyTVxpNP1nl9lw8imMnSIrw/mA1wVfqv0rDmVwnUDIwACxzlG4vMaUxyImJPBgUFAH7/vv3n1j3i1e+Jou4uEe8pT1NgU5XL9UbCaDQbbZJm5lfVXFbDXXw4OKw8Ul/dhfWLHA5i8hA8PDXrFwedUcgkXMUcjAWqZ9drGZzzMeanarnGQ0l/d1nmUMHu5RkWNpk2ZK2nI+wJS8xd1sLNu7USKtFhMyMDycg0jB8rJbh0VMnFkGGUQwS/mmmmwuD5sI37pRdbhRjMVmBg/fAM63wV5zqszd4yNhuaPNHJZeSGPyJBAyMDjcg3dCZfWTuwNxKtpKUqlA2p7Z0HalvMwj/NVKWGjhfojjWxYOMnm81EDOhX5bpAiGW+miZ1i6rGLVq7/JNhMyMDi8A8EOmF8HTLci7qXSBgbnmKR6X1syjQfXtxOeZrO4jrl/04l6lok1Fty9gn97e+O4r/bnKFOP7Wy2ZnoXVxAyMDREMetRXLDJCpOgv9JULnBlYIWKAMuSwfjr9LUltA/lLOU9MNqT/GPxPwwl96yDZaQe2kvizeLEySO4QsjA4EAnSDcejC+PS1ITMQCAdAr9FJ8aSMbjP4mg+J91ofMY5DwCZvt0fcpiyPSN5SQ8WnjehqrCvGdX7ETIwOBQdI5QOTXvgkvSZhEAAPWWdoJt1l638VfofXXJuFgcgq4As7vQ78EdDLn+T3IXkyLu1oUmD5m2oewnIQNDQ9NuQuXEZDNdN36JAUBUhfb8uC01MhZ/ffbblH6AR9IxYFi8cv1xjGvql8Y2bw+qIOrIzE06xmYhIQNDw+jKAmWUhDH+YU0RgGgLzYfPu7kF4a9O3CAYisuhcqeMYYKVdjjm+8+oo9jUoTjgJRmYeeyBRvisYYUVhAwMDGvtBcroNTzEJmu1GMCM3pJ6/BhR29/4a/OqjM1BbMLWMHUD/SE5hCPfJrVwkv1Gd7PxaY4fFyD7WdljuEbIwMAgmNfROYjCJusrBdLetJ58WtqSjx3ty3a+H/BJm1eIaQq/NjjyvQQvcColbqmDzbwYhJDCG2yy98LyHkTIwMDwEW4Lk9EWM4zCfCha7xXFStPKb3moy06TtjgXIcYzjhO72wQHhStcVuDVy59pFq5rE9B+CiTO2Qadnu+QSMjAwOAoUNyZhYUwCvsP8tKYcYY1kszkI0z/bGoM1jPQg2ozTRFjuR5Hxp2a4VZN+AhZoe0FRQBSj+wcnj9SJwgZGBiadRcmn5FVcEmK+fzkGDQ+Fxh4ICjoYvCzb9ocCA47FrrFQ0USe4nX4pXYuSXjJN1r4sh4ozX+E5yhPaQiAABpuWyurIuu0PBOUNDJwMBjQUE3g99HETLQP2YXFSaf9lynueFXts8Z4FfC1QTUIc9bpvmwhXtuq9jTv37Qi4+DsgmtLE5iFunHnI/PUTiuH7gGYfgVFOuQ6i4uqaFxyyPq1q75g/xKuMjUW1Hs6FW/z8xtl38SMtAbzlG/BcmnBvsIPYnBawfWcgQwLVK3x/QVO07cfPHubEQkQikRET/fPb12dOuySV2re0gB3BqM3PwsdQR/t4j9QT6qEd/U6jpumdWYqyY5zzwMGb+GB/g1NF+c1rslLdTGHe92jW3kDiArVLvH9JU7T91+/TEi4h9CcRERn9/dO7tnzax+DYuZATjWGbopJIWQgR4QJTojSD6F57JK9veIfzUzcKgzeM2lbNz0UkLPLu1bxQqs60+58G+OtN5XPmoR28gG/4JrqSnM04wujiHjv3AWe2UiLDPf9f0zFnYUDxa1cgGzCr2XnP2ke7Xnx8U1A2tYg3WjmVeSCBkIjRIzBMnGnPkWX8qdWTUkUt/huxkcs055uqlfKZGZeYunfFQipq4dD8ed8i9inuYBhGDIGfCfTJmgNPKnUsObRezt6QLunVYG0+7dKc839S4G1m02fCFkICiGVxMil7/AcACiuDnKDYoOPcbmuG74nu5uUGw6dj6Irun4kAfd2ASwSFRoNgZuA/wL+kuaepsBSNKWBP5D0buayeRNlrPwaPi8oY2dqPran4QMhMMZcYQAubxlNj39PN0dSs3hEHQT3RtXAEosx1q1P1WdQ/jQDcXGUXu0D/eMv/HkBfgpaM3Q2i4UiACqyE1a7mUdEi7pdHdrid+pFEIGAiHWLFCAXB4Dg5jEZ1uJXSdz9o5T3BlsbdYbX/CWmMquvFxZ/RdOsUh1heJ+l/wLeMJjk/+7MygPyEdz3DOMO1Cf8vzvDyEDYeDXU4BMrgHdBT3FMR+qzn483mnRAWWhMSZng4T6jq94Uc1nVvdJJGPwFrvG5x3cSRsLyLpi0f2rYVZ286IJGQiBFXkEOD92CmiS+7lyVIv7GDM+WxUa4JjoJ7e3vs+Pap4Cq8WNXvU557zSmb8G31dINuATLmGRUy0dOVz+QsiAwXT+Pv+ZBNJT5qd20Bx31NLzlSTDIznPOQbIL/GkmpvAasB/RMrZaa93I76a+10jqscHnAJ/jZeVuUPIgH+UF+CCmy0WdJ5abeF5Cn/eik0OLsc4ypggOcqXak4DqxlxrJzzvmDZSfzUSLHMrCT2pcmXdUT+iYQM+MZ/+fmfJ6xyoTEYbCWZGs9L7hG9qVGc4oEspHbyppq9FLt0LdtxzDheup+XCv1pJ5nDw4lExTarSqGEDHjGJxH/cSbmZ39o8YVH3qu85b/LqiKHDeud1Cr+VPM/lvFltlpyZM6zYl480T8U4asdX5e0v0nIgGfU5D/OxMTS2T1x37HOLx4L8NrLi/Ve3DUZnxOpuZ4sp9Fijo7kg2vzUZ1X7pXC+FJVTAfLy4QM+EWAUxLfWQzLrj2CrVrE81qC8HIFWDq3vnFsw+c8akwFlgl9/bkNu92W8jEucK0VzZ+uknvJrxEy4BW/TU7ynUV27fHDrWMyz0X44+vLim6iSlaI4bNcfRqwHW2V4ZTvfeAhClRMuTq8KkvRz+UrIQNe0a25nskguapvPO+1/O7Wh83LqKHbZ16L1aoDy4RBIk7zqsml+GC2Ajzfh5BQrUoyIQM+cUsUql8y2OD6RYBq3jNlMcYcIufZDaPWYJYJY00OcMg2Ke9/+Otyw5R3n5Uwlw2EDHhF2Yl6JYM/ztsEqeYEH8ZnXjZSh3kuVOkpbFOyphGEEDpkhn8vQVF5FP+NuMk1mpABn9jgmKBPMphSKusKHQAAZG0FSPsCUh9Raae0z1n+ziQdmz0My/3AbAZrs6FpP26s39CzvTi0SP2e9CsCAOrV0Vi5o/Lf9NtRvQEhy/9rbsTkIvPwkgGteuYiMoix2alHMlAUWKyliUDT1+mmpfwf0vG3Eno1ZlbsqEINk/kmA3PWNzvc4HDL/RvqNqOKAJ03Zbs2TNox87/0fyCzgZUbWg3Ti/NFBjrqmYvIAI2pxDMZNNTx4234qN2IIMNEAFRsJPP9gZRePWkptNjRaSmjsbGiVT4N5/rSCgJpWUNGESDz7QLKBUwtkVIyZcQD63lIouUO1g3iXw5lFhvUqoMAAKlWBNQaQlPniLXYw7Qd077JSgagndGfML38ZRCGeuYmMvgqu8AvGfjp+HGNE9JlRGmtqGwooDq6U7ItVbNSxw+4xKTUS2Q3kJZ3GqT3JVDpU8plVSEDUOkQygticJm1VhuzPn0ebrEhQ1NK/UCllGraBg2VU8VDTXfLa29HUJ76gWrLgo7hnUK2kykZcK9nbiIDNKCe/shgoqYrhZTmmupkoDb0VHnRqE1H1WG6nUGhr0mXaR1VKtsRZDEmAACND6a/kjLxHNiHZ1vszjblhPwJSJ1ZNVQnrSKgzK/KlVPFCYhh0o4ayCD9H9Cx8IOQxyKmZMC9nrmKDN5K7vBKBjV1/Dikjo6ZnGrb0CUDLS8V5LqSfpkj87dVsCSDbB5Unfizj+N8Fz6wS/jT4n+IFhlkqYjqd6rYI2PUjtrJAHSODFDZydjJINt65ioyQF1a8Cl9rK41iVleuo1Iqb2ykIHGNQStdpQoZrA13zlfpLb1JlC3qswpqYZpAqiYn9rb7hiwv7cxwXQPu4QT3BMyJ1TZdBJQXY3RMU04Dz+ZtKPaIo9qy+pidOeVTMmAez1zFxmEiEJ4lD7ZW8ePWy0U9IwI1HkAqS09ZWdHH4B+TMRdootaVp+VFxAzjBnSX2mZ61Hpi4mq0wS1cm015aDWKiNYJfuVOjBQmkerVie9/GorodktIL7RFPVWRzsCyjJrALVlBk35xDN1/RiEoZ65iwxQ27Y8Ctd5hPmz6LouI1JfhUZqU0pIf9kqb1trnm5uoH/1b6jNWPrV42Aqy1w5qHU0uxssx6cODHBbuCL/EobtCCrLi1nHfBob8bQ0gjEZcEYuI4OXUh5vZ1+eT9ev1YYLVMd6/eg+mVK7TIIgpjKtBIf67DNl4yz23nQ9PxY+yleIRuzN9GQXIQPmGFCbP9lrrXX9uts+UpAaPpM+pPvoEtNnwmh9WE0Oid/DXTZjwFI8nRB9LhUgnOZP60NMyYC4IzPGN/lp3mTv0jkzVlQZJUgNG9A+tvjabJlAWu/Yiktq2/XM01yEi7y9T+ryr7Dh1REhA/4xqXQKX6L361bmXclpAeq3zIpuDJ6UalVSBFJ6vb5cUrM4q5RcpjVvlflutZJvfZ1jvgdOyIAFouy38iX6BPzV+ftk69e8Vy9ITNtzbYXpC6GUXo5TSLWRzFcQ15m+568222Q8x9P86DAeETIQAiuc+Zq7XwbdN6qnNPN4x3PlrluPoT0Vt1gomM7dOIUV2GLBdAQT6TiJz+oM4+Vu2sypbLH6yYQMBEFSSb6W9Z9BNvcURlV1DeG1bqflXeiakaJuhWTBdG62hUvqh8B0RDU4bzSf1UlobsujK2uoZ1kWkZQIGbB7gUt5uoozDLILnx3TyO4ojzVbJRtE+x26RfZEMI1zvBY9TnyEWYJron38ViihveUBvmTfyufL5l5tQgbs0Lk6P4GAE7I/qJvQnxrFVyDEyJaSubQf/mk/WTiFhwI37w6PBczIw6sF3zVKHkaNSuRF8iqpH6vLpwgZsMMXy138CLbYlP0zu61K3+Ql84P53Bjc69HdM044hQfDG07pmzA7xTzJWoBgk/ssfHjwN/jYVLKA3ZuKkAFLLHHiJ7ytx2IaD72pR/XCf0v4m0ZUNwZxhC9SQQLq+xxEcko/qjKjJQZpgBCVelldMuIvXpFJC82LXmeZlpABW6WX6cKL3PL0doQC3aym4L1Y6cMAmTeT677iinQVUt+7pNzS/8+GyQi+fC2FILVSbLJ3Xh6LT17KziJmM1mH6SRkwBYPJcf4EFufpm9N9DwHy4n47ud63VfmsYHRfVHT7MKFVPcKZ27pLwID7lxk9kaoev0cI8+zCtN9Kkl7i4u7c7jxhZABa0xyi+JBaifaXrfRC52k7S/ieIMlHqxHFdrM7Oq4FyYbBdU2p3NKCKF3EEy/bmaLBKxZ2Agz29EYLm36PtdN3OklFwmEDFgjvlhfHqSOYNAg8burQdFZLznmeGdMHnGz0wx9chQ1qysE1fbgWhwJT3yQ7qMJ5X2TBa3br4Ueoobb/3AyxqMdTBzGf+BWDkIG7HFTcha/0AUFGT3+dHQ+KD3nMduOmXRznAcUn/GJccLNJs+FVbam6OKMQN+DcYLFG6FNKeVYGzOzNoEsh5oxZ3rbiOtv5by3Q8iAA/xd8V+OvtOEYQLFzRH5waXbDsYXvylermttDSWmsYkzGm4/RWBd1+3PUQDtWBCXxRv1YUx/tjcxlVSZdZuh60FKyNIGpuJqK79jKAIhAy5js1KtsMu8BD+YJ3qxqqkFuLZacJEuOX05Nb2RLTh22MTyrtSuheME1nVpruzThWZbReZvpS97ijk51BPMqo8/THO4//30zEbW4NJzL6YL4AgZcEGI6QbcIl9rio9HZ6J7e0WnggCOtQavOvZIu3GE3Tu4pG9laxCV6L3+MevTx+eo80KrOs8yjgJG04wu1Dnvb32a1Ifdw8pLwNK373+H72v1ZPkTcnz1oFr2ICrWe9NzfGs3hAw4YYX5K8wS4+A4+8Q/L6wZXMsZAOTFqzXvMWrWgoCA9YGBewMC1i6YPryrX5XCJgAi9wajNtzgtFoVU6in4Jo24Xrl7KJCtB7bJTzPZUHs3U3+DfJRAPLi1Vv08p+7OCBgS2Dg9oCApQvG9W1dy9sGAJxqD153BfN2FiEDTlA0roD7Jla7/3Hmk2CrITOGd/Wr7FXQ1tYGQGRr61CwRLXmPUbO3XH1PQZ3+HGOv4RW9B/guli7RU7rxWw92lBsK+Htxa0zhnVp7Fs4v62tOYCpra1bQZ8GHQdPXX/meSwfORIy4IYwpxGYJZaaylnEZLsoPuv8ULJLcD2/Bq5e/KeAhmtPYpVS8bnXmAkZcMQZyX68Ahv34irhhzmvIUeSyjcUXs3X4RtHCfeAhmOPv/lzRMiAkAFbTMMciKw/51iZI1xj+KzwXIv3wmv5IHCd3ryn4YJ4mNqBCBkQMmCN5PplsE7gFhTgKCDUZA2f9X1qsloPWl7nwFXCz+wvln5nPQARMiBkwGVUnrcPTnEHxBzfgX08EnisbVL5ugo9KHmGF1cJ8ZDdwbL4cuXiCBkQMuCEa5L1GKU9Am67lS8l2/msrF4mCQgN5n5xjSy7Zc8B1u8QIQNCBtywHGfc679wilP6DsX5PGXzWLZWLypu046zCLtsSr6LOoQIGRAy4Ipejp/xCXNexSX1A15NOrZEPYVeNFydezhqd917LM/NRyNCBoQMOCOhUjl8C/hVRnJJ7efDZ28dZP9VPxouMos7GczX9WtM8aoJhAwIGWDAN7eO2Ppgt6YcEl+DczxW8wh1TE8KtuF+CKSwLjJQtHX8hAgZEDLAgTtm83CJmlGcQ+KaNXms5Bf7IXpSb3z2EeSzhbcuMpgtu0yMmJABJuwU7cQkaZcsiXXa03CTvyom1/bW19bbJ463JiCEkLeOyxqPi1YREyZkgA3zZRfwCHoErF1iFT5NeazhOPlTfSmXli8xezJ4Yd2HGDAhA4zoYYsnWlacmPW1W/tFj/irXyC1U2+6PQncF2i9p2n7JapI5QRiv4QMMCKhjiee4OGF2a6cJxfvwF/1QsxH6U+3m824yyikbc0guYnbN2K+hAywIsrbF8sGY0u2XXqL5DVvlYv0rJWsP9Uu8OAuw13bXVUTTW4T4yVkgBmf3RrgGG5O8mY5NPHoy1vVkhvnC9ejZkdV5C7DSYsH4j5qCzFdQgbY8cSmCwZ3A7bbCatM+dsqHyQP1qdiO7fgLsN6ncavH8lHEMMlZMADbssx7MSz3E6IcRnJW73mi4/qVa91BnKXId2j6dvvbnWSid0SMuADR2XzOcuIE7MKnjTf8gdftdpJrdWvWovO5CziL5zRxKC+nr+I1RIy4KvfcHdfKcbmjoAoW97uNbkgm6BnrVpyv9fkA9zJ+qWijeMbYrOEDPjCcmoTVxFdGrNIxF8U1CfWXRT61ek/OMFZxgPQ0O0n4PIUI2RAyEDz/Ho3RwlLXJmn4S8K6hu3Ovp2yWF7s4wyzmu4k30z7CT2SsiAT0yjf+GvlmE5i1DAvEVBfetWIUrfGr0E3K8SDJSkGN70h5BBjoe/jFuwogjmwY54i4L61s1H71yA9khSOMv4L1+WIY9NRwUxVkIG/EIx1OQ4JwEes5mm4CsK6rt85SP1r9ClbtxljKyq9kW4p28MsVVCBryzwRAZp5lC6zYME9CIggpsmuu9e/kIQxhqVaBXMwBQr1/Gp9ZqTt4JNQqEE0slZCAAG/hL9nBIPrsgwwQ0oqCyIYN3+csZAhdk44CoUjPQ9mOFsaot1MX6CbFTQgaCYKKYw7XBp4DZS+sBdQghAEBp/0LGSzL9VZn2OfPNmdpx0h9MS6yGYJfyvw1CmTAwrTZq9UMAgFRrBqmPIdXaIoScV6qInCA+R4yUkIFAmClif5vCb4rZmoOfjyKjJ6RRgBIVZPyS+QhSf1BTM56zbBBtGLpUIza1YqvULPMX5doiFKW6KLsW1hITJWQgGBZQ7O8hKzqNydPX4Jz6C1+ts2S8VQE0Ppj+plXGTllXQwn5ARuVGUtD/dJqpjQ+UK0tQjfgo5LAo+JZxEAJGQiIZdQitkm71WfydM2aiB4ZKDWXpgdVsIQaYygbb//gZHZkkKVmqt8htMlcqTa35YOIeRIyEBRrqTksU662ZrCxnhoFNWvHV5omgKZpAqj0KtWRgWIktcxg9PgagAYZKNcs6zTB3ydT3hvH5uSkIiEDgbFRPJldwmCgH3s0PQqqygJiepdI+y6dGCBjSJ32ZeY0QaUZo1vJ9hqOGi/B94y1QJX6pVdIbWlU0wJik64Z4oiDASEDfWCHeBird1CSfAvtZ3VEQWXbMm9KOl0xIC3uAe4OiC4ZU7YYX0/iYEDIQA84ZNaW1V0D1QfQfVJXFFSWLXPGtpxBXS+0lLuFfYL0S1KSm5NTy4QM9IPrdjXZ+O2Mp32tEvYoqIoF4q5xBqXDkZU5i9gvTtslVXSRk/CnhAz0hGf5S7J4zR6nftJ7EHsU1H8dJcsMTIUY7mMflx5kdoKeA7gRMsjV+FIqXwjjRBGiw/QexB0F9X1ph/OGpsEK/pxF1Ey7Mmkt9T9ikYQM9IfI2rbMl+NK0esAuKOg7rEu88HgFOi6nKuERPPUuGkbxPOJPRIy0Cfi25syvjFtaAVaj+GNghrdixoaZ3DqS6AOchVxC14ihOJHwQxijYQM9IuUEWKmYVL3SeicC8AbBTW4iIMhTqjfwV2uIua7IIROe1ruJbZIyEDvWExNYObc+w3O0ngKZxRUxWJZ3a+GqLvL3IOeNe6A3rWGtqHEEAkZGAB2mrT6xyhB4UnZP4MzCuq3+tIFKQapuh0mXA9JJFtN6igucpZYISEDw8A1pzKM1v0H0NhcxxgFdYttobsGqrl5hbjO0lYBlNlDjiMQMjAYfPB2ucng8b2SP9k9gi8K6seGopH/DFVxA2tzSv52qjslPUPsj5CBISG6uekO+k//pI5l9wiuKKiK1ZbFbhqu3vy6sU8bsbUOlWdq3dbE+ggZGBZSxsFE+tPy0tl5ENCIgkoLr2pIJscbsNpKsTz6iX4ENJDK259MTrFdQYyPkIGhYZtJS9qRxEZ5I4TCD2l/gEYUVBpIWGhW5qFBK82WldPgi6U1xVadD8QghB7CI2J6hAwMDjecStPd3zpBnZ1eBjQqd38kSouCyhnnvMzmJhn27ApOMk5yZGABcOl9Im28s8I2hVgeIQPDQ2hpp2t0nvu9t5MJSAE0Bk0HmP8P+flwD0sW2hpafTRwjT0DRjHN46/MqCWT1Jj3IFM7rZsTuyNkYJAvupbS7F3ttziJKQkAAFTR8GsigNh+JHCO9R0/x6zwaYNX2FmIpD3luTarjhl49jug4oqlcFhCzI6QgUFCMU/cKbuFg8uQDj8Nv74EABBZbuW4ZHDS02JeguHra4MVrcfCj46vbgYFe2//rP7LU7hHrI6QgYEiyLHkq2wemShO5QJRFw0/HgcAAIry3M9hovCwEbQ3CvfcaSWyeyI5JKBHERCV7L9NY4XWWBF/I0IGhrtwUNHqsO4nEstIAQBAqimm93+yNKaAimw9hUJ7iSpcMg5ldfPTxQNPtw2vZgGW9aad1npKo30TYnGEDAwX8QOpCbpfV6/MAADAZIKG3wamLieAGE6wyz5yolnB3cZyHXm1YZq/T3qyZVgVOZj6Dt70SJcuFc4LicERMjBkbDGtoztG70YKAMBkroafqqdygcScXQjjhBUODksSjEZTeZZl5YFHm4ZUkoO88tDNj7PdFw0hSwaEDAwcDz3y3dL5QEspAMg0xUFwTuUC2/ts8k3aVtBsTKTx6CmWOqL88efFVQN8TcG86rCtIfT8I5YTLwNCBoaOiCbSJbqG6r+dxACa7nKOoQAApC4vWGSasrOIpLdRHevPcDOIurl+eF1nAPtaI7Y/ZbAk2IwcTCBkYPBQLJA00TVVuEABwOGs3z8GAJB6sHAWStlXTNL9rXFp6QRExwZvG9c4P4Blpb7LgsKYjoSsVhNTI2Rg+LiVP+9FHT+PFQNcyPr1fgpAWoJ59B/FQW9Rl5dGpaCYh3sbmniKwbRstwUnP7AScRNeEEMjZGAEiGwtnqZ9xJtQSqRp8WueCUgqMp71J+8uLWr/zFgUk/Lh7Koh9dwpkNrbzzrwmoOjwBw3YmaEDIwDa0xrftH64wuAl+jfi9tBpwMPBV1++DW1T/QEST2mEY7iAwqJOz0xBoVE3N42qW0pUwDHan0WHn6R0KIzN3m1uhEjI2RgJHjk5aDNW+BjYA0oYgGZEOepPnDNNYDWDDcG/y7JY9Lf0NcK4l8cXtinmiOASam2k7bdTr+UznsyJ6mxJtuJjREyMBZE96RGZL2s4Ofm7vlBWiLvpM0nn4RG/EVJET9eXw9cPqyOI4D5lBtMdst+Trez9P9quAqIuLdvXp/a7iKg3OsNXnHmvWrdLDZyEn4OPhMTI2RgPNhpVVI1+sbvlXXElk0X30lEv7I+/bLZ0BKQZxBdh6Pn/U3tZ/w2xGorPl3eNKmjjx2AxKPegIUHHmqa+/yAS5wyGe9F7IuQgTHhQ3WTRZnvwxvdTK17HdV6s1EyQujNQl8otlyzN36C0hqEIqgxVXRtjIFVN+75iRXD/YqZAJiXaum/9sybRO3P3gJu8RZ8BhPzImRgVEiZL6uV5gp0qSZU3ESj+z4aZGU9XcNt778L9MyYhW/2htrHDMf/LvbZqXXjO1RyBQCnyl2nbbtOw2dgt5TTkcMI8UFiXYQMjAwPilvvRAg9qw11r9FM8me2nfUSdZfc1wUAUqnk82RnWfeHhlC3f09PrhnbztcZAGzLthyx/Mgj2oEg0VxPTlkfFEUQ2yJkYGyIHU51+DpW6nONQZo/U81Kqj5/2UoCom0IKc63FrtM0fOqYWTI8VX+bSs4AoB9+VajVhx7zPwyuD4NORVhiA+xLEIGRoizTo42axkO6t80Fk9VGhxskYgARFX+rPKCanv0dTAx9uX5rTP7NSxuAQCOPm38Vx1/8pe1sFoDOZWl0ARiV4QMjBBbTKqx2AYLkFdPv5VdMTHVHYHKa95f+ODgSZ+u71k4rHk5JwAwK1q35/SNZ55xv6XJfRGX1G/gGrErQgbGh5nUVFZrZSFFPVP9iWJbi1LJQNolUrhiJ4ZeD1zm37FKXjGAxL1a53Erjz74iU16TPb3SunCCutEYliEDIwOw6RsXeV+V3F+jhAKKydJ91R05P8mhL/PgrbOGdysvAsFIMpToeXwJftufMEfa/AhcDpZ5deWGBYhA6PDbBn7oOWxTdw+o6du0ky/5WM8lTLlW/DR1ZO71ytmAQBmnjW6jF1x4OZnHqlnj5SL8FizDcSyCBkYG7aLuVyPFONb6pi5ROkQQ2XMFHD/+PoZA5r55BEDgL23X98ZG06G/BJk7sTJgfAsfCGmRcjAyPDGciWn9BFOAFKpVJTBBt9xU4BVsdpdxyzbc/VNnKCK6cTpMqTh3sS0CBkYGVJ8W3ITENxd1H3BmoBdgSeDbgQ/ffclgvW6WcTzy3uWT+rpV06FAl7ry6O53Hguqb3GE9siZGBskwQnzieJZhfhMLn++/Lq/pVT+zSrmM8EAMSupRp3H6dPCsiExSYOid/BRWJbhAyMC3Hua/QgI+btjcOrpw9oUbmAGQBQziXrdx29ZPvZJ98NKJjwJ7jOIfVaS7KxSMjAyLDWFYPRrs5DZ2gQ9/HW0YCZQ1pXLWwOAGBfvHbnkQu2nnr4zTCvZT8PXJYp/VoS2yJkYGQoj2NqG2GmbT8x/vPD0zuWTuzdvLKnJQCAtVeN9sNnbz5+77PB36Syxp5D4niLAGJbhAyMC8/gqQalAgBkVS6k/qRJTPt2yh3hy8PTO5ZN6t28cmFLAABZ3tINu4ycs/HordA4I1LNsKocEp+DUPq2m6puyNWGTcjAAF5/jtqUCpq+Bi0qX+345dGZHcsm9WlepbAVAIAsT+kGXUbO2XDkxqs/Rqqahr05JB7pzcB2NWmVkAEhA6HRtYUOMoB0M80YKGgjg4dpBFC/y4g5G45cfxWVA1STfwGHxB6TU3UI6WpMe/mnj7kA0r6BDK2qapuQASEDoVFplE4ySDNkpY+aVf4Xlr6KzFmaiREdZZ/4IdxNHf9nEkLaX0ocq0QDGR9VviNkQMhASBSZjXSuGaiRgbY1AyTbmdM085jLbUgz8ioyx/+g/JcaGUDaGEGJaNO+I2RAyEBguK3QoVRV89Q1MkDWqovnOeDu4b0SDnuuZQcjemSgpG9QWT3IdWRQh5CBvlFymm4yUDJZXWSQQu1P++PdiUW9XSHM+DUzrTj7tB/hHFKaJugmA8js/rl4mtC5JSEDfaPWYJpkoHtkEA6Xkl4dmtfV2xRAJoGc0CqtOrBPuzwtrknmegFSGltlrBGqLhbm7gVEv+6EDPSM5B5VdJKB+m6CljWD0B4glgDIxGnnFqvnANV4zGOftnZnYp0MUX0oIQO94e/JyX5FrSiQYfEE7AHKkI3IAfqhTrBO+1scSKyTITznETIQHopX63pUcJICgMi6qN9I6RkcQquM3OSQGeBEPF9h9Gq6ScOFUBu2mvwldsYMseKjhAyEZIGPQTObFbWiAEBeoPbwXanG3rY9BtHP4QmKnizLjH1m12j6qd9Gra21duzTtmxCrI0hHsAbQgaCIP5J4Iwm+SUAQFl6tZh9Qzl26HmTb9wzGF4NIYRCu1CpowPq0soungBFuq66a7TneAfVZP+Wk68nNscQ281SCBnwjIibm8Y2dRcBRYHEo+V/wRoOCtXrzzmXDyZpJ/8fVAMRAORDCKGfJ6Y1tAHTKuNO/zNGzVUZxjrpYVEYsTyG6NsAETLgDaFnVwys5QwgtZSCSemBmx5pe0c/lN3iOv9o2irj70P5xUC1yPjlxdZBxUFWbfrleGObU1luZJ22Y01ifkzhtpSQAQ9IeXNwTtfy5gC2RYo6U1Ckx/8e6b5SYLgHx3OFq60+ZH5IWGIBU1R+/rarT0GQ15t3O8mItPge7rBN+s/8f8QKGeIJF99vQgaa8O3cf7185CAq2KRXl1r2YF5r8rHw7FPFlWrO6QKSK6a7VD7/9s+6MPxhU1dXsGq6/I2xqPKwmPXkZrf0JzFFhphbGBEywIXomwFDa9sDONcbtfHw6s6uYN1sWTDdN/Fzm94ctgKfWA+mmc2aNnZQZNT5BGNQ6MyirJM29yP2yHRSVmgBIQMc+HJiXvsiIrCq3H/lhZ9R+3q5g3mjBXcZvetvyweyHhs8cGEwrki+Mt4bLNvsiDR4rbZlfTdahGw76d0MEST7QciAG5JCdoyt7wjg0XzaofcIodf/1ZFKas26xnw774xFq1h2ZThn2ZThm/7D2kYmskYBPwxbt56z2abcKCceR4yptz0iZMCeBx5vHlLJFGTleiy7FIkQQokXRhcGx257WYYYuutU9hWLZCkLpH1YjCn+7GpjLq652oD54B/7yCZ1yX2rTPFaeo+QASskh2wdWlkO8spDt6ZvFyYe72wNpSbe4LAO+L6ixWbGib42MGG7IxR7uKu1uOE2Q42PeBves0wZxuniytyJjq0QIQPGeLdzeFVzMK00ZPOTjNXBlEv97US1137kKDpxrKj2c2ajk2VWhbkweuyB1qZmbY4YpI/iake2KZdbxZHezQyPJE8JGTDC3wtzmjmCtOKgjY+Udwnujs4LFZd9xfI2LCcb/pD23p/iUAmTqbEcs4za3EDsNOqJ4Wm7azO2KSv3JL2bGRR1eiBCBrRn5k839SspBvf2y26oOvJ9nlUYSsx5hy2fNVbUAHrD48TA0qJCvuEYMv26wBMqBRhaNGXPmWzHbtQZ0r2ZYZNtGCEDWoi/OreRNZjXGHdI/TxR8tGmYtfxjzHm9bIKiN1FjQ5nO3D/ONlV3O7Jo4L5sKz7KK70tDDrHWxIWv+VFraMOWY5J5HuzQhhtpsRIYPsZwanJ1U3gXxd1jzIamC/F+QTNTqIc76dMFMqhl3Jx/xEtl0P69gdezbPh8oz7RNC6FcD0y148o5eXwYq7TCc8wunRCyHKikFyEXsDF8FTespCBnoxo+DI8qJoVi/7RoXBl8OkNuM/Yg1w+uFxQAm/xBCX9fVk0gqjgl8loWCfl1a0c4Z3IZdTNu2SJ5ADcbFR9c6yhwnfTIQ7U8rxjJhEPWS9G9GmGf9HhEy0PGePD6yJCUuP/Kglo34R+1ERdfgPRccNZASA0jTb0yMPD6mohRkJRr3nLokYFPg7oDVc0e0q+oC4Npu1RNlIj9gUfUbrjKEzcor7WoYi4n12a4CdqhOujcjXJBg3InNaWSQeG16NYmo7NhTWgfqd5tSZQ9ivpfgkKMUAIBSbpjEp3un92ri7W5rCRJbp8JV241YeSHriuGzInlu4Kv8dm+q4UUDGLrasTx3+MtkG+nfTPDZeSwiZKDRBp8s87OAgv336Tj19qYDVekE5giDX5qCCAAAzFnM2iObmmA8sas4XRvK79P3FSwv4RG7hMusY0gHZzIg9a6VTMggK2KO9MsDDu3X69wo/D1EVhy3g1vKanla7EJpD1bpp1N9cC79BbcXlQzULx1skbPcEvAeSDo4E5v39ca6p5wzyODjmsam4irzHujuA4otDq7rse9cjcoMcc5yi/yYdcXPOEv0rIOo1CF9xlceVINduttwj/Rw+khu7obVbnIAGSTfmOgN1h22ZxsR43k18TAenHMSBqRzgTVbonlVzOky1jKFtBOVOaq/Jik/jl26/qVJD2dgeG2tMS8XGzkZJJ3t4wBF/S9k3w0Vq8wq3OdpVCwVAwBIB7GW8Le1dDneMj1pQ9W8padGiZEcZJUu2nIV6eL0uaC5HW5HM2Mmg+TzAxyoqv/ROg4Q1kAygzfftiuWUgAADm93xVxxO8wnEG/VoDqF6qVdrgC70etm09+kj9NFbCPHh4iQQSpSLg12pnyX0nSzuZO3yB3+yjLUvqoYwInTqt1Fl8KPMRfrkKfMP1IPTbPQnV26st1JH6eL8MouzxAhg9TOPcwVfBZ/oPv4NtNmPJ78vyvemjyOgtHcpIRVl2/BPZJc4+CwVfiVxMbsOvUleEA6OU28KFT4LSJkgBD6vdIbvOcz8MJcSE3hca8tuVwtBUJ7gevQI2k81TMWc9kih4mrhwjcPEmW7EitfS3SyWnisl1NPmZURkcGiktdTK37M1o6mSHezGeJVpu8QAghDFHMT9iUeY27dPcrSMZFC9pCt+ADm2ShkiOkl9PDcmlXXg6lGRkZfFtQCKpsYXauYL5kD59FinUZg03Wex+rQNzlS1ln435MyDaaX4BVsjHuyaSb00F0O8lCfuZ+RkUGt9tJHUc9Z5hot+gAr4VabBGOT1j8YBiFPY7Zj67QQ8DoJw17sDJxm8Wkn9NBiJfLJZ5EGw8ZJO+vAhX3MB4e3ZPP57VY/5wmYZW306IS/g3Bo875zgnVTonmrJYMVlpEko5OY5a8Wl79G8rlZJC0pbCo9XXm6eK8+vI8KLbCvJTzooTDWeyl/NmeGiTQZc7svAxSPIeRnp49vjaUTOcvFJRxkEHCBg9pb1Z7KeM8+e0DKfknYp8TdhFNxT99DnQoJIxH4sSSbFIdE70hXT37RrQrcptH8cZABooDnrIBH1glfSK9xm/Zzok+4BcaYFo3HLvQ702kS4XwOSjnz2qhoQXp6tnhS0tqIK9HvI2ADG5WErH2q23TgefCdarDh9R7HnnxxyhRLJC05H9e/oNiszrxgLpEOns2Y9DVVp7n+c3C4MngZy+qNmvPtGfix/yWLkLtOnVciGwj5mGqcDWvB+9nhHeYsdkCb12V9HbdeFRZOjEW5W4y2OKQh8POe/96PBdvkzVfDbTWtDr+8KbhDXCGVdKIzmwuVH9CnSbdXecrcbCkMv/hLQ2bDH62FA/ncKggxXk1zwVs34430U+87PGHJEiZTo3g1bcn0W4li1QdKpD+rgNJq21cNwkQvMqgyeB8HvcrXNLfoD7zW8AUuwD+hMf0pobj9zrda9aYzyvPz1MslndeiI6THq8dJ4rLxgviUW7IZLBM3CGSk4D/8vFcwldsI3/Swy6rctjPKqA7Lt48hjkYWp5Fom5lFaTLa8PN6tBKoG1XwyWDxH6ihRxFDOL7HNxuM34vA3vjY4H/jFWotxNvHgcKt9nME71lGRkpN+BZCxAuYpXBkkFSWwvOU+YGfXgu5IxiPGeQMFbUNgK30Oim8rM8lfcesLgdvHdJMjDQjOddRGVOCZcdGCwXmF/lLKTGIJ5L2bcB74o4nzcfdpeD5G4yno4LTyrMPM0H6W7S7TUhpKOoxF4hg94bKBko2plf4S7Fj+dzCahVZ/5V8au1aALug4yKgTJeluwUBScwTzSgaArp+FnxsK3IW+D7LwyUDCaYXKFbcAAA9XqkfWrRgYECdMjRzjadtT4IqfJwYIO5zyu2zaqlVop+phcYi8r+2evAPKzSa+kO0vOzIKgBlBX87gvDJIPt1E5GNgqafxxfjqGtA0PttOim40F8qn3lY76eLRloqVVyF7pB95mQwaAyzCvXtjQZGKjPkXeXgXpnhM/XIMngpmwSQghQ6ksNEEp7vaW9bAEg7Zv0tx6kPoaUv0MI7TVJwiJHK3o1Sn37pifMkJ/ZDzO+zcwz/QlQK5fKEyqZJ04QNfuu3nDcapVQxzM8Y/CA1ISkC88YWWQqI0OgUrJ0JDgsYtzWt6izpPerIGJxfknHh/rI2RDJ4I9HS0VqH1O2ytQ+l2HXSoae8VHlO4TQa7iPRY5WTC6d3sdU5Wd0ZsgqXrkbq5Yry79KuObhsF9tGsKxVuGetRNUOEtZiDZRmnNLx1HRF8aNXb0e6f7KeNxPbjP6o37yNkQy6Jb3t7qVZlolqLxxAZRmxZAxVU+vldc0PHK0Ya9Jkkb5Kv+hDFGptIGUXtOglllGllny/tsfukaoNRy3WoVYD8y0AC1CVERpeBCprIy0YN6xj4nuEwLIHAEerA3F1/7TV/YGSAa7RRdomjtSN2bV7xCa6YlHjja8g+DsyUDtXa9xJKBaX82jkhOuyrHLMNTqmPh/NMkA6WaNNIRKGJ8pSyrehVBAOl6McRK3PK9HnwvDI4Nfjv4qA2Hd5q70wtIwvH8F17HI0QqvWRnTBKRxmoBUfwf12X4WugAtq34Iod/tqCExatMETrWaY/Zcw3QiawHVRankljkymOLKeAt0g8kHQgIIIYSiN1eGQrO/6rUMhkcG/fPHqC6RKS2qgdIqmPq6lsaFv9oN8cjRhrGlMxcQkcYFROXfQX0BUS1d5hNast5jW/g6wqedlJo+iWoLiOl9XKmAyguckFlqUKY5hBBKcJ3KtK1j8owiNIAQQjd7W5h1uaRvR0yDI4NboqMYi3YZbvBaxefUFRYqBdYN86WxaPg/fA330WoqPqvYJ2EcgGGODblqFaEfS7yg/Joo/RfE0MhAUa4p1qLVqsNvFRvU54cMtD6y1dbjIr6G2yq+hcsqFOXbMk0SZrUg1zNB7MEWUruhjw2iLIZGBnvFeC+XvSni17/tJnVKYA2FtaQG4LtFtrUnrhCbJynG+wLdPeJyNxMkHOtiKW20J95AimNgZJDk1ROzxKF2P3gtcccCf4RW0l6nfNgY6Kf9VEySqjZhmuIqdTQ3M0HSmd624toBvwynRAZGBhtNcPtbRHu05bXE3106Ck7s4Z2gB67J9lrT91jkXIIbTDtDab/cywQpFwc4iKqtCjOoQhkWGaR44j90fJbiNwboGald3wNCr/4cyeO4Dc/ac3KZpjjEKCrVZZpkhenb3MoE14e7QsWlnw2tXIZFBgf4uFdnuuwCr4X+vrCyWFJl2oVYITUVOUxU8zkWSTepExik7BA/ZJgizHpqrmSCmGP9XKDM/PcGWDTDIoNKfAzpFZ2sb/Nc7t97+xYEkxrTLwpICPfKyyZhya5HYe7znOi8/ZgmyZWrh2EbmssltZYY6JDIoMjgJvAS7i2hpZUAJ+NCt/UqCCY1pl8SysaTV1gXPInDQOUrOcuYbMP0PrhcuHr4eK6vyLr9DsN1rTAoMuhZjh+5iX0lAYJUIHRbz9QRgjBnTb61h7ZfuIsZ58J1e/GV6TKGKXLb6mFC0HAPKDDsXIIhF9KQyCDSbB1foudTY5MFqkXotp4FQOo76tAPATI7U8hyOecAzb+sFnETkFypAtNC5KrVwzdrWliLKs55ZOjlNCQyWG3B35b9frOqAlrfp91DSougSO9Nr/jOKXaarOwdrkKmOnC7V2WeKVNPsc+W03IJEUQcGOABdu03fDOCshoSGVTswaPwkNKW6wWtTdSpyTXNwKnV0tuJvObzso6oN0dLi7SdzSX5Y9l/TJM09soNq4dJV6dWEstqzr1rJIHdDIgM3sI5PsUnjBc3FZqeE28uaeEI5rWmneHzSrPd7haLuM1FZ9tyuL4rvnQNpsa+Q3QjxzPB61UtLMFr+Ilo4ymyYZDBPPfpl+LmOPF7PRG6VtBigR4WcJ5v7FEYxGWG7f3CVw6xM808D3MaGlhw2FDoY8d0z/yH3YicTQQv13dxA4cOGz8ZV7ENgwzWgAxkeSpf47mrxs4y89TPFZ9hB0b6SMCj6/9C+DmzHtqJasTlhNcwT9Yj2U0ixtept/WIzrE8oHi6uoMLWDdddM/4gj4bBhkcAACgZGBSfg6/5zZCO0KjJ3qq5L/zM+tZgl3TBdf4OMxwuaxkRCTr1G9E+1imDDadwTTJISooZxJBysPlrR3AvsWy+8lGWX7DIINrkA5bnqcK6FI5UbsQvVU0KXhFO1cwqTb+OHbXk5SNDg5rWBth60rs0oUXaMx0rBPh2icHEkHi7SXNbMGp7aonxnsNhGGQwet0LpDw/9pWHCol6vBCn7V9t7V/MYoqOWAHZv/0SH9Z2Uss095i5/wZ4+vJ+F7YnnkicxgRfDnoX8UE8nRa99y462EYZPAnjQvEMwWZ1gWWFHUM1m+Nfx0dW8UE8nZY+RDniPJFI2jOcumgTC8WiZKbOzI+WXaWOpKDeCDx9rJO7iApP2znO+OvjIFsLcpSxwUlEoXJLmVvWah1VN/judirc/2swbLetNP4Nh7PlJUMZLWBulbO4hj2IDnjI2B/83fMKUTw9ZB/FTNwab7g6r+cUSEDIQPX1IHBQ+FyvOgnKro2Ru8VTwlZ07UgiEsP3oHpzZKyyd1iNovF+ij5WsZp5oqZHzbq7fgjB3SbiKD5bdxBUn7ojnco58BAyKAMAIBYWBfVl/3N7Ea+MITahx3yr2ICLq2W3MCxzxA7x9p1E/N12F6ML01dRjE//nUIjP2wYtTFRR0KARRos/DKP5SzYCBk0BQAJF5CewT9XOQJNXcbRjjK+BtLWrmASRX/Q9xDYf0cLCnOePP/OjBcRvkftYw57Tka807C3yv/dS5CQb6Wc878RDkQBkIGfSQAIj2s6SmC2kodxjw1lNZ4t2NQSREU7LrmEcdlxTetoPYDhmmKjmD0+GaKeZxzRZNCRupuFH5+SddiIsjTbObJ7yinwkDIYIoJiCfpJ+vv8wpB+eWGM5GNOj2tniVY1pt2mlNgxRuVRF2YzWdnujBhoADxDOaFWiu+aXQ9JPnFvglN8gLk9Zt27CvK0TAQMlghFRfR23BdcaWftbRZYLwBGeCjNV0Lgsiby7KiIrCwbAiTjYU3TA6KLaFY7AK/Mp9iVJ3jz/U1/SrKQVq625LzP1HOh4GQQSDAHX3mH7uvicSm58lEQ2oazsuKSevdzCdGpnf1vtl6Clakf2fFDBbrBSixQoVEI+kWic8Cp7cuRIFd3ZFbHyagXAJ9k0HCp+ALQQcCF0Lzt7H6LcmP5VUouz5n+XaHRt8fXws6Gngi6MZTGr57HJcVYxc72C5I1Ws7GJwdG/xn9TL4QtDhwGNBl4M/6SKglFHijSxKM03+0ghmBa8Ozu5QUgYSr/ZzTnxCuQr6I4OoM4t7VXAGJdiW7jj3qD6XZz4tqUg59D/D05sg+f6GkfXyy5QqbObpN35H9h6D73YMLs12WTFqqoXr2gSEXoqAGqP1qX9X1o1qVESu3BhgU6zl+E13Nekirq0Jm2NNt8RrDLorpLw7Oq9LWRMQe7aavOdxAsp90A8ZxJ8cWVYM+RuPXXXk1rtfESnow9n3948HTG5dWAxe/fb+0Z8+PiwsT1l33Ic9FknIgsaWYF2l/+KdV15+i4hHMRFfngVtm9ejvBk4tVn1IftOzXpZ8cdwWaGdKR2kAJTGJb/wnQNLi8G+cu85W04Ev/sVkYjiIn68u3V0/czO5S3BpMrII2obAL+q2l5moYFoz8YKA+0E8Y8D53Qubw5UwabjdzyIRbkVeiCDxIMdrMSVJ57S2OVjrsyqb2rit0mPO1ChK+tKTJoEYLz5KmR8Ycjfa6vGIIwpT1d3cILy80JpDC1SlxVL9me4rPixh6gEBQAAS9R/ej6rslheZ/IxbeOxD/tGVpHI6i9TGi+/LVyA1Xmcbo5hhmf+Py4FjG5cUAQSz2ZjN9/9h3I3BCeDj5NcxI036NzJ+7u3g5nVQH3Gkv29rbWcKjvxCo4FhPjtVaHoFJ2b/smXh+URNz1B66wEq2XFZ+WkAABAqbgchy8vDx7Dz2YXjTDqQB9HUd0taT3lvJ0Pq069VfDrqnW3yvND83v62gJYV+w+7+CzBEQgOBm86y1xm0Ej/FfkihJUs3v6VEzsyaGeYN1mA8cL8eJXu5l0vJT9+DjpUENRyX00j06lLitKfUcG0oyk9ohKWwigtmYSRD9T2/7X6I3cE092MLMZ/xUhtELSkdWBjhfmYw2FBQ4vHlA3vwhEHo1GrrsURihAT2QQMUhSeCvdt+1JX2j1Qb/KebOqiRy8x15gP0DY7WY2nG7ow+edRCUvMeDVHYNLS8C9/TIa0ZebStOXBdMjGj1rQRUNYBKh+Pf8PLI+n3qJ5rOa+MeV9tX3yzc+JI0FqHy1+y08+DiWdH59ksEWB9fNTPrVyWJms/W9MR13dpQX6wHCyzqifkyc1l40pbow2k35d2mOnx2YVR+ne+cxOHOPgJIcQwiF9ZGUPca0VydscZdXOMBOjQNt9Mfr32/umtO7ViYLxJFer3cy+N1SMjySofktMK9gAEdE361qIofiQw8wdULbKC/H9Lj/kfwuTK+FVLzY2j/1QMMDbUzrByBL39KkpEFom637djbBHGKX2HiwCl+4H/YL32wxT4+tGNGspDmAzLPBwIUHQwgLGAoZ3HV3v8o81atyVocNQU1xZ8f6iKnSI47Qp7O4zqJJzOcXf7qIJrMYiEednt7IGsxrTT6hKbZiTMiRpUMa5JcAiE1EABVFI9gGcvjehhrAvE99sBkk5GrPs9MBk7pUdgEA58pdpmy6FJpM+rlBkcFJ82asQoDGDxWvMhBVRR4bVVokLu9/QoMTwvcsBx8jqjuyiwG8xbQru+l1SkhADy+KKtIjIETzaz/l48WNE9sVAmoDBy3st6vIdMqUULG0EC/l3w+PrBjVxscRAGxKNRux/NjTGNK/DZEM9kiGsKXn5SIDupbv16FhJSiJ7/izalvS+2CsqmdEePGCr1nmccW2IfvFtt8nJtcyB+uGWp2TjssbvOM09XpbyvkhsxRjzfkMIRP9PGjr7EFNS1gCgItvuzGrjj2JIv3agMngvGw6+8T7xGsNSmU/Agd6gdR35H6lRbvRIHFRnhbH+Hqz96t+6tiFk69eUrpz0ubnWeQckY3gOmiObmZ/n8nzp6htfLTCw+PrpvaoX9wSAMwK1+w2dcO5V2RRwAjI4Jl8FJfkAZLjhqa2b3uGlhZDwa7pI3JfAArqZUQKVrRy5+KfcM96HOcShh0eX90M7PzmXFKe1ZyVcZeMElrbMjhx9MmhGz69J32+sX+5f6dqHiYAYFuycZ/pG06G/CLd2HjIIM67PTev9JkOhnih9d9z0+pZgrXfnEv/kkwAAKTS6Wmb1yut3nASHSTBcudQ4u1lHd2Vo62+tfPHIre5F+2ReEKl4ty9fKNfXto+f1iLCq4iAJFrhRbD5m+/9IqsCBgjGYzy4HjyKLl2IwNVX/L9lZ3cQFoy/d4H95MIIfTCdBdHuZNcsR3W+hI40tcEnJsvuBqbWKYRnoX1qGLt6D463ILtgkHM2xuH10wf2KKyhxkAmHhU6+S/fP+Nz4mk0xoxGbyScb5/+4vVcQPWYeju2uJ0Bz9oEYpQU85XAySVH4+zhGn+y3XyR2IS+NqCZoPshb3MRpEfbx0NmDmkddXC5gAA9sVrdR45f+vJh99JV80RZNC6E3cZc4onGbIWe2e4+4LUdEGQaShniZcwyFDDh5Vm+Ch1gQet1brnFsNpPPXn9a3jm2YPa1/dywoAwNqrRvvhszcfv/eZnB/KYWTwGDDEt/lntduQtVhYJSwItMAgssYQ7KXsVx+frET3pXTm+sWqaOnPMaH3z+xcMXVQ21olXaUAABaFq7UeOnP90VuhZE8g55LB8Go4pAyoa8BKjE519JVJAcCubCmYjGHCv90W90man2Y451qLPWk4NHdyVNpUSfz25FLgmlnDOzcsm08OACB1LVmr7aCpK3aeuR9KVgNzAxkkO6hfuwMAAFmzhszipP6uguuiz4arxAsAYFm8pf+q489iEZpeXJOetVY6/Rf1V6d8H+ZSLnNPoVsoyGgRrQ3yW5LtNS1J88UrT+9aPXt0r5Y1S+WzAAAAB6+qLXqPX7L1+K3XxDUo15HBoyyzBNCcLyCEAFSNUMmw5LsMV4nPDz1Usuzag7XpWWOltbVATdzzhIZ9mBUKMnhBU4OgyqOzJIz69PTmmT1r547p3apWaXfL1Mt0HYv4Nuo0ePJ/mw9fff4jhfS43EwGaxy1mWCGoWW8nkCbeSKEag41Eo0myXfoIANNldaMSWUwl8t8B7NCZUMGk8qEvw2+cHjbyjnj+ndoXNU7v23a9qpD4YoNOw6atHiZQ8WHoX9JFyNkkAH/itpNMNXWlDtF2j8axs29GxqJRr/ALZ1koF5pbS2w0RJvuT7AXQYtkcHLWslgS+oOiplz4fL1WvccMXVxQOCZm08/ZQyRkhsU+E36FyEDZfRsomP6rIUMNHWRMRWMRKMP4JXuNQN1MtC4ZIDQYcC7sXYX3jNviYzpW9YinoTTwe9+aXcBmiYLJt2LkIEK2rfXlqWSpYFGE1TBjBJGotHr8FmHnrNWWlsLnAO8K2yX4Bfzlsj8Iksxr4BOR6AjnA5KE+RIMuhXT4cJglJvyIYMRlQ1Eo2+gBDdZKBWaW0tECjCe82ABn8Pui2hsUEOgi7H4JfWfUnnImSghsml6Zhg9iODLi2NRKPhcIkmGegeGax2xFuu73CVaUuk7zBqbJD/2evI7E+xSsR7kJCBOvaZxms1QfU1bB3b2qjENGNRqetynWRAdzcBu5uV23+IYUtkuBtoapB+OlZ0Fa2dP5O+RchAHZ/hBg4xkaKzxqLStu2xiMHOfl2bYRVXcL723+bIrpKuRcggK0pNxSFlr6XR3H210QHHCDlUdANzuQ5ZRGKUFkJpv2TttHgF6VmEDDRgWT4cbmcNjGc96q8FjrjgM4vhLleS+3KM0nTMEt7a9iAdi5BBKpbISioBqMbcz6G9Ed8zHp3imO0nuON/uS71wHcg8IuZ1qMJMaXKkWNHhAzScFH1QK9rSe7hddq1MyKdfpVzD1q2okA89nLFe03HJqudn9afOjh+JP2KkEEaUhwzmUAsqulov5SrxDOmb41JqZOLcX01frbbw0O5LshuYZK00+y9tp/+EweRbkXIIAOjZRn3fIqg+JwA2QNu8r67zDAqpUZ7DuQmILlWXQUfBRuYF09k2fvylVoJR7yE9CpCBpm4mTEwkA18iBDq4xnOaXhbu6qRXZB1V8btqoAJPIWDTqjiE4FBzFu3Htp++uDYXkF6FSGDdHya5OicxgV+qdF6/pUtw8HPPrm5W6ixqXWt+CiH1Itkp3kq17ci5bgfJXyVt4a2KEwxpUuRxUNCBmlQXGwtdp3WSwQAIun/0r8N96zM2gYTOlk/MT69TpAfY512uWgnb+X6WrQk1+WXGy51tHV4RXvH96RPETJIfTGsLQ5Vt26sBgAgdVTymnnv6fWBncio2nbXjVCvihHi9SxT+ovX8FiwsIq2ZzgJCDBppfXlP1d8gXQpQgYIIfRnrpNZn0MDrU3anSsFkooq097wio4n2ch8UCT/c+PU7CJqIJtt/XA/iQ+vfv1xvUSj2A/lf7QXzda6KHCCeB4SMkAIIfRrmq31pD0NqKJLwxFaAAPUfHL/9aJGMY73m7LMpJzRnng5ZOMdwjjRubwe64pYruQ1VuBWW8+LLEctOxzyn9P660vrXqRDETJA6PsYC/upi4tSDU4pEELo08asj+yyKsgwVve9CpJpNuWfGatuQ6tI1S5qzw7fulDtI1HcZGklXpdJvjaHZmy0eqmSaLD2oIZRRX3JsWVCBihykpnr5OE28gE6h/TfOkJjBl7F73qKaj5FryubLjbWmLop62zdAuh3kD9zbPIfQQgh9MRXNpPXOwXPlJV0e8QwzcUm0ECHw0iyX54vpD/lejJIWiMW9Wspzrcg2x2Di77gR/Nw67OeksK7FQihpLmyam+NVb3hg2X519IbHYTPtrNOv8UZpSyXlw3hs2ApO72h3nH6hBOzrRzU1rnyOFF2m3SnXE8Gh4vLOtWDivto3YZ4ugqUWJmt40vsjmrgtT1d4KPS5muN1pPl82Az68HZvoRTLncysZ8eqfTN68omc3m9X1IR1EjkNPwuHcUmnetpYdJZd3zTfdRm0ptyOxk8qEXVrgzV6W9XPRxoKW2wTsey4O9dbcxlHS4oWWnCJEn9T0ar4ojlxaDoxDvJCCGksevFXxiSB6psU1teTVls6svzRsrnBSUhT98Dv3Q+9GVLBzuqyv+yGfU9kg8nnSmXk0HMaHGxMlCb2eJ0zIGuNuDZa+OdLItR8Q93DPUWmTbfqm6ft72stxqxloMnFQNrv/lnv6xT86tWvDs6vaYZVWHBG00zpYryAL5L9mJpXRkU6bbqggZ2Tnl3elHbvGDRYn22OzrhBWonkc6Uu8ngQkHzgtCQhVNQ4o15ja2AKlCjy+gF6wL2Bq4PWDihe70iEpDXmHpO0y547EhRy1/GrOh3m3sUAqC8WwydvSJgR+DWgGUz+jctaw6iEkP2hmkbnk8St+K/0tEX5jRzBrAs3aTH+AXrAnYFbg9YvWB01/olTQAKtF92g8YKaGItj3DSl3I1GUT2oeyoZndYp/94atHQFpUK2tuKwNLWo1zT/nMOvtZ+IumSe95LRq7sqF7QoEuNoq62JiC3zVu8XveJW4N1+15cds8rjE/fr5ubJvf0K1/Q3lYKprZOBSs17zdtVzDdy9EGyR+TrpSryeCwkwlVC8+tOdUm0Jl7txZNNu6xaIQ5jGSapK1ogsFXeiV1lPSk3EwG0R1BVPQ4plJUG0/rsf/JK38wZmVPkkBlxok2ymuFGXa1Tonnk46Um8ngriNlswbbK6vaIHrPPfO23mu8uv5hCmDG3IHqSWEXgw48/sS6O+lHuZgMFL0p0YhofKWgSwYobgjV+5+x6nqkFABeME/3p41kkeH6WYQXqka8kHMxGdxzhrJYx+u0yQCho/ZFHxinqr9IAUC0iw33LpW2+mugtYrx9SQbCbmXDKIHUJJVeEvBgAzQl9omS43SH7G/FABM/FmlverqbZhRQ5KbO74hvSjXksEhF1GeV5hLUZ8BGaCUuZLmUcan6XdiAACoxi7153KO1wywUoqucnIiIdeSwfc2lKwW9iGr3yBGj1/LUzjE6DTdRQoAAHKWo5p/7WSbDK9SE8RkUzHXksEueydJb/yHa/36MHs+rLrFHiNT9HNRWpDY12xfwtMpf0MLEr2UWk+6UC4lg7AWVB0xH1ej+/VgmCBxBIw0Lgek1qkDA6D2sRaxz6xtvEHVaT21jPSgXEoGRx0LjRQt5KMUDKcJCCG027xGmBHp+UHGTRJj2Qu5Zlv7jwHVaYd4FulAuZMMYgZBn2UifgL3siAD9KRw3hvGo2c/oGQSAACoyUFKSN4yhsOAB8XjSf/JnWTwsJjd/h18DQvrsyADFNVcutpo9Bz9cP/cXlZWAMDpnOhHr4KGspN3SjaMdJ/cSQYbTOt8Pirm68rDamzIACnmiLsZ0/09f+FE9MP98zl5bv7ydTaMjZRL8t7kHrVcSQZxPUVTk2/zF8yGHRkgdMa+rBHdvBYBF7kL+VfL8akB1OW2ZYdk0ntyIxm8LWN/An12bp5saGSAPni73DEaXYcCDr+hmJoGwAYPrZuTAwm5kgzO2/q8R9HePF6pyZoM0N/GZvtyFxmgmBpO+r5K4oljfcIFuZIM/iftGIdQZycerzZiTwYoeQQ1y0gmr7/wkIH+2SDYvi65azk3kkHyKGqWAqEA0TkeS1FtNIfE6yRdjeM1FQWYblr/V8NNn5fO3bBuEkt6Ti4kg5hmZnsQQo/MpvBZCt8JXFKftarzxxh0HQe4HPmjvL31d1TrokVrMkfIjWQQWdX+NkIowbsGr2vH3pzIAD1yLf3NGJRtge2o0Wc3X30N1E/LO5Oo6LmRDMJKuT1HCKFp5vxecFZiLrf0H7wKvDACZRfC58v9xLq5frb2jsj6kD3F3EgG7wsV/YgQQg+ly/kthTvXiJq/K9vdNHxlVxyNT9YF2SB9VGGPdAjxNcqNZPAhX7kfCCGkqFKV53uQ3VdwlRDb3PyiwSu7YxuMwnbq4/jwVvFYwgW5kQw+FyyTekPqPlEwz6WwWctZRFJH+WlDV/a0klilyW4JXYE11DTSZXIjGXz19E6NdKkoynsobGsMK2vJ3WWGHnVnlwnO6XZKY7cfghZfMY1aSHpMbiSDH15eaaZ2hnqm+UngegYvA5Jd9AqZmiFo/lExQLafcbV1SsSNx/CKUdmyeTCyUD2FgLVN6i3dQjpMbiSDcG/Pr2l/tm+g9Ulc3Qb20e8eoLUMimHiXYzJQKdEzEi23oyTDNA92ULhavvPz+IU6S+5kQwSahdI93FLsQ9ACACl/g+lvVtShwSpxpXxbepAQfmJ9L81PpGRexykPq6aQcaj6Ukz80tLm+U9N1a8ObNiWCTiRcM+KL36qqVKL23GyzuzHBklVEqWjoWye0LVNtzX6S7pLrmSDPpaP0n/8wm8SDUcpGROSp1Z2ciU/gX1v7M8kZl7lHqHSCUf5UfVUqp9l4HJ1NqMETEeiVgxqzBC6mqCLOpSLYem4meMheoXjROmtu8Ke5L7EXInGfwnzrxS9SxEq3Vf5b/SJACA0vsm85fM75WegIy3WVoWoaAhAzVjhrR3nAoNpcvMxDxqA1J5oXKWiBPB8EL9ha9WKpWyaXgQqa7TfLGeKEhtg10qfCedJVeSwXHxf5kf9kNytmSg9q7XOBJQtVkVMgihQQZKpVWhIfUazBTvptk96ErECY859MggS9lUH8zEOuljAWp71rJRNOkruZIMPlj3Vfp0DcLSpwlI4zQhYzygcZoAWUkE1JeybgIADWNWelfqGOb6S48qDZxxSMQI/zIaRuxZ1aVeNpXiq+zgKKpVSOa9tttkPRNJV8mVZKCoXVb5VNoP6mLGAiLSuICIlH4H9QVEtXSZTyjlfVZpQSLjQVASpr6kpmsBTDFAFqTCWJwlYsRduKW2gJjeNZXUpbzcCpk6BGXSzcALk2U811YxESYTt8NcSgYrTJ6ofC49ke6yI6MnlJ7ZDzj7X0pX+Q1eezQXVGrPWl3aFiUtPvBa23+tTLaSfpJLyeC1udqpocnuSbyQQeYjmy2wGnNyK+v7hkoGe6XfMJNBQsmGfJLB57IGeeMrgRBkoKhWSc1nNlTCd5TBFa545SU0NIgIwhqL5jYAt8hb1AH+ynsnT4n3pJfkVjI4JMkSX69dCZ5PsM8uillgTI28hrorvkWCnae6efK2vLfPrPFf0klyKxmklOid5ZlXEp4vAx/ng1tiVHnPcMNUeEq5xrhFhpryFG5CMZMaSSKZ5F4y2G7yMetDQx35veGvb13sIsM9fQ00gO8lCvusa7x9JB8ljesoDSA9JPeSQWKhoRoeii7UhNe9pZad8Mt849jcQF9qA+1wU2uUw1geyvm5gt0F0kFyMRnskmk01JuyCXwWwncUD0JvywcZpsqjC/nhFrnK9CP+EYxjidekf+RmMqjVTvNjO6m1PBbCYwEfUo+K5xumzq+LcY++E4t0xl3IpZJ2xAM5V5PBK+qslucWiLfwVwizzbyIXUvtNEylT5TfxyzxIPUYq7yYTuKFxOswd5PB+AJaI58upFbyVYa/wFP0wgkyw5z0Jjco8BOvREXpdjjFvS1tH0T6Ru4mg2TnWdqfXEP587Qi9xp4Criq6GL1xCC1/rNAA8y6PCDCeHHEKdtyH0jXyOVkcAV0LRntN/fjxwHlOnzlqXYJddzCDFLt93GvbqYU74KNQueIuseRnpHbycDfS+ezwW5eIXyU4QDw5kEXaajuBthXN3dJMPlcRraQriL9gpBB0TG6Hw6rbYZ5HfzZ9C2XPqxy4K9+b2w7GuZCGO7VzaTCvRGK38nZvfGeR15yMImQAXoB2ZlB8lRRh984sw8DABCZVes9a/tjfip4QTYVIYRQoqH52E+RncAqb7P0xkRbzmfBV5k0CCe9gpABWmKf/apWkFserEv/TgAAABIx8HWdYwC1EyEUVsLgxr4jsF76ojjpSkkBgBPn/WknnpVCOgUhA4SatKeRIKIz1S8SX/6txalsAA6xfFVxtNltdNsJvAxO96Nlh3CJilzqARIAAPjMaYrgcpF0CUIGCKFkqzW0kgS6OO/Clv9CaSoXiPm75zm5ueNCqRiojwan/HHS3XgEvQag0kiVwwHpVSa1w0iPIGSAEELBQHOvIHKAqB6ucAFX0mzYPpa/Ov4sBAAgNUDn5GnUIjyClkM6WN9M/6edeBY5r0zIIBVLHWivu98oZTY7AUv+0aLUgcEy/qr4tWLqVMTLANUfIB6KpwNOEKWRAdsVnbueZIpAyCADLVrST5a0UO51CUsBvPgeGNxwlHIfQfOGE+ZN/+CQo+iUynjUXlbJU+ZJ65MpAiGDDHuwZ/R2/tAUWuGYK/SVAoB4KW8VPJsxgJZONsQGuJu36HMcchIaSwEAJIwcQb77p/7/lzqyxeRcEiGDjL+ewANmSU8Xlw7mft5mo5jfgYFitXn6yMDNIO09rJrlQRxyYspJAUDGZBFC4QMHEELoiH3R+6QrEGSSwSprprPXpE2uNku4Lh08AQDl29x46G3tIG1CfcsgmyBxODUyHoOc8PwSABMmw58FIsomDMUMhD7/SE8gUCKD9izi70RPNvPcy+19m2wGYBfLbyVPuUkAAGQjDLQRdlmVfoZBzBtbCciG0n/+jhhA2uRxcdtA0g8IVMjAeSGb9KHdRBXOcCpBNZ4HBgghFDNWJAEAe0PdOntfRb4WwxzmkblI3I3201FuYgCg7GqEkm5AoEIGL9gOoh/4QbXLHEowDuwEOFj4qIwIAM4ZajMkTZPUecddzAUJNKP9cLvUtRTTt6QXEKiSwXrzJLYybtSFekyZJCks5HZQ0MHAI0GTYWS4ACt7KSvkUuiV/ikh7FnwhaCgwMCDQUGXg1+G63/IcMdbvpT7sYCdAGFP7wUFHQsMDAq6GvxeRxjDgDSfRWk1chqBQJUMutfjIOViVWhKcy8i7OzqkU2LO4AKxM6lWo9bfymS16p+bg7w4MiK0W0ruluAOqw8qnaesPbkW/11jISZsor3OIwtQvYvHNigqKlavUzyVugwYf2FrEdNn5qkPyJaSroBgQoZFJ3CSc4pH6p1dnSQcHlW87wATlW6z1h76Orz0IiIZJQQEbEi5NLeVVM6+tgA5dl+8T2eXtJRp2d3yAtAuVZqP2bJ5iNXn777FRGBUHJExI93jy8d3LhwRMtyDgBm5bsvuhqrn7Z4WkPUj9Ve7YuAfj6mIPGo03d2wKCrz95HRMQhFBER9u7eqR3LxrYpZwPg3nzaaeVhQmwRSSZjPCP9gECJDH5Tx7gJUhwpB41v6DDYRQ3llFfXZVejtD4SfnZe2/xg23rtZ8yVDNvau4RIVLTNtG3rde/h/bu/Y3zTAiAtP+xAlB4aQ7HL1XYNw6hPX/7X0RXs6o/b/VxHwl/nl3QtKZZUHn8xfS44II0LxBJwaHGd9AMCJTI4C9xjWpyqArU1B9V9ObMkuPfZ/Z2GkPcbO9qLqizDxgfJF8aXpawaTT9Nv3eHHRpf3VRcedY94Z2UosfKPAPpZ/tqfkXKtvWKJ7RSRB4bVY6y734oFiG0HwAAZGDWZOUL0gkIVMlgpgcOaZfrQaXj6pYZv6s65Pe/Rd/Ek872cxA3P4Vh+q64NtiRKjvxCvO10ZiTQz3BY+JjwRvkYxdRpfP0iGNjZcg3NIhR3T6vriexGRr8BkBKicpNvZJIegBBFjJo3BGPvFvNqdK7le0zapajtP0Fpu/YxAP1KI+1HL0bv83MB+UWf2Kd/tmUwlB85R+hm+RBA6hyIluFvR9sYdblCouxy4+l3mACDgMORBDrJ9BIBo7Ygos86ijJvyw9+FbUdFvb6eyOw70eYuK2mgMd3OwodZ70imNl7g6ysBwk+ED6VlOq9F6dA6NnXSQeq1kva6yuIC64LoEYP4FGMngPGBeR3g8zt50UhhBS7HC1m8V+Je7LcLNi59n2p/pQaQcOj/8/K4uKurwSulkedRQX2ay1u/4cLPHelcRF/rtBpp6HiPUTaCKD44A1ePDvOU4mfV68qS4ayC2W8ocW0P4Xi3Qv/KAatpvVUvZ6SXoJftj/dW+Z+3KNRJqywsZ1E+cFldBOVC1yyzKBBjKY745ZblxAUallOe7Xpp3Mn/cS0zSxU2Vlz+KsTMr2AjZrBXdH+jTcQt77bpavP9aSTcZyP/KtclgORBDkNDLo1hi34KQ+lD+OaWlkW/E8ZinuFbZcnoS5Nv/GSSq/F7xx/qwtBeXWq/b8w1YlH2ASnzhF4hdFugCBGhmUH4O79zS2OoVJ1DrJECZeiatMmnzhQVFPytid0EP73Ohuaj1YaYNzkWgYxnsQb7uV+Ej6AIEKGaTIt+AVG1PZFd8W/UnzbrSHs8ndxLP5GfvG9afm6KOFfv9XBLznpg1LhkvWYRX+tbzLc9IJCJTJ4C3cwSo1ubkbzjfObesJNJ9MaGN9njddbZKM10sbKa4OcqQqrQhDaIrsFGbZ/5q4kbEBgTIZnAa8c8dRtk+wyrsg20jruZSWdsE8KuuQbKKeminpdHcrcZ3h4qPYJcfU8PxDugFBJhlssMbbd6U3MRdzswWt0B/Tbfj1Hz4p3qe3loo9UF+6iQe5USW6kW5AkEkG00tiHXp64A9K3qoWjZWA0+KTPKvrP7n+zvUklenMi9wQUxIDkSCTDHo3wilzblH8rq7fLQ5n+0x8wWm866ttA7011bo8kfwIXuJOXJMJMsigfl+c41nHzTwUdEzFbB9ZWoh/o/5mcVpPLZXgvpInyXF515KOQJBOBl4z6T2HEAIAUL3JXf1TgIt6n4TURGrPIUj7QuknSH8+SwG+iq5lU8QYux1Zi60t59RfVLJT+kJrKRCaWFZPLbXZMQ5D5TJ/UMLiAsQTkSDdkGw20SeDrNan9tmvh8bEoEkmZEhMM1ltWSBUYWw2RTwg/4eY5aycv9KzukqBnukrSBhTtWqunCZ+Q2+BXKhEkGE2+xAClPrKh7S3CaDMl0naNwCZXRcy3kFqFhZvvlub1aqmykoGoM2+EUJoinc2VenYBiFmOWv4A7IpBUJeM/TSULFm+/BUTmOdZpOeQJBqHH/hJEqngsz+DsqGBlk6rdp3GXgFj7RbrXIq1f4Pyk9qGqDvlmZTlSJzdJGBes5q/UXlRaujFAh1aamXhnqe9RJpNpXTTAZt25KeQJBqHN/gmmpfz7Qu5d4PaWME5Td66nfKEq/Adx0zd3UyQKpD8ozJQlajvZBdlEb5VoTo5wzKM+70gQ9AdqVAaKyPXhrqPPzCUTnQuBIyohrpCQSp5v4GHtIhA+V5hcqkWsW8TkKstgUHVQpR6f4q3VDjIP0efNBZkwQ4on2pI2vOqvyTlZu0rRmgOYX00lCHIAlH5bRMwUqTnkCQahwP4Q3KXDHQRQagbF6apwl34aMOq1WiFe0jA43d8BRkc1WwwzqdZKCWs1pO9MlgWHW9NNQN+IqjcprJoF890hMIUo3jGoQqrxcgpRdMxhqh6mKhjgXE0KyXNmqyWo0mq6sbbrLIpiplJ9EjA9AyR6FJBi076aWh3sNdHJXTTAZNe5CeQJBqHHdTyQAT3JZpt1r1ZW+NZKB5h79vdr5//r66yEDrgjtDP4NE2016aShFnhU4KqexlZPtNpCeQJBqHE/gJUYy6NuQl5K6L8nmgduUEHeLn5X+0k9L9eXPEfoa9ZX0BIJ0MsB54jjI9BsfBivJrqsryk0SQGGtOumppa7JeOO6AXVJRyBII4PQrK4BXOAzjoeCNu2e7SPn5Z9519cV0w/6aqo6A3kS/El2hXQEggwyuIZT5hFL/MFzrkhpnB1uWjuZZ3VFeWY6RSd8uC5okKDrUp4Ct7QlewkEGWQQDXijaTWri/vgy79CdEYbnxxH86stRRPvmPBHJzbM6NfIyxYALgvaVv29YvgQu8X8FekHBOlkgKzwrpB/s8Ps667oXILW7UgXJUv5VNbPYgBSAJCYpF1oHitoW/0r0o6Hkc9teQDpBgSZZJD9EWZmOCbGe0J+gjXNFc6Nonn86Sq5u5ktKENox+Qn1v2wnzV+YkuinhEok0HdAZjFrhXvwChtmoz2XWk7xIPjeVJVpJ/VVXTYSZrBBbJxQrfWVXl/zNfD3HFpnkx6AYESGXRvhlVoytEq+ahF2F7IfWUMwpAetqrAzxbcPQ/3ewihqIGUOJ0Net4TuiOdtWyANY71frNWJOQZgQoZTC6FUWTC5uJUs+vrxb3xLHeF1bc8x+T512XsNuIP3JMw06RRmrfRtYJpbEA5gk2LFSGCRgl64l70LjZh8eOpUSmkDxCokMF+Kbb3Q/SSvLIezxBCpxy8cHgvnHEunP3dgneaNm+Xipo1a9awBkfcG+cXi5ovyeg28VMkUgCAIoqnK1raglOHAAGvM/5eXzId01ThcSnLLaQHEKiRwRvAdJlnwgony9GfUv/+Uls28R9HeT96Ut1oXBb/A1RRStIXpwvAw2ZUMxV5T8qLAKSDEEIoOXhRIwtw6771s0AtplglL44jKGukv6zae9IBCNTJQGGJJaBx0iZ3M/+fmUsHK2zcA7kMohNW2bjvp/VkfXEmE4ja/kvZWlA28AMuKmhD+aj7YaSsMJPArvRPiddn1TIF77EXhJl/v20FjUK4svZqB4c1ZIpAkJUMUPXhGF5ZgV6SAaoXIH/vISp1gK3JJazNL5sQTe/ZXaIMKqDmKRBCievzi5uf4z6dT9xbHUof0SDnY0VQWaiMPTvKCyxarPsgRKtdKitqeYtD+r9L8pj4RxLrJ9BEBiOrcpZ0y0fU5U2Wb590EJVcF81C3Pd5biZDaA+9/5mkcYHEPP3i9OSDtakic95yGxSMdZW0vajlx6z3Hn5Y18ICvEadjeO92VKOVIKaO1n6PL0YZWfpT84pEmghgxNSjjtWP/uIamt2DHrWR2458Dazd3TS2Q4y+zFf6D4eu7ORONUnUFrwpXLWo/JCxaVvWA50HswoCkWnM1wKSLgw1hvkTdZ84b3lLrUzsR56k/Gw6+f/KkOh+RHE8gm0kUG0yWFOL6o1tnn3aP01amUpyD/6Ft09+fizfR2oajvo+g6lXOppKW02KXWO0ChK/ccBjuA59ARTqgvb29MFCoxlt6z6eUMbS8p3wUu+2y58aWlw7X+awfjg7bKaYouuV8iVKQQ6yADVGcRlhlBWNlb3VOD5TG+wbbX6SXaEkHBnYUO5qOoy2u/jF5PdofyKHyjJHoCixmt4UaYEz6shERXvvekxveW9f3dXdioI8sbzbHzYL7bHnejrCMUm3eO7271dXFUkqzY1KPv5f/LzTd3cwKnv8Thi9AS6yWCBB3vDHyWqS+OWoQ8bOzmDvMqwDZc1DqGT359b07esFDz67PlBN+ffqypB3vGpeY8QS0y0Dk7+nJ7RyBokxdrN2HntkzZCSnh7ccuEZgVF4NJqwdU4hF6XsT3BQbPJV0YVgHzDLiTx3II/Dw73psCj1cx99zTHYEp8e27dAF852DRbGkz2DwiyJ4OnrG8Nu1/cehvdafiLHSOrWwOYlajdadjMJQEBewJ3BgQsnDa4TY2iMgDHBhP303cPiD/cQmbRLSjdvO+BTPegPuXlgZntipsASPL7Nu4ybPqCdQEBgYF7AgJWL5gyuGNDnzwUgHm5bguOf8hYiuhJTeLmb/xgWimw73E8ke9W/H1uYadiUgDrUvU6DZuxMCBge2BgQMDKBeN6Na9SQAxgX9d/Rwg5g0BAjwxQaXYxw5JmS+swPAvw48a26YNaVS/mbmsrBpmtrUfJWh2Gzt5zL5KJkJtD7UT1tinPTfqF0+Kjb7f2Lfbv1aKUQ0F7W1sAsa2tU8FStVr3Gbf88P2f6k9vNK39g6OC3y6uQtn1vyTAKznp/YUNU/q3ql7cw9bWFMDW1qWgT+OuIxcduB9J7JyACRkscWdjr699zZYJvxwVOssLii34xEVEt8q0HntYMO9VzsX9tLgs5B0ZTIyNwEjIIExykXnqrXIfwe8k/rOlhshpGMeuFWO5it6DkS0kSzGw3cvpRcF7CdnbJzAKMkCNezBNGz+AGp8obHFTgrqYmbQ7wjnXvRK6w3/FAknrPziKfmuonbhJYDwxOQLDJ4M9Zj+ZJf3sY3NU6OlBAagc8BuDpOaN6D97yaXwYyzFjw9sInYY85oYHYGhk0GC23RGKYPzeL8RsqTxgfVETqOeY5H1U7adwdNh1eVbMFXi69wCVN39icTuCAyaDNBiBya+7vvlzaIFLOfjoXbiJkdw9aL/rBmdrU4aS/XH5auTcqq52GXmD2J5BIZMBpE2q+mnWyUaLdy+dcSq8lB4Ab7lN4UXU3/Lwzbl8J39/zLFwbRPCLE9AsMlAzTGk7a33HRqpVAlTAnqYmbRE6s//VV4yDTJmzI2x/EVIC6gONUgiFgfgcGSwReTjTTfrMNkuwQqX+qaYRReoV0qsOi/vagJGMdCijP1ofIpYn8EBkoGaHReWjFMFSNMTwpSOJxrhkr4Zcbq2pDNpvWwXsB8y4/yOUoOEBIYJhn8sp5PJ81Ik9NCFO0J1jVDJcy2Ybf0ed/d4yHWgtxvSVUid54SGCQZoPnWNN59E2QCDG/jd1bFumaohATXiSxThteW78Zblgf1oNULYoUEBkgGMXlHZZtirZj/9YI3Yx2kbc7zNITeJvvGNmnSKBiN+UjyaW/J0ChihwQGRwZoiyQ7Z7tDmK9R1NDjDjUQ5Zv9jS/xilLdOaTeJa/zE295UjY55TlADJHA4MhAUa2y7sOL98wm8FugH7Pyihof49GH4Qy3OyIeFsh/H3OJfvemmn0ipkhgYGSAnkr/p3PW7NaEV1+jR71MHMbze7VHjcbc0v+qZ7Ydd5kuF7E5SGyRwMDIAI231eEqm1ijMI/z25TDtaDk+lh+K3wObnOUkDyGGo47llncYBhKghMSGBgZxBToov3pyeb8hS+IXlZQ1DSI9333ShgunN5jXhP74YL9NmXIVIHAsMgAnaK0jlgviwP4KkfUbHvLoQKc7j1BPcQg5XHBfHdxl+x92XxPiT0SGBQZoH6O3zU/G5m/FU+l+D3N2nbabwGqqyjXBk+BG5puwV22v3VtrxGDJDAoMogu2ELzs/2df/FShsgJlvazhdlr3yfG9PZNnkANwe0cmdDJ7CqxSAJDIgN0VaTxTubr1B4+SpCy1sFhsUChEWLcB2GTFWhR7TvucUtLxzfEJAkMiQyQv9WHrF8mlmzIRwE+1pQJdx/wBHuMY5sQz7y3MZcvxteTeCMSGBQZxHlXynoV2WrTtzzkf8e5xAPBKvva5H9YpzeNTXF7Zn/L25HYJIEhkQF6YT5W/atY1xE8ZH9I3kTA4Gl+PnjvMkn2p6Zg3gs9BUeJURIYEhmgbZT6NYPr5N/x575cPEjAS78OUbdwi9wgaxuDV2KPfMT5iMCgyAB1d1C7HrVcb5qCAADU5WrOJXk4tUjb75AqBie+Ow3DXgV02b78V+Yq15HBd/NlGKQQEOAjg39eNVTe2SHZefGC8h9AJ5fkzqb7dfyO3axbFI3BXQWE0FuvPMHMyUBHBhOcYjFIISDARgbosdxf+eMSdwQo9UWU+k5CCNJeTQgA0r6BDBOFdFPV8PZK5wL5pbT3cPrzGWIze2TGt5lZpT8BasVReSJrnpsld3BXASGEUFQD+X61MQ1SKZKqFAAAnRn8NtuKQQoBAT4yQNupQKVP9fqgzH6YZoWpnUqp1yK1jyrfqXNBV/nFzPGuqtiMzgxZpSp3aNXiZPlXBR8spyPMVUhD0lBqtgKpjiq0/gtIRaSmDHr74pBCQICPDNAwCyVvPbsAtX6WboCg8goHUH2RpX+XlQu6yc9n7T2qf6WVTuktmDYkUJoyq+aRkVOWLON8fRIR3ipkYq2kc5yqQlUyUpasPtvXkMEdeItBCgEBRjJIqFokwwPmC9yg0ZOy9AbV75Sg6JHOBdmSgdq7XuNIQFWOJjLoZvcGIaxVUMY528ph2ZGBskzdGeRfjEMKAQE+MkDfXFsqMt5WoSqjc609CTKNUtfgdYL8nPJKmIpYyEIGoGWaAFlJBDSv/y0Wn0cZ0w48VVDBi8Luj7RNEzRwmu4MhlXDIYWAACMZoGuymWl/nYQYpX6asVYFSitXqktYupe11lK7lFfc0o1YwwKi8u+gvoColi7zCfUcT4tXpJcKVxXU8Lu2xdGsC4hqs52MhRDdGRySxWCQQkCAkwzQWupQ6h8nsNrZUfF8tiWiOxRWeea5dW/6KVkisa9oESZRP+AyMUwCQyMDNND8SRoZROHrSbflgxDPZKDyyEe36gm8kwFCS8W9EvBIyvcfMUwCgyODhFoFwhFC6DrgC13+xrF5spBVDPMsI8xRwJOW1fGEUa/fnxgmgcGRAQovWDMBIfQRsIX5iinpGyNkDUOLFA0XKKsQj0JYYqcMrUEMk8DwyAA9sRiAEErCd1i3vfNnISv4toB3mGCZ/ahmjeMayjmFiWESGCAZoMPUUoSQrz+mDP+TCnrV6B0nn18CZhffXbyKu5SN1sQwCQyRDNB88VGEhlfFk99l8TIhqydsvASEEJpHjeS8InKQbBASGCYZoEHy2+iEFMsi3GfHTkLWbpmg8RJSsde0Fdc1kRPwj1gmgUGSQXJjx8+x8r0YckuuVlLAxcOEgdQiPaj0mn3F71zJgERCJDBMMkBR3t6/OjXHkNtMMwHvCflaxeqwXnT62tPjOScBRyGeWCaBYZIB+pzP95AslHNmN8VrhKvZddeiL/Sk1J9VbDn5EG43JYZJYKhkgN44Nio0gmtefwo0UwhVL8VyafM/etNqXFvZDg7JVzkTwyQwWDJAt618zbm613V2Fcr7B/1sJpmn0KNaFWOpWexTzyV+BgQGTAbogsx8Gres9lLnhKrVxbwFbupZsevEPVlfvzbOhxgmgQGTAQoUmXJ6sf9wGCJQneLHi9tG6l2zpyzqst0T6NaUGCaBIZMB2gbeXHJq6yGQ+09wScsNhqDah3lKsFxzrTiWGCaBQZMBGgE92Ge0X6BJQuI0SZ33hqHbz94uwawS2qwnhklg2GSASsFUtvn8du4jSH1ulTJfpTAU5f5tYH6cRbIwIDezExg6GbyVUrMQQop7PRjv4HdzE8KpLnKQqN5bA9JuUl/xaoQQQjETGKS6At+JYRIYOBmgxWJqPkpuBNCEYTYX4JgAldnj4rTDwPQ7lxqdglByXThBP81Ke2KXBAZPBorG9tT8pgBAMbtHPd6rOf9VeVCL6h9hcArebdI6Fg0SUZ5JtJN09CN2SWDwZIB+uHoDBQDSBoySzZN/5LsiPweLKt0yRA1ftfOdDACi1bRTuM0jdklg+GSAjphRAAAA1xgk+iCfz3M14pfYuG5TGKaKX+UDAABbut7RH+EKsUsCwyeDMC9xKhdIKjNI1cwrgddKpGxxN5scbagqviBJ1dg4ms/vksURuyQweDL44J5q2AAA9IP9nYGLvNbhWAlJ/68Gq+En5qJUhUk/0EvQtwoxSwKDJ4PnkAmxN91ReVLxVnzW4KQv1eal4Sr4M6SNpUDanlYCRZ5ZxCwJDJ4MrlkrsQG1n2aq1SZv+Cv/iQpUs3uGrOCJShq7TSfBfbhPzJLACNYMjnpR6aYt8qQXXjDSwZ+vwift86GaBRu4hj9NdaTSVg0q0hlMTXUnVklgDGSAUnbmF6XxgWiLhp7//v6doKCzgYH7g4KCgh+F/kFotGMkP0X/uyy/uJ0xvEUTD9SipAAAVCANfZUbRKySwCjIAKGkAOfUWTCVN32P4F/wgeWjO1YtZAtZIHZwL9l1wqqjIbij+n0aY2U58r2xqPm1v7VIBKJ88dnry6ksL/oiIMBPBgjFLrWRAAUUzEWJDwKGNXAHEOWp1HrE/IDAc/fefoyIiEJIERER8e7V7TN71s4Z0rycM4DYs+nY7S9SMBU7uJM038JIY1J03PaKQMF4PemLgIAfMkAoeqY5QDMAX1Owrd53ycl32fnaxj8/NK97BXOwqj3uGOfQhImBtaHcjkRjU/WPhd4A+tAXAQGPZID+7fYBMPNospvRRkHyk82DfCSSSpMvcujJL/ydxM0uGpma/x0fWYqSVxvaZ57g+iIg4JEMIne0NJNUGdmW3S3t0SdGl6Zsux+OZZM4dks18Jj11bh0nKqvKZfihdcXAQGPZJB4yE9m1nIHt/n61zX1JOZdLjI9TBA80NqkfZBxzaP1qS8CAh7J4M14Z3GTAzhuAvy1qQoUWvCDfoIPC8tA8aU/jUu9etQXAQGfZPCoo7jArC/Y8n4xytFsiOazzXFqznpfl1em7PvfNDLlCqcvAgJByeBBE6rMXryXGseuLiDtoSGE8G3wUPr0c20tkXX308a2iCagvggIhCSDnwNEvqfwT1qTtnmaTVFbG4sbLwJIv6356/qGEvOOh43OB0dAfREQCEoG621cd/KzfpWwxNpd5Tj07cISADiHEFLcn+lDyVvtiTE+vQqoLwICIcngZ0vxOP6Ch3zrTA2LUxoWSABANiHuxEA3yDvghDG+BgXUFwGBoGRw1zU/v5H899h4f1QeFgBAfjlVfsZ949xME1BfBASCksEpixZ8X3oQWiHv48xhAQCAaMVXY9WpcPoiIBCWDPZJBiXzXo7oRta3M4cFAADHjVWlwumLgEBYMrgtnyZEQRI7ONcFUSYXyEYbqUYF05fLZ2K+BIKSwWfHvsKUJMQCAEBqIkuLnZLfOBUqmL4S6niTVUQCQcmgXa0EgYoSXmDo1UNrZgxtV6WQDQDAL6NUqID6KjiD2C+BgGRw0VS4aEJKeSWHPTkfboz61JO+CAj4J4PSEzWkAQDImhbSfoH0h5SfzXha5Vc1tOxo9Ppkpq9MNaV9o/7/OV5fBMZDBsHUOy1pQNPXqjYMys9CuvGrWrkKTphEGrk6Geor87/0f0BJkZDz9UVgRGQwuhLSbtyQYboAamSg+kcmGYC2noEQQijRfqORq5O1vjSQQW7QF4ERkUH1YTqNO9VYQemjChloGBmkf6Fx2IvqDjBydbLSV5p2QIU0VaZVOVZfBEZEBvkXI51zYHXjVp4eAyh9ozJlyHgHqqNXYyNXJ1N9ZSWDjN6vurKQQ/VFYERkYL1RRxqlXg+gMrrNOk3IWEjUNQdG/pWMXJ0s9KWZDEBtZJBD9UVgRGRQbKZu4wbVAa2a5YLKEBllTwYd2hi5OtnoK/170KignK0vAiMig0a9aBo3qJKB+m6C2laZNuOu5G/k6mSoL+X/sqiPBnkavb4IjIgMludL0WXcWlfH1f0M6O2b/5SeM3J1MtSXsp9BVjLIBfoiMCIyCBNfFrAwa12SjVydRF8EOZYMUBc/4cqS6DXb6PVJ9EWQY8ngi8UJwcqyyMP4j+ERfRHkWDJA8x3fCFSUq7ITOUChRF8EOZYMEut4RwlSkjeOg3KCQom+CHIsGaCo4pWEiCzwqkD9nLEaRvRFkGPJAL0vXPQD7+W47VAjKoeolOiLIMeSAQr3dT7LczE2mrfNOYthRF8EOZYM0L/O1Eg+be9Xa9GknDTmJfoiyLFkgNAu62K8Xeml2OrifjmHqZXoiyDHkgH62Apa8LNndquSeHBkjtMr0RdBjiUDhM4Xl/Z6gT3/m02pWg9ypGaJvghyLBmgpC3FRG1u4cw85VRNqJpjPWeIvghyLBkglHLQB7xX/saUdegsd6pRjp78En0R5FgyQAgFD7A26bD3L+d8f25oJHYd/zbH65foiyDHkgFC/7b6mZg23/yFQ6avVtQSW3Y4kpgrNEz0RZBjyQAh9GdXG0soOvjgNxZp32/vkQ8ce53ITT4zRF8EOZYMEEJJN2bXMgG3VvOCwugmUXw4NrWxA1j4/fdIkev0TPRFkGPJACGEYq4t7eQJYO3bc8He65+0D2Lj317ZMbNTWTmIvXutvZeUa3VN9EWQY8kAIYRQxNUN/k0KSgBEecrVa9dv3PzFAQEbAgP3BQQELJjj36d17dJOAGBSrNXEbXf/EX0TfRHkXDJIRcrXWweXT+jfrr5Pofy2ttYAlK2tbcEivg07Dpq8+uj970TRRF8EuYQMCAgICBkQEBAQMiAgICBkQEBAQMiAgIAgJ+L/1H1ywOH3ExQAAAAASUVORK5CYII=>>

@@ -1,380 +1,380 @@--- | Module implementing GIF decoding.-module Codec.Picture.Gif ( decodeGif-                         , decodeGifImages-                         ) where--import Control.Applicative( pure, (<$>), (<*>) )-import Control.Monad( replicateM )-import Control.Monad.ST( runST )-import Control.Monad.Trans.Class( lift )--import Data.Bits( (.&.), shiftR, testBit )-import Data.Word( Word8, Word16 )--import qualified Data.ByteString as B-import qualified Data.Vector.Storable as V-import qualified Data.Vector.Storable.Mutable as M--import Data.Binary( Binary(..) )-import Data.Binary.Get( Get-                      , getWord8-                      , getWord16le-                      , getByteString-                      )--import Codec.Picture.InternalHelper-import Codec.Picture.Types-import Codec.Picture.Gif.LZW-import Codec.Picture.BitWriter--{--   <GIF Data Stream> ::=     Header <Logical Screen> <Data>* Trailer--   <Logical Screen> ::=      Logical Screen Descriptor [Global Color Table]--   <Data> ::=                <Graphic Block>  |-                             <Special-Purpose Block>--   <Graphic Block> ::=       [Graphic Control Extension] <Graphic-Rendering Block>--   <Graphic-Rendering Block> ::=  <Table-Based Image>  |-                                  Plain Text Extension--   <Table-Based Image> ::=   Image Descriptor [Local Color Table] Image Data--   <Special-Purpose Block> ::=    Application Extension  |-                                  Comment Extension- -}---------------------------------------------------------            GifVersion----------------------------------------------------data GifVersion = GIF87a | GIF89a--gif87aSignature, gif89aSignature :: B.ByteString-gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a"-gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a"--instance Binary GifVersion where-    put GIF87a = put gif87aSignature-    put GIF89a = put gif89aSignature--    get = do-        sig <- getByteString (B.length gif87aSignature)-        case (sig == gif87aSignature, sig == gif89aSignature) of-            (True, _)  -> pure GIF87a-            (_ , True) -> pure GIF89a-            _          -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig)----------------------------------------------------------         LogicalScreenDescriptor------------------------------------------------------ | Section 18 of spec-gif89a-data LogicalScreenDescriptor = LogicalScreenDescriptor-  { -- | Stored on 16 bits-    screenWidth           :: !Word16-    -- | Stored on 16 bits-  , screenHeight          :: !Word16-    -- | Stored on 8 bits-  , backgroundIndex       :: !Word8--  -- | Stored on 1 bit-  , hasGlobalMap          :: !Bool-  -- | Stored on 3 bits-  , colorResolution       :: !Word8-  -- | Stored on 1 bit-  , isColorTableSorted    :: !Bool-  -- | Stored on 3 bits-  , colorTableSize        :: !Word8-  }--instance Binary LogicalScreenDescriptor where-    put _ = undefined-    get = do-        w <- getWord16le-        h <- getWord16le-        packedField  <- getWord8-        backgroundColorIndex  <- getWord8-        _aspectRatio  <- getWord8-        return LogicalScreenDescriptor-            { screenWidth           = w-            , screenHeight          = h-            , hasGlobalMap          = packedField `testBit` 7-            , colorResolution       = (packedField `shiftR` 5) .&. 0x7 + 1-            , isColorTableSorted    = packedField `testBit` 3-            , colorTableSize        = (packedField .&. 0x7) + 1-            , backgroundIndex       = backgroundColorIndex-            }----------------------------------------------------------            ImageDescriptor------------------------------------------------------ | Section 20 of spec-gif89a-data ImageDescriptor = ImageDescriptor-  { gDescPixelsFromLeft         :: !Word16-  , gDescPixelsFromTop          :: !Word16-  , gDescImageWidth             :: !Word16-  , gDescImageHeight            :: !Word16-  , gDescHasLocalMap            :: !Bool-  , gDescIsInterlaced           :: !Bool-  , gDescIsImgDescriptorSorted  :: !Bool-  , gDescLocalColorTableSize    :: !Word8-  }--imageSeparator, extensionIntroducer, gifTrailer :: Word8-imageSeparator      = 0x2C-extensionIntroducer = 0x21-gifTrailer          = 0x3B--graphicControlLabel :: Word8-graphicControlLabel = 0xF9----commentLabel, graphicControlLabel, applicationLabel----{-commentLabel        = 0xFE-}-{-plainTextLabel      = 0x01-}-{-applicationLabel    = 0xFF-}--parseDataBlocks :: Get B.ByteString-parseDataBlocks = B.concat <$> (getWord8 >>= aux)- where aux    0 = pure []-       aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux)--data GraphicControlExtension = GraphicControlExtension-    { gceDisposalMethod        :: !Word8 -- ^ Stored on 3 bits-    , gceUserInputFlag         :: !Bool-    , gceTransparentFlag       :: !Bool-    , gceDelay                 :: !Word16-    , gceTransparentColorIndex :: !Word8-    }--instance Binary GraphicControlExtension where-    put _ = undefined-    get = do-        -- due to missing lookahead-        {-_extensionLabel  <- getWord8-}-        _size            <- getWord8-        packedFields     <- getWord8-        delay            <- getWord16le-        idx              <- getWord8-        _blockTerminator <- getWord8-        return GraphicControlExtension-            { gceDisposalMethod        = (packedFields `shiftR` 2) .&. 0x07-            , gceUserInputFlag         = packedFields `testBit` 1-            , gceTransparentFlag       = packedFields `testBit` 0-            , gceDelay                 = delay-            , gceTransparentColorIndex = idx-            }--data GifImage = GifImage-    { imgDescriptor   :: !ImageDescriptor-    , imgLocalPalette :: !(Maybe Palette)-    , imgLzwRootSize  :: !Word8-    , imgData         :: B.ByteString-    }--instance Binary GifImage where-    put _ = undefined-    get = do-        desc <- get-        let hasLocalColorTable = gDescHasLocalMap desc-        palette <- if hasLocalColorTable-           then Just <$> getPalette (gDescLocalColorTableSize desc)-           else pure Nothing--        GifImage desc palette <$> getWord8 <*> parseDataBlocks--data Block = BlockImage GifImage-           | BlockGraphicControl GraphicControlExtension--parseGifBlocks :: Get [Block]-parseGifBlocks = getWord8 >>= blockParse-  where blockParse v-          | v == gifTrailer = pure []-          | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks-          | v == extensionIntroducer = do-                extensionCode <- getWord8-                if extensionCode /= graphicControlLabel-                   then parseDataBlocks >> parseGifBlocks-                   else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks--        blockParse v = do-            fail ("Unrecognized gif block " ++ show v)--instance Binary ImageDescriptor where-    put _ = undefined-    get = do-        -- due to missing lookahead-        {-_imageSeparator <- getWord8-}-        imgLeftPos <- getWord16le-        imgTopPos  <- getWord16le-        imgWidth   <- getWord16le-        imgHeight  <- getWord16le-        packedFields <- getWord8-        let tableSize = packedFields .&. 0x7-        return ImageDescriptor-            { gDescPixelsFromLeft = imgLeftPos-            , gDescPixelsFromTop  = imgTopPos-            , gDescImageWidth     = imgWidth-            , gDescImageHeight    = imgHeight-            , gDescHasLocalMap    = packedFields `testBit` 7-            , gDescIsInterlaced     = packedFields `testBit` 6-            , gDescIsImgDescriptorSorted = packedFields `testBit` 5-            , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0-            }----------------------------------------------------------            Palette----------------------------------------------------type Palette = Image PixelRGB8--getPalette :: Word8 -> Get Palette-getPalette bitDepth = replicateM (size * 3) get >>= return . Image size 1 . V.fromList-  where size = 2 ^ (fromIntegral bitDepth :: Int)---------------------------------------------------------            GifImage----------------------------------------------------data GifHeader = GifHeader-  { gifVersion          :: GifVersion-  , gifScreenDescriptor :: LogicalScreenDescriptor-  , gifGlobalMap        :: !Palette-  }--instance Binary GifHeader where-    put _ = undefined-    get = do-        version    <- get-        screenDesc <- get-        palette    <- getPalette $ colorTableSize screenDesc-        return GifHeader-            { gifVersion = version-            , gifScreenDescriptor = screenDesc-            , gifGlobalMap = palette-            }--data GifFile = GifFile-    { gifHeader  :: !GifHeader-    , gifImages  :: [(Maybe GraphicControlExtension, GifImage)]-    }--associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]-associateDescr [] = []-associateDescr [BlockGraphicControl _] = []-associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = associateDescr rest-associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs-associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) =-    (Just ctrl, img) : associateDescr xs--instance Binary GifFile where-    put _ = undefined-    get = do-        hdr <- get-        blocks <- parseGifBlocks-        return GifFile { gifHeader = hdr-                       , gifImages = associateDescr blocks }--substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8-substituteColors palette = pixelMap swaper-  where swaper n = pixelAt palette (fromIntegral n) 0--decodeImage :: GifImage -> Image Pixel8-decodeImage img = runST $ runBoolReader $ do-    outputVector <- lift . M.new $ width * height-    decodeLzw (imgData img) 12 lzwRoot outputVector-    frozenData <- lift $ V.unsafeFreeze outputVector-    return . deinterlaceGif $ Image-      { imageWidth = width-      , imageHeight = height-      , imageData = frozenData-      }-  where lzwRoot = fromIntegral $ imgLzwRootSize img-        width = fromIntegral $ gDescImageWidth descriptor-        height = fromIntegral $ gDescImageHeight descriptor-        isInterlaced = gDescIsInterlaced descriptor-        descriptor = imgDescriptor img--        deinterlaceGif | not isInterlaced = id-                       | otherwise = deinterlaceGifImage--deinterlaceGifImage :: Image Pixel8 -> Image Pixel8-deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h-   where lineIndices = gifInterlacingIndices h-         generator x y = pixelAt img x y'-            where y' = lineIndices V.! y--gifInterlacingIndices :: Int -> V.Vector Int-gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices-    where indices = flip zip [0..] $-                concat [ [0,     8 .. height - 1]-                       , [4, 4 + 8 .. height - 1]-                       , [2, 2 + 4 .. height - 1]-                       , [1, 1 + 2 .. height - 1]-                       ]--paletteOf :: Palette -> GifImage -> Palette-paletteOf global GifImage { imgLocalPalette = Nothing } = global-paletteOf      _ GifImage { imgLocalPalette = Just p  } = p--decodeAllGifImages :: GifFile -> [Image PixelRGB8]-decodeAllGifImages GifFile { gifImages = [] } = []-decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette-                                                   , gifScreenDescriptor = wholeDescriptor-                                                   }-                           , gifImages = (_, firstImage) : rest } = map paletteApplyer $- scanl generator (paletteOf palette firstImage, decodeImage firstImage) rest-    where globalWidth = fromIntegral $ screenWidth wholeDescriptor-          globalHeight = fromIntegral $ screenHeight wholeDescriptor--          {-background = backgroundIndex wholeDescriptor-}--          paletteApplyer (pal, img) = substituteColors pal img--          generator (_, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) =-                        (paletteOf palette img2, generateImage pixeler globalWidth globalHeight)-               where localWidth = fromIntegral $ gDescImageWidth descriptor-                     localHeight = fromIntegral $ gDescImageHeight descriptor--                     left = fromIntegral $ gDescPixelsFromLeft descriptor-                     top = fromIntegral $ gDescPixelsFromTop descriptor--                     isPixelInLocalImage x y =-                         x >= left && x < left + localWidth && y >= top && y < top + localHeight--                     decoded = decodeImage img2--                     transparent :: Int-                     transparent = case controlExt of-                        Nothing  -> 300-                        Just ext -> if gceTransparentFlag ext-                            then fromIntegral $ gceTransparentColorIndex ext-                            else 300--                     pixeler x y-                        | isPixelInLocalImage x y && fromIntegral val /= transparent = val-                            where val = pixelAt decoded (x - left) (y - top)-                     pixeler x y = pixelAt img1 x y--decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8)-decodeFirstGifImage-        GifFile { gifHeader = GifHeader { gifGlobalMap = palette}-                , gifImages = ((_, gif):_) } = Right . substituteColors palette $ decodeImage gif-decodeFirstGifImage _ = Left "No image in gif file"---- | Transform a raw gif image to an image, witout--- modifying the pixels.--- This function can output the following pixel types :------  * PixelRGB8----decodeGif :: B.ByteString -> Either String DynamicImage-decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage)---- | Transform a raw gif to a list of images, representing--- all the images of an animation.-decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8]-decodeGifImages img = decodeAllGifImages <$> decode img-+-- | Module implementing GIF decoding.
+module Codec.Picture.Gif ( decodeGif
+                         , decodeGifImages
+                         ) where
+
+import Control.Applicative( pure, (<$>), (<*>) )
+import Control.Monad( replicateM )
+import Control.Monad.ST( runST )
+import Control.Monad.Trans.Class( lift )
+
+import Data.Bits( (.&.), unsafeShiftR, testBit )
+import Data.Word( Word8, Word16 )
+
+import qualified Data.ByteString as B
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as M
+
+import Data.Binary( Binary(..) )
+import Data.Binary.Get( Get
+                      , getWord8
+                      , getWord16le
+                      , getByteString
+                      )
+
+import Codec.Picture.InternalHelper
+import Codec.Picture.Types
+import Codec.Picture.Gif.LZW
+import Codec.Picture.BitWriter
+
+{-
+   <GIF Data Stream> ::=     Header <Logical Screen> <Data>* Trailer
+
+   <Logical Screen> ::=      Logical Screen Descriptor [Global Color Table]
+
+   <Data> ::=                <Graphic Block>  |
+                             <Special-Purpose Block>
+
+   <Graphic Block> ::=       [Graphic Control Extension] <Graphic-Rendering Block>
+
+   <Graphic-Rendering Block> ::=  <Table-Based Image>  |
+                                  Plain Text Extension
+
+   <Table-Based Image> ::=   Image Descriptor [Local Color Table] Image Data
+
+   <Special-Purpose Block> ::=    Application Extension  |
+                                  Comment Extension
+ -}
+
+--------------------------------------------------
+----            GifVersion
+--------------------------------------------------
+data GifVersion = GIF87a | GIF89a
+
+gif87aSignature, gif89aSignature :: B.ByteString
+gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a"
+gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a"
+
+instance Binary GifVersion where
+    put GIF87a = put gif87aSignature
+    put GIF89a = put gif89aSignature
+
+    get = do
+        sig <- getByteString (B.length gif87aSignature)
+        case (sig == gif87aSignature, sig == gif89aSignature) of
+            (True, _)  -> pure GIF87a
+            (_ , True) -> pure GIF89a
+            _          -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig)
+
+
+--------------------------------------------------
+----         LogicalScreenDescriptor
+--------------------------------------------------
+-- | Section 18 of spec-gif89a
+data LogicalScreenDescriptor = LogicalScreenDescriptor
+  { -- | Stored on 16 bits
+    screenWidth           :: !Word16
+    -- | Stored on 16 bits
+  , screenHeight          :: !Word16
+    -- | Stored on 8 bits
+  , backgroundIndex       :: !Word8
+
+  -- | Stored on 1 bit
+  , hasGlobalMap          :: !Bool
+  -- | Stored on 3 bits
+  , colorResolution       :: !Word8
+  -- | Stored on 1 bit
+  , isColorTableSorted    :: !Bool
+  -- | Stored on 3 bits
+  , colorTableSize        :: !Word8
+  }
+
+instance Binary LogicalScreenDescriptor where
+    put _ = undefined
+    get = do
+        w <- getWord16le
+        h <- getWord16le
+        packedField  <- getWord8
+        backgroundColorIndex  <- getWord8
+        _aspectRatio  <- getWord8
+        return LogicalScreenDescriptor
+            { screenWidth           = w
+            , screenHeight          = h
+            , hasGlobalMap          = packedField `testBit` 7
+            , colorResolution       = (packedField `unsafeShiftR` 5) .&. 0x7 + 1
+            , isColorTableSorted    = packedField `testBit` 3
+            , colorTableSize        = (packedField .&. 0x7) + 1
+            , backgroundIndex       = backgroundColorIndex
+            }
+
+
+--------------------------------------------------
+----            ImageDescriptor
+--------------------------------------------------
+-- | Section 20 of spec-gif89a
+data ImageDescriptor = ImageDescriptor
+  { gDescPixelsFromLeft         :: !Word16
+  , gDescPixelsFromTop          :: !Word16
+  , gDescImageWidth             :: !Word16
+  , gDescImageHeight            :: !Word16
+  , gDescHasLocalMap            :: !Bool
+  , gDescIsInterlaced           :: !Bool
+  , gDescIsImgDescriptorSorted  :: !Bool
+  , gDescLocalColorTableSize    :: !Word8
+  }
+
+imageSeparator, extensionIntroducer, gifTrailer :: Word8
+imageSeparator      = 0x2C
+extensionIntroducer = 0x21
+gifTrailer          = 0x3B
+
+graphicControlLabel :: Word8
+graphicControlLabel = 0xF9
+
+--commentLabel, graphicControlLabel, applicationLabel
+--
+{-commentLabel        = 0xFE-}
+{-plainTextLabel      = 0x01-}
+{-applicationLabel    = 0xFF-}
+
+parseDataBlocks :: Get B.ByteString
+parseDataBlocks = B.concat <$> (getWord8 >>= aux)
+ where aux    0 = pure []
+       aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux)
+
+data GraphicControlExtension = GraphicControlExtension
+    { gceDisposalMethod        :: !Word8 -- ^ Stored on 3 bits
+    , gceUserInputFlag         :: !Bool
+    , gceTransparentFlag       :: !Bool
+    , gceDelay                 :: !Word16
+    , gceTransparentColorIndex :: !Word8
+    }
+
+instance Binary GraphicControlExtension where
+    put _ = undefined
+    get = do
+        -- due to missing lookahead
+        {-_extensionLabel  <- getWord8-}
+        _size            <- getWord8
+        packedFields     <- getWord8
+        delay            <- getWord16le
+        idx              <- getWord8
+        _blockTerminator <- getWord8
+        return GraphicControlExtension
+            { gceDisposalMethod        = (packedFields `unsafeShiftR` 2) .&. 0x07
+            , gceUserInputFlag         = packedFields `testBit` 1
+            , gceTransparentFlag       = packedFields `testBit` 0
+            , gceDelay                 = delay
+            , gceTransparentColorIndex = idx
+            }
+
+data GifImage = GifImage
+    { imgDescriptor   :: !ImageDescriptor
+    , imgLocalPalette :: !(Maybe Palette)
+    , imgLzwRootSize  :: !Word8
+    , imgData         :: B.ByteString
+    }
+
+instance Binary GifImage where
+    put _ = undefined
+    get = do
+        desc <- get
+        let hasLocalColorTable = gDescHasLocalMap desc
+        palette <- if hasLocalColorTable
+           then Just <$> getPalette (gDescLocalColorTableSize desc)
+           else pure Nothing
+
+        GifImage desc palette <$> getWord8 <*> parseDataBlocks
+
+data Block = BlockImage GifImage
+           | BlockGraphicControl GraphicControlExtension
+
+parseGifBlocks :: Get [Block]
+parseGifBlocks = getWord8 >>= blockParse
+  where blockParse v
+          | v == gifTrailer = pure []
+          | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks
+          | v == extensionIntroducer = do
+                extensionCode <- getWord8
+                if extensionCode /= graphicControlLabel
+                   then parseDataBlocks >> parseGifBlocks
+                   else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks
+
+        blockParse v = do
+            fail ("Unrecognized gif block " ++ show v)
+
+instance Binary ImageDescriptor where
+    put _ = undefined
+    get = do
+        -- due to missing lookahead
+        {-_imageSeparator <- getWord8-}
+        imgLeftPos <- getWord16le
+        imgTopPos  <- getWord16le
+        imgWidth   <- getWord16le
+        imgHeight  <- getWord16le
+        packedFields <- getWord8
+        let tableSize = packedFields .&. 0x7
+        return ImageDescriptor
+            { gDescPixelsFromLeft = imgLeftPos
+            , gDescPixelsFromTop  = imgTopPos
+            , gDescImageWidth     = imgWidth
+            , gDescImageHeight    = imgHeight
+            , gDescHasLocalMap    = packedFields `testBit` 7
+            , gDescIsInterlaced     = packedFields `testBit` 6
+            , gDescIsImgDescriptorSorted = packedFields `testBit` 5
+            , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0
+            }
+
+
+--------------------------------------------------
+----            Palette
+--------------------------------------------------
+type Palette = Image PixelRGB8
+
+getPalette :: Word8 -> Get Palette
+getPalette bitDepth = replicateM (size * 3) get >>= return . Image size 1 . V.fromList
+  where size = 2 ^ (fromIntegral bitDepth :: Int)
+
+--------------------------------------------------
+----            GifImage
+--------------------------------------------------
+data GifHeader = GifHeader
+  { gifVersion          :: GifVersion
+  , gifScreenDescriptor :: LogicalScreenDescriptor
+  , gifGlobalMap        :: !Palette
+  }
+
+instance Binary GifHeader where
+    put _ = undefined
+    get = do
+        version    <- get
+        screenDesc <- get
+        palette    <- getPalette $ colorTableSize screenDesc
+        return GifHeader
+            { gifVersion = version
+            , gifScreenDescriptor = screenDesc
+            , gifGlobalMap = palette
+            }
+
+data GifFile = GifFile
+    { gifHeader  :: !GifHeader
+    , gifImages  :: [(Maybe GraphicControlExtension, GifImage)]
+    }
+
+associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)]
+associateDescr [] = []
+associateDescr [BlockGraphicControl _] = []
+associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = associateDescr rest
+associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs
+associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) =
+    (Just ctrl, img) : associateDescr xs
+
+instance Binary GifFile where
+    put _ = undefined
+    get = do
+        hdr <- get
+        blocks <- parseGifBlocks
+        return GifFile { gifHeader = hdr
+                       , gifImages = associateDescr blocks }
+
+substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8
+substituteColors palette = pixelMap swaper
+  where swaper n = pixelAt palette (fromIntegral n) 0
+
+decodeImage :: GifImage -> Image Pixel8
+decodeImage img = runST $ runBoolReader $ do
+    outputVector <- lift . M.new $ width * height
+    decodeLzw (imgData img) 12 lzwRoot outputVector
+    frozenData <- lift $ V.unsafeFreeze outputVector
+    return . deinterlaceGif $ Image
+      { imageWidth = width
+      , imageHeight = height
+      , imageData = frozenData
+      }
+  where lzwRoot = fromIntegral $ imgLzwRootSize img
+        width = fromIntegral $ gDescImageWidth descriptor
+        height = fromIntegral $ gDescImageHeight descriptor
+        isInterlaced = gDescIsInterlaced descriptor
+        descriptor = imgDescriptor img
+
+        deinterlaceGif | not isInterlaced = id
+                       | otherwise = deinterlaceGifImage
+
+deinterlaceGifImage :: Image Pixel8 -> Image Pixel8
+deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h
+   where lineIndices = gifInterlacingIndices h
+         generator x y = pixelAt img x y'
+            where y' = lineIndices V.! y
+
+gifInterlacingIndices :: Int -> V.Vector Int
+gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices
+    where indices = flip zip [0..] $
+                concat [ [0,     8 .. height - 1]
+                       , [4, 4 + 8 .. height - 1]
+                       , [2, 2 + 4 .. height - 1]
+                       , [1, 1 + 2 .. height - 1]
+                       ]
+
+paletteOf :: Palette -> GifImage -> Palette
+paletteOf global GifImage { imgLocalPalette = Nothing } = global
+paletteOf      _ GifImage { imgLocalPalette = Just p  } = p
+
+decodeAllGifImages :: GifFile -> [Image PixelRGB8]
+decodeAllGifImages GifFile { gifImages = [] } = []
+decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette
+                                                   , gifScreenDescriptor = wholeDescriptor
+                                                   }
+                           , gifImages = (_, firstImage) : rest } = map paletteApplyer $
+ scanl generator (paletteOf palette firstImage, decodeImage firstImage) rest
+    where globalWidth = fromIntegral $ screenWidth wholeDescriptor
+          globalHeight = fromIntegral $ screenHeight wholeDescriptor
+
+          {-background = backgroundIndex wholeDescriptor-}
+
+          paletteApplyer (pal, img) = substituteColors pal img
+
+          generator (_, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) =
+                        (paletteOf palette img2, generateImage pixeler globalWidth globalHeight)
+               where localWidth = fromIntegral $ gDescImageWidth descriptor
+                     localHeight = fromIntegral $ gDescImageHeight descriptor
+
+                     left = fromIntegral $ gDescPixelsFromLeft descriptor
+                     top = fromIntegral $ gDescPixelsFromTop descriptor
+
+                     isPixelInLocalImage x y =
+                         x >= left && x < left + localWidth && y >= top && y < top + localHeight
+
+                     decoded = decodeImage img2
+
+                     transparent :: Int
+                     transparent = case controlExt of
+                        Nothing  -> 300
+                        Just ext -> if gceTransparentFlag ext
+                            then fromIntegral $ gceTransparentColorIndex ext
+                            else 300
+
+                     pixeler x y
+                        | isPixelInLocalImage x y && fromIntegral val /= transparent = val
+                            where val = pixelAt decoded (x - left) (y - top)
+                     pixeler x y = pixelAt img1 x y
+
+decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8)
+decodeFirstGifImage
+        GifFile { gifHeader = GifHeader { gifGlobalMap = palette}
+                , gifImages = ((_, gif):_) } = Right . substituteColors palette $ decodeImage gif
+decodeFirstGifImage _ = Left "No image in gif file"
+
+-- | Transform a raw gif image to an image, witout
+-- modifying the pixels.
+-- This function can output the following pixel types :
+--
+--  * PixelRGB8
+--
+decodeGif :: B.ByteString -> Either String DynamicImage
+decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage)
+
+-- | Transform a raw gif to a list of images, representing
+-- all the images of an animation.
+decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8]
+decodeGifImages img = decodeAllGifImages <$> decode img
+

@@ -1,12 +1,13 @@-module Codec.Picture.Gif.LZW( decodeLzw, lzw ) where
+module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where
 
 import Data.Word( Word8 )
 import Control.Applicative( (<$>) )
 import Control.Monad( when )
 
-{-import Control.Monad.ST( ST )-}
+import Data.Bits( (.&.) )
+
+import Control.Monad.ST( ST )
 import Control.Monad.Trans.Class( MonadTrans, lift )
-import Control.Monad.Primitive ( PrimState, PrimMonad )
 
 import Foreign.Storable ( Storable )
 
@@ -16,29 +17,29 @@ import Codec.Picture.BitWriter
 
 {-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a)
-        => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = M.unsafeRead -- M.read
+(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a
+(.!!!.) = M.unsafeRead 
+        {-M.read-}
 
 {-# INLINE (..!!!..) #-}
-(..!!!..) :: (MonadTrans t, PrimMonad m, Storable a)
-        => M.STVector (PrimState m) a -> Int -> t m a
+(..!!!..) :: (MonadTrans t, Storable a)
+          => M.STVector s a -> Int -> t (ST s) a
 (..!!!..) v idx = lift $ v .!!!. idx
 
 {-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a)
-       => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = M.unsafeWrite -- M.write
+(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s ()
+(.<-.) = M.unsafeWrite 
+         {-M.write-}
 
 {-# INLINE (..<-..) #-}
-(..<-..) :: (MonadTrans t, PrimMonad m, Storable a)
-         => M.STVector (PrimState m) a -> Int -> a -> t m ()
+(..<-..) :: (MonadTrans t, Storable a)
+         => M.STVector s a -> Int -> a -> t (ST s) ()
 (..<-..) v idx = lift . (v .<-. idx)
 
 
-duplicateData :: (MonadTrans t, PrimMonad m, Storable a)
-              => M.STVector (PrimState m) a -> M.STVector (PrimState m) a
-              -> Int -> Int -> Int -> t m ()
+duplicateData :: (Show a, MonadTrans t, Storable a)
+              => M.STVector s a -> M.STVector s a
+              -> Int -> Int -> Int -> t (ST s) ()
 duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex
   where endIndex = sourceIndex + size
         aux i _ | i == endIndex  = return ()
@@ -46,9 +47,9 @@           src .!!!. i >>= (dest .<-. j)
           aux (i + 1) (j + 1)
 
-rangeSetter :: (PrimMonad m, Storable a, Num a)
-            => Int -> M.STVector (PrimState m) a
-            -> m (M.STVector (PrimState m) a)
+rangeSetter :: (Storable a, Num a)
+            => Int -> M.STVector s a
+            -> ST s (M.STVector s a)
 rangeSetter count vec = aux 0
   where aux n | n == count = return vec
         aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1)
@@ -57,69 +58,132 @@           -> BoolReader s ()
 decodeLzw str maxBitKey initialKey outVec = do
     setDecodedString str
-    lzw maxBitKey initialKey outVec
+    lzw GifVariant maxBitKey initialKey 0 outVec
 
+isOldTiffLZW :: B.ByteString -> Bool
+isOldTiffLZW str = firstByte == 0 && secondByte == 1
+    where firstByte = str `B.index` 0
+          secondByte = (str `B.index` 1) .&. 1
+
+decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int
+              -> BoolReader s()
+decodeLzwTiff str outVec initialWriteIdx = do
+    setDecodedString str
+    let variant | isOldTiffLZW str = OldTiffVariant
+                | otherwise = TiffVariant
+    lzw variant 12 9 initialWriteIdx outVec
+
+data TiffVariant =
+      GifVariant
+    | TiffVariant
+    | OldTiffVariant
+    deriving Eq
+
 -- | Gif image constraint from spec-gif89a, code size max : 12 bits.
-lzw :: Int -> Int -> M.STVector s Word8
+lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8
     -> BoolReader s ()
-lzw nMaxBitKeySize initialKeySize outVec = do
+lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do
     -- Allocate buffer of maximum size.
-    lzwData <- lift (M.new maxDataSize) >>= resetArray
-    lzwOffsetTable <- lift (M.new tableEntryCount) >>= resetArray
-    lzwSizeTable <- lift $ M.new tableEntryCount
+    lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray
+    lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray
+    lzwSizeTable <- lift $ M.replicate tableEntryCount 0
     lift $ lzwSizeTable `M.set` 1
 
-    let maxWrite = M.length outVec
-        loop outWriteIdx writeIdx dicWriteIdx codeSize code
-          | outWriteIdx >= maxWrite = return ()
-          | code == endOfInfo = return ()
-          | code == clearCode =
-              getNextCode startCodeSize >>=
-                loop outWriteIdx firstFreeIndex firstFreeIndex startCodeSize
+    let firstVal code = do
+            dataOffset <- lzwOffsetTable ..!!!.. code
+            lzwData ..!!!.. dataOffset
 
-          | otherwise = do
-              dataOffset <- lzwOffsetTable ..!!!.. code
-              dataSize <- lzwSizeTable  ..!!!.. code
+        writeString at code = do
+            dataOffset <- lzwOffsetTable ..!!!.. code
+            dataSize   <- lzwSizeTable   ..!!!.. code
 
-              when (writeIdx < tableEntryCount) $ do
-                  when (outWriteIdx /= 0) $ do
-                     firstVal <- lzwData ..!!!.. dataOffset
-                     (lzwData ..<-.. (dicWriteIdx - 1)) firstVal
+            when (at + dataSize <= maxWrite) $
+                 duplicateData lzwData outVec dataOffset dataSize at
 
-                  when (dicWriteIdx + dataSize <= maxDataSize) $
-                       duplicateData lzwData lzwData dataOffset dataSize dicWriteIdx
+            return dataSize
 
+        addString pos at code val = do
+            dataOffset <- lzwOffsetTable ..!!!.. code
+            dataSize   <- lzwSizeTable   ..!!!.. code
 
-                  (lzwSizeTable ..<-.. writeIdx) $ dataSize + 1
-                  (lzwOffsetTable ..<-.. writeIdx) dicWriteIdx
+            when (pos < tableEntryCount) $ do
+              (lzwOffsetTable ..<-.. pos) at
+              (lzwSizeTable ..<-.. pos) $ dataSize + 1
 
-              when (outWriteIdx + dataSize <= maxWrite) $
-                   duplicateData lzwData outVec dataOffset dataSize outWriteIdx
+            when (at + dataSize + 1 <= maxDataSize) $ do
+              duplicateData lzwData lzwData dataOffset dataSize at
+              (lzwData ..<-.. (at + dataSize)) val
 
-              getNextCode codeSize >>=
-                loop (outWriteIdx + dataSize)
+            return $ dataSize + 1
+
+        maxWrite = M.length outVec
+        loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code
+          | outWriteIdx >= maxWrite = return ()
+          | code == endOfInfo = return ()
+          | code == clearCode = do
+              toOutput <- getNextCode startCodeSize
+              if toOutput == endOfInfo then
+                return ()
+              else do
+                dataSize <- writeString outWriteIdx toOutput
+                getNextCode startCodeSize >>=
+                  loop (outWriteIdx + dataSize)
+                       firstFreeIndex firstFreeIndex startCodeSize toOutput
+
+          | otherwise =  do
+              (written, dicAdd) <-
+                   if code >= writeIdx then do
+                     c <- firstVal oldCode
+                     wroteSize <- writeString outWriteIdx oldCode
+                     (outVec ..<-.. (outWriteIdx + wroteSize)) c
+                     addedSize <- addString writeIdx dicWriteIdx oldCode c
+                     return (wroteSize + 1, addedSize)
+                   else do
+                     wroteSize <- writeString outWriteIdx code
+                     c <- firstVal code
+                     addedSize <- addString writeIdx dicWriteIdx oldCode c
+                     return (wroteSize, addedSize)
+
+              let new_code_size = updateCodeSize codeSize $ writeIdx + 1
+              getNextCode new_code_size >>=
+                loop (outWriteIdx + written)
                      (writeIdx + 1)
-                     (dicWriteIdx + dataSize + 1) (updateCodeSize codeSize $ writeIdx + 1)
+                     (dicWriteIdx + dicAdd)
+                     new_code_size
+                     code
 
     getNextCode startCodeSize >>=
-        loop 0 firstFreeIndex firstFreeIndex startCodeSize
+        loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0
 
   where tableEntryCount =  2 ^ min 12 nMaxBitKeySize
-        maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount)
+        maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1
 
+        isNewTiff = variant == TiffVariant
+        (switchOffset,  isTiffVariant) = case variant of
+            GifVariant -> (0, False)
+            TiffVariant -> (1, True)
+            OldTiffVariant -> (0, True)
+
         initialElementCount = 2 ^ initialKeySize :: Int
-        clearCode = initialElementCount
-        endOfInfo = clearCode + 1
-        startCodeSize = initialKeySize + 1
+        clearCode | isTiffVariant = 256
+                  | otherwise = initialElementCount
 
+        endOfInfo | isTiffVariant = 257
+                  | otherwise = clearCode + 1
+
+        startCodeSize 
+                  | isTiffVariant = initialKeySize
+                  | otherwise = initialKeySize + 1
+
         firstFreeIndex = endOfInfo + 1
 
         resetArray a = lift $ rangeSetter initialElementCount a
 
         updateCodeSize codeSize writeIdx
-            | writeIdx == 2 ^ codeSize = min 12 $ codeSize + 1
+            | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1
             | otherwise = codeSize
 
-        getNextCode s = fromIntegral <$> getNextBits s
-
+        getNextCode s 
+            | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s
+            | otherwise = fromIntegral <$> getNextBitsLSBFirst s
 

@@ -1,449 +1,462 @@--- | Module dedicated of Radiance file decompression (.hdr or .pic) file.--- Radiance file format is used for High dynamic range imaging.-module Codec.Picture.HDR( decodeHDR, encodeHDR, writeHDR ) where--import Data.Bits( Bits, (.&.), (.|.), shiftL, shiftR )-import Data.Char( ord, chr, isDigit )-import Data.Word( Word8 )-import Data.Monoid( (<>) )-import Control.Applicative( pure, (<$>), (<*>) )-import Control.Monad( when, foldM, foldM_, forM_ )-import Control.Monad.Trans.Class( lift )-import Control.Monad.Trans.Error( ErrorT, throwError, runErrorT )-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Char8 as BC--import Data.List( partition )-import Data.Binary( Binary( .. ), encode )-import Data.Binary.Get( Get, getByteString, getWord8 )-import Data.Binary.Put( putByteString )--import Control.Monad.ST( ST, runST )-import Foreign.Storable ( Storable )-import Control.Monad.Primitive ( PrimState, PrimMonad )-import qualified Data.Vector.Storable.Mutable as M--import Codec.Picture.InternalHelper-import Codec.Picture.BitWriter-import Codec.Picture.Types--import Debug.Trace-import Text.Printf( printf )--{-# INLINE (.<<.) #-}-(.<<.), (.>>.) :: (Bits a) => a -> Int -> a-(.<<.) = shiftL-(.>>.) = shiftR--{-# INLINE (.!!!.) #-}-(.!!!.) :: (PrimMonad m, Storable a)-        => M.STVector (PrimState m) a -> Int -> m a-(.!!!.) = M.read-          {-M.unsafeRead-}--{-# INLINE (.<-.) #-}-(.<-.) :: (PrimMonad m, Storable a)-       => M.STVector (PrimState m) a -> Int -> a -> m ()-(.<-.) = M.write -         {-M.unsafeWrite-}--type HDRReader s a = ErrorT String (ST s) a--data RGBE = RGBE !Word8 !Word8 !Word8 !Word8--instance Binary RGBE where-    put (RGBE r g b e) = put r >> put g >> put b >> put e-    get = RGBE <$> get <*> get <*> get <*> get--checkLineLength :: RGBE -> Int-checkLineLength (RGBE _ _ a b) =-    (fromIntegral a .<<. 8) .|. fromIntegral b--isNewRunLengthMarker :: RGBE -> Bool-isNewRunLengthMarker (RGBE 2 2 _ _) = True-isNewRunLengthMarker _ = False--data RadianceFormat =-      FormatRGBE-    | FormatXYZE--radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString-radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe"-radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze"--instance Binary RadianceFormat where-  put FormatRGBE = putByteString radiance32bitRleRGBEFormat-  put FormatXYZE = putByteString radiance32bitRleXYZEFromat--  get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format-    where format sig-            | sig == radiance32bitRleRGBEFormat = pure FormatRGBE-            | sig == radiance32bitRleXYZEFromat = pure FormatXYZE-            | otherwise = fail "Unrecognized Radiance format"--toRGBE :: PixelRGBF -> RGBE-toRGBE (PixelRGBF r g b)-    | d <= 1e-32 = RGBE 0 0 0 0-    | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128)-  where d = maximum [r, g, b]-        e = exponent d-        coeff = significand d *  255.9999 / d-        fix v = truncate $ v * coeff---dropUntil :: Word8 -> Get ()-dropUntil c = getWord8 >>= inner-  where inner val | val == c = pure ()-        inner _ = getWord8 >>= inner--getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString-getUntil f initialAcc = getWord8 >>= inner initialAcc-  where inner acc c | f c = pure acc-        inner acc c = getWord8 >>= inner (B.snoc acc c)--data RadianceHeader = RadianceHeader-  { radianceInfos :: [(B.ByteString, B.ByteString)]-  , radianceFormat :: RadianceFormat-  , radianceHeight :: !Int-  , radianceWidth  :: !Int-  , radianceData   :: B.ByteString-  }--radianceFileSignature :: B.ByteString-radianceFileSignature = BC.pack "#?RADIANCE\n"--unpackColor :: B.ByteString -> Int -> RGBE-unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3)-  where at n = B.index str $ idx + n--storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()-storeColor vec idx (RGBE r g b e) = do-    (vec .<-. (idx + 0)) r-    (vec .<-. (idx + 1)) g-    (vec .<-. (idx + 2)) b-    (vec .<-. (idx + 3)) e--parsePair :: Char -> Get (B.ByteString, B.ByteString)-parsePair firstChar = do-    let eol c = c == fromIntegral (ord '\n')-    line <- getUntil eol B.empty-    case BC.split '=' line of-      [] -> pure (BC.singleton firstChar, B.empty)-      [val] -> pure (BC.singleton firstChar, val)-      [key, val] -> pure (BC.singleton firstChar <> key, val)-      (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals)--decodeInfos :: Get [(B.ByteString, B.ByteString)]-decodeInfos = do-    char <- getChar8-    case char of-      -- comment-      '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos-      -- end of header, no more information-      '\n' -> pure []-      -- Classical parsing-      c -> (:) <$> parsePair c <*> decodeInfos----- | Decode an HDR (radiance) image, the resulting pixel--- type can be :------  * PixelRGBF----decodeHDR :: B.ByteString -> Either String DynamicImage-decodeHDR str = runST $ runErrorT $ do-    case runGet decodeHeader $ L.fromChunks [str] of-      Left err -> throwError err-      Right rez ->-          ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage)--getChar8 :: Get Char-getChar8 = chr . fromIntegral <$> getWord8--isSign :: Char -> Bool-isSign c = c == '+' || c == '-'--isAxisLetter :: Char -> Bool-isAxisLetter c = c == 'X' || c == 'Y'--decodeNum :: Get Int-decodeNum = do-    sign <- getChar8-    letter <- getChar8-    space <- getChar8--    when (not $ isSign sign && isAxisLetter letter && space == ' ')-         (fail "Invalid radiance size declaration")--    let numDec acc c | isDigit c =-            getChar8 >>= numDec (acc * 10 + ord c - (ord '0'))-        numDec acc _-            | sign == '-' = pure $ negate acc-            | otherwise = pure acc--    getChar8 >>= numDec 0--copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()-copyPrevColor scanLine idx = do-    r <- scanLine .!!!. (idx - 4)-    g <- scanLine .!!!. (idx - 3)-    b <- scanLine .!!!. (idx - 2)-    e <- scanLine .!!!. (idx - 1)--    (scanLine .<-. (idx + 0)) r-    (scanLine .<-. (idx + 1)) g-    (scanLine .<-. (idx + 2)) b-    (scanLine .<-. (idx + 3)) e--oldStyleRLE :: B.ByteString -> Int -> M.STVector s Word8-            -> HDRReader s Int-oldStyleRLE inputData initialIdx scanLine = trace "oldStyleRLE" $ inner initialIdx 0 0-  where maxOutput = M.length scanLine-        maxInput = B.length inputData--        inner readIdx writeIdx _-            | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx-        inner readIdx writeIdx shift = trace (printf "r:%d w:%d (mi:%d mo:%d)" readIdx writeIdx maxInput maxOutput) $ do-          let color@(RGBE r g b e) = unpackColor inputData readIdx-              isRun = r == 1 && g == 1 && b == 1--          if not isRun-            then do-              lift $ storeColor scanLine writeIdx color-              inner (readIdx + 4) (writeIdx + 4) 0-         -            else do-              let count = fromIntegral e .<<. shift-              lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i)-              inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8)--newStyleRLE :: B.ByteString -> Int -> M.STVector s Word8-            -> HDRReader s Int-newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3]-  where dataAt idx-            | idx >= maxInput = throwError $ "Read index out of bound (" ++ show idx ++ ")"-            | otherwise = pure $ B.index inputData idx--        maxOutput = M.length scanline-        maxInput = B.length inputData-        stride = 4---        strideSet count destIndex _ | endIndex > maxOutput + stride =-          throwError $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")"-            where endIndex = destIndex + count * stride-        strideSet count destIndex val = aux destIndex count-            where aux i 0 =  pure i-                  aux i c = do-                    lift $ (scanline .<-. i) val-                    aux (i + stride) (c - 1)---        strideCopy _ count destIndex-            | writeEndBound > maxOutput + stride = throwError "Out of bound HDR scanline"-                where writeEndBound = destIndex + count * stride-        strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count-          where aux _ j 0 = pure j-                aux i j c = do-                    val <- dataAt i-                    lift $ (scanline .<-. j) val-                    aux (i + 1) (j + stride) (c - 1)--        inner readIdx writeIdx-            | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx-        inner readIdx writeIdx = do-          code <- dataAt readIdx-          if code > 128-            then do-              let repeatCount = fromIntegral code .&. 0x7F-              newVal <- dataAt $ readIdx + 1-              endIndex <- strideSet repeatCount writeIdx newVal-              inner (readIdx + 2) endIndex --            else do-              let iCode = fromIntegral code-              endIndex <- strideCopy (readIdx + 1) iCode writeIdx-              inner (readIdx + iCode + 1) endIndex--instance Binary RadianceHeader where-    get = decodeHeader-    put hdr = do-        putByteString radianceFileSignature-        putByteString $ BC.pack "FORMAT="-        put $ radianceFormat hdr-        let sizeString =-              BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr)-                        ++ " +X " ++ show (radianceWidth hdr) ++ "\n"-        putByteString sizeString-        putByteString $ radianceData hdr---decodeHeader :: Get RadianceHeader-decodeHeader = do-    sig <- getByteString $ B.length radianceFileSignature-    when (sig /= radianceFileSignature)-         (fail "Invalid radiance file signature")--    infos <- decodeInfos-    let formatKey = BC.pack "FORMAT"-    case partition (\(k,_) -> k /= formatKey) infos of-      (_, []) -> fail "No radiance format specified"-      (info, [(_, formatString)]) ->-        case runGet get $ L.fromChunks [formatString] of-          Left err -> fail err-          Right format ->-              RadianceHeader info format <$> decodeNum-                                         <*> decodeNum-                                         <*> getRemainingBytes--      _ -> fail "Multiple radiance format specified"--toFloat :: RGBE -> PixelRGBF-toFloat (RGBE r g b e) = PixelRGBF rf gf bf-  where f = encodeFloat 1 $ fromIntegral e - (128 + 8)-        rf = (fromIntegral r + 0.0) * f-        gf = (fromIntegral g + 0.0) * f-        bf = (fromIntegral b + 0.0) * f--encodeScanlineColor :: M.MVector s Word8 -> BoolWriter s ()-encodeScanlineColor vec = do-    val <- lift $ vec .!!!. 0-    runLength 1 0 val 1-  where maxIndex = M.length vec--        pushRun len val = do-            pushByte . fromIntegral $ len .|. 0x80-            pushByte val--        pushData start len = do-            pushByte $ fromIntegral len-            forM_ [start - len .. start - 1] $ \i ->-                lift (vec .!!!. i) >>= pushByte--        -- End of scanline, empty the thing-        runLength run cpy prev idx | idx >= maxIndex =-            case (run, cpy) of-                (0, 0) -> pure ()-                (0, n) -> pushData idx n-                (n, 0) -> pushRun n prev-                (_, _) -> error "HDR - Run length algorithm is wrong"--        -- full runlength, we must write the packet-        runLength r@127   _ prev idx = do-            pushRun r prev-            val <- lift $ vec .!!!. idx-            runLength 1 0 val $ idx + 1--        -- full copy, we must write the packet-        runLength   _ c@127    _ idx = do-            pushData idx c-            val <- lift $ vec .!!!. idx-            runLength 1 0 val $ idx + 1--        runLength n 0 prev idx = do-            val <- lift $ vec .!!!. idx-            case val == prev of-               True -> runLength (n + 1) 0 prev $ idx + 1-               False | n < 4 -> runLength 0 (n + 1) val $ idx + 1-               False -> do-                    pushRun n prev-                    runLength 1 0 val $ idx + 1--        runLength 0 n prev idx = do-            val <- lift $ vec .!!!. idx-            if val /= prev-               then runLength 0 (n + 1) val $ idx + 1-               else do-                pushData (idx - 1) $ n - 1-                runLength (2 :: Int) 0 val $ idx + 1--        runLength _ _ _ _ =-            error "HDR RLE inconsistent state"---- | Write an High dynamic range image into a radiance--- image file on disk.-writeHDR :: FilePath -> Image PixelRGBF -> IO ()-writeHDR filename img = L.writeFile filename $ encodeHDR img---- | Encode an High dynamic range image into a radiance image--- file format.-encodeHDR :: Image PixelRGBF -> L.ByteString-encodeHDR pic = encode $ runST $ do-    let w = imageWidth pic-        h = imageHeight pic--    scanLineR <- M.new w-    scanLineG <- M.new w-    scanLineB <- M.new w-    scanLineE <- M.new w--    encoded <- runBoolWriter $ do-        forM_ [0 .. h - 1] $ \line -> do-            forM_ [0 .. w - 1] $ \i -> do-                let RGBE r g b e = toRGBE $ pixelAt pic i line-                lift $ (scanLineR .<-. i) r-                lift $ (scanLineG .<-. i) g-                lift $ (scanLineB .<-. i) b-                lift $ (scanLineE .<-. i) e--            mapM_ pushByte [2, 2-                           , fromIntegral ((w .>>. 8) .&. 0xFF)-                           , fromIntegral (w .&. 0xFF)]-            encodeScanlineColor scanLineR-            encodeScanlineColor scanLineG-            encodeScanlineColor scanLineB-            encodeScanlineColor scanLineE--    pure $ RadianceHeader-        { radianceInfos = []-        , radianceFormat = FormatRGBE-        , radianceHeight = h-        , radianceWidth  = w-        , radianceData = encoded -        }-    --decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF))-decodeRadiancePicture hdr = do-    let width = abs $ radianceWidth hdr-        height = abs $ radianceHeight hdr-        packedData = radianceData hdr--    scanLine <- lift $ M.new $ width * 4-    resultBuffer <- lift $ M.new $ width * height * 3--    let scanLineImage = MutableImage-                      { mutableImageWidth = width-                      , mutableImageHeight = 1-                      , mutableImageData = scanLine-                      }--        finalImage = MutableImage-                   { mutableImageWidth = width-                   , mutableImageHeight = height-                   , mutableImageData = resultBuffer-                   }--    let scanLineExtractor readIdx line = do-          let color = unpackColor packedData readIdx-              inner | isNewRunLengthMarker color = do-                          let calcSize = checkLineLength color-                          when (calcSize /= width)-                               (throwError "Invalid sanline size")-                          pure $ \idx -> newStyleRLE packedData (idx + 4)-                    | otherwise = pure $ oldStyleRLE packedData-          f <- inner-          newRead <- f readIdx scanLine-          forM_ [0 .. width - 1] $ \i -> do-              -- mokay, it's a hack, but I don't want to define a-              -- pixel instance of RGBE...-              PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0-              lift $ writePixel finalImage i line . toFloat $ RGBE r g b e--          return newRead--    foldM_ scanLineExtractor 0 [0 .. height - 1]--    return finalImage-+-- | Module dedicated of Radiance file decompression (.hdr or .pic) file.
+-- Radiance file format is used for High dynamic range imaging.
+module Codec.Picture.HDR( decodeHDR, encodeHDR, writeHDR ) where
+
+import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR )
+import Data.Char( ord, chr, isDigit )
+import Data.Word( Word8 )
+import Data.Monoid( (<>) )
+import Control.Applicative( pure, (<$>), (<*>) )
+import Control.Monad( when, foldM, foldM_, forM, forM_ )
+import Control.Monad.Trans.Class( lift )
+import Control.Monad.Trans.Error( ErrorT, throwError, runErrorT )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as BC
+
+import Data.List( partition )
+import Data.Binary( Binary( .. ), encode )
+import Data.Binary.Get( Get, getByteString, getWord8 )
+import Data.Binary.Put( putByteString, putLazyByteString )
+
+import Control.Monad.ST( ST, runST )
+import Foreign.Storable ( Storable )
+import Control.Monad.Primitive ( PrimState, PrimMonad )
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as M
+
+import Codec.Picture.InternalHelper
+import Codec.Picture.Types
+import Codec.Picture.VectorByteConversion
+
+{-# INLINE (.<<.) #-}
+(.<<.), (.>>.) :: (Bits a) => a -> Int -> a
+(.<<.) = unsafeShiftL
+(.>>.) = unsafeShiftR
+
+{-# INLINE (.<-.) #-}
+(.<-.) :: (PrimMonad m, Storable a)
+       => M.STVector (PrimState m) a -> Int -> a -> m ()
+(.<-.) = M.write 
+         {-M.unsafeWrite-}
+
+type HDRReader s a = ErrorT String (ST s) a
+
+data RGBE = RGBE !Word8 !Word8 !Word8 !Word8
+
+instance Binary RGBE where
+    put (RGBE r g b e) = put r >> put g >> put b >> put e
+    get = RGBE <$> get <*> get <*> get <*> get
+
+checkLineLength :: RGBE -> Int
+checkLineLength (RGBE _ _ a b) =
+    (fromIntegral a .<<. 8) .|. fromIntegral b
+
+isNewRunLengthMarker :: RGBE -> Bool
+isNewRunLengthMarker (RGBE 2 2 _ _) = True
+isNewRunLengthMarker _ = False
+
+data RadianceFormat =
+      FormatRGBE
+    | FormatXYZE
+
+radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString
+radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe"
+radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze"
+
+instance Binary RadianceFormat where
+  put FormatRGBE = putByteString radiance32bitRleRGBEFormat
+  put FormatXYZE = putByteString radiance32bitRleXYZEFromat
+
+  get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format
+    where format sig
+            | sig == radiance32bitRleRGBEFormat = pure FormatRGBE
+            | sig == radiance32bitRleXYZEFromat = pure FormatXYZE
+            | otherwise = fail "Unrecognized Radiance format"
+
+toRGBE :: PixelRGBF -> RGBE
+toRGBE (PixelRGBF r g b)
+    | d <= 1e-32 = RGBE 0 0 0 0
+    | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128)
+  where d = maximum [r, g, b]
+        e = exponent d
+        coeff = significand d *  255.9999 / d
+        fix v = truncate $ v * coeff
+
+
+dropUntil :: Word8 -> Get ()
+dropUntil c = getWord8 >>= inner
+  where inner val | val == c = pure ()
+        inner _ = getWord8 >>= inner
+
+getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString
+getUntil f initialAcc = getWord8 >>= inner initialAcc
+  where inner acc c | f c = pure acc
+        inner acc c = getWord8 >>= inner (B.snoc acc c)
+
+data RadianceHeader = RadianceHeader
+  { radianceInfos :: [(B.ByteString, B.ByteString)]
+  , radianceFormat :: RadianceFormat
+  , radianceHeight :: !Int
+  , radianceWidth  :: !Int
+  , radianceData   :: L.ByteString
+  }
+
+radianceFileSignature :: B.ByteString
+radianceFileSignature = BC.pack "#?RADIANCE\n"
+
+unpackColor :: L.ByteString -> Int -> RGBE
+unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3)
+  where at n = L.index str . fromIntegral $ idx + n
+
+storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s ()
+storeColor vec idx (RGBE r g b e) = do
+    (vec .<-. (idx + 0)) r
+    (vec .<-. (idx + 1)) g
+    (vec .<-. (idx + 2)) b
+    (vec .<-. (idx + 3)) e
+
+parsePair :: Char -> Get (B.ByteString, B.ByteString)
+parsePair firstChar = do
+    let eol c = c == fromIntegral (ord '\n')
+    line <- getUntil eol B.empty
+    case BC.split '=' line of
+      [] -> pure (BC.singleton firstChar, B.empty)
+      [val] -> pure (BC.singleton firstChar, val)
+      [key, val] -> pure (BC.singleton firstChar <> key, val)
+      (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals)
+
+decodeInfos :: Get [(B.ByteString, B.ByteString)]
+decodeInfos = do
+    char <- getChar8
+    case char of
+      -- comment
+      '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos
+      -- end of header, no more information
+      '\n' -> pure []
+      -- Classical parsing
+      c -> (:) <$> parsePair c <*> decodeInfos
+
+
+-- | Decode an HDR (radiance) image, the resulting pixel
+-- type can be :
+--
+--  * PixelRGBF
+--
+decodeHDR :: B.ByteString -> Either String DynamicImage
+decodeHDR str = runST $ runErrorT $ do
+    case runGet decodeHeader $ L.fromChunks [str] of
+      Left err -> throwError err
+      Right rez ->
+          ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage)
+
+getChar8 :: Get Char
+getChar8 = chr . fromIntegral <$> getWord8
+
+isSign :: Char -> Bool
+isSign c = c == '+' || c == '-'
+
+isAxisLetter :: Char -> Bool
+isAxisLetter c = c == 'X' || c == 'Y'
+
+decodeNum :: Get Int
+decodeNum = do
+    sign <- getChar8
+    letter <- getChar8
+    space <- getChar8
+
+    when (not $ isSign sign && isAxisLetter letter && space == ' ')
+         (fail "Invalid radiance size declaration")
+
+    let numDec acc c | isDigit c =
+            getChar8 >>= numDec (acc * 10 + ord c - (ord '0'))
+        numDec acc _
+            | sign == '-' = pure $ negate acc
+            | otherwise = pure acc
+
+    getChar8 >>= numDec 0
+
+copyPrevColor :: M.STVector s Word8 -> Int -> ST s ()
+copyPrevColor scanLine idx = do
+    r <- scanLine `M.unsafeRead` (idx - 4)
+    g <- scanLine `M.unsafeRead` (idx - 3)
+    b <- scanLine `M.unsafeRead` (idx - 2)
+    e <- scanLine `M.unsafeRead` (idx - 1)
+
+    (scanLine `M.unsafeWrite` (idx + 0)) r
+    (scanLine `M.unsafeWrite` (idx + 1)) g
+    (scanLine `M.unsafeWrite` (idx + 2)) b
+    (scanLine `M.unsafeWrite` (idx + 3)) e
+
+oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
+            -> HDRReader s Int
+oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0
+  where maxOutput = M.length scanLine
+        maxInput = fromIntegral $ L.length inputData
+
+        inner readIdx writeIdx _
+            | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
+        inner readIdx writeIdx shift = do
+          let color@(RGBE r g b e) = unpackColor inputData readIdx
+              isRun = r == 1 && g == 1 && b == 1
+
+          if not isRun
+            then do
+              lift $ storeColor scanLine writeIdx color
+              inner (readIdx + 4) (writeIdx + 4) 0
+         
+            else do
+              let count = fromIntegral e .<<. shift
+              lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i)
+              inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8)
+
+newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8
+            -> HDRReader s Int
+newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3]
+  where dataAt idx
+            | fromIntegral idx >= maxInput = throwError $ "Read index out of bound (" ++ show idx ++ ")"
+            | otherwise = pure $ L.index inputData (fromIntegral idx)
+
+        maxOutput = M.length scanline
+        maxInput = fromIntegral $ L.length inputData
+        stride = 4
+
+
+        strideSet count destIndex _ | endIndex > maxOutput + stride =
+          throwError $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")"
+            where endIndex = destIndex + count * stride
+        strideSet count destIndex val = aux destIndex count
+            where aux i 0 =  pure i
+                  aux i c = do
+                    lift $ (scanline .<-. i) val
+                    aux (i + stride) (c - 1)
+
+
+        strideCopy _ count destIndex
+            | writeEndBound > maxOutput + stride = throwError "Out of bound HDR scanline"
+                where writeEndBound = destIndex + count * stride
+        strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count
+          where aux _ j 0 = pure j
+                aux i j c = do
+                    val <- dataAt i
+                    lift $ (scanline .<-. j) val
+                    aux (i + 1) (j + stride) (c - 1)
+
+        inner readIdx writeIdx
+            | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx
+        inner readIdx writeIdx = do
+          code <- dataAt readIdx
+          if code > 128
+            then do
+              let repeatCount = fromIntegral code .&. 0x7F
+              newVal <- dataAt $ readIdx + 1
+              endIndex <- strideSet repeatCount writeIdx newVal
+              inner (readIdx + 2) endIndex 
+
+            else do
+              let iCode = fromIntegral code
+              endIndex <- strideCopy (readIdx + 1) iCode writeIdx
+              inner (readIdx + iCode + 1) endIndex
+
+instance Binary RadianceHeader where
+    get = decodeHeader
+    put hdr = do
+        putByteString radianceFileSignature
+        putByteString $ BC.pack "FORMAT="
+        put $ radianceFormat hdr
+        let sizeString =
+              BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr)
+                        ++ " +X " ++ show (radianceWidth hdr) ++ "\n"
+        putByteString sizeString
+        putLazyByteString $ radianceData hdr
+
+
+decodeHeader :: Get RadianceHeader
+decodeHeader = do
+    sig <- getByteString $ B.length radianceFileSignature
+    when (sig /= radianceFileSignature)
+         (fail "Invalid radiance file signature")
+
+    infos <- decodeInfos
+    let formatKey = BC.pack "FORMAT"
+    case partition (\(k,_) -> k /= formatKey) infos of
+      (_, []) -> fail "No radiance format specified"
+      (info, [(_, formatString)]) ->
+        case runGet get $ L.fromChunks [formatString] of
+          Left err -> fail err
+          Right format -> do
+              (n1, n2, b) <- (,,) <$> decodeNum
+                                  <*> decodeNum
+                                  <*> getRemainingBytes
+              return . RadianceHeader info format n1 n2 $ L.fromChunks [b]
+
+      _ -> fail "Multiple radiance format specified"
+
+toFloat :: RGBE -> PixelRGBF
+toFloat (RGBE r g b e) = PixelRGBF rf gf bf
+  where f = encodeFloat 1 $ fromIntegral e - (128 + 8)
+        rf = (fromIntegral r + 0.0) * f
+        gf = (fromIntegral g + 0.0) * f
+        bf = (fromIntegral b + 0.0) * f
+
+encodeScanlineColor :: M.STVector s Word8
+                    -> M.STVector s Word8
+                    -> Int
+                    -> ST s Int
+encodeScanlineColor vec outVec outIdx = do
+    val <- vec `M.unsafeRead` 0
+    runLength 1 0 val 1 outIdx
+  where maxIndex = M.length vec
+
+        pushRun len val at = do
+            (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80
+            (outVec `M.unsafeWrite` (at + 1)) val
+            return $ at + 2
+
+        pushData start len at = do
+            (outVec `M.unsafeWrite` at) $ fromIntegral len
+            let first = start - len
+                end = start - 1
+                offset = at - first + 1
+            forM_ [first .. end] $ \i -> do
+                v <- vec `M.unsafeRead` i
+                (outVec `M.unsafeWrite` (offset + i)) v
+
+            return $ at + len + 1
+
+        -- End of scanline, empty the thing
+        runLength run cpy prev idx at | idx >= maxIndex =
+            case (run, cpy) of
+                (0, 0) -> pure at
+                (0, n) -> pushData idx n at
+                (n, 0) -> pushRun n prev at
+                (_, _) -> error "HDR - Run length algorithm is wrong"
+
+        -- full runlength, we must write the packet
+        runLength r@127   _ prev idx at = do
+            val <- vec `M.unsafeRead` idx
+            pushRun r prev at >>=
+                runLength 1 0 val (idx + 1)
+
+        -- full copy, we must write the packet
+        runLength   _ c@127    _ idx at = do
+            val <- vec `M.unsafeRead` idx
+            pushData idx c at >>=
+                runLength 1 0 val (idx + 1)
+
+        runLength n 0 prev idx at = do
+            val <- vec `M.unsafeRead` idx
+            case val == prev of
+               True -> runLength (n + 1) 0 prev (idx + 1) at
+               False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at
+               False -> do
+                    pushRun n prev at >>=
+                        runLength 1 0 val (idx + 1)
+
+        runLength 0 n prev idx at = do
+            val <- vec `M.unsafeRead` idx
+            if val /= prev
+               then runLength 0 (n + 1) val (idx + 1) at
+               else do
+                pushData (idx - 1) (n - 1) at >>=
+                    runLength (2 :: Int) 0 val (idx + 1)
+
+        runLength _ _ _ _ _ =
+            error "HDR RLE inconsistent state"
+
+-- | Write an High dynamic range image into a radiance
+-- image file on disk.
+writeHDR :: FilePath -> Image PixelRGBF -> IO ()
+writeHDR filename img = L.writeFile filename $ encodeHDR img
+
+-- | Encode an High dynamic range image into a radiance image
+-- file format.
+encodeHDR :: Image PixelRGBF -> L.ByteString
+encodeHDR pic = encode $ runST $ do
+    let w = imageWidth pic
+        h = imageHeight pic
+
+    scanLineR <- M.new w :: ST s (M.STVector s Word8)
+    scanLineG <- M.new w
+    scanLineB <- M.new w
+    scanLineE <- M.new w
+
+    encoded <-
+        forM [0 .. h - 1] $ \line -> do
+            buff <- M.new $ w * 4 + w `div` 127 + 2
+            let columner col | col >= w = return ()
+                columner col = do
+                      let RGBE r g b e = toRGBE $ pixelAt pic col line
+                      (scanLineR `M.unsafeWrite` col) r
+                      (scanLineG `M.unsafeWrite` col) g
+                      (scanLineB `M.unsafeWrite` col) b
+                      (scanLineE `M.unsafeWrite` col) e
+
+                      columner (col + 1)
+
+            columner 0
+
+            (buff `M.unsafeWrite` 0) 2
+            (buff `M.unsafeWrite` 1) 2
+            (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF)
+            (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF)
+
+            i1 <- encodeScanlineColor scanLineR buff 4        
+            i2 <- encodeScanlineColor scanLineG buff i1
+            i3 <- encodeScanlineColor scanLineB buff i2
+            endIndex <- encodeScanlineColor scanLineE buff i3
+
+            (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff
+
+    pure $ RadianceHeader
+        { radianceInfos = []
+        , radianceFormat = FormatRGBE
+        , radianceHeight = h
+        , radianceWidth  = w
+        , radianceData = L.fromChunks encoded 
+        }
+    
+
+decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF))
+decodeRadiancePicture hdr = do
+    let width = abs $ radianceWidth hdr
+        height = abs $ radianceHeight hdr
+        packedData = radianceData hdr
+
+    scanLine <- lift $ M.new $ width * 4
+    resultBuffer <- lift $ M.new $ width * height * 3
+
+    let scanLineImage = MutableImage
+                      { mutableImageWidth = width
+                      , mutableImageHeight = 1
+                      , mutableImageData = scanLine
+                      }
+
+        finalImage = MutableImage
+                   { mutableImageWidth = width
+                   , mutableImageHeight = height
+                   , mutableImageData = resultBuffer
+                   }
+
+    let scanLineExtractor readIdx line = do
+          let color = unpackColor packedData readIdx
+              inner | isNewRunLengthMarker color = do
+                          let calcSize = checkLineLength color
+                          when (calcSize /= width)
+                               (throwError "Invalid sanline size")
+                          pure $ \idx -> newStyleRLE packedData (idx + 4)
+                    | otherwise = pure $ oldStyleRLE packedData
+          f <- inner
+          newRead <- f readIdx scanLine
+          forM_ [0 .. width - 1] $ \i -> do
+              -- mokay, it's a hack, but I don't want to define a
+              -- pixel instance of RGBE...
+              PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0
+              lift $ writePixel finalImage i line . toFloat $ RGBE r g b e
+
+          return newRead
+
+    foldM_ scanLineExtractor 0 [0 .. height - 1]
+
+    return finalImage
+

@@ -1,29 +1,33 @@-module Codec.Picture.InternalHelper ( runGet-                                    , runGetStrict-                                    , decode-                                    , getRemainingBytes ) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Binary( Binary( get ) )-import Data.Binary.Get( Get, runGetOrFail, getRemainingLazyByteString )--decode :: (Binary a) => B.ByteString -> Either String a-decode = runGetStrict get--runGet :: Get a -> L.ByteString -> Either String a-runGet act = unpack . runGetOrFail act-    where unpack (Left (_, _, str)) = Left str-          unpack (Right (_, _, element)) = Right element--runGetStrict :: Get a -> B.ByteString -> Either String a-runGetStrict act buffer = runGet act $ L.fromChunks [buffer]--getRemainingBytes :: Get B.ByteString-getRemainingBytes = do-    rest <- getRemainingLazyByteString -    return $ case L.toChunks rest of-        [] -> B.empty-        [a] -> a-        lst -> B.concat lst-+module Codec.Picture.InternalHelper ( runGet
+                                    , runGetStrict
+                                    , decode
+                                    , getRemainingBytes
+                                    , getRemainingLazyBytes ) where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import Data.Binary( Binary( get ) )
+import Data.Binary.Get( Get, runGetOrFail, getRemainingLazyByteString )
+
+decode :: (Binary a) => B.ByteString -> Either String a
+decode = runGetStrict get
+
+runGet :: Get a -> L.ByteString -> Either String a
+runGet act = unpack . runGetOrFail act
+    where unpack (Left (_, _, str)) = Left str
+          unpack (Right (_, _, element)) = Right element
+
+runGetStrict :: Get a -> B.ByteString -> Either String a
+runGetStrict act buffer = runGet act $ L.fromChunks [buffer]
+
+getRemainingBytes :: Get B.ByteString
+getRemainingBytes = do
+    rest <- getRemainingLazyByteString 
+    return $ case L.toChunks rest of
+        [] -> B.empty
+        [a] -> a
+        lst -> B.concat lst
+
+getRemainingLazyBytes :: Get L.ByteString
+getRemainingLazyBytes = getRemainingLazyByteString 
+

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
 {-# OPTIONS_GHC -fspec-constr-count=5 #-}
 -- | Module used for JPEG file loading and writing.
 module Codec.Picture.Jpg( decodeJpeg, encodeJpegAtQuality, encodeJpeg ) where
@@ -13,8 +14,9 @@ import Control.Monad.Trans( lift )
 import qualified Control.Monad.Trans.State.Strict as S
 
+import Data.Maybe( fromMaybe )
 import Data.List( find, foldl' )
-import Data.Bits( (.|.), (.&.), shiftL, shiftR )
+import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
 import Data.Int( Int16, Int32 )
 import Data.Word(Word8, Word16, Word32)
 import Data.Binary( Binary(..), encode )
@@ -30,7 +32,7 @@ import Data.Binary.Put( Put
                       , putWord8
                       , putWord16be
-                      , putByteString
+                      , putLazyByteString 
                       )
 
 import Data.Maybe( fromJust )
@@ -78,13 +80,14 @@     | JpgRestartInterval
     deriving (Eq, Show)
 
+type HuffmanTreeInfo = HuffmanPackedTree
 
 data JpgFrame =
       JpgAppFrame        !Word8 B.ByteString
     | JpgExtension       !Word8 B.ByteString
     | JpgQuantTable      ![JpgQuantTableSpec]
-    | JpgHuffmanTable    ![(JpgHuffmanTableSpec, HuffmanTree)]
-    | JpgScanBlob        !JpgScanHeader !B.ByteString
+    | JpgHuffmanTable    ![(JpgHuffmanTableSpec, HuffmanTreeInfo)]
+    | JpgScanBlob        !JpgScanHeader !L.ByteString
     | JpgScans           !JpgFrameKind !JpgFrameHeader
     | JpgIntervalRestart !Word16
     deriving Show
@@ -223,16 +226,14 @@ buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree
 buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList
 
--- | Decode a list of huffman values, not optimized for speed, but it
--- should work.
-huffmanDecode :: HuffmanTree -> BoolReader s Word8
-huffmanDecode originalTree = getNextBitJpg >>= huffDecode originalTree
-  where huffDecode Empty                   _ = return 0
-        huffDecode (Branch (Leaf v) _) False = return v
-        huffDecode (Branch l       _ ) False = getNextBitJpg >>= huffDecode l
-        huffDecode (Branch _ (Leaf v)) True  = return v
-        huffDecode (Branch _       r ) True  = getNextBitJpg >>= huffDecode r
-        huffDecode (Leaf v) _ = return v
+huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8
+huffmanPackedDecode table = getNextBitJpg >>= aux 0
+  where aux idx b | (v .&. 0x8000) /= 0 = return 0
+                  | (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF
+                  | otherwise = getNextBitJpg >>= aux v
+          where tableIndex | b = idx + 1
+                           | otherwise = idx
+                v = table `VS.unsafeIndex` fromIntegral tableIndex
 
 --------------------------------------------------
 ----            Serialization instances
@@ -310,7 +311,7 @@ putFrame (JpgIntervalRestart size) =
     put JpgRestartInterval >> put (RestartInterval size)
 putFrame (JpgScanBlob hdr blob) =
-    put JpgStartOfScan >> put hdr >> putByteString blob
+    put JpgStartOfScan >> put hdr >> putLazyByteString blob
 putFrame (JpgScans kind hdr) =
     put kind >> put hdr
 
@@ -336,11 +337,11 @@             (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame
         JpgHuffmanTableMarker ->
             (\(TableList huffTables) lst ->
-                    JpgHuffmanTable [(t, buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst)
+                    JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst)
                     <$> get <*> parseNextFrame
         JpgStartOfScan ->
             (\frm imgData -> [JpgScanBlob frm imgData])
-                            <$> get <*> getRemainingBytes
+                            <$> get <*> getRemainingLazyBytes
 
         _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame
 
@@ -394,12 +395,12 @@               | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")")
 
 put4BitsOfEach :: Word8 -> Word8 -> Put
-put4BitsOfEach a b = put $ (a `shiftL` 4) .|. b
+put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b
 
 get4BitOfEach :: Get (Word8, Word8)
 get4BitOfEach = do
     val <- get
-    return ((val `shiftR` 4) .&. 0xF, val .&. 0xF)
+    return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF)
 
 newtype RestartInterval = RestartInterval Word16
 
@@ -494,27 +495,35 @@         putWord8 . snd $ spectralSelection v
         put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v
 
-{-quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32-}
-         {--> ST s (MutableMacroBlock s Int32)-}
-{-quantize table = mutate (\idx val -> val `quot` fromIntegral (table !!! idx))-}
-
 quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32
          -> ST s (MutableMacroBlock s Int32)
-quantize table = mutate (\idx val -> val `quotient` fromIntegral (table !!! idx))
-    where quotient val q = (val + (q `div` 2)) `quot` q -- rounded integer division
+quantize table block = update 0
+  where update 64 = return block
+        update idx = do
+            val <- block `M.unsafeRead` idx
+            let q = fromIntegral (table `VS.unsafeIndex` idx)
+                finalValue = (val + (q `div` 2)) `quot` q -- rounded integer division
+            (block `M.unsafeWrite` idx) finalValue
+            update $ idx + 1
 
 -- | Apply a quantization matrix to a macroblock
 {-# INLINE deQuantize #-}
 deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16
            -> ST s (MutableMacroBlock s Int16)
-deQuantize table = mutate (\ix val -> val * (table !!! ix))
+deQuantize table block = update 0
+    where update 64 = return block
+          update i = do
+              val <- block `M.unsafeRead` i
+              let finalValue = val * (table `VS.unsafeIndex` i)
+              (block `M.unsafeWrite` i) finalValue
+              update $ i + 1
 
 inverseDirectCosineTransform :: MutableMacroBlock s Int16
                              -> ST s (MutableMacroBlock s Int16)
 inverseDirectCosineTransform mBlock =
     fastIdct mBlock >>= mutableLevelShift
 
-zigZagOrder :: MacroBlock Word8
+zigZagOrder :: MacroBlock Int
 zigZagOrder = makeMacroBlock $ concat
     [[ 0, 1, 5, 6,14,15,27,28]
     ,[ 2, 4, 7,13,16,26,29,42]
@@ -532,30 +541,39 @@     mv <- VS.thaw vec
     zigZagReorderForward v mv >>= VS.freeze
 
+zigZagOrderForward :: MacroBlock Int
+zigZagOrderForward = VS.generate 64 inv
+  where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder
+
 zigZagReorderForward :: (Storable a, Num a)
                      => MutableMacroBlock s a
                      -> MutableMacroBlock s a
                      -> ST s (MutableMacroBlock s a)
-zigZagReorderForward zigzaged block = do
-    let update i =  do
-            let idx = zigZagOrder !!! i
-            v <- block .!!!. fromIntegral i
-            (zigzaged .<-. fromIntegral idx) v
-
-        reorder 64 = return ()
-        reorder i  = update i >> reorder (i + 1)
-
-    reorder (0 :: Int)
-    return zigzaged
+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32
+                                           -> MutableMacroBlock s Int32
+                                           -> ST s (MutableMacroBlock s Int32) #-}
+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16
+                                           -> MutableMacroBlock s Int16
+                                           -> ST s (MutableMacroBlock s Int16) #-}
+{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8
+                                           -> MutableMacroBlock s Word8
+                                           -> ST s (MutableMacroBlock s Word8) #-}
+zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged
+  where ordering !table = reorder (0 :: Int)
+         where reorder !i | i >= 64 = return ()
+               reorder i  = do
+                    let idx = table `VS.unsafeIndex` i
+                    v <- block `M.unsafeRead` idx
+                    (zigzaged `M.unsafeWrite` i) v
+                    reorder (i + 1)
 
-zigZagReorder :: (Storable a, Num a)
-              => MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
-zigZagReorder block = do
-    zigzaged <- M.replicate 64 0
+zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16
+              -> ST s (MutableMacroBlock s Int16)
+zigZagReorder zigzaged block = do
     let update i =  do
-            let idx = zigZagOrder !!! i
-            v <- block .!!!. fromIntegral idx
-            (zigzaged .<-. i) v
+            let idx = zigZagOrder `VS.unsafeIndex` i
+            v <- block `M.unsafeRead` idx
+            (zigzaged `M.unsafeWrite` i) v
 
         reorder 63 = update 63
         reorder i  = update i >> reorder (i + 1)
@@ -569,15 +587,16 @@ -- there is to know for macro block transformation
 decodeMacroBlock :: MacroBlock DctCoefficients
                  -> MutableMacroBlock s Int16
+                 -> MutableMacroBlock s Int16
                  -> ST s (MutableMacroBlock s Int16)
-decodeMacroBlock quantizationTable block =
-    deQuantize quantizationTable block >>= zigZagReorder
+decodeMacroBlock quantizationTable zigZagBlock block =
+    deQuantize quantizationTable block >>= zigZagReorder zigZagBlock
                                        >>= inverseDirectCosineTransform
 
 packInt :: [Bool] -> Int32
 packInt = foldl' bitStep 0
-    where bitStep acc True = (acc `shiftL` 1) + 1
-          bitStep acc False = acc `shiftL` 1
+    where bitStep acc True = (acc `unsafeShiftL` 1) + 1
+          bitStep acc False = acc `unsafeShiftL` 1
 
 -- | Unpack an int of the given size encoded from MSB to LSB.
 unpackInt :: Int32 -> BoolReader s Int32
@@ -590,14 +609,16 @@           limit range i | val < range = i
           limit range i = limit (2 * range) (i + 1)
 
-encodeInt :: Word32 -> Int32 -> BoolWriter s ()
-encodeInt ssss n | n > 0 = writeBits (fromIntegral n) (fromIntegral ssss)
-encodeInt ssss n         = writeBits (fromIntegral $ n - 1) (fromIntegral ssss)
+encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
+{-# INLINE encodeInt #-}
+encodeInt st ssss n | n > 0 = writeBits' st (fromIntegral n) (fromIntegral ssss)
+encodeInt st ssss n         = writeBits' st (fromIntegral $ n - 1) (fromIntegral ssss)
 
+{-# INLINE decodeInt #-}
 decodeInt :: Int32 -> BoolReader s Int32
 decodeInt ssss = do
     signBit <- getNextBitJpg
-    let dataRange = 1 `shiftL` fromIntegral (ssss - 1)
+    let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1)
         leftBitCount = ssss - 1
     -- First following bits store the sign of the coefficient, and counted in
     -- SSSS, so the bit count for the int, is ssss - 1
@@ -605,50 +626,52 @@        then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount
        else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount
 
-dcCoefficientDecode :: HuffmanTree -> BoolReader s DcCoefficient
+dcCoefficientDecode :: HuffmanTreeInfo
+                    -> BoolReader s DcCoefficient
 dcCoefficientDecode dcTree = do
-    ssss <- huffmanDecode dcTree
+    ssss <- huffmanPackedDecode dcTree
     if ssss == 0
        then return 0
        else fromIntegral <$> decodeInt (fromIntegral ssss)
 
 -- | Assume the macro block is initialized with zeroes
-acCoefficientsDecode :: HuffmanTree -> MutableMacroBlock s Int16
+acCoefficientsDecode :: HuffmanTreeInfo -> MutableMacroBlock s Int16
                      -> BoolReader s (MutableMacroBlock s Int16)
 acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock
   where parseAcCoefficient n | n >= 64 = return ()
                              | otherwise = do
-            rrrrssss <- huffmanDecode acTree
-            let rrrr = fromIntegral $ (rrrrssss `shiftR` 4) .&. 0xF
+            rrrrssss <- huffmanPackedDecode acTree
+            let rrrr = fromIntegral $ (rrrrssss `unsafeShiftR` 4) .&. 0xF
                 ssss =  rrrrssss .&. 0xF
             case (rrrr, ssss) of
                 (  0, 0) -> return ()
                 (0xF, 0) -> parseAcCoefficient (n + 16)
                 _        -> do
                     decoded <- fromIntegral <$> decodeInt (fromIntegral ssss)
-                    lift $ (mutableBlock .<-. (n + rrrr)) decoded
+                    lift $ (mutableBlock `M.unsafeWrite` (n + rrrr)) decoded
                     parseAcCoefficient (n + rrrr + 1)
 
 -- | Decompress a macroblock from a bitstream given the current configuration
 -- from the frame.
-decompressMacroBlock :: HuffmanTree         -- ^ Tree used for DC coefficient
-                     -> HuffmanTree         -- ^ Tree used for Ac coefficient
+decompressMacroBlock :: HuffmanTreeInfo     -- ^ Tree used for DC coefficient
+                     -> HuffmanTreeInfo     -- ^ Tree used for Ac coefficient
                      -> MacroBlock Int16    -- ^ Current quantization table
+                     -> MutableMacroBlock s Int16    -- ^ A zigzag table, to avoid allocation
                      -> DcCoefficient       -- ^ Previous dc value
                      -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16)
-decompressMacroBlock dcTree acTree quantizationTable previousDc = do
+decompressMacroBlock dcTree acTree quantizationTable zigzagBlock previousDc = do
     dcDeltaCoefficient <- dcCoefficientDecode dcTree
     block <- lift createEmptyMutableMacroBlock
     let neoDcCoefficient = previousDc + dcDeltaCoefficient
-    lift $ (block .<-. 0) neoDcCoefficient
+    lift $ (block `M.unsafeWrite` 0) neoDcCoefficient
     fullBlock <- acCoefficientsDecode acTree block
-    decodedBlock <- lift $ decodeMacroBlock quantizationTable fullBlock
+    decodedBlock <- lift $ decodeMacroBlock quantizationTable zigzagBlock fullBlock
     return (neoDcCoefficient, decodedBlock)
 
 gatherQuantTables :: JpgImage -> [JpgQuantTableSpec]
 gatherQuantTables img = concat [t | JpgQuantTable t <- jpgFrame img]
 
-gatherHuffmanTables :: JpgImage -> [(JpgHuffmanTableSpec, HuffmanTree)]
+gatherHuffmanTables :: JpgImage -> [(JpgHuffmanTableSpec, HuffmanTreeInfo)]
 gatherHuffmanTables img = concat [lst | JpgHuffmanTable lst <- jpgFrame img]
 
 gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
@@ -662,6 +685,116 @@ pixelClamp :: Int16 -> Word8
 pixelClamp n = fromIntegral . min 255 $ max 0 n
 
+unpack444Y :: Int -- ^ x
+           -> Int -- ^ y
+           -> MutableImage s PixelYCbCr8
+           -> MutableMacroBlock s Int16
+           -> ST s ()
+unpack444Y x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img })
+                 block = blockVert baseIdx 0 zero
+  where zero = 0 :: Int
+        baseIdx = x * 8 + y * 8 * imgWidth
+
+        blockVert        _       _ j | j >= 8 = return ()
+        blockVert writeIdx readingIdx j = blockHoriz writeIdx readingIdx zero
+          where blockHoriz   _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth) readIdx $ j + 1
+                blockHoriz idx readIdx i = do
+                    val <- pixelClamp <$> (block `M.unsafeRead` readIdx) 
+                    (img `M.unsafeWrite` idx) val
+                    blockHoriz (idx + 1) (readIdx + 1) $ i + 1
+
+unpack444Ycbcr :: Int -- ^ Component index
+              -> Int -- ^ x
+              -> Int -- ^ y
+              -> MutableImage s PixelYCbCr8
+              -> MutableMacroBlock s Int16
+              -> ST s ()
+unpack444Ycbcr compIdx x y 
+                 (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img })
+                 block = blockVert baseIdx 0 zero
+  where zero = 0 :: Int
+        baseIdx = (x * 8 + y * 8 * imgWidth) * 3 + compIdx
+
+        blockVert   _       _ j | j >= 8 = return ()
+        blockVert idx readIdx j = do
+            val0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) 
+            val1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1)) 
+            val2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2)) 
+            val3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3)) 
+            val4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4)) 
+            val5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5)) 
+            val6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6)) 
+            val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) 
+
+            (img `M.unsafeWrite` idx) val0
+            (img `M.unsafeWrite` (idx + (3 * 1))) val1
+            (img `M.unsafeWrite` (idx + (3 * 2))) val2
+            (img `M.unsafeWrite` (idx + (3 * 3))) val3
+            (img `M.unsafeWrite` (idx + (3 * 4))) val4
+            (img `M.unsafeWrite` (idx + (3 * 5))) val5
+            (img `M.unsafeWrite` (idx + (3 * 6))) val6
+            (img `M.unsafeWrite` (idx + (3 * 7))) val7
+
+            blockVert (idx + 3 * imgWidth) (readIdx + 8) $ j + 1
+
+
+          {-where blockHoriz   _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth * 3) readIdx $ j + 1-}
+                {-blockHoriz idx readIdx i = do-}
+                    {-val <- pixelClamp <$> (block `M.unsafeRead` readIdx) -}
+                    {-(img `M.unsafeWrite` idx) val-}
+                    {-blockHoriz (idx + 3) (readIdx + 1) $ i + 1-}
+
+unpack422Ycbcr :: Int -- ^ Component index
+               -> Int -- ^ x
+               -> Int -- ^ y
+               -> MutableImage s PixelYCbCr8
+               -> MutableMacroBlock s Int16
+               -> ST s ()
+unpack422Ycbcr compIdx x y 
+                 (MutableImage { mutableImageWidth = imgWidth,
+                                 mutableImageHeight = _, mutableImageData = img })
+                 block = blockVert baseIdx 0 zero
+  where zero = 0 :: Int
+        baseIdx = (x * 8 * 2 + y * 8 * imgWidth) * 3 + compIdx
+        lineOffset = imgWidth * 3
+
+        blockVert        _       _ j | j >= 8 = return ()
+        blockVert idx readIdx j = do
+            v0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) 
+            v1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1))
+            v2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2))
+            v3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3))
+            v4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4))
+            v5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5))
+            v6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6))
+            v7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7))
+
+            (img `M.unsafeWrite` idx)       v0
+            (img `M.unsafeWrite` (idx + 3)) v0
+
+            (img `M.unsafeWrite` (idx + 6 * 1))      v1
+            (img `M.unsafeWrite` (idx + 6 * 1 + 3))  v1
+
+            (img `M.unsafeWrite` (idx + 6 * 2))      v2
+            (img `M.unsafeWrite` (idx + 6 * 2 + 3))  v2
+
+            (img `M.unsafeWrite` (idx + 6 * 3))      v3
+            (img `M.unsafeWrite` (idx + 6 * 3 + 3))  v3
+
+            (img `M.unsafeWrite` (idx + 6 * 4))      v4
+            (img `M.unsafeWrite` (idx + 6 * 4 + 3))  v4
+
+            (img `M.unsafeWrite` (idx + 6 * 5))      v5
+            (img `M.unsafeWrite` (idx + 6 * 5 + 3))  v5
+
+            (img `M.unsafeWrite` (idx + 6 * 6))      v6
+            (img `M.unsafeWrite` (idx + 6 * 6 + 3))  v6
+
+            (img `M.unsafeWrite` (idx + 6 * 7))      v7
+            (img `M.unsafeWrite` (idx + 6 * 7 + 3))  v7
+
+            blockVert (idx + lineOffset) (readIdx + 8) $ j + 1
+
 -- | Given a size coefficient (how much a pixel span horizontally
 -- and vertically), the position of the macroblock, return a list
 -- of indices and value to be stored in an array (like the final
@@ -675,25 +808,30 @@                  -> MutableImage s PixelYCbCr8
                  -> MutableMacroBlock s Int16
                  -> ST s ()
-    -- Simple case, a macroblock value => a pixel
 unpackMacroBlock compCount compIdx  wCoeff hCoeff x y 
                  (MutableImage { mutableImageWidth = imgWidth,
                                  mutableImageHeight = imgHeight, mutableImageData = img })
-                 block =
-  forM_ pixelIndices $ \(i, j, wDup, hDup) -> do
-      let xPos = (i + x * 8) * wCoeff + wDup
-          yPos = (j + y * 8) * hCoeff + hDup
-      when (0 <= xPos && xPos < imgWidth && 0 <= yPos && yPos < imgHeight)
-           (do compVal <- pixelClamp <$> (block .!!!. (i + j * 8))
-               let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx
-               (img .<-. mutableIdx) compVal)
+                 block = -- trace (printf "w:%d h:%d x:%d y:%d wCoeff:%d hCoeff:%d" imgWidth imgHeight x y wCoeff hCoeff) $
+                            blockVert 0
+  where blockVert j | j >= 8 = return ()
+        blockVert j = blockHoriz 0
+          where yBase = (y * 8 + j) * hCoeff
+                blockHoriz i | i >= 8 = blockVert $ j + 1
+                blockHoriz i = (pixelClamp <$> (block `M.unsafeRead` (i + j * 8))) >>= horizDup 0
+                  where xBase = (x * 8 + i) * wCoeff
+                        horizDup wDup _ | wDup >= wCoeff = blockHoriz $ i + 1
+                        horizDup wDup compVal = vertDup 0
+                          where vertDup hDup | hDup >= hCoeff = horizDup (wDup + 1) compVal
+                                vertDup hDup = do
+                                  let xPos = xBase + wDup
+                                      yPos = yBase + hDup
 
-    where pixelIndices = [(i, j, wDup, hDup) | i <- [0 .. 7], j <- [0 .. 7]
-                                -- Repetition to spread macro block
-                                , wDup <- [0 .. wCoeff - 1]
-                                , hDup <- [0 .. hCoeff - 1]
-                                ]
+                                  when (xPos < imgWidth && yPos < imgHeight)
+                                       (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx
+                                           (img `M.unsafeWrite` mutableIdx) compVal)
 
+                                  vertDup $ hDup + 1
+
 -- | Type only used to make clear what kind of integer we are carrying
 -- Might be transformed into newtype in the future
 type DcCoefficient = Int16
@@ -711,104 +849,56 @@      else return (-1)
         -}
 
-
-decodeImage :: Int                        -- ^ Component count
-            -> JpegDecoder s              -- ^ Function to call to decode an MCU
+decodeImage :: JpgImage          
+            -> Int -- ^ Component count
             -> MutableImage s PixelYCbCr8 -- ^ Result image to write into
             -> BoolReader s ()
-decodeImage compCount decoder img = do
-    let blockIndices = [(x,y) | y <- [0 ..   verticalMcuCount decoder - 1]
-                              , x <- [0 .. horizontalMcuCount decoder - 1] ]
-        mcuDecode = mcuDecoder decoder
-        blockBeforeRestart = restartInterval decoder
-
-        folder f = foldM_ f blockBeforeRestart blockIndices
-
+decodeImage img compCount outImage = do
+    zigZagArray <- lift $ createEmptyMutableMacroBlock
     dcArray <- lift (M.replicate compCount 0  :: ST s (M.STVector s DcCoefficient))
-    folder (\resetCounter (x,y) -> do
-        when (resetCounter == 0)
-             (do forM_ [0.. compCount - 1] $
-                     \c -> lift $ (dcArray .<-. c) 0
-                 byteAlignJpg
-                 _restartCode <- decodeRestartInterval
-                 -- if 0xD0 <= restartCode && restartCode <= 0xD7
-                 return ())
 
-        forM_ mcuDecode $ \(comp, dataUnitDecoder) -> do
-            dc <- lift $ dcArray .!!!. comp
-            dcCoeff <- dataUnitDecoder x y img $ fromIntegral dc
-            lift $ (dcArray .<-. comp) dcCoeff
-            return ()
-
-        if resetCounter /= 0 then return $ resetCounter - 1
-                                         -- we use blockBeforeRestart - 1 to count
-                                         -- the current MCU
-                            else return $ blockBeforeRestart - 1)
-
--- | Type of a data unit (as in the ITU 81) standard
-type DataUnitDecoder s  =
-    (Int, Int -> Int -> MutableImage s PixelYCbCr8 -> DcCoefficient -> BoolReader s DcCoefficient)
-
-data JpegDecoder s = JpegDecoder
-    { restartInterval    :: Int
-    , horizontalMcuCount :: Int
-    , verticalMcuCount   :: Int
-    , mcuDecoder         :: [DataUnitDecoder s]
-    }
-
-allElementsEqual :: (Eq a) => [a] -> Bool
-allElementsEqual []     = True
-allElementsEqual (x:xs) = all (== x) xs
-
--- | An MCU (Minimal coded unit) is an unit of data for all components
--- (Y, Cb & Cr), taking into account downsampling.
-buildJpegImageDecoder :: JpgImage -> JpegDecoder s
-buildJpegImageDecoder img = JpegDecoder { restartInterval = mcuBeforeRestart
-                                        , horizontalMcuCount = horizontalBlockCount
-                                        , verticalMcuCount = verticalBlockCount
-                                        , mcuDecoder = mcus }
-  where huffmans = gatherHuffmanTables img
+    let huffmans = gatherHuffmanTables img
         huffmanForComponent dcOrAc dest =
             head [t | (h,t) <- huffmans, huffmanTableClass h == dcOrAc
                                        , huffmanTableDest h == dest]
-
+ 
         mcuBeforeRestart = case [i | JpgIntervalRestart i <- jpgFrame img] of
-            []    -> maxBound -- HUUUUUUGE value (enough to parse all MCU)
+            []    -> maxBound :: Int -- HUUUUUUGE value (enough to parse all MCU)
             (x:_) -> fromIntegral x
-
+ 
         quants = gatherQuantTables img
         quantForComponent dest =
             head [quantTable q | q <- quants, quantDestination q == dest]
-
+ 
         hdr = head [h | JpgScanBlob h _ <- jpgFrame img]
-
+ 
         (_, scanInfo) = gatherScanInfo img
         imgWidth = fromIntegral $ jpgWidth scanInfo
         imgHeight = fromIntegral $ jpgHeight scanInfo
-
+ 
         blockSizeOfDim fullDim maxBlockSize = block + (if rest /= 0 then 1 else 0)
                 where (block, rest) = fullDim `divMod` maxBlockSize
-
-        horizontalSamplings = [horiz | (horiz, _, _, _, _) <- componentsInfo]
-
-        imgComponentCount = fromIntegral $ jpgImageComponentCount scanInfo
+ 
+        horizontalSamplings = [horiz | (horiz, _, _, _, _, _) <- componentsInfo]
+ 
+        imgComponentCount = fromIntegral $ jpgImageComponentCount scanInfo :: Int
         isImageLumanOnly = imgComponentCount == 1
         maxHorizFactor | not isImageLumanOnly &&
                             not (allElementsEqual horizontalSamplings) = maximum horizontalSamplings
                        | otherwise = 1
-
-        verticalSamplings = [vert | (_, vert, _, _, _) <- componentsInfo]
+ 
+        verticalSamplings = [vert | (_, vert, _, _, _, _) <- componentsInfo]
         maxVertFactor | not isImageLumanOnly &&
                             not (allElementsEqual verticalSamplings) = maximum verticalSamplings
                       | otherwise = 1
-
+ 
         horizontalBlockCount =
            blockSizeOfDim imgWidth $ fromIntegral (maxHorizFactor * 8)
-
+ 
         verticalBlockCount =
            blockSizeOfDim imgHeight $ fromIntegral (maxVertFactor * 8)
 
-        fetchTablesForComponent component = (horizCount, vertCount, dcTree, acTree, qTable)
+        fetchTablesForComponent component = (horizCount, vertCount, dcTree, acTree, qTable, unpacker)
             where idx = componentIdentifier component
                   descr = head [c | c <- scans hdr, componentSelector c  == idx]
                   dcTree = huffmanForComponent DcComponent $ dcEntropyCodingTable descr
@@ -821,22 +911,66 @@                         then fromIntegral $ verticalSamplingFactor component
                         else 1
 
+                  xScalingFactor = maxHorizFactor - horizCount + 1
+                  yScalingFactor = maxVertFactor - vertCount + 1
+
+                  unpacker = unpackerDecision xScalingFactor yScalingFactor
+
+                  unpackerDecision 1 1 | isImageLumanOnly = unpack444Y 
+                                       | otherwise = unpack444Ycbcr . fromIntegral $ idx - 1
+                  unpackerDecision 2 1 = unpack422Ycbcr . fromIntegral $ idx - 1
+                  unpackerDecision _ _ =  unpackMacroBlock compCount (fromIntegral $ idx - 1) xScalingFactor yScalingFactor
+ 
         componentsInfo = map fetchTablesForComponent $ jpgComponents scanInfo
 
-        mcus = [(compIdx, \x y writeImg dc -> do
-                           (dcCoeff, block) <- decompressMacroBlock dcTree acTree qTable dc
-                           lift $ unpacker (x * horizCount + xd) (y * vertCount + yd) writeImg block
-                           return dcCoeff)
-                     | (compIdx, (horizCount, vertCount, dcTree, acTree, qTable))
-                                   <- zip [0..] componentsInfo
-                     , let xScalingFactor = maxHorizFactor - horizCount + 1
-                           yScalingFactor = maxVertFactor - vertCount + 1
-                     , yd <- [0 .. vertCount - 1]
-                     , xd <- [0 .. horizCount - 1]
-                     , let unpacker = unpackMacroBlock imgComponentCount compIdx 
-                                                    xScalingFactor yScalingFactor
-                     ]
+    let blockIndices = [(x,y) | y <- [0 ..   verticalBlockCount - 1]
+                              , x <- [0 .. horizontalBlockCount - 1] ]
+        blockBeforeRestart = mcuBeforeRestart
 
+        folder f = foldM_ f blockBeforeRestart blockIndices
+
+    folder (\resetCounter (x,y) -> do
+        when (resetCounter == 0)
+             (do forM_ [0.. compCount - 1] $
+                     \c -> lift $ (dcArray `M.unsafeWrite` c) 0
+                 byteAlignJpg
+                 _restartCode <- decodeRestartInterval
+                 -- if 0xD0 <= restartCode && restartCode <= 0xD7
+                 return ())
+
+        let comp        _ [] = return ()
+            comp compIdx ((horizCount, vertCount, dcTree, acTree, qTable, unpack):comp_rest) = liner 0
+              where liner yd | yd >= vertCount = comp (compIdx + 1) comp_rest
+                    liner yd = columner 0
+                      where columner xd | xd >= horizCount = liner (yd + 1)
+                            columner xd | (xd == horizCount - 1 && x == horizontalBlockCount - 1) || yd == horizCount - 1 = do
+                                dc <- lift $ dcArray `M.unsafeRead` compIdx
+                                (dcCoeff, block) <-
+                                    decompressMacroBlock dcTree acTree qTable zigZagArray $ fromIntegral dc
+                                lift $ unpackMacroBlock imgComponentCount compIdx (maxHorizFactor - horizCount + 1)
+                                                                                  (maxVertFactor - vertCount + 1)
+                                                        (x * horizCount + xd) (y * vertCount + yd) outImage block
+                                lift $ (dcArray `M.unsafeWrite` compIdx) dcCoeff
+                                columner $ xd + 1
+
+                            columner xd = do
+                                dc <- lift $ dcArray `M.unsafeRead` compIdx
+                                (dcCoeff, block) <-
+                                    decompressMacroBlock dcTree acTree qTable zigZagArray $ fromIntegral dc
+                                _ <- lift $ unpack (x * horizCount + xd) (y * vertCount + yd) outImage block
+                                lift $ (dcArray `M.unsafeWrite` compIdx) dcCoeff
+                                columner $ xd + 1
+        comp 0 componentsInfo
+
+        if resetCounter /= 0 then return $ resetCounter - 1
+                                         -- we use blockBeforeRestart - 1 to count
+                                         -- the current MCU
+                            else return $ blockBeforeRestart - 1)
+
+allElementsEqual :: (Eq a) => [a] -> Bool
+allElementsEqual []     = True
+allElementsEqual (x:xs) = all (== x) xs
+
 -- | Try to decompress a jpeg file and decompress. The colorspace is still
 -- YCbCr if you want to perform computation on the luma part. You can
 -- convert it to RGB using 'convertImage' from the 'ColorSpaceConvertible'
@@ -866,11 +1000,11 @@             imageSize = imgWidth * imgHeight * compCount
 
             pixelData = runST $ VS.unsafeFreeze =<< S.evalStateT (do
-                resultImage <- lift $ M.replicate imageSize 0
+                resultImage <- lift $ M.new imageSize
                 let wrapped = MutableImage imgWidth imgHeight resultImage
-                setDecodedStringJpg imgData
-                decodeImage compCount (buildJpegImageDecoder img) wrapped
-                return resultImage) (-1, 0, B.empty)
+                setDecodedStringJpg . B.concat $ L.toChunks imgData
+                decodeImage img compCount wrapped
+                return resultImage) (BoolState (-1) 0 B.empty)
 
 extractBlock :: Image PixelYCbCr8       -- ^ Source image
              -> MutableMacroBlock s Int16      -- ^ Mutable block where to put extracted block
@@ -884,16 +1018,16 @@ extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
              block 1 1 sampCount plane bx by | (bx * 8) + 7 < w && (by * 8) + 7 < h = do
     let baseReadIdx = (by * 8 * w) + bx * 8
-    sequence_ [(block .<-. (y * 8 + x)) val
+    sequence_ [(block `M.unsafeWrite` (y * 8 + x)) val
                         | y <- [0 .. 7]
                         , let blockReadIdx = baseReadIdx + y * w
                         , x <- [0 .. 7]
-                        , let val = fromIntegral $ src !!! ((blockReadIdx + x) * sampCount + plane)
+                        , let val = fromIntegral $ src `VS.unsafeIndex` ((blockReadIdx + x) * sampCount + plane)
                         ]
     return block
 extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
              block sampWidth sampHeight sampCount plane bx by = do
-    let accessPixel x y | x < w && y < h = let idx = (y * w + x) * sampCount + plane in src !!! idx
+    let accessPixel x y | x < w && y < h = let idx = (y * w + x) * sampCount + plane in src `VS.unsafeIndex` idx
                         | x >= w = accessPixel (w - 1) y
                         | otherwise = accessPixel x (h - 1)
 
@@ -908,36 +1042,37 @@         blockXBegin = bx * 8 * sampWidth
         blockYBegin = by * 8 * sampHeight
 
-    sequence_ [(block .<-. (y * 8 + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ]
+    sequence_ [(block `M.unsafeWrite` (y * 8 + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ]
     return block
 
-serializeMacroBlock :: HuffmanWriterCode -> HuffmanWriterCode
+serializeMacroBlock :: BoolWriteStateRef s
+                    -> HuffmanWriterCode -> HuffmanWriterCode
                     -> MutableMacroBlock s Int32
-                    -> BoolWriter s ()
-serializeMacroBlock dcCode acCode blk =
- lift (blk .!!!. 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return ()
+                    -> ST s ()
+serializeMacroBlock !st !dcCode !acCode !blk =
+ (blk `M.unsafeRead` 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return ()
   where writeAcs acc@(_, 63) =
-            lift (blk .!!!. 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return ()
+            (blk `M.unsafeRead` 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return ()
         writeAcs acc@(_, i ) =
-            lift (blk .!!!.  i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs
+            (blk `M.unsafeRead`  i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs
 
-        encodeDc n = writeBits (fromIntegral code) (fromIntegral bitCount)
-                        >> when (ssss /= 0) (encodeInt ssss n)
+        encodeDc n = writeBits' st (fromIntegral code) (fromIntegral bitCount)
+                        >> when (ssss /= 0) (encodeInt st ssss n)
             where ssss = powerOf $ fromIntegral n
-                  (bitCount, code) = dcCode V.! fromIntegral ssss
+                  (bitCount, code) = dcCode `V.unsafeIndex` fromIntegral ssss
 
-        encodeAc 0         0 = writeBits (fromIntegral code) $ fromIntegral bitCount
-            where (bitCount, code) = acCode V.! 0
+        encodeAc 0         0 = writeBits' st (fromIntegral code) $ fromIntegral bitCount
+            where (bitCount, code) = acCode `V.unsafeIndex` 0
 
         encodeAc zeroCount n | zeroCount >= 16 =
-          writeBits (fromIntegral code) (fromIntegral bitCount) >>  encodeAc (zeroCount - 16) n
-            where (bitCount, code) = acCode V.! 0xF0
+          writeBits' st (fromIntegral code) (fromIntegral bitCount) >>  encodeAc (zeroCount - 16) n
+            where (bitCount, code) = acCode `V.unsafeIndex` 0xF0
         encodeAc zeroCount n =
-          writeBits (fromIntegral code) (fromIntegral bitCount) >> encodeInt ssss n
-            where rrrr = zeroCount `shiftL` 4
+          writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeInt st ssss n
+            where rrrr = zeroCount `unsafeShiftL` 4
                   ssss = powerOf $ fromIntegral n
                   rrrrssss = rrrr .|. ssss
-                  (bitCount, code) = acCode V.! fromIntegral rrrrssss
+                  (bitCount, code) = acCode `V.unsafeIndex` fromIntegral rrrrssss
 
         encodeAcCoefs (            _, 63) 0 = encodeAc 0 0 >> return (0, 64)
         encodeAcCoefs (zeroRunLength,  i) 0 = return (zeroRunLength + 1, i + 1)
@@ -955,8 +1090,8 @@  blk <- fastDctLibJpeg workData block
         >>= zigZagReorderForward finalData
         >>= quantize quantTableOfComponent
- dc <- blk .!!!. 0
- (blk .<-. 0) $ dc - fromIntegral prev_dc
+ dc <- blk `M.unsafeRead` 0
+ (blk `M.unsafeWrite` 0) $ dc - fromIntegral prev_dc
  return (dc, blk)
 
 divUpward :: (Integral a) => a -> a -> a
@@ -964,7 +1099,7 @@     where (val, rest) = n `divMod` dividor
 
 prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable
-                    -> (JpgHuffmanTableSpec, HuffmanTree)
+                    -> (JpgHuffmanTableSpec, HuffmanTreeInfo)
 prepareHuffmanTable classVal dest tableDef = 
    (JpgHuffmanTableSpec { huffmanTableClass = classVal
                         , huffmanTableDest  = dest
@@ -972,7 +1107,7 @@                         , huffCodes = V.fromListN 16
                             [VU.fromListN (fromIntegral $ sizes ! i) lst
                                                 | (i, lst) <- zip [0..] tableDef ]
-                        }, Empty)
+                        }, VS.singleton 0)
       where sizes = VU.fromListN 16 $ map (fromIntegral . length) tableDef   
 
 -- | Encode an image in jpeg at a reasonnable quality level.
@@ -987,8 +1122,7 @@ encodeJpegAtQuality :: Word8                -- ^ Quality factor
                     -> Image PixelYCbCr8    -- ^ Image to encode
                     -> L.ByteString         -- ^ Encoded JPEG
-encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) =
-    encode finalImage
+encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage
   where finalImage = JpgImage [ JpgQuantTable quantTables
                               , JpgScans JpgBaselineDCTHuffman hdr
                               , JpgHuffmanTable huffTables
@@ -1064,8 +1198,7 @@                                           , quantTable = zigzagedChromaQuant }
                       ]
 
-        encodedImage = runST toExtract
-        toExtract = runBoolWriter $ do
+        encodedImage = runST $ do
             let horizontalMetaBlockCount = w `divUpward` (8 * maxSampling)
                 verticalMetaBlockCount = h `divUpward` (8 * maxSampling)
                 maxSampling = 2
@@ -1078,27 +1211,36 @@                 componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize]
   
                 imageComponentCount = length componentDef
-            block <- lift $ M.replicate 64 0
-            dc_table <- lift $ M.replicate 3 0
-            let blockList = [(comp, table, dc, ac, extractBlock img block xSamplingFactor ySamplingFactor
-                                                  imageComponentCount comp blockX blockY)
-                                    | my <- [0 .. verticalMetaBlockCount - 1]
-                                    , mx <- [0 .. horizontalMetaBlockCount - 1]
-                                    , (comp, (sizeX, sizeY, table, dc, ac)) <- zip [0..] componentDef
-                                    , subY <- [0 .. sizeY - 1]
-                                    , subX <- [0 .. sizeX - 1]
-                                    , let blockX = mx * sizeX + subX
-                                          blockY = my * sizeY + subY
-                                          xSamplingFactor = maxSampling - sizeX + 1
-                                          ySamplingFactor = maxSampling - sizeY + 1
-                                    ]
-  
-            workData <- lift createEmptyMutableMacroBlock
-            zigzaged <- lift createEmptyMutableMacroBlock
-            forM_ blockList $ \(comp, table, dc, ac, extractor) -> do
-                prev_dc <- lift $ dc_table .!!!. comp
-                (dc_coeff, neo_block) <- lift (extractor >>= 
-                                        encodeMacroBlock table workData zigzaged prev_dc)
-                lift . (dc_table .<-. comp) $ fromIntegral dc_coeff
-                serializeMacroBlock dc ac neo_block
 
+            dc_table <- M.replicate 3 0
+            block <- createEmptyMutableMacroBlock
+            workData <- createEmptyMutableMacroBlock
+            zigzaged <- createEmptyMutableMacroBlock
+            writeState <- newWriteStateRef
+
+            -- It's ugly, I know, be avoid allocation
+            let blockLine my | my >= verticalMetaBlockCount = return ()
+                blockLine my = blockColumn 0
+                  where blockColumn mx | mx >= horizontalMetaBlockCount = blockLine (my + 1)
+                        blockColumn mx = component $ zip [0..] componentDef
+                          where component [] = blockColumn (mx + 1)
+                                component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) = line 0
+                                  where xSamplingFactor = maxSampling - sizeX + 1
+                                        ySamplingFactor = maxSampling - sizeY + 1
+                                        extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount 
+                                        line subY | subY >= sizeY = component comp_rest
+                                        line subY = column 0
+                                           where blockY = my * sizeY + subY
+                                                 
+                                                 column subX | subX >= sizeX = line (subY + 1)
+                                                 column subX = do
+                                                    let blockX = mx * sizeX + subX
+                                                    prev_dc <- dc_table `M.unsafeRead` comp
+                                                    (dc_coeff, neo_block) <- (extractor comp blockX blockY >>= 
+                                                                            encodeMacroBlock table workData zigzaged prev_dc)
+                                                    (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
+                                                    serializeMacroBlock writeState dc ac neo_block
+                                                    column $ subX + 1
+            blockLine 0
+
+            finalizeBoolWriter writeState

@@ -5,6 +5,7 @@ module Codec.Picture.Jpg.DefaultTable( DctComponent( .. )
 									 , HuffmanTree( .. )
 									 , HuffmanTable
+									 , HuffmanPackedTree
 									 , MacroBlock
 									 , QuantificationTable
 									 , HuffmanWriterCode 
@@ -12,6 +13,7 @@ 									 , makeMacroBlock
 									 , makeInverseTable
 									 , buildHuffmanTree
+									 , packHuffmanTree
 
 									 , defaultChromaQuantizationTable
 
@@ -30,13 +32,15 @@ 									 , defaultDcLumaHuffmanTable
 									 ) where
 
+import Data.Int( Int16 )
 import Foreign.Storable ( Storable )
+import Control.Monad.ST( runST )
 import qualified Data.Vector.Storable as SV
 import qualified Data.Vector as V
-import Data.Bits( shiftL, (.|.) )
-import Data.Int( Int16 )
+import Data.Bits( unsafeShiftL, (.|.) )
 import Data.Word( Word8, Word16 )
 import Data.List( foldl' )
+import qualified Data.Vector.Storable.Mutable as M
 
 -- | Tree storing the code used for huffman encoding.
 data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right.
@@ -44,15 +48,49 @@                  | Empty            -- ^ no value present
                  deriving (Eq, Show)
 
+type HuffmanPackedTree = SV.Vector Word16
+
 type HuffmanWriterCode = V.Vector (Word8, Word16)
 
+packHuffmanTree :: HuffmanTree -> HuffmanPackedTree
+packHuffmanTree tree = runST $ do
+    table <- M.replicate 512 0x8000
+    let aux (Empty) idx = return $ idx + 1
+        aux (Leaf v) idx = do
+            (table `M.unsafeWrite` idx) $ (fromIntegral v .|. 0x4000)
+            return $ idx + 1
+
+        aux (Branch i1@(Leaf _) i2@(Leaf _)) idx =
+            aux i1 idx >>= aux i2
+
+        aux (Branch i1@(Leaf _) i2) idx = do
+            _ <- aux i1 idx
+            ix2 <- aux i2 $ idx + 2
+            (table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2
+            return ix2
+
+        aux (Branch i1 i2@(Leaf _)) idx = do
+            ix1 <- aux i1 (idx + 2)
+            _ <- aux i2 (idx + 1)
+            (table `M.unsafeWrite` idx) (fromIntegral ix1)
+            return ix1
+
+        aux (Branch i1 i2) idx = do
+            ix1 <- aux i1 (idx + 2)
+            ix2 <- aux i2 ix1
+            (table `M.unsafeWrite` idx) (fromIntegral $ idx + 2)
+            (table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1)
+            return ix2
+    _ <- aux tree 0
+    SV.unsafeFreeze table
+
 makeInverseTable :: HuffmanTree -> HuffmanWriterCode
 makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t
   where inner _     _     Empty   = []
         inner depth code (Leaf v) = [(fromIntegral v, (depth, code))]
         inner depth code (Branch l r) =
           inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r
-            where shifted = code `shiftL` 1
+            where shifted = code `unsafeShiftL` 1
 
 -- | Represent a compact array of 8 * 8 values. The size
 -- is not guarenteed by type system, but if makeMacroBlock is
@@ -88,6 +126,10 @@ 
 scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable 
 scaleQuantisationMatrix quality
+    | quality < 0 = scaleQuantisationMatrix 0
+        -- shouldn't show much difference than with 1,
+        -- but hey, at least we're complete
+    | quality == 0 = SV.map (scale (10000 :: Int))
     | quality < 50 = let qq = 5000 `div` quality
                      in SV.map (scale qq)
     | otherwise    = SV.map (scale q)

@@ -2,7 +2,7 @@ 
 import Control.Applicative( (<$>) )
 import Data.Int( Int16, Int32 )
-import Data.Bits( Bits, shiftR, shiftL )
+import Data.Bits( Bits, unsafeShiftR, unsafeShiftL )
 import Control.Monad.ST( ST )
 
 import qualified Data.Vector.Storable.Mutable as M
@@ -10,12 +10,6 @@ import Codec.Picture.Jpg.Types
 import Control.Monad( forM, forM_ )
 
-{-# INLINE (.>>.) #-}
-{-# INLINE (.<<.) #-}
-(.>>.), (.<<.) :: (Bits a) => a -> Int -> a
-(.>>.) = shiftR
-(.<<.) = shiftL
-
 -- | Reference implementation of the DCT, directly implementing the formula
 -- of ITU-81. It's slow as hell, perform to many operations, but is accurate
 -- and a good reference point.
@@ -24,11 +18,11 @@              -> ST s (MutableMacroBlock s Int32)
 referenceDct workData block = forM_ [(u, v) | u <- [0 :: Int .. 7], v <- [0..7]] (\(u,v) -> do
     val <- at (u,v)
-    (workData .<-. (v * 8 + u)) . truncate $ (1 / 4) * c u * c v * val)
+    (workData `M.unsafeWrite` (v * 8 + u)) . truncate $ (1 / 4) * c u * c v * val)
     >> return workData
  where -- at :: (Int, Int) -> ST s Float
        at (u,v) = sum <$> (forM [(x,y) | x <- [0..7], y <- [0..7 :: Int]] $ \(x,y) -> do
-           sample <- fromIntegral <$> (block .!!!. (y * 8 + x))
+           sample <- fromIntegral <$> (block `M.unsafeRead` (y * 8 + x))
            return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) 
                            * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16))
        c 0 = 1 / sqrt 2
@@ -74,11 +68,11 @@         firstPass         _ 8 = return ()
         firstPass dataBlock i = do
             let baseIdx = i * 8
-                readAt idx = fromIntegral <$> sample_block .!!!. (baseIdx + idx)
+                readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx)
                 mult = (*)
-                writeAt idx n = (dataBlock .<-. (baseIdx + idx)) n
-                writeAtPos idx n = (dataBlock .<-. (baseIdx + idx))
-                                    (n .>>. (cONST_BITS - pASS1_BITS))
+                writeAt idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) n
+                writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx))
+                                    (n `unsafeShiftR` (cONST_BITS - pASS1_BITS))
 
             blk0 <- readAt 0
             blk1 <- readAt 1
@@ -105,11 +99,11 @@                 tmp3' = blk3 - blk4
 
             -- Stage 4 and output
-            writeAt 0 $ (tmp10 + tmp11 - 8 * cENTERJSAMPLE) .<<. pASS1_BITS
-            writeAt 4 $ (tmp10 - tmp11) .<<. pASS1_BITS
+            writeAt 0 $ (tmp10 + tmp11 - 8 * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS
+            writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS
 
             let z1 = mult (tmp12 + tmp13) fIX_0_541196100
-                     + (1 .<<. (cONST_BITS - pASS1_BITS - 1))
+                     + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS - 1))
 
             writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865
             writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065
@@ -120,7 +114,7 @@                 tmp13' = tmp1' + tmp3'
                 z1' = mult (tmp12' + tmp13') fIX_1_175875602 --  c3 */
                         -- Add fudge factor here for final descale. */
-                        + (1 .<<. (cONST_BITS - pASS1_BITS-1))
+                        + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS-1))
                 tmp0'' = mult tmp0' fIX_1_501321110
                 tmp1'' = mult tmp1' fIX_3_072711026
                 tmp2'' = mult tmp2' fIX_2_053119869
@@ -144,10 +138,10 @@         secondPass :: M.STVector s Int32 -> Int -> ST s ()
         secondPass _     (-1) = return ()
         secondPass block i = do
-            let readAt idx = block .!!!. ((7 - i) + idx * 8)
+            let readAt idx = block `M.unsafeRead` ((7 - i) + idx * 8)
                 mult = (*)
-                writeAt idx n = (block .<-. (8 * idx + (7 - i))) n
-                writeAtPos idx n = (block .<-. (8 * idx + (7 - i))) $ n .>>. (cONST_BITS + pASS1_BITS + 3)
+                writeAt idx n = (block `M.unsafeWrite` (8 * idx + (7 - i))) n
+                writeAtPos idx n = (block `M.unsafeWrite` (8 * idx + (7 - i))) $ n `unsafeShiftR` (cONST_BITS + pASS1_BITS + 3)
             blk0 <- readAt 0
             blk1 <- readAt 1
             blk2 <- readAt 2
@@ -163,7 +157,7 @@                 tmp3 = blk3 + blk4
 
                 -- Add fudge factor here for final descale. */
-                tmp10 = tmp0 + tmp3 + (1 .<<. (pASS1_BITS-1))
+                tmp10 = tmp0 + tmp3 + (1 `unsafeShiftL` (pASS1_BITS-1))
                 tmp12 = tmp0 - tmp3
                 tmp11 = tmp1 + tmp2
                 tmp13 = tmp1 - tmp2
@@ -173,11 +167,11 @@                 tmp2' = blk2 - blk5
                 tmp3' = blk3 - blk4
 
-            writeAt 0 $ (tmp10 + tmp11) .>>. (pASS1_BITS + 3)
-            writeAt 4 $ (tmp10 - tmp11) .>>. (pASS1_BITS + 3)
+            writeAt 0 $ (tmp10 + tmp11) `unsafeShiftR` (pASS1_BITS + 3)
+            writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3)
 
             let z1 = mult (tmp12 + tmp13) fIX_0_541196100
-                    + (1 .<<. (cONST_BITS + pASS1_BITS - 1))
+                    + (1 `unsafeShiftL` (cONST_BITS + pASS1_BITS - 1))
 
             writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865
             writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065
@@ -189,7 +183,7 @@ 
                 z1' = mult (tmp12' + tmp13') fIX_1_175875602
                     -- Add fudge factor here for final descale. */
-                   + 1 .<<. (cONST_BITS+pASS1_BITS-1);
+                   + 1 `unsafeShiftL` (cONST_BITS+pASS1_BITS-1);
 
                 tmp0''  = mult tmp0'    fIX_1_501321110
                 tmp1''  = mult tmp1'    fIX_3_072711026

@@ -19,10 +19,10 @@                                  ) where
 
 import qualified Data.Vector.Storable as V
-import Control.Monad( forM_ )
 import Control.Monad.ST( ST )
-import Data.Bits( shiftL, shiftR )
+import Data.Bits( unsafeShiftL, unsafeShiftR )
 import Data.Int( Int16 )
+import qualified Data.Vector.Storable.Mutable as M
 
 import Codec.Picture.Jpg.Types
 
@@ -32,20 +32,6 @@                 | i > 255    =  255
                 | otherwise  =  i
 
-{-# INLINE clip #-}
-clip :: Int -> Int16
-clip i -- = iclip !!! (i + 512)
-       | i < 511 = if i > -512 then iclip !!! (i + 512)
-                               else iclip !!! 0
-    
-       | otherwise = iclip !!! 1023
-
-{-# INLINE (.<<.) #-}
-{-# INLINE (.>>.) #-}
-(.<<.), (.>>.) :: Int -> Int -> Int
-(.<<.) = shiftL
-(.>>.) = shiftR
-
 data IDctStage = IDctStage { 
         x0 :: {-# UNPACK #-} !Int,
         x1 :: {-# UNPACK #-} !Int,
@@ -76,16 +62,16 @@ --        c[1..7] = 128*sqrt(2)
 idctRow :: MutableMacroBlock s Int16 -> Int ->  ST s ()
 idctRow blk idx = do
-  xx0 <- blk .!!!. (0 + idx)
-  xx1 <- blk .!!!. (4 + idx) 
-  xx2 <- blk .!!!. (6 + idx)
-  xx3 <- blk .!!!. (2 + idx)
-  xx4 <- blk .!!!. (1 + idx)
-  xx5 <- blk .!!!. (7 + idx)
-  xx6 <- blk .!!!. (5 + idx)
-  xx7 <- blk .!!!. (3 + idx)
-  let initialState = IDctStage { x0 = (fromIntegral xx0 .<<. 11) + 128
-                               , x1 =  fromIntegral xx1 .<<. 11
+  xx0 <- blk `M.unsafeRead` (0 + idx)
+  xx1 <- blk `M.unsafeRead` (4 + idx) 
+  xx2 <- blk `M.unsafeRead` (6 + idx)
+  xx3 <- blk `M.unsafeRead` (2 + idx)
+  xx4 <- blk `M.unsafeRead` (1 + idx)
+  xx5 <- blk `M.unsafeRead` (7 + idx)
+  xx6 <- blk `M.unsafeRead` (5 + idx)
+  xx7 <- blk `M.unsafeRead` (3 + idx)
+  let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 11) + 128
+                               , x1 =  fromIntegral xx1 `unsafeShiftL` 11
                                , x2 =  fromIntegral xx2
                                , x3 =  fromIntegral xx3
                                , x4 =  fromIntegral xx4
@@ -120,28 +106,28 @@                        , x8 = x8 c - x3 c
                        , x3 = x0 c + x2 c
                        , x0 = x0 c - x2 c
-                       , x2 = (181 * (x4 c + x5 c) + 128) .>>. 8
-                       , x4 = (181 * (x4 c - x5 c) + 128) .>>. 8
+                       , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8
+                       , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8
                        }
-      scaled c = c { x0 = (x7 c + x1 c) .>>. 8
-                   , x1 = (x3 c + x2 c) .>>. 8
-                   , x2 = (x0 c + x4 c) .>>. 8
-                   , x3 = (x8 c + x6 c) .>>. 8
-                   , x4 = (x8 c - x6 c) .>>. 8
-                   , x5 = (x0 c - x4 c) .>>. 8
-                   , x6 = (x3 c - x2 c) .>>. 8
-                   , x7 = (x7 c - x1 c) .>>. 8
+      scaled c = c { x0 = (x7 c + x1 c) `unsafeShiftR` 8
+                   , x1 = (x3 c + x2 c) `unsafeShiftR` 8
+                   , x2 = (x0 c + x4 c) `unsafeShiftR` 8
+                   , x3 = (x8 c + x6 c) `unsafeShiftR` 8
+                   , x4 = (x8 c - x6 c) `unsafeShiftR` 8
+                   , x5 = (x0 c - x4 c) `unsafeShiftR` 8
+                   , x6 = (x3 c - x2 c) `unsafeShiftR` 8
+                   , x7 = (x7 c - x1 c) `unsafeShiftR` 8
                    }
       transformed = scaled . thirdStage . secondStage $ firstStage initialState
 
-  (blk .<-. (0 + idx)) . fromIntegral $ x0 transformed
-  (blk .<-. (1 + idx)) . fromIntegral $ x1 transformed
-  (blk .<-. (2 + idx)) . fromIntegral $ x2 transformed
-  (blk .<-. (3 + idx)) . fromIntegral $ x3 transformed
-  (blk .<-. (4 + idx)) . fromIntegral $ x4 transformed
-  (blk .<-. (5 + idx)) . fromIntegral $ x5 transformed
-  (blk .<-. (6 + idx)) . fromIntegral $ x6 transformed
-  (blk .<-. (7 + idx)) . fromIntegral $ x7 transformed
+  (blk `M.unsafeWrite` (0 + idx)) . fromIntegral $ x0 transformed
+  (blk `M.unsafeWrite` (1 + idx)) . fromIntegral $ x1 transformed
+  (blk `M.unsafeWrite` (2 + idx)) . fromIntegral $ x2 transformed
+  (blk `M.unsafeWrite` (3 + idx)) . fromIntegral $ x3 transformed
+  (blk `M.unsafeWrite` (4 + idx)) . fromIntegral $ x4 transformed
+  (blk `M.unsafeWrite` (5 + idx)) . fromIntegral $ x5 transformed
+  (blk `M.unsafeWrite` (6 + idx)) . fromIntegral $ x6 transformed
+  (blk `M.unsafeWrite` (7 + idx)) . fromIntegral $ x7 transformed
 
 -- column (vertical) IDCT
 --
@@ -154,16 +140,16 @@ --
 idctCol :: MutableMacroBlock s Int16 -> Int -> ST s ()
 idctCol blk idx = do
-  xx0 <- blk .!!!. (    0 + idx)
-  xx1 <- blk .!!!. (8 * 4 + idx)
-  xx2 <- blk .!!!. (8 * 6 + idx)
-  xx3 <- blk .!!!. (8 * 2 + idx)
-  xx4 <- blk .!!!. (8     + idx)
-  xx5 <- blk .!!!. (8 * 7 + idx)
-  xx6 <- blk .!!!. (8 * 5 + idx)
-  xx7 <- blk .!!!. (8 * 3 + idx)
-  let initialState = IDctStage { x0 = (fromIntegral xx0 .<<. 8) + 8192
-                               , x1 =  fromIntegral xx1 .<<. 8
+  xx0 <- blk `M.unsafeRead` (    0 + idx)
+  xx1 <- blk `M.unsafeRead` (8 * 4 + idx)
+  xx2 <- blk `M.unsafeRead` (8 * 6 + idx)
+  xx3 <- blk `M.unsafeRead` (8 * 2 + idx)
+  xx4 <- blk `M.unsafeRead` (8     + idx)
+  xx5 <- blk `M.unsafeRead` (8 * 7 + idx)
+  xx6 <- blk `M.unsafeRead` (8 * 5 + idx)
+  xx7 <- blk `M.unsafeRead` (8 * 3 + idx)
+  let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 8) + 8192
+                               , x1 =  fromIntegral xx1 `unsafeShiftL` 8
                                , x2 =  fromIntegral xx2
                                , x3 =  fromIntegral xx3
                                , x4 =  fromIntegral xx4
@@ -172,10 +158,10 @@                                , x7 =  fromIntegral xx7
                                , x8 = 0
                                } 
-      firstStage c = c { x4 = (x8'  + (w1 - w7) * x4 c) .>>. 3
-                       , x5 = (x8'  - (w1 + w7) * x5 c) .>>. 3
-                       , x6 = (x8'' - (w3 - w5) * x6 c) .>>. 3
-                       , x7 = (x8'' - (w3 + w5) * x7 c) .>>. 3
+      firstStage c = c { x4 = (x8'  + (w1 - w7) * x4 c) `unsafeShiftR` 3
+                       , x5 = (x8'  - (w1 + w7) * x5 c) `unsafeShiftR` 3
+                       , x6 = (x8'' - (w3 - w5) * x6 c) `unsafeShiftR` 3
+                       , x7 = (x8'' - (w3 + w5) * x7 c) `unsafeShiftR` 3
                        , x8 = x8''
                        }
           where x8'  = w7 * (x4 c + x5 c) + 4
@@ -183,8 +169,8 @@ 
       secondStage c = c { x8 = x0 c + x1 c
                         , x0 = x0 c - x1 c
-                        , x2 = (x1' - (w2 + w6) * x2 c) .>>. 3
-                        , x3 = (x1' + (w2 - w6) * x3 c) .>>. 3
+                        , x2 = (x1' - (w2 + w6) * x2 c) `unsafeShiftR` 3
+                        , x3 = (x1' + (w2 - w6) * x3 c) `unsafeShiftR` 3
                         , x4 = x4 c - x6 c
                         , x1 = x1''
                         , x6 = x5 c + x7 c
@@ -197,19 +183,24 @@                        , x8 = x8 c - x3 c
                        , x3 = x0 c + x2 c
                        , x0 = x0 c - x2 c
-                       , x2 = (181 * (x4 c + x5 c) + 128) .>>. 8
-                       , x4 = (181 * (x4 c - x5 c) + 128) .>>. 8
+                       , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8
+                       , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8
                        }
 
+      clip i | i < 511 = if i > -512 then iclip `V.unsafeIndex` (i + 512)
+                                    else iclip `V.unsafeIndex` 0
+            
+             | otherwise = iclip `V.unsafeIndex` 1023
+
       f = thirdStage . secondStage $ firstStage initialState
-  (blk .<-. (idx + 8*0)) . clip $ (x7 f + x1 f) .>>. 14
-  (blk .<-. (idx + 8  )) . clip $ (x3 f + x2 f) .>>. 14
-  (blk .<-. (idx + 8*2)) . clip $ (x0 f + x4 f) .>>. 14
-  (blk .<-. (idx + 8*3)) . clip $ (x8 f + x6 f) .>>. 14
-  (blk .<-. (idx + 8*4)) . clip $ (x8 f - x6 f) .>>. 14
-  (blk .<-. (idx + 8*5)) . clip $ (x0 f - x4 f) .>>. 14
-  (blk .<-. (idx + 8*6)) . clip $ (x3 f - x2 f) .>>. 14
-  (blk .<-. (idx + 8*7)) . clip $ (x7 f - x1 f) .>>. 14
+  (blk `M.unsafeWrite` (idx + 8*0)) . clip $ (x7 f + x1 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8  )) . clip $ (x3 f + x2 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*2)) . clip $ (x0 f + x4 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*3)) . clip $ (x8 f + x6 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*4)) . clip $ (x8 f - x6 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*5)) . clip $ (x0 f - x4 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*6)) . clip $ (x3 f - x2 f) `unsafeShiftR` 14
+  (blk `M.unsafeWrite` (idx + 8*7)) . clip $ (x7 f - x1 f) `unsafeShiftR` 14
 
 
 {-# INLINE fastIdct #-}
@@ -217,14 +208,21 @@ -- block that the one given as input.
 fastIdct :: MutableMacroBlock s Int16
          -> ST s (MutableMacroBlock s Int16)
-fastIdct block = do
-    forM_ [0..7] (\i -> idctRow block (8 * i))
-    forM_ [0..7] (idctCol block)
-    return block
+fastIdct block = rows 0
+  where rows 8 = cols 0
+        rows i = idctRow block (8 * i) >> rows (i + 1)
 
+        cols 8 = return block
+        cols i = idctCol block i >> cols (i + 1)
+
 {-# INLINE mutableLevelShift #-}
 -- | Perform a Jpeg level shift in a mutable fashion.
 mutableLevelShift :: MutableMacroBlock s Int16
                   -> ST s (MutableMacroBlock s Int16)
-mutableLevelShift = mutate (\_ v -> v + 128)
+mutableLevelShift block = update 0
+  where update 64 = return block
+        update idx = do
+            val <- block `M.unsafeRead` idx
+            (block `M.unsafeWrite` idx) $ val + 128
+            update $ idx + 1
 

@@ -1,36 +1,14 @@ module Codec.Picture.Jpg.Types( MutableMacroBlock
                               , createEmptyMutableMacroBlock
-                              , mutate
                               , printMacroBlock
-                              , (!!!),  (.!!!.), (.<-.)
                               ) where
 
 import Control.Monad.ST( ST )
 import Foreign.Storable ( Storable )
-import Control.Monad.Primitive ( PrimState, PrimMonad )
-import qualified Data.Vector.Storable as V
 import qualified Data.Vector.Storable.Mutable as M
--- import Data.Vector.Storable( (!) )
 
 import Text.Printf
 
-{-# INLINE (!!!) #-}
-(!!!) :: (Storable e) => V.Vector e -> Int -> e
-(!!!) = -- (!) 
-        V.unsafeIndex
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a)
-        => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = -- M.read
-          M.unsafeRead
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a)
-       => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = -- M.write 
-         M.unsafeWrite
-
 -- | Macroblock that can be transformed.
 type MutableMacroBlock s a = M.STVector s a
 
@@ -39,23 +17,12 @@ createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a)
 createEmptyMutableMacroBlock = M.replicate 64 0
 
-{-# INLINE mutate #-}
--- | Return the transformed block
-mutate :: Storable a
-       => (Int -> a -> a)   -- ^ The updating function
-       -> MutableMacroBlock s a -> ST s (MutableMacroBlock s a)
-mutate f block = update 0 >> return block
-   where updateVal i = (block .!!!. i) >>= (block .<-. i) . f i
-
-         update 63 = updateVal 63
-         update n  = updateVal n >> update (n + 1)
-
 printMacroBlock :: (Storable a, PrintfArg a)
                 => MutableMacroBlock s a -> ST s String
 printMacroBlock block = pLn 0
     where pLn 64 = return "===============================\n"
           pLn i = do
-              v <- block .!!!. i
+              v <- block `M.unsafeRead` i
               vn <- pLn (i+1)
               return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn
 

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE BangPatterns #-}
 -- | Module used for loading & writing \'Portable Network Graphics\' (PNG)
 -- files. The API has two layers, the high level, which load the image without
 -- looking deeply about it and the low level, allowing access to data chunks contained
@@ -18,20 +19,19 @@ 
                         ) where
 
-import Control.Monad( foldM_, forM_, when )
+import Control.Applicative( (<$>) )
+import Control.Monad( forM_, foldM_, when )
 import Control.Monad.ST( ST, runST )
-import Control.Monad.Trans( lift )
-import Control.Monad.Primitive ( PrimState, PrimMonad )
-import qualified Control.Monad.Trans.State.Strict as S
 import Data.Binary( Binary( get) )
 
 import qualified Data.Vector.Storable as V
 import qualified Data.Vector.Storable.Mutable as M
-import Data.Bits( (.&.), (.|.), shiftL, shiftR )
+import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
 import Data.List( find, zip4 )
 import Data.Word( Word8, Word16, Word32 )
 import qualified Codec.Compression.Zlib as Z
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as BU
 import qualified Data.ByteString.Lazy as Lb
 import Foreign.Storable ( Storable )
 
@@ -63,6 +63,7 @@     }
 
 unparsePngFilter :: Word8 -> Either String PngFilter
+{-# INLINE unparsePngFilter #-}
 unparsePngFilter 0 = Right FilterNone
 unparsePngFilter 1 = Right FilterSub
 unparsePngFilter 2 = Right FilterUp
@@ -70,38 +71,24 @@ unparsePngFilter 4 = Right FilterPaeth
 unparsePngFilter _ = Left "Invalid scanline filter"
 
-type ByteReader s a = S.StateT B.ByteString (ST s) a
-
-{-# INLINE getNextByte #-}
-getNextByte :: ByteReader s Word8
-getNextByte = do str <- S.get
-                 case B.uncons str of
-                    Just (v, rest) -> S.put rest >> return v
-                    Nothing -> return 0
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = M.unsafeRead
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.) = M.unsafeWrite
-
-{-# INLINE getBounds #-}
 getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int)
+{-# INLINE getBounds #-}
 getBounds v = return (0, M.length v - 1)
 
 -- | Apply a filtering method on a reduced image. Apply the filter
 -- on each line, using the previous line (the one above it) to perform
 -- some prediction on the value.
 pngFiltering :: LineUnpacker s -> Int -> (Int, Int)    -- ^ Image size
-             -> ByteReader s ()
-pngFiltering _ _ (imgWidth, imgHeight) | imgWidth <= 0 || imgHeight <= 0 = return ()
-pngFiltering unpacker beginZeroes (imgWidth, imgHeight) = do
-    thisLine <- lift $ M.replicate (beginZeroes + imgWidth) 0
-    otherLine <- lift $ M.replicate (beginZeroes + imgWidth) 0
-    foldM_ (\(previousLine, currentLine) lineIndex -> do
-               byte <- getNextByte
+             -> B.ByteString -> Int
+             -> ST s Int
+pngFiltering _ _ (imgWidth, imgHeight) _str initialIdx
+        | imgWidth <= 0 || imgHeight <= 0 = return initialIdx
+pngFiltering unpacker beginZeroes (imgWidth, imgHeight) str initialIdx = do
+    thisLine <- M.replicate (beginZeroes + imgWidth) 0
+    otherLine <- M.replicate (beginZeroes + imgWidth) 0
+    let folder            _          _  lineIndex !idx | lineIndex >= imgHeight = return idx
+        folder previousLine currentLine lineIndex !idx = do
+               let byte = str `BU.unsafeIndex` idx
                let lineFilter = case unparsePngFilter byte of
                        Right FilterNone    -> filterNone
                        Right FilterSub     -> filterSub
@@ -109,11 +96,12 @@                        Right FilterUp      -> filterUp
                        Right FilterPaeth   -> filterPaeth
                        _ -> filterNone
-               lineFilter (previousLine, currentLine)
-               lift $ unpacker lineIndex (stride, currentLine)
-               return (currentLine, previousLine)
-        ) (thisLine, otherLine) [0 .. imgHeight - 1]
+               idx' <- lineFilter previousLine currentLine $ idx + 1
+               unpacker lineIndex (stride, currentLine)
+               folder currentLine previousLine (lineIndex + 1) idx'
 
+    folder thisLine otherLine (0 :: Int) initialIdx
+
     where stride = fromIntegral beginZeroes
           lastIdx = beginZeroes + imgWidth - 1
 
@@ -122,62 +110,67 @@           -- they are faster than mapM_, gained something like 5% with
           -- a rewrite from mapM_ to this direct version
           filterNone, filterSub, filterUp, filterPaeth,
-                filterAverage :: (PngLine s, PngLine s) -> ByteReader s ()
-          filterNone (_previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             lift $ (thisLine .<-. idx) byte
-                                             inner (idx + 1)
+                filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int
+          filterNone !_previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             (thisLine `M.unsafeWrite` idx) byte
+                                             inner (idx + 1) $ readIdx + 1
 
-          filterSub (_previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             val <- lift $ thisLine .!!!. (idx - stride)
-                                             lift . (thisLine .<-. idx) $ byte + val
-                                             inner (idx + 1)
+          filterSub !_previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             val <- thisLine `M.unsafeRead` (idx - stride)
+                                             (thisLine `M.unsafeWrite` idx) $ byte + val
+                                             inner (idx + 1) $ readIdx + 1
 
-          filterUp (previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             val <- lift $ previousLine .!!!. idx
-                                             lift . (thisLine .<-. idx) $ val + byte
-                                             inner (idx + 1)
+          filterUp !previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             val <- previousLine `M.unsafeRead` idx
+                                             (thisLine `M.unsafeWrite` idx) $ val + byte
+                                             inner (idx + 1) $ readIdx + 1
 
-          filterAverage (previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             valA <- lift $ thisLine .!!!. (idx - stride)
-                                             valB <- lift $ previousLine .!!!. idx
+          filterAverage !previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             valA <- thisLine `M.unsafeRead` (idx - stride)
+                                             valB <- previousLine `M.unsafeRead` idx
                                              let a' = fromIntegral valA
                                                  b' = fromIntegral valB
                                                  average = fromIntegral ((a' + b') `div` (2 :: Word16)) 
                                                  writeVal = byte + average 
-                                             lift . (thisLine .<-. idx) $ writeVal
-                                             inner (idx + 1)
+                                             (thisLine `M.unsafeWrite` idx) $ writeVal
+                                             inner (idx + 1) $ readIdx + 1
 
-          filterPaeth (previousLine, thisLine) = inner beginZeroes
-            where inner idx | idx > lastIdx = return ()
-                            | otherwise = do byte <- getNextByte
-                                             valA <- lift $ thisLine .!!!. (idx - stride)
-                                             valC <- lift $ previousLine .!!!. (idx - stride)
-                                             valB <- lift $ previousLine .!!!. idx
-                                             lift . (thisLine .<-. idx) $ byte + paeth valA valB valC
-                                             inner (idx + 1)
+          filterPaeth !previousLine !thisLine = inner beginZeroes
+            where inner idx !readIdx
+                            | idx > lastIdx = return readIdx
+                            | otherwise = do let byte = str `BU.unsafeIndex` readIdx
+                                             valA <- thisLine `M.unsafeRead` (idx - stride)
+                                             valC <- previousLine `M.unsafeRead` (idx - stride)
+                                             valB <- previousLine `M.unsafeRead` idx
+                                             (thisLine `M.unsafeWrite` idx) $ byte + paeth valA valB valC
+                                             inner (idx + 1) $ readIdx + 1
 
+                  paeth a b c
+                    | pa <= pb && pa <= pc = a
+                    | pb <= pc             = b
+                    | otherwise            = c
+                      where a' = fromIntegral a :: Int
+                            b' = fromIntegral b
+                            c' = fromIntegral c
+                            p = a' + b' - c'
+                            pa = abs $ p - a'
+                            pb = abs $ p - b'
+                            pc = abs $ p - c'
+                  
 -- | Directly stolen from the definition in the standard (on W3C page),
 -- pixel predictor.
-paeth :: Word8 -> Word8 -> Word8 -> Word8
-paeth a b c
-  | pa <= pb && pa <= pc = a
-  | pb <= pc             = b
-  | otherwise            = c
-    where a' = fromIntegral a :: Int
-          b' = fromIntegral b
-          c' = fromIntegral c
-          p = a' + b' - c'
-          pa = abs $ p - a'
-          pb = abs $ p - b'
-          pc = abs $ p - c'
 
 type PngLine s = M.STVector s Word8
 type LineUnpacker s = Int -> (Int, PngLine s) -> ST s ()
@@ -202,9 +195,9 @@                 srcPixelIndex = pixelIndex * sampleCount + beginIdx
                 perPixel sample | sample >= sampleCount = return ()
                                 | otherwise = do
-                    val <- line .!!!. (srcPixelIndex + sample)
+                    val <- line `M.unsafeRead` (srcPixelIndex + sample)
                     let writeIdx = destSampleIndex + sample
-                    (arr .<-. writeIdx) val
+                    (arr `M.unsafeWrite` writeIdx) val
                     perPixel (sample + 1)
             perPixel 0
             inner (pixelIndex + 1)
@@ -223,15 +216,15 @@                 | otherwise = 0
         (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8
     forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
-        val <- line .!!!. (pixelIndex  + beginIdx)
+        val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
         let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft 
-        forM_ [0 .. 7] $ \bit -> (arr .<-. writeIdx (7 - bit)) ((val `shiftR` bit) .&. 1)
+        forM_ [0 .. 7] $ \bit -> (arr `M.unsafeWrite` writeIdx (7 - bit)) ((val `unsafeShiftR` bit) .&. 1)
 
     when (lineRest /= 0)
-         (do val <- line .!!!. endLine
+         (do val <- line `M.unsafeRead` endLine
              let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft
              forM_ [0 .. lineRest - 1] $ \bit ->
-                (arr .<-. writeIdx bit) ((val `shiftR` (7 - bit)) .&. 0x1))
+                (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (7 - bit)) .&. 0x1))
 
 
 -- | Unpack lines when bit depth is 2
@@ -247,18 +240,18 @@         (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4
 
     forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
-        val <- line .!!!. (pixelIndex  + beginIdx)
+        val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
         let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft 
-        (arr .<-. writeIdx 0) $ (val `shiftR` 6) .&. 0x3
-        (arr .<-. writeIdx 1) $ (val `shiftR` 4) .&. 0x3
-        (arr .<-. writeIdx 2) $ (val `shiftR` 2) .&. 0x3
-        (arr .<-. writeIdx 3) $ val .&. 0x3
+        (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 6) .&. 0x3
+        (arr `M.unsafeWrite` writeIdx 1) $ (val `unsafeShiftR` 4) .&. 0x3
+        (arr `M.unsafeWrite` writeIdx 2) $ (val `unsafeShiftR` 2) .&. 0x3
+        (arr `M.unsafeWrite` writeIdx 3) $ val .&. 0x3
 
     when (lineRest /= 0)
-         (do val <- line .!!!. endLine
+         (do val <- line `M.unsafeRead` endLine
              let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft
              forM_ [0 .. lineRest - 1] $ \bit ->
-                (arr .<-. writeIdx bit) ((val `shiftR` (6 - 2 * bit)) .&. 0x3))
+                (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (6 - 2 * bit)) .&. 0x3))
 
 halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
 halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
@@ -271,17 +264,17 @@                 | otherwise = 0
         (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2
     forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do
-        val <- line .!!!. (pixelIndex  + beginIdx)
+        val <- line `M.unsafeRead` (pixelIndex  + beginIdx)
         let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft 
-        (arr .<-. writeIdx 0) $ (val `shiftR` 4) .&. 0xF
-        (arr .<-. writeIdx 1) $ val .&. 0xF
+        (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 4) .&. 0xF
+        (arr `M.unsafeWrite` writeIdx 1) $ val .&. 0xF
     
     when (lineRest /= 0)
-         (do val <- line .!!!. endLine
+         (do val <- line `M.unsafeRead` endLine
              let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft 
-             (arr .<-. writeIdx) $ (val `shiftR` 4) .&. 0xF)
+             (arr `M.unsafeWrite` writeIdx) $ (val `unsafeShiftR` 4) .&. 0xF)
 
-shortUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
+shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s
 shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr })
              (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do
     (_, maxIdx) <- getBounds line
@@ -293,33 +286,31 @@             destSampleIndex = destPixelIndex * sampleCount
             srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx
         forM_ [0 .. sampleCount - 1] $ \sample -> do
-            highBits <- line .!!!. (srcPixelIndex + sample * 2 + 0)
-            lowBits <- line .!!!. (srcPixelIndex + sample * 2 + 1)
-            let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `shiftL` 8) :: Word32
-                word8Max = 2 ^ (8 :: Word32) - 1 :: Word32
-                word16Max = 2 ^ (16 :: Word32) - 1 :: Word32
-                val = fullValue * word8Max `div` word16Max
+            highBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 0)
+            lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1)
+            let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8)
                 writeIdx = destSampleIndex + sample
-            (arr .<-. writeIdx) $ fromIntegral val
+            (arr `M.unsafeWrite` writeIdx) $ fullValue
 
 -- | Transform a scanline to a bunch of bytes. Bytes are then packed
 -- into pixels at a further step.
-scanlineUnpacker :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s
-scanlineUnpacker 1 = bitUnpacker
-scanlineUnpacker 2 = twoBitsUnpacker
-scanlineUnpacker 4 = halfByteUnpacker
-scanlineUnpacker 8 = byteUnpacker
-scanlineUnpacker 16 = shortUnpacker
-scanlineUnpacker _ = error "Impossible bit depth"
+scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset
+                 -> LineUnpacker s
+scanlineUnpacker8 1 = bitUnpacker
+scanlineUnpacker8 2 = twoBitsUnpacker
+scanlineUnpacker8 4 = halfByteUnpacker
+scanlineUnpacker8 8 = byteUnpacker
+scanlineUnpacker8 _ = error "Impossible bit depth"
 
 byteSizeOfBitLength :: Int -> Int -> Int -> Int
 byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0)
    where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8
 
 scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-                     -> ByteReader s ()
-scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker =
-    pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight)
+                     -> B.ByteString
+                     -> ST s ()
+scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str =
+    pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 >> return ()
         where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth
               strideInfo | depth < 8 = 1
                          | otherwise = sampleCount * (depth `div` 8)
@@ -327,19 +318,21 @@ -- | Given data and image size, recreate an image with deinterlaced
 -- data for PNG's adam 7 method.
 adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s)
-            -> ByteReader s ()
-adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker = sequence_
-  [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight)
-                | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement
-                , let passWidth = sizer imgWidth beginW incrW
-                      passHeight = sizer imgHeight beginH incrH
-                      byteWidth = byteSizeOfBitLength depth sampleCount passWidth
-                ]
+            -> B.ByteString -> ST s ()
+adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str =
+  foldM_ (\i f -> f i) 0 subImages >> return ()
     where Adam7MatrixInfo { adam7StartingRow  = startRows
                           , adam7RowIncrement = rowIncrement
                           , adam7StartingCol  = startCols
                           , adam7ColIncrement = colIncrement } = adam7MatrixInfo
 
+          subImages = 
+              [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) str
+                            | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement
+                            , let passWidth = sizer imgWidth beginW incrW
+                                  passHeight = sizer imgHeight beginH incrH
+                                  byteWidth = byteSizeOfBitLength depth sampleCount passWidth
+                            ]
           strideInfo | depth < 8 = 1
                      | otherwise = sampleCount * (depth `div` 8)
           sizer dimension begin increment
@@ -349,24 +342,37 @@ 
 -- | deinterlace picture in function of the method indicated
 -- in the iHDR
-deinterlacer :: PngIHdr -> ByteReader s (M.STVector s Word8)
+deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16))
 deinterlacer (PngIHdr { width = w, height = h, colourType  = imgKind
-                      , interlaceMethod = method, bitDepth = depth  }) = do
+                      , interlaceMethod = method, bitDepth = depth  }) str = do
     let compCount = sampleCountOfImageType imgKind 
         arraySize = fromIntegral $ w * h * compCount
         deinterlaceFunction = case method of
             PngNoInterlace -> scanLineInterleaving
             PngInterlaceAdam7 -> adam7Unpack
         iBitDepth = fromIntegral depth
-    imgArray <- lift $ M.replicate arraySize 0
-    let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
-    deinterlaceFunction iBitDepth 
-                        (fromIntegral compCount)
-                        (fromIntegral w, fromIntegral h)
-                        (scanlineUnpacker iBitDepth (fromIntegral compCount)
-                                                    mutableImage)
-    return imgArray
+    if iBitDepth <= 8
+      then do
+        imgArray <- M.new arraySize
+        let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
+        deinterlaceFunction iBitDepth 
+                            (fromIntegral compCount)
+                            (fromIntegral w, fromIntegral h)
+                            (scanlineUnpacker8 iBitDepth (fromIntegral compCount)
+                                                         mutableImage)
+                            str
+        Left <$> V.unsafeFreeze imgArray
 
+      else do
+        imgArray <- M.new arraySize
+        let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray
+        deinterlaceFunction iBitDepth 
+                            (fromIntegral compCount)
+                            (fromIntegral w, fromIntegral h)
+                            (shortUnpacker (fromIntegral compCount) mutableImage)
+                            str
+        Right <$> V.unsafeFreeze imgArray
+
 generateGreyscalePalette :: Word8 -> PngPalette
 generateGreyscalePalette times = Image possibilities 0 vec
     where possibilities = 2 ^ times - 1
@@ -406,49 +412,66 @@ --
 --    * PixelY8
 --
+--    * PixelY16
+--
 --    * PixelYA8
 --
+--    * PixelYA16
+--
 --    * PixelRGB8
 --
+--    * PixelRGB16
+--
 --    * PixelRGBA8
 --
+--    * PixelRGBA16
+--
 decodePng :: B.ByteString -> Either String DynamicImage
 decodePng byte = do
     rawImg <- runGetStrict get byte
     let ihdr@(PngIHdr { width = w, height = h }) = header rawImg
         compressedImageData =
-              B.concat [chunkData chunk | chunk <- chunks rawImg
+              Lb.concat [chunkData chunk | chunk <- chunks rawImg
                                         , chunkType chunk == iDATSignature]
         zlibHeaderSize = 1 {- compression method/flags code -}
                        + 1 {- Additional flags/check bits -}
                        + 4 {-CRC-}
 
-        imager = Image (fromIntegral w) (fromIntegral h)
+        toImage const1 _const2 (Left a) =
+            Right . const1 $ Image (fromIntegral w) (fromIntegral h) a
+        toImage _const1 const2 (Right a) =
+            Right . const2 $ Image (fromIntegral w) (fromIntegral h) a
 
+        palette8 palette (Left img) =
+            Right . ImageRGB8
+                  . Image (fromIntegral w) (fromIntegral h)
+                  $ applyPalette palette img
+        palette8 _ (Right _) = Left "Invalid bit depth for paleted image"
+
         unparse _ PngGreyscale bytes
             | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) PngIndexedColor bytes
             | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) PngIndexedColor bytes
             | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) PngIndexedColor bytes
-            | otherwise = Right . ImageY8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
+            | otherwise = toImage ImageY8 ImageY16 $ runST stArray
+                where stArray = deinterlacer ihdr bytes
+
         unparse Nothing PngIndexedColor  _ = Left "no valid palette found"
         unparse _ PngTrueColour          bytes =
-            Right . ImageRGB8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
+            toImage ImageRGB8 ImageRGB16 $ runST stArray
+                where stArray = deinterlacer ihdr bytes
         unparse _ PngGreyscaleWithAlpha  bytes =
-            Right . ImageYA8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
+            toImage ImageYA8 ImageYA16 $ runST stArray
+                where stArray = deinterlacer ihdr bytes
         unparse _ PngTrueColourWithAlpha bytes =
-            Right . ImageRGBA8 . imager $ runST stArray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
+            toImage ImageRGBA8 ImageRGBA16 $ runST stArray
+                where stArray = deinterlacer ihdr bytes
         unparse (Just plte) PngIndexedColor bytes =
-            Right . ImageRGB8 . imager $ applyPalette plte uarray
-                where stArray = S.evalStateT (deinterlacer ihdr) bytes >>= V.unsafeFreeze
-                      uarray = runST stArray
+            palette8 plte $ runST stArray
+                where stArray = deinterlacer ihdr bytes
 
-    if B.length compressedImageData <= zlibHeaderSize
+    if Lb.length compressedImageData <= zlibHeaderSize
        then Left "Invalid data size"
-       else let imgData = Z.decompress $ Lb.fromChunks [compressedImageData]
+       else let imgData = Z.decompress compressedImageData
        	        parseableData = B.concat $ Lb.toChunks imgData
                 palette = case find (\c -> pLTESignature == chunkType c) $ chunks rawImg of
                     Nothing -> Nothing

@@ -9,15 +9,21 @@                                , writeDynamicPng
                                ) where
 
+import Control.Monad( forM_ )
+import Control.Monad.ST( ST, runST )
+import Data.Bits( unsafeShiftR, (.&.) )
 import Data.Binary( encode )
-import Data.Vector.Storable ( (!) )
-import Data.Word(Word8)
+import Data.Word(Word8, Word16)
 import qualified Codec.Compression.Zlib as Z
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as Lb
 
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as M
+
 import Codec.Picture.Types
 import Codec.Picture.Png.Type
+import Codec.Picture.VectorByteConversion
 
 -- | Encode an image into a png if possible.
 class PngSavable a where
@@ -44,32 +50,58 @@ endChunk = PngRawChunk { chunkLength = 0
                        , chunkType = iENDSignature
                        , chunkCRC = pngComputeCrc [iENDSignature]
-                       , chunkData = B.empty
+                       , chunkData = Lb.empty
                        }
 
 
-prepareIDatChunk :: B.ByteString -> PngRawChunk
+prepareIDatChunk :: Lb.ByteString -> PngRawChunk
 prepareIDatChunk imgData = PngRawChunk
-    { chunkLength = fromIntegral $ B.length imgData
+    { chunkLength = fromIntegral $ Lb.length imgData
     , chunkType   = iDATSignature
     , chunkCRC    = pngComputeCrc [iDATSignature, imgData]
     , chunkData   = imgData
     }
 
+genericEncode16BitsPng :: (PixelBaseComponent a ~ Word16)
+                       => PngImageType -> Int -> Image a -> Lb.ByteString
+genericEncode16BitsPng imgKind compCount 
+                 image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) =
+  encode PngRawImage { header = hdr, chunks = [prepareIDatChunk imgEncodedData, endChunk]}
+    where hdr = preparePngHeader image imgKind 16
+          zero = B.singleton 0
+
+          lineSize = compCount * w
+          toByteString vec = blitVector vec 0 (lineSize * 2)
+          encodeLine line = toByteString $ runST $ do
+              finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8)
+              let baseIndex = line * lineSize
+              forM_ [0 ..  lineSize - 1] $ \ix -> do
+                  let v = arr `VS.unsafeIndex` (baseIndex + ix)
+                      high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF
+                      low = fromIntegral $ v .&. 0xFF
+
+                  (finalVec `M.unsafeWrite` (ix * 2 + 0)) high
+                  (finalVec `M.unsafeWrite` (ix * 2 + 1)) low
+
+              VS.unsafeFreeze finalVec
+
+          imgEncodedData = Z.compress . Lb.fromChunks
+                        $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]]
+
+
 genericEncodePng :: (PixelBaseComponent a ~ Word8)
                  => PngImageType -> Int -> Image a -> Lb.ByteString
 genericEncodePng imgKind compCount 
                  image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) =
-  encode PngRawImage { header = hdr, chunks = [prepareIDatChunk strictEncoded, endChunk]}
+  encode PngRawImage { header = hdr, chunks = [prepareIDatChunk imgEncodedData, endChunk]}
     where hdr = preparePngHeader image imgKind 8
-          compBound = compCount - 1
-          encodeLine line =
-            0 : [arr ! ((line * w + column) * compCount + comp) | column <- [0 .. w - 1]
-                                                                , comp <- [0 .. compBound]]
-          imgEncodedData = Z.compress . Lb.pack 
-                         $ concat [encodeLine line | line <- [0 .. h - 1]]
-          strictEncoded = B.concat $ Lb.toChunks imgEncodedData
+          zero = B.singleton 0
 
+          lineSize = compCount * w
+          encodeLine line = blitVector arr (line * lineSize) lineSize
+          imgEncodedData = Z.compress . Lb.fromChunks
+                        $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]]
+
 instance PngSavable PixelRGBA8 where
     encodePng = genericEncodePng PngTrueColourWithAlpha 4
         
@@ -82,6 +114,18 @@ instance PngSavable PixelYA8 where
     encodePng = genericEncodePng PngGreyscaleWithAlpha 2
 
+instance PngSavable PixelYA16 where
+    encodePng = genericEncode16BitsPng PngGreyscaleWithAlpha 2
+
+instance PngSavable Pixel16 where
+    encodePng = genericEncode16BitsPng PngGreyscale 1
+
+instance PngSavable PixelRGB16 where
+    encodePng = genericEncode16BitsPng PngTrueColour 3
+
+instance PngSavable PixelRGBA16 where
+    encodePng = genericEncode16BitsPng PngTrueColourWithAlpha 4
+
 -- | Write a dynamic image in a .png image file if possible.
 -- The same restriction as encodeDynamicPng apply.
 writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool)
@@ -93,15 +137,27 @@ --
 --   - Y8
 --
+--   - Y16
+--
 --   - YA8
 --
+--   - YA16
+--
 --   - RGB8
 --
+--   - RGB16
+--
 --   - RGBA8
 --
+--   - RGBA16
+--
 encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString
 encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img
 encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img
 encodeDynamicPng (ImageY8 img) = Right $ encodePng img
+encodeDynamicPng (ImageY16 img) = Right $ encodePng img
 encodeDynamicPng (ImageYA8 img) = Right $ encodePng img
+encodeDynamicPng (ImageYA16 img) = Right $ encodePng img
+encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img
+encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img
 encodeDynamicPng _ = Left "Unsupported image format for PNG export"

@@ -19,22 +19,21 @@ 
 import Control.Applicative( (<$>) )
 import Control.Monad( when, replicateM )
-import Data.Bits( xor, (.&.), shiftR )
+import Data.Bits( xor, (.&.), unsafeShiftR )
 import Data.Binary( Binary(..), Get, get )
 import Data.Binary.Get( getWord8
                       , getWord32be
-                      , getByteString
+                      , getLazyByteString
                       )
 import Data.Binary.Put( runPut
                       , putWord8
                       , putWord32be
-                      , putByteString 
+                      , putLazyByteString
                       )
 import Data.Vector.Unboxed( Vector, fromListN, (!) )
 import qualified Data.Vector.Storable as V
 import Data.List( foldl' )
 import Data.Word( Word32, Word8 )
-import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
 import Codec.Picture.Types
@@ -45,7 +44,7 @@ --------------------------------------------------
 
 -- | Value used to identify a png chunk, must be 4 bytes long.
-type ChunkSignature = B.ByteString
+type ChunkSignature = L.ByteString
 
 -- | Generic header used in PNG images.
 data PngIHdr = PngIHdr
@@ -85,19 +84,19 @@  | otherwise = Image pixelCount 1 . V.fromListN (3 * pixelCount) <$> pixels
     where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get
           pixelCount = fromIntegral $ chunkLength plte `div` 3
-          pixels = runGetStrict pixelUnpacker (chunkData plte)
+          pixels = runGet pixelUnpacker (chunkData plte)
 
 -- | Data structure during real png loading/parsing
 data PngRawChunk = PngRawChunk
     { chunkLength :: Word32
     , chunkType   :: ChunkSignature
     , chunkCRC    :: Word32
-    , chunkData   :: B.ByteString
+    , chunkData   :: L.ByteString
     }
 
 -- | PNG chunk representing some extra information found in the parsed file.
 data PngChunk = PngChunk
-    { pngChunkData        :: B.ByteString  -- ^ The raw data inside the chunk
+    { pngChunkData        :: L.ByteString  -- ^ The raw data inside the chunk
     , pngChunkSignature   :: ChunkSignature -- ^ The name of the chunk.
     }
 
@@ -154,7 +153,7 @@ 
 instance Binary PngRawImage where
     put img = do
-        putByteString pngSignature
+        putLazyByteString pngSignature
         put $ header img
         mapM_ put $ chunks img
 
@@ -163,17 +162,17 @@ instance Binary PngRawChunk where
     put chunk = do
         putWord32be $ chunkLength chunk
-        putByteString $ chunkType chunk
+        putLazyByteString $ chunkType chunk
         when (chunkLength chunk /= 0)
-             (putByteString $ chunkData chunk)
+             (putLazyByteString $ chunkData chunk)
         putWord32be $ chunkCRC chunk
 
     get = do
         size <- getWord32be
-        chunkSig <- getByteString (B.length iHDRSignature)
+        chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature)
         imgData <- if size == 0
-            then return B.empty
-            else getByteString (fromIntegral size)
+            then return L.empty
+            else getLazyByteString (fromIntegral size)
         crc <- getWord32be
 
         let computedCrc = pngComputeCrc [chunkSig, imgData]
@@ -191,7 +190,7 @@     put hdr = do
         putWord32be 13
         let inner = runPut $ do
-                putByteString iHDRSignature
+                putLazyByteString iHDRSignature
                 putWord32be $ width hdr
                 putWord32be $ height hdr
                 putWord8    $ bitDepth hdr
@@ -199,14 +198,13 @@                 put $ compressionMethod hdr
                 put $ filterMethod hdr
                 put $ interlaceMethod hdr
-            strictList = L.toChunks inner
-            crc = pngComputeCrc strictList
-        mapM_ putByteString strictList
+            crc = pngComputeCrc [inner]
+        putLazyByteString inner
         putWord32be crc
 
     get = do
         _size <- getWord32be
-        ihdrSig <- getByteString (B.length iHDRSignature)
+        ihdrSig <- getLazyByteString (L.length iHDRSignature)
         when (ihdrSig /= iHDRSignature)
              (fail "Invalid PNG file, wrong ihdr")
         w <- getWord32be
@@ -250,7 +248,7 @@ -- unpack raw data, without decompressing it.
 parseRawPngImage :: Get PngRawImage
 parseRawPngImage = do
-    sig <- getByteString (B.length pngSignature)
+    sig <- getLazyByteString (L.length pngSignature)
     when (sig /= pngSignature)
          (fail "Invalid PNG file, signature broken")
 
@@ -270,7 +268,7 @@ 
 -- | Helper function to help pack signatures.
 signature :: [Word8] -> ChunkSignature
-signature = B.pack . map (toEnum . fromEnum)
+signature = L.pack . map (toEnum . fromEnum)
 
 -- | Signature for the header chunk of png (must be the first)
 iHDRSignature :: ChunkSignature 
@@ -311,16 +309,16 @@ pngCrcTable :: Vector Word32
 pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ]
     where zero = 0 :: Int -- To avoid defaulting to Integer
-          updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `shiftR` 1)
-                                | otherwise = c `shiftR` 1
+          updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1)
+                                | otherwise = c `unsafeShiftR` 1
           magicConstant = 0xedb88320 :: Word32
 
 -- | Compute the CRC of a raw buffer, as described in annex D of the PNG
 -- specification.
-pngComputeCrc :: [B.ByteString] -> Word32
-pngComputeCrc = (0xFFFFFFFF `xor`) . B.foldl' updateCrc 0xFFFFFFFF . B.concat
+pngComputeCrc :: [L.ByteString] -> Word32
+pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat
     where updateCrc crc val =
               let u32Val = fromIntegral val
                   lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF))
-              in lutVal `xor` (crc `shiftR` 8)
+              in lutVal `xor` (crc `unsafeShiftR` 8)
 

@@ -1,88 +1,145 @@--- | Helper functions to save dynamic images to other file format--- with automatic color space/sample format conversion done automatically.-module Codec.Picture.Saving( imageToJpg-                           , imageToPng-                           , imageToBitmap-                           , imageToRadiance-                           ) where--import Data.Word( Word8 )-import qualified Data.ByteString.Lazy as L-import Codec.Picture.Bitmap-import Codec.Picture.Jpg-import Codec.Picture.Png-import Codec.Picture.HDR-import Codec.Picture.Types--componentToLDR :: Float -> Word8-componentToLDR = truncate . (255 *) . min 1.0 . max 0.0--toStandardDef :: Image PixelRGBF -> Image PixelRGB8-toStandardDef img = pixelMap pixelConverter img-  where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b-          where r = componentToLDR rf-                g = componentToLDR gf-                b = componentToLDR bf--greyScaleToStandardDef :: Image PixelF -> Image Pixel8-greyScaleToStandardDef = pixelMap componentToLDR---- | This function will try to do anything to encode an image--- as RADIANCE, make all color conversion and such. Equivalent--- of 'decodeImage' for radiance encoding-imageToRadiance :: DynamicImage -> L.ByteString-imageToRadiance (ImageYCbCr8 img) =-    imageToRadiance . ImageRGB8 $ convertImage img-imageToRadiance (ImageRGB8   img) =-    imageToRadiance . ImageRGBF $ promoteImage img-imageToRadiance (ImageRGBF   img) = encodeHDR img-imageToRadiance (ImageRGBA8  img) =-    imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img-imageToRadiance (ImageY8     img) =-    imageToRadiance . ImageRGB8 $ promoteImage img-imageToRadiance (ImageYF     img) =-    imageToRadiance . ImageRGBF $ promoteImage img-imageToRadiance (ImageYA8    img) =-    imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img---- | This function will try to do anything to encode an image--- as JPEG, make all color conversion and such. Equivalent--- of 'decodeImage' for jpeg encoding-imageToJpg :: Int -> DynamicImage -> L.ByteString-imageToJpg quality dynImage =-    let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality)-    in case dynImage of-        ImageYCbCr8 img -> encodeAtQuality img-        ImageRGB8   img -> encodeAtQuality (convertImage img)-        ImageRGBF   img -> imageToJpg quality . ImageRGB8 $ toStandardDef img-        ImageRGBA8  img -> encodeAtQuality (convertImage $ dropAlphaLayer img)-        ImageYF     img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img-        ImageY8     img -> encodeAtQuality . convertImage-                                           $ (promoteImage img :: Image PixelRGB8)-        ImageYA8    img -> encodeAtQuality $-                            convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8)---- | This function will try to do anything to encode an image--- as PNG, make all color conversion and such. Equivalent--- of 'decodeImage' for PNG encoding-imageToPng :: DynamicImage -> L.ByteString-imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8)-imageToPng (ImageRGB8   img) = encodePng img-imageToPng (ImageRGBF   img) = encodePng $ toStandardDef img-imageToPng (ImageRGBA8  img) = encodePng img-imageToPng (ImageY8     img) = encodePng img-imageToPng (ImageYF     img) = encodePng $ greyScaleToStandardDef img-imageToPng (ImageYA8    img) = encodePng (promoteImage img :: Image PixelRGBA8)---- | This function will try to do anything to encode an image--- as bitmap, make all color conversion and such. Equivalent--- of 'decodeImage' for Bitmap encoding-imageToBitmap :: DynamicImage -> L.ByteString-imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8)-imageToBitmap (ImageRGBF   img) = encodeBitmap $ toStandardDef img-imageToBitmap (ImageRGB8   img) = encodeBitmap img-imageToBitmap (ImageRGBA8  img) = encodeBitmap img-imageToBitmap (ImageY8     img) = encodeBitmap img-imageToBitmap (ImageYF     img) = encodeBitmap $ greyScaleToStandardDef img-imageToBitmap (ImageYA8    img) = encodeBitmap (promoteImage img :: Image PixelRGBA8)-+{-# LANGUAGE TypeFamilies #-}
+-- | Helper functions to save dynamic images to other file format
+-- with automatic color space/sample format conversion done automatically.
+module Codec.Picture.Saving( imageToJpg
+                           , imageToPng
+                           , imageToBitmap
+                           , imageToRadiance
+                           ) where
+
+import Data.Bits( unsafeShiftR )
+import Data.Word( Word8, Word16 )
+import qualified Data.ByteString.Lazy as L
+import Codec.Picture.Bitmap
+import Codec.Picture.Jpg
+import Codec.Picture.Png
+import Codec.Picture.HDR
+import Codec.Picture.Types
+
+import qualified Data.Vector.Storable as V
+
+componentToLDR :: Float -> Word8
+componentToLDR = truncate . (255 *) . min 1.0 . max 0.0
+
+toStandardDef :: Image PixelRGBF -> Image PixelRGB8
+toStandardDef img = pixelMap pixelConverter img
+  where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b
+          where r = componentToLDR rf
+                g = componentToLDR gf
+                b = componentToLDR bf
+
+greyScaleToStandardDef :: Image PixelF -> Image Pixel8
+greyScaleToStandardDef = pixelMap componentToLDR
+
+from16to8 :: ( PixelBaseComponent source ~ Word16
+             , PixelBaseComponent dest ~ Word8 )
+          => Image source -> Image dest
+from16to8 Image { imageWidth = w, imageHeight = h
+                , imageData = arr } = Image w h transformed
+   where transformed = V.map toWord8 arr
+         toWord8 v = fromIntegral (v `unsafeShiftR` 8)
+
+from16toFloat :: ( PixelBaseComponent source ~ Word16
+                 , PixelBaseComponent dest ~ Float )
+          => Image source -> Image dest
+from16toFloat Image { imageWidth = w, imageHeight = h
+                    , imageData = arr } = Image w h transformed
+   where transformed = V.map toWord8 arr
+         toWord8 v = fromIntegral v / 65536.0
+
+-- | This function will try to do anything to encode an image
+-- as RADIANCE, make all color conversion and such. Equivalent
+-- of 'decodeImage' for radiance encoding
+imageToRadiance :: DynamicImage -> L.ByteString
+imageToRadiance (ImageCMYK8 img) =
+    imageToRadiance . ImageRGB8 $ convertImage img
+imageToRadiance (ImageCMYK16 img) =
+    imageToRadiance . ImageRGB16 $ convertImage img
+imageToRadiance (ImageYCbCr8 img) =
+    imageToRadiance . ImageRGB8 $ convertImage img
+imageToRadiance (ImageRGB8   img) =
+    imageToRadiance . ImageRGBF $ promoteImage img
+imageToRadiance (ImageRGBF   img) = encodeHDR img
+imageToRadiance (ImageRGBA8  img) =
+    imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img
+imageToRadiance (ImageY8     img) =
+    imageToRadiance . ImageRGB8 $ promoteImage img
+imageToRadiance (ImageYF     img) =
+    imageToRadiance . ImageRGBF $ promoteImage img
+imageToRadiance (ImageYA8    img) =
+    imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img
+imageToRadiance (ImageY16    img) =
+  imageToRadiance . ImageRGBF $ pixelMap toRgbf img
+    where toRgbf v = PixelRGBF val val val
+            where val = fromIntegral v / 65536.0
+
+imageToRadiance (ImageYA16   img) =
+  imageToRadiance . ImageRGBF $ pixelMap toRgbf img
+    where toRgbf (PixelYA16 v _) = PixelRGBF val val val
+            where val = fromIntegral v / 65536.0
+imageToRadiance (ImageRGB16  img) =
+    imageToRadiance . ImageRGBF $ from16toFloat img
+imageToRadiance (ImageRGBA16 img) =
+    imageToRadiance . ImageRGBF $ pixelMap toRgbf img
+    where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b)
+            where f v = fromIntegral v / 65536.0
+
+-- | This function will try to do anything to encode an image
+-- as JPEG, make all color conversion and such. Equivalent
+-- of 'decodeImage' for jpeg encoding
+imageToJpg :: Int -> DynamicImage -> L.ByteString
+imageToJpg quality dynImage =
+    let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality)
+    in case dynImage of
+        ImageYCbCr8 img -> encodeAtQuality img
+        ImageCMYK8  img -> imageToJpg quality . ImageRGB8 $ convertImage img
+        ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img
+        ImageRGB8   img -> encodeAtQuality (convertImage img)
+        ImageRGBF   img -> imageToJpg quality . ImageRGB8 $ toStandardDef img
+        ImageRGBA8  img -> encodeAtQuality (convertImage $ dropAlphaLayer img)
+        ImageYF     img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img
+        ImageY8     img -> encodeAtQuality . convertImage
+                                           $ (promoteImage img :: Image PixelRGB8)
+        ImageYA8    img -> encodeAtQuality $
+                            convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8)
+        ImageY16    img -> imageToJpg quality . ImageY8 $ from16to8 img
+        ImageYA16   img -> imageToJpg quality . ImageYA8 $ from16to8 img
+        ImageRGB16  img -> imageToJpg quality . ImageRGB8 $ from16to8 img
+        ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img
+
+-- | This function will try to do anything to encode an image
+-- as PNG, make all color conversion and such. Equivalent
+-- of 'decodeImage' for PNG encoding
+imageToPng :: DynamicImage -> L.ByteString
+imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8)
+imageToPng (ImageCMYK8 img)  = encodePng (convertImage img :: Image PixelRGB8)
+imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16)
+imageToPng (ImageRGB8   img) = encodePng img
+imageToPng (ImageRGBF   img) = encodePng $ toStandardDef img
+imageToPng (ImageRGBA8  img) = encodePng img
+imageToPng (ImageY8     img) = encodePng img
+imageToPng (ImageYF     img) = encodePng $ greyScaleToStandardDef img
+imageToPng (ImageYA8    img) = encodePng img
+imageToPng (ImageY16    img) = encodePng img
+imageToPng (ImageYA16   img) = encodePng img
+imageToPng (ImageRGB16  img) = encodePng img
+imageToPng (ImageRGBA16 img) = encodePng img
+
+-- | This function will try to do anything to encode an image
+-- as bitmap, make all color conversion and such. Equivalent
+-- of 'decodeImage' for Bitmap encoding
+imageToBitmap :: DynamicImage -> L.ByteString
+imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8)
+imageToBitmap (ImageCMYK8  img) = encodeBitmap (convertImage img :: Image PixelRGB8)
+imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img
+imageToBitmap (ImageRGBF   img) = encodeBitmap $ toStandardDef img
+imageToBitmap (ImageRGB8   img) = encodeBitmap img
+imageToBitmap (ImageRGBA8  img) = encodeBitmap img
+imageToBitmap (ImageY8     img) = encodeBitmap img
+imageToBitmap (ImageYF     img) = encodeBitmap $ greyScaleToStandardDef img
+imageToBitmap (ImageYA8    img) = encodeBitmap (promoteImage img :: Image PixelRGBA8)
+imageToBitmap (ImageY16    img) = imageToBitmap . ImageY8 $ from16to8 img
+imageToBitmap (ImageYA16   img) = imageToBitmap . ImageYA8 $ from16to8 img
+imageToBitmap (ImageRGB16  img) = imageToBitmap . ImageRGB8 $ from16to8 img
+imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img
+

@@ -0,0 +1,943 @@+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+-- | Module implementing TIFF decoding.
+--
+-- Supported compression schemes :
+--
+--   * Uncompressed
+--
+--   * PackBits
+--
+--   * LZW
+--
+-- Supported bit depth :
+--
+--   * 2 bits
+--
+--   * 4 bits
+--
+--   * 8 bits
+--
+--   * 16 bits
+--
+module Codec.Picture.Tiff( decodeTiff ) where
+
+import Control.Applicative( (<$>), (<*>), pure )
+import Control.Monad( when, replicateM, foldM_ )
+import Control.Monad.ST( ST, runST )
+import Data.Int( Int8 )
+import Data.Word( Word8, Word16 )
+import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( Get
+                      , getWord16le, getWord16be
+                      , getWord32le, getWord32be
+                      , bytesRead
+                      , skip
+                      , getByteString
+                      )
+import Data.Binary.Put( Put
+                      , putWord16le, putWord16be
+                      , putWord32le, putWord32be )
+
+import qualified Data.Vector as V
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector.Storable.Mutable as M
+import Data.Word( Word32 )
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as BU
+
+{-import Debug.Trace-}
+{-import Text.Groom-}
+
+import Codec.Picture.InternalHelper
+import Codec.Picture.BitWriter
+import Codec.Picture.Types
+import Codec.Picture.Gif.LZW
+
+data Endianness = EndianLittle
+                | EndianBig
+                deriving (Eq, Show)
+
+instance Binary Endianness where
+    put EndianLittle = putWord16le 0x4949
+    put EndianBig = putWord16le 0x4D4D
+
+    get = do
+        tag <- getWord16le
+        case tag of
+            0x4949 -> return EndianLittle
+            0x4D4D -> return EndianBig
+            _ -> fail "Invalid endian tag value"
+
+data TiffHeader = TiffHeader
+    { hdrEndianness :: !Endianness
+    , hdrOffset     :: {-# UNPACK #-} !Word32
+    }
+    deriving (Eq, Show)
+
+putWord16Endian :: Endianness -> Word16 -> Put
+putWord16Endian EndianLittle = putWord16le
+putWord16Endian EndianBig = putWord16be
+
+getWord16Endian :: Endianness -> Get Word16
+getWord16Endian EndianLittle = getWord16le
+getWord16Endian EndianBig = getWord16be
+
+putWord32Endian :: Endianness -> Word32 -> Put
+putWord32Endian EndianLittle = putWord32le
+putWord32Endian EndianBig = putWord32be
+
+getWord32Endian :: Endianness -> Get Word32
+getWord32Endian EndianLittle = getWord32le
+getWord32Endian EndianBig = getWord32be
+
+instance Binary TiffHeader where
+    put hdr = do
+        let endian = hdrEndianness hdr
+        put endian
+        putWord16Endian endian 42
+        putWord32Endian endian $ hdrOffset hdr
+
+    get = do
+        endian <- get
+        magic <- getWord16Endian endian
+        when (magic /= 42)
+             (fail "Invalid TIFF magic number")
+        TiffHeader endian <$> getWord32Endian endian
+
+data TiffPlanarConfiguration =
+      PlanarConfigContig    -- = 1
+    | PlanarConfigSeparate  -- = 2
+    deriving (Eq, Show)
+
+planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration
+planarConfgOfConstant 0 = pure PlanarConfigContig
+planarConfgOfConstant 1 = pure PlanarConfigContig
+planarConfgOfConstant 2 = pure PlanarConfigSeparate
+planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")"
+
+data TiffCompression =
+      CompressionNone           -- 1
+    | CompressionModifiedRLE    -- 2
+    | CompressionLZW            -- 5
+    | CompressionJPEG           -- 6
+    | CompressionPackBit        -- 32273
+    deriving (Eq, Show)
+
+data IfdType = TypeByte
+             | TypeAscii
+             | TypeShort
+             | TypeLong
+             | TypeRational
+             | TypeSByte
+             | TypeUndefined
+             | TypeSignedShort
+             | TypeSignedLong
+             | TypeSignedRational
+             | TypeFloat
+             | TypeDouble
+             deriving (Eq, Show)
+
+{-
+wordOfType :: IfdType -> Word16
+wordOfType TypeByte           = 1
+wordOfType TypeAscii          = 2
+wordOfType TypeShort          = 3
+wordOfType TypeLong           = 4
+wordOfType TypeRational       = 5
+wordOfType TypeSByte          = 6
+wordOfType TypeUndefined      = 7
+wordOfType TypeSignedShort    = 8
+wordOfType TypeSignedLong     = 9
+wordOfType TypeSignedRational = 10
+wordOfType TypeFloat          = 11
+wordOfType TypeDouble         = 12
+ -- -}
+
+typeOfWord :: Word16 -> Get IfdType
+typeOfWord 1  = return TypeByte
+typeOfWord 2  = return TypeAscii
+typeOfWord 3  = return TypeShort
+typeOfWord 4  = return TypeLong
+typeOfWord 5  = return TypeRational
+typeOfWord 6  = return TypeSByte
+typeOfWord 7  = return TypeUndefined
+typeOfWord 8  = return TypeSignedShort
+typeOfWord 9  = return TypeSignedLong
+typeOfWord 10 = return TypeSignedRational
+typeOfWord 11 = return TypeFloat
+typeOfWord 12 = return TypeDouble
+typeOfWord _  = fail "Invalid TIF directory type"
+
+data TiffTag = TagPhotometricInterpretation
+             | TagCompression
+             | TagImageWidth
+             | TagImageLength
+             | TagXResolution
+             | TagYResolution
+             | TagResolutionUnit
+             | TagRowPerStrip
+             | TagStripByteCounts
+             | TagStripOffsets
+             | TagBitsPerSample
+             | TagColorMap
+             | TagTileWidth
+             | TagTileLength
+             | TagTileOffset
+             | TagTileByteCount
+             | TagSamplesPerPixel
+             | TagArtist
+             | TagDocumentName
+             | TagSoftware
+             | TagPlanarConfiguration
+             | TagOrientation
+             | TagSampleFormat
+             | TagInkSet
+             | TagSubfileType
+             | TagFillOrder
+             | TagYCbCrCoeff
+             | TagYCbCrSubsampling
+             | TagYCbCrPositioning
+             | TagReferenceBlackWhite
+             | TagXPosition
+             | TagYPosition
+             | TagExtraSample
+             | TagImageDescription
+
+             | TagJpegProc
+             | TagJPEGInterchangeFormat
+             | TagJPEGInterchangeFormatLength
+             | TagJPEGRestartInterval
+             | TagJPEGLosslessPredictors
+             | TagJPEGPointTransforms
+             | TagJPEGQTables
+             | TagJPEGDCTables
+             | TagJPEGACTables
+
+             | TagUnknown Word16
+             deriving (Eq, Show)
+
+tagOfWord16 :: Word16 -> TiffTag
+tagOfWord16 = aux
+  where aux 255 = TagSubfileType
+        aux 256 = TagImageWidth
+        aux 257 = TagImageLength
+        aux 258 = TagBitsPerSample
+        aux 259 = TagCompression
+        aux 262 = TagPhotometricInterpretation
+        aux 266 = TagFillOrder
+        aux 269 = TagDocumentName
+        aux 270 = TagImageDescription
+        aux 273 = TagStripOffsets
+        aux 274 = TagOrientation
+        aux 277 = TagSamplesPerPixel
+        aux 278 = TagRowPerStrip
+        aux 279 = TagStripByteCounts
+        aux 282 = TagXResolution
+        aux 283 = TagYResolution
+        aux 284 = TagPlanarConfiguration
+        aux 286 = TagXPosition
+        aux 287 = TagYPosition
+        aux 296 = TagResolutionUnit
+        aux 305 = TagSoftware
+        aux 315 = TagArtist
+        aux 320 = TagColorMap
+        aux 322 = TagTileWidth
+        aux 323 = TagTileLength
+        aux 324 = TagTileOffset
+        aux 325 = TagTileByteCount
+        aux 332 = TagInkSet
+        aux 338 = TagExtraSample
+        aux 339 = TagSampleFormat
+        aux 529 = TagYCbCrCoeff
+        aux 512 = TagJpegProc
+        aux 513 = TagJPEGInterchangeFormat
+        aux 514 = TagJPEGInterchangeFormatLength
+        aux 515 = TagJPEGRestartInterval
+        aux 517 = TagJPEGLosslessPredictors
+        aux 518 = TagJPEGPointTransforms
+        aux 519 = TagJPEGQTables
+        aux 520 = TagJPEGDCTables
+        aux 521 = TagJPEGACTables
+        aux 530 = TagYCbCrSubsampling
+        aux 531 = TagYCbCrPositioning
+        aux 532 = TagReferenceBlackWhite
+        aux v = TagUnknown v
+
+data ExtendedDirectoryData =
+      ExtendedDataNone
+    | ExtendedDataAscii !B.ByteString
+    | ExtendedDataShort !(V.Vector Word16)
+    | ExtendedDataLong  !(V.Vector Word32)
+    deriving (Eq, Show)
+
+data TiffSampleFormat =
+      TiffSampleUint
+    | TiffSampleInt
+    | TiffSampleDouble
+    | TiffSampleUnknown
+    deriving (Eq, Show)
+
+unpackSampleFormat :: Word32 -> Get TiffSampleFormat
+unpackSampleFormat = aux
+  where aux 1 = pure TiffSampleUint
+        aux 2 = pure TiffSampleInt
+        aux 3 = pure TiffSampleDouble
+        aux 4 = pure TiffSampleUnknown
+        aux v = fail $ "Undefined data format (" ++ show v ++ ")"
+
+data ImageFileDirectory = ImageFileDirectory
+    { ifdIdentifier :: !TiffTag
+    , ifdType       :: !IfdType
+    , ifdCount      :: !Word32
+    , ifdOffset     :: !Word32
+    , ifdExtended   :: !ExtendedDirectoryData
+    }
+    deriving (Eq, Show)
+
+unLong :: String -> ExtendedDirectoryData -> Get (V.Vector Word32)
+unLong _ (ExtendedDataShort v) = pure $ V.map fromIntegral v
+unLong _ (ExtendedDataLong v) = pure v
+unLong errMessage _ = fail errMessage
+
+cleanImageFileDirectory :: ImageFileDirectory -> ImageFileDirectory
+cleanImageFileDirectory ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd
+    where aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 }
+          aux _ = ifd
+cleanImageFileDirectory ifd = ifd
+
+getImageFileDirectory :: Endianness -> Get ImageFileDirectory
+getImageFileDirectory endianness =
+  ImageFileDirectory <$> (tagOfWord16 <$> getWord16)
+                     <*> (getWord16 >>= typeOfWord)
+                     <*> getWord32
+                     <*> getWord32
+                     <*> pure ExtendedDataNone
+    where getWord16 = getWord16Endian endianness
+          getWord32 = getWord32Endian endianness
+
+getImageFileDirectories :: Endianness -> Get [ImageFileDirectory]
+getImageFileDirectories endianness = do
+    count <- getWord16Endian endianness
+    replicateM (fromIntegral count) $ getImageFileDirectory endianness
+
+fetchExtended :: Endianness -> [ImageFileDirectory] -> Get [ImageFileDirectory]
+fetchExtended endian = mapM fetcher
+  where align ImageFileDirectory { ifdOffset = offset } = do
+            readed <- bytesRead
+            skip . fromIntegral $ fromIntegral offset - readed
+
+        getWord16 = getWord16Endian endian
+        getWord32 = getWord32Endian endian
+
+        update ifd v = ifd { ifdExtended = v }
+        getVec count = V.replicateM (fromIntegral count)
+
+        fetcher ifd@ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 =
+            align ifd >> (update ifd . ExtendedDataAscii <$> getByteString (fromIntegral count))
+        fetcher ifd@ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } =
+            pure . update ifd . ExtendedDataShort $ V.fromListN 2 [high, low]
+              where high = fromIntegral $ ofs `unsafeShiftL` 16
+                    low = fromIntegral $ ofs .&. 0xFFFF
+
+        fetcher ifd@ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 =
+            align ifd >> (update ifd . ExtendedDataShort <$> getVec count getWord16)
+        fetcher ifd@ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 =
+            align ifd >> (update ifd . ExtendedDataLong <$> getVec count getWord32)
+
+        fetcher ifd = pure ifd
+
+findIFD :: String -> TiffTag -> [ImageFileDirectory]
+        -> Get ImageFileDirectory
+findIFD errorMessage tag lst =
+    case [v | v <- lst, ifdIdentifier v == tag] of
+        [] -> fail errorMessage
+        (x:_) -> pure x
+
+findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16))
+findPalette ifds =
+    case [v | v <- ifds, ifdIdentifier v == TagColorMap] of
+        (ImageFileDirectory { ifdExtended = ExtendedDataShort vec }:_) ->
+            pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx
+                where pixelCount = V.length vec `div` 3
+                      axx v = vec `V.unsafeIndex` (idx + color * pixelCount)
+                          where (idx, color) = v `divMod` 3
+
+        _ -> pure Nothing
+
+findIFDData :: String -> TiffTag -> [ImageFileDirectory] -> Get Word32
+findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst
+
+findIFDDefaultData :: Word32 -> TiffTag -> [ImageFileDirectory] -> Get Word32
+findIFDDefaultData d tag lst =
+    case [v | v <- lst, ifdIdentifier v == tag] of
+        [] -> pure d
+        (x:_) -> pure $ ifdOffset x
+
+findIFDExt :: String -> TiffTag -> [ImageFileDirectory] -> Get ExtendedDirectoryData
+findIFDExt msg tag lst = do
+    val <- findIFD msg tag lst
+    case val of
+      ImageFileDirectory
+        { ifdCount = 1, ifdOffset = ofs } ->
+               pure . ExtendedDataShort . V.singleton $ fromIntegral ofs
+      ImageFileDirectory { ifdExtended = v } -> pure v
+
+
+findIFDExtDefaultData :: [Word32] -> TiffTag -> [ImageFileDirectory] -> Get [Word32]
+findIFDExtDefaultData d tag lst =
+    case [v | v <- lst, ifdIdentifier v == tag] of
+        [] -> pure d
+        (x:_) -> V.toList <$> unLong "Can't unlong" (ifdExtended x)
+
+-- It's temporary, remove once tiff decoding is better
+-- handled.
+{-  instance Show (Image PixelRGB16) where
+    show _ = "Image PixelRGB16"
+-}
+
+data TiffInfo = TiffInfo
+    { tiffHeader             :: TiffHeader
+    , tiffWidth              :: Word32
+    , tiffHeight             :: Word32
+    , tiffColorspace         :: TiffColorspace
+    , tiffSampleCount        :: Word32
+    , tiffRowPerStrip        :: Word32
+    , tiffPlaneConfiguration :: TiffPlanarConfiguration
+    , tiffSampleFormat       :: [TiffSampleFormat]
+    , tiffBitsPerSample      :: V.Vector Word32
+    , tiffCompression        :: TiffCompression
+    , tiffStripSize          :: V.Vector Word32
+    , tiffOffsets            :: V.Vector Word32
+    , tiffPalette            :: Maybe (Image PixelRGB16)
+    , tiffYCbCrSubsampling   :: V.Vector Word32
+    }
+
+data TiffColorspace =
+      TiffMonochromeWhite0 -- ^ 0
+    | TiffMonochrome       -- ^ 1
+    | TiffRGB              -- ^ 2
+    | TiffPaleted          -- ^ 3
+    | TiffTransparencyMask -- ^ 4
+    | TiffCMYK             -- ^ 5
+    | TiffYCbCr            -- ^ 6
+    | TiffCIELab           -- ^ 8
+    deriving (Eq, Show)
+
+unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace
+unpackPhotometricInterpretation = aux
+  where aux 0 = pure TiffMonochromeWhite0
+        aux 1 = pure TiffMonochrome
+        aux 2 = pure TiffRGB
+        aux 3 = pure TiffPaleted
+        aux 4 = pure TiffTransparencyMask
+        aux 5 = pure TiffCMYK
+        aux 6 = pure TiffYCbCr
+        aux 8 = pure TiffCIELab
+        aux _ = fail "Unrecognized color space"
+
+unPackCompression :: Word32 -> Get TiffCompression
+unPackCompression 0 = pure CompressionNone
+unPackCompression 1 = pure CompressionNone
+unPackCompression 2 = pure CompressionModifiedRLE
+unPackCompression 5 = pure CompressionLZW
+unPackCompression 6 = pure CompressionJPEG
+unPackCompression 32773 = pure CompressionPackBit
+unPackCompression v = fail $ "Unknown compression scheme " ++ show v
+
+copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)
+               -> ST s Int
+copyByteString str vec stride startWrite (from, count) = inner startWrite fromi
+  where fromi = fromIntegral from
+        maxi = fromi + fromIntegral count
+
+        inner writeIdx i | i >= maxi = pure writeIdx
+        inner writeIdx i = do
+            let v = str `BU.unsafeIndex` i
+            (vec `M.unsafeWrite` writeIdx) v
+            inner (writeIdx + stride) $ i + 1
+
+unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int
+              -> (Word32, Word32)
+              -> ST s Int
+unpackPackBit str outVec stride writeIndex (offset, size) = loop fromi writeIndex
+  where fromi = fromIntegral offset
+        maxi = fromi + fromIntegral size
+
+        replicateByte writeIdx _     0 = pure writeIdx
+        replicateByte writeIdx v count = do
+            (outVec `M.unsafeWrite` writeIdx) v
+            replicateByte (writeIdx + stride) v $ count - 1
+
+        loop i writeIdx | i >= maxi = pure writeIdx
+        loop i writeIdx = choice
+          {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-}
+          where v = fromIntegral (str `B.index` i) :: Int8
+
+                choice
+                    -- data
+                    | 0    <= v = do
+                        copyByteString str outVec stride writeIdx
+                                        (fromIntegral $ i + 1, fromIntegral v + 1)
+                            >>= loop (i + 2 + fromIntegral v)
+                    -- run
+                    | -127 <= v = do
+                        {-let nextByte = str `BU.unsafeIndex` (i + 1)-}
+                        let nextByte = str `B.index` (i + 1)
+                            count = negate (fromIntegral v) + 1 :: Int
+                        replicateByte writeIdx nextByte count
+                            >>= loop (i + 2)
+
+                    -- noop
+                    | otherwise = loop writeIdx $ i + 1
+
+uncompressAt :: TiffCompression
+             -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)
+             -> ST s Int
+uncompressAt CompressionNone = copyByteString
+uncompressAt CompressionPackBit = unpackPackBit
+uncompressAt CompressionLZW =  \str outVec _stride writeIndex (offset, size) -> do
+    let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str
+    runBoolReader $ decodeLzwTiff toDecode outVec writeIndex
+    return 0
+uncompressAt _ = error "Unhandled compression"
+
+class Unpackable a where
+    type StorageType a :: *
+
+    outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a))
+
+    -- | Final image and size, return offset and vector
+    allocTempBuffer :: a  -> M.STVector s (StorageType a) -> Int
+                    -> ST s (M.STVector s Word8)
+
+    offsetStride :: a -> Int -> Int -> (Int, Int)
+
+    mergeBackTempBuffer :: a    -- ^ Type witness, just for the type checker.
+                        -> Endianness
+                        -> M.STVector s Word8 -- ^ Temporary buffer handling decompression.
+                        -> Int -- ^ Line size in pixels
+                        -> Int  -- ^ Write index, in bytes
+                        -> Word32  -- ^ size, in bytes
+                        -> Int  -- ^ Stride
+                        -> M.STVector s (StorageType a) -- ^ Final buffer
+                        -> ST s ()
+
+-- | The Word8 instance is just a passthrough, to avoid
+-- copying memory twice
+instance Unpackable Word8 where
+  type StorageType Word8 = Word8
+
+  offsetStride _ i stride = (i, stride)
+  allocTempBuffer _ buff _ = pure buff
+  mergeBackTempBuffer _ _ _ _ _ _ _ _ = pure ()
+  outAlloc _ count = M.replicate count 0 -- M.new
+
+instance Unpackable Word16 where
+  type StorageType Word16 = Word16
+
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  allocTempBuffer _ _ s = M.new $ s * 2
+  mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec =
+        looperLe index 0
+    where looperLe _ readIndex | readIndex >= fromIntegral size = pure ()
+          looperLe writeIndex readIndex = do
+              v1 <- tempVec `M.read` readIndex
+              v2 <- tempVec `M.read` (readIndex + 1)
+              let finalValue =
+                    (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1
+              (outVec `M.write` writeIndex) finalValue
+
+              looperLe (writeIndex + stride) (readIndex + 2)
+  mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec =
+         looperBe index 0
+    where looperBe _ readIndex | readIndex >= fromIntegral size = pure ()
+          looperBe writeIndex readIndex = do
+              v1 <- tempVec `M.read` readIndex
+              v2 <- tempVec `M.read` (readIndex + 1)
+              let finalValue =
+                    (fromIntegral v1 `unsafeShiftL` 8) .|. fromIntegral v2
+              (outVec `M.write` writeIndex) finalValue
+
+              looperBe (writeIndex + stride) (readIndex + 2)
+
+data Pack4 = Pack4
+
+instance Unpackable Pack4 where
+  type StorageType Pack4 = Word8
+  allocTempBuffer _ _ = M.new
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =
+        inner 0 index pxCount
+    where pxCount = lineSize `div` stride
+
+          maxWrite = M.length outVec
+          inner readIdx writeIdx _
+                | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()
+          inner readIdx writeIdx line
+                | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount
+          inner readIdx writeIdx line = do
+            v <- tempVec `M.read` readIdx
+            let high = (v `unsafeShiftR` 4) .&. 0xF
+                low = v .&. 0xF
+            (outVec `M.write` writeIdx) high
+            when (writeIdx + stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride)) low
+
+            inner (readIdx + 1) (writeIdx + 2 * stride) (line - 2)
+
+data Pack2 = Pack2
+
+instance Unpackable Pack2 where
+  type StorageType Pack2 = Word8
+  allocTempBuffer _ _ = M.new
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =
+        inner 0 index pxCount
+    where pxCount = lineSize `div` stride
+
+          maxWrite = M.length outVec
+          inner readIdx writeIdx _
+                | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()
+          inner readIdx writeIdx line
+                | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount
+          inner readIdx writeIdx line = do
+            v <- tempVec `M.read` readIdx
+            let v0 = (v `unsafeShiftR` 6) .&. 0x3
+                v1 = (v `unsafeShiftR` 4) .&. 0x3
+                v2 = (v `unsafeShiftR` 2) .&. 0x3
+                v3 = v .&. 0x3
+
+            (outVec `M.write` writeIdx) v0
+            when (writeIdx + 1 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride)) v1
+
+            when (writeIdx + 2 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride * 2)) v2
+
+            when (writeIdx + 3 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride * 3)) v3
+
+            inner (readIdx + 1) (writeIdx + 4 * stride) (line - 4)
+
+data Pack12 = Pack12
+
+instance Unpackable Pack12 where
+  type StorageType Pack12 = Word16
+  allocTempBuffer _ _ = M.new
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =
+        inner 0 index pxCount
+    where pxCount = lineSize `div` stride
+
+          maxWrite = M.length outVec
+          inner readIdx writeIdx _
+                | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()
+          inner readIdx writeIdx line
+                | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount
+          inner readIdx writeIdx line = do
+            v0 <- tempVec `M.read` readIdx
+            v1 <- if readIdx + 1 < fromIntegral size
+                then tempVec `M.read` (readIdx + 1)
+                else pure 0
+            v2 <- if readIdx + 2 < fromIntegral size
+                then tempVec `M.read` (readIdx + 2)
+                else pure 0
+
+            let high0 = fromIntegral v0 `unsafeShiftL` 4
+                low0 = (fromIntegral v1 `unsafeShiftR` 4) .&. 0xF
+
+                p0 = high0 .|. low0
+
+                high1 = (fromIntegral v1 .&. 0xF) `unsafeShiftL` 8
+                low1 = fromIntegral v2
+                p1 = high1 .|. low1
+
+            (outVec `M.write` writeIdx) p0
+            when (writeIdx + 1 * stride < maxWrite) $
+                 (outVec `M.write` (writeIdx + stride)) p1
+
+            inner (readIdx + 3) (writeIdx + 2 * stride) (line - 2)
+
+data YCbCrSubsampling = YCbCrSubsampling 
+    { ycbcrWidth        :: !Int
+    , ycbcrHeight       :: !Int
+    , ycbcrImageWidth   :: !Int
+    , ycbcrStripHeight  :: !Int
+    }
+
+instance Unpackable YCbCrSubsampling where
+  type StorageType YCbCrSubsampling = Word8
+
+  offsetStride _ _ _ = (0, 1)
+  outAlloc _ = M.new
+  allocTempBuffer _ _ = M.new
+  mergeBackTempBuffer subSampling _ tempVec _ index size _ outVec =
+      foldM_ unpacker 0 [(bx, by) | by <- [0, h .. lineCount - 1]
+                                  , bx <- [0, w .. imgWidth - 1]]
+    where w = ycbcrWidth subSampling
+          h = ycbcrHeight subSampling
+          imgWidth = ycbcrImageWidth subSampling
+          lineCount = ycbcrStripHeight subSampling
+
+          lumaCount = w * h
+          blockSize = lumaCount + 2
+
+          maxOut = M.length outVec
+
+          unpacker readIdx _ | readIdx >= fromIntegral size * 3 = pure readIdx
+          unpacker readIdx (bx, by) = do
+              cb <- tempVec `M.read` (readIdx + lumaCount)
+              cr <- tempVec `M.read` (readIdx + lumaCount + 1)
+
+              let pixelIndices =
+                        [index + ((by + y) * imgWidth + bx + x) * 3 | y <- [0 .. h - 1], x <- [0 .. w - 1]]
+
+                  writer readIndex writeIdx | writeIdx + 3 > maxOut = pure readIndex
+                  writer readIndex writeIdx = do
+                    y <- tempVec `M.read` readIndex
+                    (outVec `M.write` writeIdx) y
+                    (outVec `M.write` (writeIdx + 1)) cb
+                    (outVec `M.write` (writeIdx + 2)) cr
+                    return $ readIndex + 1
+
+              foldM_ writer readIdx pixelIndices
+              
+              return $ readIdx + blockSize
+
+gatherStrips :: ( Unpackable comp
+                , Pixel pixel
+                , StorageType comp ~ PixelBaseComponent pixel
+                )
+             => comp -> B.ByteString -> TiffInfo -> Image pixel
+gatherStrips comp str nfo = runST $ do
+  let width = fromIntegral $ tiffWidth nfo
+      height = fromIntegral $ tiffHeight nfo
+      sampleCount = if tiffSampleCount nfo /= 0
+        then fromIntegral $ tiffSampleCount nfo
+        else V.length $ tiffBitsPerSample nfo
+
+      rowPerStrip = fromIntegral $ tiffRowPerStrip nfo
+      endianness = hdrEndianness $ tiffHeader nfo
+
+      stripCount = V.length $ tiffOffsets nfo
+      compression = tiffCompression nfo
+
+  outVec <- outAlloc comp $ width * height * sampleCount
+  tempVec <- allocTempBuffer comp outVec
+                        (rowPerStrip * width * sampleCount)
+
+  let mutableImage = MutableImage
+                   { mutableImageWidth = fromIntegral width
+                   , mutableImageHeight = fromIntegral height
+                   , mutableImageData = outVec
+                   }
+
+  case tiffPlaneConfiguration nfo of
+    PlanarConfigContig -> V.mapM_ unpacker sizes
+        where unpacker (idx, offset, size) = do
+                  let (writeIdx, tempStride)  = offsetStride comp idx 1
+                  _ <- uncompressAt compression str tempVec tempStride
+                                    writeIdx (offset, size)
+                  mergeBackTempBuffer comp endianness tempVec (width * sampleCount)
+                                      idx size 1 outVec
+
+              startWriteOffset =
+                  V.generate stripCount(width * rowPerStrip * sampleCount *)
+
+              sizes = V.zip3 startWriteOffset (tiffOffsets nfo) (tiffStripSize nfo)
+
+    PlanarConfigSeparate -> V.mapM_ unpacker sizes
+        where unpacker (idx, offset, size) = do
+                  let (writeIdx, tempStride) = offsetStride comp idx stride
+                  _ <- uncompressAt compression str tempVec tempStride
+                                    writeIdx (offset, size)
+                  mergeBackTempBuffer comp endianness tempVec (width * sampleCount)
+                                      idx size stride outVec
+
+              stride = V.length $ tiffOffsets nfo
+              idxVector = V.enumFromN 0 stride
+              sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo)
+
+  unsafeFreezeImage mutableImage
+
+getTiffInfo :: Get TiffInfo
+getTiffInfo = do
+    hdr <- get
+    readed <- bytesRead
+    skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed
+    let endian = hdrEndianness hdr
+
+    ifd <- fmap cleanImageFileDirectory <$> getImageFileDirectories endian
+    cleaned <- {- (\a -> trace (groom a) a) <$> -} fetchExtended endian ifd
+
+    let dataFind str tag = findIFDData str tag cleaned
+        dataDefault def tag = findIFDDefaultData def tag cleaned
+        extFind str tag = findIFDExt str tag cleaned
+        extDefault def tag = findIFDExtDefaultData def tag cleaned
+
+    (\a -> {- trace (groom a) -}a) <$> (TiffInfo hdr
+        <$> dataFind "Can't find width" TagImageWidth
+        <*> dataFind "Can't find height" TagImageLength
+        <*> (dataFind "Can't find color space" TagPhotometricInterpretation
+                     >>= unpackPhotometricInterpretation)
+        <*> dataFind "Can't find sample per pixel" TagSamplesPerPixel
+        <*> dataFind "Can't find row per strip" TagRowPerStrip
+        <*> (dataDefault 1 TagPlanarConfiguration
+                     >>= planarConfgOfConstant)
+        <*> (extDefault [1] TagSampleFormat
+                     >>= mapM unpackSampleFormat)
+        <*> (extFind "Can't find bit per sample" TagBitsPerSample
+                     >>= unLong "Can't find bit depth")
+        <*> (dataFind "Can't find Compression" TagCompression
+                     >>= unPackCompression)
+        <*> (extFind "Can't find byte counts" TagStripByteCounts
+                     >>= unLong "Can't find bit per sample")
+        <*> (extFind "Strip offsets missing" TagStripOffsets
+                     >>= unLong "Can't find strip offsets")
+        <*> findPalette cleaned
+        <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling)
+            )
+
+unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage
+unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted
+                         , tiffBitsPerSample = lst
+                         , tiffSampleFormat = format
+                         , tiffPalette = Just p
+                         , tiffRowPerStrip = rowPerStrip
+                         }
+  | rowPerStrip == 0 = fail "Invalid row per strip"
+  | lst == V.singleton 8 && format == [TiffSampleUint] =
+      let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0)
+          gathered :: Image Pixel8
+          gathered = gatherStrips (0 :: Word8) file nfo
+      in
+      pure . ImageRGB16 $ applyPalette gathered
+
+  | lst == V.singleton 4 && format == [TiffSampleUint] =
+      let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0)
+          gathered :: Image Pixel8
+          gathered = gatherStrips Pack4 file nfo
+      in
+      pure . ImageRGB16 $ applyPalette gathered
+
+  | lst == V.singleton 2 && format == [TiffSampleUint] =
+      let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0)
+          gathered :: Image Pixel8
+          gathered = gatherStrips Pack2 file nfo
+      in
+      pure . ImageRGB16 $ applyPalette gathered
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK
+                         , tiffRowPerStrip = rowPerStrip
+                         , tiffBitsPerSample = lst
+                         , tiffSampleFormat = format }
+  | rowPerStrip == 0 = fail "Invalid row per strip"
+  | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format =
+        pure . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo
+
+  | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =
+        pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0
+                         , tiffRowPerStrip = rowPerStrip
+                         }
+  | rowPerStrip == 0 = fail "Invalid row per strip"
+  | otherwise = do
+    img <- unpack file (nfo { tiffColorspace = TiffMonochrome })
+    case img of
+      ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i
+      ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i
+      _ -> pure img
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome
+                         , tiffRowPerStrip = rowPerStrip
+                         , tiffBitsPerSample = lst
+                         , tiffSampleFormat = format }
+  | rowPerStrip == 0 = fail "Invalid row per strip"
+  | lst == V.singleton 2 && all (TiffSampleUint ==) format =
+        pure . ImageY8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo
+  | lst == V.singleton 4 && all (TiffSampleUint ==) format =
+        pure . ImageY8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo
+  | lst == V.singleton 8 && all (TiffSampleUint ==) format =
+        pure . ImageY8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.singleton 12 && all (TiffSampleUint ==) format =
+        pure . ImageY16 . pixelMap (16 *) $ gatherStrips Pack12 file nfo
+  | lst == V.singleton 16 && all (TiffSampleUint ==) format =
+        pure . ImageY16 $ gatherStrips (0 :: Word16) file nfo
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr
+                         , tiffBitsPerSample = lst
+                         , tiffRowPerStrip = rowPerStrip
+                         , tiffPlaneConfiguration = PlanarConfigContig
+                         , tiffSampleFormat = format }
+  | rowPerStrip == 0 = fail "Invalid row per strip"
+  | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =
+    pure . ImageYCbCr8 $ gatherStrips cbcrConf  file nfo
+      where defaulting 0 = 2
+            defaulting n = n
+
+            w = defaulting $ tiffYCbCrSubsampling nfo V.! 0
+            h = defaulting $ tiffYCbCrSubsampling nfo V.! 1
+            cbcrConf = YCbCrSubsampling
+                { ycbcrWidth        = fromIntegral w
+                , ycbcrHeight       = fromIntegral h
+                , ycbcrImageWidth   = fromIntegral $ tiffWidth nfo
+                , ycbcrStripHeight  = fromIntegral $ tiffRowPerStrip nfo
+                }
+
+unpack file nfo@TiffInfo { tiffColorspace = TiffRGB
+                         , tiffRowPerStrip = rowPerStrip
+                         , tiffBitsPerSample = lst
+                         , tiffSampleFormat = format }
+  | rowPerStrip == 0 = fail "Invalid row per strip"
+  | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format =
+        pure . ImageRGB8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo
+  | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format =
+        pure . ImageRGB8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo
+  | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =
+        pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format =
+        pure . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo
+  | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format =
+        pure . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo
+  | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =
+        pure . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo
+unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome
+                         , tiffRowPerStrip = rowPerStrip
+                         , tiffBitsPerSample = lst
+                         , tiffSampleFormat = format }
+  | rowPerStrip == 0 = fail "Invalid row per strip"
+  -- some files are a little bit borked...
+  | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =
+        pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo
+
+unpack _ _ = fail "Failure to unpack TIFF file"
+
+-- | Transform a raw tiff image to an image, without modifying
+-- the underlying pixel type.
+--
+-- This function can output the following pixel types :
+--
+-- * PixelY8
+--
+-- * PixelY16
+--
+-- * PixelRGB8
+--
+-- * PixelRGB16
+--
+-- * PixelCMYK8
+--
+-- * PixelCMYK16
+--
+decodeTiff :: B.ByteString -> Either String DynamicImage
+decodeTiff file = runGetStrict getTiffInfo file >>= unpack file
+

@@ -5,845 +5,1580 @@ {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE CPP #-}
--- | Module providing the basic types for image manipulation in the library.
--- Defining the types used to store all those _Juicy Pixels_
-module Codec.Picture.Types( -- * Types
-                            -- ** Image types
-                            Image( .. )
-                          , MutableImage( .. )
-                          , DynamicImage( .. )
-
-                            -- ** Image functions
-                          , freezeImage
-                          , unsafeFreezeImage 
-
-                            -- ** Pixel types
-                          , Pixel8
-                          , PixelF
-                          , PixelYA8( .. )
-                          , PixelRGB8( .. )
-                          , PixelRGBF( .. )
-                          , PixelRGBA8( .. )
-                          , PixelYCbCr8( .. )
-
-                          -- * Type classes
-                          , ColorConvertible( .. )
-                          , Pixel(..)
-                          -- $graph
-                          , ColorSpaceConvertible( .. )
-                          , LumaPlaneExtractable( .. )
-                          , TransparentPixel( .. )
-
-                            -- * Helper functions
-                          , pixelMap
-                          , pixelFold
-                          , dropAlphaLayer
-                          , generateImage
-                          , generateFoldImage
-                          , gammaCorrection
-                          , toneMapping
-
-                            -- * Color plane extraction
-                          , ColorPlane ( )
-
-                          , PlaneRed( .. )
-                          , PlaneGreen( .. )
-                          , PlaneBlue( .. )
-                          , PlaneAlpha( .. )
-                          , PlaneLuma( .. )
-                          , PlaneCr( .. )
-                          , PlaneCb( .. )
-
-                          , extractComponent
-                          , unsafeExtractComponent
-                          ) where
-
-import Control.Monad( forM_, foldM )
-import Control.Applicative( (<$>) )
-import Control.DeepSeq( NFData( .. ) )
-import Control.Monad.ST( ST, runST )
-import Control.Monad.Primitive ( PrimMonad, PrimState )
-import Foreign.Storable ( Storable )
-import Data.Word( Word8 )
-import Data.List( foldl' )
-import Data.Vector.Storable ( (!) )
-import qualified Data.Vector.Storable as V
-import qualified Data.Vector.Storable.Mutable as M
-
-#include "ConvGraph.hs"
-
--- | Image or pixel buffer, the coordinates are assumed to start
--- from the upper-left corner of the image, with the horizontal
--- position first, then the vertical one.
-data Image a = Image
-    { -- | Width of the image in pixels
-      imageWidth  :: {-# UNPACK #-} !Int
-      -- | Height of the image in pixels.
-    , imageHeight :: {-# UNPACK #-} !Int
-
-      -- | The real image, to extract pixels at some position
-      -- you should use the helpers functions.
-    , imageData   :: V.Vector (PixelBaseComponent a)
-    }
-
-{-# INLINE (!!!) #-}
-(!!!) :: (Storable e) => V.Vector e -> Int -> e
-(!!!) = V.unsafeIndex
-
--- | Class used to describle plane present in the pixel
--- type. If a pixel has a plane description associated,
--- you can use the plane name to extract planes independently.
-class ColorPlane pixel planeToken where
-    -- | Retrieve the index of the component in the
-    -- given pixel type.
-    toComponentIndex :: pixel -> planeToken -> Int
-
--- | Define the plane for the red color component
-data PlaneRed = PlaneRed
-
--- | Define the plane for the green color component
-data PlaneGreen = PlaneGreen
-
--- | Define the plane for the blue color component
-data PlaneBlue = PlaneBlue
-
--- | Define the plane for the alpha (transparency) component
-data PlaneAlpha = PlaneAlpha
-
--- | Define the plane for the luma component
-data PlaneLuma = PlaneLuma
-
--- | Define the plane for the Cr component
-data PlaneCr = PlaneCr
-
--- | Define the plane for the Cb component
-data PlaneCb = PlaneCb
-
-instance ColorPlane PixelYCbCr8 PlaneLuma where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelYCbCr8 PlaneCb where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelYCbCr8 PlaneCr where
-    toComponentIndex _ _ = 2
-
-instance ColorPlane PixelYA8 PlaneLuma where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelYA8 PlaneAlpha where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelRGB8 PlaneRed where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelRGB8 PlaneGreen where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelRGB8 PlaneBlue where
-    toComponentIndex _ _ = 2
-
-instance ColorPlane PixelRGBF PlaneRed where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelRGBF PlaneGreen where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelRGBF PlaneBlue where
-    toComponentIndex _ _ = 2
-
-instance ColorPlane PixelRGBA8 PlaneRed where
-    toComponentIndex _ _ = 0
-
-instance ColorPlane PixelRGBA8 PlaneGreen where
-    toComponentIndex _ _ = 1
-
-instance ColorPlane PixelRGBA8 PlaneBlue where
-    toComponentIndex _ _ = 2
-
-instance ColorPlane PixelRGBA8 PlaneAlpha where
-    toComponentIndex _ _ = 3
-
--- | Extract a color plane from an image given a present plane in the image
--- examples :
---
--- @
---  extractRedPlane :: Image PixelRGB8-> Image Pixel8
---  extractRedPlane = extractComponent PlaneRed
--- @
---
-extractComponent :: forall px plane. ( Pixel px
-                                     , Pixel (PixelBaseComponent px)
-                                     , PixelBaseComponent (PixelBaseComponent px)
-                                                    ~ PixelBaseComponent px
-                                     , ColorPlane px plane )
-                 => plane -> Image px -> Image (PixelBaseComponent px)
-extractComponent plane = unsafeExtractComponent idx
-    where idx = toComponentIndex (undefined :: px) plane
-
--- | Extract an image plane of an image, returning an image which
--- can be represented by a gray scale image.
--- If you ask a component out of bound, the `error` function will
--- be called
-unsafeExtractComponent :: forall a
-                        . ( Pixel a
-                          , Pixel (PixelBaseComponent a)
-                          , PixelBaseComponent (PixelBaseComponent a)
-                                              ~ PixelBaseComponent a)
-                       => Int     -- ^ The component index, beginning at 0 ending at (componentCount - 1)
-                       -> Image a -- ^ Source image
-                       -> Image (PixelBaseComponent a)
-unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h })
-  | comp >= padd = error $ "extractComponent : invalid component index ("
-                         ++ show comp ++ ", max:" ++ show padd ++ ")"
-  | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane }
-      where plane = stride img 1 padd comp
-            padd = componentCount (undefined :: a)
-
--- | For any image with an alpha component (transparency),
--- drop it, returning a pure opaque image.
-dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b
-dropAlphaLayer = pixelMap dropTransparency
-
--- | Class modeling transparent pixel, should provide a method
--- to combine transparent pixels
-class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where
-    -- | Just return the opaque pixel value
-    dropTransparency :: a -> b
-
-instance TransparentPixel PixelYA8 Pixel8 where
-    {-# INLINE dropTransparency #-}
-    dropTransparency (PixelYA8 y _) = y
-
-instance TransparentPixel PixelRGBA8 PixelRGB8 where
-    {-# INLINE dropTransparency #-}
-    dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b
-
-stride :: (Storable (PixelBaseComponent a))
-       => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a)
-stride Image { imageWidth = w, imageHeight = h, imageData = array }
-        run padd firstComponent = runST $ do
-    let cell_count = w * h * run
-    outArray <- M.new cell_count
-
-    let strideWrite write_idx _ | write_idx == cell_count = return ()
-        strideWrite write_idx read_idx = do
-            forM_ [0 .. run - 1] $ \i ->
-                (outArray .<-. (write_idx + i)) $ array !!! (read_idx + i)
-            strideWrite (write_idx + run) (read_idx + padd)
-
-    strideWrite 0 firstComponent
-    V.unsafeFreeze outArray
-
-instance NFData (Image a) where
-    rnf (Image width height dat) = width  `seq`
-                                   height `seq`
-                                   dat    `seq`
-                                   ()
-
--- | Image or pixel buffer, the coordinates are assumed to start
--- from the upper-left corner of the image, with the horizontal
--- position first, then the vertical one. The image can be transformed in place.
-data MutableImage s a = MutableImage
-    { -- | Width of the image in pixels
-	  mutableImageWidth  :: {-# UNPACK #-} !Int
-
-      -- | Height of the image in pixels.
-	, mutableImageHeight :: {-# UNPACK #-} !Int
-
-      -- | The real image, to extract pixels at some position
-      -- you should use the helpers functions.
-    , mutableImageData   :: M.STVector s (PixelBaseComponent a)
-    }
-
--- | `O(n)` Yield an immutable copy of an image by making a copy of it
-freezeImage :: (Storable (PixelBaseComponent a))
-            => MutableImage s a -> ST s (Image a)
-freezeImage (MutableImage w h d) = Image w h <$> V.freeze d
-
--- | `O(1)` Unsafe convert a mutable image to an immutable one without copying.
--- The mutable image may not be used after this operation.
-unsafeFreezeImage ::  (Storable (PixelBaseComponent a))
-                  => MutableImage s a -> ST s (Image a)
-unsafeFreezeImage (MutableImage w h d) = Image w h <$> V.unsafeFreeze d
-
-instance NFData (MutableImage s a) where
-    rnf (MutableImage width height dat) = width  `seq`
-                                          height `seq`
-                                          dat    `seq`
-                                          ()
-
--- | Type allowing the loading of an image with different pixel
--- structures
-data DynamicImage =
-       -- | A greyscale image.
-       ImageY8   (Image Pixel8)
-       -- | A greyscale HDR image 
-     | ImageYF   (Image PixelF)
-       -- | An image in greyscale with an alpha channel.
-     | ImageYA8  (Image PixelYA8)
-       -- | An image in true color.
-     | ImageRGB8 (Image PixelRGB8)
-       -- | An image with HDR pixels
-     | ImageRGBF (Image PixelRGBF)
-       -- | An image in true color and an alpha channel.
-     | ImageRGBA8 (Image PixelRGBA8)
-       -- | An image in the colorspace used by Jpeg images.
-     | ImageYCbCr8 (Image PixelYCbCr8)
-
-instance NFData DynamicImage where
-    rnf (ImageY8 img)     = rnf img
-    rnf (ImageYF img)     = rnf img
-    rnf (ImageYA8 img)    = rnf img
-    rnf (ImageRGB8 img)   = rnf img
-    rnf (ImageRGBF img)   = rnf img
-    rnf (ImageRGBA8 img)  = rnf img
-    rnf (ImageYCbCr8 img) = rnf img
-
--- | Simple alias for greyscale value in 8 bits.
-type Pixel8 = Word8
-
--- | Floating greyscale value, the 0 to 255 8 bit range maps
--- to 0 to 1 in this floating version
-type PixelF = Float
-
--- | Pixel type storing Luminance (Y) and alpha information
--- on 8 bits.
--- Value are stored in the following order :
---
---  * Luminance
---
---  * Alpha
---
-data PixelYA8 = PixelYA8 {-# UNPACK #-} !Word8  -- Luminance
-                         {-# UNPACK #-} !Word8  -- Alpha value
-
--- | Pixel type storing classic pixel on 8 bits
--- Value are stored in the following order :
---
---  * Red
---
---  * Green
---
---  * Blue
---
-data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Word8 -- Red
-                           {-# UNPACK #-} !Word8 -- Green
-                           {-# UNPACK #-} !Word8 -- Blue
-
--- | Pixel type storing HDR pixel on 32 bits float
--- Value are stored in the following order :
---
---  * Red
---
---  * Green
---
---  * Blue
---
-data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red
-                           {-# UNPACK #-} !PixelF -- Green
-                           {-# UNPACK #-} !PixelF -- Blue
-
--- | Pixel storing data in the YCbCr colorspace,
--- value are stored in the following order :
---
---  * Y (luminance)
---
---  * Cr
---
---  * Cb
---
-data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Word8 -- Y luminance
-                               {-# UNPACK #-} !Word8 -- Cr red difference
-                               {-# UNPACK #-} !Word8 -- Cb blue difference
-
--- | Pixel type storing a classic pixel, with an alpha component.
--- Values are stored in the following order
---
---  * Red
---
---  * Green
---
---  * Blue
---
---  * Alpha
---
-data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Word8 -- Red
-                             {-# UNPACK #-} !Word8 -- Green
-                             {-# UNPACK #-} !Word8 -- Blue
-                             {-# UNPACK #-} !Word8 -- Alpha
-
--- | Definition of pixels used in images. Each pixel has a color space, and a representative
--- component (Word8 or Float).
-class ( Storable (PixelBaseComponent a), Num (PixelBaseComponent a) ) => Pixel a where
-    -- | Type of the pixel component, "classical" images
-    -- would have Word8 type as their PixelBaseComponent,
-    -- HDR image would have Float for instance
-    type PixelBaseComponent a :: *
-
-    -- | Return the number of component of the pixel
-    componentCount :: a -> Int
-
-    -- | Apply a function to all color component of a pixel.
-    colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
-
-    -- | Calculate the index for the begining of the pixel
-    pixelBaseIndex :: Image a -> Int -> Int -> Int
-    pixelBaseIndex (Image { imageWidth = w }) x y =
-            (x + y * w) * componentCount (undefined :: a)
-
-    -- | Calculate theindex for the begining of the pixel at position x y
-    mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int
-    mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y =
-            (x + y * w) * componentCount (undefined :: a)
-
-    -- | Extract a pixel at a given position, (x, y), the origin
-    -- is assumed to be at the corner top left, positive y to the
-    -- bottom of the image
-    pixelAt :: Image a -> Int -> Int -> a
-
-    -- | Same as pixelAt but for mutable images.
-    readPixel :: MutableImage s a -> Int -> Int -> ST s a
-
-    -- | Write a pixel in a mutable image at position x y
-    writePixel :: MutableImage s a -> Int -> Int -> a -> ST s ()
-
--- | Implement upcasting for pixel types
--- Minimal declaration declaration `promotePixel`
--- It is strongly recommanded to overload promoteImage to keep
--- performance acceptable
-class (Pixel a, Pixel b) => ColorConvertible a b where
-    -- | Convert a pixel type to another pixel type. This
-    -- operation should never loss any data.
-    promotePixel :: a -> b
-
-    -- | Change the underlying pixel type of an image by performing a full copy
-    -- of it.
-    promoteImage :: Image a -> Image b
-    promoteImage = pixelMap promotePixel
-
--- | This class abstract colorspace conversion. This
--- conversion can be lossy, which ColorConvertible cannot
-class (Pixel a, Pixel b) => ColorSpaceConvertible a b where
-    -- | Pass a pixel from a colorspace (say RGB) to the second one
-    -- (say YCbCr)
-    convertPixel :: a -> b
-
-    -- | Helper function to convert a whole image by taking a
-    -- copy it.
-    convertImage :: Image a -> Image b
-    convertImage = pixelMap convertPixel
-
--- | Create an image given a function to generate pixels.
--- The function will receive value from 0 to width-1 for the x parameter
--- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper
--- left corner of the image, and (width-1, height-1) the lower right corner.
---
--- for example, to create a small gradient image :
---
--- > imageCreator :: String -> Image PixelRGB8
--- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300
--- >    where pixelRenderer x y = PixelRGB8 x y 128
---
-generateImage :: forall a. (Pixel a)
-              => (Int -> Int -> a)  -- ^ Generating function, with `x` and `y` params.
-              -> Int        -- ^ Width in pixels
-              -> Int        -- ^ Height in pixels
-              -> Image a
-generateImage f w h = Image { imageWidth = w, imageHeight = h, imageData = generated }
-  where compCount = componentCount (undefined :: a)
-        generated = runST $ do
-            arr <- M.new (w * h * compCount)
-            let mutImage = MutableImage {
-                                mutableImageWidth = w,
-                                mutableImageHeight = h,
-                                mutableImageData = arr }
-            forM_ [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] $ \(x,y) ->
-                writePixel mutImage x y $ f x y
-            V.unsafeFreeze arr
-
--- | Create an image given a function to generate pixels.
--- The function will receive value from 0 to width-1 for the x parameter
--- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper
--- left corner of the image, and (width-1, height-1) the lower right corner.
---
--- the acc parameter is a user defined one.
---
--- The function is called for each pixel in the line from left to right (0 to width - 1)
--- and for each line (0 to height - 1).
-generateFoldImage :: forall a acc. (Pixel a)
-                  => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y
-                  -> acc        -- ^ Initial state
-                  -> Int        -- ^ Width in pixels
-                  -> Int        -- ^ Height in pixels
-                  -> (acc, Image a)
-generateFoldImage f intialAcc w h =
- (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated })
-  where compCount = componentCount (undefined :: a)
-        (finalState, generated) = runST $ do
-            arr <- M.new (w * h * compCount)
-            let mutImage = MutableImage {
-                                mutableImageWidth = w,
-                                mutableImageHeight = h,
-                                mutableImageData = arr }
-            foldResult <- foldM (\acc (x,y) -> do
-                    let (acc', px) = f acc x y
-                    writePixel mutImage x y px
-                    return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]]
-
-            frozen <- V.unsafeFreeze arr
-            return (foldResult, frozen)
-
--- | Fold over the pixel of an image with a raster scan order :
--- from top to bottom, left to right
-{-# INLINE pixelFold #-}
-pixelFold :: (Pixel pixel) 
-          => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc
-pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) =
-  lineFold 
-    where pixelFolder y acc x = f acc x y $ pixelAt img x y
-          columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1]
-          lineFold = foldl' columnFold initialAccumulator [0 .. h - 1]
-          
-{-# INLINE pixelMap #-}
-{-# RULES "pixelMap fusion" forall g f. pixelMap g . pixelMap f = pixelMap (g . f) #-}
--- | `map` equivalent for an image, working at the pixel level.
--- Little example : a brightness function for an rgb image
---
--- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8
--- > brightnessRGB8 add = pixelMap brightFunction
--- >      where up v = fromIntegral (fromIntegral v + add)
--- >            brightFunction (PixelRGB8 r g b) =
--- >                    PixelRGB8 (up r) (up g) (up b)
---
-pixelMap :: forall a b. (Pixel a, Pixel b)
-         => (a -> b) -> Image a -> Image b
-pixelMap f image@(Image { imageWidth = w, imageHeight = h }) =
-  Image w h pixels
-    where pixels = runST $ do
-            newArr <- M.replicate (w * h * componentCount (undefined :: b)) 0
-            let wrapped = MutableImage w h newArr
-                promotedPixel :: Int -> Int -> b
-                promotedPixel x y = f $ pixelAt image x y
-            sequence_ [writePixel wrapped x y $ promotedPixel x y
-                                | y <- [0 .. h - 1], x <- [0 .. w - 1] ]
-            -- unsafeFreeze avoids making a second copy and it will be
-            -- safe because newArray can't be referenced as a mutable array
-            -- outside of this where block
-            V.unsafeFreeze newArr
-
--- | Helper class to help extract a luma plane out
--- of an image or a pixel
-class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where
-    -- | Compute the luminance part of a pixel
-    computeLuma      :: a -> (PixelBaseComponent a)
-
-    -- | Extract a luma plane out of an image. This
-    -- method is in the typeclass to help performant
-    -- implementation.
-    extractLumaPlane :: Image a -> Image (PixelBaseComponent a)
-    extractLumaPlane = pixelMap computeLuma
-
-instance LumaPlaneExtractable Pixel8 where
-    {-# INLINE computeLuma #-}
-    computeLuma = id
-    extractLumaPlane = id
-
-instance LumaPlaneExtractable PixelF where
-    {-# INLINE computeLuma #-}
-    computeLuma = id
-    extractLumaPlane = id
-
-instance LumaPlaneExtractable PixelRGB8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r +
-                                            0.59 * toRational g +
-                                            0.11 * toRational b
-
-instance LumaPlaneExtractable PixelRGBF where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelRGBF r g b) =
-        0.3 * r + 0.59 * g + 0.11 * b
-
-instance LumaPlaneExtractable PixelRGBA8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r +
-                                             0.59 * toRational g +
-                                             0.11 * toRational b
-
-instance LumaPlaneExtractable PixelYA8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelYA8 y _) = y
-    extractLumaPlane = extractComponent PlaneLuma
-
-instance LumaPlaneExtractable PixelYCbCr8 where
-    {-# INLINE computeLuma #-}
-    computeLuma (PixelYCbCr8 y _ _) = y
-    extractLumaPlane = extractComponent PlaneLuma
-
--- | Free promotion for identic pixel types
-instance (Pixel a) => ColorConvertible a a where
-    {-# INLINE promotePixel #-}
-    promotePixel = id
-
-    {-# INLINE promoteImage #-}
-    promoteImage = id
-
-{-# INLINE (.!!!.) #-}
-(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a
-(.!!!.) = M.read -- unsafeRead
-
-{-# INLINE (.<-.) #-}
-(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
-(.<-.)  = M.write -- unsafeWrite
-
---------------------------------------------------
-----            Pixel8 instances
---------------------------------------------------
-instance Pixel Pixel8 where
-    type PixelBaseComponent Pixel8 = Word8
-
-    {-# INLINE colorMap #-}
-    colorMap f = f
-
-    componentCount _ = 1
-    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y =
-        arr .!!!. mutablePixelBaseIndex image x y
-
-    writePixel image@(MutableImage { mutableImageData = arr }) x y =
-        arr .<-. mutablePixelBaseIndex image x y
-
-instance Pixel PixelF where
-    type PixelBaseComponent PixelF = Float
-
-    {-# INLINE colorMap #-}
-    colorMap f = f
-    componentCount _ = 1
-    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y =
-        arr .!!!. mutablePixelBaseIndex image x y
-
-    writePixel image@(MutableImage { mutableImageData = arr }) x y =
-        arr .<-. mutablePixelBaseIndex image x y
-
-instance ColorConvertible Pixel8 PixelYA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel c = PixelYA8 c 255
-
-instance ColorConvertible Pixel8 PixelF where
-    {-# INLINE promotePixel #-}
-    promotePixel c = fromIntegral c / 255.0
-
-instance ColorConvertible Pixel8 PixelRGB8 where
-    {-# INLINE promotePixel #-}
-    promotePixel c = PixelRGB8 c c c
-
-instance ColorConvertible Pixel8 PixelRGBA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel c = PixelRGBA8 c c c 255
-
-instance ColorConvertible PixelF PixelRGBF where
-    {-# INLINE promotePixel #-}
-    promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59)  (c / 0.11)
-
---------------------------------------------------
-----            PixelYA8 instances
---------------------------------------------------
-instance Pixel PixelYA8 where
-    type PixelBaseComponent PixelYA8 = Word8
-
-    {-# INLINE colorMap #-}
-    colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a)
-    componentCount _ = 2
-    pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0))
-                                                             (arr ! (baseIdx + 1))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        yv <- arr .!!!. baseIdx
-        av <- arr .!!!. (baseIdx + 1)
-        return $ PixelYA8 yv av
-        where baseIdx = mutablePixelBaseIndex image x y
-
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) yv
-        (arr .<-. (baseIdx + 1)) av
-
-
-instance ColorConvertible PixelYA8 PixelRGB8 where
-    {-# INLINE promotePixel #-}
-    promotePixel (PixelYA8 y _) = PixelRGB8 y y y
-
-instance ColorConvertible PixelYA8 PixelRGBA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a
-
---------------------------------------------------
-----            PixelRGBF instances
---------------------------------------------------
-instance Pixel PixelRGBF where
-    type PixelBaseComponent PixelRGBF = PixelF
-
-    {-# INLINE colorMap #-}
-    colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b)
-
-    componentCount _ = 3
-
-    pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0))
-                                                              (arr ! (baseIdx + 1))
-                                                              (arr ! (baseIdx + 2))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        rv <- arr .!!!. baseIdx
-        gv <- arr .!!!. (baseIdx + 1)
-        bv <- arr .!!!. (baseIdx + 2)
-        return $ PixelRGBF rv gv bv
-        where baseIdx = mutablePixelBaseIndex image x y
-
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) rv
-        (arr .<-. (baseIdx + 1)) gv
-        (arr .<-. (baseIdx + 2)) bv
-
---------------------------------------------------
-----            PixelRGB8 instances
---------------------------------------------------
-instance Pixel PixelRGB8 where
-    type PixelBaseComponent PixelRGB8 = Word8
-
-    {-# INLINE colorMap #-}
-    colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b)
-
-    componentCount _ = 3
-
-    pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0))
-                                                              (arr ! (baseIdx + 1))
-                                                              (arr ! (baseIdx + 2))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        rv <- arr .!!!. baseIdx
-        gv <- arr .!!!. (baseIdx + 1)
-        bv <- arr .!!!. (baseIdx + 2)
-        return $ PixelRGB8 rv gv bv
-        where baseIdx = mutablePixelBaseIndex image x y
-
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) rv
-        (arr .<-. (baseIdx + 1)) gv
-        (arr .<-. (baseIdx + 2)) bv
-
-instance ColorConvertible PixelRGB8 PixelRGBA8 where
-    {-# INLINE promotePixel #-}
-    promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b 255
-
-instance ColorConvertible PixelRGB8 PixelRGBF where
-    {-# INLINE promotePixel #-}
-    promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b)
-        where toF v = fromIntegral v / 255
-
---------------------------------------------------
-----            PixelRGBA8 instances
---------------------------------------------------
-instance Pixel PixelRGBA8 where
-    type PixelBaseComponent PixelRGBA8 = Word8
-
-    {-# INLINE colorMap #-}
-    colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a)
-
-    componentCount _ = 4
-
-    pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0))
-                                                               (arr ! (baseIdx + 1))
-                                                               (arr ! (baseIdx + 2))
-                                                               (arr ! (baseIdx + 3))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        rv <- arr .!!!. baseIdx
-        gv <- arr .!!!. (baseIdx + 1)
-        bv <- arr .!!!. (baseIdx + 2)
-        av <- arr .!!!. (baseIdx + 3)
-        return $ PixelRGBA8 rv gv bv av
-        where baseIdx = mutablePixelBaseIndex image x y
-
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) rv
-        (arr .<-. (baseIdx + 1)) gv
-        (arr .<-. (baseIdx + 2)) bv
-        (arr .<-. (baseIdx + 3)) av
-
---------------------------------------------------
-----            PixelYCbCr8 instances
---------------------------------------------------
-instance Pixel PixelYCbCr8 where
-    type PixelBaseComponent PixelYCbCr8 = Word8
-
-    {-# INLINE colorMap #-}
-    colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr)
-    componentCount _ = 3
-    pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0))
-                                                                (arr ! (baseIdx + 1))
-                                                                (arr ! (baseIdx + 2))
-        where baseIdx = pixelBaseIndex image x y
-
-    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
-        yv <- arr .!!!. baseIdx
-        cbv <- arr .!!!. (baseIdx + 1)
-        crv <- arr .!!!. (baseIdx + 2)
-        return $ PixelYCbCr8 yv cbv crv
-        where baseIdx = mutablePixelBaseIndex image x y
-
-    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do
-        let baseIdx = mutablePixelBaseIndex image x y
-        (arr .<-. (baseIdx + 0)) yv
-        (arr .<-. (baseIdx + 1)) cbv
-        (arr .<-. (baseIdx + 2)) crv
-
-instance (Pixel a) => ColorSpaceConvertible a a where
-    convertPixel = id
-    convertImage = id
-
-instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where
-    {-# INLINE convertPixel #-}
-    convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (truncate y)
-                                                 (truncate cb)
-                                                 (truncate cr)
-      where rf = fromIntegral r :: Float
-            gf = fromIntegral g
-            bf = fromIntegral b
-
-
-            y  =  0.29900 * rf + 0.58700 * gf + 0.11400 * bf
-            cb = -0.16874 * rf - 0.33126 * gf + 0.50000 * bf + 128
-            cr =  0.50000 * rf - 0.41869 * gf - 0.08131 * bf + 128
-
-instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where
-    {-# INLINE convertPixel #-}
-    convertPixel (PixelYCbCr8 y_w8 cb_w8 cr_w8) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)
-        where y :: Float
-              y  = fromIntegral y_w8 - 128.0
-              cb = fromIntegral cb_w8 - 128.0
-              cr = fromIntegral cr_w8 - 128.0
-
-              clampWord8 = truncate . max 0.0 . min 255.0 . (128 +)
-
-              cred = 0.299
-              cgreen = 0.587
-              cblue = 0.114
-
-              r = cr * (2 - 2 * cred) + y
-              b = cb * (2 - 2 * cblue) + y
-              g = (y - cblue * b - cred * r) / cgreen
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE CPP #-}
+-- | Module providing the basic types for image manipulation in the library.
+-- Defining the types used to store all those _Juicy Pixels_
+module Codec.Picture.Types( -- * Types
+                            -- ** Image types
+                            Image( .. )
+                          , MutableImage( .. )
+                          , DynamicImage( .. )
+
+                            -- ** Image functions
+                          , freezeImage
+                          , unsafeFreezeImage 
+
+                            -- ** Pixel types
+                          , Pixel8
+                          , Pixel16
+                          , PixelF
+                          , PixelYA8( .. )
+                          , PixelYA16( .. )
+                          , PixelRGB8( .. )
+                          , PixelRGB16( .. )
+                          , PixelRGBF( .. )
+                          , PixelRGBA8( .. )
+                          , PixelRGBA16( .. )
+                          , PixelCMYK8( .. )
+                          , PixelCMYK16( .. )
+                          , PixelYCbCr8( .. )
+
+                          -- * Type classes
+                          , ColorConvertible( .. )
+                          , Pixel(..)
+                          -- $graph
+                          , ColorSpaceConvertible( .. )
+                          , LumaPlaneExtractable( .. )
+                          , TransparentPixel( .. )
+
+                            -- * Helper functions
+                          , dynamicMap
+                          , pixelMap
+                          , pixelFold
+                          , dropAlphaLayer
+                          , withImage
+                          , generateImage
+                          , generateFoldImage
+                          , gammaCorrection
+                          , toneMapping
+
+                            -- * Color plane extraction
+                          , ColorPlane ( )
+
+                          , PlaneRed( .. )
+                          , PlaneGreen( .. )
+                          , PlaneBlue( .. )
+                          , PlaneAlpha( .. )
+                          , PlaneLuma( .. )
+                          , PlaneCr( .. )
+                          , PlaneCb( .. )
+                          , PlaneCyan( .. )
+                          , PlaneMagenta( .. )
+                          , PlaneYellow( .. )
+                          , PlaneBlack( .. )
+
+                          , extractComponent
+                          , unsafeExtractComponent
+                          ) where
+
+import Control.Monad( forM_, foldM, liftM, ap )
+import Control.DeepSeq( NFData( .. ) )
+import Control.Monad.ST( runST )
+import Control.Monad.Primitive ( PrimMonad, PrimState )
+import Foreign.Storable ( Storable )
+import Data.Bits( unsafeShiftL, unsafeShiftR )
+import Data.Word( Word8, Word16 )
+import Data.List( foldl' )
+import Data.Vector.Storable ( (!) )
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as M
+
+#include "ConvGraph.hs"
+
+-- | Image or pixel buffer, the coordinates are assumed to start
+-- from the upper-left corner of the image, with the horizontal
+-- position first, then the vertical one.
+data Image a = Image
+    { -- | Width of the image in pixels
+      imageWidth  :: {-# UNPACK #-} !Int
+      -- | Height of the image in pixels.
+    , imageHeight :: {-# UNPACK #-} !Int
+
+      -- | The real image, to extract pixels at some position
+      -- you should use the helpers functions.
+    , imageData   :: V.Vector (PixelBaseComponent a)
+    }
+
+{-# INLINE (!!!) #-}
+(!!!) :: (Storable e) => V.Vector e -> Int -> e
+(!!!) = V.unsafeIndex
+
+-- | Class used to describle plane present in the pixel
+-- type. If a pixel has a plane description associated,
+-- you can use the plane name to extract planes independently.
+class ColorPlane pixel planeToken where
+    -- | Retrieve the index of the component in the
+    -- given pixel type.
+    toComponentIndex :: pixel -> planeToken -> Int
+
+-- | Define the plane for the red color component
+data PlaneRed = PlaneRed
+
+-- | Define the plane for the green color component
+data PlaneGreen = PlaneGreen
+
+-- | Define the plane for the blue color component
+data PlaneBlue = PlaneBlue
+
+-- | Define the plane for the alpha (transparency) component
+data PlaneAlpha = PlaneAlpha
+
+-- | Define the plane for the luma component
+data PlaneLuma = PlaneLuma
+
+-- | Define the plane for the Cr component
+data PlaneCr = PlaneCr
+
+-- | Define the plane for the Cb component
+data PlaneCb = PlaneCb
+
+-- | Define plane for the cyan component of the 
+-- CMYK color space.
+data PlaneCyan = PlaneCyan
+
+-- | Define plane for the magenta component of the 
+-- CMYK color space.
+data PlaneMagenta = PlaneMagenta
+
+-- | Define plane for the yellow component of the 
+-- CMYK color space.
+data PlaneYellow = PlaneYellow
+
+-- | Define plane for the black component of
+-- the CMYK color space.
+data PlaneBlack = PlaneBlack
+
+-- | Extract a color plane from an image given a present plane in the image
+-- examples :
+--
+-- @
+--  extractRedPlane :: Image PixelRGB8-> Image Pixel8
+--  extractRedPlane = extractComponent PlaneRed
+-- @
+--
+extractComponent :: forall px plane. ( Pixel px
+                                     , Pixel (PixelBaseComponent px)
+                                     , PixelBaseComponent (PixelBaseComponent px)
+                                                    ~ PixelBaseComponent px
+                                     , ColorPlane px plane )
+                 => plane -> Image px -> Image (PixelBaseComponent px)
+extractComponent plane = unsafeExtractComponent idx
+    where idx = toComponentIndex (undefined :: px) plane
+
+-- | Extract an image plane of an image, returning an image which
+-- can be represented by a gray scale image.
+-- If you ask a component out of bound, the `error` function will
+-- be called
+unsafeExtractComponent :: forall a
+                        . ( Pixel a
+                          , Pixel (PixelBaseComponent a)
+                          , PixelBaseComponent (PixelBaseComponent a)
+                                              ~ PixelBaseComponent a)
+                       => Int     -- ^ The component index, beginning at 0 ending at (componentCount - 1)
+                       -> Image a -- ^ Source image
+                       -> Image (PixelBaseComponent a)
+unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h })
+  | comp >= padd = error $ "extractComponent : invalid component index ("
+                         ++ show comp ++ ", max:" ++ show padd ++ ")"
+  | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane }
+      where plane = stride img 1 padd comp
+            padd = componentCount (undefined :: a)
+
+-- | For any image with an alpha component (transparency),
+-- drop it, returning a pure opaque image.
+dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b
+dropAlphaLayer = pixelMap dropTransparency
+
+-- | Class modeling transparent pixel, should provide a method
+-- to combine transparent pixels
+class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where
+    -- | Just return the opaque pixel value
+    dropTransparency :: a -> b
+
+instance TransparentPixel PixelRGBA8 PixelRGB8 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b
+
+stride :: (Storable (PixelBaseComponent a))
+       => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a)
+stride Image { imageWidth = w, imageHeight = h, imageData = array }
+        run padd firstComponent = runST $ do
+    let cell_count = w * h * run
+    outArray <- M.new cell_count
+
+    let strideWrite write_idx _ | write_idx == cell_count = return ()
+        strideWrite write_idx read_idx = do
+            forM_ [0 .. run - 1] $ \i ->
+                (outArray .<-. (write_idx + i)) $ array !!! (read_idx + i)
+            strideWrite (write_idx + run) (read_idx + padd)
+
+    strideWrite 0 firstComponent
+    V.unsafeFreeze outArray
+
+instance NFData (Image a) where
+    rnf (Image width height dat) = width  `seq`
+                                   height `seq`
+                                   dat    `seq`
+                                   ()
+
+-- | Image or pixel buffer, the coordinates are assumed to start
+-- from the upper-left corner of the image, with the horizontal
+-- position first, then the vertical one. The image can be transformed in place.
+data MutableImage s a = MutableImage
+    { -- | Width of the image in pixels
+	  mutableImageWidth  :: {-# UNPACK #-} !Int
+
+      -- | Height of the image in pixels.
+	, mutableImageHeight :: {-# UNPACK #-} !Int
+
+      -- | The real image, to extract pixels at some position
+      -- you should use the helpers functions.
+    , mutableImageData   :: M.STVector s (PixelBaseComponent a)
+    }
+
+-- | `O(n)` Yield an immutable copy of an image by making a copy of it
+freezeImage :: (Storable (PixelBaseComponent a), PrimMonad m)
+            => MutableImage (PrimState m) a -> m (Image a)
+freezeImage (MutableImage w h d) = Image w h `liftM` V.freeze d
+
+-- | `O(1)` Unsafe convert a mutable image to an immutable one without copying.
+-- The mutable image may not be used after this operation.
+unsafeFreezeImage ::  (Storable (PixelBaseComponent a), PrimMonad m)
+                  => MutableImage (PrimState m) a -> m (Image a)
+unsafeFreezeImage (MutableImage w h d) = Image w h `liftM` V.unsafeFreeze d
+
+instance NFData (MutableImage s a) where
+    rnf (MutableImage width height dat) = width  `seq`
+                                          height `seq`
+                                          dat    `seq`
+                                          ()
+
+-- | Type allowing the loading of an image with different pixel
+-- structures
+data DynamicImage =
+       -- | A greyscale image.
+       ImageY8    (Image Pixel8)
+       -- | A greyscale image with 16bit components
+     | ImageY16   (Image Pixel16)
+       -- | A greyscale HDR image 
+     | ImageYF    (Image PixelF)
+       -- | An image in greyscale with an alpha channel.
+     | ImageYA8   (Image PixelYA8)
+      -- | An image in greyscale with alpha channel on 16 bits.
+     | ImageYA16  (Image PixelYA16)
+       -- | An image in true color.
+     | ImageRGB8  (Image PixelRGB8)
+       -- | An image in true color with 16bit depth.
+     | ImageRGB16 (Image PixelRGB16)
+       -- | An image with HDR pixels
+     | ImageRGBF  (Image PixelRGBF)
+       -- | An image in true color and an alpha channel.
+     | ImageRGBA8 (Image PixelRGBA8)
+       -- | A true color image with alpha on 16 bits.
+     | ImageRGBA16 (Image PixelRGBA16)
+       -- | An image in the colorspace used by Jpeg images.
+     | ImageYCbCr8 (Image PixelYCbCr8)
+       -- | An image in the colorspace CMYK
+     | ImageCMYK8  (Image PixelCMYK8)
+       -- | An image in the colorspace CMYK and 16 bots precision
+     | ImageCMYK16 (Image PixelCMYK16)
+
+-- | Helper function to help extract information from dynamic
+-- image. To get the width of an dynamic image, you can use
+-- the following snippet :
+--
+-- > dynWidth :: DynamicImage -> Int
+-- > dynWidth img = dynamicMap imageWidth img
+--
+dynamicMap :: (forall pixel . (Pixel pixel) => Image pixel -> a)
+           -> DynamicImage -> a
+dynamicMap f (ImageY8    i) = f i
+dynamicMap f (ImageY16   i) = f i
+dynamicMap f (ImageYF    i) = f i
+dynamicMap f (ImageYA8   i) = f i
+dynamicMap f (ImageYA16  i) = f i
+dynamicMap f (ImageRGB8  i) = f i
+dynamicMap f (ImageRGB16 i) = f i
+dynamicMap f (ImageRGBF  i) = f i
+dynamicMap f (ImageRGBA8 i) = f i
+dynamicMap f (ImageRGBA16 i) = f i
+dynamicMap f (ImageYCbCr8 i) = f i
+dynamicMap f (ImageCMYK8 i) = f i
+dynamicMap f (ImageCMYK16 i) = f i
+
+instance NFData DynamicImage where
+    rnf (ImageY8 img)     = rnf img
+    rnf (ImageY16 img)    = rnf img
+    rnf (ImageYF img)     = rnf img
+    rnf (ImageYA8 img)    = rnf img
+    rnf (ImageYA16 img)   = rnf img
+    rnf (ImageRGB8 img)   = rnf img
+    rnf (ImageRGB16 img)  = rnf img
+    rnf (ImageRGBF img)   = rnf img
+    rnf (ImageRGBA8 img)  = rnf img
+    rnf (ImageRGBA16 img) = rnf img
+    rnf (ImageYCbCr8 img) = rnf img
+    rnf (ImageCMYK8 img)  = rnf img
+    rnf (ImageCMYK16 img)  = rnf img
+
+-- | Simple alias for greyscale value in 8 bits.
+type Pixel8 = Word8
+
+-- | Simple alias for greyscale value in 16 bits.
+type Pixel16 = Word16
+
+-- | Floating greyscale value, the 0 to 255 8 bit range maps
+-- to 0 to 1 in this floating version
+type PixelF = Float
+
+-- | Pixel type storing Luminance (Y) and alpha information
+-- on 8 bits.
+-- Value are stored in the following order :
+--
+--  * Luminance
+--
+--  * Alpha
+--
+data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8  -- Luminance
+                         {-# UNPACK #-} !Pixel8  -- Alpha value
+              deriving (Eq, Show)
+
+-- | Pixel type storing Luminance (Y) and alpha information
+-- on 16 bits.
+-- Value are stored in the following order :
+--
+--  * Luminance
+--
+--  * Alpha
+--
+data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16  -- Luminance
+                           {-# UNPACK #-} !Pixel16  -- Alpha value
+              deriving (Eq, Show)
+
+-- | Pixel type storing classic pixel on 8 bits
+-- Value are stored in the following order :
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red
+                           {-# UNPACK #-} !Pixel8 -- Green
+                           {-# UNPACK #-} !Pixel8 -- Blue
+               deriving (Eq, Show)
+
+-- | Pixel type storing pixels on 16 bits
+-- Value are stored in the following order :
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red
+                             {-# UNPACK #-} !Pixel16 -- Green
+                             {-# UNPACK #-} !Pixel16 -- Blue
+               deriving (Eq, Show)
+
+-- | Pixel type storing HDR pixel on 32 bits float
+-- Value are stored in the following order :
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red
+                           {-# UNPACK #-} !PixelF -- Green
+                           {-# UNPACK #-} !PixelF -- Blue
+               deriving (Eq, Show)
+
+-- | Pixel storing data in the YCbCr colorspace,
+-- value are stored in the following order :
+--
+--  * Y (luminance)
+--
+--  * Cr
+--
+--  * Cb
+--
+data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance
+                               {-# UNPACK #-} !Pixel8 -- Cr red difference
+                               {-# UNPACK #-} !Pixel8 -- Cb blue difference
+                 deriving (Eq, Show)
+
+-- | Pixel storing data in the CMYK colorspace. value
+-- are stored in the following order :
+--
+--   * Cyan
+--
+--   * Magenta
+--
+--   * Yellow
+--
+--   * Black
+--
+data PixelCMYK8 = PixelCMYK8 {-# UNPACK #-} !Pixel8 -- Cyan
+                             {-# UNPACK #-} !Pixel8 -- Magenta
+                             {-# UNPACK #-} !Pixel8 -- Yellow
+                             {-# UNPACK #-} !Pixel8 -- Black
+                 deriving (Eq, Show)
+
+-- | Pixel storing data in the CMYK colorspace. value
+-- are stored in the following order :
+--
+--   * Cyan
+--
+--   * Magenta
+--
+--   * Yellow
+--
+--   * Black
+--
+data PixelCMYK16 = PixelCMYK16 {-# UNPACK #-} !Pixel16 -- Cyan
+                               {-# UNPACK #-} !Pixel16 -- Magenta
+                               {-# UNPACK #-} !Pixel16 -- Yellow
+                               {-# UNPACK #-} !Pixel16 -- Black
+                 deriving (Eq, Show)
+
+
+-- | Pixel type storing a classic pixel, with an alpha component.
+-- Values are stored in the following order
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+--  * Alpha
+--
+data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Pixel8 -- Red
+                             {-# UNPACK #-} !Pixel8 -- Green
+                             {-# UNPACK #-} !Pixel8 -- Blue
+                             {-# UNPACK #-} !Pixel8 -- Alpha
+                deriving (Eq, Show)
+
+-- | Pixel type storing a RGB information with an alpha
+-- channel on 16 bits.
+-- Values are stored in the following order
+--
+--  * Red
+--
+--  * Green
+--
+--  * Blue
+--
+--  * Alpha
+--
+data PixelRGBA16 = PixelRGBA16 {-# UNPACK #-} !Pixel16 -- Red
+                               {-# UNPACK #-} !Pixel16 -- Green
+                               {-# UNPACK #-} !Pixel16 -- Blue
+                               {-# UNPACK #-} !Pixel16 -- Alpha
+                deriving (Eq, Show)
+
+-- | Definition of pixels used in images. Each pixel has a color space, and a representative
+-- component (Word8 or Float).
+class ( Storable (PixelBaseComponent a)
+      , Num (PixelBaseComponent a), Eq a ) => Pixel a where
+    -- | Type of the pixel component, "classical" images
+    -- would have Word8 type as their PixelBaseComponent,
+    -- HDR image would have Float for instance
+    type PixelBaseComponent a :: *
+
+    -- | Return the number of component of the pixel
+    componentCount :: a -> Int
+
+    -- | Apply a function to all color component of a pixel.
+    colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
+
+    -- | Calculate the index for the begining of the pixel
+    pixelBaseIndex :: Image a -> Int -> Int -> Int
+    pixelBaseIndex (Image { imageWidth = w }) x y =
+            (x + y * w) * componentCount (undefined :: a)
+
+    -- | Calculate theindex for the begining of the pixel at position x y
+    mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int
+    mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y =
+            (x + y * w) * componentCount (undefined :: a)
+
+    -- | Extract a pixel at a given position, (x, y), the origin
+    -- is assumed to be at the corner top left, positive y to the
+    -- bottom of the image
+    pixelAt :: Image a -> Int -> Int -> a
+
+    -- | Same as pixelAt but for mutable images.
+    readPixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> m a
+
+    -- | Write a pixel in a mutable image at position x y
+    writePixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> a -> m ()
+
+    -- | Unsafe version of pixelAt, read a pixel at the given
+    -- index without bound checking (if possible).
+    -- The index is expressed in number (PixelBaseComponent a)
+    unsafePixelAt :: V.Vector (PixelBaseComponent a) -> Int -> a
+
+    -- | Unsafe version of readPixel,  read a pixel at the given
+    -- position without bound checking (if possible). The index
+    -- is expressed in number (PixelBaseComponent a)
+    unsafeReadPixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> m a
+
+    -- | Unsafe version of writePixel, write a pixel at the
+    -- given position without bound checking. This can be _really_ unsafe.
+    -- The index is expressed in number (PixelBaseComponent a)
+    unsafeWritePixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m ()
+
+
+-- | Implement upcasting for pixel types
+-- Minimal declaration declaration `promotePixel`
+-- It is strongly recommanded to overload promoteImage to keep
+-- performance acceptable
+class (Pixel a, Pixel b) => ColorConvertible a b where
+    -- | Convert a pixel type to another pixel type. This
+    -- operation should never loss any data.
+    promotePixel :: a -> b
+
+    -- | Change the underlying pixel type of an image by performing a full copy
+    -- of it.
+    promoteImage :: Image a -> Image b
+    promoteImage = pixelMap promotePixel
+
+-- | This class abstract colorspace conversion. This
+-- conversion can be lossy, which ColorConvertible cannot
+class (Pixel a, Pixel b) => ColorSpaceConvertible a b where
+    -- | Pass a pixel from a colorspace (say RGB) to the second one
+    -- (say YCbCr)
+    convertPixel :: a -> b
+
+    -- | Helper function to convert a whole image by taking a
+    -- copy it.
+    convertImage :: Image a -> Image b
+    convertImage = pixelMap convertPixel
+
+-- | Create an image given a function to generate pixels.
+-- The function will receive value from 0 to width-1 for the x parameter
+-- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper
+-- left corner of the image, and (width-1, height-1) the lower right corner.
+--
+-- for example, to create a small gradient image :
+--
+-- > imageCreator :: String -> Image PixelRGB8
+-- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300
+-- >    where pixelRenderer x y = PixelRGB8 x y 128
+--
+generateImage :: forall a. (Pixel a)
+              => (Int -> Int -> a)  -- ^ Generating function, with `x` and `y` params.
+              -> Int        -- ^ Width in pixels
+              -> Int        -- ^ Height in pixels
+              -> Image a
+generateImage f w h = Image { imageWidth = w, imageHeight = h, imageData = generated }
+  where compCount = componentCount (undefined :: a)
+        generated = runST $ do
+            arr <- M.new (w * h * compCount)
+            let lineGenerator _ y | y >= h = return ()
+                lineGenerator lineIdx y = column lineIdx 0
+                  where column idx x | x >= w = lineGenerator idx $ y + 1
+                        column idx x = do
+                            unsafeWritePixel arr idx $ f x y
+                            column (idx + compCount) $ x + 1
+
+            lineGenerator 0 0
+            V.unsafeFreeze arr
+
+-- | Create an image using a monadic initializer function.
+-- The function will receive value from 0 to width-1 for the x parameter
+-- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper
+-- left corner of the image, and (width-1, height-1) the lower right corner.
+--
+-- The function is called for each pixel in the line from left to right (0 to width - 1)
+-- and for each line (0 to height - 1).
+withImage :: forall m pixel. (Pixel pixel, PrimMonad m)
+          => Int                     -- ^ Image width
+          -> Int                     -- ^ Image height
+          -> (Int -> Int -> m pixel) -- ^ Generating functions
+          -> m (Image pixel)
+withImage width height pixelGenerator = do
+  let pixelComponentCount = componentCount (undefined :: pixel)
+  arr <- M.new (width * height * pixelComponentCount)
+  let mutImage = MutableImage
+        { mutableImageWidth = width
+        , mutableImageHeight = height
+        , mutableImageData = arr
+        }
+
+  let pixelPositions = [(x, y) | y <- [0 .. height-1], x <- [0..width-1]]
+  sequence_ [pixelGenerator x y >>= unsafeWritePixel arr idx
+                        | ((x,y), idx) <- zip pixelPositions [0, pixelComponentCount ..]]
+  unsafeFreezeImage mutImage
+
+-- | Create an image given a function to generate pixels.
+-- The function will receive value from 0 to width-1 for the x parameter
+-- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper
+-- left corner of the image, and (width-1, height-1) the lower right corner.
+--
+-- the acc parameter is a user defined one.
+--
+-- The function is called for each pixel in the line from left to right (0 to width - 1)
+-- and for each line (0 to height - 1).
+generateFoldImage :: forall a acc. (Pixel a)
+                  => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y
+                  -> acc        -- ^ Initial state
+                  -> Int        -- ^ Width in pixels
+                  -> Int        -- ^ Height in pixels
+                  -> (acc, Image a)
+generateFoldImage f intialAcc w h =
+ (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated })
+  where compCount = componentCount (undefined :: a)
+        (finalState, generated) = runST $ do
+            arr <- M.new (w * h * compCount)
+            let mutImage = MutableImage {
+                                mutableImageWidth = w,
+                                mutableImageHeight = h,
+                                mutableImageData = arr }
+            foldResult <- foldM (\acc (x,y) -> do
+                    let (acc', px) = f acc x y
+                    writePixel mutImage x y px
+                    return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]]
+
+            frozen <- V.unsafeFreeze arr
+            return (foldResult, frozen)
+
+-- | Fold over the pixel of an image with a raster scan order :
+-- from top to bottom, left to right
+{-# INLINE pixelFold #-}
+pixelFold :: (Pixel pixel) 
+          => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc
+pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) =
+  lineFold 
+    where pixelFolder y acc x = f acc x y $ pixelAt img x y
+          columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1]
+          lineFold = foldl' columnFold initialAccumulator [0 .. h - 1]
+          
+-- | `map` equivalent for an image, working at the pixel level.
+-- Little example : a brightness function for an rgb image
+--
+-- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8
+-- > brightnessRGB8 add = pixelMap brightFunction
+-- >      where up v = fromIntegral (fromIntegral v + add)
+-- >            brightFunction (PixelRGB8 r g b) =
+-- >                    PixelRGB8 (up r) (up g) (up b)
+--
+pixelMap :: forall a b. (Pixel a, Pixel b)
+         => (a -> b) -> Image a -> Image b
+{-# RULES "pixelMap fusion" forall g f. pixelMap g . pixelMap f = pixelMap (g . f) #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-}
+{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-}
+pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } =
+  Image w h pixels
+    where sourceComponentCount = componentCount (undefined :: a)
+          destComponentCount = componentCount (undefined :: b)
+
+          pixels = runST $ do
+            newArr <- M.new (w * h * destComponentCount)
+            let lineMapper _ _ y | y >= h = return ()
+                lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0
+                  where colMapper readIdx writeIdx x
+                            | x >= w = lineMapper readIdx writeIdx $ y + 1
+                            | otherwise = do
+                                unsafeWritePixel newArr writeIdx . f $ unsafePixelAt vec readIdx
+                                colMapper (readIdx + sourceComponentCount)
+                                          (writeIdx + destComponentCount)
+                                          (x + 1)
+            lineMapper 0 0 0
+
+            -- unsafeFreeze avoids making a second copy and it will be
+            -- safe because newArray can't be referenced as a mutable array
+            -- outside of this where block
+            V.unsafeFreeze newArr
+
+-- | Helper class to help extract a luma plane out
+-- of an image or a pixel
+class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where
+    -- | Compute the luminance part of a pixel
+    computeLuma      :: a -> (PixelBaseComponent a)
+
+    -- | Extract a luma plane out of an image. This
+    -- method is in the typeclass to help performant
+    -- implementation.
+    --
+    -- > jpegToGrayScale :: FilePath -> FilePath -> IO ()
+    -- > jpegToGrayScale source dest 
+    extractLumaPlane :: Image a -> Image (PixelBaseComponent a)
+    extractLumaPlane = pixelMap computeLuma
+
+instance LumaPlaneExtractable Pixel8 where
+    {-# INLINE computeLuma #-}
+    computeLuma = id
+    extractLumaPlane = id
+
+instance LumaPlaneExtractable Pixel16 where
+    {-# INLINE computeLuma #-}
+    computeLuma = id
+    extractLumaPlane = id
+
+instance LumaPlaneExtractable PixelF where
+    {-# INLINE computeLuma #-}
+    computeLuma = id
+    extractLumaPlane = id
+
+instance LumaPlaneExtractable PixelRGBF where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGBF r g b) =
+        0.3 * r + 0.59 * g + 0.11 * b
+
+instance LumaPlaneExtractable PixelRGBA8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r +
+                                             0.59 * toRational g +
+                                             0.11 * toRational b
+
+instance LumaPlaneExtractable PixelYCbCr8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelYCbCr8 y _ _) = y
+    extractLumaPlane = extractComponent PlaneLuma
+
+-- | Free promotion for identic pixel types
+instance (Pixel a) => ColorConvertible a a where
+    {-# INLINE promotePixel #-}
+    promotePixel = id
+
+    {-# INLINE promoteImage #-}
+    promoteImage = id
+
+{-# INLINE (.!!!.) #-}
+(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a
+(.!!!.) = M.read -- unsafeRead
+
+{-# INLINE (.<-.) #-}
+(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m ()
+(.<-.)  = M.write -- unsafeWrite
+
+--------------------------------------------------
+----            Pixel8 instances
+--------------------------------------------------
+instance Pixel Pixel8 where
+    type PixelBaseComponent Pixel8 = Word8
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+
+    componentCount _ = 1
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    unsafePixelAt = V.unsafeIndex
+    unsafeReadPixel = M.unsafeRead
+    unsafeWritePixel = M.unsafeWrite
+
+instance ColorConvertible Pixel8 PixelYA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelYA8 c 255
+
+instance ColorConvertible Pixel8 PixelF where
+    {-# INLINE promotePixel #-}
+    promotePixel c = fromIntegral c / 255.0
+
+instance ColorConvertible Pixel8 Pixel16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = fromIntegral c `unsafeShiftL` 8
+
+instance ColorConvertible Pixel8 PixelRGB8 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGB8 c c c
+
+instance ColorConvertible Pixel8 PixelRGBA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGBA8 c c c 255
+
+--------------------------------------------------
+----            Pixel16 instances
+--------------------------------------------------
+instance Pixel Pixel16 where
+    type PixelBaseComponent Pixel16 = Word16
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+
+    componentCount _ = 1
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    unsafePixelAt = V.unsafeIndex
+    unsafeReadPixel = M.unsafeRead
+    unsafeWritePixel = M.unsafeWrite
+
+instance ColorConvertible Pixel16 PixelYA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelYA16 c maxBound
+
+instance ColorConvertible Pixel16 PixelRGB16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGB16 c c c
+
+instance ColorConvertible Pixel16 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel c = PixelRGBA16 c c c maxBound
+
+--------------------------------------------------
+----            PixelF instances
+--------------------------------------------------
+instance Pixel PixelF where
+    type PixelBaseComponent PixelF = Float
+
+    {-# INLINE colorMap #-}
+    colorMap f = f
+    componentCount _ = 1
+    pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w)
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.read` mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y =
+        arr `M.write` mutablePixelBaseIndex image x y
+
+    unsafePixelAt = V.unsafeIndex
+    unsafeReadPixel = M.unsafeRead
+    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)
+
+--------------------------------------------------
+----            PixelYA8 instances
+--------------------------------------------------
+instance Pixel PixelYA8 where
+    type PixelBaseComponent PixelYA8 = Word8
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a)
+    componentCount _ = 2
+    pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0))
+                                                             (arr ! (baseIdx + 1))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        yv <- arr .!!!. baseIdx
+        av <- arr .!!!. (baseIdx + 1)
+        return $ PixelYA8 yv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) yv
+        (arr .<-. (baseIdx + 1)) av
+
+    unsafePixelAt v idx = 
+        PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1)
+    unsafeReadPixel vec idx =
+        PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1)
+    unsafeWritePixel v idx (PixelYA8 y a) =
+        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a
+
+instance ColorConvertible PixelYA8 PixelRGB8 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA8 y _) = PixelRGB8 y y y
+
+instance ColorConvertible PixelYA8 PixelRGBA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a
+
+instance ColorPlane PixelYA8 PlaneLuma where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelYA8 PlaneAlpha where
+    toComponentIndex _ _ = 1
+
+instance TransparentPixel PixelYA8 Pixel8 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelYA8 y _) = y
+
+instance LumaPlaneExtractable PixelYA8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelYA8 y _) = y
+    extractLumaPlane = extractComponent PlaneLuma
+
+--------------------------------------------------
+----            PixelYA16 instances
+--------------------------------------------------
+instance Pixel PixelYA16 where
+    type PixelBaseComponent PixelYA16 = Word16
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a)
+    componentCount _ = 2
+    pixelAt image@(Image { imageData = arr }) x y = PixelYA16 (arr ! (baseIdx + 0))
+                                                              (arr ! (baseIdx + 1))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        yv <- arr .!!!. baseIdx
+        av <- arr .!!!. (baseIdx + 1)
+        return $ PixelYA16 yv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA16 yv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) yv
+        (arr .<-. (baseIdx + 1)) av
+
+    unsafePixelAt v idx = 
+        PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1)
+    unsafeReadPixel vec idx =
+        PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1)
+    unsafeWritePixel v idx (PixelYA16 y a) =
+        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a
+
+instance ColorConvertible PixelYA16 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a
+
+instance ColorPlane PixelYA16 PlaneLuma where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelYA16 PlaneAlpha where
+    toComponentIndex _ _ = 1
+
+instance TransparentPixel PixelYA16 Pixel16 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelYA16 y _) = y
+--------------------------------------------------
+----            PixelRGBF instances
+--------------------------------------------------
+instance Pixel PixelRGBF where
+    type PixelBaseComponent PixelRGBF = PixelF
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b)
+
+    componentCount _ = 3
+
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0))
+                                                              (arr ! (baseIdx + 1))
+                                                              (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr .!!!. baseIdx
+        gv <- arr .!!!. (baseIdx + 1)
+        bv <- arr .!!!. (baseIdx + 2)
+        return $ PixelRGBF rv gv bv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) rv
+        (arr .<-. (baseIdx + 1)) gv
+        (arr .<-. (baseIdx + 2)) bv
+
+    unsafePixelAt v idx = 
+        PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    unsafeReadPixel vec idx =
+        PixelRGBF `liftM` M.unsafeRead vec idx
+                  `ap` M.unsafeRead vec (idx + 1)
+                  `ap` M.unsafeRead vec (idx + 2)
+    unsafeWritePixel v idx (PixelRGBF r g b) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+
+instance ColorPlane PixelRGBF PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGBF PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGBF PlaneBlue where
+    toComponentIndex _ _ = 2
+
+--------------------------------------------------
+----            PixelRGB16 instances
+--------------------------------------------------
+instance Pixel PixelRGB16 where
+    type PixelBaseComponent PixelRGB16 = Pixel16
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b)
+
+    componentCount _ = 3
+
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGB16 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr .!!!. baseIdx
+        gv <- arr .!!!. (baseIdx + 1)
+        bv <- arr .!!!. (baseIdx + 2)
+        return $ PixelRGB16 rv gv bv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB16 rv gv bv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) rv
+        (arr .<-. (baseIdx + 1)) gv
+        (arr .<-. (baseIdx + 2)) bv
+
+    unsafePixelAt v idx = 
+        PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    unsafeReadPixel vec idx =
+        PixelRGB16 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+    unsafeWritePixel v idx (PixelRGB16 r g b) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+
+instance ColorPlane PixelRGB16 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGB16 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGB16 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance ColorSpaceConvertible PixelRGB16 PixelCMYK16 where
+    {-# INLINE convertPixel #-}
+    convertPixel (PixelRGB16 r g b) = integralRGBToCMYK PixelCMYK16 (r, g, b)
+
+instance ColorConvertible PixelRGB16 PixelRGBA16 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB16 r g b) = PixelRGBA16 r g b maxBound
+
+instance LumaPlaneExtractable PixelRGB16 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGB16 r g b) = floor $ 0.3 * toRational r +
+                                             0.59 * toRational g +
+                                             0.11 * toRational b
+--------------------------------------------------
+----            PixelRGB8 instances
+--------------------------------------------------
+instance Pixel PixelRGB8 where
+    type PixelBaseComponent PixelRGB8 = Word8
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b)
+
+    componentCount _ = 3
+
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0))
+                                                              (arr ! (baseIdx + 1))
+                                                              (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr .!!!. baseIdx
+        gv <- arr .!!!. (baseIdx + 1)
+        bv <- arr .!!!. (baseIdx + 2)
+        return $ PixelRGB8 rv gv bv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) rv
+        (arr .<-. (baseIdx + 1)) gv
+        (arr .<-. (baseIdx + 2)) bv
+
+    unsafePixelAt v idx = 
+        PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    unsafeReadPixel vec idx =
+        PixelRGB8 `liftM` M.unsafeRead vec idx
+                  `ap` M.unsafeRead vec (idx + 1)
+                  `ap` M.unsafeRead vec (idx + 2)
+    unsafeWritePixel v idx (PixelRGB8 r g b) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+
+instance ColorConvertible PixelRGB8 PixelRGBA8 where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b maxBound
+
+instance ColorConvertible PixelRGB8 PixelRGBF where
+    {-# INLINE promotePixel #-}
+    promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b)
+        where toF v = fromIntegral v / 255.0
+
+instance ColorPlane PixelRGB8 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGB8 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGB8 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance LumaPlaneExtractable PixelRGB8 where
+    {-# INLINE computeLuma #-}
+    computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r +
+                                            0.59 * toRational g +
+                                            0.11 * toRational b
+
+--------------------------------------------------
+----            PixelRGBA8 instances
+--------------------------------------------------
+instance Pixel PixelRGBA8 where
+    type PixelBaseComponent PixelRGBA8 = Word8
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a)
+
+    componentCount _ = 4
+
+    pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+                                                               (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr .!!!. baseIdx
+        gv <- arr .!!!. (baseIdx + 1)
+        bv <- arr .!!!. (baseIdx + 2)
+        av <- arr .!!!. (baseIdx + 3)
+        return $ PixelRGBA8 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) rv
+        (arr .<-. (baseIdx + 1)) gv
+        (arr .<-. (baseIdx + 2)) bv
+        (arr .<-. (baseIdx + 3)) av
+
+    unsafePixelAt v idx = 
+        PixelRGBA8 (V.unsafeIndex v idx)
+                   (V.unsafeIndex v $ idx + 1)
+                   (V.unsafeIndex v $ idx + 2)
+                   (V.unsafeIndex v $ idx + 3)
+    unsafeReadPixel vec idx =
+        PixelRGBA8 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+                   `ap` M.unsafeRead vec (idx + 3)
+    unsafeWritePixel v idx (PixelRGBA8 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+instance ColorPlane PixelRGBA8 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGBA8 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGBA8 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelRGBA8 PlaneAlpha where
+    toComponentIndex _ _ = 3
+
+--------------------------------------------------
+----            PixelRGBA16 instances
+--------------------------------------------------
+instance Pixel PixelRGBA16 where
+    type PixelBaseComponent PixelRGBA16 = Pixel16
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a)
+
+    componentCount _ = 4
+
+    pixelAt image@(Image { imageData = arr }) x y =
+                PixelRGBA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1))
+                            (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr .!!!. baseIdx
+        gv <- arr .!!!. (baseIdx + 1)
+        bv <- arr .!!!. (baseIdx + 2)
+        av <- arr .!!!. (baseIdx + 3)
+        return $ PixelRGBA16 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA16 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) rv
+        (arr .<-. (baseIdx + 1)) gv
+        (arr .<-. (baseIdx + 2)) bv
+        (arr .<-. (baseIdx + 3)) av
+
+    unsafePixelAt v idx = 
+        PixelRGBA16 (V.unsafeIndex v idx)
+                    (V.unsafeIndex v $ idx + 1)
+                    (V.unsafeIndex v $ idx + 2)
+                    (V.unsafeIndex v $ idx + 3)
+    unsafeReadPixel vec idx =
+        PixelRGBA16 `liftM` M.unsafeRead vec idx
+                    `ap` M.unsafeRead vec (idx + 1)
+                    `ap` M.unsafeRead vec (idx + 2)
+                    `ap` M.unsafeRead vec (idx + 3)
+    unsafeWritePixel v idx (PixelRGBA16 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+
+instance TransparentPixel PixelRGBA16 PixelRGB16 where
+    {-# INLINE dropTransparency #-}
+    dropTransparency (PixelRGBA16 r g b _) = PixelRGB16 r g b
+
+instance ColorPlane PixelRGBA16 PlaneRed where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelRGBA16 PlaneGreen where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelRGBA16 PlaneBlue where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelRGBA16 PlaneAlpha where
+    toComponentIndex _ _ = 3
+
+--------------------------------------------------
+----            PixelYCbCr8 instances
+--------------------------------------------------
+instance Pixel PixelYCbCr8 where
+    type PixelBaseComponent PixelYCbCr8 = Word8
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr)
+    componentCount _ = 3
+    pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0))
+                                                                (arr ! (baseIdx + 1))
+                                                                (arr ! (baseIdx + 2))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        yv <- arr .!!!. baseIdx
+        cbv <- arr .!!!. (baseIdx + 1)
+        crv <- arr .!!!. (baseIdx + 2)
+        return $ PixelYCbCr8 yv cbv crv
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) yv
+        (arr .<-. (baseIdx + 1)) cbv
+        (arr .<-. (baseIdx + 2)) crv
+
+    unsafePixelAt v idx = 
+        PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2)
+    unsafeReadPixel vec idx =
+        PixelYCbCr8 `liftM` M.unsafeRead vec idx
+                    `ap` M.unsafeRead vec (idx + 1)
+                    `ap` M.unsafeRead vec (idx + 2)
+    unsafeWritePixel v idx (PixelYCbCr8 y cb cr) =
+        M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb
+                              >> M.unsafeWrite v (idx + 2) cr
+
+instance (Pixel a) => ColorSpaceConvertible a a where
+    convertPixel = id
+    convertImage = id
+
+scaleBits, oneHalf :: Int
+scaleBits = 16
+oneHalf = 1 `unsafeShiftL` (scaleBits - 1)
+
+fix :: Float -> Int
+fix x = floor $ x * fromIntegral ((1 :: Int) `unsafeShiftL` scaleBits) + 0.5
+
+
+rYTab, gYTab, bYTab, rCbTab, gCbTab, bCbTab, gCrTab, bCrTab :: V.Vector Int
+rYTab = V.fromListN 256 [fix 0.29900 * i | i <- [0..255] ]
+gYTab = V.fromListN 256 [fix 0.58700 * i | i <- [0..255] ]
+bYTab = V.fromListN 256 [fix 0.11400 * i + oneHalf | i <- [0..255] ]
+rCbTab = V.fromListN 256 [(- fix 0.16874) * i | i <- [0..255] ]
+gCbTab = V.fromListN 256 [(- fix 0.33126) * i | i <- [0..255] ]
+bCbTab = V.fromListN 256 [fix 0.5 * i + (128 `unsafeShiftL` scaleBits) + oneHalf - 1| i <- [0..255] ]
+gCrTab = V.fromListN 256 [(- fix 0.41869) * i | i <- [0..255] ]
+bCrTab = V.fromListN 256 [(- fix 0.08131) * i | i <- [0..255] ]
+
+
+instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where
+    {-# INLINE convertPixel #-}
+    convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (fromIntegral y) (fromIntegral cb) (fromIntegral cr)
+      where ri = fromIntegral r
+            gi = fromIntegral g
+            bi = fromIntegral b
+
+            y  = (rYTab `V.unsafeIndex` ri + gYTab `V.unsafeIndex` gi + bYTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits
+            cb = (rCbTab `V.unsafeIndex` ri + gCbTab `V.unsafeIndex` gi + bCbTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits
+            cr = (bCbTab `V.unsafeIndex` ri + gCrTab `V.unsafeIndex` gi + bCrTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits
+
+    convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData
+        where maxi = w * h
+
+              rY  = fix 0.29900
+              gY  = fix 0.58700
+              bY  = fix 0.11400
+              rCb = (- fix 0.16874)
+              gCb = (- fix 0.33126)
+              bCb = fix 0.5
+              gCr = (- fix 0.41869)
+              bCr = (- fix 0.08131)
+
+              newData = runST $ do
+                block <- M.new $ maxi * 3
+                let traductor _ idx | idx >= maxi = return block
+                    traductor readIdx idx = do
+                        let ri = fromIntegral $ d `V.unsafeIndex` readIdx
+                            gi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1)
+                            bi = fromIntegral $ d `V.unsafeIndex` (readIdx + 2)
+
+                            y  = (rY * ri + gY * gi + bY * bi + oneHalf) `unsafeShiftR` scaleBits
+                            cb = (rCb * ri + gCb * gi + bCb * bi + (128 `unsafeShiftL` scaleBits) + oneHalf - 1) `unsafeShiftR` scaleBits
+                            cr = (bCb * ri + (128 `unsafeShiftL` scaleBits) + oneHalf - 1+ gCr * gi + bCr * bi) `unsafeShiftR` scaleBits
+
+                        (block `M.unsafeWrite` (readIdx + 0)) $ fromIntegral y
+                        (block `M.unsafeWrite` (readIdx + 1)) $ fromIntegral cb
+                        (block `M.unsafeWrite` (readIdx + 2)) $ fromIntegral cr
+                        traductor (readIdx + 3) (idx + 1)
+
+                traductor 0 0 >>= V.freeze
+
+crRTab, cbBTab, crGTab, cbGTab :: V.Vector Int
+crRTab = V.fromListN 256 [(fix 1.40200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]]
+cbBTab = V.fromListN 256 [(fix 1.77200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]]
+crGTab = V.fromListN 256 [negate (fix 0.71414) * x | x <- [-128 .. 127]]
+cbGTab = V.fromListN 256 [negate (fix 0.34414) * x + oneHalf | x <- [-128 .. 127]]
+
+instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where
+    {-# INLINE convertPixel #-}
+    convertPixel (PixelYCbCr8 y cb cr) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)
+        where clampWord8 = fromIntegral . max 0 . min 255
+              yi = fromIntegral y
+              cbi = fromIntegral cb
+              cri = fromIntegral cr
+
+              r = yi +  crRTab `V.unsafeIndex` cri
+              g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits
+              b = yi +  cbBTab `V.unsafeIndex` cbi
+
+    convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData
+        where maxi = w * h
+              clampWord8 v | v < 0 = 0
+                           | v > 255 = 255
+                           | otherwise = fromIntegral v
+
+              newData = runST $ do
+                block <- M.new $ maxi * 3
+                let traductor _ idx | idx >= maxi = return block
+                    traductor readIdx idx = do
+                        let yi =  fromIntegral $ d `V.unsafeIndex` readIdx
+                            cbi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1)
+                            cri = fromIntegral $ d `V.unsafeIndex` (readIdx + 2)
+
+                            r = yi +  crRTab `V.unsafeIndex` cri
+                            g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits
+                            b = yi +  cbBTab `V.unsafeIndex` cbi
+
+                        (block `M.unsafeWrite` (readIdx + 0)) $ clampWord8 r
+                        (block `M.unsafeWrite` (readIdx + 1)) $ clampWord8 g
+                        (block `M.unsafeWrite` (readIdx + 2)) $ clampWord8 b
+                        traductor (readIdx + 3) (idx + 1)
+
+                traductor 0 0 >>= V.freeze
+
+instance ColorPlane PixelYCbCr8 PlaneLuma where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelYCbCr8 PlaneCb where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelYCbCr8 PlaneCr where
+    toComponentIndex _ _ = 2
+
+--------------------------------------------------
+----            PixelCMYK8 instances
+--------------------------------------------------
+instance Pixel PixelCMYK8 where
+    type PixelBaseComponent PixelCMYK8 = Word8
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelCMYK8 c m y k) = PixelCMYK8 (f c) (f m) (f y) (f k)
+
+    componentCount _ = 4
+
+    pixelAt image@(Image { imageData = arr }) x y = PixelCMYK8 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+                                                               (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr .!!!. baseIdx
+        gv <- arr .!!!. (baseIdx + 1)
+        bv <- arr .!!!. (baseIdx + 2)
+        av <- arr .!!!. (baseIdx + 3)
+        return $ PixelCMYK8 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK8 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) rv
+        (arr .<-. (baseIdx + 1)) gv
+        (arr .<-. (baseIdx + 2)) bv
+        (arr .<-. (baseIdx + 3)) av
+
+    unsafePixelAt v idx = 
+        PixelCMYK8 (V.unsafeIndex v idx)
+                   (V.unsafeIndex v $ idx + 1)
+                   (V.unsafeIndex v $ idx + 2)
+                   (V.unsafeIndex v $ idx + 3)
+    unsafeReadPixel vec idx =
+        PixelCMYK8 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+                   `ap` M.unsafeRead vec (idx + 3)
+    unsafeWritePixel v idx (PixelCMYK8 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where
+  convertPixel (PixelCMYK8 c m y k) =
+      PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b)
+    where 
+          clampWord8 = fromIntegral . (`unsafeShiftR` 8)
+          ik :: Int
+          ik = 255 - fromIntegral k
+
+          r = (255 - fromIntegral c) * ik
+          g = (255 - fromIntegral m) * ik
+          b = (255 - fromIntegral y) * ik
+
+
+{-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b)
+                                 -> (Word8, Word8, Word8) -> b #-}
+{-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b)
+                                 -> (Word16, Word16, Word16) -> b #-}
+integralRGBToCMYK :: (Bounded a, Integral a)
+                  => (a -> a -> a -> a -> b)    -- ^ Pixel building function
+                  -> (a, a, a)                  -- ^ RGB sample
+                  -> b                          -- ^ Resulting sample
+integralRGBToCMYK build (r, g, b) =
+  build (clamp c) (clamp m) (clamp y) (fromIntegral kInt)
+    where maxi = maxBound
+
+          ir = fromIntegral $ maxi - r :: Int
+          ig = fromIntegral $ maxi - g
+          ib = fromIntegral $ maxi - b
+
+          kInt = minimum [ir, ig, ib]
+          ik = fromIntegral maxi - kInt
+
+          c = (ir - kInt) `div` ik
+          m = (ig - kInt) `div` ik
+          y = (ib - kInt) `div` ik
+
+          clamp = fromIntegral . (max 0)
+
+instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where
+  convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b)
+
+instance ColorPlane PixelCMYK8 PlaneCyan where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelCMYK8 PlaneMagenta where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelCMYK8 PlaneYellow where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelCMYK8 PlaneBlack where
+    toComponentIndex _ _ = 3
+
+--------------------------------------------------
+----            PixelCMYK16 instances
+--------------------------------------------------
+instance Pixel PixelCMYK16 where
+    type PixelBaseComponent PixelCMYK16 = Word16
+
+    {-# INLINE colorMap #-}
+    colorMap f (PixelCMYK16 c m y k) = PixelCMYK16 (f c) (f m) (f y) (f k)
+
+    componentCount _ = 4
+
+    pixelAt image@(Image { imageData = arr }) x y = PixelCMYK16 (arr ! (baseIdx + 0))
+                                                               (arr ! (baseIdx + 1))
+                                                               (arr ! (baseIdx + 2))
+                                                               (arr ! (baseIdx + 3))
+        where baseIdx = pixelBaseIndex image x y
+
+    readPixel image@(MutableImage { mutableImageData = arr }) x y = do
+        rv <- arr .!!!. baseIdx
+        gv <- arr .!!!. (baseIdx + 1)
+        bv <- arr .!!!. (baseIdx + 2)
+        av <- arr .!!!. (baseIdx + 3)
+        return $ PixelCMYK16 rv gv bv av
+        where baseIdx = mutablePixelBaseIndex image x y
+
+    writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK16 rv gv bv av) = do
+        let baseIdx = mutablePixelBaseIndex image x y
+        (arr .<-. (baseIdx + 0)) rv
+        (arr .<-. (baseIdx + 1)) gv
+        (arr .<-. (baseIdx + 2)) bv
+        (arr .<-. (baseIdx + 3)) av
+
+    unsafePixelAt v idx = 
+        PixelCMYK16 (V.unsafeIndex v idx)
+                   (V.unsafeIndex v $ idx + 1)
+                   (V.unsafeIndex v $ idx + 2)
+                   (V.unsafeIndex v $ idx + 3)
+    unsafeReadPixel vec idx =
+        PixelCMYK16 `liftM` M.unsafeRead vec idx
+                   `ap` M.unsafeRead vec (idx + 1)
+                   `ap` M.unsafeRead vec (idx + 2)
+                   `ap` M.unsafeRead vec (idx + 3)
+    unsafeWritePixel v idx (PixelCMYK16 r g b a) =
+        M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g
+                              >> M.unsafeWrite v (idx + 2) b
+                              >> M.unsafeWrite v (idx + 3) a
+
+instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where
+  convertPixel (PixelCMYK16 c m y k) =
+      PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b)
+    where 
+          clampWord16 = fromIntegral . (`unsafeShiftR` 16)
+          ik :: Int
+          ik = 65535 - fromIntegral k
+
+          r = (65535 - fromIntegral c) * ik
+          g = (65535 - fromIntegral m) * ik
+          b = (65535 - fromIntegral y) * ik
+
+instance ColorPlane PixelCMYK16 PlaneCyan where
+    toComponentIndex _ _ = 0
+
+instance ColorPlane PixelCMYK16 PlaneMagenta where
+    toComponentIndex _ _ = 1
+
+instance ColorPlane PixelCMYK16 PlaneYellow where
+    toComponentIndex _ _ = 2
+
+instance ColorPlane PixelCMYK16 PlaneBlack where
+    toComponentIndex _ _ = 3
 
 -- | Perform a gamma correction for an image with HDR pixels.
 gammaCorrection :: PixelF          -- ^ Gamma value, should be between 0.5 and 3.0