;; Copyright (C) 1996 DIMACS Center, Rutgers, The State University of New Jersey
;; Author(s): Jonathan Berry

;; This software is copyrighted by the DIMACS Center at Rutgers, The State
;; University of New Jersey.  IT IS PROVIDED AS IS, AND THE AUTHORS, DIMACS, AND
;; RUTGERS, THE STATE UNIVERSITY OF NEW JERSEY  DISCLAIM
;; ALL LIABILITY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
;; DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
;; DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.

;; THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
;; IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
;; NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
;; MODIFICATIONS.

;; The authors hereby grant permission to use, copy, modify, distribute,
;; and license this software and its documentation for any purpose, provided
;; that existing copyright notices are retained in all copies and that this
;; notice is included verbatim in any distributions. No written agreement,
;; license, or royalty fee is required for any of the authorized uses.
;; Modifications to this software may be copyrighted by their authors
;; and need not follow the licensing terms described here, provided that
;; the new terms are clearly indicated on the first page of each file where
;; they apply.

;; Last File Update: 31-Jul-1996
;; 

(require "Tk-classes")
(require "Canvas")
(require "graph-menu")

;----------------------------------------------------------------------
; *link:vertex-placeholder*:  	global <oval> object used to mark old
;				location of a vertex while user drags
;				the vertex around.
(define *link:vertex-placeholder* #f)
;----------------------------------------------------------------------

;----------------------------------------------------------------------
; *link:canvas-table*:  global hash table used to look up 
;			<graph-view> objects by associated canvas
;
(define *link:canvas-table* (make-hash-table))
;----------------------------------------------------------------------

;----------------------------------------------------------------------
; *graph-view-table*:global hash table used to look up <graph-view> 
;			  objects by name
;  WILL CHANGE TO *link:graph-view-table* when I recompile
;
(define *graph-view-table* (make-hash-table))
;----------------------------------------------------------------------

;;;
;;; viewing transformations - layout algorithms specify 
;;;			      world coords (bottom left (0,0) upper right (1,1))

(define (world-to-view world-x world-y gv)
	(let* ((view-x-max (slot-ref gv 'xpixels))
	       (view-y-max (slot-ref gv 'ypixels))
	       (x (* world-x view-x-max))
	       (y (- view-y-max (* world-y view-y-max)))
	       (vx (cond ((< x 0) 0)
			((> x view-x-max) view-x-max)
			(#t x)))
	       (vy (cond ((< y 0) 0)
			((> y view-y-max) view-y-max)
			(#t y))))
	     (list vx vy)))

(define (view-to-world view-x view-y gv)
	(let* ((view-x-max (slot-ref gv 'xpixels))
	       (view-y-max (slot-ref gv 'ypixels))
	       (x (/ view-x view-x-max))
	       (y (/ (- view-y-max view-y) view-y-max))
	       (wx (cond ((< x 0.0) 0.0)
			((> x 1.0) 1.0)
			(#t x)))
	       (wy (cond ((< y 0.0) 0.0)
			((> y 1.0) 1.0)
			(#t y))))
	  (list wx wy)))

(require "graph-edit")
(require "edge")


;;;
;;; labels for extracting graphics given graph-objects
;;; (e.g. <vertex-item> given <vertex*>)
;;;
; <label-object> :used only by the C++ animation code
(define-class <label-object> () ((objlabel :getter objlabel 
					   :init-keyword :objlabel))) 
(define-generic get-label)
(define-method  get-label ((v <vertex*>)) (vertex-label v))
(define-method  get-label ((l <label-object>)) (slot-ref l 'objlabel))
(define-method  get-label ((e <edge*>)) (edge-label e))

;;;
;;; vertex and edge movement 
;;;

(define (update-vertex-coords vg view-x view-y)
	 (let* ((gcanv (slot-ref vg 'parent))
		(gv (hash-table-get *link:canvas-table* gcanv))
		(wdth  (slot-ref gv 'xpixels))
		(hgt   (slot-ref gv 'ypixels))
		(os (quotient (slot-ref vg 'size) 2))
		(offset (+ os 5))
	    	(x (cond ((< view-x 0) offset)
			 ((> view-x wdth) (- wdth offset))
			 (#t view-x)))
	    	(y (cond ((< view-y 0) offset)
			 ((> view-y hgt) (- hgt offset))
			 (#t view-y))))
            (slot-set! (slot-ref vg 'oval-item) 'coords
				(list (- x os) (- y os) (+ x os) (+ y os)))
            (slot-set! (slot-ref vg 'txt-item) 'coords 
				(list (+ os 2 x) (+ os 2 y)))))

(define (update-oval-item-coords w view-x view-y)
	 (let* ((gcanv (slot-ref w 'parent))
		(gv (hash-table-get *link:canvas-table* gcanv))
		(vttab (slot-ref gv 'vertex-tag-table))
		(vg (hash-table-get vttab (cid w))))
	  (update-vertex-coords vg view-x view-y)))

(define (update-incoming-segment w x y r verts segs vtab)
	   (let* ((seg1 (list-ref segs (- r 1)))
		  (s1(slot-ref seg1 'line-item))
	   	  (v1 (ref verts (- r 1)))
	   	  (vg1 (hash-table-get vtab v1))
		  (p2 (offset-point w vg1)))
		(cond ((not (smooth s1))            ; star-draw
			(let ((cs (coords s1)))
			   (slot-set! s1 'coords 
				(append (list (car cs) (cadr cs) (caddr cs)
					      (cadddr cs)) 
					p2))))
		       (#t 			   
			(let* ((c1 (slot-ref vg1 'coords))
		  	  (mid1 (list (/(+ (car c1) x)2) (/(+(cadr c1) y)2)))
		  	  (p1 (offset-point vg1 w)))
			(slot-set! (slot-ref seg1 'txt-item) 'coords mid1)
			(slot-set! s1 'coords (append p1 mid1 p2)))))))

(define (update-outgoing-segment w x y r verts segs vtab)
	  (let* ((seg2 (list-ref segs r))
		  (s2(slot-ref seg2 'line-item))
	   	  (v2 (ref verts (+ r 1)))
	   	  (vg2 (hash-table-get vtab v2))
		  (p1 (offset-point w vg2)))
		(cond ((not (smooth s2))            ; star-draw
			   (slot-set! s2 'coords 
				(append p1 (list-tail (coords s2) 2))))
		       (#t 			   
			(let*  ((c2 (slot-ref vg2 'coords))
		  	        (mid2 (list (/(+ (car c2) x)2) 
					    (/(+(cadr c2) y)2)))
		  		(t2(slot-ref seg2 'txt-item))
		  		(p2 (offset-point vg2 w)))
			   (slot-set! t2 'coords mid2)
			   (slot-set! s2 'coords (append p1 mid2 p2)))))))

(define (update-edges w x y v vtab etab edges)
	(cond ((not (null? (hash-table->list etab)))
	    (map (lambda (e) 
		    (let* ((eg (hash-table-get etab e)) 
			   (verts (vertices e))
			   (sz    (collection-vertex-size verts))
			   (r     (collection-vertex-rank verts v))
			   (segs (slot-ref eg 'seg-list)))
			(if (> r 0)
			   (update-incoming-segment w x y r verts segs vtab))
			(if (< r (- sz 1))
			   (update-outgoing-segment w x y r verts segs vtab))))
	     (set-edge->list edges)))))

(define (layout-vertex-item w world-x world-y)
	 (let* ((gcanv (slot-ref w 'parent))
		(gv (hash-table-get *link:canvas-table* gcanv))
		(v (slot-ref w 'vertex))
		(edges (incident-edges v))
		(etab (slot-ref gv 'edge-table))
		(vtab (slot-ref gv 'vertex-table))
		(vcrds (world-to-view world-x world-y gv))
		(x (car vcrds))
		(y (cadr vcrds)))
	    (update-vertex-coords w x y)))

(define (move-vertex-kbd w world-x world-y)
	 (let* ((gcanv (slot-ref w 'parent))
		(gv (hash-table-get *link:canvas-table* gcanv))
		(v (slot-ref w 'vertex))
		(edges (incident-edges v))
		(etab (slot-ref gv 'edge-table))
		(vtab (slot-ref gv 'vertex-table))
		(vcrds (world-to-view world-x world-y gv))
		(x (car vcrds))
		(y (cadr vcrds)))
	    (update-vertex-coords w x y)
	    (update-edges w x y v vtab etab edges)))

(define (move-vertex-mouse w view-x view-y)
	 (let* ((gcanv (slot-ref w 'parent))
		(gv (hash-table-get *link:canvas-table*
				gcanv))
		(v (slot-ref w 'vertex))
		(edges (incident-edges v))
		(etab (slot-ref gv 'edge-table))
		(vtab (slot-ref gv 'vertex-table))
		(wcrds (view-to-world view-x view-y gv)))
            (set-double-attribute! 'x (car wcrds) v)
            (set-double-attribute! 'y (cadr wcrds) v)
	    (update-vertex-coords w view-x view-y)
	    (update-edges w view-x view-y v vtab etab edges)
))

(define (move-edge-segment tx x-in y-in)
         (let* ((gcanv (slot-ref tx 'parent))
                (gv    (hash-table-get *link:canvas-table* gcanv))
		(wdth  (slot-ref gv 'xpixels))
		(hgt   (slot-ref gv 'ypixels))
                (segtab (slot-ref gv 'segment-table))
                (seg (hash-table-get segtab (slot-ref tx 'cid)))
                (ln  (slot-ref seg 'line-item))
                (crds (slot-ref ln 'coords))
                (p2 (cddddr crds))
		(x (cond ((< x-in 0) 10)
			 ((> x-in wdth) (- wdth 10))
			 (#t x-in)))
		(y (cond ((< y-in 0) 10)
			 ((> y-in hgt) (- hgt 10))
			 (#t y-in))))
            (slot-set! tx 'coords (list x y))
            (slot-set! ln 'coords (list (car crds) (cadr crds) x y
                                        (car p2)   (cadr p2)))
	))

(define *link:vertex-placeholder* #f)

(define (start-vertex-drag w x y) 
        (set! *link:vertex-placeholder* (make <oval> :parent (slot-ref w 'parent) 
				  :coords (coords w))))

(define (stop-vertex-drag w x y) 
         (let* ((gcanv (slot-ref w 'parent))
                (gv    (hash-table-get *link:canvas-table* gcanv))
                (vttab (slot-ref gv 'vertex-tag-table))
		(vg (hash-table-get vttab (cid w)))
	        (crds (slot-ref vg 'coords)))
           (move-vertex-mouse vg x y)
	   (update-edges vg (car crds) (cadr crds) 
				     (slot-ref vg 'vertex)
				     (slot-ref gv 'vertex-table)
				     (slot-ref gv 'edge-table) 
				     (incident-edges (slot-ref vg 'vertex))))
        (destroy *link:vertex-placeholder*))

(define (vertex-motion w x y)
        (update-vertex-coords w x y))

(define (graph-object-motion w vx vy)
	    (cond ((member "vertex" (tags w)) 
			(move-vertex-mouse 
			    (hash-table-get 
				(slot-ref (hash-table-get *link:canvas-table* 
					(slot-ref w 'parent))
					'vertex-tag-table) (cid w)) vx vy))
		  (#t (move-edge-segment w vx vy))))

(define (create-vertex-item gv vtab vttab v clone)
	  (let*((world-crds (list (find-double-attribute 'x v)
		                  (find-double-attribute 'y v)))
		(view-crds (world-to-view 
				(car world-crds) (cadr world-crds) gv))
		(vcolor (if clone (find-string-attribute 'color v)
				  *link:default-vertex-color*))
		(vsize (if clone (find-attribute 'size v)
				  *link:default-vertex-size*))
		(vlabel (if clone 
				 (find-string-attribute 'label v)
				 (vertex-label v)))
		(vg (make <vertex-item> 
			:parent (slot-ref gv 'graph-canvas)
		        :vertex v
			:color vcolor
			:size vsize
			:vertex-label vlabel
			:coords view-crds)))
	      (hash-table-put! vtab v vg)
              (let ((tx (slot-ref vg 'txt-item))
                    (ov (slot-ref vg 'oval-item)))
                 (hash-table-put! vttab (slot-ref ov 'cid) vg)
                 (hash-table-put! vttab (slot-ref tx 'cid) vg))
))

(define (create-vertex-items g gv order vtab vttab clone)
       (do ((i 0 (+ i 1)))
	  ((>= i order) #f)
	  (create-vertex-item gv vtab vttab (vertex-ref g i) clone)))

(define (create-vertex-items-from-set gv vset vtab vttab clone)
	(map (lambda (x) (create-vertex-item gv vtab vttab x clone))
		(set-vertex->list vset)))

(define (create-edge-item gv etab e clone)
	(let*  ((ecolor (if clone (find-string-attribute 'color e)
				  *link:default-edge-color*))
		(ewidth (if clone (find-attribute 'width e)
				  *link:default-edge-width*))
		(elabel (if clone (find-string-attribute 'label e)
				  (edge-label e)))
	        (eg (make <edge-item>
		:parent (slot-ref gv 'graph-canvas)
		:color ecolor
		:width ewidth
		:edge-label elabel
		:edge e))
	       (segs (slot-ref eg 'seg-list)))
	  (hash-table-put! etab e eg)
	))

(define (create-edge-items-from-set gv edge-set clone)
   (let  ((g    (slot-ref gv 'graph))
          (etab (slot-ref gv 'edge-table))) 
       (map (lambda (e) 
		(create-edge-item gv etab e clone))
	     (set-edge->list edge-set))))
;tag tables are set in add-edge-segment-item

(define (create-edge-items gv clone)
	(create-edge-items-from-set gv (edges (slot-ref gv 'graph)) clone))


(define-class <graph-view> (<Tk-composite-widget>)
  ((graph-toplevel)  ; the <toplevel> object associated with this <graph-view>
   (graph-canvas)    ; the <canvas> object associated with this <graph-view>
   (vertex-table)    ; given a <vertex*> object, look up its <vertex-item>
   (edge-table)      ; given an <edge*> object, look up its <edge-item>
   (segment-table)   ; given tag of <line> or <text-item>, look up 
		     ; <edge-segment-item>.  Used for dragging edge segments.
   (vertex-tag-table); given tag of <text-item>, look up <vertex-item>.
		     ; Used for selection of vertices.
   (edge-tag-table)  ; given tag of <text-item> or <line>, look up <edge-item>.
		     ; Note that the asymmetry with vertex-tag-table is due
		     ; to the structure of the objects; highlighting the
		     ; <guaded-oval> item of a <vertex-item> is sufficient
		     ; to highlight the vertex.  However, simply highlighting
		     ; the <line> of an <edge-segment-item> is not sufficent
		     ; to highlight a hyperedge. We need to find the <edge-item>
		     ; and update all of its segments
   (name		:accessor name :init-keyword :name)
   (graph		:accessor graph :init-keyword :graph)
   (layout		:accessor layout :init-keyword :layout)
   (xpixels 		:accessor xpixels :init-keyword :xpixels
                        :allocation :virtual
			:slot-ref (lambda (o)
				(let ((c (slot-ref o 'graph-canvas)))
						(slot-ref c 'width)))
			:slot-set! (lambda (o w)
				(let* ((c (slot-ref o 'graph-canvas))
				      (verts
					  (map cdr (hash-table->list 
					 	(slot-ref o 'vertex-table))))
				      (wcrds 
				       	  (map 	
				          	(lambda(x) 
						   (slot-ref x 'world-coords))
					   verts)))
				   (slot-set! c 'width w)
				   ;;; update vertex locations
				   (destroy-edge-items o)
				   (map (lambda (v crds)
					    (layout-vertex-item v (car crds)
							   (cadr crds)))
					verts wcrds))
				   (create-edge-items o 'clone)
				))
   (ypixels 		:accessor ypixels :init-keyword :ypixels
                        :allocation :virtual
			:slot-ref (lambda (o)
				(let ((c (slot-ref o 'graph-canvas)))
						(slot-ref c 'height)))
			:slot-set! (lambda (o h)
				(let* ((c (slot-ref o 'graph-canvas))
				      (verts
					  (map cdr (hash-table->list 
					 	(slot-ref o 'vertex-table))))
				      (wcrds 
				       	  (map 	
				          	(lambda(x) 
						   (slot-ref x 'world-coords))
					   verts)))
				   (slot-set! c 'height h)
				   ;;; update vertex locations
				   (destroy-edge-items o)
				   (map (lambda (v crds)
					    (layout-vertex-item v (car crds)
							   (cadr crds)))
					verts wcrds)
				   (create-edge-items o 'clone))))
    (title			:accessor title
				:init-keyword :title
				:allocation :propagated
				:propagate-to (graph-toplevel))
))

(define-method initialize ((self <graph-view>) initargs)
  (let* ((g2         (get-keyword :graph initargs ""))
         (xpixls     (get-keyword :xpixels initargs 385))
         (ypixls     (get-keyword :ypixels initargs 300))
         (layout     (get-keyword :layout initargs 'random))
         (clone      (get-keyword :clone initargs #f))
	 (g          (copy-graph g2 1))  ; 1 -> copy attributes
         (order      (order g))
         (size       (size g)))
    (slot-set! self 'graph g)
    (slot-set! self 'layout layout) ; not updated yet
    (slot-set! self 'vertex-table (make-hash-table (lambda (x y) 
					(equal? (get-label x) 
						(get-label y)))))
    (slot-set! self 'edge-table (make-hash-table (lambda (x y) 
					(equal? (get-label x) 
						(get-label y)))))
    (slot-set! self 'segment-table (make-hash-table))
    (slot-set! self 'vertex-tag-table (make-hash-table))
    (slot-set! self 'edge-tag-table (make-hash-table))
    (slot-set! self 'graph-toplevel (make <toplevel> 
			:title "LINK: graph view"))
    (wm 'minsize (slot-ref self 'graph-toplevel) xpixls ypixls)
    (slot-set! self 'graph-canvas (make <canvas> 
			:parent (slot-ref self 'graph-toplevel)
			:background "white"
			:width xpixls
			:height ypixls))
    (slot-set! self 'name (gensym "graph-view"))
    (hash-table-put! *link:canvas-table* (slot-ref self 'graph-canvas) self)
    (hash-table-put! *graph-view-table* (slot-ref self 'name) self)

    (let ((c (slot-ref self 'graph-canvas))
	  (vtab (slot-ref self 'vertex-table))
	  (etab (slot-ref self 'edge-table))
	  (stab (slot-ref self 'segment-table))
	  (ettab (slot-ref self 'edge-tag-table))
	  (vttab (slot-ref self 'vertex-tag-table)))
       (pack c :expand 'true :fill 'both)

       (create-vertex-items g self order vtab vttab clone)
       (create-edge-items self clone)

       ;(slot-set! self 'xpixels xpixls) 
       ; don't want to set ypixels here - edges would be redrawn
       ; it will be evaluated when user asks

    (cond ((eq? layout 'random)    (random-layout* g self))
          ((eq? layout 'circular)  (circle-layout* g self))
          ((eq? layout 'spring)    (spring-layout* g self))
          ((eq? layout 'custom) #f)	;; do nothing - coords already set.
          ((eq? layout 'bipartite) (bipartite-layout* g self)))

       (link:extract-induced-subgraph-binding self)
       (link:collapse-subgraph-binding self)
       (link:expand-subgraph-binding self)
       (link:button-3-binding c *link:canvas-table*)
       (link:hyperedge-continuation-binding c *link:canvas-table*)
       (link:selection-binding self)
       (link:selection-box-binding c)
       (link:add-selection-binding c vttab ettab)
       (link:selection-release-binding c vttab ettab)
       (link:edge-drag-binding c)
       (link:deletion-binding self)
       (link:vertex-enter-binding c)
       (link:vertex-leave-binding c)
    )
  )
  (define ms (menu-string self))
  (define m (make-menubar (slot-ref self 'graph-toplevel) ms))
  (pack m :before (slot-ref self 'graph-canvas) 
	  :side 'top :fill 'x)
)
(define-method update-graph-view ((gv <graph-view>))
	(slot-set! gv 'xpixels (winfo 'width (slot-ref gv 'graph-canvas)))
	(slot-set! gv 'ypixels (winfo 'height (slot-ref gv 'graph-canvas))))

(define (update-visible-attributes gv)
	(map (lambda(x) (slot-ref x 'color)) (vertices gv))
	(map (lambda(x) (slot-ref x 'size)) (vertices gv))
	(map (lambda(x) (slot-ref x 'width)) (vertices gv))
	(map (lambda(x) (slot-ref x 'vertex-label)) (vertices gv))
	(map (lambda(x) (slot-ref x 'color)) (edges gv))
	(map (lambda(x) (slot-ref x 'width)) (edges gv))
	(map (lambda(x) (slot-ref x 'edge-label)) (edges gv)))

(define (destroy-vertex-item vg gv)
	(let ((h (slot-ref gv 'vertex-table))
	      (v (slot-ref vg 'vertex))) 
		(cond ((hash-table-get h v #f)
			      	(hash-table-remove! h v) 
			      	(destroy vg)))))

(define (destroy-edge-item eg gv)
	(let ((h (slot-ref gv 'edge-table))
	      (e (slot-ref eg 'edge))) 
		(cond ((hash-table-get h e #f)
			      	(hash-table-remove! h e) 
			      	(destroy eg)))))

(define-method destroy-vertex-items ((gv <graph-view>))
    (let ((h (slot-ref gv 'vertex-table))) 
    	(hash-table-for-each h 
		(lambda (k v)
			      (cond ((hash-table-get h k #f)
			      		(hash-table-remove! h k) 
			      		(destroy v)))))))

(define-method destroy-edge-items ((gv <graph-view>))
    (let ((h (slot-ref gv 'edge-table))) 
    	(hash-table-for-each h 
		(lambda (k v) 
			      (cond ((hash-table-get h k #f)
			      		(hash-table-remove! h k) 
			      		(destroy v)))))))


(define-generic graph-view?)
(define-method graph-view? ((v <graph-view>)) #t)
(define-method graph-view? ((v <top>)) #f)

(define-generic vertex-item?)
(define-method vertex-item? ((v <vertex-item>)) #t)
(define-method vertex-item? ((v <top>)) #f)

(define-generic edge-item?)
(define-method edge-item? ((edge <edge-item>)) #t)
(define-method edge-item? ((edge <top>)) #f)

(define (next-vertex-name g)
    (if (= (order g) 0) 1
	(let ((n (string->number (vertex-label (vertex-ref g (- (order g)1))))))
	   (cond ((integer? n) (+ n 1))
		 (#t (gensym "v"))))))

;
; add-vertex-item!
; add-edge-item!		called from graph-edit.stklos (button 3 binding)
;
;
(define-generic add-vertex-item!)
(define-method add-vertex-item! ((gv <graph-view>) (vx <number>)
                                                          (vy <number>))
        (let*  ((g (slot-ref gv 'graph))
                (v (add-vertex! (next-vertex-name g) g))
                (wcrds (view-to-world vx vy gv)))
          (set-double-attribute! 'x (car wcrds)  v)
          (set-double-attribute! 'y (cadr wcrds) v)
          (let* ((vg (make <vertex-item> :parent (slot-ref gv 'graph-canvas)
                                         :vertex v
                                         :coords (list vx vy))))
		(slot-set! vg 'size *link:default-vertex-size*)
                (hash-table-put! (slot-ref gv 'vertex-table) v vg)
                (let ((tx (slot-ref vg 'txt-item))
                      (ov (slot-ref vg 'oval-item)))
                   (hash-table-put! (slot-ref gv 'vertex-tag-table)
                                        (slot-ref tx 'cid) vg)
                   (hash-table-put! (slot-ref gv 'vertex-tag-table)
                                        (slot-ref ov 'cid) vg)
		))))

(define-generic add-edge-item!)
(define-method add-edge-item! ((vs <sequence<vertex*>>) (gv <graph-view>))
        (let*  ((g  (slot-ref gv 'graph))
                (e  (add-edge! vs g)))
	  (cond ((not e) #f)
                (#t 
	   (let*((eg (make <edge-item>
                  :parent (slot-ref gv 'graph-canvas)
                  :edge e))
                (segs (slot-ref eg 'seg-list)))
	  (slot-set! eg 'width *link:default-edge-width*)
          (hash-table-put! (slot-ref gv 'edge-table) e eg)
          (map (lambda (s)
                (let ((tx (slot-ref s 'txt-item))
                      (ln (slot-ref s 'line-item)))
                   (hash-table-put! (slot-ref gv 'segment-table)
                                        (slot-ref tx 'cid) s)
                   (hash-table-put! (slot-ref gv 'segment-table)
                                        (slot-ref ln 'cid) s)
                   (hash-table-put! (slot-ref gv 'edge-tag-table)
                                        (slot-ref tx 'cid) eg)
                   (hash-table-put! (slot-ref gv 'edge-tag-table)
                                        (slot-ref ln 'cid) eg))) 
		segs))))))

(define (remove-from-list e l)	; removes first occurrence of e in l
	(cond ((or (not (list? l)) (null? l)) '())
	      ((equal? e (car l)) (cdr l))
	      (#t (cons (car l) (remove-from-list e (cdr l))))))

(define (insert-in-list e i l)	; insert e as i'th element of l
	(cond ((or (not (list? l)) (null? l)) (list e))
	      ((> i (+ (length l) 1)) l)
	      ((= i 1) (cons e l))
	      (#t (cons (car l) (insert-in-list e (- i 1) (cdr l))))))

(define (remove-edge-segment-item! eg es gv)
	(let   ((tx (slot-ref es 'txt-item))
		(ln (slot-ref es 'line-item)))
	   (hash-table-remove! (slot-ref gv 'segment-table) (slot-ref tx 'cid))
	   (hash-table-remove! (slot-ref gv 'segment-table) (slot-ref ln 'cid))
	   (hash-table-remove! (slot-ref gv 'edge-tag-table)(slot-ref tx 'cid))
	   (hash-table-remove! (slot-ref gv 'edge-tag-table)(slot-ref ln 'cid))
	   (destroy es))
	(slot-set! eg 'seg-list (remove-from-list es (slot-ref eg 'seg-list))))

(define-generic remove-edge-item!)
(define-method remove-edge-item! ((eg <edge-item>) (gv <graph-view>))
        (let*  ((g  (slot-ref gv 'graph))
		(e  (slot-ref eg 'edge))
                (segs (slot-ref eg 'seg-list)))
          (hash-table-remove! (slot-ref gv 'edge-table) e)
	  (remove-edge! e g)
          (map (lambda (s) (remove-edge-segment-item! eg s gv)) segs)))

(define (process-incoming-segment r verts segs vtab)
	   (let* ((seg1 (list-ref segs (- r 1)))
		  (s1(slot-ref seg1 'line-item))
	   	  (v1 (ref verts (- r 1)))
	   	  (vg1 (hash-table-get vtab v1))
		  (p2 (offset-point w vg1)))
		(cond ((not (smooth s1))            ; star-draw
			(let ((cs (coords s1)))
			   (slot-set! s1 'coords 
				(append (list (car cs) (cadr cs) (caddr cs)
					      (cadddr cs)) 
					p2))))
		       (#t 			   
			(let* ((c1 (slot-ref vg1 'coords))
		  	  (mid1 (list (/(+ (car c1) x)2) (/(+(cadr c1) y)2)))
		  	  (p1 (offset-point vg1 w)))
			(slot-set! (slot-ref seg1 'txt-item) 'coords mid1)
			(slot-set! s1 'coords (append p1 mid1 p2)))))))

(define (last l)	; is there a better way?
	(cond ((null? l) #f)
	      (#t (car (list-tail l (- (length l) 1))))))

(define (shrink-edge-item!  eg vertex gv)
	(let* ((verts (vertices (slot-ref eg 'edge)))
	       (sz    (collection-vertex-size verts))
	       (ecolor (color eg))
	       (ewidth (width eg))
	       (vtab  (slot-ref gv 'vertex-table))
	       (r     (collection-vertex-rank verts vertex))
	       (segs (slot-ref eg 'seg-list)))
	  (cond ((= sz 2) (remove-edge-item! eg gv))
		((and (> r 0) (< r (- sz 1))) 
		   (remove-edge-segment-item! eg (list-ref segs (- r 1)) gv)
		   (remove-edge-segment-item! eg (list-ref segs r) gv)
		   (let ((new-segs (add-edge-segment-item! 
				(hash-table-get vtab (ref verts (- r 1)))
				(hash-table-get vtab (ref verts (+ r 1)))
				(slot-ref gv 'graph-canvas)
				eg ecolor ewidth 
				(edge-label (slot-ref eg 'edge))
				verts r 
				gv
				(slot-ref eg 'seg-list))))
			(slot-set! eg 'seg-list new-segs)))
		((= r 0) (remove-edge-segment-item! eg (car segs) gv))
		((= r (- sz 1)) 
			 (remove-edge-segment-item! eg (last segs) gv)))))

(define-generic remove-vertex-item!)
(define-method remove-vertex-item! ((vg <vertex-item>) (gv <graph-view>))
        (let*  ((g  (slot-ref gv 'graph))
		(v  (slot-ref vg 'vertex)))
          (map  (lambda (s) (shrink-edge-item! 
				(hash-table-get (slot-ref gv 'edge-table) s)
				v gv))
		(set-edge->list (incident-edges v)))
          (let ((tx (slot-ref vg 'txt-item))
                (ov (slot-ref vg 'oval-item)))
             (hash-table-remove! (slot-ref gv 'vertex-tag-table)
                                     (slot-ref tx 'cid))
             (hash-table-remove! (slot-ref gv 'vertex-tag-table)
                                        (slot-ref ov 'cid)))
          (hash-table-remove! (slot-ref gv 'vertex-table) v)
	  (remove-vertex! v g)
	  (destroy vg)))

(define (replace-graph g gv)
	(destroy-edge-items gv)
	(destroy-vertex-items gv)
	(slot-set! gv 'graph g)
	(slot-set! gv 'title "LINK: graph view")
	(create-vertex-items g gv (order g) 
				  (slot-ref gv 'vertex-table)
				  (slot-ref gv 'vertex-tag-table) #f)
	(create-edge-items gv #f))

(define (reset-edge-marks g)
	(map (lambda(x) (set-attribute! 'mark 0 x))
		(set-edge->list (edges g))))

(define (gather-incident-edges vertex)
	(let ((es (mset-edge)))
	   (map (lambda (e) 
		   (cond ((= (find-attribute 'mark e) 0)
			     (insert! e es)
			     (set-attribute! 'mark 1 e))))
		(set-edge->list 
			(incident-edges vertex)))
	   es))

(define (extract-induced-subgraph vertex-item-list gv)
	(let ((subgraph-vertices (set-vertex)))
	   (map (lambda(x) (insert! (slot-ref x 'vertex) subgraph-vertices))
		vertex-item-list)
	   (let ((sg (induced-subgraph (graph gv) subgraph-vertices 1)))
		(set! *link:new-graph-view* 
			(make <graph-view> :graph sg :layout 'custom)))))

(define (extract-edge-induced-subgraph edge-item-list gv) ())

(define (collapse-subgraph vertex-item-list gv)
  (cond((not (and (binary?     (slot-ref gv 'graph)) 
		      (multigraph? (slot-ref gv 'graph))))
	  (error "collapse-subgraph:g must be binary and allow multiple edges"))
       ((not (and (list? vertex-item-list) 
			 (> (length vertex-item-list) 0))) #f)
       (#t
	(reset-edge-marks (graph gv))
	(let ((subgraph-edges (mset-edge))
	      (etab (slot-ref gv 'edge-table))
	      (vtab (slot-ref gv 'vertex-table))
	      (vttab (slot-ref gv 'vertex-tag-table))
	      (subgraph-vertices (set-vertex))
	      (n (length vertex-item-list))
	      (xsum  0)
	      (ysum  0))
	   (map (lambda(x) (insert! (slot-ref x 'vertex) subgraph-vertices))
		vertex-item-list)
	   (map (lambda(x) 
		    (set! subgraph-edges (+ subgraph-edges
			   		    (gather-incident-edges x))))
		(map (lambda(x) (slot-ref x 'vertex)) vertex-item-list))
	   (map (lambda(vg)
		    (let ((v (slot-ref vg 'vertex)))
			(set! xsum (+ xsum (find-double-attribute 'x v)))
			(set! ysum (+ ysum (find-double-attribute 'y v)))))
		vertex-item-list)
	   (map (lambda(e)
		    (let ((eg (hash-table-get etab e)))
			(destroy-edge-item eg gv)))
		(set-edge->list subgraph-edges))
	   (map (lambda(vg)
			(destroy-vertex-item vg gv))
		vertex-item-list)

	   (let* ((sv (add-subgraph (graph gv) subgraph-vertices)))
	      (display "x: ") (display xsum) (display " ") (display n)(newline)
	      (display "y: ") (display ysum) (display " ") (display n)(newline)
	      (set-double-attribute! 'x (/ xsum n) sv)
	      (set-double-attribute! 'y (/ ysum n) sv)
	      (create-vertex-item gv vtab vttab sv #t)
	      (create-edge-items-from-set gv (incident-edges sv) #f)))))
	(set! *link:selected-vertex-items* '()))

(define (expand-subgraph super-vertex gv)
	(if (not (and (binary? (slot-ref gv 'graph)) 
		      (multigraph? (slot-ref gv 'graph))))
	 (err "expand-subgraph:graph must be binary and allow multiple edges")
	)
	(let ((sv (slot-ref super-vertex 'vertex))
	      (etab (slot-ref gv 'edge-table))
	      (vtab (slot-ref gv 'vertex-table))
	      (vttab (slot-ref gv 'vertex-tag-table)))
	   (map (lambda(e)
		    (let ((eg (hash-table-get etab e)))
			(destroy-edge-item eg gv)))
		(set-edge->list (incident-edges 
					(slot-ref super-vertex 'vertex))))
	   (destroy-vertex-item super-vertex gv)

	   (let* ((subgraph-vertices (set-vertex))
		  (subgraph-edges    (mset-edge))
		  (vs (dissolve-subgraph (graph gv) sv)))
	       (reset-edge-marks (graph gv))
	       (map (lambda(x) 
		     (set! subgraph-edges (+ subgraph-edges
					     (gather-incident-edges x))))
		(set-vertex->list vs))
	      (create-vertex-items-from-set gv vs vtab vttab 'clone)
	      (create-edge-items-from-set gv subgraph-edges 'clone))))
	

(define-method vertices ((gv <graph-view>))
	(map cdr (hash-table->list (slot-ref gv 'vertex-table))))

(define-method edges ((gv <graph-view>))
	(map cdr (hash-table->list (slot-ref gv 'edge-table))))

(require "labels")
(require "graphics")
(require "flash")
(require "star-draw")

(define-generic show-labeled-graph)
(define-method show-labeled-graph ((g <graph*>))
	(make <graph-view> :graph g :clone 'clone))

(define-method show-labeled-graph ((g <graph*>) (layout <symbol>))
	(make <graph-view> :graph g :clone 'clone :layout layout))

(define-generic show-graph)
(define-method show-graph ((g <graph*>))
	(let ((gv (make <graph-view> :graph g :clone 'clone)))
		(hide-labels gv) gv))

(define-method show-graph ((g <graph*>) (layout <symbol>))
	(let ((gv (make <graph-view> :graph g :clone 'clone :layout layout)))
		(hide-labels gv) gv))

(provide "graph-view")