; ==============================================================================
; (b)
; Before declarations:
#|
(time (ray-test))

Evaluation took:
  0.756 seconds of real time
  0.269972 seconds of user run time
  0.019334 seconds of system run time
  [Run times include 0.048 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  60,035,344 bytes consed.
|#

(declaim (optimize (speed 3)
                   (compilation-speed 0)
                   (safety 0)
                   (debug 0)))

; Use declarations in math utilities:
(defun sq (x) 
  (declare (long-float x))
  (* x x))

(defun mag (x y z)
  (declare (long-float x y z))
  (sqrt (+ (sq x) (sq y) (sq z))))

(defun unit-vector (x y z)
  (declare (long-float x y z))
  (let ((d (mag x y z)))
    (declare (long-float d))
    (values (/ x d) (/ y d) (/ z d))))

(defstruct (point (:conc-name nil))  
  x y z)

(defun distance (p1 p2)
  (mag (- (x p1) (x p2))
       (- (y p1) (y p2))
       (- (z p1) (z p2))))

(defun minroot (a b c)
  (declare (long-float a b c))
  (if (zerop a)
      (/ (- c) b)
      (let ((disc (- (sq b) (* 4 a c))))
        (declare (long-float disc))
        (unless (minusp disc)
          (let ((discrt (sqrt disc)))
            (declare (long-float discrt))
            (min (/ (+ (- b) discrt) (* 2 a))
                 (/ (- (- b) discrt) (* 2 a))))))))

; Ray-tracing
(defstruct surface  color)

(defparameter *world* nil)
(defconstant eye (make-point :x 0 :y 0 :z 200))

(defun tracer (pathname &optional (res 1))
  (with-open-file (p pathname :direction :output)
    (format p "P2 ~A ~A 255" (* res 100) (* res 100))
    (let ((inc (/ res)))
      (do ((y -50L0 (+ y inc)))
          ((< (- 50L0 y) inc))
        (do ((x -50L0 (+ x inc)))
            ((< (- 50L0 x) inc))
          (print (color-at x y) p))))))

(defun color-at (x y)
  (declare (double-float x y))
  (multiple-value-bind (xr yr zr) 
                       (unit-vector (- x (x eye))
                                    (- y (y eye))
                                    (- 0L0 (z eye)))
    (declare (double-float xr yr zr))
    (round (* (sendray eye xr yr zr) 255))))

(defun sendray (pt xr yr zr)
  (multiple-value-bind (s int) (first-hit pt xr yr zr)
    (if s
        (* (lambert s int xr yr zr) (surface-color s))
        0)))

(defun first-hit (pt xr yr zr)
  (let (surface hit dist)
    (dolist (s *world*)
      (let ((h (intersect s pt xr yr zr)))
        (when h
          (let ((d (distance h pt)))
            (when (or (null dist) (< d dist))
              (setf surface s hit h dist d))))))
    (values surface hit)))

(defun lambert (s int xr yr zr)
  (multiple-value-bind (xn yn zn) (normal s int)
    (max 0 (+ (* xr xn) (* yr yn) (* zr zn)))))

; Spheres
(defstruct (sphere (:include surface))  
  radius center)

(defun defsphere (x y z r c)
  (let ((s (make-sphere 
             :radius r
             :center (make-point :x x :y y :z z)
             :color  c)))
    (push s *world*)
    s))

(defun intersect (s pt xr yr zr)
  (funcall (typecase s (sphere #'sphere-intersect))
           s pt xr yr zr))

(defun sphere-intersect (s pt xr yr zr)
  (let* ((c (sphere-center s))
         (n (minroot (+ (sq xr) (sq yr) (sq zr))
                     (* 2 (+ (* (- (x pt) (x c)) xr)
                             (* (- (y pt) (y c)) yr)
                             (* (- (z pt) (z c)) zr)))
                     (+ (sq (- (x pt) (x c)))
                        (sq (- (y pt) (y c)))
                        (sq (- (z pt) (z c)))
                        (- (sq (sphere-radius s)))))))
    (if n
        (make-point :x  (+ (x pt) (* n xr))
                    :y  (+ (y pt) (* n yr))
                    :z  (+ (z pt) (* n zr))))))

(defun normal (s pt)
  (funcall (typecase s (sphere #'sphere-normal))
           s pt))

(defun sphere-normal (s pt)
  (let ((c (sphere-center s)))
    (unit-vector (- (x c) (x pt))
                 (- (y c) (y pt))
                 (- (z c) (z pt)))))


; Using the ray-tracer
(defun ray-test (&optional (res 1))
  (setf *world* nil)
  (defsphere 0L0 -300L0 -1200L0 200L0 .8L0)
  (defsphere -80L0 -150L0 -1200L0 200L0 .7L0)
  (defsphere 70L0 -100L0 -1200L0 200L0 .9L0)
  (do ((x -2 (1+ x)))
      ((> x 2))
    (do ((z 2 (1+ z)))
        ((> z 7))
      (defsphere (* x 200L0) 300L0 (* z -400L0) 40L0 .75L0)))
  (tracer (make-pathname :directory '(:absolute "public" "data") :name "spheres.pgm") res))

#|
After adding declarations:
(time (ray-test))

Evaluation took:
  0.946 seconds of real time
  0.495919 seconds of user run time
  0.031606 seconds of system run time
  [Run times include 0.195 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  171,317,792 bytes consed.
|#