Complete rewrite of use2dot

Old version tried to leverage guile's built in use2dot, and then
modified it to fit my needs. This new version implements its own
use2dot, using the same underlying mechanism as guile's built in,
giving us FAR greater flexability.

4 files changed, 249 insertions, 50 deletions

diff --git a/use2dot/change_graph.py b/use2dot/change_graph.py
deleted file mode 100755
index 50d1c34f..00000000
--- a/use2dot/change_graph.py
+++ /dev/null
@@ -1,40 +0,0 @@
-#!/usr/bin/env python3
-
-import re
-import colorsys
-import hashlib
-import sys
-
-def md5(str):
-    return hashlib.md5(str.encode("UTF-8")).hexdigest()
-
-def rgb(str):
-    return md5(str)[0:6]
-
-def main(args):
-
-    if len(args) < 3:
-        print("Usage: ./change_graph.py <infile> <outfile>")
-        return
-
-    [_, infile, outfile, *rest] = args
-
-    with open(infile) as f:
-        lines = f.readlines()
-        # [3:-1]
-
-    f = open(outfile, 'w')
-
-    for line in lines:
-        m = re.search('^( *"\(([^)]*)\)" -> "(\([^)]*\))");', line)
-        if m:
-            f.write(f'{m.group(1)} [color="#{rgb(m.group(2))}"];\n')
-        else:
-            f.write(line)
-        # colorsys.hsv_to_rgb(
-
-
-#  "(server macro)" -> "(ice-9 regex)";
-
-if __name__ == "__main__":
-    main(sys.argv)
diff --git a/use2dot/gen-use.scm b/use2dot/gen-use.scm
new file mode 100755
index 00000000..8475d71e
--- /dev/null
+++ b/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/use2dot/gen_use_graph b/use2dot/gen_use_graph
deleted file mode 100755
index 51ee23b4..00000000
--- a/use2dot/gen_use_graph
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/bash
-
-dir=$(mktemp -d)
-here=$(dirname $(realpath $0))
-
-guild use2dot -m '(calp main)' -- `find module -name \*.scm` > $dir/use.dot
-$here/change_graph.py $dir/use.dot $dir/use2.dot
-grep -v '\(srfi\|ice-9\|(util)\)' $dir/use2.dot > $dir/use3.dot
-
-fdp $dir/use3.dot -Tpdf -o use.pdf
diff --git a/use2dot/graphviz.scm b/use2dot/graphviz.scm
new file mode 100644
index 00000000..0c75f3ff
--- /dev/null
+++ b/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")