1 files changed, 104 insertions, 0 deletions
diff --git a/src/PFM.hs b/src/PFM.hs
new file mode 100644
index 0000000..f16400f
--- /dev/null
+++ b/src/PFM.hs
@@ -0,0 +1,104 @@
+{-|
+Module      : PFM
+Description : Debevec PFM reader
+Copyright   : (c) 2019, Yann Herklotz Grave
+License     : GPL-3
+Maintainer  : ymherklotz [at] gmail [dot] com
+Stability   : experimental
+Portability : POSIX
+
+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)
+import           Data.ByteString            (ByteString)
+import qualified Data.ByteString            as B
+import           Data.ByteString.Lazy       (fromStrict)
+import           Data.Text                  (Text)
+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)
+
+matchText :: Text -> Parser ByteString
+matchText = P.string . T.encodeUtf8
+
+magicNumMono :: Parser ()
+magicNumMono = void $ matchText "Pf"
+
+magicNumRGB :: Parser ()
+magicNumRGB = void $ matchText "PF"
+
+skipNewline :: Parser ()
+skipNewline = P.skip isNewline
+  where
+    isNewline w = w == 13 || w == 10
+
+skipSpace :: Parser ()
+skipSpace = P.skip (== 32)
+
+decode :: (Read a) => [Word8] -> a
+decode = read . T.unpack . T.decodeUtf8 . B.pack
+
+matchMult :: String -> Parser [Word8]
+matchMult = P.many1 . P.satisfy . P.inClass
+
+num :: Parser Int
+num = decode <$> matchMult "0-9"
+
+endianness :: Parser Float
+endianness = decode <$> matchMult "0-9.-"
+
+float :: Parser Float
+float = runGet getFloat32le . fromStrict <$> P.take 4
+
+header :: Parser (Int, Int, Float)
+header = do
+  magicNumRGB
+  skipNewline
+  n1 <- num
+  skipSpace
+  n2 <- num
+  skipNewline
+  s <- endianness
+  skipNewline
+  return (n1, n2, s)
+
+parseColour :: Parser Colour
+parseColour = do
+  ri <- float
+  gi <- float
+  bi <- float
+  return $ Colour ri gi bi
+
+parseMono :: Parser Colour
+parseMono = Mono <$> float
+
+parser :: Parser Image
+parser = do
+  (w, h, f) <- header
+  c <- P.many1 parseColour
+  return $ Image w h c
+
+parse :: ByteString -> IO ()
+parse s = case P.parseOnly parser s of
+  Left str -> putStrLn str
+  Right i  -> print i