From bbcbee79d885904fbb1bcf20f77704562f624ef0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 31 Jan 2022 20:03:51 +0100 Subject: Move use2dot into scripts subdir. --- scripts/use2dot/gen-use.scm | 165 +++++++++++++++++++++++++++++++++++++++++++ scripts/use2dot/graphviz.scm | 84 ++++++++++++++++++++++ 2 files changed, 249 insertions(+) create mode 100755 scripts/use2dot/gen-use.scm create mode 100644 scripts/use2dot/graphviz.scm (limited to 'scripts') diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm new file mode 100755 index 00000000..8475d71e --- /dev/null +++ b/scripts/use2dot/gen-use.scm @@ -0,0 +1,165 @@ +#!/usr/bin/guile -s +!# + +(add-to-load-path (dirname (current-filename))) + +(use-modules ((scripts frisk) :select (make-frisker edge-type edge-up + edge-down)) + (srfi srfi-1) + (ice-9 ftw) + (ice-9 regex) + (ice-9 match) + ((graphviz) :prefix gv.) + ) + +(define scan (make-frisker `(default-module . (calp main)))) + +(define re (make-regexp "\\.scm$")) + +(define lst '()) + +(ftw "module" (lambda (filename statinfo flag) + (cond ((and (eq? flag 'regular) + (regexp-exec re filename)) + => (lambda (m) + (set! lst (cons filename lst)) + #t + )) + (else #t)))) + + + +(define files lst) + +(define our-modules + (filter identity + (map (lambda (file) + (match (call-with-input-file file read) + (('define-module (module ...) _ ...) + module) + (_ #f))) + files))) + +(define graph (gv.digraph "G")) +(gv.setv graph "color" "blue") +(gv.setv graph "compound" "true") +(gv.setv graph "overlap" "prism") +;; (gv.setv graph "bgcolor" "blue") + +(define count 0) + +(define colors + '("red" "green" "blue")) + +(define rem our-modules) + +;; (for-each (lambda (key) +;; +;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) +;; +;; (define-values (use rem*) (partition (lambda (mod) (eq? key (car mod))) rem)) +;; (set! rem rem*) +;; +;; ;; (gv.setv subgraph "rankdir" "TB") +;; (gv.setv subgraph "color" (list-ref colors count)) +;; +;; (for-each (lambda (name) +;; (gv.node subgraph (format #f "~a" name))) +;; use) +;; +;; (set! count (1+ count)) +;; ) +;; '(calp vcomponent)) + +;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) +;; +;; ;; (gv.setv subgraph "rankdir" "TB") +;; (gv.setv subgraph "color" (list-ref colors count)) +;; +;; (for-each (lambda (name) +;; (gv.node subgraph (format #f "~a" name))) +;; rem) + +(define subgraph (gv.graph graph (format #f "cluster_~a" 0))) + +;; (gv.setv subgraph "rankdir" "TB") +(gv.setv subgraph "color" "Red") + +(define subgraphs (make-hash-table)) + +(for-each (lambda (name) + (let ((g (hashq-ref subgraphs (car name) + (gv.graph graph (format #f "cluster_~a" (car name)))))) + (hashq-set! subgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (lambda (x) (eq? 'calp (car x))) + our-modules)) + + +(define calp-base (gv.graph graph "cluster_1")) +(define calpgraphs (make-hash-table)) + +(for-each (lambda (name) + (let ((g (hashq-ref calpgraphs (cadr name) + (gv.graph + ;; calp-base + graph + (format #f "cluster_~a" (cadr name)))))) + (hashq-set! calpgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (compose null? cdr) + (filter (lambda (x) (eq? 'calp (car x))) + our-modules))) + + +(define (remove-edges blacklist edges) + (remove (lambda (edge) + (or (member (edge-up edge) blacklist) + (member (edge-down edge) blacklist))) + edges)) + + + + + +(for-each (lambda (edge) + (let ((gv-edge (gv.edge graph + (format #f "~a" (edge-down edge)) + (format #f "~a" (edge-up edge)) + ))) + (when (and (eq? 'calp (car (edge-up edge))) + (not (eq? 'calp (car (edge-down edge))))) + (gv.setv gv-edge "color" "red")) + (when (and (memv (car (edge-up edge)) '(vcomponent calp)) + (not (memv (car (edge-down edge)) '(vcomponent calp )))) + (gv.setv gv-edge "color" "blue")) + )) + (remove-edges '((srfi srfi-1) + (srfi srfi-9) + (srfi srfi-26) + (srfi srfi-41) + + (ice-9 match) + (ice-9 format) + + (datetime) + (vcomponent) + (calp util) + ) + ((scan files) 'edges))) + +(gv.layout graph "fdp") +(gv.render graph "pdf" "graph.pdf") + + +(display "done\n") diff --git a/scripts/use2dot/graphviz.scm b/scripts/use2dot/graphviz.scm new file mode 100644 index 00000000..0c75f3ff --- /dev/null +++ b/scripts/use2dot/graphviz.scm @@ -0,0 +1,84 @@ +;;; Copyright © 2016 Roel Janssen +;;; +;;; This program is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see . + +;;; https://github.com/roelj/graphviz-guile/blob/master/graphviz.scm + +(define-module (graphviz) + #:export (;; New graphs + graph + digraph + strictgraph + strictdigraph + readstring + read + + ;; New nodes/edges + node + edge + + ;; Setting/getting attribute values + setv + getv + + ;; Finding and obtaining names + nameof + findsubg + findnode + findedge + findattr + + ;; Graph navigators + headof + tailof + graphof + rootof + + ;; Obtain handles of proto node/edge for setting attribute values + protonode + protoedge + + ;; Iterators + ok + firstsubg + nextsubg + firstsupg + nextsupg + firstedge + nextedge + firstout + nextout + firsthead + nexthead + firstin + nextin + firstnode + nextnode + firstattr + nextattr + + ;; Remove graph objects + rm + + ;; Layout + layout + render + renderresult + renderchannel + renderdata + write)) + +;; (load-extension "libgv_guile.so" "SWIG_init") + +(load-extension "/usr/lib/graphviz/guile/libgv_guile.so" "SWIG_init") -- cgit v1.2.3