341 lines
11 KiB
Plaintext
341 lines
11 KiB
Plaintext
;;;;
|
|
;;;; M e n u . s t k -- Menu Class definition
|
|
;;;;
|
|
;;;;
|
|
;;;; Copyright © 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@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)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Menu> class definition
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Menu> (<Tk-simple-widget>)
|
|
(;; 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 <Tk-metaclass>)
|
|
|
|
(define-method tk-constructor ((self <Menu>))
|
|
Tk:menu)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Menu> methods
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;
|
|
;;; Activate
|
|
;;;
|
|
(define-method activate ((self <Menu>) index)
|
|
((slot-ref self 'Id) 'activate index))
|
|
|
|
;;;
|
|
;;; Menu-add
|
|
;;;
|
|
(define-method menu-add ((self <Menu>) type . args)
|
|
(apply (slot-ref self 'Id) 'add type args))
|
|
|
|
;;;
|
|
;;; Delete
|
|
;;;
|
|
(define-method delete ((self <Menu>) index1 . index2)
|
|
(apply (slot-ref self 'Id) 'delete index1 index2))
|
|
|
|
|
|
;;;
|
|
;;; Disable
|
|
;;;
|
|
(define-method disable ((self <Menu>) index)
|
|
((slot-ref self 'Id) 'entryconfigure index :state "disabled"))
|
|
|
|
;;;
|
|
;;; Enable
|
|
;;;
|
|
(define-method enable ((self <Menu>) index)
|
|
((slot-ref self 'Id) 'entryconfigure index :state "normal"))
|
|
|
|
;;;
|
|
;;; Menu-entry-configure
|
|
;;;
|
|
(define-method menu-entry-configure ((self <Menu>) index . args)
|
|
(apply (slot-ref self 'Id) 'entryconf index args))
|
|
|
|
;;;
|
|
;;; Menu-index
|
|
;;;
|
|
(define-method menu-index ((self <Menu>) index)
|
|
((slot-ref self 'Id) 'index index))
|
|
|
|
;;;
|
|
;;; Invoke
|
|
;;;
|
|
(define-method invoke ((self <Menu>) index)
|
|
((slot-ref self 'Id) 'invoke index))
|
|
|
|
;;;
|
|
;;; Menu-Post
|
|
;;;
|
|
(define-method menu-post ((self <Menu>) x y)
|
|
((slot-ref self 'Id) 'post x y))
|
|
|
|
;;;
|
|
;;; Menu-unpost
|
|
;;;
|
|
(define-method menu-unpost ((self <Menu>))
|
|
((slot-ref self 'Id) 'unpost))
|
|
|
|
;;;
|
|
;;; Menu-y-position
|
|
;;;
|
|
(define-method menu-y-position ((self <Menu>) index)
|
|
((slot-ref self 'Id) 'ypos index))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; <Menu-button> class definition
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-class <Menu-button> (<Tk-simple-widget> <Tk-sizeable> <Tk-bitmap>
|
|
<Tk-simple-text>)
|
|
((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 <Menu-button>))
|
|
Tk:menubutton)
|
|
|
|
(define-method initialize ((self <Menu>) 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 <Menu-button>) (v <Menu>))
|
|
(slot-set! self 'menu (slot-ref v 'Id)))
|
|
|
|
(define-method menu-of ((self <Menu-button>))
|
|
(Id->instance (slot-ref self 'menu)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Menu and Menu-button cloning
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-method clone-widget ((self <Menu-Button>) 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 <Menu>) 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 <Menu> '()))
|
|
(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 <Menu> :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 <Frame> :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 <Menu-button> :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")
|