Materials and textures are relative to object file.

3 files changed, 30 insertions, 16 deletions

diff --git a/LoadMesh.hs b/LoadMesh.hs
index 9eaa047..ee93344 100644
--- a/LoadMesh.hs
+++ b/LoadMesh.hs
@@ -3,11 +3,12 @@
 {-# LANGUAGE FlexibleContexts #-}
 module LoadMesh where
 
-import LambdaCube.GL as LambdaCubeGL -- renderer
+import LambdaCube.GL as LC -- renderer
 import LambdaCube.GL.Mesh as LambdaCubeGL
 import MtlParser
 
 import Control.Monad
+import Data.Int
 import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -16,7 +17,8 @@ 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 Numeric.LinearAlgebra hiding ((<>),Element)
+import System.FilePath
 
 import Codec.Picture as Juicy
 import Wavefront
@@ -24,15 +26,20 @@ import Wavefront.Types
 import Data.Aeson
 
 type MeshData = ( [(Mesh,Maybe Text)]  -- List of uniform-material meshes (and the name of the material).
-                , MtlLib               -- Material definitions.
+                , ( 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 (readMtl . unpack) objMtlLibs
-    return $ Right (objToMesh obj,mtlLib)
+    mtlLib <- mconcat . V.toList <$> mapM (readMtlWithFallback . relativeFrom fname . unpack) objMtlLibs
+    return $ Right (objToMesh obj,(mtlLib,fname))
 
 
 data BoundingBox = BoundingBox
@@ -99,25 +106,25 @@ 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
+uploadOBJToGPU :: Maybe BoundingBox -> MeshData -> IO ([(GPUMesh, Maybe Text)],Matrix Float)
+uploadOBJToGPU scalebb (subModels,(mtlLib,objpath)) = 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)
+    return (gpuSubModels,m)
 
-uploadMtlLib :: MtlLib -> IO (Map Text (ObjMaterial,TextureData))
-uploadMtlLib mtlLib = do
+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 <- LambdaCubeGL.uploadTexture2DToGPU checkerImage
+  checkerTex <- LC.uploadTexture2DToGPU checkerImage
   -- load images and upload to gpu
-  textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case
+  textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage (relativeFrom objpath fname) >>= \case
     Left err  -> putStrLn (fname ++": "++err) >> return checkerTex
-    Right img -> LambdaCubeGL.uploadTexture2DToGPU img
-  whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage
+    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
 
@@ -144,4 +151,3 @@ objToMesh OBJ{..} = [(toMesh faceGroup, elMtl . head $ faceGroup) | faceGroup <-
                                  , 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
-
diff --git a/MeshSketch.hs b/MeshSketch.hs
index f31c7cf..167a5fd 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -179,7 +179,8 @@ uploadState obj mm storage = do
     let glarea = mmWidget mm
     -- load OBJ geometry and material descriptions
     let workarea = BoundingBox (-1.5) (1.5) (-1.5) 1.5 (-1.5) (1.5)
-    ((objMesh,mtlLib),objscale) <- uploadOBJToGPU (Just workarea) obj
+        mtlLib = snd obj
+    (objMesh,objscale) <- uploadOBJToGPU (Just workarea) obj
     -- load materials textures
     gpuMtlLib <- uploadMtlLib mtlLib
     -- add OBJ to pipeline input
diff --git a/MtlParser.hs b/MtlParser.hs
index b57a7f0..ed952d0 100644
--- a/MtlParser.hs
+++ b/MtlParser.hs
@@ -3,6 +3,7 @@ module MtlParser
   , MtlLib
   , parseMtl
   , readMtl
+  , readMtlWithFallback
   ) where
 
 import Data.Map (Map)
@@ -11,6 +12,7 @@ import Data.Maybe
 import Control.Monad.State.Strict
 import Control.Monad.Writer
 import Data.Text (pack,Text)
+import System.IO.Error
 
 type Vec3 = (Float,Float,Float)
 
@@ -72,3 +74,8 @@ parseMtl src = Map.fromList [(mtl_Name m,m) | m <- evalState (execWriterT (mapM_
 
 readMtl :: String -> IO MtlLib
 readMtl fname = parseMtl <$> readFile fname
+
+readMtlWithFallback :: String -> IO MtlLib
+readMtlWithFallback fname = do
+    catchIOError (readMtl fname)
+                 (\_ -> return $ let n = pack fname in Map.singleton mempty (newMaterial n))