182 lines
6.0 KiB
Scheme
182 lines
6.0 KiB
Scheme
(define-options-spec titlebar-options-spec
|
|
(buttons symbol-list '(kill)) ; kill, iconize, maximize
|
|
(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) ; flat | sunken
|
|
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
|
;; colors: (background top-left-border button-right-border font-img-color)
|
|
(button-up-colors colors '("gray" "white" "black" "black"))
|
|
(button-down-colors colors '("gray" "black" "white" "black"))
|
|
(height number 18)
|
|
)
|
|
|
|
(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 options)
|
|
(let* ((in-channel (make-channel))
|
|
(height (get-option-value options 'height)) ;; TODO: height button-size
|
|
(window (create-simple-window dpy parent
|
|
0 0 1 1 0
|
|
(black-pixel dpy) (black-pixel dpy)))
|
|
(gc (create-gc dpy window '()))
|
|
(tb (make-titlebar in-channel dpy window "test" 'normal))
|
|
(button-channel out-channel)
|
|
(button-size (- height 4))
|
|
(button-options
|
|
(build-options
|
|
(options:dpy options) (options:colormap options)
|
|
button-options-spec
|
|
`((up-colors . ,(get-option-value options 'button-up-colors))
|
|
(down-colors . ,(get-option-value options 'button-down-colors))
|
|
(font . ,(get-option-value options 'font))
|
|
(initial-content . "<unnamed>")
|
|
(type . standard)
|
|
(initial-state . up))))
|
|
;; TODO: border-style -> colors
|
|
(buttons (map (lambda (id)
|
|
(let ((b (create-button dpy window
|
|
(make-rectangle 0 0 1 1)
|
|
button-channel id
|
|
button-options)))
|
|
(button-set-content! b id)
|
|
b))
|
|
(get-option-value options 'buttons)))
|
|
;; icon-window...
|
|
)
|
|
(for-each map-button buttons)
|
|
(spawn*
|
|
(list 'titlebar window)
|
|
(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
|
|
((or (destroy-window-event? xevent)
|
|
(not (window-exists? dpy window)))
|
|
(exit))
|
|
((expose-event? xevent)
|
|
(if (and (= 0 (expose-event-count xevent))
|
|
(window-exists? dpy window))
|
|
(draw-titlebar tb options gc)))
|
|
((configure-event? xevent)
|
|
(refit-buttons options buttons
|
|
(configure-event-width xevent)
|
|
(configure-event-height xevent))))))
|
|
(wrap (receive-rv in-channel)
|
|
(lambda (msg)
|
|
(case (car msg)
|
|
((title)
|
|
(let ((title (cdr msg)))
|
|
(if (not (equal? (titlebar:title tb) title))
|
|
(begin
|
|
(set-titlebar:title! tb title)
|
|
(draw-titlebar tb options gc)))))
|
|
((state)
|
|
(let ((state (cdr msg)))
|
|
(if (not (equal? (titlebar:state tb) state))
|
|
(begin
|
|
(set-titlebar:state! tb (cdr msg))
|
|
(draw-titlebar tb options gc)))))
|
|
((title+state)
|
|
(let ((title (second msg))
|
|
(state (third msg)))
|
|
(if (or (not (equal? (titlebar:title tb) title))
|
|
(not (equal? (titlebar:state tb) state)))
|
|
(begin
|
|
(set-titlebar:title! tb title)
|
|
(set-titlebar:state! tb state)
|
|
(draw-titlebar tb options gc))))))))
|
|
)
|
|
(loop))))))
|
|
(free-gc dpy gc)))
|
|
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)))
|
|
|
|
(define (unmap-titlebar tb)
|
|
(unmap-window (titlebar:dpy tb) (titlebar:window tb)))
|
|
|
|
;; TODO: height must stay the same, or change buttons
|
|
(define (move-resize-titlebar tb rect)
|
|
(move-resize-window* (titlebar:dpy tb) (titlebar:window tb) 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 (set-titlebar-title+state! tb title state)
|
|
(send (titlebar:channel tb) (list 'title+state title 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
|
|
(change-gc dpy gc
|
|
(make-gc-value-alist
|
|
(foreground font-color)
|
|
(background 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))))
|
|
|
|
(define (refit-buttons options buttons width height)
|
|
(let* ((margin 2)
|
|
(bs (- height (* 2 margin)))
|
|
(spacing 2))
|
|
(for-each (lambda (i button)
|
|
(let ((r (make-rectangle (+ margin (* i (+ bs spacing)))
|
|
margin bs bs)))
|
|
(move-resize-button button r)))
|
|
(iota (length buttons))
|
|
buttons)))
|