diff options
author | Joe Crayne <joe@jerkface.net> | 2019-04-11 20:07:27 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-04-11 20:07:27 -0400 |
commit | 5b8cf0fcb93c5d6e288e4426189a1564e318927a (patch) | |
tree | 2655c83d67075942557a544fca414f144ddefda2 /HelloOBJ2.hs | |
parent | 318f170b71923849c6f93af83da85eb974f96332 (diff) |
Modified version of HelloOBJ that renders transparent grid plane.
Diffstat (limited to 'HelloOBJ2.hs')
-rw-r--r-- | HelloOBJ2.hs | 163 |
1 files changed, 163 insertions, 0 deletions
diff --git a/HelloOBJ2.hs b/HelloOBJ2.hs new file mode 100644 index 0000000..24d0843 --- /dev/null +++ b/HelloOBJ2.hs | |||
@@ -0,0 +1,163 @@ | |||
1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-} | ||
2 | import System.Environment | ||
3 | import "GLFW-b" Graphics.UI.GLFW as GLFW | ||
4 | import Data.Text (unpack,Text) | ||
5 | import Data.List (groupBy,nub) | ||
6 | import Data.Maybe | ||
7 | import Control.Monad | ||
8 | import Data.Map (Map) | ||
9 | import qualified Data.Map as Map | ||
10 | import qualified Data.Vector as V | ||
11 | import qualified Data.ByteString as SB | ||
12 | |||
13 | import LambdaCube.GL as LambdaCubeGL -- renderer | ||
14 | import LambdaCube.GL.Mesh as LambdaCubeGL | ||
15 | |||
16 | import Codec.Picture as Juicy | ||
17 | import Data.Aeson | ||
18 | import Codec.Wavefront | ||
19 | |||
20 | import MtlParser | ||
21 | import InfinitePlane | ||
22 | |||
23 | ---------------------------------------------------- | ||
24 | -- See: http://lambdacube3d.com/getting-started | ||
25 | ---------------------------------------------------- | ||
26 | |||
27 | objToMesh :: WavefrontOBJ -> [(Mesh,Maybe Text)] | ||
28 | objToMesh WavefrontOBJ{..} = [(toMesh faceGroup, elMtl . head $ faceGroup) | faceGroup <- faces] where | ||
29 | faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces) | ||
30 | toMesh l = Mesh | ||
31 | { mAttributes = Map.fromList | ||
32 | [ ("position", A_V4F position) | ||
33 | , ("normal", A_V3F normal) | ||
34 | , ("uvw", A_V3F texcoord) | ||
35 | ] | ||
36 | , mPrimitive = P_Triangles | ||
37 | } where | ||
38 | triangulate (Triangle a b c) = [a,b,c] | ||
39 | triangulate (Quad a b c d) = [a,b,c, c,d,a] | ||
40 | 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 | ||
41 | defaultPosition = Location 0 0 0 0 | ||
42 | defaultNormal = Normal 0 0 0 | ||
43 | defaultTexCoord = TexCoord 0 0 0 | ||
44 | v !- i = v V.!? (i-1) | ||
45 | toVertex FaceIndex{..} = ( let Location x y z w = fromMaybe defaultPosition (objLocations !- faceLocIndex) in V4 x y z w | ||
46 | , let Normal x y z = fromMaybe defaultNormal ((objNormals !-) =<< faceNorIndex) in V3 x y z | ||
47 | , let TexCoord x y z = fromMaybe defaultTexCoord ((objTexCoords !-) =<< faceTexCoordIndex) in V3 x y z | ||
48 | ) | ||
49 | (position,normal,texcoord) = V.unzip3 . V.concat . map (V.fromList . map toVertex . triangulate . elValue) $ l | ||
50 | |||
51 | |||
52 | loadOBJ :: String -> IO (Either String ([(Mesh,Maybe Text)],MtlLib)) | ||
53 | loadOBJ fname = fromFile fname >>= \case -- load geometry | ||
54 | Left err -> putStrLn err >> return (Left err) | ||
55 | Right obj@WavefrontOBJ{..} -> do | ||
56 | -- load materials | ||
57 | mtlLib <- mconcat . V.toList <$> mapM (readMtl . unpack) objMtlLibs | ||
58 | return $ Right (objToMesh obj,mtlLib) | ||
59 | |||
60 | loadOBJToGPU :: String -> IO (Either String ([(GPUMesh, Maybe Text)], MtlLib)) | ||
61 | loadOBJToGPU fname = loadOBJ fname >>= \case | ||
62 | Left err -> return $ Left err | ||
63 | Right (subModels,mtlLib) -> do | ||
64 | gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat) | ||
65 | return $ Right (gpuSubModels,mtlLib) | ||
66 | |||
67 | uploadMtlLib :: MtlLib -> IO (Map Text (ObjMaterial,TextureData)) | ||
68 | uploadMtlLib mtlLib = do | ||
69 | -- collect used textures | ||
70 | let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ Map.elems mtlLib | ||
71 | whiteImage = Juicy.ImageRGB8 $ Juicy.generateImage (\_ _ -> Juicy.PixelRGB8 255 255 255) 1 1 | ||
72 | 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 | ||
73 | checkerTex <- LambdaCubeGL.uploadTexture2DToGPU checkerImage | ||
74 | -- load images and upload to gpu | ||
75 | textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case | ||
76 | Left err -> putStrLn err >> return checkerTex | ||
77 | Right img -> LambdaCubeGL.uploadTexture2DToGPU img | ||
78 | whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage | ||
79 | -- pair textures and materials | ||
80 | return $ (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib | ||
81 | |||
82 | addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LambdaCubeGL.Object] | ||
83 | addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do | ||
84 | obj <- LambdaCubeGL.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh -- diffuseTexture and diffuseColor values can change on each model | ||
85 | case mat >>= flip Map.lookup mtlLib of | ||
86 | Nothing -> return () | ||
87 | Just (ObjMaterial{..},t) -> LambdaCubeGL.updateObjectUniforms obj $ do | ||
88 | "diffuseTexture" @= return t -- set model's diffuse texture | ||
89 | "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr) | ||
90 | return obj | ||
91 | |||
92 | main :: IO () | ||
93 | main = do | ||
94 | Just pipelineDesc <- decodeStrict <$> SB.readFile "hello_obj2.json" | ||
95 | |||
96 | win <- initWindow "LambdaCube 3D DSL OBJ viewer" 640 640 | ||
97 | |||
98 | -- setup render data | ||
99 | let inputSchema = makeSchema $ do | ||
100 | defObjectArray "objects" Triangles $ do | ||
101 | "position" @: Attribute_V4F | ||
102 | "normal" @: Attribute_V3F | ||
103 | "uvw" @: Attribute_V3F | ||
104 | defObjectArray "plane" Triangles $ do | ||
105 | "position" @: Attribute_V4F | ||
106 | defUniforms $ do | ||
107 | "time" @: Float | ||
108 | "diffuseTexture" @: FTexture2D | ||
109 | "diffuseColor" @: V4F | ||
110 | |||
111 | storage <- LambdaCubeGL.allocStorage inputSchema | ||
112 | |||
113 | objName <- head . (++ ["cube.obj"]) <$> getArgs | ||
114 | -- load OBJ geometry and material descriptions | ||
115 | loadOBJToGPU objName >>= \x -> case x of | ||
116 | { Left e -> \_ -> putStrLn e | ||
117 | ; Right (objMesh,mtlLib) -> \f -> f objMesh mtlLib } $ \objMesh mtlLib -> do | ||
118 | -- load materials textures | ||
119 | gpuMtlLib <- uploadMtlLib mtlLib | ||
120 | -- add OBJ to pipeline input | ||
121 | addOBJToObjectArray storage "objects" objMesh gpuMtlLib | ||
122 | |||
123 | uploadMeshToGPU xyplane >>= addMeshToObjectArray storage "plane" [] | ||
124 | |||
125 | -- allocate GL pipeline | ||
126 | renderer <- LambdaCubeGL.allocRenderer pipelineDesc | ||
127 | LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility | ||
128 | Just err -> putStrLn err | ||
129 | Nothing -> loop | ||
130 | where loop = do | ||
131 | -- update graphics input | ||
132 | GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h) | ||
133 | LambdaCubeGL.updateUniforms storage $ do | ||
134 | "time" @= do | ||
135 | Just t <- GLFW.getTime | ||
136 | return (realToFrac t :: Float) | ||
137 | -- render | ||
138 | LambdaCubeGL.renderFrame renderer | ||
139 | GLFW.swapBuffers win | ||
140 | GLFW.pollEvents | ||
141 | |||
142 | let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k | ||
143 | escape <- keyIsPressed Key'Escape | ||
144 | if escape then return () else loop | ||
145 | |||
146 | LambdaCubeGL.disposeRenderer renderer | ||
147 | LambdaCubeGL.disposeStorage storage | ||
148 | GLFW.destroyWindow win | ||
149 | GLFW.terminate | ||
150 | |||
151 | initWindow :: String -> Int -> Int -> IO Window | ||
152 | initWindow title width height = do | ||
153 | GLFW.init | ||
154 | GLFW.defaultWindowHints | ||
155 | mapM_ GLFW.windowHint | ||
156 | [ WindowHint'ContextVersionMajor 3 | ||
157 | , WindowHint'ContextVersionMinor 3 | ||
158 | , WindowHint'OpenGLProfile OpenGLProfile'Core | ||
159 | , WindowHint'OpenGLForwardCompat True | ||
160 | ] | ||
161 | Just win <- GLFW.createWindow width height title Nothing Nothing | ||
162 | GLFW.makeContextCurrent $ Just win | ||
163 | return win | ||