2d perlin noise in clojure

core.clj

(ns perlin.core
  (:require [seesaw.core :as ss])
  (:import [java.awt.image BufferedImage]))

(defn gray-to-rgb [g]
  (int (bit-or
        (bit-shift-left g 16)
        (bit-shift-left g 8)
        (bit-shift-left g 0))))

(defn float-to-rgb [f]
  (gray-to-rgb (int (* 255 (/ (+ 1 f) 2)))))

(defn float-to-rgb-array [float-array]
  (let [z (alength ^doubles float-array)
        rgb-array (int-array z)]
    (doseq [i (range z)]
      (aset-int rgb-array i
                (float-to-rgb (aget ^doubles float-array i))))
      rgb-array))

(defn create-java-image [w h rgb-array]
  (let [type BufferedImage/TYPE_INT_RGB
        image (BufferedImage. w h type)]
    (.setRGB image 0 0 w h rgb-array 0 w)
    image))

(defn vec-len [v]
  (Math/sqrt (reduce + (map #(Math/pow % 2) v))))

(defn vec-norm [v]
  (let [l (vec-len v)]
    (map #(/ % l) v)))

(defn vec-dot [^doubles v1 ^doubles v2]
  (+ (* (aget v1 0) (aget v2 0))
     (* (aget v1 1) (aget v2 1))))

(defn p5b [^double t]
  (+ (*   6 (Math/pow t 5))
     (* -15 (Math/pow t 4))
     (*  10 (Math/pow t 3))))

(defn blend [^double v1 ^double v2 ^double k]
  (+ (* v1 (- 1 k))
     (* v2 k)))

(defn gen-grad-set [n]
  (repeatedly n #(vec-norm [(- (* (Math/random) 2) 1)
                            (- (* (Math/random) 2) 1)])))

(defn gen-grad-field [grad-set w h factor]
  (let [wi (int (inc (* w factor)))
        hi (int (inc (* h factor)))
        gf (make-array Double/TYPE hi wi 2)]
    (doseq [y (range hi)
            x (range wi)]
      (aset ^objects gf y x (double-array (rand-nth grad-set))))
    gf))

(defn get-grad [^objects grad-field x y]
  (let [^objects r (aget grad-field y)]
    (aget r x)))

(defn sample-grad-field [grad-field ^double x ^double y]
  (let [i (int x)
        j (int y)
        u (- x i)
        v (- y j)
        ii (inc i)
        jj (inc j)
        uu (- u 1)
        vv (- v 1)
        uv   (double-array [u  v])
        uuv  (double-array [uu v])
        uvv  (double-array [u  vv])
        uuvv (double-array [uu vv])
        g00 (get-grad grad-field i  j)
        g10 (get-grad grad-field ii j)
        g01 (get-grad grad-field i  jj)
        g11 (get-grad grad-field ii jj)
        n00 (vec-dot g00 uv)
        n10 (vec-dot g10 uuv)
        n01 (vec-dot g01 uvv)
        n11 (vec-dot g11 uuvv)
        uk (p5b u)
        vk (p5b v)]
    (blend (blend n00 n10 uk)
           (blend n01 n11 uk)
           vk)))

(defn perlin-2d-octaves [w h factor octaves persistence n]
  (let [grad-set (gen-grad-set n)
        buf (double-array (* w h))]
    (doseq
        ;; for each octave
        [[a p] (take octaves (iterate
                                 (fn [[a p]] [(* a 2)
                                              (* p persistence)])
                                 [factor 1]))
         :let [grad-field (gen-grad-field grad-set w h a)]
         ;; for each row
         row (range h)
         :let [stride (* row w)
               y (* row a)]
         ;; for each pixel
         col (range w)
         :let [offset (+ stride col)
               x (* col a)]]
      (let [g (sample-grad-field grad-field x y)
            acc (aget ^doubles buf offset)]
        (aset-double buf offset (+ acc (* p g)))))
    buf))

(defn init-win! []
  (def frame (ss/frame :title "perlin noise"))
  (-> frame ss/pack! ss/show!)
  (def lbl (ss/label :text ""))
  (ss/config! frame :content lbl))

(defn show-image [lbl w h float-array]
  (ss/config! lbl :icon
              (create-java-image
               w h (float-to-rgb-array float-array))))

(defn time-noise []
  (let [w 256
        h 256
        factor (/ 6 w)
        octaves 3
        persistence 0.5
        n 16]
    (init-win!)
    (show-image lbl w h
                (time (perlin-2d-octaves w h factor octaves persistence n)))))