aboutsummaryrefslogtreecommitdiff
path: root/scripts/use2dot/gen-use.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/use2dot/gen-use.scm')
-rwxr-xr-xscripts/use2dot/gen-use.scm141
1 files changed, 0 insertions, 141 deletions
diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm
deleted file mode 100755
index 6c621fdd..00000000
--- a/scripts/use2dot/gen-use.scm
+++ /dev/null
@@ -1,141 +0,0 @@
-#!/usr/bin/guile -s
-!#
-
-(add-to-load-path (dirname (current-filename)))
-(add-to-load-path (dirname (dirname (current-filename))))
-
-(use-modules ((scripts frisk) :select (make-frisker edge-type edge-up
- edge-down))
- (srfi srfi-1)
- ((graphviz) :prefix gv.)
- (all-modules)
- )
-
-(define scan (make-frisker `(default-module . (calp main))))
-
-(define-values (files our-modules)
- (all-modules-under-directory "module"))
-
-(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)
- (hnh util)
- )
- ((scan files) 'edges)))
-
-(gv.layout graph "fdp")
-(gv.render graph "pdf" "graph.pdf")
-
-
-(display "done\n")