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

fixed options-diff 

added wm-state functions
added timer rendezvous
This commit is contained in:
frese 2003-04-15 16:05:29 +00:00
parent 52c1669cbe
commit a1d73f0902
1 changed files with 49 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
src/utils.scm
View File

@ -79,7 +79,9 @@
(cons (first s) (second s)))
spec))
(default-alist (map (lambda (s)
(cons (first s) (third s)))
(let ((op (assq (first s) options)))
(if op op
(cons (first s) (third s)))))
spec)))
(for-each (lambda (name.option name.type)
(allocate-option dpy colormap (car name.option)
@ -501,6 +503,30 @@
(< x (+ (rectangle:x r) (rectangle:width r)))
(< y (+ (rectangle:y r) (rectangle:height r)))))
(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 (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)))
@ -537,3 +563,25 @@
(for-each (lambda (c)
(uninstall-colormap dpy c))
(all-window-colormaps dpy window)))
;; 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)))