WaveFront reader also uses normals from file.

waldheinz · waldheinz · commit 411e57bf09e2 · 2013-03-10T19:19:39.000+01:00
diff --git a/examples/substrate.bling b/examples/substrate.bling
@@ -5,12 +5,12 @@ filter mitchell 3 3 0.333333 0.333333
 filter box
 
 imageSize 1280 720
-# imageSize 640 360
+imageSize 640 360
 
 renderer {
    sampler
    sampled {
-      sampler { stratified 8 8 }
+      sampler { stratified 2 2 }
       integrator { path maxDepth 7 sampleDepth 3 }
    }
 }
@@ -43,6 +43,7 @@ material {
    matte
    kd {
       graphPaper 0.1
+      map { uv 0 0 1 1 }
       tex1 { constant rgbR 0.8 0.8 0.8 }
       tex2 { constant rgbR 0.05 0.05 0.05 }
    }
diff --git a/src/Graphics/Bling/IO/WaveFront.hs b/src/Graphics/Bling/IO/WaveFront.hs
@@ -22,8 +22,6 @@ import Control.Monad.Trans.Class (lift)
 import qualified Data.Vector.Unboxed as V
 import qualified Data.Vector.Unboxed.Mutable as MV
 
-import Debug.Trace
-
 type STUGrowVec s a = GrowVec (MV.MVector) s a
 
 data WFState s = WFState
@@ -48,17 +46,38 @@ wfTriVerts d i = (p1, p2, p3) where
    p3 = (wfPoints d) V.! (let (i', _, _) = (wfFaces d) V.! (i+2) in i')
    
 wfTriUVs :: WFData -> Int -> TriUVs
-wfTriUVs d i = triangleNoUVs where -- (u1, v1, u2, v2, u3, v3) where
-   (u1, v1) = (wfTexCoords d) V.! (let (_, i', _) = (wfFaces d) V.! i in i')
-   (u2, v2) = (wfTexCoords d) V.! (let (_, i', _) = (wfFaces d) V.! (i+1) in i')
-   (u3, v3) = (wfTexCoords d) V.! (let (_, i', _) = (wfFaces d) V.! (i+2) in i')
+wfTriUVs d i
+   | i1 >= 0 && i2 >= 0 && i3 >= 0 = (u1, v1, u2, v2, u3, v3)
+   | otherwise = triangleDefaultUVs
+   where
+      (u1, v1) = (wfTexCoords d) V.! i1
+      (u2, v2) = (wfTexCoords d) V.! i2
+      (u3, v3) = (wfTexCoords d) V.! i3
+   
+      i1 = let (_, i', _) = (wfFaces d) V.! (i+0) in i'
+      i2 = let (_, i', _) = (wfFaces d) V.! (i+1) in i'
+      i3 = let (_, i', _) = (wfFaces d) V.! (i+1) in i'
+   
+wfTriNormals :: WFData -> Int -> Maybe TriNorms
+wfTriNormals d i
+   | i1 < 0 && i2 < 0 && i3 < 0 = Nothing
+   | otherwise = Just (n1, n2, n3)
+   where
+      n1 = (wfNormals d) V.! i1
+      n2 = (wfNormals d) V.! i2
+      n3 = (wfNormals d) V.! i3
+      
+      i1 = let (_, _, i') = (wfFaces d) V.! (i+0) in i'
+      i2 = let (_, _, i') = (wfFaces d) V.! (i+1) in i'
+      i3 = let (_, _, i') = (wfFaces d) V.! (i+1) in i'
    
 mkWFTri :: Material -> WFData -> Int -> Primitive
 mkWFTri !mat !d !i = prim where
-   prim = Primitive tint ints bounds Nothing (flip const)
+   prim = Primitive tint ints bounds Nothing shade
    tint = triangleIntersect mat prim (wfTriVerts d i) (wfTriUVs d i)
    ints = triangleIntersects (wfTriVerts d i)
    bounds = triangleBounds (wfTriVerts d i)
+   shade = maybe (flip const) triangleShadingGeometry (wfTriNormals d i)
    
 initialState :: ST s (WFState s)
 initialState = do
diff --git a/src/Graphics/Bling/Math.hs b/src/Graphics/Bling/Math.hs
@@ -128,7 +128,7 @@ solveQuadric
    -> Maybe (Float, Float)
 {-# INLINE solveQuadric #-}
 solveQuadric a b c
-   | discrim <= 0 = Nothing
+   | discrim < 0 = Nothing
    | otherwise = Just (min t0 t1, max t0 t1)
    where
          (t0, t1) = (q / a, c / q)
diff --git a/src/Graphics/Bling/Primitive/KdTree.hs b/src/Graphics/Bling/Primitive/KdTree.hs
@@ -111,8 +111,10 @@ mkKdTree psl = {-# SCC "mkKdTree" #-} KdTree bounds root where
    
 buildTree :: AABB -> V.Vector Primitive -> Int -> KdTreeNode
 buildTree bounds ps depth
-   | depth == 0 || V.length ps <= 1 = {-# SCC "buildTree.leaf" #-} Leaf ps
-   | otherwise = fromMaybe (Leaf ps) $ trySplit bounds ps depth
+   | depth == 0 || V.length ps <= 1 = {-# SCC "buildTree.leaf" #-} leaf
+   | otherwise = fromMaybe leaf $ trySplit bounds ps depth
+   where
+      leaf = Leaf $ V.force ps
       
 trySplit :: AABB -> V.Vector Primitive -> Int -> Maybe KdTreeNode
 trySplit bounds bps depth = {-# SCC "trySplit" #-} go Nothing axii where
diff --git a/src/Graphics/Bling/Primitive/TriangleMesh.hs b/src/Graphics/Bling/Primitive/TriangleMesh.hs
@@ -2,9 +2,9 @@
 module Graphics.Bling.Primitive.TriangleMesh (
    
    -- * Triangle
-   TriVerts, TriUVs, triangleIntersects, triangleIntersect, triangleBounds,
-   triangleNoUVs,
-   
+   TriVerts, TriNorms, TriUVs, triangleIntersects, triangleIntersect,
+   triangleShadingGeometry, triangleBounds, triangleDefaultUVs,
+     
    -- * Triangle Mesh
    
    mkTriangleMesh, triangulate
@@ -89,7 +89,7 @@ triNormals i m =
 
 triUVs :: Int -> Mesh -> (Float, Float, Float, Float, Float, Float)
 {-# INLINE triUVs #-}
-triUVs idx m = maybe triangleNoUVs go (muvs m) where
+triUVs idx m = maybe triangleDefaultUVs go (muvs m) where
    (o1, o2, o3) = triOffsets idx m
 
    go uvs = (muv (2 * o1), muv (2 * o1 + 1),
@@ -110,25 +110,29 @@ mkTri mesh n
 
       sg o2w dgg
          | isNothing $ mns mesh = dgg
-         | otherwise = dgg { dgN = ns, dgDPDU = ss, dgDPDV = ts }
-         where
-            (b1, b2) = fromJust $ dgtriB dgg
-            b0 = 1 - b1 - b2
-            (n0, n1, n2) = triNormals idx mesh
-            ns = normalize $ transNormal o2w ns'
-            ns' = (b0 *# n0) + (b1 *# n1) + (b2 *# n2)
-            ss' = normalize $ dgDPDU dgg
-            ts' = ss' `cross` ns
-            (ss, ts) = if sqLen ts' > 0
-                          then (normalize ts' `cross` ns, normalize ts')
-                          else coordinateSystem'' ns
+         | otherwise = triangleShadingGeometry (triNormals idx mesh) o2w dgg
 
 type TriVerts = (Point, Point, Point)
+type TriNorms = (Normal, Normal, Normal)
 type TriUVs = (Float, Float, Float, Float, Float, Float)
 
-triangleNoUVs :: TriUVs
-triangleNoUVs = (0, 0, 1, 0, 1, 1)
+triangleDefaultUVs :: TriUVs
+triangleDefaultUVs = (0, 0, 1, 0, 1, 1)
 
+triangleShadingGeometry :: TriNorms -> Transform -> DifferentialGeometry -> DifferentialGeometry
+{-# INLINE triangleShadingGeometry #-}
+triangleShadingGeometry (n0, n1, n2) o2w dgg = dgg { dgN = ns, dgDPDU = ss, dgDPDV = ts }
+   where
+      (b1, b2) = fromJust $ dgtriB dgg
+      b0 = 1 - b1 - b2
+      ns = normalize $ transNormal o2w ns'
+      ns' = (b0 *# n0) + (b1 *# n1) + (b2 *# n2)
+      ss' = normalize $ dgDPDU dgg
+      ts' = ss' `cross` ns
+      (ss, ts) = if sqLen ts' > 0
+                    then (normalize ts' `cross` ns, normalize ts')
+                    else coordinateSystem'' ns
+                    
 triangleBounds :: TriVerts -> AABB
 {-# INLINE triangleBounds #-}
 triangleBounds (p1, p2, p3) = foldl' extendAABBP emptyAABB [p1, p2, p3]
