home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / STklos / Examples / E2.stklos < prev    next >
Encoding:
Text File  |  1996-01-17  |  4.6 KB  |  136 lines
  1. ;;;;
  2. ;;;; E x a m p l e 2.  s t k
  3. ;;;;
  4. ;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date:  4-Aug-1994 15:22 
  16. ;;;; Last file update: 17-Jan-1996 23:14
  17.  
  18.  
  19. (require "Canvas")
  20. (define c (make <Canvas>))
  21. (pack c)
  22.  
  23. ;;;; Hereafter is a definition of a new composite Canvas item. This composite
  24. ;;;; object is formed of a text contained in a box.
  25. ;;;; Note how values are propagated: For instance changing the font of 
  26. ;;;; a <Boxed-text> will propagate this change to the object contained in the slot 
  27. ;;;; text-item. changing the foregroung of a  <Boxed-text> will be propagated to 
  28. ;;;; the "outline" of its box and to the "fill" of its text.
  29.  
  30. (define-class <Boxed-Text> (<Tk-Composite-item>)
  31.   ((box-item   :accessor     box-item)
  32.    (text-item  :accessor     text-item)
  33.    ;; Propagated slots
  34.    (text       :getter         text-of
  35.            :init-keyword     :text
  36.            :allocation     :propagated 
  37.            :propagate-to     (text-item))
  38.    (coords     :getter         coords 
  39.            :init-keywords     :coords
  40.            :allocation     :propagated
  41.            :propagate-to     (text-item))
  42.    (font       :getter         font
  43.            :init-keyword    :font
  44.            :allocation     :propagated 
  45.            :propagate-to     (text-item))
  46.    (foreground :accessor     foreground
  47.            :allocation     :propagated 
  48.            :propagate-to     ((box-item outline) (text-item fill)))
  49.    (background :accessor     background
  50.            :allocation     :propagated
  51.            :propagate-to     ((box-item fill)))))
  52.  
  53. ;;;; Herafter is a definition of the initialize-item method which will be 
  54. ;;;; automagically called upon instance creation. This is this routine which 
  55. ;;;; will create the components of the composite object.
  56.  
  57. (define-method initialize-item ((self  <Boxed-Text>) canvas coords args)
  58.   (let* ((parent      (slot-ref self 'parent))
  59.      (text        (get-keyword :text args ""))
  60.      (t           (make <Text-item> :text text
  61.                 :anchor "nw" :parent parent :coords coords))
  62.      (coords-rect (bounding-box t))
  63.      (r           (make <Rectangle> :parent parent :coords coords-rect))
  64.      (Cid           (gensym "group")))
  65.  
  66.     ;; set the true slots
  67.     (slot-set! self 'Cid       Cid)
  68.     (slot-set! self 'box-item  r)
  69.     (slot-set! self 'text-item t)
  70.  
  71.     ;; Add the r and t component to the "Group" whith tag "Cid"
  72.     (add-to-group self r t)
  73.  
  74.     ;; Raise the text to be sure it will not be under the rectangle
  75.     (raise t)
  76.  
  77.     ;; Give this association a default binding allowing it to be moved with mouse
  78.     (bind-for-dragging parent :tag Cid :only-current #f)
  79.     
  80.     ;; Return Cid
  81.     Cid))
  82.   
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. ;;;;
  85. ;;;; Some methods which guarantish that the box is always the good size
  86. ;;;;
  87. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  88.  
  89. (define-method (setter font) ((bt <Boxed-text>) value)
  90.   (let ((t (text-item bt)))
  91.     (set! (font t) value)
  92.     (set! (coords (box-item bt)) (bounding-box t))))
  93.  
  94. (define-method (setter text-of) ((bt <Boxed-text>) value)
  95.   (let ((t (text-item bt)))
  96.     (set! (text-of t) value)
  97.     (set! (coords (box-item bt)) (bounding-box t))))
  98.  
  99. (define-method (setter coords) ((bt <Boxed-text>) value)
  100.   (unless (and (list? value) (= (length value) 2))
  101.      (error "coords: must be a list of 2 elements. It was ~S" value))
  102.   (let ((t (text-item bt)))
  103.     (set! (coords t) value)
  104.     (set! (coords (box-item bt)) (bounding-box t))))
  105.  
  106.  
  107. ;;;; And now a little demo using the preceding new widget
  108.  
  109. (define (demo)
  110.   (let ((x  (make <Boxed-text> :parent c :coords '(50 50) :text "Hello")))
  111.     (update)
  112.     
  113.     (after 1000)
  114.     (do ((i 0 (+ i 3)))
  115.     ((> i 200))
  116.       (set! (coords x) (list i i))
  117.       (update))
  118.  
  119.     (after 1000)
  120.     (set! (coords x) '(100 100))
  121.     (set! (font x)  "10x20")
  122.     (set! (text-of x) "That's all, folks!")
  123.     (set! (background x) "lightblue")
  124.  
  125.     ;; Destroying the group will destroy all the components and change the class
  126.     ;; of x to <Destroyed-object>
  127.     (update)
  128.     (after 1000)
  129.     (destroy x)
  130.     (format #t "class of x = ~S\n" (class-name (class-of x)))))
  131.  
  132.  
  133. ;;; Run the demo
  134. (demo)
  135.  
  136.