diff options
author | Joe Crayne <joe@jerkface.net> | 2019-04-17 18:39:12 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-04-17 18:41:18 -0400 |
commit | 395f3b525090097c88434b03c88fe2fb8b8d7aba (patch) | |
tree | 0f60388ddd09bc69e7257be32959e95574a73a73 | |
parent | 64f1a100fc887fb2a8bc87e2ac6975e872010ef5 (diff) |
Refactored object-loading demo.
-rw-r--r-- | LoadMesh.hs | 75 | ||||
-rw-r--r-- | mainObj.hs | 102 |
2 files changed, 177 insertions, 0 deletions
diff --git a/LoadMesh.hs b/LoadMesh.hs new file mode 100644 index 0000000..69e66d6 --- /dev/null +++ b/LoadMesh.hs | |||
@@ -0,0 +1,75 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
2 | {-# LANGUAGE RecordWildCards #-} | ||
3 | module LoadMesh where | ||
4 | |||
5 | import LambdaCube.GL as LambdaCubeGL -- renderer | ||
6 | import LambdaCube.GL.Mesh as LambdaCubeGL | ||
7 | import MtlParser | ||
8 | |||
9 | import Control.Monad | ||
10 | import Data.Maybe | ||
11 | import Data.Map (Map) | ||
12 | import qualified Data.Map as Map | ||
13 | import qualified Data.Vector as V | ||
14 | import qualified Data.ByteString as SB | ||
15 | import Data.Text (unpack,Text) | ||
16 | import Data.List (groupBy,nub) | ||
17 | |||
18 | import Codec.Picture as Juicy | ||
19 | import Codec.Wavefront | ||
20 | import Data.Aeson | ||
21 | |||
22 | type MeshData = ([(Mesh,Maybe Text)],MtlLib) | ||
23 | |||
24 | loadOBJ :: String -> IO (Either String MeshData) | ||
25 | loadOBJ fname = fromFile fname >>= \case -- load geometry | ||
26 | Left err -> putStrLn err >> return (Left err) | ||
27 | Right obj@WavefrontOBJ{..} -> do | ||
28 | -- load materials | ||
29 | mtlLib <- mconcat . V.toList <$> mapM (readMtl . unpack) objMtlLibs | ||
30 | return $ Right (objToMesh obj,mtlLib) | ||
31 | |||
32 | uploadOBJToGPU :: MeshData -> IO ([(GPUMesh, Maybe Text)], MtlLib) | ||
33 | uploadOBJToGPU (subModels,mtlLib) = do | ||
34 | gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat) | ||
35 | return (gpuSubModels,mtlLib) | ||
36 | |||
37 | uploadMtlLib :: MtlLib -> IO (Map Text (ObjMaterial,TextureData)) | ||
38 | uploadMtlLib mtlLib = do | ||
39 | -- collect used textures | ||
40 | let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ Map.elems mtlLib | ||
41 | whiteImage = Juicy.ImageRGB8 $ Juicy.generateImage (\_ _ -> Juicy.PixelRGB8 255 255 255) 1 1 | ||
42 | 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 | ||
43 | checkerTex <- LambdaCubeGL.uploadTexture2DToGPU checkerImage | ||
44 | -- load images and upload to gpu | ||
45 | textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case | ||
46 | Left err -> putStrLn err >> return checkerTex | ||
47 | Right img -> LambdaCubeGL.uploadTexture2DToGPU img | ||
48 | whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage | ||
49 | -- pair textures and materials | ||
50 | return $ (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib | ||
51 | |||
52 | objToMesh :: WavefrontOBJ -> [(Mesh,Maybe Text)] | ||
53 | objToMesh WavefrontOBJ{..} = [(toMesh faceGroup, elMtl . head $ faceGroup) | faceGroup <- faces] where | ||
54 | faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces) | ||
55 | toMesh l = Mesh | ||
56 | { mAttributes = Map.fromList | ||
57 | [ ("position", A_V4F position) | ||
58 | , ("normal", A_V3F normal) | ||
59 | , ("uvw", A_V3F texcoord) | ||
60 | ] | ||
61 | , mPrimitive = P_Triangles | ||
62 | } where | ||
63 | triangulate (Triangle a b c) = [a,b,c] | ||
64 | triangulate (Quad a b c d) = [a,b,c, c,d,a] | ||
65 | 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 | ||
66 | defaultPosition = Location 0 0 0 0 | ||
67 | defaultNormal = Normal 0 0 0 | ||
68 | defaultTexCoord = TexCoord 0 0 0 | ||
69 | v !- i = v V.!? (i-1) | ||
70 | toVertex FaceIndex{..} = ( let Location x y z w = fromMaybe defaultPosition (objLocations !- faceLocIndex) in V4 x y z w | ||
71 | , let Normal x y z = fromMaybe defaultNormal ((objNormals !-) =<< faceNorIndex) in V3 x y z | ||
72 | , let TexCoord x y z = fromMaybe defaultTexCoord ((objTexCoords !-) =<< faceTexCoordIndex) in V3 x y z | ||
73 | ) | ||
74 | (position,normal,texcoord) = V.unzip3 . V.concat . map (V.fromList . map toVertex . triangulate . elValue) $ l | ||
75 | |||
diff --git a/mainObj.hs b/mainObj.hs new file mode 100644 index 0000000..1513075 --- /dev/null +++ b/mainObj.hs | |||
@@ -0,0 +1,102 @@ | |||
1 | {-# LANGUAGE OverloadedLabels #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | {-# LANGUAGE LambdaCase #-} | ||
4 | {-# LANGUAGE RecordWildCards #-} | ||
5 | module Main where | ||
6 | |||
7 | import Codec.Picture as Juicy | ||
8 | import Control.Concurrent | ||
9 | import Control.Monad | ||
10 | import Data.Word | ||
11 | import Data.Function | ||
12 | import Data.Text (Text) | ||
13 | import Data.Map.Strict (Map) | ||
14 | import qualified Data.Map.Strict as Map | ||
15 | import qualified Data.Vector as V | ||
16 | import GI.Gdk.Objects | ||
17 | import GI.GLib.Constants | ||
18 | import GI.Gtk as Gtk hiding (main) | ||
19 | import LambdaCube.GL as LC | ||
20 | import LambdaCube.GL.Mesh as LC | ||
21 | import System.Environment | ||
22 | import System.IO | ||
23 | import System.IO.Error | ||
24 | |||
25 | import GLWidget | ||
26 | import LambdaCubeWidget | ||
27 | import TimeKeeper | ||
28 | import LoadMesh | ||
29 | import InfinitePlane | ||
30 | import MtlParser (ObjMaterial(..)) | ||
31 | |||
32 | type State = (TimeKeeper, TickCallbackHandle) | ||
33 | |||
34 | addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object] | ||
35 | addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do | ||
36 | obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh | ||
37 | -- diffuseTexture and diffuseColor values can change on each model | ||
38 | case mat >>= flip Map.lookup mtlLib of | ||
39 | Nothing -> return () | ||
40 | Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do | ||
41 | "diffuseTexture" @= return t -- set model's diffuse texture | ||
42 | "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr) | ||
43 | return obj | ||
44 | |||
45 | |||
46 | uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State | ||
47 | uploadState obj glarea storage = do | ||
48 | -- load OBJ geometry and material descriptions | ||
49 | (objMesh,mtlLib) <- uploadOBJToGPU obj | ||
50 | -- load materials textures | ||
51 | gpuMtlLib <- uploadMtlLib mtlLib | ||
52 | -- add OBJ to pipeline input | ||
53 | addOBJToObjectArray storage "objects" objMesh gpuMtlLib | ||
54 | -- grid plane | ||
55 | uploadMeshToGPU xyplane >>= addMeshToObjectArray storage "plane" [] | ||
56 | |||
57 | -- setup FrameClock | ||
58 | tm <- newTimeKeeper | ||
59 | tickcb <- widgetAddTickCallback glarea (tick tm) | ||
60 | return (tm,tickcb) | ||
61 | |||
62 | destroyState :: GLArea -> State -> IO () | ||
63 | destroyState glarea (tm,tickcb) = do | ||
64 | widgetRemoveTickCallback glarea tickcb | ||
65 | |||
66 | setUniforms :: glctx -> GLStorage -> State -> IO () | ||
67 | setUniforms gl storage (tm,_) = do | ||
68 | t <- withMVar (tmSeconds tm) return | ||
69 | LC.updateUniforms storage $ do | ||
70 | "time" @= return (realToFrac t :: Float) | ||
71 | |||
72 | main :: IO () | ||
73 | main = do | ||
74 | m <- do | ||
75 | objName <- head . (++ ["cube.obj"]) <$> getArgs | ||
76 | mobj <- loadOBJ objName | ||
77 | mpipeline <- loadPipeline "hello_obj2.json" $ do | ||
78 | defObjectArray "objects" Triangles $ do | ||
79 | "position" @: Attribute_V4F | ||
80 | "normal" @: Attribute_V3F | ||
81 | "uvw" @: Attribute_V3F | ||
82 | defObjectArray "plane" Triangles $ do | ||
83 | "position" @: Attribute_V4F | ||
84 | defUniforms $ do | ||
85 | "time" @: Float | ||
86 | "diffuseTexture" @: FTexture2D | ||
87 | "diffuseColor" @: V4F | ||
88 | return $ (,) <$> mobj <*> mpipeline | ||
89 | either (\e _ -> hPutStrLn stderr e) (&) m $ \(obj,pipeline) -> do | ||
90 | app <- do | ||
91 | mvar <- newEmptyMVar | ||
92 | return $ \glarea -> LCMethods | ||
93 | { lcRealized = mvar | ||
94 | , lcUploadState = uploadState obj glarea | ||
95 | , lcDestroyState = destroyState glarea | ||
96 | , lcSetUniforms = setUniforms | ||
97 | , lcPipeline = pipeline | ||
98 | } | ||
99 | |||
100 | runGLApp return (lambdaRender app glmethods) | ||
101 | { glTitle = "LambdaCube 3D DSL OBJ viewer" | ||
102 | } | ||