;;;; ;;;; T o p l e v e l . s t k -- Frame and Toplevel class definitions ;;;; ;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; 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.9 Sun, 25 Oct 1998 22:52:31 +0100 eg $ ;;;; ;;;; Author: Erick Gallesio [eg@kaolin.unice.fr] ;;;; Creation date: 5-Mar-1994 17:19 ;;;; Last file update: 15-Oct-1998 21:43 (require "Basics") (select-module STklos+Tk) (export *top-root* children deiconify iconify toplevel-frame toplevel-state withdraw make-transient place-toplevel) ;============================================================================= ; ; ; ;============================================================================= (define-class ( ) ((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 )) Tk:frame) (define-method initialize ((self ) 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 )) (list :class :colormap :container :visual)) (define-method children ((self )) (let ((l (winfo 'children (slot-ref self 'Id))) (trad (lambda (x) (let ((x (Id->instance x))) (if x (list x) '()))))) (apply append (map trad l)))) ;============================================================================= ; ; ; ;============================================================================= (define-class () ((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 )) Tk:toplevel) (define-method special-Tk-slots ((self )) (list :class :colormap :container :visual :screen :use)) ;============================================================================= ; ; Some methods ; ;============================================================================= (define-method deiconify ((self )) (Tk:wm 'deiconify (slot-ref self 'Eid))) (define-method iconify ((self )) (Tk:wm 'iconify (slot-ref self 'Eid))) (define-method toplevel-frame ((self )) (Tk:wm 'frame (slot-ref self 'Eid))) (define-method toplevel-state ((self )) (Tk:wm 'state (slot-ref self 'Eid))) (define-method withdraw ((self )) (Tk:wm 'withdraw (slot-ref self 'Eid))) (define-method place-toplevel ((self ) x y) (set! (geometry self) (format #f "+~A+~A"x y))) (define-method make-transient ((self )) (withdraw self) (slot-set! self 'override #t)) ;============================================================================= ; ; Redefine *top-root* to a accessing the root window (before ; loading this file *top-root* is set to #f) ; ;============================================================================= (set! *top-root* (if Tk:initialized? (let ((top (allocate-instance '()))) (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")