;; -*- mode: common-lisp; package: user -*-
(in-package :user)
(defun sq (x) (* x x))
(define-compiler-macro sq (x)
`(let ((x ,x)) (* x x)))
(defun mag (x y z)
(sqrt (+ (sq x) (sq y) (sq z))))
(defun unit-vector (x y z)
(let ((d (mag x y z)))
(values (/ x d) (/ y d) (/ z d))))
#+never
(defstruct (point (:conc-name nil))
x y z)
;; Rather than use a defstruct to represent points, we can achieve a little more
;; efficiency by using a vector. We can specialize the element-type in some
;; implementations, allowing declarations that increase computation speed.
(defmacro x (point)
`(aref (the simple-vector ,point) 0))
(defmacro y (point)
`(aref (the simple-vector ,point) 1))
(defmacro z (point)
`(aref (the simple-vector ,point) 2))
(defun make-point (x y z)
(vector x y z))
(define-compiler-macro make-point (x y z)
`(vector ,x ,y ,z))
(defun distance (p1 p2)
(mag (- (x p1) (x p2))
(- (y p1) (y p2))
(- (z p1) (z p2))))
;; A faster alternative useful when we merely want to compare magnitudes
;; and don't care about the actual value.
(defun distance-sq (p1 p2)
(+ (sq (- (x p1) (x p2)))
(sq (- (y p1) (y p2)))
(sq (- (z p1) (z p2)))))
(defun minroot (a b c)
(if (zerop a)
(/ (- c) b)
(let ((disc (- (sq b) (* 4 a c))))
(unless (minusp disc)
(let ((discrt (sqrt disc)))
(min (/ (+ (- b) discrt) (* 2 a))
(/ (- (- b) discrt) (* 2 a))))))))
(defstruct surface color)
(defparameter *world* nil)
(defparameter eye (make-point 0 0 200))
;; dib and ppm have opposite conventions for positive y axis.
(defun tracer (p &key (res 1))
(let* ((width (round (* res 100)))
(height (round (* res 100)))
(inc (float (/ res)))
(init (- inc 50)))
(with-dib-writing (p writer padder
:width width :height height :bits-per-pixel 24)
(loop repeat height
for y from init by inc
do (loop repeat width
for x from init by inc
do (funcall writer p (color-at x y))
finally (funcall padder p))))))
(defun tracer-ppm (p &key (res 1))
(let* ((width (round (* res 100)))
(height (round (* res 100)))
(inc (float (/ res)))
(init (- inc 50)))
(with-ppm-writing (p writer padder
:width width :height height)
(loop repeat height
for y from 50 by (- inc)
do (loop repeat width
for x from init by inc
do (funcall writer p (color-at x y))
finally (funcall padder p))))))
(defun color-at (x y)
(multiple-value-bind (xr yr zr)
(unit-vector (- x (x eye))
(- y (y eye))
(- 0 (z eye)))
(sendray eye xr yr zr)))
(defun sendray (pt xr yr zr)
(multiple-value-bind (s int) (first-hit pt xr yr zr)
(if s
(let ((lambert (lambert s int xr yr zr))
(surface-color (surface-color s)))
(make-rgbi (round (* lambert (rgbi-red surface-color)))
(round (* lambert (rgbi-green surface-color)))
(round (* lambert (rgbi-blue surface-color)))))
;; dark-grey background
(load-time-value (make-rgbi 64 64 64)))))
(defun first-hit (pt xr yr zr)
(let (surface hit dist)
(dolist (s *world*)
(let ((h (intersect s pt xr yr zr)))
(when h
(let ((d (distance-sq h pt)))
(when (or (null dist) (< d dist))
(setf surface s hit h dist d))))))
(values surface hit)))
(defun lambert (s int xr yr zr)
(multiple-value-bind (xn yn zn) (normal s int)
(max 0 (+ (* xr xn) (* yr yn) (* zr zn)))))
(defvar *object-unique-id-generator* 0)
(defstruct (sphere (:include surface))
radius center
;; This provided for use in a user interface.
(unique-id (incf *object-unique-id-generator*))
)
(defun defsphere (x y z r c)
(let ((s (make-sphere :radius r
:center (make-point x y z)
:color c)))
(push s *world*)
s))
(defun intersect (s pt xr yr zr)
(funcall (typecase s (sphere #'sphere-intersect))
s pt xr yr zr))
(defun sphere-intersect (s pt xr yr zr)
(let* ((c (sphere-center s))
(n (minroot (+ (sq xr) (sq yr) (sq zr))
(* 2 (+ (* (- (x pt) (x c)) xr)
(* (- (y pt) (y c)) yr)
(* (- (z pt) (z c)) zr)))
(+ (sq (- (x pt) (x c)))
(sq (- (y pt) (y c)))
(sq (- (z pt) (z c)))
(- (sq (sphere-radius s)))))))
(when n
#+never
(make-point (round (+ (x pt) (* n xr)))
(round (+ (y pt) (* n yr)))
(round (+ (z pt) (* n zr))))
#-never
(make-point (+ (x pt) (* n xr))
(+ (y pt) (* n yr))
(+ (z pt) (* n zr))))))
(defun normal (s pt)
(funcall (typecase s (sphere #'sphere-normal))
s pt))
(defun sphere-normal (s pt)
(let ((c (sphere-center s)))
(unit-vector (- (x c) (x pt))
(- (y c) (y pt))
(- (z c) (z pt)))))
(defun ray-test (&key (res 1) ppm gif)
(let ((*world* nil))
(defsphere 45 215 -1150 110 (make-rgbi 220 40 50))
(defsphere -150 90 -1200 180 (make-rgbi 30 250 40))
(defsphere 150 -10 -1200 160 (make-rgbi 100 150 250))
(defsphere -20 -40 -1150 60 (make-rgbi 200 120 200))
(loop for x from -2 to 2
for r from 50 by 40
for b1 from 25 by 20
do (loop for z from 2 to 7
for g from 50 by 40
for b2 from 25 by 20
do (defsphere (* x 200) -300 (* z -400) 40 (make-rgbi r g (+ b1 b2)))))
(ray-trace *world* :res res :ppm ppm :gif gif)))
;; This function makes the input/output arrangements for the ray tracer, then calls it.
;; The output can be either to a stream or a file, and can be in any of bmp, gif, or ppm
;; formats. The tricky case is gif, since we need to use Linux/Unix filters in a shell
;; subprocesses to convert ppm to gif. These programs aren't available on Windows, nor on
;; many Unixes, and perhaps not even on all Linuxes.
(defun ray-trace (*world* &key (res 1) ppm gif (bmp (not (or ppm gif))))
(cond ((streamp ppm)
(tracer-ppm ppm :res res))
(ppm
(with-open-file (p "spheres.ppm" :direction :output :if-exists :supersede)
(tracer-ppm p :res res)))
(gif
#-unix
(error "gif generation is not available on the Windows platform.")
#+unix
;; We just trust that ppmquant and ppmtogif exist on the local host. This isn't
;; safe for closing all streams if interrupts or errors occur before the
;; with-open-stream.
(multiple-value-bind (to from err pid)
;; This Unix pipeline will convert a ppm bitmap to a 256-color gif. The ppm
;; is printed to one stream and the gif is read back from the other,
(excl:run-shell-command "ppmquant -floyd 256 | ppmtogif"
:wait nil :error-output :stream
:input :stream :output :stream :separate-streams t)
;; This process generates the image as a stream in ppm format.
(mp:process-run-function "PPM Writer"
(lambda (*world*) ; Need to bind *world* in the process.
(with-open-stream (s to)
(tracer-ppm s :res res)))
*world*)
;; These silly Unix commands like to emit commentary on stderr, and there is no
;; documented way to shut them up. Silly, for programs that are designed to be
;; used in pipelines. Create a process to consume the stderr.
(mp:process-run-function "PPM Stderr Reader"
(lambda ()
(with-open-stream (s err)
(loop while (read-char s nil nil)))))
;; The remaining code reads the gif and saves it to a file or writes it to a stream.
(with-open-stream (s from)
(if (streamp gif)
(loop as c = (read-byte s nil nil)
while c
do (write-byte c gif))
(with-open-file (gif "spheres.gif" :direction :output :format :binary
:if-exists :supersede)
(loop as c = (read-byte s nil nil)
while c
do (write-byte c gif)))))
(sys:reap-os-subprocess :pid pid :wait t)))
((streamp bmp)
(tracer bmp :res res))
(t ; bmp (dib)
(with-open-file (p "spheres.bmp" :direction :output :format :binary
:if-exists :supersede)
(tracer p :res res)))))