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

Net6 and format (#8)

Browse Source
This commit is contained in:
Patrick Stevens
2022-12-31 15:46:24 +00:00
committed by GitHub
parent 1bd62ade9b
commit f0ee86819b
36 changed files with 1742 additions and 613 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
.config/dotnet-tools.json Normal file
View File

@@ -0,0 +1,12 @@
{
"version": 1,
"isRoot": true,
"tools": {
"fantomas": {
"version": "5.2.0-alpha-010",
"commands": [
"fantomas"
]
}
}
}

36
.editorconfig
View File

@@ -1,13 +1,41 @@
root = true
root=true
[*.fs]
[*]
charset=utf-8
end_of_line=crlf
trim_trailing_whitespace=true
insert_final_newline=true
indent_style=space
indent_size=4
# ReSharper properties
resharper_xml_indent_size=2
resharper_xml_max_line_length=100
resharper_xml_tab_width=2
[*.{csproj,fsproj,sqlproj,targets,props,ts,tsx,css,json}]
indent_style=space
indent_size=2
[*.{fs,fsi}]
fsharp_bar_before_discriminated_union_declaration=true
fsharp_space_before_uppercase_invocation=true
fsharp_space_before_class_constructor=true
fsharp_space_before_member=true
fsharp_space_before_colon=true
fsharp_space_before_semicolon=true
fsharp_multiline_block_brackets_on_same_column=true
fsharp_newline_between_type_definition_and_members=true
fsharp_keep_if_then_in_same_line=true
fsharp_align_function_signature_to_indentation=true
fsharp_alternative_long_member_definitions=true
fsharp_disable_elmish_syntax=true
fsharp_multi_line_lambda_closing_newline=true
fsharp_experimental_keep_indent_in_branch=true
fsharp_max_value_binding_width=80
fsharp_max_record_width=0
max_line_length=120
end_of_line=lf
[*.{appxmanifest,build,dtd,nuspec,xaml,xamlx,xoml,xsd}]
indent_style=space
indent_size=2
tab_width=2

2
.github/workflows/dotnet.yml vendored
View File

@@ -16,7 +16,7 @@ jobs:
- name: Setup .NET
uses: actions/setup-dotnet@v1
with:
dotnet-version: 5.0.x
dotnet-version: 6.0.x
- name: Restore dependencies
run: dotnet restore
- name: Build

9
RayTracing.App/LoadImage.fs
View File

@@ -7,12 +7,13 @@ open System.Reflection
module LoadImage =
let fromResource (name : string) : Bitmap =
let assy = Assembly.GetExecutingAssembly()
let assy = Assembly.GetExecutingAssembly ()
use resource =
assy.GetManifestResourceNames()
assy.GetManifestResourceNames ()
|> Seq.filter (fun i -> i.EndsWith name)
|> Seq.head
|> assy.GetManifestResourceStream
let b = new Bitmap(resource)
b
let b = new Bitmap (resource)
b

43
RayTracing.App/Program.fs
View File

@@ -9,7 +9,8 @@ module Program =
type ProgressTask with
member this.Increment (prog : float<progress>) = this.Increment (prog / 1.0<progress>)
member this.Increment (progress : float<progress>) =
this.Increment (progress / 1.0<progress>)
let go (sample : SampleImages) (pngOutput : IFileInfo) (ctx : ProgressContext) =
let renderTask = ctx.AddTask "[green]Generating image[/]"
@@ -17,15 +18,17 @@ module Program =
let readTask = ctx.AddTask "[green]Reading in serialised pixels[/]"
let writeTask = ctx.AddTask "[green]Writing PPM file[/]"
let logFile = pngOutput.FileSystem.Path.GetTempFileName () |> pngOutput.FileSystem.FileInfo.FromFileName
let logFile =
pngOutput.FileSystem.Path.GetTempFileName ()
|> pngOutput.FileSystem.FileInfo.FromFileName
use stream = logFile.OpenWrite ()
use writer = new StreamWriter(stream)
use writer = new StreamWriter (stream)
writer.AutoFlush <- true
let lockObj = obj ()
let write (s : string) =
lock lockObj (fun () ->
writer.WriteLine s
)
lock lockObj (fun () -> writer.WriteLine s)
printfn "Log output, if any, to '%s'" logFile.FullName
@@ -35,12 +38,17 @@ module Program =
readTask.MaxValue <- maxProgress / 1.0<progress>
writeTask.MaxValue <- maxProgress / 1.0<progress>
let tempOutput, await = ImageOutput.toPpm writeUnorderedTask.Increment image pngOutput.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.readPixelMap readTask.Increment tempOutput (Image.rowCount image) (Image.colCount image)
let pixelMap = ImageOutput.assertComplete pixelMap
do! Png.write true writeTask.Increment pixelMap pngOutput
tempOutput.Delete ()
@@ -51,18 +59,19 @@ module Program =
printfn "%s" pngOutput.FullName
[<EntryPoint>]
let main (argv : string []) : int =
let main (argv : string[]) : int =
let fs = FileSystem ()
let sample, output =
match argv with
| [| name |] ->
SampleImages.Parse name,
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
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
let prog =
let progress =
AnsiConsole
.Progress()
.Columns (
@@ -73,8 +82,8 @@ module Program =
SpinnerColumn ()
)
prog.HideCompleted <- false
prog.AutoClear <- false
progress.HideCompleted <- false
progress.AutoClear <- false
prog.Start (go sample output)
progress.Start (go sample output)
0

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

@@ -1,7 +1,7 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net5.0</TargetFramework>
<TargetFramework>net6.0</TargetFramework>
<OutputType>Exe</OutputType>
</PropertyGroup>

812
RayTracing.App/SampleImages.fs
View File

@@ -57,12 +57,38 @@ module SampleImages =
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 =
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)
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
[|
Hittable.Sphere (Sphere.make (SphereStyle.LightSource (Texture.Colour { Red = 0uy ; Green = 255uy ; Blue = 255uy })) (Point.make 1.5 0.5 8.0) 0.5)
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
Hittable.Sphere (
Sphere.make
(SphereStyle.LightSource (
Texture.Colour
{
Red = 0uy
Green = 255uy
Blue = 255uy
}
))
(Point.make 1.5 0.5 8.0)
0.5
)
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.make
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
@@ -71,12 +97,38 @@ module SampleImages =
let random = Random () |> FloatProducer
let aspectRatio = 16.0 / 9.0
let origin = Point.make 0.0 0.0 0.0
let camera =
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)
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
[|
Hittable.Sphere (Sphere.make (SphereStyle.LightSource (Texture.Colour { Red = 0uy ; Green = 255uy ; Blue = 255uy })) (Point.make 1.5 0.5 8.0) 0.5)
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
Hittable.Sphere (
Sphere.make
(SphereStyle.LightSource (
Texture.Colour
{
Red = 0uy
Green = 255uy
Blue = 255uy
}
))
(Point.make 1.5 0.5 8.0)
0.5
)
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.make
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
@@ -87,26 +139,124 @@ module SampleImages =
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 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
[|
Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (0.95<albedo>, Texture.Colour { Red = 255uy ; Green = 255uy ; Blue = 0uy }, random1)) (Point.make 0.0 0.0 9.0) 1.0)
Hittable.Sphere (Sphere.make (SphereStyle.PureReflection (1.0<albedo>, Texture.Colour { Red = 0uy ; Green = 255uy ; Blue = 255uy })) (Point.make 1.5 0.5 8.0) 0.5)
Hittable.Sphere (Sphere.make (SphereStyle.LightSource (Texture.Colour { Colour.White with Red = 200uy ; Green = 220uy }) ) (Point.make -1.5 1.0 8.0) 0.5)
Hittable.Sphere (Sphere.make (SphereStyle.FuzzedReflection (1.0<albedo>, Texture.Colour { Red = 255uy ; Green = 100uy ; Blue = 0uy }, 0.2<fuzz>, random2) ) (Point.make -0.4 1.5 10.0) 0.25)
Hittable.Sphere (
Sphere.make
(SphereStyle.LambertReflection (
0.95<albedo>,
Texture.Colour
{
Red = 255uy
Green = 255uy
Blue = 0uy
},
random1
))
(Point.make 0.0 0.0 9.0)
1.0
)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
1.0<albedo>,
Texture.Colour
{
Red = 0uy
Green = 255uy
Blue = 255uy
}
))
(Point.make 1.5 0.5 8.0)
0.5
)
Hittable.Sphere (
Sphere.make
(SphereStyle.LightSource (
Texture.Colour
{ Colour.White with
Red = 200uy
Green = 220uy
}
))
(Point.make -1.5 1.0 8.0)
0.5
)
Hittable.Sphere (
Sphere.make
(SphereStyle.FuzzedReflection (
1.0<albedo>,
Texture.Colour
{
Red = 255uy
Green = 100uy
Blue = 0uy
},
0.2<fuzz>,
random2
))
(Point.make -0.4 1.5 10.0)
0.25
)
// Left side mirror
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.PureReflection (0.8<albedo>, Colour.White)) (Point.make 0.0 0.0 12.0) (Vector.make 1.0 0.0 -1.0 |> Vector.unitise |> Option.get))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.PureReflection (0.8<albedo>, Colour.White))
(Point.make 0.0 0.0 12.0)
(Vector.make 1.0 0.0 -1.0 |> Vector.unitise |> Option.get)
)
// Floor rug
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.FuzzedReflection (0.85<albedo>, { Red = 255uy ; Green = 100uy ; Blue = 100uy }, 0.8<fuzz>, random3)) (Point.make 0.0 -1.0 0.0) (Vector.make 0.0 1.0 0.0 |> Vector.unitise |> Option.get))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.FuzzedReflection (
0.85<albedo>,
{
Red = 255uy
Green = 100uy
Blue = 100uy
},
0.8<fuzz>,
random3
))
(Point.make 0.0 -1.0 0.0)
(Vector.make 0.0 1.0 0.0 |> Vector.unitise |> Option.get)
)
// Right side mirror
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.PureReflection (0.95<albedo>, Colour.White)) (Point.make 0.0 0.0 12.0) (Vector.make -1.0 0.0 -1.0 |> Vector.unitise |> Option.get))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.PureReflection (0.95<albedo>, Colour.White))
(Point.make 0.0 0.0 12.0)
(Vector.make -1.0 0.0 -1.0 |> Vector.unitise |> Option.get)
)
// Light pad behind us
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.LightSource (Texture.Colour { 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))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.LightSource (
Texture.Colour
{
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.make
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
@@ -118,21 +268,142 @@ module SampleImages =
let random4 = Random () |> FloatProducer
let aspectRatio = 16.0 / 9.0
let origin = Point.make 0.0 0.0 0.0
let camera =
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
[|
Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (0.95<albedo>, Texture.Colour { Red = 255uy ; Green = 255uy ; Blue = 0uy }, random1)) (Point.make 0.0 0.0 9.0) 1.0)
Hittable.Sphere (Sphere.make (SphereStyle.PureReflection (1.0<albedo>, Texture.Colour { Red = 0uy ; Green = 255uy ; Blue = 255uy })) (Point.make 1.5 0.5 8.0) 0.5)
Hittable.Sphere (Sphere.make (SphereStyle.PureReflection (1.0<albedo>, Texture.Colour { Red = 255uy ; Green = 20uy ; Blue = 20uy })) (Point.make -1.8 0.8 8.0) 0.5)
Hittable.Sphere (Sphere.make (SphereStyle.LightSource (Texture.Colour Colour.White)) (Point.make -10.0 8.0 0.0) 9.0)
Hittable.Sphere (Sphere.make (SphereStyle.FuzzedReflection (1.0<albedo>, Texture.Colour { Red = 255uy ; Green = 100uy ; Blue = 0uy }, 0.2<fuzz>, random2) ) (Point.make 1.4 1.5 10.0) 0.25)
Hittable.Sphere (Sphere.make (SphereStyle.PureReflection (0.9<albedo>, Texture.Colour { Red = 255uy ; Green = 255uy ; Blue = 255uy })) (Point.make 0.0 10.0 20.0) 8.0)
Hittable.Sphere (Sphere.make (SphereStyle.FuzzedReflection (0.6<albedo>, Texture.Colour { 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>, Texture.Colour { Red = 200uy ; Green = 200uy ; Blue = 200uy }, 0.0<fuzz>, random4)) (Point.make 0.0 0.0 20.0) 100.0)
let camera =
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
[|
Hittable.Sphere (
Sphere.make
(SphereStyle.LambertReflection (
0.95<albedo>,
Texture.Colour
{
Red = 255uy
Green = 255uy
Blue = 0uy
},
random1
))
(Point.make 0.0 0.0 9.0)
1.0
)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
1.0<albedo>,
Texture.Colour
{
Red = 0uy
Green = 255uy
Blue = 255uy
}
))
(Point.make 1.5 0.5 8.0)
0.5
)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
1.0<albedo>,
Texture.Colour
{
Red = 255uy
Green = 20uy
Blue = 20uy
}
))
(Point.make -1.8 0.8 8.0)
0.5
)
Hittable.Sphere (
Sphere.make (SphereStyle.LightSource (Texture.Colour Colour.White)) (Point.make -10.0 8.0 0.0) 9.0
)
Hittable.Sphere (
Sphere.make
(SphereStyle.FuzzedReflection (
1.0<albedo>,
Texture.Colour
{
Red = 255uy
Green = 100uy
Blue = 0uy
},
0.2<fuzz>,
random2
))
(Point.make 1.4 1.5 10.0)
0.25
)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
0.9<albedo>,
Texture.Colour
{
Red = 255uy
Green = 255uy
Blue = 255uy
}
))
(Point.make 0.0 10.0 20.0)
8.0
)
Hittable.Sphere (
Sphere.make
(SphereStyle.FuzzedReflection (
0.6<albedo>,
Texture.Colour
{
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>,
Texture.Colour
{
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 (Texture.Colour { 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 (
Texture.Colour
{
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.make
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
@@ -143,22 +414,89 @@ module SampleImages =
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)
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
[|
// Floor
Hittable.Sphere (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)
Hittable.Sphere (
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 = 204uy ; Green = 153uy ; Blue = 51uy })) (Point.make 1.0 0.0 1.0) 0.5)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
1.0<albedo>,
Texture.Colour
{
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>, Texture.Colour { Red = 25uy ; Green = 50uy ; Blue = 120uy }, random2)) (Point.make 0.0 0.0 1.0) 0.5)
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.Dielectric (1.0<albedo>, Texture.Colour Colour.White, 1.5<ior>, 1.0<prob>, random3)) (Point.make -1.0 0.0 1.0) 0.5)
Hittable.Sphere (
Sphere.make
(SphereStyle.Dielectric (1.0<albedo>, Texture.Colour 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 (Texture.Colour { Red = 80uy ; Green = 80uy ; Blue = 150uy })) (Point.make 0.0 0.0 0.0) 200.0)
Hittable.Sphere (
Sphere.make
(SphereStyle.LightSource (
Texture.Colour
{
Red = 80uy
Green = 80uy
Blue = 150uy
}
))
(Point.make 0.0 0.0 0.0)
200.0
)
|]
|> Scene.make
|> Scene.render progressIncrement log (aspectRatio * (float pixels) |> int) pixels camera
@@ -169,24 +507,89 @@ module SampleImages =
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)
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)
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)
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)
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)
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)
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
@@ -197,29 +600,107 @@ module SampleImages =
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)
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) })
let odd = ParameterisedTexture.Arbitrary (fun x y -> Texture.Colour { Red = 100uy ; Green = byte (float x * 255.0) ; Blue = byte (y * 255.0) })
ParameterisedTexture.Arbitrary (fun x y ->
Texture.Colour
{
Red = byte (float x * 255.0)
Green = 0uy
Blue = byte (y * 255.0)
}
)
let odd =
ParameterisedTexture.Arbitrary (fun x y ->
Texture.Colour
{
Red = 100uy
Green = byte (float x * 255.0)
Blue = byte (y * 255.0)
}
)
ParameterisedTexture.Checkered (even, odd, 50.0)
[|
// 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)
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>, ParameterisedTexture.toTexture (Sphere.planeMapInverse 0.5 (Point.make 1.0 0.0 1.0)) texture)) (Point.make 1.0 0.0 1.0) 0.5)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
1.0<albedo>,
ParameterisedTexture.toTexture (Sphere.planeMapInverse 0.5 (Point.make 1.0 0.0 1.0)) texture
))
(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)
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)
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)
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
@@ -231,23 +712,97 @@ module SampleImages =
let random4 = Random () |> FloatProducer
let aspectRatio = 16.0 / 9.0
let origin = Point.make -2.0 2.0 -1.0
let camera =
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)
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
[|
// Floor
Hittable.Sphere (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)
Hittable.Sphere (
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 = 204uy ; Green = 153uy ; Blue = 51uy })) (Point.make 1.0 0.0 1.0) 0.5)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
1.0<albedo>,
Texture.Colour
{
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>, Texture.Colour { Red = 25uy ; Green = 50uy ; Blue = 120uy }, random2)) (Point.make 0.0 0.0 1.0) 0.5)
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 (1.0<albedo>, Texture.Colour 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>, Texture.Colour Colour.White, 1.0<ior> / 1.5, random4)) (Point.make -1.0 0.0 1.0) -0.45)
Hittable.Sphere (
Sphere.make
(SphereStyle.Glass (1.0<albedo>, Texture.Colour 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>, Texture.Colour 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 (Texture.Colour { Red = 130uy ; Green = 130uy ; Blue = 200uy })) (Point.make 0.0 0.0 0.0) 200.0)
Hittable.Sphere (
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
@@ -255,66 +810,146 @@ module SampleImages =
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)
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
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
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, Texture.Colour (Colour.random rand), floatProducer)) centre 0.2
Sphere.make
(SphereStyle.LambertReflection (
albedo,
Texture.Colour (Colour.random rand),
floatProducer
))
centre
0.2
|> Hittable.Sphere
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, Texture.Colour (Colour.random rand), fuzz, floatProducer)) centre 0.2
Sphere.make
(SphereStyle.FuzzedReflection (
albedo,
Texture.Colour (Colour.random rand),
fuzz,
floatProducer
))
centre
0.2
|> Hittable.Sphere
else
// glass
yield
Sphere.make (SphereStyle.Glass (1.0<albedo>, Texture.Colour Colour.White, 1.5<ior>, floatProducer)) centre 0.2
Sphere.make
(SphereStyle.Glass (
1.0<albedo>,
Texture.Colour Colour.White,
1.5<ior>,
floatProducer
))
centre
0.2
|> Hittable.Sphere
let rand = Random ()
let floatProducer = FloatProducer rand
yield
Sphere.make (SphereStyle.Glass (1.0<albedo>, Texture.Colour Colour.White, 1.5<ior>, floatProducer)) (Point.make 0.0 1.0 0.0) 1.0
Sphere.make
(SphereStyle.Glass (1.0<albedo>, Texture.Colour Colour.White, 1.5<ior>, floatProducer))
(Point.make 0.0 1.0 0.0)
1.0
|> Hittable.Sphere
let rand = Random ()
let floatProducer = FloatProducer rand
yield
Sphere.make (SphereStyle.LambertReflection (1.0<albedo>, Texture.Colour { Red = 80uy ; Green = 40uy ; Blue = 20uy }, floatProducer)) (Point.make -4.0 1.0 0.0) 1.0
Sphere.make
(SphereStyle.LambertReflection (
1.0<albedo>,
Texture.Colour
{
Red = 80uy
Green = 40uy
Blue = 20uy
},
floatProducer
))
(Point.make -4.0 1.0 0.0)
1.0
|> Hittable.Sphere
yield
Sphere.make (SphereStyle.PureReflection (1.0<albedo>, Texture.Colour { Red = 180uy ; Green = 150uy ; Blue = 128uy })) (Point.make 4.0 1.0 0.0) 1.0
Sphere.make
(SphereStyle.PureReflection (
1.0<albedo>,
Texture.Colour
{
Red = 180uy
Green = 150uy
Blue = 128uy
}
))
(Point.make 4.0 1.0 0.0)
1.0
|> Hittable.Sphere
// Ceiling
yield
Sphere.make (SphereStyle.LightSource (Texture.Colour { Colour.White with Red = 200uy ; Green = 200uy })) (Point.make 0.0 0.0 0.0) 2000.0
Sphere.make
(SphereStyle.LightSource (
Texture.Colour
{ Colour.White with
Red = 200uy
Green = 200uy
}
))
(Point.make 0.0 0.0 0.0)
2000.0
|> Hittable.UnboundedSphere
// Floor
let rand = Random ()
let floatProducer = FloatProducer rand
yield
Sphere.make (SphereStyle.LambertReflection (0.5<albedo>, Texture.Colour Colour.White, floatProducer)) (Point.make 0.0 -1000.0 0.0) 1000.0
Sphere.make
(SphereStyle.LambertReflection (0.5<albedo>, Texture.Colour Colour.White, floatProducer))
(Point.make 0.0 -1000.0 0.0)
1000.0
|> Hittable.UnboundedSphere
|]
@@ -325,18 +960,49 @@ module SampleImages =
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)
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)
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)
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

2
RayTracing.Test/RayTracing.Test.fsproj
View File

@@ -1,7 +1,7 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net5.0</TargetFramework>
<TargetFramework>net6.0</TargetFramework>
</PropertyGroup>
<ItemGroup>

64
RayTracing.Test/TestBoundingBox.fs
View File

@@ -11,16 +11,30 @@ module TestBoundingBox =
let delta = 0.00000001
let sort (x1 : float) (x2 : float) =
min x1 x2, if x1 = x2 then x1 + (delta / 2.0) else max x1 x2
min x1 x2, (if x1 = x2 then x1 + (delta / 2.0) else max x1 x2)
[<TestCase true>]
[<TestCase false>]
let ``Bounding box on the left doesn't intersect ray to the right`` (negate : bool) =
let ray =
Ray.make (Point.make ((if negate then (fun x -> -x) else id) delta) 0.0 0.0) (Vector.make (if negate then -1.0 else 1.0) 0.0 0.0 |> Vector.unitise |> Option.get)
Ray.make
(Point.make ((if negate then (fun x -> -x) else id) delta) 0.0 0.0)
(Vector.make (if negate then -1.0 else 1.0) 0.0 0.0
|> Vector.unitise
|> Option.get)
let property
(x : NormalFloat)
(y : NormalFloat)
(z : NormalFloat)
(x' : NormalFloat)
(y' : NormalFloat)
(z' : NormalFloat)
: bool
=
let x1, x2 =
sort (if negate then abs x.Get else -abs x.Get) (if negate then abs x'.Get else -abs x'.Get)
let property (x : NormalFloat) (y : NormalFloat) (z : NormalFloat) (x' : NormalFloat) (y' : NormalFloat) (z' : NormalFloat) : bool =
let x1, x2 = sort (if negate then abs x.Get else -abs x.Get) (if negate then abs x'.Get else -abs x'.Get)
let y1, y2 = sort y.Get y'.Get
let z1, z2 = sort z.Get z'.Get
let box = BoundingBox.make (Point.make x1 y1 z1) (Point.make x2 y2 z2)
@@ -32,10 +46,24 @@ module TestBoundingBox =
[<TestCase false>]
let ``Bounding box on the top doesn't intersect ray to the bottom`` (negate : bool) =
let ray =
Ray.make (Point.make 0.0 ((if negate then (fun x -> -x) else id) delta) 0.0) (Vector.make 0.0 (if negate then -1.0 else 1.0) 0.0 |> Vector.unitise |> Option.get)
Ray.make
(Point.make 0.0 ((if negate then (fun x -> -x) else id) delta) 0.0)
(Vector.make 0.0 (if negate then -1.0 else 1.0) 0.0
|> Vector.unitise
|> Option.get)
let property
(x : NormalFloat)
(y : NormalFloat)
(z : NormalFloat)
(x' : NormalFloat)
(y' : NormalFloat)
(z' : NormalFloat)
: bool
=
let y1, y2 =
sort (if negate then abs y.Get else -abs y.Get) (if negate then abs y'.Get else -abs y'.Get)
let property (x : NormalFloat) (y : NormalFloat) (z : NormalFloat) (x' : NormalFloat) (y' : NormalFloat) (z' : NormalFloat) : bool =
let y1, y2 = sort (if negate then abs y.Get else -abs y.Get) (if negate then abs y'.Get else -abs y'.Get)
let x1, x2 = sort x.Get x'.Get
let z1, z2 = sort z.Get z'.Get
let box = BoundingBox.make (Point.make x1 y1 z1) (Point.make x2 y2 z2)
@@ -59,10 +87,24 @@ module TestBoundingBox =
[<TestCase false>]
let ``Bounding box forward doesn't intersect ray going backward`` (negate : bool) =
let ray =
Ray.make (Point.make 0.0 0.0 ((if negate then (fun x -> -x) else id) delta)) (Vector.make 0.0 0.0 (if negate then -1.0 else 1.0) |> Vector.unitise |> Option.get)
Ray.make
(Point.make 0.0 0.0 ((if negate then (fun x -> -x) else id) delta))
(Vector.make 0.0 0.0 (if negate then -1.0 else 1.0)
|> Vector.unitise
|> Option.get)
let property
(x : NormalFloat)
(y : NormalFloat)
(z : NormalFloat)
(x' : NormalFloat)
(y' : NormalFloat)
(z' : NormalFloat)
: bool
=
let z1, z2 =
sort (if negate then abs z.Get else -abs z.Get) (if negate then abs z'.Get else -abs z'.Get)
let property (x : NormalFloat) (y : NormalFloat) (z : NormalFloat) (x' : NormalFloat) (y' : NormalFloat) (z' : NormalFloat) : bool =
let z1, z2 = sort (if negate then abs z.Get else -abs z.Get) (if negate then abs z'.Get else -abs z'.Get)
let x1, x2 = sort x.Get x'.Get
let y1, y2 = sort y.Get y'.Get
let box = BoundingBox.make (Point.make x1 y1 z1) (Point.make x2 y2 z2)
@@ -78,4 +120,4 @@ module TestBoundingBox =
let box = BoundingBox.make (Point.make -1.0 -1.0 -1.0) (Point.make 1.0 1.0 1.0)
BoundingBox.hits (BoundingBox.inverseDirections ray) ray box |> shouldEqual true
BoundingBox.hits (BoundingBox.inverseDirections ray) ray box |> shouldEqual true

147
RayTracing.Test/TestPixel.fs
View File

@@ -12,9 +12,14 @@ module TestPixel =
[<Test>]
let ``Average of one pixel`` () =
let property (p1 : byte) (p2 : byte) (p3 : byte) : bool =
let pixel = { Red = p1 ; Green = p2 ; Blue = p3 }
Pixel.average [| pixel |]
|> (=) pixel
let pixel =
{
Red = p1
Green = p2
Blue = p3
}
Pixel.average [| pixel |] |> (=) pixel
Check.QuickThrowOnFailure property
@@ -23,64 +28,126 @@ module TestPixel =
let pixels =
[|
(0uy, 234uy, 0uy)
(0uy, 212uy, 0uy); (0uy, 59uy, 0uy); (0uy, 225uy, 0uy); (0uy, 132uy, 0uy);
(0uy, 69uy, 0uy); (0uy, 207uy, 0uy); (0uy, 212uy, 0uy); (0uy, 30uy, 0uy);
(0uy, 0uy, 0uy); (0uy, 179uy, 0uy); (0uy, 234uy, 0uy); (0uy, 54uy, 0uy);
(0uy, 212uy, 0uy)
(0uy, 59uy, 0uy)
(0uy, 225uy, 0uy)
(0uy, 132uy, 0uy)
(0uy, 69uy, 0uy)
(0uy, 207uy, 0uy)
(0uy, 212uy, 0uy)
(0uy, 30uy, 0uy)
(0uy, 0uy, 0uy)
(0uy, 179uy, 0uy)
(0uy, 234uy, 0uy)
(0uy, 54uy, 0uy)
(0uy, 43uy, 0uy)
|]
|> Array.map (fun (r, g, b) -> { Red = r ; Green = g ; Blue = b })
|> Array.map (fun (r, g, b) ->
{
Red = r
Green = g
Blue = b
}
)
let avg = Pixel.average pixels
avg.Green |> shouldEqual (pixels |> Seq.map (fun i -> float i.Green) |> Seq.average |> Math.Round |> byte)
avg.Red |> shouldEqual (pixels |> Seq.map (fun i -> float i.Red) |> Seq.average |> Math.Round |> byte)
avg.Blue |> shouldEqual (pixels |> Seq.map (fun i -> float i.Blue) |> Seq.average |> Math.Round |> byte)
avg.Green
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Green) |> Seq.average |> Math.Round |> byte)
avg.Red
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Red) |> Seq.average |> Math.Round |> byte)
avg.Blue
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Blue) |> Seq.average |> Math.Round |> byte)
[<Test>]
let ``Average of a few pixels, case 2`` () =
let pixels =
[|
(0uy, 0uy, 136uy)
(0uy, 0uy, 90uy); (0uy, 0uy, 109uy); (0uy, 0uy, 204uy); (0uy, 0uy, 209uy);
(0uy, 0uy, 31uy); (0uy, 0uy, 244uy); (0uy, 0uy, 67uy); (0uy, 0uy, 139uy);
(0uy, 0uy, 161uy); (0uy, 0uy, 179uy); (0uy, 0uy, 173uy); (0uy, 0uy, 100uy);
(0uy, 0uy, 109uy); (0uy, 0uy, 122uy); (0uy, 0uy, 27uy); (0uy, 0uy, 249uy);
(0uy, 0uy, 90uy)
(0uy, 0uy, 109uy)
(0uy, 0uy, 204uy)
(0uy, 0uy, 209uy)
(0uy, 0uy, 31uy)
(0uy, 0uy, 244uy)
(0uy, 0uy, 67uy)
(0uy, 0uy, 139uy)
(0uy, 0uy, 161uy)
(0uy, 0uy, 179uy)
(0uy, 0uy, 173uy)
(0uy, 0uy, 100uy)
(0uy, 0uy, 109uy)
(0uy, 0uy, 122uy)
(0uy, 0uy, 27uy)
(0uy, 0uy, 249uy)
(0uy, 0uy, 54uy)
|]
|> Array.map (fun (r, g, b) -> { Red = r ; Green = g ; Blue = b })
|> Array.map (fun (r, g, b) ->
{
Red = r
Green = g
Blue = b
}
)
let avg = Pixel.average pixels
avg.Green |> shouldEqual (pixels |> Seq.map (fun i -> float i.Green) |> Seq.average |> Math.Round |> byte)
avg.Red |> shouldEqual (pixels |> Seq.map (fun i -> float i.Red) |> Seq.average |> Math.Round |> byte)
avg.Blue |> shouldEqual (pixels |> Seq.map (fun i -> float i.Blue) |> Seq.average |> Math.Round |> byte)
avg.Green
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Green) |> Seq.average |> Math.Round |> byte)
avg.Red
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Red) |> Seq.average |> Math.Round |> byte)
avg.Blue
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Blue) |> Seq.average |> Math.Round |> byte)
[<Test>]
let ``Average of a few pixels, case 3`` () =
let pixels =
[|
(0uy, 0uy, 0uy)
(0uy, 0uy, 123uy)
|]
|> Array.map (fun (r, g, b) -> { Red = r ; Green = g ; Blue = b })
[| (0uy, 0uy, 0uy) ; (0uy, 0uy, 123uy) |]
|> Array.map (fun (r, g, b) ->
{
Red = r
Green = g
Blue = b
}
)
let avg = Pixel.average pixels
avg.Green |> shouldEqual (pixels |> Seq.map (fun i -> float i.Green) |> Seq.average |> Math.Round |> byte)
avg.Red |> shouldEqual (pixels |> Seq.map (fun i -> float i.Red) |> Seq.average |> Math.Round |> byte)
avg.Blue |> shouldEqual (pixels |> Seq.map (fun i -> float i.Blue) |> Seq.average |> Math.Round |> byte)
avg.Green
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Green) |> Seq.average |> Math.Round |> byte)
avg.Red
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Red) |> Seq.average |> Math.Round |> byte)
avg.Blue
|> shouldEqual (pixels |> Seq.map (fun i -> float i.Blue) |> Seq.average |> Math.Round |> byte)
[<Test>]
let ``Average of a few pixels`` () =
let property (fst : byte * byte * byte) (values : (byte * byte * byte) list) : bool =
let values = fst :: values
let pixels =
values
|> List.map (fun (a, b, c) -> { Pixel.Red = a ; Green = b ; Blue = c })
|> List.map (fun (a, b, c) ->
{
Pixel.Red = a
Green = b
Blue = c
}
)
let avg = Pixel.average (Array.ofList pixels)
avg.Green = (pixels |> List.map (fun i -> float i.Green) |> List.average |> Math.Round |> byte)
avg.Green = (pixels
|> List.map (fun i -> float i.Green)
|> List.average
|> Math.Round
|> byte)
&& avg.Red = (pixels |> List.map (fun i -> float i.Red) |> List.average |> Math.Round |> byte)
&& avg.Blue = (pixels |> List.map (fun i -> float i.Blue) |> List.average |> Math.Round |> byte)
@@ -89,10 +156,14 @@ module TestPixel =
[<Test>]
let ``Combine pixels with white`` () =
let property (r : byte) (g : byte) (b : byte) : bool =
let original = { Red = r ; Green = g ; Blue = b }
let combined =
original
|> Pixel.combine Colour.White
let original =
{
Red = r
Green = g
Blue = b
}
let combined = original |> Pixel.combine Colour.White
combined = original
Check.QuickThrowOnFailure property
@@ -100,9 +171,13 @@ module TestPixel =
[<Test>]
let ``Combine pixels with black`` () =
let property (r : byte) (g : byte) (b : byte) : bool =
let original = { Red = r ; Green = g ; Blue = b }
original
|> Pixel.combine Colour.Black
|> (=) Colour.Black
let original =
{
Red = r
Green = g
Blue = b
}
original |> Pixel.combine Colour.Black |> (=) Colour.Black
Check.QuickThrowOnFailure property

3
RayTracing.Test/TestPlane.fs
View File

@@ -15,10 +15,11 @@ module TestPlane =
let dotVectors = UnitVector.dot (Ray.vector v1) (Ray.vector v2)
let v1Length = UnitVector.dot (Ray.vector v1) (Ray.vector v1)
let v2Length = UnitVector.dot (Ray.vector v2) (Ray.vector v2)
Float.equal dotVectors 0.0
&& Float.equal v1Length 1.0
&& Float.equal v2Length 1.0
property
|> Prop.forAll (Arb.fromGen TestUtils.planeGen)
|> Check.QuickThrowOnFailure
|> Check.QuickThrowOnFailure

21
RayTracing.Test/TestPpmOutput.fs
View File

@@ -12,8 +12,7 @@ module TestRayTracing =
let ``Wikipedia example of PPM output`` () =
let fs = MockFileSystem ()
let expected =
TestUtils.getEmbeddedResource "PpmOutputExample.txt"
let expected = TestUtils.getEmbeddedResource "PpmOutputExample.txt"
let image =
[|
@@ -24,11 +23,12 @@ module TestRayTracing =
|]
[|
async {
return {
Red = 255uy
Blue = 0uy
Green = 255uy
}
return
{
Red = 255uy
Blue = 0uy
Green = 255uy
}
}
async { return Colour.White }
async { return Colour.Black }
@@ -36,9 +36,7 @@ module TestRayTracing =
|]
|> Image.make 2 3
let outputFile =
fs.Path.GetTempFileName ()
|> fs.FileInfo.FromFileName
let outputFile = fs.Path.GetTempFileName () |> fs.FileInfo.FromFileName
let tempOutput, await = ImageOutput.toPpm ignore image fs
@@ -51,5 +49,4 @@ module TestRayTracing =
}
|> Async.RunSynchronously
fs.File.ReadAllText outputFile.FullName
|> shouldEqual expected
fs.File.ReadAllText outputFile.FullName |> shouldEqual expected

36
RayTracing.Test/TestRandom.fs
View File

@@ -18,17 +18,18 @@ module TestRandom =
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 ()
let struct (r, s) = rand.GetTwo ()
check r
check s
| 3 ->
let struct(r, s, t) = rand.GetThree ()
let struct (r, s, t) = rand.GetThree ()
check r
check s
check t
@@ -38,34 +39,33 @@ module TestRandom =
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
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
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
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

29
RayTracing.Test/TestRay.fs
View File

@@ -20,42 +20,37 @@ module TestRay =
=
let origin1 = Point.make originX originY originZ
let origin2 =
Point.make origin2X origin2Y origin2Z
let origin2 = Point.make origin2X origin2Y origin2Z
let output = Ray.walkAlong (Ray.make origin1 vector) magnitude
let output2 = Ray.walkAlong (Ray.make origin2 vector) magnitude
let actual =
Point.differenceToThenFrom output output2
let actual = Point.differenceToThenFrom output output2
let expected =
Point.differenceToThenFrom origin1 origin2
let expected = Point.differenceToThenFrom origin1 origin2
Vector.equal actual expected
let gen : Gen<float> =
Arb.generate<NormalFloat>
|> Gen.map NormalFloat.op_Explicit
let gen : Gen<float> = Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit
let gen =
Gen.zip (Gen.zip (Gen.two (Gen.three gen)) TestUtils.unitVectorGen) gen
let gen = Gen.zip (Gen.zip (Gen.two (Gen.three gen)) TestUtils.unitVectorGen) gen
property
|> Prop.forAll (Arb.fromGen gen)
|> Check.QuickThrowOnFailure
property |> Prop.forAll (Arb.fromGen gen) |> Check.QuickThrowOnFailure
[<Test>]
let ``walkAlong walks the right distance`` () =
let property (ray : Ray, distance : float) =
let walked = Ray.walkAlong ray distance
Point.differenceToThenFrom walked (Ray.origin ray)
|> Vector.normSquared
|> Float.equal (distance * distance)
property
|> Prop.forAll (Arb.fromGen (Gen.zip TestUtils.rayGen (Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit)))
|> Prop.forAll (
Arb.fromGen (Gen.zip TestUtils.rayGen (Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit))
)
|> Check.QuickThrowOnFailure
[<Test>]
@@ -65,5 +60,7 @@ module TestRay =
Ray.liesOn walked ray
property
|> Prop.forAll (Arb.fromGen (Gen.zip TestUtils.rayGen (Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit)))
|> Prop.forAll (
Arb.fromGen (Gen.zip TestUtils.rayGen (Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit))
)
|> Check.QuickThrowOnFailure

141
RayTracing.Test/TestSphere.fs
View File

@@ -13,7 +13,10 @@ module TestSphere =
let ``Point at distance r from centre lies on sphere`` () =
let property (centre : Point, radius : float, point : Point) : bool =
let radius = abs radius
let sphere = Sphere.make (SphereStyle.PureReflection (1.0<albedo>, Texture.Colour Colour.White)) centre radius
let sphere =
Sphere.make (SphereStyle.PureReflection (1.0<albedo>, Texture.Colour Colour.White)) centre radius
Sphere.liesOn point sphere
@@ -21,31 +24,27 @@ module TestSphere =
gen {
let! centre = TestUtils.pointGen
let! radius = Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit
let! theta =
Arb.generate<NormalFloat>
|> Gen.map NormalFloat.op_Explicit
let! phi =
Arb.generate<NormalFloat>
|> Gen.map NormalFloat.op_Explicit
let! theta = Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit
let! phi = Arb.generate<NormalFloat> |> Gen.map NormalFloat.op_Explicit
let surfacePoint =
Point.make
(radius * cos phi * sin theta)
(radius * sin phi * sin theta)
(radius * cos theta)
Point.make (radius * cos phi * sin theta) (radius * sin phi * sin theta) (radius * cos theta)
|> fun p -> Point.sum centre p
return centre, radius, surfacePoint
}
property
|> Prop.forAll (Arb.fromGen gen)
|> Check.QuickThrowOnFailure
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 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>, Texture.Colour Colour.Green, 1.5<ior>, rand))
@@ -53,22 +52,30 @@ module TestSphere =
1.0
1.0
false
{ LightRay.Ray = ray ; Colour = Colour.White }
{
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
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 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>, Texture.Colour Colour.Green, 1.5<ior>, rand))
@@ -76,22 +83,30 @@ module TestSphere =
1.0
1.0
false
{ LightRay.Ray = ray ; Colour = Colour.White }
{
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
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 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>, Texture.Colour Colour.Green, 1.5<ior>, 1.0<prob>, rand))
@@ -99,31 +114,47 @@ module TestSphere =
1.0
1.0
false
{ LightRay.Ray = ray ; Colour = Colour.White }
{
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
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 ``Test planeMap`` () =
// theta required to be in 0,1
// phi required to be in 0,1
let property (((oX : NormalFloat, oY : NormalFloat, oZ : NormalFloat), (radius : NormalFloat)), (theta : float), (phi : float)) : bool =
let property
(
((oX : NormalFloat, oY : NormalFloat, oZ : NormalFloat), (radius : NormalFloat)),
(theta : float),
(phi : float)
)
: bool
=
let centre = Point.make oX.Get oY.Get oZ.Get
let radius = abs radius.Get
let point = Sphere.planeMap radius centre theta phi
let struct(remainingTheta, remainingPhi) = Sphere.planeMapInverse radius centre point
let struct (remainingTheta, remainingPhi) =
Sphere.planeMapInverse radius centre point
let result = Float.equal theta remainingTheta && Float.equal phi remainingPhi
result
let boundedFloat upperBound =
Arb.generate<NormalFloat> |> Gen.map (fun i -> abs i.Get) |> Gen.filter (fun i -> i <= upperBound)
Arb.generate<NormalFloat>
|> Gen.map (fun i -> abs i.Get)
|> Gen.filter (fun i -> i <= upperBound)
let arb =
gen {
@@ -137,44 +168,24 @@ module TestSphere =
}
|> Arb.fromGen
property
|> Prop.forAll arb
|> Check.QuickThrowOnFailure
property |> Prop.forAll arb |> 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)
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
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.Test/TestSphereIntersection.fs
View File

@@ -20,6 +20,7 @@ module TestSphereIntersection =
let ``Intersection of sphere and ray does lie on both`` () =
let property (ray : Ray, sphere : Sphere) : bool =
let intersection = Sphere.firstIntersection sphere ray
intersection
|> ValueOption.map (fun distance ->
let p = Ray.walkAlong ray distance
@@ -34,9 +35,16 @@ module TestSphereIntersection =
[<Test>]
let ``Intersection of sphere and ray does lie on both, case 1`` () =
let ray =
Ray.make' (Point.make 1.462205539 -4.888279676 7.123293244) (Vector.make -9.549697616 4.400018428 10.41024923)
Ray.make'
(Point.make 1.462205539 -4.888279676 7.123293244)
(Vector.make -9.549697616 4.400018428 10.41024923)
|> Option.get
let sphere = Sphere.make (SphereStyle.PureReflection (1.0<albedo>, Texture.Colour Colour.White)) (Point.make -5.688391601 -5.360125644 9.074300761) 8.199747973
let sphere =
Sphere.make
(SphereStyle.PureReflection (1.0<albedo>, Texture.Colour Colour.White))
(Point.make -5.688391601 -5.360125644 9.074300761)
8.199747973
let intersection = Sphere.firstIntersection sphere ray

9
RayTracing.Test/TestUtils.fs
View File

@@ -14,16 +14,11 @@ module TestUtils =
let getEmbeddedResource (filename : string) : string =
let filename =
Assembly
.GetAssembly(typeof<Dummy>)
.GetManifestResourceNames ()
Assembly.GetAssembly(typeof<Dummy>).GetManifestResourceNames ()
|> Seq.filter (fun s -> s.EndsWith filename)
|> Seq.exactlyOne
use stream =
Assembly
.GetAssembly(typeof<Dummy>)
.GetManifestResourceStream filename
use stream = Assembly.GetAssembly(typeof<Dummy>).GetManifestResourceStream filename
use reader = new StreamReader (stream)
reader.ReadToEnd().Replace ("\r\n", "\n")

77
RayTracing/BoundingBox.fs
View File

@@ -11,9 +11,9 @@ type BoundingBox =
module BoundingBox =
let volume (box : BoundingBox) =
(Point.coordinate 0 box.Max - Point.coordinate 0 box.Min) *
(Point.coordinate 1 box.Max - Point.coordinate 1 box.Min) *
(Point.coordinate 2 box.Max - Point.coordinate 2 box.Min)
(Point.coordinate 0 box.Max - Point.coordinate 0 box.Min)
* (Point.coordinate 1 box.Max - Point.coordinate 1 box.Min)
* (Point.coordinate 2 box.Max - Point.coordinate 2 box.Min)
let make (min : Point) (max : Point) =
{
@@ -23,9 +23,19 @@ module BoundingBox =
let inverseDirections (ray : Ray) =
struct(1.0 / (Ray.vector ray |> UnitVector.coordinate 0), 1.0 / (Ray.vector ray |> UnitVector.coordinate 1), 1.0 / (Ray.vector ray |> UnitVector.coordinate 2))
struct (1.0 / (Ray.vector ray |> UnitVector.coordinate 0),
1.0 / (Ray.vector ray |> UnitVector.coordinate 1),
1.0 / (Ray.vector ray |> UnitVector.coordinate 2))
let hits (struct(invX, invY, invZ)) { Ray.Origin = Point (x, y, z) ; Vector = UnitVector (Vector (dx, dy, dz))} (box : BoundingBox) : bool =
let hits
(struct (invX, invY, invZ))
{
Ray.Origin = Point (x, y, z)
Vector = _
}
(box : BoundingBox)
: bool
=
// The line is (x, y, z) + t (dx, dy, dz)
// The line goes through the cuboid iff it passes through the interval in each component:
// there is t such that boxMin.X <= x + t dx <= boxMax.X,
@@ -38,6 +48,7 @@ module BoundingBox =
let bailOut =
let mutable t0 = (Point.coordinate 0 box.Min - x) * invX
let mutable t1 = (Point.coordinate 0 box.Max - x) * invX
if invX < 0.0 then
let tmp = t1
t1 <- t0
@@ -48,35 +59,39 @@ module BoundingBox =
tMax < tMin || 0.0 >= tMax
if bailOut then false else
if bailOut then
false
else
let bailOut =
let mutable t0 = (Point.coordinate 1 box.Min - y) * invY
let mutable t1 = (Point.coordinate 1 box.Max - y) * invY
let bailOut =
let mutable t0 = (Point.coordinate 1 box.Min - y) * invY
let mutable t1 = (Point.coordinate 1 box.Max - y) * invY
if invY < 0.0 then
let tmp = t1
t1 <- t0
t0 <- tmp
if invY < 0.0 then
let tmp = t1
t1 <- t0
t0 <- tmp
tMin <- if t0 > tMin then t0 else tMin
tMax <- if t1 < tMax then t1 else tMax
tMin <- if t0 > tMin then t0 else tMin
tMax <- if t1 < tMax then t1 else tMax
tMax < tMin || 0.0 >= tMax
tMax < tMin || 0.0 >= tMax
if bailOut then false else
if bailOut then
false
else
let mutable t0 = (Point.coordinate 2 box.Min - z) * invZ
let mutable t1 = (Point.coordinate 2 box.Max - z) * invZ
let mutable t0 = (Point.coordinate 2 box.Min - z) * invZ
let mutable t1 = (Point.coordinate 2 box.Max - z) * invZ
if invZ < 0.0 then
let tmp = t1
t1 <- t0
t0 <- tmp
if invZ < 0.0 then
let tmp = t1
t1 <- t0
t0 <- tmp
tMin <- if t0 > tMin then t0 else tMin
tMax <- if t1 < tMax then t1 else tMax
tMax >= tMin && tMax >= 0.0
tMin <- if t0 > tMin then t0 else tMin
tMax <- if t1 < tMax then t1 else tMax
tMax >= tMin && tMax >= 0.0
let mergeTwo (i : BoundingBox) (j : BoundingBox) : BoundingBox =
{
@@ -92,8 +107,8 @@ module BoundingBox =
(max (Point.coordinate 2 i.Max) (Point.coordinate 2 j.Max))
}
let merge (boxes : BoundingBox []) : BoundingBox option =
if boxes.Length = 0 then None else
boxes
|> Array.reduce mergeTwo
|> Some
let merge (boxes : BoundingBox[]) : BoundingBox option =
if boxes.Length = 0 then
None
else
boxes |> Array.reduce mergeTwo |> Some

54
RayTracing/BoundingBoxTree.fs
View File

@@ -7,33 +7,37 @@ type BoundingBoxTree =
[<RequireQualifiedAccess>]
module BoundingBoxTree =
let make (boxes : (Hittable * BoundingBox) array) : BoundingBoxTree option =
if boxes.Length = 0 then None else
if boxes.Length = 0 then
None
else
let rec go (boxes : (Hittable * BoundingBox) array) =
let boundAll =
BoundingBox.merge (boxes |> Array.map snd) |> Option.get
let rec go (boxes : (Hittable * BoundingBox) array) =
let boundAll = BoundingBox.merge (boxes |> Array.map snd) |> Option.get
if boxes.Length = 1 then Leaf boxes.[0] else
if boxes.Length = 2 then Branch (Leaf boxes.[0], Leaf boxes.[1], boundAll) else
if boxes.Length = 1 then
Leaf boxes.[0]
else if boxes.Length = 2 then
Branch (Leaf boxes.[0], Leaf boxes.[1], boundAll)
else
let choices =
Array.init 3 (fun axis ->
let boxes =
boxes
|> Array.sortBy (fun (_, b) -> Point.coordinate axis b.Min)
let leftHalf = boxes.[0..boxes.Length / 2]
let rightHalf = boxes.[(boxes.Length / 2) + 1..]
let leftBound = leftHalf |> Array.map snd |> BoundingBox.merge |> Option.get
let rightBound = rightHalf |> Array.map snd |> BoundingBox.merge |> Option.get
(leftHalf, leftBound), (rightHalf, rightBound)
)
let (leftHalf, _), (rightHalf, _) =
choices
|> Array.minBy (fun ((_, leftBound), (_, rightBound)) ->
(BoundingBox.volume leftBound) + (BoundingBox.volume rightBound)
)
let choices =
Array.init
3
(fun axis ->
let boxes = boxes |> Array.sortBy (fun (_, b) -> Point.coordinate axis b.Min)
let leftHalf = boxes.[0 .. boxes.Length / 2]
let rightHalf = boxes.[(boxes.Length / 2) + 1 ..]
let leftBound = leftHalf |> Array.map snd |> BoundingBox.merge |> Option.get
let rightBound = rightHalf |> Array.map snd |> BoundingBox.merge |> Option.get
(leftHalf, leftBound), (rightHalf, rightBound)
)
Branch (go leftHalf, go rightHalf, boundAll)
let (leftHalf, _), (rightHalf, _) =
choices
|> Array.minBy (fun ((_, leftBound), (_, rightBound)) ->
(BoundingBox.volume leftBound) + (BoundingBox.volume rightBound)
)
go boxes
|> Some
Branch (go leftHalf, go rightHalf, boundAll)
go boxes |> Some

2
RayTracing/Camera.fs
View File

@@ -56,4 +56,4 @@ module Camera =
ViewportYAxis = yAxis
SamplesPerPixel = samplesPerPixel
BounceDepth = 150
}
}

29
RayTracing/Domain.fs
View File

@@ -8,7 +8,7 @@ type progress
type Image =
private
{
Rows : Pixel Async [] seq
Rows : Pixel Async[] seq
RowCount : int
ColCount : int
}
@@ -19,21 +19,30 @@ module Image =
let colCount i = i.ColCount
let render (i : Image) : (Pixel * Async<unit>) [] seq =
let render (i : Image) : (Pixel * Async<unit>)[] seq =
i.Rows
|> Seq.map (fun imageRow ->
if imageRow.Length <> i.ColCount then
failwithf "Thought the image had %i columns, got a pixel array with %i columns" i.ColCount imageRow.Length
failwithf
"Thought the image had %i columns, got a pixel array with %i columns"
i.ColCount
imageRow.Length
let outputRow = Array.zeroCreate<Pixel * Async<unit>> i.ColCount
let doIt =
imageRow
|> Array.mapi (fun i p -> async {
let! pixel = p
let _, a = outputRow.[i]
outputRow.[i] <- pixel, a
})
for k in 0..i.ColCount - 1 do
|> Array.mapi (fun i p ->
async {
let! pixel = p
let _, a = outputRow.[i]
outputRow.[i] <- pixel, a
}
)
for k in 0 .. i.ColCount - 1 do
outputRow.[k] <- Unchecked.defaultof<_>, doIt.[k]
outputRow
)
@@ -42,4 +51,4 @@ module Image =
RowCount = rowCount
ColCount = colCount
Rows = pixels
}
}

48
RayTracing/Float.fs
View File

@@ -26,8 +26,7 @@ module private FloatProducer =
let lowest = ((w >>> 24) &&& 0xFFu)
((highest <<< 24) ^^^ (secondHighest <<< 16) ^^^ (thirdHighest <<< 8) ^^^ lowest)
let inline toDouble (i : uint) =
float i / float UInt32.MaxValue
let inline toDouble (i : uint) = float i / float UInt32.MaxValue
type FloatProducer (rand : Random) =
let locker = obj ()
@@ -36,39 +35,45 @@ type FloatProducer (rand : Random) =
let mutable z = uint (rand.Next ())
let mutable w = uint (rand.Next ())
member __.Get () =
member _.Get () =
Monitor.Enter locker
let w =
try
FloatProducer.generateInt32 &x &y &z &w
finally
Monitor.Exit locker
FloatProducer.toDouble (FloatProducer.toInt w)
member __.GetTwo () : struct(float * float) =
member _.GetTwo () : struct (float * float) =
Monitor.Enter locker
let struct(w1, w2) =
let struct (w1, w2) =
try
let one = FloatProducer.generateInt32 &x &y &z &w
let two = FloatProducer.generateInt32 &x &y &z &w
struct(one, two)
struct (one, two)
finally
Monitor.Exit locker
struct(FloatProducer.toDouble (FloatProducer.toInt w1), FloatProducer.toDouble (FloatProducer.toInt w2))
struct (FloatProducer.toDouble (FloatProducer.toInt w1), FloatProducer.toDouble (FloatProducer.toInt w2))
member _.GetThree () : struct(float * float * float) =
member _.GetThree () : struct (float * float * float) =
Monitor.Enter locker
let struct(w1, w2, w3) =
let struct (w1, w2, w3) =
try
let one = FloatProducer.generateInt32 &x &y &z &w
let two = FloatProducer.generateInt32 &x &y &z &w
let three = FloatProducer.generateInt32 &x &y &z &w
struct(one, two, three)
struct (one, two, three)
finally
Monitor.Exit locker
struct(FloatProducer.toDouble (FloatProducer.toInt w1), FloatProducer.toDouble (FloatProducer.toInt w2), FloatProducer.toDouble (FloatProducer.toInt w3))
struct (FloatProducer.toDouble (FloatProducer.toInt w1),
FloatProducer.toDouble (FloatProducer.toInt w2),
FloatProducer.toDouble (FloatProducer.toInt w3))
[<RequireQualifiedAccess>]
@@ -76,27 +81,28 @@ module Float =
let tolerance = 0.00000001
let inline equal (a : float) (b : float) : bool =
abs (a - b) < tolerance
let inline equal (a : float) (b : float) : bool = abs (a - b) < tolerance
// TODO: use of this method appears to slow everything down
// by a factor of 4 - why?
let inline positive (a : float) : bool =
a > tolerance
let inline positive (a : float) : bool = a > tolerance
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
if abs (a - b) < LanguagePrimitives.FloatWithMeasure tolerance then
Comparison.Equal
elif a < b then
Comparison.Less
else
Comparison.Greater
let sortInPlaceBy<'b> (proj : 'b -> float) (a : 'b array) : 'b array =
for i in 0..a.Length - 2 do
for j in i+1..a.Length - 1 do
for i in 0 .. a.Length - 2 do
for j in i + 1 .. a.Length - 1 do
match compare (proj a.[i]) (proj a.[j]) with
| Greater ->
let tmp = a.[j]
a.[j] <- a.[i]
a.[i] <- tmp
| _ -> ()
a
a

13
RayTracing/Hittable.fs
View File

@@ -24,15 +24,8 @@ module Hittable =
/// Returns the distance we must walk along this ray before we first hit an object, the
/// colour the resulting light ray is after the interaction, and the new ray.
let hits
(ray : Ray)
(h : Hittable)
: float voption
=
let hits (ray : Ray) (h : Hittable) : float voption =
match h with
| UnboundedSphere s
| Sphere s ->
Sphere.firstIntersection s ray
| InfinitePlane plane ->
InfinitePlane.intersection plane ray
| Sphere s -> Sphere.firstIntersection s ray
| InfinitePlane plane -> InfinitePlane.intersection plane ray

130
RayTracing/ImageOutput.fs
View File

@@ -52,41 +52,71 @@ module ImageOutput =
let mutable answer = 0
let mutable keepGoing = true
let mutable toRet = ValueNone
while keepGoing do
let i = s.ReadByte ()
if i < 0 then keepGoing <- false else
// '0' is 48
// '9' is 57
if 48 <= i && i <= 57 then
if i < 0 then
keepGoing <- false
else if
// '0' is 48
// '9' is 57
48 <= i && i <= 57
then
answer <- (10 * answer + (i - 48))
else
toRet <- ValueSome answer
keepGoing <- false
toRet
let readPixelMap (incrementProgress : float<progress> -> unit) (progress : IFileInfo) (numRows : int) (numCols : int) : Async<Pixel ValueOption [] []> =
let rec go (dict : _ [] []) (reader : Stream) =
let readPixelMap
(incrementProgress : float<progress> -> unit)
(progress : IFileInfo)
(numRows : int)
(numCols : int)
: Async<Pixel ValueOption[][]>
=
let rec go (dict : _[][]) (reader : Stream) =
let row = consumeAsciiInteger reader
match row with
| ValueNone -> dict
| ValueSome row ->
let col = consumeAsciiInteger reader
match col with
| ValueNone -> dict
| ValueSome col ->
let r = reader.ReadByte ()
if r < 0 then dict else
let g = reader.ReadByte ()
if g = -1 then dict else
let b = reader.ReadByte ()
if b = -1 then dict else
incrementProgress 1.0<progress>
dict.[row].[col] <- ValueSome { Red = byte r ; Green = byte g ; Blue = byte b }
if r < 0 then
dict
else
let g = reader.ReadByte ()
go dict reader
if g = -1 then
dict
else
let b = reader.ReadByte ()
if b = -1 then
dict
else
incrementProgress 1.0<progress>
dict.[row].[col] <-
ValueSome
{
Red = byte r
Green = byte g
Blue = byte b
}
go dict reader
async {
use stream = progress.FileSystem.File.OpenRead progress.FullName
@@ -95,13 +125,21 @@ module ImageOutput =
return result
}
let resume (incrementProgress : float<progress> -> unit) (soFar : IReadOnlyDictionary<int * int, Pixel>) (image : Image) (fs : IFileSystem) : IFileInfo * Async<unit> =
let rec go (writer : Stream) (rowNum : int) (rowEnum : IEnumerator<Pixel Async []>) =
let resume
(incrementProgress : float<progress> -> unit)
(soFar : IReadOnlyDictionary<int * int, Pixel>)
(image : Image)
(fs : IFileSystem)
: IFileInfo * Async<unit>
=
let rec go (writer : Stream) (rowNum : int) (rowEnum : IEnumerator<Pixel Async[]>) =
async {
if not (rowEnum.MoveNext ()) then
return ()
else
let row = rowEnum.Current
do!
row
|> Array.mapi (fun colNum pixel ->
@@ -110,14 +148,19 @@ module ImageOutput =
match soFar.TryGetValue ((rowNum, colNum)) with
| false, _ -> pixel
| true, v -> async { return v }
let toWrite = ASCIIEncoding.Default.GetBytes (sprintf "%i,%i" rowNum colNum)
lock writer (fun () ->
writer.Write (toWrite, 0, toWrite.Length)
writer.WriteByte 10uy // '\n'
writer.WriteByte pixel.Red
writer.WriteByte pixel.Green
writer.WriteByte pixel.Blue
)
lock
writer
(fun () ->
writer.Write (toWrite, 0, toWrite.Length)
writer.WriteByte 10uy // '\n'
writer.WriteByte pixel.Red
writer.WriteByte pixel.Green
writer.WriteByte pixel.Blue
)
incrementProgress 1.0<progress>
return ()
}
@@ -128,10 +171,12 @@ module ImageOutput =
|> Async.Parallel
#endif
|> Async.Ignore
return! go writer (rowNum + 1) rowEnum
}
let tempFile = fs.Path.GetTempFileName () |> fs.FileInfo.FromFileName
tempFile,
async {
use outputStream = tempFile.OpenWrite ()
@@ -139,9 +184,16 @@ module ImageOutput =
return! go outputStream 0 enumerator
}
let writePpm (gammaCorrect : bool) (incrementProgress : float<progress> -> unit) (pixels : Pixel [] []) (output : IFileInfo) : Async<unit> =
let writePpm
(gammaCorrect : bool)
(incrementProgress : float<progress> -> unit)
(pixels : Pixel[][])
(output : IFileInfo)
: Async<unit>
=
let maxRow = pixels.Length
let maxCol = pixels.[0].Length
async {
use output = output.OpenWrite ()
use writer = new StreamWriter (output)
@@ -151,7 +203,7 @@ module ImageOutput =
writer.Write "255\n"
let writeRow (row : int) =
for col in 0..pixels.[row].Length - 2 do
for col in 0 .. pixels.[row].Length - 2 do
let pixel = pixels.[row].[col]
writer.Write (PixelOutput.toPpm gammaCorrect pixel)
writer.Write " "
@@ -161,15 +213,15 @@ module ImageOutput =
writer.Write (PixelOutput.toPpm gammaCorrect pixel)
incrementProgress 1.0<progress>
for row in 0..pixels.Length - 2 do
for row in 0 .. pixels.Length - 2 do
writeRow row
writer.Write "\n"
writeRow (pixels.Length - 1)
}
let assertComplete (image : Pixel ValueOption [] []) : Pixel [] [] =
image
|> Array.map (Array.map ValueOption.get)
let assertComplete (image : Pixel ValueOption[][]) : Pixel[][] =
image |> Array.map (Array.map ValueOption.get)
/// Write out this image to a temporary file, flushing intermediate work as quickly as possible.
/// Await the async to know when the entire image is complete.
@@ -185,27 +237,37 @@ module ImageOutput =
[<RequireQualifiedAccess>]
module Png =
let write (gammaCorrect : bool) (incrementProgress : float<progress> -> unit) (pixels : Pixel [] []) (output : IFileInfo) : Async<unit> =
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
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]
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
for row in 0 .. pixels.Length - 2 do
writeRow row
writeRow (pixels.Length - 1)
use fileStream = output.OpenWrite ()
img.Save (fileStream, ImageFormat.Png)
return ()
}
}

57
RayTracing/InfinitePlane.fs
View File

@@ -28,45 +28,45 @@ module InfinitePlane =
/// 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 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
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 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
| None ->
// Incoming ray is directly along the normal
Ray.flip incomingRay
|> Ray.parallelTo strikePoint
Ray.flip incomingRay |> Ray.parallelTo strikePoint
| 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 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.
|> Option.get
let newColour (incomingColour : Pixel) albedo colour =
Pixel.combine incomingColour colour
|> Pixel.darken albedo
Pixel.combine incomingColour colour |> Pixel.darken albedo
let reflection
(style : InfinitePlaneStyle)
@@ -86,33 +86,40 @@ module InfinitePlane =
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
let output = Point.differenceToThenFrom target strikePoint |> Ray.make' strikePoint
match output with
| None -> ()
| Some output ->
outgoing <- output
| Some output -> outgoing <- output
Continues { Ray = outgoing ; Colour = newColour }
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
|> Option.get
let newColour =
Pixel.combine incomingRay.Colour colour
|> Pixel.darken albedo
Continues { Ray = outgoing ; Colour = newColour }
let newColour = Pixel.combine incomingRay.Colour colour |> Pixel.darken albedo
Continues
{
Ray = outgoing
Colour = newColour
}
| InfinitePlaneStyle.PureReflection (albedo, colour) ->
{

14
RayTracing/LightRay.fs
View File

@@ -8,14 +8,14 @@ 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.)
}
type LightDestination =
| Continues of LightRay
| Absorbs of Pixel
| Absorbs of Pixel

29
RayTracing/Pixel.fs
View File

@@ -22,36 +22,42 @@ module Colour =
Green = 0uy
Blue = 0uy
}
let White =
{
Red = 255uy
Green = 255uy
Blue = 255uy
}
let Red =
{
Red = 255uy
Green = 0uy
Blue = 0uy
}
let Green =
{
Red = 0uy
Green = 255uy
Blue = 0uy
}
let Blue =
{
Red = 0uy
Green = 0uy
Blue = 255uy
}
let Yellow =
{
Red = 255uy
Green = 255uy
Blue = 0uy
}
let HotPink =
{
Red = 205uy
@@ -62,6 +68,7 @@ module Colour =
let random (rand : Random) =
let buffer = Array.zeroCreate<byte> 3
rand.NextBytes buffer
{
Red = buffer.[0]
Green = buffer.[1]
@@ -79,7 +86,13 @@ type PixelStats =
[<RequireQualifiedAccess>]
module PixelStats =
let empty () = { Count = 0 ; SumRed = 0 ; SumGreen = 0 ; SumBlue = 0 }
let empty () =
{
Count = 0
SumRed = 0
SumGreen = 0
SumBlue = 0
}
let add (p : Pixel) (stats : PixelStats) : unit =
stats.Count <- stats.Count + 1
@@ -98,17 +111,22 @@ module PixelStats =
module Pixel =
let difference (p1 : Pixel) (p2 : Pixel) : int =
abs (int p1.Red - int p2.Red) + abs (int p1.Green - int p2.Green) + abs (int p1.Blue - int p2.Blue)
abs (int p1.Red - int p2.Red)
+ abs (int p1.Green - int p2.Green)
+ abs (int p1.Blue - int p2.Blue)
let average (s : Pixel []) : Pixel =
let average (s : Pixel[]) : Pixel =
let mutable r = s.[0].Red |> float
let mutable g = s.[0].Green |> float
let mutable b = s.[0].Blue |> float
for i in 1..s.Length - 1 do
for i in 1 .. s.Length - 1 do
r <- r + float s.[i].Red
g <- g + float s.[i].Green
b <- b + float s.[i].Blue
let count = s.Length |> float
{
Red = byte (Math.Round (r / count))
Green = byte (Math.Round (g / count))
@@ -125,8 +143,9 @@ module Pixel =
/// albedo should be between 0 and 1.
let darken (albedo : float<albedo>) (p : Pixel) : Pixel =
let albedo = albedo / 1.0<albedo>
{
Red = (float p.Red) * albedo |> Math.Round |> byte
Green = (float p.Green) * albedo |> Math.Round |> byte
Blue = (float p.Blue) * albedo |> Math.Round |> byte
}
}

33
RayTracing/Plane.fs
View File

@@ -25,14 +25,9 @@ module Plane =
Vector.make 0.0 0.0 1.0
else
Vector.make 1.0 1.0 ((-x - y) / z)
let v2 =
Vector.cross v v1
|> Vector.unitise
|> Option.get
let v1 =
v1
|> Vector.unitise
|> Option.get
let v2 = Vector.cross v v1 |> Vector.unitise |> Option.get
let v1 = v1 |> Vector.unitise |> Option.get
{
Point = point
@@ -43,10 +38,12 @@ module Plane =
let inline makeNormalTo' (point : Point) (UnitVector v) = makeNormalTo point v
let orthonormalise (plane : Plane) : OrthonormalPlane option =
let coeff = UnitVector.dot plane.V1 plane.V2
let coefficient = UnitVector.dot plane.V1 plane.V2
let vec2 =
UnitVector.difference' plane.V2 (UnitVector.scale coeff plane.V1)
UnitVector.difference' plane.V2 (UnitVector.scale coefficient plane.V1)
|> Vector.unitise
match vec2 with
| None -> None
| Some v2 ->
@@ -69,7 +66,15 @@ module Plane =
let viewUp = Vector.unitise viewUp |> Option.get
let v1Component = UnitVector.dot plane.V1 viewUp
let v2Component = UnitVector.dot plane.V2 viewUp
let v2 = Vector.sum (UnitVector.scale v1Component plane.V1) (UnitVector.scale v2Component plane.V2) |> Vector.unitise |> Option.get
let v1 = Vector.sum (UnitVector.scale v2Component plane.V1) (UnitVector.scale (-v1Component) plane.V2) |> Vector.unitise |> Option.get
Ray.make plane.Point v1,
Ray.make plane.Point v2
let v2 =
Vector.sum (UnitVector.scale v1Component plane.V1) (UnitVector.scale v2Component plane.V2)
|> Vector.unitise
|> Option.get
let v1 =
Vector.sum (UnitVector.scale v2Component plane.V1) (UnitVector.scale (-v1Component) plane.V2)
|> Vector.unitise
|> Option.get
Ray.make plane.Point v1, Ray.make plane.Point v2

46
RayTracing/Point.fs
View File

@@ -5,48 +5,41 @@ open System.Runtime.CompilerServices
/// An n-dimensional point.
/// We don't let you compare these for equality, because floats are hard.
[<NoEquality ; NoComparison ; Struct ; IsReadOnly>]
type Point =
| Point of struct(float * float * float)
type Point = | Point of struct (float * float * float)
[<NoEquality ; NoComparison ; Struct ; IsReadOnly>]
type Vector =
| Vector of struct(float * float * float)
type Vector = | Vector of struct (float * float * float)
[<Struct ; IsReadOnly ; NoEquality ; NoComparison>]
type UnitVector = | UnitVector of Vector
[<RequireQualifiedAccess>]
module Vector =
let dot (Vector (x, y, z)) (Vector (a, b, c)) : float =
x * a + y * b + z * c
let dot (Vector (x, y, z)) (Vector (a, b, c)) : float = x * a + y * b + z * c
let sum (Vector (a, b, c)) (Vector (d, e, f)) =
Vector (a + d, b + e, c + f)
let sum (Vector (a, b, c)) (Vector (d, e, f)) = Vector (a + d, b + e, c + f)
let scale (scale : float) (vec : Vector) : Vector =
match vec with
| Vector (a, b, c) ->
Vector (scale * a, scale * b, scale * c)
| Vector (a, b, c) -> Vector (scale * a, scale * b, scale * c)
let difference (Vector (a, b, c)) (Vector (x, y, z)) : Vector =
Vector (a - x, b - y, c - z)
let difference (Vector (a, b, c)) (Vector (x, y, z)) : Vector = Vector (a - x, b - y, c - z)
let unitise (vec : Vector) : UnitVector option =
let dot = dot vec vec
if Float.equal dot 0.0 then None else
let factor = 1.0 / sqrt dot
scale factor vec
|> UnitVector
|> Some
let normSquared (vec : Vector) : float =
dot vec vec
if Float.equal dot 0.0 then
None
else
let factor = 1.0 / sqrt dot
scale factor vec |> UnitVector |> Some
let normSquared (vec : Vector) : float = dot vec vec
let equal (Vector (a, b, c)) (Vector (x, y, z)) : bool =
Float.equal a x && Float.equal b y && Float.equal c z
let make (x : float) (y : float) (z : float) =
Vector (x, y, z)
let make (x : float) (y : float) (z : float) = Vector (x, y, z)
let cross (Vector (x, y, z)) (Vector (a, b, c)) : Vector =
make (y * c - z * b) (z * a - x * c) (x * b - a * y)
@@ -54,10 +47,11 @@ module Vector =
[<RequireQualifiedAccess>]
module UnitVector =
let rec random (floatProducer : FloatProducer) (dimension : int) : UnitVector =
let struct(rand1, rand2, rand3) = floatProducer.GetThree ()
let struct (rand1, rand2, rand3) = floatProducer.GetThree ()
let x = (2.0 * rand1) - 1.0
let y = (2.0 * rand2) - 1.0
let z = (2.0 * rand3) - 1.0
Vector.make x y z
|> Vector.unitise
|> function
@@ -71,7 +65,7 @@ module UnitVector =
let inline scale (scale : float) (UnitVector vec) = Vector.scale scale vec
let inline flip (UnitVector vec) = UnitVector (Vector.scale -1.0 vec)
let basis (_ : int) : UnitVector [] =
let basis (_ : int) : UnitVector[] =
[|
Vector (1.0, 0.0, 0.0) |> UnitVector
Vector (0.0, 1.0, 0.0) |> UnitVector
@@ -95,11 +89,9 @@ module Point =
| 2 -> z
| _ -> failwithf "Bad coordinate: %i" i
let sum (Point (a, b, c)) (Point (x, y, z)) : Point =
Point (a + x, b + y, c + z)
let sum (Point (a, b, c)) (Point (x, y, z)) : Point = Point (a + x, b + y, c + z)
let differenceToThenFrom (Point (a, b, c)) (Point (x, y, z)) : Vector =
Vector (a - x, b - y, c - z)
let differenceToThenFrom (Point (a, b, c)) (Point (x, y, z)) : Vector = Vector (a - x, b - y, c - z)
let equal (Point (a, b, c)) (Point (x, y, z)) : bool =
Float.equal a x && Float.equal b y && Float.equal c z

7
RayTracing/Ray.fs
View File

@@ -41,10 +41,12 @@ module Ray =
| Point (p1, p2, p3), Point (o1, o2, o3), UnitVector (Vector (r1, r2, r3)) ->
let t = (p1 - o1) / r1
let t2 = (p2 - o2) / r2
if Float.equal t t2 then
let t3 = (p3 - o3) / r3
Float.equal t t3
else false
else
false
let inline vector r = r.Vector
let inline origin r = r.Origin
@@ -54,6 +56,5 @@ module Ray =
Origin = r.Origin
Vector =
let (UnitVector v) = r.Vector
Vector.scale -1.0 v
|> UnitVector
Vector.scale -1.0 v |> UnitVector
}

2
RayTracing/Ray.fsi
View File

@@ -22,4 +22,4 @@ module Ray =
val inline vector : Ray -> UnitVector
val inline origin : Ray -> Point
val flip : Ray -> Ray
val flip : Ray -> Ray

4
RayTracing/RayTracing.fsproj
View File

@@ -1,7 +1,7 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<TargetFramework>net5.0</TargetFramework>
<TargetFramework>net6.0</TargetFramework>
</PropertyGroup>
<ItemGroup>
@@ -25,8 +25,8 @@
</ItemGroup>
<ItemGroup>
<PackageReference Include="System.Drawing.Common" Version="6.0.0-preview.3.21201.4" />
<PackageReference Include="System.IO.Abstractions" Version="13.2.28" />
<PackageReference Include="System.Drawing.Common" Version="6.0.0-preview.3.21201.4" />
</ItemGroup>
</Project>

71
RayTracing/SampleImages.fs
View File

@@ -33,27 +33,79 @@ module SampleImages =
let spheres (progressIncrement : float<progress> -> unit) : float<progress> * Image Async =
let random = Random ()
let aspectRatio = 16.0 / 9.0
let camera =
Camera.makeBasic 4.0 aspectRatio (Point [| 0.0 ; 0.0 ; 0.0 |])
let camera = Camera.makeBasic 4.0 aspectRatio (Point [| 0.0 ; 0.0 ; 0.0 |])
let pixels = 200
{
Objects =
[|
Hittable.Sphere (Sphere.make (SphereStyle.LambertReflection (1.0, { Red = 255uy ; Green = 255uy ; Blue = 0uy }, random)) (Point [| 0.0 ; 0.0 ; 9.0 |]) 1.0)
Hittable.Sphere (Sphere.make (SphereStyle.PureReflection (1.0, { Red = 0uy ; Green = 255uy ; Blue = 255uy })) (Point [| 1.5 ; 0.5 ; 8.0 |]) 0.5)
Hittable.Sphere (Sphere.make (SphereStyle.LightSource Colour.Blue) (Point [| -1.5 ; 1.5 ; 8.0 |]) 0.5)
Hittable.Sphere (
Sphere.make
(SphereStyle.LambertReflection (
1.0,
{
Red = 255uy
Green = 255uy
Blue = 0uy
},
random
))
(Point [| 0.0 ; 0.0 ; 9.0 |])
1.0
)
Hittable.Sphere (
Sphere.make
(SphereStyle.PureReflection (
1.0,
{
Red = 0uy
Green = 255uy
Blue = 255uy
}
))
(Point [| 1.5 ; 0.5 ; 8.0 |])
0.5
)
Hittable.Sphere (
Sphere.make (SphereStyle.LightSource Colour.Blue) (Point [| -1.5 ; 1.5 ; 8.0 |]) 0.5
)
// Side mirror
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.PureReflection (1.0, { Colour.White with Green = 240uy })) (Point [| 0.1 ; 0.0 ; 16.0 |]) (Vector [| -2.0 ; 0.0 ; -1.0 |] |> Vector.unitise |> Option.get))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.PureReflection (
1.0,
{ Colour.White with
Green = 240uy
}
))
(Point [| 0.1 ; 0.0 ; 16.0 |])
(Vector [| -2.0 ; 0.0 ; -1.0 |] |> Vector.unitise |> Option.get)
)
// Floor mirror
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.PureReflection (0.4, Colour.White)) (Point [| 0.0 ; -1.0 ; 0.0 |]) (Vector [| 0.0 ; 1.0 ; 0.0 |] |> Vector.unitise |> Option.get))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.PureReflection (0.4, Colour.White))
(Point [| 0.0 ; -1.0 ; 0.0 |])
(Vector [| 0.0 ; 1.0 ; 0.0 |] |> Vector.unitise |> Option.get)
)
// Back plane
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.PureReflection (0.6, Colour.White)) (Point [| 0.0 ; 0.0 ; 16.0 |]) (Vector [| 0.0 ; 0.0 ; -1.0 |] |> Vector.unitise |> Option.get))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.PureReflection (0.6, Colour.White))
(Point [| 0.0 ; 0.0 ; 16.0 |])
(Vector [| 0.0 ; 0.0 ; -1.0 |] |> Vector.unitise |> Option.get)
)
// Light pad behind us
Hittable.InfinitePlane (InfinitePlane.make (InfinitePlaneStyle.LightSource Colour.White) (Point [| 0.0 ; 1.0 ; -1.0 |]) (Vector [| 0.0 ; -1.0 ; 1.0 |] |> Vector.unitise |> Option.get))
Hittable.InfinitePlane (
InfinitePlane.make
(InfinitePlaneStyle.LightSource Colour.White)
(Point [| 0.0 ; 1.0 ; -1.0 |])
(Vector [| 0.0 ; -1.0 ; 1.0 |] |> Vector.unitise |> Option.get)
)
|]
}
|> Scene.render progressIncrement (aspectRatio * (float pixels) |> int) pixels camera
@@ -62,4 +114,3 @@ module SampleImages =
match s with
| Gradient -> gradient
| Spheres -> spheres

145
RayTracing/Scene.fs
View File

@@ -17,17 +17,25 @@ module Scene =
objects
|> Array.map (fun h -> h, Hittable.boundingBox h)
|> Array.partition (snd >> Option.isSome)
let bounded = bounded |> Array.map (fun (h, box) -> h, Option.get box)
let unbounded = unbounded |> Array.map fst
let tree =
bounded
|> BoundingBoxTree.make
let tree = bounded |> BoundingBoxTree.make
{
UnboundedObjects = unbounded
BoundingBoxes = tree
}
let rec bestCandidate (inverseDirections : struct(float * float * float)) (ray : Ray) (bestFloat : float) (bestObject : Hittable) (bestLength : float) (box : BoundingBoxTree) : struct(float * Hittable * float) =
let rec bestCandidate
(inverseDirections : struct (float * float * float))
(ray : Ray)
(bestFloat : float)
(bestObject : Hittable)
(bestLength : float)
(box : BoundingBoxTree)
: struct (float * Hittable * float)
=
match box with
| BoundingBoxTree.Leaf (object, box) ->
if BoundingBox.hits inverseDirections ray box then
@@ -35,22 +43,23 @@ module Scene =
| ValueNone -> struct (bestFloat, bestObject, bestLength)
| ValueSome point ->
let a = point * point
if a < bestFloat then
struct (a, object, point)
else
struct (bestFloat, bestObject, bestLength)
else struct (bestFloat, bestObject, bestLength)
else
struct (bestFloat, bestObject, bestLength)
| BoundingBoxTree.Branch (left, right, all) ->
if BoundingBox.hits inverseDirections ray all then
let struct (bestFloat, bestObject, bestLength) = bestCandidate inverseDirections ray bestFloat bestObject bestLength left
bestCandidate inverseDirections ray bestFloat bestObject bestLength right
else struct (bestFloat, bestObject, bestLength)
let struct (bestFloat, bestObject, bestLength) =
bestCandidate inverseDirections ray bestFloat bestObject bestLength left
let hitObject
(s : Scene)
(ray : Ray)
: (Hittable * Point) option
=
bestCandidate inverseDirections ray bestFloat bestObject bestLength right
else
struct (bestFloat, bestObject, bestLength)
let hitObject (s : Scene) (ray : Ray) : (Hittable * Point) option =
let mutable best = Unchecked.defaultof<_>
let mutable bestLength = nan
let mutable bestFloat = infinity
@@ -58,7 +67,9 @@ module Scene =
match s.BoundingBoxes with
| None -> ()
| Some boundingBoxes ->
let struct(f, o, l) = bestCandidate (BoundingBox.inverseDirections ray) ray bestFloat best bestLength boundingBoxes
let struct (f, o, l) =
bestCandidate (BoundingBox.inverseDirections ray) ray bestFloat best bestLength boundingBoxes
bestFloat <- f
best <- o
bestLength <- l
@@ -68,62 +79,91 @@ module Scene =
| ValueNone -> ()
| ValueSome point ->
let a = point * point
if Float.compare a bestFloat = Less then
bestFloat <- a
best <- i
bestLength <- point
if Double.IsNaN bestLength then None else
Some (best, Ray.walkAlong ray bestLength)
if Double.IsNaN bestLength then
None
else
Some (best, Ray.walkAlong ray bestLength)
let internal traceRay
(maxCount : int)
(scene : Scene)
(ray : LightRay)
: Pixel
=
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
if ray.Colour = Colour.Black then
Colour.Black
else
Colour.HotPink
else
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 (object, strikePoint) ->
let outgoingRay = object.Reflection ray strikePoint
match outgoingRay with
| Absorbs colour ->
colour
| Continues outgoingRay ->
go (bounces + 1) outgoingRay
| Absorbs colour -> colour
| Continues outgoingRay -> go (bounces + 1) outgoingRay
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 struct(rand1, rand2) = rand.GetTwo ()
let private traceOnce
(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
let pointOnXAxis =
landingPoint
|> Ray.walkAlong camera.ViewportXAxis
let pointOnXAxis = landingPoint |> Ray.walkAlong camera.ViewportXAxis
let toWalkUp = Ray.parallelTo pointOnXAxis camera.ViewportYAxis
let endPoint =
((float row + rand2) * camera.ViewportHeight) / float maxHeightCoord
|> Ray.walkAlong toWalkUp
let ray =
Ray.make' (Ray.origin camera.View) (Point.differenceToThenFrom endPoint (Ray.origin camera.View))
|> Option.get
// 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
{
Ray = ray
Colour = Colour.White
}
PixelStats.add result stats
let renderPixel (_ : string -> unit) (scene : Scene) (rand : FloatProducer) (camera : Camera) maxWidthCoord maxHeightCoord row col =
let renderPixel
(_ : 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.
@@ -143,12 +183,12 @@ module Scene =
let difference = Pixel.difference newMean oldMean
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
// The mean didn't really change when we added another five samples; assume it's not going to change
// with more.
newMean
else
for _ in 1..(camera.SamplesPerPixel - 2 * firstTrial - 1) do
for _ in 1 .. (camera.SamplesPerPixel - 2 * firstTrial - 1) do
traceOnce scene rand camera maxWidthCoord maxHeightCoord row col stats
PixelStats.mean stats
@@ -167,20 +207,27 @@ module Scene =
// in the direction of that pixel.
let rowsIter = 2 * maxHeightCoord + 1
let colsIter = 2 * maxWidthCoord + 1
1.0<progress> * float (rowsIter * colsIter),
{
RowCount = rowsIter
ColCount = colsIter
Rows =
Array.init rowsIter (fun row ->
let row = maxHeightCoord - row - 1
Array.init colsIter (fun col ->
let col = col - maxWidthCoord
async {
let ret = renderPixel print s rand camera maxWidthCoord maxHeightCoord row col
progressIncrement 1.0<progress>
return ret
}
Array.init
rowsIter
(fun row ->
let row = maxHeightCoord - row - 1
Array.init
colsIter
(fun col ->
let col = col - maxWidthCoord
async {
let ret = renderPixel print s rand camera maxWidthCoord maxHeightCoord row col
progressIncrement 1.0<progress>
return ret
}
)
)
)
}
}

175
RayTracing/Sphere.fs
View File

@@ -31,7 +31,7 @@ type SphereStyle =
/// Perfect reflection, as you would see from a smooth flat metal surface.
/// Albedo must be between 0 and 1.
/// Fuzz must be between 0 (no fuzziness) and 1 (lots of fuzziness)
| FuzzedReflection of albedo : float<albedo> * texture : Texture * fuzz : float<fuzz> * FloatProducer
| FuzzedReflection of albedo : float<albedo> * texture : Texture * fuzz : float<fuzz> * FloatProducer
/// 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.
@@ -40,7 +40,12 @@ type SphereStyle =
/// 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> * texture : Texture * boundaryRefractance : float<ior> * refraction : float<prob> * FloatProducer
| Dielectric of
albedo : float<albedo> *
texture : Texture *
boundaryRefractance : float<ior> *
refraction : float<prob> *
FloatProducer
/// A glass material which uses Schlick's approximation for reflectance probability.
| Glass of albedo : float<albedo> * texture : Texture * float<ior> * FloatProducer
@@ -55,21 +60,23 @@ module Sphere =
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 * cos phi * sin theta) (-radius * cos theta) (-radius * sin phi * sin theta)
|> Point.sum centre
/// 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 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 (-y)
let phi = atan2 (-z) x + System.Math.PI
struct((phi / (2.0 * System.Math.PI)), theta / 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.
let normal (centre : Point) (p : Point) : Ray =
Ray.make' p (Point.differenceToThenFrom p centre)
|> Option.get
Ray.make' p (Point.differenceToThenFrom p centre) |> Option.get
let private liesOn' (centre : Point) (radius : float) (p : Point) : bool =
let rSquared = radius * radius
@@ -90,30 +97,43 @@ module Sphere =
// 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
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))
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
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 =
Plane.makeSpannedBy normal incomingLight.Ray
|> Plane.orthonormalise
let plane = Plane.makeSpannedBy normal incomingLight.Ray |> Plane.orthonormalise
let outgoing =
match plane with
| None ->
// Incoming ray is directly along the normal
Ray.flip incomingLight.Ray
|> Ray.parallelTo strikePoint
Ray.flip incomingLight.Ray |> Ray.parallelTo strikePoint
| 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 incomingLight.Ray)
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
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.
@@ -123,37 +143,42 @@ module Sphere =
| 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>)
let exitPoint =
Point.differenceToThenFrom target strikePoint
|> Ray.make' strikePoint
Point.differenceToThenFrom target strikePoint |> Ray.make' strikePoint
match exitPoint with
| None -> ()
| Some o ->
answer <- o
| Some o -> answer <- o
answer
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
|> Plane.orthonormalise
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
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
@@ -173,27 +198,30 @@ module Sphere =
let circleCentreZCoord = Point.coordinate 0 centre
let zCoordLowerBound = circleCentreZCoord + (radius - (radius / 4.0))
let strikeZCoord = Point.coordinate 0 strikePoint
let colour =
match Float.compare strikeZCoord zCoordLowerBound with
| Greater ->
Pixel.combine colour incomingLight.Colour
| _ ->
Colour.Black
| Greater -> Pixel.combine colour incomingLight.Colour
| _ -> Colour.Black
Absorbs 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
Point.differenceToThenFrom target strikePoint |> Ray.make' strikePoint
match outputPoint with
| Some o -> answer <- o
| None -> ()
answer
let newColour =
@@ -201,7 +229,12 @@ module Sphere =
|> Texture.colourAt strikePoint
|> Pixel.combine incomingLight.Colour
|> Pixel.darken albedo
Continues { Ray = outgoing ; Colour = newColour }
Continues
{
Ray = outgoing
Colour = newColour
}
| SphereStyle.PureReflection (albedo, texture) ->
let darkened =
@@ -210,7 +243,11 @@ module Sphere =
|> Pixel.combine incomingLight.Colour
|> Pixel.darken albedo
Continues { Ray = fuzzedReflection None ; Colour = darkened }
Continues
{
Ray = fuzzedReflection None
Colour = darkened
}
| SphereStyle.FuzzedReflection (albedo, texture, fuzz, random) ->
let darkened =
@@ -219,7 +256,11 @@ module Sphere =
|> Pixel.combine incomingLight.Colour
|> Pixel.darken albedo
Continues { Ray = fuzzedReflection (Some (fuzz, random)) ; Colour = darkened }
Continues
{
Ray = fuzzedReflection (Some (fuzz, random))
Colour = darkened
}
| SphereStyle.Dielectric (albedo, texture, sphereRefractance, refractionProb, random) ->
let newColour =
@@ -232,10 +273,19 @@ module Sphere =
if LanguagePrimitives.FloatWithMeasure rand > refractionProb then
// reflect!
Continues { Ray = fuzzedReflection None ; Colour = newColour }
Continues
{
Ray = fuzzedReflection None
Colour = newColour
}
else
let incomingCos = UnitVector.dot (Ray.vector incomingLight.Ray) (Ray.vector normal)
Continues { Ray = refract incomingCos sphereRefractance ; Colour = newColour }
Continues
{
Ray = refract incomingCos sphereRefractance
Colour = newColour
}
| SphereStyle.Glass (albedo, texture, sphereRefractance, random) ->
let newColour =
@@ -244,29 +294,48 @@ module Sphere =
|> Pixel.combine incomingLight.Colour
|> Pixel.darken albedo
let incomingCos = UnitVector.dot (UnitVector.flip (Ray.vector incomingLight.Ray)) (Ray.vector normal)
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 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
// reflect!
Continues { Ray = fuzzedReflection None ; Colour = newColour }
Continues
{
Ray = fuzzedReflection None
Colour = newColour
}
else
Continues { Ray = refract incomingCos sphereRefractance ; Colour = newColour }
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 (Float.compare radius 0.0 = Less)
RadiusSquared = radiusSquared
BoundingBox = BoundingBox.make (Point.sum centre (Point.make -radius -radius -radius)) (Point.sum centre (Point.make radius radius radius))
BoundingBox =
BoundingBox.make
(Point.sum centre (Point.make -radius -radius -radius))
(Point.sum centre (Point.make radius radius radius))
}
let boundingBox (s : Sphere) = s.BoundingBox
@@ -278,11 +347,7 @@ module 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
=
let firstIntersection (sphere : Sphere) (ray : Ray) : float voption =
let difference = Point.differenceToThenFrom (Ray.origin ray) sphere.Centre
let b = (UnitVector.dot' (Ray.vector ray) difference)
@@ -293,28 +358,30 @@ module Sphere =
let intersectionPoint =
match Float.compare discriminantOverFour 0.0 with
| Comparison.Equal ->
Some (-b)
| Comparison.Equal -> Some (-b)
| Comparison.Less -> None
| Comparison.Greater ->
let intermediate = sqrt discriminantOverFour
let i1 = intermediate - b
let i2 = - (b + intermediate)
let i2 = -(b + intermediate)
let i1Pos = Float.positive i1
let i2Pos = Float.positive i2
if i1Pos && i2Pos then
match Float.compare i1 i2 with
| Less -> i1
| Greater -> i2
| Equal -> i1
|> Some
elif i1Pos then Some i1
elif i2Pos then Some i2
else None
elif i1Pos then
Some i1
elif i2Pos then
Some i2
else
None
match intersectionPoint with
| None -> ValueNone
| Some i ->
// Don't return anything that's behind us
if Float.positive i then
ValueSome i
else ValueNone
if Float.positive i then ValueSome i else ValueNone

39
RayTracing/Texture.fs
View File

@@ -26,36 +26,45 @@ type ParameterisedTexture =
module ParameterisedTexture =
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 }
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 ->
let struct(x, y) = interpret p
let struct (x, y) = interpret p
Texture.colourAt p (f x y)
| ParameterisedTexture.Checkered (even, odd, gridSize) ->
let struct(x, y) = interpret p
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
| ParameterisedTexture.Image img ->
let struct(x, y) = interpret p
let x = int ((1.0-x) * float (img.[0].Length - 1))
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 =
let toTexture (interpret : Point -> struct (float * float)) (texture : ParameterisedTexture) : Texture =
match texture with
| ParameterisedTexture.Colour p -> Texture.Colour p
| _ ->
colourAt interpret texture
|> Texture.Arbitrary
| _ -> colourAt interpret texture |> Texture.Arbitrary