378 lines
12 KiB
Plaintext
378 lines
12 KiB
Plaintext
|
;;;;
|
|||
|
|
;;;; B a s i c s . s t k -- Basic object class definition
|
|||
|
|
;;;;
|
|||
|
|
;;;; Copyright <20> 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|||
|
|
;;;;
|
|||
|
|
;;;; Permission to use, copy, and/or distribute this software and its
|
|||
|
|
;;;; documentation for any purpose and without fee is hereby granted, provided
|
|||
|
|
;;;; that both the above copyright notice and this permission notice appear in
|
|||
|
|
;;;; all copies and derived works. Fees for distribution or use of this
|
|||
|
|
;;;; software or derived works may only be charged with express written
|
|||
|
|
;;;; permission of the copyright holder.
|
|||
|
|
;;;; This software is provided ``as is'' without express or implied warranty.
|
|||
|
|
;;;;
|
|||
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|||
|
|
;;;; Creation date: 30-Mar-1993 15:39
|
|||
|
|
;;;; Last file update: 24-Sep-1996 17:49
|
|||
|
|
|
|||
|
|
|
|||
|
|
(require "Tk-meta")
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-object> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-object> ()
|
|||
|
|
((Id :getter Id) ;; Widget Id
|
|||
|
|
(Eid :getter Eid) ;; External widget Id
|
|||
|
|
(parent :getter parent :init-keyword :parent))) ;; Parent widget
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-widget> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define-class <Tk-widget> (<Tk-object>)
|
|||
|
|
())
|
|||
|
|
|
|||
|
|
;;;
|
|||
|
|
;;; Utility method Id->instance
|
|||
|
|
;;;
|
|||
|
|
|
|||
|
|
(define-method Id->instance ((id <widget>))
|
|||
|
|
(let ((plist (get-widget-data id)))
|
|||
|
|
(if plist
|
|||
|
|
(get-keyword :instance plist #f)
|
|||
|
|
#f)))
|
|||
|
|
|
|||
|
|
(define-method Id->instance ((id <string>))
|
|||
|
|
(let ((var (read-from-string id)))
|
|||
|
|
(if (and (not (equal? id "")) (symbol-bound? var))
|
|||
|
|
(Id->instance (eval var))
|
|||
|
|
#f)))
|
|||
|
|
|
|||
|
|
(define-method Id->instance ((id <symbol>))
|
|||
|
|
(if (symbol-bound? id)
|
|||
|
|
(Id->instance (eval id))
|
|||
|
|
#f))
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-simple-widget> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-simple-widget> (<Tk-widget>)
|
|||
|
|
((background :accessor background
|
|||
|
|
:init-keyword :background
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(border-width :accessor border-width
|
|||
|
|
:init-keyword :border-width
|
|||
|
|
:tk-name bd
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(cursor :accessor cursor
|
|||
|
|
:init-keyword :cursor
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(highlight-background :accessor highlight-background
|
|||
|
|
:init-keyword :highlight-background
|
|||
|
|
:tk-name highlightback
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(highlight-color :accessor highlight-color
|
|||
|
|
:init-keyword :highlight-color
|
|||
|
|
:tk-name highlightcolor
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(highlight-thickness :accessor highlight-thickness
|
|||
|
|
:init-keyword :highlight-thickness
|
|||
|
|
:tk-name highlightthick
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(relief :accessor relief
|
|||
|
|
:init-keyword :relief
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(take-focus :accessor take-focus
|
|||
|
|
:init-keyword :take-focus
|
|||
|
|
:tk-name takefocus
|
|||
|
|
:allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
|
|||
|
|
(define-method initialize ((self <Tk-simple-widget>) initargs)
|
|||
|
|
(let* ((parent (get-keyword :parent initargs *root*))
|
|||
|
|
(Id (get-keyword :Id initargs #f))
|
|||
|
|
(Eid (get-keyword :Eid initargs #f))
|
|||
|
|
(tk-options (get-keyword :tk-options initargs '())))
|
|||
|
|
|
|||
|
|
(if Eid
|
|||
|
|
;; Eid is already defined. All we have to do is to reconfigure self
|
|||
|
|
(letrec ((valids (slot-ref (class-of self) 'tk-valid-options))
|
|||
|
|
(find (lambda (k l)
|
|||
|
|
(cond
|
|||
|
|
((null? l) #f)
|
|||
|
|
((eq? k (vector-ref (car l) 1)) (vector-ref (car l) 2))
|
|||
|
|
(else (find k (cdr l)))))))
|
|||
|
|
|
|||
|
|
(do ((l tk-options (cddr l)))
|
|||
|
|
((null? l))
|
|||
|
|
(slot-set! self (find (car l) valids) (cadr l))))
|
|||
|
|
;; Eid is undefined. Ask Tk to create the widget
|
|||
|
|
(begin
|
|||
|
|
(set! Eid (apply (tk-constructor self)
|
|||
|
|
(Tk::make-tk-name parent Id)
|
|||
|
|
tk-options))
|
|||
|
|
(slot-set! self 'Id Eid) ; retain Tk command which implement this object
|
|||
|
|
(slot-set! self 'Eid Eid))); Eid an Id are the same for non composite
|
|||
|
|
|
|||
|
|
;; Udate parent
|
|||
|
|
(slot-set! self 'parent parent)
|
|||
|
|
;; Store the information <self> in the Tk command to allow widget->instance
|
|||
|
|
;; conversion
|
|||
|
|
(set-widget-data! Eid (list :instance self)))
|
|||
|
|
(next-method))
|
|||
|
|
|
|||
|
|
(define-method tk-constructor ((self <Tk-simple-widget>))
|
|||
|
|
;; Returns the Tk function that makes an object of this kind.
|
|||
|
|
(error "tk-constructor: method must be overridden for ~S"
|
|||
|
|
(class-name (class-of self))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-composite-widget>
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-composite-widget> (<Tk-widget>)
|
|||
|
|
((frame :accessor frame-of))
|
|||
|
|
:metaclass <Tk-composite-metaclass>)
|
|||
|
|
|
|||
|
|
(define-method initialize ((self <Tk-composite-widget>) initargs)
|
|||
|
|
;; To work properly, the parent slot must be set before anything
|
|||
|
|
(let* ((parent (get-keyword :parent initargs *root*))
|
|||
|
|
(Id (get-keyword :Id initargs #f))
|
|||
|
|
(frame (make <Frame> :parent parent :Id Id))
|
|||
|
|
(Eid (slot-ref frame 'Id)))
|
|||
|
|
|
|||
|
|
(slot-set! self 'parent parent)
|
|||
|
|
(slot-set! self 'Eid Eid)
|
|||
|
|
(slot-set! self 'frame frame)
|
|||
|
|
|
|||
|
|
;; Now call initialize-composite-widget
|
|||
|
|
(initialize-composite-widget self initargs frame)
|
|||
|
|
|
|||
|
|
;; Continue to initialize with value passed to "make" (and signal that
|
|||
|
|
;; Eid is already initialized)
|
|||
|
|
(next-method self (cons :Eid (cons Eid initargs)))
|
|||
|
|
|
|||
|
|
;; Store the information <self> in the Tk command to allow widget->instance
|
|||
|
|
;; conversion
|
|||
|
|
(set-widget-data! (slot-ref frame 'Id) (list :instance self))))
|
|||
|
|
|
|||
|
|
(define-method initialize-composite-widget ((c <Tk-composite-widget>) args parent)
|
|||
|
|
;; We are here is no initialize-composite-widget metho is provided for c
|
|||
|
|
#f)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-sizeable> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-sizeable> ()
|
|||
|
|
((width :accessor width :init-keyword :width :allocation :tk-virtual)
|
|||
|
|
(height :accessor height :init-keyword :height :allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-simple-text> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-simple-text> ()
|
|||
|
|
((anchor :accessor anchor
|
|||
|
|
:init-keyword :anchor
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(font :accessor font
|
|||
|
|
:init-keyword :font
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(foreground :accessor foreground
|
|||
|
|
:init-keyword :foreground
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(image :accessor image-of
|
|||
|
|
:init-keyword :image
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(justify :accessor justify
|
|||
|
|
:init-keyword :justify
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(pad-x :accessor pad-x
|
|||
|
|
:init-keyword :pad-x
|
|||
|
|
:allocation :tk-virtual
|
|||
|
|
:tk-name padx)
|
|||
|
|
(pad-y :accessor pad-y
|
|||
|
|
:init-keyword :pad-y
|
|||
|
|
:allocation :tk-virtual
|
|||
|
|
:tk-name pady)
|
|||
|
|
(text :accessor text-of
|
|||
|
|
:init-keyword :text
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(text-variable :accessor text-variable
|
|||
|
|
:init-keyword :text-variable
|
|||
|
|
:allocation :tk-virtual
|
|||
|
|
:tk-name textvar)
|
|||
|
|
(underline :accessor underline
|
|||
|
|
:init-keyword :underline
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(wrap-length :accessor wrap-length
|
|||
|
|
:init-keyword :wrap-length
|
|||
|
|
:tk-name wraplength
|
|||
|
|
:allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-bitmap> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-bitmap> ()
|
|||
|
|
((bitmap :accessor bitmap :init-keyword :bitmap :allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-reactive> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-reactive> ()
|
|||
|
|
((active-background :accessor active-background
|
|||
|
|
:init-keyword :active-background
|
|||
|
|
:allocation :tk-virtual
|
|||
|
|
:tk-name activebackground)
|
|||
|
|
(active-foreground :accessor active-foreground
|
|||
|
|
:init-keyword :active-foreground
|
|||
|
|
:allocation :tk-virtual
|
|||
|
|
:tk-name activeforeground)
|
|||
|
|
(command :accessor command
|
|||
|
|
:init-keyword :command
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(disabled-foreground :accessor disabled-foreground
|
|||
|
|
:init-keyword :disabled-foreground
|
|||
|
|
:allocation :tk-virtual
|
|||
|
|
:tk-name disabledf)
|
|||
|
|
(state :accessor state
|
|||
|
|
:init-keyword :state
|
|||
|
|
:allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-xyscrollable> class
|
|||
|
|
;;;;
|
|||
|
|
;;;; A Tk-xyscrollable is an object which can be scrolled
|
|||
|
|
;;;; both horizontally and vertically.
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-xyscrollable> ()
|
|||
|
|
((x-scroll-command :init-keyword :x-scroll-command
|
|||
|
|
:accessor x-scroll-command
|
|||
|
|
:tk-name xscrollcommand
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(y-scroll-command :init-keyword :y-scroll-command
|
|||
|
|
:accessor y-scroll-command
|
|||
|
|
:tk-name yscrollcommand
|
|||
|
|
:allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-editable> class
|
|||
|
|
;;;;
|
|||
|
|
;;;; A Tk-editable object is not a graphical object per se. It's a
|
|||
|
|
;;;; recipient for the common slots of all editable objects
|
|||
|
|
;;;; (canvas, entry, ...)
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-editable> ()
|
|||
|
|
((insert-background :init-keyword :insert-background
|
|||
|
|
:accessor insert-background
|
|||
|
|
:tk-name insertbackground
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(insert-border-width :init-keyword :insert-border-width
|
|||
|
|
:accessor insert-border-width
|
|||
|
|
:tk-name insertborderwidth
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(insert-off-time :init-keyword :insert-off-time
|
|||
|
|
:accessor insert-off-time
|
|||
|
|
:tk-name insertofftime
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(insert-on-time :init-keyword :insert-on-time
|
|||
|
|
:accessor insert-on-time
|
|||
|
|
:tk-name insertontime
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(insert-width :init-keyword :insert-width
|
|||
|
|
:accessor insert-width
|
|||
|
|
:tk-name insertwidth
|
|||
|
|
:allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-selectable> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-selectable> ()
|
|||
|
|
((select-background :init-keyword :select-background
|
|||
|
|
:accessor select-background
|
|||
|
|
:tk-name selectbackground
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(select-foreground :init-keyword :select-foreground
|
|||
|
|
:accessor select-foreground
|
|||
|
|
:tk-name selectforeground
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(select-border-width :init-keyword :select-border-width
|
|||
|
|
:accessor select-border-width
|
|||
|
|
:tk-name selectborderwidth
|
|||
|
|
:allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Tk-text-selectable> class
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
|
|||
|
|
(define-class <Tk-text-selectable> ()
|
|||
|
|
((export-selection :init-keyword :export-selection
|
|||
|
|
:accessor export-selection
|
|||
|
|
:tk-name exportselection
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(font :init-keyword :font
|
|||
|
|
:accessor font
|
|||
|
|
:allocation :tk-virtual)
|
|||
|
|
(foreground :init-keyword :foreground
|
|||
|
|
:accessor foreground
|
|||
|
|
:allocation :tk-virtual))
|
|||
|
|
:metaclass <Tk-metaclass>)
|
|||
|
|
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
;;;;
|
|||
|
|
;;;; <Destroyed-object>
|
|||
|
|
;;;; This class serves only for destroyed objects (i.e. when a
|
|||
|
|
;;;; widget or a canvas item is destroyed, its class is changed
|
|||
|
|
;;;; to destroyed
|
|||
|
|
;;;;
|
|||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|||
|
|
(define-class <Destroyed-object> ()
|
|||
|
|
())
|
|||
|
|
|
|||
|
|
(provide "Basics")
|
|||
|
|
(require "Tk-methods")
|