# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1470875790 0
# Node ID fba3d66a6a95f885a53a8288f0361b50fa651742
# Parent  5a286decc7ed1b76d2bdb7cd902f388021610b81
DS

diff -r 5a286decc7ed -r fba3d66a6a95 .lispwords
--- a/.lispwords	Thu Aug 04 17:49:15 2016 +0000
+++ b/.lispwords	Thu Aug 11 00:36:30 2016 +0000
@@ -1,2 +1,3 @@
 (1 spit)
 (1 recursively)
+(1 just-once)
diff -r 5a286decc7ed -r fba3d66a6a95 package.lisp
--- a/package.lisp	Thu Aug 04 17:49:15 2016 +0000
+++ b/package.lisp	Thu Aug 11 00:36:30 2016 +0000
@@ -4,54 +4,19 @@
 (defpackage #:sand.utils
   (:use
     #:cl
+    #:losh
     #:iterate
     #:cl-arrows
     #:sand.quickutils)
   (:export
-    #:zap%
-    #:%
-    #:recursively
-    #:recur
-    #:dis
-    #:bits
-    #:spit
-
-    #:dlambda
-
-    #:hash-set
-    #:make-set
-    #:set-contains-p
-    #:set-add
-    #:set-remove
-    #:set-add-all
-    #:set-remove-all
-    #:set-random
-    #:set-pop
-    #:set-empty-p
-    #:set-clear
-
-    #:averaging
-    #:timing
-    #:real-time
-    #:run-time
-    #:since-start-into
-    #:per-iteration-into
-    #:in-whatever
-
-    #:queue
-    #:queue-contents
-    #:enqueue
-    #:dequeue
-    #:queue-empty-p
-    #:queue-append
-
-    )
+    #:average4)
   (:shadowing-import-from #:cl-arrows
     #:->))
 
 (defpackage #:sand.random-numbers
   (:use
     #:cl
+    #:losh
     #:iterate
     #:cl-arrows
     #:sand.quickutils
@@ -62,28 +27,40 @@
 (defpackage #:sand.parenscript
   (:use
     #:cl
+    #:losh
     #:sand.quickutils
     #:cl-arrows
     #:cl-fad
-
     #:parenscript)
   (:shadowing-import-from #:cl-arrows
     #:->)
-  (:import-from #:sand.utils)
-  )
+  (:shadowing-import-from #:losh
+    #:%))
 
 
 (defpackage #:sand.ascii
-  (:use #:cl
-        #:iterate
-        #:cl-arrows
-        #:sand.quickutils
-        #:sand.utils))
+  (:use
+    #:cl
+    #:losh
+    #:iterate
+    #:cl-arrows
+    #:sand.quickutils
+    #:sand.utils))
+
 
+(defpackage #:sand.terrain.diamond-square
+  (:use
+    #:cl
+    #:losh
+    #:iterate
+    #:cl-arrows
+    #:sand.quickutils
+    #:sand.utils))
 
 (defpackage #:sand.sketch
   (:use
     #:cl
+    #:losh
     #:sketch
     #:iterate
     #:sand.quickutils
diff -r 5a286decc7ed -r fba3d66a6a95 sand.asd
--- a/sand.asd	Thu Aug 04 17:49:15 2016 +0000
+++ b/sand.asd	Thu Aug 11 00:36:30 2016 +0000
@@ -12,7 +12,8 @@
                #:cl-arrows
                #:cl-fad
                #:parenscript
-               #:sketch)
+               #:sketch
+               #:losh)
 
   :serial t
   :components
@@ -23,7 +24,10 @@
     :components ((:file "utils")
                  (:file "random-numbers")
                  (:file "ascii")
-                 (:file "sketch")
+                 (:module "terrain"
+                  :serial t
+                  :components ((:file "diamond-square")))
                  (:module "parenscript"
                   :serial t
-                  :components ((:file "compiler")))))))
+                  :components ((:file "compiler")))
+                 (:file "sketch")))))
diff -r 5a286decc7ed -r fba3d66a6a95 src/sketch.lisp
--- a/src/sketch.lisp	Thu Aug 04 17:49:15 2016 +0000
+++ b/src/sketch.lisp	Thu Aug 11 00:36:30 2016 +0000
@@ -42,99 +42,16 @@
 
 
 ;;;; 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*)
+(defun allocate-heightmap (size)
+  (make-array (list size 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))
@@ -147,8 +64,8 @@
         (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))))))
-
+              (/ (- v min) span)))
+      (return heightmap))))
 
 
 (defun draw-hm (hm ox oy ts)
@@ -165,18 +82,30 @@
                                       (gray h)
                                       (rgb 1.0 0 0)))
             (rect (* x ts) (* y ts)
-                  ts ts)))))))
+                  ts ts))))
+      (with-pen (make-pen :fill nil :stroke (rgb 1.0 0 0))
+        ; (rect 0 0 (* ts size) (* ts size))
+        ))))
+
+
+(defmacro just-once (done &body body)
+  `(when (not ,done)
+     (setf ,done t)
+     ,@body))
 
 
 ;;;; Sketch
 (defsketch demo
     ((width *width*) (height *height*) (y-axis :up) (title "Sketch")
-     (copy-pixels nil)
+     (copy-pixels t)
      (mouse (list 0 0))
      (frame 0)
+     (done nil)
      ;; Data
-     (hm (diamond-square (allocate-heightmap)))
-     (ts 8)
+     (size (1+ (expt 2 4)))
+     (hm (sand.terrain.diamond-square::diamond-square
+           (allocate-heightmap size)))
+     (tile-size 5)
      ;; 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))
@@ -185,15 +114,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)))))
+  (just-once done
+    (with-setup
+      (in-context
+        (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))))))
   ;;
 
   )
diff -r 5a286decc7ed -r fba3d66a6a95 src/terrain/diamond-square.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/terrain/diamond-square.lisp	Thu Aug 11 00:36:30 2016 +0000
@@ -0,0 +1,87 @@
+(in-package #:sand.terrain.diamond-square)
+
+
+
+(defvar *size* 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*)))))
+    (aref heightmap (ref x) (ref y))))
+
+
+(defun heightmap-extrema (heightmap)
+  (iterate
+    (for v :across-flat-array heightmap :with-index i)
+    (maximize v :into max)
+    (minimize v :into min)
+    (finally (return (values min max)))))
+
+(defun normalize-heightmap (heightmap)
+  (multiple-value-bind (min max) (heightmap-extrema heightmap)
+    (do-array (v heightmap)
+      (setf v (norm min max v)))))
+
+
+(defun ds-init (heightmap)
+  (let ((last (1- *size*)))
+    (setf
+      (aref heightmap 0 0) 0.5
+      (aref heightmap 0 last) 0.5
+      (aref heightmap last 0) 0.5
+      (aref heightmap last last) 0.5)))
+
+
+(defun ds-square (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (random-around (average4 (hm-ref heightmap (- x radius) (- y radius))
+                                 (hm-ref heightmap (- x radius) (+ y radius))
+                                 (hm-ref heightmap (+ x radius) (- y radius))
+                                 (hm-ref heightmap (+ x radius) (+ y radius)))
+                       spread)))
+
+(defun ds-diamond (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (random-around (average4 (hm-ref heightmap (- x radius) y)
+                                 (hm-ref heightmap (+ x radius) y)
+                                 (hm-ref heightmap x (- y radius))
+                                 (hm-ref heightmap x (+ y radius)))
+                       spread)))
+
+
+(defun ds-squares (heightmap radius spread)
+  (iterate
+    (for x :from radius :below *size* :by (* 2 radius))
+    (iterate
+      (for y :from radius :below *size* :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 *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 diamond-square (heightmap)
+  (ds-init heightmap)
+  (let ((*size* (heightmap-size heightmap))
+        (spread 0.8)
+        (spread-reduction 0.7))
+    (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)
+
diff -r 5a286decc7ed -r fba3d66a6a95 src/utils.lisp
--- a/src/utils.lisp	Thu Aug 04 17:49:15 2016 +0000
+++ b/src/utils.lisp	Thu Aug 11 00:36:30 2016 +0000
@@ -1,237 +1,6 @@
 (in-package #:sand.utils)
 
-;;;; Miscellaneous
-(defmacro zap% (place function &rest arguments &environment env)
-  "Update `place` by applying `function` to its current value and `arguments`.
-
-  `arguments` should contain the symbol `%`, which is treated as a placeholder
-  where the current value of the place will be substituted into the function
-  call.
-
-  For example:
-
-  (zap% foo #'- % 10) => (setf foo (- foo 10)
-  (zap% foo #'- 10 %) => (setf foo (- 10 foo)
-
-  "
-  ;; original idea/name from http://malisper.me/2015/09/29/zap/
-  (assert (find '% arguments) ()
-    "Placeholder % not included in zap macro form.")
-  (multiple-value-bind (temps exprs stores store-expr access-expr)
-      (get-setf-expansion place env)
-    `(let* (,@(mapcar #'list temps exprs)
-            (,(car stores)
-             (funcall ,function
-                      ,@(substitute access-expr '% arguments))))
-      ,store-expr)))
-
-(defmacro recursively (bindings &body body)
-  "Execute body recursively, like Clojure's `loop`/`recur`.
-
-  `bindings` should contain a list of symbols and (optional) default values.
-
-  In `body`, `recur` will be bound to the function for recurring.
-
-  Example:
-
-      (defun length (some-list)
-        (recursively ((list some-list) (n 0))
-          (if (null list)
-            n
-            (recur (cdr list) (1+ n)))))
-
-  "
-  (flet ((extract-var (binding)
-           (if (atom binding) binding (first binding)))
-         (extract-val (binding)
-           (if (atom binding) nil (second binding))))
-    `(labels ((recur ,(mapcar #'extract-var bindings)
-                ,@body))
-      (recur ,@(mapcar #'extract-val bindings)))))
-
-(defmacro dis (arglist &body body)
-  "Disassemble the code generated for a `lambda*` with `arglist` and `body`.
-
-  It will also spew compiler notes so you can see why the garbage box isn't
-  doing what you think it should be doing.
-
-  "
-  `(->> '(lambda ,arglist
-          (declare (optimize speed))
-          ,@body)
-    (compile nil)
-    #+sbcl sb-disassem:disassemble-code-component
-    #-sbcl disassemble))
-
-(defun bits (n size)
-  ;; http://blog.chaitanyagupta.com/2013/10/print-bit-representation-of-signed.html
-  (format t (format nil "~~~D,'0B" size) (ldb (byte size 0) n))
-  (values))
-
-(defmacro spit (filename &body body)
-  `(with-open-file (*standard-output* ,filename
-                                      :direction :output
-                                      :if-exists :supersede)
-     ,@body))
-
-
-;;;; dlambda
-(defmacro dlambda (&rest clauses)
-  (with-gensyms (message arguments)
-    (flet ((parse-clause (clause)
-             (destructuring-bind (key arglist &rest body)
-                 clause
-               `(,key (apply (lambda ,arglist ,@body) ,arguments)))))
-      `(lambda (,message &rest ,arguments)
-        (ecase ,message
-          ,@(mapcar #'parse-clause clauses))))))
-
-
-;;;; Sets
-;;; Janky implementation of basic sets.
-(defclass hash-set ()
-  ((data :initarg :data)))
-
-
-(defun make-set (&key (test #'eql) (initial-data nil))
-  (let ((set (make-instance 'hash-set
-                            :data (make-hash-table :test test))))
-    (mapcar (curry #'set-add set) initial-data)
-    set))
-
 
-(defun set-contains-p (set value)
-  (nth-value 1 (gethash value (slot-value set 'data))))
-
-(defun set-empty-p (set)
-  (zerop (hash-table-count (slot-value set 'data))))
-
-(defun set-add (set value)
-  (setf (gethash value (slot-value set 'data)) t)
-  value)
-
-(defun set-add-all (set seq)
-  (map nil (curry #'set-add set) seq))
-
-(defun set-remove (set value)
-  (remhash value (slot-value set 'data))
-  value)
-
-(defun set-remove-all (set seq)
-  (map nil (curry #'set-remove set) seq))
-
-(defun set-clear (set)
-  (clrhash (slot-value set 'data))
-  set)
-
-(defun set-random (set)
-  (if (set-empty-p set)
-    (values nil nil)
-    (loop :with data = (slot-value set 'data)
-          :with target = (random (hash-table-count data))
-          :for i :from 0
-          :for k :being :the :hash-keys :of data
-          :when (= i target)
-          :do (return (values k t)))))
-
-(defun set-pop (set)
-  (multiple-value-bind (val found) (set-random set)
-    (if found
-      (progn
-        (set-remove set val)
-        (values val t))
-      (values nil nil))))
-
-
-(defmethod print-object ((set hash-set) stream)
-  (print-unreadable-object (set stream :type t)
-    (format stream "~{~S~^ ~}"
-            (iterate
-              (for (key) :in-hashtable (slot-value set 'data))
-              (collect key)))))
-
-
-;;;; Iterate
-(defmacro-clause (AVERAGING expr &optional INTO var)
-  (with-gensyms (count)
-    (let ((average (or var (gensym "average"))))
-      `(progn
-        (for ,average
-             :first ,expr
-             ;; continuously recompute the running average instead of keeping
-             ;; a running total to avoid bignums when possible
-             :then (/ (+ (* ,average ,count)
-                         ,expr)
-                      (1+ ,count)))
-        (for ,count :from 1)
-        ,(when (null var)
-           ;; todo handle this better
-           `(finally (return ,average)))))))
+(defun average4 (a b c d)
+  (/ (+ a b c d) 4))
 
-(defmacro-clause (TIMING time-type &optional SINCE-START-INTO var PER-ITERATION-INTO per)
-  (let ((timing-function (ecase time-type
-                           ((real-time) #'get-internal-real-time)
-                           ((run-time) #'get-internal-run-time)))
-        (since (or var (gensym))))
-    (with-gensyms (start-time current-time previous-time)
-      `(progn
-        (with ,start-time = (funcall ,timing-function))
-        (for ,current-time = (funcall ,timing-function))
-        (for ,previous-time :previous ,current-time :initially ,start-time)
-        (for ,since = (- ,current-time ,start-time))
-        ,(when per
-           `(for ,per = (- ,current-time ,previous-time)))
-        ,(when (and (null var) (null per))
-           `(finally (return ,since)))))))
-
-(defmacro-driver (FOR var IN-WHATEVER seq)
-  "Iterate over items in the given sequence.
-
-  Unlike iterate's own `in-sequence` this won't use the horrifically inefficient
-  `elt`/`length` functions on a list.
-
-  "
-  (let ((kwd (if generate 'generate 'for)))
-    (with-gensyms (is-list source i len)
-      `(progn
-        (with ,source = ,seq)
-        (with ,is-list = (typep ,source 'list))
-        (with ,len = (if ,is-list -1 (length ,source)))
-        (for ,i :from 0)
-        (,kwd ,var next (if ,is-list
-                          (if ,source
-                            (pop ,source)
-                            (terminate))
-                          (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
-;               ()
-;               )))))