M guix/graph.scm => guix/graph.scm +68 -1
@@ 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.
M tests/graph.scm => tests/graph.scm +61 -0
@@ 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")