From: "Ludovic Courtès" <ludo@gnu.org>
To: 41164@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#41164] [PATCH 2/3] graph: Add 'shortest-path'.
Date: Sun, 10 May 2020 01:27:38 +0200 [thread overview]
Message-ID: <20200509232739.29016-2-ludo@gnu.org> (raw)
In-Reply-To: <20200509232739.29016-1-ludo@gnu.org>
* guix/graph.scm (shortest-path): New procedure.
* tests/graph.scm ("shortest-path, packages + derivations")
("shortest-path, reverse packages")
("shortest-path, references"): New tests.
---
guix/graph.scm | 69 ++++++++++++++++++++++++++++++++++++++++++++++++-
tests/graph.scm | 61 +++++++++++++++++++++++++++++++++++++++++++
2 files changed, 129 insertions(+), 1 deletion(-)
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))))))
+
\f
;;;
;;; 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")
--
2.26.2
next prev parent reply other threads:[~2020-05-09 23:27 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-05-09 23:04 [bug#41164] [PATCH 0/3] Add 'guix graph --path' Ludovic Courtès
2020-05-09 23:27 ` [bug#41164] [PATCH 1/3] graph: reference/referrer node types work with graph traversal Ludovic Courtès
2020-05-09 23:27 ` Ludovic Courtès [this message]
2020-05-09 23:27 ` [bug#41164] [PATCH 3/3] guix graph: Add '--path' Ludovic Courtès
2020-05-10 10:51 ` [bug#41164] [PATCH 0/3] Add 'guix graph --path' zimoun
2020-05-10 14:16 ` Ludovic Courtès
2020-05-10 16:18 ` zimoun
2020-05-10 19:27 ` zimoun
2020-05-11 12:33 ` Ludovic Courtès
2020-05-11 12:36 ` Ludovic Courtès
2020-05-11 14:02 ` zimoun
2020-05-11 20:55 ` Ludovic Courtès
2020-05-11 22:13 ` zimoun
2020-05-12 8:41 ` Ludovic Courtès
2020-05-12 11:56 ` zimoun
2020-05-11 21:36 ` bug#41164: " Ludovic Courtès
2020-05-10 23:45 ` [bug#41164] Fix pipe 'guix show' zimoun
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20200509232739.29016-2-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=41164@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).