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.003 / stk-3 / stk / 3.1 / STk / Basics.stklos next >
Encoding:
Text File  |  1996-07-29  |  12.3 KB  |  376 lines
  1. ;;;;
  2. ;;;; B a s i c s . s t k         --  Basic object class definition
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 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@unice.fr]
  15. ;;;;    Creation date: 30-Mar-1993 15:39
  16. ;;;; Last file update: 27-Apr-1996 00:05
  17.  
  18.  
  19. (require "Tk-meta")
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. ;;;;
  23. ;;;; <Tk-object> class
  24. ;;;;
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. (define-class <Tk-object> ()
  28.   ((Id      :getter Id)                    ;; Widget Id
  29.    (Eid        :getter Eid)                ;; External widget Id
  30.    (parent  :getter parent :init-keyword :parent))) ;; Parent widget
  31.  
  32.  
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. ;;;;
  35. ;;;; <Tk-widget> class
  36. ;;;;
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38.  
  39.  
  40. (define-class <Tk-widget> (<Tk-object>)
  41.   ())
  42.  
  43. ;;;
  44. ;;; Utility method Id->instance
  45. ;;;
  46.  
  47. (define-method Id->instance ((id <widget>))
  48.   (let ((plist (get-widget-data id)))
  49.     (if plist 
  50.     (get-keyword :instance plist #f)
  51.     #f)))
  52.  
  53. (define-method Id->instance ((id <string>))
  54.   (let ((var (read-from-string id)))
  55.     (if (and (not (equal? id "")) (symbol-bound? var))
  56.     (Id->instance (eval var))
  57.     #f)))
  58.  
  59. (define-method Id->instance ((id <symbol>))
  60.   (if (symbol-bound? id)
  61.       (Id->instance (eval id))
  62.       #f))
  63.  
  64. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65. ;;;;
  66. ;;;; <Tk-simple-widget> class
  67. ;;;;
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69.  
  70. (define-class <Tk-simple-widget> (<Tk-widget>)
  71.   ((background        :accessor     background   
  72.               :init-keyword :background   
  73.               :allocation   :tk-virtual)
  74.    (border-width      :accessor     border-width 
  75.               :init-keyword :border-width
  76.              :tk-name      bd     
  77.               :allocation   :tk-virtual)
  78.    (cursor          :accessor     cursor
  79.               :init-keyword :cursor  
  80.               :allocation   :tk-virtual)
  81.    (highlight-background :accessor     highlight-background  
  82.              :init-keyword :highlight-background
  83.              :tk-name      highlightback
  84.              :allocation   :tk-virtual)
  85.    (highlight-color      :accessor     highlight-color  
  86.              :init-keyword :highlight-color
  87.              :tk-name      highlightcolor
  88.              :allocation   :tk-virtual)
  89.    (highlight-thickness  :accessor     highlight-thickness  
  90.              :init-keyword :highlight-thickness
  91.              :tk-name      highlightthick
  92.              :allocation   :tk-virtual)
  93.    (relief          :accessor     relief    
  94.               :init-keyword :relief       
  95.               :allocation   :tk-virtual)
  96.    (take-focus         :accessor     take-focus
  97.              :init-keyword :take-focus
  98.              :tk-name      takefocus
  99.              :allocation   :tk-virtual))
  100.   :metaclass <Tk-metaclass>)
  101.  
  102.  
  103. (define-method initialize ((self <Tk-simple-widget>) initargs)
  104.   (let* ((parent    (get-keyword :parent initargs *root*))
  105.      (Eid        (get-keyword :Eid     initargs #f))
  106.      (tk-options    (get-keyword :tk-options initargs '())))
  107.  
  108.     (if Eid 
  109.     ;; Eid is already defined. All we have to do is to reconfigure self
  110.     (letrec ((valids (slot-ref (class-of self) 'tk-valid-options))
  111.          (find   (lambda (k l)
  112.                (cond
  113.                 ((null? l) #f)
  114.                 ((eq? k (vector-ref (car l) 1)) (vector-ref (car l) 2))
  115.                 (else   (find k (cdr l)))))))
  116.  
  117.       (do ((l tk-options (cddr l)))
  118.           ((null? l))
  119.         (slot-set! self (find (car l) valids) (cadr l))))
  120.     ;; Eid is undefined. Ask Tk to create the widget
  121.     (begin
  122.       (set! Eid (apply (tk-constructor self) 
  123.                (Tk::make-tk-name parent '()) tk-options))
  124.  
  125.       (slot-set! self 'Id  Eid)  ; retain Tk command which implement this object
  126.       (slot-set! self 'Eid Eid))); Eid an Id are the same for non composite 
  127.  
  128.     ;; Udate parent
  129.     (slot-set! self 'parent parent)
  130.     ;; Store the information <self> in the Tk command to allow widget->instance
  131.     ;; conversion
  132.     (set-widget-data! Eid (list :instance self)))
  133.   (next-method))
  134.  
  135. (define-method tk-constructor ((self <Tk-simple-widget>))
  136.   ;; Returns the Tk function that makes an object of this kind.
  137.   (error "tk-constructor: method must be overridden for ~S" 
  138.      (class-name (class-of self))))
  139.  
  140.  
  141. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  142. ;;;;
  143. ;;;; <Tk-composite-widget>
  144. ;;;;
  145. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  146.  
  147. (define-class <Tk-composite-widget> (<Tk-widget>)
  148.   ((frame     :accessor   frame-of))
  149.   :metaclass <Tk-composite-metaclass>)
  150.  
  151. (define-method initialize ((self <Tk-composite-widget>) initargs)
  152.   ;; To work properly, the parent slot must be set before anything
  153.   (let* ((parent (get-keyword  :parent initargs *root*))
  154.      (frame     (make <Frame> :parent parent))
  155.      (Eid    (slot-ref frame 'Id)))
  156.  
  157.     (slot-set! self 'parent parent)
  158.     (slot-set! self 'Eid    Eid)
  159.     (slot-set! self 'frame  frame)
  160.  
  161.     ;; Now call initialize-composite-widget
  162.     (initialize-composite-widget self initargs frame)
  163.  
  164.     ;; Continue to initialize with value passed to "make" (and signal that 
  165.     ;; Eid is already initialized)
  166.     (next-method self (cons :Eid (cons Eid initargs)))
  167.  
  168.     ;; Store the information <self> in the Tk command to allow widget->instance
  169.     ;; conversion
  170.     (set-widget-data! (slot-ref frame 'Id) (list :instance self))))
  171.  
  172. (define-method initialize-composite-widget ((c <Tk-composite-widget>) args parent)
  173.   ;; We are here is no initialize-composite-widget metho is provided for c
  174.   #f)
  175.  
  176. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  177. ;;;;
  178. ;;;; <Tk-sizeable> class
  179. ;;;;
  180. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  181.  
  182. (define-class <Tk-sizeable> ()
  183.   ((width  :accessor width  :init-keyword :width  :allocation :tk-virtual)
  184.    (height :accessor height :init-keyword :height :allocation :tk-virtual))
  185.   :metaclass <Tk-metaclass>)
  186.  
  187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  188. ;;;;
  189. ;;;; <Tk-simple-text> class
  190. ;;;;
  191. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  192.  
  193. (define-class <Tk-simple-text> ()
  194.   ((anchor      :accessor     anchor
  195.           :init-keyword :anchor
  196.           :allocation   :tk-virtual)
  197.    (font      :accessor     font
  198.           :init-keyword :font
  199.           :allocation   :tk-virtual)
  200.    (foreground      :accessor     foreground
  201.           :init-keyword :foreground
  202.           :allocation   :tk-virtual)
  203.    (image      :accessor     image-of
  204.           :init-keyword :image
  205.           :allocation   :tk-virtual)
  206.    (justify      :accessor     justify
  207.           :init-keyword :justify
  208.           :allocation   :tk-virtual)
  209.    (pad-x      :accessor     pad-x
  210.           :init-keyword :pad-x
  211.           :allocation   :tk-virtual
  212.           :tk-name      padx)
  213.    (pad-y      :accessor     pad-y
  214.           :init-keyword :pad-y
  215.           :allocation   :tk-virtual
  216.           :tk-name      pady)
  217.    (text      :accessor     text-of
  218.           :init-keyword :text
  219.           :allocation   :tk-virtual)
  220.    (text-variable :accessor     text-variable
  221.           :init-keyword :text-variable
  222.           :allocation   :tk-virtual
  223.           :tk-name      textvar)
  224.    (underline      :accessor     underline
  225.           :init-keyword :underline
  226.           :allocation   :tk-virtual)
  227.    (wrap-length      :accessor     wrap-length
  228.           :init-keyword :wrap-length
  229.           :tk-name    wraplength
  230.           :allocation   :tk-virtual))
  231.   :metaclass <Tk-metaclass>)
  232.  
  233. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  234. ;;;;
  235. ;;;; <Tk-bitmap> class
  236. ;;;;
  237. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  238.  
  239. (define-class <Tk-bitmap> ()
  240.   ((bitmap  :accessor bitmap :init-keyword :bitmap :allocation :tk-virtual))
  241.   :metaclass <Tk-metaclass>)
  242.  
  243. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  244. ;;;;
  245. ;;;; <Tk-reactive> class
  246. ;;;;
  247. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  248.  
  249. (define-class <Tk-reactive> ()
  250.   ((active-background   :accessor     active-background
  251.             :init-keyword :active-background
  252.                 :allocation   :tk-virtual
  253.             :tk-name      activebackground)
  254.    (active-foreground   :accessor     active-foreground
  255.             :init-keyword :active-foreground
  256.             :allocation   :tk-virtual
  257.             :tk-name      activeforeground)
  258.    (command             :accessor     command
  259.             :init-keyword :command
  260.             :allocation   :tk-virtual)
  261.    (disabled-foreground :accessor     disabled-foreground
  262.             :init-keyword :disabled-foreground
  263.             :allocation   :tk-virtual
  264.             :tk-name      disabledf)
  265.    (state         :accessor     state
  266.             :init-keyword :state
  267.             :allocation   :tk-virtual))
  268.   :metaclass <Tk-metaclass>)
  269.  
  270. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  271. ;;;;
  272. ;;;; <Tk-xyscrollable> class
  273. ;;;;
  274. ;;;;         A Tk-xyscrollable is an object which can be scrolled 
  275. ;;;;         both horizontally and vertically.
  276. ;;;;
  277. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  278.  
  279. (define-class <Tk-xyscrollable> ()
  280.   ((x-scroll-command :init-keyword :x-scroll-command
  281.              :accessor     x-scroll-command
  282.              :tk-name      xscrollcommand
  283.              :allocation   :tk-virtual)
  284.    (y-scroll-command :init-keyword :y-scroll-command
  285.              :accessor     y-scroll-command
  286.              :tk-name      yscrollcommand
  287.              :allocation   :tk-virtual))
  288.   :metaclass <Tk-metaclass>)
  289.  
  290. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  291. ;;;;
  292. ;;;; <Tk-editable> class 
  293. ;;;;
  294. ;;;;         A Tk-editable object is not a graphical object per se. It's a 
  295. ;;;;        recipient for the common slots of all editable objects 
  296. ;;;;        (canvas, entry, ...)
  297. ;;;;
  298. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  299.  
  300. (define-class <Tk-editable> ()
  301.   ((insert-background   :init-keyword :insert-background
  302.             :accessor     insert-background
  303.             :tk-name      insertbackground
  304.             :allocation   :tk-virtual)
  305.    (insert-border-width :init-keyword :insert-border-width
  306.             :accessor     insert-border-width
  307.             :tk-name      insertborderwidth
  308.             :allocation   :tk-virtual)
  309.    (insert-off-time     :init-keyword :insert-off-time
  310.             :accessor     insert-off-time
  311.             :tk-name      insertofftime
  312.             :allocation   :tk-virtual)
  313.    (insert-on-time      :init-keyword :insert-on-time
  314.             :accessor     insert-on-time
  315.             :tk-name      insertontime
  316.             :allocation   :tk-virtual)
  317.    (insert-width        :init-keyword :insert-width
  318.             :accessor     insert-width
  319.             :tk-name      insertwidth
  320.             :allocation   :tk-virtual))
  321.   :metaclass <Tk-metaclass>)
  322.  
  323. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  324. ;;;;
  325. ;;;; <Tk-selectable> class
  326. ;;;;
  327. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  328.  
  329. (define-class <Tk-selectable> ()
  330.   ((select-background   :init-keyword :select-background
  331.             :accessor     select-background
  332.             :tk-name      selectbackground
  333.             :allocation   :tk-virtual)
  334.    (select-foreground   :init-keyword :select-foreground
  335.             :accessor     select-foreground
  336.             :tk-name      selectforeground
  337.             :allocation   :tk-virtual)
  338.    (select-border-width :init-keyword :select-border-width
  339.             :accessor     select-border-width
  340.             :tk-name      selectborderwidth
  341.             :allocation   :tk-virtual))
  342.   :metaclass <Tk-metaclass>)
  343.  
  344. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  345. ;;;;
  346. ;;;; <Tk-text-selectable> class
  347. ;;;;
  348. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  349.  
  350. (define-class <Tk-text-selectable> ()
  351.   ((export-selection    :init-keyword :export-selection
  352.             :accessor     export-selection
  353.             :tk-name      exportselection
  354.             :allocation   :tk-virtual)
  355.    (font        :init-keyword :font
  356.             :accessor     font
  357.             :allocation   :tk-virtual)
  358.    (foreground        :init-keyword :foreground
  359.             :accessor     foreground
  360.             :allocation   :tk-virtual))
  361.   :metaclass <Tk-metaclass>)
  362.  
  363. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  364. ;;;;
  365. ;;;; <Destroyed-object>
  366. ;;;;        This class serves only for destroyed objects (i.e. when a
  367. ;;;;        widget or a canvas item is destroyed, its class is changed 
  368. ;;;;        to destroyed 
  369. ;;;;
  370. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  371. (define-class <Destroyed-object> ()
  372.   ())
  373.  
  374. (provide "Basics")
  375. (load "Tk-methods")
  376.