--- a/package.lisp Thu Aug 18 12:16:41 2016 +0000
+++ b/package.lisp Thu Aug 18 17:47:14 2016 +0000
@@ -75,3 +75,18 @@
#:split-sequence
#:sand.quickutils
#:sand.utils))
+
+(defpackage #:sand.dijkstra-maps
+ (:use
+ #:cl
+ #:cl-arrows
+ #:losh
+ #:iterate
+ #:sand.quickutils
+ #:sand.utils)
+ (:export
+ #:dijkstra-map
+ #:make-dijkstra-map
+ #:dm-maximum-value
+ #:dm-map
+ #:dm-ref))
--- a/sand.asd Thu Aug 18 12:16:41 2016 +0000
+++ b/sand.asd Thu Aug 18 17:47:14 2016 +0000
@@ -34,6 +34,7 @@
(:file "random-numbers")
(:file "ascii")
(:file "markov")
+ (:file "dijkstra-maps")
(:module "terrain"
:serial t
:components ((:file "diamond-square")))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/dijkstra-maps.lisp Thu Aug 18 17:47:14 2016 +0000
@@ -0,0 +1,118 @@
+(in-package #:sand.dijkstra-maps)
+
+
+(defclass dijkstra-map ()
+ ((map
+ :initarg :map
+ :accessor dm-map
+ :type (simple-array single-float (* *)))
+ (source
+ :initarg :source
+ :accessor dm-source
+ :type (array t (* *)))
+ (maximum-value
+ :initarg :maximum-value
+ :accessor dm-maximum-value
+ :type single-float)
+ (impassable-p
+ :initarg :impassable-p
+ :accessor dm-impassable-p
+ :type function)
+ (goal-p
+ :initarg :goal-p
+ :accessor dm-goal-p
+ :type function)))
+
+
+(defun make-dijkstra-map (array goal-p impassable-p)
+ (let ((dm (make-instance 'dijkstra-map
+ :source array
+ :map (make-array (array-dimensions array)
+ :element-type 'single-float
+ :initial-element 0.0
+ :adjustable nil)
+ :maximum-value 0.0
+ :impassable-p impassable-p
+ :goal-p goal-p)))
+ (dm-recalculate dm)
+ dm))
+
+(defmethod print-object ((object dijkstra-map) stream)
+ (destructuring-bind (rows cols)
+ (array-dimensions (dm-map object))
+ (print-unreadable-object (object stream :type t)
+ (format stream "(~D ~D) (max ~F)~%" rows cols (dm-maximum-value object))
+ (if (and (< cols 10)
+ (< rows 30))
+ (iterate
+ (for row :from 0 :below rows)
+ (iterate
+ (for col :from 0 :below cols)
+ (for val = (aref (dm-map object) row col))
+ (if (= val most-positive-single-float)
+ (format stream " INF")
+ (format stream " ~5,1F" val)))
+ (terpri stream))
+ (format stream " ...very large array...")))))
+
+
+(defun dm-recalculate (dm)
+ (let* ((source (dm-source dm))
+ (rows (first (array-dimensions source)))
+ (cols (second (array-dimensions source)))
+ (map (dm-map dm))
+ (impassable-p (dm-impassable-p dm))
+ (goal-p (dm-goal-p dm))
+ (unset most-positive-single-float))
+ (flet ((init-goals ()
+ (iterate (for (val r c) :in-array source)
+ (when (funcall goal-p val)
+ (setf (aref map r c) 0.0)
+ (collect (list 0.0 r c)))))
+ (find-neighbors (row col)
+ (iterate
+ (for (dr dc) :within-radius 1 :skip-origin t)
+ (for nr = (+ row dr))
+ (for nc = (+ col dc))
+ (when (and (< -1 nr rows)
+ (< -1 nc cols))
+ (for nv = (aref source nr nc))
+ (unless (funcall impassable-p nv)
+ (collect (list (aref map nr nc) nr nc)))))))
+ (fill-multidimensional-array-single-float map unset)
+ (iterate
+ main
+ (for frontier
+ :first (init-goals)
+ :then (iterate
+ new-frontier
+ (for (value row col) :in frontier)
+ (iterate
+ (for (nvalue nrow ncol) :in (find-neighbors row col))
+ (when (= nvalue unset)
+ (let ((nvalue (+ 1.0 value)))
+ (setf (aref map nrow ncol) nvalue)
+ (in main (maximize nvalue :into max))
+ (in new-frontier (collect (list nvalue nrow ncol))))))))
+ (while frontier)
+ (finally (setf (dm-maximum-value dm) (float max)))))))
+
+
+
+(defun dm-ref (dm x y)
+ (aref (dm-map dm) x y))
+
+; (defparameter *m*
+; (make-array '(5 6)
+; :initial-contents (list (list 0 8 0 0 1 0)
+; (list 0 0 1 0 1 0)
+; (list 0 0 1 0 1 0)
+; (list 0 0 1 0 0 0)
+; (list 8 0 1 0 0 0))))
+
+
+; (defparameter *d*
+; (make-dijkstra-map *m*
+; (curry #'= 8)
+; (curry #'= 1)))
+
--- a/src/sketch.lisp Thu Aug 18 12:16:41 2016 +0000
+++ b/src/sketch.lisp Thu Aug 18 17:47:14 2016 +0000
@@ -2,8 +2,9 @@
;;;; Config
(setf *bypass-cache* t)
+(defparameter *wat* nil)
(defparameter *width* 600)
-(defparameter *height* 400)
+(defparameter *height* 600)
(defparameter *center-x* (/ *width* 2))
@@ -32,7 +33,7 @@
;;;; Utils
(defmacro with-setup (&body body)
`(progn
- (background (gray 1))
+ (background (gray 1.0))
,@body))
(defmacro in-context (&body body)
@@ -57,109 +58,127 @@
,@body))
-;;;; Diamond Square
-(defparameter *world-exponent* 4)
-(defparameter *world-size* (expt 2 *world-exponent*))
+;;;; Sketch
+(defparameter *tile-count* 20)
+(defparameter *tile-width* (/ *width* *tile-count*))
+(defparameter *tile-height* (/ *height* *tile-count*))
+
+(defparameter *wall-pen* (make-pen :fill (gray 0.0)))
+(defparameter *floor-pen* (make-pen :fill (gray 1.0)))
+(defparameter *goal-pen* (make-pen :fill (rgb 0.0 1.0 0.0)))
-(defun allocate-heightmap (size)
- (make-array (list size size)
- :element-type 'single-float
- :initial-element 0.0
- :adjustable nil))
+(defun draw-map (map)
+ (iterate (for (v x y) :in-array map)
+ (with-pen (ecase v
+ (:blank *floor-pen*)
+ (:wall *wall-pen*)
+ (:goal *goal-pen*))
+ (rect (* x *tile-width*)
+ (* y *tile-height*)
+ *tile-width*
+ *tile-height*))))
-(defun normalize-heightmap (heightmap)
+(defun draw-dijkstra (dm)
(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)))
- (return heightmap))))
-
-(defun draw-hm (hm ox oy ts)
- (let ((size (first (array-dimensions hm))))
- (in-context
- (translate (* ox (* ts size))
- (* oy (* ts size)))
- (iterate
- (for (h x y) :in-array hm)
- (with-pen (make-pen :fill (gray h))
- (rect (* x ts) (* y ts)
- ts ts)))
- (with-pen (make-pen :fill nil :stroke (rgb 1.0 0 0 0.5))
- (rect 0 0 (* ts size) (* ts size))))))
-
+ (with max = (sand.dijkstra-maps:dm-maximum-value dm))
+ (with data = (sand.dijkstra-maps::dm-map dm))
+ (for (v x y) :in-array data)
+ (unless (= most-positive-single-float v)
+ (with-pen (make-pen :fill (rgb 1.0 0.0 0.0
+ (/ v max)))
+ (rect (* x *tile-width*)
+ (* y *tile-height*)
+ *tile-width*
+ *tile-height*)))))
(defsketch demo
- ((width *width*) (height *height*) (y-axis :up) (title "Diamond Square")
+ ((width *width*) (height *height*) (y-axis :up) (title "Sketch")
(copy-pixels t)
(mouse (list 0 0))
+ (mouse-down-left nil)
+ (mouse-down-right nil)
(dirty t)
;; Data
- (size (1+ (expt 2 4)))
- (hm (sand.terrain.diamond-square::diamond-square
- 5 :tileable t :spread 0.7 :spread-reduction 0.5))
- (tile-size 3)
- )
+ (map (make-array (list *tile-count* *tile-count*)
+ :element-type t
+ :initial-element :blank))
+ (dm nil)
+ (lol (progn
+ (setf (aref map
+ (random-range 0 *tile-count*)
+ (random-range 0 *tile-count*))
+ :goal)
+ )))
;;
(just-once dirty
(with-setup
- (iterate
- (for-nested ((x :from 0 :to (floor *width* (* size tile-size)))
- (y :from 0 :to (floor *height* (* size tile-size)))))
- (draw-hm hm x y tile-size))))
+ (setf dm (sand.dijkstra-maps::make-dijkstra-map map
+ (curry #'eql :goal)
+ (curry #'eql :wall)))
+ (draw-map map)
+ (draw-dijkstra dm)))
;;
)
-;;;; Template
-(defsketch demo
- ((width *width*) (height *height*) (y-axis :up) (title "Sketch")
- (copy-pixels t)
- (mouse (list 0 0))
- (dirty t)
- ;; Data
- )
- ;;
- (just-once dirty
- (with-setup
- (text "Demo" (- *center-x* 23) (- *center-y* 10))
-
- ))
- ;;
-
- )
;;;; Mouse
+(defun mouse-in-bounds-p (x y)
+ (and (>= x 0)
+ (>= y 0)
+ (< x *width*)
+ (< y *height*)))
+
(defun mousemove (instance x y)
- (with-slots (mouse) instance
- (setf mouse (list x (- *height* y)))
- ;;
- ;;
- )
+ (when (mouse-in-bounds-p x y)
+ (with-slots (mouse) instance
+ (setf mouse (list x (- *height* y 1)))
+ ;;
+ (when (or (slot-value instance 'mouse-down-left)
+ (slot-value instance 'mouse-down-right))
+ (setf (slot-value instance 'dirty) t)
+ (let ((tx (floor x *tile-width*))
+ (ty (floor (- *height* y 1) *tile-height*)))
+ (zapf (aref (slot-value instance 'map) tx ty)
+ (if (slot-value instance 'mouse-down-left)
+ (case %
+ (:blank :wall)
+ (:goal :goal)
+ (:wall :wall))
+ (case %
+ (:blank :blank)
+ (:goal :goal)
+ (:wall :blank))))))
+ ;;
+ ))
)
(defun mousedown-left (instance x y)
- (declare (ignorable instance x y))
- )
+ (when (mouse-in-bounds-p x y)
+ (setf (slot-value instance 'mouse-down-left) t)
+ ;;
+ (mousemove instance x y)
+ ;;
+ ))
(defun mousedown-right (instance x y)
- (declare (ignorable instance x y))
- )
+ (when (mouse-in-bounds-p x y)
+ (setf (slot-value instance 'mouse-down-right) t)
+ ;;
+ (mousemove instance x y)
+ ;;
+ ))
(defun mouseup-left (instance x y)
- (declare (ignorable instance x y))
+ (declare (ignorable x y))
+ (setf (slot-value instance 'mouse-down-left) nil)
+ ;;
)
(defun mouseup-right (instance x y)
- (declare (ignorable instance x y))
+ (declare (ignorable x y))
+ (setf (slot-value instance 'mouse-down-right) nil)
)