diff --git a/Codec/Picture.hs b/Codec/Picture.hs --- a/Codec/Picture.hs +++ b/Codec/Picture.hs @@ -33,6 +33,12 @@ , encodeDynamicBitmap , writeDynamicBitmap + -- ** Gif handling + , readGif + , readGifImages + , decodeGif + , decodeGifImages + -- ** Jpeg handling , readJpeg , decodeJpeg @@ -69,6 +75,7 @@ import Codec.Picture.Jpg( decodeJpeg, encodeJpeg, encodeJpegAtQuality ) import Codec.Picture.Png( PngSavable( .. ), decodePng, writePng , encodeDynamicPng , writeDynamicPng ) +import Codec.Picture.Gif( decodeGif, decodeGifImages ) import Codec.Picture.Saving import Codec.Picture.Types import System.IO ( withFile, IOMode(ReadMode) ) @@ -107,12 +114,22 @@ decodeImage :: B.ByteString -> Either String DynamicImage decodeImage str = eitherLoad str [("Jpeg", decodeJpeg) ,("PNG", decodePng) + ,("GIF", decodeGif) ,("Bitmap", decodeBitmap) ] -- | Helper function trying to load a png file from a file on disk. readPng :: FilePath -> IO (Either String DynamicImage) readPng = withImageDecoder decodePng + +-- | Helper function trying to load a gif file from a file on disk. +readGif :: FilePath -> IO (Either String DynamicImage) +readGif = withImageDecoder decodeGif + +-- | Helper function trying to load all the images of an animated +-- gif file. +readGifImages :: FilePath -> IO (Either String [Image PixelRGB8]) +readGifImages = withImageDecoder decodeGifImages -- | Try to load a jpeg file and decompress. The colorspace is still -- YCbCr if you want to perform computation on the luma part. You can diff --git a/Codec/Picture/BitWriter.hs b/Codec/Picture/BitWriter.hs --- a/Codec/Picture/BitWriter.hs +++ b/Codec/Picture/BitWriter.hs @@ -4,16 +4,17 @@ module Codec.Picture.BitWriter( BoolWriter , BoolReader , writeBits - , byteAlign - , getNextBit + , byteAlignJpg + , getNextBits + , getNextBitJpg , setDecodedString + , setDecodedStringJpg , runBoolWriter + , runBoolReader ) where import Control.Monad( when ) -import Control.Monad.ST( ST - -- , runST - ) +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 ) @@ -39,32 +40,61 @@ -- | 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) + +-- | 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) + -- | Drop all bit until the bit of indice 0, usefull to parse restart -- marker, as they are byte aligned, but Huffman might not. -byteAlign :: BoolReader s () -byteAlign = do +byteAlignJpg :: BoolReader s () +byteAlignJpg = do (idx, _, chain) <- S.get - when (idx /= 7) (setDecodedString chain) + when (idx /= 7) (setDecodedStringJpg chain) --- | Return the next bit in the input stream. +{-# INLINE getNextBitJpg #-} +getNextBitJpg :: BoolReader s Bool +getNextBitJpg = do + (idx, v, chain) <- S.get + let val = (v .&. (1 `shiftL` idx)) /= 0 + if idx == 0 + then setDecodedStringJpg chain + else S.put (idx - 1, v, chain) + return val + +{-# INLINE getNextBits #-} +getNextBits :: Int -> BoolReader s Word32 +getNextBits count = aux 0 count + where aux acc 0 = return acc + aux acc n = do + bit <- getNextBit + let nextVal | bit = acc .|. (1 .<<. (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 - if idx == 0 + if idx == 7 then setDecodedString chain - else S.put (idx - 1, v, chain) + else S.put (idx + 1, v, chain) return val --- | Bitify a list of things to decode. -setDecodedString :: B.ByteString -> BoolReader s () -setDecodedString str = case B.uncons str of +-- | 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) Just (0xFF, rest) -> case B.uncons rest of Nothing -> S.put (maxBound, 0, B.empty) Just (0x00, afterMarker) -> S.put (7, 0xFF, afterMarker) - Just (_ , afterMarker) -> setDecodedString afterMarker + Just (_ , afterMarker) -> setDecodedStringJpg afterMarker Just (v, rest) -> S.put ( 7, v, rest) -------------------------------------------------- diff --git a/Codec/Picture/Gif.hs b/Codec/Picture/Gif.hs --- a/Codec/Picture/Gif.hs +++ b/Codec/Picture/Gif.hs @@ -1,191 +1,290 @@ -module Codec.Picture.Gif ( ) where - -import Data.Vector (Vector) -import qualified Data.Vector as V -import Data.Word -import Data.Maybe( fromMaybe ) -import Data.List -import Control.Applicative( (<$>), pure ) -import Control.Monad( replicateM ) -import Data.Bits( (.&.), shiftR, testBit ) -import Data.Word( Word8 ) -{-import LZW-} -import qualified Data.ByteString as B -import qualified Data.Vector as V -import Data.Maybe( fromMaybe ) - -import Data.Serialize( Serialize(..), Get, Put - , getWord8, putWord8 - , getWord16be, putWord16be - , remaining, lookAhead, skip - , getBytes, decode - , encode, putByteString - ) - -import Codec.Picture.Types - -data GifVersion = GIF87a | GIF89a - deriving (Show, Eq) - --- | Section 18 of spec-gif89a -data ScreenDescriptor = ScreenDescriptor - { -- | 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 - } - deriving (Show, Eq) - --- | Section 20 of spec-gif89a -data GifImageDescriptor = GifImageDescriptor - { gDescPixelsFromLeft :: !Int - , gDescPixelsFromTop :: !Int - , gDescImageWidth :: !Int - , gDescImageHeight :: !Int - , gDescHasLocalMap :: !Bool - , gDescIsInterlaced :: !Bool - , gDescIsImgDescriptorSorted :: !Bool - , gDescLocalColorTableSize :: !Int - } - deriving (Show, Eq) - -type Palette = V.Vector PixelRGB8 - -type GifImageData = (GifImageDescriptor, Maybe Palette, Raster) - --- Stelt 1 pixel waarde voor door een index en de bijbehorende colormap -type GifPixel = (Int, Palette) - -type Raster = V.Vector (V.Vector GifPixel) - -data GifImage = GifImage - { gifVersion :: !GifVersion - , gifScreenDescriptor :: !ScreenDescriptor - , gifGlobalMap :: !Palette - , images :: [GifImageData] - } - deriving (Eq, Show) - -gif87aSignature, gif89aSignature :: B.ByteString -gif87aSignature = B.pack "GIF87a" -gif89aSignature = B.pack "GIF89a" - -instance Serialize GifVersion where - put GIF87a = put gif87aSignature - put GIF89a = put gif89aSignature - - get = do - sig <- getBytes (B.length gif87aSignature) - case (sig == gif87aSignature, sig == gif89aSignature) of - (True, _) -> pure GIF87a - (_ , True) -> pure GIF89a - _ -> fail "Invalid Gif signature" - --- Add 2 bytes together -lsbAdd :: Integral a => a -> a -> Int -lsbAdd l r = (fromIntegral l) * 0x100 + (fromIntegral r) - -(<++>) = lsbAdd - -instance Serialize ScreenDescriptor where - put _ = undefined - get = do - w <- getWord16be - h <- getWord16be - packedField <- getWord8 - backgroundColorIndex <- getWord8 - aspectRatio <- getWord8 - return ScreenDescriptor - { screenWidth = w - , screenHeight = h - , hasGlobalMap = packedField `testBit` 7 - , colorResolution = (packedField `shiftR` 5) .&. 0x7 + 1 - , isColorTableSorted = packedField `testBit` 3 - , colorTableSize = (packedField .&. 0x7) + 1 - , backgroundIndex = backgroundColorIndex - } - -colorMap :: Int -> Get Palette -colorMap bits = fmap V.fromList $ replicateM (2 ^ bits) get - -imageSeperator, gifTerminator :: Word8 -imageSeperator = 0x2c -gifTerminator = 0x3b - - -instance Serialize GifImageDescriptor where - put _ = undefined - get = do - imgSeparator <- getWord8 - imgLeftPos <- getWord16be - imgTopPos <- getWord16be - imgWidth <- getWord16be - imgHeight <- getWord16be - packedFields <- getWord8 - return GifImageDescriptor - { gDescPixelsFromLeft = imgLeftPos - , gDescPixelsFromTop = imgTopPos - , gDescImageWidth = imgWidth - , gDescImageHeight = imgHeight - , gDescHasLocalMap = packedFields `testBit` 7 - , gDescIsInterlaced = packedFields `testBit` 6 - , gDescIsImgDescriptorSorted = packedFields `testBit` 5 - , gDescLocalColorTableSize = packedFields .&. 0x7 + 1 - } - --- Takes the global color map as an argument -imageParser :: Palette -> Parser Image -imageParser globalMap = do - descriptor <- imageDescriptor - localMap <- if hasLocalMap descriptor - then Just <$> colorMap (localColorTableSize descriptor) - else return $ Nothing - - -- the map the raster should use - let useMap = fromMaybe globalMap localMap - codeSize <- fromIntegral <$> anyWord8 - rasterData <- B.concat <$> imageRasterBlock `A.manyTill` zeroImageRaster - return (descriptor, localMap, parseRaster descriptor (lzwDecode codeSize rasterData) useMap) - - -imageRasterBlock :: Parser ByteString -imageRasterBlock = do - byteCount <- anyWord8 - rasterData <- A.take (fromIntegral byteCount) - return rasterData - -parseRaster :: GifImageDescriptor -> [Int] -> Palette -> Raster -parseRaster ds list cm - | interlaced ds = undefined - | otherwise = - V.fromList $ map V.fromList $ groupEach (imageWidth ds) $ map (\x -> (x, cm)) list - where - groupEach _ [] = [] - groupEach a l = let (left, right) = splitAt a l - in [left] ++ groupEach a right - -gifParser = do - signature <- gifSignature - descriptor <- screenDescriptor - globalCM <- colorMap $ screenBitsPerPixel descriptor - _ <- anyWord8 `A.manyTill` imageSeperator - images <- imageParser globalCM `A.sepBy` imageSeperator - _ <- gifTerminator - return GifImage - { gifVersion = signature - , gifScreenDescriptor = descriptor - , gifGlobalMap = globalCM - , images = images - } - +-- | 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.Serialize( Serialize(..) + , Get + , decode + , getWord8 + , getWord16le + , getBytes + , lookAhead + {-, decode-} + {-, remaining-} + + {-, Put-} + {-, putWord8-} + {-, putWord16be-} + {-, encode-} + {-, putByteString -} + ) + +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 Serialize GifVersion where + put GIF87a = put gif87aSignature + put GIF89a = put gif89aSignature + + get = do + sig <- getBytes (B.length gif87aSignature) + case (sig == gif87aSignature, sig == gif89aSignature) of + (True, _) -> pure GIF87a + (_ , True) -> pure GIF89a + _ -> fail "Invalid Gif signature" + + +-------------------------------------------------- +---- 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 Serialize 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 + +{-commentLabel, graphicControlLabel, graphicControlLabel,-} + {-applicationLabel :: Word8-} +{-commentLabel = 0xFE-} +{-graphicControlLabel = 0xF9-} +{-plainTextLabel = 0x01-} +{-applicationLabel = 0xFF-} + +parseDataBlocks :: Get B.ByteString +parseDataBlocks = B.concat <$> (getWord8 >>= aux) + where aux 0 = pure [] + aux size = (:) <$> getBytes (fromIntegral size) <*> (getWord8 >>= aux) + +data GifImage = GifImage + { imgDescriptor :: !ImageDescriptor + , imgLocalPalette :: !(Maybe Palette) + , imgLzwRootSize :: !Word8 + , imgData :: B.ByteString + } + +instance Serialize GifImage where + put _ = undefined + get = do + desc <- get + let paletteSize = gDescLocalColorTableSize desc + palette <- if paletteSize > 0 + then Just <$> getPalette paletteSize + else pure Nothing + + GifImage desc palette <$> getWord8 <*> parseDataBlocks + +parseGifBlocks :: Get [GifImage] +parseGifBlocks = lookAhead getWord8 >>= blockParse + where blockParse v + | v == gifTrailer = getWord8 >> pure [] + | v == imageSeparator = (:) <$> get <*> parseGifBlocks + | v == extensionIntroducer = + getWord8 >> getWord8 >> parseDataBlocks >> parseGifBlocks + blockParse v = fail ("Unrecognize gif block " ++ show v) + +instance Serialize ImageDescriptor where + put _ = undefined + get = do + _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 = V.Vector PixelRGB8 + +getPalette :: Word8 -> Get Palette +getPalette bitDepth = replicateM size get >>= return . V.fromList + where size = 2 ^ (fromIntegral bitDepth :: Int) + +-------------------------------------------------- +---- GifImage +-------------------------------------------------- +data GifHeader = GifHeader + { gifVersion :: GifVersion + , gifScreenDescriptor :: LogicalScreenDescriptor + , gifGlobalMap :: !Palette + } + +instance Serialize 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 :: [GifImage] + } + +instance Serialize GifFile where + put _ = undefined + get = do + hdr <- get + images <- parseGifBlocks + + return GifFile { gifHeader = hdr + , gifImages = images } + +substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 +substituteColors palette = pixelMap swaper + where swaper n = palette V.! (fromIntegral n) + +decodeImage :: Palette -> GifImage -> Image PixelRGB8 +decodeImage globalPalette img = runST $ runBoolReader $ do + outputVector <- lift . M.new $ width * height + decodeLzw (imgData img) 12 lzwRoot outputVector + frozenData <- lift $ V.unsafeFreeze outputVector + return $ substituteColors palette Image + { imageWidth = width + , imageHeight = height + , imageData = frozenData + } + where lzwRoot = fromIntegral $ imgLzwRootSize img + width = fromIntegral $ gDescImageWidth descriptor + height = fromIntegral $ gDescImageHeight descriptor + descriptor = imgDescriptor img + palette = case imgLocalPalette img of + Nothing -> globalPalette + Just p -> p + +decodeAllGifImages :: GifFile -> [Image PixelRGB8] +decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette} + , gifImages = lst } = map (decodeImage palette) lst + +decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8) +decodeFirstGifImage + GifFile { gifHeader = GifHeader { gifGlobalMap = palette} + , gifImages = (gif:_) } = Right $ decodeImage palette 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,178 +1,120 @@ -{-# LANGUAGE OverloadedStrings #-} -module LZW where -import Control.Monad (liftM) -import Data.Binary.Strict.BitGet -import Data.Bits -import Data.Map ((!), insert, lookup, fromList, Map, member) -import Data.Word -import Prelude hiding (lookup) -import qualified Data.ByteString as B -import Control.Monad.State -import Control.Applicative -import Data.Maybe - -data DecodeState = DecodeState - { stringTable :: Map Int [Int] - , compressionSize :: Int - , oldCode :: [Int] - , currentIndex :: Int - } deriving (Show) - -type Decoder a = StateT DecodeState BitGet a - -runDecoder :: B.ByteString -- ^ Input BS - -> DecodeState -- ^ Initial state - -> Decoder a -- ^ Our decoder - -> a -- ^ Result -runDecoder bs initial decoder = - let x = evalStateT decoder initial -- x = BitGet a - in case runBitGet (reverseBytes bs) x of - Left err -> error err - Right x -> x - -getNextCode :: Decoder Int -getNextCode = do - cs <- getCompressionSize - bs <- lift $ getLeftByteString cs - return $ (fromIntegral . toWord) bs - -getStringTable :: Decoder (Map Int [Int]) -getStringTable = gets stringTable - -getCompressionSize :: Decoder Int -getCompressionSize = gets compressionSize - -getOldCode :: Decoder [Int] -getOldCode = gets oldCode - -getCurrentIndex :: Decoder Int -getCurrentIndex = gets currentIndex - -lzwDecode rootSize string = - let initial = DecodeState - { stringTable = fromList $ map (\x -> (x, [x])) [0 .. (2 ^ rootSize - 1)] - , currentIndex = 2 ^ rootSize + 1 - , compressionSize = rootSize + 1 - , oldCode = [] - } - in runDecoder string initial (decodeS initial) - - -decodeS :: DecodeState -> Decoder [Int] -decodeS initial = decode - where - decode = do - code <- getNextCode - evalCode code - - clearCode = 2 ^ (compressionSize initial - 1) - endOfInfo = clearCode + 1 - - reset = put initial - - lookupCode code = do - res <- lookup code `liftM` getStringTable - prev <- getOldCode - add $ prev ++ [head $ fromMaybe prev res] - return $ fromMaybe (prev ++ [head prev]) res - - adjustDS r = modify func - where - func ds = ds { currentIndex = (currentIndex ds) + 1 - , compressionSize = comp ds - , oldCode = r - } - comp ds = min 12 $ if (currentIndex ds) == (2 ^ compressionSize ds) - 1 - then compressionSize ds + 1 else compressionSize ds - - add x = modify (\ds -> ds { stringTable = insert (currentIndex ds) x (stringTable ds)}) - - evalCode code - | code == clearCode = reset >> decodeS initial - | code == endOfInfo = return [] - | otherwise = do - r <- lookupCode code - adjustDS r - (r ++) `liftM` decode - -lzwEncode rootSize arr = - B.pack . mapAdd $ encode rootSize arr - where - mapAdd :: [(Int, Int)] -> [Word8] - mapAdd [] = [] - mapAdd [(c,w)] - | c <= 8 = [(fromIntegral w)] - | otherwise = (fromIntegral w) : mapAdd [(c-8, w `shiftR` 8)] - mapAdd (x@(b, w):y:xs) - | b == 8 = (fromIntegral w) : (mapAdd (y:xs)) - | otherwise = mapAdd $ (add x y) ++ xs - --- Adds 2 numbers together based on how many bits we're allowed to take --- this works by returning an array the numbers it produces --- --- Possibilites: --- * All bits of the second number are consumed -> discard second number from result --- * The bits of the produced number are > 8 -> we have a valid Word8 we can return (set bits == 8) --- * The bits of the left input number > 8 -> take 8 bits (this is a valid Word8) --- -> remaining bits are added as a next input --- -> original left input is just added again -add :: (Int,Int) -> (Int, Int) -> [(Int, Int)] -add (c1, v1) (c2, v2) = - if c1 > 8 then - [(8, v1), (c1 - 8, v1 `shiftR` 8), (c2, v2)] - else - let leftShifted = v2 `shiftL` c1 -- the right input shifted the correct amount - combined = v1 .|. leftShifted -- the 2 numbers added together - next = v2 `shiftR` (c2 - bitsLeft) -- next input (deduced from right input) - bitsLeft = c2 - (8 - c1) -- remaining bits in the next input - bits = if c1 + c2 > 8 then 8 else c1 + c2 -- set to 8 so mapAdd knows it can output a Word8 - in if bitsLeft <= 0 then [(bits, combined)] -- discard right input when there are no remaining bits - else [(bits, combined),(bitsLeft, next)] - --- Convert the given array with given rootSize to a array where each element --- is of the following form (bits to take, actual element) -encode :: Int -> [Int] -> [(Int,Int)] -encode rootSize arr = - (compressionSize, clearCode) : encode' arr startStringTable compressionSize [] startingPoint - where - startStringTable = fromList $ map (\x -> ([x], x)) [0 .. (2 ^ rootSize + 1)] :: Map [Int] Int - compressionSize = rootSize + 1 :: Int - clearCode = 2 ^ rootSize :: Int - endOfInfo = clearCode + 1 - startingPoint = endOfInfo + 1 - - -- Don't forget to output our last code and the endOfInfo - encode' [] strTable c last i = [(c, strTable ! last), (newC, endOfInfo)] - where - newC = min 12 $ if i == (2 ^ c) - then c + 1 else c - encode' (x:xs) strTable compSize last currentIndex = - let string = (last ++ [x]) - in if string `member` strTable then - encode' xs strTable compSize string currentIndex - else - let newStrTable = insert string currentIndex strTable - newCompSize = if currentIndex == (2 ^ compSize) - then compSize + 1 else compSize - in (compSize, strTable ! last) : - if newCompSize == 13 - then (12, clearCode) : encode' (x:xs) startStringTable compressionSize [] startingPoint - else encode' xs newStrTable newCompSize [x] (currentIndex + 1) - - --- source: http://graphics.stanford.edu/~seander/bithacks.html -reverseBytes :: B.ByteString -> B.ByteString -reverseBytes = B.map (\b -> - fromIntegral $ (`shiftR` 32) - $ (* 0x0101010101) - $ (.&. 0x0884422110) - $ (* 0x80200802) (fromIntegral b :: Word64)) - -toWord :: B.ByteString -> Word16 -toWord s = - case B.unpack $ reverseBytes s of - [small] -> fromIntegral small - [l,r] -> r <+> l - _ -> error "more than 2 bytes should never happen" - -(<+>) l r = (fromIntegral l) `shiftL` 8 .|. (fromIntegral r) +module Codec.Picture.Gif.LZW( decodeLzw, lzw ) where + +import Data.Word( Word8 ) +import Control.Applicative( (<$>) ) +import Control.Monad( when ) + +{-import Control.Monad.ST( ST )-} +import Control.Monad.Trans.Class( MonadTrans, lift ) +import Control.Monad.Primitive ( PrimState, PrimMonad ) + +import Foreign.Storable ( Storable ) + +import qualified Data.ByteString as B +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.BitWriter + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (PrimMonad m, Storable a) + => M.STVector (PrimState m) a -> Int -> m a +(.!!!.) = M.read + -- M.unsafeRead + +{-# INLINE (..!!!..) #-} +(..!!!..) :: (MonadTrans t, PrimMonad m, Storable a) + => M.STVector (PrimState m) a -> Int -> t m a +(..!!!..) v idx = lift $ v .!!!. idx + +{-# INLINE (.<-.) #-} +(.<-.) :: (PrimMonad m, Storable a) + => M.STVector (PrimState m) a -> Int -> a -> m () +(.<-.) = M.write + -- M.unsafeWrite + +{-# INLINE (..<-..) #-} +(..<-..) :: (MonadTrans t, PrimMonad m, Storable a) + => M.STVector (PrimState m) a -> Int -> a -> t m () +(..<-..) 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 src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex + where endIndex = sourceIndex + size + aux i _ | i == endIndex = return () + aux i j = do + 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 count vec = aux 0 + where aux n | n == count = return vec + aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) + +decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +decodeLzw str maxBitKey initialKey outVec = do + setDecodedString str + lzw maxBitKey initialKey outVec + +-- | Gif image constraint from spec-gif89a, code size max : 12 bits. +lzw :: Int -> Int -> M.STVector s Word8 + -> BoolReader s () +lzw nMaxBitKeySize initialKeySize outVec = do + -- Allocate buffer of maximum size. + lzwData <- lift (M.new maxDataSize) >>= resetArray + lzwOffsetTable <- lift (M.new tableEntryCount) >>= resetArray + lzwSizeTable <- lift $ M.new tableEntryCount + lift $ lzwSizeTable `M.set` 1 + + let loop outWriteIdx writeIdx dicWriteIdx codeSize code + | code == endOfInfo = return () + | code == clearCode = + getNextCode startCodeSize >>= + loop outWriteIdx firstFreeIndex firstFreeIndex startCodeSize + + | otherwise = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (outWriteIdx /= 0) $ do + firstVal <- lzwData ..!!!.. dataOffset + (lzwData ..<-.. (dicWriteIdx - 1)) firstVal + + duplicateData lzwData outVec dataOffset dataSize outWriteIdx + duplicateData lzwData lzwData dataOffset dataSize dicWriteIdx + + (lzwSizeTable ..<-.. writeIdx) $ dataSize + 1 + (lzwOffsetTable ..<-.. writeIdx) dicWriteIdx + + getNextCode codeSize >>= + loop (outWriteIdx + dataSize) + (writeIdx + 1) + (dicWriteIdx + dataSize + 1) (updateCodeSize codeSize $ writeIdx + 1) + + getNextCode startCodeSize >>= + loop 0 firstFreeIndex firstFreeIndex startCodeSize + + where tableEntryCount = 2 ^ min 12 nMaxBitKeySize + maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + + initialElementCount = 2 ^ initialKeySize :: Int + clearCode = initialElementCount + endOfInfo = clearCode + 1 + startCodeSize = initialKeySize + 1 + + firstFreeIndex = endOfInfo + 1 + + resetArray a = lift $ rangeSetter initialElementCount a + + updateCodeSize codeSize writeIdx + | writeIdx == 2 ^ codeSize = min 12 $ codeSize + 1 + | otherwise = codeSize + + getNextCode s = fromIntegral <$> getNextBits s + + diff --git a/Codec/Picture/Gif/Writer.hs b/Codec/Picture/Gif/Writer.hs deleted file mode 100644 --- a/Codec/Picture/Gif/Writer.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Writer where -import GifImage -import LZW -import Data.Bits -import Control.Monad (liftM) -import qualified Data.ByteString as B -import qualified Data.Vector as V -import Data.ByteString.Char8 hiding (head, concat, map) -import Data.Binary.BitPut -import Data.ByteString.Lazy (toChunks) - -putWord8 :: Int -> BitPut -putWord8 = putNBits 8 - -putDescriptor :: ScreenDescriptor -> BitPut -putDescriptor ds = do - putWord8 (screenWidth ds) - putWord8 (screenWidth ds `shiftR` 8) - putWord8 (screenHeight ds) - putWord8 (screenHeight ds `shiftR` 8) - putBit $ hasGlobalMap ds - putNBits 3 (bitsOfColorResolution ds - 1) - putBit False - putNBits 3 (screenBitsPerPixel ds - 1) - putWord8 (backgroundIndex ds) - putWord8 0 - -putGlobalMap :: ColorMap -> BitPut -putGlobalMap cm = do - sequence_ $ putColor `liftM` V.toList cm - where - putColor (r,g,b) = do - putWord8 $ fromIntegral r - putWord8 $ fromIntegral g - putWord8 $ fromIntegral b - - -putImage :: ScreenDescriptor -> Image -> BitPut -putImage _ (descriptor, Just map, raster) = do - putImageDescriptor $ descriptor - putGlobalMap $ map - putRasterData raster $ bitsPerPixel descriptor -putImage ds (descriptor, Nothing, raster) = do - putImageDescriptor $ descriptor - putRasterData raster $ screenBitsPerPixel ds - -putImageDescriptor :: ImageDescriptor -> BitPut -putImageDescriptor ds = do - putWord8 0x2c - putWord8 $ pixelsFromLeft ds - putWord8 $ pixelsFromLeft ds `shiftR` 8 - putWord8 $ pixelsFromTop ds - putWord8 $ pixelsFromTop ds `shiftR` 8 - putWord8 $ imageWidth ds - putWord8 $ imageWidth ds `shiftR` 8 - putWord8 $ imageHeight ds - putWord8 $ imageHeight ds `shiftR` 8 - putBit $ hasLocalMap ds - putBit $ interlaced ds - putNBits 3 (0 :: Int) - putNBits 3 (bitsPerPixel ds - 1) - - -putRasterData :: Raster -> Int -> BitPut -putRasterData raster rootSize = do - let intList = map fst $ concat .V.toList $ V.map V.toList $ raster :: [Int] - let lzw = lzwEncode rootSize intList :: ByteString - putWord8 rootSize - putBlocks lzw - where - putBlocks :: ByteString -> BitPut - putBlocks arr - | B.null arr = putWord8 0 - | otherwise = - let bytes = B.take 255 arr - actual = B.length bytes - in do - putWord8 actual - putByteString bytes - putBlocks (B.drop actual arr) - -putGifTerminator :: BitPut -putGifTerminator = do - putWord8 0x3b - -gifWriter :: GifImage -> BitPut -gifWriter image = do - putByteString "GIF87a" - putDescriptor $ gifScreenDescriptor image - putGlobalMap $ gifGlobalMap image - putImage (gifScreenDescriptor image) `mapM_` images image - putGifTerminator - -runGifWriter :: GifImage -> ByteString -runGifWriter image = - B.concat . toChunks $ runBitPut (gifWriter image) - diff --git a/Codec/Picture/Jpg.hs b/Codec/Picture/Jpg.hs --- a/Codec/Picture/Jpg.hs +++ b/Codec/Picture/Jpg.hs @@ -215,12 +215,12 @@ -- | Decode a list of huffman values, not optimized for speed, but it -- should work. huffmanDecode :: HuffmanTree -> BoolReader s Word8 -huffmanDecode originalTree = getNextBit >>= huffDecode originalTree +huffmanDecode originalTree = getNextBitJpg >>= huffDecode originalTree where huffDecode Empty _ = return 0 huffDecode (Branch (Leaf v) _) False = return v - huffDecode (Branch l _ ) False = getNextBit >>= huffDecode l + huffDecode (Branch l _ ) False = getNextBitJpg >>= huffDecode l huffDecode (Branch _ (Leaf v)) True = return v - huffDecode (Branch _ r ) True = getNextBit >>= huffDecode r + huffDecode (Branch _ r ) True = getNextBitJpg >>= huffDecode r huffDecode (Leaf v) _ = return v -------------------------------------------------- @@ -565,7 +565,7 @@ -- | Unpack an int of the given size encoded from MSB to LSB. unpackInt :: Int32 -> BoolReader s Int32 -unpackInt bitCount = packInt <$> replicateM (fromIntegral bitCount) getNextBit +unpackInt bitCount = packInt <$> replicateM (fromIntegral bitCount) getNextBitJpg powerOf :: Int32 -> Word32 powerOf 0 = 0 @@ -580,7 +580,7 @@ decodeInt :: Int32 -> BoolReader s Int32 decodeInt ssss = do - signBit <- getNextBit + signBit <- getNextBitJpg let dataRange = 1 `shiftL` fromIntegral (ssss - 1) leftBitCount = ssss - 1 -- First following bits store the sign of the coefficient, and counted in @@ -687,10 +687,10 @@ decodeRestartInterval :: BoolReader s Int32 decodeRestartInterval = return (-1) {- do - bits <- replicateM 8 getNextBit + bits <- replicateM 8 getNextBitJpg if bits == replicate 8 True then do - marker <- replicateM 8 getNextBit + marker <- replicateM 8 getNextBitJpg return $ packInt marker else return (-1) -} @@ -713,7 +713,7 @@ when (resetCounter == 0) (do forM_ [0.. compCount - 1] $ \c -> lift $ (dcArray .<-. c) 0 - byteAlign + byteAlignJpg _restartCode <- decodeRestartInterval -- if 0xD0 <= restartCode && restartCode <= 0xD7 return ()) @@ -851,7 +851,7 @@ pixelData = runST $ VS.unsafeFreeze =<< S.evalStateT (do resultImage <- lift $ M.replicate imageSize 0 let wrapped = MutableImage imgWidth imgHeight resultImage - setDecodedString imgData + setDecodedStringJpg imgData decodeImage compCount (buildJpegImageDecoder img) wrapped return resultImage) (-1, 0, B.empty) diff --git a/Codec/Picture/Types.hs b/Codec/Picture/Types.hs --- a/Codec/Picture/Types.hs +++ b/Codec/Picture/Types.hs @@ -27,11 +27,24 @@ -- * Helper functions , canConvertTo - , extractComponent , pixelMap , dropAlphaLayer , generateImage , generateFoldImage + + -- * Color plane extraction + , ColorPlane ( ) + + , PlaneRed( .. ) + , PlaneGreen( .. ) + , PlaneBlue( .. ) + , PlaneAlpha( .. ) + , PlaneLuma( .. ) + , PlaneCr( .. ) + , PlaneCb( .. ) + + , extractComponent + , unsafeExtractComponent ) where import Control.Monad( forM_, foldM ) @@ -66,15 +79,93 @@ (!!!) :: (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 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, ColorPlane px plane) + => plane -> Image px -> Image Pixel8 +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 -extractComponent :: forall a. (Pixel a) - => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) - -> Image a -- ^ Source image - -> Image Pixel8 -extractComponent comp img@(Image { imageWidth = w, imageHeight = h }) +unsafeExtractComponent :: forall a. (Pixel a) + => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) + -> Image a -- ^ Source image + -> Image Pixel8 +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 } @@ -529,12 +620,12 @@ instance LumaPlaneExtractable PixelYA8 where {-# INLINE computeLuma #-} computeLuma (PixelYA8 y _) = y - extractLumaPlane = extractComponent 0 + extractLumaPlane = extractComponent PlaneLuma instance LumaPlaneExtractable PixelYCbCr8 where {-# INLINE computeLuma #-} computeLuma (PixelYCbCr8 y _ _) = y - extractLumaPlane = extractComponent 0 + extractLumaPlane = extractComponent PlaneLuma -- | Free promotion for identic pixel types instance (Pixel a) => ColorConvertible a a where diff --git a/Codec/client_session_key.aes b/Codec/client_session_key.aes deleted file mode 100644 --- a/Codec/client_session_key.aes +++ /dev/null @@ -1,2 +0,0 @@ - ÃõîecveÐ7Ï¿'¹n&öóѲÉ8{E‚Úœ¢ìCøµ£1ЛõëF‚8íZL‡¸ùÐ{æ-59ÈB«%­eMpGÛ9? - ¢®i¡Bøó1j‚ðêMöŠÉ diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,10 +1,15 @@ Name: JuicyPixels -Version: 1.3 -Synopsis: Picture loading/serialization (in png, jpeg and bitmap) +Version: 2.0 +Synopsis: Picture loading/serialization (in png, jpeg, bitmap and gif) Description: - This library can load and store images in various image formats, - for now mainly in PNG/Bitmap and Jpeg - + This library can load and store images in PNG/Bitmap and Jpeg, and + read Gif images. + + Version 2.0 changelog: + - New extractComponent version with type safe plane + extraction + - Gif file reading + Version 1.3 changelog: - Fix extractComponent function - Adding saving for YA8 functions @@ -29,12 +34,13 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v1.3 + Tag: v2.0 Library Default-Language: Haskell2010 Exposed-modules: Codec.Picture, Codec.Picture.Bitmap, + Codec.Picture.Gif, Codec.Picture.Png, Codec.Picture.Jpg, Codec.Picture.Saving, @@ -45,7 +51,7 @@ bytestring >= 0.9 && < 0.10, mtl >= 1.1 && < 2.2, cereal >= 0.3.3.0 && < 0.4, - zlib >= 0.5.3.1, + zlib >= 0.5.3.1 && < 0.6, transformers >= 0.2.2 && < 0.4, vector >= 0.9 && < 1.0, primitive >= 0.4 && < 0.5, @@ -56,6 +62,8 @@ Codec.Picture.Jpg.FastIdct, Codec.Picture.Jpg.FastDct, Codec.Picture.Jpg.Types, + Codec.Picture.Gif.LZW, Codec.Picture.Png.Export, Codec.Picture.Png.Type, Codec.Picture.BitWriter + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -45,6 +45,9 @@ * Reading non-interlaced baseline DCT image, seems to be OK * Writing + - Gif (.gif) + * Reading non-interlaced normal & animated Gif image + _I love juicy pixels_ You can make [donations on this page](http://twinside.github.com/Juicy.Pixels/).