; Ray tracing program - 30th July 2019
; See http://www.ulisp.com/show?2NWA
;

; TFT colour display interface

; Pins used for display
(defvar dc 16)

(defvar cs 18)

; Display commands
(defvar CASET #x2A)

(defvar RASET #x2B)

(defvar RAMWR #x2C)

; Display offsets and dimensions
(defvar yoff 0)

(defvar xoff 0)

(defvar xsize 160)

(defvar ysize 128)

; Convert red, green, blue components 0 to 1 to a 16-bit 565 RGB value
(defun rgb (r g b)
 (logior
  (ash (logand (truncate (* 255 r)) #xf8) 8)
  (ash (logand (truncate (* 255 g)) #xfc) 3)
  (ash (truncate (* 255 b)) -3)))

; Write a command with data bytes to the display
(defun cmd (c &rest data)
  (with-spi (str cs)
    (digitalwrite dc 0)
    (write-byte c str)
    (digitalwrite dc 1)
    (dolist (d data)
      (write-byte d str))))

; Initialize the display
(defun init ()
  (pinmode dc t)
  (cmd #x01)      ; Software reset
  (delay 500)     ; delay 150 ms
  (cmd #x11)      ; Out of sleep mode
  (delay 500)     ; delay 500 ms
  (cmd #x3A #x05) ; Set color mode - 16-bit color
  (cmd #x26 8)    ; Set gamma
  (clear)
  (cmd #x29))     ; Display on

; Clear the display
(defun clear ()
  (cmd CASET 0 yoff 0 (+ yoff ysize -1))
  (cmd RASET 0 xoff 0 (+ xoff xsize -1))
  (cmd #x3A #x03)
  (cmd RAMWR)
  (with-spi (str cs)
    (dotimes (p (* (/ xsize 2) ysize 3))
      (write-byte 0 str)))
  (cmd #x3A #x05)))

; Plot colour c at coordinates x, y
(defun plotpoint (x y c)
  (cmd CASET 0 (+ yoff y) 0 (+ yoff y))
  (cmd RASET 0 (+ xoff x) 0 (+ xoff x))
  (cmd RAMWR (ash c -8) (logand c #xff)))

; Ray trace program

; Vector routines

(defun colour (r g b) (list r g b))
(defun point (x y z) (list x y z))
(defun vect (x y z) (list x y z))

(defun dot (v w) (apply + (mapcar * v w)))

(defun mul (k v) (mapcar (lambda (z) (* k z)) v))

(defun add (v w) (mapcar + v w))
(defun sub (v w) (mapcar - v w))

(defun sq (x) (* x x))
(defun mag (v) (sqrt (apply + (mapcar sq v))))

(defun unit-vector (v)
  (let ((d (mag v)))
    (mapcar (lambda (j) (/ j d)) v)))

(defun distance (p1 p2)
  (mag (mapcar - p1 p2)))

(defvar *world* nil)

(defvar *eye* nil)

(defvar *light* nil)

; Objects

(defun sphere-center (s) (second s))
(defun sphere-radius (s) (third s))
(defun sphere-colour (s) (nth 3 s))

(defun plane-point (s) (second s))
(defun plane-normal (s) (third s))
(defun plane-colour (s) (nth 3 s))

(defun make (&rest list)
  (push list *world*))

; Methods

; Get the colour of the object s
(defun object-colour (s)
  (case (first s)
    (sphere (sphere-colour s))
    (plane (plane-colour s))))

; Get the normal to the surface of object s at the point pt
(defun object-normal (s pt)
  (case (first s)
    (sphere (sphere-normal s pt))
    (plane (plane-normal s))))

(defun sphere-normal (s pt)
  (unit-vector (sub (sphere-center s) pt)))

; Find where the ray defined by pt and pr hits object s and return distance
(defun object-hit (s pt pr)
  (case (first s)
    (sphere (sphere-hit s pt pr))
    (plane (plane-hit s pt pr))))

(defun sphere-hit (s pt pr)
  (let* ((c (sphere-center s))
         (oc (mapcar - pt c)))
    (minroot
     (apply + (mapcar sq pr))
     (* 2 (dot oc pr))
     (- (dot oc oc) (sq (sphere-radius s))))))

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

(defun plane-hit (s pt pr)
  (let ((denom (dot (plane-normal s) pr)))
    (unless (zerop denom)
      (let ((n (/ (dot (sub (plane-point s) pt) (plane-normal s)) denom)))
        (when (>= n 0) n)))))

(defun background (x y) (colour 0.5 0.7 1))

(defun tracer ()
    (dotimes (x 160)
      (dotimes (y 128)
        (plotpoint x y (apply rgb (colour-at (- x 80) (- y 64)))))))

(defun colour-at (x y)
  (let ((c (send-ray 
            *eye*
            (unit-vector
             (sub (list x y 0) *eye*)))))
   (or c (background x y))))

; Return colour where ray hits first object, or nil if no hit
(defun send-ray (pt pr)
  (let* ((f (first-hit pt pr))
         (s (first f))
         (hit (second f)))
    (when s (mul (lambert s hit pr) (object-colour s)))))

(defun send-ray (pt pr)
  (let* ((f (first-hit pt pr))
         (s (first f))
         (hit (second f)))
    (when s
      (let* ((c (mul (lambert s hit pr) (object-colour s)))
             (f2 (first-hit *light* (unit-vector (sub hit *light*))))
             (h2 (second f2)))
        (cond
         ((< (distance hit h2) 1) c)
         (t (mul .75 c)))))))

; Return nearest surface in world, and hit point
(defun first-hit (pt pr)
  (let (surface hit dist)
    (dolist (s *world*)
      (let ((d (object-hit s pt pr)))
        (when d
          (let ((h (add pt (mul d pr))))
            (when (or (null dist) (< d dist))
              (setq surface s)
              (setq hit h)
              (setq dist d))))))
    (list surface hit)))

(defun lambert (s hit pr)
  (max 0 (dot pr (object-normal s hit))))

(defun ray-trace ()
  (setq *world* nil)
  (setq *eye* (point 0.0 0.0 200.0))
  (setq *light* (point -5000 10000 -1200))
  (make 'plane (point 0 -200 0) (vect 0 -1 0) (colour 2 2 2))
  (make 'sphere (point -250 0 -1000) 200 (colour 0 1 .5))
  (make 'sphere (point 50 0 -1200) 200 (colour 1 .5 0))
  (make 'sphere (point 400 0 -1400) 200 (colour 0 .5 1))
  (make 'sphere (point -50 -150 -600) 50 (colour 0 0 1))
  (make 'sphere (point 200 -150 -800) 50 (colour 1 0 0))
  (tracer))