From c0118f29bcfc1fb7cf61da7260e4fdc2283be241 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Wed, 30 Jan 2019 01:14:24 +0000 Subject: Fix ordering of PFM and add PPM --- app/Main.hs | 20 ++++++++++++-- pfm.cabal | 1 + src/PFM.hs | 92 ++++++++++++++++++++++++++++++++++++++----------------------- 3 files changed, 76 insertions(+), 37 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 9c75d6f..d04a3b3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,26 @@ module Main where +import Criterion import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T +import Data.Word (Word8) import PFM +clamp :: PFMColour -> PPMColour +clamp (PFMColour ri gi bi) = + PPMColour (f ri) (f gi) (f bi) + where + v s = s * 255.0 + f s = if v s > 255.0 then 255 else fromInteger (round (v s)) +clamp _ = undefined + +clampImage :: PFMImage -> PPMImage +clampImage (PFMImage w h c) = + PPMImage w h . reverse $ fmap clamp <$> c + main :: IO () main = do - s <- B.readFile "/home/yannherklotz/Imperial/AdvancedGraphics/coursework1/CO417-Assignment1/UrbanProbe/urbanEM_latlong.pfm" - let i = parse s - BL.writeFile "random.pfm" $ encode i + -- s <- B.readFile "/home/yannherklotz/Imperial/AdvancedGraphics/coursework1/CO417-Assignment1/UrbanProbe/urbanEM_latlong.pfm" + s <- B.readFile "/home/yannherklotz/Downloads/memorial.pfm" + BL.writeFile "random.ppm" . encodePPM . clampImage . parse $ s diff --git a/pfm.cabal b/pfm.cabal index e4bcda1..b529dfc 100644 --- a/pfm.cabal +++ b/pfm.cabal @@ -42,4 +42,5 @@ executable readpfm , pfm , text , bytestring + , criterion default-extensions: OverloadedStrings diff --git a/src/PFM.hs b/src/PFM.hs index bf805a5..06e8557 100644 --- a/src/PFM.hs +++ b/src/PFM.hs @@ -13,16 +13,15 @@ Debevec PFM reader module PFM where import Control.Applicative ((<|>)) -import Control.Monad (void) import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as P import Data.Binary.Get (runGet) import Data.Binary.IEEE754 (getFloat32be, getFloat32le, - putFloat32be, putFloat32le) + putFloat32le) import Data.Binary.Put (runPut) import Data.ByteString (ByteString) import qualified Data.ByteString as B -import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.ByteString.Lazy (fromStrict) import qualified Data.ByteString.Lazy as BL import Data.Foldable (fold) import Data.Text (Text) @@ -30,17 +29,29 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Word (Word8) -data Image = Image { width :: Int - , height :: Int - , colour :: [Colour] - } deriving (Show) - -data Colour = Colour { r :: Float - , g :: Float - , b :: Float - } - | Mono Float - deriving (Show) +data PFMImage = PFMImage { pfmWidth :: Int + , pfmHeight :: Int + , pfmColour :: [[PFMColour]] + } deriving (Show) + +data PPMImage = PPMImage { ppmWidth :: Int + , ppmHeight :: Int + , ppmColour :: [[PPMColour]] + } deriving (Show) + +data PFMColour = PFMColour { r :: Float + , g :: Float + , b :: Float + } + | PFMMono Float + deriving (Show) + +data PPMColour = PPMColour { rw :: Word8 + , gw :: Word8 + , bw :: Word8 + } + | PPMMono Word8 + deriving (Show) data Endianness = Big | Little @@ -76,7 +87,7 @@ num = decode <$> matchMult "0-9" endianness :: Parser Endianness endianness = - getEnd . (<0.0) . decode <$> matchMult "0-9.-" + getEnd . (<(0.0 :: Float)) . decode <$> matchMult "0-9.-" where getEnd True = Little getEnd False = Big @@ -101,30 +112,30 @@ header = do skipNewline return (n1, n2, s, n) -parseColour :: Endianness -> Parser Colour +parseColour :: Endianness -> Parser PFMColour parseColour e = do ri <- float e gi <- float e bi <- float e - return $ Colour ri gi bi + return $ PFMColour ri gi bi -parseMono :: Endianness -> Parser Colour -parseMono e = Mono <$> float e +parseMono :: Endianness -> Parser PFMColour +parseMono e = PFMMono <$> float e -parser :: Parser Image +parser :: Parser PFMImage parser = do (w, h, e, i) <- header - c <- P.many1 $ fun i e - return $ Image w h c + c <- P.many1 . P.count w $ fun i e + return $ PFMImage w h c where fun i = case i of ColourImage -> parseColour MonoImage -> parseMono -imageType :: [Colour] -> Text -imageType [] = "PF" -imageType (Colour{}:_) = "PF" -imageType (Mono{}:_) = "Pf" +magicNumPFM :: [[PFMColour]] -> Text +magicNumPFM ((PFMColour{}:_):_) = "PF" +magicNumPFM ((PFMMono{}:_):_) = "Pf" +magicNumPFM _ = "PF" tShow :: (Show a) => a -> Text tShow = T.pack . show @@ -132,20 +143,33 @@ tShow = T.pack . show encFloat :: Float -> BL.ByteString encFloat = runPut . putFloat32le -encodeColour :: Colour -> BL.ByteString -encodeColour (Colour ri gi bi) = +encodeColourPFM :: PFMColour -> BL.ByteString +encodeColourPFM (PFMColour ri gi bi) = encFloat ri <> encFloat gi <> encFloat bi -encodeColour (Mono m) = +encodeColourPFM (PFMMono m) = encFloat m -encode :: Image -> BL.ByteString -encode (Image w h c) = +encodeColourPPM :: PPMColour -> BL.ByteString +encodeColourPPM (PPMColour ri gi bi) = + BL.pack [ri, gi, bi] +encodeColourPPM (PPMMono m) = + BL.pack [m, m, m] + +encode :: PFMImage -> BL.ByteString +encode (PFMImage w h c) = + fromStrict (T.encodeUtf8 he) <> body + where + he = magicNumPFM c <> "\n" <> tShow w <> " " <> tShow h <> "\n-1.0\n" + body = fold . fold $ fmap encodeColourPFM <$> c + +encodePPM :: PPMImage -> BL.ByteString +encodePPM (PPMImage w h c) = fromStrict (T.encodeUtf8 he) <> body where - he = imageType c <> "\n" <> tShow w <> " " <> tShow h <> "\n-1.0\n" - body = fold $ encodeColour <$> c + he = "P6" <> "\n" <> tShow w <> " " <> tShow h <> "\n255\n" + body = fold . fold $ fmap encodeColourPPM <$> c -parse :: ByteString -> Image +parse :: ByteString -> PFMImage parse s = case P.parseOnly parser s of Left str -> error str Right i -> i -- cgit