Sabadie parser: support vp token.

4 files changed, 38 insertions, 2 deletions

diff --git a/src/Codec/Wavefront/Lexer.hs b/src/Codec/Wavefront/Lexer.hs
index efb4b97..712cabf 100644
--- a/src/Codec/Wavefront/Lexer.hs
+++ b/src/Codec/Wavefront/Lexer.hs
@@ -32,6 +32,8 @@ data Ctxt = Ctxt {
     ctxtLocations :: DList Location
     -- |Texture coordinates.
   , ctxtTexCoords :: DList TexCoord
+    -- |Texture coordinates.
+  , ctxtParamCoords :: DList ParamCoord
     -- |Normals.
   , ctxtNormals :: DList Normal
     -- |Points.
@@ -58,6 +60,7 @@ emptyCtxt :: Ctxt
 emptyCtxt = Ctxt {
     ctxtLocations = empty
   , ctxtTexCoords = empty
+  , ctxtParamCoords = empty
   , ctxtNormals = empty
   , ctxtPoints = empty
   , ctxtLines = empty
@@ -83,6 +86,9 @@ lexer stream = execState (traverse_ consume stream) emptyCtxt
       TknVT vt -> do
         texCoords <- gets ctxtTexCoords
         modify $ \ctxt -> ctxt { ctxtTexCoords = texCoords `snoc` vt }
+      TknVP vp -> do
+        pCoords <- gets ctxtParamCoords
+        modify $ \ctxt -> ctxt { ctxtParamCoords = pCoords `snoc` vp }
       TknP p -> do
         (pts,element) <- prepareElement ctxtPoints
         modify $ \ctxt -> ctxt { ctxtPoints = pts `append` fmap element (fromList p) }
diff --git a/src/Codec/Wavefront/TexCoord.hs b/src/Codec/Wavefront/TexCoord.hs
index 02e5c5a..0eb09f4 100644
--- a/src/Codec/Wavefront/TexCoord.hs
+++ b/src/Codec/Wavefront/TexCoord.hs
@@ -18,10 +18,25 @@ module Codec.Wavefront.TexCoord where
 --   let TexCoord r s t = TexCoord 0.1 0.2 0.3
 -- @
 --
--- That type is strcit and unboxed.
+-- That type is strict and unboxed.
 data TexCoord = TexCoord {
     texcoordR :: {-# UNPACK #-} !Float
   , texcoordS :: {-# UNPACK #-} !Float
   , texcoordT :: {-# UNPACK #-} !Float
   } deriving (Eq,Show)
 
+
+-- |A parameter-space coordinate is a 3D-floating vector. You can access to its components by pattern
+-- matching on them:
+--
+-- @
+--   let ParamCoord r s t = ParamCoord 0.1 0.2 0.3
+-- @
+--
+-- That type is strict and unboxed.
+data ParamCoord = ParamCoord {
+    paramcoordR :: {-# UNPACK #-} !Float
+  , paramcoordS :: {-# UNPACK #-} !Float
+  , paramcoordT :: {-# UNPACK #-} !Float
+  } deriving (Eq,Show)
+
diff --git a/src/Codec/Wavefront/Token.hs b/src/Codec/Wavefront/Token.hs
index 31e62e7..71691a8 100644
--- a/src/Codec/Wavefront/Token.hs
+++ b/src/Codec/Wavefront/Token.hs
@@ -34,6 +34,7 @@ data Token
   = TknV Location
   | TknVN Normal
   | TknVT TexCoord
+  | TknVP ParamCoord
   | TknP [Point]
   | TknL [Line]
   | TknF Face
@@ -55,6 +56,7 @@ tokenize = fmap cleanupTokens . analyseResult False . parse (untilEnd tokenizer)
         fmap (Just . TknV) location
       , fmap (Just . TknVN) normal
       , fmap (Just . TknVT) texCoord
+      , fmap (Just . TknVP) paramCoord
       , fmap (Just . TknP) points
       , fmap (Just . TknL) lines
       , fmap (Just . TknF) face
@@ -116,6 +118,19 @@ texCoord = skipSpace *> string "vt " *> skipHSpace *> parseUVW <* eol
         _ -> fail "wrong number of u, v and w arguments for texture coordinates"
 
 ----------------------------------------------------------------------------------------------------
+-- Parameter-space coordinates -----------------------------------------------------------------------------
+
+paramCoord :: Parser ParamCoord
+paramCoord = skipSpace *> string "vp " *> skipHSpace *> parseUVW <* eol
+  where
+    parseUVW = do
+      uvw <- float `sepBy1` skipHSpace
+      case uvw of
+        [u,v] -> pure (ParamCoord u v 0)
+        [u,v,w] -> pure (ParamCoord u v w)
+        _ -> fail "wrong number of u, v and w arguments for parameter-space coordinates"
+
+----------------------------------------------------------------------------------------------------
 -- Points ------------------------------------------------------------------------------------------
 
 points :: Parser [Point]
diff --git a/test/TestSabadie.hs b/test/TestSabadie.hs
index a01693b..de13678 100644
--- a/test/TestSabadie.hs
+++ b/test/TestSabadie.hs
@@ -16,4 +16,4 @@ main = do
     r1 <- fromFile (ddir ++ "/01.obj")
     print r1
     -- Failed: `    vp    ` [...]: Failed reading: empty
-    -- Reason: vp token and blank lines
+    -- Reason: blank lines