Commits

Paul Sexton committed 3fae6db

First commit.

  • Participants

Comments (0)

Files changed (2)

+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; coding: utf-8-unix -*- ;;;;;;;;80
+
+(defpackage #:dijkstra-map-system
+  (:use :cl :asdf))
+
+(in-package :dijkstra-map-system)
+
+(defsystem dijkstra-map
+  :name "Dijkstra-Map"
+  :version "1.0.0"
+  :author "Paul Sexton"
+  :serial t
+  :components ((:file "dijkstra-map"))
+  :depends-on ("iterate"
+               "defstar"))

dijkstra-map.lisp

+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; coding: utf-8-unix -*- ;;;;;;;;80
+
+(in-package :cl-user)
+
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+
+(defpackage :dijkstra-map
+  (:use :cl :iterate
+        :defstar :cartesian)
+  (:export #:dijkstra-map
+           #:make-dijkstra-map
+           #:dijkstra-compute
+           #:dijkstra-compute-multi
+           #:dijkstra-computed?
+           #:dijkstra-path-exists?
+           #:random-reachable-position
+           #:dijkstra-distance
+           #:dijkstra-print
+           #:dm-timestamp)
+  (:documentation
+   "* Description
+
+The Dijkstra pathfinding algorithm is used to find the shortest path
+between two positions. It is similar to the A* algorithm, but does use a
+heuristic to guess the cost of future movement.
+
+'Dijkstra map' is a two-dimensional grid where each cell stores
+the distance from that cell to the /root/ cell. The root cell is specified
+when the Dijkstra map is created.
+
+The term 'Dijkstra map' was originally coined by Brian Walker, the creator
+of the roguelike game [[http://sites.google.com/site/broguegame/][Brogue]].
+They may also be called 'distance maps'.
+
+This library allows the creation of two-dimensional Dijkstra maps with
+specification of the root cell or cells, and specification of impassable
+obstacles.
+
+* Usage ideas
+
+- D0 is a Dijkstra map with root cell at P's current location
+  - Find the number of turns it will take for P to move to any other location
+    on the map -- (dijkstra-distance D0 x y)
+- D1 is a Dijkstra map with root cell set to some other location, L
+  - Find the number of turns it will take for P to move from its
+    current position to L
+  - Find the adjacent position (if any) which will move P nearest to the root
+    (which could be a goal item, enemy, ally, noise, smell, stairs, ...)
+  - Find the adjacent position (if any) which will move P furthest from the root
+  - Find a map position very far, or furthest, from the root
+    (max dijkstra-distance)
+  - For goals that move (enemies etc), use a copy of the Dijkstra map when the
+    goal moves out of line of sight (ur just use the cached map for the square
+    where the goal was last seen), and discard the copy when the goal moves
+    back into view.
+- Dn is a Dijkstra map with multiple root cells, each corresponding to the
+  location of the same type of item (eg food items, treasure, noises, any
+    item on the floor)
+  - Find the adjacent cell which is closest to the nearest of the items
+  - Find the adjacent cell which is furthest from the nearest of the items
+  - Prioritise goals by giving some root cells a negative BASE-DISTANCE.
+  - Make each unexplored tile a root cell, and roll downhill for autoexplore
+    - Once there are no accessible unexplored tiles left, set the stairs as
+      the root
+  - Make each player-visible cell a root cell, and stealthy monsters can
+    move out of sight
+  - Simulate smells using root cells with negative starting distances,
+    proportional to the smell strength, and ignore distances that go above
+    zero or 'sense of smell threshold'.
+- AI routine can consider several Dijkstra maps, multiply the raw
+  distances by positive or negative 'desire factors', then add all the relevant
+  distances together when considering a cell. Or simply compare the distances
+  on several maps.
+
+* External links
+
+[[http://roguebasin.roguelikedevelopment.org/index.php/The_Incredible_Power_of_Dijkstra_Maps]]"
+   ))
+
+(in-package :dijkstra-map)
+
+
+(defconstant +DIJKSTRA-START-VALUE+ most-positive-fixnum)
+
+
+(defclass dijkstra-map ()
+  ((dm-xdim :initform 0 :type fixnum :initarg :xdim :accessor dm-xdim
+            :documentation "Width of map")
+   (dm-ydim :initform 0 :type fixnum :initarg :ydim :accessor dm-ydim
+            :documentation "Height of map")
+   (dm-diagonal-cost :initform 140 :type fixnum :initarg :diagonal-cost
+                      :accessor dm-diagonal-cost
+                     :documentation
+                     "140 if diagonal movement costs more, 100 otherwise.")
+   (dm-obstacle-map :initform nil :initarg :map :accessor dm-obstacle-map
+                    :documentation "2D array of boolean or real values. True
+means there is an obstacle at that location. A number is interpreted either
+as a factor multiplying the cost of moving into or through that location,
+or as a fixed cost that is added to the cost of moving through the
+location. 1.0 = no change (if multiplying) or +1 cost if adding.")
+   (dm-multiply-costs? :initform nil :type boolean :initarg :multiply-costs?
+                        :accessor dm-multiply-costs?
+                       :documentation "If true, numbers in the OBSTACLE-MAP are
+treated as factors that MULTIPLY the cost of travelling through the
+location. If false, the numbers are ADDED to the cost of travelling
+through the location.")
+   (dm-stop-after? :initform nil :type boolean :initarg :stop-after?
+                    :accessor dm-stop-after?
+                   :documentation "If true, propagate into an 'obstacle', but do
+not propagate PAST the obstacle. If false (default), do not propagate
+into an obstacle.")
+   (dm-distances :initform #() :type simple-vector :accessor dm-distances)
+   (dm-nodes :initform #() :type simple-vector :accessor dm-nodes
+             :documentation "1-D array of indices into the distances vector.")
+   (dm-nodes-max :initform 0 :type fixnum :accessor dm-nodes-max)
+   (dm-grid :initform #2a() :type simple-array :accessor dm-grid)
+   (dm-root-coords :initform nil :type list :accessor dm-root-coords
+                   :documentation "List of (X . Y) coordinates
+of 'root' cells.")
+   (dm-root-map :initform nil :initarg :root-map :accessor dm-root-map)
+   (dm-timestamp :initform 0 :type integer :initarg :timestamp
+                  :accessor dm-timestamp)))
+
+
+
+(defmethod initialize-instance :after ((dm dijkstra-map) &key)
+  (if (and (zerop (dm-xdim dm)) (zerop (dm-ydim dm)) (dm-obstacle-map dm))
+      (setf (dm-xdim dm) (array-dimension (dm-obstacle-map dm) 1)
+            (dm-ydim dm) (array-dimension (dm-obstacle-map dm) 0)))
+  (setf (dm-grid dm)
+        (make-array (list (dm-ydim dm) (dm-xdim dm))
+                    :element-type 'real))
+  (setf (dm-nodes-max dm) (* (dm-xdim dm) (dm-ydim dm)))
+  (setf (dm-nodes dm) (make-array (list (dm-nodes-max dm))
+                                  :initial-element 0))
+  (setf (dm-distances dm) (make-array (list (dm-nodes-max dm))
+                                      :initial-element
+                                      +DIJKSTRA-START-VALUE+)))
+
+
+
+(defun* (make-dijkstra-map -> dijkstra-map) ((obst-map (or array null))
+                                             &rest initargs
+                                             &key diagonal-cost
+                                                  xdim ydim timestamp
+                                                  root-map multiply-costs?
+                                                  stop-after?)
+  "* Arguments:
+- OBST-MAP :: A 2D array of boolean values. Boolean true indicates there is
+an obstacle at that position on the map."
+  (declare (ignorable xdim ydim timestamp root-map multiply-costs?
+                      stop-after?))
+  (if diagonal-cost
+      (setf diagonal-cost (round (* 100 diagonal-cost))))
+  (apply #'make-instance 'dijkstra-map :map obst-map
+         initargs))
+
+
+(defun* (dijkstra-computed? -> boolean) ((dmap dijkstra-map))
+  (plusp (length (dm-nodes dmap))))
+
+
+(defun* (dijkstra-distance -> float) ((dmap dijkstra-map)
+                                      (x fixnum) (y fixnum))
+  "* Returns:
+Distance from the node at X, Y in DMAP, to DMAP's root node.
+A distance of 1 means 1 square (converted from internal representation where
+100 = 1 square.)"
+  (/ (aref (dm-distances dmap) (+ x (* (dm-xdim dmap) y)))
+     100.0))
+
+
+(defun* (dijkstra-path-exists? -> boolean) ((dmap dijkstra-map)
+                                            (x fixnum) (y fixnum))
+  (:pre (dijkstra-computed? dmap))
+  (< (dijkstra-distance dmap x y) 999999))
+
+
+(defun* (random-reachable-position -> (cons fixnum fixnum)) ((dmap dijkstra-map))
+  (:pre (dijkstra-computed? dmap))
+  (let* ((mmax (position 0 (dm-nodes dmap)))
+         (node (aref (dm-nodes dmap) (random mmax))))
+    (cons (mod node (dm-xdim dmap))
+          (floor node (dm-xdim dmap)))))
+
+
+(defun* (dijkstra-compute -> dijkstra-map) ((dmap dijkstra-map)
+                                            (rootx fixnum)
+                                            (rooty fixnum)
+                                            &key (base-distance 0))
+  "* Arguments:
+- DMAP :: An instance of DIJKSTRA-MAP.
+- ROOTX, ROOTY :: coordinates of the /root node/ (the node with zero
+  distance.)
+- BASE-DISTANCE :: The starting distance at the root node, usually zero. It
+  can be useful to set this to a negative number to 'strengthen' the effect
+  of this root node if the Dijkstra map is to be compared to other
+  Dijkstra maps.
+* Effects:
+Sets the value of each node (map position) in DMAP to the DISTANCE
+required to navigate from that node to the root node, taking into account
+obstacles as specified in (DM-OBSTACLE-MAP DMAP)."
+  (*let ((mx fixnum (dm-xdim dmap))
+         (my fixnum (dm-ydim dmap))
+         (mmax fixnum (dm-nodes-max dmap))
+         (root fixnum (+ rootx (* mx rooty)))
+         (index fixnum 0)
+         (last-index fixnum 1)
+         (diag-cost fixnum (dm-diagonal-cost dmap))
+         (dx simple-vector (vector -1  0  1 0 -1  1 1 -1))
+         (dy simple-vector (vector  0 -1  0 1 -1 -1 1  1))
+         (dd simple-vector (vector 100 100 100 100
+                                   diag-cost diag-cost diag-cost diag-cost))
+         (obstacle-map (or simple-array null) (dm-obstacle-map dmap))
+         (distances simple-vector (dm-distances dmap))
+         (nodes simple-vector (dm-nodes dmap)))
+    (fill distances +DIJKSTRA-START-VALUE+)
+    (fill nodes 0)
+    (setf (aref distances root) base-distance)
+    (setf (aref nodes index) root)
+
+    (iterate
+      ;; Coordinates of current node
+      (for (the fixnum x) = (mod (aref nodes index) mx))
+      (for (the fixnum y) = (floor (aref nodes index) mx))
+      (if (and (dm-stop-after? dmap)
+               obstacle-map
+               (eq t (aref obstacle-map y x)))
+          (next-iteration))
+      (iterate
+        (for (the fixnum i) from 0 below 8)
+        (for (the fixnum tx) = (+ x (aref dx i)))
+        (for (the fixnum ty) = (+ y (aref dy i)))
+        (when (and (<= 0 tx (1- mx))
+                   (<= 0 ty (1- my)))
+          (let ((dt (aref distances (aref nodes index)))
+                (new-node 0))
+            (incf dt (aref dd i))
+            ;; If obstacle-map contains a number, that number adds
+            ;; to/multiplies the distance increment when moving into that
+            ;; square
+            (when (and obstacle-map
+                       (numberp (aref obstacle-map ty tx)))
+              (cond
+                ((dm-multiply-costs? dmap)
+                 (setf dt (* dt (aref obstacle-map ty tx))))
+                (t
+                 (incf dt (* 100 (aref obstacle-map ty tx))))))
+
+            (setf new-node (+ tx (* ty mx)))
+            (when (> (aref distances new-node) dt)
+              (let ((j 0))
+                (if (and (not (dm-stop-after? dmap))
+                         obstacle-map
+                         (eql t (aref obstacle-map ty tx)))
+                    (next-iteration))
+                (setf (aref distances new-node) dt
+                      j (1- last-index))
+                (if (>= j (1- mmax)) (next-iteration)) ; added
+                (iterate
+                  (while (>= (aref distances (aref nodes j))
+                             (aref distances new-node)))
+                  (cond
+                    ((= (aref nodes j) new-node)
+                     (iterate
+                       (with k = j)
+                       (while (< -1 k (min last-index mmax)))
+                       (setf (aref nodes k) (aref nodes (1+ k)))
+                       (incf k))
+                     (decf last-index)
+                     )
+                    (t
+                     (setf (aref nodes (1+ j)) (aref nodes j))
+                     (decf j))))
+                (incf last-index)
+                (setf (aref nodes (1+ j)) new-node))))))
+      (while (> (1- mmax) (incf index))))
+    dmap))
+
+
+
+(defun* (dijkstra-compute-multi -> dijkstra-map)
+    ((dmap dijkstra-map) &key (roots nil)
+                              (root-base-distances nil)
+                              (base-distance 0))
+  "* Arguments:
+- DMAP :: An instance of <DIJKSTRA-MAP>.
+- ROOTS :: List of (X . Y) coordinate pairs. Each coordinate is
+  treated as a root cell.
+  If not supplied, use the root nodes specified in the map's ROOT-MAP
+  array.
+- ROOT-BASE-DISTANCES :: List of integers, which if supplied must be the
+  same length as ROOTS.
+- BASE-DISTANCE :: Default base distance for root nodes, usually 0.
+* Effects:
+Sets the value of each node (map position) in DMAP to the DISTANCE
+required to navigate from that node to the NEAREST root node, taking into
+account obstacles as specified in (DM-OBSTACLE-MAP DMAP).
+* Notes:
+Fast, but slightly less efficient than DIJKSTRA-COMPUTE (about twice
+as slow). However, speed appears to increase as more root nodes are
+specified."
+  (*let ((mx fixnum (dm-xdim dmap))
+         (my fixnum (dm-ydim dmap))
+         (index fixnum 0)
+         (diag-cost fixnum (dm-diagonal-cost dmap))
+         (dx simple-vector (vector -1  0  1 0 -1  1 1 -1))
+         (dy simple-vector (vector  0 -1  0 1 -1 -1 1  1))
+         (dd simple-vector (vector 100 100 100 100
+                                   diag-cost diag-cost diag-cost diag-cost))
+         (obstacle-map (or simple-array null) (dm-obstacle-map dmap))
+         (distances simple-vector (dm-distances dmap))
+         (nodes simple-vector (dm-nodes dmap))
+         (active-nodes simple-vector #()))
+
+    (if root-base-distances
+        (assert (= (length root-base-distances) (length roots))))
+    (fill distances +DIJKSTRA-START-VALUE+)
+    (fill nodes -1)
+
+    (cond
+      (roots
+       (iterate
+         (for (the fixnum i) from 0 below (length roots))
+         (for (rootx . rooty) in roots)
+         (for (the fixnum root) = (+ rootx (* mx rooty)))
+         (setf (aref distances root) (if root-base-distances
+                                         (elt root-base-distances i)
+                                         base-distance))
+         (setf (aref nodes i) root)))
+      ((dm-root-map dmap)
+       (let ((i 0))
+         (do-2d-array (root? (dm-root-map dmap) rootx rooty)
+           (when root?
+             (let ((root (+ rootx (* mx rooty))))
+               (setf (aref distances root) base-distance)
+               (setf (aref nodes i) root)
+               (incf i)))))))
+    (setf index 0)
+    (setf (dm-root-coords dmap) roots)
+
+    (setf active-nodes (copy-seq nodes))
+
+    (iterate
+      (for (the boolean continue?) = nil)
+      (for (the simple-vector old-active-nodes) = (copy-seq active-nodes))
+      (fill active-nodes -1)
+      (iterate
+        (with (the fixnum new-idx) = 0)
+        (for (the fixnum index) from 0)
+        (for (the fixnum x) = (mod (aref old-active-nodes index) mx))
+        (for (the fixnum y) = (floor (aref old-active-nodes index) mx))
+        (if (minusp (aref old-active-nodes index)) (finish))
+        (if (and (dm-stop-after? dmap)
+                 obstacle-map
+                 (eq t (aref obstacle-map y x)))
+            (next-iteration))
+        (iterate
+          (for (the fixnum i) from 0 below 8)
+          (for (the fixnum tx) = (+ x (aref dx i)))
+          (for (the fixnum ty) = (+ y (aref dy i)))
+          (when (and (<= 0 tx (1- mx))
+                     (<= 0 ty (1- my))
+                     (or (dm-stop-after? dmap)
+                         (null obstacle-map)
+                         (not (eq t (aref obstacle-map ty tx))))
+                     (plusp (aref distances (+ tx (* ty mx)))))
+            (let* ((old-dt (aref distances (+ tx (* ty mx))))
+                   (base-dt (+ (aref distances (+ x (* y mx)))
+                               (aref dd i)))
+                   (dt (if (and obstacle-map
+                                (numberp (aref obstacle-map ty tx)))
+                           (if (dm-multiply-costs? dmap)
+                               (* base-dt (aref obstacle-map ty tx))
+                               (+ base-dt (* 100 (aref obstacle-map ty tx))))
+                           base-dt)))
+              (cond
+                ((= old-dt +DIJKSTRA-START-VALUE+)
+                 (setf (aref distances (+ tx (* ty mx))) dt)
+                 (setf (aref active-nodes new-idx) (+ tx (* ty mx)))
+                 (incf new-idx)
+                 (setf continue? t))
+                ((< dt old-dt)
+                 (setf (aref distances (+ tx (* ty mx))) dt)))))))
+      (while continue?))
+    dmap))
+
+
+(defun dijkstra-print (dmap &key (max-distance nil))
+  "* Arguments:
+- DMAP :: An instance of DIJKSTRA-MAP.
+* Effects:
+Print a representation of the Dijkstra map DMAP to standard output.
+In the output, '0' represents the root node, '#' represents an obstacle,
+and lowercase letters represent distances from the root node, with
+'a' being the shortest distance. Distances above 26 (z) are represented
+by '+'."
+  (do-2d-array (el (dm-grid dmap) x y)
+    (setf (array-at (dm-grid dmap) x y)
+          (dijkstra-distance dmap x y)))
+  (print-2d-array (dm-grid dmap)
+                  :coord-print-fn
+                  (lambda (x y)
+                    (let ((dist (round (dijkstra-distance dmap x y))))
+                      (cond
+                        ((and (not (dm-stop-after? dmap))
+                              (dm-obstacle-map dmap)
+                              (aref (dm-obstacle-map dmap) y x))
+                         #\#)
+                        ((> dist 100000)
+                         #\?)
+                        ((= dist 0)
+                         #\0)
+                        ((and max-distance (> dist max-distance))
+                         #\-)
+                        ((< dist 27)
+                         (code-char (+ dist 96)))
+                        (t
+                         #\+)))))
+  dmap)
+
+
+(defun dijkstra-test (&key (root-count 5) (wall? nil) (max-distance nil))
+  (let* ((omap (make-2d-array 30 30 nil))
+         (roots (iterate (for i from 1 to root-count)
+                  (collect (cons (random 30) (random 30)))))
+         (dmap nil))
+    (when wall?
+      (iterate
+        (for y from 2 to 27)
+        (setf (array-at omap 15 y) t)))
+    (setf dmap (make-dijkstra-map omap :xdim 30 :ydim 30))
+    (dijkstra-print
+     (time
+      (if (> root-count 1)
+          (dijkstra-compute-multi dmap :roots roots)
+          (dijkstra-compute dmap (car (first roots)) (cdr (first roots))))))
+    dmap))
+
+
+;; (dijkstra-test :root-count 2 :max-distance 15)
+
+;;;; dijkstra-map.lisp ends here ==============================================