;; vtwm-menu.gwm --- Menu constructors for the VTWM profile
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1995  Anders Holst
;; Version: vtwm-1.0
;; Last change: 17/6 1995
;;
;; 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 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 vtwmrc.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 'vtwm-pop-menu'.
;; 


(declare-screen-dependent
  vtwm-menu-foreground 
  vtwm-menu-background
  vtwm-menu-borderwidth
  vtwm-menu-border-color
  vtwm-menu-label-foreground
  vtwm-menu-label-background
  vtwm-menu-label-borderwidth
  vtwm-menu-hilite-bordercolor
  vtwm-menu-hilite-borderwidth
  vtwm-menu-hilite-foreground
  vtwm-menu-hilite-background
  vtwm-menu-shadow
  vtwm-menu-shadow-color
  vtwm-menu-shadow-offset
  vtwm-menu-font
  vtwm-menu-label-font
  vtwm-menu-item-height
  vtwm-menu-min-width
)

;;
;;    USER CUSTOMIZABLE VARIABLES
;;    ---------------------------  
;;    Adjust these in your own profile
;;
(for screen (list-of-screens)
     (defaults-to
       vtwm-menu-foreground black     ; Foreground of menus  
       vtwm-menu-background white     ; Background of menus  
       vtwm-menu-borderwidth 2        ; Border width of menus
       vtwm-menu-border-color black   ; Border color of menus
       vtwm-menu-label-foreground ()  ; Foreground of menu labels
       vtwm-menu-label-background ()  ; Background of menu labels
       vtwm-menu-label-borderwidth 1  ; Border width of menu labels
       vtwm-menu-hilite-bordercolor black ; Border color of current menu item
       vtwm-menu-hilite-borderwidth 1     ; Border width of current menu item
       vtwm-menu-hilite-foreground ()     ; Text color of current menu item
       vtwm-menu-hilite-background ()     ; Background color of current menu item
       vtwm-menu-shadow t             ; Whether the menu has a shadow
       vtwm-menu-shadow-color black   ; Color of shadow
       vtwm-menu-shadow-offset 6      ; Offset of shadow from menu
       vtwm-menu-font (font-make "8x13") ; Menu item font
       vtwm-menu-label-font ()           ; Menu label font (defaults to above)
       vtwm-menu-item-height 10       ; Minimum height of an item
       vtwm-menu-min-width 100        ; Minimum width of menu
       )
)


(defun vtwm-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 vtwm-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 vtwm-menu-root ()
  (with (wob wob mf ())
    (while (setq mf (vtwm-menu-father))
      (setq wob mf))
    wob))

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

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

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

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

(defun vtwm-unpop-menu ()
  (if vtwm-menu-shadow
      (unpop-menu (# 'shadow wob-property)))
  (unpop-menu wob))
  

(setq vtwm-menu-item-fsm
      (fsm-make
       (state-make
        (on (buttonrelease any any)
            (with (calling-wob (with (wob (vtwm-menu-root)) wob-parent)
                   action (# 'action wob-property))
              (send-user-event 'inactive wob)
              (wob wob-parent)
              (vtwm-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
              (vtwm-unpop-old-cascade)
              (send-user-event 'active wob)
              (if (if wob-menu 
                      (not (# 'poped (menu-wob wob-menu)))
                    (# 'menu-expr wob-property))
                  (vtwm-pop-cascade))
              ))
        (on leave-window 
            (if (not (or (# 'menu-expr wob-property)
                         wob-menu))
                (send-user-event 'inactive wob)))
        (on (user-event 'active)
            (progn
              (if (# 0 (# 'cols wob-property))
                  (wob-borderpixel (# 0 (# 'cols wob-property))))
              (if (# 1 (# 'cols wob-property))
                  (wob-background (# 1 (# 'cols wob-property))))))
        (on (user-event 'inactive)
            (progn
              (if (# 0 (# 'cols wob-property))
                  (wob-borderpixel (# 2 (# 'cols wob-property))))
              (if (# 1 (# 'cols wob-property))
                  (wob-background (# 2 (# 'cols wob-property)))))))))

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

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

(defun vtwm-menu-item-make (label action)
  (list 
     (with (borderwidth vtwm-menu-hilite-borderwidth
            borderpixel vtwm-menu-background
            background vtwm-menu-background
            foreground vtwm-menu-foreground
            font vtwm-menu-font
            fsm vtwm-menu-item-fsm
            menu (if (= (type action) 'menu) action)
            menu-expr (if (member (type action) '(expr subr fexpr fsubr))
                          (list action))
            bar-min-width vtwm-menu-item-height
            cdiff (or (and vtwm-menu-hilite-background
                           (not (= vtwm-menu-hilite-background
                                   vtwm-menu-background)))
                      (and vtwm-menu-hilite-foreground
                           (not (= vtwm-menu-hilite-foreground
                                   vtwm-menu-foreground))))
            bdiff (and (> vtwm-menu-hilite-borderwidth 0)
                       vtwm-menu-hilite-bordercolor
                       (not (= vtwm-menu-hilite-bordercolor
                               vtwm-menu-background)))
            ntile (label-make label)
            atile (with (background (or vtwm-menu-hilite-background
                                        vtwm-menu-background)
                         foreground (or vtwm-menu-hilite-foreground
                                        vtwm-menu-foreground))
                    (label-make label))
            cols (list (if bdiff (or vtwm-menu-hilite-bordercolor
                                     vtwm-menu-background))
                       (if cdiff (or vtwm-menu-hilite-background
                                     vtwm-menu-foreground))
                       (if (or cdiff bdiff) vtwm-menu-background))
            property (+ (if (not (or menu menu-expr))
                            (list 'action action))
                        (if menu-expr
                            (list 'menu-expr menu-expr))
                        (list 'cols cols)
                        property))
       (bar-make
        ()
        (with (borderwidth 0
               fsm vtwm-menu-item-inner-fsm
               property (if cdiff (list 'ntile ntile 'atile atile)))
          (plug-make ntile))
        ()))
     (if vtwm-menu-shadow
         (with (borderwidth vtwm-menu-hilite-borderwidth
                borderpixel vtwm-menu-shadow-color
                foreground vtwm-menu-shadow-color
                background vtwm-menu-shadow-color
                fsm ()
                bar-min-width vtwm-menu-item-height
                property ())
           (bar-make
            ()
            (with (borderwidth 0
                   fsm ()
                   font vtwm-menu-font)
              (plug-make (label-make label)))
            ())))))
     
(defun vtwm-menu-label-make (label)
  (list 
    (with (borderwidth (or vtwm-menu-label-borderwidth 0)
           background (or vtwm-menu-label-background vtwm-menu-background)
           foreground (or vtwm-menu-label-foreground vtwm-menu-foreground)
           borderpixel foreground
           fsm vtwm-menu-label-fsm
           menu ())
      (bar-make
       ()
       (with (borderwidth 0
              fsm ()
              font (or vtwm-menu-label-font vtwm-menu-font))
         (plug-make (label-make label)))
       ()))
    (if vtwm-menu-shadow
        (with (borderwidth (or vtwm-menu-label-borderwidth 0)
               borderpixel vtwm-menu-shadow-color
               background vtwm-menu-shadow-color
               foreground vtwm-menu-shadow-color
               fsm ())
           (bar-make
            ()
            (with (borderwidth 0
                   font (or vtwm-menu-label-font vtwm-menu-font))
              (plug-make (label-make label)))
            ())))))

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

(defun vtwm-menu-make args
  (if args
      (with (fsm ()
             menu ()
             bar-list (list menu-make)
             back-list (list menu-make) 
             menu-min-width vtwm-menu-min-width
             borderwidth vtwm-menu-borderwidth
             bar-separator 0
             direction vertical)
        (for item args
             (setq bar-list (+ bar-list (list (# 0 item))))
             (setq back-list (+ back-list (list (# 1 item)))))
        (with (shadow (if vtwm-menu-shadow
                          (with (borderpixel vtwm-menu-shadow-color)
                            (eval back-list)))
               fsm vtwm-menu-fsm
               borderpixel vtwm-menu-border-color
               property (+ (list 'shadow shadow
                                 'cascademenu ()
                                 'poped ())
                           property))
          (eval bar-list)))))

(defunq vtwm-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)
         shadow (# 'shadow wob-property)
         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 (/ vtwm-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))))
    (if (and vtwm-menu-shadow shadow)
        (progn
          (move-window (menu-wob shadow)
                       (+ xpos vtwm-menu-shadow-offset)
                       (+ ypos vtwm-menu-shadow-offset))
          (pop-menu shadow 'here)
          (ungrab-server (menu-wob shadow))))
    (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)
  (and (= (type obj) 'list)
       (= (length obj) 2)
       (= (type (# 0 obj)) 'bar)
       (or (not (# 1 obj)) 
           (= (type (# 1 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 'vtwm-menu-make
         (+ (list (vtwm-menu-label-make name))
            (with (name (machine-name hostname))
              (list (vtwm-menu-item-make name 
                                         (` (with (host "." name (, name))
                                                  (, expr))))))
            (mapfor host machine-list
              (with (name (machine-name host))
                (vtwm-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))
      (vtwm-menu-item-make name 
                           (` (with (host (, host) name (, name))
                                    (, expr)))))))

(defun construct-window-menu (name expr)
  (apply 'vtwm-menu-make
         (+ (list (vtwm-menu-label-make name))
            (remove-nil
             (mapfor wob (list-of-windows 'window) 
               (if (not (= window-client-class 'Gwm))
                   (vtwm-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)
         (vtwm-menu-item-make window-name
                              (` (if (wob-is-valid (, wob))
                                     (with (wob (, wob))
                                           (, expr)))))))))

(defun construct-menu item-lists
  (apply 'vtwm-menu-make
         (apply '+
                (mapfor items item-lists
                  (if (= (type items) 'string)
                      (list (vtwm-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 (vtwm-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 (vtwm-menu-item-make (# 0 items)
                                                     (eval (# 1 items))))
                        (and (= (type (# 1 items)) 'list)
                             (member (type (# 0 (# 1 items)))
                                     '(string list)))
                          (list (vtwm-menu-item-make (# 0 items)
                                                     (apply construct-menu
                                                            (# 1 items))))
                          (list (vtwm-menu-item-make (# 0 items)
                                                     (# 1 items))))
                      ())))))