;; 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)))))