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
206
207
208
209
210
211
212
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module LoadMesh where
import LambdaCube.GL as LC -- renderer
import LambdaCube.GL.Mesh as LambdaCubeGL
import LambdaCube.GL.Type as LC
import MtlParser
import Control.Arrow
import Control.Monad
import Data.Int
import Data.List as List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Vector as V
import qualified Data.ByteString as SB
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Text (unpack,Text)
import Data.List (groupBy,nub)
import Numeric.LinearAlgebra hiding ((<>),Element)
import System.FilePath
import Codec.Picture as Juicy
import Wavefront
import Wavefront.Types
import Data.Aeson
import Mask
data MaterialMesh m = MaterialMesh
{ materialMesh :: m
, materialName :: Maybe Text
, materialMasks :: Map Text Mask
}
type MeshData = ( [MaterialMesh Mesh] -- List of uniform-material meshes (and the name of the material).
, ( MtlLib -- Material definitions.
, FilePath ) -- Path to wavefront obj file.
)
relativeFrom :: FilePath -> FilePath -> FilePath
relativeFrom path file | isAbsolute file = file
relativeFrom path file = takeDirectory path </> file
loadOBJ :: String -> IO (Either String MeshData)
loadOBJ fname = L.readFile fname >>= \bs -> do
let obj@OBJ{..} = parse bs
-- load materials
mtlLib <- mconcat . V.toList <$> mapM (readMtlWithFallback . relativeFrom fname . unpack) objMtlLibs
return $ Right (objToMesh obj,(mtlLib,fname))
data BoundingBox = BoundingBox
{ minX :: Float
, maxX :: Float
, minY :: Float
, maxY :: Float
, minZ :: Float
, maxZ :: Float
}
deriving (Eq,Ord,Show)
instance Semigroup BoundingBox where
a <> b = BoundingBox
{ minX = if minX b < minX a then minX b else minX a
, maxX = if maxX b > maxX a then maxX b else maxX a
, minY = if minY b < minY a then minY b else minY a
, maxY = if maxY b > maxY a then maxY b else maxY a
, minZ = if minZ b < minZ a then minZ b else minZ a
, maxZ = if maxZ b > maxZ a then maxZ b else maxZ a
}
instance Monoid BoundingBox where mempty = BoundingBox 0 0 0 0 0 0
attribBoundingBox :: Map String MeshAttribute -> BoundingBox
attribBoundingBox attrib = case Map.lookup "position" attrib of
Just (A_V3F vs) -> V.foldr (\(V3 x y z ) bb -> bb <> BoundingBox x x y y z z) mempty vs
Just (A_V4F vs) -> V.foldr (\(V4 x y z _) bb -> bb <> BoundingBox x x y y z z) mempty vs
_ -> mempty
bbnorm :: BoundingBox -> Float
bbnorm (BoundingBox x0 x y0 y z0 z) = sqrt $ (x-x0)^2 + (y-y0)^2 + (z-z0)^2
scaleWithin :: BoundingBox -> BoundingBox -> Matrix Float
scaleWithin meshbb scalebb =
if meshbb <> scalebb /= scalebb
|| (let {m=bbnorm meshbb; s=bbnorm scalebb} in m < 0.1*s)
then let tr0 = (4><4) [ 1,0,0, negate $ (minX meshbb + maxX meshbb)/2
, 0,1,0, negate $ (minY meshbb + maxY meshbb)/2
, 0,0,1, negate $ (minZ meshbb + maxZ meshbb)/2
, 0,0,0, 1 ]
sc = (4><4) [s,0,0,0
,0,s,0,0
,0,0,s,0
,0,0,0,1]
s = minimum [sx,sy,sz]
sx = (maxX scalebb - minX scalebb) / (maxX meshbb - minX meshbb)
sy = (maxY scalebb - minY scalebb) / (maxY meshbb - minY meshbb)
sz = (maxZ scalebb - minZ scalebb) / (maxZ meshbb - minZ meshbb)
tr1 = (4><4) [ 1,0,0, (minX scalebb + maxX scalebb)/2
, 0,1,0, (minY scalebb + maxY scalebb)/2
, 0,0,1, (minZ scalebb + maxZ scalebb)/2
, 0,0,0, 1 ]
in tr1 <> sc <> tr0
else ident 4
transV3 t (V3 x y z) = let v = t #> fromList [x,y,z,1] in V3 (v!0/v!3) (v!1/v!3) (v!2/v!3)
transV4 t (V4 x y z w) = let v = t #> fromList [x,y,z,w] in V4 (v!0) (v!1) (v!2) (v!3)
tranformAttribute t (A_V3F v) = A_V3F $ transV3 t <$> v
tranformAttribute t (A_V4F v) = A_V4F $ transV4 t <$> v
transformMesh :: Matrix Float -> Mesh -> Mesh
transformMesh t m = m
{ mAttributes = Map.adjust (tranformAttribute t) "position" (mAttributes m)
}
uploadOBJToGPU :: Maybe BoundingBox -> MeshData -> IO ([MaterialMesh GPUMesh],Matrix Float)
uploadOBJToGPU scalebb (subModels,(mtlLib,objpath)) = do
let meshbb = foldMap (attribBoundingBox . mAttributes . materialMesh) subModels :: BoundingBox
m = maybe (ident 4) (scaleWithin meshbb) scalebb
gpuSubModels <- forM subModels $ \matmesh -> do
a <- LambdaCubeGL.uploadMeshToGPU (transformMesh m (materialMesh matmesh))
return matmesh { materialMesh = a }
return (gpuSubModels,m)
uploadMtlLib :: (MtlLib,FilePath) -> IO (Map Text (ObjMaterial,TextureData))
uploadMtlLib (mtlLib,objpath) = do
-- collect used textures
let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ Map.elems mtlLib
whiteImage = Juicy.ImageRGB8 $ Juicy.generateImage (\_ _ -> Juicy.PixelRGB8 255 255 255) 1 1
checkerImage = Juicy.ImageRGB8 $ Juicy.generateImage (\x y -> if mod (x + y) 2 == 0 then Juicy.PixelRGB8 0 0 0 else Juicy.PixelRGB8 255 255 0) 2 2
checkerTex <- LC.uploadTexture2DToGPU checkerImage
-- load images and upload to gpu
textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage (relativeFrom objpath fname) >>= \case
Left err -> putStrLn (fname ++": "++err) >> return checkerTex
Right img -> LC.uploadTexture2DToGPU img
whiteTex <- LC.uploadTexture2DToGPU whiteImage
-- pair textures and materials
return $ (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib
objToMesh :: WavefrontOBJ -> [MaterialMesh Mesh]
objToMesh OBJ{..} = [ toMesh faceGroup | faceGroup <- faces ]
where
faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces)
toMesh l = MaterialMesh mesh mtl gs
where
mtl = elMtl $ head l
mesh = Mesh { mAttributes = Map.fromList
[ ("position", A_V4F position)
, ("normal", A_V3F normal)
, ("uvw", A_V3F texcoord)
]
, mPrimitive = P_Triangles
}
defaultPosition = Location 0 0 0 0
defaultNormal = Normal 0 1 0
defaultTexCoord = TexCoord 0 0 0
v !- i = v V.!? i
toVertex FaceIndex{..} = ( let Location x y z w = fromMaybe defaultPosition (objLocations !- faceLocIndex) in V4 x y z w
, let Normal x y z = fromMaybe defaultNormal ((objNormals !-) =<< faceNorIndex) in V3 x y z
, let TexCoord x y z = fromMaybe defaultTexCoord ((objTexCoords !-) =<< faceTexCoordIndex) in V3 x y z
)
(gs,fs) = elementIndices l
(positions,normals,texcoords) = unzip3 $ map toVertex fs
position = V.fromList positions
normal = V.fromList normals
texcoord = V.fromList texcoords
triangulate :: Face -> [FaceIndex]
triangulate (Triangle a b c) = [a,b,c]
triangulate (Quad a b c d) = [a,b,c, c,d,a]
triangulate (Face a b c l) = a : b : c : concatMap (\(x,y) -> [a,x,y]) (zip (c:l) l) -- should work for convex polygons without holes
elementIndices :: [Element Face] -> (Map Text Mask, [FaceIndex])
elementIndices els = (spans,concatMap snd ts)
where
ts = map ((elGroups &&& elValue) . fmap triangulate) els
rs = List.scanl' go ((0,0),[]) ts -- scanl :: (b -> a -> b) -> b -> [a] -> [b]
go ((start,len),_) (gs,vs) = ((start+len,length vs),gs)
spans = fmap (Mask . map (fromIntegral***fromIntegral))
$ foldr (Map.unionWith (++)) Map.empty $ map singletonSpan rs
singletonSpan (span,gnames) = Map.fromList $ map (, [span]) gnames
data MaskableObject = MaskableObject
{ maskableObject :: LC.Object
, groupMasks :: Map Text Mask
}
objSpan :: LC.Object -> Mask
objSpan obj = case Map.elems (objAttributes obj) of
Stream { streamLength = x }:_ -> Mask [(0,fromIntegral x)]
_ -> Mask [(0,1)]
addOBJToObjectArray :: GLStorage -> String -> [MaterialMesh GPUMesh] -> Map Text (ObjMaterial,TextureData)
-> IO [MaskableObject]
addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \matmesh -> do
obj <- LambdaCubeGL.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] (materialMesh matmesh)
-- diffuseTexture and diffuseColor values can change on each model
case (materialName matmesh) >>= flip Map.lookup mtlLib of
Nothing -> return ()
Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
"diffuseTexture" @= return t -- set model's diffuse texture
"diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
let matmask = maybe Map.empty (`Map.singleton` objSpan obj) (fmap ("m:" <>) $ materialName matmesh)
return $ MaskableObject obj (matmask `Map.union` materialMasks matmesh)
|
