stk/STklos/Tk/Canvitem.stklos

468 lines
15 KiB
Plaintext
Raw Normal View History

1996-09-27 06:29:02 -04:00
;;;;
;;;; C a n v i t e m . s t k -- Canvas Items classes definition
;;;;
1999-09-05 07:16:41 -04:00
;;;; Copyright <20> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1996-09-27 06:29:02 -04:00
;;;;
1999-09-05 07:16:41 -04:00
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; 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.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
1998-04-10 06:59:06 -04:00
;;;;
1996-09-27 06:29:02 -04:00
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;; Creation date: 24-Aug-1993 11:24
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 20:10 (eg)
1998-04-10 06:59:06 -04:00
;;;
;;; This file must not be loaded directly but from Canvas.stklos
;;;
1996-09-27 06:29:02 -04:00
1998-04-10 06:59:06 -04:00
(select-module STklos+Tk)
(export initialize-item add-to-group delete-from-group
items-of-group tag-value Cid->instance)
1996-09-27 06:29:02 -04:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Tk-canvas-item>
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Tk-canvas-item> (<Tk-object>)
((Cid :getter Cid))
:metaclass <Tk-item-metaclass>)
(define-method initialize ((self <Tk-canvas-item>) initargs)
(let* ((parent (get-keyword :parent initargs #f))
(coords (get-keyword :coords initargs '())))
;; Verify that parent exists and that it is a canvas
(unless parent
1998-04-10 06:59:06 -04:00
(error "**** You must specify the canvas which contains this object"))
1996-09-27 06:29:02 -04:00
(unless (is-a? parent <Canvas>)
(error "**** Specified canvas ~A is not valid" parent))
(let ((parent-Id (slot-ref parent 'Id)))
(slot-set! self 'parent parent)
(slot-set! self 'Id parent-Id)
(slot-set! self 'Eid parent-Id)
;; Initialize Cid last because composite item need it
(let ((Cid (initialize-item self parent-Id coords initargs)))
(slot-set! self 'Cid Cid)
(hash-table-put! (slot-ref parent 'items) Cid self)))
(next-method)))
1998-04-10 06:59:06 -04:00
1996-09-27 06:29:02 -04:00
(define-method initialize-item ((self <Tk-canvas-item>) canv-Id coords args)
(error "initialize-item: no method for ~S subclass" self))
(define-method Tk-write-object ((self <Tk-Canvas-item>) port)
(write (slot-ref self 'Cid) port))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Tk-canvas-figure> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Tk-canvas-figure> (<Tk-canvas-item>)
((tags :accessor tags
:init-keyword :tags
:allocation :tk-virtual)
(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-item ((self <Tk-canvas-figure>) canv-Id coords args)
(apply canv-Id 'create (canvas-item-initializer self)
(append coords (get-keyword :tk-options args '()))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Tk-composite-item> class
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Tk-composite-item> (<Tk-canvas-item>)
()
:metaclass <Tk-composite-item-metaclass>)
(define-method add-to-group ((self <Tk-composite-item>) . items)
(let ((tag (Cid self)))
(for-each (lambda (i) (add-tag i tag)) items)))
(define-method delete-from-group ((self <Tk-composite-item>) item)
(delete-tag item (Cid self)))
(define-method items-of-group ((self <Tk-composite-item>))
(find-items (slot-ref self 'parent) 'withtag (Cid self)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Canvas-group> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Canvas-group> (<Tk-composite-item>)
()
)
(define-method initialize-item ((self <Canvas-group>) parent-Id coords initargs)
;; Just return the tag which will be shared among items
(gensym "group"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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 (Cid->instance 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>))
(let ((parent (slot-ref self 'parent))
(cid-item (slot-ref self 'Cid)))
;; First delete item from canvas
((slot-ref parent 'Id) 'delete cid-item)
;; Now delete its reference in the hash table
(hash-table-remove! (slot-ref parent 'items) cid-item)
;; Change class of the item to <Destroyed-object>
(change-class self <Destroyed-object>)))
(define-method destroy ((self <Tk-composite-item>))
(let* ((parent (slot-ref self 'parent))
(all (find-items parent 'with (Cid self))))
;; Destroy each components
(for-each destroy all)
;; Delete reference of the group in hash table
(hash-table-remove! (slot-ref parent 'items) (Cid self)))
;; Change class of the group to <Destroyed-object>
(change-class self <Destroyed-object>))
1998-04-10 06:59:06 -04:00
#|
1996-09-27 06:29:02 -04:00
(define-method delete ((self <Tk-canvas-item>))
;; For compatibility with older versions
(destroy self))
1998-04-10 06:59:06 -04:00
|#
1996-09-27 06:29:02 -04:00
;;;
;;; 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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Arc> (<Tk-canvas-figure>)
((extent :accessor extent :init-keyword :extent :allocation :tk-virtual)
(fill :accessor fill :init-keyword :fill :allocation :tk-virtual)
(outline :accessor outline :init-keyword :outline :allocation :tk-virtual)
(start :accessor start :init-keyword :start :allocation :tk-virtual)
(stipple :accessor stipple :init-keyword :stipple :allocation :tk-virtual)
(style :accessor style :init-keyword :style :allocation :tk-virtual)
(width :accessor width :init-keyword :width :allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Arc>)) "arc")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Bitmap-item> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Bitmap-item> (<Tk-canvas-figure>)
((anchor :accessor anchor
:init-keyword :anchor
:allocation :tk-virtual)
(background :accessor background
:init-keyword :background
:allocation :tk-virtual)
(bitmap-name :accessor bitmap-name
:init-keyword :bitmap-name
:tk-name bitmap
:allocation :tk-virtual)
(foreground :accessor foreground
:init-keyword :foreground
:allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Bitmap-Item>)) "bitmap")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Image-item> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Image-item> (<Tk-canvas-figure>)
((anchor :accessor anchor
:init-keyword :anchor
:allocation :tk-virtual)
(image-name :accessor image-name
:init-keyword :image-name
:tk-name image
:allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Image-Item>)) "image")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Line> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Line> (<Tk-canvas-figure>)
((arrow :accessor arrow
:init-keyword :arrow
:allocation :tk-virtual)
(arrow-shape :accessor arrow-shape
:init-keyword :arrow-shape
:tk-name arrowshape
:allocation :tk-virtual)
(cap-style :accessor cap-style
:init-keyword :cap-style
:tk-name capstyle
:allocation :tk-virtual)
(fill :accessor fill
:init-keyword :fill
:tk-name fill
:allocation :tk-virtual)
(join-style :accessor join-style
:init-keyword :join-style
:tk-name joinstyle
:allocation :tk-virtual)
(smooth :accessor smooth
:init-keyword :smooth
:allocation :tk-virtual)
(spline-steps :accessor spline-steps
:init-keyword :spline-steps
:tk-name splinesteps
:allocation :tk-virtual)
(stipple :accessor stipple
:init-keyword :stipple
:allocation :tk-virtual)
(width :accessor width
:init-keyword :width
:allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Line>)) "line")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Oval> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Oval> (<Tk-canvas-figure>)
((fill :accessor fill :init-keyword :fill :allocation :tk-virtual)
(outline :accessor outline :init-keyword :outline :allocation :tk-virtual)
(stipple :accessor stipple :init-keyword :stipple :allocation :tk-virtual)
(width :accessor width :init-keyword :width :allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Oval>)) "oval")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Polygon> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Polygon> (<Tk-canvas-figure>)
((fill :accessor fill
:init-keyword :fill
:allocation :tk-virtual)
(outline :accessor outline
:init-keyword :outline
:allocation :tk-virtual)
(smooth :accessor smooth
:init-keyword :smooth
:allocation :tk-virtual)
(spline-steps :accessor spline-steps
:init-keyword :spline-steps
:tk-name splinesteps
:allocation :tk-virtual)
(stipple :accessor stipple
:init-keyword :stipple
:allocation :tk-virtual)
(width :accessor width
:init-keyword :width
:allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Polygon>)) "polygon")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Rectangle> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Rectangle> (<Tk-canvas-figure>)
((fill :accessor fill :init-keyword :fill :allocation :tk-virtual)
(outline :accessor outline :init-keyword :outline :allocation :tk-virtual)
(stipple :accessor stipple :init-keyword :stipple :allocation :tk-virtual)
(width :accessor width :init-keyword :width :allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Rectangle>)) "rectangle")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Text-Item> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Text-item> (<Tk-canvas-figure>)
((anchor :accessor anchor :init-keyword :anchor :allocation :tk-virtual)
(fill :accessor fill :init-keyword :fill :allocation :tk-virtual)
(font :accessor font :init-keyword :font :allocation :tk-virtual)
(justify :accessor justify :init-keyword :justify :allocation :tk-virtual)
(stipple :accessor stipple :init-keyword :stipple :allocation :tk-virtual)
(text :accessor text-of :init-keyword :text :allocation :tk-virtual)
(width :accessor width :init-keyword :width :allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Text-item>)) "text")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <Canvas-window> class definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class <Canvas-Window> (<Tk-canvas-figure>)
((anchor :accessor anchor :init-keyword :anchor :allocation :tk-virtual)
(height :accessor height :init-keyword :height :allocation :tk-virtual)
(width :accessor width :init-keyword :width :allocation :tk-virtual)
(window :accessor window :init-keyword :window :allocation :tk-virtual)))
(define-method canvas-item-initializer((self <Canvas-window>)) "window")