Skip to content

Instantly share code, notes, and snippets.

@sjl sjl/lisprb.lisp
Last active Apr 25, 2019

Embed
What would you like to do?
(declaim (optimize (speed 3) (safety 1) (space 1) (debug 1) (compilation-speed 1)))
(defconstant +width+ 1280)
(defconstant +height+ 720)
(defconstant +samples+ 50)
(defconstant +max-depth+ 5)
(defstruct (vec
(:conc-name v-)
(:constructor v-new (x y z)))
(x 0.0 :type single-float)
(y 0.0 :type single-float)
(z 0.0 :type single-float))
(defparameter *zero* (v-new 0.0 0.0 0.0))
(declaim
(ftype (function (vec) vec) v-unit)
(ftype (function (vec) single-float) v-norm)
(ftype (function (vec vec) vec) v-add v-sub v-mul v-div)
(ftype (function (vec vec) single-float) v-dot)
(ftype (function (vec single-float) vec) v-mul-s v-div-s)
(ftype (function (ray single-float) vec) ray-point)
(ftype (function (sphere ray) (or null hit)) sphere-hit)
(ftype (function (t ray single-float) vec) trace-ray)
(inline v-new v-unit v-norm v-add v-sub v-mul v-div v-dot v-mul-s v-div-s))
(defun v-add (v1 v2)
(v-new (+ (v-x v1) (v-x v2)) (+ (v-y v1) (v-y v2)) (+ (v-z v1) (v-z v2))))
(defun v-sub (v1 v2)
(v-new (- (v-x v1) (v-x v2)) (- (v-y v1) (v-y v2)) (- (v-z v1) (v-z v2))))
(defun v-mul (v1 v2)
(v-new (* (v-x v1) (v-x v2)) (* (v-y v1) (v-y v2)) (* (v-z v1) (v-z v2))))
(defun v-mul-s (v1 s)
(v-new (* (v-x v1) s) (* (v-y v1) s) (* (v-z v1) s)))
(defun v-div (v1 v2)
(v-new (/ (v-x v1) (v-x v2)) (/ (v-y v1) (v-y v2)) (/ (v-z v1) (v-z v2))))
(defun v-div-s (v1 s)
(v-new (/ (v-x v1) s) (/ (v-y v1) s) (/ (v-z v1) s)))
(defun v-dot (v1 v2)
(+ (* (v-x v1) (v-x v2)) (* (v-y v1) (v-y v2)) (* (v-z v1) (v-z v2))))
(defun v-norm (v1)
(sqrt (v-dot v1 v1)))
(defun v-unit (v1)
(v-div-s v1 (v-norm v1)))
(defun v-map (function v1)
(list (funcall function (v-x v1))
(funcall function (v-y v1))
(funcall function (v-z v1))))
(defstruct (ray
(:conc-name ray-)
(:constructor ray-new (origin direction)))
origin direction)
(defun ray-point (ray dist)
(v-add (ray-origin ray) (v-mul-s (ray-direction ray) dist)))
(defstruct (camera (:constructor camera-new (eye lt rt lb)))
(eye *zero* :type vec)
(lt *zero* :type vec)
(rt *zero* :type vec)
(lb *zero* :type vec))
(defstruct (sphere (:constructor sphere-new (center radius color is-light)))
(center *zero* :type vec)
(radius 0.0 :type single-float)
(color *zero* :type vec)
(is-light nil :type boolean))
(defstruct (hit (:constructor hit-new (distance point normal sphere)))
(distance 0.0 :type single-float)
(point *zero* :type vec)
(normal *zero* :type vec)
(sphere (error "required") :type sphere))
(defparameter *no-hit* (hit-new 1e16 *zero* *zero* (sphere-new *zero* 0.0 *zero* nil)))
(defun sphere-hit (sphere ray)
(let* ((oc (v-sub (ray-origin ray) (sphere-center sphere)))
(dir (ray-direction ray))
(a (v-dot dir dir))
(b (v-dot oc dir))
(c (- (v-dot oc oc) (* (sphere-radius sphere) (sphere-radius sphere))))
(dis (- (* b b) (* a c))))
(if (> dis 0)
(let* ((e (sqrt dis))
(t1 (/ (- (- b) e) a))
(t2 (/ (+ (- b) e) a)))
(if (> t1 0.007)
(let ((point (ray-point ray t1)))
(hit-new t1 point (v-unit (v-sub point (sphere-center sphere))) sphere))
(if (> t2 0.007)
(let ((point (ray-point ray t2)))
(hit-new t1 point (v-unit (v-sub point (sphere-center sphere))) sphere))
*no-hit*)))
*no-hit*)))
(defun world-new ()
(list (camera-new (v-new 0.0 4.5 75.0)
(v-new -8.0 9.0 50.0)
(v-new 8.0 9.0 50.0)
(v-new -8.0 0.0 50.0))
(list (sphere-new (v-new 0.0 -10002.0 0.0) 9999.0 (v-new 1.0 1.0 1.0) nil)
(sphere-new (v-new -10012.0 0.0 0.0) 9999.0 (v-new 1.0 0.0 0.0) nil)
(sphere-new (v-new 10012.0 0.0 0.0) 9999.0 (v-new 0.0 1.0 0.0) nil)
(sphere-new (v-new 0.0 0.0 -10012.0) 9999.0 (v-new 1.0 1.0 1.0) nil)
(sphere-new (v-new 0.0 10012.0 0.0) 9999.0 (v-new 1.0 1.0 1.0) t)
(sphere-new (v-new -5.0 0.0 2.0) 2.0 (v-new 1.0 1.0 0.0) nil)
(sphere-new (v-new 0.0 5.0 -1.0) 4.0 (v-new 1.0 0.0 0.0) nil)
(sphere-new (v-new 8.0 5.0 -1.0) 2.0 (v-new 0.0 0.0 1.0) nil))))
(defun world-camera (world)
(nth 0 world))
(defun world-spheres (world)
(nth 1 world))
(defun rnd-dome (normal)
(let ((p (v-new (- (* 2.0 (random 1.0)) 1.0)
(- (* 2.0 (random 1.0)) 1.0)
(- (* 2.0 (random 1.0)) 1.0))))
(if (< (v-dot p normal) 0) (rnd-dome normal) p)))
(defun trace-ray (world ray depth)
(let* ((hits (loop for sp in (world-spheres world) collect (sphere-hit sp ray)))
(hit (reduce (lambda (h1 h2) (if (< (hit-distance h1) (hit-distance h2)) h1 h2)) hits))
(color (sphere-color (hit-sphere hit))))
(cond ((eq hit *no-hit*) *zero*)
((sphere-is-light (hit-sphere hit)) color)
((< depth +max-depth+)
(let* ((nray (ray-new (hit-point hit) (rnd-dome (hit-normal hit))))
(ncolor (trace-ray world nray (+ depth 1.0)))
(at (v-dot (ray-direction nray) (hit-normal hit))))
(v-mul color (v-mul-s ncolor at))))
(t *zero*))))
(defun to-255 (color)
(v-map #'floor (v-mul-s color 255.99)))
(defun writeppm (data)
(with-open-file (ppm "lisprb.ppm" :direction :output :if-exists :supersede)
(format ppm "P3~%~A ~A~%255~%" +width+ +height+)
(loop for row in data do
(loop for color in row
for (r g b) = (to-255 color)
do (format ppm "~A ~A ~A " r g b))
(format ppm "~%"))))
(defun main ()
(let* ((world (world-new))
(camera (world-camera world))
(lt (camera-lt camera))
(vdu (v-div-s (v-sub (camera-rt camera) (camera-lt camera)) (float +width+)))
(vdv (v-div-s (v-sub (camera-lb camera) (camera-lt camera)) (float +height+)))
(data (loop for y from 0.0 to (- +height+ 1.0) collect
(loop for x from 0.0 to (- +width+ 1.0) collect
(let ((color *zero*)
(ray (ray-new (camera-eye camera) nil))
(dir nil))
(dotimes (_ +samples+)
(setf dir (v-add lt (v-add
(v-mul-s vdu (+ x (random 1.0)))
(v-mul-s vdv (+ y (random 1.0))))))
(setf dir (v-unit (v-sub dir (ray-origin ray))))
(setf (ray-direction ray) dir)
(setf color (v-add color (trace-ray world ray 0.0))))
(v-div-s color (float +samples+)))))))
(writeppm data)))
;; (time (main))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.