Added glass material

app/Main.hs

@@ -35,6 +35,20 @@ scatter (Ray o d) (Hit t p n (Lambertian c)) = do
 scatter (Ray o d) (Hit t p n (Metal c)) = do
   let reflected = reflect (unitVector d) n
   return $ Ray p reflected
+scatter (Ray o d) (Hit t p n (Glass c)) = do
+  let refraction_ratio = if isFrontFace (Ray o d) n then 1.0 / 1.5 else 1.0
+  let ud = unitVector d
+  let ct = min (ud `dotP` (unitVector n)) 1.0
+  let st = sqrt (1.0 - ct * ct)
+  rVal <- rand
+
+  if refraction_ratio * st > 1.0 || reflectance ct refraction_ratio < rVal
+    then do
+      let reflected = reflect ud n
+      return $ Ray p reflected
+    else do
+      let refracted = refract ud n refraction_ratio
+      return $ Ray p refracted
 
 getRayColor :: (Shape s, RandomGen g) => [s] -> Int -> Ray Double -> Rand g (V3 Double)
 getRayColor ws d r = do
@@ -105,8 +119,9 @@ main = do
   let w = 400
   let h = 400
   let world =
-        [ Circle (V3 0.0 0.0 (-1.0)) 0.25 (Metal (V3 0.8 0.8 0.8)),
-          Circle (V3 0.0 (-10.25) (-1.0)) 10 (Lambertian (V3 0.7 0.3 0.3))
+        [ Circle (V3 (0.0) 0.0 (-1.0)) 0.25 (Glass (V3 1.0 1.0 1.0)),
+          Circle (V3 (-0.5) 0.0 (-1.0)) 0.25 (Lambertian (V3 0.7 0.1 0.1)),
+          Circle (V3 0.0 (-10.25) (-1.0)) 10 (Lambertian (V3 0.7 0.6 0.5))
         ]
   let coords = reverse $ range ((-1 * (w `div` 2), -1 * (h `div` 2)), ((w `div` 2) - 1, (h `div` 2) - 1)) -- "canvas"
   colors <- mapM (\x -> rayTrace x (w, h) (1.0, 1.0) world) coords

src/Hittable.hs

@@ -1,4 +1,4 @@
-module Hittable (Shape (..), Circle (..), Hit (..)) where
+module Hittable (Shape (..), Circle (..), Hit (..), isFrontFace) where
 
 import Linear.V3
 import Linear.Vector
@@ -18,6 +18,11 @@ getFaceNormal (Ray o d) n
   | (d `dotP` n) < 0.0 = n
   | otherwise = (-1.0) *^ n
 
+isFrontFace :: Ray Double -> V3 Double -> Bool
+isFrontFace (Ray o d) n
+  | (d `dotP` n) < 0.0 = True
+  | otherwise = False
+
 -- t_min 0 t_max infinity... need closest so far
 instance Shape Circle where
   testHit (Ray o d) (Circle center r m) =

src/Material.hs

@@ -5,8 +5,9 @@ import Linear.Vector
 import Maths
 import Ray
 
-data Material = Lambertian (V3 Double) | Metal (V3 Double)
+data Material = Lambertian (V3 Double) | Metal (V3 Double) | Glass (V3 Double)
 
 -- attenuation :: (Material m) => m -> V3 Double
 attenuation (Lambertian c) = c
 attenuation (Metal c) = c
+attenuation (Glass c) = (V3 1.0 1.0 1.0)

src/Maths.hs

@@ -5,6 +5,8 @@ module Maths
     randV3,
     rand,
     reflect,
+    refract,
+    reflectance,
   )
 where
 
@@ -48,3 +50,16 @@ unitVector v = v ^/ vectorLength v
 
 reflect :: (Floating f) => V3 f -> V3 f -> V3 f
 reflect v n = v - (2 * (v `dotP` n)) *^ n
+
+refract :: (RealFloat f) => V3 f -> V3 f -> f -> V3 f
+refract uv n etai_over_etat = perp ^+^ parallel
+  where
+    ct = min (uv `dotP` n) 1.0
+    perp = etai_over_etat *^ ((-1.0 *^ uv) ^+^ (ct *^ n))
+    parallel = -1.0 * sqrt (abs (1.0 - lengthSquared perp)) *^ n
+
+reflectance :: Double -> Double -> Double
+reflectance c r = r00 + (1 - r00) * (1 - c) ^ 5
+  where
+    r0 = (1 - r) / (1 + r)
+    r00 = r0 * r0