Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
131 lines (107 sloc) 3.85 KB
;;; Implementation of ray tracing algorithm from ANSI Common Lisp
(import '(javax.swing JFrame JPanel)
'(java.awt Color)
'(java.awt.image BufferedImage))
;; Bits for the modelling
;; Math Utility functions
(defn square [x] (* x x))
(defstruct point :x :y :z)
(defn magnitude [p]
(Math/sqrt (+ (square (:x p)) (square (:y p)) (square (:z p)))))
(defn unit-vector [p]
(let [d (magnitude p)]
(struct point (/ (:x p) d) (/ (:y p) d) (/ (:z p) d))))
(defn point-subtract [p1 p2]
(struct point
(- (:x p1) (:x p2))
(- (:y p1) (:y p2))
(- (:z p1) (:z p2))))
(defn distance [p1 p2]
(magnitude (point-subtract p1 p2)))
(defn minroot [a b c]
(if (zero? a)
(/ (- c) b)
(let [disc (- (square b) (* 4 a c))]
(if (> disc 0)
(let [discroot (Math/sqrt disc)]
(min (/ (+ (- b) discroot) (* 2 a))
(/ (- (- b) discroot) (* 2 a))))))))
;; Ray tracing bits
(def eye (struct point 150 150 200))
(defstruct surface :color)
(defstruct sphere :color :radius :centre) ;; Clojure doesn't appear to support include?
(defn defsphere [point r c]
(struct sphere c r point))
(def world [(defsphere (struct point 150 150 -600) 250 0.32)
(defsphere (struct point 175 175 -300) 100 0.64)])
(defn sphere-normal [s pt]
(let [c (:centre s)]
(unit-vector (point-subtract c pt))))
(defn sphere-intersect [s pt ray]
(let [c (:centre s)
n (minroot (+ (square (:x ray)) (square (:y ray)) (square (:z ray)))
(* 2 (+
(* (- (:x pt) (:x c)) (:x ray))
(* (- (:y pt) (:y c)) (:y ray))
(* (- (:z pt) (:z c)) (:z ray))))
(+ (square (- (:x pt) (:x c)))
(square (- (:y pt) (:y c)))
(square (- (:z pt) (:z c)))
(- (square (:radius s)))))]
(if n
(struct point (+ (:x pt) (* n (:x ray)))
(+ (:y pt) (* n (:y ray)))
(+ (:z pt) (* n (:z ray)))))))
(defn lambert [s intersection ray]
(let [normal (sphere-normal s intersection)]
(max 0 (+ (* (:x ray) (:x normal))
(* (:y ray) (:y normal))
(* (:z ray) (:z normal))))))
;; second item = what we hit
;; first item = where we hit
(defn first-hit [pt ray]
(fn [x y]
(let [hx (first x) hy (first y)]
(nil? hx) y
(nil? hy) x
:else (let [d1 (distance hx pt) d2 (distance hy pt)]
(if (< d1 d2) x y)))))
(map (fn [obj]
(let [h (sphere-intersect obj pt ray)]
(if (not (nil? h))
[h obj]))) world)))
(defn send-ray [src ray]
(let [hit (first-hit src ray)]
(if (not (nil? hit))
(let [int (first hit) s (second hit)]
(* (lambert s ray int) (:color s)))
(defn color-at [x y]
(let [ray (unit-vector (point-subtract (struct point x y 0) eye))]
(* (send-ray eye ray) 255)))
(defn ray-trace [world w h ox oy]
(let [buffered-image (BufferedImage. w h BufferedImage/TYPE_BYTE_GRAY)]
(doseq [x (range 0 (dec w))]
(doseq [y (range 0 (dec h))]
(.setRGB buffered-image x y (color-at (+ x ox) (+ y oy)))))
(defn create-work-list [width height unitX unitY]
(let [xs (range 0 width unitX) ys (range 0 height unitY)]
(mapcat (fn [x] (mapcat (fn [y] (list (list x y))) ys)) xs)))
(def canvas (proxy [JPanel] []
(paintComponent [g]
(proxy-super paintComponent g)
(.setColor g Color/RED)
(let [width (.getWidth this) height (.getHeight this) unitX (/ width 100) unitY (/ height 100) work-list (create-work-list width height unitX unitY)]
(doseq [image (pmap (fn [pos] (list (apply ray-trace (list world unitX unitY (first pos) (second pos))) (first pos) (second pos))) work-list)]
(.drawImage g (first image) (second image) (nth image 2) unitX unitY nil)))))))
(defn raytraceapp []
(let [frame (JFrame. "Ray Tracing")]
(doto frame
(.add canvas)
(.setSize 1000 1000)
(.setResizable false)
(.setVisible true))))