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

added option-type cursor 

optimized window-contains-focus?
fixed take-focus and get-wm-state
This commit is contained in:
frese 2003-05-05 14:53:18 +00:00
parent 36da85834f
commit 8c8e13639e
1 changed files with 32 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
src/utils.scm
View File

@ -42,11 +42,12 @@
(spawn (lambda ()
(with-handler
(lambda (condition punt)
(mdisplay "condition in " id ":\n " condition "\n")
(mdisplay "condition in " id ":")
(punt))
(lambda ()
(let ((res (fun (lambda () (sync-point-release sp)))))
(mdisplay "thread " id " returned: " res "\n"))
;;(mdisplay "thread " id " returned: " res "\n")
res)
))))
(sync-point-wait sp))))
@ -116,7 +117,9 @@
(list value) 0))
((eq? (option-type colors) type)
(free-colors (options:dpy options) (options:colormap options)
value 0)))))
value 0))
((eq? (option-type cursor) type)
(free-cursor (options:dpy options) value)))))
(options:value-alist options)))
(define (get-option-value options name)
@ -162,7 +165,8 @@
(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 keys-list sexp binding-list))
boolean symbol-list keys keys-list sexp binding-list
cursor))
(define-syntax define-options-spec
(syntax-rules
@ -220,6 +224,8 @@
(option-type keys) (car b))))
(cons k (cdr b))))
def)))
((eq? type (option-type cursor))
(check (create-font-cursor dpy def) (lambda (x) x)))
(else (error "option type not implemented" name type)))))
;; *** keys utilities ************************************************
@ -300,10 +306,16 @@
(eq? (get-input-focus-window dpy) window))
(define (window-contains-focus? dpy window)
(or (window-focused? dpy window)
(any (lambda (child)
(window-contains-focus? dpy child))
(or (window-children dpy window) '()))))
(let ((fw (get-input-focus-window dpy)))
(or (equal? fw window)
(window-contains-window? dpy window fw))))
(define (window-contains-window? dpy window child)
(let ((children (or (window-children dpy window) '())))
(or (member child children)
(any (lambda (c)
(window-contains-window? dpy c child))
children))))
(define (take-focus dpy window time)
;; implements the TAKE_FOCUS protocol
@ -312,7 +324,7 @@
(wm-hints (get-wm-hints dpy window))
(t (and wm-hints (assq (wm-hint input?) wm-hints)))
(input? (if t (cdr t) #f)))
(if (and input? (window-mapped? dpy window))
(if (and input? (window-viewable? dpy window))
(set-input-focus dpy window (revert-to parent) time))
(if (and protocols wm-take-focus
(memq wm-take-focus protocols))
@ -524,6 +536,15 @@
(< x (+ (rectangle:x r) (rectangle:width r)))
(< y (+ (rectangle:y r) (rectangle:height r)))))
(define (rectangles-overlap? r1 r2)
(let ((x1 (rectangle:x r2))
(y1 (rectangle:y r2))
(x2 (+ (rectangle:x r2) (rectangle:width r2)))
(y2 (+ (rectangle:y r2) (rectangle:height r2))))
(any (lambda (p)
(point-in-rectangle? r1 (car p) (cdr p)))
(list (cons x1 y1) (cons x1 y2) (cons x2 y1) (cons x2 y2)))))
(define-enumerated-type wm-state :wm-state
wm-state? wm-states wm-state-name wm-state-index
(withdrawn normal wm-state-2 iconic))
@ -540,7 +561,8 @@
(and p
(eq? (property-format long) (property:format p))
(eq? ws (property:type p))
(cons (first (property:data p)) (second (property:data p))))))
(cons (integer->wm-state (first (property:data p)))
(second (property:data p))))))
(define (set-wm-state! dpy window state icon-window)
(let* ((ws (intern-atom dpy "WM_STATE" #f))