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