Something went wrong. Try again.
A ray tracer in Coalton
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281(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) (#:simd #:sb-simd-avx)))
(cl:in-package #:ray)
(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0) (cl:debug 0)))
(cl:defmacro with-thread-rng (cl:&rest body) `(with-thread-rng% (fn () ,@body)))
(coalton-toplevel (declare ASPECT-RATIO F64) (define ASPECT-RATIO (/ 16.0d0 9.0d0)) (declare IMAGE-WIDTH UFix) (define IMAGE-WIDTH 1200) (declare IMAGE-HEIGHT UFix) (define IMAGE-HEIGHT (unwrap-as UFix (floor (/ (unwrap-as F64 IMAGE-WIDTH) ASPECT-RATIO)))) (declare SAMPLES-PER-PIXEL UFix) (define SAMPLES-PER-PIXEL 250) (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:v3 13.0d0 2.0d0 3.0d0)) (declare LOOK-AT v:Vec3) (define LOOK-AT (v:v3 0.0d0 0.0d0 0.0d0)) (declare CAMERA-UP v:Vec3) (define CAMERA-UP (v:v3 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 24) (declare WORLD (la:LispArray h:Surface)) (define WORLD scene:complex-world) (inline) (declare get-ray (UFix * UFix -> v:Vec3 * v:Vec3)) (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)) (values ray-origin direction))
(inline) (declare defocus-disk-sample (Void -> v::Vec3)) (define (defocus-disk-sample) (let (values x y _) = (v:spread (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)))) (inline) (declare sample-square (Void -> F64 * F64)) (define (sample-square) (values (- (util:rand-f64) 0.5d0) (- (util:rand-f64) 0.5d0))) (inline) (declare hit-any? ((la:LispArray h:Surface) * v:Vec3 * v:Vec3 * F64 * F64 -> Boolean * v:Vec3 * v:Vec3 * F64 * Boolean * m:Material)) (define (hit-any? scene origin direction tmin tmax) (let len = (la:length scene)) (rec % ((i 0) (closest-t tmax) (closest-idx 0)) (cond ((== i len) (cond ((== closest-t tmax) (h:miss-record)) (True (match (la:aref scene closest-idx) ((h:Sphere center radius material) (let point = (r:ray-at origin direction closest-t)) (let outward-normal = (v:vec-div-scalar (v:vec-sub point center) radius)) (let front-face = (< (v:vec-dot direction outward-normal) 0)) (let normal = (if front-face outward-normal (v:vec-negate outward-normal))) (values True point normal closest-t front-face material)))))) (True (let (values obj-hit hit-t) = (h:hit-surface-distance? (la:aref scene i) origin direction tmin closest-t)) (if (and obj-hit (< hit-t closest-t)) (% (+ 1 i) hit-t i) (% (+ 1 i) closest-t closest-idx)))))) (inline) (declare hit-skybox (v:Vec3 -> c:Color)) (define (hit-skybox direction) (let vec = (v:unit-vector direction)) (let y = (v:get-y vec)) (let alpha = (* 0.5d0 (+ y 1.0d0))) (c:add (c:mul-scalar c:white (- 1.0d0 alpha)) (c:mul-scalar (c:make-color 0.5d0 0.7d0 1.0d0) alpha))) (inline) (declare ray-color (v:Vec3 * v:Vec3 * UFix -> c:Color)) (define (ray-color origin direction depth) (rec % ((origin origin) (direction direction) (depth depth) (acc c:white)) (cond ((<= depth 0) c:black) (True (let (values hit? point normal _ front-face? material) = (hit-any? WORLD origin direction 0.001d0 INFINITY)) (cond (hit? (let (values scatter-point scatter-direction attenuation) = (m:scatter direction point normal front-face? material)) (if (v:near-zero? scatter-direction) attenuation (% scatter-point scatter-direction (1- depth) (c:mul acc attenuation)))) (True (c:mul acc (hit-skybox direction)))))))) (inline) (declare trace-ray (UFix * UFix -> c:Color)) (define (trace-ray x y) (let (values ray-origin ray-direction) = (get-ray x y)) (ray-color ray-origin ray-direction MAX-DEPTH)) (inline) (declare generate-pixel ((la:LispArray U8) * UFix * UFix -> Unit)) (define (generate-pixel buffer x y) (let offset = (the UFix (* 3 x))) (let pixel = (for ((sample 0 (1+ sample)) (pixel-color c:black (c:add pixel-color (trace-ray x y)))) :returns (c:mul-scalar pixel-color PIXEL-SAMPLES-SCALE) :repeat SAMPLES-PER-PIXEL)) (let (values r g b) = (c:gamma-correct pixel)) (la:set! buffer offset r) (la:set! buffer (+ 1 offset) g) (la:set! buffer (+ 2 offset) b) Unit)
;(declare sync-main (Void -> Void)) ;(define (sync-main) ; (let image-buffer = (la:make (* (* IMAGE-HEIGHT IMAGE-WIDTH) 3) 0)) ; (for* ((y 0 (1+ y))) ; :repeat IMAGE-HEIGHT ; (print (<> "Scanlines remaining: " (into (- IMAGE-HEIGHT y)))) ; (for* ((x 0 (1+ x))) ; :repeat IMAGE-WIDTH ; (generate-pixel image-buffer x y))) ; (ppm:save-image image-buffer IMAGE-WIDTH IMAGE-HEIGHT COLORS))
(declare with-thread-rng% ((Void -> Unit) -> Unit)) (define (with-thread-rng% thunk) (lisp (-> Unit) (thunk) (cl:let ((cl:*random-state* (cl:make-random-state cl:t))) (cl:funcall thunk)))) (declare threaded-main (Void -> Void)) (define (threaded-main) ;(declare image-buffer (LispArray (LispArray U8))) (let image-buffer = (the (la:LispArray (la:LispArray U8)) (la:make-uninitialized IMAGE-HEIGHT))) (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 (the UFix (- IMAGE-HEIGHT y))))) (do-submit-job_ pool (wrap-io (with-thread-rng (let line-buffer = (the (la:LispArray U8) (la:make (* 3 IMAGE-WIDTH) (the U8 0)))) (coalton/experimental/loops:dotimes (x IMAGE-WIDTH) (generate-pixel line-buffer x y)) (la:set! image-buffer y line-buffer) 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)))