stk/STklos/Tk/Basics.stklos

;;;;
;;;; B a s i c s . s t k 		--  Basic object class definition
;;;;
;;;; Copyright <20> 1993-1999 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@unice.fr]
;;;;    Creation date: 30-Mar-1993 15:39
;;;; Last file update:  3-Sep-1999 20:09 (eg)

(require "Tk-meta")

(select-module STklos+Tk)

(export <Tk-object>		    ; The base class of all STklos widgets
	<destroyed-object>	    ; Class in which destroyed objects are mapped
	Id->instance 		    ; really necessary?
	parent			    ; Parent of a widget
	Id			    ; Tk Id of a widget
	Eid			    ; External Id of widget
	tk-widget? 		    ; a predicate
	clone-widget		    ; clone for widgets
	initialize-composite-widget ; must be overloaded for composite widgets
	get-Tk-default-value	    ; Find the default value of a given Tk option
	tk-constructor		    ; Returns the Tk-command associated to a class
	destroy			    ; A redefinition of the Tk destroy
	focus			    ; A redefinition of the Tk focus
	bind			    ; A redefinition of the Tk bind
	unpack)			    ; to avoid the (pack 'unpack ...) construction

;;;;
;;;; Utilities
;;;;

;;
;; Stuff for generating Tcl variable names
;;
(define (Tk::make-tk-name parent subname)
  (format #f "~A.~A"
	  [if (or (eq? parent *root*) (eq? parent *top-root*))
	      "" 
	      (widget->string (slot-ref parent 'Id))]
	  [or subname (gensym "v")]))
;;
;; Setter for read-only slots
;;
(define (Tk:slot-is-read-only object slot)
  (error "Value of the slot ``~S'' in ~S cannot be changed." slot object))


;;
;; Initialize the virtual "value" slot independently of the state of the object
;; (Tk forbid to give a value to a "disabled" object)
;;
(define (initialize-value-slot obj value)
  (let ((s (slot-ref obj 'state)))
    (unless (equal? s "normal")
      (slot-set! obj 'state "normal")
      (slot-set! obj 'value value)
      (slot-set! obj 'state s))))


;=============================================================================
;
; 				<Tk-object>
;
;=============================================================================

(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>
;
;=============================================================================

(define-class <Tk-widget> (<Tk-object>)
  ()
  :metaclass <Tk-metaclass>)

;;;
;;; Utility method Id->instance
;;;

(define-method Id->instance ((id <widget>))
  (let ((plist (get-widget-data id)))
    (and plist (get-keyword :instance plist #f))))

(define-method Id->instance ((id <symbol>))
  (let ((env (module-environment (find-module 'Tk))))
    (and (symbol-bound? id env)	(Id->instance (eval id env)))))

(define-method Id->instance ((id <string>))
  (Id->instance (string->symbol id)))

(define-method Id ((self <widget>))
  self)

;;;
;;; A kind of predicate to determine if an object is a Tk-widget descendant
;;;
(define-method tk-widget? ((self <Tk-widget>))  #t)
(define-method tk-widget? ((self <top>))        #f)

;;;
;;; Tk-write-object is called when a STklos object is passed to a Tk-command.
;;; By default, we do the same job as write; but if an object is a <Tk-widget>
;;; we will pass it its Eid. This method does this job.
;;;
(define-method Tk-write-object((self <Tk-widget>) port)
  (write (widget-name (slot-ref self 'Eid)) port))


;;;
;;; get-Tk-default-value (find the default value of a given Tk option)
;;;
(define-method get-Tk-default-value ((self <Tk-widget>) slot)
  (list-ref ((slot-ref self 'Id) 'configure (make-keyword slot)) 3))


;;;
;;; Clone a widget
;;;
(define-method clone-widget ((self <Tk-widget>) new-parent)
  (let ((options '()))
    ;; Build the option list used for creating the widget by introspecting it
    (for-each (lambda (slot)
		(let ((name    (slot-definition-name slot))
		      (keyword (slot-definition-init-keyword slot)))
		  (unless (member name '(id eid parent))
		    (if keyword 
			(set! options (append (list keyword (slot-ref self name))
					      options))))))
	      (class-slots (class-of self)))
    (apply make (class-of self) :parent new-parent options)))


;=============================================================================
;
;				<Tk-simple-widget>
;
;=============================================================================

(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)))

(define-method initialize ((self <Tk-simple-widget>) initargs)
  (unless (get-keyword :Eid  initargs #f)
    ;; This is not a composite widget. Initialize it
    (let* ((parent     (get-keyword :parent     initargs *top-root*))
	   (Id	       (get-keyword :Id         initargs #f))
	   (tk-options (get-keyword :tk-options initargs '()))
	   (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
      (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))))

  ;; Continue initializing
  (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)
   (class :accessor     class
	  :init-form    "Composite"
	  :init-keyword :class))
  :metaclass <Tk-composite-metaclass>)

(define-method initialize ((self <Tk-composite-widget>) initargs)
  ;; Initialize the class resource name of the object.
  ;; The code below is a little bit tricky because 
  ;;     1. We don't use a clean object approach for composites (i.e
  ;;	  we use inheritance to avoid a lot of redefinitions). 
  ;;     2. The class of a Tk frame or toplevel must be defined before 
  ;;     the object is created.
  ;;
  (let* ((kwd   (slot-definition-init-keyword 
		     (class-slot-definition (class-of self) 'class)))
	 (class (and kwd (get-keyword kwd initargs #f))))
    (if class
	(slot-set! self 'class class)
	(let ((init (slot-init-function (class-of self) 'class)))
	  (if init
	      (slot-set! self 'class (init))))))

  ;; To work properly, the parent slot must be set before anything
  (let* ((parent (get-keyword  :parent initargs *top-root*))
	 (Id     (get-keyword  :Id     initargs #f))
	 (frame	 (make-composite-container self parent Id (slot-ref self 'class)))
	 (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 `(:Eid #t ,@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 make-composite-container((self <Tk-composite-widget>)parent Id class)
  (make <Frame> :parent parent 	:Id Id :border-width 0 
	        :highlight-thickness 0 :class class))

(define-method initialize-composite-widget ((c <Tk-composite-widget>) args parent)
  ; Just fall thru when a composite inherit from a composite
  (next-method))

(define-method initialize-composite-widget (c args parent)
  ;; We are here if no initialize-composite-widget method is provided for c
  #f)

;=============================================================================
;
;	 		 <Tk-composite-toplevel>
;
; (as <Tk-composite-widget>, but in a separate window)
;
;=============================================================================

(define-class <Tk-composite-toplevel> (<Tk-composite-widget>)
  ((title :initform 	""
	  :accessor 	title 
	  :init-keyword :title
	  :allocation   :propagated 
	  :propagate-to (frame))))


(define-method make-composite-container((self <Tk-composite-toplevel>) parent 
								       Id class)
  (make <Toplevel> :Id Id :border-width 0 :highlight-thickness 0 :class class))

;=============================================================================
;
;				 <Tk-sizeable>
;
;=============================================================================

(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>
;
;=============================================================================

(define-class <Tk-simple-text> ()
  ((anchor	  :accessor     anchor
		  :init-keyword :anchor
		  :allocation   :tk-virtual)
   (environment	  :accessor	environment
		  :init-keyword :environment
		  :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>
;
;=============================================================================

(define-class <Tk-bitmap> ()
  ((bitmap  :accessor bitmap :init-keyword :bitmap :allocation :tk-virtual))
  :metaclass <Tk-metaclass>)


;=============================================================================
;
;				<Tk-reactive>
;
;=============================================================================

(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> 
;
;=============================================================================

(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> 
;
;=============================================================================

(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>
;
;=============================================================================

(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>
;
;=============================================================================

(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-object>
;=============================================================================

(define-class <Destroyed-object> () ())


;=============================================================================
;
;			Redefine some Tk-commands as generics
;
;=============================================================================

;;;
;;; A general destroy
;;;

(define-method destroy ((self <Tk-widget>))
  (let ((Eid        (slot-ref self 'Eid))
	(Tk:destroy (with-module Tk destroy)))
    ;; Destroy all the sons of this widget
    (apply destroy (map (lambda (x) (or (Id->instance x) x))
			(winfo 'children Eid)))	   
    ;; Suicide
    (Tk:destroy Eid)
    (change-class self <Destroyed-object>)))

(define-method destroy (obj)    	
  ;; Method called when not using objects (e.g. [destroy .b])
  (let ((Tk:destroy (with-module Tk destroy))
	(inst 	    (Id->instance obj)))
    ;; Destroy all the sons of this widget  
    (for-each destroy (winfo 'children obj))

    ;; Suicide
    (when inst (change-class inst <Destroyed-object>))
    (Tk:destroy obj)))

(define-method destroy l		  ;; Destroy a list of widgets
  (for-each destroy l))

;;;
;;; A general focus
;;;
(define-method focus ()
  (let ((w (Tk:focus)))
    (and w (Id->instance w))))

(define-method focus l (apply Tk:focus l))


;;;
;;; A general bind
;;;
(define-method bind ((self <Tk-widget>) . l)
  ;; Use the Id slot of a widget (instead of its Eid) for bind
  (apply Tk:bind (slot-ref self 'Id) l))


;;;
;;; A general unpack (to avoid [pack 'forget ...] which is ugly
;;;
(define (unpack . l)
  (apply pack 'forget l))


(provide "Basics")