136 lines
4.0 KiB
Plaintext
136 lines
4.0 KiB
Plaintext
; Twm-Style Popup Menus (hacked up from std-popups.gwm)
|
|
; =====================================================
|
|
|
|
; This file is derived from the std-popups.gwm distributed with gwm 1.4.1.30
|
|
; The original file was written by Colas Nahaboo, BULL Research, France.
|
|
;
|
|
; Modifications [Dec 1989] for twm emulation by Arup Mukherjee
|
|
; (arup@grip.cis.upenn.edu)
|
|
;
|
|
; Within the restrictions of the GWM copyright, you may do whatever you
|
|
; want with this code. It would be nice, however, if my name were to remain
|
|
; in it somewhere.
|
|
|
|
; Pop-ups
|
|
; =======
|
|
|
|
(if (not (boundp 'twm-pop-item-font))
|
|
(defname 'twm-pop-item-font screen. (font-make "8x13")))
|
|
|
|
(if (not (boundp 'twm-pop-label-font))
|
|
(defname 'twm-pop-label-font screen. (font-make "8x13")))
|
|
|
|
(if (not (boundp 'twm-pop-item-height))
|
|
(defname 'twm-pop-item-height screen. 10))
|
|
|
|
(setq twm-popups.fsm (fsm-make
|
|
(: closed
|
|
(state-make
|
|
(on enter-window
|
|
(wob-borderpixel twm-menu-hilite-color)
|
|
opened)))
|
|
(: opened
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(with (calling-wob (with (wob wob-parent)
|
|
wob-parent))
|
|
(wob-borderpixel twm-menu-background)
|
|
(setq twm-popups.action
|
|
(# 'action wob-property))
|
|
(wob wob-parent)
|
|
(unpop-menu
|
|
(# 'shadow wob-property))
|
|
(unpop-menu wob)
|
|
(wob calling-wob)
|
|
(eval twm-popups.action)
|
|
)
|
|
closed)
|
|
(on enter-window
|
|
(wob-borderpixel twm-menu-hilite-color))
|
|
(on leave-window
|
|
(wob-borderpixel twm-menu-background))))))
|
|
|
|
(df twm-item-make (label action)
|
|
(list
|
|
(with (borderwidth twm-borderwidth
|
|
borderpixel twm-menu-background
|
|
background twm-menu-background
|
|
foreground twm-menu-foreground
|
|
fsm twm-popups.fsm
|
|
bar-min-width twm-pop-item-height
|
|
property (+ (list 'action action) property))
|
|
(bar-make
|
|
()
|
|
(with (borderwidth 0 fsm () font twm-pop-item-font)
|
|
(plug-make (label-make label)
|
|
))()))
|
|
(with (borderwidth twm-borderwidth
|
|
borderpixel twm-menu-shadow-color
|
|
foreground twm-menu-shadow-color
|
|
background twm-menu-shadow-color
|
|
fsm ()
|
|
bar-min-width twm-pop-item-height
|
|
property ())
|
|
(bar-make
|
|
()
|
|
(with (borderwidth 0 fsm () font twm-pop-item-font)
|
|
(plug-make (label-make label)
|
|
))()))))
|
|
|
|
|
|
(df twm-pop-label-make (label)
|
|
(list
|
|
(with (borderwidth twm-borderwidth
|
|
borderpixel twm-menu-border-color fsm ()
|
|
background twm-menu-background
|
|
foreground twm-menu-foreground)
|
|
(bar-make
|
|
(with (borderwidth 0 font twm-pop-label-font)
|
|
(plug-make (label-make label)))))
|
|
(with (borderwidth twm-borderwidth
|
|
borderpixel twm-menu-shadow-color fsm ()
|
|
background twm-menu-shadow-color
|
|
foreground twm-menu-shadow-color)
|
|
(bar-make
|
|
(with (borderwidth 0 font twm-pop-label-font)
|
|
(plug-make (label-make label)))))))
|
|
|
|
(: twm-pop-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonrelease any any)
|
|
(progn (unpop-menu (# 'shadow wob-property))
|
|
(unpop-menu))))))
|
|
|
|
(df twm-menu-make twm-menu-args
|
|
(with (bar-list (list menu-make) back-list (list menu-make)
|
|
fsm () bar-separator 0)
|
|
(for item twm-menu-args
|
|
(: twm-item (eval item))
|
|
(setq bar-list (+ bar-list (list (# 0 twm-item))))
|
|
(setq back-list (+ back-list (list (# 1 twm-item)))))
|
|
(with (shadow (eval back-list) fsm twm-pop-fsm
|
|
borderpixel twm-menu-border-color)
|
|
(with (property (+ (list 'shadow shadow) property))
|
|
(eval bar-list)))))
|
|
|
|
(df twm-pop-menu args
|
|
(if (= (length args) 0)
|
|
(: twm-menu (wob-menu))
|
|
(: twm-menu (eval (# 0 args))))
|
|
(if (= (length args) 2)
|
|
(: pos (eval (# 1 args)))
|
|
(: pos 0))
|
|
(with (wob (menu-wob twm-menu))
|
|
(: shadow (# 'shadow wob-property)))
|
|
(if (not shadow)
|
|
(print "twm menu has no shadow!\n"))
|
|
(with (x (current-event-x) y (current-event-y))
|
|
(warp-pointer (+ x 10) (+ y 10) root-window)
|
|
(pop-menu shadow 0)
|
|
(warp-pointer x y root-window)
|
|
(ungrab-server (menu-wob shadow))
|
|
(pop-menu twm-menu pos)))
|
|
|
|
|