Simpel ray tracer in cljs/quil.

ray-trace.cljs

;; Converted from this: http://www.ulisp.com/list?2O52
(ns ray.core
  (:require [quil.core :as q :include-macros true]
            [quil.middleware :as m]))

(defn col [r g b]
  [r g b])
(defn pt [x y z]
  [x y z])
(defn v [x y z]
  [x y z])

(def *eye* (pt 0.0 0.0 200.0))
(def *light* (pt -5000 10000 -1200))

(def *world*
  [[:plane (pt 0 -200 0) (v 0 -1 0) (col 2 2 2)]
   [:sphere (pt -250 0 -1000) 200 (col 0 1 .5)]
   [:sphere (pt 50 0 -1200) 200 (col 1 .5 0)]
   [:sphere (pt 400 0 -1400) 200 (col 0 .5 1)]
   [:sphere (pt -50 -150 -600) 50 (col 0 0 1)]
   [:sphere (pt 200 -150 -800) 50 (col 1 0 0)]])

(defn add [v w]
  (map + v w))

(defn sub [v w]
  (map - v w))

(defn dot [v w]
  (apply + (map * v w)))

(defn mul [k v] (map #(* k %) v))

(defn mag [v] (q/sqrt (apply + (map q/sq v))))

(defn unit-vector [v]
  (let [d (mag v)]
    (map (fn [j] (/ j d)) v)))

(defn distance [p1 p2]
  (mag (map - p1 p2)))

;; Objects

(defn sphere-center [s] (second s))
(defn sphere-radius [s] (nth s 2))
(defn sphere-colour [s] (nth s 3))
(defn sphere-normal [s pt]
  (unit-vector (sub (sphere-center s) pt)))

(defn plane-point [s] (second s))
(defn plane-normal [s] (nth s 2))
(defn plane-colour [s] (nth s 3))

(defn add-to-world [world & args]
  (into world args))

(defn object-colour [s]
  (case (first s)
    :sphere (sphere-colour s)
    :plane (plane-colour s)))

(defn object-normal [s pt]
  (case (first s)
    :sphere (sphere-normal s pt)
    :plane (plane-normal s)))

(defn minroot [a b c]
  (if (zero? a)
    (/ (- c) b)
    (let [disc (- (q/sq b) (* 4 a c))]
      (when-not (neg? disc)
        (min (/ (+ (- b) (q/sqrt disc)) (* 2 a))
             (/ (- (- b) (q/sqrt disc)) (* 2 a)))))))

(defn sphere-hit [s pt pr]
  (let [c (sphere-center s)
        oc (map - pt c)]
    (minroot
     (apply + (map q/sq pr))
     (* 2 (dot oc pr))
     (- (dot oc oc) (q/sq (sphere-radius s))))))

(defn plane-hit [s pt pr]
  (let [denom (dot (plane-normal s) pr)]
    (when-not (zero? denom)
      (let [n (/ (dot (sub (plane-point s) pt) (plane-normal s)) denom)]
        (when (>= n 0) n)))))

(defn object-hit [s pt pr]
  (case (first s)
    :sphere (sphere-hit s pt pr)
    :plane (plane-hit s pt pr)))

(defn background [x y] (col 0.5 0.7 1))

(defn lambert [s hit pr]
  (max 0 (dot pr (object-normal s hit))))

(defn first-hit [pt pr]
  (reduce (fn [[_ _ dist :as f] s]
            (if-let [d (object-hit s pt pr)]
              (if-let [h (add pt (mul d pr))]
                (if (or (nil? dist) (< d dist))
                  [s h d]
                  f) f) f))
          [nil nil nil]
          *world*))

(defn send-ray [pt pr]
  (let [f (first-hit pt pr)
        s (first f)
        hit (second f)]
    (when s
      (let [c (mul (lambert s hit pr) (object-colour s))
            f2 (first-hit *light* (unit-vector (sub hit *light*)))
            h2 (second f2)]
        (cond
          (< (distance hit h2) 1) c
          :else (mul .75 c))))))

(defn colour-at [x y]
  (let [c (send-ray
           *eye*
           (unit-vector
            (sub (vector x y 0) *eye*)))]
    (or c (background x y))))

(defn tracer []
  (q/color-mode :rgb 1.0)
  (dotimes [x 320]
    (dotimes [y 256]
      (let [[r g b] (colour-at (- x 160) (- y 128))]
        (apply q/stroke [r g b 1])
        (q/with-rotation [3.14159]
          (q/with-translation [(/ (q/width) -1)
                               (/ (q/height) -1)]
            (q/point x y)))))))

(defn draw []
  (q/no-loop)
  ; make background white
  (q/background 255)
  (tracer))

; run sketch
(q/defsketch ray-trace
  :host "host"
  :size [320 256]
  :draw draw)