diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,15 @@ +import qualified Data.ByteString as BS +import Criterion.Main + +import Graphics.Netpbm + + +main :: IO () +main = do + sipi <- BS.readFile "test/ppms/SIPI.ppm" + image <- BS.readFile "test/ppms/image.ppm" + + defaultMain [ + bgroup "fib" [ bench "SIPI.ppm" $ whnf parsePPM sipi + , bench "image.ppm" $ whnf parsePPM image + ] ] diff --git a/netpbm.cabal b/netpbm.cabal --- a/netpbm.cabal +++ b/netpbm.cabal @@ -1,5 +1,5 @@ name: netpbm -version: 0.2.1 +version: 0.3.0 license: MIT copyright: 2013 Niklas Hambüchen author: Niklas Hambüchen @@ -12,7 +12,12 @@ homepage: https://github.com/nh2/haskell-netpbm bug-Reports: https://github.com/nh2/haskell-netpbm/issues synopsis: Loading PBM, PGM, PPM image files -description: This package contains pure Haskell parsers for the netpbm image formats: PBM, PGM and PPM, for both ASCII and binary encodings. +description: + This package contains pure Haskell parsers for the netpbm image formats: PBM, PGM and PPM, for both ASCII and binary encodings. + . + All netpbm image formats are implemented (P1 - P6). + . + The current implementation parses PPM images at around 10 MB/s on a Core i5-2520M. source-repository head @@ -27,7 +32,7 @@ base < 5 , attoparsec >= 0.10 , attoparsec-binary >= 0.2 - , bytestring >= 0.10 + , bytestring >= 0.9 , storable-record >= 0.0.2.5 , unordered-containers >= 0.1.3.0 , vector >= 0.7 @@ -48,7 +53,22 @@ build-depends: base >= 4 , netpbm - , bytestring >= 0.10 + , bytestring >= 0.9 , hspec >= 1.3.0.1 , HUnit >= 1.2 + ghc-options: -Wall + + +benchmark bench + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: + bench + main-is: + Bench.hs + build-depends: + base >= 4 + , netpbm + , bytestring >= 0.9 + , criterion >= 0.6.0.0 ghc-options: -Wall diff --git a/src/Graphics/Netpbm.hs b/src/Graphics/Netpbm.hs --- a/src/Graphics/Netpbm.hs +++ b/src/Graphics/Netpbm.hs @@ -4,17 +4,23 @@ -- | Parsing the netpbm image formates (PBM, PGM and PPM, both ASCII and binary) from 'ByteString's. -- +-- All netpbm image formats are implemented (P1 - P6). +-- -- To parse one of these formats, use `parsePPM`. -- --- Currently, only P6 images are implemented. --- Implementing the other types should be straighforward. +-- See also: module Graphics.Netpbm ( PPMType (..) , PPM (..) -, PpmPixelRGB8 -, PpmPixelRGB16 +, PpmPixelRGB8 (..) +, PpmPixelRGB16 (..) +, PbmPixel (..) +, PgmPixel8 (..) +, PgmPixel16 (..) , PPMHeader (..) , PpmPixelData (..) +, pixelVectorToList +, pixelDataToIntList , parsePPM , PpmParseResult -- TODO expose attoparsec functions in .Internal package @@ -25,16 +31,18 @@ import Data.Attoparsec.ByteString as A import Data.Attoparsec.ByteString.Char8 as A8 import Data.Attoparsec.Binary (anyWord16be) +import Data.Bits (testBit) import Data.ByteString (ByteString) -import Data.Char (ord) +import Data.Char (chr, ord) import Data.List (foldl') import Data.Word (Word8, Word16) import Foreign.Storable.Record as Store import Foreign.Storable (Storable (..)) import qualified Data.Vector.Unboxed as U +import Data.Vector.Unboxed ((!)) import qualified Data.Vector.Generic -import qualified Data.Vector.Generic.Mutable +import qualified Data.Vector.Generic.Mutable as VGM import Data.Vector.Unboxed.Deriving @@ -79,11 +87,40 @@ {-# UNPACK #-} !Word16 -- Blue deriving (Eq, Show) +-- | A pixel containing black or white. +newtype PbmPixel = PbmPixel Bool -- False = black, True = white + deriving (Eq, Show) + +-- | A pixel containing an 8-bit greyscale value. +data PgmPixel8 = PgmPixel8 {-# UNPACK #-} !Word8 + deriving (Eq, Show) + +-- | A pixel containing a 16-bit greyscale value. +data PgmPixel16 = PgmPixel16 {-# UNPACK #-} !Word16 + deriving (Eq, Show) + -- | Image data, either 8 or 16 bits. +-- TODO rename to PNM data PpmPixelData = PpmPixelDataRGB8 (U.Vector PpmPixelRGB8) -- ^ For 8-bit PPMs. | PpmPixelDataRGB16 (U.Vector PpmPixelRGB16) -- ^ For 16-bit PPMs. + | PbmPixelData (U.Vector PbmPixel) -- ^ For 1-bit PBMs. + | PgmPixelData8 (U.Vector PgmPixel8) -- ^ For 8-bit PGMs. + | PgmPixelData16 (U.Vector PgmPixel16) -- ^ For 16-bit PGMs. +pixelVectorToList :: (U.Unbox a) => U.Vector a -> [a] +pixelVectorToList = U.toList + + +pixelDataToIntList :: PpmPixelData -> [Int] +pixelDataToIntList d = case d of + PpmPixelDataRGB8 v -> concat [ map fromIntegral [r, g, b] | PpmPixelRGB8 r g b <- U.toList v ] + PpmPixelDataRGB16 v -> concat [ map fromIntegral [r, g, b] | PpmPixelRGB16 r g b <- U.toList v ] + PbmPixelData v -> [ if b then 1 else 0 | PbmPixel b <- U.toList v ] + PgmPixelData8 v -> [ fromIntegral x | PgmPixel8 x <- U.toList v ] + PgmPixelData16 v -> [ fromIntegral x | PgmPixel16 x <- U.toList v ] + + -- * Unbox instance for pixels derivingUnbox "PpmPixelRGB8" @@ -96,36 +133,84 @@ [| \ (PpmPixelRGB16 a b c) -> (a, b, c) |] [| \ (a, b, c) -> PpmPixelRGB16 a b c |] +derivingUnbox "PbmPixel" + [t| PbmPixel -> Bool |] + [| \ (PbmPixel b) -> b |] + [| \ b -> PbmPixel b |] +derivingUnbox "PgmPixel8" + [t| PgmPixel8 -> Word8 |] + [| \ (PgmPixel8 x) -> x |] + [| \ x -> PgmPixel8 x |] + +derivingUnbox "PgmPixel16" + [t| PgmPixel16 -> Word16 |] + [| \ (PgmPixel16 x) -> x |] + [| \ x -> PgmPixel16 x |] + + -- * Storable instance for pixels -storePixel8 :: Store.Dictionary PpmPixelRGB8 -storePixel8 = +storePpmPixel8 :: Store.Dictionary PpmPixelRGB8 +storePpmPixel8 = Store.run $ liftA3 PpmPixelRGB8 (Store.element (\(PpmPixelRGB8 x _ _) -> x)) (Store.element (\(PpmPixelRGB8 _ y _) -> y)) (Store.element (\(PpmPixelRGB8 _ _ z) -> z)) -storePixel16 :: Store.Dictionary PpmPixelRGB16 -storePixel16 = +storePpmPixel16 :: Store.Dictionary PpmPixelRGB16 +storePpmPixel16 = Store.run $ liftA3 PpmPixelRGB16 (Store.element (\(PpmPixelRGB16 x _ _) -> x)) (Store.element (\(PpmPixelRGB16 _ y _) -> y)) (Store.element (\(PpmPixelRGB16 _ _ z) -> z)) +storePbmPixel :: Store.Dictionary PbmPixel +storePbmPixel = + Store.run $ liftA PbmPixel + (Store.element (\(PbmPixel x) -> x)) + +storePgmPixel8 :: Store.Dictionary PgmPixel8 +storePgmPixel8 = + Store.run $ liftA PgmPixel8 + (Store.element (\(PgmPixel8 x) -> x)) + +storePgmPixel16 :: Store.Dictionary PgmPixel16 +storePgmPixel16 = + Store.run $ liftA PgmPixel16 + (Store.element (\(PgmPixel16 x) -> x)) + instance Storable PpmPixelRGB8 where - sizeOf = Store.sizeOf storePixel8 - alignment = Store.alignment storePixel8 - peek = Store.peek storePixel8 - poke = Store.poke storePixel8 + sizeOf = Store.sizeOf storePpmPixel8 + alignment = Store.alignment storePpmPixel8 + peek = Store.peek storePpmPixel8 + poke = Store.poke storePpmPixel8 instance Storable PpmPixelRGB16 where - sizeOf = Store.sizeOf storePixel16 - alignment = Store.alignment storePixel16 - peek = Store.peek storePixel16 - poke = Store.poke storePixel16 + sizeOf = Store.sizeOf storePpmPixel16 + alignment = Store.alignment storePpmPixel16 + peek = Store.peek storePpmPixel16 + poke = Store.poke storePpmPixel16 +instance Storable PbmPixel where + sizeOf = Store.sizeOf storePbmPixel + alignment = Store.alignment storePbmPixel + peek = Store.peek storePbmPixel + poke = Store.poke storePbmPixel +instance Storable PgmPixel8 where + sizeOf = Store.sizeOf storePgmPixel8 + alignment = Store.alignment storePgmPixel8 + peek = Store.peek storePgmPixel8 + poke = Store.poke storePgmPixel8 + +instance Storable PgmPixel16 where + sizeOf = Store.sizeOf storePgmPixel16 + alignment = Store.alignment storePgmPixel16 + peek = Store.peek storePgmPixel16 + poke = Store.poke storePgmPixel16 + + -- | Parses a netpbm magic number. -- One of P1, P2, P3, P4, P5, P6. magicNumberParser :: Parser PPMType @@ -134,7 +219,6 @@ case magic of "P1" -> return P1 "P2" -> return P2 - "P3" -> return P3 "P4" -> return P4 "P5" -> return P5 @@ -143,6 +227,66 @@ +-- Not writing this as @comments = skipMany comment@ because that would allow this parser +-- to consume no input, which makes it loop forever when stuck into something like `many`. +{-# INLINE comment #-} +comment :: Parser ByteString +comment = "#" .*> A.takeWhile isNotNewline <* endOfLine + where + isNotNewline w = w /= 10 && w /= 13 + + +{-# INLINE sep #-} +sep :: Parser () +-- At least one space, optionally with more space or comments around +sep = do skipMany comment + singleWhitespace + skipMany (singleWhitespace <|> void comment) + + +-- | Decimal, possibly with comments interleaved, +-- but starting and ending with a digit. +-- See the notes about comments. +{-# INLINE decimalC #-} +decimalC :: Parser Int +decimalC = foldl' shiftDecimalChar 0 <$> (digit `sepBy1` skipMany comment) + where + shiftDecimalChar a d = a * 10 + ord d - (48 :: Int) + + +headerParser :: Parser PPMHeader +headerParser = do + ppmType <- magicNumberParser + sep + width <- decimalC + sep + height <- decimalC + skipMany comment -- Don't allow whitespace here since after the next whitespace there must not be any more comments + return $ PPMHeader ppmType width height + + +{-# INLINE word8max #-} +-- Parsing words not bigger than given maxval +word8max :: Word8 -> Parser Word8 +word8max m = A.satisfy (<= m) "pixel data must be smaller than maxval" + +{-# INLINE word16max #-} +word16max :: Word16 -> Parser Word16 +word16max m = do w16 <- anyWord16be + when (not $ w16 <= m) $ fail "pixel data must be smaller than maxval" + return w16 + + +{-# INLINE isValidMaxval #-} +isValidMaxval :: Int -> Bool +isValidMaxval v = v > 0 && v < 65536 + + +{-# INLINE singleWhitespace #-} +singleWhitespace :: Parser () +singleWhitespace = void $ A.satisfy isSpace_w8 + + -- | Parses a SINGLE PPM file. -- -- Specification: http://netpbm.sourceforge.net/doc/ppm.html @@ -157,61 +301,218 @@ -- inside the magic number". -- -- See also the notes for `imagesParser`. -ppmParser :: Parser PPM -ppmParser = do - ppmType <- magicNumberParser - -- TODO Implement the other netpbm image types - when (ppmType /= P6) $ error "haskell-netpbm currently only supports PPM P6" - comments - skipSpace - comments - width <- decimalC - comments - skipSpace - comments - height <- decimalC - comments - skipSpace - comments +ppmBodyParser :: PPMHeader -> Parser PPM +ppmBodyParser header@PPMHeader { ppmWidth = width, ppmHeight = height } = do + + sep + maxColorVal <- decimalC - when (not $ isValidColorVal maxColorVal) $ + when (not $ isValidMaxval maxColorVal) $ fail $ "PPM: invalid color maxval " ++ show maxColorVal - comments - _ <- A8.satisfy isSpace -- obligatory SINGLE whitespace - -- Starting from here, comments are not allowed any more - raster <- if maxColorVal < 256 -- 1 or 2 bytes per pixel - -- TODO check if values are smaller than maxColorVal - then PpmPixelDataRGB8 <$> (U.replicateM (height * width) $ - PpmPixelRGB8 <$> anyWord8 <*> anyWord8 <*> anyWord8) - else PpmPixelDataRGB16 <$> (U.replicateM (height * width) $ - PpmPixelRGB16 <$> anyWord16be <*> anyWord16be <*> anyWord16be) + skipMany comment - return $ PPM (PPMHeader ppmType width height) raster + singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more + raster <- case maxColorVal of -- 1 or 2 bytes per pixel + -- Parse pixel data into vector, making sure that words don't exceed maxColorVal + m | m < 256 -> let v = word8max (fromIntegral m) + in PpmPixelDataRGB8 <$> U.replicateM (height * width) (PpmPixelRGB8 <$> v <*> v <*> v) + m | otherwise -> let v = word16max (fromIntegral m) + in PpmPixelDataRGB16 <$> U.replicateM (height * width) (PpmPixelRGB16 <$> v <*> v <*> v) + + return $ PPM header raster + + +pgmBodyParser :: PPMHeader -> Parser PPM +pgmBodyParser header@PPMHeader { ppmWidth = width, ppmHeight = height } = do + + sep + + maxGreyVal <- decimalC + when (not $ isValidMaxval maxGreyVal) $ + fail $ "PGM: invalid grey maxval " ++ show maxGreyVal + skipMany comment + + singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more + + raster <- case maxGreyVal of -- 1 or 2 bytes per pixel + -- Parse pixel data into vector, making sure that words don't exceed maxGreyVal + m | m < 256 -> let v = word8max (fromIntegral m) + in PgmPixelData8 <$> U.replicateM (height * width) (PgmPixel8 <$> v) + m | otherwise -> let v = word16max (fromIntegral m) + in PgmPixelData16 <$> U.replicateM (height * width) (PgmPixel16 <$> v) + + return $ PPM header raster + + +pbmBodyParser :: PPMHeader -> Parser PPM +pbmBodyParser header@PPMHeader { ppmWidth = width, ppmHeight = height } = do + + singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more + + -- From: http://netpbm.sourceforge.net/doc/pbm.html + -- "Each row is Width bits, packed 8 to a byte, with don't care bits to fill out the last byte in the row." + let widthBytes = (width + 7) // 8 + + -- Parse pixel data first in into a Word8 vector, then translate to a Bool vector, leaving the don't-cares at the end out. + word8Vector <- U.replicateM (height * widthBytes) anyWord8 + + let bits = U.create $ do + v <- VGM.replicate (width * height) (PbmPixel False) + forM_ [0..height-1] $ \row -> + forM_ [0..width-1] $ \col -> + let i = row * width + col + (col8, bitN) = col /% 8 + i8 = row * widthBytes + col8 + -- We negate (see "not"), because: + -- "1 is black, 0 is white." + -- Also, `testBit` indexes from the right (LSB). + in VGM.write v i (PbmPixel . not $ (word8Vector ! i8) `testBit` (7 - bitN)) + return v + + return $ PPM header (PbmPixelData bits) where - isValidColorVal v = v > 0 && v < 65536 - comments = void $ many comment - comment = "#" .*> A.takeWhile isNotNewline <* endOfLine - isNotNewline w = w /= 10 && w /= 13 - -- Decimal, possibly with comments interleaved, - -- but starting and ending with a digit. - -- See the notes about comments above. - decimalC :: Parser Int - decimalC = foldl' shiftDecimalChar 0 <$> ((:) <$> digit <*> many (comments *> digit)) - shiftDecimalChar a d = a * 10 + ord d - (48 :: Int) + (//) = quot + (/%) = quotRem +-- | See http://netpbm.sourceforge.net/doc/pbm.html +-- +-- We ignore the "No line should be longer than 70 characters" here due to "should". +pbmAsciiBodyParser :: PPMHeader -> Parser PPM +pbmAsciiBodyParser header@PPMHeader { ppmWidth = width, ppmHeight = height } = do + + singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more + + -- Parse pixel data into Bool vector. + let n = height * width + -- There must be whitespace *between* the values. + -- There can be whitespace *before* the first value since: + -- "White space in the raster section is ignored." + -- Don't allow it *after* so that we can check if there is a whitespace between raster and optional junk. + -- I use `generateM` here instead of fromList . (`sepBy` [whitespace]) because I believe it's faster. + bits <- U.replicateM n (A.takeWhile isSpace_w8 *> asciiBit) + + -- From the spec (who the heck can even come up with this): + -- "You can put any junk you want after the raster, if it starts with a white space character." + -- Note that it says *can*, i.e. the junk can also be empty, so trailing whitespace is allowed. + -- So let's eat all remaining input: + option () (A.takeWhile1 isSpace_w8 *> takeLazyByteString *> pure ()) + + -- Now we should be at the end of file. + endOfInput "there is junk after the ASCII raster that is not separated by whitespace" + + return $ PPM header (PbmPixelData bits) + where + asciiBit = PbmPixel <$> (anyWord8 >>= toBool) + -- We flip True/False because "1" means black == False. + toBool 48 = return True + toBool 49 = return False + toBool w = fail $ "ASCII bit must be '0' or '1', not " ++ show (chr $ fromIntegral w) + + +pgmAsciiBodyParser :: PPMHeader -> Parser PPM +pgmAsciiBodyParser header@PPMHeader { ppmWidth = width, ppmHeight = height } = do + + sep + + maxGreyVal <- decimalC + when (not $ isValidMaxval maxGreyVal) $ + fail $ "PGM: invalid grey maxval " ++ show maxGreyVal + skipMany comment + + singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more + + let n = height * width + + -- TODO size-check the int by first putting it in Word64 and limiting decimal length + raster <- case maxGreyVal of -- 1 or 2 bytes per pixel + -- Parse pixel data into vector, making sure that words don't exceed maxGreyVal + m | m < 256 -> PgmPixelData8 <$> U.replicateM n (A.takeWhile isSpace_w8 *> (PgmPixel8 <$> decimal)) + _ -> PgmPixelData16 <$> U.replicateM n (A.takeWhile isSpace_w8 *> (PgmPixel16 <$> decimal)) + + option () (A.takeWhile1 isSpace_w8 *> takeLazyByteString *> pure ()) + + -- Now we should be at the end of file. + endOfInput "there is junk after the ASCII raster that is not separated by whitespace" + + return $ PPM header raster + + +ppmAsciiBodyParser :: PPMHeader -> Parser PPM +ppmAsciiBodyParser header@PPMHeader { ppmWidth = width, ppmHeight = height } = do + + sep + + maxColorVal <- decimalC + when (not $ isValidMaxval maxColorVal) $ + fail $ "PGM: invalid color maxval " ++ show maxColorVal + skipMany comment + + singleWhitespace -- obligatory SINGLE whitespace; starting from here, comments are not allowed any more + + let n = height * width + d8 = A.takeWhile isSpace_w8 *> decimal :: Parser Word8 + d16 = A.takeWhile isSpace_w8 *> decimal :: Parser Word16 + + -- TODO size-check the int by first putting it in Word64 and limiting decimal length + raster <- case maxColorVal of -- 1 or 2 bytes per pixel + -- Parse pixel data into vector, making sure that words don't exceed maxColorVal + m | m < 256 -> PpmPixelDataRGB8 <$> U.replicateM n (PpmPixelRGB8 <$> d8 <*> d8 <*> d8 ) + _ -> PpmPixelDataRGB16 <$> U.replicateM n (PpmPixelRGB16 <$> d16 <*> d16 <*> d16) + + option () (A.takeWhile1 isSpace_w8 *> takeLazyByteString *> pure ()) + + -- Now we should be at the end of file. + endOfInput "there is junk after the ASCII raster that is not separated by whitespace" + + return $ PPM header raster + + +imageParserOfType :: Maybe PPMType -> Parser PPM +imageParserOfType mpN = do + header@PPMHeader { ppmType } <- headerParser + + case mpN of + Just pN | pN /= ppmType -> fail "an image in a multi-image file is not of the same type as the first image in the file" + _ -> return () + + case ppmType of + P1 -> pbmAsciiBodyParser header + P2 -> pgmAsciiBodyParser header + P3 -> ppmAsciiBodyParser header + P4 -> pbmBodyParser header + P5 -> pgmBodyParser header + P6 -> ppmBodyParser header + + +imageParser :: Parser PPM +imageParser = imageParserOfType Nothing + + -- | Parses a full PPM file, containing one or more images. -- --- "A PPM file consists of a sequence of one or more PPM images." --- We allow trailing whitespace after images, which is AGAINST THE SPEC: +-- From the spec: -- -- >"A PPM file consists of a sequence of one or more PPM images. -- > There are no data, delimiters, or padding before, after, or between images." -- --- However, you can find PPM files that have trailing whitespace, especially a '\n'. +-- However, you can find PPM files that have trailing whitespace, especially a '\n', +-- so we allow this. imagesParser :: Parser [PPM] -imagesParser = many1 (ppmParser <* skipSpace) +imagesParser = do + -- Parse the first image. + firstImage@PPM { ppmHeader = PPMHeader { ppmType } } <- imageParser <* skipSpace + + -- Force the following images, if any, to be of the same type. + otherImages <- many (imageParserOfType (Just ppmType) <* skipSpace) + + -- TODO Restructure so that this cannot happen. There is no point of returning [PPM] for ASCII images. + when (ppmType `elem` [P1, P2, P3] && not (null otherImages)) $ + error "haskell-netpbm bug: ASCII formats should never contain more than one image (they treat remaining data as junk)" + + return $ firstImage:otherImages + -- | The result of a PPM parse. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -16,6 +16,16 @@ Left e -> assertFailure $ "image parse failed: " ++ e +checkSinglePPMdata :: PPMType -> (Int, Int) -> [Int] -> PpmParseResult -> Assertion +checkSinglePPMdata typ size expected parseResult = case parseResult of + Right ([PPM { ppmHeader = PPMHeader { ppmType, ppmWidth, ppmHeight } + , ppmData }], rest) -> do + (ppmType, (ppmWidth, ppmHeight), rest) `shouldBe` (typ, size, Nothing) + pixelDataToIntList ppmData `shouldBe` expected + Right (ppms, _) -> assertFailure $ "expected only one image, but got " ++ show (length ppms) + Left e -> assertFailure $ "image parse failed: " ++ e + + shouldNotParse :: PpmParseResult -> Assertion shouldNotParse res = case res of Left _ -> return () @@ -31,6 +41,16 @@ parse ("test/ppms/" ++ name) >>= check +repcat :: Int -> [a] -> [a] +repcat n = concat . replicate n + + +-- @dir@ must have trailing slash. +checkDirectory :: FilePath -> String -> PPMType -> [(String, (Int, Int))] -> Spec +checkDirectory dir desc typ filesWithSizes = forM_ filesWithSizes $ \(f, size) -> + parseTestFile (dir ++ f) desc $ checkSinglePPM typ size + + main :: IO () main = hspec $ do describe "P6 PPM (color binary)" $ do @@ -38,7 +58,7 @@ parseTestFile "gimp.ppm" "a file produced by GIMP" $ checkSinglePPM P6 (640,400) - parseTestFile "gitlogo.ppm" "a file produced convert" $ + parseTestFile "gitlogo.ppm" "a file produced by convert" $ checkSinglePPM P6 (220,92) parseTestFile "image.ppm" "some random file from the internet" $ @@ -48,7 +68,7 @@ checkSinglePPM P6 (227,149) describe "more test files from the internet" $ do - forM_ + checkDirectory "internet/set1/" "from the internet" P6 [ ("boxes_1.ppm", (63,63)) , ("boxes_2.ppm", (63,63)) , ("house_1.ppm", (111,132)) @@ -65,11 +85,25 @@ , ("tree_2.ppm", (133,133)) , ("west_1.ppm", (366,216)) , ("west_2.ppm", (366,216)) - ] $ \(f, size) -> - parseTestFile ("internet/set1/" ++ f) "from the internet" $ - checkSinglePPM P6 size + ] + checkDirectory "internet/set3/" "from the internet, PNM" P6 + [ ("birch.pnm", (128,128)) + , ("cotton.pnm", (256,170)) + , ("oak.pnm", (128,128)) + , ("quilt.pnm", (256,237)) + ] + parseTestFile "internet/set2/mandrill.ppm" "the color file from the 'Math 625' course" $ + checkSinglePPM P6 (512,512) + parseTestFile "internet/set2/half.ppm" "the color file from the 'Math 625' course, half width" $ + checkSinglePPM P6 (256,512) + + parseTestFile "SIPI.ppm" "SIPI test file" $ + -- convert SIPI.tiff SIPI.ppm + checkSinglePPM P6 (256,256) + + parseTestFile "gitlogo-double.ppm" "a multi-image file" $ do \res -> case res of Right ([ PPM { ppmHeader = h1 } @@ -134,6 +168,25 @@ Left e -> assertFailure $ "did not parse: " ++ e + describe "16-bit images" $ do + + -- See http://wiki.simg.de/doku.php?id=common:formats#pnm_family + parseTestFile "gitlogo-16bit-created-by-simg_convert_-16be_gitlogo.ppm_output.ppm" "16-bit image created by simg" $ + \res -> case res of + Right ([PPM { ppmHeader, ppmData }], rest) -> do ppmHeader `shouldBe` PPMHeader P6 220 92 + rest `shouldBe` Nothing + case ppmData of + PpmPixelDataRGB16 _ -> return () + _ -> assertFailure $ "did not get 16-bit data" + Right r -> assertFailure $ "parsed unexpected: " ++ show r + Left e -> assertFailure $ "did not parse: " ++ e + + parseTestFile "SIPI-16.ppm" "SIPI test file" $ + -- convert SIPI.tiff -depth 16 SIPI-16.ppm + checkSinglePPM P6 (256,256) + + -- TODO try to get a 16-bit image out of the new gimp + describe "negative examples" $ do parseTestFile "bad/gitlogo-garbage-in-numbers.ppm" "ascii characters in a number" shouldNotParse @@ -146,4 +199,127 @@ parseTestFile "bad/gitlogo-comment-user-error.ppm" "a comment accidentally being put to close to a number, eating the following whitespace" $ shouldNotParse + parseTestFile "bad/gitlogo-comment-user-error-no-space-after-magic.ppm" "a comment accidentally being put to close to the magic number, eating the following whitespace" $ shouldNotParse + parseTestFile "bad/gitlogo-comment-without-following-extra-newline-before-data-block.ppm" "no non-comment whitespace before data block" shouldNotParse + + parseTestFile "bad/gitlogo-value-bigger-than-maxval.ppm" "subpixel value is bigger than maxval" shouldNotParse + + parseTestFile "internet/set3/cathedral.pnm" "subpixel value is bigger than maxval" shouldNotParse + parseTestFile "internet/set3/checkers.pnm" "subpixel value is bigger than maxval" shouldNotParse + parseTestFile "internet/set3/fish_tile.pnm" "subpixel value is bigger than maxval" shouldNotParse + parseTestFile "internet/set3/garnet.pnm" "subpixel value is bigger than maxval" shouldNotParse + + + describe "P5 PGM (greyscale binary)" $ do + + parseTestFile "internet/set2/mandrill.pgm" "the color file from the 'Math 625' course" $ + checkSinglePPM P5 (512,512) + + parseTestFile "internet/set2/half.pgm" "the color file from the 'Math 625' course, half width" $ + checkSinglePPM P5 (256,512) + + parseTestFile "SIPI-convert.pgm" "a file produced by convert" $ + -- convert SIPI.tiff SIPI-convert.pgm + checkSinglePPM P5 (256,256) + + + describe "comments" $ do + + parseTestFile "internet/set2/comments.pgm" "the color file from the 'Math 625' course, with comments" $ + checkSinglePPM P5 (512,512) + + + describe "16-bit" $ do + + parseTestFile "SIPI-convert-16.pgm" "a file produced by convert, 16-bit" $ + -- convert SIPI.tiff -depth 16 SIPI-convert-16.pgm + checkSinglePPM P5 (256,256) + + + describe "P4 PBM (bitmap binary)" $ do + + parseTestFile "testgrid.pbm" "the bitmap file from the netpbm test suite" $ + checkSinglePPMdata P4 (14,16) (repcat 8 (repcat 7 [0,1] ++ replicate 14 0)) + + parseTestFile "SIPI-convert.pbm" "a file produced by convert" $ + -- convert SIPI.tiff SIPI-convert.pbm + checkSinglePPM P4 (256,256) + + + describe "P3 PPM (color ASCII)" $ do + + checkDirectory "internet/set3/" "more test files from the internet" P3 + [ ("feep.ppm", (4,4)) + , ("snail.ppm", (256,256)) + ] + + parseTestFile "SIPI-convert-plain.ppm" "a file produced by convert" $ + -- convert SIPI.tiff -compress none SIPI-convert-plain.ppm + checkSinglePPM P3 (256,256) + + parseTestFile "SIPI-convert-plain-16.ppm" "a file produced by convert, 16-bit" $ + -- convert SIPI.tiff -compress none -depth 16 SIPI-convert-plain-16.ppm + checkSinglePPM P3 (256,256) + + + describe "P2 PGM (greyscale ASCII)" $ do + + checkDirectory "internet/set3/" "more test files from the internet" P2 + [ ("balloons.pgm", (640,480)) + , ("columns.pgm", (640,480)) + , ("feep.pgm", (24,7)) + , ("tracks.pgm", (300,200)) + ] + + parseTestFile "pgm-plain-made-up-from-pbm-spec.pgm" "the plain PBM file from the spec example, converted to PGM" $ + -- Invert 0/1 because in PBM 1 is black, not so in PGM + checkSinglePPMdata P2 (24,7) (map (1 -) pbmFromSpecResult) + + parseTestFile "SIPI-convert-plain.pgm" "a file produced by convert" $ + -- convert SIPI.tiff -compress none SIPI-convert-plain.pgm + checkSinglePPM P2 (256,256) + + describe "16-bit" $ do + + parseTestFile "SIPI-convert-plain-16.pgm" "a file produced by convert, 16-bit" $ + -- convert SIPI.tiff -compress none -depth 16 SIPI-convert-plain-16.pgm + checkSinglePPM P2 (256,256) + + + describe "P1 PBM (bitmap ASCII)" $ do + + describe "more test files from the internet" $ do + checkDirectory "internet/set3/" "from the internet" P1 + [ ("circle_ascii.pbm", (200,200)) + , ("feep.pbm", (24,7)) + ] + + parseTestFile "pbm-plain-from-spec.pbm" "the plain PBM file from the spec example" $ + checkSinglePPMdata P1 (24,7) pbmFromSpecResult + + + describe "ASCII files should only contain one image" $ do + + parseTestFile "pbm-plain-from-spec-multiple-but-treated-as-junk.pbm" "ASCII PBM from spec, multiple times, rest should be treated as junk" $ + checkSinglePPMdata P1 (24,7) pbmFromSpecResult + + parseTestFile "bad/pbm-plain-from-spec-multiple-no-space-before-junk.pbm" "ASCII PBM from spec, multiple times, rest should be treated as junk" $ + shouldNotParse + + + parseTestFile "SIPI-convert-plain.pbm" "a file produced by convert" $ + -- convert SIPI.tiff -compress none SIPI-convert-plain.pbm + checkSinglePPM P1 (256,256) + +-- Some result data + +-- Note that in a PBM file, "1" means black, but in the result 0 means black. +pbmFromSpecResult :: [Int] +pbmFromSpecResult = [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 + ,1,0,0,0,0,1,1,0,0,0,0,1,1,0,0,0,0,1,1,0,0,0,0,1 + ,1,0,1,1,1,1,1,0,1,1,1,1,1,0,1,1,1,1,1,0,1,1,0,1 + ,1,0,0,0,1,1,1,0,0,0,1,1,1,0,0,0,1,1,1,0,0,0,0,1 + ,1,0,1,1,1,1,1,0,1,1,1,1,1,0,1,1,1,1,1,0,1,1,1,1 + ,1,0,1,1,1,1,1,0,0,0,0,1,1,0,0,0,0,1,1,0,1,1,1,1 + ,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1]