Re: stklos question relating to Tk-composite-item and the like.

From: Kevin K. Lewis <lewikk_at_rockdal.aud.alcatel.com>
Date: Tue, 27 Feb 96 07:12:10 CST

> Date: Mon, 26 Feb 1996 17:54:48 -0500
> From: Jonathan Berry <berryj_at_dimacs.rutgers.edu>
>
> This is a message for any STklos experts out there. I have a question
> possibly relating to <Tk-composite-item> and generally relating to
> initialize-item. Here is a current goal of mine: I would like a
> canvas item class with the following attributes:
> * a canvas figure derived from <oval>
> * a <text-item> which will be associated to that figure & will
> move around with it.

Believe it or not, I just did something _very_ similar to this. Note
that since STk's `bind-for-dragging' is busted, you may only
effectively bind one object for dragging. Also, I'm not sure about
your other requirements, but this is an Oval with centered Text, and
they drag together.

Here's my class (which has stuff taken from the E? example):

----
;; Defaults.
(define bon-class-background-color "Yellow")
(define bon-class-foreground-color "Black")
;; This is the actual height of the graphic.
(define bon-class-graphic-height 60)
;; This is how many extra pixels to put at each end of the text.
(define bon-class-graphic-width 10)
(define bon-class-font
  "-adobe-courier-bold-o-normal--18-180-75-75-m-110-iso8859-1")
;; Class definition.
(define-class <BON-Class> (<Tk-Composite-Item>)
  ((oval-item           :accessor       oval-item)
   (text-item           :accessor       text-item)
   (tail                :accessor       tail-of
                        :allocation     :virtual
                        :slot-ref       (lambda (o)
                                          (let* ((ov (slot-ref o 'oval-item))
                                                 (cs (slot-ref ov 'coords))
                                                 (x1 (list-ref cs 0))
                                                 (x2 (list-ref cs 2))
                                                 (y2 (list-ref cs 3)))
                                          (list (- x2 (/ (- x2 x1) 2)) y2)))
                        :slot-set!      ())
   (head                :getter         head-of
                        :allocation     :virtual
                        :slot-ref       (lambda (o)
                                          (let* ((ov (slot-ref o 'oval-item))
                                                 (cs (slot-ref ov 'coords))
                                                 (x1 (list-ref cs 0))
                                                 (x2 (list-ref cs 2))
                                                 (y1 (list-ref cs 1)))
                                          (list (- x2 (/ (- x2 x1) 2)) y1)))
                        :slot-set!      ())
   (width               :getter         width-of
                        :allocation     :virtual
                        :slot-ref       (lambda (o)
                                          (let* ((ov (slot-ref o 'oval-item))
                                                 (cs (slot-ref ov 'coords))
                                                 (x1 (list-ref cs 0))
                                                 (x2 (list-ref cs 2)))
                                            (- x2 x1)))
                        :slot-set!      ())
   (height              :getter         height-of
                        :allocation     :virtual
                        :slot-ref       (lambda (o)
                                          (let* ((ov (slot-ref o 'oval-item))
                                                 (cs (slot-ref ov 'coords))
                                                 (y1 (list-ref cs 1))
                                                 (y2 (list-ref cs 3)))
                                            (- y2 y1)))
                        :slot-set!      ())
   ;; Propagated slots
   (text                :getter         text-of
                        :init-keyword   :text
                        :allocation     :propagated
                        :propagate-to   (text-item))
   (coords              :getter         coords
                        :init-keywords  :coords
                        :allocation     :propagated
                        :propagate-to   (oval-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)))
   ))
;; Find the boundaries for an oval.
(define oval-bound
  (lambda (text height width)
    (let* ((bb (bounding-box text))
           (x1 (list-ref bb 0))         ; The coordinates of the text
           (y1 (list-ref bb 1))         ; boundary box.
           (x2 (list-ref bb 2))
           (y2 (list-ref bb 3))
           (x1p (- x1 width))           ; The coordinates of the oval bbox.
           (y1p (- (+ y1 (/ (- y2 y1) 2)) (/ height 2)))
           (x2p (+ x2 width))
           (y2p (+ y1p height)))
      (list x1p y1p x2p y2p))
    ))
;; Initializer for <BON-Class>'s.
(define-method initialize-item ((self <BON-Class>) 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 coords
                            :font bon-class-font
                            :foreground bon-class-foreground-color
                            :background bon-class-background-color))
         (bound       (oval-bound text-object
                                  bon-class-graphic-height
                                  bon-class-graphic-width))
         (oval-object (make <Oval> :parent parent
                            :coords bound :fill bon-class-background-color))
         (Cid         (gensym "bon-class-")))
    ;; Set the true slots.
    (slot-set! self 'Cid Cid)
    (slot-set! self 'oval-item oval-object)
    (slot-set! self 'text-item text-object)
    ;; Add the oval-object and text-object component to the "Group"
    ;; with tag "Cid".
    (add-to-group self oval-object text-object)
    ;; Raise the text to be sure it will not be under the rectangle
    (raise text-object)
    ;; Return Cid
    Cid))
----
Good luck.
-- 
Kevin K. Lewis               | My opinions may be unreasonable
lewikk_at_aud.alcatel.com       | but such is the voice of inspiration

Received on Tue Feb 27 1996 - 14:38:38 CET