Move use2dot into scripts subdir.

2 files changed, 249 insertions, 0 deletions

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 <roel@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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")