Scale loaded mesh to fit viewport.

2 files changed, 78 insertions, 7 deletions

diff --git a/LoadMesh.hs b/LoadMesh.hs
index affadba..9eaa047 100644
--- a/LoadMesh.hs
+++ b/LoadMesh.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 module LoadMesh where
 
 import LambdaCube.GL as LambdaCubeGL -- renderer
@@ -15,13 +16,16 @@ 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 ((<>))
 
 import Codec.Picture as Juicy
 import Wavefront
 import Wavefront.Types
 import Data.Aeson
 
-type MeshData = ([(Mesh,Maybe Text)],MtlLib)
+type MeshData = ( [(Mesh,Maybe Text)]  -- List of uniform-material meshes (and the name of the material).
+                , MtlLib               -- Material definitions.
+                )
 
 loadOBJ :: String -> IO (Either String MeshData)
 loadOBJ fname = L.readFile fname >>= \bs -> do
@@ -31,10 +35,76 @@ loadOBJ fname = L.readFile fname >>= \bs -> do
     return $ Right (objToMesh obj,mtlLib)
 
 
-uploadOBJToGPU :: MeshData -> IO ([(GPUMesh, Maybe Text)], MtlLib)
-uploadOBJToGPU (subModels,mtlLib) = do
-    gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat)
-    return (gpuSubModels,mtlLib)
+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 (([(GPUMesh, Maybe Text)], MtlLib),Matrix Float)
+uploadOBJToGPU scalebb (subModels,mtlLib) = do
+    let meshbb = foldMap (attribBoundingBox . mAttributes . fst) subModels :: BoundingBox
+        m = maybe (ident 4) (scaleWithin meshbb) scalebb
+    gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU (transformMesh m mesh) >>= \a -> return (a,mat)
+    return ((gpuSubModels,mtlLib),m)
 
 uploadMtlLib :: MtlLib -> IO (Map Text (ObjMaterial,TextureData))
 uploadMtlLib mtlLib = do
@@ -45,7 +115,7 @@ uploadMtlLib mtlLib = do
   checkerTex <- LambdaCubeGL.uploadTexture2DToGPU checkerImage
   -- load images and upload to gpu
   textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case
-    Left err  -> putStrLn err >> return checkerTex
+    Left err  -> putStrLn (fname ++": "++err) >> return checkerTex
     Right img -> LambdaCubeGL.uploadTexture2DToGPU img
   whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage
   -- pair textures and materials
diff --git a/MeshSketch.hs b/MeshSketch.hs
index f1ee612..a153f5e 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -163,7 +163,8 @@ xzPlaneVector = fromList [ 0,1,0 -- unit normal
 uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
 uploadState obj glarea storage = do
     -- load OBJ geometry and material descriptions
-    (objMesh,mtlLib) <- uploadOBJToGPU obj
+    let workarea = BoundingBox (-1.5) (1.5) (-1.5) 1.5 (-1.5) (1.5)
+    ((objMesh,mtlLib),objscale) <- uploadOBJToGPU (Just workarea) obj
     -- load materials textures
     gpuMtlLib <- uploadMtlLib mtlLib
     -- add OBJ to pipeline input