;; from ANSI Common Lisp (acl2.lisp)
(require 'stdlib)
(require 'rep.data.records)

(defun sq (x) (* x x))

(defun mag (x y z)
  (sqrt (+ (sq x) (sq y) (sq z))))

(defun unit-vector (x y z)
  (let ((d (mag x y z)))
    (list (/ x d) (/ y d) (/ z d))))

(define-record-type :point
  (make-point x y z)                    ; constructor
  (x point-x)                           ; (attr reader [writer])
  (y point-y)
  (z point-z))

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

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

(define *world* nil)
(define eye (make-point 0 0 200))

(defun tracer (pathname #!optional (res 1))
  (let ((p (open-file pathname 'write)))
    (format p "P2 %s %s 255" (* res 100) (* res 100))
    (let ((inc (/ 1 res)))
      (do ((y -50 (+ y inc)))
          ((< (- 50 y) inc))
        (printf "line %s of %s\n" (* res (+ y 50)) (* res 100))
        (do ((x -50 (+ x inc)))
            ((< (- 50 x) inc))
          (print (color-at x y) p))))
    (print "" p)
    (close-file p)))

(defun color-at (x y)
  (multiple-value-bind (xr yr zr)
      (unit-vector (- x (point-x eye))
                   (- y (point-y eye))
                   (- 0 (point-z eye)))
    (inexact->exact (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))
              (setq surface s hit h dist d))))))
    (list 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)))))

(define-record-type :sphere
  (make-sphere radius center color)
  sphere?
  (radius sphere-radius)
  (center sphere-center)
  (color surface-color))

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

(defun intersect (s pt xr yr zr)
  (funcall (and (sphere? s) 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 (+ (* (- (point-x pt) (point-x c)) xr)
                             (* (- (point-y pt) (point-y c)) yr)
                             (* (- (point-z pt) (point-z c)) zr)))
                     (+ (sq (- (point-x pt) (point-x c)))
                        (sq (- (point-y pt) (point-y c)))
                        (sq (- (point-z pt) (point-z c)))
                        (- (sq (sphere-radius s)))))))
    (if n
        (make-point (+ (point-x pt) (* n xr))
                    (+ (point-y pt) (* n yr))
                    (+ (point-z pt) (* n zr))))))

(defun normal (s pt)
  (funcall (and (sphere? s) sphere-normal) s pt))

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

(defun ray-test (#!optional (res 1))
  (setq *world* nil)
  (setq eye (make-point 0 0 200))
  (defsphere 0 -300 -1200 200 .8)
  (defsphere -80 -150 -1200 200 .7)
  (defsphere 70 -100 -1200 200 .9)
  (do ((x -2 (1+ x)))
      ((> x 2))
    (do ((z 2 (1+ z)))
        ((> z 7))
      (defsphere (* x 200) 300 (* z -400) 40 .75)))
  (tracer "ray-trace.pgm" res))

(defun ray-test-1 (#!optional (res 1))
  (setq *world* nil)
  (setq eye (make-point 0 0 250))
  (defsphere 0 0 -1200 200 .9)
  (time (tracer "ray-trace.pgm" res)))

(define (prof)
  (require 'rep.lang.profiler)
  (call-in-profiler ray-test)
  (print-profile))