137 lines
4.5 KiB

;;;; E x a m p l e 2. s t k
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; 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.
;;;; Author: Erick Gallesio []
;;;; Creation date: 4-Aug-1994 15:22
;;;; Last file update: 3-Sep-1999 20:07 (eg)
(require "Canvas")
(define c (make <Canvas>))
(pack c)
;;;; Hereafter is a definition of a new composite Canvas item. This composite
;;;; object is formed of a text contained in a box.
;;;; Note how values are propagated: For instance changing the font of
;;;; a <Boxed-text> will propagate this change to the object contained in the slot
;;;; text-item. changing the foregroung of a <Boxed-text> will be propagated to
;;;; the "outline" of its box and to the "fill" of its text.
(define-class <Boxed-Text> (<Tk-Composite-item>)
((box-item :accessor box-item)
(text-item :accessor text-item)
;; 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 (text-item))
(font :getter font
:init-keyword :font
:allocation :propagated
:propagate-to (text-item))
(foreground :accessor foreground
:allocation :propagated
:propagate-to ((box-item outline) (text-item fill)))
(background :accessor background
:allocation :propagated
:propagate-to ((box-item fill)))))
;;;; Herafter is a definition of the initialize-item method which will be
;;;; automagically called upon instance creation. This is this routine which
;;;; will create the components of the composite object.
(define-method initialize-item ((self <Boxed-Text>) canvas coords args)
(let* ((parent (slot-ref self 'parent))
(text (get-keyword :text args ""))
(t (make <Text-item> :text text
:anchor "nw" :parent parent :coords coords))
(coords-rect (bounding-box t))
(r (make <Rectangle> :parent parent :coords coords-rect))
(Cid (gensym "group")))
;; set the true slots
(slot-set! self 'Cid Cid)
(slot-set! self 'box-item r)
(slot-set! self 'text-item t)
;; Add the r and t component to the "Group" whith tag "Cid"
(add-to-group self r t)
;; Raise the text to be sure it will not be under the rectangle
(raise t)
;; Give this association a default binding allowing it to be moved with mouse
(bind-for-dragging parent :tag Cid :only-current #f)
;; Return Cid
;;;; Some methods which guarantish that the box is always the good size
(define-method (setter font) ((bt <Boxed-text>) value)
(let ((t (text-item bt)))
(set! (font t) value)
(set! (coords (box-item bt)) (bounding-box t))))
(define-method (setter text-of) ((bt <Boxed-text>) value)
(let ((t (text-item bt)))
(set! (text-of t) value)
(set! (coords (box-item bt)) (bounding-box t))))
(define-method (setter coords) ((bt <Boxed-text>) value)
(unless (and (list? value) (= (length value) 2))
(error "coords: must be a list of 2 elements. It was ~S" value))
(let ((t (text-item bt)))
(set! (coords t) value)
(set! (coords (box-item bt)) (bounding-box t))))
;;;; And now a little demo using the preceding new widget
(define (demo)
(let ((x (make <Boxed-text> :parent c :coords '(50 50) :text "Hello")))
(after 1000)
(do ((i 0 (+ i 3)))
((> i 200))
(set! (coords x) (list i i))
(after 1000)
(set! (coords x) '(100 100))
(set! (font x) "10x20")
(set! (text-of x) "That's all, folks!")
(set! (background x) "lightblue")
;; Destroying the group will destroy all the components and change the class
;; of x to <Destroyed-object>
(after 1000)
(destroy x)
(format #t "class of x = ~S\n" (class-name (class-of x)))))
;;; Run the demo