From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp2 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id yGTSKHo8t15XAgAA0tVLHw (envelope-from ) for ; Sat, 09 May 2020 23:27:54 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp2 with LMTPS id qH+ZOYc8t16iFAAAB5/wlQ (envelope-from ) for ; Sat, 09 May 2020 23:28:07 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 4B98A9400EF for ; Sat, 9 May 2020 23:28:05 +0000 (UTC) Received: from localhost ([::1]:49812 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jXYt4-00075c-0c for larch@yhetil.org; Sat, 09 May 2020 19:28:06 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:50728) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1jXYt0-00075G-Qc for guix-patches@gnu.org; Sat, 09 May 2020 19:28:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:37042) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jXYt0-00081A-Gq for guix-patches@gnu.org; Sat, 09 May 2020 19:28:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jXYt0-00055R-EJ for guix-patches@gnu.org; Sat, 09 May 2020 19:28:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#41164] [PATCH 2/3] graph: Add 'shortest-path'. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 09 May 2020 23:28:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 41164 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 41164@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 41164-submit@debbugs.gnu.org id=B41164.158906687519524 (code B ref 41164); Sat, 09 May 2020 23:28:02 +0000 Received: (at 41164) by debbugs.gnu.org; 9 May 2020 23:27:55 +0000 Received: from localhost ([127.0.0.1]:48584 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jXYss-00054p-TE for submit@debbugs.gnu.org; Sat, 09 May 2020 19:27:55 -0400 Received: from eggs.gnu.org ([209.51.188.92]:47708) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jXYsq-00054R-R5 for 41164@debbugs.gnu.org; Sat, 09 May 2020 19:27:53 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:34094) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jXYsl-0007Dn-Jj; Sat, 09 May 2020 19:27:47 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40868 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1jXYsk-00020y-JV; Sat, 09 May 2020 19:27:47 -0400 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sun, 10 May 2020 01:27:38 +0200 Message-Id: <20200509232739.29016-2-ludo@gnu.org> X-Mailer: git-send-email 2.26.2 In-Reply-To: <20200509232739.29016-1-ludo@gnu.org> References: <20200509232739.29016-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Spam-Score: -3.3 (---) X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Scanner: scn0 X-Spam-Score: 1.49 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Scan-Result: default: False [1.49 / 13.00]; RCVD_VIA_SMTP_AUTH(0.00)[]; GENERIC_REPUTATION(0.00)[-0.53962640777633]; MX_INVALID(1.00)[cached]; TO_DN_SOME(0.00)[]; R_SPF_ALLOW(-0.20)[+ip4:209.51.188.0/24:c]; IP_REPUTATION_HAM(0.00)[asn: 22989(0.09), country: US(-0.00), ip: 209.51.188.17(-0.54)]; DWL_DNSWL_FAIL(0.00)[209.51.188.17:server fail]; RCPT_COUNT_TWO(0.00)[2]; MAILLIST(-0.20)[mailman]; FORGED_RECIPIENTS_MAILLIST(0.00)[]; R_DKIM_NA(0.00)[]; MIME_TRACE(0.00)[0:+]; ASN(0.00)[asn:22989, ipnet:209.51.188.0/24, country:US]; TAGGED_FROM(0.00)[larch=yhetil.org]; FROM_NEQ_ENVFROM(0.00)[ludo@gnu.org,guix-patches-bounces@gnu.org]; ARC_NA(0.00)[]; URIBL_BLOCKED(0.00)[elephly.net:email,gnu.org:email]; FROM_HAS_DN(0.00)[]; MIME_GOOD(-0.10)[text/plain]; RCVD_TLS_LAST(0.00)[]; DMARC_NA(0.00)[gnu.org]; HAS_LIST_UNSUB(-0.01)[]; DNSWL_BLOCKED(0.00)[209.51.188.17:from]; MID_CONTAINS_FROM(1.00)[]; RWL_MAILSPIKE_POSSIBLE(0.00)[209.51.188.17:from]; RCVD_COUNT_SEVEN(0.00)[9]; FORGED_SENDER_MAILLIST(0.00)[] X-TUID: I+9yCheBfUx3 * 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 +;;; Copyright © 2015, 2016, 2020 Ludovic Courtès ;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; 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") -- 2.26.2