
;; problems with induced-subgraph within function -spins off an infinite
;; loop of "out of space" messages.  Making an induced subgraph *outside*
;; of a function works longer (at least I haven't seen it crash yet).

(define (reset-post gv)
	(set-seed! 3)
	(klfm (slot-ref gv 'graph))
	(init-post (slot-ref gv 'graph))
)

(define (reset-unplaced-colors sv)
	(map (lambda(x) (set! (color (vertex-item x)) "blue"))
		(set-vertex->list sv)))

(define (pa gv k)
	(reset-unplaced-colors (unplaced (slot-ref gv 'graph)))
	(post-analyze (slot-ref gv 'graph) k)
	(partitioning-layout* (slot-ref gv 'graph) gv)
	(hide-edge-labels gv)
	k
)

(define (pag gv greedy-verts k)
	(reset-unplaced-colors (unplaced (slot-ref gv 'graph)))
	(post-analyze (slot-ref gv 'graph) greedy-verts  k)
	(partitioning-layout* (slot-ref gv 'graph) gv)
	(hide-edge-labels gv)
	k
)

(define (greedy-step gv)
	  (pag gv (unplaced (slot-ref gv 'graph)) 1))

(define (post-step gv)
	  (pa gv 1))

(define (post-backup gv)
	(let ((sz (size (unplaced (slot-ref gv 'graph)))))
	  (reset-graphics gv)
	  (reset-post gv)	
	  (pa gv (- (- (order (slot-ref gv 'graph)) sz) 1))))

;-----------------------------graphics---------------------------
(define (reset-color-unplaced g)
	(map (lambda (x) (set! (color (vertex-item x)) "blue"))
	     (set-vertex->list (unplaced g))))

(define (abs-max l)
	(cond ((null? l) 0)
	      ((> (abs (car l)) (abs-max (cdr l))) (abs (car l)))
	      (#t (abs-max (cdr l)))))

(define (unplaced-costs g)
	(map (lambda(x) (find-attribute 'cost x)) 
	     (set-vertex->list (unplaced g))))

(define (max-diff-vertices g)
    (let ((absunpc (abs-max (unplaced-costs g))))
	(rmfalses (map (lambda(x) (if (max-diff? x absunpc g) x #f)) 
		       (set-vertex->list (vertices g))))))

(define (unplaced-degrees g)
	(map (lambda(x) (degree x)) 
	     (max-diff-vertices g)))

(define (max-diff-max-degree-vertices g)
    (let ((mdv (max-diff-vertices g))
          (absunpd  (abs-max (unplaced-degrees g))))
	(rmfalses (map (lambda(x) (if (max-diff-max-degree? x absunpd g) x #f)) 
	               mdv))))

(define (max-diff? v absunpc g)
	(cond ((and (equal? (find-attribute 'placed v) 0)
	         (equal? (abs (find-attribute 'cost v))
                         absunpc))
	    	     #t)
	      (#t #f)))

(define (max-diff-max-degree? v absunpd g)
	(cond ((and (equal? (find-attribute 'placed v) 0)
	         (equal? (degree v)
                         absunpd))
	    	     #t)
	      (#t #f)))

(define (flash-max-diffs g)
	(map (lambda(x) (flash (vertex-item x))
			(set! (color (vertex-item x)) "red"))
	     (max-diff-vertices g)))

(define (flash-max-degrees g)
	(map (lambda(x) (flash (vertex-item x))
			(set! (color (vertex-item x)) "green"))
	     (max-diff-max-degree-vertices g)))

(define (rmfalses l)
	(cond ((null? l) '())
	      ((car l) (cons (car l) (rmfalses (cdr l))))
	      (#t (rmfalses (cdr l)))))

(define (flash-max-diff-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-x>"
		(lambda (x y)
			(flash-max-diffs (slot-ref gv 'graph)))))

(define (flash-max-diff-max-degree-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-d>"
		(lambda (x y)
			(flash-max-degrees (slot-ref gv 'graph)))))

(define (reset-post-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-r>"
		(lambda (x y)
			(reset-post gv))))

(define (post-step-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-n>"
		(lambda (x y)
			(post-step gv))))

(define (greedy-step-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-g>"
		(lambda (x y)
			(greedy-step gv))))

(define (post-backup-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-p>"
		(lambda (x y)
			(post-backup gv))))

(define (show-cuts gv)
	(map (lambda (eg)
		(let* ((vs (vertices (edge eg)))
		       (p1 (find-attribute 'partition (ref vs 0)))
		       (p2 (find-attribute 'partition (ref vs 1))))
                   (cond ((not (equal? p1 p2))
                            (set! (width eg) 4)
                            (set! (color eg) "red")
			    (jiggle eg)
			    (jiggle eg)))))
		(edges gv))
	(map (lambda (eg)
		(let* ((vs (vertices (edge eg)))
		       (p1 (find-attribute 'partition (ref vs 0)))
		       (p2 (find-attribute 'partition (ref vs 1))))
                   (cond ((not (equal? p1 p2))
                            (set! (width eg) 2)
                            (set! (color eg) "black")))))
		(edges gv)))

(define (show-cuts-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-c>"
		(lambda (x y)
			(show-cuts gv))))

(define (post-analyze-bindings gv)
		(flash-max-diff-binding gv)
		(flash-max-diff-max-degree-binding gv)
		(reset-post-binding gv)
		(post-step-binding gv)
		(greedy-step-binding gv)
		(post-backup-binding gv)
		(show-cuts-binding gv))

(provide "part")
