diff options
author | Yann Herklotz Grave <git@yannherklotzgrave.com> | 2019-02-21 19:33:16 +0000 |
---|---|---|
committer | Yann Herklotz Grave <git@yannherklotzgrave.com> | 2019-02-21 19:33:16 +0000 |
commit | ec56fed98f691fe32de29e0cdbaa354cf9c3e79a (patch) | |
tree | 3e060cab235a650529ab34615e7e3bc8e104b135 /src | |
parent | 711deffd693615530ec9a12f7c3e58682633e032 (diff) | |
download | pfm-master.tar.gz pfm-master.zip |
Diffstat (limited to 'src')
-rw-r--r-- | src/PFM.hs | 152 | ||||
-rw-r--r-- | src/PFM/Vec.hs | 41 |
2 files changed, 86 insertions, 107 deletions
@@ -10,37 +10,42 @@ Portability : POSIX Debevec PFM reader -} -module PFM ( PFMImage(..) - , PPMImage(..) - , PFMColour(..) - , PPMColour(..) - , parse - , encode - , encodePPM - , revColour - , gamma - , module PFM.Vec) where - -import Control.Applicative ((<|>)) -import Data.Attoparsec.ByteString (Parser) -import qualified Data.Attoparsec.ByteString as P -import Data.Binary.Get (runGet) -import Data.Binary.IEEE754 (getFloat32be, getFloat32le, - putFloat32le) -import Data.Binary.Put (runPut) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Lazy (fromStrict) -import qualified Data.ByteString.Lazy as BL -import Data.Foldable (fold) -import Data.Functor ((<$>)) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Vector (Vector) -import qualified Data.Vector as V -import Data.Word (Word8) +module PFM + ( PFMImage(..) + , PPMImage(..) + , PFMColour(..) + , PPMColour(..) + , parse + , encode + , encodePPM + , revColour + , gamma + , module PFM.Vec + ) +where + +import Control.Applicative ( (<|>) ) +import Data.Attoparsec.ByteString ( Parser ) +import qualified Data.Attoparsec.ByteString as P +import Data.Binary.Get ( runGet ) +import Data.Binary.IEEE754 ( getFloat32be + , getFloat32le + , putFloat32le + ) +import Data.Binary.Put ( runPut ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B +import Data.ByteString.Lazy ( fromStrict ) +import qualified Data.ByteString.Lazy as BL +import Data.Foldable ( fold ) +import Data.Functor ( (<$>) ) +import Data.Monoid ( (<>) ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Vector ( Vector ) +import qualified Data.Vector as V +import Data.Word ( Word8 ) import PFM.Vec type PFMColours = Vector (Vector PFMColour) @@ -80,16 +85,12 @@ matchText = P.string . T.encodeUtf8 magicNum :: Parser ImageType magicNum = do - match <- T.decodeUtf8 <$> (matchText "Pf" <|> matchText "PF") - if match == "Pf" - then return MonoImage - else return ColourImage + match <- T.decodeUtf8 <$> (matchText "Pf" <|> matchText "PF") + if match == "Pf" then return MonoImage else return ColourImage skipNewline :: Parser () -skipNewline = P.skip isNewline - where - isNewline w = w == 13 || w == 10 +skipNewline = P.skip isNewline where isNewline w = w == 13 || w == 10 skipSpace :: Parser () skipSpace = P.skip (== 32) @@ -104,51 +105,49 @@ num :: Parser Int num = decode <$> matchMult "0-9" endianness :: Parser Endianness -endianness = - getEnd . (<(0.0 :: Float)) . decode <$> matchMult "0-9.-" +endianness = getEnd . (< (0.0 :: Float)) . decode <$> matchMult "0-9.-" where getEnd True = Little getEnd False = Big float :: Endianness -> Parser Float -float e = - runGet conv . fromStrict <$> P.take 4 +float e = runGet conv . fromStrict <$> P.take 4 where conv = case e of - Big -> getFloat32be - Little -> getFloat32le + Big -> getFloat32be + Little -> getFloat32le header :: Parser (Int, Int, Endianness, ImageType) header = do - n <- magicNum - skipNewline - n1 <- num - skipSpace - n2 <- num - skipNewline - s <- endianness - skipNewline - return (n1, n2, s, n) + n <- magicNum + skipNewline + n1 <- num + skipSpace + n2 <- num + skipNewline + s <- endianness + skipNewline + return (n1, n2, s, n) parseColour :: Endianness -> Parser PFMColour parseColour e = do - ri <- float e - gi <- float e - bi <- float e - return $ PFMColour ri gi bi + ri <- float e + gi <- float e + bi <- float e + return $ PFMColour ri gi bi parseMono :: Endianness -> Parser PFMColour parseMono e = PFMMono <$> float e parser :: Parser PFMImage parser = do - (w, h, e, i) <- header - c <- V.fromList <$> (P.many1 . fmap V.fromList . P.count w) (fun i e) - return $ PFMImage w h c + (w, h, e, i) <- header + c <- V.fromList <$> (P.many1 . fmap V.fromList . P.count w) (fun i e) + return $ PFMImage w h c where fun i = case i of - ColourImage -> parseColour - MonoImage -> parseMono + ColourImage -> parseColour + MonoImage -> parseMono magicNumPFM :: PFMColours -> Text magicNumPFM v = case V.head $ V.head v of @@ -162,45 +161,38 @@ encFloat :: Float -> BL.ByteString encFloat = runPut . putFloat32le encodeColourPFM :: PFMColour -> BL.ByteString -encodeColourPFM (PFMColour ri gi bi) = - encFloat ri <> encFloat gi <> encFloat bi -encodeColourPFM (PFMMono m) = - encFloat m +encodeColourPFM (PFMColour ri gi bi) = encFloat ri <> encFloat gi <> encFloat bi +encodeColourPFM (PFMMono m ) = encFloat m encodeColourPPM :: PPMColour -> BL.ByteString -encodeColourPPM (PPMColour ri gi bi) = - BL.pack [ri, gi, bi] -encodeColourPPM (PPMMono m) = - BL.pack [m, m, m] +encodeColourPPM (PPMColour ri gi bi) = BL.pack [ri, gi, bi] +encodeColourPPM (PPMMono m ) = BL.pack [m, m, m] -- | Encode as a PFM file. Returns a lazy ByteString with the encoded -- result. encode :: PFMImage -> BL.ByteString -encode (PFMImage w h c) = - fromStrict (T.encodeUtf8 he) <> body +encode (PFMImage w h c) = fromStrict (T.encodeUtf8 he) <> body where - he = magicNumPFM c <> "\n" <> tShow w <> " " <> tShow h <> "\n-1.0\n" + he = magicNumPFM c <> "\n" <> tShow w <> " " <> tShow h <> "\n-1.0\n" body = fold . fold $ fmap encodeColourPFM <$> c -- | Encode as a PPM file. Returns a lazy ByteString which contains the encoded -- file. encodePPM :: PPMImage -> BL.ByteString -encodePPM (PPMImage w h c) = - fromStrict (T.encodeUtf8 he) <> body +encodePPM (PPMImage w h c) = fromStrict (T.encodeUtf8 he) <> body where - he = "P6" <> "\n" <> tShow w <> " " <> tShow h <> "\n255\n" + he = "P6" <> "\n" <> tShow w <> " " <> tShow h <> "\n255\n" body = fold . fold $ fmap encodeColourPPM <$> c -- | Parse a 'ByteString' into a 'PFMImage'. These can be mono colour images or -- RGB colour images. parse :: ByteString -> PFMImage parse s = case P.parseOnly parser s of - Left str -> error str - Right i -> i + Left str -> error str + Right i -> i revColour :: PFMImage -> PFMImage -revColour (PFMImage w h i) = - PFMImage w h $ V.reverse i +revColour (PFMImage w h i) = PFMImage w h $ V.reverse i gamma :: (Floating a) => a -> a -> a gamma g m = m ** (1 / g) diff --git a/src/PFM/Vec.hs b/src/PFM/Vec.hs index 2e8f8ab..8cd3f71 100644 --- a/src/PFM/Vec.hs +++ b/src/PFM/Vec.hs @@ -33,44 +33,31 @@ instance Functor Sph where fmap f (Sph (a, b)) = Sph (f a, f b) findZ :: (RealFloat a) => a -> a -> Vec a -findZ x y = - Vec (x, y, z) +findZ x y = Vec (x, y, z) where - sq = sqrt (1 - x**2 - y**2) - z = if isNaN sq then 0 else sq + sq = sqrt (1 - x ** 2 - y ** 2) + z = if isNaN sq then 0 else sq dot :: (Num a) => Vec a -> Vec a -> a -dot (Vec (x1, y1, z1)) (Vec (x2, y2, z2)) = - x1 * x2 + y1 * y2 + z1 * z2 +dot (Vec (x1, y1, z1)) (Vec (x2, y2, z2)) = x1 * x2 + y1 * y2 + z1 * z2 normalise :: (RealFloat a) => Int -> (Int, Int) -> Vec a -normalise size (y, x) = - findZ (scale x) $ scale y - where - scale a = 2 * fromIntegral a / fromIntegral size - 1 +normalise size (y, x) = findZ (scale x) $ scale y + where scale a = 2 * fromIntegral a / fromIntegral size - 1 reflect :: (RealFloat a) => Int -> Vec a -> (Int, Int) -> Vec a -reflect size v (y, x) = - l - v +reflect size v (y, x) = l - v where n = normalise size (y, x) - l = ((2 * dot n v)*) <$> n + l = ((2 * dot n v) *) <$> n toSpherical :: (Floating a, Eq a, Ord a) => Vec a -> Sph a -toSpherical (Vec (x, y, z)) - | z == 0 && x >= 0 = - Sph (acos y, pi / 2) - | z == 0 = - Sph (acos y, - pi / 2) - | z < 0 && x >= 0 = - Sph (acos y, pi + atan (x / z)) - | z < 0 = - Sph (acos y, - pi + atan (x / z)) - | otherwise = - Sph (acos y, atan (x / z)) +toSpherical (Vec (x, y, z)) | z == 0 && x >= 0 = Sph (acos y, pi / 2) + | z == 0 = Sph (acos y, -pi / 2) + | z < 0 && x >= 0 = Sph (acos y, pi + atan (x / z)) + | z < 0 = Sph (acos y, -pi + atan (x / z)) + | otherwise = Sph (acos y, atan (x / z)) indexLatLong :: (RealFrac a, Floating a) => Int -> Int -> Sph a -> (Int, Int) indexLatLong w h (Sph (theta, phi)) = - ( floor $ theta / pi * fromIntegral h - , floor $ ((phi / (2 * pi)) + 0.5) * fromIntegral w - ) + (floor $ theta / pi * fromIntegral h, floor $ ((phi / (2 * pi)) + 0.5) * fromIntegral w) |