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

(define (mid-point es)
	(let*  ((ln (slot-ref es 'line-item))
	        (crds (slot-ref ln 'coords))
	        (x1   (car crds))
	        (y1   (cadr crds))
		(p2 (cddddr crds))
	        (x2   (car p2))
	        (y2   (cadr p2))
                (xmid   (/ (+ x1 x2) 2))
                (ymid   (/ (+ y1 y2) 2)))
	  (list xmid ymid)))

(define (move-star-edge w vx vy)
	(let*  ((segs (slot-ref w 'seg-list))
	        (tx-items (map txt-item segs)))
             	(map (lambda (tx) (move-edge-segment tx vx vy)) tx-items) #f))

(define (edge-draw-mode e mode)
	(let* ((c (slot-ref e 'parent))
	       (segs (slot-ref e 'seg-list))
	       (crds (coords (car segs)))
	       (smooth-flag (if (equal? mode 'star-draw) 0 1))
	       (move-all (if (equal? mode 'star-draw) #f #t)))
	   (map (lambda (x) 
			(if (= smooth-flag 1)
				(set! (coords x) (mid-point x))
				(set! (coords x) crds))
			(set! (smooth (slot-ref x 'line-item))smooth-flag))segs)
	   (bind-for-dragging c :tag (cid (slot-ref e 'edge-group))
				:button 2 
				:only-current move-all
        			:motion (lambda (w x y) 
			 	  (let ((segs (find-items c 'withtag 
						(slot-ref w 'cid))))
             				(map (lambda (es)
				      		(graph-object-motion es x y))
					    segs))))) #f)
(define-generic star-draw)
(define-generic path-draw)
(define-method star-draw ((e <edge-item>)) (edge-draw-mode e 'star-draw))
(define-method path-draw ((e <edge-item>)) (edge-draw-mode e 'path-draw))
(define-method star-draw ((gv <graph-view>)) 
	(map (lambda (x) (star-draw x)) (edges gv)) #f)
(define-method path-draw ((gv <graph-view>)) 
	(map (lambda (x) (path-draw x)) (edges gv)) #f)
(define-method star-draw ((t <top>)) 
	(error "star-draw: expecting <graph-view>")) 
(define-method path-draw ((t <top>)) 
	(error "path-draw: expecting <graph-view>")) 

(define-generic move-edge)
(define-method move-edge ((e <label-object>) (wx <number>) (wy <number>)
			    (gv <graph-view>))
	(let*  ((etab (slot-ref gv 'edge-table))
		(eg   (hash-table-get etab e))
		(vcrds(world-to-view wx wy gv))
		(vx   (car vcrds))
		(vy   (cadr vcrds))
		(segs (slot-ref eg 'seg-list)))
	    (star-draw eg)
	    (move-star-edge eg vx vy))
	#f)

(define-method move-edge ((eg <edge-item>) (wx <number>) (wy <number>)
			    (gv <graph-view>))
	(let*  ((vcrds(world-to-view wx wy gv))
		(vx   (car vcrds))
		(vy   (cadr vcrds))
		(segs (slot-ref eg 'seg-list)))
	    (star-draw eg)
	    (move-star-edge eg vx vy))
	#f)

(define-method move-edge ((t <top>) (t1 <top>) (t2 <top>) (t3 <top>))
	(error "move-edge: expected (<label-object>|<edge-item>) \
 <number> <number> <graph-view>"))

(define-generic layout-edge)
(define-method layout-edge ((eg <edge-item>) (gv <graph-view>))
	(let*  ((e (slot-ref eg 'edge))
	        (wx (find-double-attribute 'x e))
	        (wy (find-double-attribute 'y e))
		(vcrds(world-to-view wx wy gv))
		(vx   (car vcrds))
		(vy   (cadr vcrds)))
	   (move-star-edge eg vx vy)))

(define-generic layout-edges)
(define-method layout-edges ((gv <graph-view>))
	(map (lambda (x) (layout-edge x gv)) (edges gv)) #f)

(define-generic layout-vertices)
(define-method layout-vertices ((gv <graph-view>))
	(map world-coords (vertices gv)))
	
(define-method layout-edges ((t <top>))
	(error "layout-edges: expecting <graph-view>"))
	
(define-method layout-vertices ((t <top>))
	(error "layout-vertices: expecting <graph-view>"))


(provide "star-draw")