137 lines
4.5 KiB
Plaintext
137 lines
4.5 KiB
Plaintext
;;;;
|
|
;;;; E x a m p l e 2. s t k
|
|
;;;;
|
|
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; 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 [eg@kaolin.unice.fr]
|
|
;;;; 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
|
|
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")))
|
|
(update)
|
|
|
|
(after 1000)
|
|
(do ((i 0 (+ i 3)))
|
|
((> i 200))
|
|
(set! (coords x) (list i i))
|
|
(update))
|
|
|
|
(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>
|
|
(update)
|
|
(after 1000)
|
|
(destroy x)
|
|
(format #t "class of x = ~S\n" (class-name (class-of x)))))
|
|
|
|
|
|
;;; Run the demo
|
|
(demo)
|
|
|