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 ++++++++++++++++++++++ use2dot/gen-use.scm | 165 ------------------------------------------- use2dot/graphviz.scm | 84 ---------------------- 4 files changed, 249 insertions(+), 249 deletions(-) create mode 100755 scripts/use2dot/gen-use.scm create mode 100644 scripts/use2dot/graphviz.scm delete mode 100755 use2dot/gen-use.scm delete mode 100644 use2dot/graphviz.scm 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") diff --git a/use2dot/gen-use.scm b/use2dot/gen-use.scm deleted file mode 100755 index 8475d71e..00000000 --- a/use2dot/gen-use.scm +++ /dev/null @@ -1,165 +0,0 @@ -#!/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/use2dot/graphviz.scm b/use2dot/graphviz.scm deleted file mode 100644 index 0c75f3ff..00000000 --- a/use2dot/graphviz.scm +++ /dev/null @@ -1,84 +0,0 @@ -;;; 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