9bd6c3377af8

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/diamond-square.lisp	Sat Feb 03 14:53:48 2018 -0500
@@ -0,0 +1,109 @@
+(in-package :magitek.diamond-square)
+
+
+(defun heightmap-size (heightmap)
+  (array-dimension heightmap 0))
+
+(defun average (a b c d)
+  (/ (+ a b c d) 4))
+
+(defun ref (heightmap x y)
+  (let ((size (array-dimension heightmap 0)))
+    (aref heightmap (mod x size) (mod y size))))
+
+
+(defun allocate (size)
+  (let ((heightmap (make-array (list size size)
+                     ;; :element-type 'single-float
+                     :initial-element 0.0
+                     :adjustable nil)))
+    (setf (aref heightmap 0 0) (random 1.0))
+    heightmap))
+
+
+(defun heightmap-extrema (heightmap)
+  (iterate
+    (for v :across-flat-array heightmap)
+    (maximize v :into max)
+    (minimize v :into min)
+    (finally (return (values min max)))))
+
+(defun normalize (heightmap)
+  (multiple-value-bind (min max) (heightmap-extrema heightmap)
+    ;; (do-array (v heightmap)
+    ;;   (setf v (/ (- v min) span)))
+    (iterate
+      (with span = (- max min))
+      (for v :across-flat-array heightmap :with-index i)
+      (setf (row-major-aref heightmap i)
+            (/ (- v min) span)))))
+
+
+(defun ds-square (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (random-around (average (ref heightmap (- x radius) (- y radius))
+                                (ref heightmap (- x radius) (+ y radius))
+                                (ref heightmap (+ x radius) (- y radius))
+                                (ref heightmap (+ x radius) (+ y radius)))
+                       spread)))
+
+(defun ds-diamond (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (random-around (average (ref heightmap (- x radius) y)
+                                (ref heightmap (+ x radius) y)
+                                (ref heightmap x (- y radius))
+                                (ref heightmap x (+ y radius)))
+                       spread)))
+
+
+(defun squares (heightmap radius spread)
+  (iterate
+    (with size = (heightmap-size heightmap))
+    (for-nested ((x :from radius :below size :by (* 2 radius))
+                 (y :from radius :below size :by (* 2 radius))))
+    (ds-square heightmap x y radius spread)))
+
+(defun diamonds (heightmap radius spread)
+  (iterate
+    (with size = (heightmap-size heightmap))
+    (for i :from 0)
+    (for y :from 0 :below size :by radius)
+    (iterate
+      (with shift = (if (evenp i) radius 0))
+      (for x :from shift :below size :by (* 2 radius))
+      (ds-diamond heightmap x y radius spread))))
+
+
+(defun generate-heightmap
+    (size &key (spread 0.8) (spread-reduction 0.7))
+  (let ((heightmap (allocate size)))
+    (recursively ((radius (floor size 2))
+                  (spread spread))
+      (when (>= radius 1)
+        (squares heightmap radius spread)
+        (diamonds heightmap radius spread)
+        (recur (/ radius 2)
+               (* spread spread-reduction))))
+    (normalize heightmap)
+    heightmap))
+
+
+(defun heightmap-to-pixels (heightmap)
+  (do-array (h heightmap)
+    (setf h (floor (* 255 h)))))
+
+(defun color-pixel (pixel)
+  (cond
+    ((< pixel 100) (vector 0 0 200))
+    ((< pixel 200) (vector 0 150 0))
+    (t (vector 255 255 255))))
+
+(defun color (pixels)
+  (do-array (p pixels)
+    (setf p (color-pixel p))))
+
+(defun dump ()
+  (trivial-ppm:write-to-file
+    "heightmap.pbm"
+    (color (heightmap-to-pixels (generate-heightmap 512)))
+    :if-exists :supersede))