;;;; ;;;; M e n u . s t k -- Menu Class definition ;;;; ;;;; ;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; 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@kaolin.unice.fr] ;;;; Creation date: 3-Mar-1994 21:03 ;;;; Last file update: 3-Sep-1999 20:10 (eg) (require "Basics") (select-module STklos+Tk) (export ;; Menu methods activate menu-add delete disable enable menu-entry-configure menu-index invoke menu-post menu-unpost menu-y-position ;; Menu-button Methods menu-of (setter menu-of) make-menubar) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; class definition ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () (;; The slots hilight* are overloaded here since they don't exist in Tk ;; Change the hierarchy? (highlight-background :accessor highlight-background :init-keyword :highlight-background :allocation :virtual :slot-ref (lambda (o) #f) :slot-set! (lambda (o v) v)) (highlight-color :accessor highlight-color :init-keyword :highlight-color :tk-name highlightcolor :allocation :virtual :slot-ref (lambda (o) #f) :slot-set! (lambda (o v) v)) (highlight-thickness :accessor highlight-thickness :init-keyword :highlight-thickness :tk-name highlightthick :allocation :virtual :slot-ref (lambda (o) #f) :slot-set! (lambda (o v) v)) (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) (select-color :init-keyword :select-color :accessor select-color :tk-name selectcolor :allocation :tk-virtual) (tear-off :init-keyword :tear-off :accessor tear-off :tk-name tearoff :allocation :tk-virtual) (title :init-keyword :title :accessor title :allocation :tk-virtual) (type :init-keyword :type :accessor type :allocation :tk-virtual)) :metaclass ) (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) 'entryconfigure index :state "disabled")) ;;; ;;; Enable ;;; (define-method enable ((self ) index) ((slot-ref self 'Id) 'entryconfigure index :state "normal")) ;;; ;;; 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) (direction :accessor direction :init-keyword :direction :allocation :tk-virtual) (disabled-foreground :accessor disabled-foreground :init-keyword :disabled-foreground :allocation :tk-virtual :tk-name disabledf) (indicator-on :init-keyword :indicator-on :accessor indicator-on :allocation :tk-virtual :tk-name indicatoron) (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 (slot-exists? parent 'menu)) (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; Menu and Menu-button cloning ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-method clone-widget ((self ) new-parent) (let ((clone (next-method)) (menu (slot-ref self 'menu))) (when menu ;; This menubutton has an associated menu. Clone it (slot-set! clone 'menu (clone-widget (Id->instance menu) clone))) clone)) (define-method clone-widget ((self ) new-parent) ;; Tk has a clone procedure for menus. This procedure (in C) finally ;; call the Scheme function Tk:menu-dup. (Note that the normal Tk ;; function cannot be used because the parent of the new menu must ;; be a decendant of the original one. Anyway the Tk:menu-dup ;; function has not this problem and we use this in this code. ;; However, all that stuff is a little bit complicated besause we ;; need to return a Tk-object and the Tk toolkit already initializes ;; the new menu. So we just allocate the object here and fill-in it ;; with the values provided by Tk. Furthermore, we have to set the ;; ":instance" property to allow further Id->instance on the cloned ;; menu (let* ((m (Id self)) (new-id (gensym (& (Id new-parent) '.clone))) (new-obj (allocate-instance '())) (clone (Tk:menu-dup m new-id "normal"))) (slot-set! new-obj 'Id clone) (slot-set! new-obj 'Eid clone) (slot-set! new-obj 'parent new-parent) (set-widget-data! clone (list :instance new-obj)) ;; ;; The following code is an adpation of the Tk:menu-dup code ;; to take into accound cascade menus. In fact, Tk:menu-dup ;; does not take into account the cascades (this is done in C ;; in the normal clone procedure). If we omit this code, the ;; cascades will be created but since their place in the hierarchy ;; is incorrect, they will be inactive. (let ((last (clone 'index "last"))) (unless (equal? last "none") (let loop ((i (if (tk-get clone :tearoff) 1 0))) (when (<= i last) (if (equal? (clone 'type i) "cascade") ;; We are on a cascade menu: clone it (let* ((item (clone 'entrycget i :menu)) (menu (and item (Id->instance item)))) (if menu (let ((x (clone-widget menu new-obj))) (clone 'entryconfigure i :menu x))))) (loop (+ i 1)))))) new-obj)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; 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 (cadr item)))) ; Cascade menu ((and (= (length item) 2) (list? (cadr item)) (menu-add m 'cascade :label (car item) :menu (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")