media/js/wisp/terrain3.wisp @ 15591e79caeb

(ns demo
  (:require [ndarray]))


; Constants -------------------------------------------------------------------
(def width 610)
(def height 400)
(def wireframe true)
(def wireframe-width 1.2)
(def terrain-height 50)
(def terrain-size 100)

; General Utilities -----------------------------------------------------------
(defmacro when [condition & body]
  `(if ~condition
     (do ~@body)))

(defmacro when-not [condition & body]
  `(when (not ~condition)
     ~@body))

(defmacro -> [& operations]
  (reduce
    (fn [form operation]
      (cons (first operation)
            (cons form (rest operation))))
    (first operations)
    (rest operations)))


(defn inc [x]
  (+ x 1))

(defn dec [x]
  (- x 1))


(defmacro do-times [varname limit & body]
  (let [end (gensym)]
    `(let [~end ~limit]
       (loop [~varname 0]
         (when (< ~varname ~end)
           ~@body
           (recur (inc ~varname)))))))

(defmacro do-stride [varnames start-form end-form stride-form & body]
  (let [stride (gensym "stride")
        start (gensym "start")
        end (gensym "end")
        build (fn build [vars]
                (if (empty? vars)
                  `(do ~@body)
                  (let [varname (first vars)]
                    `(loop [~varname ~start]
                       (when (< ~varname ~end)
                         ~(build (rest vars))
                         (recur (+ ~varname ~stride)))))))]
    ; Fix the numbers once outside the nested loops,
    ; and then build the guts.
    `(let [~start ~start-form
           ~end ~end-form
           ~stride ~stride-form]
       ~(build varnames))))


(defmacro do-ndarray [vars array-form & body]
  (let [array-var (gensym "array")
        build (fn build [vars n]
                (if (empty? vars)
                  `(do ~@body)
                  `(do-times ~(first vars) (aget (.-shape ~array-var) ~n)
                     ~(build (rest vars) (inc n)))))]
    `(let [~array-var ~array-form]
       ~(build vars 0))))

(defmacro do-ndarray-el [element array-form & body]
  (let [index (gensym "index")
        array (gensym "array")]
    `(let [~array ~array-form]
       (do-times ~index (.-length (.-data ~array))
         (let [~element (aget (.-data ~array) ~index)]
           ~@body)))))


(defmacro inc! [place]
  `(set! ~place (inc ~place)))

(defmacro add! [place amount]
  `(set! ~place (+ ~place ~amount)))


(defmacro l [& forms]
  `(console.log ~@forms))

(defmacro time [& body]
  (let [start (gensym)
        end (gensym)
        result (gensym)]
    `(let [~start (.getTime (new Date))
           ~result (do ~@body)
           ~end (.getTime (new Date))]
       (l (+ "Elapsed time: " (- ~end ~start) "ms."))
       ~result)))


(defn midpoint [a b]
  (/ (+ a b) 2))

(defn average2 [a b]
  (/ (+ a b) 2))

(defn average4 [a b c d]
  (/ (+ a b c d) 4))

(defn safe-average [a b c d]
  (let [total 0 count 0]
    (when a (add! total a) (inc! count))
    (when b (add! total b) (inc! count))
    (when c (add! total c) (inc! count))
    (when d (add! total d) (inc! count))
    (/ total count)))


(defn even? [n]
  (== 0 (mod n 2)))

(defn odd? [n]
  (== 1 (mod n 2)))


; Randomness ------------------------------------------------------------------
(defn rand []
  (Math.random))

(defn rand-around-zero [spread]
  (- (* spread (rand) 2) spread))

(defn jitter [value spread]
  (+ value (rand-around-zero spread)))


; Heightmap Helpers -----------------------------------------------------------
(defn heightmap-resolution [heightmap]
  (aget heightmap.shape 0))

(defn heightmap-last-index [heightmap]
  (dec (heightmap-resolution heightmap)))

(defn heightmap-center-index [heightmap]
  (midpoint 0 (heightmap-last-index heightmap)))


(defn heightmap-get [heightmap x y]
  (.get heightmap x y))

(defn heightmap-get-safe [heightmap x y]
  (let [last (heightmap-last-index heightmap)]
    (when (and (<= 0 x last)
               (<= 0 y last))
      (heightmap-get heightmap x y))))

(defn heightmap-set! [heightmap x y val]
  (.set heightmap x y val))

(defn heightmap-set-if-unset! [heightmap x y val]
  (when (== 0 (heightmap-get heightmap x y))
    (heightmap-set! heightmap x y val)))


(defn normalize [heightmap]
  (let [max (- Infinity)
        min Infinity]
    (do-ndarray-el el heightmap
      (when (< max el) (set! max el))
      (when (> min el) (set! min el)))
    (let [span (- max min)]
      (do-ndarray [x y] heightmap
        (heightmap-set! heightmap x y
                        (/ (- (heightmap-get heightmap x y) min)
                           span))))))


(defn make-heightmap [exponent]
  (let [resolution (+ (Math.pow 2 exponent) 1)]
    (let [heightmap (ndarray (new Float64Array (* resolution resolution))
                             [resolution resolution])]
      (set! heightmap.exponent exponent)
      (set! heightmap.resolution resolution)
      (set! heightmap.last (dec resolution))
      heightmap)))


(defn top-left-corner [heightmap]
  (let [center (heightmap-center-index heightmap)]
    (-> heightmap
      (.lo 0 0)
      (.hi (inc center) (inc center)))))

(defn top-right-corner [heightmap]
  (let [center (heightmap-center-index heightmap)]
    (-> heightmap
      (.lo center 0)
      (.hi (inc center) (inc center)))))

(defn bottom-left-corner [heightmap]
  (let [center (heightmap-center-index heightmap)]
    (-> heightmap
      (.lo 0 center)
      (.hi (inc center) (inc center)))))

(defn bottom-right-corner [heightmap]
  (let [center (heightmap-center-index heightmap)]
    (-> heightmap
      (.lo center center)
      (.hi (inc center) (inc center)))))


; Diamond-Square --------------------------------------------------------------
(defn ds-init-corners [heightmap]
  (let [last (heightmap-last-index heightmap)]
    (heightmap-set! heightmap 0    0    (rand))
    (heightmap-set! heightmap 0    last (rand))
    (heightmap-set! heightmap last 0    (rand))
    (heightmap-set! heightmap last last (rand))))

(defn ds-square [heightmap x y radius spread]
  (let [new-height (jitter
                     (average4
                       (heightmap-get heightmap (- x radius) (- y radius))
                       (heightmap-get heightmap (- x radius) (+ y radius))
                       (heightmap-get heightmap (+ x radius) (- y radius))
                       (heightmap-get heightmap (+ x radius) (+ y radius)))
                     spread)]
    (heightmap-set! heightmap x y new-height)))

(defn ds-diamond [heightmap x y radius spread]
  (let [new-height (jitter
                     (safe-average
                       (heightmap-get-safe heightmap (- x radius) y)
                       (heightmap-get-safe heightmap (+ x radius) y)
                       (heightmap-get-safe heightmap x (- y radius))
                       (heightmap-get-safe heightmap x (+ y radius)))
                     spread)]
    (heightmap-set! heightmap x y new-height)))


(defn ds-squares [heightmap radius spread]
  (do-stride [x y] radius (heightmap-resolution heightmap) (* 2 radius)
    (ds-square heightmap x y radius spread)))

(defn ds-diamonds [heightmap radius spread]
  (let [size (heightmap-resolution heightmap)]
    (do-stride [y] 0 size radius
      (let [shift (if (even? (/ y radius)) radius 0)]
        (do-stride [x] shift size (* 2 radius)
          (ds-diamond heightmap x y radius spread))))))

(defn diamond-square [heightmap]
  (let [initial-spread 0.3
        spread-reduction 0.5
        center (heightmap-center-index heightmap)
        size (aget heightmap.shape 0)]
    (ds-init-corners heightmap)
    (loop [radius center
           spread initial-spread]
      (when (>= radius 1)
        (ds-squares heightmap radius spread)
        (ds-diamonds heightmap radius spread)
        (recur (/ radius 2)
               (* spread spread-reduction))))
    (normalize heightmap)))


(defn diamond-square-1 [heightmap]
  (ds-init-corners heightmap)
  (normalize heightmap))

(defn diamond-square-2 [heightmap]
  (let [initial-spread 0.3
        spread-reduction 0.5
        center (heightmap-center-index heightmap)
        size (aget heightmap.shape 0)]
    (ds-init-corners heightmap)
    (ds-squares heightmap center initial-spread)
    (normalize heightmap)))

(defn diamond-square-3 [heightmap]
  (let [initial-spread 0.3
        spread-reduction 0.5
        center (heightmap-center-index heightmap)
        size (aget heightmap.shape 0)]
    (ds-init-corners heightmap)
    (ds-squares heightmap center initial-spread)
    (ds-diamonds heightmap center initial-spread)
    (ds-squares heightmap (/ center 2) (* spread-reduction initial-spread))
    (ds-diamonds heightmap (/ center 2) (* spread-reduction initial-spread))
    (normalize heightmap)))


; Three.js Helpers ------------------------------------------------------------
(defn make-directional-light []
  (let [light (new THREE.DirectionalLight 0xffffff 1)]
    (light.position.set 100 0 150)
    light))

(defn make-camera []
  (let [camera (new THREE.PerspectiveCamera
                    55,
                    (/ width height)
                    0.1,
                    1000)]
    (camera.position.set 0 -100 150)
    camera))

(defn make-renderer []
  (let [renderer (new THREE.WebGLRenderer {:antialias false})]
    (renderer.setClearColor 0xffffff)
    (renderer.setSize width height)
    (renderer.setPixelRatio 2)
    renderer))

(defn make-geometry [heightmap]
  (let [resolution (aget heightmap.shape 0)
        geometry (new THREE.PlaneGeometry
                      terrain-size
                      terrain-size
                      (- resolution 1)
                      (- resolution 1))]
    geometry))

(defn make-controls [camera renderer]
  (let [controls (new THREE.TrackballControls camera renderer.domElement)]
    (set! controls.rotateSpeed 1.4)
    (set! controls.zoomSpeed 0.5)
    (set! controls.staticMoving true)
    (set! controls.dynamicDampingFactor 0.3)
    controls))

(defn make-plane [geometry]
  (let [material (new THREE.MeshLambertMaterial
                      {:wireframe wireframe
                       :wireframeLinewidth wireframe-width
                       :color 0x00bb00})]
    (new THREE.Mesh geometry material)))


(defn attach-to-dom [renderer el-name refresh-fn]
  (let [container (document.getElementById el-name)
        settings (document.createElement "div")
        refresh-button (document.createElement "button")
        button-text (document.createTextNode "Refresh")
        cancel-scroll (fn [e] (.preventDefault e))]
    (set! refresh-button.onclick refresh-fn)
    (set! renderer.domElement.onmousewheel cancel-scroll)
    (renderer.domElement.addEventListener "MozMousePixelScroll" cancel-scroll false)
    (.appendChild refresh-button button-text)
    (.appendChild container renderer.domElement)
    (.appendChild container settings)
    (.appendChild settings refresh-button)))


(defn update-geometry [geometry heightmap]
  (loop [i 0]
    (if (< i geometry.vertices.length)
      (do (set! (.-z (aget geometry.vertices i))
                (* terrain-height (aget (.-data heightmap) i)))
        (recur (+ i 1)))))
  (geometry.computeVertexNormals)
  geometry)


; Main ------------------------------------------------------------------------
(defn make-demo [element-id algorithm size]
  (def scene (new THREE.Scene))
  (scene.add (new THREE.AxisHelper 100))

  (def clock (new THREE.Clock))
  (def camera (make-camera))
  (def renderer (make-renderer))

  (def geometry)
  (def plane)

  (scene.add (make-directional-light))
  (scene.add (new THREE.AmbientLight 0xffffff 0.05))

  (defn refresh []
    (let [heightmap (make-heightmap size)]
      (l "Generating terrain...")
      (time (algorithm heightmap))

      (l "Rebuilding geometry...")
      (time
        (set! geometry (make-geometry heightmap))
        (update-geometry geometry heightmap))

      (l "Rebuilding plane...")
      (time
        (scene.remove plane)
        (set! plane (make-plane geometry))
        (scene.add plane))))

  (attach-to-dom renderer element-id refresh)
  (def controls (make-controls camera renderer))

  (defn render []
    (let [delta (clock.getDelta)]
      (requestAnimationFrame render)
      (.update controls delta)
      (renderer.render scene camera)))

  (refresh)
  (render)

  nil)

(defn make-final [element-id]
  (def scene (new THREE.Scene))
  (scene.add (new THREE.AxisHelper 100))

  (def clock (new THREE.Clock))
  (def camera (make-camera))
  (def renderer (make-renderer))

  (def geometry)
  (def plane)

  (scene.add (make-directional-light))
  (scene.add (new THREE.AmbientLight 0xffffff 0.05))

  (defn refresh []
    (let [heightmap (make-heightmap 6)]
      (l "Generating terrain...")
      (time (diamond-square heightmap))

      (l "Rebuilding geometry...")
      (time
        (set! geometry (make-geometry heightmap))
        (update-geometry geometry heightmap))

      (l "Rebuilding plane...")
      (time
        (scene.remove plane)
        (set! plane (make-plane geometry))
        (scene.add plane))))

  (attach-to-dom renderer element-id refresh)
  (def controls (make-controls camera renderer))

  (defn render []
    (let [delta (clock.getDelta)]
      (requestAnimationFrame render)
      (.update controls delta)
      (renderer.render scene camera)))

  (refresh)
  (render)

  nil)

(defn run []
  (make-demo "demo-1" diamond-square-1 2)
  (make-demo "demo-2" diamond-square-2 4)
  (make-demo "demo-3" diamond-square-3 4)
  (make-final "demo-final"))

($ run)


; vim: lw+=do-times lw+=do-nested :