Dielectric kind of works, glass does not

RayTracing.App/Program.fs

@@ -11,13 +11,13 @@ module Program =
 
         member this.Increment (prog : float<progress>) = this.Increment (prog / 1.0<progress>)
 
-    let go (sample : SampleImages) (ppmOutput : IFileInfo) (ctx : ProgressContext) =
+    let go (sample : SampleImages) (pngOutput : IFileInfo) (ctx : ProgressContext) =
         let renderTask = ctx.AddTask "[green]Generating image[/]"
         let writeUnorderedTask = ctx.AddTask "[green]Writing unordered pixels[/]"
         let readTask = ctx.AddTask "[green]Reading in serialised pixels[/]"
         let writeTask = ctx.AddTask "[green]Writing PPM file[/]"
 
-        let logFile = ppmOutput.FileSystem.Path.GetTempFileName () |> ppmOutput.FileSystem.FileInfo.FromFileName
+        let logFile = pngOutput.FileSystem.Path.GetTempFileName () |> pngOutput.FileSystem.FileInfo.FromFileName
         use stream = logFile.OpenWrite ()
         use writer = new StreamWriter(stream)
         writer.AutoFlush <- true
@@ -35,20 +35,20 @@ module Program =
         readTask.MaxValue <- maxProgress / 1.0<progress>
         writeTask.MaxValue <- maxProgress / 1.0<progress>
 
-        let tempOutput, await = ImageOutput.toPpm writeUnorderedTask.Increment image ppmOutput.FileSystem
+        let tempOutput, await = ImageOutput.toPpm writeUnorderedTask.Increment image pngOutput.FileSystem
         AnsiConsole.WriteLine (sprintf "Temporary output being written eagerly to '%s'" tempOutput.FullName)
 
         async {
             do! await
             let! pixelMap = ImageOutput.readPixelMap readTask.Increment tempOutput (Image.rowCount image) (Image.colCount image)
             let pixelMap = ImageOutput.assertComplete pixelMap
-            do! ImageOutput.writePpm true writeTask.Increment pixelMap ppmOutput
+            do! Png.write true writeTask.Increment pixelMap pngOutput
             tempOutput.Delete ()
             return ()
         }
         |> Async.RunSynchronously
 
-        printfn "%s" ppmOutput.FullName
+        printfn "%s" pngOutput.FullName
 
     [<EntryPoint>]
     let main (argv : string []) : int =
@@ -57,7 +57,7 @@ module Program =
             match argv with
             | [| name |] ->
                 SampleImages.Parse name,
-                fs.Path.GetTempFileName () |> fun i -> fs.Path.ChangeExtension (i, ".ppm") |> fs.FileInfo.FromFileName
+                fs.Path.GetTempFileName () |> fun i -> fs.Path.ChangeExtension (i, ".png") |> fs.FileInfo.FromFileName
             | [| name ; output |] ->
                 SampleImages.Parse name, fs.FileInfo.FromFileName output
             | _ -> failwithf "Expected two args 'sample name' 'output file', got %+A"  argv

RayTracing.App/SampleImages.fs

@@ -5,11 +5,12 @@ open System
 type SampleImages =
     | Gradient
     | Spheres
+    | RandomSpheres
     | ShinyFloor
     | FuzzyFloor
     | InsideSphere
     | TotalRefraction
-    | HollowDielectric
+    | HollowGlassSphere
     | MovedCamera
     static member Parse (s : string) =
         match s with
@@ -20,7 +21,8 @@ type SampleImages =
         | "inside-sphere" -> SampleImages.InsideSphere
         | "total-refraction" -> SampleImages.TotalRefraction
         | "moved-camera" -> SampleImages.MovedCamera
-        | "hollow-dielectric" -> SampleImages.HollowDielectric
+        | "hollow-glass" -> SampleImages.HollowGlassSphere
+        | "random-spheres" -> SampleImages.RandomSpheres
         | s -> failwithf "Unrecognised arg: %s" s
 
 [<RequireQualifiedAccess>]
@@ -50,7 +52,7 @@ module SampleImages =
         let aspectRatio = 16.0 / 9.0
         let origin = Point.make 0.0 0.0 0.0
         let camera =
-            Camera.makeBasic 2.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+            Camera.makeBasic 50 2.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
         let pixels = 400
         {
             Objects =
@@ -66,7 +68,7 @@ module SampleImages =
         let aspectRatio = 16.0 / 9.0
         let origin = Point.make 0.0 0.0 0.0
         let camera =
-            Camera.makeBasic 2.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+            Camera.makeBasic 50 2.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
         let pixels = 400
         {
             Objects =
@@ -84,7 +86,7 @@ module SampleImages =
         let aspectRatio = 16.0 / 9.0
         let origin = Point.make 0.0 0.0 0.0
         let camera =
-            Camera.makeBasic 7.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+            Camera.makeBasic 50 7.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
         let pixels = 200
         {
             Objects =
@@ -117,7 +119,7 @@ module SampleImages =
         let aspectRatio = 16.0 / 9.0
         let origin = Point.make 0.0 0.0 0.0
         let camera =
-            Camera.makeBasic 7.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+            Camera.makeBasic 50 7.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
         let pixels = 1200
         {
             Objects =
@@ -132,31 +134,33 @@ module SampleImages =
                     Hittable.Sphere (Sphere.make (SphereStyle.FuzzedReflection (0.6<albedo>, { Red = 200uy ; Green = 50uy ; Blue = 255uy }, 0.4<fuzz>, random3)) (Point.make 0.0 -76.0 9.0) 75.0 )
                     Hittable.Sphere (Sphere.make (SphereStyle.FuzzedReflection (0.4<albedo>, { Red = 200uy ; Green = 200uy ; Blue = 200uy }, 0.0<fuzz>, random4)) (Point.make 0.0 0.0 20.0) 100.0)
                     // Light pad behind us
-                    Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.LightSource ({ Red = 80uy ; Green = 80uy ; Blue = 150uy })) (Point.make 0.0 0.0 -5.0) (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get))
+                    Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.LightSource { Red = 80uy ; Green = 80uy ; Blue = 150uy }) (Point.make 0.0 0.0 -5.0) (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get))
 
                 |]
         }
         |> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
 
     let totalRefraction (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
-        let random = Random () |> FloatProducer
+        let random1 = Random () |> FloatProducer
+        let random2 = Random () |> FloatProducer
+        let random3 = Random () |> FloatProducer
         let aspectRatio = 16.0 / 9.0
         let origin = Point.make 0.0 0.0 0.0
         let camera =
-            Camera.makeBasic 1.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+            Camera.makeBasic 50 1.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
         let pixels = 300
         {
             Objects =
                 [|
                     // Floor
-                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (0.5<albedo>, { Red = 204uy ; Green = 204uy ; Blue = 0uy }, random)) (Point.make 0.0 -100.5 1.0) 100.0)
+                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (0.5<albedo>, { Red = 204uy ; Green = 204uy ; Blue = 0uy }, random1)) (Point.make 0.0 -100.5 1.0) 100.0)
 
                     // Right sphere
                     Hittable.Sphere (Sphere.make (SphereStyle.PureReflection (1.0<albedo>, { Red = 204uy ; Green = 153uy ; Blue = 51uy })) (Point.make 1.0 0.0 1.0) 0.5)
                     // Middle sphere
-                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, { Red = 25uy ; Green = 50uy ; Blue = 120uy }, random)) (Point.make 0.0 0.0 1.0) 0.5)
+                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, { Red = 25uy ; Green = 50uy ; Blue = 120uy }, random2)) (Point.make 0.0 0.0 1.0) 0.5)
                     // Left sphere
-                    Hittable.Sphere (Sphere.make (SphereStyle.Dielectric (1.0<albedo>, Colour.White, 1.5<ior>, 1.0<prob>, random)) (Point.make -1.0 0.0 1.0) 0.5)
+                    Hittable.Sphere (Sphere.make (SphereStyle.Dielectric (1.0<albedo>, Colour.White, 1.5<ior>, 1.0<prob>, random3)) (Point.make -1.0 0.0 1.0) 0.5)
 
                     // Light around us
                     Hittable.Sphere (Sphere.make (SphereStyle.LightSource { Red = 80uy ; Green = 80uy ; Blue = 150uy }) (Point.make 0.0 0.0 0.0) 200.0)
@@ -172,8 +176,8 @@ module SampleImages =
         let aspectRatio = 16.0 / 9.0
         let origin = Point.make 0.0 0.0 0.0
         let camera =
-            Camera.makeBasic 1.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
-        let pixels = 300
+            Camera.makeBasic 50 1.0 aspectRatio origin (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+        let pixels = 200
         {
             Objects =
                 [|
@@ -186,7 +190,7 @@ module SampleImages =
                     Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, { Red = 25uy ; Green = 50uy ; Blue = 120uy }, random2)) (Point.make 0.0 0.0 1.0) 0.5)
                     // Left sphere
                     Hittable.Sphere (Sphere.make (SphereStyle.Glass (0.9<albedo>, Colour.White, 1.5<ior>, random3)) (Point.make -1.0 0.0 1.0) 0.5)
-                    Hittable.Sphere (Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.0<ior> / 1.5, random4)) (Point.make -1.0 0.0 1.0) 0.4)
+                    Hittable.Sphere (Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.0<ior> / 1.5, random4)) (Point.make -1.0 0.0 1.0) -0.4)
 
                     // Light around us
                     Hittable.Sphere (Sphere.make (SphereStyle.LightSource { Red = 80uy ; Green = 80uy ; Blue = 150uy }) (Point.make 0.0 0.0 0.0) 200.0)
@@ -195,25 +199,28 @@ module SampleImages =
         |> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
 
     let movedCamera (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
-        let random = Random () |> FloatProducer
+        let random1 = Random () |> FloatProducer
+        let random2 = Random () |> FloatProducer
+        let random3 = Random () |> FloatProducer
+        let random4 = Random () |> FloatProducer
         let aspectRatio = 16.0 / 9.0
         let origin = Point.make -2.0 2.0 -1.0
         let camera =
-            Camera.makeBasic 10.0 aspectRatio origin (Point.differenceToThenFrom (Point.make -1.0 0.0 1.0) origin |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+            Camera.makeBasic 50 10.0 aspectRatio origin (Point.differenceToThenFrom (Point.make -1.0 0.0 1.0) origin |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
         let pixels = 300
         {
             Objects =
                 [|
                     // Floor
-                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (0.5<albedo>, { Red = 204uy ; Green = 204uy ; Blue = 0uy }, random)) (Point.make 0.0 -100.5 1.0) 100.0)
+                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (0.5<albedo>, { Red = 204uy ; Green = 204uy ; Blue = 0uy }, random1)) (Point.make 0.0 -100.5 1.0) 100.0)
 
                     // Right sphere
                     Hittable.Sphere (Sphere.make (SphereStyle.PureReflection (1.0<albedo>, { Red = 204uy ; Green = 153uy ; Blue = 51uy })) (Point.make 1.0 0.0 1.0) 0.5)
                     // Middle sphere
-                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, { Red = 25uy ; Green = 50uy ; Blue = 120uy }, random)) (Point.make 0.0 0.0 1.0) 0.5)
+                    Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, { Red = 25uy ; Green = 50uy ; Blue = 120uy }, random2)) (Point.make 0.0 0.0 1.0) 0.5)
                     // Left sphere
-                    Hittable.Sphere (Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.5<ior>, random)) (Point.make -1.0 0.0 1.0) 0.5)
-                    Hittable.Sphere (Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.0<ior> / 1.5, random)) (Point.make -1.0 0.0 1.0) 0.45)
+                    Hittable.Sphere (Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.5<ior>, random3)) (Point.make -1.0 0.0 1.0) 0.5)
+                    Hittable.Sphere (Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.0<ior> / 1.5, random4)) (Point.make -1.0 0.0 1.0) -0.45)
 
                     // Light around us
                     Hittable.Sphere (Sphere.make (SphereStyle.LightSource { Red = 130uy ; Green = 130uy ; Blue = 200uy }) (Point.make 0.0 0.0 0.0) 200.0)
@@ -221,6 +228,62 @@ module SampleImages =
         }
         |> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
 
+    let randomSpheres (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
+        let aspectRatio = 3.0 / 2.0
+        let origin = Point.make 13.0 2.0 -3.0
+        let camera =
+            Camera.makeBasic 500 10.0 aspectRatio origin (Point.differenceToThenFrom (Point.make 0.0 0.0 0.0) origin |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
+        let pixels = 800
+
+        let spheres =
+            [|
+                for a in -11..10 do
+                    for b in -11..10 do
+                        let rand = Random ()
+                        let floatProducer = FloatProducer rand
+                        let materialChoice = floatProducer.Get ()
+                        let centre = Point.make (float a + 0.9 * floatProducer.Get ()) 0.2 (float b + 0.9 * floatProducer.Get ())
+
+                        if Vector.normSquared (Point.differenceToThenFrom centre (Point.make 4.0 0.2 0.0)) > 0.9 * 0.9 then
+                            if Float.compare materialChoice 0.8 = Less then
+                                // diffuse
+                                let albedo = floatProducer.Get () * floatProducer.Get () * 1.0<albedo>
+                                yield Sphere.make (SphereStyle.LambertReflection (albedo, Colour.random rand, floatProducer)) centre 0.2
+                            elif Float.compare materialChoice 0.95 = Less then
+                                // metal
+                                let albedo = floatProducer.Get () / 2.0 * 1.0<albedo> + 0.5<albedo>
+                                let fuzz = floatProducer.Get () / 2.0 * 1.0<fuzz>
+                                yield Sphere.make (SphereStyle.FuzzedReflection (albedo, Colour.random rand, fuzz, floatProducer)) centre 0.2
+                            else
+                                // glass
+                                yield Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.5<ior>, floatProducer)) centre 0.2
+
+
+                let rand = Random ()
+                let floatProducer = FloatProducer rand
+                yield Sphere.make (SphereStyle.Glass (1.0<albedo>, Colour.White, 1.5<ior>, floatProducer)) (Point.make 0.0 1.0 0.0) 1.0
+
+                let rand = Random ()
+                let floatProducer = FloatProducer rand
+                yield Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, { Red = 80uy ; Green = 40uy ; Blue = 20uy }, floatProducer)) (Point.make -4.0 1.0 0.0) 1.0
+
+                yield Sphere.make (SphereStyle.PureReflection (1.0<albedo>, { Red = 180uy ; Green = 150uy ; Blue = 128uy })) (Point.make 4.0 1.0 0.0) 1.0
+
+                // Ceiling
+                yield Sphere.make (SphereStyle.LightSource { Colour.White with Red = 200uy ; Green = 200uy }) (Point.make 0.0 0.0 0.0) 2000.0
+
+                // Floor
+                let rand = Random ()
+                let floatProducer = FloatProducer rand
+                yield Sphere.make (SphereStyle.LambertReflection (0.5<albedo>, Colour.White, floatProducer)) (Point.make 0.0 -1000.0 0.0) 1000.0
+            |]
+
+        {
+            Objects = spheres |> Array.map Hittable.Sphere
+        }
+        |> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
+
+
     let get (s : SampleImages) : (float<progress> -> unit) -> (string -> unit) -> float<progress> * Image =
         match s with
         | Gradient -> gradient
@@ -229,5 +292,6 @@ module SampleImages =
         | FuzzyFloor -> fuzzyPlane
         | InsideSphere -> insideSphere
         | TotalRefraction -> totalRefraction
-        | HollowDielectric -> hollowGlassSphere
+        | HollowGlassSphere -> hollowGlassSphere
         | MovedCamera -> movedCamera
+        | RandomSpheres -> randomSpheres

RayTracing.Test/RayTracing.Test.fsproj

@@ -13,6 +13,7 @@
         <Compile Include="TestPixel.fs" />
         <Compile Include="TestPlane.fs" />
         <Compile Include="TestSphere.fs" />
+        <Compile Include="TestRandom.fs" />
     </ItemGroup>
 
     <ItemGroup>

RayTracing.Test/TestRandom.fs

@@ -0,0 +1,71 @@
+namespace RayTracing.Test
+
+open System
+open NUnit.Framework
+open FsUnitTyped
+open RayTracing
+
+[<TestFixture>]
+module TestRandom =
+
+    [<TestCase 1>]
+    [<TestCase 2>]
+    [<TestCase 3>]
+    let ``Random floats are in the right range`` (outputNum : int) =
+        let check (r : float) : unit =
+            Double.IsNormal r |> shouldEqual true
+            r < 0.0 |> shouldEqual false
+            r > 1.0 |> shouldEqual false
+
+        let rand = Random () |> FloatProducer
+        for _ in 1..100 do
+            match outputNum with
+            | 1 ->
+                let r = rand.Get ()
+                check r
+            | 2 ->
+                let struct(r, s) = rand.GetTwo ()
+                check r
+                check s
+            | 3 ->
+                let struct(r, s, t) = rand.GetThree ()
+                check r
+                check s
+                check t
+            | _ -> failwithf "unknown: %i" outputNum
+
+    [<Test>]
+    let ``Random floats are distributed over the whole range`` () =
+        let rand = Random () |> FloatProducer
+        let randoms = Array.init 100 (fun _ -> rand.Get ()) |> Array.sort
+        for i in 0..9 do
+            let contains =
+                randoms
+                |> Array.exists (fun j -> float i * 0.1 < j && j < float (i + 1) * 0.1)
+            if not contains then failwithf "%i: %+A" i randoms
+            contains
+            |> shouldEqual true
+
+    [<TestCase 1>]
+    [<TestCase 2>]
+    [<TestCase 3>]
+    let ``Floats aren't obviously correlated`` (inputNum : int) =
+        let rand = Random () |> FloatProducer
+        match inputNum with
+        | 1 ->
+            let r1 = rand.Get ()
+            let r2 = rand.Get ()
+            r1 |> shouldNotEqual r2
+        | 2 ->
+            let struct(r1, r2) = rand.GetTwo ()
+            let struct(r3, r4) = rand.GetTwo ()
+            Set.ofList [r1 ; r2 ; r3 ; r4]
+            |> Set.count
+            |> shouldEqual 4
+        | 3 ->
+            let struct(r1, r2, r3) = rand.GetThree ()
+            let struct(r4, r5, r6) = rand.GetThree ()
+            Set.ofList [r1 ; r2 ; r3 ; r4 ; r5 ; r6]
+            |> Set.count
+            |> shouldEqual 6
+        | _ -> failwithf "unrecognised: %i" inputNum

RayTracing.Test/TestSphere.fs

@@ -1,8 +1,10 @@
 namespace RayTracing.Test
 
+open System
 open RayTracing
 open NUnit.Framework
 open FsCheck
+open FsUnitTyped
 
 [<TestFixture>]
 module TestSphere =
@@ -38,3 +40,72 @@ module TestSphere =
         property
         |> Prop.forAll (Arb.fromGen gen)
         |> Check.QuickThrowOnFailure
+
+    [<Test>]
+    let ``Glass sphere perfectly reflects against the edge`` () =
+        let rand = Random () |> FloatProducer
+        let ray = Ray.make (Point.make 0.0 0.0 0.0) (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get)
+        let strikePoint = Point.make 0.0 0.0 1.0
+        let destination =
+            Sphere.reflection
+                (SphereStyle.Glass (1.0<albedo>, Colour.Green, 1.5<ior>, rand))
+                (Point.make 0.0 1.0 1.0)
+                1.0
+                1.0
+                false
+                { LightRay.Ray = ray ; Colour = Colour.White }
+                strikePoint
+
+        match destination with
+        | Continues onward ->
+            onward.Colour |> shouldEqual Colour.Green
+            Point.equal (Ray.origin onward.Ray) strikePoint |> shouldEqual true
+            Vector.equal (Ray.vector onward.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) |> shouldEqual true
+        | Absorbs colour ->
+            failwithf "Absorbed: %+A" colour
+
+    [<Test>]
+    let ``Glass sphere perfectly refracts through the middle`` () =
+        let rand = Random () |> FloatProducer
+        let ray = Ray.make (Point.make 0.0 0.0 0.0) (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get)
+        let strikePoint = Point.make 0.0 0.0 1.0
+        let destination =
+            Sphere.reflection
+                (SphereStyle.Glass (1.0<albedo>, Colour.Green, 1.5<ior>, rand))
+                (Point.make 0.0 0.0 2.0)
+                1.0
+                1.0
+                false
+                { LightRay.Ray = ray ; Colour = Colour.White }
+                strikePoint
+
+        match destination with
+        | Continues onward ->
+            onward.Colour |> shouldEqual Colour.Green
+            Point.equal (Ray.origin onward.Ray) strikePoint |> shouldEqual true
+            Vector.equal (Ray.vector onward.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) |> shouldEqual true
+        | Absorbs colour ->
+            failwithf "Absorbed: %+A" colour
+
+    [<Test>]
+    let ``Dielectric sphere refracts when incoming ray `` () =
+        let rand = Random () |> FloatProducer
+        let ray = Ray.make (Point.make 0.0 0.0 0.0) (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get)
+        let strikePoint = Point.make 0.0 0.0 1.0
+        let destination =
+            Sphere.reflection
+                (SphereStyle.Dielectric (1.0<albedo>, Colour.Green, 1.5<ior>, 1.0<prob>, rand))
+                (Point.make 0.0 0.0 2.0)
+                1.0
+                1.0
+                false
+                { LightRay.Ray = ray ; Colour = Colour.White }
+                strikePoint
+
+        match destination with
+        | Continues onward ->
+            onward.Colour |> shouldEqual Colour.Green
+            Point.equal (Ray.origin onward.Ray) strikePoint |> shouldEqual true
+            Vector.equal (Ray.vector onward.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) |> shouldEqual true
+        | Absorbs colour ->
+            failwithf "Absorbed: %+A" colour

RayTracing/Camera.fs

@@ -30,6 +30,7 @@ module Camera =
 
     /// View angle is in radians (specified arbitrarily)
     let makeBasic
+        (samplesPerPixel : int)
         (focalLength : float)
         (aspectRatio : float)
         (origin : Point)
@@ -51,5 +52,5 @@ module Camera =
             View = view
             ViewportXAxis = xAxis
             ViewportYAxis = yAxis
-            SamplesPerPixel = 60
+            SamplesPerPixel = samplesPerPixel
         }

RayTracing/Float.fs

@@ -11,7 +11,7 @@ type Comparison =
 
 [<RequireQualifiedAccess>]
 module private FloatProducer =
-    let inline generateInt32 (x : byref<int>) (y : byref<int>) (z : byref<int>) (w : byref<int>) =
+    let inline generateInt32 (x : byref<uint>) (y : byref<uint>) (z : byref<uint>) (w : byref<uint>) =
         let t = x ^^^ (x <<< 11)
         x <- y
         y <- z
@@ -19,22 +19,22 @@ module private FloatProducer =
         w <- w ^^^ (w >>> 19) ^^^ (t ^^^ (t >>> 8))
         w
 
-    let inline toInt (w : int) =
-        let highest = (w &&& 0xFF)
-        let secondHighest = ((w >>> 8) &&& 0xFF)
-        let thirdHighest = ((w >>> 16) &&& 0xFF)
-        let lowest = ((w >>> 24) &&& 0xFF)
+    let inline toInt (w : uint) : uint =
+        let highest = (w &&& 0xFFu)
+        let secondHighest = ((w >>> 8) &&& 0xFFu)
+        let thirdHighest = ((w >>> 16) &&& 0xFFu)
+        let lowest = ((w >>> 24) &&& 0xFFu)
         ((highest <<< 24) ^^^ (secondHighest <<< 16) ^^^ (thirdHighest <<< 8) ^^^ lowest)
 
-    let inline toDouble (i : int) =
-        float i / float Int32.MaxValue
+    let inline toDouble (i : uint) =
+        float i / float UInt32.MaxValue
 
 type FloatProducer (rand : Random) =
     let locker = obj ()
-    let mutable x = rand.Next ()
-    let mutable y = rand.Next ()
-    let mutable z = rand.Next ()
-    let mutable w = rand.Next ()
+    let mutable x = uint (rand.Next ())
+    let mutable y = uint (rand.Next ())
+    let mutable z = uint (rand.Next ())
+    let mutable w = uint (rand.Next ())
 
     member __.Get () =
         Monitor.Enter locker

RayTracing/ImageOutput.fs

@@ -3,6 +3,7 @@
 open System
 open System.Collections.Generic
 open System.Collections.Immutable
+open System.Drawing.Imaging
 open System.IO
 open System.IO.Abstractions
 open System.Text
@@ -30,6 +31,17 @@ module PixelOutput =
             let blue = pixel.Blue
             sprintf "%i %i %i" red green blue
 
+    let toSystem (gammaCorrect : bool) (pixel : Pixel) : System.Drawing.Color =
+        if gammaCorrect then
+            let red = correct pixel.Red
+            let green = correct pixel.Green
+            let blue = correct pixel.Blue
+            Drawing.Color.FromArgb (255, int red, int green, int blue)
+        else
+            let red = pixel.Red
+            let green = pixel.Green
+            let blue = pixel.Blue
+            Drawing.Color.FromArgb (255, int red, int green, int blue)
 
 [<RequireQualifiedAccess>]
 module ImageOutput =
@@ -169,3 +181,31 @@ module ImageOutput =
         : IFileInfo * Async<unit>
         =
         resume progressIncrement ImmutableDictionary.Empty image fs
+
+[<RequireQualifiedAccess>]
+module Png =
+
+    let write (gammaCorrect : bool) (incrementProgress : float<progress> -> unit) (pixels : Pixel [] []) (output : IFileInfo) : Async<unit> =
+        let maxRow = pixels.Length
+        let maxCol = pixels.[0].Length
+        async {
+            use img = new System.Drawing.Bitmap (maxCol, maxRow)
+
+            let writeRow (row : int) =
+                for col in 0..pixels.[row].Length - 2 do
+                    let colour = PixelOutput.toSystem gammaCorrect pixels.[row].[col]
+                    img.SetPixel (col, row, colour)
+                    incrementProgress 1.0<progress>
+
+                let colour = PixelOutput.toSystem gammaCorrect pixels.[row].[pixels.[row].Length - 1]
+                img.SetPixel (pixels.[row].Length - 1, row, colour)
+                incrementProgress 1.0<progress>
+
+            for row in 0..pixels.Length - 2 do
+                writeRow row
+            writeRow (pixels.Length - 1)
+
+            use fileStream = output.OpenWrite ()
+            img.Save (fileStream, ImageFormat.Png)
+            return ()
+        }

RayTracing/Pixel.fs

@@ -59,6 +59,15 @@ module Colour =
             Blue = 180uy
         }
 
+    let random (rand : Random) =
+        let buffer = Array.zeroCreate<byte> 3
+        rand.NextBytes buffer
+        {
+            Red = buffer.[0]
+            Green = buffer.[1]
+            Blue = buffer.[2]
+        }
+
 type PixelStats =
     private
         {

RayTracing/RayTracing.fsproj

@@ -21,6 +21,7 @@
     </ItemGroup>
 
     <ItemGroup>
+      <PackageReference Include="System.Drawing.Common" Version="6.0.0-preview.3.21201.4" />
       <PackageReference Include="System.IO.Abstractions" Version="13.2.28" />
     </ItemGroup>
 

RayTracing/Scene.fs

@@ -97,7 +97,9 @@ module Scene =
         : Pixel
         =
         let rec go (bounces : int) (ray : LightRay) : Pixel =
-            if bounces > maxCount then Colour.HotPink else
+            if bounces > maxCount then
+                if ray.Colour = Colour.Black then Colour.Black else Colour.HotPink
+            else
 
             let thingsWeHit = hitObject scene ray.Ray
             match thingsWeHit with
@@ -159,7 +161,7 @@ module Scene =
         let newMean = PixelStats.mean stats
         let difference = Pixel.difference newMean oldMean
 
-        if difference < 2 then
+        if difference = 0 then
            // The mean didn't really change when we added another five samples; assume it's not going to change
            // with more.
            newMean

RayTracing/Sphere.fs

@@ -64,20 +64,24 @@ module Sphere =
         (style : SphereStyle)
         (centre : Point)
         (radius : float)
+        (radiusSquared : float)
+        (flipped : bool)
         (incomingLight : LightRay)
         (strikePoint : Point)
         : LightDestination
         =
         let normal = normal centre strikePoint
-        // If the incoming ray is on the sphere, then we have to be an internal ray.
+
+        // If the incoming ray is on the sphere, then we have to be an internal ray, so the normal is flipped.
+        // But to model a glass shell (not a sphere), we allow negative radius, which contributes a flipping term.
         let inside, normal =
-            match Float.compare (Vector.normSquared (Point.differenceToThenFrom centre (Ray.origin incomingLight.Ray))) (radius * radius) with
+            match Float.compare (Vector.normSquared (Point.differenceToThenFrom centre (Ray.origin incomingLight.Ray))) radiusSquared with
             | Equal
             | Less ->
                 // Point is inside or on the sphere so we are coming from within
-                true, Ray.make (Ray.origin normal) (UnitVector.scale -1.0 (Ray.vector normal) |> UnitVector)
+                if flipped then false, normal else true, Ray.make (Ray.origin normal) (UnitVector.flip (Ray.vector normal))
             | Greater ->
-                false, normal
+                if flipped then true, Ray.make (Ray.origin normal) (UnitVector.flip (Ray.vector normal)) else false, normal
 
         let fuzzedReflection (fuzz : (float<fuzz> * FloatProducer) option) =
             let plane =
@@ -119,9 +123,16 @@ module Sphere =
 
         let refract (incomingCos : float) (index : float<ior>) =
             let index = if inside then 1.0<ior> / index else index / 1.0<ior>
-            let plane = Plane.makeSpannedBy normal incomingLight.Ray
+            let plane =
+                Plane.makeSpannedBy normal incomingLight.Ray
+                |> Plane.orthonormalise
+            match plane with
+            | None ->
+                // Incoming ray was parallel to normal; pass straight through
+                Ray.make strikePoint (Ray.vector incomingLight.Ray)
+            | Some plane ->
             let incomingSin = sqrt (1.0 - incomingCos * incomingCos)
-            let outgoingSin = incomingSin * index
+            let outgoingSin = incomingSin / index
             if Float.compare outgoingSin 1.0 = Greater then
                 // override our decision to refract - from this angle, there's no way we could have refracted
                 fuzzedReflection None
@@ -197,7 +208,7 @@ module Sphere =
                 // reflect!
                 Continues { Ray = fuzzedReflection None ; Colour = newColour }
             else
-                let incomingCos = UnitVector.dot (UnitVector.flip (Ray.vector incomingLight.Ray)) (Ray.vector normal)
+                let incomingCos = UnitVector.dot (Ray.vector incomingLight.Ray) (Ray.vector normal)
                 Continues { Ray = refract incomingCos sphereRefractance ; Colour = newColour }
 
         | SphereStyle.Glass (albedo, colour, sphereRefractance, random) ->
@@ -205,26 +216,28 @@ module Sphere =
                 Pixel.combine incomingLight.Colour colour
                 |> Pixel.darken albedo
 
-            let incomingCos = UnitVector.dot (Ray.vector normal) (UnitVector.flip (Ray.vector incomingLight.Ray))
+            let incomingCos = UnitVector.dot (UnitVector.flip (Ray.vector incomingLight.Ray)) (Ray.vector normal)
 
             let rand = random.Get ()
             let reflectionProb =
+                let sphereRefractance = if inside then 1.0<ior * ior> / sphereRefractance else sphereRefractance
                 let param = (1.0<ior> - sphereRefractance) / (1.0<ior> + sphereRefractance)
                 let param = param * param
                 param + (1.0 - param) * ((1.0 - incomingCos) ** 5.0)
 
-            if LanguagePrimitives.FloatWithMeasure rand > reflectionProb then
+            if LanguagePrimitives.FloatWithMeasure rand < reflectionProb then
                 // reflect!
                 Continues { Ray = fuzzedReflection None ; Colour = newColour }
             else
                 Continues { Ray = refract incomingCos sphereRefractance ; Colour = newColour }
 
     let make (style : SphereStyle) (centre : Point) (radius : float) : Sphere =
+        let radiusSquared = radius * radius
         {
             Centre = centre
             Radius = radius
-            Reflection = reflection style centre radius
-            RadiusSquared = radius * radius
+            Reflection = reflection style centre radius radiusSquared (Float.compare radius 0.0 = Less)
+            RadiusSquared = radiusSquared
         }
 
     let liesOn (point : Point) (sphere : Sphere) : bool =