;; 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 "vertex")
(require "edge-segment")

(define (recursive-member e l)
        (cond ((null?  l) #f) 
	      ((list? (car l))  (or (recursive-member e (car l)) 
				    (recursive-member e(cdr l))))
              (#t   (or (equal? e (car l)) (recursive-member e (cdr l))))))

(define (add-edge-segment-item! v1 v2 canvas edge-item 
		ecolor ewidth elabel verts rank gv seg-list)
	(let*  ((p1 	(offset-point v1 v2))
		(p2 	(offset-point v2 v1))
		(xmid 	(/ (+ (car p1) (car p2)) 2))
		(ymid 	(/ (+ (cadr p1) (cadr p2)) 2))
	        (s (make <edge-segment-item> :parent canvas
			  :edge-group (slot-ref edge-item 'edge-group)
			  :color      ecolor
			  :width      ewidth
			  :text       elabel
			  :coords1 p1
			  :coords  (list xmid ymid)
			  :coords2 p2
			  :direction 
				(if (collection-vertex-sorted? verts) #f #t)))
                (stab (slot-ref gv 'segment-table))
                (ettab (slot-ref gv 'edge-tag-table))
                (ln (slot-ref s 'line-item))
                (tx (slot-ref s 'txt-item)))
            (add-to-group (slot-ref edge-item 'edge-group) tx)
            (hash-table-put! stab (slot-ref tx 'cid) s)
            (hash-table-put! stab (slot-ref ln 'cid) s)
            (hash-table-put! ettab (slot-ref tx 'cid) edge-item)
            (hash-table-put! ettab (slot-ref ln 'cid) edge-item)
 
	    (insert-in-list s rank seg-list)))

;*****************************************************************************
(define-class <edge-item> (<Tk-Widget>)
  ((edge  :accessor edge  :init-keyword :edge)
   (seg-list           :accessor       seg-list)
   (edge-group         :accessor       edge-group)
   (tags               :accessor       tags
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                         (tags (car (slot-ref o 'seg-list))))
					 ; maybe should change to find union
					 ; of tags of all segs, reset all to
					 ; this union
                       :slot-set!      (lambda (o l)
                                          (let* ((sgs (slot-ref o 'seg-list)))
						(map (lambda (x) 
							(set! (tags x) l)) sgs)
					  )))
   (width              :accessor       width
                       :init-keyword   :width
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                        (let* ((w (find-attribute
                                          	'width
						(slot-ref o 'edge))))
                                          (let* ((sgs (slot-ref o 'seg-list)))
                                                (map (lambda (x)
                                                    (slot-set! x 'width w)) sgs)
					  )
					  w))

                       :slot-set!      (lambda (o l)
                                	  (set-attribute!
                                        	'width l
                                        	(slot-ref o 'edge))
                                          (let* ((sgs (slot-ref o 'seg-list)))
						(map (lambda (x) 
						    (slot-set! x 'width l)) sgs)
					  )l ))
   (color              :accessor       color
                       :init-keyword   :color
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                        (let* ((c (find-string-attribute
                                          'color
                                          (slot-ref o 'edge))))
                                          (let* ((sgs (slot-ref o 'seg-list)))
						(map (lambda (x) 
						    (slot-set! x 'color c)) sgs)
					  ) c))
                       :slot-set!      (lambda (o c)
                                	  (set-string-attribute!
                                        	'color c
                                        	(slot-ref o 'edge))
                                          (let* ((sgs (slot-ref o 'seg-list)))
						(map (lambda (x) 
						    (slot-set! x 'color c)) sgs)
					  )))
   (arrow-shape        :accessor       arrow-shape
                       :init-keyword   :arrow-shape
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                          (let* ((sgs (slot-ref o 'seg-list))
						 (eg (car sgs))
						 (ln (slot-ref eg 'line-item)))
						(slot-ref ln 'arrow-shape)))
                       :slot-set!      (lambda (o l)
                                          (let* ((sgs (slot-ref o 'seg-list)))
					    (map (lambda (x) 
					     (let ((ln (slot-ref x 'line-item)))
					        (slot-set! ln 'arrow-shape l)))
					     sgs)
					    )))
   (text-color         :accessor       text-color
                       :init-keyword   :text-color
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                          (let* ((sgs (slot-ref o 'seg-list))
						 (eg (car sgs))
						 (tx (slot-ref eg 'txt-item)))
						(slot-ref tx 'fill)))
                       :slot-set!      (lambda (o l)
                                          (let* ((sgs (slot-ref o 'seg-list)))
					    (map (lambda (x) 
					     (let ((tx (slot-ref x 'txt-item)))
						    (slot-set! tx 'fill l)))sgs)
					    )))
   (edge-label    :accessor       edge-label
                       :init-keyword   :edge-label
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                          (let* ((l (find-string-attribute
							'label
							(slot-ref o 'edge)))
                                                 (sgs (slot-ref o 'seg-list)))
					    (map (lambda (x) 
					     (let ((tx (slot-ref x 'txt-item)))
						    (slot-set! tx 'text l)))sgs)
					     l
					    ))
                       :slot-set!      (lambda (o l)
					  (set-string-attribute! 'label l
						(slot-ref o 'edge))
                                          (let* ((sgs (slot-ref o 'seg-list)))
					    (map (lambda (x) 
					     (let ((tx (slot-ref x 'txt-item)))
						    (slot-set! tx 'text l)))sgs)
					    )))
   (font               :accessor       font
                       :init-keyword   :font
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                          (let* ((sgs (slot-ref o 'seg-list))
						 (eg (car sgs))
						 (tx (slot-ref eg 'txt-item)))
						(slot-ref tx 'font)))
                       :slot-set!      (lambda (o l)
                                          (let* ((sgs (slot-ref o 'seg-list)))
					    (map (lambda (x) 
					     (let ((tx (slot-ref x 'txt-item)))
						    (slot-set! tx 'font l)))sgs)
					    )))
))

(define-method initialize ((self <edge-item>) initargs) 
  (let* ((parent(get-keyword :parent initargs ""))
	 (gv    (hash-table-get *link:canvas-table* parent))
         (edge  (get-keyword :edge initargs ""))
         (ecolor(get-keyword :color initargs *link:default-edge-color*))
         (ewidth(get-keyword :width initargs *link:default-edge-width*))
         (elabel(get-keyword :edge-label initargs (edge-label edge)))
	 (verts (vertices edge))
	 (vert-list (set-vertex->list verts))
	 (vtab	(slot-ref gv 'vertex-table))
	 (vg-list (map (lambda (x) (hash-table-get vtab x)) vert-list))
	 (vg-vector (list->vector vg-list))
	 (seg-list '())
	 (edge-group (make <canvas-group> :parent parent)))
    (slot-set! self 'parent parent)
    (slot-set! self 'edge edge)
    (slot-set! self 'edge-group edge-group)

      (do ((i 0 (+ i 1)))
	   ((>= i (- (vector-length vg-vector) 1)) seg-list)
	   (set! seg-list (add-edge-segment-item! (vector-ref vg-vector i)
	        		(vector-ref vg-vector (+ i 1))
				parent self ecolor ewidth elabel verts 
				(+ i 1) gv
				seg-list)))
    (slot-set! self 'seg-list seg-list)
    (slot-set! self 'arrow-shape '(13 15 4))
    (slot-set! self 'edge-label elabel))
)

(define-method destroy ((eg <edge-item>))
	(map destroy-edge-segment-item (slot-ref eg 'seg-list))
	(change-class eg <destroyed-object>))

(define-method lower-edge ((eg <edge-item>))
	(let ((segs (slot-ref eg 'seg-list)))
		(map lower-edge-segment segs)))

(define-method raise-edge ((eg <edge-item>))
	(let ((segs (slot-ref eg 'seg-list)))
		(map raise-edge-segment segs)))

(define (random-edge-weights g)
        (let ((eg (set-edge->list (edges g))))
                (map (lambda (x)
                        (let ((r(string->number (number->string (random 100)))))
                                (set-double-attribute! 'weight r x))) eg)) #f)

(define (show-edge-weights g)
        (let ((eg (set-edge->list (edges g))))
                (map (lambda (x) (find-double-attribute 'weight x)) eg)))


(provide "edge")