;;;;
;;;;  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")