diff --git a/RayTracing.Test/TestSphere.fs b/RayTracing.Test/TestSphere.fs index b707eaf..2a841ad 100644 --- a/RayTracing.Test/TestSphere.fs +++ b/RayTracing.Test/TestSphere.fs @@ -45,6 +45,12 @@ module TestSphere = let strikePoint = Point.make 0.0 0.0 1.0 + let mutable incoming = + { + LightRay.Ray = ray + Colour = Colour.White + } + let destination = Sphere.reflection (SphereStyle.Glass (1.0, Texture.Colour Colour.Green, 1.5, rand)) @@ -52,20 +58,17 @@ module TestSphere = 1.0 1.0 false - { - LightRay.Ray = ray - Colour = Colour.White - } + &incoming strikePoint match destination with - | Continues onward -> - onward.Colour |> shouldEqual Colour.Green - Point.equal (Ray.origin onward.Ray) strikePoint |> shouldEqual true + | ValueNone -> + incoming.Colour |> shouldEqual Colour.Green + Point.equal (Ray.origin incoming.Ray) strikePoint |> shouldEqual true - Vector.equal (Ray.vector onward.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) + Vector.equal (Ray.vector incoming.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) |> shouldEqual true - | Absorbs colour -> failwithf "Absorbed: %+A" colour + | ValueSome colour -> failwithf "Absorbed: %+A" colour [] let ``Glass sphere perfectly refracts through the middle`` () = @@ -76,6 +79,12 @@ module TestSphere = let strikePoint = Point.make 0.0 0.0 1.0 + let mutable incoming = + { + LightRay.Ray = ray + Colour = Colour.White + } + let destination = Sphere.reflection (SphereStyle.Glass (1.0, Texture.Colour Colour.Green, 1.5, rand)) @@ -83,20 +92,17 @@ module TestSphere = 1.0 1.0 false - { - LightRay.Ray = ray - Colour = Colour.White - } + &incoming strikePoint match destination with - | Continues onward -> - onward.Colour |> shouldEqual Colour.Green - Point.equal (Ray.origin onward.Ray) strikePoint |> shouldEqual true + | ValueNone -> + incoming.Colour |> shouldEqual Colour.Green + Point.equal (Ray.origin incoming.Ray) strikePoint |> shouldEqual true - Vector.equal (Ray.vector onward.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) + Vector.equal (Ray.vector incoming.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) |> shouldEqual true - | Absorbs colour -> failwithf "Absorbed: %+A" colour + | ValueSome colour -> failwithf "Absorbed: %+A" colour [] let ``Dielectric sphere refracts when incoming ray `` () = @@ -107,6 +113,12 @@ module TestSphere = let strikePoint = Point.make 0.0 0.0 1.0 + let mutable incoming = + { + LightRay.Ray = ray + Colour = Colour.White + } + let destination = Sphere.reflection (SphereStyle.Dielectric (1.0, Texture.Colour Colour.Green, 1.5, 1.0, rand)) @@ -114,20 +126,17 @@ module TestSphere = 1.0 1.0 false - { - LightRay.Ray = ray - Colour = Colour.White - } + &incoming strikePoint match destination with - | Continues onward -> - onward.Colour |> shouldEqual Colour.Green - Point.equal (Ray.origin onward.Ray) strikePoint |> shouldEqual true + | ValueNone -> + incoming.Colour |> shouldEqual Colour.Green + Point.equal (Ray.origin incoming.Ray) strikePoint |> shouldEqual true - Vector.equal (Ray.vector onward.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) + Vector.equal (Ray.vector incoming.Ray |> UnitVector.scale 1.0) (Ray.vector ray |> UnitVector.scale 1.0) |> shouldEqual true - | Absorbs colour -> failwithf "Absorbed: %+A" colour + | ValueSome colour -> failwithf "Absorbed: %+A" colour [] let ``Test planeMap`` () = diff --git a/RayTracing/Hittable.fs b/RayTracing/Hittable.fs index dfc1b16..2465526 100644 --- a/RayTracing/Hittable.fs +++ b/RayTracing/Hittable.fs @@ -5,11 +5,11 @@ type Hittable = | UnboundedSphere of Sphere | InfinitePlane of InfinitePlane - member this.Reflection (incoming : LightRay) (strikePoint : Point) = + member this.Reflection (incoming : byref, strikePoint : Point) = match this with | Sphere s - | UnboundedSphere s -> s.Reflection incoming strikePoint - | InfinitePlane p -> p.Reflection incoming strikePoint + | UnboundedSphere s -> s.Reflection (&incoming, strikePoint) + | InfinitePlane p -> p.Reflection (&incoming, strikePoint) member this.BoundingBox : BoundingBox voption = match this with diff --git a/RayTracing/InfinitePlane.fs b/RayTracing/InfinitePlane.fs index 1dad9eb..c34972b 100644 --- a/RayTracing/InfinitePlane.fs +++ b/RayTracing/InfinitePlane.fs @@ -12,39 +12,11 @@ type InfinitePlaneStyle = | LambertReflection of albedo : float * colour : Pixel * FloatProducer | FuzzedReflection of albedo : float * colour : Pixel * fuzz : float * FloatProducer -type InfinitePlane = - { - Normal : UnitVector - Point : Point - /// 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 : LightRay -> Point -> LightDestination - } - [] module InfinitePlane = - /// Returns the position along this ray where we intersect this plane, or None if none exists or the ray is in the plane. - /// Does not return any intersections which are behind us. - /// If the plane is made of a material which does not re-emit light, you'll - /// get a None for the outgoing ray. - let intersection (plane : InfinitePlane) (ray : Ray) : float voption = - let rayVec = Ray.vector ray - let denominator = UnitVector.dot plane.Normal rayVec - - if Float.equal denominator 0.0 then - ValueNone - else - let t = - (UnitVector.dot' plane.Normal (Point.differenceToThenFrom plane.Point (Ray.origin ray))) - / denominator - - if Float.positive t then ValueSome t else ValueNone - let pureOutgoing (strikePoint : Point) (normal : UnitVector) (incomingRay : Ray) : Ray = - let plane = - Plane.makeSpannedBy (Ray.make strikePoint normal) incomingRay - |> Plane.orthonormalise + let plane = Plane.makeOrthonormalSpannedBy (Ray.make strikePoint normal) incomingRay match plane with | ValueNone -> @@ -72,65 +44,93 @@ module InfinitePlane = (style : InfinitePlaneStyle) (pointOnPlane : Point) (normal : UnitVector) - : LightRay -> Point -> LightDestination + (incomingRay : byref) + (strikePoint : Point) + : Pixel ValueOption = - fun incomingRay strikePoint -> - match style with - | InfinitePlaneStyle.LightSource texture -> - texture - |> Texture.colourAt strikePoint - |> Pixel.combine incomingRay.Colour - |> Absorbs + match style with + | InfinitePlaneStyle.LightSource texture -> + texture + |> Texture.colourAt strikePoint + |> Pixel.combine incomingRay.Colour + |> ValueSome - | InfinitePlaneStyle.FuzzedReflection (albedo, colour, fuzz, rand) -> - let newColour = newColour incomingRay.Colour albedo colour - let pureOutgoing = pureOutgoing strikePoint normal incomingRay.Ray - let mutable outgoing = Unchecked.defaultof<_> + | InfinitePlaneStyle.FuzzedReflection (albedo, colour, fuzz, rand) -> + 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) - let output = Point.differenceToThenFrom target strikePoint |> Ray.make' strikePoint + 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) + let output = Point.differenceToThenFrom target strikePoint |> Ray.make' strikePoint - match output with - | ValueNone -> () - | ValueSome output -> outgoing <- output + match output with + | ValueNone -> () + | ValueSome output -> outgoing <- output - Continues - { - Ray = outgoing - Colour = newColour - } + incomingRay.Colour <- newColour + incomingRay.Ray <- outgoing - | InfinitePlaneStyle.LambertReflection (albedo, colour, rand) -> - let outgoing = - let sphereCentre = Ray.walkAlong (Ray.make strikePoint normal) 1.0 - let offset = UnitVector.random rand (Point.dimension pointOnPlane) - let target = Ray.walkAlong (Ray.make sphereCentre offset) 1.0 + ValueNone - Point.differenceToThenFrom target strikePoint - |> Ray.make' strikePoint - |> ValueOption.get + | InfinitePlaneStyle.LambertReflection (albedo, colour, rand) -> + let outgoing = + let sphereCentre = Ray.walkAlong (Ray.make strikePoint normal) 1.0 + let offset = UnitVector.random rand (Point.dimension pointOnPlane) + let target = Ray.walkAlong (Ray.make sphereCentre offset) 1.0 - let newColour = Pixel.combine incomingRay.Colour colour |> Pixel.darken albedo + Point.differenceToThenFrom target strikePoint + |> Ray.make' strikePoint + |> ValueOption.get - Continues - { - Ray = outgoing - Colour = newColour - } + let newColour = Pixel.combine incomingRay.Colour colour |> Pixel.darken albedo - | InfinitePlaneStyle.PureReflection (albedo, colour) -> - { - Ray = pureOutgoing strikePoint normal incomingRay.Ray - Colour = newColour incomingRay.Colour albedo colour - } - |> Continues + incomingRay.Colour <- newColour + incomingRay.Ray <- outgoing - let make (style : InfinitePlaneStyle) (pointOnPlane : Point) (normal : UnitVector) : InfinitePlane = + ValueNone + + | InfinitePlaneStyle.PureReflection (albedo, colour) -> + incomingRay.Colour <- newColour incomingRay.Colour albedo colour + incomingRay.Ray <- pureOutgoing strikePoint normal incomingRay.Ray + + ValueNone + +type InfinitePlane = + { + Style : InfinitePlaneStyle + Normal : UnitVector + Point : Point + } + + /// If an incoming ray hits the given point (which is guaranteed to be on the surface), + /// is it absorbed (if so, returns Some(the colour of light)), or does it bounce off + /// (if so, returns None and mutates the input ray to the new reflected ray)? + member this.Reflection (ray : byref, strikePoint : Point) : Pixel ValueOption = + InfinitePlane.reflection this.Style this.Point this.Normal &ray strikePoint + + static member make (style : InfinitePlaneStyle) (pointOnPlane : Point) (normal : UnitVector) : InfinitePlane = { Point = pointOnPlane + Style = style Normal = normal - Reflection = reflection style pointOnPlane normal } + + /// Returns the position along this ray where we intersect this plane, or None if none exists or the ray is in the plane. + /// Does not return any intersections which are behind us. + /// If the plane is made of a material which does not re-emit light, you'll + /// get a None for the outgoing ray. + static member intersection (plane : InfinitePlane) (ray : Ray) : float voption = + let rayVec = Ray.vector ray + let denominator = UnitVector.dot plane.Normal rayVec + + if Float.equal denominator 0.0 then + ValueNone + else + let t = + (UnitVector.dot' plane.Normal (Point.differenceToThenFrom plane.Point (Ray.origin ray))) + / denominator + + if Float.positive t then ValueSome t else ValueNone diff --git a/RayTracing/LightRay.fs b/RayTracing/LightRay.fs index f47181c..9fac9ad 100644 --- a/RayTracing/LightRay.fs +++ b/RayTracing/LightRay.fs @@ -6,14 +6,14 @@ 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.) + // 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.) + mutable Ray : Ray + mutable Colour : Pixel } type LightDestination = diff --git a/RayTracing/Plane.fs b/RayTracing/Plane.fs index ad280e2..56236d7 100644 --- a/RayTracing/Plane.fs +++ b/RayTracing/Plane.fs @@ -61,6 +61,23 @@ module Plane = Point = Ray.origin r1 } + let makeOrthonormalSpannedBy (r1 : Ray) (r2 : Ray) : OrthonormalPlane ValueOption = + let coefficient = UnitVector.dot r1.Vector r2.Vector + + let vec2 = + UnitVector.difference' r2.Vector (UnitVector.scale coefficient r1.Vector) + |> Vector.unitise + + match vec2 with + | ValueNone -> ValueNone + | ValueSome v2 -> + { + V1 = r1.Vector + V2 = v2 + Point = Ray.origin r1 + } + |> ValueSome + /// Construct a basis for this plane, whose second ("up") component is `viewUp` when projected onto the plane. let basis (viewUp : Vector) (plane : OrthonormalPlane) : Ray * Ray = let viewUp = Vector.unitise viewUp |> ValueOption.get diff --git a/RayTracing/Ray.fs b/RayTracing/Ray.fs index 73e2838..25b19af 100644 --- a/RayTracing/Ray.fs +++ b/RayTracing/Ray.fs @@ -2,12 +2,27 @@ namespace RayTracing type Ray = { - Origin : Point - Vector : UnitVector + mutable Origin : Point + mutable Vector : UnitVector } [] module Ray = + let overwriteWithMake (origin : Point) (vector : Vector) (ray : byref) : bool = + let dot = Vector.dot vector vector + + if Float.equal dot 0.0 then + false + else + + ray.Origin <- origin + + ray.Vector <- + let factor = 1.0 / sqrt dot + Vector.scale factor vector |> UnitVector + + true + let make' (origin : Point) (vector : Vector) : Ray voption = match Vector.unitise vector with | ValueNone -> ValueNone @@ -24,18 +39,20 @@ module Ray = Vector = vector } - let walkAlong (ray : Ray) (magnitude : float) : Point = - let (Point (oX, oY, oZ)) = ray.Origin - let (UnitVector (Vector (vX, vY, vZ))) = ray.Vector - + let walkAlongRay (Point (oX, oY, oZ)) (UnitVector (Vector (vX, vY, vZ))) (magnitude : float) : Point = Point.make (oX + (vX * magnitude)) (oY + (vY * magnitude)) (oZ + (vZ * magnitude)) + let walkAlong (ray : Ray) (magnitude : float) : Point = + walkAlongRay ray.Origin ray.Vector magnitude + let parallelTo (p1 : Point) (ray : Ray) : Ray = { Vector = ray.Vector Origin = p1 } + let translateToIntersect (p1 : Point) (ray : Ray) : unit = ray.Origin <- p1 + let liesOn (point : Point) (ray : Ray) : bool = match point, ray.Origin, ray.Vector with | Point (p1, p2, p3), Point (o1, o2, o3), UnitVector (Vector (r1, r2, r3)) -> @@ -58,3 +75,7 @@ module Ray = let (UnitVector v) = r.Vector Vector.scale -1.0 v |> UnitVector } + + let flipInPlace (r : Ray) : unit = + let (UnitVector v) = r.Vector + r.Vector <- Vector.scale -1.0 v |> UnitVector diff --git a/RayTracing/Ray.fsi b/RayTracing/Ray.fsi index 2b5a383..2ef4e4a 100644 --- a/RayTracing/Ray.fsi +++ b/RayTracing/Ray.fsi @@ -3,9 +3,9 @@ namespace RayTracing type Ray = { /// For performance reasons, this is public, but please don't use it - Origin : Point + mutable Origin : Point /// For performance reasons, this is public, but please don't use it - Vector : UnitVector + mutable Vector : UnitVector } [] @@ -13,9 +13,16 @@ module Ray = val make' : Point -> Vector -> Ray voption val make : Point -> UnitVector -> Ray + /// If we can make a ray from Point and Vector, overwrite the input and return true. + /// Otherwise do nothing and return false. + val overwriteWithMake : Point -> Vector -> byref -> bool + val walkAlong : Ray -> float -> Point + val walkAlongRay : Point -> UnitVector -> float -> Point + val parallelTo : Point -> Ray -> Ray + val translateToIntersect : Point -> Ray -> unit val liesOn : Point -> Ray -> bool @@ -23,3 +30,4 @@ module Ray = val inline origin : Ray -> Point val flip : Ray -> Ray + val flipInPlace : Ray -> unit diff --git a/RayTracing/Scene.fs b/RayTracing/Scene.fs index 0d28946..d06a6ae 100644 --- a/RayTracing/Scene.fs +++ b/RayTracing/Scene.fs @@ -59,7 +59,7 @@ module Scene = else struct (bestFloat, bestObject, bestLength) - let hitObject (s : Scene) (ray : Ray) : (Hittable * Point) voption = + let hitObject (s : Scene) (ray : Ray) : struct (Hittable * Point) voption = let mutable best = Unchecked.defaultof<_> let mutable bestLength = nan let mutable bestFloat = infinity @@ -88,31 +88,30 @@ module Scene = if Double.IsNaN bestLength then ValueNone else - ValueSome (best, Ray.walkAlong ray bestLength) + ValueSome (struct (best, Ray.walkAlong ray bestLength)) - let internal traceRay (maxCount : int) (scene : Scene) (ray : LightRay) : Pixel = - let rec go (bounces : int) (ray : LightRay) : Pixel = - if bounces > maxCount then - if ray.Colour = Colour.Black then - Colour.Black - else - Colour.HotPink - else + let internal traceRay (maxCount : int) (scene : Scene) (ray : byref) : Pixel = + let mutable bounces = 0 + let mutable result = Colour.Black + let mutable isDone = false + while bounces <= maxCount && not isDone do let thingsWeHit = hitObject scene ray.Ray match thingsWeHit with | ValueNone -> // Ray goes off into the distance and is never heard from again - Colour.Black + isDone <- true | ValueSome (object, strikePoint) -> - let outgoingRay = object.Reflection ray strikePoint + let stopWithColour = object.Reflection (&ray, strikePoint) - match outgoingRay with - | Absorbs colour -> colour - | Continues outgoingRay -> go (bounces + 1) outgoingRay + match stopWithColour with + | ValueSome colour -> + isDone <- true + result <- colour + | ValueNone -> bounces <- bounces + 1 - go 0 ray + if not isDone then Colour.HotPink else result /// Trace a ray to this one pixel, updating the PixelStats with the result. /// n.b. not thread safe @@ -122,35 +121,36 @@ module Scene = (camera : Camera) (maxWidthCoord : int) (maxHeightCoord : int) - row - col - stats + (row : int) + (col : int) + (stats : PixelStats) + : unit = let struct (rand1, rand2) = rand.GetTwo () let landingPoint = ((float col + rand1) * camera.ViewportWidth) / float maxWidthCoord - let pointOnXAxis = landingPoint |> Ray.walkAlong camera.ViewportXAxis - let toWalkUp = Ray.parallelTo pointOnXAxis camera.ViewportYAxis + let pointOnXAxis = Ray.walkAlong camera.ViewportXAxis landingPoint + + let walkDistance = + ((float row + rand2) * camera.ViewportHeight) / float maxHeightCoord let endPoint = - ((float row + rand2) * camera.ViewportHeight) / float maxHeightCoord - |> Ray.walkAlong toWalkUp + Ray.walkAlongRay pointOnXAxis camera.ViewportYAxis.Vector walkDistance let ray = Ray.make' (Ray.origin camera.View) (Point.differenceToThenFrom endPoint (Ray.origin camera.View)) |> ValueOption.get + let mutable initialRay = + { + Ray = ray + Colour = Colour.White + } + // Here we've hardcoded that the eye is emitting white light through a medium with refractance 1. - let result = - traceRay - camera.BounceDepth - scene - { - Ray = ray - Colour = Colour.White - } + let result = traceRay camera.BounceDepth scene &initialRay PixelStats.add result stats @@ -171,12 +171,12 @@ module Scene = let firstTrial = min 5 (camera.SamplesPerPixel / 2) - for _ in 0..firstTrial do + for _ = 0 to firstTrial do traceOnce scene rand camera maxWidthCoord maxHeightCoord row col stats let oldMean = PixelStats.mean stats - for _ in 1..firstTrial do + for _ = 1 to firstTrial do traceOnce scene rand camera maxWidthCoord maxHeightCoord row col stats let newMean = PixelStats.mean stats @@ -188,7 +188,7 @@ module Scene = newMean else - for _ in 1 .. (camera.SamplesPerPixel - 2 * firstTrial - 1) do + for _ = 1 to (camera.SamplesPerPixel - 2 * firstTrial - 1) do traceOnce scene rand camera maxWidthCoord maxHeightCoord row col stats PixelStats.mean stats diff --git a/RayTracing/Sphere.fs b/RayTracing/Sphere.fs index 30bdf54..3492aae 100644 --- a/RayTracing/Sphere.fs +++ b/RayTracing/Sphere.fs @@ -7,19 +7,6 @@ type fuzz [] type prob -type Sphere = - private - { - Centre : Point - Radius : float - /// 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 : LightRay -> Point -> LightDestination - RadiusSquared : float - BoundingBox : BoundingBox - } - type SphereStyle = /// An emitter of light. | LightSource of Texture @@ -78,122 +65,128 @@ module Sphere = let normal (centre : Point) (p : Point) : Ray = Ray.make' p (Point.differenceToThenFrom p centre) |> ValueOption.get - let private liesOn' (centre : Point) (radius : float) (p : Point) : bool = - let rSquared = radius * radius - Float.equal (Vector.normSquared (Point.differenceToThenFrom p centre)) rSquared + let private reflectWithoutFuzz normal (strikePoint : Point) (incomingLight : byref) : unit = + let plane = Plane.makeOrthonormalSpannedBy normal incomingLight.Ray + match plane with + | ValueNone -> + // Incoming ray is directly along the normal + Ray.flipInPlace incomingLight.Ray + Ray.translateToIntersect strikePoint incomingLight.Ray + | ValueSome 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 incomingLight.Ray) + let tangentComponent = (UnitVector.dot plane.V2 (Ray.vector incomingLight.Ray)) + + let dest = + Ray.walkAlongRay (Ray.walkAlongRay plane.Point plane.V1 normalComponent) plane.V2 tangentComponent + + Ray.overwriteWithMake strikePoint (Point.differenceToThenFrom dest strikePoint) &incomingLight.Ray + // This is safe: it's actually a logic error for this to fail. + |> ignore + + let private addFuzz + (fuzz : float) + (rand : FloatProducer) + (strikePoint : Point) + (reflected : byref) + : unit + = + let mutable isDone = false + + while not isDone do + let offset = UnitVector.random rand (Point.dimension strikePoint) + let sphereCentre = Ray.walkAlong reflected.Ray 1.0 + let target = Ray.walkAlongRay sphereCentre offset (fuzz / 1.0) + + let newDirection = Point.differenceToThenFrom target strikePoint + isDone <- Ray.overwriteWithMake strikePoint newDirection &reflected.Ray + + /// If there were no refraction at all, the reflected ray would bounce off as `reflectionWithoutFuzz`. + /// This function adds a refraction term. + let private refract + (inside : bool) + (normal : Ray) + (strikePoint : Point) + (incomingCos : float) + (index : float) + (incomingLight : byref) + : unit + = + let index = if inside then 1.0 / index else index / 1.0 + let plane = Plane.makeOrthonormalSpannedBy normal incomingLight.Ray + + match plane with + | ValueNone -> + // Incoming ray was parallel to normal; pass straight through + let (UnitVector vec) = Ray.vector incomingLight.Ray + Ray.overwriteWithMake strikePoint vec &incomingLight.Ray |> ignore + | ValueSome plane -> + + 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 + reflectWithoutFuzz normal strikePoint &incomingLight + + else + + let outgoingCos = sqrt (1.0 - outgoingSin * outgoingSin) + + let outgoingPoint = + Ray.walkAlong (Ray.make (Ray.walkAlong normal (-outgoingCos)) plane.V2) outgoingSin + + let outgoingLine = Point.differenceToThenFrom outgoingPoint strikePoint + + Ray.overwriteWithMake strikePoint outgoingLine &incomingLight.Ray + // 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. + |> ignore + + /// If the light ray is absorbed, this returns Some(the colour of light). + /// Otherwise, returns None and mutates `incomingLight`. let reflection (style : SphereStyle) (centre : Point) (radius : float) (radiusSquared : float) (flipped : bool) - (incomingLight : LightRay) + (incomingLight : byref) (strikePoint : Point) - : LightDestination + : Pixel ValueOption = - let normal = normal centre strikePoint - // 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))) - radiusSquared - with - | Equal - | Less -> - // Point is inside or on the sphere so we are coming from within - if flipped then - false, normal - else - true, Ray.make (Ray.origin normal) (UnitVector.flip (Ray.vector normal)) - | Greater -> - if flipped then - true, Ray.make (Ray.origin normal) (UnitVector.flip (Ray.vector normal)) - else - false, normal + let mutable inside = false + let mutable normal = normal centre strikePoint - let fuzzedReflection (fuzz : (float * FloatProducer) option) = - let plane = Plane.makeSpannedBy normal incomingLight.Ray |> Plane.orthonormalise + 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 + if not flipped then + inside <- true + Ray.flipInPlace normal + | Greater -> + if flipped then + inside <- true + Ray.flipInPlace normal - let outgoing = - match plane with - | ValueNone -> - // Incoming ray is directly along the normal - Ray.flip incomingLight.Ray |> Ray.parallelTo strikePoint - | ValueSome 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 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. - |> ValueOption.get - - 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) - - let exitPoint = - Point.differenceToThenFrom target strikePoint |> Ray.make' strikePoint - - match exitPoint with - | ValueNone -> () - | ValueSome o -> answer <- o - - answer - - let refract (incomingCos : float) (index : float) = - let index = if inside then 1.0 / index else index / 1.0 - let plane = Plane.makeSpannedBy normal incomingLight.Ray |> Plane.orthonormalise - - match plane with - | ValueNone -> - // Incoming ray was parallel to normal; pass straight through - Ray.make strikePoint (Ray.vector incomingLight.Ray) - | ValueSome plane -> - - 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. - |> ValueOption.get + let inside = inside + let normal = normal match style with | SphereStyle.LightSource texture -> texture |> Texture.colourAt strikePoint |> Pixel.combine incomingLight.Colour - |> Absorbs + |> ValueSome | SphereStyle.LightSourceCap colour -> let circleCentreZCoord = Point.coordinate 0 centre let zCoordLowerBound = circleCentreZCoord + (radius - (radius / 4.0)) @@ -204,37 +197,29 @@ module Sphere = | Greater -> Pixel.combine colour incomingLight.Colour | _ -> Colour.Black - Absorbs colour + ValueSome colour | SphereStyle.LambertReflection (albedo, texture, rand) -> - let outgoing = - let sphereCentre = Ray.walkAlong normal 1.0 - 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 - | ValueSome o -> answer <- o - | ValueNone -> () - - answer - let newColour = texture |> Texture.colourAt strikePoint |> Pixel.combine incomingLight.Colour |> Pixel.darken albedo - Continues - { - Ray = outgoing - Colour = newColour - } + incomingLight.Colour <- newColour + + let sphereCentre = Ray.walkAlong normal 1.0 + let mutable isDone = false + + while not isDone do + let offset = UnitVector.random rand (Point.dimension sphereCentre) + let target = Ray.walkAlongRay sphereCentre offset 1.0 + + let outputVec = Point.differenceToThenFrom target strikePoint + + isDone <- Ray.overwriteWithMake strikePoint outputVec &incomingLight.Ray + + ValueNone | SphereStyle.PureReflection (albedo, texture) -> let darkened = @@ -243,11 +228,9 @@ module Sphere = |> Pixel.combine incomingLight.Colour |> Pixel.darken albedo - Continues - { - Ray = fuzzedReflection None - Colour = darkened - } + reflectWithoutFuzz normal strikePoint &incomingLight + incomingLight.Colour <- darkened + ValueNone | SphereStyle.FuzzedReflection (albedo, texture, fuzz, random) -> let darkened = @@ -256,11 +239,11 @@ module Sphere = |> Pixel.combine incomingLight.Colour |> Pixel.darken albedo - Continues - { - Ray = fuzzedReflection (Some (fuzz, random)) - Colour = darkened - } + incomingLight.Colour <- darkened + + reflectWithoutFuzz normal strikePoint &incomingLight + addFuzz fuzz random strikePoint &incomingLight + ValueNone | SphereStyle.Dielectric (albedo, texture, sphereRefractance, refractionProb, random) -> let newColour = @@ -273,19 +256,15 @@ module Sphere = if LanguagePrimitives.FloatWithMeasure rand > refractionProb then // reflect! - Continues - { - Ray = fuzzedReflection None - Colour = newColour - } + incomingLight.Colour <- newColour + reflectWithoutFuzz normal strikePoint &incomingLight + ValueNone else let incomingCos = UnitVector.dot (Ray.vector incomingLight.Ray) (Ray.vector normal) - Continues - { - Ray = refract incomingCos sphereRefractance - Colour = newColour - } + refract inside normal strikePoint incomingCos sphereRefractance &incomingLight + incomingLight.Colour <- newColour + ValueNone | SphereStyle.Glass (albedo, texture, sphereRefractance, random) -> let newColour = @@ -312,25 +291,44 @@ module Sphere = if LanguagePrimitives.FloatWithMeasure rand < reflectionProb then // reflect! - Continues - { - Ray = fuzzedReflection None - Colour = newColour - } + reflectWithoutFuzz normal strikePoint &incomingLight + incomingLight.Colour <- newColour + ValueNone else - Continues - { - Ray = refract incomingCos sphereRefractance - Colour = newColour - } + refract inside normal strikePoint incomingCos sphereRefractance &incomingLight + incomingLight.Colour <- newColour + ValueNone - let make (style : SphereStyle) (centre : Point) (radius : float) : Sphere = +type Sphere = + private + { + Centre : Point + Radius : float + RadiusSquared : float + BoundingBox : BoundingBox + Style : SphereStyle + } + + /// If an incoming ray has the given colour, and hits the + /// given point (which is guaranteed to be on the surface), + /// does it get absorbed? If not, mutates the input `ray` to hold the new light ray. + member this.Reflection (ray : byref, strikePoint : Point) : Pixel ValueOption = + Sphere.reflection + this.Style + this.Centre + this.Radius + this.RadiusSquared + (Float.compare this.Radius 0.0 = Less) + &ray + strikePoint + + static member make (style : SphereStyle) (centre : Point) (radius : float) : Sphere = let radiusSquared = radius * radius { + Style = style Centre = centre Radius = radius - Reflection = reflection style centre radius radiusSquared (Float.compare radius 0.0 = Less) RadiusSquared = radiusSquared BoundingBox = BoundingBox.make @@ -338,16 +336,17 @@ module Sphere = (Point.sum centre (Point.make radius radius radius)) } - let boundingBox (s : Sphere) = s.BoundingBox + static member boundingBox (s : Sphere) = s.BoundingBox - let liesOn (point : Point) (sphere : Sphere) : bool = - liesOn' sphere.Centre sphere.Radius point + static member liesOn (point : Point) (sphere : Sphere) : bool = + let rSquared = sphere.RadiusSquared + Float.equal (Vector.normSquared (Point.differenceToThenFrom point sphere.Centre)) rSquared /// Returns the distance along this ray at which the nearest intersection of the ray lies with this sphere. /// Does not return any intersections which are behind us. /// If the sphere is made of a material which does not re-emit light, you'll /// get a None for the outgoing ray. - let firstIntersection (sphere : Sphere) (ray : Ray) : float voption = + static member firstIntersection (sphere : Sphere) (ray : Ray) : float voption = let difference = Point.differenceToThenFrom (Ray.origin ray) sphere.Centre let b = (UnitVector.dot' (Ray.vector ray) difference)