diff --git a/Codec/Picture.hs b/Codec/Picture.hs --- a/Codec/Picture.hs +++ b/Codec/Picture.hs @@ -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 diff --git a/Codec/Picture/BitWriter.hs b/Codec/Picture/BitWriter.hs --- a/Codec/Picture/BitWriter.hs +++ b/Codec/Picture/BitWriter.hs @@ -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 diff --git a/Codec/Picture/Bitmap.hs b/Codec/Picture/Bitmap.hs --- a/Codec/Picture/Bitmap.hs +++ b/Codec/Picture/Bitmap.hs @@ -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 diff --git a/Codec/Picture/ConvGraph.hs b/Codec/Picture/ConvGraph.hs --- a/Codec/Picture/ConvGraph.hs +++ b/Codec/Picture/ConvGraph.hs @@ -1,9 +1,9 @@ --- $graph --- --- The following graph describe the differents way to convert between pixel types, --- --- * Nodes describe pixel type --- --- * Arrows describe functions --- --- <> +-- $graph +-- +-- The following graph describe the differents way to convert between pixel types, +-- +-- * Nodes describe pixel type +-- +-- * Arrows describe functions +-- +-- <> diff --git a/Codec/Picture/Gif.hs b/Codec/Picture/Gif.hs --- a/Codec/Picture/Gif.hs +++ b/Codec/Picture/Gif.hs @@ -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 - -{- - ::= Header * Trailer - - ::= Logical Screen Descriptor [Global Color Table] - - ::= | - - - ::= [Graphic Control Extension] - - ::= | - Plain Text Extension - - ::= Image Descriptor [Local Color Table] Image Data - - ::= 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 + +{- + ::= Header * Trailer + + ::= Logical Screen Descriptor [Global Color Table] + + ::= | + + + ::= [Graphic Control Extension] + + ::= | + Plain Text Extension + + ::= Image Descriptor [Local Color Table] Image Data + + ::= 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 + diff --git a/Codec/Picture/Gif/LZW.hs b/Codec/Picture/Gif/LZW.hs --- a/Codec/Picture/Gif/LZW.hs +++ b/Codec/Picture/Gif/LZW.hs @@ -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 diff --git a/Codec/Picture/HDR.hs b/Codec/Picture/HDR.hs --- a/Codec/Picture/HDR.hs +++ b/Codec/Picture/HDR.hs @@ -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 + diff --git a/Codec/Picture/InternalHelper.hs b/Codec/Picture/InternalHelper.hs --- a/Codec/Picture/InternalHelper.hs +++ b/Codec/Picture/InternalHelper.hs @@ -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 + diff --git a/Codec/Picture/Jpg.hs b/Codec/Picture/Jpg.hs --- a/Codec/Picture/Jpg.hs +++ b/Codec/Picture/Jpg.hs @@ -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 diff --git a/Codec/Picture/Jpg/DefaultTable.hs b/Codec/Picture/Jpg/DefaultTable.hs --- a/Codec/Picture/Jpg/DefaultTable.hs +++ b/Codec/Picture/Jpg/DefaultTable.hs @@ -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) diff --git a/Codec/Picture/Jpg/FastDct.hs b/Codec/Picture/Jpg/FastDct.hs --- a/Codec/Picture/Jpg/FastDct.hs +++ b/Codec/Picture/Jpg/FastDct.hs @@ -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 diff --git a/Codec/Picture/Jpg/FastIdct.hs b/Codec/Picture/Jpg/FastIdct.hs --- a/Codec/Picture/Jpg/FastIdct.hs +++ b/Codec/Picture/Jpg/FastIdct.hs @@ -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 diff --git a/Codec/Picture/Jpg/Types.hs b/Codec/Picture/Jpg/Types.hs --- a/Codec/Picture/Jpg/Types.hs +++ b/Codec/Picture/Jpg/Types.hs @@ -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 diff --git a/Codec/Picture/Png.hs b/Codec/Picture/Png.hs --- a/Codec/Picture/Png.hs +++ b/Codec/Picture/Png.hs @@ -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 diff --git a/Codec/Picture/Png/Export.hs b/Codec/Picture/Png/Export.hs --- a/Codec/Picture/Png/Export.hs +++ b/Codec/Picture/Png/Export.hs @@ -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" diff --git a/Codec/Picture/Png/Type.hs b/Codec/Picture/Png/Type.hs --- a/Codec/Picture/Png/Type.hs +++ b/Codec/Picture/Png/Type.hs @@ -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) diff --git a/Codec/Picture/Saving.hs b/Codec/Picture/Saving.hs --- a/Codec/Picture/Saving.hs +++ b/Codec/Picture/Saving.hs @@ -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 + diff --git a/Codec/Picture/Tiff.hs b/Codec/Picture/Tiff.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Tiff.hs @@ -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 + diff --git a/Codec/Picture/Types.hs b/Codec/Picture/Types.hs --- a/Codec/Picture/Types.hs +++ b/Codec/Picture/Types.hs @@ -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 diff --git a/Codec/Picture/VectorByteConversion.hs b/Codec/Picture/VectorByteConversion.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/VectorByteConversion.hs @@ -0,0 +1,12 @@ +module Codec.Picture.VectorByteConversion( blitVector ) where + +import Data.Word( Word8 ) +import Data.Vector.Storable( Vector, unsafeToForeignPtr ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as S + +blitVector :: Vector Word8 -> Int -> Int -> B.ByteString +blitVector vec atIndex blitSize = S.PS ptr (offset + atIndex) blitSize + where (ptr, offset, _length) = unsafeToForeignPtr vec + diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,11 +1,10 @@ Name: JuicyPixels -Version: 3.0 -Synopsis: Picture loading/serialization (in png, jpeg, bitmap, radiance and gif) +Version: 3.1 +Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance) Description: <> . - This library can load and store images in PNG,Bitmap, Jpeg, Radiance and - read Gif images. + This library can load and store images in PNG,Bitmap, Jpeg, Radiance and read Gif and Tiff images. homepage: https://github.com/Twinside/Juicy.Pixels License: BSD3 @@ -25,7 +24,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.0 + Tag: v3.1 Library Default-Language: Haskell2010 @@ -35,6 +34,7 @@ Codec.Picture.Png, Codec.Picture.Jpg, Codec.Picture.HDR, + Codec.Picture.Tiff, Codec.Picture.Saving, Codec.Picture.Types @@ -42,12 +42,13 @@ Build-depends: base >= 4 && < 5, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.2, - binary >= 0.6.4.0 && < 0.7, + binary >= 0.6.4.0 && < 0.7.2, zlib >= 0.5.3.1 && < 0.6, transformers >= 0.2.2 && < 0.4, - vector >= 0.10 && < 0.11, + vector >= 0.9 && < 0.11, primitive >= 0.5 && < 0.6, - deepseq >= 1.1 && < 1.4 + deepseq >= 1.1 && < 1.4, + mmap -- Modules not exported by this package. Other-modules: Codec.Picture.Jpg.DefaultTable, @@ -58,7 +59,9 @@ Codec.Picture.Png.Export, Codec.Picture.Png.Type, Codec.Picture.BitWriter, - Codec.Picture.InternalHelper + Codec.Picture.InternalHelper, + Codec.Picture.VectorByteConversion Install-Includes: Codec/Picture/ConvGraph.hs Include-Dirs: Codec/Picture +