440 lines
15 KiB
Scheme
440 lines
15 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))
|
|
|
|
;; *** cml utilities *************************************************
|
|
|
|
(define (select* . list) (select list))
|
|
|
|
(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* fun)
|
|
(let ((sp (make-sync-point)))
|
|
(spawn (lambda ()
|
|
(fun (lambda () (sync-point-release sp)))))
|
|
(sync-point-wait sp)))
|
|
|
|
(define (with-lock lock thunk)
|
|
(obtain-lock lock)
|
|
(let ((r (thunk)))
|
|
(release-lock lock)
|
|
r))
|
|
|
|
;; *** option utilities **********************************************
|
|
|
|
(define-record-type options :options
|
|
(make-options dpy colormap option-alist value-alist type-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!))
|
|
|
|
(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 (map (lambda (s)
|
|
(cons (first s) (second 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)))
|
|
|
|
(define (free-options options)
|
|
;; TODO
|
|
#t)
|
|
|
|
(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-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))
|
|
|
|
(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 (allocate-option dpy colormap name type def)
|
|
(let ((check (lambda (value pred)
|
|
(if (not (pred value))
|
|
(error "wrong type argument" value) ;; TODO: other??
|
|
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))))
|
|
(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 (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))))
|
|
(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)
|
|
;; 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)))
|
|
|
|
(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)
|
|
(eq? (window-attribute:map-state (get-window-attributes dpy window))
|
|
(map-state is-viewable)))
|
|
|
|
(define (window-focused? dpy window)
|
|
(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))
|
|
(window-children dpy window))))
|
|
|
|
(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-hints (get-wm-hints dpy window))
|
|
(t (and wm-hints (assq (wm-hint input?) wm-hints)))
|
|
(input? (if t (cdr t) #t)))
|
|
(let ((type (if (not (and protocols wm-take-focus
|
|
(memq wm-take-focus protocols)))
|
|
(if input?
|
|
'passive
|
|
'no-input)
|
|
(if input?
|
|
'locally-active
|
|
'globally-active))))
|
|
;; we use passive as the default (with no hints at all)
|
|
(case type
|
|
((passive)
|
|
(set-input-focus dpy window (revert-to parent) time)) ;; ??
|
|
((globally-active) #t)
|
|
((locally-active)
|
|
(send-protocol-message dpy window wm-take-focus time))
|
|
((no-focus) #f)))))
|
|
|
|
(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" #t)
|
|
(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)))
|
|
(if (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 (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 (floor (/ (- (rectangle:width rect) tw) 2))
|
|
(+ (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)))
|
|
(mdisplay "maximize-window: " window " "
|
|
(rectangle:x r) " " (rectangle:y r) " "
|
|
(rectangle:width r) " " (rectangle:height r) "\n")
|
|
(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?
|
|
(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))))
|
|
|
|
(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))
|
|
|
|
;; 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 width height)))
|