lisprb.lisp

(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))