namespace RayTracing type InfinitePlaneStyle = /// An emitter of light. | LightSource of Texture /// Perfect reflection, as you would see from a smooth flat metal surface. /// Albedo must be between 0 and 1. | PureReflection of albedo : float * colour : Pixel /// An ideal matte (diffusely-reflecting) surface: apparent brightness of the /// surface is the same regardless of the angle of view. /// Albedo must be between 0 and 1. | 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 match plane with | ValueNone -> // Incoming ray is directly along the normal Ray.flip incomingRay |> 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 incomingRay)) let tangentComponent = (UnitVector.dot plane.V2 (Ray.vector incomingRay)) let s = tangentComponent |> 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. |> ValueOption.get let newColour (incomingColour : Pixel) albedo colour = Pixel.combine incomingColour colour |> Pixel.darken albedo let reflection (style : InfinitePlaneStyle) (pointOnPlane : Point) (normal : UnitVector) : LightRay -> Point -> LightDestination = fun incomingRay strikePoint -> match style with | InfinitePlaneStyle.LightSource texture -> texture |> Texture.colourAt strikePoint |> Pixel.combine incomingRay.Colour |> Absorbs | 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 match output with | ValueNone -> () | ValueSome output -> outgoing <- output Continues { Ray = outgoing Colour = newColour } | 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 Point.differenceToThenFrom target strikePoint |> Ray.make' strikePoint |> ValueOption.get let newColour = Pixel.combine incomingRay.Colour colour |> Pixel.darken albedo Continues { Ray = outgoing Colour = newColour } | InfinitePlaneStyle.PureReflection (albedo, colour) -> { Ray = pureOutgoing strikePoint normal incomingRay.Ray Colour = newColour incomingRay.Colour albedo colour } |> Continues let make (style : InfinitePlaneStyle) (pointOnPlane : Point) (normal : UnitVector) : InfinitePlane = { Point = pointOnPlane Normal = normal Reflection = reflection style pointOnPlane normal }