crayne parser: higher level interface.

4 files changed, 309 insertions, 3 deletions

diff --git a/src/Data/Wavefront.hs b/src/Data/Wavefront.hs
new file mode 100644
index 0000000..2284d38
--- /dev/null
+++ b/src/Data/Wavefront.hs
@@ -0,0 +1,167 @@
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE UndecidableInstances  #-}
+module Data.Wavefront where
+
+import Data.Kind
+import Data.Text (Text)
+import Numeric.Natural
+import qualified Rank2
+
+data WavefrontOBJ v = WavefrontOBJ {
+    objLocations :: v Location
+  , objTexCoords :: v TexCoord
+  , objNormals   :: v Normal
+  , objPoints    :: v (Element Point)
+  , objLines     :: v (Element Line)
+  , objFaces     :: v (Element Face)
+  , objMtlLibs   :: v Text
+  }
+
+type ForThisWavefrontOBJ (c :: * -> Constraint) v =
+        ( c (v Location)
+        , c (v TexCoord)
+        , c (v Normal)
+        , c (v (Element Point))
+        , c (v (Element Line))
+        , c (v (Element Face))
+        , c (v Text) )
+
+type ForAllWavefrontOBJ (c :: * -> Constraint) =
+        ( c Location
+        , c TexCoord
+        , c Normal
+        , c (Element Point)
+        , c (Element Line)
+        , c (Element Face)
+        , c Text
+        )
+
+deriving instance ForThisWavefrontOBJ Eq v => Eq (WavefrontOBJ v)
+deriving instance ForThisWavefrontOBJ Show v => Show (WavefrontOBJ v)
+
+instance Rank2.Functor WavefrontOBJ where
+    f <$> obj = obj
+        { objLocations = f (objLocations obj)
+        , objTexCoords = f (objTexCoords obj)
+        , objNormals   = f (objNormals obj)
+        , objPoints    = f (objPoints obj)
+        , objLines     = f (objLines obj)
+        , objFaces     = f (objFaces obj)
+        , objMtlLibs   = f (objMtlLibs obj)
+        }
+
+class Rank2.Functor g => Payload c g where
+    mapPayload :: proxy c -> (forall a. c a => p a -> q a) -> g p -> g q
+
+instance ForAllWavefrontOBJ c => Payload c WavefrontOBJ where
+    mapPayload _ f obj = obj
+        { objLocations = f (objLocations obj)
+        , objTexCoords = f (objTexCoords obj)
+        , objNormals   = f (objNormals obj)
+        , objPoints    = f (objPoints obj)
+        , objLines     = f (objLines obj)
+        , objFaces     = f (objFaces obj)
+        , objMtlLibs   = f (objMtlLibs obj)
+        }
+
+
+
+-- | A location is a 4-floating vector. You can access to its components by
+-- pattern matching on them:
+--
+-- > let Location x y z w = Location 1 2 3 4
+--
+-- That type is strict and unboxed.
+data Location = Location {
+    locX :: {-# UNPACK #-} !Float
+  , locY :: {-# UNPACK #-} !Float
+  , locZ :: {-# UNPACK #-} !Float
+  , locW :: {-# UNPACK #-} !Float
+  } deriving (Eq,Show)
+
+-- | A texture coordinate is a 3D-floating vector. You can access to its
+-- components by pattern matching on them:
+--
+-- > let TexCoord r s t = TexCoord 0.1 0.2 0.3
+--
+-- That type is strcit and unboxed.
+data TexCoord = TexCoord {
+    texcoordR :: {-# UNPACK #-} !Float
+  , texcoordS :: {-# UNPACK #-} !Float
+  , texcoordT :: {-# UNPACK #-} !Float
+  } deriving (Eq,Show)
+
+
+-- | A normal is a 3-floating vector. You can access to its components by
+-- pattern matching on them:
+--
+-- > let Normal nx ny nz = Normal 0.1 0.2 0.3
+--
+-- That type is strict and unboxed.
+data Normal = Normal {
+    norX :: {-# UNPACK #-} !Float
+  , norY :: {-# UNPACK #-} !Float
+  , norZ :: {-# UNPACK #-} !Float
+  } deriving (Eq,Show)
+
+-- | A point is a single index that references the locations. It’s a canonical
+-- type that truly represents a polygonal point.
+data Point = Point {
+    pointLocIndex :: {-# UNPACK #-} !Int
+  } deriving (Eq,Show)
+
+-- | A line index is a pair of indices. @'LineIndex' vi vti@. @vi@ references
+-- the locations and @vti@ indexes the texture coordinates. If @vti ==
+-- 'Nothing'@, then that 'LineIndex' doesn’t have texture coordinates
+-- associated with.
+data LineIndex = LineIndex {
+    lineLocIndex      :: {-# UNPACK #-} !Int
+  , lineTexCoordIndex :: !(Maybe Int)
+  } deriving (Eq,Show)
+
+-- | A line gathers two line indices accessible by pattern matching or
+-- 'lineIndexA' and 'lineIndexB'.
+data Line = Line {
+    lineIndexA :: LineIndex
+  , lineIndexB :: LineIndex
+  } deriving (Eq,Show)
+
+-- | A face index is a triplet of indices. @'FaceIndex' vi vti vni@ is a face
+-- that indexes the locations with @vi@, the texture coordinates with @vti@ and
+-- the normals with @vni@. An index set to 'Nothing' means /no information/.
+-- That is, if @vni == 'Nothing'@, then that 'FaceIndex' doesn’t have a normal
+-- associated with.
+data FaceIndex = FaceIndex {
+    faceLocIndex      :: {-# UNPACK #-} !Int
+  , faceTexCoordIndex :: !(Maybe Int)
+  , faceNorIndex      :: !(Maybe Int)
+  } deriving (Eq,Show)
+
+-- | A face gathers several 'FaceIndex' to build up faces. It has a least three
+-- vertices
+data Face = Face FaceIndex FaceIndex FaceIndex [FaceIndex] deriving (Eq,Show)
+
+pattern Triangle :: FaceIndex -> FaceIndex -> FaceIndex -> Face
+pattern Triangle a b c = Face a b c []
+
+pattern Quad :: FaceIndex -> FaceIndex -> FaceIndex -> FaceIndex -> Face
+pattern Quad a b c d = Face a b c [d]
+
+-- | An element holds a value along with the user-defined object’s name (if
+-- any), the associated groups, the used material and the smoothing group the
+-- element belongs to (if any). Those values can be used to sort the data per
+-- object or per group and to lookup materials.
+data Element a = Element {
+    elObject         :: Maybe Text
+  , elGroups         :: [Text]
+  , elMtl            :: Maybe Text
+  , elSmoothingGroup :: Natural
+  , elValue          :: a
+  } deriving (Eq,Show,Functor)
diff --git a/src/Wavefront.hs b/src/Wavefront.hs
new file mode 100644
index 0000000..6195eee
--- /dev/null
+++ b/src/Wavefront.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Wavefront where
+
+import Data.Wavefront
+import Wavefront.Lex
+
+import Control.Arrow
+import Control.Monad.State
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.DList                 as DList
+         ;import Data.DList                 (DList)
+import Data.Functor.Identity
+import qualified Data.IntMap                as IntMap
+import Data.Text.Encoding                   (decodeUtf8)
+import qualified Data.Vector                as Vector
+         ;import Data.Vector                (Vector)
+import qualified Rank2
+
+newtype Count x = Count Int
+
+updateCount :: MonadState s m => (s -> Count x) -> (Count x -> s -> s) -> m ()
+updateCount field setField = do
+    Count c0 <- gets field
+    let c = succ c0
+    c `seq` modify (setField $ Count c)
+
+fixupRef :: Count x -> Int -> Int
+fixupRef (Count n) x | x >  0    = x - 1 -- Renumber from 0.
+                     | otherwise = n + x -- Negative values are relative.
+
+fixupTriple :: WavefrontOBJ Count -> RefTriple -> RefTriple
+fixupTriple o (RefTriple v t n) =
+    RefTriple (fixupRef (objLocations o) v)
+              (fixupRef (objTexCoords o) <$> t)
+              (fixupRef (objNormals   o) <$> n)
+
+objBookKeeping :: Monad m => ObjBuilder m -> ObjBuilder (StateT (WavefrontOBJ Count) m)
+objBookKeeping builder = (lift Rank2.<$> builder)
+    { vertex = \xs -> do lift $ vertex builder xs
+                         updateCount objLocations $ \x o -> o { objLocations = x }
+    , vertexT = \xs -> do lift $ vertexT builder xs
+                          updateCount objTexCoords $ \x o -> o { objTexCoords = x }
+    , vertexN = \xs -> do lift $ vertexN builder xs
+                          updateCount objNormals $ \x o -> o { objNormals = x }
+    , points = \xs -> do
+        n <- gets objLocations
+        lift $ points builder $ fixupRef n <$> xs
+    , line = \ts -> do
+        o <- get
+        lift $ line builder $ fixupTriple o <$> ts
+    , face = \ts -> do
+        o <- get
+        lift $ face builder $ fixupTriple o <$> ts
+    }
+
+mkv :: [Double] -> Location
+mkv cs = Location x y z w where (x:y:z:w:_) = map realToFrac cs
+
+mkt :: [Double] -> TexCoord
+mkt cs = TexCoord x y z where (x:y:z:_) = map realToFrac cs
+
+mkn :: [Double] -> Normal
+mkn cs = Normal x y z where (x:y:z:_) = map realToFrac cs
+
+mkl :: RefTriple -> RefTriple -> Line
+mkl (RefTriple a at _) (RefTriple b bt _) = Line (LineIndex a at) (LineIndex b bt)
+
+-- I'd have thought these would be Coercible, but I guess not.
+mkF :: RefTriple -> FaceIndex
+mkF (RefTriple a at an) = FaceIndex a at an
+
+elemental :: Element () -> x -> Element x
+elemental element x = fmap (const x) element
+
+modifyFirst :: MonadState (c, d) m => (c -> c) -> m ()
+modifyFirst = modify' . first
+
+buildOBJ :: ObjBuilder (State (WavefrontOBJ DList,Element ()))
+buildOBJ = (nullBuilder $ pure ())
+    { vertex = \xs -> modifyFirst $ \o -> o { objLocations = objLocations o `DList.snoc` mkv xs }
+    , vertexT = \xs -> modifyFirst $ \o -> o { objTexCoords = objTexCoords o `DList.snoc` mkt xs }
+    , vertexN = \xs -> modifyFirst $ \o -> o { objNormals = objNormals o `DList.snoc` mkn xs }
+    , points = \xs -> do
+        let p = map Point xs :: [Point]
+        (pts,element) <- gets (objPoints *** elemental)
+        modifyFirst $ \o -> o { objPoints = pts `DList.append` fmap element (DList.fromList p) }
+    , line = \xs -> do
+        (lns,element) <- gets (objLines *** elemental)
+        let l = zipWith mkl xs (tail xs)
+        -- Line requires at least two points.  We'll ignore it otherwise.
+        when (not $ null l) $
+            modifyFirst $ \o -> o { objLines = lns `DList.append` fmap element (DList.fromList l) }
+    , face = \xs -> do
+        (fcs,element) <- gets (objFaces *** elemental)
+        case map mkF xs of
+          a:b:c:ds -> modifyFirst $ \o -> o { objFaces = fcs `DList.snoc` element (Face a b c ds) }
+          _        -> return () -- Ignore faces with less than 3 indices.
+    , mtllib = \xs -> do
+        let l = map decodeUtf8 xs
+        libs <- gets (objMtlLibs . fst)
+        modifyFirst $ \o -> o { objMtlLibs = libs `DList.append` DList.fromList l }
+    , groups = \xs -> do
+        let g = map decodeUtf8 xs
+        modify' $ second $ \e -> e { elGroups = g }
+    , objectName = \x -> do
+        let o = decodeUtf8 x
+        modify' $ second $ \e -> e { elObject = Just o }
+    , usemtl = \x -> do
+        let mtl = decodeUtf8 x
+        modify' $ second $ \e -> e { elMtl = Just mtl }
+    , smoothingGroup = \x -> when (x > 0) $ do
+        modify $ second $ \e -> e { elSmoothingGroup = fromIntegral x }
+    }
+
+parse :: L.ByteString -> WavefrontOBJ Vector
+parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj
+ where
+    b = objBookKeeping buildOBJ
+    ls = WavefrontOBJ
+            { objLocations = DList.empty
+            , objTexCoords = DList.empty
+            , objNormals   = DList.empty
+            , objPoints    = DList.empty
+            , objLines     = DList.empty
+            , objFaces     = DList.empty
+            , objMtlLibs   = DList.empty
+            }
+    c = Rank2.fmap (const $ Count 0) ls :: WavefrontOBJ Count
+    el = Element
+            { elObject         = Nothing
+            , elGroups         = []
+            , elMtl            = Nothing
+            , elSmoothingGroup = 0
+            , elValue          = ()
+            }
+    substvars = ObjConfig IntMap.empty
+    (obj,_) = execState (runStateT (parseOBJ b substvars bs) c) (ls,el)
diff --git a/src/Wavefront/Lex.hs b/src/Wavefront/Lex.hs
index 7123184..78c6f1d 100644
--- a/src/Wavefront/Lex.hs
+++ b/src/Wavefront/Lex.hs
@@ -377,9 +377,9 @@ data ParamSpec = ParamU | ParamV
  deriving (Eq,Ord,Show,Enum)
 
 data RefTriple = RefTriple
-        { refV :: Int
-        , refT :: Maybe Int
-        , refN :: Maybe Int
+        { refV :: {-# UNPACK #-} !Int
+        , refT :: !(Maybe Int)
+        , refN :: !(Maybe Int)
         }
 -- data RefTriple = RefTriple Int (Maybe Int) (Maybe Int)
  deriving (Eq,Ord,Show)
diff --git a/wavefront-obj.cabal b/wavefront-obj.cabal
index 1ccbc91..a771fe9 100644
--- a/wavefront-obj.cabal
+++ b/wavefront-obj.cabal
@@ -49,6 +49,8 @@ library
                     , Codec.Wavefront.FreeForm
                     , Codec.Wavefront.Token
                     , Wavefront.Lex
+                    , Data.Wavefront
+                    , Wavefront
   -- other-modules:
   other-extensions:   ForeignFunctionInterface
                     , UnicodeSyntax