X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/e82e55e58c67b0215e768c4612ca542bc670f633..1306283843c6a933e0dc3bc1eedbc38b687c0d73:/guix/graph.scm diff --git a/guix/graph.scm b/guix/graph.scm index a39208e7f9..b695ca4306 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2016, 2020 Ludovic Courtès +;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix sets) + #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -37,11 +39,18 @@ node-edges node-back-edges + traverse/depth-first node-transitive-edges + node-reachable-count + shortest-path + %graph-backends + %d3js-backend %graphviz-backend graph-backend? graph-backend + graph-backend-name + graph-backend-description export-graph)) @@ -65,7 +74,7 @@ (identifier node-type-identifier) ;node -> M identifier (label node-type-label) ;node -> string (edges node-type-edges) ;node -> M list of nodes - (convert node-type-convert ;package -> M list of nodes + (convert node-type-convert ;any -> M list of nodes (default (lift1 list %store-monad))) (name node-type-name) ;string (description node-type-description)) ;string @@ -99,13 +108,13 @@ returns its back edges. NODES is taken to be the sinks of the global graph." (lambda (source target edges) (vhash-consq target source edges)))) -(define (node-transitive-edges nodes node-edges) - "Return the list of nodes directly or indirectly connected to NODES -according to the NODE-EDGES procedure. NODE-EDGES must be a one-argument -procedure that, given a node, returns its list of direct dependents; it is -typically returned by 'node-edges' or 'node-back-edges'." +(define (traverse/depth-first proc seed nodes node-edges) + "Do a depth-first traversal of NODES along NODE-EDGES, calling PROC with +each node and the current result, and visiting each reachable node exactly +once. NODES must be a list of nodes, and NODE-EDGES must be a one-argument +procedure as returned by 'node-edges' or 'node-back-edges'." (let loop ((nodes (append-map node-edges nodes)) - (result '()) + (result seed) (visited (setq))) (match nodes (() @@ -115,21 +124,113 @@ typically returned by 'node-edges' or 'node-back-edges'." (loop tail result visited) (let ((edges (node-edges head))) (loop (append edges tail) - (cons head result) + (proc head result) (set-insert head visited)))))))) +(define (node-transitive-edges nodes node-edges) + "Return the list of nodes directly or indirectly connected to NODES +according to the NODE-EDGES procedure. NODE-EDGES must be a one-argument +procedure that, given a node, returns its list of direct dependents; it is +typically returned by 'node-edges' or 'node-back-edges'." + (traverse/depth-first cons '() nodes node-edges)) + +(define (node-reachable-count nodes node-edges) + "Return the number of nodes reachable from NODES along NODE-EDGES." + (traverse/depth-first (lambda (_ count) + (+ 1 count)) + 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. ;;; (define-record-type - (graph-backend prologue epilogue node edge) + (graph-backend name description prologue epilogue node edge) graph-backend? - (prologue graph-backend-prologue) - (epilogue graph-backend-epilogue) - (node graph-backend-node) - (edge graph-backend-edge)) + (name graph-backend-name) + (description graph-backend-description) + (prologue graph-backend-prologue) + (epilogue graph-backend-epilogue) + (node graph-backend-node) + (edge graph-backend-edge)) + +(define %colors + ;; See colortbl.h in Graphviz. + #("red" "magenta" "blue" "cyan3" "darkseagreen" + "peachpuff4" "darkviolet" "dimgrey" "darkgoldenrod")) + +(define (pop-color hint) + "Return a Graphviz color based on HINT, an arbitrary object." + (let ((index (hash hint (vector-length %colors)))) + (vector-ref %colors index))) (define (emit-prologue name port) (format port "digraph \"Guix ~a\" {\n" @@ -140,13 +241,100 @@ typically returned by 'node-edges' or 'node-back-edges'." (format port " \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%" id label)) (define (emit-edge id1 id2 port) - (format port " \"~a\" -> \"~a\" [color = red];~%" - id1 id2)) + (format port " \"~a\" -> \"~a\" [color = ~a];~%" + id1 id2 (pop-color id1))) (define %graphviz-backend - (graph-backend emit-prologue emit-epilogue + (graph-backend "graphviz" + "Generate graph in DOT format for use with Graphviz." + emit-prologue emit-epilogue emit-node emit-edge)) + +;;; +;;; d3js export. +;;; + +(define (emit-d3js-prologue name port) + (format port "\ + + + + + + + + + " + (search-path %load-path "graph.js"))) + +(define (emit-d3js-node id label port) + (format port "\ +nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length}; +nodeArray.push(nodes[\"~a\"]);~%" + id id label id)) + +(define (emit-d3js-edge id1 id2 port) + (format port "links.push({\"source\": \"~a\", \"target\": \"~a\"});~%" + id1 id2)) + +(define %d3js-backend + (graph-backend "d3js" + "Generate chord diagrams with d3js." + emit-d3js-prologue emit-d3js-epilogue + emit-d3js-node emit-d3js-edge)) + + + +;;; +;;; Cypher export. +;;; + +(define (emit-cypher-prologue name port) + (format port "")) + +(define (emit-cypher-epilogue port) + (format port "")) + +(define (emit-cypher-node id label port) + (format port "MERGE (p:Package { id: ~s }) SET p.name = ~s;~%" + id label )) + +(define (emit-cypher-edge id1 id2 port) + (format port "MERGE (a:Package { id: ~s });~%" id1) + (format port "MERGE (b:Package { id: ~s });~%" id2) + (format port "MATCH (a:Package { id: ~s }), (b:Package { id: ~s }) CREATE UNIQUE (a)-[:NEEDS]->(b);~%" + id1 id2)) + +(define %cypher-backend + (graph-backend "cypher" + "Generate Cypher queries." + emit-cypher-prologue emit-cypher-epilogue + emit-cypher-node emit-cypher-edge)) + + + +;;; +;;; Shared. +;;; + +(define %graph-backends + (list %graphviz-backend + %d3js-backend + %cypher-backend)) + (define* (export-graph sinks port #:key reverse-edges? node-type @@ -155,7 +343,7 @@ typically returned by 'node-edges' or 'node-back-edges'." given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is true, draw reverse arrows." (match backend - (($ emit-prologue emit-epilogue emit-node emit-edge) + (($ _ _ emit-prologue emit-epilogue emit-node emit-edge) (emit-prologue (node-type-name node-type) port) (match node-type