;********************************************************************
; water.stklos
;             show the water network in an attractive way
;               unix> Link
;               (load "water.stklos")
;	        (define g (load-graph "nc-whatever-.g"))
;		(define gv (show-sensor-gv g 'morning))
;		(morning gv)
;		(day gv)
;		(evening gv)
;		(night gv)
;		; if too complicated:
;  		(collapse-sector gv "green") 
;********************************************************************

(require "daily-flow")

(define (id-sensor-edges gv)
        (map (lambda(e) 
                (let* ( (mark (find-attribute 'sensor (edge e)))
                      )
                   (cond ((= mark 1) (set! (width e) 7)
                                     (set! (color e) "black")))))
             (edges gv)))

(define (color-vertices gv)
        (map (lambda(v c)
                (set! (color v) c))
             (vertices gv)
             '("red" "green" "green" "green" "green"
               "blue" "blue" "brown" "blue" "brown"
               "blue" "blue" "blue"   "blue" "brown"
               "green" "green" "green" "green" "blue"
               "blue"  "brown" "green" "brown" "green"
               "green" "green" "green" "green" "brown"
               "green" "green" "brown" "brown" "green"
               "brown")))

(define (color-edges gv)
        (map (lambda (e)
                (let*  ( (vs (vertices e))
                         (v1    (car vs))
                         (v2    (cadr vs)))
                     (cond  ( (equal? (color v1) (color v2)) 
					(set! (color e) (color v1))))))
             (edges gv)))

(define (label-vertices gv) 
        (map (lambda (v)
                (set! (vertex-label v) 
			(find-string-attribute 'name (vertex v))))
             (vertices gv))
        (show-vertex-labels gv))

(define (sensor-picture gv time)
        (spring-layout* (graph gv) gv)
        (hide-edge-labels gv)
        (show-vertex-labels gv)
        (label-vertices gv)
        (color-vertices gv)
        (color-edges gv)
        (id-sensor-edges gv)
        (cond  ((equal? time 'morning) (morning gv))
               ((equal? time 'day)     (day gv))
               ((equal? time 'evening) (evening gv))
               ((equal? time 'night)   (night gv))))

(define (snapshot gv time fname-root)
        (sensor-picture gv time)
	(update)
	(graph->postscript gv (string-append fname-root "-" 
                                             (symbol->string time) ".ps")))

(define (daily-snapshots gv fname-root)
        (snapshot gv 'morning fname-root)
        (snapshot gv 'day fname-root)
        (snapshot gv 'evening fname-root)
        (snapshot gv 'night fname-root))

(define (root-filename facil time-of-day trial-no prob num-sensors)
            (string-append "nc-" (number->string facil) "-" 
                                 (number->string time-of-day) "-" 
                                 (number->string trial-no) "-"
                                 prob "-"
                                 (number->string num-sensors)))

(define attacks '(0 1 2 3 4))   ; varied watertower neighborhood town industry
(define probs '("0.050000000000000003" "0.10000000000000001" "0.25"))
(define trials '(0 1))
(define nums-of-sensors '(3 5 7))

(define (sensor-gv g) 
              (make <graph-view> :graph g :layout 'random))

(define (show-sensor-gv g time) 
              (sensor-picture (make <graph-view> :graph g :layout 'random)
			time))

(define (gen-psfiles attack trial prob num-sensors)
        (let* ( (fname0 (root-filename 1 attack trial prob num-sensors))
                (gv0  (sensor-gv (load-graph (string-append fname0 ".g")))))
              (daily-snapshots gv0 fname0)))


(define (gen-psfiles-all-sensors attack trial prob)
        (map (lambda (num-sensors) (gen-psfiles attack trial prob num-sensors))
             nums-of-sensors))

(define (gen-psfiles-all-probs attack trial)
        (map (lambda (prob) 
                     (gen-psfiles-all-sensors attack trial prob))
             probs))

(define (gen-psfiles-all-trials attack)
        (map (lambda (trial) 
                     (gen-psfiles-all-probs attack trial))
             trials))

(define (gen-all-psfiles)
        (map (lambda (attack) 
                     (gen-psfiles-all-trials attack ))
             attacks))

(define (other ei vi)
        (let ((vl (vertices ei)))
              (if (equal? (car vl) vi) 
                  (cadr vl)
                  (car vl))))

;
;  I shouldn't have had to rewrite this, but I couldn't find it
;
(define (incident-edge-items vi)
        (map edge-item (set-edge->list (incident-edges (vertex vi)))))

(define (links-v1-v2 v1 v2 ei)
        (let* ((ei1  (car (vertices ei)))
               (ei2  (cadr (vertices ei))))
          (if (or (and (equal? v1 ei1) (equal? v2 ei2))
                  (and (equal? v1 ei2) (equal? v2 ei1)))
              #t #f)))

(define (select-v1-v2-edge-items v1 v2 elist)
        (cond ((null? elist) '())
              ((links-v1-v2 v1 v2 (car elist)) (cons (car elist) 
                                               (select-v1-v2-edge-items v1 v2
							(cdr elist))))
              (#t (select-v1-v2-edge-items v1 v2 (cdr elist)))))

(define (all-edge-items-between v1 v2)
        (let*  ((elist1 (incident-edge-items v1))
                (elist2 (incident-edge-items v2)))
            (select-v1-v2-edge-items v1 v2 (append elist1 elist2))))

(define (sensor-edge-in elist)
        (cond ((null? elist) #f)
              ((= (find-attribute 'sensor (edge (car elist))) 1) #t)
              (#t (sensor-edge-in (cdr elist)))))

(define (can-collapse-edge ei sector-color)
        (let* ((v1 (car (vertices ei)))
               (v2 (cadr (vertices ei)))
               (connecting (all-edge-items-between v1 v2)))
            (if (and (equal? sector-color (color v1)) 
                     (equal? sector-color (color v2)) 
                     (not (sensor-edge-in connecting)))
                #t #f)))

(define (can-be-collapsed ei-list sector-color)
        (cond ((null? ei-list) #f)
              ((can-collapse-edge  (car ei-list) sector-color) (car ei-list))
              (#t (can-be-collapsed (cdr ei-list) sector-color))))

(define (collapse-sector-edge ei sector-color)
        (let* ((vlist (vertices ei))
               (v1    (car vlist))
               (v2    (cadr vlist)))
            (let*((s1 (size v1))
                  (s2 (size v2))
                  (sv (collapse-subgraph (list v1 v2) (graph-view ei))))
                   (set! (color sv) sector-color)
                   (set! (size sv) (min (+ s1 s2) 25))
                   (map (lambda (inc-edge) 
                                (if (equal? sector-color 
                                            (color (other inc-edge sv)))
                                          (set! (color inc-edge) sector-color)))
                        (incident-edge-items sv)) sv)))

(define (collapse-sector gv sector-color)
        (while (can-be-collapsed (edges gv) sector-color)
               (collapse-sector-edge (can-be-collapsed (edges gv) sector-color)
                                     sector-color)
               (id-sensor-edges gv)
        ))

(define (collapse-sectors gv)
        (collapse-sector gv "blue")
        (collapse-sector gv "green")
        (collapse-sector gv "brown")
        (collapse-sector gv "red")
        (hide-labels gv))