(in-package :fwoar.lisp-sandbox.1)

(defclass hittable ()
  ())

(fw.lu:defclass+ sphere (hittable)
  ((center :initarg :center)
   (radius :initarg :radius)
   (material-color :initarg :color
                   :reader material-color
                   :initform (vec3 (random 1.0d0)
                                   (random 1.0d0)
                                   (random 1.0d0)))
   (material :initarg :material
             :reader .material
             :initform (lambertian-material (random 0.8)))))

(fw.lu:defclass+ ray ()
  ((origin :initarg :origin)
   (direction :initarg :direction)))

(fw.lu:defclass+ hit-record ()
  ((p :initarg :p :reader .p)
   (time :initarg :time :reader .time)
   (thing :initarg :thing :accessor .thing)
   (material :initarg :material :accessor .material)
   (normal :initarg :normal :accessor .normal :initform ())
   (front-face :initarg :front-face :accessor .front-face :initform ())))

(defclass camera ()
  ((origin :initarg :origin :reader origin)
   (lower-left-corner :initarg :lower-left-corner :reader lower-left-corner)
   (horizontal :initarg :horizontal :reader horizontal)
   (vertical :initarg :vertical :reader vertical)))

(defstruct (vec3 (:type vector)
                 (:constructor vec3 (x y z))
                 (:conc-name v3-))
  x y z)

(defun call-with-ppm-header (stream size callback &optional (colors 255))
  (format stream "P3~%~d ~d~%~d~%"
          (size-width size)
          (size-height size)
          colors)
  (funcall callback stream))

#.(progn (defmacro ig (&rest syms) `'(declare (ignore ,@syms)))
         nil)

(defun format-color (s v _ __)
  #.(ig _ __)
  (fw.lu:vector-destructuring-bind (r g b) (scale-to-8bit v)
    (format s "~4d ~4d ~4d" r g b)))

(defun write-colors (stream colors columns)
  (funcall colors
           (lambda (color pos)
             (fwoar.lisp-sandbox.canvas-server:send-update
              (scale-to-8bit color) pos)))
  #+(or)
  (let ((intermediate ())
        (idx 0))
    (funcall colors
             (lambda (color)
               (push color intermediate)
               (when (= (1- columns)
                        (mod idx columns))
                 (format stream "~{~/fwoar.lisp-sandbox.1::format-color/~^  ~}~&" intermediate)
                 (setf intermediate ()))
               (incf idx)))
    (when intermediate
      (format stream "~{~/fwoar.lisp-sandbox.1::format-color/~^  ~}~&" intermediate))))

(defgeneric at (self it)
  (:method ((ray ray) (it number))
    (with-slots (origin direction) ray
      (vec+ origin
            (vec* it direction)))))
(defun set-face-normal (hit-record r outward-normal)
  (prog1 hit-record
    (with-slots (direction) r
      (let ((front-face (< (dot direction outward-normal)
                           0)))
        (setf (.front-face hit-record) front-face
              (.normal hit-record) (if front-face
                                       outward-normal
                                       (vec* -1 outward-normal)))))))

(defgeneric hit (thing ray t-min t-max)
  (:method ((things list) (r ray) (t-min real) (t-max real))
    (let (temp-rec
          (hit-anything nil)
          (closest-so-far t-max))
      (loop for thing in things
            for (hit-p hit-rec) = (multiple-value-list
                                   (hit thing r t-min closest-so-far))
            when hit-p do
              (setf hit-anything t
                    closest-so-far (.time hit-rec)
                    temp-rec hit-rec))
      (when hit-anything
        (values hit-anything
                temp-rec))))
  (:method ((sphere sphere) (r ray) (t-min real) (t-max real))
    (declare (optimize (speed 3)))
    (uiop:nest (with-slots ((%center center) (%radius radius)) sphere)
               (let ((center %center) (radius %radius)))
               (with-slots ((%origin origin) (%direction direction)) r)
               (let ((origin %origin) (direction %direction)))
               (let* ((oc (vec- origin center))
                      (a (length-squared direction))
                      (half-b (dot oc direction))
                      (c (- (length-squared oc)
                            (* radius radius)))
                      (discriminant (- (* half-b half-b)
                                       (* a c))))
                 (if (< discriminant 0)
                     (return-from hit nil)
                     (let* ((sqrtd (sqrt discriminant))
                            (root (/ (- (- half-b)
                                        sqrtd)
                                     a)))
                       (when (or (< root t-min)
                                 (< t-max root))
                         (setf root (/ (- sqrtd half-b)
                                       a))
                         (when (or (< root t-min)
                                   (< t-max root))
                           (return-from hit nil)))
                       (let* ((p (at r root))
                              (outward-normal (vec/ (vec- p center)
                                                    radius)))

                         (values t
                                 (set-face-normal (hit-record p root sphere (.material sphere))
                                                  r
                                                  outward-normal)))))))))

(defun hit-sphere (center radius r)
  (with-slots (origin direction) r
    (let* ((oc (vec- origin center))
           (a (length-squared direction))
           (half-b (dot oc direction))
           (c (- (length-squared oc)
                 (expt radius 2)))
           (discriminant (- (* half-b half-b)
                            (* a c))))
      (if (< discriminant 0)
          -1.0d0
          (/ (- (- half-b) (sqrt discriminant))
             a)))))

(defgeneric scatter (material ray-in rec))

(defun reflect (v n)
  (vec- v
        (vec* 2.0d0
              (vec* (dot v n)
                    n))))

(defun refract (uv n eta*/eta)
  (let* ((cos-theta (min 1.0d0
                         (dot (negate uv)
                              n)))
         (out-perp (vec* eta*/eta
                         (vec+ uv
                               (vec* cos-theta
                                     n))))
         (out-parallel (vec* (- (sqrt (abs (- 1.0d0
                                              (length-squared out-perp)))))
                             n)))
    (vec+ out-perp out-parallel)))

(defun reflectance (cosine ref-idx)
  (let* ((r0 (/ (- 1 ref-idx)
                (+ 1 ref-idx)))
         (r0 (* r0 r0)))
    (+ r0
       (* (- 1 r0)
          (expt (- 1 cosine)
                5)))))

(define-symbol-macro infinity
  #.sb-ext:double-float-positive-infinity)
(defgeneric ray-color (ray world depth)
  (:method :around (r w (depth integer))
    (if (<= depth 0)
        (vec3 1.0d0 1.0d0 1.0d0)
        (call-next-method)))
  (:method ((ray ray) world (depth integer))
    (multiple-value-bind (hit-p rec)
        (hit world ray 0.001d0 infinity)
      (when hit-p
        (return-from ray-color
          (funcall (.material rec) rec ray world depth)))
      (with-slots (direction) ray
        (let* ((unit-direction (unit-vector direction))
               (it (+ (* 0.5 (v3-y unit-direction))
                      1.0d0)))
          (vec+ (vec* (- 1.0d0 it)
                      #(1.0d0 1.0d0 1.0d0))
                (vec* it
                      #(0.5d0 0.7d0 1.0d0))))))))

(defun camera (&key
                 (aspect-ratio 16/9)
                 (viewport-height 2.0d0)
                 (viewport-width (* aspect-ratio viewport-height))
                 (focal-length 1.0d0))
  (let ((origin (vec3 0d0 0.0d0 0.0d0))
        (horizontal (vec3 viewport-width 0.0d0 0.0d0))
        (vertical (vec3 0.0d0 viewport-height 0.0d0)))
    (make-instance 'camera
                   :origin origin
                   :horizontal horizontal
                   :vertical vertical
                   :lower-left-corner (vec- (vec- (vec- origin
                                                        (vec/ horizontal 2))
                                                  (vec/ vertical 2))
                                            (vec3 0 0 focal-length)))))
(defgeneric get-ray (camera u v)
  (:method ((camera camera) (u real) (v real))
    (with-slots (origin horizontal vertical lower-left-corner) camera
      (macrolet ((-> (v &body forms)
                   (if forms
                       `(-> (,(caar forms) ,v ,@(cdar forms))
                            ,@(cdr forms))
                       v)))


        (ray origin
             (-> lower-left-corner
                 (vec+ (vec* u horizontal))
                 (vec+ (vec* v vertical))
                 (vec- origin)))))))

(declaim (notinline u-loop))
(defun u-loop (j image-width image-height camera world max-depth c)
  (loop for i from 0 below image-width
        for u = (/ (* 1.0d0 i)
                   (1- image-width))
        for v = (/ (* 1.0d0 j)
                   (1- image-height))
        for r = (get-ray camera u v)
        for color = (loop for s below *samples-per-pixel*
                          for u = (/ i
                                     (1- image-width))
                            then (/ (+ i (random 1.0d0))
                                    (1- image-width))
                          for v = (/ j
                                     (1- image-height))
                            then (/ (+ j (random 1.0d0))
                                    (1- image-height))
                          for r = (get-ray camera u v)
                          for pixel-color = (ray-color r world max-depth)
                            then (vec+ pixel-color
                                       (ray-color r world max-depth))
                          finally (return pixel-color))
        do (funcall c color
                    (list i
                          (- image-height j)))))

(defvar *thread-queues*
  (make-array 8))

(defun start-worker (id)
  (let ((mailbox (sb-concurrency:make-mailbox :name (format nil "mailbox-~d" id))))
    (setf (aref *thread-queues* id) mailbox)
    (bt:make-thread
     (lambda ()
       (loop
         (destructuring-bind (*samples-per-pixel*
                              j image-width image-height camera world max-depth c)
             (sb-concurrency:receive-message mailbox)
           (u-loop j image-width image-height camera world max-depth c))))
     :name (format nil "worker-~d" id))))

(defun start-workers (&optional (n 8))
  (loop for x below n
        collect (start-worker x)))

(defun shuffle (seq)
  (let ((arr (map 'vector 'identity seq)))
    (loop for i from (1- (length arr)) downto 1
          for j = (random i)
          do (rotatef (aref arr i)
                      (aref arr j))
          finally (return (coerce arr (type-of seq))))))

#+(or)
(progn (let ((it (map 'list
                      'sb-concurrency:mailbox-count
                      *thread-queues*)))
         (list it (apply '+ it)))
       )