1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
-----------------------------------------------------------------------------
-- |
-- Copyright : (C) 2015 Dimitri Sabadie
-- License : BSD3
--
-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Codec.Wavefront.Lexer where
import Codec.Wavefront.Element
import Codec.Wavefront.Face
import Codec.Wavefront.FreeForm
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 Data.DList ( DList, append, empty, fromList, snoc )
import Data.Text ( Text )
import Control.Monad.State ( State, execState, gets, modify )
import Data.Foldable ( traverse_ )
import Numeric.Natural ( Natural )
-- |The lexer context. The result of lexing a stream of tokens is this exact type.
data Ctxt = Ctxt {
-- |Locations.
ctxtLocations :: (Int, DList Location)
-- |Texture coordinates.
, ctxtTexCoords :: (Int, DList TexCoord)
-- |Texture coordinates.
, ctxtParamCoords :: (Int, DList ParamCoord)
-- |Normals.
, ctxtNormals :: (Int, DList Normal)
-- |Points.
, ctxtPoints :: DList (Element Point)
-- |Lines.
, ctxtLines :: DList (Element Line)
-- |Faces.
, ctxtFaces :: DList (Element Face)
-- |Curves.
, ctxtCurves :: DList (Element Curve)
-- |Curves on surfaces.
, ctxtEmbeddedCurves :: DList (Element EmbeddedCurve)
-- |Surfaces.
, ctxtSurfaces :: DList (Element Surface)
-- |Current object.
, ctxtCurrentObject :: Maybe Text
-- |Current groups.
, ctxtCurrentGroups :: [Text]
-- |Current material.
, ctxtCurrentMtl :: Maybe Text
-- |Material libraries.
, ctxtMtlLibs :: DList Text
-- |Current smoothing group.
, ctxtCurrentSmoothingGroup :: Natural
} deriving (Eq,Show)
-- |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 {
ctxtLocations = (0,empty)
, ctxtTexCoords = (0,empty)
, ctxtParamCoords = (0,empty)
, ctxtNormals = (0,empty)
, ctxtPoints = empty
, ctxtLines = empty
, ctxtFaces = empty
, ctxtCurves = empty
, ctxtEmbeddedCurves = empty
, ctxtSurfaces = empty
, ctxtCurrentObject = Nothing
, ctxtCurrentGroups = ["default"]
, ctxtCurrentMtl = Nothing
, ctxtMtlLibs = empty
, 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 -> 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 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 }
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 }
TknS sg -> modify $ \ctxt -> ctxt { ctxtCurrentSmoothingGroup = sg }
-- Prepare to create a new 'Element' by retrieving its associated list.
prepareElement :: (Ctxt -> DList (Element a)) -> State Ctxt (DList (Element a),a -> Element a)
prepareElement field = do
(aList,obj,grp,mtl,sg) <- gets $ (\ctxt -> (field ctxt,ctxtCurrentObject ctxt,ctxtCurrentGroups ctxt,ctxtCurrentMtl ctxt,ctxtCurrentSmoothingGroup ctxt))
pure (aList,Element obj grp mtl sg)
|
