aboutsummaryrefslogtreecommitdiff
path: root/ch10/10_a_1.hs
diff options
context:
space:
mode:
Diffstat (limited to 'ch10/10_a_1.hs')
-rw-r--r--ch10/10_a_1.hs224
1 files changed, 224 insertions, 0 deletions
diff --git a/ch10/10_a_1.hs b/ch10/10_a_1.hs
new file mode 100644
index 0000000..4a0c1cd
--- /dev/null
+++ b/ch10/10_a_1.hs
@@ -0,0 +1,224 @@
+-- 1. Write a parser for "plain" PGM files.
+--
+-- 2. In our description of "raw" PGM files, we omitted a small detail. If the
+-- "maximum grey" value in the header is less than 256, each pixel is
+-- represented by a single byte. However, it can range up to 65,535, in which
+-- case, each pixel will be represented by 2 bytes, in big-endian order (most
+-- significant byte first).
+--
+-- Rewrite the raw PGM parser to accommodate both the single- and double-byte
+-- pixel formats.
+--
+-- 3. Extend your parser so that it can identify a raw or plain PGM file, and parse
+-- the appropriate file type.
+
+
+{-- From examples/examples/ch10/Parse.hs modified according to the assignment --}
+import Control.Applicative ((<$>))
+import qualified Data.ByteString.Lazy as L
+import Data.Char (chr, isDigit, isSpace)
+import Data.Int (Int64)
+import Data.Word (Word8)
+
+
+data ParseState = ParseState {
+ string :: L.ByteString
+ , offset :: Int64
+ } deriving (Show)
+
+newtype Parse a = Parse {
+ runParse :: ParseState -> Either String (a, ParseState)
+ }
+
+identity :: a -> Parse a
+identity a = Parse (\s -> Right (a, s))
+
+bail :: String -> Parse a
+bail err = Parse $ \s -> Left $
+ "byte offset " ++ show (offset s) ++ ": " ++ err
+
+(==>) :: Parse a -> (a -> Parse b) -> Parse b
+
+firstParser ==> secondParser = Parse chainedParser
+ where chainedParser initState =
+ case runParse firstParser initState of
+ Left errMessage ->
+ Left errMessage
+ Right (firstResult, newState) ->
+ runParse (secondParser firstResult) newState
+
+
+getState :: Parse ParseState
+getState = Parse (\s -> Right (s, s))
+
+putState :: ParseState -> Parse ()
+putState s = Parse (\_ -> Right ((), s))
+
+parseByte :: Parse Word8
+parseByte =
+ getState ==> \initState ->
+ case L.uncons (string initState) of
+ Nothing ->
+ bail "no more input"
+ Just (byte,remainder) ->
+ putState newState ==> \_ ->
+ identity byte
+ where newState = initState { string = remainder,
+ offset = newOffset }
+ newOffset = offset initState + 1
+
+peekByte :: Parse (Maybe Word8)
+peekByte = (fmap fst . L.uncons . string) <$> getState
+
+instance Functor Parse where
+ fmap f parser = parser ==> \result ->
+ identity (f result)
+
+peekChar :: Parse (Maybe Char)
+peekChar = fmap w2c <$> peekByte
+
+w2c :: Word8 -> Char
+w2c = chr . fromIntegral
+
+parseWhile :: (Word8 -> Bool) -> Parse [Word8]
+parseWhile p = (fmap p <$> peekByte) ==> \mp ->
+ if mp == Just True
+ then parseByte ==> \b ->
+ (b:) <$> parseWhile p
+ else identity []
+
+parseWhileWith :: (Word8 -> a) -> (a -> Bool) -> Parse [a]
+parseWhileWith f p = fmap f <$> parseWhile (p . f)
+
+parseNat :: Parse Int
+parseNat = parseWhileWith w2c isDigit ==> \digits ->
+ if null digits
+ then bail "no more input"
+ else let n = read digits
+ in if n < 0
+ then bail "integer overflow"
+ else identity n
+
+(==>&) :: Parse a -> Parse b -> Parse b
+p ==>& f = p ==> \_ -> f
+
+skipSpaces :: Parse ()
+skipSpaces = parseWhileWith w2c isSpace ==>& identity ()
+
+assert :: Bool -> String -> Parse ()
+assert True _ = identity ()
+assert False err = bail err
+
+parseBytes :: Int -> Parse L.ByteString
+parseBytes n =
+ getState ==> \st ->
+ let n' = fromIntegral n
+ (h, t) = L.splitAt n' (string st)
+ st' = st { offset = offset st + L.length h, string = t }
+ in putState st' ==>&
+ assert (L.length h == n') "end of input" ==>&
+ identity h
+
+parseRawPGM :: Int -> WordSize -> Parse [Int]
+parseRawPGM pixelCount wordSize =
+ parseByte ==>&
+ parseBytes byteCount ==> \bitmap ->
+ identity (wordsToInts bitmap)
+ where (byteCount, wordsToInts) = if wordSize == WordSize16bit
+ then ((2 * pixelCount), words8ToInts16)
+ else (pixelCount, words8ToInts8)
+{-- End of code from examples --}
+
+
+{-- From examples/examples/ch10/Parse.hs modified according to the assignment --}
+data Greymap = Greymap {
+ greyWidth :: Int
+ , greyHeight :: Int
+ , greyMax :: Int
+ , greyData :: [Int]
+ } deriving (Eq)
+{-- End of code from examples --}
+
+type PGMType = String
+
+data WordSize = WordSize8bit | WordSize16bit deriving (Eq)
+
+instance Show Greymap where
+ show (Greymap w h m d) = "Greymap " ++ show w ++ "x" ++ show h ++
+ " " ++ show m ++ " " ++ show d
+
+
+words8ToInts8 :: L.ByteString -> [Int]
+words8ToInts8 words =
+ case (L.uncons words) of
+ Nothing -> []
+ Just (w, rem) -> (fromIntegral w) : (words8ToInts8 rem)
+
+
+words8ToInts16 :: L.ByteString -> [Int]
+words8ToInts16 words = ints8ToInts16 (words8ToInts8 words)
+ where
+ ints8ToInts16 (a:b:rem) = ((a * 256) + b) : (ints8ToInts16 rem)
+ ints8ToInts16 _ = []
+
+
+is16Bit :: Greymap -> Bool
+is16Bit (Greymap _ _ m _) = (m > 255)
+
+
+parseHeaderPGM =
+ parseWhileWith w2c notWhite ==> \header -> skipSpaces ==>&
+ parseNat ==> \width -> skipSpaces ==>&
+ parseNat ==> \height -> skipSpaces ==>&
+ parseNat ==> \maxGrey ->
+ identity (header, (Greymap width height maxGrey []))
+ where notWhite = (`notElem` " \r\n\t")
+
+
+parsePlainPixel :: Parse Int
+parsePlainPixel = skipSpaces ==>& parseNat
+
+
+parsePlainPGM :: Int -> Parse [Int]
+parsePlainPGM pixelCount =
+ if pixelCount == 0
+ then
+ identity []
+ else
+ parsePlainPixel ==> \pixelValue ->
+ (pixelValue:) <$> parsePlainPGM (pixelCount - 1)
+
+
+parsePGMFile :: FilePath -> IO (Either String Greymap)
+parsePGMFile filePath = do
+ str <- L.readFile filePath
+ let state = ParseState str 0
+ case (runParse parseHeaderPGM) state of
+ Left err -> return (Left err)
+ Right (header, state) -> return $ parsePGMFile' header state
+ where
+ parsePGMFile' :: (PGMType, Greymap) -> ParseState -> Either String Greymap
+ parsePGMFile' (pgmType, greymap) state
+ | pgmType == "P2" = parse (parsePlainPGM pixelCount) state
+ | pgmType == "P5" && is16Bit greymap = parse (parseRawPGM pixelCount WordSize16bit) state
+ | pgmType == "P5" = parse (parseRawPGM pixelCount WordSize8bit) state
+ | otherwise = Left "Unknown PGM type"
+ where (Greymap width height maxGrey _) = greymap
+ pixelCount = width * height
+ parse parser state = case (runParse parser) state of
+ Left err -> Left err
+ Right (body, state) -> Right (Greymap width height maxGrey body)
+
+
+-- ghci> :l 10_a_1.hs
+-- [1 of 1] Compiling Main ( 10_a_1.hs, interpreted )
+-- Ok, one module loaded.
+
+-- ghci> parsePGMFile "test-10_a_1/plain.pgm"
+-- Right Greymap 3x3 255 [0,12,65,101,143,192,200,224,255]
+
+-- ghci> parsePGMFile "test-10_a_1/raw_8bit.pgm"
+-- Right Greymap 3x3 255 [0,12,65,101,143,192,200,224,255]
+
+-- ghci> parsePGMFile "test-10_a_1/raw_16bit.pgm"
+-- Right Greymap 3x3 65535 [0,3073,16642,25859,36612,49157,51206,57351,65535]
generated by cgit v1.2.3 (git 2.39.1) at 2025-12-01 01:18:19 +0000