Maskable groups.

1 files changed, 42 insertions, 21 deletions

diff --git a/LoadMesh.hs b/LoadMesh.hs
index bfc5070..b970f3e 100644
--- a/LoadMesh.hs
+++ b/LoadMesh.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE LambdaCase      #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
 module LoadMesh where
 
 import LambdaCube.GL as LC -- renderer
@@ -8,8 +10,10 @@ 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
@@ -139,32 +143,48 @@ uploadMtlLib (mtlLib,objpath) = do
   return $ (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib
 
 objToMesh :: WavefrontOBJ -> [MaterialMesh Mesh]
-objToMesh OBJ{..} = [ MaterialMesh (toMesh faceGroup)
-                                   (elMtl . head $ faceGroup)
-                                   Map.empty {- TODO -}
-                       | faceGroup <- faces ]
+objToMesh OBJ{..} = [ toMesh faceGroup | faceGroup <- faces ]
  where
   faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces)
-  toMesh l = Mesh
-    { mAttributes   = Map.fromList
-        [ ("position",  A_V4F position)
-        , ("normal",    A_V3F normal)
-        , ("uvw",       A_V3F texcoord)
-        ]
-    , mPrimitive    = P_Triangles
-    } where
-        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
+  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 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
                                  )
-        (position,normal,texcoord) = V.unzip3 . V.concat . map (V.fromList . map toVertex . triangulate . elValue) $ l
+        (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
@@ -188,4 +208,5 @@ addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \matmesh ->
     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)
-  return $ MaskableObject obj $ maybe Map.empty (`Map.singleton` objSpan obj) (materialName matmesh)
+  let matmask = maybe Map.empty (`Map.singleton` objSpan obj) (fmap ("m:" <>) $ materialName matmesh)
+  return $ MaskableObject obj (matmask `Map.union` materialMasks matmesh)