;; 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 (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-class () ((fill :getter fill :init-keyword :fill :allocation :tk-virtual) (parent :accessor parent :init-keyword :parent) (vertex :accessor vertex :init-keyword :vertex) (outline :accessor outline :init-keyword :outline :allocation :tk-virtual) (stipple :accessor stipple :init-keyword :stipple :allocation :tk-virtual) (tags :accessor tags :init-keyword :tags :allocation :tk-virtual) (vertex-label :initform "v" :accessor vertex-label :init-keyword :vertex-label) (color :initform *link:default-vertex-color* :accessor color :init-keyword :color :allocation :virtual :slot-ref (lambda (o) (let* ((clr (find-string-attribute 'color (slot-ref o 'vertex)))) (slot-set! o 'fill clr) clr)) :slot-set! (lambda (o c) (set-string-attribute! 'color c (slot-ref o 'vertex)) (slot-set! o 'fill c))) (width :accessor width :init-keyword :width :allocation :tk-virtual))) (define-method initialize-item ((self ) canvas coords args) (define v (eval `(apply ,canvas 'create 'oval ,@coords ',(get-keyword :tk-options args '())))) (slot-set! self 'cid v) (slot-set! self 'tags '("vertex")) v ) (define-generic guarded-oval?) (define-method guarded-oval? ((o )) #t) (define-method guarded-oval? ((o )) #f) ;***************************************************************************** (define vertex-font "-adobe-courier-bold-o-normal--18-180-75-75-m-110-iso8859-1") (define-class () ((oval-item :accessor oval-item) (txt-item :accessor txt-item) (vertex :getter vertex) (coords :getter coords :allocation :virtual :slot-ref (lambda (o) (let* ((ov (slot-ref o 'oval-item)) (cs (slot-ref ov 'coords)) (os (quotient (slot-ref o 'size) 2)) (x1 (+ (list-ref cs 0) os)) (y1 (+ (list-ref cs 1) os))) (list x1 y1))) :slot-set! (lambda (o l) (let* ((ov (slot-ref o 'oval-item)) (tx (slot-ref o 'txt-item)) (sz (slot-ref o 'size)) (os (quotient (slot-ref o 'size)2))) (set! (coords ov) (list (- (car l) os) (- (cadr l) os) (+ (car l) os) (+ (cadr l) os))) (set! (coords tx) (list (+ os 2 (car l)) (+ os 2 (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))) (ov (slot-ref o 'oval-item)) (tx (slot-ref o 'txt-item)) (cs (slot-ref ov 'coords)) (x1 (list-ref cs 0)) (y1 (list-ref cs 1))) (set! (coords ov) (list x1 y1 (+ x1 sz) (+ y1 sz))) (set! (coords tx) (list (+ (+ sz 2) x1) (+ (+ sz 2) y1))) sz)) :slot-set! (lambda (o l) (let* ((ov (slot-ref o 'oval-item)) (tx (slot-ref o 'txt-item)) (cds (slot-ref o 'coords)) (os (quotient l 2))) (set! (coords ov) (list (- (car cds) os) (- (cadr cds) os) (+ (car cds) os) (+ (cadr cds) os))) (set! (coords tx) (list (+ os 2 (car cds)) (+ os 2 (cadr cds)))) (set-attribute! 'size l (slot-ref o 'vertex)) (raise ov) (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 (oval-item)) (color :accessor color :init-keyword :color :allocation :propagated :propagate-to (oval-item)) (font :accessor 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))) (stipple :accessor stipple :init-keyword :stipple :allocation :propagated :propagate-to (oval-item)) (width :accessor width :init-keyword :width :allocation :propagated :propagate-to (oval-item)) (outline :accessor outline :init-keyword :outline :allocation :propagated :propagate-to (oval-item)) ;(background :accessor background ; :allocation :propagated ; :propagate-to ((oval-item fill))) )) (define-method initialize-item ((self ) canvas coords args) (let* ((parent (slot-ref self 'parent)) (vertex (get-keyword :vertex args "")) (vcolor (get-keyword :color args *link:default-vertex-color*)) (vsize (get-keyword :size args *link:default-vertex-size*)) (vlabel (get-keyword :vertex-label args (vertex-label vertex))) (text-object (make :text vlabel :parent parent :anchor "nw" :coords (list (+ (car coords) 12) (+ (cadr coords) 12)) ;;; :font vertex-font :text-color 'black :background 'orange)) (oval-object (make :parent parent :vertex vertex :color vcolor :coords (list (car coords) (cadr coords) (+ (car coords) vsize) (+(cadr coords) vsize)))) (Cid (gensym "vertex"))) (slot-set! self 'Cid Cid) (slot-set! self 'vertex vertex) (slot-set! self 'oval-item oval-object) (slot-set! self 'txt-item text-object) (slot-set! self 'vertex-label vlabel) (add-to-group self oval-object text-object) (bind-for-dragging parent :tag (slot-ref (slot-ref self 'oval-item) 'cid) :button 2 :only-current #f :start start-vertex-drag :motion update-oval-item-coords :stop stop-vertex-drag) Cid)) (provide "vertex")