Implement 3 distinct lighting models.

3 files changed, 133 insertions, 22 deletions

diff --git a/LoadMesh.hs b/LoadMesh.hs
index cda6349..d8ce42b 100644
--- a/LoadMesh.hs
+++ b/LoadMesh.hs
@@ -126,8 +126,6 @@ uploadOBJToGPU :: Maybe BoundingBox -> MeshData -> IO ([MaterialMesh GPUMesh],Ma
 uploadOBJToGPU scalebb (subModels,(mtlLib,objpath)) = do
     let meshbb = foldMap (attribBoundingBox . mAttributes . materialMesh) subModels :: BoundingBox
         m = maybe (ident 4) (scaleWithin meshbb) scalebb
-    -- BoundingBox {minX = -6.44698, maxX = 6.44698, minY = 0.0, maxY = 1.0e9, minZ = -0.768655, maxZ = 1.0e8}
-    -- BoundingBox {minX = -6.44698, maxX = 6.44698, minY = 0.0, maxY = 18.2027, minZ = -0.768655, maxZ = 2.238049}
     putStrLn $ show meshbb
     gpuSubModels <- forM subModels $ \matmesh -> do
         a <- LambdaCubeGL.uploadMeshToGPU (transformMesh m (materialMesh matmesh))
@@ -204,25 +202,44 @@ objSpan obj = case Map.elems (objAttributes obj) of
         _                             -> Mask [(0,1)]
 
 
-searchMaterial :: V.Vector (Map Text (ObjMaterial, TextureData))
-                  -> (Int, Text)
-                  -> Maybe (ObjMaterial, TextureData)
+searchMaterial
+    :: V.Vector (Map Text (ObjMaterial, TextureData)) -- ^ Some tail end of this vector will be searched.
+    -> (Int, Text)                                    -- ^ Size of tail and material name to search for.
+    -> Maybe (ObjMaterial, TextureData)
 searchMaterial mtlLib (count,name) = foldr go id (V.drop (V.length mtlLib - count) mtlLib) Nothing
  where
     go m f r = case Map.lookup name m of
         Nothing -> f r
         x       -> x :: Maybe (ObjMaterial,TextureData)
 
-addOBJToObjectArray :: GLStorage -> String -> [MaterialMesh GPUMesh] -> V.Vector (Map Text (ObjMaterial,TextureData))
+addOBJToObjectArray :: GLStorage -> String
+                                 -> [MaterialMesh GPUMesh]
+                                 -> V.Vector (Map Text (ObjMaterial,TextureData))
                                  -> IO [MaskableObject]
 addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \matmesh -> do
-  obj <- LambdaCubeGL.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] (materialMesh matmesh)
-         -- diffuseTexture and diffuseColor values can change on each model
-  case materialName matmesh >>= searchMaterial mtlLib of
-    Nothing -> return ()
-    Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
-      "diffuseTexture" @= return t -- set model's diffuse texture
-      "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
+  obj <- case materialName matmesh >>= searchMaterial mtlLib of
+    Nothing -> do
+        let slotnm = slotName ++ "0"
+        obj <- LambdaCubeGL.addMeshToObjectArray storage
+                                                 slotnm
+                                                 [ "diffuseTexture"
+                                                 , "diffuseColor"
+                                                 , "specularReflectivity"]
+                                                 (materialMesh matmesh)
+        return obj
+    Just (ObjMaterial{..},t) -> do
+        let slotnm = slotName ++ show (if 0 <= mtl_illum && mtl_illum <= 2 then mtl_illum else 2)
+        obj <- LambdaCubeGL.addMeshToObjectArray storage
+                                                 slotnm
+                                                 [ "diffuseTexture"
+                                                 , "diffuseColor"
+                                                 , "specularReflectivity"]
+                                                 (materialMesh matmesh)
+        LC.updateObjectUniforms obj $ do
+          "diffuseTexture" @= return t -- set model's diffuse texture
+          "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
+          "specularReflectivity" @= let (r,g,b) = mtl_Ks in return (V4 r g b mtl_Ns)
+        return obj
   let matmask = maybe Map.empty (`Map.singleton` objSpan obj)
                       (fmap (\(c,n) -> "m:" <> pack (show c) <> ":" <> n) $ materialName matmesh)
   return $ MaskableObject obj (matmask `Map.union` materialMasks matmesh)
diff --git a/MeshSketch.hs b/MeshSketch.hs
index 56bbdaa..a51cd3d 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -333,7 +333,15 @@ new = do
         mpipeline <- loadPipeline ppath $ do
           defObjectArray "SkyCube" Triangles $ do
             "position"  @: Attribute_V3F
-          defObjectArray "objects" Triangles $ do
+          defObjectArray "objects0" Triangles $ do
+            "position"  @: Attribute_V4F
+            "normal"    @: Attribute_V3F
+            "uvw"       @: Attribute_V3F
+          defObjectArray "objects1" Triangles $ do
+            "position"  @: Attribute_V4F
+            "normal"    @: Attribute_V3F
+            "uvw"       @: Attribute_V3F
+          defObjectArray "objects2" Triangles $ do
             "position"  @: Attribute_V4F
             "normal"    @: Attribute_V3F
             "uvw"       @: Attribute_V3F
@@ -355,6 +363,7 @@ new = do
             "PointsStart"     @: Int
             "diffuseTexture"  @: FTexture2D
             "diffuseColor"    @: V4F
+            "specularReflectivity" @: V4F
         return mpipeline
     either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \pipeline -> do
         mapM_ (putStrLn . ppShow) (targets $ dynamicPipeline pipeline)
diff --git a/hello_obj2.lc b/hello_obj2.lc
index 7e7defc..a6df7b7 100644
--- a/hello_obj2.lc
+++ b/hello_obj2.lc
@@ -10,6 +10,88 @@ blendplane = -- NoBlending -- BlendLogicOp Xor
 point :: Vec 3 Float -> Vec 4 Float
 point p = V4 p%x p%y p%z 1
 
+homoproj :: Vec 4 Float -> Vec 3 Float
+homoproj v = v%xyz *! (1 / v%w)
+
+type Position = Vec 4 Float
+type TextureCoord = Vec 3 Float
+type Normal = Vec 3 Float
+type Overlay = ( (FragmentOperation Depth, FragmentOperation (Color (VecScalar 4 Float)))
+               , FragmentStream 1 ((Vec 4 Float)) )
+
+-- This lighting model ignores the normal vector and simply applies
+-- ambient lighting and a texture map.
+--
+-- "Color on and Ambient off"
+-- inputs: Kd, map_Kd
+--
+-- illum 0 -- color = Kd
+ambientOnly :: Mat 4 4 Float -> Vec 4 Float -> Texture -> PrimitiveStream Triangle (Position,TextureCoord,Normal)
+                                                       -> Overlay
+ambientOnly cam color texture prims = prims
+    & mapPrimitives (\(p,n,uvw) -> ( coordmap cam p, V2 uvw%x (1 - uvw%y) ))
+    & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth))
+    & mapFragments (\((uv)) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
+    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
+
+-- ½ ambient + ½ lambertian reflectance
+-- lambertian reflectance = (light ∙ normal) * diffuse * intensity
+-- I_d = (L ∙ N) C_d I_L
+--
+-- "Color on and Ambient on"
+-- Chrome example indicates: Ka, Kd, Ks, refl
+--
+-- illum 1 -- color = KaIa + Kd { SUM j=1..ls, (N ∙ Lj)Ij }
+--
+-- The illum 0 can be implemented using illum 1 code by setting
+--   KaIa = Kd
+--   Ij = 0 forall j
+lambertianReflectance cam lightpos color texture prims = prims
+    & mapPrimitives (\(p,n,uvw) ->
+        let light_vector = normalize $ -- light direction from surface
+                            if lightpos%w == 0
+                                then lightpos%xyz
+                                else homoproj lightpos - homoproj p
+            lambertian = dot light_vector (normalize n)
+          in ( coordmap cam p, V2 uvw%x (1 - uvw%y), lambertian ))
+    & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) (Smooth,Smooth)
+    & mapFragments (\(uv,lambertian) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv *! (0.5 + 0.5*lambertian) )))
+    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
+
+
+-- Blinn-Phong
+--
+-- illum 0 -- color = Kd
+-- illum 1 -- color = KaIa + Kd { SUM j=1..ls, (N ∙ Lj)Ij }
+-- illum 2 -- color = KaIa + Kd { SUM j=1..ls, (N ∙ Lj)Ij } + Ks { SUM j=1..ls, ((H∙Hj)^Ns)Ij }
+--
+-- The illum 1 can be implemented using illum2 code by setting
+--   Ks = 0 (specular reflectance)
+--
+-- TODO: Add (H∙Hj)^Ns term
+--
+-- Okay, I don't understand why the spec says H∙Hj.  I think it means N∙Hj.
+-- So i'm implementing that.
+blinnPhong cam lightpos color texture specular prims = prims
+    & mapPrimitives (\(p,n,uvw) ->
+        let light_vector = normalize $ -- light direction from surface
+                            if lightpos%w == 0
+                                then lightpos%xyz
+                                else homoproj lightpos - homoproj p
+            campos = cam *. V4 0 0 0 1
+            view_vector = normalize $ homoproj campos - homoproj p
+            h = normalize $ light_vector + view_vector
+            refl = dot h (normalize n)
+            lambertian = dot light_vector (normalize n)
+          in ( coordmap cam p, V2 uvw%x (1 - uvw%y), lambertian, refl ))
+    & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) (Smooth,Smooth,Smooth)
+    & mapFragments (\(uv,lambertian, refl) ->
+        let ct = texture2D (Sampler PointFilter MirroredRepeat texture) uv
+            ns = specular%w
+            ks = point $ specular%xyz
+        in (( color * ct *! (0.5 + 0.5*lambertian) + if refl>0 then ks *! pow refl ns else zero )) )
+    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
+
 
 makeFrame (cubemap :: TextureCube)
           (skybox :: PrimitiveStream Triangle ((Vec 3 Float)))
@@ -17,7 +99,10 @@ makeFrame (cubemap :: TextureCube)
           (cam ::  Mat 4 4 Float)
           (color :: Vec 4 Float)
           (texture :: Texture)
-          (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
+          (specular :: Vec 4 Float)
+          (prims0 :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
+          (prims1 :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
+          (prims2 :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
           (plane :: PrimitiveStream Triangle ((Vec 4 Float)))
           (lines :: PrimitiveStream Line (Vec 3 Float, Vec 3 Float))
           (points :: PrimitiveStream Point (Vec 3 Float, Vec 3 Float))
@@ -32,12 +117,9 @@ makeFrame (cubemap :: TextureCube)
     & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth))
     & mapFragments (\((d)) -> (( textureCube cubemap d )))
     & accumulateWith (DepthOp Always False, ColorOp NoBlending (V4 True True True True))
-  `overlay`
-      prims
-    & mapPrimitives (\(p,n,uvw) -> ( coordmap cam p, V2 uvw%x (1 - uvw%y) ))
-    & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth))
-    & mapFragments (\((uv)) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
-    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
+  `overlay` ambientOnly           cam color texture prims0
+  `overlay` lambertianReflectance cam (V4 0 20 10 1) color texture prims1
+  `overlay` blinnPhong            cam (V4 0 20 10 1) color texture specular prims2
   `overlay`
       plane
     & mapPrimitives (\((p)) -> let p' = coordmap cam $ plane_mat *. p in (p', p%xz))
@@ -89,7 +171,10 @@ main = renderFrame $
              (Uniform "ViewProjection")
              (Uniform "diffuseColor")
              (Texture2DSlot "diffuseTexture")
-             (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
+             (Uniform "specularReflectivity")
+             (fetch "objects0" (Attribute "position", Attribute "normal", Attribute "uvw"))
+             (fetch "objects1" (Attribute "position", Attribute "normal", Attribute "uvw"))
+             (fetch "objects2" (Attribute "position", Attribute "normal", Attribute "uvw"))
              (fetch "plane"   ((Attribute "position")))
              (fetch "Curve" (Attribute "position", Attribute "color"))
              (fetch "Points" (Attribute "position", Attribute "color"))