graph: Add 'shortest-path'.

* guix/graph.scm (shortest-path): New procedure.
* tests/graph.scm ("shortest-path, packages + derivations")
("shortest-path, reverse packages")
("shortest-path, references"): New tests.

2 files changed, 129 insertions, 1 deletions

diff --git a/guix/graph.scm b/guix/graph.scm
index d7fd5f3e4b..b695ca4306 100644
--- a/guix/graph.scm
+++ b/guix/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -42,6 +42,7 @@
             traverse/depth-first
             node-transitive-edges
             node-reachable-count
+            shortest-path
 
             %graph-backends
             %d3js-backend
@@ -140,6 +141,72 @@ typically returned by 'node-edges' or 'node-back-edges'."
                         0
                         nodes node-edges))
 
+(define (shortest-path node1 node2 type)
+  "Return as a monadic value the shorted path, represented as a list, from
+NODE1 to NODE2 of the given TYPE.  Return #f when there is no path."
+  (define node-edges
+    (node-type-edges type))
+
+  (define (find-shortest lst)
+    ;; Return the shortest path among LST, where each path is represented as a
+    ;; vlist.
+    (let loop ((lst lst)
+               (best +inf.0)
+               (shortest #f))
+      (match lst
+        (()
+         shortest)
+        ((head . tail)
+         (let ((len (vlist-length head)))
+           (if (< len best)
+               (loop tail len head)
+               (loop tail best shortest)))))))
+
+  (define (find-path node path paths)
+    ;; Return the a vhash that maps nodes to paths, with each path from the
+    ;; given node to NODE2.
+    (define (augment-paths child paths)
+      ;; When using %REFERENCE-NODE-TYPE, nodes can contain self references,
+      ;; hence this test.
+      (if (eq? child node)
+          (store-return paths)
+          (find-path child vlist-null paths)))
+
+    (cond ((eq? node node2)
+           (store-return (vhash-consq node (vlist-cons node path)
+                                      paths)))
+          ((vhash-assq node paths)
+           (store-return paths))
+          (else
+           ;; XXX: We could stop recursing if one if CHILDREN is NODE2, but in
+           ;; practice it's good enough.
+           (mlet* %store-monad ((children (node-edges node))
+                                (paths    (foldm %store-monad
+                                                 augment-paths
+                                                 paths
+                                                 children)))
+             (define sub-paths
+               (filter-map (lambda (child)
+                             (match (vhash-assq child paths)
+                               (#f #f)
+                               ((_ . path) path)))
+                           children))
+
+             (match sub-paths
+               (()
+                (return (vhash-consq node #f paths)))
+               (lst
+                (return (vhash-consq node
+                                     (vlist-cons node (find-shortest sub-paths))
+                                     paths))))))))
+
+  (mlet %store-monad ((paths (find-path node1
+                                        (vlist-cons node1 vlist-null)
+                                        vlist-null)))
+    (return (match (vhash-assq node1 paths)
+              ((_ . #f) #f)
+              ((_ . path) (vlist->list path))))))
+
 
 ;;;
 ;;; Graphviz export.
diff --git a/tests/graph.scm b/tests/graph.scm
index 983a6ed654..136260c7d1 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -398,4 +398,65 @@ edges."
         (return (list (node-reachable-count (list p2) edges)
                       (node-reachable-count (list p0) back)))))))
 
+(test-equal "shortest-path, packages + derivations"
+  '(("p5" "p4" "p1" "p0")
+    ("p3" "p2" "p1" "p0")
+    #f
+    ("p5-0.drv" "p4-0.drv" "p1-0.drv" "p0-0.drv"))
+  (run-with-store %store
+    (let* ((p0 (dummy-package "p0"))
+           (p1 (dummy-package "p1" (inputs `(("p0" ,p0)))))
+           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
+           (p3 (dummy-package "p3" (inputs `(("p2" ,p2)))))
+           (p4 (dummy-package "p4" (inputs `(("p1" ,p1)))))
+           (p5 (dummy-package "p5" (inputs `(("p4" ,p4) ("p3" ,p3))))))
+      (mlet* %store-monad ((path1 (shortest-path p5 p0 %package-node-type))
+                           (path2 (shortest-path p3 p0 %package-node-type))
+                           (nope  (shortest-path p3 p4 %package-node-type))
+                           (drv5  (package->derivation p5))
+                           (drv0  (package->derivation p0))
+                           (path3 (shortest-path drv5 drv0
+                                                 %derivation-node-type)))
+        (return (append (map (lambda (path)
+                               (and path (map package-name path)))
+                             (list path1 path2 nope))
+                        (list (map (node-type-label %derivation-node-type)
+                                   path3))))))))
+
+(test-equal "shortest-path, reverse packages"
+  '("libffi" "guile" "guile-json")
+  (run-with-store %store
+    (mlet %store-monad ((path (shortest-path (specification->package "libffi")
+                                             guile-json
+                                             %reverse-package-node-type)))
+      (return (map package-name path)))))
+
+(test-equal "shortest-path, references"
+  `(("d2" "d1" ,(package-full-name %bootstrap-guile "-"))
+    (,(package-full-name %bootstrap-guile "-") "d1" "d2"))
+  (run-with-store %store
+    (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile))
+                         (d1 (gexp->derivation "d1"
+                                               #~(begin
+                                                   (mkdir #$output)
+                                                   (symlink #$%bootstrap-guile
+                                                            (string-append
+                                                             #$output "/l")))))
+                         (d2 (gexp->derivation "d2"
+                                               #~(begin
+                                                   (mkdir #$output)
+                                                   (symlink #$d1
+                                                            (string-append
+                                                             #$output "/l")))))
+                         (_  (built-derivations (list d2)))
+                         (->node -> (node-type-convert %reference-node-type))
+                         (o2   (->node (derivation->output-path d2)))
+                         (o0   (->node (derivation->output-path d0)))
+                         (path (shortest-path (first o2) (first o0)
+                                              %reference-node-type))
+                         (rpath (shortest-path (first o0) (first o2)
+                                               %referrer-node-type)))
+      (return (list (map (node-type-label %reference-node-type) path)
+                    (map (node-type-label %referrer-node-type) rpath))))))
+
 (test-end "graph")