diff --git a/Codec/Picture.hs b/Codec/Picture.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Main module exporting import/export functions into various +-- image formats. +-- +-- To use the library without thinking about it, look after 'decodeImage' and +-- 'readImage'. +-- +-- Generally, the read* functions read the images from a file and try to decode +-- it, and the decode* functions try to decode a bytestring. +-- +-- For an easy image writing use the write* functions and writeDynamic* functions. +module Codec.Picture ( + -- * Generic functions + readImage + , decodeImage + -- * Specific image format functions + -- ** Bitmap handling + , BmpEncodable + , writeBitmap + , encodeBitmap + , decodeBitmap + , encodeDynamicBitmap + , writeDynamicBitmap + + -- ** Jpeg handling + , readJpeg + , decodeJpeg + + -- ** Png handling + , PngSavable( .. ) + , readPng + , decodePng + , writePng + , encodeDynamicPng + , writeDynamicPng + + -- * Image types and pixel types + -- ** Image + , Image + , DynamicImage( .. ) + -- ** Pixels + , Pixel( .. ) + , Pixel8 + , PixelYA8( .. ) + , PixelRGB8( .. ) + , PixelRGBA8( .. ) + , PixelYCbCr8( .. ) + ) where + +import Control.Applicative( (<$>) ) +import Codec.Picture.Bitmap +import Codec.Picture.Jpg( readJpeg, decodeJpeg ) +import Codec.Picture.Png( PngSavable( .. ), readPng, decodePng, writePng + , encodeDynamicPng , writeDynamicPng ) +import Codec.Picture.Types + +import qualified Data.ByteString as B + +-- | Return the first Right thing, accumulating error +eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b +eitherLoad v = inner "" + where inner errAcc [] = Left $ "Cannot load file\n" ++ errAcc + inner errAcc ((hdr, f) : rest) = case f v of + Left err -> inner (errAcc ++ hdr ++ " " ++ err ++ "\n") rest + Right rez -> Right rez + +-- | Load an image file without even thinking about it, it does everything +-- as 'decodeImage' +readImage :: FilePath -> IO (Either String DynamicImage) +readImage path = decodeImage <$> B.readFile path + +-- | If you want to decode an image in a bytestring without even thinking +-- in term of format or whatever, this is the function to use. It will try +-- to decode in each known format and if one decoding succeed will return +-- the decoded image in it's own colorspace +decodeImage :: B.ByteString -> Either String DynamicImage +decodeImage str = eitherLoad str [("Jpeg", decodeJpeg) + ,("PNG", decodePng) + ] + diff --git a/Codec/Picture/Bitmap.hs b/Codec/Picture/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Bitmap.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | Modules used for Bitmap file (.bmp) file loading and writing +module Codec.Picture.Bitmap( -- * Functions + writeBitmap + , encodeBitmap + , decodeBitmap + , encodeDynamicBitmap + , writeDynamicBitmap + -- * Accepted formt in output + , BmpEncodable( ) + ) where +import Control.Monad( when, forM_ ) +import Data.Array.Base( unsafeAt, unsafeWrite ) +import Data.Array.Unboxed( IArray ) +import Data.Serialize( Serialize( .. ) + , putWord8, putWord16le, putWord32le + , getWord16le, getWord32le + , Get, Put, runGet, runPut + , remaining, getBytes ) +import Data.Word( Word32, Word16, Word8 ) +import Data.Array.ST( MArray, runSTUArray, newArray ) +import qualified Data.ByteString as B + +import Codec.Picture.Types + +data BmpHeader = BmpHeader + { magicIdentifier :: !Word16 + , fileSize :: !Word32 -- ^ in bytes + , reserved1 :: !Word16 + , reserved2 :: !Word16 + , dataOffset :: !Word32 + } + +bitmapMagicIdentifier :: Word16 +bitmapMagicIdentifier = 0x4D42 + +instance Serialize BmpHeader where + put hdr = do + putWord16le $ magicIdentifier hdr + putWord32le $ fileSize hdr + putWord16le $ reserved1 hdr + putWord16le $ reserved2 hdr + putWord32le $ dataOffset hdr + + get = do + ident <- getWord16le + when (ident /= bitmapMagicIdentifier) + (fail "Invalid Bitmap magic identifier") + fsize <- getWord32le + r1 <- getWord16le + r2 <- getWord16le + offset <- getWord32le + return BmpHeader + { magicIdentifier = ident + , fileSize = fsize + , reserved1 = r1 + , reserved2 = r2 + , dataOffset = offset + } + + +data BmpInfoHeader = BmpInfoHeader + { size :: !Word32 -- Header size in bytes + , width :: !Word32 + , height :: !Word32 + , planes :: !Word16 -- Number of colour planes + , bitPerPixel :: !Word16 + , bitmapCompression :: !Word32 + , byteImageSize :: !Word32 + , xResolution :: !Word32 -- ^ Pixels per meter + , yResolution :: !Word32 -- ^ Pixels per meter + , colorCount :: !Word32 + , importantColours :: !Word32 + } + +sizeofBmpHeader, sizeofBmpInfo :: Word32 +sizeofBmpHeader = 2 + 4 + 2 + 2 + 4 +sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4 + +instance Serialize BmpInfoHeader where + put hdr = do + putWord32le $ size hdr + putWord32le $ width hdr + putWord32le $ height hdr + putWord16le $ planes hdr + putWord16le $ bitPerPixel hdr + putWord32le $ bitmapCompression hdr + putWord32le $ byteImageSize hdr + putWord32le $ xResolution hdr + putWord32le $ yResolution hdr + putWord32le $ colorCount hdr + putWord32le $ importantColours hdr + + get = do + readSize <- getWord32le + readWidth <- getWord32le + readHeight <- getWord32le + readPlanes <- getWord16le + readBitPerPixel <- getWord16le + readBitmapCompression <- getWord32le + readByteImageSize <- getWord32le + readXResolution <- getWord32le + readYResolution <- getWord32le + readColorCount <- getWord32le + readImportantColours <- getWord32le + return BmpInfoHeader { + size = readSize, + width = readWidth, + height = readHeight, + planes = readPlanes, + bitPerPixel = readBitPerPixel, + bitmapCompression = readBitmapCompression, + byteImageSize = readByteImageSize, + xResolution = readXResolution, + yResolution = readYResolution, + colorCount = readColorCount, + importantColours = readImportantColours + } + +newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)] + +putPalette :: BmpPalette -> Put +putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p + +-- | All the instance of this class can be written as a bitmap file +-- using this library. +class BmpEncodable pixel where + bitsPerPixel :: pixel -> Int + bmpEncode :: Image pixel -> Put + defaultPalette :: pixel -> BmpPalette + defaultPalette _ = BmpPalette [] + +{-# INLINE (!!!) #-} +(!!!) :: (IArray array e) => array Int e -> Int -> e +(!!!) = unsafeAt -- (!) + +{-# INLINE stridePut #-} +stridePut :: Int -> Put +stridePut 0 = return () +stridePut 1 = putWord8 0 +stridePut n = putWord8 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 + 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) + inner 0 + stridePut stride + putLine (line - 1) + +instance BmpEncodable PixelRGBA8 where + bitsPerPixel _ = 32 + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = 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)) + 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) + 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) + inner (col + 1) (readIdx + 3) + inner 0 initialIndex + stridePut stride + putLine (line - 1) + +{-# INLINE (.<-.) #-} +(.<-.) :: (MArray array e m) => array Int e -> Int -> e -> m () +(.<-.) = unsafeWrite + +decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 +decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray + where wi = fromIntegral w + hi = fromIntegral h + stArray = runSTUArray $ do + arr <- newArray (0, fromIntegral $ w * h * 3) 128 + forM_ [hi - 1, hi - 2 .. 0] (readLine arr) + return arr + + stride = linePadding 24 wi + readLine arr line = + let readIndex = (wi * 3 + stride) * line + lastIndex = wi * (hi - 1 - line + 1) * 3 + writeIndex = wi * (hi - 1 - line) * 3 + + inner _ writeIdx | writeIdx >= lastIndex = return () + inner readIdx writeIdx = do + (arr .<-. writeIdx ) (str `B.index` (readIdx + 2)) + (arr .<-. (writeIdx + 1)) (str `B.index` (readIdx + 1)) + (arr .<-. (writeIdx + 2)) (str `B.index` readIdx) + inner (readIdx + 3) (writeIdx + 3) + + in inner readIndex writeIndex + + +-- | Try to decode a bitmap image. +-- Right now this function can output the following pixel types : +-- +-- * PixelRGB8 +-- +decodeBitmap :: B.ByteString -> Either String DynamicImage +decodeBitmap str = flip runGet str $ do + _hdr <- (get :: Get BmpHeader) + bmpHeader <- (get :: Get BmpInfoHeader) + case (bitPerPixel bmpHeader, planes bmpHeader, + bitmapCompression bmpHeader) of + -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" + (24, 1, 0) -> do + rest <- remaining >>= getBytes + return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest + _ -> fail "Can't handle BMP file" + + +-- | Write an image in a file use the bitmap format. +writeBitmap :: (BmpEncodable pixel) + => FilePath -> Image pixel -> IO () +writeBitmap filename img = B.writeFile filename $ encodeBitmap img + +linePadding :: Int -> Int -> Int +linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4 + where bytesPerLine = imgWidth * (fromIntegral bpp `div` 8) + +-- | Encode an image into a bytestring in .bmp format ready to be written +-- on disk. +encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> B.ByteString +encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel)) + + +-- | Write a dynamic image in a .bmp image file if possible. +-- The same restriction as encodeDynamicBitmap apply. +writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool) +writeDynamicBitmap path img = case encodeDynamicBitmap img of + Left err -> return $ Left err + Right b -> B.writeFile path b >> return (Right True) + +-- | Encode a dynamic image in bmp if possible, supported pixel type are : +-- +-- - RGB8 +-- +-- - RGBA8 +-- +-- - Y8 +-- +encodeDynamicBitmap :: DynamicImage -> Either String B.ByteString +encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img +encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img +encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img +encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export" + + +-- | Convert an image to a bytestring ready to be serialized. +encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel) + => BmpPalette -> Image pixel -> B.ByteString +encodeBitmapWithPalette pal@(BmpPalette palette) img = + runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img + where imgWidth = fromIntegral $ imageWidth img + imgHeight = fromIntegral $ imageHeight img + + paletteSize = fromIntegral $ length palette + bpp = bitsPerPixel (undefined :: pixel) + padding = linePadding bpp (imgWidth + 1) + imagePixelSize = fromIntegral $ (imgWidth + padding) * imgHeight * 4 + hdr = BmpHeader { + magicIdentifier = bitmapMagicIdentifier, + fileSize = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + imagePixelSize, + reserved1 = 0, + reserved2 = 0, + dataOffset = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + } + + info = BmpInfoHeader { + size = sizeofBmpInfo, + width = fromIntegral $ imgWidth, + height = fromIntegral $ imgHeight, + planes = 1, + bitPerPixel = fromIntegral $ bpp, + bitmapCompression = 0, -- no compression + byteImageSize = imagePixelSize, + xResolution = 0, + yResolution = 0, + colorCount = 0, + importantColours = paletteSize + } + + diff --git a/Codec/Picture/Jpg.hs b/Codec/Picture/Jpg.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Jpg.hs @@ -0,0 +1,819 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Module used for JPEG file loading and writing. +module Codec.Picture.Jpg( readJpeg, decodeJpeg ) where + +import Control.Applicative( (<$>), (<*>)) +import Control.Monad( when, replicateM, forM, forM_, foldM_, unless ) +import Control.Monad.ST( ST ) +import Control.Monad.Trans( lift ) +import qualified Control.Monad.Trans.State.Strict as S + +import Data.Array.Base( unsafeAt, unsafeRead, unsafeWrite ) +import Data.List( find, foldl' ) +import Data.Bits( (.|.), (.&.), shiftL, shiftR ) +import Data.Int( Int16, Int32 ) +import Data.Word(Word8, Word16, Word32) +import Data.Serialize( Serialize(..), Get, Put + , getWord8, putWord8 + , getWord16be, putWord16be + , remaining, lookAhead, skip + , getBytes, decode ) +import Data.Maybe( fromJust ) +import Data.Array.Unboxed( IArray, Array, UArray, elems, listArray) +import Data.Array.ST( STUArray, MArray, newArray, runSTUArray ) +import qualified Data.ByteString as B + +import Codec.Picture.Types +import Codec.Picture.Jpg.DefaultTable +import Codec.Picture.Jpg.FastIdct + + +-------------------------------------------------- +---- Types +-------------------------------------------------- +data JpgFrameKind = + JpgBaselineDCTHuffman + | JpgExtendedSequentialDCTHuffman + | JpgProgressiveDCTHuffman + | JpgLosslessHuffman + | JpgDifferentialSequentialDCTHuffman + | JpgDifferentialProgressiveDCTHuffman + | JpgDifferentialLosslessHuffman + | JpgExtendedSequentialArithmetic + | JpgProgressiveDCTArithmetic + | JpgLosslessArithmetic + | JpgDifferentialSequentialDCTArithmetic + | JpgDifferentialProgressiveDCTArithmetic + | JpgDifferentialLosslessArithmetic + | JpgQuantizationTable + | JpgHuffmanTableMarker + | JpgStartOfScan + | JpgAppSegment Word8 + | JpgExtensionSegment Word8 + + | JpgRestartInterval + deriving (Eq, Show) + + +data JpgFrame = + JpgAppFrame !Word8 B.ByteString + | JpgExtension !Word8 B.ByteString + | JpgQuantTable ![JpgQuantTableSpec] + | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanTree)] + | JpgScanBlob !JpgScanHeader !B.ByteString + | JpgScans !JpgFrameKind !JpgFrameHeader + | JpgIntervalRestart !Word16 + deriving Show + +data JpgFrameHeader = JpgFrameHeader + { jpgFrameHeaderLength :: !Word16 + , jpgSamplePrecision :: !Word8 + , jpgHeight :: !Word16 + , jpgWidth :: !Word16 + , jpgImageComponentCount :: !Word8 + , jpgComponents :: [JpgComponent] + } + deriving Show + +data JpgComponent = JpgComponent + { componentIdentifier :: !Word8 + -- | Stored with 4 bits + , horizontalSamplingFactor :: !Word8 + -- | Stored with 4 bits + , verticalSamplingFactor :: !Word8 + , quantizationTableDest :: !Word8 + } + deriving Show + +data JpgImage = JpgImage { jpgFrame :: [JpgFrame]} + deriving Show + +data JpgScanSpecification = JpgScanSpecification + { componentSelector :: !Word8 + -- | Encoded as 4 bits + , dcEntropyCodingTable :: !Word8 + -- | Encoded as 4 bits + , acEntropyCodingTable :: !Word8 + + } + deriving Show + +data JpgScanHeader = JpgScanHeader + { scanLength :: !Word16 + , scanComponentCount :: !Word8 + , scans :: [JpgScanSpecification] + + -- | (begin, end) + , spectralSelection :: (Word8, Word8) + + -- | Encoded as 4 bits + , successiveApproxHigh :: !Word8 + + -- | Encoded as 4 bits + , successiveApproxLow :: !Word8 + } + deriving Show + +data JpgQuantTableSpec = JpgQuantTableSpec + { -- | Stored on 4 bits + quantPrecision :: !Word8 + + -- | Stored on 4 bits + , quantDestination :: !Word8 + + , quantTable :: MacroBlock Int16 + } + deriving Show + +-- | Type introduced only to avoid some typeclass overlapping +-- problem +newtype TableList a = TableList [a] + +class SizeCalculable a where + calculateSize :: a -> Int + +instance (SizeCalculable a, Serialize a) => Serialize (TableList a) where + put (TableList lst) = do + putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + mapM_ put lst + + get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) + where innerParse :: Int -> Get [a] + innerParse 0 = return [] + innerParse size = do + onStart <- fromIntegral <$> remaining + table <- get + onEnd <- fromIntegral <$> remaining + (table :) <$> innerParse (size - (onStart - onEnd)) + +instance SizeCalculable JpgQuantTableSpec where + calculateSize table = + 1 + (fromIntegral (quantPrecision table) + 1) * 64 + +instance Serialize JpgQuantTableSpec where + put table = do + let precision = quantPrecision table + put4BitsOfEach precision (quantDestination table) + forM_ (elems $ quantTable table) $ \coeff -> + if precision == 0 then putWord8 $ fromIntegral coeff + else putWord16be $ fromIntegral coeff + + get = do + (precision, dest) <- get4BitOfEach + coeffs <- replicateM 64 $ if precision == 0 + then fromIntegral <$> getWord8 + else fromIntegral <$> getWord16be + return JpgQuantTableSpec + { quantPrecision = precision + , quantDestination = dest + , quantTable = listArray (0, 63) coeffs + } + +data JpgHuffmanTableSpec = JpgHuffmanTableSpec + { -- | 0 : DC, 1 : AC, stored on 4 bits + huffmanTableClass :: !DctComponent + -- | Stored on 4 bits + , huffmanTableDest :: !Word8 + + , huffSizes :: !(UArray Word32 Word8) + , huffCodes :: !(Array Word32 (UArray Int Word8)) + } + deriving Show + +buildPackedHuffmanTree :: Array Word32 (UArray Int Word8) -> HuffmanTree +buildPackedHuffmanTree = buildHuffmanTree . map elems . elems + +-- | Decode a list of huffman values, not optimized for speed, but it +-- should work. +huffmanDecode :: HuffmanTree -> BoolReader s Word8 +huffmanDecode originalTree = getNextBit >>= huffDecode originalTree + where huffDecode Empty _ = return 0 + huffDecode (Branch (Leaf v) _) False = return v + huffDecode (Branch l _ ) False = getNextBit >>= huffDecode l + huffDecode (Branch _ (Leaf v)) True = return v + huffDecode (Branch _ r ) True = getNextBit >>= huffDecode r + huffDecode (Leaf v) _ = return v + +-- | 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 + (idx, _, chain) <- S.get + when (idx /= 7) (setDecodedString chain) + +-- | Bitify a list of things to decode. +setDecodedString :: B.ByteString -> BoolReader s () +setDecodedString 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 (v, rest) -> S.put ( 7, v, rest) + +{-# INLINE getNextBit #-} +getNextBit :: BoolReader s Bool +getNextBit = do + (idx, v, chain) <- S.get + let val = (v .&. (1 `shiftL` idx)) /= 0 + if idx == 0 + then setDecodedString chain + else S.put (idx - 1, v, chain) + return val + +-------------------------------------------------- +---- Serialization instances +-------------------------------------------------- +commonMarkerFirstByte :: Word8 +commonMarkerFirstByte = 0xFF + +checkMarker :: Word8 -> Word8 -> Get () +checkMarker b1 b2 = do + rb1 <- getWord8 + rb2 <- getWord8 + when (rb1 /= b1 || rb2 /= b2) + (fail "Invalid marker used") + +eatUntilCode :: Get () +eatUntilCode = do + code <- lookAhead getWord8 + unless (code == 0xFF) + (skip 1 >> eatUntilCode) + +instance SizeCalculable JpgHuffmanTableSpec where + calculateSize table = 1 + 16 + sum [fromIntegral e | e <- elems $ huffSizes table] + +instance Serialize JpgHuffmanTableSpec where + put = error "Unimplemented" + get = do + (huffClass, huffDest) <- get4BitOfEach + sizes <- replicateM 16 getWord8 + codes <- forM sizes $ \s -> do + let si = fromIntegral s + listArray (0, si - 1) <$> replicateM (fromIntegral s) getWord8 + return JpgHuffmanTableSpec + { huffmanTableClass = + if huffClass == 0 then DcComponent else AcComponent + , huffmanTableDest = huffDest + , huffSizes = listArray (0, 15) sizes + , huffCodes = listArray (0, 15) codes + } + +instance Serialize JpgImage where + put = error "Unimplemented" + get = do + let startOfImageMarker = 0xD8 + -- endOfImageMarker = 0xD9 + checkMarker commonMarkerFirstByte startOfImageMarker + eatUntilCode + frames <- parseFrames + {-checkMarker commonMarkerFirstByte endOfImageMarker-} + return JpgImage { jpgFrame = frames } + +takeCurrentFrame :: Get B.ByteString +takeCurrentFrame = do + size <- getWord16be + getBytes (fromIntegral size - 2) + +parseFrames :: Get [JpgFrame] +parseFrames = do + kind <- get + case kind of + JpgAppSegment c -> + (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseFrames + JpgExtensionSegment c -> + (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseFrames + JpgQuantizationTable -> + (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseFrames + JpgRestartInterval -> + (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseFrames + JpgHuffmanTableMarker -> + (\(TableList huffTables) lst -> + JpgHuffmanTable [(t, buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) + <$> get <*> parseFrames + JpgStartOfScan -> + (\frm imgData -> [JpgScanBlob frm imgData]) + <$> get <*> (remaining >>= getBytes) + + _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseFrames + +secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 +secondStartOfFrameByteOfKind JpgBaselineDCTHuffman = 0xC0 +secondStartOfFrameByteOfKind JpgExtendedSequentialDCTHuffman = 0xC1 +secondStartOfFrameByteOfKind JpgProgressiveDCTHuffman = 0xC2 +secondStartOfFrameByteOfKind JpgLosslessHuffman = 0xC3 +secondStartOfFrameByteOfKind JpgDifferentialSequentialDCTHuffman = 0xC5 +secondStartOfFrameByteOfKind JpgDifferentialProgressiveDCTHuffman = 0xC6 +secondStartOfFrameByteOfKind JpgDifferentialLosslessHuffman = 0xC7 +secondStartOfFrameByteOfKind JpgExtendedSequentialArithmetic = 0xC9 +secondStartOfFrameByteOfKind JpgProgressiveDCTArithmetic = 0xCA +secondStartOfFrameByteOfKind JpgLosslessArithmetic = 0xCB +secondStartOfFrameByteOfKind JpgHuffmanTableMarker = 0xC4 +secondStartOfFrameByteOfKind JpgDifferentialSequentialDCTArithmetic = 0xCD +secondStartOfFrameByteOfKind JpgDifferentialProgressiveDCTArithmetic = 0xCE +secondStartOfFrameByteOfKind JpgDifferentialLosslessArithmetic = 0xCF +secondStartOfFrameByteOfKind JpgQuantizationTable = 0xDB +secondStartOfFrameByteOfKind JpgStartOfScan = 0xDA +secondStartOfFrameByteOfKind JpgRestartInterval = 0xDD +secondStartOfFrameByteOfKind (JpgAppSegment a) = a +secondStartOfFrameByteOfKind (JpgExtensionSegment a) = a + +instance Serialize JpgFrameKind where + put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) + get = do + word <- getWord8 + word2 <- getWord8 + when (word /= 0xFF) (do leftData <- remaining + fail $ "Invalid Frame marker (" ++ show word + ++ ", remaining : " ++ show leftData ++ ")") + return $ case word2 of + 0xC0 -> JpgBaselineDCTHuffman + 0xC1 -> JpgExtendedSequentialDCTHuffman + 0xC2 -> JpgProgressiveDCTHuffman + 0xC3 -> JpgLosslessHuffman + 0xC4 -> JpgHuffmanTableMarker + 0xC5 -> JpgDifferentialSequentialDCTHuffman + 0xC6 -> JpgDifferentialProgressiveDCTHuffman + 0xC7 -> JpgDifferentialLosslessHuffman + 0xC9 -> JpgExtendedSequentialArithmetic + 0xCA -> JpgProgressiveDCTArithmetic + 0xCB -> JpgLosslessArithmetic + 0xCD -> JpgDifferentialSequentialDCTArithmetic + 0xCE -> JpgDifferentialProgressiveDCTArithmetic + 0xCF -> JpgDifferentialLosslessArithmetic + 0xDA -> JpgStartOfScan + 0xDB -> JpgQuantizationTable + 0xDD -> JpgRestartInterval + a | a >= 0xF0 -> JpgExtensionSegment a + | a >= 0xE0 -> JpgAppSegment a + | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") + +put4BitsOfEach :: Word8 -> Word8 -> Put +put4BitsOfEach a b = put $ (a `shiftL` 4) .|. b + +get4BitOfEach :: Get (Word8, Word8) +get4BitOfEach = do + val <- get + return ((val `shiftR` 4) .&. 0xF, val .&. 0xF) + +newtype RestartInterval = RestartInterval Word16 + +instance Serialize RestartInterval where + put (RestartInterval i) = putWord16be 4 >> putWord16be i + get = do + size <- getWord16be + when (size /= 4) (fail "Invalid jpeg restart interval size") + RestartInterval <$> getWord16be + +instance Serialize JpgComponent where + get = do + ident <- getWord8 + (horiz, vert) <- get4BitOfEach + quantTableIndex <- getWord8 + return JpgComponent + { componentIdentifier = ident + , horizontalSamplingFactor = horiz + , verticalSamplingFactor = vert + , quantizationTableDest = quantTableIndex + } + put v = do + put $ componentIdentifier v + put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v + put $ quantizationTableDest v + +instance Serialize JpgFrameHeader where + get = do + beginOffset <- remaining + frmHLength <- getWord16be + samplePrec <- getWord8 + h <- getWord16be + w <- getWord16be + compCount <- getWord8 + components <- replicateM (fromIntegral compCount) get + endOffset <- remaining + when (beginOffset - endOffset < fromIntegral frmHLength) + (skip $ fromIntegral frmHLength - (beginOffset - endOffset)) + return JpgFrameHeader + { jpgFrameHeaderLength = frmHLength + , jpgSamplePrecision = samplePrec + , jpgHeight = h + , jpgWidth = w + , jpgImageComponentCount = compCount + , jpgComponents = components + } + + put v = do + putWord16be $ jpgFrameHeaderLength v + putWord8 $ jpgSamplePrecision v + putWord16be $ jpgHeight v + putWord16be $ jpgWidth v + putWord8 $ jpgImageComponentCount v + mapM_ put $ jpgComponents v + +instance Serialize JpgScanSpecification where + put v = do + put $ componentSelector v + put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v + + get = do + compSel <- get + (dc, ac) <- get4BitOfEach + return JpgScanSpecification { + componentSelector = compSel + , dcEntropyCodingTable = dc + , acEntropyCodingTable = ac + } + +instance Serialize JpgScanHeader where + get = do + thisScanLength <- getWord16be + compCount <- getWord8 + comp <- replicateM (fromIntegral compCount) get + specBeg <- get + specEnd <- get + (approxHigh, approxLow) <- get4BitOfEach + return JpgScanHeader { + scanLength = thisScanLength, + scanComponentCount = compCount, + scans = comp, + spectralSelection = (specBeg, specEnd), + successiveApproxHigh = approxHigh, + successiveApproxLow = approxLow + } + + put v = do + put $ scanLength v + put $ scanComponentCount v + mapM_ put $ scans v + put . fst $ spectralSelection v + put . snd $ spectralSelection v + put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v + +-- | Current bit index, current value, string +type BoolState = (Int, Word8, B.ByteString) + +type BoolReader s a = S.StateT BoolState (ST s) a + +{-# INLINE (!!!) #-} +(!!!) :: (IArray array e) => array Int e -> Int -> e +(!!!) = unsafeAt + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (MArray array e m) => array Int e -> Int -> m e +(.!!!.) = unsafeRead + +{-# INLINE (.<-.) #-} +(.<-.) :: (MArray array e m) => array Int e -> Int -> e -> m () +(.<-.) = unsafeWrite + +-- | Apply a quantization matrix to a macroblock +{-# INLINE deQuantize #-} +deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +deQuantize table block = dequant 0 >> return block + where updateVal i = do + val <- block .!!!. i + let quantCoeff = table !!! i + newVal = val * quantCoeff + (block .<-. i) newVal + + dequant 63 = updateVal 63 + dequant n = updateVal n >> dequant (n + 1) + +inverseDirectCosineTransform :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +inverseDirectCosineTransform mBlock = + fastIdct mBlock >>= mutableLevelShift + +zigZagOrder :: MacroBlock Word8 +zigZagOrder = makeMacroBlock $ concat + [[ 0, 1, 5, 6,14,15,27,28] + ,[ 2, 4, 7,13,16,26,29,42] + ,[ 3, 8,12,17,25,30,41,43] + ,[ 9,11,18,24,31,40,44,53] + ,[10,19,23,32,39,45,52,54] + ,[20,22,33,38,46,51,55,60] + ,[21,34,37,47,50,56,59,61] + ,[35,36,48,49,57,58,62,63] + ] + +zigZagReorder :: MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) +zigZagReorder block = do + zigzaged <- newArray (0, 63) 0 + let update i = do + let idx = zigZagOrder !!! i + v <- block .!!!. fromIntegral idx + (zigzaged .<-. i) v + + reorder 63 = update 63 + reorder i = update i >> reorder (i + 1) + + reorder 0 + return zigzaged + + +-- | This is one of the most important function of the decoding, +-- it form the barebone decoding pipeline for macroblock. It's all +-- there is to know for macro block transformation +decodeMacroBlock :: MacroBlock DctCoefficients + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +decodeMacroBlock quantizationTable block = + deQuantize quantizationTable block >>= zigZagReorder + >>= inverseDirectCosineTransform + +packInt :: [Bool] -> Int32 +packInt = foldl' bitStep 0 + where bitStep acc True = (acc `shiftL` 1) + 1 + bitStep acc False = acc `shiftL` 1 + +-- | Unpack an int of the given size encoded from MSB to LSB. +unpackInt :: Int32 -> BoolReader s Int32 +unpackInt bitCount = packInt <$> replicateM (fromIntegral bitCount) getNextBit + +decodeInt :: Int32 -> BoolReader s Int32 +decodeInt ssss = do + signBit <- getNextBit + let dataRange = 1 `shiftL` fromIntegral (ssss - 1) + leftBitCount = ssss - 1 + -- First following bits store the sign of the coefficient, and counted in + -- SSSS, so the bit count for the int, is ssss - 1 + if signBit + then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount + else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount + +dcCoefficientDecode :: HuffmanTree -> BoolReader s DcCoefficient +dcCoefficientDecode dcTree = do + ssss <- huffmanDecode dcTree + if ssss == 0 + then return 0 + else fromIntegral <$> decodeInt (fromIntegral ssss) + +-- | Assume the macro block is initialized with zeroes +acCoefficientsDecode :: HuffmanTree -> MutableMacroBlock s Int16 + -> BoolReader s (MutableMacroBlock s Int16) +acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock + where parseAcCoefficient n | n >= 64 = return () + | otherwise = do + rrrrssss <- huffmanDecode acTree + let rrrr = fromIntegral $ (rrrrssss `shiftR` 4) .&. 0xF + ssss = rrrrssss .&. 0xF + case (rrrr, ssss) of + ( 0, 0) -> return () + (0xF, 0) -> parseAcCoefficient (n + 16) + _ -> do + decoded <- fromIntegral <$> decodeInt (fromIntegral ssss) + lift $ (mutableBlock .<-. (n + rrrr)) decoded + parseAcCoefficient (n + rrrr + 1) + +-- | Decompress a macroblock from a bitstream given the current configuration +-- from the frame. +decompressMacroBlock :: HuffmanTree -- ^ Tree used for DC coefficient + -> HuffmanTree -- ^ Tree used for Ac coefficient + -> MacroBlock Int16 -- ^ Current quantization table + -> DcCoefficient -- ^ Previous dc value + -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16) +decompressMacroBlock dcTree acTree quantizationTable previousDc = do + dcDeltaCoefficient <- dcCoefficientDecode dcTree + block <- lift createEmptyMutableMacroBlock + let neoDcCoefficient = previousDc + dcDeltaCoefficient + lift $ (block .<-. 0) neoDcCoefficient + fullBlock <- acCoefficientsDecode acTree block + decodedBlock <- lift $ decodeMacroBlock quantizationTable fullBlock + return (neoDcCoefficient, decodedBlock) + +gatherQuantTables :: JpgImage -> [JpgQuantTableSpec] +gatherQuantTables img = concat [t | JpgQuantTable t <- jpgFrame img] + +gatherHuffmanTables :: JpgImage -> [(JpgHuffmanTableSpec, HuffmanTree)] +gatherHuffmanTables img = concat [lst | JpgHuffmanTable lst <- jpgFrame img] + +gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader) +gatherScanInfo img = fromJust $ unScan <$> find scanDesc (jpgFrame img) + where scanDesc (JpgScans _ _) = True + scanDesc _ = False + + unScan (JpgScans a b) = (a,b) + unScan _ = error "If this can happen, the JPEG image is ill-formed" + +pixelClamp :: Int16 -> Word8 +pixelClamp n = fromIntegral . min 255 $ max 0 n + +-- | Given a size coefficient (how much a pixel span horizontally +-- and vertically), the position of the macroblock, return a list +-- of indices and value to be stored in an array (like the final +-- image) +unpackMacroBlock :: Int -- ^ Component count + -> Int -- ^ Component index + -> Int -- ^ Width coefficient + -> Int -- ^ Height coefficient + -> Int -- ^ x + -> Int -- ^ y + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () + -- Simple case, a macroblock value => a pixel +unpackMacroBlock compCount compIdx wCoeff hCoeff x y + (MutableImage { mutableImageWidth = imgWidth, + mutableImageHeight = imgHeight, mutableImageData = img }) + block = do + forM_ pixelIndices $ \(i, j, wDup, hDup) -> do + let xPos = (i + x * 8) * wCoeff + wDup + yPos = (j + y * 8) * hCoeff + hDup + when (0 <= xPos && xPos < imgWidth && 0 <= yPos && yPos < imgHeight) + (do compVal <- pixelClamp <$> (block .!!!. (i + j * 8)) + let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx + (img .<-. mutableIdx) compVal) + + where pixelIndices = [(i, j, wDup, hDup) | i <- [0 .. 7], j <- [0 .. 7] + -- Repetition to spread macro block + , wDup <- [0 .. wCoeff - 1] + , hDup <- [0 .. hCoeff - 1] + ] + +-- | Type only used to make clear what kind of integer we are carrying +-- Might be transformed into newtype in the future +type DcCoefficient = Int16 + +-- | Same as for DcCoefficient, to provide nicer type signatures +type DctCoefficients = DcCoefficient + +decodeRestartInterval :: BoolReader s Int32 +decodeRestartInterval = return (-1) {- do + bits <- replicateM 8 getNextBit + if bits == replicate 8 True + then do + marker <- replicateM 8 getNextBit + return $ packInt marker + else return (-1) + -} + + +decodeImage :: Int -- ^ Component count + -> JpegDecoder s -- ^ Function to call to decode an MCU + -> MutableImage s PixelYCbCr8 -- ^ Result image to write into + -> BoolReader s () +decodeImage compCount decoder img = do + let blockIndices = [(x,y) | y <- [0 .. verticalMcuCount decoder - 1] + , x <- [0 .. horizontalMcuCount decoder - 1] ] + mcuDecode = mcuDecoder decoder + blockBeforeRestart = restartInterval decoder + + folder f = foldM_ f blockBeforeRestart blockIndices + + dcArray <- lift (newArray (0, compCount - 1) 0 :: ST s (STUArray s Int DcCoefficient)) + folder (\resetCounter (x,y) -> do + when (resetCounter == 0) + (do forM_ [0.. compCount - 1] $ + \c -> lift $ (dcArray .<-. c) 0 + byteAlign + _restartCode <- decodeRestartInterval + -- if 0xD0 <= restartCode && restartCode <= 0xD7 + return ()) + + forM_ mcuDecode $ \(comp, dataUnitDecoder) -> do + dc <- lift $ dcArray .!!!. comp + dcCoeff <- dataUnitDecoder x y img $ fromIntegral dc + lift $ (dcArray .<-. comp) dcCoeff + return () + + if resetCounter /= 0 then return $ resetCounter - 1 + -- we use blockBeforeRestart - 1 to count + -- the current MCU + else return $ blockBeforeRestart - 1) + +-- | Type of a data unit (as in the ITU 81) standard +type DataUnitDecoder s = + (Int, Int -> Int -> MutableImage s PixelYCbCr8 -> DcCoefficient -> BoolReader s DcCoefficient) + +data JpegDecoder s = JpegDecoder + { restartInterval :: Int + , horizontalMcuCount :: Int + , verticalMcuCount :: Int + , mcuDecoder :: [DataUnitDecoder s] + } + +allElementsEqual :: (Eq a) => [a] -> Bool +allElementsEqual [] = True +allElementsEqual (x:xs) = all (== x) xs + +-- | An MCU (Minimal coded unit) is an unit of data for all components +-- (Y, Cb & Cr), taking into account downsampling. +buildJpegImageDecoder :: JpgImage -> JpegDecoder s +buildJpegImageDecoder img = JpegDecoder { restartInterval = mcuBeforeRestart + , horizontalMcuCount = horizontalBlockCount + , verticalMcuCount = verticalBlockCount + , mcuDecoder = mcus } + where huffmans = gatherHuffmanTables img + huffmanForComponent dcOrAc dest = + head [t | (h,t) <- huffmans, huffmanTableClass h == dcOrAc + , huffmanTableDest h == dest] + + mcuBeforeRestart = case [i | JpgIntervalRestart i <- jpgFrame img] of + [] -> maxBound -- HUUUUUUGE value (enough to parse all MCU) + (x:_) -> fromIntegral x + + quants = gatherQuantTables img + quantForComponent dest = + head [quantTable q | q <- quants, quantDestination q == dest] + + hdr = head [h | JpgScanBlob h _ <- jpgFrame img] + + (_, scanInfo) = gatherScanInfo img + imgWidth = fromIntegral $ jpgWidth scanInfo + imgHeight = fromIntegral $ jpgHeight scanInfo + + blockSizeOfDim fullDim maxBlockSize = block + (if rest /= 0 then 1 else 0) + where (block, rest) = fullDim `divMod` maxBlockSize + + horizontalSamplings = [horiz | (horiz, _, _, _, _) <- componentsInfo] + + imgComponentCount = fromIntegral $ jpgImageComponentCount scanInfo + isImageLumanOnly = imgComponentCount == 1 + maxHorizFactor | not isImageLumanOnly && + not (allElementsEqual horizontalSamplings) = maximum horizontalSamplings + | otherwise = 1 + + verticalSamplings = [vert | (_, vert, _, _, _) <- componentsInfo] + maxVertFactor | not isImageLumanOnly && + not (allElementsEqual verticalSamplings) = maximum verticalSamplings + | otherwise = 1 + + horizontalBlockCount = + blockSizeOfDim imgWidth $ fromIntegral (maxHorizFactor * 8) + + verticalBlockCount = + blockSizeOfDim imgHeight $ fromIntegral (maxVertFactor * 8) + + fetchTablesForComponent component = (horizCount, vertCount, dcTree, acTree, qTable) + where idx = componentIdentifier component + descr = head [c | c <- scans hdr, componentSelector c == idx] + dcTree = huffmanForComponent DcComponent $ dcEntropyCodingTable descr + acTree = huffmanForComponent AcComponent $ acEntropyCodingTable descr + qTable = quantForComponent $ if idx == 1 then 0 else 1 + horizCount = if not isImageLumanOnly + then fromIntegral $ horizontalSamplingFactor component + else 1 + vertCount = if not isImageLumanOnly + then fromIntegral $ verticalSamplingFactor component + else 1 + + componentsInfo = map fetchTablesForComponent $ jpgComponents scanInfo + + mcus = [(compIdx, \x y writeImg dc -> do + (dcCoeff, block) <- decompressMacroBlock dcTree acTree qTable dc + lift $ unpacker (x * horizCount + xd) (y * vertCount + yd) writeImg block + return dcCoeff) + | (compIdx, (horizCount, vertCount, dcTree, acTree, qTable)) + <- zip [0..] componentsInfo + , let xScalingFactor = maxHorizFactor - horizCount + 1 + yScalingFactor = maxVertFactor - vertCount + 1 + , yd <- [0 .. vertCount - 1] + , xd <- [0 .. horizCount - 1] + , let unpacker = unpackMacroBlock imgComponentCount compIdx + xScalingFactor yScalingFactor + ] + +-- | 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 +-- convert it to RGB using 'colorSpaceConversion' +readJpeg :: FilePath -> IO (Either String DynamicImage) +readJpeg f = decodeJpeg <$> B.readFile f + +-- | 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' +-- +-- This function can output the following pixel types : +-- +-- * PixelY8 +-- +-- * PixelYCbCr8 +-- +decodeJpeg :: B.ByteString -> Either String DynamicImage +decodeJpeg file = case decode file of + Left err -> Left err + Right img -> case compCount of + 1 -> Right . ImageY8 $ Image imgWidth imgHeight pixelData + 3 -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData + _ -> Left "Wrong component count" + + where (imgData:_) = [d | JpgScanBlob _kind d <- jpgFrame img] + (_, scanInfo) = gatherScanInfo img + compCount = length $ jpgComponents scanInfo + + imgWidth = fromIntegral $ jpgWidth scanInfo + imgHeight = fromIntegral $ jpgHeight scanInfo + + imageSize = (0, imgWidth * imgHeight * compCount - 1) + + pixelData = runSTUArray $ S.evalStateT (do + resultImage <- lift $ newArray imageSize 0 + let wrapped = MutableImage imgWidth imgHeight resultImage + setDecodedString imgData + decodeImage compCount (buildJpegImageDecoder img) wrapped + return resultImage) (-1, 0, B.empty) + diff --git a/Codec/Picture/Jpg/DefaultTable.hs b/Codec/Picture/Jpg/DefaultTable.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Jpg/DefaultTable.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Module used by the jpeg decoder internally, shouldn't be used +-- in user code. +module Codec.Picture.Jpg.DefaultTable( DctComponent( .. ) + , HuffmanTree( .. ) + , MacroBlock + , makeMacroBlock + , buildHuffmanTree + {- + , defaultChromaQuantizationTable + , defaultLumaQuantizationTable + , defaultAcChromaHuffmanTable + , defaultAcLumaHuffmanTable + , defaultDcChromaHuffmanTable + , defaultDcLumaHuffmanTable + -} + ) where + +import Data.Array.Unboxed( IArray, UArray, listArray ) +import Data.Word( Word8 ) +import Data.List( foldl' ) + +-- | Tree storing the code used for huffman encoding. +data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right. + | Leaf Word8 -- ^ We should output the value + | Empty -- ^ no value present + deriving (Eq, Show) + +-- | Represent a compact array of 8 * 8 values. The size +-- is not guarenteed by type system, but if makeMacroBlock is +-- used, everything should be fine size-wise +type MacroBlock a = UArray Int a + +-- | Helper function to create pure macro block of the good size. +makeMacroBlock :: (IArray UArray a) => [a] -> MacroBlock a +makeMacroBlock = listArray (0, 63) + +-- | Enumeration used to search in the tables for different components. +data DctComponent = DcComponent | AcComponent + deriving (Eq, Show) + +-- | Transform parsed coefficients from the jpeg header to a +-- tree which can be used to decode data. +buildHuffmanTree :: [[Word8]] -> HuffmanTree +buildHuffmanTree table = foldl' insertHuffmanVal Empty + . concatMap (\(i, t) -> map (i + 1,) t) + $ zip ([0..] :: [Int]) table + where isTreeFullyDefined Empty = False + isTreeFullyDefined (Leaf _) = True + isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r + + insertHuffmanVal Empty (0, val) = Leaf val + insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty + insertHuffmanVal (Branch l r) (d, val) + | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val)) + | otherwise = Branch (insertHuffmanVal l (d - 1, val)) r + insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen" + +{- +defaultLumaQuantizationTable :: MacroBlock Int16 +defaultLumaQuantizationTable = makeMacroBlock + [16, 11, 10, 16, 24, 40, 51, 61 + ,12, 12, 14, 19, 26, 58, 60, 55 + ,14, 13, 16, 24, 40, 57, 69, 56 + ,14, 17, 22, 29, 51, 87, 80, 62 + ,18, 22, 37, 56, 68, 109, 103, 77 + ,24, 35, 55, 64, 81, 104, 113, 92 + ,49, 64, 78, 87, 103, 121, 120, 101 + ,72, 92, 95, 98, 112, 100, 103, 99 + ] + +defaultChromaQuantizationTable :: MacroBlock Int16 +defaultChromaQuantizationTable = makeMacroBlock + [17, 18, 24, 47, 99, 99, 99, 99 + ,18, 21, 26, 66, 99, 99, 99, 99 + ,24, 26, 56, 99, 99, 99, 99, 99 + ,47, 66, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ] +-- | From the Table K.3 of ITU-81 (p153) +defaultDcLumaHuffmanTable :: HuffmanTree +defaultDcLumaHuffmanTable = buildHuffmanTree + [ [] + , [0] + , [1, 2, 3, 4, 5] + , [6] + , [7] + , [8] + , [9] + , [10] + , [11] + , [] + , [] + , [] + , [] + , [] + , [] + , [] + ] + +-- | From the Table K.4 of ITU-81 (p153) +defaultDcChromaHuffmanTable :: HuffmanTree +defaultDcChromaHuffmanTable = buildHuffmanTree + [ [] + , [0, 1, 2] + , [3] + , [4] + , [5] + , [6] + , [7] + , [8] + , [9] + , [10] + , [11] + , [] + , [] + , [] + , [] + , [] + ] + +-- | From the Table K.5 of ITU-81 (p154) +defaultAcLumaHuffmanTable :: HuffmanTree +defaultAcLumaHuffmanTable = buildHuffmanTree + [ [] + , [0x01, 0x02] + , [0x03] + , [0x00, 0x04, 0x11] + , [0x05, 0x12, 0x21] + , [0x31, 0x41] + , [0x06, 0x13, 0x51, 0x61] + , [0x07, 0x22, 0x71] + , [0x14, 0x32, 0x81, 0x91, 0xA1] + , [0x08, 0x23, 0x42, 0xB1, 0xC1] + , [0x15, 0x52, 0xD1, 0xF0] + , [0x24, 0x33, 0x62, 0x72] + , [] + , [] + , [0x82] + , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35 + ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54 + ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 + ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A + ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7 + ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4 + ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA + ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5 + ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA] + ] + +defaultAcChromaHuffmanTable :: HuffmanTree +defaultAcChromaHuffmanTable = buildHuffmanTree + [ [] + , [0x00, 0x01] + , [0x02] + , [0x03, 0x11] + , [0x04, 0x05, 0x21, 0x31] + , [0x06, 0x12, 0x41, 0x51] + , [0x07, 0x61, 0x71] + , [0x13, 0x22, 0x32, 0x81] + , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1] + , [0x09, 0x23, 0x33, 0x52, 0xF0] + , [0x15, 0x62, 0x72, 0xD1] + , [0x0A, 0x16, 0x24, 0x34] + , [] + , [0xE1] + , [0x25, 0xF1] + , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35 + , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47 + , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59 + , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 + , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84 + , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95 + , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6 + , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7 + , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8 + , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9 + , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA + , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA + ] + ] +-} diff --git a/Codec/Picture/Jpg/FastIdct.hs b/Codec/Picture/Jpg/FastIdct.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Jpg/FastIdct.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Module providing a 'fast' implementation of IDCT +-- +-- inverse two dimensional DCT, Chen-Wang algorithm +-- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984) +-- 32-bit integer arithmetic (8 bit coefficients) +-- 11 mults, 29 adds per DCT +-- sE, 18.8.91 +-- +-- coefficients extended to 12 bit for IEEE1180-1990 +-- compliance sE, 2.1.94 +-- +-- this code assumes >> to be a two's-complement arithmetic +-- right shift: (-2)>>1 == -1 , (-3)>>1 == -2 +module Codec.Picture.Jpg.FastIdct( MutableMacroBlock + , fastIdct + , mutableLevelShift + , createEmptyMutableMacroBlock + ) where + +import Data.Array.Base( IArray, UArray, unsafeAt + , unsafeRead, unsafeWrite, listArray ) +import Data.Array.ST( MArray, STUArray, newArray ) +import Control.Monad( forM_ ) +import Control.Monad.ST( ST ) +import Data.Bits( shiftL, shiftR ) +import Data.Int( Int16 ) + +iclip :: UArray Int Int16 +iclip = listArray (-512, 512) [ val i| i <- [(-512) .. 511]] + where val i | i < (-256) = -256 + | i > 255 = 255 + | otherwise = i + + + +{-# INLINE (.<<.) #-} +{-# INLINE (.>>.) #-} +(.<<.), (.>>.) :: Int -> Int -> Int +(.<<.) = shiftL +(.>>.) = shiftR + +data IDctStage = IDctStage { + x0 :: {-# UNPACK #-} !Int, + x1 :: {-# UNPACK #-} !Int, + x2 :: {-# UNPACK #-} !Int, + x3 :: {-# UNPACK #-} !Int, + x4 :: {-# UNPACK #-} !Int, + x5 :: {-# UNPACK #-} !Int, + x6 :: {-# UNPACK #-} !Int, + x7 :: {-# UNPACK #-} !Int, + x8 :: {-# UNPACK #-} !Int + } + +w1, w2, w3, w5, w6, w7 :: Int +w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16) +w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16) +w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16) +w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16) +w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16) +w7 = 565 -- 2048*sqrt(2)*cos(7*pi/16) + +{-# INLINE (!!!) #-} +(!!!) :: (IArray array e) => array Int e -> Int -> e +(!!!) a i = unsafeAt a (i + 512) + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (MArray array e m) => array Int e -> Int -> m e +(.!!!.) = unsafeRead + +{-# INLINE (.<-.) #-} +(.<-.) :: (MArray array e m) => array Int e -> Int -> e -> m () +(.<-.) = unsafeWrite + +-- | Macroblock that can be transformed. +type MutableMacroBlock s a = STUArray s Int a + +{-# INLINE createEmptyMutableMacroBlock #-} +-- | Create a new macroblock with the good array size +createEmptyMutableMacroBlock :: ST s (MutableMacroBlock s Int16) +createEmptyMutableMacroBlock = newArray (0, 63) 0 + +-- row (horizontal) IDCT +-- +-- 7 pi 1 +-- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l ) +-- l=0 8 2 +-- +-- where: c[0] = 128 +-- c[1..7] = 128*sqrt(2) +idctRow :: MutableMacroBlock s Int16 -> Int -> ST s () +idctRow blk idx = do + xx0 <- blk .!!!. (0 + idx) + xx1 <- blk .!!!. (4 + idx) + xx2 <- blk .!!!. (6 + idx) + xx3 <- blk .!!!. (2 + idx) + xx4 <- blk .!!!. (1 + idx) + xx5 <- blk .!!!. (7 + idx) + xx6 <- blk .!!!. (5 + idx) + xx7 <- blk .!!!. (3 + idx) + let initialState = IDctStage { x0 = (fromIntegral xx0 .<<. 11) + 128 + , x1 = fromIntegral xx1 .<<. 11 + , x2 = fromIntegral xx2 + , x3 = fromIntegral xx3 + , x4 = fromIntegral xx4 + , x5 = fromIntegral xx5 + , x6 = fromIntegral xx6 + , x7 = fromIntegral xx7 + , x8 = 0 + } + + firstStage c = c { x4 = x8' + (w1 - w7) * x4 c + , x5 = x8' - (w1 + w7) * x5 c + , x6 = x8'' - (w3 - w5) * x6 c + , x7 = x8'' - (w3 + w5) * x7 c + , x8 = x8'' + } + where x8' = w7 * (x4 c + x5 c) + x8'' = w3 * (x6 c + x7 c) + + secondStage c = c { x0 = x0 c - x1 c + , x8 = x0 c + x1 c + , x1 = x1'' + , x2 = x1' - (w2 + w6) * x2 c + , x3 = x1' + (w2 - w6) * x3 c + , x4 = x4 c - x6 c + , x6 = x5 c + x7 c + , x5 = x5 c - x7 c + } + where x1' = w6 * (x3 c + x2 c) + x1'' = x4 c + x6 c + + thirdStage c = c { x7 = x8 c + x3 c + , x8 = x8 c - x3 c + , x3 = x0 c + x2 c + , x0 = x0 c - x2 c + , x2 = (181 * (x4 c + x5 c) + 128) .>>. 8 + , x4 = (181 * (x4 c - x5 c) + 128) .>>. 8 + } + scaled c = c { x0 = (x7 c + x1 c) .>>. 8 + , x1 = (x3 c + x2 c) .>>. 8 + , x2 = (x0 c + x4 c) .>>. 8 + , x3 = (x8 c + x6 c) .>>. 8 + , x4 = (x8 c - x6 c) .>>. 8 + , x5 = (x0 c - x4 c) .>>. 8 + , x6 = (x3 c - x2 c) .>>. 8 + , x7 = (x7 c - x1 c) .>>. 8 + } + transformed = scaled . thirdStage . secondStage $ firstStage initialState + + (blk .<-. (0 + idx)) . fromIntegral $ x0 transformed + (blk .<-. (1 + idx)) . fromIntegral $ x1 transformed + (blk .<-. (2 + idx)) . fromIntegral $ x2 transformed + (blk .<-. (3 + idx)) . fromIntegral $ x3 transformed + (blk .<-. (4 + idx)) . fromIntegral $ x4 transformed + (blk .<-. (5 + idx)) . fromIntegral $ x5 transformed + (blk .<-. (6 + idx)) . fromIntegral $ x6 transformed + (blk .<-. (7 + idx)) . fromIntegral $ x7 transformed + +-- column (vertical) IDCT +-- +-- 7 pi 1 +-- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l ) +-- l=0 8 2 +-- +-- where: c[0] = 1/1024 +-- c[1..7] = (1/1024)*sqrt(2) +-- +idctCol :: MutableMacroBlock s Int16 -> Int -> ST s () +idctCol blk idx = do + xx0 <- blk .!!!. (8 * 0 + idx) + xx1 <- blk .!!!. (8 * 4 + idx) + xx2 <- blk .!!!. (8 * 6 + idx) + xx3 <- blk .!!!. (8 * 2 + idx) + xx4 <- blk .!!!. (8 * 1 + idx) + xx5 <- blk .!!!. (8 * 7 + idx) + xx6 <- blk .!!!. (8 * 5 + idx) + xx7 <- blk .!!!. (8 * 3 + idx) + let initialState = IDctStage { x0 = (fromIntegral xx0 .<<. 8) + 8192 + , x1 = fromIntegral xx1 .<<. 8 + , x2 = fromIntegral xx2 + , x3 = fromIntegral xx3 + , x4 = fromIntegral xx4 + , x5 = fromIntegral xx5 + , x6 = fromIntegral xx6 + , x7 = fromIntegral xx7 + , x8 = 0 + } + firstStage c = c { x4 = (x8' + (w1 - w7) * x4 c) .>>. 3 + , x5 = (x8' - (w1 + w7) * x5 c) .>>. 3 + , x6 = (x8'' - (w3 - w5) * x6 c) .>>. 3 + , x7 = (x8'' - (w3 + w5) * x7 c) .>>. 3 + , x8 = x8'' + } + where x8' = w7 * (x4 c + x5 c) + 4 + x8'' = w3 * (x6 c + x7 c) + 4 + + secondStage c = c { x8 = x0 c + x1 c + , x0 = x0 c - x1 c + , x2 = (x1' - (w2 + w6) * x2 c) .>>. 3 + , x3 = (x1' + (w2 - w6) * x3 c) .>>. 3 + , x4 = x4 c - x6 c + , x1 = x1'' + , x6 = x5 c + x7 c + , x5 = x5 c - x7 c + } + where x1' = w6 * (x3 c + x2 c) + 4 + x1'' = x4 c + x6 c + + thirdStage c = c { x7 = x8 c + x3 c + , x8 = x8 c - x3 c + , x3 = x0 c + x2 c + , x0 = x0 c - x2 c + , x2 = (181 * (x4 c + x5 c) + 128) .>>. 8 + , x4 = (181 * (x4 c - x5 c) + 128) .>>. 8 + } + + f = thirdStage . secondStage $ firstStage initialState + (blk .<-. (idx + 8*0)) $ iclip !!! ((x7 f + x1 f) .>>. 14) + (blk .<-. (idx + 8*1)) $ iclip !!! ((x3 f + x2 f) .>>. 14) + (blk .<-. (idx + 8*2)) $ iclip !!! ((x0 f + x4 f) .>>. 14) + (blk .<-. (idx + 8*3)) $ iclip !!! ((x8 f + x6 f) .>>. 14) + (blk .<-. (idx + 8*4)) $ iclip !!! ((x8 f - x6 f) .>>. 14) + (blk .<-. (idx + 8*5)) $ iclip !!! ((x0 f - x4 f) .>>. 14) + (blk .<-. (idx + 8*6)) $ iclip !!! ((x3 f - x2 f) .>>. 14) + (blk .<-. (idx + 8*7)) $ iclip !!! ((x7 f - x1 f) .>>. 14) + + +{-# INLINE fastIdct #-} +-- | Algorithm to call to perform an IDCT, return the same +-- block that the one given as input. +fastIdct :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +fastIdct block = do + forM_ [0..7] (\i -> idctRow block (8 * i)) + forM_ [0..7] (idctCol block) + return block + +{-# INLINE mutableLevelShift #-} +-- | Perform a Jpeg level shift in a mutable fashion. +mutableLevelShift :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +mutableLevelShift block = do + forM_ [0..63] (\i -> do + v <- block .!!!. i + (block .<-. i) $ v + 128) + return block + diff --git a/Codec/Picture/Png.hs b/Codec/Picture/Png.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Png.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BangPatterns #-} +-- | Module used for loading & writing \'Portable Network Graphics\' (PNG) +-- files. The API has two layers, the high level, which load the image without +-- looking deeply about it and the low level, allowing access to data chunks contained +-- in the PNG image. +-- +-- For general use, please use 'decodePng' function. +-- +-- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html) +module Codec.Picture.Png( -- * High level functions + PngSavable( .. ) + + , readPng + , decodePng + , writePng + , encodeDynamicPng + , writeDynamicPng + + ) where + +import Control.Monad( foldM_, forM_, when ) +import Control.Monad.ST( ST ) +import Control.Monad.Trans( lift ) +import qualified Control.Monad.Trans.State.Strict as S +import Data.Serialize( Serialize, runGet, get) + +import Data.Array.Base( unsafeAt, unsafeRead, unsafeWrite ) +-- import Data.Array.Unboxed( (!) ) +-- import Data.Array.ST( readArray, writeArray ) + +import Data.Array.Unboxed( IArray, UArray, listArray, bounds, elems ) +import Data.Array.ST( STUArray, runSTUArray, MArray, newArray, getBounds ) +import Data.Bits( (.&.), (.|.), shiftL, shiftR ) +import Data.List( find, zip4 ) +import Data.Word( Word8, Word16, Word32 ) +import qualified Codec.Compression.Zlib as Z +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb + +import Codec.Picture.Types +import Codec.Picture.Png.Type +import Codec.Picture.Png.Export + +-- | Simple structure used to hold information about Adam7 deinterlacing. +-- A structure is used to avoid pollution of the module namespace. +data Adam7MatrixInfo = Adam7MatrixInfo + { adam7StartingRow :: [Int] + , adam7StartingCol :: [Int] + , adam7RowIncrement :: [Int] + , adam7ColIncrement :: [Int] + , adam7BlockHeight :: [Int] + , adam7BlockWidth :: [Int] + } + +-- | The real info about the matrix. +adam7MatrixInfo :: Adam7MatrixInfo +adam7MatrixInfo = Adam7MatrixInfo + { adam7StartingRow = [0, 0, 4, 0, 2, 0, 1] + , adam7StartingCol = [0, 4, 0, 2, 0, 1, 0] + , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2] + , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1] + , adam7BlockHeight = [8, 8, 4, 4, 2, 2, 1] + , adam7BlockWidth = [8, 4, 4, 2, 2, 1, 1] + } + +unparsePngFilter :: Word8 -> Either String PngFilter +unparsePngFilter 0 = Right FilterNone +unparsePngFilter 1 = Right FilterSub +unparsePngFilter 2 = Right FilterUp +unparsePngFilter 3 = Right FilterAverage +unparsePngFilter 4 = Right FilterPaeth +unparsePngFilter _ = Left "Invalid scanline filter" + +type ByteReader s a = S.StateT B.ByteString (ST s) a + +{-# INLINE getNextByte #-} +getNextByte :: ByteReader s Word8 +getNextByte = do str <- S.get + case B.uncons str of + Just (v, rest) -> S.put rest >> return v + Nothing -> return 0 + +{-# INLINE (!!!) #-} +(!!!) :: (IArray array e) => array Int e -> Int -> e +(!!!) = unsafeAt + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (MArray array e m) => array Int e -> Int -> m e +(.!!!.) = unsafeRead + +{-# INLINE (.<-.) #-} +(.<-.) :: (MArray array e m) => array Int e -> Int -> e -> m () +(.<-.) = unsafeWrite + +-- | Apply a filtering method on a reduced image. Apply the filter +-- on each line, using the previous line (the one above it) to perform +-- some prediction on the value. +pngFiltering :: LineUnpacker s -> Int -> (Int, Int) -- ^ Image size + -> ByteReader s () +pngFiltering _ _ (imgWidth, imgHeight) | imgWidth <= 0 || imgHeight <= 0 = return () +pngFiltering unpacker beginZeroes (imgWidth, imgHeight) = do + thisLine <- lift $ newArray (0, beginZeroes + imgWidth - 1) 0 + otherLine <- lift $ newArray (0, beginZeroes + imgWidth - 1) 0 + foldM_ (\(previousLine, currentLine) lineIndex -> do + byte <- getNextByte + let lineFilter = case unparsePngFilter byte of + Right FilterNone -> filterNone + Right FilterSub -> filterSub + Right FilterAverage -> filterAverage + Right FilterUp -> filterUp + Right FilterPaeth -> filterPaeth + _ -> filterNone + lineFilter (previousLine, currentLine) + lift $ unpacker lineIndex (stride, currentLine) + return (currentLine, previousLine) + ) (thisLine, otherLine) [0 .. imgHeight - 1] + + where stride = fromIntegral beginZeroes + lastIdx = beginZeroes + imgWidth - 1 + + -- The filter implementation are... well non-idiomatic + -- to say the least, but my benchmarks proved me one thing, + -- they are faster than mapM_, gained something like 5% with + -- a rewrite from mapM_ to this direct version + filterNone, filterSub, filterUp, filterPaeth, + filterAverage :: (PngLine s, PngLine s) -> ByteReader s () + filterNone (_previousLine, thisLine) = inner beginZeroes + where inner idx | idx > lastIdx = return () + | otherwise = do byte <- getNextByte + lift $ (thisLine .<-. idx) byte + inner (idx + 1) + + filterSub (_previousLine, thisLine) = inner beginZeroes + where inner idx | idx > lastIdx = return () + | otherwise = do byte <- getNextByte + val <- lift $ thisLine .!!!. (idx - stride) + lift . (thisLine .<-. idx) $ byte + val + inner (idx + 1) + + filterUp (previousLine, thisLine) = inner beginZeroes + where inner idx | idx > lastIdx = return () + | otherwise = do byte <- getNextByte + val <- lift $ previousLine .!!!. idx + lift . (thisLine .<-. idx) $ val + byte + inner (idx + 1) + + filterAverage (previousLine, thisLine) = inner beginZeroes + where inner idx | idx > lastIdx = return () + | otherwise = do byte <- getNextByte + valA <- lift $ thisLine .!!!. (idx - stride) + valB <- lift $ previousLine .!!!. idx + let a' = fromIntegral valA + b' = fromIntegral valB + average = fromIntegral ((a' + b') `div` (2 :: Word16)) + writeVal = byte + average + lift . (thisLine .<-. idx) $ writeVal + inner (idx + 1) + + filterPaeth (previousLine, thisLine) = inner beginZeroes + where inner idx | idx > lastIdx = return () + | otherwise = do byte <- getNextByte + valA <- lift $ thisLine .!!!. (idx - stride) + valC <- lift $ previousLine .!!!. (idx - stride) + valB <- lift $ previousLine .!!!. idx + lift . (thisLine .<-. idx) $ byte + paeth valA valB valC + inner (idx + 1) + +-- | Directly stolen from the definition in the standard (on W3C page), +-- pixel predictor. +paeth :: Word8 -> Word8 -> Word8 -> Word8 +paeth a b c + | pa <= pb && pa <= pc = a + | pb <= pc = b + | otherwise = c + where a' = fromIntegral a :: Int + b' = fromIntegral b + c' = fromIntegral c + p = a' + b' - c' + pa = abs $ p - a' + pb = abs $ p - b' + pc = abs $ p - c' + +type PngLine s = STUArray s Int Word8 +type LineUnpacker s = Int -> (Int, PngLine s) -> ST s () + +type StrideInfo = (Int, Int) + +type BeginOffset = (Int, Int) + + +-- | Unpack lines where bit depth is 8 +byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +byteUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, maxIdx) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount + inner pixelIndex | pixelIndex > pixelToRead = return () + | otherwise = do + let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft + destSampleIndex = destPixelIndex * sampleCount + srcPixelIndex = pixelIndex * sampleCount + beginIdx + perPixel sample | sample >= sampleCount = return () + | otherwise = (do + val <- line .!!!. (srcPixelIndex + sample) + let writeIdx = destSampleIndex + sample + (arr .<-. writeIdx) val + perPixel (sample + 1)) + perPixel 0 + inner (pixelIndex + 1) + inner 0 + + +-- | Unpack lines where bit depth is 1 +bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, endLine) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth + subPadd | subImageRest > 0 = 1 + | otherwise = 0 + (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8 + forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do + val <- line .!!!. (pixelIndex + beginIdx) + let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft + forM_ [0 .. 7] $ \bit -> (arr .<-. writeIdx (7 - bit)) ((val `shiftR` bit) .&. 1) + + when (lineRest /= 0) + (do val <- line .!!!. endLine + let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft + forM_ [0 .. lineRest - 1] $ \bit -> + (arr .<-. writeIdx bit) $ ((val `shiftR` (7 - bit)) .&. 0x1)) + + +-- | Unpack lines when bit depth is 2 +twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, endLine) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth + subPadd | subImageRest > 0 = 1 + | otherwise = 0 + (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4 + + forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do + val <- line .!!!. (pixelIndex + beginIdx) + let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft + (arr .<-. writeIdx 0) $ (val `shiftR` 6) .&. 0x3 + (arr .<-. writeIdx 1) $ (val `shiftR` 4) .&. 0x3 + (arr .<-. writeIdx 2) $ (val `shiftR` 2) .&. 0x3 + (arr .<-. writeIdx 3) $ val .&. 0x3 + + when (lineRest /= 0) + (do val <- line .!!!. endLine + let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft + forM_ [0 .. lineRest - 1] $ \bit -> + (arr .<-. writeIdx bit) $ ((val `shiftR` (6 - 2 * bit)) .&. 0x3)) + +halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, endLine) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth + subPadd | subImageRest > 0 = 1 + | otherwise = 0 + (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2 + forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do + val <- line .!!!. (pixelIndex + beginIdx) + let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft + (arr .<-. writeIdx 0) $ (val `shiftR` 4) .&. 0xF + (arr .<-. writeIdx 1) $ val .&. 0xF + + when (lineRest /= 0) + (do val <- line .!!!. endLine + let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft + (arr .<-. writeIdx) $ (val `shiftR` 4) .&. 0xF) + +shortUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, maxIdx) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2) + forM_ [0 .. pixelToRead] $ \pixelIndex -> do + let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft + destSampleIndex = destPixelIndex * sampleCount + srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx + forM_ [0 .. sampleCount - 1] $ \sample -> do + highBits <- line .!!!. (srcPixelIndex + sample * 2 + 0) + lowBits <- line .!!!. (srcPixelIndex + sample * 2 + 1) + let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `shiftL` 8) :: Word32 + word8Max = 2 ^ (8 :: Word32) - 1 :: Word32 + word16Max = 2 ^ (16 :: Word32) - 1 :: Word32 + val = fullValue * word8Max `div` word16Max + writeIdx = destSampleIndex + sample + (arr .<-. writeIdx) $ fromIntegral val + +-- | Transform a scanline to a bunch of bytes. Bytes are then packed +-- into pixels at a further step. +scanlineUnpacker :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +scanlineUnpacker 1 = bitUnpacker +scanlineUnpacker 2 = twoBitsUnpacker +scanlineUnpacker 4 = halfByteUnpacker +scanlineUnpacker 8 = byteUnpacker +scanlineUnpacker 16 = shortUnpacker +scanlineUnpacker _ = error "Impossible bit depth" + +byteSizeOfBitLength :: Int -> Int -> Int -> Int +byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0) + where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8 + +scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) + -> ByteReader s () +scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker = + pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) + where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth + strideInfo | depth < 8 = 1 + | otherwise = sampleCount * (depth `div` 8) + +-- | Given data and image size, recreate an image with deinterlaced +-- data for PNG's adam 7 method. +adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) + -> ByteReader s () +adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker = sequence_ + [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) + | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement + , let passWidth = sizer imgWidth beginW incrW + passHeight = sizer imgHeight beginH incrH + byteWidth = byteSizeOfBitLength depth sampleCount passWidth + ] + where Adam7MatrixInfo { adam7StartingRow = startRows + , adam7RowIncrement = rowIncrement + , adam7StartingCol = startCols + , adam7ColIncrement = colIncrement } = adam7MatrixInfo + + strideInfo | depth < 8 = 1 + | otherwise = sampleCount * (depth `div` 8) + sizer dimension begin increment + | dimension <= begin = 0 + | otherwise = outDim + (if restDim /= 0 then 1 else 0) + where (outDim, restDim) = (dimension - begin) `quotRem` increment + +-- | deinterlace picture in function of the method indicated +-- in the iHDR +deinterlacer :: PngIHdr -> ByteReader s (STUArray s Int Word8) +deinterlacer (PngIHdr { width = w, height = h, colourType = imgKind + , interlaceMethod = method, bitDepth = depth }) = do + let compCount = sampleCountOfImageType imgKind + arraySize = fromIntegral $ w * h * compCount + deinterlaceFunction = case method of + PngNoInterlace -> scanLineInterleaving + PngInterlaceAdam7 -> adam7Unpack + iBitDepth = fromIntegral depth + imgArray <- lift $ newArray (0, arraySize - 1) 0 + let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray + deinterlaceFunction iBitDepth + (fromIntegral compCount) + (fromIntegral w, fromIntegral h) + (scanlineUnpacker iBitDepth (fromIntegral compCount) + mutableImage) + return imgArray + +generateGreyscalePalette :: Word8 -> PngPalette +generateGreyscalePalette times = listArray (0, fromIntegral possibilities) pixels + where possibilities = 2 ^ times - 1 + pixels = [PixelRGB8 i i i | n <- [0..possibilities] + , let i = n * (255 `div` possibilities)] + +sampleCountOfImageType :: PngImageType -> Word32 +sampleCountOfImageType PngGreyscale = 1 +sampleCountOfImageType PngTrueColour = 3 +sampleCountOfImageType PngIndexedColor = 1 +sampleCountOfImageType PngGreyscaleWithAlpha = 2 +sampleCountOfImageType PngTrueColourWithAlpha = 4 + +paletteRGBA1, paletteRGBA2, paletteRGBA4 :: PngPalette +paletteRGBA1 = generateGreyscalePalette 1 +paletteRGBA2 = generateGreyscalePalette 2 +paletteRGBA4 = generateGreyscalePalette 4 + +applyPalette :: PngPalette -> UArray Int Word8 -> UArray Int Word8 +applyPalette pal img = listArray (0, (initSize + 1) * 3 - 1) pixels + where (_, initSize) = bounds img + pixels = concat [[r, g, b] | ipx <- elems img + , let PixelRGB8 r g b = pal !!! fromIntegral ipx] + +-- | Helper function trying to load a png file from a file on disk. +readPng :: FilePath -> IO (Either String DynamicImage) +readPng path = B.readFile path >>= return . decodePng + +-- | Transform a raw png image to an image, without modifying the +-- underlying pixel type. If the image is greyscale and < 8 bits, +-- a transformation to RGBA8 is performed. This should change +-- in the future. +-- The resulting image let you manage the pixel types. +-- +-- This function can output the following pixel types : +-- +-- * PixelY8 +-- +-- * PixelYA8 +-- +-- * PixelRGB8 +-- +-- * PixelRGBA8 +-- +decodePng :: B.ByteString -> Either String DynamicImage +decodePng byte = do + rawImg <- runGet get byte + let ihdr@(PngIHdr { width = w, height = h }) = header rawImg + compressedImageData = + B.concat [chunkData chunk | chunk <- chunks rawImg + , chunkType chunk == iDATSignature] + zlibHeaderSize = 1 {- compression method/flags code -} + + 1 {- Additional flags/check bits -} + + 4 {-CRC-} + + imager = Image (fromIntegral w) (fromIntegral h) + + unparse _ PngGreyscale bytes + | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) PngIndexedColor bytes + | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) PngIndexedColor bytes + | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) PngIndexedColor bytes + | otherwise = Right . ImageY8 . imager $ runSTUArray stArray + where stArray = S.evalStateT (deinterlacer ihdr) bytes + unparse Nothing PngIndexedColor _ = Left "no valid palette found" + unparse _ PngTrueColour bytes = + Right . ImageRGB8 . imager $ runSTUArray stArray + where stArray = S.evalStateT (deinterlacer ihdr) bytes + unparse _ PngGreyscaleWithAlpha bytes = + Right . ImageYA8 . imager $ runSTUArray stArray + where stArray = S.evalStateT (deinterlacer ihdr) bytes + unparse _ PngTrueColourWithAlpha bytes = + Right . ImageRGBA8 . imager $ runSTUArray stArray + where stArray = S.evalStateT (deinterlacer ihdr) bytes + unparse (Just plte) PngIndexedColor bytes = + Right . ImageRGB8 . imager $ applyPalette plte uarray + where stArray = S.evalStateT (deinterlacer ihdr) bytes + uarray = runSTUArray stArray + + if B.length compressedImageData <= zlibHeaderSize + then Left "Invalid data size" + else let imgData = Z.decompress $ Lb.fromChunks [compressedImageData] + parseableData = B.concat $ Lb.toChunks imgData + palette = case find (\c -> pLTESignature == chunkType c) $ chunks rawImg of + Nothing -> Nothing + Just p -> case parsePalette p of + Left _ -> Nothing + Right plte -> Just plte + in unparse palette (colourType ihdr) parseableData + diff --git a/Codec/Picture/Png/Export.hs b/Codec/Picture/Png/Export.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Png/Export.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | Module implementing a basic png export, no filtering is applyed, but +-- export at least valid images. +module Codec.Picture.Png.Export( PngSavable( .. ) + , writePng + , encodeDynamicPng + , writeDynamicPng + ) where + +import Data.Serialize(encode) +import Data.Array.Unboxed((!)) +import Data.Word(Word8) +import qualified Codec.Compression.Zlib as Z +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb + +import Codec.Picture.Types +import Codec.Picture.Png.Type + +-- | Encode an image into a png if possible. +class PngSavable a where + -- | Transform an image into a png encoded bytestring, ready + -- to be writte as a file. + encodePng :: Image a -> B.ByteString + +preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr +preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr + { width = fromIntegral w + , height = fromIntegral h + , bitDepth = depth + , colourType = imgType + , compressionMethod = 0 + , filterMethod = 0 + , interlaceMethod = PngNoInterlace + } + +-- | Helper function to directly write an image as a png on disk. +writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () +writePng path img = B.writeFile path $ encodePng img + +endChunk :: PngRawChunk +endChunk = PngRawChunk { chunkLength = 0 + , chunkType = iENDSignature + , chunkCRC = pngComputeCrc [iENDSignature] + , chunkData = B.empty + } + + +prepareIDatChunk :: B.ByteString -> PngRawChunk +prepareIDatChunk imgData = PngRawChunk + { chunkLength = fromIntegral $ B.length imgData + , chunkType = iDATSignature + , chunkCRC = pngComputeCrc [iDATSignature, imgData] + , chunkData = imgData + } + +genericEncodePng :: PngImageType -> Int -> Image a -> B.ByteString +genericEncodePng imgKind compCount + image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = + encode PngRawImage { header = hdr, chunks = [prepareIDatChunk strictEncoded, endChunk]} + where hdr = preparePngHeader image imgKind 8 + compBound = compCount - 1 + encodeLine line = + 0 : [arr ! ((line * w + column) * compCount + comp) | column <- [0 .. w - 1] + , comp <- [0 .. compBound]] + imgEncodedData = Z.compress . Lb.pack + $ concat [encodeLine line | line <- [0 .. h - 1]] + strictEncoded = B.concat $ Lb.toChunks imgEncodedData + +instance PngSavable PixelRGBA8 where + encodePng = genericEncodePng PngTrueColourWithAlpha 4 + +instance PngSavable PixelRGB8 where + encodePng = genericEncodePng PngTrueColour 3 + +instance PngSavable Pixel8 where + encodePng = genericEncodePng PngGreyscale 1 + +-- | Write a dynamic image in a .png image file if possible. +-- The same restriction as encodeDynamicPng apply. +writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) +writeDynamicPng path img = case encodeDynamicPng img of + Left err -> return $ Left err + Right b -> B.writeFile path b >> return (Right True) + +-- | Encode a dynamic image in bmp if possible, supported pixel type are : +-- +-- - 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 _ = Left "Unsupported image format for PNG export" diff --git a/Codec/Picture/Png/Type.hs b/Codec/Picture/Png/Type.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Png/Type.hs @@ -0,0 +1,315 @@ +-- | Low level png module, you should import 'Codec.Picture.Png' instead. +module Codec.Picture.Png.Type( PngIHdr( .. ) + , PngFilter( .. ) + , PngInterlaceMethod( .. ) + , PngPalette + , PngImageType( .. ) + , parsePalette + , pngComputeCrc + , pLTESignature + , iDATSignature + , iENDSignature + -- * Low level types + , ChunkSignature + , PngRawImage( .. ) + , PngChunk( .. ) + , PngRawChunk( .. ) + , PngLowLevel( .. ) + ) where + +import Control.Applicative( (<$>) ) +import Control.Monad( when, replicateM ) +import Data.Bits( xor, (.&.), shiftR ) +import Data.Serialize( Serialize(..), Get, get, runGet, runPut + , putWord8, getWord8 + , putWord32be, getWord32be + , getByteString, putByteString ) +import Data.Array.Unboxed( Array, UArray, listArray, (!) ) +import Data.List( foldl' ) +import Data.Word( Word32, Word8 ) +import qualified Data.ByteString as B + +import Codec.Picture.Types + +-------------------------------------------------- +---- Types +-------------------------------------------------- + +-- | Value used to identify a png chunk, must be 4 bytes long. +type ChunkSignature = B.ByteString + +-- | Generic header used in PNG images. +data PngIHdr = PngIHdr + { width :: Word32 -- ^ Image width in number of pixel + , height :: Word32 -- ^ Image height in number of pixel + , bitDepth :: Word8 -- ^ Number of bit per sample + , colourType :: PngImageType -- ^ Kind of png image (greyscale, true color, indexed...) + , compressionMethod :: Word8 -- ^ Compression method used + , filterMethod :: Word8 -- ^ Must be 0 + , interlaceMethod :: PngInterlaceMethod -- ^ If the image is interlaced (for progressive rendering) + } + deriving Show + +-- | What kind of information is encoded in the IDAT section +-- of the PngFile +data PngImageType = + PngGreyscale + | PngTrueColour + | PngIndexedColor + | PngGreyscaleWithAlpha + | PngTrueColourWithAlpha + deriving Show + +-- | Raw parsed image which need to be decoded. +data PngRawImage = PngRawImage + { header :: PngIHdr + , chunks :: [PngRawChunk] + } + +-- | Palette with indices beginning at 0 to elemcount - 1 +type PngPalette = Array Int PixelRGB8 + +-- | Parse a palette from a png chunk. +parsePalette :: PngRawChunk -> Either String PngPalette +parsePalette plte + | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" + | otherwise = listArray (0, pixelCount - 1) <$> runGet pixelUnpacker (chunkData plte) + where pixelUnpacker = replicateM (fromIntegral pixelCount) get + pixelCount = fromIntegral $ chunkLength plte `div` 3 + +-- | Data structure during real png loading/parsing +data PngRawChunk = PngRawChunk + { chunkLength :: Word32 + , chunkType :: ChunkSignature + , chunkCRC :: Word32 + , chunkData :: B.ByteString + } + +-- | PNG chunk representing some extra information found in the parsed file. +data PngChunk = PngChunk + { pngChunkData :: B.ByteString -- ^ The raw data inside the chunk + , pngChunkSignature :: ChunkSignature -- ^ The name of the chunk. + } + +-- | Low level access to PNG information +data PngLowLevel a = PngLowLevel + { pngImage :: Image a -- ^ The real uncompressed image + , pngChunks :: [PngChunk] -- ^ List of raw chunk where some user data might be present. + } + +-- | The pixels value should be : +-- +---+---+ +-- | c | b | +-- +---+---+ +-- | a | x | +-- +---+---+ +-- x being the current filtered pixel +data PngFilter = + -- | Filt(x) = Orig(x), Recon(x) = Filt(x) + FilterNone + -- | Filt(x) = Orig(x) - Orig(a), Recon(x) = Filt(x) + Recon(a) + | FilterSub + -- | Filt(x) = Orig(x) - Orig(b), Recon(x) = Filt(x) + Recon(b) + | FilterUp + -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2), + -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2) + | FilterAverage + -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)), + -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c)) + | FilterPaeth + deriving (Enum, Show) + +-- | Different known interlace methods for PNG image +data PngInterlaceMethod = + -- | No interlacing, basic data ordering, line by line + -- from left to right. + PngNoInterlace + + -- | Use the Adam7 ordering, see `adam7Reordering` + | PngInterlaceAdam7 + deriving (Enum, Show) + +-------------------------------------------------- +---- Instances +-------------------------------------------------- +instance Serialize PngFilter where + put = putWord8 . toEnum . fromEnum + get = getWord8 >>= \w -> case w of + 0 -> return FilterNone + 1 -> return FilterSub + 2 -> return FilterUp + 3 -> return FilterAverage + 4 -> return FilterPaeth + _ -> fail "Invalid scanline filter" + +instance Serialize PngRawImage where + put img = do + putByteString pngSignature + put $ header img + mapM_ put $ chunks img + + get = parseRawPngImage + +instance Serialize PngRawChunk where + put chunk = do + putWord32be $ chunkLength chunk + putByteString $ chunkType chunk + when (chunkLength chunk /= 0) + (putByteString $ chunkData chunk) + putWord32be $ chunkCRC chunk + + get = do + size <- getWord32be + chunkSig <- getByteString (B.length iHDRSignature) + imgData <- if size == 0 + then return B.empty + else getByteString (fromIntegral size) + crc <- getWord32be + + let computedCrc = pngComputeCrc [chunkSig, imgData] + when (computedCrc `xor` crc /= 0) + (fail $ "Invalid CRC : " ++ show computedCrc ++ ", " + ++ show crc) + return PngRawChunk { + chunkLength = size, + chunkData = imgData, + chunkCRC = crc, + chunkType = chunkSig + } + +instance Serialize PngIHdr where + put hdr = do + putWord32be 13 + let inner = runPut $ do + putByteString iHDRSignature + putWord32be $ width hdr + putWord32be $ height hdr + putWord8 $ bitDepth hdr + put $ colourType hdr + put $ compressionMethod hdr + put $ filterMethod hdr + put $ interlaceMethod hdr + crc = pngComputeCrc [inner] + putByteString inner + putWord32be crc + + get = do + _size <- getWord32be + ihdrSig <- getByteString (B.length iHDRSignature) + when (ihdrSig /= iHDRSignature) + (fail "Invalid PNG file, wrong ihdr") + w <- getWord32be + h <- getWord32be + depth <- get + colorType <- get + compression <- get + filtermethod <- get + interlace <- get + _crc <- getWord32be + return PngIHdr { + width = w, + height = h, + bitDepth = depth, + colourType = colorType, + compressionMethod = compression, + filterMethod = filtermethod, + interlaceMethod = interlace + } + +-- | Parse method for a png chunk, without decompression. +parseChunks :: Get [PngRawChunk] +parseChunks = do + chunk <- get + + if chunkType chunk == iENDSignature + then return [chunk] + else (chunk:) <$> parseChunks + + +instance Serialize PngInterlaceMethod where + get = getWord8 >>= \w -> case w of + 0 -> return PngNoInterlace + 1 -> return PngInterlaceAdam7 + _ -> fail "Invalid interlace method" + + put PngNoInterlace = putWord8 0 + put PngInterlaceAdam7 = putWord8 1 + +-- | Implementation of the get method for the PngRawImage, +-- unpack raw data, without decompressing it. +parseRawPngImage :: Get PngRawImage +parseRawPngImage = do + sig <- getByteString (B.length pngSignature) + when (sig /= pngSignature) + (fail "Invalid PNG file, signature broken") + + ihdr <- get + + chunkList <- parseChunks + return PngRawImage { header = ihdr, chunks = chunkList } + +-------------------------------------------------- +---- functions +-------------------------------------------------- + +-- | Signature signalling that the following data will be a png image +-- in the png bit stream +pngSignature :: ChunkSignature +pngSignature = signature [137, 80, 78, 71, 13, 10, 26, 10] + +-- | Helper function to help pack signatures. +signature :: [Word8] -> ChunkSignature +signature = B.pack . map (toEnum . fromEnum) + +-- | Signature for the header chunk of png (must be the first) +iHDRSignature :: ChunkSignature +iHDRSignature = signature [73, 72, 68, 82] + +-- | Signature for a palette chunk in the pgn file. Must +-- occure before iDAT. +pLTESignature :: ChunkSignature +pLTESignature = signature [80, 76, 84, 69] + +-- | Signature for a data chuck (with image parts in it) +iDATSignature :: ChunkSignature +iDATSignature = signature [73, 68, 65, 84] + +-- | Signature for the last chunk of a png image, telling +-- the end. +iENDSignature :: ChunkSignature +iENDSignature = signature [73, 69, 78, 68] + +instance Serialize PngImageType where + put PngGreyscale = putWord8 0 + put PngTrueColour = putWord8 2 + put PngIndexedColor = putWord8 3 + put PngGreyscaleWithAlpha = putWord8 4 + put PngTrueColourWithAlpha = putWord8 6 + + get = get >>= imageTypeOfCode + +imageTypeOfCode :: Word8 -> Get PngImageType +imageTypeOfCode 0 = return PngGreyscale +imageTypeOfCode 2 = return PngTrueColour +imageTypeOfCode 3 = return PngIndexedColor +imageTypeOfCode 4 = return PngGreyscaleWithAlpha +imageTypeOfCode 6 = return PngTrueColourWithAlpha +imageTypeOfCode _ = fail "Invalid png color code" + +-- | From the Annex D of the png specification. +pngCrcTable :: UArray Word32 Word32 +pngCrcTable = listArray (0, 255) [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ] + where zero = 0 :: Int -- To avoid defaulting to Integer + updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `shiftR` 1) + | otherwise = c `shiftR` 1 + magicConstant = 0xedb88320 :: Word32 + +-- | Compute the CRC of a raw buffer, as described in annex D of the PNG +-- specification. +pngComputeCrc :: [B.ByteString] -> Word32 +pngComputeCrc = (0xFFFFFFFF `xor`) . B.foldl' updateCrc 0xFFFFFFFF . B.concat + where updateCrc crc val = + let u32Val = fromIntegral val + lutVal = pngCrcTable ! ((crc `xor` u32Val) .&. 0xFF) + in lutVal `xor` (crc `shiftR` 8) + diff --git a/Codec/Picture/Types.hs b/Codec/Picture/Types.hs new file mode 100644 --- /dev/null +++ b/Codec/Picture/Types.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | Module providing the basic types for image manipulation in the library. +-- Defining the types used to store all those _Juicy Pixels_ +module Codec.Picture.Types( -- * Types + -- ** Image types + Image( .. ) + , MutableImage( .. ) + , DynamicImage( .. ) + , PixelType( .. ) + -- ** Pixel types + , Pixel8 + , PixelYA8( .. ) + , PixelRGB8( .. ) + , PixelRGBA8( .. ) + , PixelYCbCr8( .. ) + + -- * Type classes + , ColorConvertible( .. ) + , Pixel(..) + , ColorSpaceConvertible( .. ) + -- * Helper functions + , canConvertTo + ) where + +import Control.Applicative( (<$>), (<*>) ) +import Control.Monad.ST( ST ) +import Data.Word( Word8 ) +import Data.Array.Unboxed( UArray, (!) ) +import Data.Array.ST( MArray, STUArray + , writeArray, newArray, runSTUArray, readArray ) +import Data.Serialize( Serialize, put, get ) + + +-- | Image or pixel buffer, the coordinates are assumed to start +-- from the upper-left corner of the image, with the horizontal +-- position first, then the vertical one. +data Image a = Image + { -- | Width of the image in pixels + imageWidth :: {-# UNPACK #-} !Int + -- | Height of the image in pixels. + , imageHeight :: {-# UNPACK #-} !Int + + -- | The real image, to extract pixels at some position + -- you should use the helpers functions. + , imageData :: UArray Int Word8 + } + +-- | Image or pixel buffer, the coordinates are assumed to start +-- from the upper-left corner of the image, with the horizontal +-- position first, then the vertical one. The image can be transformed in place. +data MutableImage s a = MutableImage + { -- | Width of the image in pixels + mutableImageWidth :: {-# UNPACK #-} !Int + + -- | Height of the image in pixels. + , mutableImageHeight :: {-# UNPACK #-} !Int + + -- | The real image, to extract pixels at some position + -- you should use the helpers functions. + , mutableImageData :: STUArray s Int Word8 + } + +-- | Type allowing the loading of an image with different pixel +-- structures +data DynamicImage = + -- | A greyscale image. + ImageY8 (Image Pixel8) + -- | An image in greyscale with an alpha channel. + | ImageYA8 (Image PixelYA8) + -- | An image in true color. + | ImageRGB8 (Image PixelRGB8) + -- | An image in true color and an alpha channel. + | ImageRGBA8 (Image PixelRGBA8) + -- | An image in the colorspace used by Jpeg images. + | ImageYCbCr8 (Image PixelYCbCr8) + +-- | Simple alias for greyscale value in 8 bits. +type Pixel8 = Word8 + +-- | Pixel type storing Luminance (Y) and alpha information +-- on 8 bits. +-- Value are stored in the following order : +-- +-- * Luminance +-- +-- * Alpha +-- +data PixelYA8 = PixelYA8 {-# UNPACK #-} !Word8 -- Luminance + {-# UNPACK #-} !Word8 -- Alpha value + +-- | Pixel type storing classic pixel on 8 bits +-- Value are stored in the following order : +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Word8 -- Red + {-# UNPACK #-} !Word8 -- Green + {-# UNPACK #-} !Word8 -- Blue + +-- | Pixel storing data in the YCbCr colorspace, +-- value are stored in teh following order : +-- +-- * Y (luminance) +-- +-- * Cr +-- +-- * Cb +-- +data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Word8 -- Y luminance + {-# UNPACK #-} !Word8 -- Cr red difference + {-# UNPACK #-} !Word8 -- Cb blue difference + +-- | Pixel type storing a classic pixel, with an alpha component. +-- Values are stored in the following order +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +-- * Alpha +data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Word8 -- Red + {-# UNPACK #-} !Word8 -- Green + {-# UNPACK #-} !Word8 -- Blue + {-# UNPACK #-} !Word8 -- Alpha + +instance Serialize PixelYA8 where + {-# INLINE put #-} + put (PixelYA8 y a) = put y >> put a + {-# INLINE get #-} + get = PixelYA8 <$> get <*> get + +instance Serialize PixelRGB8 where + {-# INLINE put #-} + put (PixelRGB8 r g b) = put r >> put g >> put b + {-# INLINE get #-} + get = PixelRGB8 <$> get <*> get <*> get + +instance Serialize PixelYCbCr8 where + {-# INLINE put #-} + put (PixelYCbCr8 y cb cr) = put y >> put cb >> put cr + {-# INLINE get #-} + get = PixelYCbCr8 <$> get <*> get <*> get + +instance Serialize PixelRGBA8 where + {-# INLINE put #-} + put (PixelRGBA8 r g b a) = put r >> put g >> put b >> put a + {-# INLINE get #-} + get = PixelRGBA8 <$> get <*> get <*> get <*> get + +-- | Describe pixel kind at runtime +data PixelType = PixelMonochromatic -- ^ For 2 bits pixels + | PixelGreyscale + | PixelGreyscaleAlpha + | PixelRedGreenBlue8 + | PixelRedGreenBlueAlpha8 + | PixelYChromaRChromaB8 + deriving Eq + +-- | Typeclass used to query a type about it's properties +-- regarding casting to other pixel types +class (Serialize a) => Pixel a where + -- | Tell if a pixel can be converted to another pixel, + -- the first value should not be used, and 'undefined' can + -- be used as a valid value. + canPromoteTo :: a -> PixelType -> Bool + + -- | Return the number of component of the pixel + componentCount :: a -> Int + + -- | Calculate the index for the begining of the pixel + pixelBaseIndex :: Image a -> Int -> Int -> Int + pixelBaseIndex (Image { imageWidth = w }) x y = + (x + y * w) * componentCount (undefined :: a) + + -- | Calculate theindex for the begining of the pixel at position x y + mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int + mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y = + (x + y * w) * componentCount (undefined :: a) + + -- | Return the constructor associated to the type, again + -- the value in the first parameter is not used, so you can use undefined + promotionType :: a -> PixelType + + -- | Extract a pixel at a given position, (x, y), the origin + -- is assumed to be at the corner top left, positive y to the + -- bottom of the image + pixelAt :: Image a -> Int -> Int -> a + + -- | Same as pixelAt but for mutable images. + readPixel :: MutableImage s a -> Int -> Int -> ST s a + + -- | Write a pixel in a mutable image at position x y + writePixel :: MutableImage s a -> Int -> Int -> a -> ST s () + +-- | Tell if you can convert between two pixel types, both arguments +-- are unused. +canConvertTo :: (Pixel a, Pixel b) => a -> b -> Bool +canConvertTo a b = canPromoteTo a $ promotionType b + +-- | Implement upcasting for pixel types +-- Minimal declaration declaration `promotePixel` +-- It is strongly recommanded to overload promoteImage to keep +-- performance acceptable +class (Pixel a, Pixel b) => ColorConvertible a b where + -- | Convert a pixel type to another pixel type. This + -- operation should never loss any data. + promotePixel :: a -> b + + -- | Change the underlying pixel type of an image by performing a full copy + -- of it. + promoteImage :: Image a -> Image b + promoteImage image@(Image { imageWidth = w, imageHeight = h }) = + Image w h pixels + where pixels = runSTUArray $ do + newArr <- newArray (0, w * h * componentCount (undefined :: b) - 1) 0 + let wrapped = MutableImage w h newArr + promotedPixel :: Int -> Int -> b + promotedPixel x y = promotePixel $ pixelAt image x y + sequence_ [writePixel wrapped x y $ promotedPixel x y + | y <- [0 .. h - 1], x <- [0 .. w - 1] ] + return newArr + +-- | This class abstract colorspace conversion. This +-- conversion can be lossy, which ColorConvertible cannot +class (Pixel a, Pixel b) => ColorSpaceConvertible a b where + convertPixel :: a -> b + + convertImage :: Image a -> Image b + convertImage image@(Image { imageWidth = w, imageHeight = h }) = + Image w h pixels + where pixels = runSTUArray $ do + newArr <- newArray (0, w * h * componentCount (undefined :: b) - 1) 0 + let wrapped = MutableImage w h newArr + promotedPixel :: Int -> Int -> b + promotedPixel x y = convertPixel $ pixelAt image x y + sequence_ [writePixel wrapped x y $ promotedPixel x y + | y <- [0 .. h - 1], x <- [0 .. w - 1] ] + return newArr + +-- | Free promotion for identic pixel types +instance (Pixel a) => ColorConvertible a a where + {-# INLINE promotePixel #-} + promotePixel = id + + {-# INLINE promoteImage #-} + promoteImage = id + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (MArray array e m) => array Int e -> Int -> m e +(.!!!.) = readArray -- unsafeRead + +{-# INLINE (.<-.) #-} +(.<-.) :: (MArray array e m) => array Int e -> Int -> e -> m () +(.<-.) = writeArray -- unsafeWrite + +-------------------------------------------------- +---- Pixel8 instances +-------------------------------------------------- +instance Pixel Pixel8 where + canPromoteTo _ a = a /= PixelMonochromatic + promotionType _ = PixelGreyscale + componentCount _ = 1 + pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) + + readPixel image@(MutableImage { mutableImageData = arr }) x y = + arr .!!!. (mutablePixelBaseIndex image x y) + + writePixel image@(MutableImage { mutableImageData = arr }) x y v = + (arr .<-. (mutablePixelBaseIndex image x y)) v + +instance ColorConvertible Pixel8 PixelYA8 where + {-# INLINE promotePixel #-} + promotePixel c = PixelYA8 c 255 + +instance ColorConvertible Pixel8 PixelRGB8 where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGB8 c c c + +instance ColorConvertible Pixel8 PixelRGBA8 where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGBA8 c c c 255 + +-------------------------------------------------- +---- PixelYA8 instances +-------------------------------------------------- +instance Pixel PixelYA8 where + canPromoteTo _ a = a == PixelRedGreenBlueAlpha8 + promotionType _ = PixelGreyscaleAlpha + componentCount _ = 2 + pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + yv <- arr .!!!. baseIdx + av <- arr .!!!. (baseIdx + 1) + return $ PixelYA8 yv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) yv + (arr .<-. (baseIdx + 1)) av + + +instance ColorConvertible PixelYA8 PixelRGB8 where + {-# INLINE promotePixel #-} + promotePixel (PixelYA8 y _) = PixelRGB8 y y y + +instance ColorConvertible PixelYA8 PixelRGBA8 where + {-# INLINE promotePixel #-} + promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a + +-------------------------------------------------- +---- PixelRGB8 instances +-------------------------------------------------- +instance Pixel PixelRGB8 where + canPromoteTo _ PixelMonochromatic = False + canPromoteTo _ PixelGreyscale = False + canPromoteTo _ _ = True + + componentCount _ = 3 + + promotionType _ = PixelRedGreenBlue8 + + pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + return $ PixelRGB8 rv gv bv + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + +instance ColorConvertible PixelRGB8 PixelRGBA8 where + {-# INLINE promotePixel #-} + promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b 255 + +-------------------------------------------------- +---- PixelRGBA8 instances +-------------------------------------------------- +instance Pixel PixelRGBA8 where + canPromoteTo _ PixelRedGreenBlueAlpha8 = True + canPromoteTo _ _ = False + + promotionType _ = PixelRedGreenBlueAlpha8 + + componentCount _ = 4 + + pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + (arr ! (baseIdx + 3)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + av <- arr .!!!. (baseIdx + 3) + return $ PixelRGBA8 rv gv bv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + (arr .<-. (baseIdx + 3)) av + +-------------------------------------------------- +---- PixelYCbCr8 instances +-------------------------------------------------- +instance Pixel PixelYCbCr8 where + canPromoteTo _ _ = False + promotionType _ = PixelYChromaRChromaB8 + componentCount _ = 3 + pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + yv <- arr .!!!. baseIdx + cbv <- arr .!!!. (baseIdx + 1) + crv <- arr .!!!. (baseIdx + 2) + return $ PixelYCbCr8 yv cbv crv + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) yv + (arr .<-. (baseIdx + 1)) cbv + (arr .<-. (baseIdx + 2)) crv + +instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where + {-# INLINE convertPixel #-} + convertPixel (PixelYCbCr8 y_w8 cb_w8 cr_w8) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) + where y :: Float + y = fromIntegral y_w8 - 128.0 + cb = fromIntegral cb_w8 - 128.0 + cr = fromIntegral cr_w8 - 128.0 + + clampWord8 = truncate . max 0.0 . min 255.0 . (128 +) + + cred = 0.299 + cgreen = 0.587 + cblue = 0.114 + + r = cr * (2 - 2 * cred) + y + b = cb * (2 - 2 * cblue) + y + g = (y - cblue * b - cred * r) / cgreen + diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal new file mode 100644 --- /dev/null +++ b/JuicyPixels.cabal @@ -0,0 +1,52 @@ +Name: JuicyPixels +Version: 1.0 +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 (jpeg writing not + implemented yet though) +homepage: https://github.com/Twinside/Juicy.Pixels +License: BSD3 +License-file: LICENSE +Author: Vincent Berthoux +Maintainer: vincent.berthoux@gmail.com +Category: Codec, Graphics +Build-type: Simple + +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + +Source-Repository head + Type: git + Location: git://github.com/Twinside/Juicy.Pixels.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/Juicy.Pixels.git + Tag: v1.0 + +Library + Exposed-modules: Codec.Picture, + Codec.Picture.Bitmap, + Codec.Picture.Png, + Codec.Picture.Jpg, + Codec.Picture.Types + + Ghc-options: -O3 -Wall + Build-depends: base >= 4 && < 5, + array, + bytestring, + mtl >= 1.1, + cereal >= 0.3.3.0 && < 0.4, + zlib >= 0.5.3.1, + transformers >= 0.2.2 && < 0.3 + +-- Modules not exported by this package. + Other-modules: Codec.Picture.Jpg.DefaultTable, + Codec.Picture.Jpg.FastIdct, + Codec.Picture.Png.Export, + Codec.Picture.Png.Type + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Vincent Berthoux + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Vincent Berthoux nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain