;;;; ;;;; M e n u . s t k -- Menu Class definition ;;;; ;;;; ;;;; Copyright (C) 1993,1994,1995 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. ;;; ;;;; This software is a derivative work of other copyrighted softwares; the ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS ;;;;; ;;;; Author: Erick Gallesio [eg@kaolin.unice.fr] ;;;; Creation date: 3-Mar-1994 21:03 ;;;; Last file update: 6-Jun-1995 13:48 (require "Basics") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; WARNING: Menus have not a relief (which is inherited by ). ;;; Hence, it is overloaded here (define-class () ((active-background :init-keyword :active-background :accessor active-background :tk-name activebackground :allocation :tk-virtual) (active-border-width :init-keyword :active-border-width :accessor active-border-width :tk-name activeborderwidth :allocation :tk-virtual) (active-foreground :init-keyword :active-foreground :accessor active-foreground :tk-name activeforeground :allocation :tk-virtual) (disabled-foreground :init-keyword :disabled-foreground :accessor disabled-foreground :tk-name disabledforeground :allocation :tk-virtual) (font :init-keyword :font :accessor font :allocation :tk-virtual) (foreground :init-keyword :foreground :accessor foreground :allocation :tk-virtual) (post-command :init-keyword :post-command :accessor post-command :tk-name postcommand :allocation :tk-virtual) (selector :init-keyword :selector :accessor selector :allocation :tk-virtual) ;; A special case for relief slot (which is inherited but don't exist). (relief :allocation :virtual :slot-ref (lambda (o) "flat") :slot-set! (lambda (o v) (error "Relief cannot be set on a menu"))))) (define-method tk-constructor ((self )) Tk:menu) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; methods ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Activate ;;; (define-method activate ((self ) index) ((slot-ref self 'Id) 'activate index)) ;;; ;;; Menu-add ;;; (define-method menu-add ((self ) type . args) (apply (slot-ref self 'Id) 'add type args)) ;;; ;;; Delete ;;; (define-method delete ((self ) index1 . index2) (apply (slot-ref self 'Id) 'delete index1 index2)) ;;; ;;; Disable ;;; (define-method disable ((self ) index) ((slot-ref self 'Id) 'disable index)) ;;; ;;; Enable ;;; (define-method enable ((self ) index) ((slot-ref self 'Id) 'enable index)) ;;; ;;; Menu-entry-configure ;;; (define-method menu-entry-configure ((self ) index . args) (apply (slot-ref self 'Id) 'entryconf index args)) ;;; ;;; Menu-index ;;; (define-method menu-index ((self ) index) ((slot-ref self 'Id) 'index index)) ;;; ;;; Invoke ;;; (define-method invoke ((self ) index) ((slot-ref self 'Id) 'invoke index)) ;;; ;;; Menu-Post ;;; (define-method menu-post ((self ) x y) ((slot-ref self 'Id) 'post x y)) ;;; ;;; Menu-unpost ;;; (define-method menu-unpost ((self )) ((slot-ref self 'Id) 'unpost)) ;;; ;;; Menu-y-position ;;; (define-method menu-y-position ((self ) index) ((slot-ref self 'Id) 'ypos index)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class ( ) ((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) (disabled-foreground :accessor disabled-foreground :init-keyword :disabled-foreground :allocation :tk-virtual :tk-name disabledf) (menu :accessor menu-of :allocation :tk-virtual) (state :accessor state :init-keyword :state :allocation :tk-virtual) (underline :accessor underline :init-keyword :underline :allocation :tk-virtual))) (define-method tk-constructor ((self )) Tk:menubutton) (define-method initialize ((self ) initargs) ;; Do normal initialization (next-method) ;; If a parent is specified, modify the parent menu-button to point self (let ((parent (get-keyword :parent initargs #f))) (if (and parent (is-a? parent )) (slot-set! parent 'menu (Id self))))) ;;; ;;; Define new accessors for menu slot to allow (set! (menu m-b) m) where m is an ;;; instance. ;;; Note that not init-keyword exists for menu since a menu must be descendant ;;; of its's menu button (this implies it must be created after its menu button). ;;; (define-method (setter menu-of) ((self ) (v )) (slot-set! self 'menu (slot-ref v 'Id))) (define-method menu-of ((self )) (Id->instance (slot-ref self 'menu))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Make-menubar -- A simper way to make menus ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (make-menubar parent l) (define (make-menu parent items) (let ((m (make :parent parent))) (for-each (lambda (item) (cond ; Separator ((equal? (car item) "") (menu-add m 'separator)) ; Normal Menu ((and (= (length item) 2) (procedure? (cadr item)) (menu-add m 'command :label (car item) :command (address-of (cadr item))))) ; Cascade menu ((and (= (length item) 2) (list? (cadr item)) (menu-add m 'cascade :label (car item) :menu (Id (make-menu m (cadr item)))))) (ELSE (apply menu-add m item)))) items) m)) (let ((f (make :parent parent))) ;; Store l in the f object to avoid GC problems (set-widget-data! (Id f) `(:menu ,l ,@(get-widget-data (Id f)))) (for-each (lambda (x) (let* ((title (if (list? (car x)) (caar x) (car x))) (rest (cdr x)) (mb (make :text title :parent f))) (if (list? (car x)) ;; User has specified pack options. Use them. (apply pack mb (cdar x)) ;; Pack menubutton on left and create its associated menu (pack mb :side "left")) (make-menu mb rest))) l) ;; Return the created frame as result f)) (provide "Menu")