mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2025-01-11 13:49:23 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
7240202136
commit
36c2192414
2 changed files with 129 additions and 1 deletions
|
|
@ -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 @@ (define-module (guix graph)
|
|||
traverse/depth-first
|
||||
node-transitive-edges
|
||||
node-reachable-count
|
||||
shortest-path
|
||||
|
||||
%graph-backends
|
||||
%d3js-backend
|
||||
|
|
@ -140,6 +141,72 @@ (define (node-reachable-count nodes node-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.
|
||||
|
|
|
|||
|
|
@ -398,4 +398,65 @@ (define (edge->tuple source target)
|
|||
(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…
Reference in a new issue