~nprescott/ray-tracer

016ab63dc08ff69b613b5268b60e4294e573ccfc — Nolan Prescott 1 year, 2 days ago 9ada50d
add lighting, draws a real sphere!
3 files changed, 223 insertions(+), 56 deletions(-)

M sample.lisp
M tests.lisp
M tracer.lisp
M sample.lisp => sample.lisp +18 -8
@@ 52,19 52,18 @@
              (loop for hour below 12 collect (face-point hour)))
      (ppm->file (canvas->ppm canvas) "/home/nolan/test-output.ppm"))))

;;; silhouette test
(defun cast-silhouette ()
;;; cast some rays!
(defun draw-sphere ()
  (let* ((ray-starting-place (point 0 0 -5))
         (wall-z 10)
         (wall-size 7.0)
         (canvas-pixels 100)
         (canvas-pixels 400)
         (pixel-size (/ wall-size canvas-pixels))
         (half (/ wall-size 2))
         (c (make-canvas :width canvas-pixels :height canvas-pixels))
         (color (vec3 255 0 0))
         (shape (make-sphere)))
    ;; (set-transform shape (matrix*matrix (shearing 1 0 0 0 0 0)
    ;;                                     (scaling 0.5 1 1)))
         (shape (make-sphere :material (make-material :color (vec3 0.8 0.6 0))))
         (light (make-light :intensity (vec3 1 1 1)
                            :position (point 5 12 -8))))
    (loop for y below canvas-pixels
       for world-y = (- half (* pixel-size y))
       do (loop for x below canvas-pixels


@@ 74,5 73,16 @@
                               :direction (normalize (VECTOR- the-position
                                                              ray-starting-place)))
             for xs = (intersect shape r)
             when (hit xs) do (write-pixel c x y color)))
             for contact = (hit xs)
             when contact do
               (let* ((pos (ray-position r (crosspoint-time contact)))
                      (normal (normal-at (crosspoint-object contact) pos))
                      (eye (negate-vector (ray-direction r)))
                      (color-at-point
                       (lighting (sphere-material (crosspoint-object contact))
                                 light
                                 pos
                                 eye
                                 normal)))
                 (write-pixel c x y color-at-point))))
    (ppm->file (canvas->ppm c) "/home/nolan/test-output.ppm")))

M tests.lisp => tests.lisp +159 -46
@@ 16,6 16,12 @@
(defun float= (f1 f2)
  (< (abs (- f1 f2)) single-float-epsilon))

(defun float-vectors-equal (v1 v2)
  ;; is there a better way to do float= over two arrays?
  (let ((a (loop for i across v1 collect i))
        (b (loop for i across v2 collect i)))
    (not (member nil (mapcar #'float= a b)))))

;;; tests
(deftest adding-vectors
  (let ((a (vec3 3 -2 5))


@@ 403,63 409,36 @@
(deftest rotation-around-x-axis
  (let* ((p (point 0 1 0))
         (half-quarter (rotation-x (/ pi 4)))
         (full-quarter (rotation-x (/ pi 2)))
         (hq-values (loop for i across (matrix*vector half-quarter p)
                       collect i))
         (hq-actuals (loop for i across (point 0 (/ (sqrt 2) 2) (/ (sqrt 2) 2))
                        collect i))
         (fq-values (loop for i across (matrix*vector full-quarter p)
                       collect i))
         (fq-actuals (loop for i across (point 0 0 1)
                        collect i)))
    (check (not (member nil (mapcar #'float= hq-values hq-actuals)))
           (not (member nil (mapcar #'float= fq-values fq-actuals))))))
         (full-quarter (rotation-x (/ pi 2))))
    (check (float-vectors-equal (matrix*vector half-quarter p)
                                (point 0 (/ (sqrt 2) 2) (/ (sqrt 2) 2)))
           (float-vectors-equal (matrix*vector full-quarter p)
                                (point 0 0 1)))))

(deftest inverse-x-rotation-rotates-oppositely
  (let* ((p (point 0 1 0))
         (half-quarter (rotation-x (/ pi 4)))
         (inv (inverse half-quarter))
         (inverse-values (loop for i across (matrix*vector inv p)
                            collect i))
         (inverse-actuals (loop for i across (point 0 (/ (sqrt 2) 2) (-(/ (sqrt 2) 2)))
                             collect i)))
    (check
      ;; is there a better way to do float= over two arrays?
      (not (member nil (mapcar #'float= inverse-values inverse-actuals))))))
         (inv (inverse half-quarter)))
    (check (float-vectors-equal (matrix*vector inv p)
                                (point 0 (/ (sqrt 2) 2) (-(/ (sqrt 2) 2)))))))

(deftest rotation-around-y-axis
  (let* ((p (point 0 0 1))
         (half-quarter (rotation-y (/ pi 4)))
         (full-quarter (rotation-y (/ pi 2)))
         (hq-values (loop for i across (matrix*vector half-quarter p)
                       collect i))
         (hq-actuals (loop for i across (point (/ (sqrt 2) 2)
                                               0
                                               (/ (sqrt 2) 2))
                        collect i))
         (fq-values (loop for i across (matrix*vector full-quarter p)
                       collect i))
         (fq-actuals (loop for i across (point 1 0 0)
                        collect i)))
    (check (not (member nil (mapcar #'float= hq-values hq-actuals)))
           (not (member nil (mapcar #'float= fq-values fq-actuals))))))
         (full-quarter (rotation-y (/ pi 2))))
    (check (float-vectors-equal (matrix*vector half-quarter p)
                                (point (/ (sqrt 2) 2) 0 (/ (sqrt 2) 2)))
           (float-vectors-equal (matrix*vector full-quarter p)
                                (point 1 0 0)))))

(deftest rotation-around-z-axis
  (let* ((p (point 0 1 0))
         (half-quarter (rotation-z (/ pi 4)))
         (full-quarter (rotation-z (/ pi 2)))
         (hq-values (loop for i across
                         (matrix*vector half-quarter p)
                       collect i))
         (hq-actuals (loop for i across
                          (point (- (/ (sqrt 2) 2)) (/ (sqrt 2) 2) 0)
                        collect i))
         (fq-values (loop for i across (matrix*vector full-quarter p)
                       collect i))
         (fq-actuals (loop for i across (point -1 0 0)
                        collect i)))
    (check (not (member nil (mapcar #'float= hq-values hq-actuals)))
           (not (member nil (mapcar #'float= fq-values fq-actuals))))))
         (full-quarter (rotation-z (/ pi 2))))
    (check (float-vectors-equal (matrix*vector half-quarter p)
                                (point (- (/ (sqrt 2) 2)) (/ (sqrt 2) 2) 0))
           (float-vectors-equal (matrix*vector full-quarter p)
                                (point -1 0 0)))))

(deftest shearing-transforms-x-proportionally-to-y
  (let ((transform (shearing 1 0 0 0 0 0))


@@ 684,9 663,143 @@
  (intersecting-scaled-sphere-with-ray)
  (intersecting-translated-sphere-with-ray))

(deftest normal-of-sphere-on-x-axis
  (let* ((s (make-sphere))
         (n (normal-at s (point 1 0 0))))
    (check (equalp n (vec3 1 0 0)))))

(deftest normal-of-sphere-on-y-axis
  (let* ((s (make-sphere))
         (n (normal-at s (point 0 1 0))))
    (check (equalp n (vec3 0 1 0)))))

(deftest normal-of-sphere-on-z-axis
  (let* ((s (make-sphere))
         (n (normal-at s (point 0 0 1))))
    (check (equalp n (vec3 0 0 1)))))

(deftest normal-of-sphere-on-nonaxial-point
  (let* ((s (make-sphere))
         (p (/ (sqrt 3d0) 3d0))
         (n (normal-at s (point p p p))))
    (check (float-vectors-equal n (vec3 p p p)))))

(deftest normals-are-normalized
  (let* ((s (make-sphere))
         (p (/ (sqrt 3) 3))
         (n (normal-at s (point p p p))))
    (check (float-vectors-equal n (normalize n)))))

(deftest normal-of-translated-sphere
  (let* ((s (make-sphere :transformation (translation 0 1 0)))
         (n (normal-at s (point 0 1.707 -0.707))))
    (check (float-vectors-equal n (vec3 0 0.7071068 -0.7071068)))))

(deftest normal-of-transformed-sphere
  (let* ((s (make-sphere :transformation (matrix*matrix (scaling 1 0.5 1)
                                                        (rotation-z (/ pi 5)))))
         (n (normal-at s (point 0 (/ (sqrt 2) 2) (- (/ (sqrt 2) 2))))))
    (check (float-vectors-equal n (vec3 0 0.9701425 -0.242535625)))))

(deftest reflecting-a-vector-at-45-degrees
  (let* ((v (vec3 1 -1 0))
         (n (vec3 0 1 0)))
    (check (float-vectors-equal (reflect v n) (vec3 1 1 0)))))

(deftest reflecting-a-vector-off-a-slanted-surface
  (let* ((v (vec3 0 -1 0))
         (s (/ (sqrt 2) 2))
         (n (vec3 s s 0)))
    (check (float-vectors-equal (reflect v n) (vec3 1 0 0)))))

(deftest point-light-has-position-and-intensity
  (let ((l (make-light :position (point 0 0 0)
                        :intensity (vec3 1 1 1))))
    (check (equalp (light-position l) (point 0 0 0))
           (equalp (light-intensity l) (vec3 1 1 1)))))

(deftest default-material-properties
  (let ((m (make-material)))
    (check (equalp (material-color m)(vec3 1 1 1))
           (equalp (material-ambient m) 0.1)
           (equalp (material-diffuse m) 0.9)
           (equalp (material-specular m) 0.9)
           (equalp (material-shininess m) 200.0))))

(deftest sphere-may-be-assigned-material
  (let* ((m (make-material :ambient 1))
         (s (make-sphere :material m)))
    (check (equalp (sphere-material s) m))))

(deftest lighting-with-eye-between-light-and-surface
  (let* ((m (make-material))
         (pos (point 0 0 0))
         (eye (vec3 0 0 -1))
         (normal (vec3 0 0 -1))
         (light (make-light :intensity (vec3 1 1 1)
                            :position (point 0 0 -10))))
    (check (equalp (lighting m light pos eye normal)
                   (vec3 1.9 1.9 1.9)))))

(deftest lighting-with-eye-between-light-and-surface-offset-45-degrees
  (let* ((m (make-material))
         (pos (point 0 0 0))
         (eye (vec3 0 (/ (sqrt 2) 2) (/ (sqrt 2) 2)))
         (normal (vec3 0 0 -1))
         (light (make-light :intensity (vec3 1 1 1) :position (point 0 0 -10))))
    (check (equalp (lighting m light pos eye normal)
                   (vec3 1.0 1.0 1.0)))))

(deftest lighting-with-eye-opposite-light-offset-45-degrees
  (let* ((m (make-material))
         (pos (point 0 0 0))
         (eye (vec3 0 0 -1))
         (normal (vec3 0 0 -1))
         (light (make-light :intensity (vec3 1 1 1) :position (point 0 10 -10))))
    (check (equalp (lighting m light pos eye normal)
                   (vec3 0.73639613 0.73639613 0.73639613)))))

(deftest lighting-with-eye-in-path-of-reflection-vector
  (let* ((m (make-material))
         (pos (point 0 0 0))
         (eye (vec3 0 (- (/ (sqrt 2) 2)) (- (/ (sqrt 2) 2))))
         (normal (vec3 0 0 -1))
         (light (make-light :intensity (vec3 1 1 1) :position (point 0 10 -10))))
    (check (equalp (lighting m light pos eye normal)
                   (vec3 1.6363962 1.6363962 1.6363962)))))

(deftest lighting-with-eye-behind-surface
  (let* ((m (make-material))
         (pos (point 0 0 0))
         (eye (vec3 0 0 -1))
         (normal (vec3 0 0 -1))
         (light (make-light :intensity (vec3 1 1 1) :position (point 0 0 10))))
    (check (equalp (lighting m light pos eye normal)
                   (vec3 0.1 0.1 0.1)))))

(deftest properties-of-lighting
  (normal-of-sphere-on-x-axis)
  (normal-of-sphere-on-y-axis)
  (normal-of-sphere-on-z-axis)
  (normal-of-sphere-on-nonaxial-point)
  (normals-are-normalized)
  (normal-of-translated-sphere)
  (normal-of-transformed-sphere)
  (reflecting-a-vector-at-45-degrees)
  (reflecting-a-vector-off-a-slanted-surface)
  (point-light-has-position-and-intensity)
  (default-material-properties)
  (sphere-may-be-assigned-material)
  (lighting-with-eye-between-light-and-surface)
  (lighting-with-eye-between-light-and-surface-offset-45-degrees)
  (lighting-with-eye-opposite-light-offset-45-degrees)
  (lighting-with-eye-in-path-of-reflection-vector)
  (lighting-with-eye-behind-surface))

(deftest suite
  (vector-basics)
  (canvas-and-visuals)
  (matrix-basics)
  (matrix-transformations)
  (casting-rays))
  (casting-rays)
  (properties-of-lighting))

M tracer.lisp => tracer.lisp +46 -2
@@ 89,7 89,10 @@
    (mapcan #'(lambda (x) (if (atom x) (mklist x) (flatten x))) ls)))

(defun canvas-pixel-strings (c)
  (labels ((pixel->string (v) (format nil "~s ~s ~s" (Red v) (Green v) (Blue v))))
  (labels ((pixel->string (v) (format nil "~d ~d ~d"
                                      (floor (* 255 (Red v)))
                                      (floor (* 255 (Green v)))
                                      (floor (* 255 (Blue v))))))
    (flatten (loop for i below (canvas-height c) collect
                  (loop for j below (canvas-width c)
                     collect (pixel->string (aref (canvas-body c) j i)))))))


@@ 222,8 225,17 @@
                                         (,zx ,zy   1 0)
                                         (  0   0   0 1))))

(defstruct material
  (color (vec3 1 1 1))
  (ambient 0.1)
  (diffuse 0.9)
  (specular 0.9)
  (shininess 200))
(defstruct light intensity position)
(defstruct ray origin direction)
(defstruct sphere (transformation identity-matrix))
(defstruct sphere
  (transformation identity-matrix)
  (material (make-material)))
(defstruct crosspoint time object)

(defun ray-position (r time)


@@ 258,3 270,35 @@
;;; should probably just drop this entirely...
(defun set-transform (s transform)
  (setf (sphere-transformation s) transform))

(defun normal-at (sphere world-point)
  (let* ((object-point (matrix*vector (inverse (sphere-transformation sphere)) world-point))
         (object-normal (VECTOR- object-point (point 0 0 0)))
         (world-normal (matrix*vector (transpose (inverse (sphere-transformation sphere)))
                                      object-normal)))
    (setf (aref world-normal 3) 0)      ; FIXME submatrix 3,3 instead
    (normalize world-normal)))

(defun reflect (in normal)
  (VECTOR- in (scale-vector normal (* 2 (dot-product in normal)))))

(defun lighting (material light position eye-vector normal-vector)
  (let* ((effective-color (VECTOR* (material-color material) (light-intensity light)))
         (lightv (normalize (VECTOR- (light-position light) position)))
         (ambient (scale-vector effective-color (material-ambient material)))
         (light-dot-normal (dot-product lightv normal-vector))
         (black (vec3 0 0 0))
         (diffuse black)
         (specular black)
         (reflect-dot-eye (dot-product (reflect (negate-vector lightv) normal-vector)
                                       eye-vector)))
    (if (> light-dot-normal 0)
        (setf diffuse (scale-vector
                       (scale-vector effective-color (material-diffuse material))
                       light-dot-normal)))
    (if (> reflect-dot-eye 0)
        (setf specular (scale-vector (light-intensity light)
                                     (* (material-specular material)
                                        (expt reflect-dot-eye
                                              (material-shininess material))))))
    (reduce #'VECTOR+ (list ambient diffuse specular))))