318 lines
8.3 KiB
Plaintext
318 lines
8.3 KiB
Plaintext
; Various utilities used in mwm profile
|
|
; ==========================================
|
|
|
|
;;File: mwm-utils.gwm -- General-purpose WOOL utilities
|
|
;;Author: vincent@mirsa.inria.fr (Vincent BOUTHORS) -- Bull Research FRANCE
|
|
;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
|
|
;;Author: Frederic CHARTON
|
|
;;Author: Glen WHITNEY
|
|
;;Revision: 1.2 -- Feb 5,1991
|
|
;;State: Exp
|
|
;;GWM Version: 1.7d
|
|
|
|
(: focus-in-menu-name-placed ())
|
|
(: action-by-menu ())
|
|
(: double-click-required ())
|
|
(: while-opening ())
|
|
|
|
(load "utils.gwm")
|
|
|
|
; Teste si une propriete est presente dans une liste de proprietes
|
|
(de got-property (atome liste)
|
|
(with (place (member atome liste))
|
|
(if place (= 0 (% place 2)))
|
|
)
|
|
)
|
|
|
|
(de property-of-wob (my-wob)
|
|
(with (wob my-wob)
|
|
wob-property
|
|
)
|
|
)
|
|
|
|
|
|
|
|
(: to-lower-case-list '(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" ))
|
|
|
|
(df window-menu ()
|
|
(with (wob window)
|
|
wob-menu
|
|
)
|
|
)
|
|
|
|
|
|
(de mwm-iconify-window ()
|
|
(if lowerOnIconify (with (window window-icon) (lower-window)))
|
|
(if iconAutoPlace
|
|
(with (
|
|
theWindow window
|
|
wob (if window-group
|
|
(with (window (# 0 window-group)) window-icon)
|
|
window-icon)
|
|
X (# 'X wob-property)
|
|
Y (# 'Y wob-property)
|
|
theIcon (if (and X Y) (get-icon-from-array X Y) t)
|
|
icon-window-group (if (member theIcon (list-of-windows))
|
|
(with (window theIcon) window-group)
|
|
())
|
|
)
|
|
(if (= theIcon ())
|
|
(progn
|
|
(## 'X wob X)
|
|
(## 'Y wob Y)
|
|
(set-icon-of-array X Y wob)
|
|
(eval (+ '(move-window wob) (XY-to-xy X Y)))
|
|
(with (window theWindow)
|
|
(iconify-window)
|
|
)
|
|
)
|
|
(= theIcon wob)
|
|
(with (window theWindow)
|
|
(iconify-window)
|
|
)
|
|
|
|
(member theWindow icon-window-group)
|
|
(progn
|
|
(with (window theWindow)
|
|
(iconify-window)
|
|
)
|
|
)
|
|
|
|
(with (thePlace (auto-get-place)
|
|
X (# 0 thePlace)
|
|
Y (# 1 thePlace)
|
|
)
|
|
(## 'X wob X)
|
|
(## 'Y wob Y)
|
|
(eval (+ '(move-window wob) (XY-to-xy X Y)))
|
|
(set-icon-of-array X Y wob)
|
|
(with (window theWindow)
|
|
(iconify-window)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(progn (move-window window-icon (+ window-x window-client-x)
|
|
(+ window-y window-client-y))
|
|
(iconify-window)
|
|
)
|
|
)
|
|
)
|
|
|
|
(: mwmIconifyHack ())
|
|
(de mwm-de-iconify-window ()
|
|
(if (not mwmIconifyHack)
|
|
(with (X (# 'X window-property)
|
|
Y (# 'Y window-property)
|
|
)
|
|
(: mwmIconifyHack t)
|
|
(set-icon-of-array X Y ())
|
|
(iconify-window)
|
|
(raise-window)
|
|
(if (and (= 'explicit keyboardFocusPolicy) deiconifyKeyFocus)
|
|
(set-focus))
|
|
(process-events 'sync)
|
|
(: mwmIconifyHack ()) ; danger of re-entrance over.
|
|
(with (window window-icon)
|
|
(if (# 'got-focus window)
|
|
(progn
|
|
(## 'got-focus window ())
|
|
(send-user-event 'focus-out)
|
|
(if (# 'focus-in-menu-name-placed window)
|
|
(progn
|
|
(unpop-menu (# 'focus-in-menu-name window))
|
|
(ungrab-server)
|
|
(## 'focus-in-menu-name-placed window ())
|
|
)))))
|
|
)
|
|
))
|
|
|
|
(: delta moveThreshold)
|
|
(: delta2 (* delta delta))
|
|
|
|
(de deltabutton ()
|
|
(allow-event-processing) ; otherwise pointer state frozen
|
|
(if (and (> (current-event-code) 0) ; last event received
|
|
(< (current-event-modifier) 256)) ; is a buttonpress
|
|
(tag DELTABUTTON
|
|
(: e-m (# (current-event-code) '(0 1 2 4)))
|
|
(: e-x (current-event-x))
|
|
(: e-y (current-event-y))
|
|
(: m-p (current-mouse-position))
|
|
(while (= (/ (# 2 m-p) 256) e-m) ; the button is still pressed
|
|
(: dx (- (# 0 m-p) e-x))
|
|
(: dy (- (# 1 m-p) e-y))
|
|
(if (> (+ (* dx dx) (* dy dy)) delta2)
|
|
(exit DELTABUTTON (list dx dy)))
|
|
(: m-p (current-mouse-position)))
|
|
()))
|
|
)
|
|
|
|
|
|
(df move-icon ()
|
|
(move-window)
|
|
(if iconAutoPlace
|
|
(with (
|
|
target.x (+ window-x (/ window-width 2))
|
|
target.y (+ window-y (/ window-height 2))
|
|
theCoords (xy-to-XY target.x target.y)
|
|
X (# 0 theCoords)
|
|
Y (# 1 theCoords)
|
|
theIcon (get-icon-from-array X Y)
|
|
)
|
|
(if (or (= theIcon ()) (= theIcon window))
|
|
(progn
|
|
(eval (+ '(move-window) (XY-to-xy X Y)))
|
|
(set-icon-of-array (# 'X window) (# 'Y window) ())
|
|
(## 'X window X)
|
|
(## 'Y window Y)
|
|
(set-icon-of-array X Y window)
|
|
)
|
|
(with (theNeighbors (neighbors target.x target.y)
|
|
first (# 0 theNeighbors)
|
|
first.X (# 1 first)
|
|
first.Y (# 2 first)
|
|
second (# 1 theNeighbors)
|
|
second.X (# 1 second)
|
|
second.Y (# 2 second)
|
|
)
|
|
(if (not (# 0 first))
|
|
(progn
|
|
(eval (+ '(move-window) (XY-to-xy first.X first.Y)))
|
|
(set-icon-of-array (# 'X window) (# 'Y window) ())
|
|
(## 'X window first.X)
|
|
(## 'Y window first.Y)
|
|
(set-icon-of-array first.X first.Y window)
|
|
)
|
|
(not (# 0 second))
|
|
(progn
|
|
(eval (+ '(move-window) (XY-to-xy second.X second.Y)))
|
|
(set-icon-of-array (# 'X window) (# 'Y window) ())
|
|
(## 'X window second.X)
|
|
(## 'Y window second.Y)
|
|
(set-icon-of-array second.X second.Y window)
|
|
)
|
|
(progn
|
|
(eval (+ '(move-window)
|
|
(XY-to-xy (# 'X window) (# 'Y window) ))
|
|
)
|
|
(bell)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(: keyFocusList ())
|
|
|
|
(df maintain-focus-in ()
|
|
(if (not (# 'got-focus wob))
|
|
(progn
|
|
(## 'got-focus window t)
|
|
(send-user-event 'focus-in)
|
|
(set-colormap-focus)
|
|
(if (and autoKeyFocus (= keyboardFocusPolicy 'explicit)
|
|
(= window-status 'window))
|
|
(progn
|
|
(remove-kFL window)
|
|
(new-head-kFL window)))
|
|
|
|
(if (and (= 'icon wob-status) completeIconNameOnFocusIn )
|
|
(with (x (- wob-x
|
|
(/ (- (width
|
|
(menu-wob (# 'focus-in-menu-name window)))
|
|
wob-width) 2))
|
|
y (+ wob-y (- wob-height icon-bottom-bar-width) 4)
|
|
)
|
|
(## 'focus-in-menu-name-placed window t)
|
|
(## 'icon-father (menu-wob
|
|
(# 'focus-in-menu-name window)) window)
|
|
(if (< x 0)
|
|
(: x 0))
|
|
(if (> (+ x (width (menu-wob
|
|
(# 'focus-in-menu-name window))))
|
|
screen-width)
|
|
(: x (- screen-width
|
|
(width (menu-wob
|
|
(# 'focus-in-menu-name window))))))
|
|
(menu.move (# 'focus-in-menu-name window) x y)
|
|
(send-user-event 'focus-in (menu-wob
|
|
(# 'focus-in-menu-name window)))
|
|
(move-window (menu-wob (# 'focus-in-menu-name window))
|
|
x y)
|
|
(pop-menu (# 'focus-in-menu-name window) 'here)
|
|
(with (grab-keyboard-also t) (grab-server window))
|
|
))
|
|
(if (and (= keyboardFocusPolicy 'pointer)
|
|
(get-res-truth-value 'focusAutoRaise)
|
|
(not (= 'icon wob-status)))
|
|
(with (start-time (elapsed-time))
|
|
(while (< (- (elapsed-time) start-time) autoRaiseDelay)
|
|
(process-events)) ; wait for a bit
|
|
(if (# 'got-focus window) (f.raise))))
|
|
)))
|
|
|
|
(df maintain-focus-out ()
|
|
(if (# 'got-focus wob)
|
|
(progn
|
|
(## 'got-focus window ())
|
|
(send-user-event 'focus-out)
|
|
(if (# 'focus-in-menu-name-placed window)
|
|
(progn
|
|
(unpop-menu (# 'focus-in-menu-name window))
|
|
(ungrab-server)
|
|
(## 'focus-in-menu-name-placed window ())
|
|
)))))
|
|
|
|
(de head-kFL ()
|
|
(# 0 keyFocusList)
|
|
)
|
|
|
|
(de remove-kFL (w)
|
|
(with (index (member w keyFocusList)
|
|
)
|
|
(if index
|
|
(: keyFocusList (+ (sublist 0 index keyFocusList)
|
|
(sublist (+ index 1)
|
|
(length keyFocusList) keyFocusList)
|
|
)))))
|
|
|
|
|
|
(de new-head-kFL (w)
|
|
(: keyFocusList (+ (list w) keyFocusList))
|
|
)
|
|
|
|
(de obscured-by (w1 w2)
|
|
(with (window w1
|
|
w1l window-x
|
|
w1t window-y
|
|
w1r (+ window-width w1l)
|
|
w1b (+ window-height w1t)
|
|
window w2
|
|
w2l window-x
|
|
w2t window-y
|
|
w2r (+ window-width w2l)
|
|
w2b (+ window-height w2t))
|
|
(and (< w2l w1r)
|
|
(< w2t w1b)
|
|
(> w2b w1t)
|
|
(> w2r w1l))))
|
|
|
|
(de pop-up-win strings
|
|
(place-menu (# 0 strings)
|
|
(with (direction vertical
|
|
fsm (fsm-make (state-make (on (button any any) (delete-window))))
|
|
borderwidth 0)
|
|
(eval (+ '(menu-make)
|
|
(mapfor line (+ (sublist 1 (length strings) strings)
|
|
(list "" "Click a button to delete"))
|
|
(bar-make
|
|
() (plug-make (active-label-make line)) () )))))
|
|
(current-event-x)
|
|
(current-event-y)))
|