0e1d7a2087cc

--- a/src/sketch.lisp	Thu Aug 11 00:36:30 2016 +0000
+++ b/src/sketch.lisp	Wed Aug 17 01:52:14 2016 +0000
@@ -42,7 +42,6 @@
 
 
 ;;;; Box
-
 (defparameter *world-exponent* 4)
 (defparameter *world-size* (expt 2 *world-exponent*))
 
@@ -69,7 +68,7 @@
 
 
 (defun draw-hm (hm ox oy ts)
-  (let ((size (- (hm-size hm) 0)))
+  (let ((size (first (array-dimensions hm))))
     (in-context
       (translate (* ox (* ts size))
                  (* oy (* ts size)))
@@ -104,8 +103,8 @@
      ;; Data
      (size (1+ (expt 2 4)))
      (hm (sand.terrain.diamond-square::diamond-square
-           (allocate-heightmap size)))
-     (tile-size 5)
+           5 :tileable t :spread 0.7 :spread-reduction 0.5))
+     (tile-size 3)
      ;; 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))
@@ -116,12 +115,11 @@
   ;;
   (just-once done
     (with-setup
-      (in-context
+      (iterate
+        (for x :from 0 :to (floor *width* (* size tile-size)))
         (iterate
-          (for x :from 0 :to (floor *width* (* size tile-size)))
-          (iterate
-            (for y :from 0 :to (floor *height* (* size tile-size)))
-            (draw-hm hm x y tile-size))))))
+          (for y :from 0 :to (floor *height* (* size tile-size)))
+          (draw-hm hm x y tile-size)))))
   ;;
 
   )

--- a/src/terrain/diamond-square.lisp	Thu Aug 11 00:36:30 2016 +0000
+++ b/src/terrain/diamond-square.lisp	Wed Aug 17 01:52:14 2016 +0000
@@ -3,14 +3,21 @@
 
 
 (defvar *size* nil)
+(defvar *tileable* nil)
 
 (defun heightmap-size (heightmap)
   (first (array-dimensions heightmap)))
 
 (defun hm-ref (heightmap x y)
   (flet ((ref (n)
-           (cond ((< -1 n *size*) n)
-                 (t (mod n *size*)))))
+           (cond ((< n 0)
+                  (- (mod n *size*)
+                     (if *tileable* 0 1)))
+                 ((< n *size*)
+                  n)
+                 ((>= n *size*)
+                  (+ (mod n *size*)
+                     (if *tileable* 0 1))))))
     (aref heightmap (ref x) (ref y))))
 
 
@@ -70,18 +77,23 @@
       (ds-diamond heightmap x y radius spread))))
 
 
-(defun diamond-square (heightmap)
-  (ds-init heightmap)
-  (let ((*size* (heightmap-size heightmap))
-        (spread 0.8)
-        (spread-reduction 0.7))
-    (recursively ((radius (floor size 2))
+(defun diamond-square (exponent &key (spread 0.7) (spread-reduction 0.7) (tileable nil))
+  (let* ((*size* (if tileable
+                   (expt 2 exponent)
+                   (1+ (expt 2 exponent))))
+         (*tileable* tileable)
+         (heightmap (make-array (list *size* *size*)
+                      :element-type 'single-float
+                      :initial-element 0.0
+                      :adjustable nil)))
+    (ds-init heightmap)
+    (recursively ((radius (floor *size* 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)
+               (* spread spread-reduction))))
+    (normalize-heightmap heightmap)
+    heightmap))