From 083779f1bdf92aed9519c9d1f1e6c4042f574a82 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Tue, 11 Jun 2019 05:11:54 -0400
Subject: Sabadie parser: relative vertex references in faces.

---
 src/Codec/Wavefront/Lexer.hs  | 54 +++++++++++++++++++++++++------------------
 src/Codec/Wavefront/Object.hs |  8 +++----
 src/Codec/Wavefront/Token.hs  |  6 ++---
 3 files changed, 39 insertions(+), 29 deletions(-)

diff --git a/src/Codec/Wavefront/Lexer.hs b/src/Codec/Wavefront/Lexer.hs
index 712cabf..77ecb35 100644
--- a/src/Codec/Wavefront/Lexer.hs
+++ b/src/Codec/Wavefront/Lexer.hs
@@ -29,13 +29,13 @@ import Numeric.Natural ( Natural )
 -- |The lexer context. The result of lexing a stream of tokens is this exact type.
 data Ctxt = Ctxt {
     -- |Locations.
-    ctxtLocations :: DList Location
+    ctxtLocations :: (Int, DList Location)
     -- |Texture coordinates.
-  , ctxtTexCoords :: DList TexCoord
+  , ctxtTexCoords :: (Int, DList TexCoord)
     -- |Texture coordinates.
-  , ctxtParamCoords :: DList ParamCoord
+  , ctxtParamCoords :: (Int, DList ParamCoord)
     -- |Normals.
-  , ctxtNormals :: DList Normal
+  , ctxtNormals :: (Int, DList Normal)
     -- |Points.
   , ctxtPoints :: DList (Element Point)
     -- |Lines.
@@ -56,12 +56,12 @@ data Ctxt = Ctxt {
 
 -- |The empty 'Ctxt'. Such a context exists at the beginning of the token stream and gets altered
 -- as we consume tokens.
-emptyCtxt :: Ctxt 
+emptyCtxt :: Ctxt
 emptyCtxt = Ctxt {
-    ctxtLocations = empty
-  , ctxtTexCoords = empty
-  , ctxtParamCoords = empty
-  , ctxtNormals = empty
+    ctxtLocations = (0,empty)
+  , ctxtTexCoords = (0,empty)
+  , ctxtParamCoords = (0,empty)
+  , ctxtNormals = (0,empty)
   , ctxtPoints = empty
   , ctxtLines = empty
   , ctxtFaces = empty
@@ -72,30 +72,40 @@ emptyCtxt = Ctxt {
   , ctxtCurrentSmoothingGroup = 0
   }
 
+updateList v field setField = do
+    (c0,vs) <- gets field
+    let c = succ c0
+    c `seq` modify $ setField (c, vs `snoc` v)
+
+derel c x | x > 0     = x
+          | otherwise = c + x + 1
+
+derelF cv ct cn (FaceIndex v mt mn) = FaceIndex (derel cv v) (derel ct <$> mt) (derel cn <$> mn)
+
+derelativizeFace cv ct cn (Face a b c ds) = Face a' b' c' ds'
+ where
+    a':b':c':ds' = map (derelF cv ct cn) $ a:b:c:ds
+
 -- |The lexer function, consuming tokens and yielding a 'Ctxt'.
 lexer :: TokenStream -> Ctxt
 lexer stream = execState (traverse_ consume stream) emptyCtxt
   where
     consume tk = case tk of
-      TknV v -> do
-        locations <- gets ctxtLocations
-        modify $ \ctxt -> ctxt { ctxtLocations = locations `snoc` v }
-      TknVN vn -> do
-        normals <- gets ctxtNormals
-        modify $ \ctxt -> ctxt { ctxtNormals = normals `snoc` vn }
-      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 }
+      TknV v   -> updateList v  ctxtLocations   $ \x ctxt -> ctxt { ctxtLocations   = x }
+      TknVN vn -> updateList vn ctxtNormals     $ \x ctxt -> ctxt { ctxtNormals     = x }
+      TknVT vt -> updateList vt ctxtTexCoords   $ \x ctxt -> ctxt { ctxtTexCoords   = x }
+      TknVP vp -> updateList vp ctxtParamCoords $ \x ctxt -> ctxt { ctxtParamCoords = x }
       TknP p -> do
         (pts,element) <- prepareElement ctxtPoints
         modify $ \ctxt -> ctxt { ctxtPoints = pts `append` fmap element (fromList p) }
       TknL l -> do
         (lns,element) <- prepareElement ctxtLines
         modify $ \ctxt -> ctxt { ctxtLines = lns `append` fmap element (fromList l) }
-      TknF f -> do
+      TknF f0 -> do
+        vgcnt <- gets (fst . ctxtLocations)
+        vtcnt <- gets (fst . ctxtTexCoords)
+        vncnt <- gets (fst . ctxtNormals)
+        let f = derelativizeFace vgcnt vtcnt vncnt f0
         (fcs,element) <- prepareElement ctxtFaces
         modify $ \ctxt -> ctxt { ctxtFaces = fcs `snoc` element f }
       TknG g -> modify $ \ctxt -> ctxt { ctxtCurrentGroups = g }
diff --git a/src/Codec/Wavefront/Object.hs b/src/Codec/Wavefront/Object.hs
index bdd756f..26d85c2 100644
--- a/src/Codec/Wavefront/Object.hs
+++ b/src/Codec/Wavefront/Object.hs
@@ -44,10 +44,10 @@ data WavefrontOBJ = WavefrontOBJ {
 
 ctxtToWavefrontOBJ :: Ctxt -> WavefrontOBJ
 ctxtToWavefrontOBJ ctxt = WavefrontOBJ {
-    objLocations = fromDList (ctxtLocations ctxt)
-  , objTexCoords = fromDList (ctxtTexCoords ctxt)
-  , objNormals = fromDList (ctxtNormals ctxt)
-  , objParamCoords = fromDList (ctxtParamCoords ctxt)
+    objLocations = fromDList (snd $ ctxtLocations ctxt)
+  , objTexCoords = fromDList (snd $ ctxtTexCoords ctxt)
+  , objNormals = fromDList (snd $ ctxtNormals ctxt)
+  , objParamCoords = fromDList (snd $ ctxtParamCoords ctxt)
   , objPoints = fromDList (ctxtPoints ctxt)
   , objLines = fromDList (ctxtLines ctxt)
   , objFaces = fromDList (ctxtFaces ctxt)
diff --git a/src/Codec/Wavefront/Token.hs b/src/Codec/Wavefront/Token.hs
index 01acd5c..70b3437 100644
--- a/src/Codec/Wavefront/Token.hs
+++ b/src/Codec/Wavefront/Token.hs
@@ -169,13 +169,13 @@ face = do
   where
     parseFaceIndices = fmap (\(i,k,j) -> FaceIndex i k j) parseFaceTriple `sepBy1` skipHSpace
     parseFaceTriple = do
-      v <- decimal
+      v <- signed decimal
       slashThenElse (parseVT v) (pure (v,Nothing,Nothing))
     parseVT v = slashThenElse (parseVN v Nothing) $ do
-      vt <- decimal
+      vt <- signed decimal
       slashThenElse (parseVN v $ Just vt) (pure (v,Just vt,Nothing))
     parseVN v vt = do
-      vn <- decimal
+      vn <- signed decimal
       pure (v,vt,Just vn)
 
 ----------------------------------------------------------------------------------------------------
-- 
cgit v1.2.3