robios::blog

ANSI Common Lispの簡易レイトレーサをScheme (DrScheme)へ移植してみました。

dolistとpushのマクロを定義しています。

(define sq
  (lambda (x)
    (* x x)))

(define mag
  (lambda (x y z)
    (sqrt (+ (sq x) (sq y) (sq z)))))

(define unit-vector
  (lambda (x y z)
    (let ((d (mag x y z)))
      (values (/ x d) (/ y d) (/ z d)))))

(define-struct point (x y z))

(define distance
  (lambda (p1 p2)
    (mag (- (point-x p1) (point-x p2))
         (- (point-y p1) (point-y p2))
         (- (point-z p1) (point-z p2)))))

(define minroot
  (lambda (a b c)
    (if (zero? a)
        (/ (- c) b)
        (let ((disc (- (sq b) (* 4 a c))))
          (if (negative? disc)
              #f
              (let ((discrt (sqrt disc)))
                (min (/ (+ (- b) discrt) (* 2 a))
                     (/ (- (- b) discrt) (* 2 a)))))))))

(define-struct surface (color))

(define *world* null)

(define eye (make-point 0 0 200))

(define tracer
  (lambda (pathname res)
    (let ((p (open-output-file pathname 'replace)))
      (fprintf p "P2 ~A ~A 255 ~n" (* res 100) (* res 100))
      (let ((inc (/ res)))
        (do ((y -50 (+ y inc)))
          ((< (- 50 y) inc))
          (do ((x -50 (+ x inc)))
            ((< (- 50 x) inc))
            (fprintf p "~A ~n" (color-at x y)))))
      (close-output-port p))))

(define color-at
  (lambda (x y)
    (call-with-values
     (lambda ()
       (unit-vector (- x (point-x eye))
                    (- y (point-y eye))
                    (- 0 (point-z eye))))
     (lambda (xr yr zr)
       (inexact->exact
        (round (* (sendray eye xr yr zr) 255)))))))

(define sendray
  (lambda (pt xr yr zr)
    (call-with-values 
     (lambda () (first-hit pt xr yr zr))
     (lambda (s int)
       (if (null? s)
           0
           (* (lambert s int xr yr zr) (surface-color s)))))))

(define-syntax dolist 
  (syntax-rules ()
    ((dolist (el list) body1 body2 ...)
     (do ((to-do list (cdr to-do)))
       ((null? to-do))
       (let ((el (car to-do)))
         body1
         body2
         ...)))
    ((dolist (el list res) body1 body2 ...)
     (do ((to-do list (cdr to-do)))
       ((null? to-do) res)
       (let ((el (car to-do)))
         body1
         body2
         ...)))))

(define first-hit
  (lambda (pt xr yr zr)
    (let ((surface null) (hit null) (dist null))
      (dolist (s *world*)
              (let ((h (intersect s pt xr yr zr)))
                (when h
                  (let ((d (distance h pt)))
                    (when (or (null? dist) (< d dist))
                      (set! surface s)
                      (set! hit h)
                      (set! dist d))))))
      (values surface hit))))

(define lambert
  (lambda (s int xr yr zr)
    (call-with-values
     (lambda () (normal s int))
     (lambda (xn yn zn)
       (max 0 (+ (* xr xn) (* yr yn) (* zr zn)))))))

(define-struct (sphere surface) (radius center))

(define-syntax push
  (syntax-rules ()
    ((push item list)
     (set! list (cons item list)))))

(define defsphere
  (lambda (x y z r c)
    (let ((s (make-sphere c r (make-point x y z))))
      (push s *world*)
      s)))

(define intersect
  (lambda (s pt xr yr zr)
    (cond
      ((sphere? s) (sphere-intersect s pt xr yr zr)))))

(define sphere-intersect
  (lambda (s pt xr yr zr)
    (let* ((c (sphere-center s))
           (n (minroot 
               (+ (sq xr) (sq yr) (sq zr))
               (* 2 (+ (* (- (point-x pt) (point-x c)) xr)
                       (* (- (point-y pt) (point-y c)) yr)
                       (* (- (point-z pt) (point-z c)) zr)))
               (+ (sq (- (point-x pt) (point-x c)))
                  (sq (- (point-y pt) (point-y c)))
                  (sq (- (point-z pt) (point-z c)))
                  (- (sq (sphere-radius s)))))))
      (if n
          (make-point 
           (+ (point-x pt) (* n xr))
           (+ (point-y pt) (* n yr))
           (+ (point-z pt) (* n zr)))
          #f))))

(define normal
  (lambda (s pt)
    (cond
      ((sphere? s) (sphere-normal s pt)))))

(define sphere-normal
  (lambda (s pt)
    (let ((c (sphere-center s)))
      (unit-vector (- (point-x c) (point-x pt))
                   (- (point-y c) (point-y pt))
                   (- (point-z c) (point-z pt))))))

(define ray-test
  (lambda (res)
    (set! *world* null)
    (defsphere 0 -300 -1200 200 .8)
    (defsphere -80 -150 -1200 200 .7)
    (defsphere 70 -100 -1200 200 .9)
    (do ((x -2 (add1 x)))
      ((> x 2))
      (do ((z 2 (add1 z)))
	((> z 7))
        (defsphere (* x 200) 300 (* z -400) 40 .75)))
    (tracer "spheres.pgm" res)))

実行は、(ray-test 1)。生成されるファイルはpgm形式なので、Win/Mac系ではビューワが必要。

Common LispとSchemeのベンチマークはおもしろそうなので次回。実装に依存しまくりだろうけど。