X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/00091ab3d552b0ab7bc177e19e86110d8c1cd20b..17c7c784e0632dff2f93a69a837585fd6f31f4a1:/src/utilities.lisp?ds=inline

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 38bb746..0415a90 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -439,6 +439,93 @@
    and return the result of appending all of the resulting lists."
   (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
 
+(export 'distinguished-point-shortest-paths)
+(defun distinguished-point-shortest-paths (root neighbours-func)
+  "Moderately efficient shortest-paths-from-root computation.
+
+   The ROOT is a distinguished vertex in a graph.  The NEIGHBOURS-FUNC
+   accepts a VERTEX as its only argument, and returns a list of conses (V .
+   C) for each of the VERTEX's neighbours, indicating that there is an edge
+   from VERTEX to V, with cost C.
+
+   The return value is a list of entries (COST . REV-PATH) for each vertex
+   reachable from the ROOT; the COST is the total cost of the shortest path,
+   and REV-PATH is the path from the ROOT, in reverse order -- so the first
+   element is the vertex itself and the last element is the ROOT.
+
+   The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to
+   produce its output list.  The computation as a whole takes O(N^2) time,
+   where N is the number of vertices in the graph, assuming there is at most
+   one edge between any pair of vertices."
+
+  ;; This is a listish version of Dijkstra's shortest-path algorithm.  It
+  ;; could be made more efficient by using a fancy priority queue rather than
+  ;; a linear search for finding the nearest live element (see below), but it
+  ;; still runs pretty well.
+
+  (let ((map (make-hash-table))
+	(dead nil)
+	(live (list (list 0 root))))
+    (setf (gethash root map) (cons :live (car live)))
+    (loop
+      ;; The dead list contains a record, in output format (COST . PATH), for
+      ;; each vertex whose shortest path has been finally decided.  The live
+      ;; list contains a record for the vertices of current interest, also in
+      ;; output format; the COST for a live record shows the best cost for a
+      ;; path using only dead vertices.
+      ;;
+      ;; Each time through here, we pull an item off the live list and
+      ;; push it onto the dead list, so we do at most N iterations total.
+
+      ;; If there are no more live items, then we're done; the remaining
+      ;; vertices, if any, are unreachable from the ROOT.
+      (when (null live) (return))
+
+      ;; Find the closest live vertex to the root.  The linear scan through
+      ;; the live list costs at most N time.
+      (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live))
+	     (best-cost (car best))
+	     (best-path (cdr best))
+	     (best-vertex (car best-path)))
+
+	;; Remove the chosen vertex from the LIVE list, and add the
+	;; appropriate record to the dead list.  We must have the shortest
+	;; path to this vertex now: we have the shortest path using currently
+	;; dead vertices; any other path must use at least one live vertex,
+	;; and, by construction, the path through any such vertex must be
+	;; further than the path we already have.
+	;;
+	;; Removal from the live list uses a linear scan which costs N time.
+	(setf live (delete best live))
+	(push best dead)
+	(setf (car (gethash best-vertex map)) :dead)
+
+	;; Work through the chosen vertex's neighbours, adding each of them
+	;; to the live list if they're not already there.  If a neighbour is
+	;; already live, and we find a shorter path to it through our chosen
+	;; vertex, then update the neighbour's record.
+	;;
+	;; The chosen vertex obviously has at most N neighbours.  There's no
+	;; more looping in here, so performance is as claimed.
+	(dolist (neigh (funcall neighbours-func best-vertex))
+	  (let* ((neigh-vertex (car neigh))
+		 (neigh-cost (+ best-cost (cdr neigh)))
+		 (neigh-record (gethash neigh-vertex map)))
+	    (cond ((null neigh-record)
+		   ;; If the neighbour isn't known, then now's the time to
+		   ;; make a fresh live record for it.
+		   (let ((new-record (list* :live neigh-cost
+					    neigh-vertex best-path)))
+		     (push (cdr new-record) live)
+		     (setf (gethash neigh-vertex map) new-record)))
+		  ((and (eq (car neigh-record) :live)
+			(< neigh-cost (cadr neigh-record)))
+		   ;; If the neighbour is live, and we've found a better path
+		   ;; to it, then update its record.
+		   (setf (cadr neigh-record) neigh-cost
+			 (cdddr neigh-record) best-path)))))))
+    dead))
+
 (export '(inconsistent-merge-error merge-error-candidates))
 (define-condition inconsistent-merge-error (error)
   ((candidates :initarg :candidates