5a286decc7ed

game jam diamond square
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Thu, 04 Aug 2016 17:49:15 +0000
parents ab25b62d3f1d
children fba3d66a6a95
branches/tags (none)
files .lispwords src/sketch.lisp src/utils.lisp

Changes

--- a/.lispwords	Thu Aug 04 13:12:00 2016 +0000
+++ b/.lispwords	Thu Aug 04 17:49:15 2016 +0000
@@ -1,1 +1,2 @@
 (1 spit)
+(1 recursively)
--- a/src/sketch.lisp	Thu Aug 04 13:12:00 2016 +0000
+++ b/src/sketch.lisp	Thu Aug 04 17:49:15 2016 +0000
@@ -41,6 +41,133 @@
            pairs)))))
 
 
+;;;; Box
+(defun clamp (from to n)
+  (let ((max (max from to))
+        (min (min from to)))
+    (cond
+      ((> n max) max)
+      ((< n min) min)
+      (t n))))
+
+(defparameter *world-exponent* 4)
+(defparameter *world-size* (expt 2 *world-exponent*))
+
+(defun jitter (value spread)
+  (+ value (- (random (* 2.0 spread))
+              spread)))
+
+(defun average (&rest values)
+  (/ (apply #'+ values) (length values)))
+
+
+(defun allocate-heightmap ()
+  (make-array (list *world-size* *world-size*)
+    :element-type 'single-float
+    :initial-element 0.0
+    :adjustable nil))
+
+(defun hm-size (heightmap)
+  (first (array-dimensions heightmap)))
+
+(defun hmref (heightmap x y)
+  (let ((last (hm-size heightmap)))
+    (aref heightmap
+          (cond
+            ((< -1 x last) x)
+            ((= x last) 0)
+            (t (mod x last)))
+          (cond
+            ((< -1 y last) y)
+            ((= y last) 0)
+            (t (mod y last))))))
+
+(defun ds-init (heightmap)
+  (setf (aref heightmap 0 0) 0.5))
+
+
+(defun ds-square (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (jitter (average (hmref heightmap (- x radius) (- y radius))
+                         (hmref heightmap (- x radius) (+ y radius))
+                         (hmref heightmap (+ x radius) (- y radius))
+                         (hmref heightmap (+ x radius) (+ y radius)))
+                spread)))
+
+(defun ds-diamond (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (jitter (average (hmref heightmap (- x radius) y)
+                         (hmref heightmap (+ x radius) y)
+                         (hmref heightmap x (- y radius))
+                         (hmref heightmap x (+ y radius)))
+                spread)))
+
+
+(defun ds-squares (heightmap radius spread)
+  (iterate
+    (for x :from radius :below (hm-size heightmap) :by (* 2 radius))
+    (iterate
+      (for y :from radius :below (hm-size heightmap) :by (* 2 radius))
+      (ds-square heightmap x y radius spread))))
+
+(defun ds-diamonds (heightmap radius spread)
+  (iterate
+    (for i :from 0)
+    (for y :from 0 :below (hm-size heightmap) :by radius)
+    (for shift = (if (evenp i) radius 0))
+    (iterate
+      (for x :from shift :below (hm-size heightmap) :by (* 2 radius))
+      (ds-diamond heightmap x y radius spread))))
+
+
+(defun diamond-square (heightmap)
+  (ds-init heightmap)
+  (let ((spread 0.7)
+        (spread-reduction 0.5))
+    (recursively ((radius (floor (hm-size heightmap) 2))
+                  (spread spread))
+      (when (>= radius 1)
+        (ds-squares heightmap radius spread)
+        (ds-diamonds heightmap radius spread)
+        (recur (/ radius 2)
+               (* spread spread-reduction)))))
+  (normalize-heightmap heightmap)
+  heightmap)
+
+
+(defun normalize-heightmap (heightmap)
+  (iterate
+    (for i :from 0 :below (array-total-size heightmap))
+    (for v = (row-major-aref heightmap i))
+    (maximize v :into max)
+    (minimize v :into min)
+    (finally
+      (iterate
+        (with span = (- max min))
+        (for i :from 0 :below (array-total-size heightmap))
+        (for v = (row-major-aref heightmap i))
+        (setf (row-major-aref heightmap i)
+              (/ (- v min) span))))))
+
+
+
+(defun draw-hm (hm ox oy ts)
+  (let ((size (- (hm-size hm) 0)))
+    (in-context
+      (translate (* ox (* ts size))
+                 (* oy (* ts size)))
+      (iterate
+        (for x :from 0 :below size)
+        (iterate
+          (for y :from 0 :below size)
+          (for h = (aref hm x y))
+          (with-pen (make-pen :fill (if (<= 0.0 h 1.0)
+                                      (gray h)
+                                      (rgb 1.0 0 0)))
+            (rect (* x ts) (* y ts)
+                  ts ts)))))))
+
+
 ;;;; Sketch
 (defsketch demo
     ((width *width*) (height *height*) (y-axis :up) (title "Sketch")
@@ -48,6 +175,8 @@
      (mouse (list 0 0))
      (frame 0)
      ;; Data
+     (hm (diamond-square (allocate-heightmap)))
+     (ts 8)
      ;; Pens
      (black-pen (make-pen :stroke (rgb 0 0 0) :fill (rgb 0.4 0.4 0.4) :weight 1 :curve-steps 50))
      (red-pen (make-pen :stroke (rgb 0.6 0 0) :fill (rgb 0.9 0 0) :weight 1 :curve-steps 50))
@@ -57,7 +186,14 @@
   (incf frame)
   ;;
   (with-setup
-    )
+    (in-context
+      (translate *center-x* *center-y*)
+      (translate (- (/ (* ts *world-size*) 2))
+                 (- (/ (* ts *world-size*) 2)))
+      (iterate
+        (for ox :from -1 :to 1)
+        (iterate (for oy :from -1 :to 1)
+                 (draw-hm hm ox oy ts)))))
   ;;
 
   )
--- a/src/utils.lisp	Thu Aug 04 13:12:00 2016 +0000
+++ b/src/utils.lisp	Thu Aug 04 17:49:15 2016 +0000
@@ -205,3 +205,33 @@
                           (if (< ,i ,len)
                             (elt ,source ,i)
                             (terminate))))))))
+
+; (defun array-subscripts (a row-major-index)
+;   "Convert the row-major index `i` to a list of subscripts for accessing in `a`.
+  
+;   This is basically the inverse of 'array-row-major-index`."
+;   (loop :with dims = (array-dimensions a)
+;         :with i = row-major-index
+;         :for ds :on dims
+;         :for size = (apply #'* (cdr ds))
+;         :collect (multiple-value-bind (idx rem)
+;                      (floor i size)
+;                    (setf i rem)
+;                    idx)))
+
+; (defmacro-driver (FOR var ACROSS-ARRAY array WITH-INDICES index-vars)
+;   "Iterate across a multidimensional array."
+;   (labels ((array-row-major-to-indexes (dimensions ))))
+;   (let ((kwd (if generate 'generate 'for)))
+;     (with-gensyms (arr size i)
+;       `(progn
+;         (with ,arr = ,array)
+;         (with ,size = (array-total-size ,arr))
+
+;         (generate ,i :from 0 :below ,size)
+;         (generate ,index-vars = (array-subscripts ,arr ,i))
+;         ,@(mapcar (lambda (v) `(generate )))
+
+;         (,kwd ,var next
+;               ()
+;               )))))