123 lines
4.1 KiB
Scheme
123 lines
4.1 KiB
Scheme
(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))))
|