diff options
Diffstat (limited to 'src/Codec/Wavefront/Lexer.hs')
-rw-r--r-- | src/Codec/Wavefront/Lexer.hs | 54 |
1 files changed, 32 insertions, 22 deletions
diff --git a/src/Codec/Wavefront/Lexer.hs b/src/Codec/Wavefront/Lexer.hs index 712cabf..77ecb35 100644 --- a/src/Codec/Wavefront/Lexer.hs +++ b/src/Codec/Wavefront/Lexer.hs | |||
@@ -29,13 +29,13 @@ import Numeric.Natural ( Natural ) | |||
29 | -- |The lexer context. The result of lexing a stream of tokens is this exact type. | 29 | -- |The lexer context. The result of lexing a stream of tokens is this exact type. |
30 | data Ctxt = Ctxt { | 30 | data Ctxt = Ctxt { |
31 | -- |Locations. | 31 | -- |Locations. |
32 | ctxtLocations :: DList Location | 32 | ctxtLocations :: (Int, DList Location) |
33 | -- |Texture coordinates. | 33 | -- |Texture coordinates. |
34 | , ctxtTexCoords :: DList TexCoord | 34 | , ctxtTexCoords :: (Int, DList TexCoord) |
35 | -- |Texture coordinates. | 35 | -- |Texture coordinates. |
36 | , ctxtParamCoords :: DList ParamCoord | 36 | , ctxtParamCoords :: (Int, DList ParamCoord) |
37 | -- |Normals. | 37 | -- |Normals. |
38 | , ctxtNormals :: DList Normal | 38 | , ctxtNormals :: (Int, DList Normal) |
39 | -- |Points. | 39 | -- |Points. |
40 | , ctxtPoints :: DList (Element Point) | 40 | , ctxtPoints :: DList (Element Point) |
41 | -- |Lines. | 41 | -- |Lines. |
@@ -56,12 +56,12 @@ data Ctxt = Ctxt { | |||
56 | 56 | ||
57 | -- |The empty 'Ctxt'. Such a context exists at the beginning of the token stream and gets altered | 57 | -- |The empty 'Ctxt'. Such a context exists at the beginning of the token stream and gets altered |
58 | -- as we consume tokens. | 58 | -- as we consume tokens. |
59 | emptyCtxt :: Ctxt | 59 | emptyCtxt :: Ctxt |
60 | emptyCtxt = Ctxt { | 60 | emptyCtxt = Ctxt { |
61 | ctxtLocations = empty | 61 | ctxtLocations = (0,empty) |
62 | , ctxtTexCoords = empty | 62 | , ctxtTexCoords = (0,empty) |
63 | , ctxtParamCoords = empty | 63 | , ctxtParamCoords = (0,empty) |
64 | , ctxtNormals = empty | 64 | , ctxtNormals = (0,empty) |
65 | , ctxtPoints = empty | 65 | , ctxtPoints = empty |
66 | , ctxtLines = empty | 66 | , ctxtLines = empty |
67 | , ctxtFaces = empty | 67 | , ctxtFaces = empty |
@@ -72,30 +72,40 @@ emptyCtxt = Ctxt { | |||
72 | , ctxtCurrentSmoothingGroup = 0 | 72 | , ctxtCurrentSmoothingGroup = 0 |
73 | } | 73 | } |
74 | 74 | ||
75 | updateList v field setField = do | ||
76 | (c0,vs) <- gets field | ||
77 | let c = succ c0 | ||
78 | c `seq` modify $ setField (c, vs `snoc` v) | ||
79 | |||
80 | derel c x | x > 0 = x | ||
81 | | otherwise = c + x + 1 | ||
82 | |||
83 | derelF cv ct cn (FaceIndex v mt mn) = FaceIndex (derel cv v) (derel ct <$> mt) (derel cn <$> mn) | ||
84 | |||
85 | derelativizeFace cv ct cn (Face a b c ds) = Face a' b' c' ds' | ||
86 | where | ||
87 | a':b':c':ds' = map (derelF cv ct cn) $ a:b:c:ds | ||
88 | |||
75 | -- |The lexer function, consuming tokens and yielding a 'Ctxt'. | 89 | -- |The lexer function, consuming tokens and yielding a 'Ctxt'. |
76 | lexer :: TokenStream -> Ctxt | 90 | lexer :: TokenStream -> Ctxt |
77 | lexer stream = execState (traverse_ consume stream) emptyCtxt | 91 | lexer stream = execState (traverse_ consume stream) emptyCtxt |
78 | where | 92 | where |
79 | consume tk = case tk of | 93 | consume tk = case tk of |
80 | TknV v -> do | 94 | TknV v -> updateList v ctxtLocations $ \x ctxt -> ctxt { ctxtLocations = x } |
81 | locations <- gets ctxtLocations | 95 | TknVN vn -> updateList vn ctxtNormals $ \x ctxt -> ctxt { ctxtNormals = x } |
82 | modify $ \ctxt -> ctxt { ctxtLocations = locations `snoc` v } | 96 | TknVT vt -> updateList vt ctxtTexCoords $ \x ctxt -> ctxt { ctxtTexCoords = x } |
83 | TknVN vn -> do | 97 | TknVP vp -> updateList vp ctxtParamCoords $ \x ctxt -> ctxt { ctxtParamCoords = x } |
84 | normals <- gets ctxtNormals | ||
85 | modify $ \ctxt -> ctxt { ctxtNormals = normals `snoc` vn } | ||
86 | TknVT vt -> do | ||
87 | texCoords <- gets ctxtTexCoords | ||
88 | modify $ \ctxt -> ctxt { ctxtTexCoords = texCoords `snoc` vt } | ||
89 | TknVP vp -> do | ||
90 | pCoords <- gets ctxtParamCoords | ||
91 | modify $ \ctxt -> ctxt { ctxtParamCoords = pCoords `snoc` vp } | ||
92 | TknP p -> do | 98 | TknP p -> do |
93 | (pts,element) <- prepareElement ctxtPoints | 99 | (pts,element) <- prepareElement ctxtPoints |
94 | modify $ \ctxt -> ctxt { ctxtPoints = pts `append` fmap element (fromList p) } | 100 | modify $ \ctxt -> ctxt { ctxtPoints = pts `append` fmap element (fromList p) } |
95 | TknL l -> do | 101 | TknL l -> do |
96 | (lns,element) <- prepareElement ctxtLines | 102 | (lns,element) <- prepareElement ctxtLines |
97 | modify $ \ctxt -> ctxt { ctxtLines = lns `append` fmap element (fromList l) } | 103 | modify $ \ctxt -> ctxt { ctxtLines = lns `append` fmap element (fromList l) } |
98 | TknF f -> do | 104 | TknF f0 -> do |
105 | vgcnt <- gets (fst . ctxtLocations) | ||
106 | vtcnt <- gets (fst . ctxtTexCoords) | ||
107 | vncnt <- gets (fst . ctxtNormals) | ||
108 | let f = derelativizeFace vgcnt vtcnt vncnt f0 | ||
99 | (fcs,element) <- prepareElement ctxtFaces | 109 | (fcs,element) <- prepareElement ctxtFaces |
100 | modify $ \ctxt -> ctxt { ctxtFaces = fcs `snoc` element f } | 110 | modify $ \ctxt -> ctxt { ctxtFaces = fcs `snoc` element f } |
101 | TknG g -> modify $ \ctxt -> ctxt { ctxtCurrentGroups = g } | 111 | TknG g -> modify $ \ctxt -> ctxt { ctxtCurrentGroups = g } |