summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-04-17 18:39:12 -0400
committerJoe Crayne <joe@jerkface.net>2019-04-17 18:41:18 -0400
commit395f3b525090097c88434b03c88fe2fb8b8d7aba (patch)
tree0f60388ddd09bc69e7257be32959e95574a73a73
parent64f1a100fc887fb2a8bc87e2ac6975e872010ef5 (diff)
Refactored object-loading demo.
-rw-r--r--LoadMesh.hs75
-rw-r--r--mainObj.hs102
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 #-}
3module LoadMesh where
4
5import LambdaCube.GL as LambdaCubeGL -- renderer
6import LambdaCube.GL.Mesh as LambdaCubeGL
7import MtlParser
8
9import Control.Monad
10import Data.Maybe
11import Data.Map (Map)
12import qualified Data.Map as Map
13import qualified Data.Vector as V
14import qualified Data.ByteString as SB
15import Data.Text (unpack,Text)
16import Data.List (groupBy,nub)
17
18import Codec.Picture as Juicy
19import Codec.Wavefront
20import Data.Aeson
21
22type MeshData = ([(Mesh,Maybe Text)],MtlLib)
23
24loadOBJ :: String -> IO (Either String MeshData)
25loadOBJ 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
32uploadOBJToGPU :: MeshData -> IO ([(GPUMesh, Maybe Text)], MtlLib)
33uploadOBJToGPU (subModels,mtlLib) = do
34 gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat)
35 return (gpuSubModels,mtlLib)
36
37uploadMtlLib :: MtlLib -> IO (Map Text (ObjMaterial,TextureData))
38uploadMtlLib 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
52objToMesh :: WavefrontOBJ -> [(Mesh,Maybe Text)]
53objToMesh 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 #-}
5module Main where
6
7import Codec.Picture as Juicy
8import Control.Concurrent
9import Control.Monad
10import Data.Word
11import Data.Function
12import Data.Text (Text)
13import Data.Map.Strict (Map)
14import qualified Data.Map.Strict as Map
15import qualified Data.Vector as V
16import GI.Gdk.Objects
17import GI.GLib.Constants
18import GI.Gtk as Gtk hiding (main)
19import LambdaCube.GL as LC
20import LambdaCube.GL.Mesh as LC
21import System.Environment
22import System.IO
23import System.IO.Error
24
25import GLWidget
26import LambdaCubeWidget
27import TimeKeeper
28import LoadMesh
29import InfinitePlane
30import MtlParser (ObjMaterial(..))
31
32type State = (TimeKeeper, TickCallbackHandle)
33
34addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
35addOBJToObjectArray 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
46uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
47uploadState 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
62destroyState :: GLArea -> State -> IO ()
63destroyState glarea (tm,tickcb) = do
64 widgetRemoveTickCallback glarea tickcb
65
66setUniforms :: glctx -> GLStorage -> State -> IO ()
67setUniforms gl storage (tm,_) = do
68 t <- withMVar (tmSeconds tm) return
69 LC.updateUniforms storage $ do
70 "time" @= return (realToFrac t :: Float)
71
72main :: IO ()
73main = 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 }