;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; 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@unice.fr]
;;;;    Creation date: 17-May-1993 12:35
;;;; Last file update: 22-May-1995 10:25
;;;;


;; ----------------------------------------------------------------------
;; Class bindings for menubutton widgets.  Variables used:
;; tk::posted -		keeps track of the menubutton whose menu is
;;				currently posted (or empty string, if none).
;; tk::inMenuButton-	if non-null, identifies menu button
;;				containing mouse pointer.
;; tk::relief -		keeps track of original relief of posted
;;				menu button, so it can be restored later.
;; tk::dragging -		if non-null, identifies menu button whose
;;				menu is currently being dragged in a tear-off
;;				operation.
;; tk::focus -		records old focus window so focus can be
;;				returned there after keyboard traversal
;;				to menu.
;; ----------------------------------------------------------------------


(do-bindings "Menubutton" '(
  ("<Any-Enter>"	 . (begin
			     (set! tk::inMenuButton |%W|)
			     (unless (equal? (tk-get |%W| :state) "disabled")
				(unless tk-strictMotif
				   (tk-set! |%W| :state "active")))))
  ("<Any-Leave>"	 . (begin
			     (set! tk::inMenuButton '())
			     (when (equal? (tk-get |%W| :state) "active")
				(tk-set! |%W| :state "normal"))))

  ("<1>"		 . (tk-mbButtonDown |%W|))
  ("<Any-ButtonRelease-1>" . (if (and (equal? |%W| tk::posted)
				      (equal? |%W| tk::inMenuButton))
				 [(string->widget (tk-get |%W| :menu)) 'activate 0]
				 [tk-mbUnpost]))
  ;; The binding below is trickier than it looks.  It's important to check
  ;; to see that another menu is posted in the "if" statement below.
  ;; The check is needed because some window managers (e.g. mwm in
  ;; click-to-focus mode) cause a button-press event to be preceded by
  ;; a B1-Enter event;  we don't want to process that B1-Enter event (if
  ;; we do, the grab may get mis-set so that the menu is non-responsive).
  ("<B1-Enter>"		 . (begin 
			     (set! tk::inMenuButton |%W|)
			     (when (and (not (equal? (tk-get |%W| :state) "disabled"))
					tk::posted)
				(unless tk-strictMotif
				   (tk-set! |%W| :state "active"))
				(tk-mbPost |%W|))))
  
  ("<2>" 		. (unless (or tk::posted 
				      (equal? (tk-get |%W| :state) "disabled"))
			     (set! tk::dragging |%W|)
			     (tk-execute-menu |%W| |%X| |%Y|)))

  ("<B2-Motion>"	. (unless (equal? tk::dragging "")
			     (tk-execute-menu |%W| |%X| |%Y|)))

  ("<ButtonRelease-2>"	. (set! tk::dragging ""))
))


;; ----------------------------------------------------------------------
;; Class bindings for menu widgets.  tk-priv(x) and tk-priv(y) are used
;; to keep track of the position of the mouse cursor in the menu window
;; during dragging of tear-off menus.  tk-priv(window) keeps track of
;; the menu containing the mouse, if any.
;; ----------------------------------------------------------------------

(do-bindings "Menu" '(
  ("<Any-Enter>"		. (begin
			    (set! tk::window |%W|)
			    (|%W| 'activate '@%y)))
  ("<Any-Leave>"		. (begin
			    (set! tk::window '())
			    (|%W| 'activate "none")))
  ("<Any-Motion>"		. (when (equal? tk::window |%W|)
				(|%W| 'activate '@%y)))

  ("<1>"			. (unless (equal? tk::grab "")
			     (grab tk::grab)))
  ("<ButtonRelease-1>"	. (tk-invokeMenu |%W|))

  ("<2>"			. (begin
			    (set! tk::x %x)
			    (set! tk::y %y)))
  ("<B2-Motion>"		. (unless tk::posted
			     (|%W| 'post (- |%X|  tk::x) (- |%Y| tk::y))))
  ("<B2-Leave>"		. ())
  ("<B2-Enter>"		. ())
  ("<Escape>" 		. (tk-mbUnpost))
; ("<Any-KeyPress>"	. (tk-traverseWithinMenu |%W| "%A"))
; ("<Left>" 		. (tk-nextMenu -1))
; ("<Right>"		. (tk-nextMenu 1))
; ("<Up>"		. (tk-nextMenuEntry -1))
; ("<Down>"		. (tk-nextMenuEntry 1))
  ("<Return>" 		. (tk-invokeMenu |%W|))
))

;; The procedure below is publically available.  It is used to identify
;; a frame that serves as a menu bar and the menu buttons that lie inside
;; the menu bar.  This procedure establishes proper "menu bar" behavior
;; for all of the menu buttons, including keyboard menu traversal.  Only
;; one menu bar may exist for a given top-level window at a time.
;; Arguments:
;;	
;; bar -			The path name of the containing frame.  Must
;;				be an ancestor of all of the menu buttons,
;;				since it will be be used in grabs.
;; additional arguments -	One or more menu buttons that are descendants
;;				of bar.  The order of these arguments
;;				determines the order of keyboard traversal.
;;				If no extra arguments are named then all of
;;				the menu bar information for bar is cancelled.

(define tk::menusFor   '())
(define tk::menuBarFor '())

(define (tk-menuBar w . args)
  (format #t "~S~%" args)
  (if (null? args)
      [cdr (assoc w tk::menusFor)]
      [let* ((win  (winfo 'toplevel w))
	     (tmp1 (assoc w tk::menusFor))
	     (tmp2 (assoc win tk::menuBarFor)))
	(format #t "tmp1 ~S tmp2 ~S win ~S~%" tmp1 tmp2 win)
	
	(if tmp1 
	    [set-cdr! tmp1 args]
	    [set! tk::menusFor (cons (cons w args) tk::menusFor)])
	(if tmp2 
	    [set-cdr! tmp2 w]
	    [set! tk::menuBarFor (cons (cons win w) tk::menuBarFor)])
	(bind w "<Any-ButtonRelease-1>" '(tk-mbUnpost))]))

;; The procedure below is publically available.  It takes any number of
;; arguments that are names of widgets or classes.  It sets up bindings
;; for the widgets or classes so that keyboard menu traversal is possible
;; when the input focus is in those widgets or classes.

(define (tk-bindForTraversal . args)
  (for-each (lambda (w)
	      (bind w "<Alt-KeyPress>" '(tk-traverseToMenu |%W| "%A"))
	      (bind w "<F10>" (tk-firstMenu |%W|)))
	    args))

;; The function below does all of the work of posting a menu (including
;; unposting any other menu that might currently be posted).  The "w"
;; argument is the name of the menubutton for the menu to be posted.
;; Note:  if w is disabled then the procedure does nothing.

(define (tk-mbPost w)
  (call/cc 
   (lambda (return)
     (when (equal? (tk-get w :state) "disabled")
	(return #f))

     (when (equal? tk::posted w)
;      (grab :global tk::grab)
       (grab tk::grab)
       (return #f))

     (let ((Menu (tk-get w :menu)))
       (when (equal? Menu "")
	  (return #f))

       (set! Menu (string->widget Menu))

       ;; if a menu is already posted, unpost it
       (when tk::posted (tk-mbUnpost))

       ;; Retain several graphical infos
       (set! tk::relief   (tk-get w :relief))
       (set! tk::activeBg (tk-get Menu :activebackground))
       (set! tk::activeFg (tk-get Menu :activeforeground))	

       (tk-set! w :relief "raised")
       (set! tk::posted w)

       (when (eqv? tk::focus '())
	  (let ((f (focus)))
	    (set! tk::focus
		  (if (equal? f 'none) "none" (eval f)))))
       (focus Menu)

       (when tk-strictMotif
	  (tk-set! Menu :activebackground (tk-get Menu :background))
	  (tk-set! Menu :activeforeground (tk-get Menu :foreground)))

       (Menu 'activate "none")
       (Menu 'post (winfo 'rootx w) (+ (winfo 'rooty w) (winfo 'height w)))
       (let* ((grb '())
	      (win (winfo 'toplevel w))
	      (tmp (assoc win tk::menuBarFor)))
	 (if tmp
	     ;; menu associated 
	     [begin
	       (set! grb (cdr tmp))
	       (unless (member w (cdr (assoc grb tk::menusFor)))
		  (set! grb w))]
	     [set! grb w])
	 
	 ;; Retain actual cursor and set it now to an arrow
	 (set! tk::cursor (tk-get grb :cursor))
	 (tk-set! grb :cursor "arrow")

	 (set! tk::grab grb)
;	 (grab :global grb)
	 (grab grb))))))


;; The procedure below does all the work of unposting the menubutton that's
;; currently posted.  It takes no arguments.  Special notes:
;; 1. It's important to unpost the menu before releasing the grab, so
;;    that any Enter-Leave events (e.g. from menu back to main
;;    application) have mode NotifyGrab.
;; 2. Be sure to enclose various groups of commands in "catch" so that
;;    the procedure will complete even if the menubutton or the menu
;;    or the grab window has been deleted.

(define (tk-mbUnpost)
  (when tk::posted
	(let ((w tk::posted))
	  (catch 
	     (let ((Menu (string->widget (tk-get w :menu))))
	       (Menu 'unpost)
	       (tk-set! Menu :activebackground tk::activeBg)
	       (tk-set! Menu :activeforeground tk::activeFg)
	       (tk-set! w :relief tk::relief)))
	  (catch
	      (tk-set! tk::grab :cursor tk::cursor))
	  (focus tk::focus)
	  (grab 'release tk::grab)
	  (set! tk::focus '())
	  (set! tk::posted #f))))

;; Following function executes the menu-button associated menu (if it exists)
(define (tk-execute-menu w x y)
  (let ((widget (string->widget (tk-get w :menu))))
    (if widget
	(widget 'post x y))))


;; The procedure below invokes the active entry in the posted menu,
;; if there is one.  Otherwise it does nothing.

(define (tk-invokeMenu menu)
  (let ((i (menu 'index 'active)))
    (unless (equal? i "none")
      (tk-mbUnpost)
      (update 'idletasks)
      (menu 'invoke i))))

;; The procedure below is invoked when a button-1-down event is
;; received by a menu button.  If the mouse is in the menu button
;; then it posts the button's menu.  If the mouse isn't in the
;; button's menu, then it deactivates any active entry in the menu.
;; Remember, event-sharing can cause this procedure to be invoked
;; for two different menu buttons on the same event.

(define (tk-mbButtonDown w)
  (unless (equal? (tk-get w :state) "disabled")
    (when (equal? tk::inMenuButton w)
       (tk-mbPost w))))