(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 "sfdp")
(gv.render g "svg" "out.svg")
;; (gv.render g "png" "out.png")