;; 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")

(define edge-segment-background-color "Yellow")
(define edge-segment-foreground-color "Black")

;; This is the actual height of the graphic.
(define edge-segment-graphic-height 30)

;; This is how many extra pixels to put at each end of the text.
(define edge-segment-graphic-width 5)
(define edge-segment-font
  "-adobe-courier-bold-o-normal--18-180-75-75-m-110-iso8859-1")

(define-class <edge-segment-item> (<Tk-Composite-Item>)
  ((line-item          :accessor       line-item)
   (txt-item           :accessor       txt-item)
   (edge-group	       :accessor       edge-group :init-keyword :edge-group)
   (coords             :accessor       coords
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
                                          (let* ((tx (slot-ref o 'txt-item))
                                                 (cs (slot-ref tx 'coords)))
                                          	cs))
                       :slot-set!      (lambda (o l)
                                          (let* ((ln (slot-ref o 'line-item))
                                                 (tx (slot-ref o 'txt-item))
                                                 (lcds (slot-ref ln 'coords))
						 (mid (list (- (car l) 2)
						            (- (cadr l) 2)))
                                                 (p1  (list (car lcds) 
						      (cadr lcds)))
                                                 (p3  (cddddr lcds)))
                                             (set!(coords ln)(append p1 mid p3))
                                             (set! (coords tx) (list 
						  	(car l)
						  	(cadr l))))))
   ;; Propagated slots
   (tags    	       :accessor tags    
		       :init-keyword :tags    
		       :allocation :propagated
                       :propagate-to   (txt-item))
   (stipple    	       :accessor stipple    
		       :init-keyword :stipple    
		       :allocation :propagated
                       :propagate-to   (line-item))
   (width              :accessor       width
                       :init-keyword   :width
                       :allocation     :propagated
                       :propagate-to   ((line-item width)))
   (arrow-shape        :accessor       arrow-shape
                       :init-keyword   :arrow-shape
                       :allocation     :propagated
                       :propagate-to   ((line-item arrow-shape)))
   (color              :accessor       color
                       :init-keyword   :color
                       :allocation     :propagated
                       :propagate-to   ((line-item fill)))
   (edge-segment-label :getter         edge-segment-label
                       :init-keyword   :edge-segment-label
                       :allocation     :propagated
                       :propagate-to   ((txt-item text)))
   (font               :getter         font
                       :init-keyword   :font
                       :allocation     :propagated
                       :propagate-to   (txt-item))
   (text-color         :accessor       text-color
                       :allocation     :propagated
                       :propagate-to   (;(oval-item outline)
                                         (txt-item fill)))
   ))

(define-method initialize-item ((self <edge-segment-item>) canvas coords args)
  (let* ((parent     (slot-ref self 'parent))
         (text       (get-keyword :text args ""))
         (swidth     (get-keyword :width args *link:default-edge-width*))
         (scolor     (get-keyword :color args *link:default-edge-color*))
         (coords1    (get-keyword :coords1 args ""))
         (coords2    (get-keyword :coords2 args ""))
         (directed   (get-keyword :direction args ""))
         (edge-group (get-keyword :edge-group args ""))
         (arrow      (if directed "last" "none"))
         (text-object (make <text-item> :text text :parent parent
                            :anchor "nw" :coords coords
                            ;;; :font edge-segment-font
                            :text-color edge-segment-foreground-color
                            :background edge-segment-background-color))
         (line-object (make <line> :parent parent 
                            :coords (append coords1 coords coords2) 
			    :arrow arrow
			    :width swidth
			    :fill scolor
			    :smooth 1))
         (Cid         (gensym "edge-segment")))

    (slot-set! self 'Cid Cid)
    (slot-set! self 'edge-group edge-group)
    (slot-set! self 'line-item line-object)
    (slot-set! self 'txt-item text-object)
    (lower line-object)

    (add-to-group self line-object text-object)
           (bind-for-dragging parent :tag (slot-ref edge-group 'cid) 
			:button 2
                        :only-current #t
                        :motion (lambda (w x y)
                                (let((segs(find-items parent 'withtag 
							(slot-ref w 'cid))))
                                        (map (lambda (es)
                                                (graph-object-motion es x y))
                                        segs))
				))
    Cid)
)

(define-method destroy-edge-segment-item ((es <edge-segment-item>))
	(destroy (slot-ref es 'line-item))
	(destroy (slot-ref es 'txt-item)))

(define-method lower-edge-segment ((es <edge-segment-item>))
	(let ((l (slot-ref es 'line-item))
	      (t (slot-ref es 'txt-item)))
	    (lower l)
	    (lower t)))

(define-method raise-edge-segment ((es <edge-segment-item>))
	(let ((l (slot-ref es 'line-item))
	      (t (slot-ref es 'txt-item)))
	    (raise l)
	    (raise t)))

(provide "edge-segment")