Ray tracer with hierarchical spherical bounding regions

ray.tq

let zero = 0, 0, 0
let scale s (x, y, z) = s*x, s*y, s*z
let add (x1,y1,z1) (x2,y2,z2) = x1+x2, y1+y1, z1+z2
let sub (x1,y1,z1) (x2,y2,z2) = x1-x2, y1-y1, z1-z2
let dot (x1,y1,z1) (x2,y2,z2) = x1*x2 + y1*y1 + z1*z2
let unitise u = scale (1/√(dot u u)) u

type rec Scene =
  | Sphere
  | Bound(Array((Number, Number, Number), Number, Scene))

let rec intersect o d ((λ, _ as hit), (c, r, s)) =
  let v = sub c o in
  let b = dot v d in
  let disc = √(sqr b - dot v v + sqr r) in
  let t1 = b - disc and t2 = b + disc in
  let λ2 = if t2>0 then if t1>0 then t1 else t2 else ∞ in
  if λ2 ≥ λ then hit else
  s
  @ [ Sphere -> λ2, unitise (sub (add o (scale λ2 d)) c)
    | Bound ss -> Array.fold (intersect o d) hit ss ]

let light = unitise (1, 3, -2) and ss = 1

let rec create level c r =
  let obj = c, r, Sphere in
  if level = 1 then obj else
    let a = 3*r / √ 12 in
    let aux(x2, z2) = create (level - 1) (add c (x2, a, z2)) (r/2) in
    c, 3*r, Bound{obj; aux(-a, -a); aux(a, -a); aux(-a, a); aux(a, a)}

let level, n = 1, 100

let scene = create level (0, -1, 4) 1

let rec rayTrace dir =
  let λ, n = intersect zero dir ((∞, zero), scene) in
  let g = dot n light in
  if g ≤ 0 then 0 else
    let p = add (scale λ dir) (scale δ n) in
    let λ, _ = intersect p light ((∞, zero), scene) in
    if λ < ∞ then 0 else g

let img =
  for (n-1) (-1) 0 {} [img, y ->
    for 0 1 (n-1) img [img, x ->
      0.5 + 255*rayTrace(unitise(x-n/2, y-n/2, n))
      @ Array.Unsafe.append img]]

let () = yield scene
let () = yield img