(define-structure vec x y z)

(define-structure scene c r scenes)

(define-structure hit l n)

(define fail #f)

(define infinity (/ 1.0 0.0))

(define delta 1.49011611938476562e-08)

(define (fold f i l)
  (let loop ((result i) (l l))
    (if (null? l) result (loop (f (car l) result) (cdr l)))))

(define (s*v s b)
  (make-vec (* s (vec-x b)) (* s (vec-y b)) (* s (vec-z b))))

(define (v+v a b)
  (make-vec (+ (vec-x a) (vec-x b))
	    (+ (vec-y a) (vec-y b))
	    (+ (vec-z a) (vec-z b))))

(define (v-v a b)
  (make-vec (- (vec-x a) (vec-x b))
	    (- (vec-y a) (vec-y b))
	    (- (vec-z a) (vec-z b))))

(define (dot a b)
  (+ (* (vec-x a) (vec-x b))
     (* (vec-y a) (vec-y b))
     (* (vec-z a) (vec-z b))))

(define (magnitude r) (sqrt (dot r r)))

(define (unitise r) (s*v (/ 1.0 (magnitude r)) r))

(define (ray-sphere orig dir center radius)
  (let* ((v (v-v center orig))
	 (b (dot v dir))
	 (disc (+ (- (* b b) (dot v v)) (* radius radius))))
    (if (negative? disc)
	infinity
	(let* ((disc (sqrt disc)) (t2 (+ b disc)))
	  (if (negative? t2)
	      infinity
	      (let ((t1 (- b disc))) (if (positive? t1) t1 t2)))))))

(define (sray-sphere? orig dir center radius)
  (let* ((v (v-v center orig))
	 (b (dot v dir))
	 (disc (+ (- (* b b) (dot v v)) (* radius radius))))
    (not (or (negative? disc) (negative? (+ b (sqrt disc)))))))

(define zero (make-vec 0.0 0.0 0.0))

(define (intersect orig dir scene)
  (let aux ((scene scene) (hit (make-hit infinity zero)))
    (let ((l (hit-l hit)))
      (if (null? (scene-scenes scene))
	  (let ((l-prime (ray-sphere orig dir (scene-c scene)
				     (scene-r scene))))
	    (if (>= l-prime l)
		hit
		(make-hit
		 l-prime
		 (unitise (v+v orig (v-v (s*v l-prime dir)
					 (scene-c scene)))))))
	  (if (>= (ray-sphere orig dir (scene-c scene) (scene-r scene)) l)
	      hit
	      (fold aux hit (scene-scenes scene)))))))

(define (sintersect? orig dir scene)
  (if (null? (scene-scenes scene))
      (sray-sphere? orig dir (scene-c scene) (scene-r scene))
      (and
       (sray-sphere? orig dir (scene-c scene) (scene-r scene))
       (let loop ((scenes (scene-scenes scene)))
	 (and (not (null? scenes))
	      (or (sintersect? orig dir (car scenes)) (loop (cdr scenes))))))))

(define neg-light (unitise (make-vec 1.0 3.0 -2.0)))

(define (ray-trace orig dir scene)
  (let* ((hit (intersect orig dir scene)) (lam (hit-l hit)) (n (hit-n hit)))
    (if (>= lam infinity)
	0.0
	(let ((g (dot n neg-light)))
	  (if (and (positive? g)
		   (not (sintersect? (v+v orig (v+v (s*v lam dir)
						    (s*v delta n)))
				     neg-light
				     scene)))
	      g
	      0.0)))))

(define (bound scene-prime scene)
  (if (null? (scene-scenes scene-prime))
      (make-scene
       (scene-c scene)
       (max (scene-r scene)
	    (+ (magnitude (v-v (scene-c scene) (scene-c scene-prime)))
	       (scene-r scene-prime)))
       '())
      (fold bound scene (scene-scenes scene-prime))))

(define (create level r c)
  (let ((obj (make-scene c r '())))
    (if (= level 1)
	obj
	(let* ((r-prime (* 3.0 (/ r (sqrt 12.0))))
	       (aux (lambda (x-prime z-prime)
		      (create (- level 1)
			      (* 0.5 r)
			      (v+v c (make-vec x-prime r-prime z-prime)))))
	       (objs (list obj
			   (aux (- r-prime) (- r-prime))
			   (aux r-prime (- r-prime))
			   (aux (- r-prime) r-prime)
			   (aux r-prime r-prime)))
	       (obj (fold bound
			  (make-scene
			   (make-vec (vec-x c) (+ (vec-y c) r)
				     (vec-z c))
			   0.0
			   '())
			  objs)))
	  (make-scene (scene-c obj) (scene-r obj) objs)))))

(define level
  (if (= (vector-length argv) 3)
      (inexact->exact (truncate (string->number (vector-ref argv 1))))
      9))

(define n
  (if (= (vector-length argv) 3)
      (inexact->exact (truncate (string->number (vector-ref argv 2))))
      512))

(define ss 4)

(define scene (create level 1.0 (make-vec 0.0 -1.0 0.0)))

(define (aux x d) (+ (- x (/ n 2.0)) (/ d ss)))

(define orig (make-vec 0.0 0.0 -4.0))

(define (g x y)
  (do ((dx  0   (+ dx 1))
       (sum 0.0 (do ((dy	 0   (+ dy 1))
		     (sum sum (+ sum
				 (ray-trace orig
					    (unitise
					     (make-vec (aux x dx)
						       (aux (- (- n 1) y) dy)
						       (exact->inexact n)))
					    scene))))
		    ((>= dy ss) sum))))
      ((>= dx ss) sum)))

(define (pixel x y)
  (write-char
   (integer->char
    (inexact->exact (truncate (+ 0.5 (* 255 (/ (g x y) (* ss ss)))))))))

(define (go)
  (display "P5")
  (newline)
  (display n)
  (display " ")
  (display n)
  (newline)
  (display 255)
  (newline)
  (do ((y 0 (+ y 1))) ((>= y n)) (do ((x 0 (+ x 1))) ((>= x n)) (pixel x y))))

(go)