diff options
| -rw-r--r-- | guix/graph.scm | 69 | ||||
| -rw-r--r-- | tests/graph.scm | 61 |
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") |