M Jared Finder wrote:
> Post the ported code and we can take a look at it. Without the code, we
> can only make shots in the dark.
Here is Nathan Baum's port for CMUCL and SBCL:
(declaim (optimize (speed 3) (space 0) (debug 0) (safety 0)))
(defconstant infinity most-positive-single-float)
(defconstant delta (the single-float (sqrt single-float-epsilon)))
(declaim (inline vec v* v+ v- dot unitise ray vec make-ray make-sphere x y z
ray_trace))
(defstruct (vec (:conc-name nil) (:constructor vec (x y z)))
(x 0.0 :type single-float)
(y 0.0 :type single-float)
(z 0.0 :type single-float))
(defun v* (s r)
(declare (single-float s))
(the vec (vec (* s (x r)) (* s (y r)) (* s (z r)))))
(defmacro defvfun (name op)
`(defun ,name (a b)
(vec (,op (x a) (x b))
(,op (y a) (y b))
(,op (z a) (z b)))))
(defvfun v+ +)
(defvfun v- -)
(defun dot (a b)
(+ (* (x a) (x b)) (* (y a) (y b)) (* (z a) (z b))))
(defun unitise (r)
(the vec (v* (/ 1 (the single-float (sqrt (dot r r)))) r)))
(defstruct (ray (:conc-name nil))
(orig (vec 0.0 0.0 0.0) :type vec)
(dir (vec 0.0 0.0 0.0) :type vec))
(defun ray (orig dir) (make-ray :orig orig :dir dir))
(defstruct (sphere (:conc-name nil))
(center (vec 0.0 0.0 0.0) :type vec)
(radius 0.0 :type single-float))
(shadow 'group)
(defstruct (group (:conc-name nil) (:include sphere))
(children () :type list))
(defun ray_sphere (ray sphere)
(let* ((v (v- (center sphere) (orig ray)))
(b (dot v (dir ray)))
(disc (+ (- (* b b) (dot v v)) (* (radius sphere) (radius
sphere)))))
(if (< disc 0.0) infinity
(let ((disc (sqrt disc)))
(let ((t2 (+ b disc))
(t1 (- b disc)))
(cond ((< t2 0.0) infinity)
((> t1 0.0) t1)
(t t2)))))))
(defun intersect (ray scene)
(labels ((aux (hit scene)
(destructuring-bind (lam . _) hit
(declare (ignore _) (single-float lam))
(etypecase scene
(group
(if (>= (ray_sphere ray scene) lam)
hit
(reduce #'aux (children scene) :initial-value hit)))
(sphere
(let ((lamt (ray_sphere ray scene)))
(if (>= lamt lam) hit
(cons lamt (unitise (v- (v+ (orig ray) (v* lamt (dir
ray))) (center scene)))))))))))
(aux `(,infinity . (vec 0.0 0.0 0.0)) scene)))
(defun ray_trace (light ray scene)
(destructuring-bind (lam . normal) (intersect ray scene)
(declare (single-float lam))
(if (= lam infinity) 0.0
(let ((g (dot normal light)))
(if (>= g 0.0) 0.0
(let ((p (v+ (v+ (orig ray) (v* lam (dir ray))) (v* delta
normal))))
(destructuring-bind (lam . _)
(intersect (ray p (v* -1.0 light)) scene)
(declare (ignore _) (single-float lam))
(if (< lam infinity) 0.0 (- g)))))))))
(defun create (n c r)
(declare (single-float r)
(fixnum n))
(let ((obj (make-sphere :center c :radius r)))
(if (= n 1)
obj
(let ((rt (* 3.0 (/ r (sqrt 12.0)))))
(labels ((aux (x z) (create (1- n) (v+ c (vec x rt z)) (/ r
2.0))))
(make-group :center c
:radius (* 3.0 r)
:children (list* obj (mapcar #'aux
(list (- rt) rt (- rt)
rt)
(list (- rt) (- rt) rt
rt)))))))))
(defun main (level file-name n ss)
(declare (fixnum level n ss))
(let ((scene (create level (vec 0.0 -1.0 0.0) 1.0))
(light (unitise (vec -1.0 -3.0 2.0)))
(-n/2 (- (/ (float n) 2.0)))
(1-n/2 (1- (/ (float n) 2.0))))
(with-open-file (s
file-name :if-exists :supersede :if-does-not-exist :create :direction :output)
(format s "P5~%~A ~A~%255~%" n n))
(with-open-file (s file-name :element-type '(unsigned-byte
8) :if-exists :append :direction :output)
(loop for y of-type single-float from 1-n/2 downto -n/2
;;do (sb-ext:gc-off)
do (print y)
do (loop for x of-type single-float from -n/2 to 1-n/2
do (let ((g 0.0))
(declare (single-float g))
(loop for dx of-type single-float from x below (1+ x) by (/
1.0 ss)
do (loop for dy of-type single-float from y below (1+
y) by (/ 1.0 ss)
do (let ((d (unitise (vec dx dy (float
n)))))
(incf g (ray_trace light (ray (vec 0.0
0.0 -4.0) d) scene)))))
(let ((g (+ 0.5 (* 255.0 (/ g (* (float ss) (float
ss)))))))
(write-byte (floor g) s))))))))
#+sbcl (setf (sb-ext:BYTES-CONSED-BETWEEN-GCS) 100000000)
(time (main 6 "image.pgm" 160 4))
(quit)
--
Dr Jon D Harrop, Flying Frog Consultancy
http://www.ffconsultancy.com
|
