From 9eead9118dabe93d4958ae6caf81ef9871c6c62f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 11 Feb 2021 01:06:15 +0100
Subject: Initial commit.

---
 read-proc.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 129 insertions(+)
 create mode 100644 read-proc.scm

(limited to 'read-proc.scm')

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")
+
+
-- 
cgit v1.2.3