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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
{-# LANGUAGE FlexibleContexts #-}
module Wavefront where
import Wavefront.Types
import Wavefront.Lex
import Control.Arrow
import Control.Monad.State
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.DList as DList
;import Data.DList (DList)
import Data.Functor.Identity
import qualified Data.IntMap as IntMap
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Vector as Vector
;import Data.Vector (Vector)
import qualified Rank2
type WavefrontOBJ = OBJ Vector
newtype Count x = Count Int
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)
fixupRef :: Count x -> Int -> Int
fixupRef (Count n) x | x > 0 = x - 1 -- Renumber from 0.
| otherwise = n + x -- Negative values are relative.
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 (OBJ Count) m)
objBookKeeping builder = (lift Rank2.<$> builder)
{ vertex = \xs -> do lift $ vertex builder xs
incrementCount objLocations $ \x o -> o { objLocations = x }
, vertexT = \xs -> do lift $ vertexT builder xs
incrementCount objTexCoords $ \x o -> o { objTexCoords = x }
, vertexN = \xs -> do lift $ vertexN builder xs
incrementCount objNormals $ \x o -> o { objNormals = x }
, points = \xs -> do
n <- gets objLocations
lift $ points builder $ fixupRef n <$> xs
incrementCount objPoints $ \x o -> o { objPoints = x }
, line = \ts -> do
o <- get
lift $ line builder $ fixupTriple o <$> ts
incrementCount objLines $ \x o -> o { objLines = x }
, face = \ts -> do
o <- get
lift $ face builder $ fixupTriple o <$> ts
incrementCount objFaces $ \x o -> o { objFaces = x }
}
mkv :: [Double] -> Location
mkv cs = Location x y z w where (x:y:z:w:_) = map realToFrac cs ++ repeat 1
mkt :: [Double] -> TexCoord
mkt cs = TexCoord x y z where (x:y:z:_) = map realToFrac cs ++ repeat 0
mkn :: [Double] -> Normal
mkn cs = Normal x y z where (x:y:z:_) = map realToFrac cs ++ repeat 0
mkl :: RefTriple -> RefTriple -> Line
mkl (RefTriple a at _) (RefTriple b bt _) = Line (LineIndex a at) (LineIndex b bt)
-- I'd have thought these would be Coercible, but I guess not.
mkF :: RefTriple -> FaceIndex
mkF (RefTriple a at an) = FaceIndex a at an
elemental :: Element () -> x -> Element x
elemental element x = fmap (const x) element
modifyFirst :: MonadState (c, d) m => (c -> c) -> m ()
modifyFirst = modify' . first
buildOBJ :: ObjBuilder (State (OBJ DList,Element ()))
buildOBJ = nullBuilder
{ vertex = \xs -> modifyFirst $ \o -> o { objLocations = objLocations o `DList.snoc` mkv xs }
, vertexT = \xs -> modifyFirst $ \o -> o { objTexCoords = objTexCoords o `DList.snoc` mkt xs }
, vertexN = \xs -> modifyFirst $ \o -> o { objNormals = objNormals o `DList.snoc` mkn xs }
, points = \xs -> do
let p = map Point xs :: [Point]
(pts,element) <- gets (objPoints *** elemental)
modifyFirst $ \o -> o { objPoints = pts `DList.append` fmap element (DList.fromList p) }
, line = \xs -> do
(lns,element) <- gets (objLines *** elemental)
let l = zipWith mkl xs (tail xs)
-- Line requires at least two points. We'll ignore it otherwise.
when (not $ null l) $
modifyFirst $ \o -> o { objLines = lns `DList.append` fmap element (DList.fromList l) }
, face = \xs -> do
(fcs,element) <- gets (objFaces *** elemental)
case map mkF xs of
a:b:c:ds -> modifyFirst $ \o -> o { objFaces = fcs `DList.snoc` element (Face a b c ds) }
_ -> return () -- Ignore faces with less than 3 indices.
, mtllib = \xs -> do
let l = map decodeUtf8 xs
libs <- gets (objMtlLibs . fst)
modifyFirst $ \o -> o { objMtlLibs = DList.fromList l `DList.append` libs }
, groups = \xs -> do
let g = map decodeUtf8 xs
modify' $ second $ \e -> e { elGroups = g }
, objectName = \x -> do
let o = decodeUtf8 x
modify' $ second $ \e -> e { elObject = Just o }
, usemtl = \x -> do
let mtl = decodeUtf8 x
libs <- DList.toList <$> gets (objMtlLibs . fst)
modify' $ second $ \e -> e { elMtl = Just (length libs,mtl) }
, smoothingGroup = \x -> when (x > 0) $ do
modify $ second $ \e -> e { elSmoothingGroup = fromIntegral x }
}
blankElement :: Element ()
blankElement = Element
{ elObject = Nothing
, elGroups = []
, elMtl = Nothing
, elSmoothingGroup = 0
, elValue = ()
}
emptyCounts :: OBJ Count
emptyCounts = OBJ
{ objLocations = Count 0
, objTexCoords = Count 0
, objNormals = Count 0
, objPoints = Count 0
, objLines = Count 0
, objFaces = Count 0
, objMtlLibs = Count 0
}
mzeroOBJ :: MonadPlus m => OBJ m
mzeroOBJ = OBJ
{ objLocations = mzero
, objTexCoords = mzero
, objNormals = mzero
, objPoints = mzero
, objLines = mzero
, objFaces = mzero
, objMtlLibs = mzero
}
parse :: L.ByteString -> OBJ Vector
parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj
where
go = parseCustom buildOBJ (const $ return ()) bs
(obj,_) = execState go (mzeroOBJ,blankElement)
parseCustom :: Monad m => ObjBuilder m -> (OBJ Count -> m b) -> L.ByteString -> m b
parseCustom builder finish bs = do
counts <- execStateT (parseOBJ (objBookKeeping builder) (ObjConfig IntMap.empty) bs) emptyCounts
finish counts
data Renumbering = Renumbering
{ renumV :: Int -> Int
, renumVT :: Int -> Int
, renumVN :: Int -> Int
, renumVP :: Int -> Int
}
renumFrom1 :: Renumbering
renumFrom1 = Renumbering
{ renumV = succ
, renumVT = succ
, renumVN = succ
, renumVP = succ
}
addCounts :: OBJ Count -> Renumbering -> Renumbering
addCounts c r = Renumbering
{ renumV = addc (objLocations c) . renumV r
, renumVT = addc (objTexCoords c) . renumVT r
, renumVN = addc (objNormals c) . renumVN r
, renumVP = renumVP r -- TODO
}
addc :: Count x -> Int -> Int
addc (Count c) x = c + x
renumTriple :: Renumbering -> RefTriple -> RefTriple
renumTriple r (RefTriple v t n) = RefTriple (renumV r v) (renumVT r <$> t) (renumVN r <$> n)
applyRenumbering :: MonadState Renumbering m => ObjBuilder m -> ObjBuilder m
applyRenumbering builder = builder
{ face = \ts -> do
r <- get
face builder $ map (renumTriple r) ts
, line = \ts -> do
r <- get
line builder $ map (renumTriple r) ts
, surf = \u0 u1 v0 v1 ts -> do
r <- get
surf builder u0 u1 v0 v1 $ map (renumTriple r) ts
}
|
