STk-folk,
I've made some minor changes to my local copy of <Canvitem> (and
<Tk-meta>) that I find very helpful, so I thought I'd share them.
The primary motivation for the changes was to allow me to define
a <Group> subclass of <Tk-canvas-item> for groups of canvas items
held together by sharing a common tag. This was something I did
all the time in Tcl/Tk and STklos makes this even nicer. Methods
applied to the <Group> (such as move, rescale, or bind) apply to
all members of the group.
;----------------------------------------------------------------
(define-class <Group> (<Tk-canvas-item>)
((name :accessor name :initform (gensym "group"))
(members :accessor members :initform () :init-keyword :members))
:metaclass <Tk-item>)
(define-method initialize ((self <Group>) initargs)
(next-method)
(slot-set! self 'Cid (slot-ref self 'name))
(let ((mems (get-keyword :members initargs #f)))
(when mems (apply %tag-members self mems))))
(define-method create-item ((self <Group>) canvas coords newargs)
;; this is a "virtual" item, so do nothing
#t)
(define-method %tag-members ((self <Group>) . new-members)
(for-each
(lambda (m) (add-tag m (name self)))
new-members))
(define-method add-members ((self <Group>) . new-members)
(for-each
(lambda (m)
(when (not (member m (members self)))
(slot-set! self (cons m (members self)))))
new-members)
(apply %tag-members self new-members))
;----------------------------------------------------------------
The truly useful thing is to subclass off of <Group> to create
application-specific groups of items.
The catch is that, in order for the above code to work, you need
to make a few changes to <Canvitem> and <Tk-meta>, which I believe
are healthy changes anyway.
The change to Tk-meta is small, so I'll list it first. The method
compute-get-n-set is simply made more robust:
;----------------------------------------------------------------
(define-method compute-get-n-set ((class <Tk-item>) s)
(if (eqv? :pseudo (get-keyword :allocation (cdr s) :instance))
;; Psudo slot for a Tk-item
(let* ((tk-name (get-keyword :tk-name (cdr s) (car s)))
(slot-name (make-keyword tk-name)))
(list
;; ====> THIS LAMBDA EXPRESSION IS ALL THAT CHANGED <=====
(lambda (o)
(let ((value [(slot-ref o 'Id) 'itemconf (slot-ref o 'Cid) slot-name]))
(if (null? value) value (list-ref value 2))))
(lambda (o v)
((slot-ref o 'Id) 'itemconf (slot-ref o 'Cid) slot-name v))))
;; "Normal" slot. Lets superclass do the job
(next-method)))
;----------------------------------------------------------------
Finally, the changes to <Canvitem> (and its subclasses) are small
but spread out, so I'll simply include the file at the end. The
general idea is that Tk::class-item-alist is eliminated. The job
of creating the canvas item is handled in a new method called create-item.
This is done so that <Group> can override create-item to do nothing
(there is no canvas item created for a group). These changes also
have the nice benefit that subclassing off of <Rectangle>, <Arc>,
and so on is much easier now.
Regards,
Rob DeLine
;----------------------------------------------------------------
;;;;
;;;; c a n v i t e m . s t k -- Canvas Items classes definition
;;;;
;;;; Copyright (C) 1993, 1994 Erick Gallesio - I3S - CNRS / UNSA <eg_at_unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; Author: Erick Gallesio [eg_at_kaolin.unice.fr]
;;;; Creation date: 24-Aug-1993 11:24
;;;; Last file update: 3-Jun-1994 13:14
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Tk-canvas-item> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Tk-canvas-item> (<Tk-object>)
((Cid :initform ()
:getter Cid)
(tags :accessor tags
:init-keyword :tags
:allocation :pseudo)
(coords :accessor coords
:init-keyword :coords
:allocation :virtual
:slot-ref (lambda (o)
((slot-ref o 'Id) 'coords (slot-ref o 'Cid)))
:slot-set! (lambda (o v)
(apply (slot-ref o 'Id) 'coords (slot-ref o 'Cid) v)))))
(define-method initialize ((self <Tk-canvas-item>) initargs)
(let* ((parent (get-keyword :parent initargs '()))
(coords (get-keyword :coords initargs '()))
(tk-name (Tk::make-tk-name parent '()))
(newargs '())
(valids (slot-ref (class-of self) 'tk-valid-options)))
;; Verify that parent exists and that it is a canvas
(when (null? parent)
(error "**** You must specify the canvas which contain this object"))
(unless (eqv? (class-of parent) <Canvas>)
(error "**** Specified canvas ~A is not valid" parent))
;; Filter initargs to pass only valid options to TK
(do ((args initargs (cddr args)))
((null? args))
(let ((opt (assoc (car args) valids)))
(if opt
(set! newargs (cons (cdr opt) (cons (cadr args) newargs))))))
;; Now newargs contains the filtered options.
(slot-set! self 'Id (slot-ref parent 'Id))
(slot-set! self 'parent parent)
(next-method)
(slot-set! self 'Cid (create-item self (slot-ref parent 'Id) coords newargs))
(hash-table-put! (slot-ref parent 'items) Cid self)))
(define-method create-item ((self <Tk-canvas-item>) canvas coords newargs)
; do nothing by default
#t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Utilities
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; tag-value delivers the integer Id of an object
(define-method tag-value ((object <Tk-canvas-item>))
(slot-ref object 'Cid))
;;;
;;; Utility: Cid->instance
;;;
(define-method Cid->instance ((canvas <Canvas>) id)
(hash-table-get (slot-ref canvas 'items) id #f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Tk-canvas-item> methods
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Add-tag
;;;
(define-method add-tag ((self <Tk-canvas-item>) tag)
((slot-ref self 'Id) 'addtag tag 'withtag (slot-ref self 'Cid)))
;;;
;;; Bounding-box
;;;
(define-method bounding-box ((self <Tk-canvas-item>))
((slot-ref self 'Id) 'bbox (slot-ref self 'Cid)))
;;;
;;; Bind
;;;
(define-method bind ((self <Tk-canvas-item>) . args)
(apply (slot-ref self 'Id) 'bind (slot-ref self 'Cid) args))
;;;
;;; Delete-chars
;;;
(define-method delete-chars ((self <Tk-Canvas-item>) first . last)
(apply (slot-ref self 'Id) 'dchars (slot-ref self 'Cid) first last))
;;;
;;; Delete/Destroy
;;;
(define-method destroy ((self <Tk-canvas-item>))
;; First delete item from canvas
((slot-ref self 'Id) 'delete (slot-ref self 'Cid))
;; Now delete its reference in the hash table
(hash-table-remove! (slot-ref (slot-ref self 'Id) 'items)
(slot-ref self 'Cid)))
(define-method delete ((self <Tk-canvas-item>))
;; For compatibility with older versions
(destroy self))
;;;
;;; Delete-tag
;;;
(define-method delete-tag ((self <Tk-canvas-item>) tag-to-delete)
((slot-ref self 'Id) 'dtag (slot-ref self 'Cid) tag-to-delete))
;;;;;;;;;; find is useless for Tk-canvas-item
;;;
;;; focus
;;;
(define-method focus ((self <Tk-canvas-item>))
((slot-ref self 'Id) 'focus (slot-ref self 'Cid)))
;;;
;;; get-tags
;;;
(define-method get-tags ((self <Tk-canvas-item>))
((slot-ref self 'Id) 'gettags (slot-ref self 'Cid)))
;;;
;;; Icursor
;;;
(define-method icursor ((self <Tk-Canvas-item>) index)
((slot-ref self 'Id) 'icursor (slot-ref self 'Cid) index))
;;;
;;; Index
;;;
(define-method text-index ((self <Tk-Canvas-item>) index)
((slot-ref self 'Id) 'index (slot-ref self 'Cid) index))
;;;
;;; Insert
;;;
(define-method text-insert ((self <Tk-Canvas-item>) before string)
((slot-ref self 'Id) 'insert (slot-ref self 'Cid) before string))
;;;
;;; Lower
;;;
(define-method lower ((self <Tk-canvas-item>) . below)
(apply (slot-ref self 'Id) 'lower (slot-ref self 'Cid) (map tag-value below)))
;;;
;;; Move
;;;
(define-method move ((self <Tk-canvas-item>) x y)
((slot-ref self 'Id) 'move (slot-ref self 'Cid) x y))
;;;;;;;;;; postscript has no sense for Tk-canvas-item
;;;
;;; Raise
;;;
(define-method raise ((self <Tk-canvas-item>) . above)
(apply (slot-ref self 'Id) 'raise (slot-ref self 'Cid) (map tag-value above)))
;;;
;;; Rescale
;;;
(define-method rescale ((self <Tk-canvas-item>) x y xs ys)
((slot-ref self 'Id) 'scale (slot-ref self 'Cid) x y xs ys))
;;;
;;; Text-selection (not implemented. What is the prototype?)
;;;
;;;;;;;; item-type can (approximatively) be obtained by (class-name(class-of xxx))
;;;
;;; xview
;;;
(define-method xview ((self <Tk-canvas-item>) x)
((slot-ref self 'Id) 'xview x))
;;;
;;; yview
;;;
(define-method yview ((self <Tk-canvas-item>) x)
((slot-ref self 'Id) 'yview x))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Arc> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Arc>")
(define-class <Arc> (<Tk-canvas-item>)
((extent :accessor extent :init-keyword :extent :allocation :pseudo)
(fill :accessor fill :init-keyword :fill :allocation :pseudo)
(outline :accessor outline :init-keyword :outline :allocation :pseudo)
(start :accessor start :init-keyword :start :allocation :pseudo)
(stipple :accessor stipple :init-keyword :stipple :allocation :pseudo)
(style :accessor style :init-keyword :style :allocation :pseudo)
(width :accessor width :init-keyword :width :allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Arc>) canvas coords newargs)
(eval `(,canvas 'create 'arc ,_at_coords ,_at_newargs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Bitmap> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Bitmap>")
(define-class <Bitmap> (<Tk-canvas-item>)
((anchor :accessor anchor :init-keyword :anchor :allocation :pseudo)
(background :accessor background :init-keyword :background :allocation :pseudo)
(bitmap :accessor bitmap :init-keyword :bitmap :allocation :pseudo)
(foreground :accessor foreground :init-keyword :foreground :allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Bitmap>) canvas coords newargs)
(eval `(,canvas 'create 'bitmap ,_at_coords ,_at_newargs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Line> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Line>")
(define-class <Line> (<Tk-canvas-item>)
((arrow :accessor arrow
:init-keyword :arrow
:allocation :pseudo)
(arrow-shape :accessor arrow-shape
:init-keyword :arrow-shape
:tk-name arrowshape
:allocation :pseudo)
(capstyle :accessor capstyle
:init-keyword :capstyle
:allocation :pseudo)
(fill :accessor fill
:init-keyword :fill
:tk-name fill
:allocation :pseudo)
(join-style :accessor join-style
:init-keyword :join-style
:tk-name joinstyle
:allocation :pseudo)
(smooth :accessor smooth
:init-keyword :smooth
:allocation :pseudo)
(spline-steps :accessor spline-steps
:init-keyword :spline-steps
:tk-name splinesteps
:allocation :pseudo)
(stipple :accessor stipple
:init-keyword :stipple
:allocation :pseudo)
(width :accessor width
:init-keyword :width
:allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Line>) canvas coords newargs)
(eval `(,canvas 'create 'line ,_at_coords ,_at_newargs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Oval> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Oval>")
(define-class <Oval> (<Tk-canvas-item>)
((fill :accessor fill :init-keyword :fill :allocation :pseudo)
(outline :accessor outline :init-keyword :outline :allocation :pseudo)
(stipple :accessor stipple :init-keyword :stipple :allocation :pseudo)
(tags :accessor tags :init-keyword :tags :allocation :pseudo)
(width :accessor width :init-keyword :width :allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Oval>) canvas coords newargs)
(eval `(,canvas 'create 'oval ,_at_coords ,_at_newargs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Polygon> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Polygon>")
(define-class <Polygon> (<Tk-canvas-item>)
((fill :accessor fill
:init-keyword :fill
:allocation :pseudo)
(smooth :accessor smooth
:init-keyword :smooth
:allocation :pseudo)
(stipple :accessor stipple
:init-keyword :stipple
:allocation :pseudo)
(spline-steps :accessor spline-steps
:init-keyword :spline-steps
:tk-name splinesteps
:allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Polygon>) canvas coords newargs)
(eval `(,canvas 'create 'poly ,_at_coords ,_at_newargs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Rectangle> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Rectangle>")
(define-class <Rectangle> (<Tk-canvas-item>)
((fill :accessor fill :init-keyword :fill :allocation :pseudo)
(outline :accessor outline :init-keyword :outline :allocation :pseudo)
(stipple :accessor stipple :init-keyword :stipple :allocation :pseudo)
(width :accessor width :init-keyword :width :allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Rectangle>) canvas coords newargs)
(eval `(,canvas 'create 'rect ,_at_coords ,_at_newargs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Text> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Text>")
(define-class <Text> (<Tk-canvas-item>)
((anchor :accessor anchor :init-keyword :anchor :allocation :pseudo)
(fill :accessor fill :init-keyword :fill :allocation :pseudo)
(justify :accessor justify :init-keyword :justify :allocation :pseudo)
(font :accessor font :init-keyword :font :allocation :pseudo)
(stipple :accessor stipple :init-keyword :stipple :allocation :pseudo)
(text :accessor text-of :init-keyword :text :allocation :pseudo)
(width :accessor width :init-keyword :width :allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Text>) canvas coords newargs)
(eval `(,canvas 'create 'text ,_at_coords ,_at_newargs)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Window> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Say-define "<Window>")
(define-class <Window> (<Tk-canvas-item>)
((anchor :accessor anchor :init-keyword :anchor :allocation :pseudo)
(height :accessor height :init-keyword :height :allocation :pseudo)
(width :accessor width :init-keyword :width :allocation :pseudo)
(window :accessor window :init-keyword :window :allocation :pseudo))
:metaclass <Tk-item>)
(define-method create-item ((self <Window>) canvas coords newargs)
(eval `(,canvas 'create 'window ,_at_coords ,_at_newargs)))
(provide "Canvitem")
;----------------------------------------------------------------
Received on Sun Jul 24 1994 - 02:22:00 CEST