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


(define (offset-point p1 p2)
	(coords p1))
;### putting the following in messes up star-draw, but makes directed graphs
;### look nicer by ending edges at vertex borders instead of centers. 
;### However, modifying arrow-shape can make the graph look nice again
;        (let* ( (crds1  (coords p1))
;                (crds2  (coords p2))
;                (sz     (size p1))
;                (x1     (car crds1))
;                (y1     (cadr crds1))
;                (x2     (car crds2))
;                (y2     (cadr crds2))
;                (offset (quotient sz 2))
;                (dist   (sqrt (+ (* (- x1 x2) (- x1 x2))
;                                 (* (- y1 y2) (- y1 y2)))))
;                (lamb   (if (= dist 0.0) 1.0
;			    (/ offset (floor 
;				  (sqrt (+ (* (- x1 x2) (- x1 x2))
;                                           (* (- y1 y2) (- y1 y2))))))))
;                (xs     (+ (* (- 1 lamb) x1) (* lamb x2)))
;                (ys     (+ (* (- 1 lamb) y1) (* lamb y2))))
;        (list xs ys)))
;*****************************************************************************

(define vertex-font
  "-adobe-courier-bold-o-normal--18-180-75-75-m-110-iso8859-1")

(define-class <vertex-item> (<Tk-Composite-Item>)
  ((vertex-object      :accessor       vertex-object)
   (txt-item           :accessor       txt-item)
   (graph-view         :getter         graph-view)
   (vertex             :getter         vertex)
   (label-offset       :accessor       label-offset)
   (coords             :getter         coords
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
					 (vertex-object-coords 
						(slot-ref o 'vertex-object)
						(slot-ref o 'size)))
                       :slot-set!      (lambda (o l)
                                          (let* ((tx (slot-ref o 'txt-item))
                                                 (sz (slot-ref o 'size))
                                                 (xlo (car (slot-ref o 
								'label-offset)))
                                                 (ylo (cadr (slot-ref o 
								'label-offset)))
                                                 (os (quotient
							(slot-ref o 'size)2)))
					    (set-vertex-object-coords!
						(slot-ref o 'vertex-object)
						(car l)
						(cadr l)
						sz)
                                             (set! (coords tx) (list 
						  (+ xlo (car l))
						  (+ ylo (cadr l)))))))
   (world-coords       :accessor       world-coords
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
					   (let* ((v (slot-ref o 'vertex))
					          (wx (find-double-attribute
							'x v))
					          (wy (find-double-attribute
							'y v)))
					     (move-vertex-kbd o wx wy)
					     (list wx wy)))
                       :slot-set!      (lambda (o l)
					   (let* ((v (slot-ref o 'vertex))
						  (vx (car l))
						  (vy (cadr l))
						  (wx (min (max 0.0 vx)
							   (min 1.0 vy)))
						  (wy (min (max 0.0 vx)
							   (min 1.0 vy))))
					      (set-double-attribute!
						  'x wx v)
					      (set-double-attribute!
						  'y wy v)
					      (move-vertex-kbd o wx wy))))
							     
   (size               :accessor       size
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
					(let*((sz (find-attribute 'size
					             (slot-ref o 'vertex)))
                                              (vo(slot-ref o 'vertex-object))
                                              (tx (slot-ref o 'txt-item))
                                              (cs (vertex-object-coords vo sz))
                                              (xlo (car (slot-ref o 
								'label-offset)))
                                              (ylo (cadr (slot-ref o 
								'label-offset)))
					      (os (/ sz 2))
                                              (x1 (car cs))
                                              (y1 (cadr cs)))
					     (set-vertex-object-coords! vo
                                                       x1 y1 sz)
                                             (set! (coords tx) (list
                                                     (+ xlo x1)
                                                     (+ ylo y1)))
					     sz))

		       :slot-set!      (lambda (o l)
                                          (let*((vo (slot-ref o 'vertex-object))
                                                (tx (slot-ref o 'txt-item))
						(s (slot-ref o 'size))
                                                (xlo (car (slot-ref o 
								'label-offset)))
                                                (ylo (cadr (slot-ref o 
								'label-offset)))
                                                (cs (vertex-object-coords vo s))
                                                (os (quotient l 2)))
					     (set-vertex-object-coords! vo
                                                       (car cs) (cadr cs) l)
                                             (set! (coords tx) (list 
						  (+ xlo (car cs))
						  (+ ylo (cadr cs)))) 
					     (set-attribute! 'size l 
						     (slot-ref o 'vertex))
					     (move-vertex-mouse o (car cs)
								  (cadr cs))
					     (raise vo)
					     (raise tx))))
   (vertex-label       :accessor       vertex-label
                       :allocation     :virtual
                       :slot-ref       (lambda (o)
					(let*((lb (find-string-attribute 'label
						     (slot-ref o 'vertex)))
                                              (tx (slot-ref o 'txt-item)))
                                             (set! (text-of tx) lb)
					     lb))

		       :slot-set!      (lambda (o lb)
					  (set-string-attribute! 'label lb
						     (slot-ref o 'vertex))
                                          (let* ((tx (slot-ref o 'txt-item)))
                                             (set! (text-of tx) lb))))
   ;; Propagated slots
   (tags    	       :accessor tags    
		       :init-keyword :tags    
		       :allocation :propagated
                       :propagate-to   (vertex-object))
   (color              :accessor       color
                       :init-keyword   :color
                       :allocation     :propagated
                       :propagate-to   (vertex-object))
   (font               :accessor       font
                       :init-keyword   :font
                       :allocation     :propagated
                       :propagate-to   (txt-item))
   (text-color         :accessor       text-color
                       :allocation     :propagated
                       :propagate-to   ((txt-item fill)))
   (stipple            :accessor       stipple
                       :init-keyword   :stipple
                       :allocation     :propagated
                       :propagate-to   (vertex-object))
   (width              :accessor       width
                       :init-keyword   :width
                       :allocation     :propagated
                       :propagate-to   (vertex-object))
   (outline            :accessor       outline
                       :init-keyword   :outline
                       :allocation     :propagated
                       :propagate-to   (vertex-object))
   ;(background         :accessor       background
   ;                    :allocation     :propagated
   ;                    :propagate-to   ((vertex-object fill)))
   ))

(define-method initialize-item ((self <vertex-item>) canvas coords args)
  (let* ((parent      (slot-ref self 'parent))
	 (vs          *link:default-vertex-size*)
	 (half-vs     (/ vs 2))
         (vertex      (get-keyword :vertex args ""))
         (graph-view  (get-keyword :graph-view args ""))
         (vcolor      (get-keyword :color args *link:default-vertex-color*))
         (vsize       (get-keyword :size args vs))
         (vlabel      (get-keyword :vertex-label args (vertex-label vertex)))
         (text-object (make <text-item> :text vlabel :parent parent
                            :anchor "nw" :coords (list
				(+ (car coords) vs 2) (+ (cadr coords) vs 2))
                            ;;; :font vertex-font
                            :text-color 'black
                            :background 'orange))
         (file "/home/berryj/link/stklos/todd.gif")
         (xpix 72) ; width of image in pixels (all the way across, not half way)
         (ypix 92) ; height of image (all the way down, not half way)
         ;(vo (make <my-image-item> :parent parent 
	;	      :file file :xpixels xpix :ypixels ypix
        ;              :coords (list (car coords) (cadr coords))))
         (vo (make <guarded-oval> :parent parent :vertex vertex
				  :color vcolor
				  :coords (list (car coords) (cadr coords)
	 			(+ (car coords) vsize) (+(cadr coords) vsize))))
         (Cid         (my-gensym "vertex")))

    (slot-set! self 'Cid Cid)
    (slot-set! self 'vertex vertex)
    (slot-set! self 'graph-view graph-view)
    (slot-set! self 'vertex-object vo)
    (slot-set! self 'txt-item text-object)
    (slot-set! self 'vertex-label vlabel)
    (slot-set! self 'label-offset (list (+ half-vs 2) (+ half-vs 2)))

    (add-to-group self vo text-object)
    (bind-for-dragging parent 
		:tag (slot-ref (slot-ref self 'vertex-object) 'cid)
		:button 1
		:modifier "Control"
		:only-current #f
		:start start-vertex-drag
		:motion find-and-update-vertex-item
		:stop stop-vertex-drag)
    (bind-for-dragging parent 
		:tag (slot-ref (slot-ref self 'txt-item) 'cid)
		:button 1
		:modifier "Control"
		:only-current #f
		:start start-vlabel-drag
		:motion vlabel-motion
		:stop stop-vlabel-drag)
    Cid))

(define (start-vlabel-drag w x y) '())	; does nothing for now
(define (stop-vlabel-drag w x y)  '())

(define (vlabel-motion w x y) 
   (let* ((gcanv (slot-ref w 'parent))
                (gv    (hash-table-get *link:canvas-table* gcanv #f)))
	   (cond (gv
	     (let* (
                (vttab (slot-ref gv 'vertex-tag-table))
		(vg (hash-table-get vttab (cid w) #f)))
	      (cond (vg
	        (let* (
	          (vcrds (slot-ref vg 'coords))
	          (txt-item (slot-ref vg 'txt-item)))
	  (slot-set! txt-item 'coords (list x y))
	  (slot-set! vg 'label-offset (list (- x (car vcrds))
					    (- y (cadr vcrds))))
	     ))))))))

(provide "vertex")
