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

(defun raytrace (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50))
  (let* ((world (append (list (sphere #(0 0 -1) .5
                                      #(0.5 0.5 0.0)
                                      (dielectric-material 0.4)
                                      #+(or)
                                      (lambda (rec ray world depth)
                                        (declare (ignore rec world depth))
                                        (with-slots (direction) ray
                                          (fw.lu:vector-destructuring-bind
                                              (x y z) (unit-vector direction)
                                            (vector (abs x)
                                                    (abs y)
                                                    (abs z)))))))
                        (loop repeat 30
                              collect (sphere (vector (rand-min-max -3 3)
                                                      (rand-min-max -0.5 2)
                                                      (rand-min-max -1.5d0 -0.5d0))
                                              (rand-min-max 0.2 0.5)
                                              (vector (random 1.0d0)
                                                      (random 1.0d0)
                                                      (random 1.0d0))
                                              (case (random 5)
                                                (0 (lambertian-material
                                                    (rand-min-max 0.25 0.75)))
                                                (1 (metal-material
                                                    (rand-min-max 0.25 0.75)))
                                                (2 (fuzzy-metal-material
                                                    (rand-min-max 0.25 0.75)
                                                    (rand-min-max 0.01 0.75)))
                                                (3 (dielectric-material
                                                    (rand-min-max 0.1 2.4)))
                                                (4 #'original-material)
                                                (5
                                                 (lambda (rec ray world depth)
                                                   (declare (ignore rec world depth))
                                                   (vector 1d0 1d0 1d0)
                                                   #+(or)
                                                   (with-slots (direction) ray
                                                     (fw.lu:vector-destructuring-bind
                                                         (x y z) (unit-vector direction)
                                                       (vector (abs x)
                                                               (abs y)
                                                               (abs z)))))))))
                        ;; #+(or)
                        (list (sphere #(0 -100.5 -1) 100
                                      #(0.5 0.5 0.5)
                                      (lambertian-material 0.2)))))
         (aspect-ratio 4/3)
         (image-height (* (floor (/ image-width aspect-ratio))))

         (camera (camera :focal-length 1.0d0)))
    (let ((mailbox (sb-concurrency:make-mailbox)))
      (loop for j in (shuffle (loop for x from 0 to image-height collect x))
            do
               (sb-concurrency:send-message
                (aref *thread-queues*
                      (mod j
                           (length *thread-queues*)))
                (list *samples-per-pixel*
                      j image-width
                      image-height camera
                      world max-depth
                      (lambda (a b)
                        (sb-concurrency:send-message
                         mailbox
                         (list a b))))))
      (write-colors nil
                    (lambda (c)
                      (loop with messages = 0
                            for it = (sb-concurrency:receive-message mailbox :timeout 2)
                            while it
                            do (destructuring-bind (color pos) it
                                 (funcall c color pos))))
                    image-width))))

(defun refraction-scene
    (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50))
  (let* ((world (list (sphere #(0 0 -1) .5
                              #(0.5 0.5 0.0)
                              (lambertian-material #(0.7 0.3 0.3)))
                      (sphere #(-1 0 -1) 0.5
                              #(0 0 0)
                              (dielectric-material 1.5))
                      (sphere #(-1 0 -1) -0.4
                              #(0 0 0)
                              (dielectric-material 1.5))
                      (sphere #(-1 0 -1) -0.2
                              #(0 0 0)
                              (lambertian-material
                               #(0.8 0.6 0.2)))
                      #+(or)
                      (sphere #(1 0 -1) 0.5
                              #(0 0 0)
                              (dielectric-material 2.4))
                      #+(or)
                      (sphere #(-2 0 -1) 0.5
                              #(0 0 0)
                              (metal-material #(0.8 0.8 0.8)))
                      (sphere #(1 0 -1) 0.5
                              #(0 0 0)
                              (metal-material #(0.8 0.6 0.2)))
                      (sphere #(0 -100.5 -1) 100
                              #(0.5 0.5 0.5)
                              (lambertian-material #(0.8 0.8 0.0)))))
         (aspect-ratio 16/9)
         (image-height (* (floor (/ image-width aspect-ratio))))

         (camera (camera)))
    (let ((mailbox (sb-concurrency:make-mailbox)))
      (loop for j in (shuffle (loop for x from 0 to image-height collect x))
            do
               (sb-concurrency:send-message
                (aref *thread-queues*
                      (mod j
                           (length *thread-queues*)))
                (list *samples-per-pixel*
                      j image-width
                      image-height camera
                      world max-depth
                      (lambda (a b)
                        (sb-concurrency:send-message
                         mailbox
                         (list a b))))))
      (write-colors nil
                    (lambda (c)
                      (loop with messages = 0
                            for it = (sb-concurrency:receive-message mailbox :timeout 2)
                            while it
                            do (destructuring-bind (color pos) it
                                 (funcall c color pos))))
                    image-width))))

(defun refraction-scene1
    (out &optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50))
  (let* ((world (list (sphere #(0 0 -1) 1
                              #(0.5 0.5 0.0)
                              (dielectric-material 2.4))
                      (sphere #(-0.5 0 -1) 0.5
                              #(0 0 0)
                              (dielectric-material 1.5 0.2))
                      (sphere #(-0.5 0 -1) -0.4
                              #(0 0 0)
                              (dielectric-material 1.5 0.2))
                      (sphere #(-0.5 0 -1) -0.2
                              #(0 0 0)
                              (metal-material
                               #(0.8 0.6 0.2)))
                      #+(or)
                      (sphere #(1 0 -1) 0.5
                              #(0 0 0)
                              (dielectric-material 2.4))
                      #+(or)
                      (sphere #(-2 0 -1) 0.5
                              #(0 0 0)
                              (metal-material #(0.8 0.8 0.8)))
                      (sphere #(0.5 0 -1) 0.5
                              #(0 0 0)
                              (metal-material #(0.8 0.6 0.2)))
                      (sphere #(0 -100.5 -1) 100
                              #(0.5 0.5 0.5)
                              (lambertian-material #(0.8 0.8 0.0)))))
         (aspect-ratio 16/9)
         (image-height (* (floor (/ image-width aspect-ratio))))

         (camera (camera)))
    (let ((mailbox (sb-concurrency:make-mailbox)))
      (loop for j in (shuffle (loop for x from 0 to image-height collect x))
            do
               (sb-concurrency:send-message
                (aref *thread-queues*
                      (mod j
                           (length *thread-queues*)))
                (list *samples-per-pixel*
                      j image-width
                      image-height camera
                      world max-depth
                      (lambda (a b)
                        (sb-concurrency:send-message
                         mailbox
                         (list a b))))))
      (write-colors nil
                    (lambda (c)
                      (loop with messages = 0
                            for it = (sb-concurrency:receive-message mailbox :timeout 2)
                            while it
                            do (destructuring-bind (color pos) it
                                 (funcall c color pos))))
                    image-width))))

(defun refraction-scene2
    (&optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50) (rows nil rows-p))
  (let* ((world (list (sphere #( 0.0 0 -1.0) 0.1 #(0.5 0.5 0.0) (dielectric-material 1.5))
                      (sphere #( 0.0 0 -1.4) 0.2 #(0.5 0.5 0.0) (dielectric-material 1.7))
                      (sphere #( 0.0 0 -2.4) 0.8 #(0.5 0.5 0.0) (dielectric-material 1.9))
                      (sphere #(-0.0 0 -3.6) 1.0 #(0.5 0.5 0.0) (dielectric-material 2.1))
                      (sphere #(-0.0 0 -5.0) 1.2 #(0.5 0.5 0.0) (dielectric-material 2.3))
                      (sphere #(-0.0 0 -6.6) 1.4 #(0.5 0.5 0.0) (dielectric-material 2.5))
                      #+foo (sphere #(-0.0 0 -1) -0.2
                                    #(0 0 0)
                                    (metal-material #(0.859375d0 0.859375d0 0.796875d0)))
                      #+foo (sphere #(0.6 0.0 -1) 0.2
                                    #(0 0 0)
                                    (metal-material #(0.859375d0 0.859375d0 0.796875d0)))
                      #+foo (sphere #(0 1 -1) 0.2
                                    nil
                                    (lambda (rec ray world depth)
                                      (declare (ignore rec ray world depth))
                                      #(1.0d0 1.0d0 1.0d0)))
                      (sphere #(0 -1000.5 -1.5) 1000
                              #(0.5 0.5 0.5)
                              (lambertian-material #(0.8 0.0 0.0))))
                #+(or)
                (list
                 (sphere #(-0.0 0 -1) 0.2
                         #(0 0 0)
                         (metal-material
                          #(0.8 0.6 0.2)))
                 (sphere #(0 -100.5 -1.5) 100
                         #(0.5 0.5 0.5)
                         (lambertian-material #(0.8 0.8 0.0)))))
         (aspect-ratio 16/9)
         (image-height (* (floor (/ image-width aspect-ratio))))

         (camera (camera)))
    (let ((mailbox (sb-concurrency:make-mailbox)))
      (loop for j in (if rows-p
                         rows
                         (shuffle (loop for x from 0 to image-height collect x)))
            do
               (sb-concurrency:send-message
                (aref *thread-queues*
                      (mod j
                           (length *thread-queues*)))
                (list *samples-per-pixel*
                      j image-width
                      image-height camera
                      world max-depth
                      (lambda (a b)
                        (sb-concurrency:send-message
                         mailbox
                         (list a b))))))
      (write-colors nil
                    (lambda (c)
                      (loop with messages = 0
                            for it = (sb-concurrency:receive-message mailbox :timeout 2)
                            while it
                            do (destructuring-bind (color pos) it
                                 (funcall c color pos))))
                    image-width))))

(defvar *planets*
  '(:mercury 3031/7917
    :venus   7520/7917
    :earth   7917/7917
    :mars    4212/7917))

(defun scene-3
    (&optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50) (rows nil rows-p))
  (let* ((world (list (sphere #(-2.25 0 -2)
                              (* 0.5 (getf *planets* :mercury))
                              nil
                              (metal-material #(0.8 0.8 0)))
                      (sphere #(-0.75 0 -2)
                              (* 0.5 (getf *planets* :venus))
                              nil
                              (metal-material #(0.0 0.8 0)))
                      (sphere #(0.75 0 -2)
                              (* 0.5 (getf *planets* :earth))
                              nil
                              (metal-material #(0.0 0.0 0.8)))
                      (sphere #(2.25 -0 -2)
                              (* 0.5 (getf *planets* :mars))
                              nil
                              (metal-material #(0.8 0.0 0.0)))))

         (aspect-ratio 16/9)
         (image-height (* (floor (/ image-width aspect-ratio))))

         (camera (camera)))
    (let ((mailbox (sb-concurrency:make-mailbox)))
      (loop for j in (if rows-p
                         rows
                         (shuffle (loop for x from 0 to image-height collect x)))
            do
               (sb-concurrency:send-message
                (aref *thread-queues*
                      (mod j
                           (length *thread-queues*)))
                (list *samples-per-pixel*
                      j image-width
                      image-height camera
                      world max-depth
                      (lambda (a b)
                        (sb-concurrency:send-message
                         mailbox
                         (list a b))))))
      (write-colors nil
                    (lambda (c)
                      (loop with messages = 0
                            for it = (sb-concurrency:receive-message mailbox :timeout 2)
                            while it
                            do (destructuring-bind (color pos) it
                                 (funcall c color pos))))
                    image-width))))

(defun scene-4
    (&optional (*samples-per-pixel* 10) (image-width 400) (max-depth 50) (rows nil rows-p))
  (let* ((world (append (loop for ti from 0 by (/ pi 7)
                              for x from 0
                              repeat 20
                              collect
                              (sphere
                               (vector (- (* 2 (sin ti)) 1)
                                       (- (* 2 (cos ti)) 1)
                                       (+ -0.5 (* -0.3 x)))
                               0.25
                               nil
                               (case (random 3)
                                 (0 (metal-material (vector (/ (mod (* 20 x)
                                                                    256)
                                                               256d0)
                                                            (/ (mod (* 20 x)
                                                                    256)
                                                               256d0)
                                                            (/ (mod (* 20 x)
                                                                    256)
                                                               256d0))))
                                 (1 (lambertian-material (vector (/ (mod (* 20 x)
                                                                         256)
                                                                    256d0)
                                                                 (/ (mod (* 20 x)
                                                                         256)
                                                                    256d0)
                                                                 (/ (mod (* 20 x)
                                                                         256)
                                                                    256d0))))
                                 (2 (dielectric-material (rand-min-max 1.4 2.5)
                                                         (rand-min-max 0 0.2))))))
                        (loop for ti from 0 by (/ pi 7)
                              for x from 0
                              repeat 20
                              collect
                              (sphere
                               (vector (- (sin (+ ti (/ pi 14))) 0.5)
                                       (- (cos (+ ti (/ pi 14))) 0.5)
                                       (+ -0.5 (* -0.3 x)))
                               0.25
                               nil
                               (case (random 3)
                                 (0 (metal-material (vector (/ (mod (* 20 x)
                                                                    256)
                                                               256d0)
                                                            (/ (mod (* 20 x)
                                                                    256)
                                                               256d0)
                                                            (/ (mod (* 20 x)
                                                                    256)
                                                               256d0))))
                                 (1 (lambertian-material (vector (/ (mod (* 20 x)
                                                                         256)
                                                                    256d0)
                                                                 (/ (mod (* 20 x)
                                                                         256)
                                                                    256d0)
                                                                 (/ (mod (* 20 x)
                                                                         256)
                                                                    256d0))))
                                 (2 (dielectric-material (rand-min-max 1.4 2.5)
                                                         (rand-min-max 0 0.2)))))))
                #+(or)
                (list
                 (sphere #(-0.0 0 -1) 0.2
                         #(0 0 0)
                         (metal-material
                          #(0.8 0.6 0.2)))
                 (sphere #(0 -100.5 -1.5) 100
                         #(0.5 0.5 0.5)
                         (lambertian-material #(0.8 0.8 0.0)))))
         (aspect-ratio 16/9)
         (image-height (* (floor (/ image-width aspect-ratio))))

         (camera (camera)))
    (let ((mailbox (sb-concurrency:make-mailbox)))
      (loop for j in (if rows-p
                         rows
                         (shuffle (loop for x from 0 to image-height collect x)))
            do
               (sb-concurrency:send-message
                (aref *thread-queues*
                      (mod j
                           (length *thread-queues*)))
                (list *samples-per-pixel*
                      j image-width
                      image-height camera
                      world max-depth
                      (lambda (a b)
                        (sb-concurrency:send-message
                         mailbox
                         (list a b))))))
      (write-colors nil
                    (lambda (c)
                      (loop with messages = 0
                            for it = (sb-concurrency:receive-message mailbox :timeout 2)
                            while it
                            do (destructuring-bind (color pos) it
                                 (funcall c color pos))))
                    image-width))))

(defun sample-image (out)
  (let ((image-width 256)
        (image-height 256))
    (alexandria:with-output-to-file (s out :if-exists :supersede)
      (call-with-ppm-header
       s (make-size :width image-width :height image-height)
       (lambda (s)
         (write-colors
          s (lambda (c)
              (loop for j from (1- image-height) downto 0
                    do (format *trace-output*
                               "~&Scanlines remaining: ~d ~s~%"
                               j
                               (local-time:now))
                    do
                       (loop for i from 0 below image-width
                             collect
                             (let* ((r (/ (* i 1.0d0)
                                          (1- image-width)))
                                    (g (/ (* j 1.0d0)
                                          (1- image-height)))
                                    (b 0.15d0))
                               (funcall c (make-color :r r
                                                      :g g
                                                      :b b))))))
          image-width))
       (1- #.(expt 2 8))))))

#+(or)
((list 'quote
       (loop for ti from 0 by (/ pi 7)
             for x from 0
             repeat 20
             collect (list (vector (- (* 2 (sin ti)) 1)
                                   (- (* 2 (cos ti)) 1)
                                   (+ -0.2 (* -0.3 x)))
                           0.25
                           nil
                           (list (vector (/ (mod (* 20 x)
                                                 256)
                                            256d0)
                                         (/ (mod (* 20 x)
                                                 256)
                                            256d0)
                                         (/ (mod (* 20 x)
                                                 256)
                                            256d0))))))

 '((#(-1.0 1.0 -0.2) 0.25 NIL)
   (#(-0.13223252176488376d0 0.8019377358048383d0 -0.5) 0.25 NIL)
   (#(0.5636629649360596d0 0.2469796037174672d0 -0.8) 0.25 NIL)
   (#(0.9498558243636472d0 -0.5549581320873711d0 -1.1) 0.25 NIL)
   (#(0.9498558243636472d0 -1.4450418679126287d0 -1.4000001) 0.25 NIL)
   (#(0.5636629649360598d0 -2.2469796037174667d0 -1.7) 0.25 NIL)
   (#(-0.13223252176488354d0 -2.801937735804838d0 -2.0) 0.25 NIL)
   (#(-0.9999999999999998d0 -3.0d0 -2.3000002) 0.25 NIL)
   (#(-1.8677674782351161d0 -2.801937735804838d0 -2.6000001) 0.25 NIL)
   (#(-2.5636629649360594d0 -2.246979603717467d0 -2.9) 0.25 NIL)
   (#(-2.949855824363647d0 -1.4450418679126291d0 -3.2) 0.25 NIL)
   (#(-2.949855824363647d0 -0.5549581320873715d0 -3.5000002) 0.25 NIL)
   (#(-2.56366296493606d0 0.24697960371746674d0 -3.8000002) 0.25 NIL)
   (#(-1.8677674782351166d0 0.8019377358048381d0 -4.1) 0.25 NIL)
   (#(-1.0000000000000004d0 1.0d0 -4.4) 0.25 NIL)
   (#(-0.1322325217648842d0 0.8019377358048385d0 -4.7) 0.25 NIL)
   (#(0.5636629649360592d0 0.2469796037174674d0 -5.0) 0.25 NIL)
   (#(0.949855824363647d0 -0.5549581320873707d0 -5.3) 0.25 NIL)
   (#(0.9498558243636475d0 -1.4450418679126282d0 -5.6) 0.25 NIL)
   (#(0.56366296493606d0 -2.2469796037174667d0 -5.9) 0.25 NIL))

 (/ 1960 60.0)
 )