simplex-noise.lisp

;;;
;;;  Perlin noise simplex algorithm.
;;;  Ported from the Javascript implementation at: https://gist.github.com/304522
;;;

(in-package :battle-map)

(declaim #.*compile-decl*)

(defun make-simplex-noise-generator ()
  (flet ((dot-prod (g x y)
           (declare (optimize (speed 3) (safety 1))
                    (type (simple-vector 3) g)
                    (type double-float x y))
           (+ (* (the (double-float -1d0 1d0) (aref g 0)) x)
              (* (the (double-float -1d0 1d0) (aref g 1)) y))))

    (let ((grad3 #(#(1d0 1d0 0d0) #(-1d0 1d0 0d0) #(1d0 -1d0 0d0) #(-1d0 -1d0 0d0)
                   #(1d0 0d0 1d0) #(-1d0 0d0 1d0) #(1d0 0d0 -1d0) #(-1d0 0d0 -1d0)
                   #(0d0 1d0 1d0) #(0d0 -1d0 1d0) #(0d0 1d0 -1d0) #(0d0 -1d0 -1d0)))
          (p (make-array 256 :element-type '(integer 0 255))))
      (map-into p #'(lambda () (random 256)))

      #'(lambda (xin yin)
          (declare (optimize (speed 3) (safety 1)))
          (check-type xin double-float)
          (check-type yin double-float)
          (let* ((f2 (* 0.5d0 (1- (sqrt 3d0))))
                 (s (* (+ xin yin) f2))
                 (i (truncate (the (double-float -1000d0 1000d0) (+ xin s))))
                 (j (truncate (the (double-float -1000d0 1000d0) (+ yin s))))
                 (g2 (/ (- 3 (sqrt 3d0)) 6))
                 (tz (* (+ i j) g2))
                 (x0u (- i tz))
                 (y0u (- j tz))
                 (x0 (- xin x0u))
                 (y0 (- yin y0u))
                 ;; Determine simplex
                 (i1 (if (> x0 y0) 1 0))
                 (j1 (if (> x0 y0) 0 1))
                 (x1 (+ (- x0 i1) g2))
                 (y1 (+ (- y0 j1) g2))
                 (x2 (+ (1- x0) (* g2 2)))
                 (y2 (+ (1- y0) (* g2 2)))
                 ;; Hashed gradient
                 (ii (logand i 255))
                 (jj (logand j 255))
                 (gi0 (mod (aref p (mod (+ ii (aref p jj)) 256)) 12))
                 (gi1 (mod (aref p (mod (+ ii i1 (aref p (mod (+ jj j1) 256))) 256)) 12))
                 (gi2 (mod (aref p (mod (+ ii 1 (aref p (mod (+ jj 1) 256))) 256)) 12))
                 ;; Corner contribution
                 (t0 (- 0.5d0 (* x0 x0) (* y0 y0)))
                 (n0 (if (minusp t0)
                         0d0
                         (let ((t0n (* t0 t0)))
                           (* t0n t0n (dot-prod (aref grad3 gi0) x0 y0)))))
                 (t1 (- 0.5d0 (* x1 x1) (* y1 y1)))
                 (n1 (if (minusp t1)
                         0d0
                         (let ((t1n (* t1 t1)))
                           (* t1n t1n (dot-prod (aref grad3 gi1) x1 y1)))))
                 (t2 (- 0.5d0 (* x2 x2) (* y2 y2)))
                 (n2 (if (minusp t2)
                         0d0
                         (let ((t2n (* t2 t2)))
                           (* t2n t2n (dot-prod (aref grad3 gi2) x2 y2))))))
            (* 70 (+ n0 n1 n2)))))))

(defun make-simplex-heightmap (width height frequency)
  (let ((g (make-simplex-noise-generator))
        (a (make-array (list height width) :element-type 'number))
        (rx (coerce (/ frequency width) 'double-float))
        (ry (coerce (/ frequency height) 'double-float)))
    (loop
       for y from 0 below height
       do (loop
             for x from 0 below width
             do (setf (aref a y x) (funcall g (* x rx) (* y ry)))))
    a))

(defun normalise-heightmap (m &key (low 0) (high 255))
  (let* ((f (make-array (list (* (array-dimension m 0) (array-dimension m 1))) :displaced-to m))
         (min (reduce #'min f))
         (max (reduce #'max f))
         (a (make-array (array-dimensions m))))
    (map-into (make-array (list (array-dimension f 0)) :displaced-to a)
              #'(lambda (v) (+ (* (/ (- v min) (- max min)) (- high low)) low))
              f)
    a))

(defun write-simplex-to-file (freq)
  (let* ((m (normalise-heightmap (make-simplex-heightmap 1000 1000 freq)))
         (i (image:make-image (array-dimension m 1) (array-dimension m 0))))
    (loop for y from 0 below (array-dimension m 1)
       do (loop for x from 0 below (array-dimension m 0)
             do (image:plot i x y (truncate (aref m y x)) 0 0)))
    (image:export-to-gif i "~/foo.gif")))