229 lines
7.9 KiB
Plaintext
229 lines
7.9 KiB
Plaintext
;; vtwm-multimenu.gwm --- Menu constructors for the VTWM profile
|
|
;;
|
|
;; Author: Anders Holst (aho@sans.kth.se)
|
|
;; Copyright (C) 1997 Anders Holst
|
|
;; Version: vtwm-1.0
|
|
;; Last change: 15/11 1997
|
|
;;
|
|
;; 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.
|
|
;;
|
|
;; ---------------------------------------------------------------------
|
|
;;
|
|
|
|
|
|
(defun vtwm-multimenu-selp ()
|
|
(# (# 'multinum wob-parent) (# 'multivec wob-parent)))
|
|
|
|
(defun vtwm-multimenu-donep ()
|
|
(with (vec (# 'multivec wob-parent))
|
|
(tag ret3
|
|
(for e vec
|
|
(if (not e)
|
|
(exit ret3 ())))
|
|
t)))
|
|
|
|
(defun vtwm-multimenu-action ()
|
|
(+ (list (# 'multifunc wob-parent))
|
|
(mapfor e (# 'multivec wob-parent)
|
|
(# 0 e))))
|
|
|
|
(defun vtwm-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)
|
|
(vtwm-unpop-cascade)
|
|
(## 'poped wob nil)
|
|
(vtwm-unpop-menu)))
|
|
(## i lst ())
|
|
(setq i (+ 1 i)))
|
|
(unpop-menu topmenu)))
|
|
|
|
(defun vtwm-multimenu-store (arg)
|
|
(## (# 'multinum wob-parent) (# 'multivec wob-parent)
|
|
(list arg)))
|
|
|
|
(setq vtwm-multimenu-item-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (vtwm-menu-root)) wob-parent)
|
|
action (# 'action wob-property))
|
|
(vtwm-multimenu-store action)
|
|
(send-user-event 'inactive (vtwm-menu-father))
|
|
(if (vtwm-multimenu-donep)
|
|
(progn
|
|
(setq action (vtwm-multimenu-action))
|
|
(wob wob-parent)
|
|
(vtwm-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
|
|
(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 enter-window
|
|
(if (not (vtwm-multimenu-selp))
|
|
(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 (vtwm-multimenu-selp))
|
|
(send-user-event 'inactive (vtwm-menu-father))))
|
|
(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-multimenu-label-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (vtwm-menu-root)) wob-parent))
|
|
(wob wob-parent)
|
|
(vtwm-multimenu-unpop)
|
|
(if (and autocolormap
|
|
(not (eq root-window calling-wob)))
|
|
(set-colormap-focus (with (wob calling-wob) window)))))
|
|
(on enter-window
|
|
(if (not (vtwm-multimenu-selp))
|
|
(vtwm-unpop-old-cascade)))
|
|
)))
|
|
|
|
(setq vtwm-multimenu-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (vtwm-menu-root)) wob-parent))
|
|
(vtwm-multimenu-unpop)
|
|
(if (and autocolormap
|
|
(not (eq root-window calling-wob)))
|
|
(set-colormap-focus (with (wob calling-wob) window)))))
|
|
)))
|
|
|
|
(setq vtwm-multimenu-topfsm
|
|
(fsm-make
|
|
(state-make
|
|
(on map-notify
|
|
(with (lst (# 'multilst wob))
|
|
(if lst
|
|
(vtwm-multimenu-popall lst))))
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob (vtwm-menu-root)) wob-parent))
|
|
(vtwm-multimenu-unpop)
|
|
(if (and autocolormap
|
|
(not (eq root-window calling-wob)))
|
|
(set-colormap-focus (with (wob calling-wob) window)))))
|
|
)))
|
|
|
|
(defun vtwm-multimenu-topmenu ()
|
|
(with (fsm vtwm-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 vtwm-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 (/ vtwm-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)
|
|
shadow (# 'shadow wob-property))
|
|
(move-window (menu-wob mn) xpos ypos)
|
|
(## 'multitop wob topmenu)
|
|
(## 'multinum wob i)
|
|
(## 'multivec wob vec)
|
|
(## 'multifunc wob func)
|
|
(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))))
|
|
(setq xpos (+ xpos wob-width wob-borderwidth))
|
|
(setq i (+ 1 i)))
|
|
(pop-menu mn 'here))
|
|
(ungrab-server)
|
|
(grab-server topmenu)))
|
|
|
|
(defun vtwm-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))
|
|
(vtwm-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)
|
|
vtwm-menu-item-fsm vtwm-multimenu-item-fsm
|
|
vtwm-menu-label-fsm vtwm-multimenu-label-fsm
|
|
vtwm-menu-fsm vtwm-multimenu-fsm)
|
|
(eval (+ '(construct-menu) args)))))
|
|
|