Initial commit.

3 files changed, 481 insertions, 0 deletions

diff --git a/src/Graphics/WaveFront/Parse/Common.hs b/src/Graphics/WaveFront/Parse/Common.hs
new file mode 100644
index 0000000..bfeb2d8
--- /dev/null
+++ b/src/Graphics/WaveFront/Parse/Common.hs
@@ -0,0 +1,166 @@
+-- |
+-- Module      : Graphics.WaveFront.Parse.Common
+-- Description :
+-- Copyright   : (c) Jonatan H Sundqvist, October 2 2016
+-- License     : MIT
+-- Maintainer  : Jonatan H Sundqvist
+-- Stability   : experimental|stable
+-- Portability : POSIX (not sure)
+
+-- TODO | - Fully polymorphic (even in the string and list types) (?)
+--        - 
+
+-- SPEC | - 
+--        - 
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- GHC Extensions
+--------------------------------------------------------------------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- Section
+--------------------------------------------------------------------------------------------------------------------------------------------
+module Graphics.WaveFront.Parse.Common where
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- We'll need these
+--------------------------------------------------------------------------------------------------------------------------------------------
+import           Data.Text (Text, pack)
+import qualified Data.Attoparsec.Text as Atto
+
+import Control.Applicative (pure, liftA2, (<$>), (<*>), (<*), (*>), (<|>))
+import Linear (V2(..), V3(..))
+
+import Graphics.WaveFront.Types
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- Functions (pure)
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- Jon's little helpers --------------------------------------------------------------------------------------------------------------------
+
+-- | Consumes all input, including any leading or trailing comments and whitespace
+-- TODO | - Rename (?)
+wholeFile :: Atto.Parser a -> Atto.Parser a
+wholeFile p = cutToTheChase *> p <* cutToTheChase <* Atto.endOfInput
+
+
+-- | Skips any leading comments, line breaks and empty lines
+-- TODO | - Rename (?)
+--        - Skip whitespace
+cutToTheChase :: Atto.Parser ()
+cutToTheChase = Atto.skipMany ((comment *> pure ()) <|> (Atto.satisfy isLinearSpace *> pure ()) <|> Atto.endOfLine)
+
+
+-- | OBJ rows may be separated by one or more lines of comments and whitespace, or empty lines.
+-- TODO | - Make sure this is right
+lineSeparator :: Atto.Parser ()
+lineSeparator = Atto.skipMany1 $ ignore space *> ignore comment *> Atto.endOfLine
+
+
+-- | Parses a comment (from the '#' to end of the line), possibly preceded by whitespace
+-- TODO | - Break out the whitespace part (?)
+comment :: Atto.Parser Text
+comment = Atto.skipSpace *> Atto.char '#' *> Atto.takeTill (\c -> (c == '\r') || (c == '\n')) -- TODO: Is the newline consumed (?)
+
+
+-- | Tries the given parser, falls back to 'Nothing' if it fails
+-- TODO | - Use 'try' to enforce backtracking (?)
+optional :: Atto.Parser a -> Atto.Parser (Maybe a)
+optional p = Atto.option Nothing (Just <$> p)
+
+
+-- | Like Atto.skipMany, except it skips one match at the most
+ignore :: Atto.Parser a -> Atto.Parser ()
+ignore p = optional p *> pure ()
+
+
+-- | 
+atleast :: Int -> Atto.Parser a -> Atto.Parser [a]
+atleast n p = liftA2 (++) (Atto.count n p) (Atto.many' p)
+
+
+-- | Skips atleast one white space character (not including newlines and carriage returns)
+space :: Atto.Parser ()
+space = Atto.skipMany1 (Atto.satisfy isLinearSpace)
+
+
+-- | Predicate for linear space (eg. whitespace besides newlines)
+-- TODO | - Unicode awareness (cf. Data.Char.isSpace)
+--        - Come up with a better name (?)
+isLinearSpace :: Char -> Bool
+isLinearSpace c = (c == ' ') || (c == '\t')
+
+
+-- | One or more letters (cf. 'Atto.letter' for details)
+word :: Atto.Parser Text
+word = pack <$> Atto.many1 Atto.letter
+
+
+-- | Used for texture, material, object and group names (and maybe others that I have yet to think of)
+-- TODO | - Use Unicode groups, make more robust (?)
+name :: Atto.Parser Text
+name = pack <$> Atto.many1 (Atto.satisfy $ \c -> (c /= ' ') && (c /= '\t') && (c /= '\r') && (c /= '\n'))
+
+
+-- | Parses the strings "off" (False) and "on" (True)
+toggle :: Atto.Parser Bool
+toggle = (Atto.string "off" *> pure False) <|> (Atto.string "on" *> pure True)
+
+
+-- | Wraps a parser in a '(' and a ')', with no whitespace in between
+parenthesised :: Atto.Parser a -> Atto.Parser a
+parenthesised p = Atto.char '(' *> p <* Atto.char ')'
+
+
+-- TODO | - Allow scientific notation (?)
+
+-- |
+coord :: Fractional f => Atto.Parser f
+coord = space *> (parenthesised Atto.rational <|> Atto.rational)
+
+
+-- | A single colour channel
+-- TODO | - Clamp to [0,1] (cf. partial from monadplus) (?)
+--        - Can channels be parenthesised (?)
+channel :: Fractional f => Atto.Parser f
+channel = space *> (parenthesised Atto.rational <|> Atto.rational)
+
+
+-- | A colour with three or four channels (RGB[A])
+colour :: Fractional f => Atto.Parser (Colour f)
+colour = Colour <$> channel <*> channel <*> channel <*> Atto.option 1 channel
+
+
+-- | A point in 3D space
+point3D :: Fractional f => Atto.Parser (V3 f)
+point3D = V3 <$> coord <*> coord <*> coord
+
+
+-- | A point in 2D space
+point2D :: Fractional f => Atto.Parser (V2 f)
+point2D = V2 <$> coord <*> coord
+
+
+-- |
+clamp :: Ord n => n -> n -> n -> Atto.Parser n
+clamp lower upper n
+  | between lower upper n = pure n
+  | otherwise             = fail "Number not in range"
+  where
+    between lw up n = (lower <= n) && (n <= upper)
+    -- between 0 <. n <. 5
+
+-- |
+-- TODO | - Clean up and generalise
+clamped :: Integral i => i -> i -> Atto.Parser i
+clamped lower upper = Atto.decimal >>= clamp lower upper
\ No newline at end of file
diff --git a/src/Graphics/WaveFront/Parse/MTL.hs b/src/Graphics/WaveFront/Parse/MTL.hs
new file mode 100644
index 0000000..060952f
--- /dev/null
+++ b/src/Graphics/WaveFront/Parse/MTL.hs
@@ -0,0 +1,142 @@
+-- |
+-- Module      : Graphics.WaveFront.Parse.MTL
+-- Description :
+-- Copyright   : (c) Jonatan H Sundqvist, October 2 2016
+-- License     : MIT
+-- Maintainer  : Jonatan H Sundqvist
+-- Stability   : experimental|stable
+-- Portability : POSIX (not sure)
+
+-- TODO | - 
+--        - 
+
+-- SPEC | -
+--        -
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- GHC Extensions
+--------------------------------------------------------------------------------------------------------------------------------------------
+{-# LANGUAGE UnicodeSyntax     #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- API
+--------------------------------------------------------------------------------------------------------------------------------------------
+module Graphics.WaveFront.Parse.MTL (
+  mtl, row, token,
+  ambient, diffuse, specular,
+  mapDiffuse, newMaterial
+) where
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- We'll need these
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- import qualified Data.Map  as M
+-- import qualified Data.Set  as S
+-- import qualified Data.Vector as V
+import Data.Text (Text)
+
+import qualified Data.Attoparsec.Text as Atto
+
+import Control.Applicative ((<$>), (<*), (*>), (<|>))
+
+import Graphics.WaveFront.Parse.Common
+
+import Graphics.WaveFront.Types hiding (ambient, diffuse, specular)
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- Functions
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- MTL parsing -----------------------------------------------------------------------------------------------------------------------------
+
+-- | Produces a list of MTL tokens
+mtl :: (Fractional f) => Atto.Parser (MTL f Text [])
+mtl = Atto.sepBy row lineSeparator
+
+
+-- | Parses a single MTL row.
+row :: (Fractional f) => Atto.Parser (MTLToken f Text)
+row = token <* ignore comment
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- | Parse an MTL token
+-- TODO: How to deal with common prefix (Ka, Kd, Ks) (backtrack?)
+token :: (Fractional f) => Atto.Parser (MTLToken f Text)
+token = (Atto.string "Ka"     *> ambient)     <|>
+        (Atto.string "Kd"     *> diffuse)     <|>
+        (Atto.string "Ks"     *> specular)    <|>
+        (Atto.string "Ns"     *> specExp)     <|>
+        (Atto.string "illum"  *> illum)       <|>
+        (Atto.string "Ni"     *> refraction)  <|>
+        (Atto.string "d"      *> dissolve)    <|> -- TODO: Handle inverse as well (cf. 'Tr' attribute)
+        (Atto.string "map_Kd" *> mapDiffuse)  <|>
+        (Atto.string "map_Ka" *> mapAmbient)  <|>
+        (Atto.string "newmtl" *> newMaterial)
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- TODO: Expose these parsers for testing purposes (?)
+
+-- TODO | - Change definition of 'colour' and 'Colour' to only allow three channels (alpha is handled by the 'dissolve' attribute)
+--        - Change the definition of 'Colour' or use the one defined in the colour package
+
+-- | Three or four channel values (RGB[A])
+ambient :: (Fractional f) => Atto.Parser (MTLToken f s)
+ambient = Ambient <$> colour
+
+
+-- | Three or four channel values (RGB[A])
+diffuse :: (Fractional f) => Atto.Parser (MTLToken f s)
+diffuse = Diffuse <$> colour
+
+
+-- | Three or four channel values (RGB[A])
+specular :: (Fractional f) => Atto.Parser (MTLToken f s)
+specular = Specular <$> colour
+
+
+-- | A rational number, preceded by whitespace (specular exponent)
+specExp :: (Fractional f) => Atto.Parser (MTLToken f s)
+specExp = space *> (SpecularExponent <$> Atto.rational)
+
+
+-- | A number between 0 and 10 (inclusive) (illumination model)
+illum :: Atto.Parser (MTLToken f s)
+illum = space *> (Illum <$> clamped 0 10)
+
+
+-- | A rational number, preceded by whitespace (refraction index)
+refraction :: (Fractional f) => Atto.Parser (MTLToken f s)
+refraction = space *> (Refraction <$> Atto.rational)
+
+
+-- | A rational number, preceded by whitespace (doss)
+dissolve :: (Fractional f) => Atto.Parser (MTLToken f s)
+dissolve = space *> (Dissolve <$> Atto.rational)
+
+
+-- | A texture name, preceded by whitespace
+mapDiffuse :: Atto.Parser (MTLToken f Text)
+mapDiffuse = space *> (MapDiffuse <$> name)
+
+
+-- | A texture name, preceded by whitespace
+mapAmbient :: Atto.Parser (MTLToken f Text)
+mapAmbient = space *> (MapAmbient <$> name)
+
+
+-- | A material name, preceded by whitespace
+newMaterial :: Atto.Parser (MTLToken f Text)
+newMaterial = space *> (NewMaterial <$> name)
\ No newline at end of file
diff --git a/src/Graphics/WaveFront/Parse/OBJ.hs b/src/Graphics/WaveFront/Parse/OBJ.hs
new file mode 100644
index 0000000..37aa5a0
--- /dev/null
+++ b/src/Graphics/WaveFront/Parse/OBJ.hs
@@ -0,0 +1,173 @@
+-- |
+-- Module      : Graphics.WaveFront.Parse.OBJ
+-- Description :
+-- Copyright   : (c) Jonatan H Sundqvist, October 2 2016
+-- License     : MIT
+-- Maintainer  : Jonatan H Sundqvist
+-- Stability   : experimental|stable
+-- Portability : POSIX (not sure)
+
+-- TODO | - Fully polymorphic (even in the string and list types) (?)
+--        - 
+
+-- SPEC | -
+--        -
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- GHC Extensions
+--------------------------------------------------------------------------------------------------------------------------------------------
+{-# LANGUAGE UnicodeSyntax     #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- API
+--------------------------------------------------------------------------------------------------------------------------------------------
+module Graphics.WaveFront.Parse.OBJ (
+  obj, row, face,
+  normal, texcoord, vertex, object, group,
+  lib, use,
+  vertexIndices,
+) where
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- We'll need these
+--------------------------------------------------------------------------------------------------------------------------------------------
+import Data.Text (Text)
+-- import qualified Data.Vector as V
+import qualified Data.Set as S
+
+import qualified Data.Attoparsec.Text as Atto
+
+import Control.Applicative ((<$>), (<*>), (<*), (*>), (<|>))
+
+-- import Linear (V2(..), V3(..))
+
+import Graphics.WaveFront.Parse.Common
+import Graphics.WaveFront.Types hiding (texture)
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- Functions
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- OBJ parsing -----------------------------------------------------------------------------------------------------------------------------
+
+-- | This function creates an OBJToken or error for each line in the input data
+obj :: (Fractional f, Integral i) => Atto.Parser (OBJ f Text i [])
+obj = Atto.sepBy row lineSeparator -- <* Atto.endOfInput
+
+
+-- | Parses a token given a single valid OBJ row
+--
+-- TODO | - Correctness (total function, no runtime exceptions)
+--        - Handle invalid rows (how to deal with mangled definitions w.r.t indices?)
+--        - Use ListLike or Monoid (or maybe Indexable, since that's the real requirement) (?)
+row :: (Fractional f, Integral i) => Atto.Parser (OBJToken f Text i [])
+row = token <* ignore comment -- TODO: Let the separator handle comments (?)
+
+
+-- |
+-- Parses an OBJ token
+token :: (Fractional f, Integral i) => Atto.Parser (OBJToken f Text i [])
+token = (Atto.string "f"  *> face)     <|>
+        (Atto.string "l"  *> line)     <|>
+        -- TODO: How to deal with common prefix (v, vn, vt) (backtrack?) (doesn't seem to be a problem)
+        (Atto.string "vn" *> normal)   <|>
+        (Atto.string "vt" *> texcoord) <|>
+        (Atto.string "v"  *> vertex)   <|>
+        (Atto.string "o"  *> object)   <|>
+        (Atto.string "g"  *> group)    <|>
+        (Atto.string "s"  *> smooth)   <|>
+        (Atto.string "mtllib" *> lib)  <|>
+        (Atto.string "usemtl" *> use)
+
+    
+-- TODO: Expose these parsers for testing purposes (?)
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- | Three or more vertex definitions (cf. 'vertexIndices' for details)
+face :: Integral i => Atto.Parser (OBJToken f Text i [])
+face = OBJFace <$> vertexIndices
+
+
+-- | A single vertex definition with indices for vertex position, normal, and texture coordinates
+--
+-- TODO: | - Should the slashes be optional?
+--         - Allowed trailing slashes (I'll have to check the spec again) (?)
+--
+-- f Int[/((Int[/Int])|(/Int))]
+vertexIndices :: Integral i => Atto.Parser [VertexIndices i]
+vertexIndices = atleast 3 (space *> (ivertex <*> index   <*> index))     <|> -- vi/ti/ni
+                atleast 3 (space *> (ivertex <*> nothing <*> skipIndex)) <|> -- vi//ni
+                atleast 3 (space *> (ivertex <*> index   <*> nothing))   <|> -- vi/ti
+                atleast 3 (space *> (ivertex <*> nothing <*> nothing))       -- vi
+  where
+    ivertex :: Integral i => Atto.Parser (Maybe i -> Maybe i -> VertexIndices i)
+    ivertex = VertexIndices <$> Atto.decimal
+
+    index :: Integral i => Atto.Parser (Maybe i)
+    index = Just <$> (Atto.char '/' *> Atto.decimal)
+    
+    skipIndex :: Integral i => Atto.Parser (Maybe i)
+    skipIndex = Atto.char '/' *> index
+
+    nothing :: Atto.Parser (Maybe i)
+    nothing = pure Nothing
+
+-- Geometry primitives ---------------------------------------------------------------------------------------------------------------------
+
+-- | Two integers, separated by whitespace
+line :: Integral i => Atto.Parser (OBJToken f Text i m)
+line = Line <$> (space *> Atto.decimal) <*> (space *> Atto.decimal)
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- | Three cordinates, separated by whitespace
+normal :: (Fractional f) => Atto.Parser (OBJToken f Text i m)
+normal = OBJNormal <$> point3D
+
+
+-- | Two coordinates, separated by whitespace
+texcoord :: (Fractional f) => Atto.Parser (OBJToken f Text i m)
+texcoord = OBJTexCoord <$> point2D
+
+
+-- | Three coordinates, separated by whitespace
+vertex :: (Fractional f) =>  Atto.Parser (OBJToken f s i m)
+vertex  = OBJVertex <$> point3D
+
+
+-- | Object names, separated by whitespace
+object :: Atto.Parser (OBJToken f Text i m)
+object = Object . S.fromList <$> atleast 1 (space *> name)
+
+
+-- | Group names, separated by whitespace
+group :: Atto.Parser (OBJToken f Text i m)
+group = Group . S.fromList <$> atleast 1 (space *> name)
+
+
+-- | Smoothing group
+-- TODO: Refactor
+smooth :: Atto.Parser (OBJToken f Text i m)
+smooth = SmoothGroup <$> (((Atto.string "off" <|> Atto.string "0") *> pure Nothing) <|> (space *> (Just <$> name)))
+
+
+-- | An MTL library name
+lib :: Atto.Parser (OBJToken f Text i m)
+lib = LibMTL <$> (space *> name)
+
+
+-- | An MTL material name
+use :: Atto.Parser (OBJToken f Text i m)
+use = UseMTL <$> (space *> name)
\ No newline at end of file