;; directed graph processes
#lang scheme/base

(provide (all-defined-out))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a node
; (the desc is for 'user defined' data

(define (make-node name desc)
  (list name desc))

(define (node-name node)
  (car node))

(define (node-desc node)
  (cadr node))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; an edge

(define (make-edge from to desc)
  (list from to desc))

(define (edge-from edge)
  (car edge))

(define (edge-to edge)
  (cadr edge))

(define (edge-desc edge)
  (list-ref edge 2))

(define (edge=? a b)
  (or 
   (and (eq? (edge-from a) (edge-from b)) (eq? (edge-to a) (edge-to b)))
   (and (eq? (edge-to a) (edge-from b)) (eq? (edge-from a) (edge-to b)))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; base graph functions

(define (make-graph nodes edges)
  (list nodes edges))

(define (graph-nodes graph)
  (car graph))

(define (graph-edges graph)
  (cadr graph))

(define (graph-merge a b)
  (list (append (graph-nodes a) (graph-nodes b))
        (append (graph-edges a) (graph-edges b))))

(define (graph-find-node graph name)
  (assq name (graph-nodes graph)))

(define (graph-find-edge graph edge)
  (foldl
      (lambda (oedge r)
      (if (edge=? edge oedge) #t r))
    #f
    (graph-edges graph)))
  
(define (graph-find-node-edges graph name)
  (foldl
   (lambda (edge r)
     (if (or (eq? (edge-from edge) name) 
             (eq? (edge-to edge) name))
         (cons edge r) r))
   '()
   (graph-edges graph)))

(define (graph-nodes-connected? graph namea nameb)
  (foldl
   (lambda (edge r)
     (if (or (eq? (edge-from edge) nameb)
             (eq? (edge-to edge) nameb))
         edge r))
   #f
   (graph-find-node-edges graph namea)))

(define (graph-find-edges-to-node graph name)
  (foldl
   (lambda (edge r)
     (if (eq? (edge-to edge) name) (cons edge r) r))
   '()
   (graph-edges graph)))

(define (graph-find-edges-from-node graph name)
  (foldl
   (lambda (edge r)
     (if (eq? (edge-from edge) name) (cons edge r) r))
   '()
   (graph-edges graph)))

(define (graph-remove-unconnected-edges graph)
  (make-graph
   (graph-nodes graph)
   (filter
    (lambda (edge)
      (and (graph-find-node graph (edge-from edge))
           (graph-find-node graph (edge-to edge))))
    (graph-edges graph))))

(define (graph-remove-node graph name)
  (make-graph 
   (filter
    (lambda (node)
      (not (eq? (node-name node) name)))
    (graph-nodes graph))
   (filter
    (lambda (edge)
      (not (or (eq? (edge-from edge) name)
               (eq? (edge-to edge) name))))
    (graph-edges graph))))

(define (graph-remove-edge graph edge)
  (make-graph
   (graph-nodes graph)
   (filter
    (lambda (iedge)
      (not (edge=? iedge edge)))
    (graph-edges graph))))

(define (graph-add-node graph parent-node node)
  (graph-merge 
   graph 
   (make-graph (list node)
               (list (make-edge (node-name node)
                                (node-name parent-node))))))

(define (graph-add-edge graph from to)
  (graph-merge 
   graph 
   (make-graph '()
               (list (make-edge from to)))))

(define (graph-node-get-children graph name)
  (map
   (lambda (edge)
     (graph-find-node graph (edge-to edge)))
   (graph-find-edges-from-node graph name)))

(define (graph-display-nodes graph)
  (for-each
   (lambda (node)
     (printf "node: ~a desc:~a~n" (node-name node) (node-desc node)))
   (graph-nodes graph))
    (display (length (graph-nodes graph)))(newline))

(define (graph-display-edges graph)
  (for-each
   (lambda (edge)
     (printf "~a -> ~a~n" (edge-from edge) (edge-to edge)))
   (graph-edges graph)))

(define (graph-output-dot graph filename)
  (let ((f (open-output-file filename)))
    (display "digraph {" f)
    (for-each
     (lambda (edge)
       (printf "\"~a\" -> \"~a\"~n" (edge-from edge) (edge-to edge)))
     (graph-edges graph))
    (close-output-port f)))