477 lines
15 KiB
Plaintext
477 lines
15 KiB
Plaintext
; Various utilities used in standard profile
|
|
; ==========================================
|
|
|
|
;;File: 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
|
|
;;Revision: 1.0 -- Feb 7 1989
|
|
;;State: Exp
|
|
;;GWM Version: 1.4
|
|
|
|
;;=============================================================================
|
|
;; default
|
|
;;=============================================================================
|
|
; returns value of variable if set or evaluated provided value
|
|
|
|
(df default (variable value)
|
|
(if (boundp variable)
|
|
(eval variable)
|
|
(eval value)))
|
|
|
|
; defvar defines variable if unbound
|
|
|
|
(df defvar (defvar:variable defvar:value)
|
|
(if (boundp defvar:variable) ()
|
|
(set defvar:variable (eval defvar:value))
|
|
))
|
|
|
|
; defaults-to
|
|
; set variable if was unset
|
|
|
|
(df defaults-to args
|
|
(with (i 0 l (length args))
|
|
(if (= (% l 2) 1)
|
|
(trigger-error "defaults-to must have an even number of args"))
|
|
(while (< i l)
|
|
(if (not (boundp (# i args)))
|
|
(set (# i args) (eval (# (+ 1 i) args))))
|
|
(setq i (+ i 2))))))
|
|
|
|
; declare a list of variable as screen-dependent
|
|
|
|
(df declare-screen-dependent args
|
|
(for var args
|
|
(defname var screen.)))
|
|
|
|
;; (default-if-nil v1 a1 v2 a2...)
|
|
;; sets vN to aN value if vN is nil
|
|
|
|
(df default-if-nil args
|
|
(with (i 0)
|
|
(while (# i args)
|
|
(if (not (eval (# i args)))
|
|
(set (# i args) (eval (# (+ 1 i) args))))
|
|
(setq i (+ 2 i))
|
|
)))
|
|
|
|
;;=============================================================================
|
|
;; autoload
|
|
;;=============================================================================
|
|
; specifies that calling this function (with no args!) will load the file
|
|
; and execute the supposedly redefined function
|
|
|
|
(df autoload (function filename)
|
|
(set function
|
|
(lambda ()
|
|
(setq autoload.tmp (eval function)) ; to prevent bug
|
|
(load filename)
|
|
(eval (list function)))))
|
|
|
|
;;=============================================================================
|
|
;; print-window-info
|
|
;;=============================================================================
|
|
;; prints client info in a pop-up window at the center of the screen
|
|
|
|
(defaults-to
|
|
info.foreground black
|
|
info.background (color-make "moccasin")
|
|
info.borderwidth 1
|
|
)
|
|
|
|
|
|
|
|
(de print-window-info ()
|
|
(with (fsm-but (fsm-make (state-make ; kill by clicking in it
|
|
(on (button any alone) (delete-window))
|
|
window-behavior
|
|
standard-behavior
|
|
))
|
|
borderwidth info.borderwidth
|
|
background info.background
|
|
foreground info.foreground
|
|
fsm window-fsm
|
|
direction vertical
|
|
label-horizontal-margin 4 label-vertical-margin 2
|
|
menu-min-width 30 menu-max-width 1000
|
|
win
|
|
(place-menu
|
|
"Client Info"
|
|
(menu-make
|
|
(bar-make
|
|
(with (fsm fsm-but)
|
|
(plug-make
|
|
(label-make (setq print-window-info.string
|
|
(create-window-info)))))))
|
|
-1000 -1000 ; place it outside screen
|
|
))
|
|
(with (wob win) ; then center it when we know its size
|
|
(move-window
|
|
(- (- (/ screen-width 2) (/ window-width 2)) wob-borderwidth)
|
|
(- (- (/ screen-height 2) (/ window-height 2)) wob-borderwidth)
|
|
)))
|
|
;; output on stdout too
|
|
(print print-window-info.string "\n")
|
|
)
|
|
|
|
(defun create-window-info ()
|
|
(+ "Window: " (window-client-class) "."
|
|
(make-string-usable-for-resource-key
|
|
(window-client-name))
|
|
"."
|
|
(make-string-usable-for-resource-key (window-name))
|
|
"@" (window-machine-name) ": Geometry="
|
|
(itoa window-width) "x" (itoa window-height)
|
|
"+" (itoa window-x) "+" (itoa window-y)
|
|
))
|
|
|
|
;;=============================================================================
|
|
;; WM misc utils
|
|
;;=============================================================================
|
|
; ensure window is contained in screen
|
|
|
|
(df place-window-in-screen ()
|
|
(: x (window-x))
|
|
(: y (window-y))
|
|
(: xe (+ x (window-width)))
|
|
(: ye (+ y (window-height)))
|
|
(if (< x 0) (move-window 0 y))
|
|
(if (< y 0) (move-window x 0))
|
|
(if (> xe screen-width) (move-window (- screen-width
|
|
(window-width)) y))
|
|
(if (> ye screen-height) (move-window x (- screen-height
|
|
(window-height))))))
|
|
|
|
;;=============================================================================
|
|
;; wool misc utilities:
|
|
;;=============================================================================
|
|
|
|
;; min/max
|
|
|
|
(de min (n1 n2) (if (< n1 n2) n1 n2))
|
|
(de max (n1 n2) (if (> n1 n2) n1 n2))
|
|
|
|
; not equal: !=
|
|
|
|
(defun != (obj1 obj2)
|
|
(not (= obj1 obj2)))
|
|
|
|
;; insert elt in list at pos pos (creates new list)
|
|
;; used mainly for inserting items in menus
|
|
|
|
(defunq insert-at (elt listname pos)
|
|
(with (listval (eval listname)
|
|
pos (eval pos))
|
|
(set listname
|
|
(+ (sublist 0 pos listval)
|
|
(list (eval elt))
|
|
(sublist pos (length listval) listval)))))
|
|
|
|
;; the require/provide functions
|
|
|
|
(defun require packages
|
|
(for package packages
|
|
(if (not (boundp package)) (load package))
|
|
))
|
|
|
|
(defun provide packages
|
|
(for package packages
|
|
(if (not (boundp package)) (set package ()))
|
|
))
|
|
|
|
;; string package
|
|
|
|
(defun make-string-usable-for-resource-key-non-nil (string)
|
|
(if (setq #tmp# (make-string-usable-for-resource-key string))
|
|
(if (= #tmp# "") "_" #tmp#)
|
|
'any
|
|
))
|
|
|
|
;; The "backquote" function, (` <EXPR>),
|
|
;; which makes it much easier to construct various pieces of code and
|
|
;; data. As usual, unquote with a "comma", (, <EXPR>).
|
|
|
|
(defun backquote-eval (ele)
|
|
(if (= (type ele) 'list)
|
|
(if (= (# 0 ele) ',)
|
|
(eval (# 1 ele))
|
|
(mapfor subele ele
|
|
(backquote-eval subele)))
|
|
ele))
|
|
|
|
(defunq ` (body)
|
|
(backquote-eval body))
|
|
|
|
(defun apply (func lst)
|
|
(if (member (type func) '(fsubr fexpr))
|
|
(eval (+ (list func) lst))
|
|
(eval (+ (list func) (mapfor ele lst (list 'quote ele))))))
|
|
|
|
|
|
;;=============================================================================
|
|
;; rwhitby@adl.austek.oz.au (Rod Whitby)
|
|
;;=============================================================================
|
|
; First a function that returns t if the window is at the top of the stack.
|
|
; (This is needed because windows that are partially off-screen are
|
|
; considered by X to be only partially visible, even if they are at the top
|
|
; of the stack.)
|
|
|
|
(defun window-is-topmost (win)
|
|
(progn
|
|
(with (window-list (list-of-windows 'stacking-order))
|
|
(= win (# (- (length window-list) 1) window-list)))))
|
|
|
|
(defun window-is-bottommost (win)
|
|
(progn
|
|
(with (window-list (list-of-windows 'stacking-order))
|
|
(= win (# 0 window-list)))))
|
|
|
|
;;=============================================================================
|
|
;; Jay Berkenbilt's match-windowspec function
|
|
;;=============================================================================
|
|
|
|
;;
|
|
;; Returns t if the current window matches this windowspec
|
|
;; or nil otherwise
|
|
;; windowspec is a property list with 'client-class 'client-name
|
|
;; and 'window-name as possible tags
|
|
;; As you see, windowspecs can themselves contain regular
|
|
;; expressions. I could match all xterms set aside for buils with
|
|
;; the windowspec
|
|
;; (list 'client-class "XTerm" 'window-name ".*build")
|
|
;; for example.
|
|
|
|
(defun match-windowspec (windowspec)
|
|
(with (clientclass (# 'client-class windowspec)
|
|
clientname (# 'client-name windowspec)
|
|
windowname (# 'window-name windowspec))
|
|
(for a '(clientclass clientname windowname)
|
|
(if (= (eval a) nil)
|
|
(set a ".*")))
|
|
(if (and (match clientclass window-client-class)
|
|
(match clientname window-client-name)
|
|
(match windowname window-name))
|
|
t
|
|
nil)))
|
|
|
|
;; More window matching, by Anders Holst
|
|
|
|
(defun matches-token (token)
|
|
(if (not token) ; True and false are literary
|
|
()
|
|
(= token t)
|
|
t
|
|
(= (type token) 'atom) ; Atom is resource specification
|
|
(with (tmp (match ; client-class[.client-name[.window-name[.machine-name]]]
|
|
"^\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)[.]*\\([^.]*\\)$"
|
|
token 1 2 3 4))
|
|
(and (or (member (# 0 tmp) '(() "" "*" "any"))
|
|
(= (# 0 tmp) window-client-class))
|
|
(or (member (# 1 tmp) '(() "" "*" "any"))
|
|
(= (# 1 tmp) (make-string-usable-for-resource-key window-client-name)))
|
|
(or (member (# 2 tmp) '(() "" "*" "any"))
|
|
(= (# 2 tmp) (make-string-usable-for-resource-key window-name)))
|
|
(or (member (# 3 tmp) '(() "" "*" "any"))
|
|
(= (# 3 tmp) window-machine-name))))
|
|
(= (type token) 'string) ; String is regexp matching name
|
|
(match token window-name)
|
|
(and (= (type token) 'list) ; Lisp expression
|
|
(or (and (= (type (# 0 token)) 'atom)
|
|
(boundp (# 0 token))
|
|
(member (type (eval (# 0 token)))
|
|
'(subr fsubr expr fexpr)))
|
|
(= (type (# 0 token)) 'active)))
|
|
(eval token)
|
|
(and (= (type token) 'list) ; Windowspec
|
|
(= (type (# 0 token)) 'atom))
|
|
(match-windowspec token)
|
|
())) ; Else no match
|
|
|
|
(defun matches-list (lst)
|
|
(tag ret1
|
|
(for ele lst
|
|
(if (matches-token ele)
|
|
(exit ret1 t)))
|
|
()))
|
|
|
|
(defun matches-cond (condlst)
|
|
(tag ret2
|
|
(for lst condlst
|
|
(if (matches-token (# 0 lst))
|
|
(exit ret2
|
|
(sublist 1 (length lst) lst))))
|
|
()))
|
|
|
|
(defun matches-cond-all (condlst)
|
|
(with (res ())
|
|
(for lst condlst
|
|
(if (matches-token (# 0 lst))
|
|
(setq res (+ (sublist 1 (length lst) lst)
|
|
res))))
|
|
res))
|
|
|
|
|
|
;; qjb's utils
|
|
|
|
(defun ceildiv (x y)
|
|
;;
|
|
;; Returns (ceiling (/ x y))
|
|
;;
|
|
(/ (+ x (- y 1)) y))
|
|
|
|
(defun le (x y)
|
|
(or (< x y) (= x y)))
|
|
|
|
(defun ge (x y)
|
|
(or (> x y) (= x y)))
|
|
|
|
;;=============================================================================
|
|
;; place-button
|
|
;;=============================================================================
|
|
;; places a button on the screen
|
|
;; parameters (evaluated):
|
|
;;
|
|
;; name: text string
|
|
;; fore: color of text
|
|
;; 4 colors (can be strings or colors) from light to dark:
|
|
;; upper-left color, normal back, pressed back, lower right color
|
|
;; action is the code to be executed
|
|
;; in action, you can look at (current-event-code) and (current-event-modifier)
|
|
;; to know which button and which modifiers triggered you
|
|
|
|
(defun place-button (name fore lit norm press dark action)
|
|
(with (atype (eval (boundp 'place-button-action-type))
|
|
fsm-but (fsm-make (state-make
|
|
(on-eval '(buttonrelease any any)
|
|
(list 'progn
|
|
(if (= atype 'release)
|
|
action)
|
|
'(wob-tile (# 'normal wob)))
|
|
)
|
|
(on-eval '(buttonpress any any)
|
|
(list 'progn
|
|
'(wob-tile (# 'pressed wob))
|
|
(if (not (= atype 'release))
|
|
action)
|
|
(if (= atype 'press)
|
|
'(wob-tile (# 'normal wob)))
|
|
))
|
|
))
|
|
window-behavior standard-behavior
|
|
fsm window-fsm
|
|
fore-c (if (= (type fore) 'number) fore (color-make fore))
|
|
norm-c (if (= (type norm) 'number) norm (color-make norm))
|
|
press-c (if (= (type press) 'number) press (color-make press))
|
|
lit-c (if (= (type lit) 'number) lit (color-make lit))
|
|
dark-c (if (= (type dark) 'number) dark (color-make dark))
|
|
background norm-c
|
|
foreground fore-c
|
|
borderwidth 0
|
|
direction vertical
|
|
label-horizontal-margin 8 label-vertical-margin 6
|
|
menu-min-width 30 menu-max-width 1000
|
|
class-name "Gwm" client-name "button"
|
|
pix (if (= (type name) 'pixmap) name (label-make name))
|
|
background press-c
|
|
ppix (if (= (type name) 'pixmap) name (label-make name))
|
|
foreground lit-c
|
|
w (- (width pix) 1) h (- (height pix) 1)
|
|
w-1 (- w 1) h-1 (- h 1)
|
|
property (+ property (list 'normal pix 'pressed ppix
|
|
))
|
|
win (place-menu
|
|
(if (= (type name) 'pixmap) "button" name)
|
|
(menu-make
|
|
(bar-make
|
|
(with (fsm fsm-but)
|
|
(draw-line pix 0 0 w 0)
|
|
(draw-line pix 1 1 w-1 1)
|
|
(draw-line pix 0 0 0 h)
|
|
(draw-line pix 1 1 1 h-1)
|
|
(draw-line ppix w h w 0)
|
|
(draw-line ppix w-1 h-1 w-1 1)
|
|
(draw-line ppix w h 0 h)
|
|
(draw-line ppix w-1 h-1 1 h-1)
|
|
(setq foreground dark-c)
|
|
(draw-line pix w h w 0)
|
|
(draw-line pix w-1 h-1 w-1 1)
|
|
(draw-line pix w h 0 h)
|
|
(draw-line pix w-1 h-1 1 h-1)
|
|
(draw-line ppix 0 0 w 0)
|
|
(draw-line ppix 1 1 w-1 1)
|
|
(draw-line ppix 0 0 0 h)
|
|
(draw-line ppix 1 1 1 h-1)
|
|
|
|
(plug-make pix)
|
|
)))))
|
|
()
|
|
))
|
|
|
|
;; place-3d-button is a simplified version for use with colors using
|
|
;; the 1,2,3,4 shade system in rgb.txt.
|
|
;; these are:
|
|
|
|
(setq shaded-colors '(
|
|
snow seashell AntiqueWhite bisque PeachPuff NavajoWhite
|
|
LemonChiffon cornsilk ivory honeydew LavenderBlush MistyRose azure SlateBlue
|
|
RoyalBlue blue DodgerBlue SteelBlue DeepSkyBlue SkyBlue LightSkyBlue SlateGray
|
|
LightSteelBlue LightBlue LightCyan PaleTurquoise CadetBlue turquoise cyan
|
|
DarkSlateGray aquamarine DarkSeaGreen SeaGreen PaleGreen SpringGreen green
|
|
chartreuse OliveDrab DarkOliveGreen khaki LightGoldenrod LightYellow yellow
|
|
gold goldenrod DarkGoldenrod RosyBrown IndianRed sienna burlywood wheat tan
|
|
chocolate firebrick brown salmon LightSalmon orange DarkOrange coral tomato
|
|
OrangeRed red DeepPink HotPink pink LightPink PaleVioletRed maroon VioletRed
|
|
magenta orchid plum MediumOrchid DarkOrchid purple MediumPurple thistle
|
|
))
|
|
|
|
(defun place-3d-button (name pen color action)
|
|
(place-button name pen
|
|
(+ "" color "1")
|
|
(+ "" color "2")
|
|
(+ "" color "3")
|
|
(+ "" color "4")
|
|
action
|
|
))
|
|
|
|
(setq demo-button:color 0)
|
|
(setq demo-button:startcol ())
|
|
|
|
(defun place-3d-demo-button (name pen color action)
|
|
(place-button name pen
|
|
(setq place-3d-demo-button.c1 (color-make (+ "" color "1")))
|
|
(setq place-3d-demo-button.c2 (color-make (+ "" color "2")))
|
|
(setq place-3d-demo-button.c3 (color-make (+ "" color "3")))
|
|
(setq place-3d-demo-button.c4 (color-make (+ "" color "4")))
|
|
action
|
|
))
|
|
(defun demo-button ()
|
|
(setq demo-button:startcol (color-make "#123456789"))
|
|
(color-free demo-button:startcol)
|
|
(do-demo-button)
|
|
)
|
|
|
|
(defun do-demo-button ()
|
|
(place-3d-demo-button
|
|
(# demo-button:color shaded-colors) ;name
|
|
black ;pen ink
|
|
(# demo-button:color shaded-colors) ;color
|
|
'(progn
|
|
(setq demo-button:curcolor (# demo-button:color shaded-colors))
|
|
(if (not (< place-3d-demo-button.c1 demo-button:startcol))
|
|
(color-free place-3d-demo-button.c1)
|
|
)
|
|
(if (not (< place-3d-demo-button.c2 demo-button:startcol))
|
|
(color-free place-3d-demo-button.c2)
|
|
)
|
|
(if (not (< place-3d-demo-button.c3 demo-button:startcol))
|
|
(color-free place-3d-demo-button.c3)
|
|
)
|
|
(if (not (< place-3d-demo-button.c4 demo-button:startcol))
|
|
(color-free place-3d-demo-button.c4 )
|
|
)
|
|
(setq demo-button:color (+ 1 demo-button:color))
|
|
(delete-window) ;action
|
|
(if (# demo-button:color shaded-colors)
|
|
(do-demo-button)
|
|
))
|
|
))
|