From 98aa7d7177aaf46171b095bbb28e2f1e868323c5 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 14 Jun 2019 20:41:03 -0400 Subject: Reorganizing. --- src/Data/Wavefront.hs | 167 ------------------------------------------------- src/Wavefront.hs | 27 ++++---- src/Wavefront/Types.hs | 167 +++++++++++++++++++++++++++++++++++++++++++++++++ wavefront-obj.cabal | 2 +- 4 files changed, 183 insertions(+), 180 deletions(-) delete mode 100644 src/Data/Wavefront.hs create mode 100644 src/Wavefront/Types.hs diff --git a/src/Data/Wavefront.hs b/src/Data/Wavefront.hs deleted file mode 100644 index 2284d38..0000000 --- a/src/Data/Wavefront.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# 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 index 6195eee..1fc8ec3 100644 --- a/src/Wavefront.hs +++ b/src/Wavefront.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} module Wavefront where -import Data.Wavefront +import Wavefront.Types import Wavefront.Lex import Control.Arrow @@ -16,10 +16,13 @@ import qualified Data.Vector as Vector ;import Data.Vector (Vector) import qualified Rank2 +type WavefrontOBJ = OBJ Vector + newtype Count x = Count Int -updateCount :: MonadState s m => (s -> Count x) -> (Count x -> s -> s) -> m () -updateCount field setField = do + +incrementCount :: MonadState s m => (s -> Count x) -> (Count x -> s -> s) -> m () +incrementCount field setField = do Count c0 <- gets field let c = succ c0 c `seq` modify (setField $ Count c) @@ -28,20 +31,20 @@ 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 :: OBJ 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 :: Monad m => ObjBuilder m -> ObjBuilder (StateT (OBJ Count) m) objBookKeeping builder = (lift Rank2.<$> builder) { vertex = \xs -> do lift $ vertex builder xs - updateCount objLocations $ \x o -> o { objLocations = x } + incrementCount objLocations $ \x o -> o { objLocations = x } , vertexT = \xs -> do lift $ vertexT builder xs - updateCount objTexCoords $ \x o -> o { objTexCoords = x } + incrementCount objTexCoords $ \x o -> o { objTexCoords = x } , vertexN = \xs -> do lift $ vertexN builder xs - updateCount objNormals $ \x o -> o { objNormals = x } + incrementCount objNormals $ \x o -> o { objNormals = x } , points = \xs -> do n <- gets objLocations lift $ points builder $ fixupRef n <$> xs @@ -75,7 +78,7 @@ 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 :: ObjBuilder (State (OBJ 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 } @@ -112,11 +115,11 @@ buildOBJ = (nullBuilder $ pure ()) modify $ second $ \e -> e { elSmoothingGroup = fromIntegral x } } -parse :: L.ByteString -> WavefrontOBJ Vector +parse :: L.ByteString -> OBJ Vector parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj where b = objBookKeeping buildOBJ - ls = WavefrontOBJ + ls = OBJ { objLocations = DList.empty , objTexCoords = DList.empty , objNormals = DList.empty @@ -125,7 +128,7 @@ parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj , objFaces = DList.empty , objMtlLibs = DList.empty } - c = Rank2.fmap (const $ Count 0) ls :: WavefrontOBJ Count + c = Rank2.fmap (const $ Count 0) ls :: OBJ Count el = Element { elObject = Nothing , elGroups = [] diff --git a/src/Wavefront/Types.hs b/src/Wavefront/Types.hs new file mode 100644 index 0000000..564f5d5 --- /dev/null +++ b/src/Wavefront/Types.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Wavefront.Types where + +import Data.Kind +import Data.Text (Text) +import Numeric.Natural +import qualified Rank2 + +data OBJ v = OBJ { + 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 ForThisOBJ (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 ForAllOBJ (c :: * -> Constraint) = + ( c Location + , c TexCoord + , c Normal + , c (Element Point) + , c (Element Line) + , c (Element Face) + , c Text + ) + +deriving instance ForThisOBJ Eq v => Eq (OBJ v) +deriving instance ForThisOBJ Show v => Show (OBJ v) + +instance Rank2.Functor OBJ 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 ForAllOBJ c => Payload c OBJ 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/wavefront-obj.cabal b/wavefront-obj.cabal index d4df055..5baa231 100644 --- a/wavefront-obj.cabal +++ b/wavefront-obj.cabal @@ -15,7 +15,7 @@ extra-source-files: CHANGELOG.md library exposed-modules: Wavefront.Lex - , Data.Wavefront + , Wavefront.Types , Wavefront -- other-modules: other-extensions: ConstraintKinds -- cgit v1.2.3