stk/STklos/Tk/Toplevel.stklos

;;;;
;;;; T o p l e v e l . s t k	  --  Frame and Toplevel class definitions
;;;;
;;;; Copyright <20> 1993-1998 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.
;;;;
;;;; $Id: Toplevel.stklos 1.7 Tue, 03 Mar 1998 22:48:24 +0000 eg $
;;;;
;;;;	       Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;;	Creation date:	5-Mar-1994 17:19
;;;; Last file update:  3-Mar-1998 19:49

(require "Basics")

(select-module STklos+Tk)

(export *top-root* deiconify iconify toplevel-frame toplevel-state withdraw)

;=============================================================================
;
;			 	<Frame> 
;
;=============================================================================

(define-class <Frame> (<Tk-simple-widget> <Tk-sizeable>)
  ((class	:getter   	class
		:init-keyword   :class
		:allocation	:tk-virtual)
   (colormap	:getter   	colormap  
		:init-keyword	:colormap
		:allocation	:tk-virtual)
   (container	:accessor	container 
		:init-keyword	:container
		:allocation	:tk-virtual)
   (visual	:accessor	visual
		:init-keyword	:visual
		:allocation	:tk-virtual)))

(define-method tk-constructor ((self <Frame>))
  Tk:frame)

(define-method initialize ((self <Frame>) initargs)
  ;; We have a special initialization because some slots values must be
  ;; passed at widget initialization. So we have to isolate these slots 
  ;; since they cannot be initialized in a standard way
  (let ((specials (special-Tk-slots self)))
    (let Loop ((l initargs) (normal '()) (special '()))
      (cond
       ((null? l) 
	     (if (null? special)
		 (next-method self normal)
		 (next-method self `(:tk-options ,special ,@normal))))
       ((memv (car l) specials)
	     (Loop (cddr l) normal (list* (car l) (cadr l) special)))
       (else (Loop (cddr l) (list* (car l) (cadr l) normal) special))))))

(define-method special-Tk-slots ((self <Frame>))
  (list :class :colormap :container :visual))

;=============================================================================
;
;				 <Toplevel>
;
;=============================================================================

(define-class <Toplevel> (<Frame>)
  ((menu	:accessor     	menu-of 
		:init-keyword   :menu
		:allocation   	:tk-virtual)
   (screen	:getter		screen
		:init-keyword	:screen
		:allocation	:tk-virtual)
   (use		:getter		use
		:init-keyword	:use
		:allocation	:tk-virtual)

   ;;;;
   ;;;; Following slots embody the Tk:wm command options
   ;;;; Note: "Uncommon" slots have not been given an accessor
   ;;;;
   (aspect	:allocation	:virtual
		:init-keyword	:aspect
		:slot-ref	(lambda (o) (Tk:wm 'aspect (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) 
				  (apply Tk:wm 'aspect (slot-ref o 'Eid) v)))

   (client	:allocation	:virtual
		:init-keyword	:client
		:slot-ref	(lambda (o) (Tk:wm 'client (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) 
				  (Tk:wm 'client (slot-ref o 'Eid) v)))
   (command	:allocation	:virtual
		:init-keyword	:command
		:slot-ref	(lambda (o) (Tk:wm 'command (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) 
				  (Tk:wm 'command (slot-ref o 'Eid) v)))
   (focus-model	:allocation	:virtual
		:init-keyword	:focus-model
		:slot-ref	(lambda (o) (Tk:wm 'focus (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v)
				  (Tk:wm 'focus (slot-ref o 'Eid) v)))
   (geometry	:accessor	geometry
		:init-keyword 	:geometry
		:allocation	:virtual
		:slot-ref	(lambda (o) (Tk:wm 'geometry (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v)
				  (Tk:wm 'geometry (slot-ref o 'Eid) v)))
   (wm-group	:allocation	:virtual
		:init-keyword	:wm-group
		:slot-ref	(lambda (o) (Tk:wm 'group (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) 
				  (Tk:wm 'group (slot-ref o 'Eid) v)))
   (icon-bitmap	:accessor	icon-bitmap
		:init-keyword	:icon-bitmap
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'iconbit (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'iconbit (slot-ref o 'Eid) v)))
   (icon-mask	:init-keyword	:icon-mask
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'iconma (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'iconma (slot-ref o 'Eid) v)))
   (icon-name	:accessor	icon-name
		:init-keyword	:icon-name
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'iconnam (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'iconnam (slot-ref o 'Eid) v)))
   (icon-window	:init-keyword	:icon-window
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'iconwin (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'iconwin (slot-ref o 'Eid) v)))
   (max-size	:accessor	maximum-size
		:init-keyword	:maximum-size
		:allocation	:virtual
		:slot-ref	(lambda (o) (Tk:wm 'max (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v)
				  (apply Tk:wm 'max (slot-ref o 'Eid) v)))
   (min-size	:accessor	minimum-size
		:init-keyword	:minimum-size
		:allocation	:virtual
		:slot-ref	(lambda (o) (Tk:wm 'min (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v)
				  (apply Tk:wm 'min (slot-ref o 'Eid) v)))
   (override 	:init-keyword	:override-redirect
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'over (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'over (slot-ref o 'Eid) v)))
   (pos-from	:init-keyword	:position-from
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'pos (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'pos (slot-ref o 'Eid) v)))
   (protocol	:init-keyword	:protocol
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'proto (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'proto (slot-ref o 'Eid) v)))
   (size-from	:init-keyword	:size-from
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'size (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'size (slot-ref o 'Eid) v)))
   (title	:accessor	title
		:init-keyword	:title
		:allocation	:virtual
		:slot-ref	(lambda (o)   (Tk:wm 'title (slot-ref o 'Eid)))
		:slot-set!	(lambda (o v) (Tk:wm 'title (slot-ref o 'Eid) v)))
   (transient	:accessor	transient-for
		:init-keyword	:transient-for
		:allocation	:virtual
		:slot-ref       (lambda (o)   (Tk:wm 'trans (slot-ref o 'Eid)))
		:slot-set!      (lambda (o v) (Tk:wm 'trans (slot-ref o 'Eid) v)))))


(define-method tk-constructor ((self <Toplevel>))
  Tk:toplevel)

(define-method special-Tk-slots ((self <Frame>))
  (list :class :colormap :container :visual :screen :use))

;=============================================================================
;
; Some <Toplevel> methods 
;
;=============================================================================

(define-method deiconify ((self <Toplevel>))
  (Tk:wm 'deiconify (slot-ref self 'Eid)))

(define-method iconify ((self <Toplevel>))
  (Tk:wm 'iconify (slot-ref self 'Eid)))

(define-method toplevel-frame ((self <Toplevel>))
  (Tk:wm 'frame (slot-ref self 'Eid)))

(define-method toplevel-state ((self <Toplevel>))
  (Tk:wm 'state (slot-ref self 'Eid)))

(define-method withdraw ((self <Toplevel>))
  (Tk:wm 'withdraw (slot-ref self 'Eid)))

;=============================================================================
;
; Redefine *top-root* to a <Toplevel> accessing the root window (before
; loading this file *top-root* is set to #f)
;
;=============================================================================
(set! *top-root* (if Tk:initialized?
		     (let ((top (allocate-instance <Toplevel> '())))
			 (slot-set! top 'Id     *root*)
			 (slot-set! top 'Eid    *root*)
			 (slot-set! top 'parent *root*)
			 (set-widget-data! *root* `(:instance ,top))
			 top)
		       #f))

(provide "Toplevel")