From bc7855492d8bdb21437c6d6b94a9c1872da45f1f Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 14 Jun 2019 19:22:29 -0400 Subject: crayne parser: higher level interface. --- src/Data/Wavefront.hs | 167 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/Wavefront.hs | 137 +++++++++++++++++++++++++++++++++++++++++ src/Wavefront/Lex.hs | 6 +- wavefront-obj.cabal | 2 + 4 files changed, 309 insertions(+), 3 deletions(-) create mode 100644 src/Data/Wavefront.hs create mode 100644 src/Wavefront.hs 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 -- cgit v1.2.3