diff --git a/Codec/Picture/BitWriter.hs b/Codec/Picture/BitWriter.hs --- a/Codec/Picture/BitWriter.hs +++ b/Codec/Picture/BitWriter.hs @@ -76,7 +76,7 @@ runBoolWriter writer = do let finalWriter = writer >> flushWriter PairS _ (BoolWriteState builder _ _) <- - run finalWriter (BoolWriteState (empty) 0 0) + run finalWriter (BoolWriteState empty 0 0) return $ toByteString builder -- | Current serializer, bit buffer, bit count @@ -84,7 +84,7 @@ {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int -data BoolWriterT m a = BitPut { run :: (BoolWriteState -> m (PairS a)) } +data BoolWriterT m a = BitPut { run :: BoolWriteState -> m (PairS a) } type BoolWriter s a = BoolWriterT (ST s) a @@ -131,7 +131,7 @@ | otherwise = let leftBitCount = 8 - count :: Int highPart = cleanData .>>. (bitCount - leftBitCount) :: Word32 - prevPart = (fromIntegral currentWord) .<<. leftBitCount :: Word32 + prevPart = fromIntegral currentWord .<<. leftBitCount :: Word32 nextMask = (1 .<<. (bitCount - leftBitCount)) - 1 :: Word32 newData = cleanData .&. nextMask :: Word32 diff --git a/Codec/Picture/Gif.hs b/Codec/Picture/Gif.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Gif.hs @@ -0,0 +1,191 @@ +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 + } + diff --git a/Codec/Picture/Gif/LZW.hs b/Codec/Picture/Gif/LZW.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Gif/LZW.hs @@ -0,0 +1,178 @@ +{-# 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) diff --git a/Codec/Picture/Gif/Writer.hs b/Codec/Picture/Gif/Writer.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Gif/Writer.hs @@ -0,0 +1,99 @@ +{-# 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 @@ -251,15 +251,15 @@ then 0 else 1 put4BitsOfEach classVal $ huffmanTableDest table mapM_ put . VU.toList $ huffSizes table - forM_ [0 .. 15] $ \i -> do + forM_ [0 .. 15] $ \i -> when (huffSizes table ! i /= 0) (let elements = VU.toList $ huffCodes table V.! i - in mapM_ put $ elements) + in mapM_ put elements) get = do (huffClass, huffDest) <- get4BitOfEach sizes <- replicateM 16 getWord8 - codes <- forM sizes $ \s -> do + codes <- forM sizes $ \s -> VU.replicateM (fromIntegral s) getWord8 return JpgHuffmanTableSpec { huffmanTableClass = @@ -270,7 +270,7 @@ } instance Serialize JpgImage where - put (JpgImage { jpgFrame = frames }) = do + put (JpgImage { jpgFrame = frames }) = putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames >> putWord8 0xFF >> putWord8 0xD9 @@ -478,9 +478,14 @@ 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 `quot` (fromIntegral $ table !!! idx)) +quantize table = mutate (\idx val -> val `quotient` fromIntegral (table !!! idx)) + where quotient val q = (val + (q `div` 2)) `quot` q -- rounded integer division -- | Apply a quantization matrix to a macroblock {-# INLINE deQuantize #-} @@ -846,7 +851,7 @@ pixelData = runST $ VS.unsafeFreeze =<< S.evalStateT (do resultImage <- lift $ M.replicate imageSize 0 let wrapped = MutableImage imgWidth imgHeight resultImage - setDecodedString {- . (\a -> trace ("read " ++ show (map (printf "%02X" :: Word8 -> String) $ B.unpack a)) a) -}$ imgData + setDecodedString imgData decodeImage compCount (buildJpegImageDecoder img) wrapped return resultImage) (-1, 0, B.empty) @@ -895,7 +900,7 @@ serializeMacroBlock dcCode acCode blk = lift (blk .!!!. 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return () where writeAcs acc@(_, 63) = - lift (blk .!!!. 63) >>= (fromIntegral >>> encodeAcCoefs acc) + lift (blk .!!!. 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return () writeAcs acc@(_, i ) = lift (blk .!!!. i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs @@ -948,7 +953,7 @@ , huffmanTableDest = dest , huffSizes = sizes , huffCodes = V.fromListN 16 - [VU.fromListN (fromIntegral $ (sizes ! i)) lst + [VU.fromListN (fromIntegral $ sizes ! i) lst | (i, lst) <- zip [0..] tableDef ] }, Empty) where sizes = VU.fromListN 16 $ map (fromIntegral . length) tableDef @@ -1005,7 +1010,7 @@ } hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } - hdr' = (JpgFrameHeader{ jpgFrameHeaderLength = 0 + hdr' = JpgFrameHeader{ jpgFrameHeaderLength = 0 , jpgSamplePrecision = 8 , jpgHeight = fromIntegral h , jpgWidth = fromIntegral w @@ -1027,15 +1032,15 @@ , quantizationTableDest = 1 } ] - }) + } lumaQuant = scaleQuantisationMatrix (fromIntegral quality) defaultLumaQuantizationTable chromaQuant = scaleQuantisationMatrix (fromIntegral quality) defaultChromaQuantizationTable - zigzagedLumaQuant = zigZagReorderForwardv $ lumaQuant - zigzagedChromaQuant = zigZagReorderForwardv $ chromaQuant + zigzagedLumaQuant = zigZagReorderForwardv lumaQuant + zigzagedChromaQuant = zigZagReorderForwardv chromaQuant quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0 , quantTable = zigzagedLumaQuant } , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1 @@ -1071,8 +1076,8 @@ ySamplingFactor = maxSampling - sizeY + 1 ] - workData <- lift $ createEmptyMutableMacroBlock - zigzaged <- lift $ createEmptyMutableMacroBlock + 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 >>= 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 @@ -77,6 +77,9 @@ instance PngSavable Pixel8 where encodePng = genericEncodePng PngGreyscale 1 +instance PngSavable PixelYA8 where + encodePng = genericEncodePng PngGreyscaleWithAlpha 2 + -- | Write a dynamic image in a .png image file if possible. -- The same restriction as encodeDynamicPng apply. writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) @@ -86,14 +89,17 @@ -- | Encode a dynamic image in bmp if possible, supported pixel type are : -- +-- - Y8 +-- +-- - YA8 +-- -- - RGB8 -- -- - RGBA8 -- --- - Y8 --- encodeDynamicPng :: DynamicImage -> Either String B.ByteString encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img encodeDynamicPng (ImageY8 img) = Right $ encodePng img +encodeDynamicPng (ImageYA8 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 @@ -311,6 +311,6 @@ pngComputeCrc = (0xFFFFFFFF `xor`) . B.foldl' updateCrc 0xFFFFFFFF . B.concat where updateCrc crc val = let u32Val = fromIntegral val - lutVal = pngCrcTable ! (fromIntegral $ ((crc `xor` u32Val) .&. 0xFF)) + lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF)) in lutVal `xor` (crc `shiftR` 8) diff --git a/Codec/Picture/Saving.hs b/Codec/Picture/Saving.hs --- a/Codec/Picture/Saving.hs +++ b/Codec/Picture/Saving.hs @@ -28,19 +28,19 @@ -- as PNG, make all color conversion and such. Equivalent -- of 'decodeImage' for PNG encoding imageToPng :: DynamicImage -> B.ByteString -imageToPng (ImageYCbCr8 img) = encodePng $ (convertImage img :: Image PixelRGB8) +imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) imageToPng (ImageRGB8 img) = encodePng img imageToPng (ImageRGBA8 img) = encodePng img imageToPng (ImageY8 img) = encodePng img -imageToPng (ImageYA8 img) = encodePng $ (promoteImage img :: Image PixelRGBA8) +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 -> B.ByteString -imageToBitmap (ImageYCbCr8 img) = encodeBitmap $ (convertImage img :: Image PixelRGB8) +imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) imageToBitmap (ImageRGB8 img) = encodeBitmap img imageToBitmap (ImageRGBA8 img) = encodeBitmap img imageToBitmap (ImageY8 img) = encodeBitmap img -imageToBitmap (ImageYA8 img) = encodeBitmap $ (promoteImage img :: Image PixelRGBA8) +imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) diff --git a/Codec/Picture/Types.hs b/Codec/Picture/Types.hs --- a/Codec/Picture/Types.hs +++ b/Codec/Picture/Types.hs @@ -68,14 +68,18 @@ -- | 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 }) = - Image { imageWidth = w, imageHeight = h, imageData = plane } - where plane = stride img 1 padd comp - padd = componentCount (undefined :: a) - 1 +extractComponent 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. @@ -512,15 +516,15 @@ instance LumaPlaneExtractable PixelRGB8 where {-# INLINE computeLuma #-} - computeLuma (PixelRGB8 r g b) = floor $ 0.3 * (toRational r) + - 0.59 * (toRational g) + - 0.11 * (toRational b) + computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + + 0.59 * toRational g + + 0.11 * toRational 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) + computeLuma (PixelRGBA8 r g b _) = floor $ 0.3 * toRational r + + 0.59 * toRational g + + 0.11 * toRational b instance LumaPlaneExtractable PixelYA8 where {-# INLINE computeLuma #-} diff --git a/Codec/client_session_key.aes b/Codec/client_session_key.aes new file mode 100644 --- /dev/null +++ b/Codec/client_session_key.aes @@ -0,0 +1,2 @@ + Ãõî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,9 +1,13 @@ Name: JuicyPixels -Version: 1.2.1 +Version: 1.3 Synopsis: Picture loading/serialization (in png, jpeg and bitmap) Description: This library can load and store images in various image formats, for now mainly in PNG/Bitmap and Jpeg + + Version 1.3 changelog: + - Fix extractComponent function + - Adding saving for YA8 functions homepage: https://github.com/Twinside/Juicy.Pixels License: BSD3 @@ -25,7 +29,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v1.2.1 + Tag: v1.3 Library Default-Language: Haskell2010 @@ -55,4 +59,3 @@ 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 @@ -1,15 +1,22 @@ Juicy.Pixels ============ -This library provide saving & loading of different picture formats for -the Haskell language. The aim of the library is to be as lightweight as -possible, you ask it to load an image, and it'l dump you a big MUArray -or UArray full of juicy pixels. Or squared pixels, or whatever, as long -as they're unboxed. +This library provide saving & loading of different picture formats for the +Haskell language. The aim of the library is to be as lightweight as possible, +you ask it to load an image, and it'l dump you a big Vector full of juicy +pixels. Or squared pixels, or whatever, as long as they're unboxed. Documentation ------------- The library documentation can be accessed on [Hackage](http://hackage.haskell.org/package/JuicyPixels) + +REPA +---- +For the user of +[REPA](http://www.haskell.org/haskellwiki/Numeric_Haskell:_A_Repa_Tutorial), +check-out JuicyPixels-repa on +[GitHub](https://github.com/TomMD/JuicyPixels-repa) or +[Hackage](http://hackage.haskell.org/package/JuicyPixels-repa) Status ------