# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1471542434 0
# Node ID d03941f38bca3945627f6aea3483cd3e1fb40b4c
# Parent  37d71dad1f25c4278d03a141411b4124c253e0be
Dijkstra maps

diff -r 37d71dad1f25 -r d03941f38bca package.lisp
--- 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))
diff -r 37d71dad1f25 -r d03941f38bca sand.asd
--- 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")))
diff -r 37d71dad1f25 -r d03941f38bca src/dijkstra-maps.lisp
--- /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)))
+
diff -r 37d71dad1f25 -r d03941f38bca src/sketch.lisp
--- 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)
   )