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 / E3.stklos < prev    next >
Encoding:
Text File  |  1995-01-01  |  4.8 KB  |  144 lines
  1. ;;;;
  2. ;;;; E x a m p l e 3 .  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 17:33
  16. ;;;; Last file update:  5-Aug-1994 12:04 
  17. ;;;;
  18.  
  19.  
  20. ;;;; This file demonstates the use of grouped canvas items.
  21. ;;;; Grouping can be viewed
  22. ;;;;    - statically by defining a class which is the composition of
  23. ;;;;      several items (such as <Chair> or <Table> classes below)
  24. ;;;;    - dynamically by making a <Canvas-group> instance 
  25. ;;;;      of several items (such as the red-group below)
  26.  
  27.  
  28.  
  29. (require "Canvas")
  30. ;;;; Create canvas
  31. (define c (make <Canvas> :width 800 :height 600))
  32. (pack c)
  33.  
  34.  
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ;;;;
  37. ;;;; The <Table> class
  38. ;;;; 
  39. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40.  
  41. (define-class <Table> (<Tk-composite-item>)
  42.   (deck f1 f2
  43.    (fill :init-keyword :fill 
  44.      :accessor     fill
  45.      :allocation     :propagated 
  46.      :propagate-to  (deck f1 f2))))
  47.  
  48. (define-method initialize-item ((self  <Table>) canvas coords args)
  49.   (let* ((parent      (slot-ref self 'parent))
  50.      (x          (car coords))
  51.      (y          (cadr coords))
  52.      (deck          (make <Line> :parent parent :width 8
  53.                 :coords (list x y (+ x 200) y)))
  54.      (f1          (make <Polygon> :parent parent
  55.                 :coords (list (+ x 40) y (+ x 20) (+ y 150)
  56.                       (+ x 25) (+ y 150) (+ x 55) y)))
  57.      (f2          (make <Polygon> :parent parent
  58.                 :coords (list (+ x 160) y (+ x 180) (+ y 150)
  59.                       (+ x 175) (+ y 150) (+ x 145) y))))
  60.     (let ((Cid (gensym "group")))
  61.       ;; Initialize true slots
  62.       (slot-set! self 'Cid  Cid)
  63.       (slot-set! self 'deck deck)
  64.       (slot-set! self 'f1   f1)
  65.       (slot-set! self 'f2   f2)
  66.       ;; Add the deck f1 f2 components to the "Group" whith tag "Cid"
  67.       (add-to-group self deck f1 f2)
  68.       ;; Give this association a default binding allowing it to be moved with mouse
  69.       (bind-for-dragging parent :tag Cid :only-current #f)
  70.       ;; Return Cid
  71.       Cid)))
  72.  
  73. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74. ;;;;
  75. ;;;; The <Chair> class
  76. ;;;; 
  77. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78. (define-class <Chair> (<Tk-composite-item>)
  79.   (deck back f1 f2 
  80.    (fill :init-keyword :fill 
  81.      :accessor     fill
  82.      :allocation     :propagated 
  83.      :propagate-to  (deck back f1 f2))))
  84.  
  85. (define-method initialize-item ((self  <Chair>) canvas coords args)
  86.   (let* ((parent      (slot-ref self 'parent))
  87.      (x          (car coords))
  88.      (y          (cadr coords))
  89.      (deck          (make <Line> :parent parent :width 8
  90.                 :coords (list x y (+ x 100) y)))
  91.      (back          (make <Line> :parent parent :width 5
  92.                 :coords (list (+ x 70) y (+ x 100) (- y 90))))
  93.      (f1          (make <Polygon> :parent parent
  94.                 :coords (list (+ x 20) y x (+ y 90)
  95.                       (+ x 5) (+ y 90) (+ x 30) y)))
  96.      (f2          (make <Polygon> :parent parent
  97.                 :coords (list (+ x 80) y (+ x 100) (+ y 90)
  98.                       (+ x 95) (+ y 90) (+ x 70) y))))
  99.     (let ((Cid (gensym "group")))
  100.       ;; Initialize true slots
  101.       (slot-set! self 'Cid  Cid)
  102.       (slot-set! self 'deck deck)
  103.       (slot-set! self 'back back)
  104.       (slot-set! self 'f1   f1)
  105.       (slot-set! self 'f2   f2)
  106.       ;; Add the deck f1 f2 components to the "Group" whith tag "Cid"
  107.       (add-to-group self deck back f1 f2)
  108.       ;; Give this association a default binding allowing it to be moved with mouse
  109.       (bind-for-dragging parent :tag Cid :only-current #f)
  110.       ;; Return Cid
  111.       Cid)))
  112.  
  113. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  114.  
  115. ;;;; Define a table and two chairs
  116. (define t1 (make <Table> :parent c :coords '(120 50) :fill "red"))
  117. (define c1 (make <Chair> :parent c :coords '(320 110) :fill "green"))
  118. (define c2 (make <Chair> :parent c :coords '(450 110) :fill "red"))
  119.  
  120.  
  121. ;;;; Define the group of red objects
  122. (define red-group (make <Canvas-group> :parent c))
  123. (add-to-group red-group t1 c2)
  124.  
  125. ;;;; Using button 2 of the mouse will move all the components of the red-group
  126. (bind-for-dragging c :tag (Cid red-group) :button 2 :only-current #f)
  127.  
  128.  
  129. ;;;; Zoom in and out the red-group
  130. (update)
  131. (dotimes (i 20)
  132.    (rescale red-group 0 0 0.9 0.9)
  133.    (update))
  134. (dotimes (i 20)
  135.    (rescale red-group 0 0 1.1 1.1)
  136.    (update))
  137.  
  138.  
  139. (update)
  140. (delay 1000)
  141.  
  142.               
  143.                 
  144.