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
|
{-# 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 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
, line = \ts -> do
o <- get
lift $ line builder $ fixupTriple o <$> ts
, face = \ts -> do
o <- get
lift $ face builder $ fixupTriple o <$> ts
}
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 = libs `DList.append` DList.fromList l }
, 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
modify' $ second $ \e -> e { elMtl = Just mtl }
, smoothingGroup = \x -> when (x > 0) $ do
modify $ second $ \e -> e { elSmoothingGroup = fromIntegral x }
}
parse :: L.ByteString -> OBJ Vector
parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj
where
b = objBookKeeping buildOBJ
ls = OBJ
{ objLocations = DList.empty
, objTexCoords = DList.empty
, objNormals = DList.empty
, objPoints = DList.empty
, objLines = DList.empty
, objFaces = DList.empty
, objMtlLibs = DList.empty
}
c = Rank2.fmap (const $ Count 0) ls :: OBJ Count
el = Element
{ elObject = Nothing
, elGroups = []
, elMtl = Nothing
, elSmoothingGroup = 0
, elValue = ()
}
substvars = ObjConfig IntMap.empty
(obj,_) = execState (runStateT (parseOBJ b substvars bs) c) (ls,el)
|
