;; fvwm-menu.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 mainly just a copy of vtwm-menu.gwm, with slight adjustment
;; of the menu look. Note that the menu constructors defined at the end
;; collides with the same functions in vtwm-menu.gwm, so only one of
;; the files should be loaded.
;;
;; This file defines how the pop-up menus behave and look. It also
;; defines a set of convenient menu constructors. To customize your
;; menus, don't change this file. Instead set the variables and call
;; the constructors from fvwmrc.gwm .
;;
;; To define a menu, you can use the following constructors:
;; 
;;   (construct-menu ENTRY ...)
;;     where ENTRY can be a string denoting a menu label, a list
;;     with a string and an action denoting a menu item, or the
;;     output from the functions 'construct-machine-menu-items' or
;;     'construct-window-menu-items' below.
;;     
;;   (construct-window-menu NAME ACTION)
;;     This constructs a menu with all current windows (except GWM
;;     menu windows), which when invoked runs the ACTION on the
;;     selected window.
;;
;;   (construct-machine-menu NAME MACHINE-LIST ACTION)
;;     Constructs a menu with entries for each of the machines in 
;;     MACHINE-LIST plus the local host, which when invoked runs
;;     the ACTION with 'host' bound to the corresponding element
;;     from MACHINE-LIST and 'name' bound to the capitalized first
;;     part of the host name.
;;
;;   (construct-xrsh-menu MACHINE-LIST COMMAND)
;;     Constructs a menu with entries for each of the machines in 
;;     MACHINE-LIST plus the local host, which when invoked runs
;;     "xrsh" on the selected host and COMMAND. COMMAND can be a
;;     list of command tokens, or the command tokens can all be
;;     inserted directly at COMMAND. The first command token will
;;     be used as the name of the menu.
;;
;;   (construct-window-menu-items WINDOW-TYPE ACTION)
;;     Returns a list of menu items to be used by 'construct-menu'.
;;     There is one item for each window matching WINDOW-TYPE, which
;;     can be an atom denoting a client class, a string denoting a
;;     window name regexp, or an arbitrary wool expression.
;;
;;   (construct-machine-menu-items MACHINE-LIST ACTION)
;;     Returns a list of menu items to be used by 'construct-menu'.
;;     There is one item for each machine in MACHINE-LIST, and the
;;     ACTION will be run with 'host' and 'name' bound as for
;;     'construct-machine-menu' above.
;;
;; To pop a menu, use 'fvwm-pop-menu'.
;; 


(declare-screen-dependent
  fvwm-menu-color
  fvwm-menu-text-color
  fvwm-menu-font
  fvwm-menu-label-font
  fvwm-menu-item-height
  fvwm-menu-min-width
)

;;
;;    USER CUSTOMIZABLE VARIABLES
;;    ---------------------------  
;;    Adjust these in your own profile
;;
(for screen (list-of-screens)
     (defaults-to
       fvwm-menu-color "gray"          ; Foreground of menus  
       fvwm-menu-text-color "black"    ; Background of menus  
       fvwm-menu-font "8x13"           ; Menu item font
       fvwm-menu-label-font ()         ; Menu label font (defaults to above)
       fvwm-menu-item-height 22        ; Height of a menu item
       fvwm-menu-min-width 100         ; Minimum width of menu
       )
)

;;=============================================================

(require 'fvwm-window)

(defun fvwm-menu-father ()
  (with (wob wob)
    (while (and wob-parent
                (not (member (with (wob wob-parent) wob-status) '(menu root))))
      (setq wob wob-parent))
    (if (= (with (wob wob-parent) wob-status) 'menu)
        wob-parent
      ())))

(defun fvwm-menu-father-item ()
  (with (wob wob)
    (while (and wob-parent
                (not (member (with (wob wob-parent) wob-status) '(menu root))))
      (setq wob wob-parent))
    (if (= (with (wob wob-parent) wob-status) 'menu)
        wob
      ())))

(defun fvwm-menu-root ()
  (with (wob wob mf ())
    (while (setq mf (fvwm-menu-father))
      (setq wob mf))
    wob))

(defun fvwm-pop-cascade ()
  (if (# 'menu-expr wob)
      (setq wob-menu (eval (# 'menu-expr wob))))
  (with (cascademenu (menu-wob wob-menu)
	 cascaderoot (fvwm-menu-root)
         wm wob-menu)
    (ungrab-server)
    (grab-server cascaderoot)
    (with (wob (fvwm-menu-father))
      (## 'cascademenu wob cascademenu)) 
    (## 'poped cascademenu t)
    (with (wob (fvwm-menu-father-item))
      (fvwm-pop-menu wm (+ wob-x (width wob)) wob-y))
    (ungrab-server)
    (grab-server cascaderoot)))

(defun fvwm-unpop-cascade ()
  (if (# 'cascademenu wob)
      (with (wob (# 'cascademenu wob))
        (fvwm-unpop-cascade)
	(with (wob (fvwm-menu-father-item))
          (send-user-event 'inactive wob))
	(## 'poped wob nil)
        (fvwm-unpop-menu)))
  (## 'cascademenu wob nil))

(defun fvwm-unpop-old-cascade ()
  (with (thiswob (if wob-menu (menu-wob wob-menu))
         wob (fvwm-menu-father))
    (if (not (= (# 'cascademenu wob) thiswob))
        (fvwm-unpop-cascade))))

(defun fvwm-unpop-all-cascade ()
  (with (wob (fvwm-menu-root))
    (fvwm-unpop-cascade)
    (## 'poped wob nil)
    (fvwm-unpop-menu)))

(defun fvwm-unpop-menu ()
  (unpop-menu wob))
  

(setq fvwm-menu-item-fsm
      (fsm-make
       (state-make
        (on (buttonrelease any any)
            (with (calling-wob (with (wob (fvwm-menu-root)) wob-parent)
                   action (# 'action wob-property))
              (send-user-event 'inactive wob)
              (wob wob-parent)
              (fvwm-unpop-all-cascade)
              (if (and autocolormap
                       (not (eq root-window calling-wob)))
                  (set-colormap-focus (with (wob calling-wob) window)))
              (wob calling-wob)
              (eval action)
              ))
        (on enter-window 
            (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 (or (# 'menu-expr wob-property)
                         wob-menu))
                (send-user-event 'inactive wob)))
        (on (user-event 'active)
            (wob-tile (# 'atile wob)))
        (on (user-event 'inactive)
            (wob-tile (# 'tile wob))))))

(setq fvwm-menu-item-inner-fsm
      (fsm-make
       (state-make
        (on (user-event 'active)
            (wob-tile (# 'atile wob)))
        (on (user-event 'inactive)
            (wob-tile (# 'tile wob))))))

(setq fvwm-menu-label-fsm
      (fsm-make
       (state-make
        (on enter-window 
            (progn
              (fvwm-unpop-old-cascade)
              )))))

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

(defun fvwm-menu-topbar ()
  (with (tile ()
         background (# 0 color-scheme)
         foreground background
         bar-max-width 2
         bar-min-width bar-max-width
         pix (pixmap-make 2 2)
         foreground (# 2 color-scheme))
    (draw-line pix 1 1 1 1)
    (bar-make () (plug-make pix))))

(defun fvwm-menu-bottombar ()
  (with (tile ()
         background (# 2 color-scheme)
         foreground (# 0 color-scheme)
         bar-max-width 2
         bar-min-width bar-max-width
         pix (pixmap-make 2 2)
         foreground background)
    (draw-line pix 1 1 1 1)
    (with (background (# 2 color-scheme))
      (bar-make (plug-make pix) ()))))

(defun fvwm-menu-labeltile (size)
  (with (tile ()
         pix (with (foreground background) (pixmap-make 1 size)))
    (draw-line pix 0 (- size 3) 0 (- size 3))
    (draw-line pix 0 (- size 1) 0 (- size 1))
    pix))

(defun fvwm-menu-itemtile (size active)
  (with (fsm fvwm-menu-item-inner-fsm
         background (# 1 color-scheme)
         tile ()
         foreground background
         pix (pixmap-make 1 size))
    (if active
        (progn
          (with (foreground (# 0 color-scheme))
            (draw-line pix 0 0 0 1))
          (with (foreground (# 2 color-scheme))
            (draw-line pix 0 (- size 2) 0 (- size 1)))))
    pix))

(defun fvwm-menu-vplug (size side)
  (with (fsm fvwm-menu-item-inner-fsm
         tile ()
         foreground (# 1 color-scheme)
         pix (pixmap-make 1 size)
         foreground (# (if (= side 'left) 0 2) color-scheme)
         apix (pixmap-make 1 size))
    (if (= side 'left)
        (with (foreground (# 2 color-scheme))
          (draw-line apix 0 (- size 1) 0 (- size 1)))
      (with (foreground (# 0 color-scheme))
        (draw-line apix 0 0 0 0)))
    (with (property (list 'tile pix 'atile apix))
      (plug-make pix))))

(defun fvwm-menu-subarrow (size)
  (with (fsm fvwm-menu-item-inner-fsm
         tile ()
         foreground (# 1 color-scheme)
         size (- size 4)
         pix (pixmap-make size size)
         apix (pixmap-make size size)
         x1 (/ size 3)
         x2 (- size x1 (% size 2) -1)
         h (/ size 2))
    (with (foreground (# 0 color-scheme))
      (draw-line pix x1 x1 x1 x2)
      (draw-line pix x1 x1 x2 h)
      (draw-line apix x1 x2 x2 h))
    (with (foreground (# 2 color-scheme))
      (draw-line apix x1 x1 x1 x2)
      (draw-line apix x1 x1 x2 h)
      (draw-line pix x1 x2 x2 h))
    (with (property (list 'tile pix 'atile apix))
      (plug-make pix))))

(defun fvwm-menu-separator-make ()
  (with (fsm ()
         tile ()
         borderwidth 0
         color-scheme (make-color-scheme fvwm-menu-color fvwm-menu-text-color)
         background (# 2 color-scheme)
         foreground (# 0 color-scheme)
         bar-max-width 2
         bar-min-width bar-max-width
         left (pixmap-make 1 2)
         right (pixmap-make 1 2)
         tile (pixmap-make 1 2)
         foreground background
         )
    (draw-line tile 0 0 0 0)
    (draw-line right 0 0 0 1)
    (bar-make (plug-make left) () (plug-make right))))

(defun fvwm-menu-item-make (label action)
  (with (borderwidth 0
         color-scheme (make-color-scheme fvwm-menu-color fvwm-menu-text-color)
         font (if (= (type fvwm-menu-font) 'string)
                  (font-make fvwm-menu-font)
                fvwm-menu-font)
         background (# 1 color-scheme)
         foreground (# 3 color-scheme)
         fsm fvwm-menu-item-fsm
         menu (if (= (type action) 'menu) action)
         menu-expr (if (member (type action) '(expr subr fexpr fsubr))
                       (list action))
         bar-min-width fvwm-menu-item-height
         bar-max-width bar-min-width
         plug-separator 0
         ntile (label-make label)
         left0 (with (fsm ()
                      bar-max-width 2
                      bar-min-width bar-max-width
                      background (# 0 color-scheme))
                (bar-make ))
         right0 (with (fsm ()
                       bar-max-width 2
                       bar-min-width bar-max-width
                       background (# 2 color-scheme))
                 (bar-make ))
         left (fvwm-menu-vplug fvwm-menu-item-height 'left)
         right (fvwm-menu-vplug fvwm-menu-item-height 'right)
         atile (fvwm-menu-itemtile fvwm-menu-item-height t)
         tile (fvwm-menu-itemtile fvwm-menu-item-height ())
         arrow (if (or menu menu-expr) 
                   (fvwm-menu-subarrow fvwm-menu-item-height))
         property (+ (if (not (or menu menu-expr))
                         (list 'action action))
                     (if menu-expr
                         (list 'menu-expr menu-expr))
                     (list 'tile tile 'atile atile)))
    (bar-make
     left0
     left
     (with (borderwidth 0
            fsm ()
            property ())
       (plug-make ntile))
     ()
     arrow
     right
     right0)))
     
(defun fvwm-menu-label-make (label)
  (with (borderwidth 0
         color-scheme (make-color-scheme fvwm-menu-color fvwm-menu-text-color)
         background (# 1 color-scheme)
         foreground (# 3 color-scheme)
         bar-min-width fvwm-menu-item-height
         bar-max-width bar-min-width
         plug-separator 0
         fsm fvwm-menu-label-fsm
         left (with (fsm ()
                     bar-max-width 2
                     bar-min-width bar-max-width
                     background (# 0 color-scheme))
                (bar-make ))
         right (with (fsm ()
                      bar-max-width 2
                      bar-min-width bar-max-width
                      background (# 2 color-scheme))
                 (bar-make ))
         tile (fvwm-menu-labeltile fvwm-menu-item-height)
         menu ())
    (bar-make
     left
     ()
     (with (borderwidth 0
            fsm ()
            font (if (= (type fvwm-menu-label-font) 'string)
                     (font-make fvwm-menu-label-font)
                   fvwm-menu-label-font
                     fvwm-menu-label-font
                   (= (type fvwm-menu-font) 'string)
                     (font-make fvwm-menu-font)
                     fvwm-menu-font))
       (plug-make (label-make label)))
     ()
     right)))

(defun fvwm-menu-make args
  (if args
      (with (menu ()
             fsm fvwm-menu-fsm
             menu-min-width fvwm-menu-min-width
             borderwidth 0
             bar-separator 0
             direction vertical
             property ()
             color-scheme (make-color-scheme fvwm-menu-color
                                             fvwm-menu-text-color)
             top (fvwm-menu-topbar)
             bottom (fvwm-menu-bottombar)
             res ())
        (apply 'menu-make (+ (list top) args (list bottom))))))

(defunq fvwm-pop-menu args
  (with (pmenu (if (= (length args) 0)
                   (wob-menu)
                 (eval (# 0 args)))
         pos (if (= (length args) 3)
                 (list (eval (# 1 args)) (eval (# 2 args)))
               ())
         calling-wob wob
         wob (menu-wob pmenu)
         bw wob-borderwidth
         wdt wob-width
         hgt wob-height
         wob calling-wob
         xm (current-event-x)
         ym (current-event-y)
         xpos (if pos (# 0 pos) (- xm (/ wdt 2) bw))
         ypos (if pos (# 1 pos) (- ym (/ fvwm-menu-item-height 2) bw)))
    (if (< xpos 0)
        (setq xpos 0)
      (> (+ xpos wdt) screen-width)
      (setq xpos (- screen-width wdt)))
    (if (< ypos 0)
        (setq ypos 0)
      (> (+ ypos hgt) screen-height)
      (setq ypos (max 0 (- screen-height hgt))))
    (move-window (menu-wob pmenu) xpos ypos)
    (if (and autocolormap
             (not (eq root-window calling-wob)))
        (set-colormap-focus ()))
    (pop-menu pmenu 'here)
))
      

;;
;; Some useful routines
;;

(defun append-sublists (lists)
  (eval (+ '(+) (mapfor lst lists (list 'quote lst)))))

(defun remove-nil (lst)
  (with (ele ())
    (while (setq ele (member () lst))
      (delete-nth ele lst))
    lst))

(defun upchar (char)
  (or (# (atom char) '(a "A" b "B" c "C" d "D" e "E" f "F" g "G"
                       h "H" i "I" j "J" k "K" l "L" m "M" n "N"
                       o "O" p "P" q "Q" r "R" s "S" t "T" u "U"
                       v "V" w "W" x "X" y "Y" z "Z"))
      char))

(defun capitalize (str)
  (if (= (length str) 0)
      " "
    (with (pair (match "^\\(.\\)\\(.*\\)" str 1 2))
      (+ (upchar (# 0 pair)) (# 1 pair)))))

(defun is-menu-item (obj)
  (= (type obj) 'bar))

(defun is-sub-menu (obj)
  (and (= (type obj) 'list)
       ()))

;;
;; Remote machine command menus
;;

(defun machine-name (host)
  (capitalize (match "^\\([^.]*\\)" host 1)))

(setq xrsh-program "xrsh")

(defun xrsh-command (host command)
  (if (equal host ".")
      (with (host hostname)
        (eval (+ '(!) command)))
    (eval (+ (list '! xrsh-program host) command))))

(defun do-command (command)
  (eval (+ '(!) command)))

(defun construct-machine-menu (name machine-list expr)
  (apply 'fvwm-menu-make
         (+ (list (fvwm-menu-label-make name))
            (with (name (machine-name hostname))
              (list (fvwm-menu-item-make name 
                                         (` (with (host "." name (, name))
                                                  (, expr))))))
            (mapfor host machine-list
              (with (name (machine-name host))
                (fvwm-menu-item-make name 
                                     (` (with (host (, host) name (, name))
                                              (, expr)))))))))

(defun construct-xrsh-menu args
  (with (machine-list (# 0 args)
         command (if (= (type (# 1 args)) 'list)
                     (# 1 args)
                   (sublist 1 (length args) args)))
    (construct-machine-menu (capitalize (# 0 command))
                            machine-list
                            (` (xrsh-command host (quote (, command)))))))

(defun construct-machine-menu-items (machine-list expr)
  (mapfor host machine-list
    (with (name (machine-name host))
      (fvwm-menu-item-make name 
                           (` (with (host (, host) name (, name))
                                    (, expr)))))))

(defun construct-window-menu (name expr)
  (apply 'fvwm-menu-make
         (+ (list (fvwm-menu-label-make name))
            (remove-nil
             (mapfor wob (list-of-windows 'window) 
               (if (not (= window-client-class 'Gwm))
                   (fvwm-menu-item-make window-name
                                        (` (if (wob-is-valid (, wob))
                                               (with (wob (, wob))
                                                 (, expr)))))))))))

(defun construct-window-menu-items (wlst expr)
  (remove-nil
   (mapfor wob (list-of-windows 'window) 
     (if (matches-token wlst)
         (fvwm-menu-item-make window-name
                              (` (if (wob-is-valid (, wob))
                                     (with (wob (, wob))
                                           (, expr)))))))))

(defun construct-menu item-lists
  (apply 'fvwm-menu-make
         (apply '+
                (mapfor items item-lists
                  (if (= (type items) 'string)
                      (list (fvwm-menu-label-make items))
                    (is-menu-item items)
                      (list items)
                    (and (= (type items) 'list)
                         (is-menu-item (# 0 items)))
                      items
                    (and (= (type items) 'list)
                         (= (type (# 0 items)) 'string))
                      (if (and (= (type (# 1 items)) 'atom)
                             (boundp (# 1 items))
                             (= (type (eval (# 1 items))) 'list))
                          (list (fvwm-menu-item-make (# 0 items)
                                                     (apply construct-menu
                                                          (eval (# 1 items)))))
                        (and (= (type (# 1 items)) 'atom)
                             (boundp (# 1 items))
                             (member (type (eval (# 1 items)))
                                     '(expr subr fexpr fsubr)))
                          (list (fvwm-menu-item-make (# 0 items)
                                                     (eval (# 1 items))))
                        (and (= (type (# 1 items)) 'list)
                             (member (type (# 0 (# 1 items)))
                                     '(string list)))
                          (list (fvwm-menu-item-make (# 0 items)
                                                     (apply construct-menu
                                                            (# 1 items))))
                          (list (fvwm-menu-item-make (# 0 items)
                                                     (# 1 items))))
                      ())))))