Browse Source

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.
wip-gnome3.36
Ludovic Courtès 2 years ago
parent
commit
36c2192414
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 69
      guix/graph.scm
  2. 61
      tests/graph.scm

69
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.

61
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")
Loading…
Cancel
Save