% gcl -load ray.lsp
; $Header: /home/abe/school/manual/ray-project/RCS/lisp.html,v 1.1 2010/06/05 16:29:47 abe Exp abe $
(setq objects '(((0.0 0.0 3.0) 1.0)))
(setq eye-point '(0 0 0.0))
(defun scan (objects xres yres pic)
(prog (x y color outf)
(setq y 0)
(setq outf (open pic :direction :output))
(output-header xres yres outf)
loop-y
(cond ((>= y yres)(go finish)))
(setq x 0)
loop-x
(cond ((>= x xres)(go next-y)))
(setq eye (make-eye-ray x y xres yres eye-point))
(setq color (trace-ray objects eye))
(setq color (make-normal-color color))
(output-color color outf)
(setq x (add1 x))
(go loop-x)
next-y
(setq y (add1 y))
(go loop-y)
finish
(close outf)
(return t)))
(defun output-header (xres yres f)
(prog ()
(format f "P3~%")
(format f "~d ~d~%" xres yres)
(format f "255~%")))
(defun output-color (c f)
(prog ()
(format f "~d ~d ~d~%"
(round (* 255 (car c)))
(round (* 255 (cadr c)))
(round (* 255 (caddr c))))))
(defun make-normal-color (color)
(prog (maxval)
(setq maxval (car color))
(cond ((> (cadr color) maxval) (setq maxval (cadr color))))
(cond ((> (caddr color) maxval) (setq maxval (caddr color))))
(cond ((> maxval 1.0)
(return (mapcar (function (lambda (x) (/ (float x) maxval))) color)))
(t (return color)))))
(defun make-eye-ray (x y xres yres atvec)
(prog (rat wx wy tv l)
(setq rat (/ (float yres) xres))
(setq wx (/ (- (* 2 x) (float xres)) (float xres)))
(setq wy (* rat (/ (+ (* -2 y) (float yres)) (float yres))))
(setq tv (/ 1 (sqrt (+ (+ (* wx wx) (* wy wy)) 1.0))))
(setq l (list (* wx tv)))
(setq l (append l (list (* wy tv))))
(setq l (append l (list tv)))
(return (list l atvec))))
(defun trace-ray (objects ray)
(prog (nv)
(setq nv (intersect objects ray))
(cond ((notnil nv) (return (shade nv)))
(t (return (back-ground-color ray))))))
(defun back-ground-color (ray)
(prog () (return '(1 1 1))))
(defun shade (nv)
(prog (d d1 d2)
(setq d1 (+ (+ (* 0.57735 (car nv)) (* -0.57735 (cadr nv)))
(+ (* 0.57735 (caddr nv) 0.8))))
(setq d2 (+ (+ (* -0.57735 (car nv)) (* 0.57735 (cadr nv)))
(+ (* 0.57735 (caddr nv)) 0.8)))
(setq d (max d1 d2))
(setq c (append (list (max 0.0 d)) (list 0)))
(return (append c (list 0)))))
(defun get-nthval (array n)
(cond ((< n 0) nil)
((= n 0) (car array))
(t (get-nthval (cdr array) (- n 1)))))
(defun intersect (objects ray)
(prog (mint vt obj n interobj vector)
(setq mint nil)
(setq n 0)
loop-obj
(setq obj (get-nthval objects n))
(cond ((isnil obj) (go finish)))
(setq vt (is-intersect ray obj))
(cond ((and (notnil vt) (or (isnil mint) (< vt mint)))
(prog () (setq mint vt)
(setq interobj obj))))
(setq n (add1 n))
(go loop-obj)
finish
(cond ((notnil mint) (prog (v) (setq v (car ray))
(setq vector (multi-vector mint v))
(setq vector (vector-minus vector (car interobj)))
(setq vector (make-normalv vector))))
(t (setq vector nil)))
(return vector)))
(defun make-normalv (v)
(prog (len nv)
(setq len (float (vector-length v)))
(setq nv (append (list (/ (car v) len)) (list (/ (cadr v) len))))
(setq nv (append nv (list (/ (caddr v) len))))
(return nv)))
(defun vector-length (v)
(prog (z)
(setq z (* (car v) (car v)))
(setq z (+ z (* (cadr v) (cadr v))))
(setq z (+ z (* (caddr v) (caddr v))))
(return (sqrt (float z)))))
(defun is-intersect (ray obj)
(prog (v b c d rad det t1 t2)
(setq v (vector-minus (cadr ray) (car obj)))
(setq rad (cadr obj))
(setq b (inner-product (car ray) v))
(setq c (- (inner-product v v) (* rad rad)))
(setq d (- (* b b) c))
(cond ((< d 0) (return nil)))
(setq det (sqrt (float d)))
(setq t1 (* -1 (+ b det)))
(setq t2 (- det b))
(cond ((< t2 0) (return nil))
((< t1 0) (return t2))
((> t1 t2) (return t2))
(t (return t1)))))
(defun vector-minus (x y)
(prog (v)
(setq v (- (car x) (car y)))
(setq v (append (list v) (list (- (cadr x) (cadr y)))))
(return (append v (list (- (caddr x) (caddr y)))))))
(defun multi-vector (a v)
(mapcar (function (lambda (x) (* (float x) a))) v))
(defun inner-product (x y)
(prog (i)
(setq i (* (car x) (car y)))
(setq i (+ i (* (cadr x) (cadr y))))
(setq i (+ i (* (caddr x) (caddr y))))
(return i)))
(defun add1 (x) (+ x 1))
(defun isnil (x) (eq x nil))
(defun notnil (x) (not (eq x nil)))
(scan objects 200 200 "lispray.ppm")
(quit)
Gnu Common Lisp によってレンダリングを実行している。