Initial commit.

3 files changed, 216 insertions, 0 deletions

diff --git a/graphviz.scm b/graphviz.scm
new file mode 100644
index 0000000..0c75f3f
--- /dev/null
+++ b/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")
diff --git a/read-proc.scm b/read-proc.scm
new file mode 100644
index 0000000..9eda8d1
--- /dev/null
+++ b/read-proc.scm
@@ -0,0 +1,129 @@
+(use-modules (ice-9 ftw)
+             (srfi srfi-1)
+             ((graphviz) :prefix gv.))
+
+(define g (gv.graph "test-graph"))
+
+(define (show g)
+  (gv.layout g "dot")
+  (let* ((filename (tmpnam)))
+    (gv.render g "png" filename)
+    (display (format #f  "#<Image: ~a>~%" filename))))
+
+(define (numeric-string< a b)
+  (< (string->number a) (string->number b)))
+
+(use-modules (ice-9 pretty-print))
+(define pp pretty-print)
+
+(define processes (scandir "/proc" string->number numeric-string<))
+(define (fds pid) (scandir (format #f "/proc/~a/fd" pid) string->number numeric-string<))
+(define (fd-link pid fd) (catch 'system-error (lambda () (readlink (format #f "/proc/~a/fd/~a" pid fd)))
+                           (lambda args "#f")))
+(define (process-attribute pid field)
+  (call-with-input-file (format #f "/proc/~a/~a" pid field)
+    (@ (ice-9 rdelim) read-line)))
+
+(define (process-cmd pid)
+  (cond ((process-attribute pid "cmdline")
+         (negate eof-object?) => identity)
+        (else (process-attribute pid "comm"))))
+
+
+(use-modules (ice-9 hash-table))
+(define freqs (make-hash-table))
+
+;; (gv.setv g "nodesep" "1")
+(gv.setv g "overlap" "false")
+;; (gv.setv g "splines" "line")
+(gv.setv g "K" "10.0")
+;; (gv.setv g "sep" "+1")
+;; (gv.setv g "pack" "true")
+
+(use-modules (rnrs records syntactic))
+
+(define-record-type proc-node
+  (fields (immutable name)
+          (mutable files)))
+(define-record-type file-node
+  (fields (immutable name)
+          (mutable procs)))
+
+(define file-nodes (make-hash-table))
+
+(define (get-file-node proc name)
+  (define fn (hash-ref file-nodes name (make-file-node name '())))
+  (file-node-procs-set! fn (cons proc (file-node-procs fn)))
+  (hash-set! file-nodes name fn)
+  fn)
+
+(define next-color
+  (let ((lst (circular-list "cyan" "red" "green" "blue" "orange" "purple" "pink" "yellow"))) 
+    (lambda () (set! lst (cdr lst)) (car lst))))
+
+(define proc-nodes
+  (map (lambda (pid)
+         (define pn (make-proc-node (format #f "~a: ~a" pid (process-cmd pid)) '()))
+         (proc-node-files-set!
+          pn
+          (cond ((fds pid)
+                 => (lambda (lst)
+                      (map (lambda (fd)
+                             (define target (fd-link pid fd))
+                             (hash-set! freqs target (1+ (hash-ref freqs target 0)))
+                             (get-file-node pn target))
+                           lst)))
+                (else '()))))
+       processes))
+
+(define colored (make-hash-table))
+
+;;; Split file nodes into those that many have open, and those that only a few have open
+
+(define-values (popular-files loser-files)
+  (span (lambda (fn) (< 30 (length (file-node-procs fn))))
+        (map (lambda (name) (hash-ref file-nodes name))
+             (map car
+                  (sort (hash-map->list cons freqs)
+                        (lambda (a b) (> (cdr a) (cdr b))))))))
+
+;;; This allows us to focus on the "popular" nodes, and given them a subpgrah and color each
+
+(for-each (lambda (fn)
+            (define c (next-color))
+            (let ((sg (gv.graph g (symbol->string (gensym "graph")))))
+              ;; (gv.setv sg "layout" "circo")
+              (gv.setv sg "style" "dotted")
+              (let ((fn-node (gv.node sg (file-node-name fn))))
+                (gv.setv fn-node "fillcolor" c)
+                (gv.setv fn-node "style" "filled")
+                (for-each (lambda (proc)
+                            (define gn-node (gv.node sg (proc-node-name proc)))
+                            (define edge (gv.edge fn-node gn-node))
+                            (gv.setv edge "color" c)
+                            (gv.setv gn-node "shape" "box")
+                            )
+                          (file-node-procs fn)))))
+          popular-files)
+
+;;; Then just place the impopular nodes anywhere.
+
+;;; Note that this fails to account for busy programs, opening ALL THE FILES!
+
+(for-each (lambda (fn)
+            (let ((fn-node (gv.node g (file-node-name fn))))
+              (for-each (lambda (proc)
+                          (define gn-node (gv.node g (proc-node-name proc)))
+                          (define edge (gv.edge fn-node gn-node))
+                          (gv.setv gn-node "shape" "box")
+                          )
+                        (file-node-procs fn)))
+
+            )
+          loser-files)
+
+(gv.layout g "neato")
+(gv.render g "dot" "out.dot")
+;; (gv.render g "png" "out.png")
+
+
diff --git a/run.sh b/run.sh
new file mode 100755
index 0000000..bdb475c
--- /dev/null
+++ b/run.sh
@@ -0,0 +1,3 @@
+#!/bin/bash
+sudo GUILE_LOAD_PATH=. guile -s read-proc.scm
+neato -Tsvg out.dot > out.svg