;;File: std-popups.gwm -- 
;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
;;Author: Frederic CHARTON
;;Revision: 1.0 -- Sep 12 1989
;;State: Exp
;;GWM Version: 1.4


; Pop-ups
; =======

(defname 'pop-item-font screen. menuFontList)
(defname 'pop-item-height screen. 18)
(defname 'pop-label-font screen. menuFontList)


(with (font menuFontList) (: item-height (+ 4 (height "A"))))

; Offset for cascading menus :
(: menu.offset.x 8)
(: menu.offset.y -4)

(: menu-right-arrow 
 (with (
	borderwidth 0
	fsm ()
       )
  (plug-make
   (pixmap-make menuBackground "right-arrow" menuForeground)
  )
 )
)


; Left and right plugs for items (-> 3D look)
(de border-plug-make (top h)
	(with ( foreground (if top menuTopShadowColor menuBottomShadowColor)
		fsm ()
		borderwidth 0
	      )
	(plug-make (pixmap-make 2 h) )
	)
)

(: border-plug-right (border-plug-make () item-height))
(: border-plug-left  (border-plug-make t item-height))

(: corner-plug (with (borderwidth 0 fsm ())
		(plug-make (pixmap-make menuTopShadowColor 
			"cornerPlug" menuBottomShadowColor) ) ))


(: top-bar-menu 
  (with (fsm () borderwidth 0 background menuTopShadowColor
	  bar-min-width 2
	  bar-max-width 2)
	 (bar-make () corner-plug)
  )
)

(: bottom-bar-menu 
  (with (fsm () borderwidth 0 background menuBottomShadowColor
	  bar-min-width 2
	  bar-max-width 2)
	 (bar-make corner-plug ())
  )
)

;-------------------------------------------------------------------------


; MENU.MAKE : args = list of items obtained by item-make or pop-label-make
; =========
(df menu.make args
 (with (
	borderwidth 0
	menu ()
	cursor menu-cursor
	myMenu (eval (+ '(menu-make) 
			(+ 
				'(top-bar-menu) 
				'(blank-item-separator)
				args 
				'(blank-item-separator)
				'(bottom-bar-menu))))
       )
   (send-user-event 'make-opened-tile (menu-wob myMenu))
 myMenu
 )
)


;-------------------------------------------------------------------------
; MENU.MOVE : places the menu inside the screen
; =========
(de menu.move (theMenu x y)
 (with (theMenuWob (menu-wob theMenu)
	w (width theMenuWob)
	h (height theMenuWob)
       )
  (if (> (+ y h) screen-height)
          (: y (- screen-height h)))
  (if (> (+ x w) screen-width)
          (: x (- screen-width w)))
  (move-window theMenuWob x y)
 )
)



;-------------------------------------------------------------------------

; MENU.POP : "pop" of a menu : args = (menu-to-pop button-to-use <'here>)
; ========
(de menu.pop args
  (with (menu-to-pop (if args (# 0 args) wob-menu) 
      window-of-menu window)
    (if (# 1 args) (: button-menu (# 1 args)))
    (send-user-event 'update-items (menu-wob menu-to-pop))
    (send-user-event 'activate-menu (menu-wob menu-to-pop))
    (## 'current-valid-item (menu-wob menu-to-pop) 0)
    (if (> (current-event-code) 5)
      (send-user-event 'select-item (# 0 (# 'valid-items
	    (menu-wob menu-to-pop)))))
    (## 'menu-son wob (menu-wob menu-to-pop))
    (## 'already-popped (menu-wob menu-to-pop) t)
    (## 'father (menu-wob menu-to-pop) wob)
    (setq popping-window window)
    (with (grab-keyboard-also t)
      (if (member 'here args)
	(pop-menu menu-to-pop 'here)
	(pop-menu menu-to-pop)
    ))
    (send-user-event 'set-grabs (menu-wob menu-to-pop))
))

;-------------------------------------------------------------------------


; Borders plugs of item separators
(: separator-plug-left
	(with (
		fsm ()
		borderwidth 0 
		foreground menuBackground
		plug-tile (pixmap-make 4 3)
		foreground menuTopShadowColor
	      )
	(draw-line plug-tile 0 0 0 2)
	(draw-line plug-tile 1 0 1 2)
	(plug-make plug-tile)
	)
)
(: separator-plug-right
	(with (
		fsm ()
		borderwidth 0
		foreground menuBackground
		plug-tile (pixmap-make 4 3)
		foreground menuBottomShadowColor
	      )
	(draw-line plug-tile 2 0 2 2)
	(draw-line plug-tile 3 0 3 2)
	(plug-make plug-tile)
	)
)

; Blank item separator (space between two consecutive items)
(: blank-item-separator
   (with (fsm () borderwidth 0
	  background menuBackground
          bar-min-width 3 )
     (bar-make separator-plug-left () separator-plug-right )
   )
)

; Item separator (line between two consecutive items)
(: item-separator
   (with (fsm () borderwidth 0
	  tile (pixmap-make menuBackground "itemSep" menuForeground)
          bar-min-width 3 background menuBottomShadowColor)
     (bar-make separator-plug-left () separator-plug-right )
   )
)



;-------------------------------------------------------------------------

; VARIOUS UTILITIES :
; =-=-=-=-=-=-=-=-=

; Good button checking :
(df check-button ()
 (= button-menu (current-event-code))
)


(df valid-items eventual-wob
 (if eventual-wob 
  (with (wob (eval (# 0 eventual-wob)))
   (# 'valid-items wob)
  )
   (# 'valid-items wob)
 )
)

(df set-valid-items args
(with (item-nb (eval (# 0 args)) eventual-wob (eval (# 1 args)))
 (if eventual-wob 
  (with (wob (eval eventual-wob))
   (## 'valid-items wob item-nb)
  )
   (## 'valid-items wob item-nb)
 )
)
)

(df nb-valid-items ()
  (length (# 'valid-items wob))
)

(df current-valid-item eventual-wob
 (if eventual-wob 
  (with (wob (eval (# 0 eventual-wob)))
   (# 'current-valid-item wob)
  )
   (# 'current-valid-item wob)
 )
)

(de set-current-valid-item (item-nb)
  (## 'current-valid-item wob item-nb)
)

; Is the action "f.menu" ?
(df action-is-f.menu ()
 (= 'f.menu (# 0 (# 'action wob)))
)

(df menu-wob-of-action ()
 (menu-wob (eval (# 1 (# 'action wob))))
)

(df menu-of-action ()
 (eval (# 1 (# 'action wob)))
)


; The oldest menu father of the menu
(de menu-oldest-father (theWob)
 (with (father (or (# 'father theWob) root-window))
  (if (with (wob father) (= 'menu wob-status)) 
   (menu-oldest-father father)
   theWob
  )
 )
)

; The oldest father of the menu to grab
(de oldest-father-for-grab (theWob)
 (with (father (or (# 'father theWob) root-window))
  (if (with (wob father) (= 'menu wob-status)) 
   (menu-oldest-father father)
   (if (# 'is-button-menu father) father theWob)
  )
 )
)


; Setting of the current item :
(df fix-current-item ()
 (with (i 0 listOfValidItems (valid-items wob-parent) 
        current-item (# i listOfValidItems))
  (while current-item
   (if (= wob current-item) 
    (progn
     (with (wob wob-parent) 
	(## 'current-valid-item wob i)
     )
     (: current-item ())
    )
    (progn
     (: i (+ i 1))
     (: current-item (# i listOfValidItems))
    )
   )
  )
 )
)

(: menus-basic-state
 (state-make
 (on (user-event 'select-item)
   (wob-tile (# 'opened-tile wob)))
  (on (user-event 'goto-opened) () opened)
  (on (user-event 'goto-activable) () activable)
  (on (user-event 'depop) (: wob-background menuBackground) activable)
  (on (user-event 'unselect-item)
         (progn
                 (with (wob wob-parent)
                 (if (# 'item-menu-son wob)
                         (send-user-event 'depop (# 'menu-son wob)))
                 )
                 (: wob-background menuBackground)
         )
  )
  (on (user-event 'test-item-menu-popped)
   (if (action-is-f.menu)
     (: in-item-menu-popped
         (and (> cerx 0)
              (> cery 0)
              (< cerx wob-width)
              (< cery wob-height)
         )
     )
   )
  )
 )
)

;-------------------------------------------------------------------------



; ========================================================================
; ITEMS' FSM : 4 states : activable / non-activable / closed / opened
; ========================================================================

(setq menus.fsm  
(fsm-make 
;-----------------------------------------------------------ACTIVABLE
(: activable
(state-make
 (on (buttonpress any any) 
    (if (check-button)
     (progn
       (if (# (current-valid-item  wob-parent) (valid-items  wob-parent))
	   (send-user-event 
	    'unselect-item
	    (# (current-valid-item  wob-parent) (valid-items  wob-parent))
	    )
	 )
	(if (action-is-f.menu)
         (if (# 'already-popped wob)
          (progn
           (send-user-event 'unselect-item
                (# (current-valid-item  (menu-wob-of-action))
                       (valid-items  (menu-wob-of-action))) 
	   )
          )
          (progn
	   (with (theWob wob wob wob-parent)
            (## 'item-menu-son wob theWob)
	   )
	   (menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x) 
				       (+ wob-y menu.offset.y))
           (with (theMenu (menu-of-action) wob wob-parent) 
		(menu.pop theMenu button-menu 'here))
          )
         )
    	)
	(wob-tile (# 'opened-tile wob))
	(send-user-event 'activate-menu (menu-oldest-father wob-parent))
	(send-user-event 'goto-opened wob) 
     )
    )
 )
 (on (user-event 'update-items)
   (if (not 
        (with (condition (# 'enable-condition wob )
	       wob window-of-menu)
	(eval condition))
       )
	(send-user-event 'disable-item wob) 
	(set-valid-items (+ (valid-items wob-parent) (list wob)) wob-parent)
   ) 
 )
 (on (user-event 'disable-item) () non-activable)
 (on (user-event 'activate-menu) 
  (if (= wob (# (current-valid-item wob-parent) (valid-items wob-parent)))
	(if (or (not (action-is-f.menu)) 
	        (not (= wob (with (wob wob-parent) (# 'item-menu-son wob)))))
		 (: wob-background menuBackground) 
	)
  )
 closed)
 (on (user-event 'make-opened-tile) 
	(## 'opened-tile wob (item-tile.make wob-width wob-height))
 )

 menus-basic-state
)
)
;-----------------------------------------------------------NON-ACTIVABLE
(: non-activable
	(state-make
	 (on (buttonpress any any) 
	   (if (check-button) 
	    (send-user-event 'activate-menu (menu-oldest-father wob-parent))
	   )
	 )
	 (on (buttonrelease any any) 
	   (if (check-button) 
		   (send-user-event 'depop (menu-oldest-father wob-parent))
	   )
	 )
	 (on (user-event 'update-items)
	   (if 
	     (with  (condition (# 'enable-condition wob)
		     wob window-of-menu)
	       (eval condition))
	       (progn
	         (send-user-event 'enable-item wob) 
	         (set-valid-items (+ (valid-items wob-parent) (list wob)) 
			  wob-parent)
	       ) 
	   ) 
	 )
	 (on (user-event 'enable-item) () activable)
	)
)
;-----------------------------------------------------------CLOSED
(: closed 
   (state-make 
   (on enter-window 
	(progn
	 (: wob-tile (# 'opened-tile wob))
	 (if (action-is-f.menu)
	  (if (not (# 'already-popped wob))
          (progn
	   (with (theWob wob theMenu (menu-wob-of-action) wob wob-parent)
	    (## 'item-menu-son wob theWob)
	   )
	   (menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x) 
				       (+ wob-y menu.offset.y))
           (with (theMenu (menu-of-action) wob wob-parent) 
		(menu.pop theMenu button-menu 'here))
	   (fix-current-item)
          )
	  )
	 )
	)
   opened)

   menus-basic-state
  )
)
;-----------------------------------------------------------OPENED
(: opened
   (state-make
   (on (buttonpress any any)
    (if (and (check-button) (action-is-f.menu))
     (send-user-event 'activate-menu  (menu-oldest-father wob-parent))
    )
   )
   (on (buttonrelease any any)
    (if (check-button)
     (if (action-is-f.menu)
      (progn
       (fix-current-item)
       (with (wob  (menu-wob-of-action))
        (## 'current-valid-item wob 0))
       (with (theWob (oldest-father-for-grab wob-parent))
	(if (# 'is-button-menu theWob) 
	 (send-user-event 'button-release theWob))
       )
       (send-user-event 'goto-activable  (menu-oldest-father wob-parent))
       (send-user-event 'select-item 
	(# 0 (valid-items  (menu-wob-of-action))) )
      )
      (progn
       (setq std-popups.action (# 'action wob))
       (send-user-event 'goto-activable (menu-oldest-father wob-parent))
       (send-user-event 'depop (menu-oldest-father wob-parent))
       (: wob-background menuBackground)
       (wob wob-parent)
       (wob (# 'father wob))
       (with (window popping-window action-by-menu t) (eval std-popups.action))
      )
     ) 
    )
   )
   (on leave-window
    (if (action-is-f.menu)
     (with (cerx (current-event-relative-x) 
	    cery (current-event-relative-y))
      (if (not
          (and (> cerx 0)
               (> cery 0)
               (< cerx wob-width)
               (< cery wob-height)
          ) )
	(with (cex (current-event-x) cey (current-event-y)
		in-menu-son ())
	(send-user-event 'in-menu-son-test (menu-wob-of-action))
	(if (not in-menu-son)
         (progn
          (: wob-background menuBackground )
          (send-user-event 'goto-activable  (menu-wob-of-action))
          (send-user-event 'unselect-item
                (# (current-valid-item  (menu-wob-of-action))
                          (valid-items  (menu-wob-of-action))))
          (send-user-event 'depop  (menu-wob-of-action))
	  (send-user-event 'goto-closed wob)
         )
        )
	)
     )
     )
     (progn
      (: wob-background menuBackground )
      (send-user-event 'goto-closed wob)
     )
    )
   )
   (on (user-event 'goto-closed) () closed)
   (on (user-event 'unselect-item) (: wob-background menuBackground))
   menus-basic-state
  )
 )
)
)


;-------------------------------------------------------------------------


; MNEMO-LABEL-MAKE : making of a label with is underlined mnemonic
; ================   or of the pixmap designed by the file "@file" .
(de mnemo-label-make (label mnemo)
(if (eq 0 (member "@" label))
 (with ( pixmapFile (match "@\\(.*\\)" label 1))
  (pixmap-make menuBackground pixmapFile menuForeground)
 )
 (if mnemo
  (with (
	 foreground menuForeground
	 background menuBackground
	 before-mnemo (match (+ "\\(.*\\)" mnemo) label 1)
	 after-mnemo (match (+ "\\(.*" mnemo "\\)") label 1)
	 font menuFontList
	 x1 (if (and before-mnemo
		     (not (= before-mnemo "")))
		(- (width before-mnemo) label-horizontal-margin) 
	      label-horizontal-margin)
	 x2 (- (width after-mnemo) label-horizontal-margin)
	 y (- item-height 6)
        )
   ;(? before-mnemo "!!" after-mnemo  "!!" x1 "!!" x2 "\n")
   (draw-line (label-make label) (- x1 1) y (- x2 2) y)
  )
  (with (
	 foreground menuForeground
	 background menuBackground
	 font menuFontList
	)
   (label-make label)
  )
 )
)
)


;-------------------------------------------------------------------------


; ITEM-TILE.MAKE : making of the selected framework of an item
; ==============
(de item-tile.make (w h)
 (with (
	foreground menuBackground
	item-tile (pixmap-make (+ w (* 2 plug-separator)) h)
	item-xmax (- w 5)
	item-ymax (- h 1)
       )
 (with (foreground menuTopShadowColor)
	(draw-line item-tile 4 0 item-xmax 0         )
	(draw-line item-tile 4 1 item-xmax 1         )
	(draw-line item-tile 4 0 4         item-ymax)
	(draw-line item-tile 5 0 5         item-ymax)
 )
 (with (foreground menuBottomShadowColor)
	(draw-line item-tile 4               item-ymax        item-xmax       item-ymax      )
	(draw-line item-tile 5               (- item-ymax 1)  item-xmax       (- item-ymax 1))
	(draw-line item-tile item-xmax       0                item-xmax       item-ymax      )
	(draw-line item-tile (- item-xmax 1) 1                (- item-xmax 1) item-ymax      )
 )
 item-tile
 )
)


;-------------------------------------------------------------------------


; ITEM-MAKE  : 
; =========
; args : (label mnemonic action enable-condition blank-plug accelerator)
(df item-make args
    (with (
	   label (+ (# 0 args) "") ; assure que 'label' est une string
	   label-is-bitmap (eq 0 (member "@" label))
	   mnemo (# 1 args) action (# 2 args)
	   blank-plug (# 4 args) accelerator (# 5 args)
           property (+ 
		       '(opened-tile ())
		       (list 'enable-condition (if (> (length args) 3) (# 3 args) t))
		       (list 'action action) 
		       (list 'mnemonic mnemo)
		       '(already-popped  ())
		    )
	   borderwidth 0
	   enable-pixmap (mnemo-label-make   label mnemo)
	   bar-min-width (+ 
			   (if label-is-bitmap 8 4)
			   (height enable-pixmap))
	   plug-separator 4
	   fsm menus.fsm
	   background menuBackground
	  )
	  (bar-make
	      (if label-is-bitmap (border-plug-make t bar-min-width)
		border-plug-left)
	      (with (borderwidth 0 font pop-item-font
                   menuForeground ; Dynamic binding hack--boo hiss
                     (if shadeDisabled
                         menuShadeColor
                         menuForeground)
                   background menuBackground
		     disable-pixmap (mnemo-label-make label mnemo)
		     property (list 'item-label label 'mnemo mnemo
				    'enable-pixmap  enable-pixmap
				    'disable-pixmap
                             (if shadeDisabled disable-pixmap
                              (with (foreground menuForeground)
				    (draw-line disable-pixmap
					       0 (/ (height disable-pixmap) 2) 
					       (width disable-pixmap)
					       (/ (height disable-pixmap) 2))))
			      )
		     fsm 
			(fsm-make (state-make 
			 (on (user-event 'enable-item) 
                                 (: wob-tile (# 'enable-pixmap wob))
			 )
			 (on (user-event 'disable-item) 
                                 (: wob-tile (# 'disable-pixmap wob))
			 )
			 )
		    ))
		    (plug-make enable-pixmap)
		)
	      blank-plug 
	      (if (not (= (# 0 action) 'f.menu)) accelerator)
	      ()
	      (if (= (# 0 action) 'f.menu) menu-right-arrow)
	      (if label-is-bitmap (border-plug-make () bar-min-width) border-plug-right)
  ) )
)

;-------------------------------------------------------------------------


; POP-LABEL-MAKE : making of the menu's title
; ==============
(df pop-label-make (label)
    (with (fsm ()
	   background menuBackground
	   foreground menuForeground
	   borderwidth 0
	   bar-min-width item-height bar-max-width item-height
	   plug-separator 4
	  ) 
	  (bar-make
	      border-plug-left
	      ()
	      (with (borderwidth 0 font pop-label-font 
		     background menuBackground foreground menuForeground) 
		    (plug-make (mnemo-label-make label ())))
	      ()
	      border-plug-right
	  )
    )
)


;-------------------------------------------------------------------------

(de youngest-son (theWob)
 (with (wob theWob son (# 'menu-son wob))
  (if son (youngest-son son) wob)
 )
)

(de propagate-key-event (user-evt-name)
  (if (# 'menu-son wob) 
   (send-user-event user-evt-name (youngest-son wob))
   (send-user-event user-evt-name wob)
  )
)

; UPDATE-GRAB : grabs the server with flag "grab-keyboard-also" to true
; ===========   on the menu oldest father of the wob, then grabs the server
;		on the oldest father with flag "grab-keyborad-also" to false.
(de update-grab ()
  (with (
	 o-father (oldest-father-for-grab wob)
	 m-o-father (menu-oldest-father wob)
	)
   (with (grab-keyboard-also t) (grab-server m-o-father))
   (if (not (= o-father m-o-father)) (grab-server o-father))
  )
)


; MENUS' FSM :
; ==========
(: pop-fsm 
    (fsm-make 
     (: pop-state (state-make 
	(on enter-window
	(progn 
	 (if (and (not (current-event-from-grab)) (# 'active wob))
	 (progn
	  (if (# 'menu-son wob)
	   (progn
	    (: in-item-menu-popped ())
            (with (
		   cerx 
		   (current-event-relative-x)
		   cery 
		   (- (+ (current-event-relative-y) wob-y) 
		    (with (wob  (# 'item-menu-son wob)) wob-y))
		  )
	     (send-user-event 'test-item-menu-popped (# 'item-menu-son wob))
	    )
	    (if (not in-item-menu-popped)
	     (progn
	     (send-user-event 'goto-closed (# 'item-menu-son wob))
	     (send-user-event 'unselect-item (# 'item-menu-son wob))
	     ;(send-user-event 'depop (# 'menu-son wob))
	     )
	    )
	   )
	  )
	 )
	) )
	)
	(on (buttonpress any any) 
	  (if (check-button) 
               (progn
		(if (and double-click-required (= button-menu 1))
		 (progn 
		  (if (< (- (current-event-time) time-of-last-release) 
			 doubleClickTime)
			(send-user-event 'double-click double-click-required)
		  )
		  (: double-click-required ())
		 )
		)
		(send-user-event 'activate-menu (menu-oldest-father wob))
	       )
	   )
	)
	(on (buttonrelease any any) 
	  (if (check-button) (send-user-event 'depop (menu-oldest-father wob))) )
	(on (user-event 'depop) 
	 (progn
	  (if (# 'menu-son wob)
	   (send-user-event 'depop (# 'menu-son wob))
	  )
	  (update-grab)
	  (unpop-menu)
	  (with (father (or (# 'father wob) root-window))
	     (with (wob father)
	      (## 'already-popped wob ())
	      (## 'menu-son wob ())
	      (## 'item-menu-son wob ())
	     )
	     (send-user-event 'button-release father)
	     (with (wob father)
	      (if (not (= wob-status 'menu)) (ungrab-server))
	     )
	  )
	  (## 'menu-son wob ())
	  (## 'item-menu-son wob ())
	 )
	)
	(on (user-event 'activate-menu) 
	 (progn
	 (## 'active wob t)
         (if (# 'menu-son wob)
          (send-user-event 'activate-menu (# 'menu-son wob))
	 ) 
	 )
	)
	(on (user-event 'goto-activable) 
	 (progn
	 (## 'active wob ())
         (if (# 'menu-son wob)
          (send-user-event 'goto-activable (# 'menu-son wob))
	 ) 
	 )
	)
	(on (user-event 'update-items) (set-valid-items ()))
	(on (user-event 'set-grabs) (update-grab))
	(on (user-event 'in-menu-son-test)
	  (: in-menu-son (and (> cex wob-x) (> cey wob-y)
				(< cex (+ wob-x wob-width))
			 	(< cey (+ wob-y wob-height)))))

        ;--Keys Events :
	;--UP------------------------------------------------
	(on (keypress (key-make "Up") alone) 
	 (propagate-key-event 'Up)
	)
	(on (user-event 'Up)
	 (if (valid-items)
	  (progn 
	   (send-user-event 'unselect-item (# (current-valid-item) (valid-items)))
	   (set-current-valid-item (% (- 
		 (if (> (current-valid-item) 0) (current-valid-item) (nb-valid-items))
		 1) (nb-valid-items))
	   )
	   (send-user-event 'select-item (# (current-valid-item) (valid-items)))
	  )
	 )
	)
	;--DOWN----------------------------------------------
	(on (keypress (key-make "Down") alone) 
	 (propagate-key-event 'Down)
	)
	(on (user-event 'Down)
	 (if (valid-items)
	  (progn 
	   (send-user-event 'unselect-item (# (current-valid-item) (valid-items)))
	   (set-current-valid-item (% (+ (current-valid-item) 1) (nb-valid-items)))
	   (send-user-event 'select-item (# (current-valid-item) (valid-items)))
	  )
	 )
	)
	;--RIGHT---------------------------------------------
	(on (keypress (key-make "Right") alone) 
	 (propagate-key-event 'Right)
	)
	(on (user-event 'Right)
	 (with (wob  (# (current-valid-item) (valid-items)))
	  (if (action-is-f.menu)
	   (with (theMenu (menu-wob-of-action))
           (with (theWob wob wob wob-parent)
            (## 'item-menu-son wob theWob)
           )
	   (menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x) 
				       (+ wob-y menu.offset.y))
           (with (theMenu (menu-of-action) wob wob-parent) 
		(menu.pop theMenu button-menu 'here))
           (send-user-event 'goto-activable  theMenu)
           (send-user-event 'select-item (# 0 (valid-items  theMenu)) )
	   )
	  )
	 )
	)
	;--LEFT----------------------------------------------
	(on (keypress (key-make "Left") alone) 
	 (propagate-key-event 'Left)
	)
	(on (user-event 'Left)
	 (if (not (= wob (menu-oldest-father wob)))
	  (progn
          (send-user-event 'goto-activable  wob)
          (send-user-event 'depop wob)
	  (update-grab)
	  )
	 )
	)
	(on (keypress (key-make "Return") alone) 
	 (propagate-key-event 'Return)
	)
	;--RETURN--------------------------------------------
	(on (user-event 'Return)
	 (if (valid-items)
	  (if (with (wob (# (current-valid-item) (valid-items)) )
	       (action-is-f.menu) )
           (with (wob  (# (current-valid-item) (valid-items)))
            (if (action-is-f.menu)
             (with (theMenu (menu-wob-of-action))
             (with (theWob wob wob wob-parent)
              (## 'item-menu-son wob theWob)
             )
	   (menu.move (menu-of-action) (- (+ wob-x wob-width) menu.offset.x) 
				       (+ wob-y menu.offset.y))
           (with (theMenu (menu-of-action) wob wob-parent) 
		(menu.pop theMenu button-menu 'here))
             (send-user-event 'goto-activable  theMenu)
             (send-user-event 'select-item (# 0 (valid-items  theMenu)) )
             )
            )
          )
	  (progn 
	   (send-user-event 'unselect-item (# (current-valid-item) (valid-items)))
	   (with (wob (# (current-valid-item) (valid-items)))
            (setq std-popups.action (# 'action wob))
            (send-user-event 'depop (menu-oldest-father wob-parent))
            (: wob-background menuBackground)
            (wob wob-parent)
            (wob (# 'father wob))
            (with (action-by-menu t) (eval std-popups.action))
            (send-user-event 'goto-activable wob)
	   )
	  )
	  )
	 )
	)
	;--ESCAPE--------------------------------------------
	(on (keypress (key-make "Escape") alone) 
	 (propagate-key-event 'Escape)
	)
	(on (user-event 'Escape)
	 (if (valid-items)
	   (with (wob (# (current-valid-item) (valid-items)))
	    (send-user-event 'unselect-item wob)
            (send-user-event 'depop (menu-oldest-father wob-parent))
	   )
	 )
	)
	;--ANY KEY-------------------------------------------
	(on (keypress any any)
	 (with (cec (current-event-code) cem (current-event-modifier))
	  (send-user-event 'keypress-any-any (menu-oldest-father wob))
	 )
	)
	(on (user-event 'keypress-any-any)
	    (progn
	      (with (theKey cec
			    theAcceleratorItem
			    (# (atom (+ "key"
					(itoa
					 (keycode-to-keysym theKey alone))
					"m" (itoa cem)))
			       (# 'accelerator-list wob))
			    theMnemonicItem 
			    (# (atom (+ "key"
					(itoa
					 (keycode-to-keysym theKey alone))))
			       (# 'mnemonic-list wob))
			    theItem
			    (if theAcceleratorItem theAcceleratorItem
			      theMnemonicItem)
			    enable (# 0 theItem)
			    action (# 1 theItem)
			    )
		(if theItem
		    (if (eval enable)
			(progn
			  (send-user-event 'Escape wob)
			  (wob (# 'father wob))
			  (with (action-by-menu t) (eval action))
			  (send-user-event 'goto-activable wob)
			  )
		      )
		  (if (# 'menu-son wob) 
		      (send-user-event 'keypress-any-any (# 'menu-son wob))
		    )
		  )
		)
	      )
	    )
     )
   )
 )
)


;-------------------------------------------------------------------------


; MK-BLANK-PLUG : making of a "blank" pixmap 
; =============
(de mk-blank-plug (w)
 (with (fsm () foreground menuBackground borderwidth 0)
  (plug-make (pixmap-make (+ 1 w) 1))
 )
)


;-------------------------------------------------------------------------

;*******************************
(load "mwm-functions")
;*******************************

;-------------------------------------------------------------------------
(de modifier-string.make (theModifiers)
 (with (theRes ""
	i 0 l (length theModifiers)
       )
  (while (< i l)
   (with (modifier (# i theModifiers))
   (: theRes (+ theRes
    (if (= modifier 'any) ""
        (= modifier 'alone) ""
        (= modifier 'with-alt) "Alt+"
        (= modifier 'with-shift) "Shift+"
        (= modifier 'with-control) "Ctrl+"
        (= modifier 'with-lock) "Lock+"
        (= modifier 'with-modifier-1) "Mod1+"
        (= modifier 'with-modifier-2) "Mod2+"
        (= modifier 'with-modifier-3) "Mod3+"
        (= modifier 'with-modifier-4) "Mod4+"
        (= modifier 'with-modifier-5) "Mod5+"
        (= modifier 'with-button-1) "But1+"
        (= modifier 'with-button-2) "But2+"
        (= modifier 'with-button-3) "But3+"
        (= modifier 'with-button-4) "But4+"
        (= modifier 'with-button-5) "But5+"
        ""
    )
   ))
   )
   (: i (+ i 1))
  )
 theRes
 )
)



;============================================================================
; MWM-MENU.MAKE
;============================================================================
(df mwm-menu.make args
 (with 
  (state pop-state
   mnemonic-list ()
   accelerator-list ()
   wgrabs window-grabs
   wbeh ()
   args-for-menu.make ()
   max-width-label 0
   max-width-acc 0
  )
 (with (font menuFontList)
 (for item args
  (with (label (# 0 item)
	 acc   (# 2 item))
   (if (eq 0 (member "@" label))
 	(with ( pixmapFile (match "@\\(.*\\)" label 1))
  	(: label (pixmap-make menuBackground pixmapFile menuForeground))
 	)
   )
	(if label
	(if (> (width label) max-width-label) 
		(: max-width-label (width label))))
	))
 )
 (for item args
  (with (
	 label 		  (# 0 item)
	 mnemo 		  (# 1 item)
	 acc   		  (# 2 item)
	 key  		  (# 0 acc)
	 modifier 	  (# 1 acc)
	 fctn  		  (# 3 item)
	 fctn.name 	  (# 0 fctn)
	 fctn.name.string (match "[.]\\(.*\\)" fctn.name 1)
	 transition 	  ()
	 acc-string
		 	  (+ 
			   (if (= 'atom (type modifier))
			      	(modifier-string.make (list modifier))
				(modifier-string.make (sublist 1 (length modifier)
						      modifier) )
			   )
		           key)
	)
   (if (= fctn.name 'f.separator)
	(: args-for-menu.make (+ args-for-menu.make '(item-separator)))
       (= fctn.name 'f.title)
	(: args-for-menu.make (+ args-for-menu.make '(item-separator item-separator)
			      (list (list 'pop-label-make label))
			      '(item-separator item-separator) ))
	; else
	(progn
	 (: args-for-menu.make
	  (+ args-for-menu.make
	   (list (list
	    'item-make
		label
		mnemo
		fctn (eval (atom (+ "e." fctn.name.string))) 
		(if acc (mk-blank-plug 
			(with (font menuFontList)
			 (- max-width-label (width label)))))
		(if acc 
		(with (borderwidth 0
		       fsm ()
		       font menuFontList
		       foreground menuForeground
		       background menuBackground
		      )
		(plug-make (active-label-make acc-string)))
		)
	   ))
	  )
	 )
	 (if (= fctn.name 'f.menu)
	   (progn
	   (: wgrabs (+ wgrabs 
 		(with (wob (menu-wob (eval (# 1 fctn)))) (# 'wgrabs wob))))
	   (: wbeh (state-make wbeh 
                (with (wob (menu-wob (eval (# 1 fctn)))) (# 'wfsm wob))))
	   )
	 )
	 (if acc
	  (progn
	  (: transition
		(list 'on (list 'keypress (key-make key) modifier)
		  (list 'if (eval (atom (+ "e." fctn.name.string))) 
			(list 'with '(action-by-menu t) fctn))
	  	)
	  )
	  (: wgrabs (+ wgrabs (list (eval (list 'keypress (key-make key) modifier)))))
	  (: wbeh   (eval (list 'state-make transition 'wbeh)))
	  (## (atom (+ "key" (itoa (key-make 
		 (if (# (atom key) to-lower-case-list)
		 (# (atom key) to-lower-case-list) key
		 )
	      )) "m" (itoa (eval modifier))) )
	   'accelerator-list 
		 (list (eval (atom (+ "e." fctn.name.string))) fctn) )
	  )
	 )
	 (if mnemo
	     (with (key mnemo modifier with-alt)
	       (## (atom (+ "key" (itoa (key-make (setq key
		   (if (# (atom mnemo) to-lower-case-list)
		      (# (atom mnemo) to-lower-case-list) mnemo)))))) 
		   'mnemonic-list 
		   (list (eval (atom (+ "e." fctn.name.string))) fctn) )
	       (: transition
		  (list 'on (list 'keypress (key-make key) modifier)
			(list 'if (eval (atom (+ "e." fctn.name.string))) 
			      (list 'with '(action-by-menu t) fctn))
			)
		  )
	       (: wgrabs
		  (+ wgrabs (list (eval
				   (list 'keypress (key-make key) modifier)))))
	       (: wbeh   (eval (list 'state-make transition 'wbeh)))
	       (## (atom (+ "key" (itoa
				   (key-make 
				    (if (# (atom key) to-lower-case-list)
					(# (atom key) to-lower-case-list) key)
					 )) "m" (itoa (eval modifier))) )
		   'accelerator-list 
		 (list (eval (atom (+ "e." fctn.name.string))) fctn) )
	       ))
	)
   )
  )
 )
 (with (
	fsm (fsm-make state)
	property '(father () valid-items () menu-son () item-menu-son () active ()
		   current-valid-item 0 wgrabs () wfsm () )
	property (+ (list 'mnemonic-list mnemonic-list
			  'accelerator-list accelerator-list) property)
	myMenu (eval (+ '(menu.make) args-for-menu.make))
	wob (menu-wob myMenu)
       )
  (## 'wfsm wob wbeh)
  (## 'wgrabs wob wgrabs)
  myMenu
 )
))




;------------------------------------------------------------Fin----------