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
|
-----------------------------------------------------------------------------
-- |
-- 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.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)
-- |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
, 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)
|
