Merge pull request #23 from alt-romes/wip/romes/teapot

Add Utah Teapot demo and object loading

Author: alt-romes

README.md

@@ -12,6 +12,7 @@ The working examples are the following. In sequence, they build up to a
 Cooler examples:
 
 * `planets-core` implements Sebastian Lague's procedural planets
+* `teapot-obj` renders the Utah teapot using Blinn-Phong lighting and a perspective camera
 
 Solid examples:
 

examples/planets-core/Planet.hs

@@ -82,12 +82,12 @@ newPlanetMesh rp Planet{..} = enterD "newPlanetMesh" $ Linear.do
 
       (planetPs, elevations)
                = V.unzip $ V.map (\(p :&: _) -> pointOnPlanet planetShape p) (V.convert us)
-      planetNs = computeNormals (SV.map fromIntegral is) (V.convert planetPs)
-      planetVs = SV.zipWith (:&:) (V.convert planetPs) planetNs
+      planetNs = computeNormals (SV.map fromIntegral is) planetPs
+      planetVs = V.zipWith (:&:) (planetPs) planetNs
 
       minmax = MinMax (P.minimum elevations) (P.maximum elevations)
 
-   in (, Ur minmax) <$> (createMeshWithIxsSV rp (DynamicBinding (Ur mempty) :## GHNil) planetVs is ↑)
+   in (, Ur minmax) <$> (createMeshWithIxsSV rp (DynamicBinding (Ur mempty) :## GHNil) (V.convert planetVs) is ↑)
 
 --------------------------------------------------------------------------------
 -- * Material

examples/teapot-obj/Main.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+module Main where
+
+import Ghengin.Core.Prelude as Linear
+import qualified Prelude
+
+import Geomancy
+import Geomancy.Transform
+import Ghengin.Core
+import Ghengin.Core.Shader.Data
+import Ghengin.Core.Mesh
+import Ghengin.Core.Material
+import Ghengin.Core.Render
+import Ghengin.Core.Render.Property
+import Ghengin.Core.Render.Pipeline
+import Ghengin.Core.Render.Queue
+
+import qualified FIR
+import qualified Math.Linear as FIR
+
+import qualified Data.Monoid.Linear as LMon
+import qualified Data.Linear.Alias as Alias
+
+-- ghengin
+import Ghengin.Camera
+import Ghengin.Geometry.Obj
+
+import Shaders
+
+main :: Prelude.IO ()
+main = do
+ withLinearIO $
+  runCore (640, 480) Linear.do
+
+    (rp1, rp2) <- (Alias.share =<< createSimpleRenderPass ↑)
+
+    pipeline <- (makeRenderPipelineWith defaultGraphicsPipelineSettings{cullMode=CullNone} rp1 shaderPipeline (StaticBinding (Ur camera) :## GHNil) ↑)
+    (emptyMat, pipeline) <- (material GHNil pipeline ↑)
+    (mesh, pipeline) <- (loadObjMesh "examples/teapot-obj/assets/teapot.obj" pipeline
+                          (DynamicBinding (Ur (scale 1.2)) :## GHNil) ↑)
+
+    let !(rq, Ur pkey) = insertPipeline pipeline LMon.mempty
+    (rq, Ur mkey)    <- pure (insertMaterial pkey emptyMat rq)
+    (rq, Ur mshkey)  <- pure (insertMesh mkey mesh rq)
+
+    rq <- gameLoop mshkey rp2 rq
+
+    (freeRenderQueue rq ↑)
+
+    return (Ur ())
+
+gameLoop :: MeshKey _ _ _ _ '[Transform] -- ^ rq key to cube mesh
+         -> Alias RenderPass
+          ⊸ RenderQueue ()
+          ⊸ Core (RenderQueue ())
+gameLoop mkey rp rq = Linear.do
+ should_close <- (shouldCloseWindow ↑)
+ if should_close then (Alias.forget rp ↑) >> return rq else Linear.do
+  (pollWindowEvents ↑)
+
+  (rp, rq) <- render rp rq
+  rq <- (editMeshes mkey rq (traverse' $ propertyAt @0 (\(Ur tr) -> pure $ Ur $
+    rotateY 0.01 <> tr)) ↑)
+
+  gameLoop mkey rp rq
+
+camera :: Camera "view_matrix" "proj_matrix"
+camera = cameraLookAt (vec3 0 (-5) (-5){- move camera up and back-}) (vec3 0 0 0) (1280, 720)
+
+-- non-compositional instance for "Transform", just for demo
+instance ShaderData Transform where
+  type FirType Transform = FIR.Struct '[ "m" 'FIR.:-> FIR.M 4 4 Float ]

examples/teapot-obj/Shaders.hs

@@ -0,0 +1,86 @@
+{-# OPTIONS_GHC -Wno-missing-local-signatures #-}
+
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE OverloadedLabels      #-}
+{-# LANGUAGE RebindableSyntax      #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE NamedWildCards        #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ViewPatterns          #-}
+
+module Shaders where
+
+-- fir
+import FIR
+import FIR.Syntax.Labels
+import Math.Linear
+
+-- ghengin
+import qualified Ghengin.Core.Shader as G
+import Ghengin.Camera.Shader.Lighting
+
+-- See FIR.Validation.Layout about locations/component layouts...
+type VertexInput
+  = '[ Slot 0 0 ':-> V 3 Float
+     , Slot 1 0 ':-> V 3 Float ]
+
+shaderPipeline :: G.ShaderPipeline _
+shaderPipeline
+  = G.ShaderPipeline (StructInput @VertexInput @(Triangle List))
+  G.:>-> vertex
+  G.:>-> fragment
+
+type VertexDefs =
+  '[ "in_position"  ':-> Input      '[ Location 0 ] (V 3 Float)
+   , "in_normal"    ':-> Input      '[ Location 1 ] (V 3 Float)
+   , "out_position" ':-> Output     '[ Location 0 ] (V 4 Float)
+   , "out_normal"   ':-> Output     '[ Location 1 ] (V 4 Float)
+
+    -- Descriptor Set 0 : Pipeline properties (bound once per pipeline)
+   , "camera"       ':-> Uniform    '[ DescriptorSet 0, Binding 0 ]
+                          (Struct [ "view_matrix" ':-> M 4 4 Float
+                                  , "proj_matrix" ':-> M 4 4 Float
+                                  ])
+    -- Descriptor Set 1 : Material properties (bound once per material)
+    -- ...
+
+    -- Descriptor Set 2 : Mesh properties (bound once per mesh)
+   , "model"        ':-> Uniform    '[ DescriptorSet 2, Binding 0 ] (Struct '[ "m" ':-> M 4 4 Float ])
+   ]
+
+
+vertex :: G.VertexShaderModule VertexDefs _
+vertex = shader do
+    ~(Vec3 x y z)    <- #in_position
+    ~(Vec3 nx ny nz) <- #in_normal
+    proj_matrix <- use @(Name "camera" :.: Name "proj_matrix")
+    view_matrix <- use @(Name "camera" :.: Name "view_matrix")
+    model_mat   <- use @(Name "model" :.: Name "m")
+    let view_p = (view_matrix !*! model_mat) !*^ (Vec4 x y z 1)
+    #gl_Position  .= proj_matrix !*^ view_p
+    #out_position .= view_p
+    #out_normal   .= (view_matrix !*! model_mat) !*^ (Vec4 nx ny nz 0) -- careful! don't translate (hence the w=0)
+
+fragment :: G.FragmentShaderModule
+  '[ "in_position"  ':-> Input      '[ Location 0 ] (V 4 Float) -- in view space
+   , "in_normal"    ':-> Input      '[ Location 1 ] (V 4 Float) -- in view space
+   ] _
+fragment = shader do
+  let lightDir  = Vec3 0 (-1) 0
+  let lightCol  = Vec3 0.3 0.3 0.3
+  let objectCol = Vec3 1 1 1
+  let shininess = 16
+
+  lightValue <- blinnPhong 0.05 shininess lightDir lightCol
+
+  let Vec3 colx coly colz
+        = gammaCorrection defaultGamma (lightValue `pointwiseMult` objectCol)
+
+  #out_colour .= Vec4 colx coly colz 1
+

examples/teapot-obj/teapot.obj renamed to examples/teapot-obj/assets/teapot.obj

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 -- | Module with utilities for computing normals of a Mesh.
 --
@@ -18,7 +19,7 @@ import qualified Geomancy.Vec3 as Vec3
 
 import Prelude.Linear
 import qualified Data.Vector as V
-import qualified Data.Vector.Storable as SV
+import qualified Data.Vector.Generic as GV
 import qualified Data.Array.Mutable.Linear as Array
 
 {- | Compute the smooth normal vectors of a mesh surface.
@@ -58,12 +59,14 @@ have all allocated buffers automatically initialized to zero. In that case, if
 this is the first and only normalization for a given mesh, you may skip the
 first loop on the function too of course.
 -}
-computeNormals :: SV.Vector Int  -- ^ Every three indices into the vertices array forms a face
-               -> SV.Vector Vec3 -- ^ The position of every vertex
-               -> SV.Vector Vec3 -- ^ The normal vector for each vertex
+{-# INLINEABLE computeNormals #-}
+computeNormals :: (GV.Vector v Int, GV.Vector w Vec3)
+               => v Int  -- ^ Every three indices into the vertices array forms a face
+               -> w Vec3 -- ^ The position of every vertex
+               -> V.Vector Vec3 -- ^ The normal vector for each vertex
 computeNormals ixs vs =
-  V.convert $ unur $ -- todo: freeze variant which constructs SV.Vector?
-  Array.alloc (SV.length vs) (vec3 0 0 0) $ \arr0 ->
+  unur $ -- todo: freeze variant which constructs SV.Vector?
+  Array.alloc (GV.length vs) (vec3 0 0 0) $ \arr0 ->
     Array.freeze $
     Array.map Vec3.normalize $
       foldl' (\arr (Ur i) -> let
@@ -76,14 +79,23 @@ computeNormals ixs vs =
         in arr & ia += no
                & ib += no
                & ic += no
-        ) arr0 [Ur i | i <- [0,3..SV.length ixs - 1]]
+        ) arr0 [Ur i | i <- [0,3..GV.length ixs - 4]]
   where
-    (!) :: SV.Storable x => SV.Vector x -> Int -> x
-    (!) = SV.unsafeIndex
+    (!) :: GV.Vector t x => t x -> Int -> x
+#ifdef DEBUG
+    (!) = (GV.!)
+#else
+    (!) = GV.unsafeIndex
+#endif
 
     (+=) :: Int -> Vec3 -> Array.Array Vec3 %1 -> Array.Array Vec3
+#ifdef DEBUG
+    (+=) i new arr0 = case Array.get i arr0 of
+      (Ur exists, arr1) -> Array.set i (new ^+^ exists) arr1
+#else
     (+=) i new arr0 = case Array.unsafeGet i arr0 of
       (Ur exists, arr1) -> Array.unsafeSet i (new ^+^ exists) arr1
+#endif
 
 -- TODO: Try backpermute
 

ghengin/ghengin-geometry/Ghengin/Geometry/Normals.hs

@@ -4,28 +4,37 @@
 {-# LANGUAGE OverloadedRecordDot #-}
 module Ghengin.Geometry.Obj where
 
-import Prelude
-import qualified Prelude.Linear as Linear
+import Prelude hiding (log)
 import Control.Monad
+import qualified Prelude.Linear as Linear
 
 import qualified Data.Vector as V
+import qualified Data.Vector.Storable as SV
 
 import Geomancy
 
 import Codec.Wavefront
 
+import Ghengin.Core.Log
 import Ghengin.Core.Type.Compatible
-import Ghengin.Core.Prelude (GHList(..))
 import Ghengin.Core.Render.Pipeline
 import Ghengin.Core.Render.Property
 import Ghengin.Core.Renderer
 import Ghengin.Core.Mesh
-import Ghengin.Core.Mesh.Vertex
 import qualified Data.Linear.Alias as Alias
 
 import qualified Control.Functor.Linear as Linear
 import qualified Control.Monad.IO.Class.Linear as Linear
 
+import Ghengin.Geometry.Normals
+
+-- | Loads a 'WavefrontOBJ' from a file.
+--
+-- Useful if one desires to embed the model with template haskell
+loadObjFile :: FilePath -> IO (Either String WavefrontOBJ)
+loadObjFile = fromFile
+
+-- | Load an .obj file and create a mesh from it.
 loadObjMesh :: (CompatibleMesh ts π, CompatibleVertex '[Vec3, Vec3] π)
             => FilePath
             -> RenderPipeline π ps
@@ -34,27 +43,50 @@ loadObjMesh :: (CompatibleMesh ts π, CompatibleVertex '[Vec3, Vec3] π)
             -- The property bindings need to set when creating it.
              ⊸ Renderer (Mesh '[Vec3, Vec3] ts, RenderPipeline π ps)
 loadObjMesh filepath rp props = Linear.do
-  Linear.liftSystemIOU (fromFile filepath) Linear.>>= \case
+  Linear.liftSystemIOU (loadObjFile filepath) Linear.>>= \case
     Linear.Ur (Left err) -> Linear.do
       destroyRenderPipeline rp
       Alias.forget props
       Linear.liftSystemIO (fail err)
     Linear.Ur (Right wavefrontObj) ->
-      let
-          locs    = V.map getLoc    $ wavefrontObj.objLocations
-          normals = V.map getNormal $ wavefrontObj.objNormals
-          faces   = V.map (.elValue) wavefrontObj.objFaces
-
-          getLoc :: Location -> Vec3
-          getLoc (Location x y z _) = vec3 x (-y) z
-
-          getNormal :: Normal -> Vec3
-          getNormal (Normal x y z) = vec3 x y z
-
-          vertices = V.zipWith (:&:) locs normals
-          ixs = V.concatMap (\(Face a b c d) -> V.fromList $
-                  [ a.faceLocIndex , b.faceLocIndex , c.faceLocIndex ] ++ map (.faceLocIndex) d
-                  ) faces
-       in
-          createMeshWithIxsSV rp props (V.convert vertices) (V.convert $ V.map fromIntegral ixs)
+      createObjMesh wavefrontObj rp props
+
+-- | Create a mesh from a 'WavefrontOBJ'
+createObjMesh :: (CompatibleMesh ts π, CompatibleVertex '[Vec3, Vec3] π)
+              => WavefrontOBJ
+              -> RenderPipeline π ps
+               ⊸ PropertyBindings ts
+              -- ^ These must NOT be added after creating the mesh.
+              -- The property bindings need to set when creating it.
+               ⊸ Renderer (Mesh '[Vec3, Vec3] ts, RenderPipeline π ps)
+createObjMesh wavefrontObj rp props =
+  let
+      locs    = V.map getLoc    $ wavefrontObj.objLocations
+      normals = V.map getNormal $ wavefrontObj.objNormals
+      faces   = V.map (.elValue) wavefrontObj.objFaces
+
+      getLoc :: Location -> Vec3
+      getLoc (Location x y z _) = vec3 x (-y) z
+
+      -- get normal, currently ignoring face
+      getNormal :: Normal -> Vec3
+      getNormal (Normal x y z) = vec3 x y z
+
+      vertices
+        | V.length normals == 0
+            || V.length locs /= V.length normals {- bad object file! -}
+        = V.zipWith (:&:) locs (computeNormals ixs locs)
+        | otherwise
+        = V.zipWith (:&:) locs normals
+
+      ixs = V.concatMap (\(Face a b c _) -> V.fromList $ map (\x -> x-1) {-face indices are 1-indexed-}
+              [ a.faceLocIndex , b.faceLocIndex , c.faceLocIndex ]
+              ) faces
+   in Linear.do
+    if (V.length normals > 0 && V.length locs /= V.length normals)
+      then log $ toLogStr $ "createObjMesh: length of normals ("
+        ++ show (V.length normals) ++ ") is not the same as length of locations ("
+        ++ show (V.length locs)    ++ ")! Ignoring and recomputing normals from scratch..."
+      else Linear.pure ()
+    createMeshWithIxsSV rp props (V.convert vertices) (SV.map fromIntegral $ V.convert ixs)
 

ghengin/ghengin-geometry/Ghengin/Geometry/Obj.hs

@@ -15,6 +15,7 @@ import Ghengin.Core.Renderer
 import Ghengin.Core.Render.Pipeline
 import Ghengin.Core.Mesh
 
+import qualified Data.Vector as V
 import qualified Data.Vector.Storable as SV
 
 import Ghengin.Geometry.Normals
@@ -69,7 +70,7 @@ newUnitSphere res =
       ps = SV.fromList $ v1 <> v2 <> v3 <> v4 <> v5 <> v6
       ns = computeNormals is ps
    in
-      UnitSphere (SV.zipWith (\a b -> a :&: b) ps ns) (SV.map fromIntegral is)
+      UnitSphere (SV.zipWith (\a b -> a :&: b) ps (V.convert ns)) (SV.map fromIntegral is)
 
 newSphereMesh :: (CompatibleMesh '[] π, CompatibleVertex [Vec3, Vec3] π)
               => RenderPipeline π bs