From patchwork Sat May 9 23:27:38 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 21962 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 14AD827BBE3; Sun, 10 May 2020 00:28:09 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 545D727BBE1 for ; Sun, 10 May 2020 00:28:08 +0100 (BST) Received: from localhost ([::1]:49812 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jXYt5-00075c-PR for patchwork@mira.cbaines.net; Sat, 09 May 2020 19:28:07 -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 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * 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")