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

fixed intern-atom calls 

added some option types
added colormap installation utils
This commit is contained in:
frese 2003-04-11 01:34:20 +00:00
parent 3ecd9478ee
commit 1393131948
1 changed files with 54 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
src/utils.scm
View File

@ -16,6 +16,12 @@
'()
lists))
(define (list-diff list1 list2)
;; returns every member in list2 that is not in list1
(filter (lambda (e)
(not (member e list1)))
list2))
;; *** cml utilities *************************************************
(define (select* . list) (select list))
@ -39,8 +45,8 @@
(mdisplay "condition in " id ":\n " condition "\n")
(punt))
(lambda ()
(fun (lambda () (sync-point-release sp)))
(mdisplay "thread " id " returned\n")
(let ((res (fun (lambda () (sync-point-release sp)))))
(mdisplay "thread " id " returned: " res "\n"))
))))
(sync-point-wait sp))))
@ -53,13 +59,14 @@
;; *** option utilities **********************************************
(define-record-type options :options
(make-options dpy colormap option-alist value-alist type-alist)
(make-options dpy colormap option-alist value-alist type-alist default-alist)
options?
(dpy options:dpy)
(colormap options:colormap)
(option-alist options:option-alist set-options:option-alist!)
(value-alist options:value-alist set-options:value-alist!)
(type-alist options:type-alist set-options:type-alist!))
(type-alist options:type-alist set-options:type-alist!)
(default-alist options:default-alist))
(define (create-options dpy colormap spec options)
(let ((option-alist (map (lambda (s)
@ -70,12 +77,16 @@
(value-alist '())
(type-alist (map (lambda (s)
(cons (first s) (second s)))
spec)))
spec))
(default-alist (map (lambda (s)
(cons (first s) (third s)))
spec)))
(for-each (lambda (name.option name.type)
(allocate-option dpy colormap (car name.option)
(cdr name.type) (cdr name.option)))
option-alist type-alist)
(make-options dpy colormap option-alist value-alist type-alist)))
(make-options dpy colormap option-alist value-alist type-alist
default-alist)))
;; if the colormap gets freed, then the colors don't have to
(define (free-options options free-colors?)
@ -130,10 +141,14 @@
(define (get-options options)
(options:option-alist options))
(define (get-options-diff options)
(list-diff (options:default-alist options)
(options:option-alist options)))
(define-enumerated-type option-type :option-type
option-type? option-types option-type-name option-type-index
(int number inexact exact string symbol font color colors
boolean symbol-list keys))
boolean symbol-list keys keys-list sexp))
(define-syntax define-options-spec
(syntax-rules
@ -177,6 +192,13 @@
((eq? type (option-type keys))
(let ((keys (string->keys dpy def)))
(check keys (lambda (x) x))))
((eq? type (option-type keys-list))
(and (check def list?)
(map (lambda (s) (allocate-option dpy colormap name
(option-type keys) s))
def)))
((eq? type (option-type sexp))
def)
(else (error "option type not implemented" name type)))))
;; *** keys utilities ************************************************
@ -261,7 +283,7 @@
(define (take-focus dpy window time)
;; implements the TAKE_FOCUS protocol
(let* ((protocols (get-wm-protocols dpy window))
(wm-take-focus (intern-atom dpy "WM_TAKE_FOCUS" #t))
(wm-take-focus (intern-atom dpy "WM_TAKE_FOCUS" #f))
(wm-hints (get-wm-hints dpy window))
(t (and wm-hints (assq (wm-hint input?) wm-hints)))
(input? (if t (cdr t) #t)))
@ -286,13 +308,13 @@
(send-event dpy window #f (event-mask)
(create-client-message-event
(event-type client-message) 0 #t dpy window
(make-property (intern-atom dpy "WM_PROTOCOLS" #t)
(make-property (intern-atom dpy "WM_PROTOCOLS" #f)
(property-format long)
(list atom time)))))
(define (delete-window dpy window time)
(let* ((protocols (get-wm-protocols dpy window))
(wm-delete-window (intern-atom dpy "WM_DELETE_WINDOW" #t)))
(wm-delete-window (intern-atom dpy "WM_DELETE_WINDOW" #f)))
(if (member wm-delete-window protocols)
(send-protocol-message dpy window wm-delete-window time)
(destroy-window dpy window))))
@ -493,3 +515,25 @@
thunk
(lambda ()
(display-select-input dpy window before)))))
(define (all-window-colormaps dpy window)
(let ((wins (cons window
(let* ((a (intern-atom dpy "WM_COLORMAP_WINDOWS" #f))
(t (intern-atom dpy "WINDOW" #f))
(p (get-full-window-property dpy window a #f t)))
(if (and p (property:data p))
(property:data p)
'())))))
(map (lambda (win)
(window-attribute:colormap (get-window-attributes dpy win)))
wins)))
(define (install-colormaps dpy window)
(for-each (lambda (c)
(install-colormap dpy c))
(all-window-colormaps dpy window)))
(define (uninstall-colormaps dpy window)
(for-each (lambda (c)
(uninstall-colormap dpy c))
(all-window-colormaps dpy window)))