# HG changeset patch # User Steve Losh # Date 1470332955 0 # Node ID 5a286decc7ed1b76d2bdb7cd902f388021610b81 # Parent ab25b62d3f1dd4624fec316f8cc18608ce3e7e1a game jam diamond square diff -r ab25b62d3f1d -r 5a286decc7ed .lispwords --- 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) diff -r ab25b62d3f1d -r 5a286decc7ed src/sketch.lisp --- 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))))) ;; ) diff -r ab25b62d3f1d -r 5a286decc7ed src/utils.lisp --- 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 +; () +; )))))