first commit
This commit is contained in:
frese
commit
e3e12d92f8
|
|
@ -0,0 +1,28 @@
|
|||
# CVS default ignores begin
|
||||
tags
|
||||
TAGS
|
||||
.make.state
|
||||
.nse_depinfo
|
||||
*~
|
||||
\#*
|
||||
.#*
|
||||
,*
|
||||
_$*
|
||||
*$
|
||||
*.old
|
||||
*.bak
|
||||
*.BAK
|
||||
*.orig
|
||||
*.rej
|
||||
.del-*
|
||||
*.a
|
||||
*.olb
|
||||
*.o
|
||||
*.obj
|
||||
*.so
|
||||
*.exe
|
||||
*.Z
|
||||
*.elc
|
||||
*.ln
|
||||
core
|
||||
# CVS default ignores end
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
SCX=@SCX@
|
||||
ORION-WM=orion-wm
|
||||
|
||||
$(ORION-WM): Makefile
|
||||
script=$(ORION-WM) && \
|
||||
echo '#!$(SCX) \\' > $$script && \
|
||||
echo "-lm `pwd`/src/packages.scm -m main -s" >> $$script && \
|
||||
echo '!#' >> $$script && \
|
||||
echo '(start)' >> $$script && \
|
||||
chmod 755 $$script
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
AC_INIT
|
||||
AC_PATH_PROG(SCX, scx, /usr/local/bin/scx)
|
||||
|
||||
AC_OUTPUT(Makefile)
|
||||
|
||||
|
|
@ -0,0 +1,134 @@
|
|||
;; *** the draw window ***********************************************
|
||||
|
||||
(define-record-type drag-window :drag-window
|
||||
(make-drag-window dpy window)
|
||||
drag-window?
|
||||
(dpy dw:dpy)
|
||||
(window dw:window))
|
||||
|
||||
(define (create-drag-window dpy dwindow)
|
||||
(let* ((width (window-width dpy dwindow))
|
||||
(height (window-height dpy dwindow))
|
||||
(pixmap (create-pixmap dpy dwindow width height
|
||||
(window-depth dpy dwindow)))
|
||||
(gc (create-gc dpy pixmap
|
||||
(make-gc-value-alist
|
||||
(graphics-exposures #t)
|
||||
(background (black-pixel dpy))
|
||||
(foreground (white-pixel dpy))
|
||||
(subwindow-mode (subwindow-mode include-inferiors)))))
|
||||
)
|
||||
(copy-area dpy dwindow pixmap gc 0 0 width height 0 0)
|
||||
;; TODO: draw X shape over this now.
|
||||
(free-gc dpy gc)
|
||||
(let* ((rect (root-rectangle dpy dwindow))
|
||||
(window (create-simple-window dpy (default-root-window dpy)
|
||||
(rectangle:x rect) (rectangle:y rect)
|
||||
(rectangle:width rect)
|
||||
(rectangle:height rect)
|
||||
0 (black-pixel dpy)
|
||||
(black-pixel dpy)))
|
||||
(gc (create-gc dpy window
|
||||
(make-gc-value-alist
|
||||
(tile pixmap)
|
||||
(fill-style (fill-style tiled))
|
||||
(fill-rule (fill-rule even-odd))))))
|
||||
(set-window-override-redirect! dpy window #t)
|
||||
(spawn* (lambda (release)
|
||||
(call-with-event-channel
|
||||
dpy window (event-mask exposure structure-notify)
|
||||
(lambda (channel)
|
||||
(release)
|
||||
(map-window dpy window)
|
||||
(fill-rectangle dpy window gc 0 0 width height)
|
||||
(let loop ()
|
||||
(let ((xevent (receive channel)))
|
||||
(cond
|
||||
((expose-event? xevent)
|
||||
(if (= (expose-event-count xevent) 0)
|
||||
(fill-rectangle dpy window gc 0 0 width height))
|
||||
(loop))
|
||||
((destroy-window-event? xevent)
|
||||
(free-gc dpy gc)
|
||||
(free-pixmap dpy pixmap))
|
||||
(else (loop)))))))))
|
||||
(make-drag-window dpy window))))
|
||||
|
||||
(define (destroy-drag-window dw)
|
||||
(destroy-window (dw:dpy dw) (dw:window dw)))
|
||||
|
||||
(define (move-drag-window dw x y)
|
||||
(move-window (dw:dpy dw) (dw:window dw) x y))
|
||||
|
||||
;; *** control over the dragging *************************************
|
||||
|
||||
(define (install-dragging-control channel dpy click-window dragged-window)
|
||||
(spawn*
|
||||
(lambda (release)
|
||||
(call-with-event-channel
|
||||
dpy click-window
|
||||
(event-mask button-press button-release
|
||||
button-1-motion structure-notify)
|
||||
(lambda (event-channel)
|
||||
(release)
|
||||
(letrec ((idle
|
||||
(lambda ()
|
||||
(let ((xevent (receive event-channel)))
|
||||
(cond
|
||||
((eq? (event-type button-press)
|
||||
(any-event-type xevent))
|
||||
(trans (button-event-x xevent)
|
||||
(button-event-y xevent)))
|
||||
|
||||
((destroy-window-event? xevent) #t)
|
||||
(else (idle))))))
|
||||
(trans
|
||||
(lambda (click-x click-y)
|
||||
;; if next event is motion-event it's a drag, if
|
||||
;; button-release then it's a click.
|
||||
(let ((xevent (receive event-channel)))
|
||||
(cond
|
||||
((eq? (event-type button-release)
|
||||
(any-event-type xevent))
|
||||
(send channel (list 'click click-x click-y
|
||||
(button-event-time xevent)))
|
||||
(idle))
|
||||
((motion-event? xevent)
|
||||
(let ((r (root-rectangle dpy dragged-window))
|
||||
(dw (create-drag-window dpy
|
||||
dragged-window)))
|
||||
;;(grab-server dpy)
|
||||
(drag dw click-x click-y (rectangle:x r)
|
||||
(rectangle:y r))))
|
||||
((destroy-window-event? xevent) #t)
|
||||
(else (trans click-x click-y))))))
|
||||
|
||||
(drag
|
||||
(lambda (dwin click-x click-y win-x win-y)
|
||||
(let ((xevent (receive event-channel)))
|
||||
(cond
|
||||
((eq? (event-type button-release)
|
||||
(any-event-type xevent))
|
||||
(let ((x (+ (window-x dpy dragged-window)
|
||||
(- (button-event-x xevent)
|
||||
click-x)))
|
||||
(y (+ (window-y dpy dragged-window)
|
||||
(- (button-event-y xevent)
|
||||
click-y))))
|
||||
(destroy-drag-window dwin)
|
||||
(send channel (list 'drop x y))
|
||||
;;(ungrab-server dpy)
|
||||
(idle)))
|
||||
|
||||
((motion-event? xevent)
|
||||
(let ((x (motion-event-x xevent))
|
||||
(y (motion-event-y xevent)))
|
||||
(move-drag-window dwin
|
||||
(+ win-x (- x click-x))
|
||||
(+ win-y (- y click-y)))
|
||||
(drag dwin click-x click-y win-x win-y)))
|
||||
|
||||
((destroy-window-event? xevent) #t)
|
||||
(else
|
||||
(drag dwin click-x click-y win-x win-y)))))))
|
||||
(idle)))))))
|
||||
|
|
@ -0,0 +1,151 @@
|
|||
(define-record-type key-grab :key-grab
|
||||
(make-key-grab window keys message channel override?)
|
||||
key-grab?
|
||||
(window key-grab:window)
|
||||
(keys key-grab:keys)
|
||||
(message key-grab:message)
|
||||
(channel key-grab:channel)
|
||||
(override? key-grab:override?))
|
||||
|
||||
(define (create-grab-server dpy)
|
||||
(let ((in-channel (make-channel)))
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let ((grabs '())
|
||||
(event-cache '()))
|
||||
(let loop ()
|
||||
(let ((msg (receive in-channel)))
|
||||
(case (car msg)
|
||||
((add-key-grab)
|
||||
(let* ((key-grab (second msg))
|
||||
(first (car (key-grab:keys key-grab))))
|
||||
(set! grabs (cons key-grab grabs))
|
||||
(grab-key dpy (key:keycode first)
|
||||
(key:modifiers first) (key-grab:window key-grab)
|
||||
#f (grab-mode async) (grab-mode async))
|
||||
(spawn* (lambda (resume)
|
||||
(call-with-event-channel
|
||||
dpy (key-grab:window key-grab)
|
||||
(event-mask key-press structure-notify)
|
||||
(lambda (event-channel)
|
||||
(resume)
|
||||
(let loop ()
|
||||
(let ((e (receive event-channel)))
|
||||
(cond
|
||||
((destroy-window-event? e)
|
||||
(send in-channel (list 'remove-key-grab
|
||||
key-grab)))
|
||||
((eq? (event-type key-press)
|
||||
(any-event-type e))
|
||||
(send in-channel (list 'key-press e))
|
||||
(loop))
|
||||
(else (loop)))))))))))
|
||||
((remove-key-grab)
|
||||
(let* ((key-grab (second msg))
|
||||
(first (car (key-grab:keys key-grab))))
|
||||
(if (window-exists? dpy (key-grab:window key-grab))
|
||||
(ungrab-key dpy (key:keycode first)
|
||||
(key:modifiers first)
|
||||
(key-grab:window key-grab)))
|
||||
(set! grabs (filter (lambda (g) (not (eq? g key-grab)))
|
||||
grabs))))
|
||||
((key-press)
|
||||
(let ((e (second msg))
|
||||
(events (filter (lambda (x) x)
|
||||
(map weak-pointer-ref event-cache))))
|
||||
;; because more of these can come in a row, we
|
||||
;; skip the ones already handled.
|
||||
(if (memq e events)
|
||||
#f
|
||||
(begin
|
||||
(set! event-cache
|
||||
(map make-weak-pointer (cons e events)))
|
||||
(let ((winner (do-grabs dpy grabs e)))
|
||||
(if winner
|
||||
(send (key-grab:channel winner)
|
||||
(list (key-grab:message winner)
|
||||
;; this event ??
|
||||
(key-event-time e)))))))))
|
||||
))
|
||||
(loop)))))
|
||||
in-channel))
|
||||
|
||||
(define *grab-server* #f)
|
||||
(define *grab-server-lock* (make-lock))
|
||||
|
||||
(define (grab-shortcut dpy window keys message channel override?)
|
||||
;; assert |keys| > 0 ??
|
||||
(with-lock *grab-server-lock*
|
||||
(lambda ()
|
||||
(if (not *grab-server*)
|
||||
(set! *grab-server* (create-grab-server dpy)))))
|
||||
(let ((key-grab (make-key-grab window keys message channel override?)))
|
||||
(send *grab-server* (list 'add-key-grab key-grab))
|
||||
key-grab))
|
||||
|
||||
;; unregister-key ??
|
||||
|
||||
(define (do-grabs dpy grabs event)
|
||||
(let* ((path (reverse (window-path dpy (get-input-focus-window dpy))))
|
||||
(grabs (flatten
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map (lambda (win)
|
||||
(filter
|
||||
(lambda (grab)
|
||||
(let ((first (car (key-grab:keys grab))))
|
||||
(and (equal? win (key-grab:window grab))
|
||||
(enum-set=? (key:modifiers first)
|
||||
(key-event-state event))
|
||||
(equal? (key:keycode first)
|
||||
(key-event-keycode event)))))
|
||||
grabs))
|
||||
path))))
|
||||
(grabs-rests (map (lambda (g)
|
||||
(cons g (cdr (key-grab:keys g))))
|
||||
grabs))
|
||||
(winner? (lambda (grabs-rests)
|
||||
(let ((dones (map car (filter (lambda (grab-rest)
|
||||
(null? (cdr grab-rest)))
|
||||
grabs-rests))))
|
||||
(mdisplay "winner? dones: " dones "\n")
|
||||
(let loop ((dones dones))
|
||||
(if (null? dones)
|
||||
#f
|
||||
(if (or (null? (cdr dones))
|
||||
(key-grab:override? (car dones)))
|
||||
(car dones)
|
||||
(loop (cdr dones)))))))))
|
||||
(grab-keyboard dpy (default-root-window dpy) #f
|
||||
(grab-mode async) (grab-mode async) ;; ??
|
||||
(key-event-time event))
|
||||
;; Cursor ?
|
||||
(let ((result
|
||||
(call-with-event-channel
|
||||
dpy (default-root-window dpy) (event-mask key-press)
|
||||
(lambda (event-channel)
|
||||
(let loop ((grabs-rests grabs-rests))
|
||||
(mdisplay "grabs-rests: " grabs-rests "\n")
|
||||
(and (not (null? grabs-rests))
|
||||
(or (winner? grabs-rests)
|
||||
(let ((e (receive event-channel)))
|
||||
(cond
|
||||
((eq? (event-type key-press)
|
||||
(any-event-type e))
|
||||
(let ((rest
|
||||
(filter
|
||||
(lambda (grab-rest)
|
||||
(and (not (null? (cdr grab-rest)))
|
||||
(let ((next (car (cdr grab-rest))))
|
||||
(enum-set=? (key:modifiers next)
|
||||
(key-event-state e))
|
||||
(equal? (key:keycode next)
|
||||
(key-event-keycode e)))))
|
||||
grabs-rests)))
|
||||
(loop (map (lambda (grab-rest)
|
||||
(cons (car grab-rest)
|
||||
(cdr (cdr grab-rest))))
|
||||
rest))))
|
||||
(else (loop grabs-rests)))))))))))
|
||||
(ungrab-keyboard dpy current-time)
|
||||
result)))
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
(define (start)
|
||||
(apply orion-wm (command-line)))
|
||||
|
||||
(define (orion-wm . args)
|
||||
(let ((dpy (open-display)))
|
||||
(synchronize dpy #t)
|
||||
(init-sync-x-events dpy)
|
||||
;; for debugging:
|
||||
(spawn (lambda ()
|
||||
(let loop ((se (most-recent-sync-x-event)))
|
||||
(let ((e (sync-x-event-event se)))
|
||||
(if (not (eq? e 'no-event))
|
||||
(display-event e))
|
||||
(loop (next-sync-x-event se (lambda (e) #t)))))))
|
||||
|
||||
(let ((root-manager (create-root-wm dpy)))
|
||||
(display "Orion-wm finished\n"))))
|
||||
|
||||
(define (display-event e)
|
||||
;;(mdisplay "event: " (any-event-type e) " " (any-event-window e) "\n"))
|
||||
#t)
|
||||
|
|
@ -0,0 +1,358 @@
|
|||
(define-record-type wm :wm
|
||||
(make-wm type in-channel out-channel internal-out-channel
|
||||
dpy window colormap options
|
||||
clients current-client)
|
||||
wm?
|
||||
(type wm:type)
|
||||
(in-channel wm:in-channel)
|
||||
(out-channel wm:out-channel)
|
||||
(internal-out-channel wm:internal-out-channel)
|
||||
(dpy wm:dpy)
|
||||
(window wm:window)
|
||||
(colormap wm:colormap)
|
||||
(options wm:options)
|
||||
(clients wm:clients set-wm:clients!)
|
||||
(current-client wm:current-client set-wm:current-client!))
|
||||
|
||||
(define wm-clients wm:clients)
|
||||
(define wm-current-client wm:current-client)
|
||||
|
||||
(define-enumerated-type manager-type :manager-type
|
||||
manager-type? manager-types manager-type-name manager-type-index
|
||||
(split switch move))
|
||||
|
||||
(define (manager-name type)
|
||||
(cond
|
||||
((eq? type (manager-type split)) "split-wm")
|
||||
((eq? type (manager-type switch)) "switch-wm")
|
||||
((eq? type (manager-type move)) "move-wm")))
|
||||
|
||||
(define focus-policy '(enter click)) ;; TODO: -> options
|
||||
|
||||
(define (create-wm dpy parent options children
|
||||
type options-spec out-channel fun)
|
||||
(let* ((wa (get-window-attributes dpy parent))
|
||||
(main-window
|
||||
(create-simple-window dpy parent 0 0 (window-attribute:width wa)
|
||||
(window-attribute:height wa)
|
||||
0 (white-pixel dpy) (black-pixel dpy)))
|
||||
(colormap (create-colormap dpy main-window
|
||||
(window-attribute:visual wa)
|
||||
(colormap-alloc none)))
|
||||
(in-channel (make-channel))
|
||||
(internal-out-channel (make-channel))
|
||||
(wm (make-wm type in-channel out-channel internal-out-channel
|
||||
dpy main-window colormap
|
||||
(create-options dpy colormap options-spec options)
|
||||
'() #f)))
|
||||
|
||||
;; set properties ************************************************
|
||||
(set-wm-name! dpy main-window
|
||||
(string-list->property (list (manager-name type))))
|
||||
;; icon ??
|
||||
;; size-hints ??
|
||||
(set-wm-hints! dpy main-window
|
||||
(make-wm-hint-alist (input? #t)))
|
||||
;; class-hint ??
|
||||
(set-wm-protocols! dpy main-window
|
||||
(list (intern-atom dpy "WM_TAKE_FOCUS" #t)))
|
||||
;; TODO: Colormaps
|
||||
|
||||
;; spawn handlers ************************************************
|
||||
(spawn* (lambda (release)
|
||||
(call-with-event-channel
|
||||
(wm:dpy wm) (wm:window wm)
|
||||
(event-mask structure-notify
|
||||
enter-window
|
||||
focus-change
|
||||
exposure)
|
||||
(lambda (event-channel)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(release)
|
||||
(send internal-out-channel '(fit-windows)) ;; ??
|
||||
(let loop ()
|
||||
(select*
|
||||
(wrap (receive-rv event-channel)
|
||||
(lambda (xevent)
|
||||
(handle-xevent wm exit xevent)))
|
||||
(wrap (receive-rv (wm:in-channel wm))
|
||||
(lambda (msg)
|
||||
(handle-external-message wm exit msg))))
|
||||
(loop))))))
|
||||
(free-colormap dpy colormap)))
|
||||
|
||||
(for-each (lambda (window)
|
||||
(wm-manage-window wm window))
|
||||
children)
|
||||
(fun wm internal-out-channel)))
|
||||
|
||||
(define (handle-xevent wm exit xevent)
|
||||
(let ((main-window (wm:window wm))
|
||||
(dpy (wm:dpy wm))
|
||||
(internal-out-channel (wm:internal-out-channel wm))
|
||||
(type (any-event-type xevent)))
|
||||
(cond
|
||||
((expose-event? xevent)
|
||||
(send internal-out-channel '(draw-main-window)))
|
||||
|
||||
((configure-event? xevent)
|
||||
(send internal-out-channel '(fit-windows)))
|
||||
|
||||
;; the manager got the focus (as a client)
|
||||
((client-message-event? xevent)
|
||||
(let* ((p (client-message-event-property xevent))
|
||||
(type (property:type p)))
|
||||
(if (equal? type (intern-atom dpy "WM_PROTOCOLS" #t))
|
||||
(let ((name (car (property:data p)))
|
||||
(time (cadr (property:data p)))
|
||||
(client (wm:current-client wm)))
|
||||
(if (and client
|
||||
(equal? name (intern-atom dpy "WM_TAKE_FOCUS" #t)))
|
||||
(handle-external-message wm exit
|
||||
(list 'select-client client time)))
|
||||
))))
|
||||
|
||||
)))
|
||||
|
||||
(define (handle-external-message wm exit msg)
|
||||
(let ((internal-out-channel (wm:internal-out-channel wm))
|
||||
(dpy (wm:dpy wm)))
|
||||
(case (car msg)
|
||||
((manage-window)
|
||||
(let* ((window (second msg))
|
||||
(client (create-client wm window)))
|
||||
(set-wm:clients! wm (cons client (wm:clients wm)))
|
||||
(send internal-out-channel
|
||||
(list 'init-client client (third msg)))
|
||||
(send internal-out-channel (list 'fit-client client))
|
||||
;; sync ??
|
||||
(map-window dpy window)
|
||||
(send internal-out-channel (list 'update-client-state client))))
|
||||
|
||||
((unmanage-window)
|
||||
(let* ((window (second msg))
|
||||
(client (find (lambda (c)
|
||||
(eq? window (client:window c)))
|
||||
(wm:clients wm))))
|
||||
(if client
|
||||
(begin
|
||||
(reparent-to-root dpy window)
|
||||
(handle-external-message wm exit
|
||||
(list 'deinit-client client))))))
|
||||
|
||||
((destroy-manager)
|
||||
;; (send internal-out-channel '(deinit-manager))
|
||||
;; sync ??
|
||||
(destroy-window dpy (wm:window wm)))
|
||||
|
||||
((deinit-client)
|
||||
(let ((client (second msg)))
|
||||
(set-wm:clients! wm (filter (lambda (c) (not (eq? c client)))
|
||||
(wm:clients wm)))
|
||||
(if (eq? (wm:current-client wm) client)
|
||||
(set-wm:current-client! wm #f)) ;; select another ??
|
||||
(send (wm:internal-out-channel wm) (list 'deinit-client client))
|
||||
;; sync ??
|
||||
(destroy-window dpy (client:client-window client))))
|
||||
|
||||
((select-client)
|
||||
(let ((client (second msg))
|
||||
(time (third msg)))
|
||||
(set-wm:current-client! wm client)
|
||||
(raise-window dpy (client:client-window client))
|
||||
(take-focus dpy (client:window client) time)
|
||||
; (for-each (lambda (c)
|
||||
; (if (not (eq? c client))
|
||||
; (grab-button dpy
|
||||
; (button button1) (state-set)
|
||||
; (client:client-window c) #f
|
||||
; (event-mask button-press)
|
||||
; (grab-mode async) (grab-mode async)
|
||||
; none none)))
|
||||
; (wm:clients wm))
|
||||
))
|
||||
|
||||
)))
|
||||
|
||||
(define (wm-deinit-client wm client)
|
||||
(mdisplay "manager deinit-client\n")
|
||||
(send (wm:in-channel wm) (list 'deinit-client client)))
|
||||
|
||||
;; *** external messages *********************************************
|
||||
|
||||
(define (wm-manage-window wm window . rect)
|
||||
(send (wm:in-channel wm)
|
||||
(list 'manage-window window
|
||||
(if (null? rect)
|
||||
#f
|
||||
(car rect))))
|
||||
;; sync ??
|
||||
)
|
||||
|
||||
(define (wm-unmanage-window wm window)
|
||||
(send (wm:in-channel wm) (list 'unmanage-window window)))
|
||||
|
||||
(define (wm-select-client wm client time)
|
||||
(send (wm:in-channel wm) (list 'select-client client time)))
|
||||
|
||||
(define (destroy-wm wm)
|
||||
(send (wm:in-channel wm) '(destroy-manager)))
|
||||
|
||||
(define (send-root-drop wm window x y)
|
||||
(send (wm:out-channel wm) (list 'root-drop window x y)))
|
||||
|
||||
;; *** client ********************************************************
|
||||
|
||||
(define-record-type client :client
|
||||
(make-client window client-window data)
|
||||
client?
|
||||
(window client:window)
|
||||
(client-window client:client-window)
|
||||
(data client:data set-client:data!))
|
||||
|
||||
(define (create-client wm window)
|
||||
(mdisplay "creating client for " window "\n")
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(client-window (create-simple-window dpy (wm:window wm)
|
||||
0 0
|
||||
(window-width dpy window)
|
||||
(window-height dpy window)
|
||||
0
|
||||
(white-pixel dpy)
|
||||
(black-pixel dpy)))
|
||||
(client (make-client window client-window #f)))
|
||||
(reparent-window dpy window client-window 0 0)
|
||||
(create-client-handler wm client)
|
||||
client))
|
||||
|
||||
(define (create-client-handler wm client)
|
||||
(spawn*
|
||||
(lambda (release)
|
||||
(call-with-event-channel
|
||||
(wm:dpy wm) (client:client-window client)
|
||||
(event-mask exposure
|
||||
enter-window
|
||||
button-press
|
||||
structure-notify
|
||||
focus-change)
|
||||
(lambda (client-window-channel)
|
||||
(call-with-event-channel
|
||||
(wm:dpy wm) (client:window client)
|
||||
(event-mask property-change
|
||||
structure-notify)
|
||||
(lambda (client-channel)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(release)
|
||||
(let loop ()
|
||||
(select*
|
||||
(wrap (receive-rv client-window-channel)
|
||||
(lambda (xevent)
|
||||
(handle-client-window-xevent wm exit client xevent)))
|
||||
(wrap (receive-rv client-channel)
|
||||
(lambda (xevent)
|
||||
(handle-client-xevent wm exit client xevent))))
|
||||
(loop)))))))))))
|
||||
|
||||
(define (handle-client-window-xevent wm exit client xevent)
|
||||
(let ((type (any-event-type xevent))
|
||||
(internal-out-channel (wm:internal-out-channel wm))
|
||||
(dpy (wm:dpy wm)))
|
||||
(cond
|
||||
((expose-event? xevent)
|
||||
(send internal-out-channel
|
||||
(list 'draw-client-window client)))
|
||||
((configure-event? xevent)
|
||||
(send internal-out-channel
|
||||
(list 'fit-client client)))
|
||||
((or (focus-change-event? xevent) (circulate-event? xevent))
|
||||
;; TODO: look at mode? or maybe only look at focus-in of the
|
||||
;; client, because the client-window never gets the focus
|
||||
;; anyway.
|
||||
(if (window-exists? dpy (client:window client)) ;; TODO: not perfect
|
||||
(send internal-out-channel
|
||||
(list 'update-client-state client))))
|
||||
|
||||
((eq? (event-type enter-notify) type)
|
||||
(if (memq 'enter focus-policy)
|
||||
(wm-select-client wm client (crossing-event-time xevent))))
|
||||
|
||||
((eq? (event-type button-press) type)
|
||||
(if (memq 'click focus-policy)
|
||||
(wm-select-client wm client (button-event-time xevent))))
|
||||
|
||||
((destroy-window-event? xevent)
|
||||
(mdisplay "client-window destroyed\n")
|
||||
(exit)))))
|
||||
|
||||
(define (handle-client-xevent wm exit client xevent)
|
||||
(let ((type (any-event-type xevent))
|
||||
(internal-out-channel (wm:internal-out-channel wm))
|
||||
(dpy (wm:dpy wm)))
|
||||
(cond
|
||||
((property-event? xevent)
|
||||
(let ((name (get-atom-name (property-event-display xevent)
|
||||
(property-event-atom xevent))))
|
||||
(cond
|
||||
((equal? "WM_NAME" name)
|
||||
(send internal-out-channel
|
||||
(list 'update-client-state client)))
|
||||
;; TODO: respect NORMAL_HINTS change
|
||||
)))
|
||||
((configure-event? xevent)
|
||||
;; TODO: we have to prevent this event if changed the size on our own.
|
||||
;; --> XReconfigureWMWindow ??
|
||||
;;(send internal-out-channel (list 'fit-client-window client))
|
||||
#t)
|
||||
((reparent-event? xevent) #t)
|
||||
; (if (or (not (window-exists? dpy (client:window client)))
|
||||
; (not (eq? (client:client-window client)
|
||||
; (window-parent dpy (client:window client)))))
|
||||
; (begin
|
||||
; (mdisplay "manager " (wm:type wm) " reparented client\n")
|
||||
; (wm-deinit-client wm client)
|
||||
; (exit)))
|
||||
;; TODO: withdrawn-state etc.
|
||||
((destroy-window-event? xevent)
|
||||
(mdisplay "destroy-window client\n")
|
||||
(wm-deinit-client wm client)
|
||||
(exit))
|
||||
)))
|
||||
|
||||
;; *** client names **************************************************
|
||||
|
||||
(define client-name
|
||||
(let ((names '()) ;; (window oname name)
|
||||
(lock (make-lock)))
|
||||
(lambda (dpy client)
|
||||
(let* ((w (client:window client))
|
||||
(cname (let* ((p (get-wm-name dpy w))
|
||||
(l (if p (property->string-list p) '())))
|
||||
(if (null? l)
|
||||
"<untitled>"
|
||||
(car l)))))
|
||||
(with-lock lock
|
||||
(lambda ()
|
||||
(let ((name? (let ((p (assq w names)))
|
||||
(and p (equal? (cadr p) cname)
|
||||
(caddr p)))))
|
||||
(set! names
|
||||
(filter (lambda (e)
|
||||
(and (not (eq? (car e) w))
|
||||
(window-exists? dpy (car e))))
|
||||
names))
|
||||
(let ((name (if name? name?
|
||||
(unique-name cname
|
||||
(map caddr names)))))
|
||||
(set! names (cons (list w cname name) names))
|
||||
name))))))))
|
||||
|
||||
(define (unique-name name names)
|
||||
(if (not (member name names))
|
||||
name
|
||||
(let loop ((i 1))
|
||||
(let ((n (string-append name "<" (number->string i) ">")))
|
||||
(if (member n names)
|
||||
(loop (+ i 1))
|
||||
n)))))
|
||||
|
|
@ -0,0 +1,223 @@
|
|||
;; TODO: -> options ??
|
||||
(define default-cursor xc-X-cursor)
|
||||
(define frame-size 3)
|
||||
|
||||
(define (create-resizer wm client)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(window (client:client-window client))
|
||||
(gc (create-gc dpy (default-root-window dpy)
|
||||
(make-gc-value-alist
|
||||
(foreground (white-pixel dpy))
|
||||
(subwindow-mode (subwindow-mode include-inferiors))
|
||||
(line-width frame-size)
|
||||
(function (gc-function xor)))))
|
||||
(cursors
|
||||
(map (lambda (dir id)
|
||||
(cons dir (create-font-cursor dpy id)))
|
||||
'(west north-west north north-east east south-east south
|
||||
south-west none)
|
||||
(list xc-left-side xc-top-left-corner xc-top-side
|
||||
xc-top-right-corner xc-right-side xc-bottom-right-corner
|
||||
xc-bottom-side xc-bottom-left-corner default-cursor))))
|
||||
|
||||
(spawn*
|
||||
(lambda (release)
|
||||
(call-with-event-channel
|
||||
dpy window
|
||||
(event-mask structure-notify
|
||||
button-press button-release
|
||||
pointer-motion)
|
||||
(lambda (event-channel)
|
||||
(release)
|
||||
(letrec
|
||||
((idle
|
||||
(lambda ()
|
||||
(let ((xevent (receive event-channel)))
|
||||
(cond
|
||||
((motion-event? xevent)
|
||||
(set-resize-cursor wm client cursors
|
||||
(motion-event-x xevent)
|
||||
(motion-event-y xevent))
|
||||
(idle))
|
||||
((eq? (event-type button-press)
|
||||
(any-event-type xevent))
|
||||
(let* ((x (button-event-x xevent))
|
||||
(y (button-event-y xevent))
|
||||
(dir (resizer-direction wm client x y)))
|
||||
(if (eq? dir 'none)
|
||||
(idle)
|
||||
(let ((r (root-rectangle dpy window)))
|
||||
(grab-server dpy)
|
||||
(rubber-draw dpy gc r)
|
||||
(drag x y r r dir)))))
|
||||
((destroy-window-event? xevent) #t)
|
||||
(else (idle))))))
|
||||
|
||||
(drag
|
||||
(lambda (start-x start-y start-r prev-rect dir)
|
||||
(let ((xevent (receive event-channel)))
|
||||
(cond
|
||||
((motion-event? xevent)
|
||||
(let ((new-rect
|
||||
(adjust-rect wm client start-r
|
||||
(- (motion-event-x xevent) start-x)
|
||||
(- (motion-event-y xevent) start-y)
|
||||
dir)))
|
||||
(rubber-draw dpy gc prev-rect)
|
||||
(rubber-draw dpy gc new-rect)
|
||||
(drag start-x start-y start-r new-rect dir)))
|
||||
((eq? (event-type button-release)
|
||||
(any-event-type xevent))
|
||||
(rubber-draw dpy gc prev-rect)
|
||||
(ungrab-server dpy)
|
||||
(commit-resize wm client
|
||||
(- (button-event-x xevent) start-x)
|
||||
(- (button-event-y xevent) start-y)
|
||||
dir)
|
||||
(idle))
|
||||
((destroy-window-event? xevent) #t)
|
||||
(else (drag start-x start-y start-r
|
||||
prev-rect dir)))))))
|
||||
(idle))))
|
||||
(free-gc dpy gc)
|
||||
(for-each (lambda (c) (free-cursor dpy (cdr c))) cursors)))))
|
||||
|
||||
(define (rubber-draw dpy gc rect)
|
||||
(draw-rectangle dpy (default-root-window dpy) gc
|
||||
(rectangle:x rect) (rectangle:y rect)
|
||||
(rectangle:width rect) (rectangle:height rect)))
|
||||
|
||||
(define (adjust-rect wm client sr dx dy dir)
|
||||
(let* ((r
|
||||
(case dir
|
||||
((west)
|
||||
(make-rectangle (+ (rectangle:x sr) dx)
|
||||
(rectangle:y sr)
|
||||
(- (rectangle:width sr) dx)
|
||||
(rectangle:height sr)))
|
||||
((north-west)
|
||||
(make-rectangle (+ (rectangle:x sr) dx)
|
||||
(+ (rectangle:y sr) dy)
|
||||
(- (rectangle:width sr) dx)
|
||||
(- (rectangle:height sr) dy)))
|
||||
((north)
|
||||
(make-rectangle (rectangle:x sr)
|
||||
(+ (rectangle:y sr) dy)
|
||||
(rectangle:width sr)
|
||||
(- (rectangle:height sr) dy)))
|
||||
((north-east)
|
||||
(make-rectangle (rectangle:x sr)
|
||||
(+ (rectangle:y sr) dy)
|
||||
(+ (rectangle:width sr) dx)
|
||||
(- (rectangle:height sr) dy)))
|
||||
((east)
|
||||
(make-rectangle (rectangle:x sr)
|
||||
(rectangle:y sr)
|
||||
(+ (rectangle:width sr) dx)
|
||||
(rectangle:height sr)))
|
||||
((south-east)
|
||||
(make-rectangle (rectangle:x sr)
|
||||
(rectangle:y sr)
|
||||
(+ (rectangle:width sr) dx)
|
||||
(+ (rectangle:height sr) dy)))
|
||||
((south)
|
||||
(make-rectangle (rectangle:x sr)
|
||||
(rectangle:y sr)
|
||||
(rectangle:width sr)
|
||||
(+ (rectangle:height sr) dy)))
|
||||
((south-west)
|
||||
(make-rectangle (+ (rectangle:x sr) dx)
|
||||
(rectangle:y sr)
|
||||
(- (rectangle:width sr) dx)
|
||||
(+ (rectangle:height sr) dy)))
|
||||
(else sr)))
|
||||
(w.h (maximal-size/hints (wm:dpy wm) (client:window client)
|
||||
(rectangle:width r) (rectangle:height r))))
|
||||
(set-rectangle:width! r (car w.h))
|
||||
(set-rectangle:height! r (cdr w.h))
|
||||
r))
|
||||
|
||||
(define (commit-resize wm client dx dy dir)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(win (client:client-window client))
|
||||
(sr (window-rectangle dpy win))
|
||||
(rect (adjust-rect wm client sr dx dy dir)))
|
||||
(move-resize-window dpy win
|
||||
(rectangle:x rect)
|
||||
(rectangle:y rect)
|
||||
(rectangle:width rect)
|
||||
(rectangle:height rect))))
|
||||
|
||||
(define (set-resize-cursor wm client cursors x y)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(c (assq (resizer-direction wm client x y) cursors)))
|
||||
(if c
|
||||
(define-cursor dpy (client:client-window client) (cdr c)))))
|
||||
|
||||
(define (resizer-direction wm client x y)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(win (client:client-window client))
|
||||
(width (window-width dpy win))
|
||||
(height (window-height dpy win))
|
||||
(corner-size (get-option (wm:options wm) 'corner-width))
|
||||
(fc-size (+ frame-size corner-size)))
|
||||
(let ((region-alist
|
||||
(list (cons 'west
|
||||
(list (make-rectangle 0 fc-size frame-size
|
||||
(- height (* 2 fc-size)))))
|
||||
(cons 'north-west
|
||||
(list (make-rectangle 0 frame-size frame-size
|
||||
corner-size)
|
||||
(make-rectangle 0 0 frame-size frame-size)
|
||||
(make-rectangle frame-size 0 corner-size
|
||||
frame-size)))
|
||||
(cons 'north
|
||||
(list (make-rectangle fc-size 0 (- width (* 2 fc-size))
|
||||
frame-size)))
|
||||
(cons 'north-east
|
||||
(list (make-rectangle (- width fc-size) 0 corner-size
|
||||
frame-size)
|
||||
(make-rectangle (- width frame-size) 0
|
||||
frame-size frame-size)
|
||||
(make-rectangle (- width frame-size) frame-size
|
||||
frame-size corner-size)))
|
||||
(cons 'east
|
||||
(list (make-rectangle (- width frame-size) fc-size
|
||||
frame-size
|
||||
(- height (* 2 fc-size)))))
|
||||
(cons 'south-east
|
||||
(list (make-rectangle (- width frame-size)
|
||||
(- height fc-size) frame-size
|
||||
corner-size)
|
||||
(make-rectangle (- width frame-size)
|
||||
(- height frame-size)
|
||||
frame-size frame-size)
|
||||
(make-rectangle (- width fc-size)
|
||||
(- height frame-size)
|
||||
corner-size frame-size)))
|
||||
(cons 'south
|
||||
(list (make-rectangle fc-size (- height frame-size)
|
||||
(- width (* 2 fc-size))
|
||||
frame-size)))
|
||||
(cons 'south-west
|
||||
(list (make-rectangle frame-size
|
||||
(- height frame-size) corner-size
|
||||
frame-size)
|
||||
(make-rectangle 0 (- width frame-size)
|
||||
frame-size frame-size)
|
||||
(make-rectangle 0 (- height fc-size)
|
||||
frame-size corner-size))))))
|
||||
(let ((matches (filter (lambda (d.rs)
|
||||
(any (lambda (r)
|
||||
(point-in-rectangle? r x y))
|
||||
(cdr d.rs)))
|
||||
region-alist)))
|
||||
(if (null? matches)
|
||||
'none
|
||||
(car (car matches)))))))
|
||||
|
||||
(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)))))
|
||||
|
|
@ -0,0 +1,198 @@
|
|||
(define-options-spec move-wm-options-spec
|
||||
(titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
|
||||
(titlebar-colors-active colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
|
||||
(titlebar-height int 18)
|
||||
(titlebar-style symbol 'flat)
|
||||
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
||||
(border-width int 3)
|
||||
(corner-width int 10)
|
||||
(border-style symbol 'raised) ;; raised | sunken | flat
|
||||
(border-colors colors '("#333333" "#dddddd"))
|
||||
(kill-client keys "M-c")
|
||||
)
|
||||
|
||||
(define (create-move-wm out-channel dpy parent options . children)
|
||||
(create-wm dpy parent options children
|
||||
(manager-type move) move-wm-options-spec
|
||||
out-channel
|
||||
(lambda (wm in-channel)
|
||||
(spawn (lambda ()
|
||||
(move-wm-handler wm in-channel)))
|
||||
wm)))
|
||||
|
||||
(define (move-wm-handler wm channel)
|
||||
(let ((gc (create-gc (wm:dpy wm) (wm:window wm) '())))
|
||||
(let loop ()
|
||||
(let ((msg (receive channel)))
|
||||
(case (car msg)
|
||||
((draw-main-window) #t)
|
||||
|
||||
((fit-windows)
|
||||
(map (lambda (client)
|
||||
(assert-client-visible wm client))
|
||||
(wm-clients wm)))
|
||||
|
||||
((init-client)
|
||||
(init-client wm (second msg) (third msg)))
|
||||
((deinit-client)
|
||||
(deinit-client wm (second msg)))
|
||||
|
||||
((draw-client-window)
|
||||
(draw-client-window wm (second msg) gc))
|
||||
((fit-client)
|
||||
;; client-window changed it's size
|
||||
(fit-client-windows wm (second msg)))
|
||||
|
||||
((fit-client-window)
|
||||
;; client changed it's size ??
|
||||
(fit-client-window wm (second msg)))
|
||||
|
||||
((update-client-state)
|
||||
(let* ((client (second msg))
|
||||
(dpy (wm:dpy wm))
|
||||
(window (client:window client))
|
||||
(state (if (window-contains-focus? dpy window)
|
||||
'active
|
||||
'normal))
|
||||
(titlebar (car (client:data client)))
|
||||
(name (client-name (wm:dpy wm) client)))
|
||||
(set-titlebar-state! titlebar state)
|
||||
(set-titlebar-title! titlebar name)))
|
||||
))
|
||||
(loop))
|
||||
(free-gc (wm:dpy wm) gc)))
|
||||
|
||||
(define (init-client wm client maybe-rect)
|
||||
(let ((dpy (wm:dpy wm)))
|
||||
(set-window-border-width! dpy (client:window client) 0)
|
||||
(let* ((r (initial-client-rect wm (client:window client) maybe-rect))
|
||||
(channel (make-channel))
|
||||
(titlebar (create-client-titlebar channel wm client))
|
||||
(resizer (create-resizer wm client))
|
||||
(options (wm:options wm)))
|
||||
(set-client:data! client (list titlebar resizer))
|
||||
(move-resize-window dpy (client:client-window client)
|
||||
(rectangle:x r) (rectangle:y r)
|
||||
(rectangle:width r) (rectangle:height r))
|
||||
(fit-client-windows wm client)
|
||||
|
||||
(install-dragging-control channel dpy
|
||||
(titlebar:window titlebar)
|
||||
(client:client-window client))
|
||||
(grab-shortcut dpy (client:client-window client)
|
||||
(get-option-value options 'kill-client)
|
||||
'kill-client channel #f) ;; -> manager.scm ??
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(select*
|
||||
(wrap (receive-rv channel)
|
||||
(lambda (msg)
|
||||
(case (car msg)
|
||||
((drop)
|
||||
;; TODO: check if outside...
|
||||
(move-window dpy (client:client-window client)
|
||||
(second msg) (third msg)))
|
||||
((kill-client)
|
||||
(let ((time (second msg)))
|
||||
(delete-window dpy (client:window client) time)))))))
|
||||
;; TODO: internal channel
|
||||
(loop))))
|
||||
|
||||
(map-titlebar titlebar)
|
||||
(map-window dpy (client:client-window client))
|
||||
;;(select-client wm client))) ??
|
||||
)))
|
||||
|
||||
(define (create-client-titlebar channel wm client)
|
||||
(let ((options (wm:options wm)))
|
||||
(create-titlebar channel (wm:dpy wm) (client:client-window client)
|
||||
(wm:colormap wm)
|
||||
;; TODO: buttons
|
||||
(list (cons 'normal-colors
|
||||
(get-option options 'titlebar-colors))
|
||||
(cons 'active-colors
|
||||
(get-option options'titlebar-colors-active))
|
||||
(cons 'focused-colors
|
||||
(get-option options 'titlebar-colors-active))
|
||||
(cons 'border-style
|
||||
(get-option options 'titlebar-style))))))
|
||||
|
||||
(define (deinit-client wm client)
|
||||
(let ((dpy (wm:dpy wm)))
|
||||
#t))
|
||||
|
||||
;; ***
|
||||
|
||||
(define (fit-client-windows wm client)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(options (wm:options wm))
|
||||
(border-width (get-option-value options 'border-width))
|
||||
(titlebar-height (get-option-value options 'titlebar-height))
|
||||
(wa (get-window-attributes dpy (client:client-window client))))
|
||||
;; TODO: is called much too often
|
||||
(move-resize-window dpy (client:window client)
|
||||
border-width
|
||||
(+ border-width titlebar-height)
|
||||
(- (window-attribute:width wa) (* 2 border-width))
|
||||
(- (window-attribute:height wa)
|
||||
(+ (* 2 border-width) titlebar-height)))
|
||||
|
||||
(move-resize-titlebar
|
||||
(car (client:data client))
|
||||
(make-rectangle border-width border-width
|
||||
(- (window-attribute:width wa) (* 2 border-width))
|
||||
titlebar-height))))
|
||||
|
||||
(define (fit-client-window wm client)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(options (wm:options wm))
|
||||
(border-width (get-option-value options 'border-width))
|
||||
(titlebar-height (get-option-value options 'titlebar-height))
|
||||
(wa (get-window-attributes dpy (client:window client))))
|
||||
(resize-window dpy (client:client-window client)
|
||||
(+ (window-attribute:width wa) (* 2 border-width))
|
||||
(+ (window-attribute:height wa)
|
||||
(* 2 border-width)
|
||||
titlebar-height))))
|
||||
|
||||
(define (assert-client-visible wm client)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(win (client:client-window client))
|
||||
(x (window-x dpy win))
|
||||
(y (window-y dpy win)))
|
||||
#t)) ;; ... TODO
|
||||
|
||||
(define (draw-client-window wm client gc)
|
||||
(let* ((options (wm:options wm))
|
||||
(colors (get-option-value options 'border-colors))
|
||||
(window (client:client-window client))
|
||||
(dpy (wm:dpy wm))
|
||||
(border-style (get-option-value options 'border-style))
|
||||
(border-width (get-option-value options 'border-width))
|
||||
(clip-rect (clip-rectangle dpy window)))
|
||||
(if (not (eq? border-style 'flat))
|
||||
(let ((light (if (eq? border-style 'sunken)
|
||||
(car colors) (cadr colors)))
|
||||
(dark (if (eq? border-style 'sunken)
|
||||
(cadr colors) (car colors))))
|
||||
(for-each (lambda (i)
|
||||
(let ((r (make-rectangle
|
||||
(+ i (rectangle:x clip-rect))
|
||||
(+ i (rectangle:y clip-rect))
|
||||
(- (rectangle:width clip-rect) (* i 2))
|
||||
(- (rectangle:height clip-rect) (* i 2)))))
|
||||
(draw-shadow-rectangle dpy window gc
|
||||
r light dark)))
|
||||
(iota border-width))))))
|
||||
|
||||
(define (initial-client-rect wm win maybe-rect)
|
||||
(if maybe-rect
|
||||
maybe-rect
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(w.h (desired-size/hints dpy win
|
||||
(maximal-size/hints dpy win 400 200)))
|
||||
(x.y (desired-position/hints dpy win (cons 0 0))))
|
||||
(make-rectangle (car x.y) (cdr x.y)
|
||||
(car w.h) (cdr w.h)))))
|
||||
|
||||
|
|
@ -0,0 +1,139 @@
|
|||
|
||||
;; *** utils *********************************************************
|
||||
(define-structure utils
|
||||
(export mdisplay assq/false flatten
|
||||
select* spawn* with-lock
|
||||
|
||||
create-options free-options
|
||||
get-option-value get-option set-option! get-options
|
||||
((define-options-spec) :syntax)
|
||||
|
||||
string->keys string->key key:keycode key:modifiers
|
||||
|
||||
reparent-to-root window-path
|
||||
window-viewable?
|
||||
window-focused?
|
||||
window-contains-focus?
|
||||
take-focus delete-window
|
||||
window-exists?
|
||||
move-resize-window*
|
||||
root-rectangle window-rectangle clip-rectangle
|
||||
draw-shadow-rectangle
|
||||
invalidate-window
|
||||
text-center-pos
|
||||
|
||||
maximize-window maximal-size/hints
|
||||
size-window desired-size/hints desired-position/hints)
|
||||
(open scheme i/o list-lib define-record-types finite-types enum-sets
|
||||
threads locks placeholders rendezvous
|
||||
signals handle
|
||||
rx-syntax field-reader-package
|
||||
xlib)
|
||||
(files utils))
|
||||
|
||||
(define-structure dragging
|
||||
(export install-dragging-control)
|
||||
(open scheme define-record-types threads
|
||||
rendezvous-channels rendezvous
|
||||
xlib
|
||||
utils)
|
||||
(files drag-window))
|
||||
|
||||
(define-structure titlebar
|
||||
(export create-titlebar destroy-titlebar titlebar? titlebar:window
|
||||
map-titlebar unmap-titlebar move-resize-titlebar
|
||||
set-titlebar-state! set-titlebar-title!)
|
||||
(open scheme define-record-types threads list-lib
|
||||
rendezvous-channels rendezvous
|
||||
xlib
|
||||
utils)
|
||||
(files titlebar))
|
||||
|
||||
;; *** key-grab ******************************************************
|
||||
|
||||
(define-structure key-grab
|
||||
(export grab-shortcut)
|
||||
(open scheme define-record-types enum-sets weak
|
||||
threads list-lib
|
||||
rendezvous-channels rendezvous locks
|
||||
xlib utils)
|
||||
(files key-grab))
|
||||
|
||||
;; *** manager *******************************************************
|
||||
|
||||
(define-structure manager
|
||||
(export wm? wm:type wm:dpy wm:window wm:colormap wm:options
|
||||
(manager-type :syntax) manager-types manager-type-name
|
||||
create-wm destroy-wm
|
||||
wm-clients wm-current-client
|
||||
|
||||
wm-manage-window wm-unmanage-window wm-select-client
|
||||
|
||||
client? client:window client:client-window
|
||||
client:data set-client:data!
|
||||
client-name)
|
||||
(open scheme threads list-lib locks
|
||||
xlib
|
||||
define-record-types
|
||||
finite-types
|
||||
rendezvous-channels
|
||||
rendezvous
|
||||
utils key-grab)
|
||||
(files manager))
|
||||
|
||||
;; *** move manager **************************************************
|
||||
|
||||
(define-structure move-wm
|
||||
(export create-move-wm)
|
||||
(open scheme list-lib define-record-types
|
||||
threads rendezvous-channels rendezvous
|
||||
xlib
|
||||
manager key-grab
|
||||
utils dragging titlebar)
|
||||
(files move-wm
|
||||
move-wm-resizer))
|
||||
|
||||
;; *** split manager *************************************************
|
||||
|
||||
(define-structure split-wm
|
||||
(export create-split-wm)
|
||||
(open scheme list-lib define-record-types
|
||||
threads rendezvous-channels rendezvous
|
||||
xlib
|
||||
manager
|
||||
utils)
|
||||
(files split-wm
|
||||
split-wm-resizer))
|
||||
|
||||
;; *** switch manager ************************************************
|
||||
|
||||
(define-structure switch-wm
|
||||
(export create-switch-wm)
|
||||
(open scheme list-lib define-record-types
|
||||
threads rendezvous-channels rendezvous
|
||||
xlib
|
||||
manager titlebar dragging
|
||||
utils key-grab)
|
||||
(files switch-wm))
|
||||
|
||||
;; *** main package **************************************************
|
||||
|
||||
(define-structure root-manager
|
||||
(export root-wm? create-root-wm)
|
||||
(open scheme
|
||||
define-record-types
|
||||
xlib
|
||||
rendezvous rendezvous-channels
|
||||
utils
|
||||
manager
|
||||
move-wm split-wm switch-wm
|
||||
)
|
||||
(files root-manager))
|
||||
|
||||
(define-structure main
|
||||
(export start)
|
||||
(open scsh scheme threads
|
||||
xlib
|
||||
root-manager
|
||||
utils)
|
||||
(files main))
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
(define-record-type root-wm :root-wm
|
||||
(make-root-wm dpy managers current-manager)
|
||||
root-wm?
|
||||
(dpy root-wm:dpy)
|
||||
(managers root-wm:managers set-root-wm:managers!)
|
||||
(current-manager root-wm:current-manager set-root-wm:current-manager!))
|
||||
|
||||
(define (create-root-wm dpy)
|
||||
(let* ((window (default-root-window dpy))
|
||||
(children (window-children dpy window))
|
||||
(in-channel (make-channel))
|
||||
(root-wm (make-root-wm dpy '() #f))
|
||||
(initial-manager (create-move-wm in-channel dpy window '())))
|
||||
(mdisplay "creating root-wm\n")
|
||||
(set-root-wm:managers! root-wm (list initial-manager))
|
||||
(set-root-wm:current-manager! root-wm initial-manager)
|
||||
|
||||
(map-window dpy (wm:window initial-manager))
|
||||
|
||||
(for-each (lambda (window)
|
||||
(wm-manage-window initial-manager window))
|
||||
children)
|
||||
;;(create-move-wm in-channel dpy window '())
|
||||
|
||||
(call-with-event-channel
|
||||
dpy window (event-mask substructure-redirect)
|
||||
(lambda (event-channel)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(let loop ()
|
||||
(select*
|
||||
(wrap (receive-rv event-channel)
|
||||
(lambda (xevent)
|
||||
(handle-xevent root-wm exit xevent)))
|
||||
(wrap (receive-rv in-channel)
|
||||
(lambda (msg)
|
||||
(handle-message root-wm exit msg))))
|
||||
(loop))))))))
|
||||
|
||||
(define (handle-xevent root-wm exit xevent)
|
||||
(let ((type (any-event-type xevent))
|
||||
(dpy (root-wm:dpy root-wm)))
|
||||
(cond
|
||||
((configure-request-event? xevent)
|
||||
;; TODO: maybe let it configure by the future manager...
|
||||
(configure-window dpy (configure-request-event-window xevent)
|
||||
(configure-request-event-window-change-alist xevent)))
|
||||
((map-request-event? xevent)
|
||||
(wm-manage-window (root-wm:current-manager root-wm)
|
||||
(map-request-event-window xevent)
|
||||
#f))
|
||||
)))
|
||||
|
||||
(define (handle-message root-wm exit msg)
|
||||
'none)
|
||||
|
||||
;; *** observing managers ********************************************
|
||||
|
||||
(define (add-manager! manager)
|
||||
#t)
|
||||
|
|
@ -0,0 +1,283 @@
|
|||
(define-options-spec split-wm-options-spec
|
||||
(orientation symbol 'horizontal) ;; horizontal | vertical
|
||||
(aspect number 1/1)
|
||||
(bar-width int 3)
|
||||
(resize-step int 5)
|
||||
(bar-style symbol 'raised) ;; raised | sunken | flat
|
||||
(bar-colors colors '("#dddddd" "#888888" "#333333"))
|
||||
)
|
||||
|
||||
;; ---------- ----------
|
||||
;; | | | | |
|
||||
;; ---------- vertical | | | horizontal
|
||||
;; | | | | |
|
||||
;; ---------- ----------
|
||||
|
||||
(define (create-split-wm external-in-channel dpy parent options . children)
|
||||
(create-wm dpy parent options children
|
||||
(manager-type split) split-wm-options-spec
|
||||
external-in-channel
|
||||
(lambda (wm in-channel)
|
||||
(spawn (lambda ()
|
||||
(split-wm-handler wm in-channel)))
|
||||
wm)))
|
||||
|
||||
(define (split-wm-handler wm channel)
|
||||
(let ((resizer-window (create-resizer wm)))
|
||||
(map-window (wm:dpy wm) resizer-window)
|
||||
(let loop ()
|
||||
(let ((msg (receive channel)))
|
||||
(case (car msg)
|
||||
((draw-main-window) #t)
|
||||
|
||||
((fit-windows)
|
||||
(fit-windows wm resizer-window))
|
||||
|
||||
((init-client)
|
||||
(init-client wm (second msg) (third msg)))
|
||||
|
||||
((deinit-client)
|
||||
(deinit-client wm (second msg)))
|
||||
|
||||
((draw-client-window) #t)
|
||||
|
||||
((fit-client)
|
||||
;; client-window changed it's size
|
||||
(fit-client-windows wm (second msg)))
|
||||
|
||||
((fit-client-window)
|
||||
;; client changed it's size ??
|
||||
(fit-client-window wm (second msg)))
|
||||
|
||||
((update-client-state) #t)
|
||||
))
|
||||
(loop))))
|
||||
|
||||
;(define (draw-main-window wm gc)
|
||||
; (let* ((dpy (wm:dpy wm))
|
||||
; (options (wm:options wm))
|
||||
; (colors (get-option-value options 'bar-colors))
|
||||
; (bar-style (get-option-value options 'bar-style))
|
||||
; (rects (calc-rectangles wm))
|
||||
; (bar-rect (second rects))
|
||||
; (win (wm:window wm))
|
||||
; (x1 (rectangle:x bar-rect))
|
||||
; (y1 (rectangle:y bar-rect))
|
||||
; (x2 (+ (rectangle:x bar-rect) (rectangle:width bar-rect) -1))
|
||||
; (y2 (+ (rectangle:y bar-rect) (rectangle:height bar-rect) -1)))
|
||||
; (mdisplay "bar drawing: " bar-rect "\n")
|
||||
; (set-gc-foreground! dpy gc (second colors))
|
||||
; (fill-rectangle dpy win gc x1 y1
|
||||
; (rectangle:width bar-rect) (rectangle:height bar-rect))
|
||||
; (if (and #f (not (eq? bar-style 'flat)))
|
||||
; (let ((light (if (eq? bar-style 'raised)
|
||||
; (first colors)
|
||||
; (third colors)))
|
||||
; (dark (if (eq? bar-style 'raised)
|
||||
; (third colors)
|
||||
; (first colors))))
|
||||
; (set-gc-line-width! dpy gc 1)
|
||||
; (set-gc-foreground! dpy gc light)
|
||||
; (draw-lines dpy win gc (list (cons x1 y2) (cons x1 y1) (cons x2 y1))
|
||||
; (coord-mode origin))
|
||||
; (set-gc-foreground! dpy gc dark)
|
||||
; (draw-lines dpy win gc (list (cons x2 (+ y1 1)) (cons x2 y2)
|
||||
; (cons x1 y2))
|
||||
; (coord-mode origin))))))
|
||||
|
||||
(define (calc-rectangles wm)
|
||||
(let* ((options (wm:options wm))
|
||||
(bar-width (get-option-value options 'bar-width))
|
||||
(orientation (get-option-value options 'orientation))
|
||||
(aspect (get-option-value options 'aspect))
|
||||
(r (clip-rectangle (wm:dpy wm) (wm:window wm))))
|
||||
(mdisplay "calc-rects: aspect " aspect "\n")
|
||||
(if (eq? orientation 'horizontal)
|
||||
(let* ((r1 (make-rectangle 0 0
|
||||
(floor (/ (- (rectangle:width r) bar-width)
|
||||
(+ 1 (/ 1 aspect))))
|
||||
(rectangle:height r)))
|
||||
(r2 (make-rectangle (rectangle:width r1) 0
|
||||
bar-width (rectangle:height r)))
|
||||
(r3 (make-rectangle (+ (rectangle:width r1) bar-width) 0
|
||||
(- (rectangle:width r)
|
||||
(+ (rectangle:width r1) bar-width))
|
||||
(rectangle:height r))))
|
||||
(list r1 r2 r3))
|
||||
(let* ((r1 (make-rectangle 0 0 (rectangle:width r)
|
||||
(floor (/ (- (rectangle:height r) bar-width)
|
||||
(+ 1 (/ 1 aspect))))))
|
||||
(r2 (make-rectangle 0 (rectangle:height r1)
|
||||
(rectangle:width r) bar-width))
|
||||
(r3 (make-rectangle 0 (+ (rectangle:height r1) bar-width)
|
||||
(rectangle:width r)
|
||||
(- (rectangle:height r)
|
||||
(+ (rectangle:height r1) bar-width)))))
|
||||
(list r1 r2 r3)))))
|
||||
|
||||
(define (fit-windows wm resizer-window)
|
||||
(let* ((rects (calc-rectangles wm))
|
||||
(clients (wm-clients wm))
|
||||
(dpy (wm:dpy wm)))
|
||||
(mdisplay "splitter rects: " rects "\n")
|
||||
(move-resize-window* dpy resizer-window (second rects))
|
||||
(if (and (pair? clients) (pair? (cdr clients)))
|
||||
(move-resize-window* dpy
|
||||
(client:client-window (second clients))
|
||||
(first rects)))
|
||||
(if (pair? clients)
|
||||
(move-resize-window* dpy
|
||||
(client:client-window (first clients))
|
||||
(third rects)))))
|
||||
|
||||
(define (init-client wm client maybe-rect)
|
||||
(let* ((rects (calc-rectangles wm))
|
||||
(r (if (> (length (wm-clients wm)) 1)
|
||||
(third rects)
|
||||
(first rects))))
|
||||
(let ((dpy (wm:dpy wm))
|
||||
(options (wm:options wm)))
|
||||
(set-window-border-width! dpy (client:window client) 0)
|
||||
(move-resize-window* dpy (client:client-window client) r)
|
||||
|
||||
(map-window dpy (client:client-window client))
|
||||
;;(select-client wm client))) ??
|
||||
)))
|
||||
|
||||
(define (deinit-client wm client)
|
||||
(let ((dpy (wm:dpy wm)))
|
||||
;; maybe destroy-wm ?? TODO
|
||||
#t))
|
||||
|
||||
(define (fit-client-windows wm client)
|
||||
(let ((dpy (wm:dpy wm)))
|
||||
(maximize-window dpy (client:window client))))
|
||||
|
||||
(define (fit-client-window wm client)
|
||||
#t)
|
||||
|
||||
;; *******************************************************************
|
||||
;; Resizer
|
||||
;; *******************************************************************
|
||||
|
||||
(define (create-resizer wm)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(main-window (wm:window wm))
|
||||
(options (wm:options wm))
|
||||
(window (create-simple-window dpy main-window 0 0 1 1 0
|
||||
(white-pixel dpy) (black-pixel dpy)))
|
||||
(root (window-root dpy window))
|
||||
(gc (create-gc dpy window '()))
|
||||
(root-gc (create-gc dpy window
|
||||
(make-gc-value-alist
|
||||
(function (gc-function xor))
|
||||
(subwindow-mode (subwindow-mode
|
||||
include-inferiors)))))
|
||||
(cursor (create-font-cursor
|
||||
dpy (if (eq? (get-option-value options 'orientation)
|
||||
'horizontal)
|
||||
xc-sb-h-double-arrow
|
||||
xc-sb-v-double-arrow))))
|
||||
(set-window-cursor! dpy window cursor)
|
||||
(spawn*
|
||||
(lambda (release)
|
||||
(call-with-event-channel
|
||||
dpy window (event-mask structure-notify
|
||||
exposure
|
||||
button-press button-release
|
||||
button-1-motion)
|
||||
(lambda (event-channel)
|
||||
(release)
|
||||
(letrec
|
||||
((idle (lambda ()
|
||||
(let* ((e (receive event-channel))
|
||||
(type (any-event-type e)))
|
||||
(cond
|
||||
((eq? (event-type button-press) type)
|
||||
(let ((r (root-rectangle dpy window)))
|
||||
(grab-server dpy)
|
||||
(draw-resizer r)
|
||||
(drag r r (button-event-x e) (button-event-y e))))
|
||||
((expose-event? e)
|
||||
(draw-resizer-window)
|
||||
(idle))
|
||||
((destroy-window-event? e) #t)
|
||||
(else (idle))))))
|
||||
(drag (lambda (start-rect last-rect start-x start-y)
|
||||
(let* ((e (receive event-channel))
|
||||
(type (any-event-type e)))
|
||||
(cond
|
||||
((motion-event? e)
|
||||
(draw-resizer last-rect)
|
||||
(let ((new-rect (calc-new-rect
|
||||
start-rect
|
||||
(- (motion-event-x e) start-x)
|
||||
(- (motion-event-y e) start-y))))
|
||||
(draw-resizer new-rect)
|
||||
(drag start-rect new-rect start-x start-y)))
|
||||
((eq? (event-type button-release) type)
|
||||
(draw-resizer last-rect)
|
||||
(ungrab-server dpy)
|
||||
(commit-resize (- (button-event-x e) start-x)
|
||||
(- (button-event-y e) start-y))
|
||||
(idle))
|
||||
((expose-event? e)
|
||||
(draw-resizer-window)
|
||||
(drag start-rect last-rect start-x start-y))
|
||||
((destroy-window-event? e) #t)
|
||||
(else
|
||||
(drag start-rect last-rect start-x start-y))))))
|
||||
|
||||
(draw-resizer
|
||||
(lambda (rect)
|
||||
(draw dpy root root-gc rect)))
|
||||
(draw-resizer-window
|
||||
(lambda ()
|
||||
(draw dpy window gc (clip-rectangle dpy window))))
|
||||
(commit-resize
|
||||
(lambda (dx dy)
|
||||
;; check if outside... TODO
|
||||
(let* ((rects (calc-rectangles wm))
|
||||
(r1 (first rects)) (r2 (third rects))
|
||||
(aspect
|
||||
(if (eq? 'horizontal
|
||||
(get-option-value options 'orientation))
|
||||
(if (= 0 (- (rectangle:width r2) dx))
|
||||
0
|
||||
(/ (+ (rectangle:width r1) dx)
|
||||
(- (rectangle:width r2) dx)))
|
||||
(if (= 0 (- (rectangle:height r2) dy))
|
||||
0
|
||||
(/ (+ (rectangle:height r1) dy)
|
||||
(- (rectangle:height r2) dy))))))
|
||||
(if (> aspect 0)
|
||||
(begin
|
||||
(set-option! options 'aspect aspect)
|
||||
(fit-windows wm window))))))
|
||||
(calc-new-rect
|
||||
(lambda (start-rect dx dy)
|
||||
(let ((width (rectangle:width start-rect))
|
||||
(height (rectangle:height start-rect)))
|
||||
(if (eq? (get-option-value options 'orientation)
|
||||
'horizontal)
|
||||
(make-rectangle (+ (rectangle:x start-rect) dx)
|
||||
(rectangle:y start-rect)
|
||||
width height)
|
||||
(make-rectangle (rectangle:x start-rect)
|
||||
(+ (rectangle:y start-rect) dy)
|
||||
width height)))))
|
||||
(draw
|
||||
(lambda (dpy window gc r)
|
||||
(let ((colors (get-option-value options 'bar-colors)))
|
||||
(set-gc-foreground! dpy gc (second colors))
|
||||
(fill-rectangle dpy window gc
|
||||
(rectangle:x r) (rectangle:y r)
|
||||
(rectangle:width r) (rectangle:height r))
|
||||
;; Rest ??
|
||||
)))
|
||||
)
|
||||
(idle)
|
||||
(free-cursor dpy cursor)
|
||||
(free-gc dpy gc)
|
||||
(free-gc dpy root-gc))))))
|
||||
window))
|
||||
|
|
@ -0,0 +1,240 @@
|
|||
(define-options-spec switch-wm-options-spec
|
||||
(titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
|
||||
(titlebar-colors-active colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
|
||||
(titlebar-colors-focused colors '("#9999aa" "#eeeeff" "#777788" "black"))
|
||||
(titlebar-height int 18)
|
||||
(titlebar-style symbol 'flat)
|
||||
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
||||
(select-next keys "M-k n")
|
||||
(select-previous keys "M-k p")
|
||||
(kill-client keys "M-c")
|
||||
)
|
||||
|
||||
(define (create-switch-wm out-channel dpy parent options . children)
|
||||
(create-wm dpy parent options children
|
||||
(manager-type switch) switch-wm-options-spec
|
||||
out-channel
|
||||
(lambda (wm in-channel)
|
||||
(spawn (lambda ()
|
||||
(switch-wm-handler wm in-channel)))
|
||||
wm)))
|
||||
|
||||
(define-record-type switch-wm-data :switch-wm-data
|
||||
(make-switch-wm-data titlebars empty-titlebar)
|
||||
switch-wm-data?
|
||||
(titlebars data:titlebars set-data:titlebars!)
|
||||
(empty-titlebar data:empty-titlebar))
|
||||
|
||||
(define (switch-wm-handler wm channel)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(options (wm:options wm))
|
||||
(gc (create-gc dpy (wm:window wm) '()))
|
||||
(empty-titlebar (create-empty-titlebar wm))
|
||||
(data (make-switch-wm-data '() empty-titlebar)))
|
||||
(update-titlebars wm data)
|
||||
|
||||
(grab-shortcut dpy (wm:window wm)
|
||||
(get-option-value options 'select-next)
|
||||
'select-next channel #f)
|
||||
(grab-shortcut dpy (wm:window wm)
|
||||
(get-option-value options 'select-previous)
|
||||
'select-previous channel #f)
|
||||
|
||||
(let loop ()
|
||||
(let ((msg (receive channel)))
|
||||
(case (car msg)
|
||||
((draw-main-window) #t)
|
||||
|
||||
((fit-windows)
|
||||
(fit-titlebars wm data)
|
||||
(for-each (lambda (c)
|
||||
(fit-client-window wm c))
|
||||
(wm-clients wm)))
|
||||
|
||||
((init-client)
|
||||
(init-client wm data (second msg) (third msg)))
|
||||
((deinit-client)
|
||||
(deinit-client wm data (second msg)))
|
||||
|
||||
((draw-client-window) #f)
|
||||
|
||||
((fit-client)
|
||||
;; client-window changed it's size
|
||||
(fit-client wm (second msg)))
|
||||
|
||||
((fit-client-window)
|
||||
;; client changed it's size ??
|
||||
(fit-client-window wm (second msg)))
|
||||
|
||||
;; TODO: need focus-in of manager to update empty-titlebar
|
||||
|
||||
((update-client-state)
|
||||
(let* ((client (second msg))
|
||||
(dpy (wm:dpy wm))
|
||||
(window (client:window client))
|
||||
(state (if (window-contains-focus? dpy window)
|
||||
'focused
|
||||
(if (window-viewable? dpy window)
|
||||
'active
|
||||
'normal)))
|
||||
(titlebar (assq/false client (data:titlebars data)))
|
||||
(name (client-name dpy client)))
|
||||
(set-titlebar-state! titlebar state)
|
||||
(set-titlebar-title! titlebar name)))
|
||||
|
||||
((select-next) (select-next-client wm (second msg)))
|
||||
((select-previous) (select-previous-client wm (second msg)))
|
||||
))
|
||||
(loop))
|
||||
(free-gc (wm:dpy wm) gc)))
|
||||
|
||||
(define (fit-titlebars wm data)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(width (window-width dpy (wm:window wm)))
|
||||
(height (window-height dpy (wm:window wm)))
|
||||
(titlebar-height (get-option-value (wm:options wm) 'titlebar-height)))
|
||||
(move-resize-titlebar (data:empty-titlebar data)
|
||||
(make-rectangle 0 0 width titlebar-height))
|
||||
(let* ((titlebars (map cdr (data:titlebars data)))
|
||||
(n (length titlebars))
|
||||
(widths (if (zero? n) '()
|
||||
(let ((dw (quotient width n)))
|
||||
(append (map (lambda (_) dw) (iota (- n 1)))
|
||||
(list (- width (* dw (- n 1)))))))))
|
||||
(for-each (lambda (i width titlebar)
|
||||
(move-resize-titlebar
|
||||
titlebar
|
||||
(make-rectangle (* i width) 0
|
||||
width titlebar-height)))
|
||||
(iota n) widths titlebars))))
|
||||
|
||||
(define (update-titlebars wm data)
|
||||
(if (null? (data:titlebars data))
|
||||
(map-titlebar (data:empty-titlebar data))
|
||||
(begin
|
||||
(unmap-titlebar (data:empty-titlebar data))
|
||||
(for-each (lambda (c.t)
|
||||
(map-titlebar (cdr c.t)))
|
||||
(data:titlebars data)))))
|
||||
|
||||
(define (init-client wm data client maybe-rect)
|
||||
;; TODO: transients!
|
||||
(let ((dpy (wm:dpy wm))
|
||||
(options (wm:options wm)))
|
||||
(set-window-border-width! dpy (client:window client) 0)
|
||||
(let* ((channel (make-channel))
|
||||
(titlebar (create-client-titlebar channel wm client)))
|
||||
(set-data:titlebars! data (cons (cons client titlebar)
|
||||
(data:titlebars data)))
|
||||
(fit-titlebars wm data)
|
||||
(update-titlebars wm data)
|
||||
(fit-client-window wm client)
|
||||
(fit-client wm client)
|
||||
|
||||
(install-dragging-control channel dpy
|
||||
(titlebar:window titlebar)
|
||||
(client:client-window client))
|
||||
(grab-shortcut dpy (client:client-window client)
|
||||
(get-option-value options 'kill-client)
|
||||
'kill-client channel #f)
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ((msg (receive channel)))
|
||||
(case (car msg)
|
||||
((drop)
|
||||
;; TODO: check if outside...
|
||||
;;(move-window dpy (client:client-window client)
|
||||
;; (second msg) (third msg))
|
||||
#t
|
||||
)
|
||||
((click)
|
||||
(wm-select-client wm client (fourth msg)))
|
||||
((kill-client)
|
||||
(let ((time (second msg)))
|
||||
(delete-window dpy (client:window client) time)))
|
||||
(else (mdisplay "unhandled client message: " msg "\n"))))
|
||||
;; TODO: internal channel
|
||||
(loop))))
|
||||
|
||||
(map-titlebar titlebar)
|
||||
(map-window dpy (client:client-window client))
|
||||
;;(select-client wm client))) ??
|
||||
)))
|
||||
|
||||
(define (create-client-titlebar channel wm client)
|
||||
(let ((options (wm:options wm)))
|
||||
(create-titlebar channel (wm:dpy wm) (wm:window wm)
|
||||
(wm:colormap wm)
|
||||
;; TODO: buttons
|
||||
(list (cons 'normal-colors
|
||||
(get-option options 'titlebar-colors))
|
||||
(cons 'active-colors
|
||||
(get-option options 'titlebar-colors-active))
|
||||
(cons 'focused-colors
|
||||
(get-option options 'titlebar-colors-focused))
|
||||
(cons 'border-style
|
||||
(get-option options 'titlebar-style))))))
|
||||
|
||||
(define (create-empty-titlebar wm)
|
||||
(let* ((options (wm:options wm))
|
||||
(tb
|
||||
(create-titlebar #f (wm:dpy wm) (wm:window wm) (wm:colormap wm)
|
||||
;; buttons ??
|
||||
(list ;; TODO: (cons 'draggable #f)
|
||||
(cons 'normal-colors
|
||||
(get-option options 'titlebar-colors))
|
||||
(cons 'active-colors
|
||||
(get-option options 'titlebar-colors-active))
|
||||
(cons 'focused-colors
|
||||
(get-option options 'titlebar-colors-focused))
|
||||
(cons 'border-style
|
||||
(get-option options 'titlebar-style))))))
|
||||
(set-titlebar-title! tb "<empty frame>")
|
||||
tb))
|
||||
|
||||
(define (deinit-client wm data client)
|
||||
(let ((dpy (wm:dpy wm))
|
||||
(tb (assq/false client (data:titlebars data))))
|
||||
(set-data:titlebars! data (filter (lambda (c.t)
|
||||
(not (eq? (car c.t) client)))
|
||||
(data:titlebars data)))
|
||||
(if tb (destroy-titlebar tb))
|
||||
(fit-titlebars wm data)
|
||||
(update-titlebars wm data)))
|
||||
|
||||
;; ***
|
||||
|
||||
(define (fit-client wm client)
|
||||
(maximize-window (wm:dpy wm) (client:window client)))
|
||||
|
||||
(define (fit-client-window wm client)
|
||||
(let* ((dpy (wm:dpy wm))
|
||||
(w (wm:window wm))
|
||||
(options (wm:options wm))
|
||||
(titlebar-height (get-option-value options 'titlebar-height)))
|
||||
(move-resize-window dpy (client:client-window client)
|
||||
0 titlebar-height
|
||||
(window-width dpy w) (- (window-height dpy w)
|
||||
titlebar-height))))
|
||||
|
||||
;; ***
|
||||
|
||||
(define (select-next-client* wm clients time)
|
||||
(let ((cc (wm-current-client wm)))
|
||||
(let loop ((rest clients))
|
||||
(if (null? rest)
|
||||
(if (null? clients)
|
||||
#f
|
||||
(car clients))
|
||||
(if (eq? cc (car rest))
|
||||
(if (null? (cdr rest))
|
||||
#f
|
||||
(wm-select-client wm (cadr rest) time))
|
||||
(loop (cdr rest)))))))
|
||||
|
||||
(define (select-next-client wm time)
|
||||
(select-next-client* wm (wm-clients wm) time))
|
||||
|
||||
(define (select-previous-client wm time)
|
||||
(select-next-client* wm (reverse (wm-clients wm)) time))
|
||||
|
|
@ -0,0 +1,122 @@
|
|||
(define-options-spec titlebar-options-spec
|
||||
(buttons symbol-list '(kill)) ; iconize, maximize, roll
|
||||
(normal-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
|
||||
(active-colors colors '("#9999aa" "#eeeeff" "#777788" "black"))
|
||||
(focused-colors colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
|
||||
(border-style symbol 'raised) ; none | sunken
|
||||
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
||||
(button-border-style symbol 'flat) ; none | raised
|
||||
)
|
||||
|
||||
(define-record-type titlebar :titlebar
|
||||
(make-titlebar channel dpy window title state)
|
||||
titlebar?
|
||||
(channel titlebar:channel)
|
||||
(dpy titlebar:dpy)
|
||||
(window titlebar:window)
|
||||
(title titlebar:title set-titlebar:title!)
|
||||
(state titlebar:state set-titlebar:state!)) ;; active | focused | normal
|
||||
|
||||
(define (create-titlebar out-channel dpy parent colormap options-def)
|
||||
(let* ((in-channel (make-channel))
|
||||
(window (create-simple-window dpy parent
|
||||
0 0 1 1 0
|
||||
(black-pixel dpy) (black-pixel dpy)))
|
||||
(options (create-options dpy colormap titlebar-options-spec
|
||||
options-def))
|
||||
(gc (create-gc dpy window '()))
|
||||
(tb (make-titlebar in-channel dpy window "test" 'normal))
|
||||
;; buttons... icon-window...
|
||||
)
|
||||
(mdisplay "creating titlebar " window "\n")
|
||||
(spawn*
|
||||
(lambda (release)
|
||||
(call-with-event-channel
|
||||
dpy window (event-mask exposure structure-notify)
|
||||
(lambda (event-channel)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(release)
|
||||
(let loop ()
|
||||
(select*
|
||||
(wrap (receive-rv event-channel)
|
||||
(lambda (xevent)
|
||||
(cond
|
||||
((expose-event? xevent)
|
||||
(draw-titlebar tb options gc))
|
||||
((destroy-window-event? xevent)
|
||||
(exit)))))
|
||||
(wrap (receive-rv in-channel)
|
||||
(lambda (msg)
|
||||
(case (car msg)
|
||||
((title)
|
||||
(set-titlebar:title! tb (cdr msg))
|
||||
(invalidate-window dpy window))
|
||||
((state)
|
||||
(set-titlebar:state! tb (cdr msg))
|
||||
(invalidate-window dpy window)))))
|
||||
)
|
||||
(loop))))))
|
||||
(free-gc dpy gc)
|
||||
(free-options options)))
|
||||
tb))
|
||||
|
||||
(define (destroy-titlebar tb)
|
||||
(destroy-window (titlebar:dpy tb) (titlebar:window tb)))
|
||||
|
||||
(define (map-titlebar tb)
|
||||
(map-window (titlebar:dpy tb) (titlebar:window tb)))
|
||||
; (send (titlebar:channel tb) '(map #f)))
|
||||
|
||||
(define (unmap-titlebar tb)
|
||||
(unmap-window (titlebar:dpy tb) (titlebar:window tb)))
|
||||
|
||||
(define (move-resize-titlebar tb rect)
|
||||
(move-resize-window (titlebar:dpy tb) (titlebar:window tb)
|
||||
(rectangle:x rect) (rectangle:y rect)
|
||||
(rectangle:width rect) (rectangle:height rect)))
|
||||
|
||||
(define (set-titlebar-title! tb title)
|
||||
(send (titlebar:channel tb) (cons 'title title)))
|
||||
|
||||
(define (set-titlebar-state! tb state)
|
||||
(send (titlebar:channel tb) (cons 'state state)))
|
||||
|
||||
(define (draw-titlebar tb options gc)
|
||||
(let ((dpy (titlebar:dpy tb))
|
||||
(window (titlebar:window tb))
|
||||
(state (titlebar:state tb))
|
||||
(title (titlebar:title tb)))
|
||||
(let ((colors (colors-of-state state options))
|
||||
(font (get-option-value options 'font))
|
||||
(border-style (get-option-value options 'border-style)))
|
||||
(let ((main-color (first colors))
|
||||
(light-color (second colors))
|
||||
(dark-color (third colors))
|
||||
(font-color (fourth colors))
|
||||
(r (clip-rectangle dpy window)))
|
||||
;; fill the area with the main color
|
||||
(set-gc-foreground! dpy gc main-color)
|
||||
(fill-rectangle dpy window gc 0 0 (rectangle:width r)
|
||||
(rectangle:height r))
|
||||
;; draw the border
|
||||
(case border-style
|
||||
((raised) (draw-shadow-rectangle dpy window gc r
|
||||
light-color dark-color))
|
||||
((sunken) (draw-shadow-rectangle dpy window gc r
|
||||
dark-color light-color)))
|
||||
;; else flat...
|
||||
;; draw the title
|
||||
(set-gc-foreground! dpy gc font-color)
|
||||
(set-gc-background! dpy gc main-color)
|
||||
(let ((x.y (text-center-pos r font title)))
|
||||
(draw-image-string dpy window gc (car x.y) (cdr x.y)
|
||||
title))
|
||||
))))
|
||||
|
||||
(define (colors-of-state state options)
|
||||
(get-option-value options
|
||||
(case state
|
||||
((active) 'active-colors)
|
||||
((focused) 'focused-colors)
|
||||
(else 'normal-colors))))
|
||||
|
|
@ -0,0 +1,439 @@
|
|||
(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)))
|
||||
Loading…
Reference in New Issue