Something went wrong. Try again.
A ray tracer in Coalton
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237(cl:defpackage #:ray (:use #:coalton #:coalton-prelude #:io/monad-io #:io/simple-io #:io/thread #:io/conc/ring-buffer #:io/conc/worker-pool) (:import-from #:coalton/experimental/do-control-loops #:do-loop-times) (:local-nicknames (#:file #:coalton/file) (#:it #:coalton/iterator) (#:list #:coalton/list) (#:math #:coalton/math) (#:trig #:coalton/math/elementary) (#:sh #:coalton/show) (#:la #:coalton/lisparray) (#:c #:ray/color) (#:v #:ray/vec3) (#:h #:ray/hittable) (#:r #:ray/ray) (#:s #:ray/sphere) (#:m #:ray/material) (#:util #:ray/util) (#:scene #:ray/scene) (#:ppm #:ray/ppm)))
(cl:in-package #:ray)
(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0) (cl:debug 0)))
(coalton-toplevel (declare ASPECT-RATIO Fraction) (define ASPECT-RATIO (/ 16 9)) (declare IMAGE-WIDTH UFix) (define IMAGE-WIDTH 1200) (declare IMAGE-HEIGHT UFix) (define IMAGE-HEIGHT (unwrap-as UFix (floor (/ (into IMAGE-WIDTH) ASPECT-RATIO)))) (declare SAMPLES-PER-PIXEL UFix) (define SAMPLES-PER-PIXEL 500) (declare PIXEL-SAMPLES-SCALE F64) (define PIXEL-SAMPLES-SCALE (/ 1.0d0 (unwrap-as F64 SAMPLES-PER-PIXEL))) (declare VFOV F64) (define VFOV 20.0d0) (declare DEFOCUS-ANGLE F64) (define DEFOCUS-ANGLE 0.6d0) (declare FOCUS-DIST F64) (define FOCUS-DIST 10.0d0) (declare LOOK-FROM v:Vec3) (define LOOK-FROM (v:Vec3 13.0d0 2.0d0 3.0d0)) (declare LOOK-AT v:Vec3) (define LOOK-AT (v:Vec3 0.0d0 0.0d0 0.0d0)) (declare CAMERA-UP v:Vec3) (define CAMERA-UP (v:Vec3 0.0d0 1.0d0 0.0d0)) (declare FOCAL-LENGTH F64) (define FOCAL-LENGTH (v:vec-length (v:vec-sub LOOK-FROM LOOK-AT))) (define W (v:unit-vector (v:vec-sub LOOK-FROM LOOK-AT))) (define U (v:unit-vector (v:vec-cross CAMERA-UP W))) (define V (v:vec-cross W U)) (declare VIEWPORT-HEIGHT F64) (define VIEWPORT-HEIGHT (* 2.0d0 (* (trig:tan (/ (util:deg-to-rad VFOV) 2.0d0)) FOCUS-DIST))) (declare VIEWPORT-WIDTH F64) (define VIEWPORT-WIDTH (* VIEWPORT-HEIGHT (/ (unwrap-as F64 IMAGE-WIDTH) (unwrap-as F64 IMAGE-HEIGHT)))) (declare COLORS UFix) (define COLORS 255) (declare CAMERA-CENTER v:Vec3) (define CAMERA-CENTER LOOK-FROM) (declare VIEWPORT-U v:Vec3) (define VIEWPORT-U (v:vec-mul-scalar U VIEWPORT-WIDTH)) (declare VIEWPORT-V v:Vec3) (define VIEWPORT-V (v:vec-mul-scalar (v:vec-negate V) VIEWPORT-HEIGHT)) (declare PIXEL-DELTA-U v:Vec3) (define PIXEL-DELTA-U (v:vec-div-scalar VIEWPORT-U (unwrap-as F64 IMAGE-WIDTH)))
(declare PIXEL-DELTA-V v:Vec3) (define PIXEL-DELTA-V (v:vec-div-scalar VIEWPORT-V (unwrap-as F64 IMAGE-HEIGHT))) (declare VIEWPORT-UPPER-LEFT v:Vec3) (define VIEWPORT-UPPER-LEFT (v:vec-sub (v:vec-sub (v:vec-sub CAMERA-CENTER (v:vec-mul-scalar W FOCUS-DIST)) (v:vec-div-scalar VIEWPORT-U 2.0d0)) (v:vec-div-scalar VIEWPORT-V 2.0d0))) (declare PIXEL-00-LOC v:Vec3) (define PIXEL-00-LOC (v:vec-add VIEWPORT-UPPER-LEFT (v:vec-mul-scalar (v:vec-add PIXEL-DELTA-U PIXEL-DELTA-V) 0.5d0))) (define DEFOCUS-RADIUS (* FOCUS-DIST (trig:tan (util:deg-to-rad (/ DEFOCUS-ANGLE 2.0d0))))) (define DEFOCUS-DISK-U (v:vec-mul-scalar U DEFOCUS-RADIUS)) (define DEFOCUS-DISK-V (v:vec-mul-scalar V DEFOCUS-RADIUS))
(declare INFINITY F64) (define INFINITY (the F64 math:infinity)) (declare MAX_DEPTH UFix) (define MAX_DEPTH 50) (declare NUM-THREADS UFix) (define NUM-THREADS 12) (declare get-ray (UFix * UFix -> r:Ray)) (define (get-ray i j) "Construct a camera ray originating at the origin and directed at a randomly sampled point around pixel location (i,j)" (let (values offset-x offset-y) = (sample-square)) (let pixel-sample = (v:vec-add PIXEL-00-LOC (v:vec-add (v:vec-mul-scalar PIXEL-DELTA-U (+ (unwrap-as F64 i) offset-x)) (v:vec-mul-scalar PIXEL-DELTA-V (+ (unwrap-as F64 j) offset-y))))) (let ray-origin = (if (<= DEFOCUS-ANGLE 0) CAMERA-CENTER (defocus-disk-sample))) (let direction = (v:vec-sub pixel-sample ray-origin)) (r:Ray ray-origin direction)) (declare defocus-disk-sample (Void -> v:Vec3)) (define (defocus-disk-sample) (let (v:Vec3 x y _) = (v:random-in-unit-disk)) (v:vec-add CAMERA-CENTER (v:vec-add (v:vec-mul-scalar DEFOCUS-DISK-U x) (v:vec-mul-scalar DEFOCUS-DISK-V y)))) (declare sample-square (Void -> F64 * F64)) (define (sample-square) (values (- (util:rand-f64) 0.5d0) (- (util:rand-f64) 0.5d0))) (declare hit-any? (r:Ray * F64 * F64 -> Optional h:HitRecord)) (define (hit-any? ray tmin tmax) (let (Tuple closest-hit _) = (fold (fn ((Tuple hit-rec closest-so-far) obj) (match (h:hit? obj ray tmin closest-so-far) ((Some hit) (Tuple (Some hit) (.t hit))) ((None) (Tuple hit-rec closest-so-far)))) (Tuple None tmax) scene:complex-world)) closest-hit) (declare ray-color (r:Ray * UFix -> c:Color)) (define (ray-color r depth) (cond ((<= depth 0) c:black) (True (match (hit-any? r 0.0d001 INFINITY) ((Some (h:HitRecord point normal _ front-face? material)) (let (values maybe-ray attenuation) = (m:scatter r point normal front-face? material)) (match maybe-ray ((Some scatter-ray) (c:mul attenuation (ray-color scatter-ray (1- depth)))) ; We return 0,0,0 in the None case ((None) attenuation))) ((None) (let (v:Vec3 _ y _) = (v:unit-vector (.direction r))) (let alpha = (* 0.5d0 (+ y 1.0d0))) (c:add (c:mul-scalar c:white (- 1.0d0 alpha)) (c:mul-scalar (c:Color 0.5d0 0.7d0 1.0d0) alpha)))))))
(declare pixel-center (UFix * UFix -> v:Vec3)) (define (pixel-center i j) (v:vec-add PIXEL-00-LOC (v:vec-add (v:vec-mul-scalar PIXEL-DELTA-U (unwrap-as F64 i)) (v:vec-mul-scalar PIXEL-DELTA-V (unwrap-as F64 j))))) (declare generate-pixel (UFix * UFix -> c:Color)) (define (generate-pixel x y) (for ((sample 0 (1+ sample)) (pixel-color c:black (c:add pixel-color (ray-color (get-ray x y) MAX_DEPTH)))) :returns (c:mul-scalar pixel-color PIXEL-SAMPLES-SCALE) :repeat SAMPLES-PER-PIXEL))
(declare sync-main (Void -> Void)) (define (sync-main) (let image-buffer = (la:make (* IMAGE-HEIGHT IMAGE-WIDTH) (c:Color 1.0d0 0.0d0 0.0d0))) (for* ((y 0 (1+ y))) :repeat IMAGE-HEIGHT (print (<> "Scanlines remaining: " (into (- IMAGE-HEIGHT y)))) (for* ((x 0 (1+ x))) :repeat IMAGE-WIDTH (let color = (generate-pixel x y)) (let offset = (+ x (* y IMAGE-WIDTH))) (la:set! image-buffer offset color))) (ppm:save-image image-buffer IMAGE-WIDTH IMAGE-HEIGHT COLORS)) (declare threaded-main (Void -> Void)) (define (threaded-main) (let image-buffer = (la:make (* IMAGE-HEIGHT IMAGE-WIDTH) (c:Color 1.0d0 0.0d0 0.0d0))) (run-io! (do ;; Setup the worker pool (scheduler <- (new-ring-buffer-scheduler NUM-THREADS)) (pool <- (new-worker-pool_ NUM-THREADS scheduler)) ;; Send off the work (do-loop-times (y IMAGE-HEIGHT) (io/term:write-line (<> "Scanlines remaining: " (into (- IMAGE-HEIGHT y)))) (do-submit-job_ pool (wrap-io (coalton/experimental/loops:dotimes (x IMAGE-WIDTH) (let color = (generate-pixel x y)) (let offset = (+ x (* y IMAGE-WIDTH))) (la:set! image-buffer offset color)) Unit))) ;; Wait for finish, then cleanup (request-shutdown pool) (await pool))) (ppm:save-image image-buffer IMAGE-WIDTH IMAGE-HEIGHT COLORS))
(declare main (Void -> Void)) (define (main) (threaded-main)))