solution to earlier Tk-composite-item problem

From: Jonathan Berry <berryj_at_dimacs.rutgers.edu>
Date: Tue, 27 Feb 1996 15:11:27 -0500

; To the stklos'ers out there: Thanks to Kevin Lewis
; (lewikk_at_rockdal.aud.alcatel.com (Kevin K. Lewis))
; for sending me a sample of his code. It proved to
; me that I could use Tk-composite-item for my task after
; all. I've included a modified version of his code below
; which does exactly what I had in mind (modulo the
; bind-for-dragging glitch). - Jon Berry
;********************************************************************

(require "Canvas")
(define vertex-background-color "Yellow")
(define vertex-foreground-color "Black")

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

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

(define-class <vertex> (<Tk-Composite-Item>)
  ((oval-item :accessor oval-item)
   (text-item :accessor text-item)

   (coords :accessor coords
                        :allocation :virtual
                        :slot-ref (lambda (o)
                                          (let* ((ov (slot-ref o 'oval-item))
                                                 (cs (slot-ref ov 'coords))
                                                 (x1 (list-ref cs 0))
                                                 (y1 (list-ref cs 1)))
                                          (list x1 y1)))
                        :slot-set! (lambda (o l)
                                          (let* ((ov (slot-ref o 'oval-item))
                                                 (tx (slot-ref o 'text-item)))
                                             (set! (coords ov) (list (car l)
                                                 (cadr l) (+ 10 (car l))
                                                          (+ 10 (cadr l))))
                                             (set! (coords tx) (list
                                                          (+ 12 (car l))
                                                          (+ 12 (cadr l)))))))
   ;; Propagated slots
   (text :accessor text
                        :init-keyword :text
                        :allocation :propagated
                        :propagate-to (text-item))
   (font :getter font
                        :init-keyword :font
                        :allocation :propagated
                        :propagate-to (text-item))
   (foreground :accessor foreground
                        :allocation :propagated
                        :propagate-to ((oval-item outline)
                                         (text-item fill)))
   (background :accessor background
                        :allocation :propagated
                        :propagate-to ((oval-item fill)))
   ))

(define-method initialize-item ((self <vertex>) canvas coords args)
  (let* ((parent (slot-ref self 'parent))
         (text (get-keyword :text args ""))
         (text-object (make <Text-Item> :text text :parent parent
                            :anchor "nw" :coords (list
                                (+ (car coords) 12) (+ (cadr coords) 12))
                            ;;; :font vertex-font
                            :foreground vertex-foreground-color
                            :background vertex-background-color))
         (oval-object (make <Oval> :parent parent
                            :coords (list (car coords) (cadr coords)
                                (+ (car coords) 10) (+ (cadr coords) 10))
                            :fill vertex-background-color))
         (Cid (gensym "vertex")))

    (slot-set! self 'Cid Cid)
    (slot-set! self 'oval-item oval-object)
    (slot-set! self 'text-item text-object)

    (add-to-group self oval-object text-object)
    Cid))

(define c (make <canvas>))
(pack c)
(define v (make <vertex> :parent c :coords '(100 100) :text "1"))
(set! (coords v) '(150 150))
Received on Tue Feb 27 1996 - 21:13:43 CET