;
; -- sprouts.stklos --------------------------------------------------------
;
(define-generic add-sprouts-edge!)
(define-method add-sprouts-edge! ((sv <sequence<vertex*>>) (gv <graph-view>)
				  (k <integer>))
     (if (and (equal? (size sv) 2) 
              (< (degree (ref sv 0)) k)
              (< (degree (ref sv 1)) k) 
              (not (and (equal? (vertex-label (ref sv 0)) 
                                (vertex-label (ref sv 1)))
                        (= (degree (ref sv 0)) (- k 1)))))
	(let*  ((v1 (ref sv 0))
	        (v2 (ref sv 1))
	        (v1x (car (coords (vertex-item v1))))
	        (v1y (cadr (coords (vertex-item v1))))
	        (v2x (car (coords (vertex-item v2))))
	        (v2y (cadr (coords (vertex-item v2))))
	   	(new-v (add-vertex-item! gv (/ (+ v1x v2x) 2)(/ (+ v1y v2y)2))))
	   (add-edge-item! v1 (vertex new-v) gv)
	   (add-edge-item! (vertex new-v) v2 gv)
	   (if (= (degree v1) k) (set! (color (vertex-item v1)) "brown"))
	   (if (= (degree v2) k) (set! (color (vertex-item v2)) "brown")))))

(define-method add-sprouts-edge! ((v1 <vertex-item>) (v2 <vertex-item>) 
                                  (gv <graph-view>) (k <integer>))
	(let (sv (sequence-vertex))
	   (append! (vertex v1) sv)
	   (append! (vertex v2) sv)
	   (add-sprouts-edge! sv gv k)))

(define (link:sprouts-button-3-binding c ctab k)
  (bind c "<Button-3>" 
   (lambda (x y) 
	(set! *link:undirected-in-mixed* #f)
        (let*  ((items (find-items c 'withtag 'current))
		(gv (hash-table-get ctab c))
                (g  (slot-ref gv 'graph)))
	  (cond ((null? items) #f)
		((not (null? *link:new-edge-vertices*))
			(let ((i (find-items c 'withtag 'drag)))
				(for-each (lambda(x)
					   (destroy x)) i))
			(let* ((its (find-items c 'overlapping x y x y)))
			   (cond ((not (null? its))
			     (append! (slot-ref(link:find-vertex-in-list its) 
							'vertex)
			     	       *link:new-edge-vertices*)
			     (add-sprouts-edge! *link:new-edge-vertices* gv k)
			     (hide-vertex-labels gv)
					)))
			(clear! *link:new-edge-vertices*))
		((member "vertex" (tags (car items)))
			(append! (slot-ref (car items) 'vertex) 
						*link:new-edge-vertices*)
			(make <oval>    :parent (slot-ref gv 'graph-canvas)
                       		        :coords (list x y x y)
                                	:tags 'drag)
			(make <line>    :parent (slot-ref gv 'graph-canvas)
                                	:coords (list x y x y)
                                	:tags 'drag)))))))


(define (sprouts n k)
    (let ((g (mubingraph)))
       (if (> n 1) (add-vertices! 1 n g) (add-vertex! 1 g)) 
       (let* ((gv (show-graph g))
              (c  (slot-ref gv 'graph-canvas)))
         (link:sprouts-button-3-binding c *link:canvas-table* k)
	 (hide-labels gv))))

(provide "sprouts")
;------------------------------------------------------------------------
