patrick/ray-tracing-fsharp
1
0
Fork 0
mirror of https://github.com/Smaug123/ray-tracing-fsharp synced 2025-10-07 12:58:40 +00:00
Code Issues Packages Projects Releases Wiki Activity

Earth sphere (#7)

Browse Source
This commit is contained in:
Patrick Stevens
2021-04-24 23:18:57 +01:00
committed by GitHub
parent 67f9f8d3bf
commit 1bd62ade9b
7 changed files with 140 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
RayTracing.App/LoadImage.fs Normal file
View File

@@ -0,0 +1,18 @@
namespace RayTracing.App
open System.Drawing
open System.Reflection
[<RequireQualifiedAccess>]
module LoadImage =
let fromResource (name : string) : Bitmap =
let assy = Assembly.GetExecutingAssembly()
use resource =
assy.GetManifestResourceNames()
|> Seq.filter (fun i -> i.EndsWith name)
|> Seq.head
|> assy.GetManifestResourceStream
let b = new Bitmap(resource)
b

2
RayTracing.App/RayTracing.App.fsproj
View File

@@ -6,8 +6,10 @@
</PropertyGroup>
<ItemGroup>
<Compile Include="LoadImage.fs" />
<Compile Include="SampleImages.fs" />
<Compile Include="Program.fs" />
<EmbeddedResource Include="earthmap.jpg" />
</ItemGroup>
<ItemGroup>

56
RayTracing.App/SampleImages.fs
View File

@@ -1,6 +1,7 @@
namespace RayTracing
namespace RayTracing.App
open System
open RayTracing
type SampleImages =
| Gradient
@@ -12,6 +13,8 @@ type SampleImages =
| TotalRefraction
| GlassSphere
| MovedCamera
| TexturedSphere
| Earth
static member Parse (s : string) =
match s with
@@ -24,6 +27,8 @@ type SampleImages =
| "moved-camera" -> SampleImages.MovedCamera
| "glass" -> SampleImages.GlassSphere
| "random-spheres" -> SampleImages.RandomSpheres
| "textured-sphere" -> SampleImages.TexturedSphere
| "earth" -> SampleImages.Earth
| s -> failwithf "Unrecognised arg: %s" s
[<RequireQualifiedAccess>]
@@ -167,6 +172,34 @@ module SampleImages =
let camera =
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
[|
// Floor
Hittable.UnboundedSphere (Sphere.make (SphereStyle.LambertReflection (0.5<albedo>, Texture.Colour { 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>, Texture.Colour { Red = 100uy ; Green = 150uy ; Blue = 200uy })) (Point.make 1.0 0.0 1.0) 0.5)
// Middle sphere
Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, Texture.Colour { 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>, Texture.Colour Colour.White, 1.5<ior>, random3)) (Point.make -1.0 0.0 1.0) 0.5)
// Light around us
Hittable.UnboundedSphere (Sphere.make (SphereStyle.LightSource (Texture.Colour { Red = 200uy ; Green = 200uy ; Blue = 200uy })) (Point.make 0.0 0.0 0.0) 200.0)
|]
|> Scene.make
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let texturedSphere (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
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 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
let texture =
let even =
ParameterisedTexture.Arbitrary (fun x y -> Texture.Colour { Red = byte (float x * 255.0) ; Green = 0uy ; Blue = byte (y * 255.0) })
@@ -289,6 +322,25 @@ module SampleImages =
|> Scene.make
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
let earth (progressIncrement : float<progress> -> unit) (log : string -> unit) : float<progress> * Image =
let aspectRatio = 16.0 / 9.0
let origin = Point.make 13.0 2.0 -3.0
let camera =
Camera.makeBasic 50 12.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 = 400
let texture = ParameterisedTexture.ofImage (LoadImage.fromResource "earthmap.jpg")
let random1 = Random () |> FloatProducer
[|
// Earth
Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, ParameterisedTexture.toTexture (Sphere.planeMapInverse 1.0 (Point.make 0.0 0.0 0.0)) texture, random1)) (Point.make 0.0 0.0 0.0) 1.0)
// Light around us
Hittable.UnboundedSphere (Sphere.make (SphereStyle.LightSource (Texture.Colour { Red = 130uy ; Green = 130uy ; Blue = 200uy })) (Point.make 0.0 0.0 0.0) 200.0)
|]
|> Scene.make
|> 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
@@ -300,3 +352,5 @@ module SampleImages =
| GlassSphere -> glassSphere
| MovedCamera -> movedCamera
| RandomSpheres -> randomSpheres
| TexturedSphere -> texturedSphere
| Earth -> earth

BIN
RayTracing.App/earthmap.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 158 KiB

40
RayTracing.Test/TestSphere.fs
View File

@@ -139,4 +139,42 @@ module TestSphere =
property
|> Prop.forAll arb
|> Check.QuickThrowOnFailure
|> Check.QuickThrowOnFailure
[<Test>]
let ``Specific planeMapInverses`` () =
let sphere = Sphere.planeMapInverse 1.0 (Point.make 0.0 0.0 0.0)
sphere (Point.make 1.0 0.0 0.0)
|> shouldEqual (0.5, 0.5)
sphere (Point.make -1.0 0.0 0.0)
|> shouldEqual (0.0, 0.5)
sphere (Point.make 0.0 1.0 0.0)
|> shouldEqual (0.5, 1.0)
sphere (Point.make 0.0 -1.0 0.0)
|> shouldEqual (0.5, 0.0)
sphere (Point.make 0.0 0.0 1.0)
|> shouldEqual (0.25, 0.5)
sphere (Point.make 0.0 0.0 -1.0)
|> shouldEqual (0.75, 0.5)
[<Test>]
let ``Specific planeMaps`` () =
let sphere = Sphere.planeMap 1.0 (Point.make 0.0 0.0 0.0)
sphere 0.5 0.5
|> Point.equal (Point.make 1.0 0.0 0.0)
|> shouldEqual true
sphere 0.0 0.5
|> Point.equal (Point.make -1.0 0.0 0.0)
|> shouldEqual true
sphere 0.5 1.0
|> Point.equal (Point.make 0.0 1.0 0.0)
|> shouldEqual true
sphere 0.5 0.0
|> Point.equal (Point.make 0.0 -1.0 0.0)
|> shouldEqual true
sphere 0.25 0.5
|> Point.equal (Point.make 0.0 0.0 1.0)
|> shouldEqual true
sphere 0.75 0.5
|> Point.equal (Point.make 0.0 0.0 -1.0)
|> shouldEqual true

12
RayTracing/Sphere.fs
View File

@@ -52,18 +52,18 @@ type Orientation =
module Sphere =
/// Parameterisation of a sphere of radius 1 centred on 0,0,0 by points in the box [0, 1] x [0, 1]
let planeMap (radius : float) (centre : Point) (theta : float) (phi : float) : Point =
let planeMap (radius : float) (centre : Point) (phi : float) (theta : float) : Point =
let theta = theta * System.Math.PI
let phi = phi * System.Math.PI * 2.0 - System.Math.PI
Point.make (radius * sin theta * cos phi) (radius * sin theta * sin phi) (radius * cos theta)
Point.make (radius * cos phi * sin theta) (-radius * cos theta) (-radius * sin phi * sin theta)
|> Point.sum centre
/// Give back the theta and phi (scaled to 0..1 each) that result in this point.
/// Give back the phi and theta (scaled to 0..1 each) that result in this point.
let planeMapInverse (radius : float) (centre : Point) (p : Point) : struct(float * float) =
let (Vector(x, y, z)) = Point.differenceToThenFrom p centre |> Vector.scale (1.0 / radius)
let theta = acos z
let phi = atan2 y x
struct(theta / System.Math.PI, ((phi + System.Math.PI) / (2.0 * System.Math.PI)))
let theta = acos (-y)
let phi = atan2 (-z) x + System.Math.PI
struct((phi / (2.0 * System.Math.PI)), theta / System.Math.PI)
/// A ray hits the sphere with centre `centre` at point `p`.
/// This function gives the outward-pointing normal.

33
RayTracing/Texture.fs
View File

@@ -17,23 +17,25 @@ module Texture =
type ParameterisedTexture =
| Colour of Pixel
| Checkered of even : ParameterisedTexture * odd : ParameterisedTexture * gridSize : float
/// An image, given as an array of rows of pixels, top row first, left coordinate first.
| Image of Pixel[][]
| Arbitrary of (float -> float -> Texture)
/// A collection of textures, paramaterised by 2d coordinates between 0 and 1.
[<RequireQualifiedAccess>]
module ParameterisedTexture =
let rec colourAt (interpret : float -> float -> Point) (t : ParameterisedTexture) (x : float) (y : float) : Pixel =
match t with
| ParameterisedTexture.Colour p -> p
| ParameterisedTexture.Arbitrary f -> Texture.colourAt (interpret x y) (f x y)
| ParameterisedTexture.Checkered (even, odd, gridSize) ->
let sine = sin (gridSize * x) * sin (gridSize * y)
match Float.compare sine 0.0 with
| Less -> colourAt interpret even x y
| _ -> colourAt interpret odd x y
let ofImage (img : System.Drawing.Bitmap) : ParameterisedTexture =
Array.init img.Height (fun y ->
let y = img.Height - y - 1
Array.init img.Width (fun x ->
let p = img.GetPixel (x, y)
{ Red = p.R ; Green = p.G ; Blue = p.B }
)
)
|> ParameterisedTexture.Image
let rec colourAt' (interpret : Point -> struct(float * float)) (t : ParameterisedTexture) (p : Point) : Pixel =
let rec colourAt (interpret : Point -> struct(float * float)) (t : ParameterisedTexture) (p : Point) : Pixel =
match t with
| ParameterisedTexture.Colour p -> p
| ParameterisedTexture.Arbitrary f ->
@@ -43,12 +45,17 @@ module ParameterisedTexture =
let struct(x, y) = interpret p
let sine = sin (gridSize * x) * sin (gridSize * y)
match Float.compare sine 0.0 with
| Less -> colourAt' interpret even p
| _ -> colourAt' interpret odd p
| Less -> colourAt interpret even p
| _ -> colourAt interpret odd p
| ParameterisedTexture.Image img ->
let struct(x, y) = interpret p
let x = int ((1.0-x) * float (img.[0].Length - 1))
let y = int (y * float (img.Length - 1))
img.[y].[x]
let toTexture (interpret : Point -> struct(float * float)) (texture : ParameterisedTexture) : Texture =
match texture with
| ParameterisedTexture.Colour p -> Texture.Colour p
| _ ->
colourAt' interpret texture
colourAt interpret texture
|> Texture.Arbitrary