module Codec.Wavefront.Object (
Ctxt(..)
, emptyCtxt
, Element(..)
, lexer
, WavefrontOBJ
) where
import Codec.Wavefront.Face
import Codec.Wavefront.Line
import Codec.Wavefront.Location
import Codec.Wavefront.Normal
import Codec.Wavefront.Point
import Codec.Wavefront.Token
import Codec.Wavefront.TexCoord
import Control.Monad.State ( State, execState, gets, modify )
import Data.DList ( DList, append, empty, fromList, snoc )
import Data.Text ( Text )
import Data.Foldable ( traverse_ )
data Element a = Element {
elObject :: Maybe Text
, elGroups :: [Text]
, elMtl :: Maybe Text
, elValue :: a
} deriving (Eq,Show)
data Ctxt = Ctxt {
ctxtName :: Maybe Text
, ctxtLocations :: DList Location
, ctxtTexCoords :: DList TexCoord
, ctxtNormals :: DList Normal
, ctxtPoints :: DList (Element Point)
, ctxtLines :: DList (Element Line)
, ctxtFaces :: DList (Element Face)
, ctxtCurrentObject :: Maybe Text
, ctxtCurrentGroups :: [Text]
, ctxtCurrentMtl :: Maybe Text
, ctxtMtlLibs :: DList Text
} deriving (Eq,Show)
type WavefrontOBJ = Ctxt
emptyCtxt :: Ctxt
emptyCtxt = Ctxt {
ctxtName = Nothing
, ctxtLocations = empty
, ctxtTexCoords = empty
, ctxtNormals = empty
, ctxtPoints = empty
, ctxtLines = empty
, ctxtFaces = empty
, ctxtCurrentObject = Nothing
, ctxtCurrentGroups = ["default"]
, ctxtCurrentMtl = Nothing
, ctxtMtlLibs = empty
}
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 }
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
(fcs,element) <- prepareElement ctxtFaces
modify $ \ctxt -> ctxt { ctxtFaces = fcs `append` fmap element (fromList f) }
TknG g -> modify $ \ctxt -> ctxt { ctxtCurrentGroups = g }
TknO o -> modify $ \ctxt -> ctxt { ctxtCurrentObject = Just o }
TknMtlLib l -> do
libs <- gets ctxtMtlLibs
modify $ \ctxt -> ctxt { ctxtMtlLibs = libs `append` fromList l }
TknUseMtl mtl -> modify $ \ctxt -> ctxt { ctxtCurrentMtl = Just mtl }
prepareElement :: (Ctxt -> DList (Element a)) -> State Ctxt (DList (Element a),a -> Element a)
prepareElement field = do
(aList,obj,grp,mtl) <- gets $ (\ctxt -> (field ctxt,ctxtCurrentObject ctxt,ctxtCurrentGroups ctxt,ctxtCurrentMtl ctxt))
pure (aList,Element obj grp mtl)