;; fvwm-multimenu.gwm --- Menu constructors for the FVWM profile
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1999  Anders Holst
;; Last change: 2/5 1999
;;
;; This file is copyrighted under the same terms as the rest of GWM
;; (see the X Inc license for details). There is no warranty that it
;; works. 
;;
;; --------------------------------------------------------------------- 
;;
;; This is just a copy of vtwm-multimenu.gwm with all "vtwm" replaced
;; by "fvwm".


(defun fvwm-multimenu-selp ()
  (# (# 'multinum wob-parent) (# 'multivec wob-parent)))

(defun fvwm-multimenu-donep ()
  (with (vec (# 'multivec wob-parent))
    (tag ret3 
      (for e vec
        (if (not e)
            (exit ret3 ())))
      t)))

(defun fvwm-multimenu-action ()
  (+ (list (# 'multifunc wob-parent))
     (mapfor e (# 'multivec wob-parent)
       (# 0 e))))

(defun fvwm-multimenu-unpop ()
  (with (topmenu (# 'multitop wob)
         i 0
         lst (# 'multilst topmenu))
    (for e lst
      (if e
          (with (wob (menu-wob e))
            (send-user-event 'inactive wob)
            (fvwm-unpop-cascade)
            (## 'poped wob nil)
            (fvwm-unpop-menu)))
      (## i lst ())
      (setq i (+ 1 i)))
    (unpop-menu topmenu)))

(defun fvwm-multimenu-store (arg)
  (## (# 'multinum wob-parent) (# 'multivec wob-parent)
      (list arg)))

(setq fvwm-multimenu-item-fsm
      (fsm-make
       (state-make
        (on (buttonrelease any any)
            (with (calling-wob (with (wob (fvwm-menu-root)) wob-parent)
                   action (# 'action wob-property))
              (fvwm-multimenu-store action)
              (send-user-event 'inactive (fvwm-menu-father))
              (if (fvwm-multimenu-donep)
                  (progn
                    (setq action (fvwm-multimenu-action))
                    (wob wob-parent)
                    (fvwm-multimenu-unpop)
                    (if (and autocolormap
                             (not (eq root-window calling-wob)))
                        (set-colormap-focus (with (wob calling-wob) window)))
                    (wob calling-wob)
                    (eval action))
                (progn
                  (fvwm-unpop-old-cascade)
                  (send-user-event 'active wob)
                  (if (if wob-menu 
                          (not (# 'poped (menu-wob wob-menu)))
                        (# 'menu-expr wob-property))
                      (fvwm-pop-cascade))))
              ))
        (on enter-window 
            (if (not (fvwm-multimenu-selp))
                (progn
                  (fvwm-unpop-old-cascade)
                  (send-user-event 'active wob)
                  (if (if wob-menu 
                          (not (# 'poped (menu-wob wob-menu)))
                        (# 'menu-expr wob-property))
                      (fvwm-pop-cascade))
                  )))
        (on leave-window 
            (if (not (fvwm-multimenu-selp))
                (send-user-event 'inactive (fvwm-menu-father))))
        (on (user-event 'active)
            (wob-tile (# 'atile wob)))
        (on (user-event 'inactive)
            (wob-tile (# 'tile wob))))))

(setq fvwm-multimenu-label-fsm
      (fsm-make
       (state-make
        (on (buttonrelease any any) 
            (with (calling-wob (with (wob (fvwm-menu-root)) wob-parent))
              (wob wob-parent)
              (fvwm-multimenu-unpop)
              (if (and autocolormap
                       (not (eq root-window calling-wob)))
                  (set-colormap-focus (with (wob calling-wob) window)))))
        (on enter-window 
            (if (not (fvwm-multimenu-selp))
              (fvwm-unpop-old-cascade)))
        )))

(setq fvwm-multimenu-fsm
   (fsm-make 
    (state-make
     (on (buttonrelease any any) 
         (with (calling-wob (with (wob (fvwm-menu-root)) wob-parent))
            (fvwm-multimenu-unpop)
            (if (and autocolormap
                     (not (eq root-window calling-wob)))
                (set-colormap-focus (with (wob calling-wob) window)))))
     )))

(setq fvwm-multimenu-topfsm
      (fsm-make
       (state-make
        (on map-notify
            (with (lst (# 'multilst wob))
              (if lst
                  (fvwm-multimenu-popall lst))))
     (on (buttonrelease any any) 
         (with (calling-wob (with (wob (fvwm-menu-root)) wob-parent))
            (fvwm-multimenu-unpop)
            (if (and autocolormap
                     (not (eq root-window calling-wob)))
                (set-colormap-focus (with (wob calling-wob) window)))))
        )))

(defun fvwm-multimenu-topmenu ()
  (with (fsm fvwm-multimenu-topfsm
         background black
         borderwidth 0
         inner-borderwidth 0
         describe-window '(lambda () (list (window-make () () () () ())
                                           (window-make () () () () ())))
         reenter-on-opening ())
     (with (menu-min-width 1
            menu-max-width 1
            bar-min-width 1
            bar-max-width 1)
       (menu-make (with (fsm ()) (bar-make ()))))))

(defun fvwm-multimenu-popall (lst)
  (with (topmenu wob
         i 0
         vec (list-make (length lst))
         func (# 'multifunc wob)
         wdt 0
         hgt 0
         xm (# 0 (# 'multipos topmenu))
         ym (# 1 (# 'multipos topmenu))
         wob (menu-wob (# 0 lst))
         xpos (- xm (/ wob-width 2) wob-borderwidth)
         ypos (- ym (/ fvwm-menu-item-height 2) wob-borderwidth))
    (for mn lst
      (with (wob (menu-wob mn))
        (setq wdt (+ wdt wob-width wob-borderwidth))
        (setq hgt (max hgt (+ wob-height wob-borderwidth)))))
    (if (< xpos 0)
        (setq xpos 0)
      (> (+ xpos wdt) screen-width)
      (setq xpos (max 0 (- screen-width wdt))))
    (if (< ypos 0)
        (setq ypos 0)
      (> (+ ypos hgt) screen-height)
      (setq ypos (max 0 (- screen-height hgt))))
    (wob topmenu)
    (ungrab-server)
    (grab-server topmenu)
    (for mn lst
      (with (wob (menu-wob mn))
        (move-window (menu-wob mn) xpos ypos)
        (## 'multitop wob topmenu)
        (## 'multinum wob i)
        (## 'multivec wob vec)
        (## 'multifunc wob func)
        (setq xpos (+ xpos wob-width wob-borderwidth))
        (setq i (+ 1 i)))
      (pop-menu mn 'here))
    (ungrab-server)
    (grab-server topmenu)))

(defun fvwm-pop-multimenu args
  (if (> (length args) 1)
      (with (menu (with (property (+ (list 'multilst (sublist 1 (length args) args)
                                           'multifunc (# 0 args)
                                           'multipos (list (current-event-x)
                                                           (current-event-y))
                                           'multitop ())
                                     property))
                    (fvwm-multimenu-topmenu)))
        (wob (menu-wob menu))
        (move-window wob 15 15)
        (## 'multitop wob wob)
        (pop-menu menu 'here))))

(defunq construct-multimenu args
  (if args
      (with (property (+ (list 'multinum () 'multivec () 'multifunc ())
                         property)
             fvwm-menu-item-fsm fvwm-multimenu-item-fsm
             fvwm-menu-label-fsm fvwm-multimenu-label-fsm
             fvwm-menu-fsm fvwm-multimenu-fsm)
        (eval (+ '(construct-menu) args)))))