JuicyPixels 2.0 → 2.0.1
raw patch · 7 files changed
+153/−88 lines, 7 filesdep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: bytestring
API changes (from Hackage documentation)
Files
- Codec/Picture.hs +4/−4
- Codec/Picture/BitWriter.hs +80/−39
- Codec/Picture/Bitmap.hs +20/−16
- Codec/Picture/Gif/LZW.hs +12/−13
- Codec/Picture/Jpg.hs +2/−1
- Codec/Picture/Types.hs +9/−2
- JuicyPixels.cabal +26/−13
Codec/Picture.hs view
@@ -68,7 +68,7 @@ import Control.Applicative( (<$>) ) import Control.DeepSeq( NFData, deepseq ) -import Control.Exception( catch, IOException ) +import qualified Control.Exception as Exc ( catch, IOException ) import Codec.Picture.Bitmap( BmpEncodable, decodeBitmap , writeBitmap, encodeBitmap , encodeDynamicBitmap, writeDynamicBitmap ) @@ -79,8 +79,8 @@ import Codec.Picture.Saving import Codec.Picture.Types import System.IO ( withFile, IOMode(ReadMode) ) -import Prelude hiding(catch) + import qualified Data.ByteString as B -- | Return the first Right thing, accumulating error @@ -94,8 +94,8 @@ withImageDecoder :: (NFData a) => (B.ByteString -> Either String a) -> FilePath -> IO (Either String a) -withImageDecoder decoder path = catch doit - (\e -> return . Left $ show (e :: IOException)) +withImageDecoder decoder path = Exc.catch doit + (\e -> return . Left $ show (e :: Exc.IOException)) where doit = withFile path ReadMode $ \h -> force . decoder <$> B.hGetContents h -- force appeared in deepseq 1.3, Haskell Platform
Codec/Picture/BitWriter.hs view
@@ -9,6 +9,7 @@ , getNextBitJpg , setDecodedString , setDecodedStringJpg + , pushByte , runBoolWriter , runBoolReader ) where @@ -18,10 +19,10 @@ import qualified Control.Monad.Trans.State.Strict as S import Control.Monad.Trans.Class( MonadTrans( .. ) ) import Data.Word( Word8, Word32 ) --- import Data.Serialize( Put, runPut ) -import Data.Serialize.Builder( Builder, empty, append, singleton, toByteString ) import Data.Bits( Bits, (.&.), (.|.), shiftR, shiftL ) +import qualified Data.Vector.Storable.Mutable as M +import qualified Data.Vector.Storable as VS import qualified Data.ByteString as B {-# INLINE (.>>.) #-} @@ -100,63 +101,103 @@ -------------------------------------------------- ---- Writer -------------------------------------------------- +defaultBufferSize :: Int +defaultBufferSize = 100 * 1024 -- | Run the writer and get the serialized data. runBoolWriter :: BoolWriter s b -> ST s B.ByteString runBoolWriter writer = do - let finalWriter = writer >> flushWriter - PairS _ (BoolWriteState builder _ _) <- - run finalWriter (BoolWriteState empty 0 0) - return $ toByteString builder + origMv <- M.new defaultBufferSize + st <- S.execStateT (writer >> flushWriter) (BoolWriteState origMv [] 0 0 0) + st' <- forceBufferFlushing st + return . B.concat $ strings st' --- | Current serializer, bit buffer, bit count -data BoolWriteState = BoolWriteState !Builder - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Int +-- | Current serializer, bit buffer, bit count +data BoolWriteState s = BoolWriteState + { wordWrite :: M.MVector s Word8 + , strings :: ![B.ByteString] + , writtenWords :: {-# UNPACK #-} !Int + , bitAcc :: {-# UNPACK #-} !Word8 + , bitReaded :: {-# UNPACK #-} !Int + } -data BoolWriterT m a = BitPut { run :: BoolWriteState -> m (PairS a) } +type BoolWriter s a = S.StateT (BoolWriteState s) (ST s) a -type BoolWriter s a = BoolWriterT (ST s) a +forceBufferFlushing :: BoolWriteState s -> ST s (BoolWriteState s) +forceBufferFlushing st@(BoolWriteState { wordWrite = vec + , writtenWords = count + , strings = lst + }) = do + nmv <- M.new defaultBufferSize + str <- byteStringFromVector vec count + return $ st { wordWrite = nmv + , strings = lst ++ [str] + , writtenWords = 0 + } -data PairS a = PairS a {-# UNPACK #-} !BoolWriteState +flushCurrentBuffer :: BoolWriteState s -> ST s (BoolWriteState s) +flushCurrentBuffer st | writtenWords st < M.length (wordWrite st) = return st +flushCurrentBuffer st = forceBufferFlushing st +-- Data.Vector.Storable.Mutable +-- unsafeToForeignPtr0 :: Storable a => MVector s a -> (ForeignPtr a, Int) +-- +-- Data.ByteString.Unsafe +-- unsafePackCStringFinalizer :: Ptr Word8 -> Int -> IO () -> IO ByteString +-- +-- Data.Vector.Storable.Internal +-- getPtr :: ForeignPtr a -> Ptr a +byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString +byteStringFromVector vec size = do + frozen <- VS.unsafeFreeze vec + return . B.pack . take size $ VS.toList frozen + +setBitCount :: Word8 -> Int -> BoolWriter s () +setBitCount acc count = S.modify $ \s -> + s { bitAcc = acc, bitReaded = count } + +resetBitCount :: BoolWriter s () +resetBitCount = setBitCount 0 0 + +pushByte :: Word8 -> BoolWriter s () +pushByte v = do + st <- S.get + st'@(BoolWriteState { writtenWords = idx }) + <- lift $ flushCurrentBuffer st + lift $ M.write (wordWrite st') idx v + S.put $ st' { writtenWords = idx + 1 } + -- | If some bits are not serialized yet, write -- them in the MSB of a word. flushWriter :: BoolWriter s () -flushWriter = BitPut $ \st@(BoolWriteState p val count) -> return . PairS () $ - let realVal = val `shiftL` (8 - count) - new_context = BoolWriteState (append p (singleton realVal)) 0 0 - in if count == 0 then st else new_context - -instance MonadTrans BoolWriterT where - lift a = BitPut $ \s -> - a >>= \b -> return $ PairS b s - -instance Monad m => Monad (BoolWriterT m) where - m >>= k = BitPut $ \s -> do - PairS a s' <- run m s - PairS b s'' <- run (k a) s' - return $ PairS b s'' - return x = BitPut $ \s -> return $ PairS x s +flushWriter = do + st <- S.get + let count = bitReaded st + when (count > 0) + (do let newContext = st { bitAcc = 0, bitReaded = 0 } + S.put newContext + pushByte $ bitAcc st `shiftL` (8 - count)) -- | Append some data bits to a Put monad. writeBits :: Word32 -- ^ The real data to be stored. Actual data should be in the LSB -> Int -- ^ Number of bit to write from 1 to 32 -> BoolWriter s () -writeBits = \d c -> BitPut (serialize d c) - where dumpByte str 0xFF = append (append str (singleton 0xFF)) $ singleton 0x00 - dumpByte str i = append str (singleton i) +writeBits d c = do + currWord <- S.gets bitAcc + currCount <- S.gets bitReaded + serialize d c currWord currCount + where dumpByte 0xFF = pushByte 0xFF >> pushByte 0x00 + dumpByte i = pushByte i - serialize bitData bitCount (BoolWriteState str currentWord count) - | bitCount + count == 8 = - let newVal = fromIntegral $ - (currentWord .<<. bitCount) .|. fromIntegral cleanData - in return . PairS () $ BoolWriteState (dumpByte str newVal) 0 0 + serialize bitData bitCount currentWord count + | bitCount + count == 8 = do + resetBitCount + dumpByte (fromIntegral $ (currentWord .<<. bitCount) .|. + fromIntegral cleanData) | bitCount + count < 8 = let newVal = currentWord .<<. bitCount - in return . PairS () $ BoolWriteState str (newVal .|. fromIntegral cleanData) - (count + bitCount) + in setBitCount (newVal .|. fromIntegral cleanData) $ count + bitCount | otherwise = let leftBitCount = 8 - count :: Int @@ -168,7 +209,7 @@ newCount = bitCount - leftBitCount :: Int toWrite = fromIntegral $ prevPart .|. highPart :: Word8 - in serialize newData newCount (BoolWriteState (dumpByte str toWrite) 0 0) + in resetBitCount >> dumpByte toWrite >> serialize newData newCount 0 0 where cleanMask = (1 `shiftL` bitCount) - 1 :: Word32 cleanData = bitData .&. cleanMask :: Word32
Codec/Picture/Bitmap.hs view
@@ -19,13 +19,14 @@ import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M import Data.Serialize( Serialize( .. ) - , putWord8, putWord16le, putWord32le + , putWord16le, putWord32le , getWord16le, getWord32le , Get, Put, runGet, runPut - , remaining, getBytes ) + , remaining, getBytes, putByteString ) import Data.Word( Word32, Word16, Word8 ) import qualified Data.ByteString as B +import Codec.Picture.BitWriter import Codec.Picture.Types data BmpHeader = BmpHeader @@ -140,54 +141,57 @@ (!!!) = V.unsafeIndex {-# INLINE stridePut #-} -stridePut :: Int -> Put +stridePut :: Int -> BoolWriter s () stridePut 0 = return () -stridePut 1 = putWord8 0 -stridePut n = putWord8 0 >> stridePut (n - 1) +stridePut 1 = pushByte 0 +stridePut n = pushByte 0 >> stridePut (n - 1) instance BmpEncodable Pixel8 where defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]] bitsPerPixel _ = 8 - bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = putLine $ h - 1 + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = + putByteString $ runST $ runBoolWriter . putLine $ h - 1 where stride = fromIntegral $ linePadding 8 w putLine line | line < 0 = return () putLine line = do let lineIdx = line * w inner col | col >= w = return () - | otherwise = put (arr !!! (lineIdx + col)) >> inner (col + 1) + | otherwise = pushByte (arr !!! (lineIdx + col)) >> inner (col + 1) inner 0 stridePut stride putLine (line - 1) instance BmpEncodable PixelRGBA8 where bitsPerPixel _ = 32 - bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = putLine (h - 1) + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = + putByteString $ runST $ runBoolWriter . putLine $ h - 1 where putLine line | line < 0 = return () putLine line = do let initialIndex = line * w * 4 inner col _ | col >= w = return () inner col readIdx = do - put (arr !!! (readIdx + 2)) - put (arr !!! (readIdx + 1)) - put (arr !!! readIdx) - put (arr !!! (readIdx + 3)) + pushByte (arr !!! (readIdx + 2)) + pushByte (arr !!! (readIdx + 1)) + pushByte (arr !!! readIdx) + pushByte (arr !!! (readIdx + 3)) inner (col + 1) (readIdx + 4) inner 0 initialIndex putLine (line - 1) instance BmpEncodable PixelRGB8 where bitsPerPixel _ = 24 - bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = putLine (h - 1) + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = + putByteString $ runST $ runBoolWriter . putLine $ h - 1 where stride = fromIntegral . linePadding 24 $ w putLine line | line < 0 = return () putLine line = do let initialIndex = line * w * 3 inner col _ | col >= w = return () inner col readIdx = do - put (arr !!! (readIdx + 2)) - put (arr !!! (readIdx + 1)) - put (arr !!! readIdx) + pushByte (arr !!! (readIdx + 2)) + pushByte (arr !!! (readIdx + 1)) + pushByte (arr !!! readIdx) inner (col + 1) (readIdx + 3) inner 0 initialIndex stridePut stride
Codec/Picture/Gif/LZW.hs view
@@ -18,8 +18,7 @@ {-# INLINE (.!!!.) #-} (.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a -(.!!!.) = M.read - -- M.unsafeRead +(.!!!.) = M.unsafeRead -- M.read {-# INLINE (..!!!..) #-} (..!!!..) :: (MonadTrans t, PrimMonad m, Storable a) @@ -29,8 +28,7 @@ {-# INLINE (.<-.) #-} (.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m () -(.<-.) = M.write - -- M.unsafeWrite +(.<-.) = M.unsafeWrite -- M.write {-# INLINE (..<-..) #-} (..<-..) :: (MonadTrans t, PrimMonad m, Storable a) @@ -81,15 +79,16 @@ 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 + when (writeIdx < tableEntryCount) $ do + 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)
Codec/Picture/Jpg.hs view
@@ -823,7 +823,8 @@ -- | Try to decompress a jpeg file and decompress. The colorspace is still -- YCbCr if you want to perform computation on the luma part. You can --- convert it to RGB using 'colorSpaceConversion' +-- convert it to RGB using 'convertImage' from the 'ColorSpaceConvertible' +-- typeclass. -- -- This function can output the following pixel types : --
Codec/Picture/Types.hs view
@@ -538,8 +538,15 @@ writePixel mutImage x y $ f x y V.unsafeFreeze arr --- | This function implement the same algorithm as 'generateImage', --- and let use an user-defined state +-- | Create an image given a function to generate pixels. +-- The function will receive value from 0 to width-1 for the x parameter +-- and 0 to height-1 for the y parameter. The coordinate 0,0 is the upper +-- left corner of the image, and (width-1, height-1) the lower right corner. +-- +-- the acc parameter is a user defined one. +-- +-- The function is called for each pixel in the line from left to right (0 to width - 1) +-- and for each line (0 to height - 1). generateFoldImage :: forall a acc. (Pixel a) => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y -> acc -- ^ Initial state
JuicyPixels.cabal view
@@ -1,18 +1,31 @@ Name: JuicyPixels -Version: 2.0 +Version: 2.0.1 Synopsis: Picture loading/serialization (in png, jpeg, bitmap and gif) Description: 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 + read Gif images. + . + Version 2.0.1 changelog: + . + * Documentation enhancements. + . + * Fixing some huge gif file loading. + . + * Fixing performance problem of Bitmap and Jpeg savings. + . + 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 + . homepage: https://github.com/Twinside/Juicy.Pixels License: BSD3 @@ -34,7 +47,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v2.0 + Tag: v2.0.1 Library Default-Language: Haskell2010 @@ -48,7 +61,7 @@ Ghc-options: -O3 -Wall Build-depends: base >= 4 && < 5, - bytestring >= 0.9 && < 0.10, + bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.2, cereal >= 0.3.3.0 && < 0.4, zlib >= 0.5.3.1 && < 0.6,