672 lines
23 KiB
Scheme
672 lines
23 KiB
Scheme
(define (mdisplay . args)
|
|
(for-each display args)
|
|
(force-output (current-output-port)))
|
|
|
|
(define (:optional args default)
|
|
(if (null? args)
|
|
default
|
|
(car args)))
|
|
|
|
(define (assq/false key alist)
|
|
(let ((p (assq key alist)))
|
|
(and p (cdr p))))
|
|
|
|
(define (flatten lists)
|
|
(fold-right append
|
|
'()
|
|
lists))
|
|
|
|
(define (list-diff list1 list2)
|
|
;; returns every member in list2 that is not in list1
|
|
(filter (lambda (e)
|
|
(not (member e list1)))
|
|
list2))
|
|
|
|
(define (floor* x)
|
|
(let ((y (floor x)))
|
|
(if (inexact? y)
|
|
(inexact->exact y)
|
|
y)))
|
|
|
|
;; *** cml utilities *************************************************
|
|
|
|
(define select* select)
|
|
|
|
(define (make-sync-point)
|
|
(make-placeholder))
|
|
|
|
(define (sync-point-release sp)
|
|
(placeholder-set! sp #t))
|
|
|
|
(define (sync-point-wait sp)
|
|
(placeholder-value sp))
|
|
|
|
(define (spawn* id . fun)
|
|
(let ((id (if (null? fun) "unnamed" id))
|
|
(fun (if (null? fun) id (car fun))))
|
|
(let ((sp (make-sync-point)))
|
|
(spawn (lambda ()
|
|
(with-fatal-and-capturing-error-handler
|
|
(lambda (condition continuation punt)
|
|
(display-continuation continuation)
|
|
(punt))
|
|
(lambda ()
|
|
(let ((res (fun (lambda () (sync-point-release sp)))))
|
|
;;(mdisplay "thread " id " returned: " res "\n")
|
|
res)
|
|
))) id)
|
|
(sync-point-wait sp))))
|
|
|
|
(define (with-lock lock thunk)
|
|
(obtain-lock lock)
|
|
(let ((r (thunk)))
|
|
(release-lock lock)
|
|
r))
|
|
|
|
(define (send-message+wait channel message)
|
|
(let ((sp (make-sync-point)))
|
|
(send channel (list 'wait sp message))
|
|
(sync-point-wait sp)))
|
|
|
|
;; *** option utilities **********************************************
|
|
|
|
(define-record-type options :options
|
|
(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!)
|
|
(default-alist options:default-alist))
|
|
|
|
;; create new options structure out of existing (allocated) values
|
|
;; TODO: remember which options were specified and don't have to be
|
|
;; freed, and those that are allocated later.
|
|
;; TODO: the options are taken out of the spec, but that mustn't match
|
|
;; the given values
|
|
(define (build-options dpy colormap spec option-values)
|
|
(make-options dpy colormap
|
|
(options-spec-defaults spec)
|
|
option-values ;; TODO check this alist
|
|
(options-spec-types spec)
|
|
(options-spec-defaults spec)))
|
|
|
|
(define (create-options dpy colormap spec options)
|
|
(let ((option-alist (map (lambda (s)
|
|
(let* ((n (first s))
|
|
(op (assq n options)))
|
|
(cons n (if op (cdr op) (third s)))))
|
|
spec))
|
|
(value-alist '())
|
|
(type-alist (options-spec-types spec))
|
|
(default-alist (options-spec-defaults 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
|
|
default-alist)))
|
|
|
|
(define (spec-defaults defaults spec)
|
|
(map (lambda (s)
|
|
(let ((name (first s))
|
|
(type (second s))
|
|
(def1 (third s)))
|
|
(let ((def2 (assq name defaults)))
|
|
(list name type (if def2 (cdr def2) def1)))))
|
|
spec))
|
|
|
|
;; 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)
|
|
(free-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))
|
|
((eq? (option-type cursor) type)
|
|
(free-cursor (options:dpy options) value)))))
|
|
(options:value-alist options)))
|
|
|
|
(define (get-option-value options name)
|
|
(let ((p (assq name (options:value-alist options))))
|
|
(if p
|
|
(cdr p)
|
|
(let ((op (assq name (options:option-alist options)))
|
|
(tp (assq name (options:type-alist options))))
|
|
(if (or (not op) (not tp))
|
|
(error "option not defined" name)
|
|
(let ((v (allocate-option (options:dpy options)
|
|
(options:colormap options)
|
|
name (cdr tp) (cdr op))))
|
|
(set-options:value-alist! options
|
|
(cons (cons name v)
|
|
(options:value-alist options)))
|
|
v))))))
|
|
|
|
(define (get-option options name)
|
|
(let ((vp (assq name (options:option-alist options))))
|
|
(if (not vp)
|
|
(error "option not defined" name)
|
|
(cdr vp))))
|
|
|
|
(define (set-option! options name def)
|
|
(set-options:option-alist! options
|
|
(cons (cons name def)
|
|
(filter (lambda (n.o)
|
|
(not (eq? (car n.o) name)))
|
|
(options:option-alist options))))
|
|
(set-options:value-alist! options
|
|
(filter (lambda (n.v)
|
|
(not (eq? (car n.v) name)))
|
|
(options:value-alist options))))
|
|
|
|
(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 keys-list sexp binding-list
|
|
cursor))
|
|
|
|
(define-syntax define-options-spec
|
|
(syntax-rules
|
|
()
|
|
((define-options-spec id (name type default) ...)
|
|
(define id (list (list (quote name) (option-type type) default)
|
|
...)))))
|
|
|
|
(define (options-spec-union spec1 spec2)
|
|
(append spec1 spec2))
|
|
|
|
(define (options-spec-types spec)
|
|
(map (lambda (s)
|
|
(cons (first s) (second s)))
|
|
spec))
|
|
|
|
(define (options-spec-defaults spec)
|
|
(map (lambda (s)
|
|
(cons (first s) (third s)))
|
|
spec))
|
|
|
|
(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??
|
|
value))))
|
|
(cond
|
|
((eq? type (option-type int)) (check def integer?))
|
|
((eq? type (option-type number)) (check def number?))
|
|
((eq? type (option-type inexact)) (check def inexact?))
|
|
((eq? type (option-type exact)) (check def inexact?))
|
|
((eq? type (option-type string)) (check def string?))
|
|
((eq? type (option-type symbol)) (check def symbol?))
|
|
((eq? type (option-type font))
|
|
(check (load-query-font dpy def) (lambda (v) v)))
|
|
((eq? type (option-type color))
|
|
(let ((c (alloc-named-color dpy colormap def)))
|
|
(check (and c (color:pixel c)) (lambda (v) v))))
|
|
((eq? type (option-type colors))
|
|
(and (check def list?)
|
|
(map (lambda (c) (allocate-option dpy colormap name
|
|
(option-type color) c))
|
|
def)))
|
|
((eq? type (option-type boolean))
|
|
(check def boolean?)) ;; maybe allow 'yes 'no ??
|
|
((eq? type (option-type symbol-list))
|
|
(and (check def list?)
|
|
(map (lambda (s) (allocate-option dpy colormap name
|
|
(option-type symbol) s))
|
|
def)))
|
|
((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)
|
|
((eq? type (option-type binding-list))
|
|
(and (check def list?)
|
|
(map (lambda (b)
|
|
(let ((k (allocate-option dpy colormap name
|
|
(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 ************************************************
|
|
|
|
(define-record-type key :key
|
|
(make-key modifiers keycode)
|
|
key?
|
|
(modifiers key:modifiers)
|
|
(keycode key:keycode))
|
|
|
|
(define (string->keys dpy s)
|
|
(let* ((keys-s (split-space s))
|
|
(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))
|
|
(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))))
|
|
|
|
(define split-minus (infix-splitter (rx "-")))
|
|
(define split-space (infix-splitter (rx " ")))
|
|
|
|
(define (strings->modifiers str-list)
|
|
(let ((l (map string->modifiers str-list)))
|
|
(and (not (memq #f l))
|
|
(fold enum-set-union
|
|
(state-set)
|
|
l))))
|
|
|
|
(define (string->modifiers s)
|
|
(cond
|
|
((equal? s "C") (state-set control))
|
|
((equal? s "M") (state-set mod1))
|
|
((equal? s "M1") (state-set mod1))
|
|
((equal? s "M2") (state-set mod2))
|
|
((equal? s "M3") (state-set mod3))
|
|
((equal? s "M4") (state-set mod4))
|
|
((equal? s "M5") (state-set mod5))
|
|
((equal? s "S") (state-set shift)) ;; needed?
|
|
(else #f)))
|
|
|
|
;; *** xlib utilities ************************************************
|
|
|
|
(define (reparent-to-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
|
|
(let ((p (window-parent dpy window)))
|
|
(if (zero? p)
|
|
'()
|
|
(window-path dpy p)))))
|
|
|
|
(define (window-viewable? dpy window)
|
|
(and window
|
|
(let ((attrs (get-window-attributes dpy window)))
|
|
(and attrs
|
|
(eq? (window-attribute:map-state attrs)
|
|
(map-state is-viewable))))))
|
|
|
|
(define (window-mapped? dpy window)
|
|
(and window
|
|
(let ((attrs (get-window-attributes dpy window)))
|
|
(and attrs
|
|
(not (eq? (window-attribute:map-state attrs)
|
|
(map-state is-unmapped)))))))
|
|
|
|
(define (window-focused? dpy window)
|
|
(eq? (get-input-focus-window dpy) window))
|
|
|
|
(define (window-contains-focus? 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
|
|
(let* ((protocols (get-wm-protocols dpy window))
|
|
(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)))
|
|
(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))
|
|
(send-protocol-message dpy window wm-take-focus time))))
|
|
|
|
(define (send-protocol-message dpy window atom time)
|
|
(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" #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" #f)))
|
|
(if (and protocols (member wm-delete-window protocols))
|
|
(send-protocol-message dpy window wm-delete-window time)
|
|
(destroy-window dpy window))))
|
|
|
|
(define (move-resize-window* dpy window rect)
|
|
(move-resize-window dpy window
|
|
(rectangle:x rect) (rectangle:y rect)
|
|
(rectangle:width rect) (rectangle:height rect)))
|
|
|
|
(define (root-rectangle dpy win)
|
|
(let ((r (translate-coordinates dpy win (default-root-window dpy)
|
|
0 0)))
|
|
(make-rectangle (if r (car r) 0) (if r (cadr r) 0)
|
|
(window-width dpy win) (window-height dpy win))))
|
|
|
|
(define (window-rectangle dpy win)
|
|
(let ((wa (get-window-attributes dpy win)))
|
|
(make-rectangle (window-attribute:x wa) (window-attribute:y wa)
|
|
(window-attribute:width wa) (window-attribute:height wa))))
|
|
|
|
(define (clip-rectangle dpy win)
|
|
(make-rectangle 0 0 (window-width dpy win) (window-height dpy win)))
|
|
|
|
(define (draw-shadow-rectangle dpy win gc r lc dc)
|
|
(let* ((x1 (rectangle:x r))
|
|
(y1 (rectangle:y r))
|
|
(x2 (- (+ x1 (rectangle:width r)) 1))
|
|
(y2 (- (+ y1 (rectangle:height r)) 1)))
|
|
(set-gc-foreground! dpy gc lc)
|
|
(draw-lines dpy win gc (list (cons x1 y2) (cons x1 y1) (cons x2 y1))
|
|
(coord-mode origin))
|
|
(set-gc-foreground! dpy gc dc)
|
|
(draw-lines dpy win gc (list (cons x2 y1) (cons x2 y2) (cons x1 y2))
|
|
(coord-mode origin))))
|
|
|
|
(define (fill-rectangle* dpy win gc rect)
|
|
(fill-rectangle dpy win gc (rectangle:x rect) (rectangle:y rect)
|
|
(rectangle:width rect) (rectangle:height rect)))
|
|
|
|
(define (invalidate-window dpy win)
|
|
(let ((wa (get-window-attributes dpy win)))
|
|
(clear-area dpy win 0 0 (window-attribute:width wa)
|
|
(window-attribute:height wa) #t)))
|
|
|
|
(define (text-center-pos rect font-struct str)
|
|
(let* ((cs (text-extents font-struct str))
|
|
(tw (char-struct:width cs)))
|
|
(cons (+ (rectangle:x rect) (floor* (/ (- (rectangle:width rect) tw) 2)))
|
|
(+ (rectangle:y rect)
|
|
(floor* (/ (rectangle:height rect) 2))
|
|
(font-struct:descent font-struct)))))
|
|
|
|
;; maximize-window moves and resizes the window fill as much space of
|
|
;; it's parent (or the window specified with the optional
|
|
;; argument). If there is a WM_NORMAL hint present for the window, and
|
|
;; the window has to be smaller than the parent, it is centered.
|
|
|
|
(define (maximize-window dpy window . maybe-parent)
|
|
(let ((r (apply maximal-rect/hints dpy window maybe-parent)))
|
|
(move-resize-window dpy window (rectangle:x r) (rectangle:y r)
|
|
(rectangle:width r) (rectangle:height r))))
|
|
|
|
(define (maximal-rect/hints dpy window . maybe-parent)
|
|
(let ((parent (:optional maybe-parent (window-parent dpy window))))
|
|
(let ((max-width (window-width dpy parent))
|
|
(max-height (window-height dpy parent)))
|
|
(let ((w.h (maximal-size/hints dpy window max-width max-height)))
|
|
(let ((width (car w.h))
|
|
(height (cdr w.h)))
|
|
(let ((x (quotient (- max-width width) 2))
|
|
(y (quotient (- max-height height) 2)))
|
|
(make-rectangle x y width height)))))))
|
|
|
|
(define (maximal-size/hints dpy window max-width max-height)
|
|
(let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
|
|
(if hints
|
|
(adjust-size/hints hints max-width max-height)
|
|
(cons max-width max-height))))
|
|
|
|
(define (size-window dpy window default-size)
|
|
(let ((size (desired-size/hints dpy window default-size)))
|
|
(configure-window dpy window
|
|
(make-window-change-alist
|
|
(width (car size))
|
|
(height (cdr size))))))
|
|
|
|
(define (desired-size/hints dpy window default-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?
|
|
(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
|
|
;; width/height (but never bigger).
|
|
|
|
(define (adjust-size/hints size-hints width height)
|
|
(let ((min-size-hint (assq (size-hint min-size) size-hints))
|
|
(max-size-hint (assq (size-hint max-size) size-hints))
|
|
(resize-inc-hint (assq (size-hint resize-inc) size-hints))
|
|
(aspect-hint (assq (size-hint aspect) size-hints))
|
|
(base-size-hint (assq (size-hint base-size) size-hints)))
|
|
|
|
;; respect the desired maximal size ******************************
|
|
(if max-size-hint
|
|
(let ((max-width (car (cdr max-size-hint)))
|
|
(max-height (cdr (cdr max-size-hint))))
|
|
(if (> width max-width) (set! width max-width))
|
|
(if (> height max-height) (set! height max-height))))
|
|
|
|
;; ignore the minimal size, but give a warning *******************
|
|
; (let ((hint (or min-size-hint base-size-hint))) ;; according to ICCCM
|
|
; (if hint
|
|
; (let* ((min-size (cdr hint))
|
|
; (min-width (car min-size))
|
|
; (min-height (cdr min-size)))
|
|
; (if (or (< width min-width)
|
|
; (< height min-height))
|
|
; (debug-message 1 "% has to be smaller, than the desired minimal size %."
|
|
; window hint)))))
|
|
|
|
;; respect aspect ratios *****************************************
|
|
(if aspect-hint
|
|
(let* ((base-width (if base-size-hint
|
|
(car (cdr base-size-hint))
|
|
0))
|
|
(base-height (if base-size-hint
|
|
(cdr (cdr base-size-hint))
|
|
0))
|
|
(width* (- width base-width))
|
|
(height* (- height base-height))
|
|
|
|
(ratio (/ width* height*))
|
|
(min-ratio (/ (car (car (cdr aspect-hint)))
|
|
(cdr (car (cdr aspect-hint)))))
|
|
(max-ratio (/ (car (cdr (cdr aspect-hint)))
|
|
(cdr (cdr (cdr aspect-hint)))))
|
|
(new-ratio ratio))
|
|
(if (> ratio max-ratio)
|
|
(set! new-ratio max-ratio)
|
|
(if (< ratio min-ratio)
|
|
(set! new-ratio min-ratio)))
|
|
(if (< new-ratio ratio)
|
|
(set! width* (* height* new-ratio))
|
|
(if (> new-ratio ratio)
|
|
(set! height* (/ width* new-ratio))))
|
|
(set! width (+ width* base-width))
|
|
(set! height (+ height* base-height))))
|
|
|
|
;; respect resize-incs *******************************************
|
|
(if resize-inc-hint
|
|
(let* ((width-inc (car (cdr resize-inc-hint)))
|
|
(height-inc (cdr (cdr resize-inc-hint)))
|
|
(base-size-hint (or base-size-hint min-size-hint))
|
|
(base-width (if base-size-hint
|
|
(car (cdr base-size-hint))
|
|
0))
|
|
(base-height (if base-size-hint
|
|
(cdr (cdr base-size-hint))
|
|
0)))
|
|
(set! width
|
|
(+ base-width (* width-inc (quotient (- width base-width)
|
|
width-inc))))
|
|
(set! height
|
|
(+ base-height (* height-inc (quotient (- height base-height)
|
|
height-inc))))))
|
|
|
|
;; result ********************************************************
|
|
(cons (floor* width) (floor* height))))
|
|
|
|
(define (minimal-size/hints dpy window default-width default-height)
|
|
(let ((hints (get-wm-normal-hints dpy window)) ;; or group-leader?
|
|
(default-size (cons default-width default-height)))
|
|
(if hints
|
|
(or (assq/false (size-hint min-size) hints)
|
|
(assq/false (size-hint base-size) hints) ;; according to ICCCM
|
|
default-size)
|
|
default-size)))
|
|
|
|
(define (point-in-rectangle? r x y)
|
|
(and (>= x (rectangle:x r))
|
|
(>= y (rectangle:y r))
|
|
(< 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 (+ -1 (rectangle:x r2) (rectangle:width r2)))
|
|
(y2 (+ -1 (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))
|
|
|
|
(define (integer->wm-state i)
|
|
(vector-ref wm-states i))
|
|
|
|
(define (wm-state->integer s)
|
|
(wm-state-index s))
|
|
|
|
(define (get-wm-state dpy window)
|
|
(let* ((ws (intern-atom dpy "WM_STATE" #f))
|
|
(p (get-full-window-property dpy window ws #f ws)))
|
|
(and p
|
|
(eq? (property-format long) (property:format p))
|
|
(eq? ws (property:type 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))
|
|
(p (make-property ws (property-format long)
|
|
(list (wm-state->integer state) icon-window))))
|
|
(change-property dpy window ws (change-property-mode replace) p)))
|
|
|
|
(define (window-level dpy win)
|
|
(length (window-path dpy win)))
|
|
|
|
(define (with-prevent-events dpy window event-mask thunk)
|
|
(let* ((before (window-attribute:your-event-mask
|
|
(get-window-attributes dpy window)))
|
|
(new (enum-set-intersection before
|
|
(enum-set-negation event-mask))))
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(display-select-input dpy window new))
|
|
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)))
|
|
(filter (lambda (x) x) 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)))
|
|
|
|
(define (send-configuration dpy window)
|
|
(let ((r (root-rectangle dpy window)))
|
|
(send-event dpy window #f (event-mask structure-notify)
|
|
(create-configure-event
|
|
(event-type configure-notify) 0 #t dpy window window
|
|
(rectangle:x r) (rectangle:y r)
|
|
(rectangle:width r) (rectangle:height r)
|
|
0 none #f))))
|
|
|
|
;; timer
|
|
|
|
(define (now)
|
|
(call-with-values time+ticks
|
|
(lambda (secs ticks)
|
|
(+ secs (/ ticks (ticks/sec))))))
|
|
|
|
(define (at-time-rv time)
|
|
(let ((ch (make-channel)))
|
|
(spawn (lambda ()
|
|
(let ((a (* 1000 (- time (now)))))
|
|
(if (> a 0)
|
|
(sleep a))
|
|
(send ch 'wake))))
|
|
(receive-rv ch)))
|
|
; (with-nack (lambda (nack)
|
|
; (choose (list (receive-rv ch)
|
|
; nack))))))
|
|
|
|
(define (after-time-rv time)
|
|
(at-time-rv (+ (now) time)))
|