(define-structure point 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 (sqrt 1e-15)) (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-point (* s (point-x b)) (* s (point-y b)) (* s (point-z b)))) (define (v+v a b) (make-point (+ (point-x a) (point-x b)) (+ (point-y a) (point-y b)) (+ (point-z a) (point-z b)))) (define (v-v a b) (make-point (- (point-x a) (point-x b)) (- (point-y a) (point-y b)) (- (point-z a) (point-z b)))) (define (dot a b) (+ (* (point-x a) (point-x b)) (* (point-y a) (point-y b)) (* (point-z a) (point-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 zero (make-point 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)) (< (ray-sphere orig dir (scene-c scene) (scene-r scene)) infinity) (and (< (ray-sphere orig dir (scene-c scene) (scene-r scene)) infinity) (let loop ((scenes (scene-scenes scene))) (and (not (null? scenes)) (or (sintersect? orig dir (car scenes)) (loop (cdr scenes)))))))) (define neg-light (unitise (make-point 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-point 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-point (point-x c) (+ (point-y c) r) (point-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-point 0.0 -1.0 0.0))) (define (aux x d) (+ (- x (/ n 2.0)) (/ d ss))) (define orig (make-point 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-point (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)