JuicyPixels 1.3 → 2.0
raw patch · 10 files changed
+598/−509 lines, 10 filesdep ~zlibPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: zlib
API changes (from Hackage documentation)
+ Codec.Picture: decodeGif :: ByteString -> Either String DynamicImage
+ Codec.Picture: decodeGifImages :: ByteString -> Either String [Image PixelRGB8]
+ Codec.Picture: readGif :: FilePath -> IO (Either String DynamicImage)
+ Codec.Picture: readGifImages :: FilePath -> IO (Either String [Image PixelRGB8])
+ Codec.Picture.Gif: decodeGif :: ByteString -> Either String DynamicImage
+ Codec.Picture.Gif: decodeGifImages :: ByteString -> Either String [Image PixelRGB8]
+ Codec.Picture.Gif: instance Serialize GifFile
+ Codec.Picture.Gif: instance Serialize GifHeader
+ Codec.Picture.Gif: instance Serialize GifImage
+ Codec.Picture.Gif: instance Serialize GifVersion
+ Codec.Picture.Gif: instance Serialize ImageDescriptor
+ Codec.Picture.Gif: instance Serialize LogicalScreenDescriptor
+ Codec.Picture.Types: PlaneAlpha :: PlaneAlpha
+ Codec.Picture.Types: PlaneBlue :: PlaneBlue
+ Codec.Picture.Types: PlaneCb :: PlaneCb
+ Codec.Picture.Types: PlaneCr :: PlaneCr
+ Codec.Picture.Types: PlaneGreen :: PlaneGreen
+ Codec.Picture.Types: PlaneLuma :: PlaneLuma
+ Codec.Picture.Types: PlaneRed :: PlaneRed
+ Codec.Picture.Types: class ColorPlane pixel planeToken
+ Codec.Picture.Types: data PlaneAlpha
+ Codec.Picture.Types: data PlaneBlue
+ Codec.Picture.Types: data PlaneCb
+ Codec.Picture.Types: data PlaneCr
+ Codec.Picture.Types: data PlaneGreen
+ Codec.Picture.Types: data PlaneLuma
+ Codec.Picture.Types: data PlaneRed
+ Codec.Picture.Types: instance ColorPlane PixelRGB8 PlaneBlue
+ Codec.Picture.Types: instance ColorPlane PixelRGB8 PlaneGreen
+ Codec.Picture.Types: instance ColorPlane PixelRGB8 PlaneRed
+ Codec.Picture.Types: instance ColorPlane PixelRGBA8 PlaneAlpha
+ Codec.Picture.Types: instance ColorPlane PixelRGBA8 PlaneBlue
+ Codec.Picture.Types: instance ColorPlane PixelRGBA8 PlaneGreen
+ Codec.Picture.Types: instance ColorPlane PixelRGBA8 PlaneRed
+ Codec.Picture.Types: instance ColorPlane PixelYA8 PlaneAlpha
+ Codec.Picture.Types: instance ColorPlane PixelYA8 PlaneLuma
+ Codec.Picture.Types: instance ColorPlane PixelYCbCr8 PlaneCb
+ Codec.Picture.Types: instance ColorPlane PixelYCbCr8 PlaneCr
+ Codec.Picture.Types: instance ColorPlane PixelYCbCr8 PlaneLuma
+ Codec.Picture.Types: unsafeExtractComponent :: Pixel a => Int -> Image a -> Image Pixel8
- Codec.Picture.Types: extractComponent :: Pixel a => Int -> Image a -> Image Pixel8
+ Codec.Picture.Types: extractComponent :: (Pixel px, ColorPlane px plane) => plane -> Image px -> Image Pixel8
Files
- Codec/Picture.hs +17/−0
- Codec/Picture/BitWriter.hs +45/−15
- Codec/Picture/Gif.hs +290/−191
- Codec/Picture/Gif/LZW.hs +120/−178
- Codec/Picture/Gif/Writer.hs +0/−99
- Codec/Picture/Jpg.hs +9/−9
- Codec/Picture/Types.hs +99/−8
- Codec/client_session_key.aes +0/−2
- JuicyPixels.cabal +15/−7
- README.md +3/−0
Codec/Picture.hs view
@@ -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
Codec/Picture/BitWriter.hs view
@@ -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) --------------------------------------------------
Codec/Picture/Gif.hs view
@@ -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 + +{- + <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer + + <Logical Screen> ::= Logical Screen Descriptor [Global Color Table] + + <Data> ::= <Graphic Block> | + <Special-Purpose Block> + + <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block> + + <Graphic-Rendering Block> ::= <Table-Based Image> | + Plain Text Extension + + <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data + + <Special-Purpose Block> ::= Application Extension | + Comment Extension + -} + +-------------------------------------------------- +---- GifVersion +-------------------------------------------------- +data GifVersion = GIF87a | GIF89a + +gif87aSignature, gif89aSignature :: B.ByteString +gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" +gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" + +instance 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 +
Codec/Picture/Gif/LZW.hs view
@@ -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 + +
− Codec/Picture/Gif/Writer.hs
@@ -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)-
Codec/Picture/Jpg.hs view
@@ -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)
Codec/Picture/Types.hs view
@@ -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
− Codec/client_session_key.aes
@@ -1,2 +0,0 @@- ÃõîecveÐ7Ï¿'¹n&öóѲÉ8{EÚ¢ìCøµ£1ÐõëF8íZL¸ùÐ{æ-59ÈB«%eMpGÛ9?- ¢®i¡Bøó1jðêMöÉ
JuicyPixels.cabal view
@@ -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 +
README.md view
@@ -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/).