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

;----------------------------------------------------------------------
; *link:new-edge-vertices*:     global <sequence<vertex*>> object used to 
;				store vertices as the user creates edges
;
(define *link:new-edge-vertices* (sequence-vertex))
;----------------------------------------------------------------------

;----------------------------------------------------------------------
; *link:selection-box*:         global <rectangle> object used to 
;				select regions of objects 
;
(define *link:selection-box* '())
(define *link:selection-box-x* 0)
(define *link:selection-box-y* 0)
;----------------------------------------------------------------------

;----------------------------------------------------------------------
; *link:selected-graph-view*:
; *link:selected-graph-view1*:
; *link:selected-graph-view2*:	these are used for point&click binary 
;				operations (e.g. isomorphism)
;			
;
(define *link:selected-graph-view* #f)
(define *link:selected-graph-view1* #f)
(define *link:selected-graph-view2* #f)
;----------------------------------------------------------------------

;----------------------------------------------------------------------
; *link:canvas-clicks*:		counts the number of clicks in canvases
;				(useful for k-ary predicates)
;			
;
(define *link:canvas-clicks* 0)
;----------------------------------------------------------------------

;----------------------------------------------------------------------
; *link:selected-vertex-items*:      global list of vertex-items used 
;				     by the menu callbacks
;
(define *link:selected-vertex-items* '())
;----------------------------------------------------------------------

;----------------------------------------------------------------------
; *link:selected-edge-items*:        global list of vertex-items used 
;				     by the menu callbacks
;
(define *link:selected-edge-items* '())
;----------------------------------------------------------------------

(define (link:find-vertex-in-list l)
	(cond ((null? l) '())
	      ((member "vertex" (tags (car l))) (car l))
	      (#t (link:find-vertex-in-list (cdr l)))))


;;; continue edge (make a hyperedge)

(define (link:hyperedge-continuation-binding c ctab)
  (bind c "<Shift-Button-3>" 
    (lambda (x y) 
     (let*  ((gv (hash-table-get ctab c))
             (g  (slot-ref gv 'graph)))
	(cond ((bingraph? g)
			  (error "can't add hyperedges in a binary graph"))
      (#t (let   ((items (find-items c 'withtag 'current)))
	      (cond ((and (not (null? items))
		          (member "drag" (tags (car items))))
                      (let* ((its (find-items c 'overlapping x y x y))
                             (vg (link:find-vertex-in-list its)))
			 (cond  
			   ((not (null? vg))
                              (append! (slot-ref vg 'vertex) 
						*link:new-edge-vertices*)
	    	      	      (let* ((its (find-items c 'withtag 'drag))
	    	      	             (oval-first(< (slot-ref (car its) 'cid)
						   (slot-ref (cadr its) 'cid))) 
	           	             (l  (if (< (slot-ref (car its) 'cid)
						(slot-ref (cadr its) 'cid)) 
	           	                    (cadr its) 
					    (car its))))
				 (set! (coords l)(append (list x y) 
							 (coords l)))))
			    (#t  (clear! *link:new-edge-vertices*)
			         (let ((its (find-items c 'withtag 'drag)))
					(for-each (lambda(x)
					   	(destroy x)) its))))
		      ))))))))))


(define (link:button-3-binding c ctab)
  (bind c "<Button-3>" 
   (lambda (x y) 
        (let*  ((items (find-items c 'withtag 'current))
		(gv (hash-table-get ctab c))
                (g  (slot-ref gv 'graph)))
	  (cond ((null? items)
	  		(add-vertex-item! gv x y))
		((not (null? *link:new-edge-vertices*))
			(let ((i (find-items c 'withtag 'drag)))
				(for-each (lambda(x)
					   (destroy x)) i))
			(let* ((its (find-items c 'overlapping x y x y)))
			   (cond ((not (null? its))
			     (append! (slot-ref(link:find-vertex-in-list its) 
							'vertex)
			     	       *link:new-edge-vertices*)
			     (add-edge-item! *link:new-edge-vertices* gv)
					)))
			(clear! *link:new-edge-vertices*))
		((member "vertex" (tags (car items)))
			(append! (slot-ref (car items) 'vertex) 
						*link:new-edge-vertices*)
			(make <oval>    :parent (slot-ref gv 'graph-canvas)
                       		        :coords (list x y x y)
                                	:tags 'drag)
			(make <line>    :parent (slot-ref gv 'graph-canvas)
                                	:coords (list x y x y)
                                	:tags 'drag)))))))

(define (link:edge-drag-binding c)
  (bind c "<Motion>"
   (lambda (x y)
     (let   ((ol (find-items c 'withtag 'drag)))
	   (cond ((and (not (null? ol)) (> x 0) (> y 0))
	    (let* ((ol (find-items c 'withtag 'drag))
	           (oval-first  (< (cid (car ol)) (cid (cadr ol)))) 
	           (o  (if oval-first (car ol) (cadr ol)))
	           (l  (if oval-first (cadr ol) (car ol))))
	    (slot-set! o 'coords (list x y x y))
	    (let ((lcrds (coords l)))
	      (slot-set! l 'coords (append (list x y) (cddr lcrds))))))))
   )))


;;;; link:selected tag	- STk canvas widget uses the 'selected tag

(define (link:selected? v)
	(member "link:selected" (tags v)))

(define (link:unselect c)	
	(set! *link:selected-vertex-items* '())
	(set! *link:selected-edge-items* '())
	(let ((its (find-items c 'withtag 'link:selected)))
		(map (lambda (x) 
			(delete-tag x 'link:selected)
			(cond ((member "vertex" (tags x))
				(slot-set! x 'width 1)
				(set! (outline x) 'black))
			       (#t (set! (stipple x) "")))) its)))

(define (link:select-item x vtag-table etag-table)
	;;; allows duplicates (mult. segments in hyperedge)
	(let ((eg (hash-table-get etag-table (slot-ref x 'cid) #f)))
	    (cond ((and eg (not(member "link:selected" (tags eg))))
	      	    (set! *link:selected-edge-items* 
	   			(cons eg *link:selected-edge-items*))
		    (map (lambda (s)
   	     	   	   (add-tag s 'link:selected)
	           	   (set! (stipple s) 'gray50))
				        (slot-ref eg 'seg-list)))))
	     	    (let ((vg (hash-table-get vtag-table (slot-ref x 'cid) #f)))
			    (cond ((and vg
			  	        (not(member "link:selected" (tags vg))))
	     	       		  (set! *link:selected-vertex-items* 
		          		(cons vg *link:selected-vertex-items*))
   	     			  (add-tag vg 'link:selected)
	     	        	  (slot-set! vg 'width 3)
	     			  (set! (outline vg) 'black))))
)

(define (link:select-items c x y vtag-table etag-table)
		(let* ((its (find-items c 'withtag 'current)))
		     (cond ((not (null? its))
			     (link:select-item (car its) vtag-table etag-table))
			   (#t 	(set! *link:selection-box-x* x)
			  	(set! *link:selection-box-y* y)))
			))

(define (link:select-graph-items item-list gv)
	(let ((vt (slot-ref gv 'vertex-tag-table))
	      (et (slot-ref gv 'edge-tag-table)))
	   (map (lambda(x)
	 	    (cond ((vertex-item? x) 
				(link:select-item 
					(oval-item x) vt et))
			  ((edge-item? x)
				(link:select-item 
					(txt-item (car (seg-list x)))
					vt et))))
		     item-list)))

(define (link:selection-box-binding c)
  	(bind c "<B1-Motion>"
   		(lambda (x y)
		  (cond ((null? (find-items c 'withtag 'current))
     			(if (not (null? *link:selection-box*))
			  (destroy *link:selection-box*))
	      		(set! *link:selection-box* 
			      (make <rectangle> :parent c 
				  :coords (list 
					*link:selection-box-x*
				        *link:selection-box-y*
					x
					y))))
		 ))))
	      				

(define (link:selection-binding gv)
   (let ((c (slot-ref gv 'graph-canvas))
	 (vtag-table (slot-ref gv 'vertex-tag-table))
	 (etag-table (slot-ref gv 'edge-tag-table)))
     (bind c "<Button-1>" 
	(lambda (x y) 
		(link:unselect c)
		(link:select-items c x y vtag-table etag-table)
		(set! *link:selected-graph-view* gv)
		(cond ((> *link:canvas-clicks* 2)
		  	(set!   *link:selected-graph-view1* 
				*link:selected-graph-view2*)
		  	(set! *link:selected-graph-view2* gv))
		      ((= *link:canvas-clicks* 1)
		  	(set! *link:selected-graph-view2* gv))
		      ((= *link:canvas-clicks* 0)
		  	(set! *link:selected-graph-view1* gv)))
		(set! *link:canvas-clicks* (+ *link:canvas-clicks* 1))
	))))

(define (link:selection-release-binding c vtag-table etag-table)
   (bind c "<ButtonRelease-1>" 
	(lambda (x y) 
		(cond ((not (null? *link:selection-box*))
			(let ((its (apply find-items 
				     (append (list c 'enclosed)
					     (coords *link:selection-box*)))))
				(map (lambda (x)
				     (link:select-item x vtag-table etag-table))
				  its))
			(destroy *link:selection-box*)
			(set! *link:selection-box* '()))))))

(define (link:add-selection-binding c vtag-table etag-table)
   (bind c "<Shift-Button-1>" 
	(lambda (x y) 
		(link:select-items c x y vtag-table etag-table)
	)))

(define (link:induce-selected gv)
	(extract-induced-subgraph *link:selected-vertex-items* gv)
	(set! *link:selected-vertex-items* '())
	(set! *link:selected-edge-items* '()))

(define (link:collapse-selected gv)
	(collapse-subgraph *link:selected-vertex-items* gv)
	(set! *link:selected-vertex-items* '())
	(set! *link:selected-edge-items* '()))

(define (link:expand-selected gv)
	(map (lambda (v) (expand-subgraph v gv)) *link:selected-vertex-items*)
	(set! *link:selected-vertex-items* '())
	(set! *link:selected-edge-items* '()))

(define (link:delete-selected gv)
	(map (lambda (eg) (remove-edge-item! eg gv)) *link:selected-edge-items*)
	(map (lambda (eg) (remove-vertex-item! eg gv))
				*link:selected-vertex-items*)
	(set! *link:selected-vertex-items* '())
	(set! *link:selected-edge-items* '())
)

(define (link:extract-induced-subgraph-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-i>" 
	  (lambda(x y)
		(link:induce-selected gv))))

(define (link:collapse-subgraph-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-s>" 
	  (lambda(x y)
		(link:collapse-selected gv))))

(define (link:expand-subgraph-binding gv)
	(bind (slot-ref gv 'graph-toplevel) "<KeyPress-S>" 
	  (lambda(x y)
		(link:expand-selected gv))))

(define (link:deletion-binding gv)
   (bind (slot-ref gv 'graph-toplevel) "<KeyPress-x>" 
	(lambda (x y) 
		(link:delete-selected gv))))

(define (link:vertex-enter-binding c)
	(bind c 'vertex "<Any-Enter>" (lambda (x y) 
			(let ((v (car (find-items c 'withtag 'current))))
					(set! (stipple v) 'gray50)))))

(define (link:vertex-leave-binding c)
	(bind c 'vertex "<Any-Leave>" (lambda (x y) 
			(let ((v (car (find-items c 'withtag 'current))))
					(set! (stipple v) "")))))

(provide "graph-edit")