;#!/usr/bin/clisp

(defparameter world '(
                      
                      ((sphere (vector 4 5 5) 2 (rationalize .6)))
                      ((sphere (vector -5 0 5) 2 (rationalize .6)))
                      ((sphere (vector 5 5  5) 2 (rationalize .6)))
                      ((plane (vector 0 0 3) (vector -.5 .2 -1) (rationalize .4)) (< x 3) (< y 0))
              ))
(defparameter eye (vector 0 0 -1))
(declaim (type (vector fixnum 3) eye))

(defun init-pgm (width height colors)
  (format t "P2~%~A ~A~%~A~%" width height colors))


; make-run-kill-universe was too glorious
(defun uni (&optional (viewx -2) (viewy 2) (viewz 0) (grain (rationalize .02)) (maxcolor 255) (xmax 2) (xmin -2) (ymax 2) (ymin -2))
;  (format t "~%~A ~A " viewx viewy)
  (declare (rational viewx viewy  viewxz grain)
           (fixnum xmin xmax ymin ymax maxcolor))
  (if (and (= viewx xmin) (= viewy ymax))
      (init-pgm (+ 1 (round (/ (abs (- xmax xmin)) grain)))
                (+ 1 (round (/ (abs (- ymax ymin)) grain)))
            maxcolor))
  (cond ((> viewx xmax) (format t "~%" ) (uni xmin (- viewy grain)))
        ((< viewy ymin) (format t "~%" ))
        (t
         (let ((thiscolor (find-nearest-good-hit (mkunitvec (v- (vector viewx viewy viewz) eye)))))
         ;(let ((thiscolor (find-nearest-good-hit (mkunitvec (vector viewx viewy (rationalize -1))   )))) 
           (if  (null thiscolor)
             ;(format t "~A ~A 0 ~%" viewx viewy) (format t "~A ~A 1 ~%" viewx viewy))
               (format t "0 ")
             (if (or (minusp thiscolor) (zerop thiscolor))
                 (format t "0 ")
               (format t "~A " (values (floor (* maxcolor thiscolor))))))
             ;(format t "~A " maxcolor thiscolor))
           (uni (+ grain viewx) viewy)))))


;find the nearest hit,color list
; return the color [0,1] to be printed
(defun find-nearest-good-hit (view)
  ;(let ((allhits (remove-if #'(lambda (x) (null (cdr x))) (find-all-hits view world))))
  (let ((allhits (find-all-hits view world) ))
    (if (equal nil allhits)
        nil
                                        ; return the z value of nearest intersection or nil
                                        ;(reduce #'max (mapcar #'(lambda (x) (float (svref (car x) 2))) allhits))
      ; return the color or nil, using (#(x y z) col)
      ;(cadar (sort allhits #'(lambda (a b) (< (svref (car a) 2) (svref (car b) 2)))))
      
      ;return the color or nil, using (z col)
      ;later, we can have find-all-hits itself keep track of the nearest z point instead of having to sort...
      ;(cadar (sort allhits #'(lambda (a b) (< (car a) (car b)))))
      (cadar allhits)
      
      )))


; sort list of 2-tuple lists by the 2nd tuple ; >-)
(defun 2sortl (lst)
  (sort lst #'(lambda (a b) (< (cadr a) (cadr b)))))


(defun update-hits (val hits)
  (cond ((null val) hits)              ;no point here
        ((null hits) (list val))       ;point here, but no other candidates
        (t                             ;point here, other candidates here
         (if (< (car val) (caar hits))
             (list val)
           hits))))

;given a ray, iterate over world and append hits
; return ((hit1vector colorvalue) (hit2vector colorvalue) ...)
(defun find-all-hits (view someworld &optional (hits ()))
  (if (equal someworld nil) hits
    (let ((entity (car someworld)))
      (cond
       ((equal 'sphere (caar entity))
        (find-all-hits view
                       (cdr someworld)                       
                       (update-hits (handle-sphere entity view) hits)
;                       (let ((sphere-and-col (handle-sphere entity view)))
;                         (cond ((null sphere-and-col) hits)
;                               ((null hits) (list sphere-and-col))
;                               (t
;                                (if (< (car sphere-and-col) (caar hits))
;                                    (list sphere-and-col)
;                                  hits))))
                       ))
       
       ((equal 'plane (caar entity))
        (find-all-hits view
                       (cdr someworld)
                                        ;hits = ((#(x y z) col) (#u v w) com)...
                                        ;(append hits (list (handle-plane entity view))))
                                        ;hits = ((z col) (w com))...
                       (update-hits (handle-plane entity view) hits)
;                       (let ((z-and-col (handle-plane entity view)))
;                         (cond ((null z-and-col) hits) ;didn't find a point
;                               ((null hits)  (list z-and-col))
                                        ; found point, but didn't find existing candidates for points
;                               (t ;found point, found existing candidates
;                                (if (< (car z-and-col) (caar hits))
;                                    (list z-and-col)
;                                  hits))))

                       ))))))

(defun uplist (lst &optional (nice ()))
  (if (equal nil lst) nice
    (uplist (cdr lst) (append nice (car lst)))))


; '((sphere center-vector radius-rational color-rational:[0,1]))
; '((sphere (vector 0 0 5) 1 (rationalize .5)))
(defun handle-sphere (info view)
  (declare (type (vector rational 3) view))
  (let* ((center (eval (second (car info))))
         (intersect (sl-int ;(vector (svref eye 0) (svref eye 1) (svref center 2))
                            center                    ;center
                            (eval (third (car info)))         ;radius
                            view
                           )))
    (if (equal intersect nil)
        nil
      (list (svref intersect 2)
            (find-color (mkunitvec (v- intersect center)) ;normal
                        view
                        (eval (fourth (car info)))
                         )))))

(defun sl-int (c r view)
  (declare (type (vector rational 3) v c))
  (let* (
         (pox (svref eye 0))
         (poy (svref eye 1))
         (poz (svref eye 2))
         (p1x (svref view 0))
         (p1y (svref view 1))
         (p1z (svref view 2))
         (cx (svref c 0))
         (cy (svref c 1))
         (cz (svref c 2))
         (u (- pox cx))
         (v (- poy cy))
         (w (- poz cz))
         )
    (let ((s1 (minquad (+ (sq p1x) (sq p1y) (sq p1z))
                       (* 2 (+ (* u p1x)
                               (* v p1y)
                               (* w p1z)))
                       (+ (sq u) (sq v) (sq w) (- (sq r))))))
      (if (null s1) nil
        (v+ eye (v*c view s1))))
  ))

(defun minquad (a b c)
  (if (zerop a) (/ (- c) b)
    (let ((discr (- (sq b) (* 4 a c))))
      (unless (minusp discr)
        (let ((sqrtdiscr (sqrt discr)))
          (min (/ (+ (- b) sqrtdiscr) (* 2 a))
               (/ (- (- b) sqrtdiscr) (* 2 a))))))))

;handles one plane
;will recv ((PLANE (VECTOR 1 1 1) (VECTOR 0 0 1) (rationalize .8)) (> Y 0))
; finds a hit
; decides if the hit is valid for this given plane
; returns z value of intersection, and color potential
(defun handle-plane (info view)
  (declare (type (vector rational 3) view)
           )
  (let ((theplane (first info)))
    ;find the intersection:
    (let ((intersect (pl-int (eval (second theplane)) (eval (third theplane)) eye view)))
      (if (equal intersect nil)
          nil
       (let ((success (fooman `((x ,(svref intersect 0))  ; check intersection on restraints
                               (y ,(svref intersect 1))
                               (z ,(svref intersect 2)))
                             (cdr info))))
        (if (member nil success) nil
          ;if intersect found, get its color, and return the full point vector+col
          ;(list intersect
          ;if intersect found, get its color and return (z color)
          (list (svref intersect 2)
                (find-color
                 (mkunitvec (eval (third theplane)))
                 view
                 (eval (fourth theplane))))
      ))))))


;send me normal, view vector (oppsite of what lambert's law needs), and color [0,1]
; lambert's law needs normal vector and vector(point,light)
; observe we do not check intersection's validity using this dot product
;  because it was already calculated in the intersection routine
; send UNIT vectors
(defun find-color (n v col)
  ;inversion of the view vector
  (* col (dot  (v*c n -1) v)))

(defun find-color-plane (n v col)
  ;inversion of the view vector
  (* col (dot (mkunitvec (v*c -1 n)) (mkunitvec v))))


(defun fooman (lets tests)
    (let ((test (gensym)))
          (mapcar #'(lambda (test) (eval `(let ,lets ,test))) tests)))
;(fooman '((y 2)) '((< y 4) (> y 10)))



;vo = point on plane; n = normal vector at vo
;po = start point of line; p1 = end point of line
; returns intersection.
(defun pl-int (vo nn po p1)
    (let ((neye (dot nn (v- p1 po))))
      (if (= neye 0)
          nil
        (let ((s1 (/ (dot nn (v- vo po)) neye) ))
          (if (minusp s1) nil ;s1<0 means intersection behind us
                                        ;(format t "~A " s1)
            (v+ po (v*c (v- p1 po) s1)) ;formula
            )))))
;http://softsurfer.com/Archive/algorithm_0104/algorithm_0104B.htm#Line-Plane



(defun sq (a)
  (* a a))

(defun vecmag (x)
  (declare (type (vector rational 3) x))
  (sqrt (+ (sq (svref x 0)) (sq (svref x 1)) (sq (svref x 2)))))

(defun mkunitvec (vec)
  (declare (type (vector rational 3) vec))
  (let ((d (vecmag vec)))
    ;(format t "~%#d: ~A, v: ~A~%"  d vec)
    (if (zerop d) vec 
      (v*c vec (1/ d)))))
  

(defun 1/ (k)
  ;(format t  "~%#here in 1/, k: ~A~%" k)
  (/ 1 k))

;vector multiplied by constant
(defun v*c (vec k)
  (declare (type (vector rational 3) vec))
  (if (vectorp k) ; if order switched
      (v*c k vec)
    (vector (* k (svref vec 0))
            (* k (svref vec 1))
            (* k (svref vec 2)))))
;vector add
(defun v- (v1 v2)
  (declare (type (vector rational 3) v1 v2))
  (vector (- (svref v1 0) (svref v2 0))
          (- (svref v1 1) (svref v2 1))
          (- (svref v1 2) (svref v2 2))))
;vector subtract
(defun v+ (v1 v2)
    (declare (type (vector rational 3) v1 v2))
  (vector (+ (svref v1 0) (svref v2 0))
          (+ (svref v1 1) (svref v2 1))
          (+ (svref v1 2) (svref v2 2))))
;vector dot
(defun dot (v1 v2)
  (declare (type (vector rational 3) v1 v2))
  (+ (* (svref v1 0) (svref v2 0))
     (* (svref v1 1) (svref v2 1))
     (* (svref v1 2) (svref v2 2)) ))


(defun vec2lst (vec &optional (lst ()) (i 0))
  (if (= (length vec) i) lst
    (vec2lst vec (append lst (list (svref vec i))) (1+ i) )))


(defun magn (x y z)
  (sqrt (+ (* x x) (* y y) (* z z))))

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

(compile 'uni)
(compile 'dot)
(compile 'mkunitvec)
(compile 'update-hits)
(compile 'handle-plane)
(compile 'pl-int)
(compile 'handle-sphere)
(compile 'sl-int)
(compile 'minquad)
(compile 'find-all-hits)
(compile 'find-color-plane)
(compile 'find-color)
;(compile 'fooman)
(uni)