patrick/ray-tracing-fsharp
1
0
Fork 0
mirror of https://github.com/Smaug123/ray-tracing-fsharp synced 2025-10-08 05:18:43 +00:00
Code Issues Packages Projects Releases Wiki Activity

Replace random number generator

Browse Source
This commit is contained in:
Patrick Stevens
2021-04-17 00:18:19 +01:00
parent 1fe0847a1e
commit c8e514d7ad
12 changed files with 329 additions and 149 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
RayTracing.App/Program.fs
View File

@@ -1,5 +1,6 @@
namespace RayTracing.App
open System.IO
open RayTracing
open System.IO.Abstractions
open Spectre.Console
@@ -16,7 +17,19 @@ module Program =
let readTask = ctx.AddTask "[green]Reading in serialised pixels[/]"
let writeTask = ctx.AddTask "[green]Writing PPM file[/]"
let maxProgress, image = SampleImages.get sample renderTask.Increment
let logFile = ppmOutput.FileSystem.Path.GetTempFileName () |> ppmOutput.FileSystem.FileInfo.FromFileName
use stream = logFile.OpenWrite ()
use writer = new StreamWriter(stream)
writer.AutoFlush <- true
let lockObj = obj ()
let write (s : string) =
lock lockObj (fun () ->
writer.WriteLine s
)
printfn "Log output, if any, to '%s'" logFile.FullName
let maxProgress, image = SampleImages.get sample renderTask.Increment write
renderTask.MaxValue <- maxProgress / 1.0<progress>
writeUnorderedTask.MaxValue <- maxProgress / 1.0<progress>
readTask.MaxValue <- maxProgress / 1.0<progress>

76
RayTracing.App/SampleImages.fs
View File

@@ -9,6 +9,7 @@ type SampleImages =
| FuzzyFloor
| InsideSphere
| TotalRefraction
| HollowDielectric
| MovedCamera
static member Parse (s : string) =
match s with
@@ -19,12 +20,13 @@ type SampleImages =
| "inside-sphere" -> SampleImages.InsideSphere
| "total-refraction" -> SampleImages.TotalRefraction
| "moved-camera" -> SampleImages.MovedCamera
| "hollow-dielectric" -> SampleImages.HollowDielectric
| s -> failwithf "Unrecognised arg: %s" s
[<RequireQualifiedAccess>]
module SampleImages =
let gradient (progressIncrement : float<progress> -> unit) : float<progress> * Image =
let gradient (progressIncrement : float<progress> -> unit) (_ : string -> unit) : float<progress> * Image =
let pixelAt height width =
{
Red = (byte width)
@@ -44,7 +46,7 @@ module SampleImages =
256.0<progress>, image
let shinyPlane (progressIncrement : float<progress> -> unit) : float<progress> * Image =
let shinyPlane (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
let aspectRatio = 16.0 / 9.0
let origin = Point.make 0.0 0.0 0.0
let camera =
@@ -57,9 +59,9 @@ module SampleImages =
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.PureReflection (0.5<albedo>, Colour.White)) (Point.make 0.0 -1.0 0.0) (Vector.make 0.0 1.0 0.0 |> Vector.unitise |> Option.get)) // Floor rug
|]
}
|> Scene.render progressIncrement (aspectRatio * (float pixels) |> int) pixels camera
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let fuzzyPlane (progressIncrement : float<progress> -> unit) : float<progress> * Image =
let fuzzyPlane (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
let random = Random () |> FloatProducer
let aspectRatio = 16.0 / 9.0
let origin = Point.make 0.0 0.0 0.0
@@ -73,9 +75,9 @@ module SampleImages =
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.FuzzedReflection (1.0<albedo>, Colour.White, 0.75<fuzz>, random)) (Point.make 0.0 -1.0 0.0) (Vector.make 0.0 1.0 0.0 |> Vector.unitise |> Option.get)) // Floor rug
|]
}
|> Scene.render progressIncrement (aspectRatio * (float pixels) |> int) pixels camera
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let spheres (progressIncrement : float<progress> -> unit) : float<progress> * Image =
let spheres (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
let random1 = Random () |> FloatProducer
let random2 = Random () |> FloatProducer
let random3 = Random () |> FloatProducer
@@ -105,9 +107,9 @@ module SampleImages =
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.LightSource { Red = 15uy ; Green = 15uy ; Blue = 15uy }) (Point.make 0.0 1.0 -1.0) (Vector.make 0.0 0.0 1.0 |> Vector.unitise |> Option.get))
|]
}
|> Scene.render progressIncrement (aspectRatio * (float pixels) |> int) pixels camera
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let insideSphere (progressIncrement : float<progress> -> unit) : float<progress> * Image =
let insideSphere (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
let random1 = Random () |> FloatProducer
let random2 = Random () |> FloatProducer
let random3 = Random () |> FloatProducer
@@ -134,9 +136,9 @@ module SampleImages =
|]
}
|> Scene.render progressIncrement (aspectRatio * (float pixels) |> int) pixels camera
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let totalRefraction (progressIncrement : float<progress> -> unit) : float<progress> * Image =
let totalRefraction (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
let random = Random () |> FloatProducer
let aspectRatio = 16.0 / 9.0
let origin = Point.make 0.0 0.0 0.0
@@ -154,22 +156,51 @@ module SampleImages =
// 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)
// Left sphere
Hittable.Sphere (Sphere.make (SphereStyle.Dielectric (1.0<albedo>, Colour.White, 0.666<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>, random)) (Point.make -1.0 0.0 1.0) 0.4)
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)
// 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)
|]
}
|> Scene.render progressIncrement (aspectRatio * (float pixels) |> int) pixels camera
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let movedCamera (progressIncrement : float<progress> -> unit) : float<progress> * Image =
let hollowGlassSphere (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
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 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
{
Objects =
[|
// Floor
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 }, 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)
// 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)
|]
}
|> 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 aspectRatio = 16.0 / 9.0
let origin = Point.make -2.0 2.0 -1.0
let camera =
Camera.makeBasic 1.0 aspectRatio origin (Point.differenceToThenFrom (Point.make 0.0 0.0 1.0) origin |> Vector.unitise |> Option.get) (Vector.make 0.0 1.0 0.0)
let pixels = 200
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)
let pixels = 300
{
Objects =
[|
@@ -181,16 +212,16 @@ module SampleImages =
// 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)
// Left sphere
Hittable.Sphere (Sphere.make (SphereStyle.Dielectric (1.0<albedo>, Colour.White, 0.666<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>, random)) (Point.make -1.0 0.0 1.0) 0.4)
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)
// 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)
Hittable.Sphere (Sphere.make (SphereStyle.LightSource { Red = 130uy ; Green = 130uy ; Blue = 200uy }) (Point.make 0.0 0.0 0.0) 200.0)
|]
}
|> Scene.render progressIncrement (aspectRatio * (float pixels) |> int) pixels camera
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let get (s : SampleImages) : (float<progress> -> unit) -> float<progress> * Image =
let get (s : SampleImages) : (float<progress> -> unit) -> (string -> unit) -> float<progress> * Image =
match s with
| Gradient -> gradient
| Spheres -> spheres
@@ -198,6 +229,5 @@ module SampleImages =
| FuzzyFloor -> fuzzyPlane
| InsideSphere -> insideSphere
| TotalRefraction -> totalRefraction
// TODO - the movedCamera image is weird and not right - probably to do with the x and y axes being
// vertical rather than scaled with the lookAt?
| HollowDielectric -> hollowGlassSphere
| MovedCamera -> movedCamera

7
RayTracing.Test/TestRay.fs
View File

@@ -67,3 +67,10 @@ module TestRay =
property
|> Prop.forAll (Arb.fromGen (Gen.zip TestUtils.rayGen (Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit)))
|> Check.QuickThrowOnFailure
[<Test>]
let foo () =
let r = System.Random ()
let fp = FloatProducer r
for i in Array.init 100 (fun _ -> fp.Get ()) |> Array.sort do
printfn "%f" i

2
RayTracing/Camera.fs
View File

@@ -51,5 +51,5 @@ module Camera =
View = view
ViewportXAxis = xAxis
ViewportYAxis = yAxis
SamplesPerPixel = 50
SamplesPerPixel = 60
}

41
RayTracing/Float.fs
View File

@@ -10,21 +10,36 @@ type Comparison =
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 ()
member _.Get () : float =
lock locker (fun () ->
rand.NextDouble ()
)
let generateInt32 () =
let w =
lock locker (fun () ->
let t = x ^^^ (x <<< 11)
x <- y
y <- z
z <- w
w <- w ^^^ (w >>> 19) ^^^ (t ^^^ (t >>> 8))
w
)
let highest = (w &&& 0xFF)
let secondHighest = ((w >>> 8) &&& 0xFF)
let thirdHighest = ((w >>> 16) &&& 0xFF)
let lowest = ((w >>> 24) &&& 0xFF)
((highest <<< 24) ^^^ (secondHighest <<< 16) ^^^ (thirdHighest <<< 8) ^^^ lowest)
member _.GetTwo () : struct(float * float) =
lock locker (fun () ->
rand.NextDouble (), rand.NextDouble()
)
let generateDouble () =
float (generateInt32 ()) / float Int32.MaxValue
member _.Get () : float = generateDouble ()
member _.GetTwo () : struct(float * float) = generateDouble (), generateDouble ()
member _.GetThree () : struct(float * float * float) =
lock locker (fun () ->
rand.NextDouble (), rand.NextDouble(), rand.NextDouble()
)
generateDouble (), generateDouble (), generateDouble ()
[<RequireQualifiedAccess>]
@@ -40,8 +55,8 @@ module Float =
let inline positive (a : float) : bool =
a > tolerance
let inline compare (a : float) (b : float) : Comparison =
if abs (a - b) < tolerance then Comparison.Equal
let inline compare<[<Measure>] 'a> (a : float<'a>) (b : float<'a>) : Comparison =
if abs (a - b) < LanguagePrimitives.FloatWithMeasure tolerance then Comparison.Equal
elif a < b then Comparison.Less
else Comparison.Greater

51
RayTracing/InfinitePlane.fs
View File

@@ -16,10 +16,9 @@ type InfinitePlane =
{
Normal : UnitVector
Point : Point
/// If an incoming ray has the given colour, and hits the
/// given point (which is guaranteed to be on the surface),
/// If an incoming ray hits the given point (which is guaranteed to be on the surface),
/// what colour ray does it output and in what direction?
Reflection : Ray -> Pixel -> Point -> Ray option * Pixel
Reflection : LightRay -> Point -> LightDestination
}
[<RequireQualifiedAccess>]
@@ -43,7 +42,7 @@ module InfinitePlane =
ValueSome t
else ValueNone
let pureOutgoing (strikePoint : Point) (normal : UnitVector) (incomingRay : Ray) : Ray option =
let pureOutgoing (strikePoint : Point) (normal : UnitVector) (incomingRay : Ray) : Ray =
let plane =
Plane.makeSpannedBy (Ray.make strikePoint normal) incomingRay
|> Plane.orthonormalise
@@ -52,7 +51,6 @@ module InfinitePlane =
// Incoming ray is directly along the normal
Ray.flip incomingRay
|> Ray.parallelTo strikePoint
|> Some
| Some plane ->
// Incoming ray is (plane1.ray) plane1 + (plane2.ray) plane2
// We want the reflection in the normal, so need (plane1.ray) plane1 - (plane2.ray) plane2
@@ -63,6 +61,8 @@ module InfinitePlane =
|> Ray.walkAlong (Ray.make (Ray.walkAlong (Ray.make plane.Point plane.V1) normalComponent) plane.V2)
Point.differenceToThenFrom s strikePoint
|> Ray.make' strikePoint
// This is definitely safe. It's actually a logic error if this fails.
|> Option.get
let newColour (incomingColour : Pixel) albedo colour =
Pixel.combine incomingColour colour
@@ -72,27 +72,30 @@ module InfinitePlane =
(style : InfinitePlaneStyle)
(pointOnPlane : Point)
(normal : UnitVector)
: Ray -> Pixel -> Point -> Ray option * Pixel
: LightRay -> Point -> LightDestination
=
fun incomingRay incomingColour strikePoint ->
fun incomingRay strikePoint ->
match style with
| InfinitePlaneStyle.LightSource colour ->
None, Pixel.combine incomingColour colour
Absorbs (Pixel.combine incomingRay.Colour colour)
| InfinitePlaneStyle.FuzzedReflection (albedo, colour, fuzz, rand) ->
let newColour = newColour incomingColour albedo colour
let pureOutgoing = pureOutgoing strikePoint normal incomingRay
let outgoing =
match pureOutgoing with
| None -> None
| Some outgoing ->
let offset = UnitVector.random rand (Point.dimension pointOnPlane)
let sphereCentre = Ray.walkAlong outgoing 1.0
let target = Ray.walkAlong (Ray.make sphereCentre offset) (fuzz / 1.0<fuzz>)
let newColour = newColour incomingRay.Colour albedo colour
let pureOutgoing = pureOutgoing strikePoint normal incomingRay.Ray
let mutable outgoing = Unchecked.defaultof<_>
while obj.ReferenceEquals (outgoing, null) do
let offset = UnitVector.random rand (Point.dimension pointOnPlane)
let sphereCentre = Ray.walkAlong pureOutgoing 1.0
let target = Ray.walkAlong (Ray.make sphereCentre offset) (fuzz / 1.0<fuzz>)
let output =
Point.differenceToThenFrom target strikePoint
|> Ray.make' strikePoint
match output with
| None -> ()
| Some output ->
outgoing <- output
outgoing, newColour
Continues { Ray = outgoing ; Colour = newColour }
| InfinitePlaneStyle.LambertReflection (albedo, colour, rand) ->
let outgoing =
@@ -101,14 +104,19 @@ module InfinitePlane =
let target = Ray.walkAlong (Ray.make sphereCentre offset) 1.0
Point.differenceToThenFrom target strikePoint
|> Ray.make' strikePoint
|> Option.get
let newColour =
Pixel.combine incomingColour colour
Pixel.combine incomingRay.Colour colour
|> Pixel.darken albedo
outgoing, newColour
Continues { Ray = outgoing ; Colour = newColour }
| InfinitePlaneStyle.PureReflection (albedo, colour) ->
pureOutgoing strikePoint normal incomingRay, newColour incomingColour albedo colour
{
Ray = pureOutgoing strikePoint normal incomingRay.Ray
Colour = newColour incomingRay.Colour albedo colour
}
|> Continues
let make (style : InfinitePlaneStyle) (pointOnPlane : Point) (normal : UnitVector) : InfinitePlane =
{
@@ -116,4 +124,3 @@ module InfinitePlane =
Normal = normal
Reflection = reflection style pointOnPlane normal
}

21
RayTracing/LightRay.fs Normal file
View File

@@ -0,0 +1,21 @@
namespace RayTracing
/// Index of refraction of this material.
[<Measure>]
type ior
type LightRay =
{
Ray : Ray
Colour : Pixel
// We have chosen not to include refractance here, because that would mean
// we had to model the material at every point in space rather than just the
// ratio of refractance at the boundaries of objects. (For example, if we
// modelled a light ray leaving a glass sphere, we would have to know what
// material we were leaving *into*, which we can't easily know given the
// current structure of things.)
}
type LightDestination =
| Continues of LightRay
| Absorbs of Pixel

3
RayTracing/Pixel.fs
View File

@@ -1,11 +1,12 @@
namespace RayTracing
open System
open System.Runtime.CompilerServices
[<Measure>]
type albedo
[<Struct>]
[<Struct ; IsReadOnly>]
type Pixel =
{
Red : byte

9
RayTracing/Point.fs
View File

@@ -1,18 +1,21 @@
namespace RayTracing
open System.Runtime.CompilerServices
/// An n-dimensional point.
/// We don't let you compare these for equality, because floats are hard.
[<NoEquality ; NoComparison ; Struct>]
[<NoEquality ; NoComparison ; Struct ; IsReadOnly>]
type Point =
private
| Point of struct(float * float * float)
[<NoEquality ; NoComparison ; Struct>]
[<NoEquality ; NoComparison ; Struct ; IsReadOnly>]
type Vector =
private
| Vector of struct(float * float * float)
type UnitVector = UnitVector of Vector
[<Struct ; IsReadOnly ; NoEquality ; NoComparison>]
type UnitVector = | UnitVector of Vector
[<RequireQualifiedAccess>]
module Vector =

1
RayTracing/RayTracing.fsproj
View File

@@ -12,6 +12,7 @@
<Compile Include="Ray.fsi" />
<Compile Include="Ray.fs" />
<Compile Include="Plane.fs" />
<Compile Include="LightRay.fs" />
<Compile Include="Sphere.fs" />
<Compile Include="InfinitePlane.fs" />
<Compile Include="ImageOutput.fs" />

85
RayTracing/Scene.fs
View File

@@ -6,10 +6,10 @@ type Hittable =
| Sphere of Sphere
| InfinitePlane of InfinitePlane
member this.Reflection (incoming : Ray) (incomingColour : Pixel) (strikePoint : Point) =
member this.Reflection (incoming : LightRay) (strikePoint : Point) =
match this with
| Sphere s -> s.Reflection incoming incomingColour strikePoint
| InfinitePlane p -> p.Reflection incoming incomingColour strikePoint
| Sphere s -> s.Reflection incoming strikePoint
| InfinitePlane p -> p.Reflection incoming strikePoint
[<RequireQualifiedAccess>]
module Hittable =
@@ -57,34 +57,66 @@ module Scene =
if Double.IsNaN bestLength then None else
Some (bestIndex, Ray.walkAlong ray bestLength)
let internal traceRayPrinting
(print : string -> unit)
(maxCount : int)
(scene : Scene)
(ray : LightRay)
: Pixel
=
let rec go (bounces : int) (ray : LightRay) : Pixel =
let (Point(x, y, z)) = Ray.origin ray.Ray
let (UnitVector (Vector(a, b, c))) = Ray.vector ray.Ray
print (sprintf "Ray, colour %i,%i,%i\n origin (%f, %f, %f)\n vector (%f, %f, %f)" ray.Colour.Red ray.Colour.Green ray.Colour.Blue x y z a b c)
if bounces > maxCount then Colour.HotPink else
let thingsWeHit = hitObject scene ray.Ray
match thingsWeHit with
| None ->
print ">>> No object collision; black."
// Ray goes off into the distance and is never heard from again
Colour.Black
| Some (objectNumber, strikePoint) ->
let (Point(x, y, z)) = strikePoint
print (sprintf ">>> collided with object %i at (%f, %f, %f)" objectNumber x y z)
let outgoingRay = scene.Objects.[objectNumber].Reflection ray strikePoint
match outgoingRay with
| Absorbs colour ->
print (sprintf ">>> surface absorbs, yielding colour %i,%i,%i" colour.Red colour.Green colour.Blue)
colour
| Continues outgoingRay ->
print ">>> continuing tracing."
go (bounces + 1) outgoingRay
go 0 ray
let internal traceRay
(maxCount : int)
(scene : Scene)
(ray : Ray)
(colour : Pixel)
(ray : LightRay)
: Pixel
=
let rec go (bounces : int) (ray : Ray) (colour : Pixel) : Pixel =
let rec go (bounces : int) (ray : LightRay) : Pixel =
if bounces > maxCount then Colour.HotPink else
let thingsWeHit = hitObject scene ray
let thingsWeHit = hitObject scene ray.Ray
match thingsWeHit with
| None ->
// Ray goes off into the distance and is never heard from again
Colour.Black
| Some (objectNumber, strikePoint) ->
let outgoingRay, colour = scene.Objects.[objectNumber].Reflection ray colour strikePoint
let outgoingRay = scene.Objects.[objectNumber].Reflection ray strikePoint
match outgoingRay with
| None ->
| Absorbs colour ->
colour
| Some outgoingRay ->
go (bounces + 1) outgoingRay colour
| Continues outgoingRay ->
go (bounces + 1) outgoingRay
go 0 ray colour
go 0 ray
/// Trace a ray to this one pixel, updating the PixelStats with the result.
/// n.b. not thread safe
let private traceOnce (scene : Scene) (rand : FloatProducer) (camera : Camera) (maxWidthCoord : int) (maxHeightCoord : int) row col stats =
let private traceOnce (print : string -> unit) (scene : Scene) (rand : FloatProducer) (camera : Camera) (maxWidthCoord : int) (maxHeightCoord : int) row col stats =
let struct(rand1, rand2) = rand.GetTwo ()
let landingPoint =
((float col + rand1) * camera.ViewportWidth) / float maxWidthCoord
@@ -99,22 +131,30 @@ module Scene =
Ray.make' (Ray.origin camera.View) (Point.differenceToThenFrom endPoint (Ray.origin camera.View))
|> Option.get
let result = traceRay 150 scene ray Colour.White
// Here we've hardcoded that the eye is emitting white light through a medium with refractance 1.
let result = traceRay 150 scene { Ray = ray ; Colour = Colour.White }
//if result = Colour.HotPink then
// print "hi"
// traceRayPrinting print 150 scene { Ray = ray ; Colour = Colour.White ; Refractance = 1.0<ior> }
// |> ignore
// failwith "Stopping."
PixelStats.add result stats
let renderPixel (scene : Scene) (rand : FloatProducer) (camera : Camera) maxWidthCoord maxHeightCoord row col =
let renderPixel (print : string -> unit) (scene : Scene) (rand : FloatProducer) (camera : Camera) maxWidthCoord maxHeightCoord row col =
// Where does this pixel correspond to, on the imaginary canvas?
// For the early prototype, we'll just take the upper right quadrant
// from the camera.
let stats = PixelStats.empty ()
for _ in 1..5 do
traceOnce scene rand camera maxWidthCoord maxHeightCoord row col stats
let firstTrial = min 5 (camera.SamplesPerPixel / 2)
for _ in 0..firstTrial do
traceOnce print scene rand camera maxWidthCoord maxHeightCoord row col stats
let oldMean = PixelStats.mean stats
for _ in 1..5 do
traceOnce scene rand camera maxWidthCoord maxHeightCoord row col stats
for _ in 1..firstTrial do
traceOnce print scene rand camera maxWidthCoord maxHeightCoord row col stats
let newMean = PixelStats.mean stats
let difference = Pixel.difference newMean oldMean
@@ -125,13 +165,14 @@ module Scene =
newMean
else
for _ in 1..camera.SamplesPerPixel - 10 do
traceOnce scene rand camera maxWidthCoord maxHeightCoord row col stats
for _ in 1..(camera.SamplesPerPixel - 2 * firstTrial - 1) do
traceOnce print scene rand camera maxWidthCoord maxHeightCoord row col stats
PixelStats.mean stats
let render
(progressIncrement : float<progress> -> unit)
(print : string -> unit)
(maxWidthCoord : int)
(maxHeightCoord : int)
(camera : Camera)
@@ -153,7 +194,7 @@ module Scene =
Array.init colsIter (fun col ->
let col = col - maxWidthCoord
async {
let ret = renderPixel s rand camera maxWidthCoord maxHeightCoord row col
let ret = renderPixel print s rand camera maxWidthCoord maxHeightCoord row col
progressIncrement 1.0<progress>
return ret
}

167
RayTracing/Sphere.fs
View File

@@ -3,10 +3,6 @@ namespace RayTracing
[<Measure>]
type fuzz
/// Index of refraction. Must be greater than or equal to 1.
[<Measure>]
type ior
/// A probability, between 0 and 1.
[<Measure>]
type prob
@@ -19,7 +15,7 @@ type Sphere =
/// If an incoming ray has the given colour, and hits the
/// given point (which is guaranteed to be on the surface),
/// what colour ray does it output and in what direction?
Reflection : Ray -> Pixel -> Point -> Ray option * Pixel
Reflection : LightRay -> Point -> LightDestination
RadiusSquared : float
}
@@ -39,10 +35,13 @@ type SphereStyle =
/// surface is the same regardless of the angle of view.
/// Albedo must be between 0 and 1.
| LambertReflection of albedo : float<albedo> * colour : Pixel * FloatProducer
/// A refracting sphere with the given ratio `ior` of its index of refraction with that of the surrounding
/// medium.
/// A refracting sphere with the given ratio `ior` of its index of refraction with that of the medium on
/// the other side of the surface. The convention is such that a solid sphere, with a light ray
/// entering from outside, should have index of refraction greater than 1.
/// The probability is the probability that a ray will refract, so 0 yields a perfectly reflecting sphere.
| Dielectric of albedo : float<albedo> * colour : Pixel * float<ior> * reflection : float<prob> * FloatProducer
| Dielectric of albedo : float<albedo> * colour : Pixel * boundaryRefractance : float<ior> * refraction : float<prob> * FloatProducer
/// A glass material which uses Schlick's approximation for reflectance probability.
| Glass of albedo : float<albedo> * colour : Pixel * float<ior> * FloatProducer
type Orientation =
| Inside
@@ -57,24 +56,22 @@ module Sphere =
Ray.make' p (Point.differenceToThenFrom p centre)
|> Option.get
let private liesOn' (centre : Point) (radius : float) : Point -> bool =
let private liesOn' (centre : Point) (radius : float) (p : Point) : bool =
let rSquared = radius * radius
fun p ->
Float.equal (Vector.normSquared (Point.differenceToThenFrom p centre)) rSquared
Float.equal (Vector.normSquared (Point.differenceToThenFrom p centre)) rSquared
let reflection
(style : SphereStyle)
(centre : Point)
(radius : float)
(incomingRay : Ray)
(incomingColour : Pixel)
(incomingLight : LightRay)
(strikePoint : Point)
: Ray option * Pixel
: LightDestination
=
let normal = normal centre strikePoint
// If the incoming ray is on the sphere, then we have to be an internal ray.
let inside, normal =
match Float.compare (Vector.normSquared (Point.differenceToThenFrom centre (Ray.origin incomingRay))) (radius * radius) with
match Float.compare (Vector.normSquared (Point.differenceToThenFrom centre (Ray.origin incomingLight.Ray))) (radius * radius) with
| Equal
| Less ->
// Point is inside or on the sphere so we are coming from within
@@ -82,45 +79,67 @@ module Sphere =
| Greater ->
false, normal
let fuzzedReflection (colour : Pixel) (albedo : float<albedo>) (fuzz : (float<fuzz> * FloatProducer) option) =
let fuzzedReflection (fuzz : (float<fuzz> * FloatProducer) option) =
let plane =
Plane.makeSpannedBy normal incomingRay
Plane.makeSpannedBy normal incomingLight.Ray
|> Plane.orthonormalise
let outgoing =
match plane with
| None ->
// Incoming ray is directly along the normal
Ray.flip incomingRay
Ray.flip incomingLight.Ray
|> Ray.parallelTo strikePoint
|> Some
| Some plane ->
// Incoming ray is (plane1.ray) plane1 + (plane2.ray) plane2
// We want the reflection in the normal, so need (plane1.ray) plane1 - (plane2.ray) plane2
let normalComponent = - UnitVector.dot plane.V1 (Ray.vector incomingRay)
let tangentComponent = (UnitVector.dot plane.V2 (Ray.vector incomingRay))
let normalComponent = - UnitVector.dot plane.V1 (Ray.vector incomingLight.Ray)
let tangentComponent = (UnitVector.dot plane.V2 (Ray.vector incomingLight.Ray))
let dest = Ray.walkAlong (Ray.make (Ray.walkAlong (Ray.make plane.Point plane.V1) normalComponent) plane.V2) tangentComponent
Point.differenceToThenFrom dest strikePoint
|> Ray.make' strikePoint
// This is safe: it's actually a logic error for this to fail.
|> Option.get
let outgoing =
match outgoing, fuzz with
| None, _ -> None
| Some outgoing, None -> Some outgoing
| Some outgoing, Some (fuzz, rand) ->
match fuzz with
| None -> outgoing
| Some (fuzz, rand) ->
let mutable answer = Unchecked.defaultof<_>
while obj.ReferenceEquals (answer, null) do
let offset = UnitVector.random rand (Point.dimension centre)
let sphereCentre = Ray.walkAlong outgoing 1.0
let target = Ray.walkAlong (Ray.make sphereCentre offset) (fuzz / 1.0<fuzz>)
Point.differenceToThenFrom target strikePoint
|> Ray.make' strikePoint
let exitPoint =
Point.differenceToThenFrom target strikePoint
|> Ray.make' strikePoint
match exitPoint with
| None -> ()
| Some o ->
answer <- o
answer
let darkened =
Pixel.combine incomingColour colour
|> Pixel.darken albedo
outgoing, darkened
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 incomingSin = sqrt (1.0 - incomingCos * incomingCos)
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
else
let outgoingCos = sqrt (1.0 - outgoingSin * outgoingSin)
let outgoingPoint =
Ray.walkAlong (Ray.make (Ray.walkAlong normal (-outgoingCos)) plane.V2) outgoingSin
Point.differenceToThenFrom outgoingPoint strikePoint
|> Ray.make' strikePoint
// This is safe: it's a logic error for this to fail. It would imply both the
// cos and the sin outgoing components were 0.
|> Option.get
match style with
| SphereStyle.LightSource colour ->
None, Pixel.combine incomingColour colour
Absorbs (Pixel.combine incomingLight.Colour colour)
| SphereStyle.LightSourceCap colour ->
let circleCentreZCoord = Point.xCoordinate centre
let zCoordLowerBound = circleCentreZCoord + (radius - (radius / 4.0))
@@ -128,55 +147,77 @@ module Sphere =
let colour =
match Float.compare strikeZCoord zCoordLowerBound with
| Greater ->
Pixel.combine colour incomingColour
Pixel.combine colour incomingLight.Colour
| _ ->
Colour.Black
None, colour
Absorbs colour
| SphereStyle.LambertReflection (albedo, colour, rand) ->
let outgoing =
let sphereCentre = Ray.walkAlong normal 1.0
let offset = UnitVector.random rand (Point.dimension sphereCentre)
let target = Ray.walkAlong (Ray.make sphereCentre offset) 1.0
Point.differenceToThenFrom target strikePoint
|> Ray.make' strikePoint
let mutable answer = Unchecked.defaultof<_>
while obj.ReferenceEquals (answer, null) do
let offset = UnitVector.random rand (Point.dimension sphereCentre)
let target = Ray.walkAlong (Ray.make sphereCentre offset) 1.0
let outputPoint =
Point.differenceToThenFrom target strikePoint
|> Ray.make' strikePoint
match outputPoint with
| Some o -> answer <- o
| None -> ()
answer
let newColour =
Pixel.combine incomingColour colour
Pixel.combine incomingLight.Colour colour
|> Pixel.darken albedo
outgoing, newColour
Continues { Ray = outgoing ; Colour = newColour }
| SphereStyle.PureReflection (albedo, colour) ->
fuzzedReflection colour albedo None
| SphereStyle.FuzzedReflection (albedo, colour, fuzz, random) ->
fuzzedReflection colour albedo (Some (fuzz, random))
let darkened =
Pixel.combine incomingLight.Colour colour
|> Pixel.darken albedo
| SphereStyle.Dielectric (albedo, colour, index, reflectionProb, random) ->
Continues { Ray = fuzzedReflection None ; Colour = darkened }
| SphereStyle.FuzzedReflection (albedo, colour, fuzz, random) ->
let darkened =
Pixel.combine incomingLight.Colour colour
|> Pixel.darken albedo
Continues { Ray = fuzzedReflection (Some (fuzz, random)) ; Colour = darkened }
| SphereStyle.Dielectric (albedo, colour, sphereRefractance, refractionProb, random) ->
let newColour =
Pixel.combine incomingColour colour
Pixel.combine incomingLight.Colour colour
|> Pixel.darken albedo
let rand = random.Get ()
if LanguagePrimitives.FloatWithMeasure rand > refractionProb then
// reflect!
Continues { Ray = fuzzedReflection None ; Colour = newColour }
else
let incomingCos = UnitVector.dot (UnitVector.flip (Ray.vector incomingLight.Ray)) (Ray.vector normal)
Continues { Ray = refract incomingCos sphereRefractance ; Colour = newColour }
| SphereStyle.Glass (albedo, colour, sphereRefractance, random) ->
let newColour =
Pixel.combine incomingLight.Colour colour
|> Pixel.darken albedo
let incomingCos = UnitVector.dot (Ray.vector normal) (UnitVector.flip (Ray.vector incomingLight.Ray))
let rand = random.Get ()
let reflectionProb =
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
// reflect!
fuzzedReflection colour albedo None
Continues { Ray = fuzzedReflection None ; Colour = newColour }
else
let index = if inside then 1.0<ior>/index else index / 1.0<ior>
let plane = Plane.makeSpannedBy normal incomingRay
let incomingCos = UnitVector.dot (Ray.vector incomingRay) (Ray.vector normal)
let incomingSin = sqrt (1.0 - incomingCos * incomingCos)
let outgoingSin = index * incomingSin
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 colour albedo None
else
let outgoingCos = sqrt (1.0 - outgoingSin * outgoingSin)
let outgoingPoint =
Ray.walkAlong (Ray.make (Ray.walkAlong normal (-outgoingCos)) plane.V2) outgoingSin
let outgoing = Point.differenceToThenFrom outgoingPoint strikePoint |> Ray.make' strikePoint |> Option.get
Some outgoing, newColour
Continues { Ray = refract incomingCos sphereRefractance ; Colour = newColour }
let make (style : SphereStyle) (centre : Point) (radius : float) : Sphere =
{