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