media/js/wisp/terrain1.wisp @ 8d1cd7431860

; 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 do-times [varname limit & body]
  (let [end (gensym)]
    `(let [~end ~limit]
       (loop [~varname 0]
         (when (< ~varname ~end)
           ~@body
           (recur (+ 1 ~varname)))))))

(defmacro do-nested [xname yname width & body]
  (let [iterations (gensym)]
    `(let [~iterations ~width]
       (do-times ~xname ~iterations
         (do-times ~yname ~iterations
           ~@body)))))

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

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

(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 l [v]
  (console.log v))


(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 rand []
  (Math.random))

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


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


; Heightmap Helpers -----------------------------------------------------------
(defmacro heightmap-get [hm x y]
  `(aget ~hm (+ (* ~y (.-resolution ~hm)) ~x)))

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

(defmacro heightmap-set! [hm x y val]
  `(set! (heightmap-get ~hm ~x ~y) ~val))


(defn normalize [hm]
  (let [max (- Infinity)
        min Infinity]
    (do-times i hm.length
      (let [el (aget hm i)]
        (when (< max el) (set! max el))
        (when (> min el) (set! min el))))
    (let [span (- max min)]
      (do-times i hm.length
        (set! (aget hm i)
          (/ (- (aget hm i) min)
             span))))))

(defn zero-heightmap [heightmap]
  (do-times i heightmap.length
    (set! (aget heightmap i) 0.0))
  heightmap)

(defn make-heightmap [exponent]
  (let [resolution (+ 1 (Math.pow 2 exponent))]
    (l (+ "Creating " resolution " by " resolution " heightmap..."))
    (def heightmap
      (new Array (* resolution resolution)))
    (set! heightmap.resolution resolution)
    (set! heightmap.exponent exponent)
    (set! heightmap.last (- resolution 1))
    (zero-heightmap heightmap)))


; Random Noise ----------------------------------------------------------------
(defn random-noise [heightmap]
  (do-times i heightmap.length
    (set! (aget heightmap i) (rand))))


; Midpoint Displacement -------------------------------------------------------
(defn mpd-init-corners [heightmap]
  (heightmap-set! heightmap 0 0 (rand))
  (heightmap-set! heightmap 0 heightmap.last (rand))
  (heightmap-set! heightmap heightmap.last 0 (rand))
  (heightmap-set! heightmap heightmap.last heightmap.last (rand)))

(defn mpd-displace [heightmap lx rx by ty spread]
  (let [cx (midpoint lx rx)
        cy (midpoint by ty)

        bottom-left (heightmap-get heightmap lx by)
        bottom-right (heightmap-get heightmap rx by)
        top-left (heightmap-get heightmap lx ty)
        top-right (heightmap-get heightmap rx ty)

        top (average2 top-left top-right)
        left (average2 bottom-left top-left)
        bottom (average2 bottom-left bottom-right)
        right (average2 bottom-right top-right)
        center (average4 top left bottom right)]
    (heightmap-set! heightmap cx by (jitter bottom spread))
    (heightmap-set! heightmap cx ty (jitter top spread))
    (heightmap-set! heightmap lx cy (jitter left spread))
    (heightmap-set! heightmap rx cy (jitter right spread))
    (heightmap-set! heightmap cx cy (jitter center spread))))

(defn midpoint-displacement [heightmap]
  (mpd-init-corners heightmap)
  ; (mpd-displace heightmap 0 heightmap.last 0 heightmap.last 0.1)
  (loop [iter 0
         spread 0.3]
    (when (< iter heightmap.exponent)
      (let [chunks (Math.pow 2 iter)
            chunk-width (/ (- heightmap.resolution 1) chunks)]
        (do-nested xchunk ychunk chunks
          (let [left-x (* chunk-width xchunk)
                right-x (+ left-x chunk-width)
                bottom-y (* chunk-width ychunk)
                top-y (+ bottom-y chunk-width)]
            (mpd-displace heightmap left-x right-x bottom-y top-y spread))))
      (recur (+ 1 iter) (* spread 0.5))))
  (normalize heightmap))


(defn midpoint-displacement-final [heightmap]
  (mpd-init-corners heightmap)
  ; (let [spread ])
  (loop [iter 0
         spread (+ 0 (.val ($ "#input-starting-spread")))]
    (when (< iter heightmap.exponent)
      (let [chunks (Math.pow 2 iter)
            chunk-width (/ (- heightmap.resolution 1) chunks)]
        (do-nested xchunk ychunk chunks
          (let [left-x (* chunk-width xchunk)
                right-x (+ left-x chunk-width)
                bottom-y (* chunk-width ychunk)
                top-y (+ bottom-y chunk-width)]
            (mpd-displace heightmap left-x right-x bottom-y top-y spread))))
      (recur (+ 1 iter) (* spread
                           (+ 0 (.val ($ "#input-spread-reduction")))))))
  (normalize heightmap))


(defn mpd-displace-d2 [heightmap lx rx by ty spread]
  (let [cx (midpoint lx rx)
        cy (midpoint by ty)

        bottom-left (heightmap-get heightmap lx by)
        bottom-right (heightmap-get heightmap rx by)
        top-left (heightmap-get heightmap lx ty)
        top-right (heightmap-get heightmap rx ty)

        top (average2 top-left top-right)
        left (average2 bottom-left top-left)
        bottom (average2 bottom-left bottom-right)
        right (average2 bottom-right top-right)]
    (heightmap-set! heightmap cx by (jitter bottom spread))
    (heightmap-set! heightmap cx ty (jitter top spread))
    (heightmap-set! heightmap lx cy (jitter left spread))
    (heightmap-set! heightmap rx cy (jitter right spread))))

(defn midpoint-displacement-d1 [heightmap]
  (mpd-init-corners heightmap))

(defn midpoint-displacement-d2 [heightmap]
  (mpd-init-corners heightmap)
  (mpd-displace-d2 heightmap
                   0 heightmap.last
                   0 heightmap.last
                   0.1))

(defn midpoint-displacement-d3 [heightmap]
  (mpd-init-corners heightmap)
  (mpd-displace heightmap
                0 heightmap.last
                0 heightmap.last
                0.1))



; 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 [geometry (new THREE.PlaneGeometry
                      terrain-size
                      terrain-size
                      (- heightmap.resolution 1)
                      (- heightmap.resolution 1))]
    (set! geometry.dynamic true)
    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]
  (do-times i geometry.vertices.length
    (set! (.-z (aget geometry.vertices i))
      (* terrain-height (aget heightmap i))))
  (set! geometry.verticesNeedUpdate true)
  (geometry.computeFaceNormals)
  (geometry.computeVertexNormals)
  (geometry.computeMorphNormals)
  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 (make-geometry (make-heightmap size)))

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

  (defn refresh []
    (l "Refreshing ========================================")
    (let [heightmap (make-heightmap size)]
      (l "Generating terrain...")
      (time (algorithm heightmap))
      (l "Refreshing geometry...")
      (time (update-geometry geometry heightmap))
      (l "Done!")))

  (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)))

  (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 heightmap (make-heightmap (.val ($ "#input-exponent"))))
  (def geometry (make-geometry heightmap))
  (def plane (make-plane geometry))

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

  (defn refresh []
    (l "Refreshing ========================================")
    (scene.remove plane)
    (set! heightmap (make-heightmap (.val ($ "#input-exponent"))))
    (set! geometry (make-geometry heightmap))
    (set! plane (make-plane geometry))
    (scene.add plane)
    (l "Generating terrain...")
    (time (midpoint-displacement-final heightmap))
    (l "Refreshing geometry...")
    (time (update-geometry geometry heightmap))
    (l "Done!"))

  (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)))

  (render)

  nil)


(defn run []
  (make-demo "demo-random" random-noise 7)
  (make-demo "demo-mpd-1" midpoint-displacement-d1 2)
  (make-demo "demo-mpd-2" midpoint-displacement-d2 2)
  (make-demo "demo-mpd-3" midpoint-displacement-d3 2)
  (make-demo "demo-mpd-4" midpoint-displacement 3)
  (make-final "demo-final")
  ; (make-demo "demo-midpoint" midpoint-displacement)
  ; (make-demo "demo-diamond" diamond-square)

  )

($ run)


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