scsh-conservatory
/
orion-wm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added free-options 

fixed wm-hints stuff
added uppercase/lowercase to keys option
This commit is contained in:
frese 2003-03-30 01:49:10 +00:00
parent da76ea4b48
commit 1d426ce2dd
1 changed files with 46 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
src/utils.scm
View File

@ -68,9 +68,22 @@
option-alist type-alist)
(make-options dpy colormap option-alist value-alist type-alist)))
(define (free-options options)
;; TODO
#t)
;; if the colormap gets freed, then the colors don't have to
(define (free-options options free-colors?)
(for-each (lambda (n.v)
(let* ((name (car n.v))
(value (cdr n.v))
(type (assq/false name (options:type-alist options))))
(cond
((eq? (option-type font) type)
(unload-font (options:dpy options) value))
((eq? (option-type color) type)
(free-colors (options:dpy options) (options:colormap options)
(list value) 0))
((eq? (option-type colors) type)
(free-colors (options:dpy options) (options:colormap options)
value 0)))))
(options:value-alist options)))
(define (get-option-value options name)
(let ((p (assq name (options:value-alist options))))
@ -120,10 +133,13 @@
(define id (list (list (quote name) (option-type type) default)
...)))))
(define (options-spec-union spec1 spec2)
(append spec1 spec2))
(define (allocate-option dpy colormap name type def)
(let ((check (lambda (value pred)
(if (not (pred value))
(error "wrong type argument" value) ;; TODO: other??
(error "wrong type argument" value) ;; TODO: other error??
value))))
(cond
((eq? type (option-type int)) (check def integer?))
@ -167,13 +183,20 @@
(keys (map (lambda (s) (string->key dpy s)) keys-s)))
(and (not (memq #f keys)) keys)))
(define (is-uppercase? keysym)
(let ((low.up (convert-case keysym)))
(not (equal? (car low.up) keysym))))
(define (string->key dpy s)
(let* ((l (reverse (split-minus s)))
(mod-strings (reverse (cdr l)))
(key-string (car l))
(modifiers (strings->modifiers mod-strings))
;; TODO: upcase chars + Shift
(keycode (keysym->keycode dpy (string->keysym key-string))))
(keysym (string->keysym key-string))
(keycode (keysym->keycode dpy keysym))
(modifiers (enum-set-union (if (is-uppercase? keysym)
(state-set shift)
(state-set))
(strings->modifiers mod-strings))))
(and modifiers keycode
(make-key modifiers keycode))))
@ -202,10 +225,9 @@
;; *** xlib utilities ************************************************
(define (reparent-to-root dpy window)
;; reparent window to it's root-window so that it stays virtually at
;; the same position.
;; TODO
(reparent-window dpy window (window-root dpy window)))
(let ((r (root-rectangle dpy window)))
(reparent-window dpy window (window-root dpy window)
(rectangle:x r) (rectangle:y r))))
(define (window-path dpy window)
(cons window
@ -347,18 +369,21 @@
(height (cdr size))))))
(define (desired-size/hints dpy window default-size)
(let* ((hints (get-wm-normal-hints dpy window)) ;; or group-leader?
(size (or (assq/false (size-hint us-size) hints)
(assq/false (size-hint size) hints)
default-size)))
(adjust-size/hints hints (car size) (cdr size))))
(let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
(if hints
(let ((size (or (assq/false (size-hint us-size) hints)
(assq/false (size-hint size) hints)
default-size)))
(adjust-size/hints hints (car size) (cdr size)))
default-size)))
(define (desired-position/hints dpy window default-position)
(let* ((hints (get-wm-normal-hints dpy window)) ;; or group-leader?
(pos (or (assq/false (size-hint us-position) hints)
(assq/false (size-hint position) hints)
default-position)))
pos))
(let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
(if hints
(or (assq/false (size-hint us-position) hints)
(assq/false (size-hint position) hints)
default-position)
default-position)))
;; returns width/height pair that conform to the defined
;; aspects/resize-inc etc. in hints, and are as close as possible to