182 lines
5.8 KiB
Scheme
182 lines
5.8 KiB
Scheme
(define-options-spec button-options-spec
|
|
;; colors: (background top-left-border button-right-border font-img-color)
|
|
(up-colors colors '("gray" "white" "black" "black"))
|
|
(down-colors colors '("gray" "black" "white" "black"))
|
|
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
|
(initial-content sexp 'none) ;; string | 'kill | 'iconify | 'maximize
|
|
(type sexp 'standard) ;; 'standard | 'switch (remains pressed)
|
|
(initial-state sexp 'up) ;; 'up | 'down
|
|
)
|
|
|
|
(define-record-type button :button
|
|
(make-button dpy window options in-channel)
|
|
button?
|
|
(dpy button:dpy)
|
|
(window button:window)
|
|
(options button:options)
|
|
(in-channel button:in-channel))
|
|
|
|
(define-record-discloser :button
|
|
(lambda (b)
|
|
`(Button ,(button:window b))))
|
|
|
|
(define (create-button dpy parent rect out-channel message options)
|
|
(let* ((bgcolor (first (get-option-value options 'up-colors)))
|
|
(window (create-simple-window dpy parent
|
|
(rectangle:x rect)
|
|
(rectangle:y rect)
|
|
(rectangle:width rect)
|
|
(rectangle:height rect)
|
|
0 (black-pixel dpy)
|
|
bgcolor))
|
|
(gc (create-gc dpy window '()))
|
|
(in-channel (make-channel))
|
|
(abutton (make-button dpy window options in-channel))
|
|
(type (get-option-value options 'type)))
|
|
(spawn*
|
|
(list 'button abutton)
|
|
(lambda (release)
|
|
(call-with-event-channel
|
|
dpy window (event-mask exposure structure-notify
|
|
button-press button-release)
|
|
(lambda (event-channel)
|
|
(release)
|
|
(call-with-current-continuation
|
|
(lambda (exit)
|
|
(let ((state (get-option-value options 'initial-state))
|
|
(content (get-option-value options 'initial-content)))
|
|
(let loop ()
|
|
(select*
|
|
(wrap (receive-rv in-channel)
|
|
(lambda (msg)
|
|
(case (car msg)
|
|
((get-state)
|
|
(placeholder-set! (second msg) state))
|
|
((set-state!)
|
|
(let ((s (second msg)))
|
|
(if (not (eq? s state))
|
|
(draw-button abutton gc s content))
|
|
(set! state s)))
|
|
((set-content!)
|
|
(let ((c (second msg)))
|
|
(if (not (equal? c content))
|
|
(draw-button abutton gc state c))
|
|
(set! content c))))))
|
|
(wrap (receive-rv event-channel)
|
|
(lambda (e)
|
|
(cond
|
|
((and (expose-event? e) (window-exists? dpy window))
|
|
(draw-button abutton gc state content))
|
|
((destroy-window-event? e) (exit 'destroyed))
|
|
((and (button-event? e) (window-exists? dpy window)
|
|
(eq? (button-event-button e)
|
|
(button button1)))
|
|
(let ((new-state
|
|
(if (eq? (event-type button-press)
|
|
(button-event-type e))
|
|
(if (eq? type 'standard)
|
|
'down
|
|
(if (eq? state 'up)
|
|
'down
|
|
'up))
|
|
(if (eq? type 'standard)
|
|
'up
|
|
#f))))
|
|
(if new-state
|
|
(begin
|
|
(draw-button abutton gc new-state content)
|
|
(set! state new-state)))
|
|
(if (and (eq? type 'standard)
|
|
(eq? new-state 'up))
|
|
(send out-channel
|
|
(list message (button-event-time e)
|
|
'click)))
|
|
(if (and (eq? type 'switch) new-state)
|
|
(send out-channel
|
|
(list message (button-event-time e)
|
|
new-state)))))))))
|
|
(loop)))))
|
|
(free-gc dpy gc)))))
|
|
abutton))
|
|
|
|
(define (destroy-button button)
|
|
(destroy-window (button:dpy button) (button:window button)))
|
|
|
|
(define (map-button button)
|
|
(map-window (button:dpy button) (button:window button)))
|
|
|
|
(define (unmap-button button)
|
|
(unmap-window (button:dpy button) (button:window button)))
|
|
|
|
(define (move-resize-button button r)
|
|
(move-resize-window* (button:dpy button) (button:window button) r))
|
|
|
|
(define (button-get-state button)
|
|
(let ((ph (make-placeholder)))
|
|
(send (button:in-channel button)
|
|
(list 'get-state ph))
|
|
(placeholder-value ph)))
|
|
|
|
(define (button-set-state! button state)
|
|
(send (button:in-channel button)
|
|
(list 'set-state! state)))
|
|
|
|
(define (button-set-content! button content)
|
|
(send (button:in-channel button)
|
|
(list 'set-content! content)))
|
|
|
|
|
|
(define (draw-button button gc state content)
|
|
(let ((dpy (button:dpy button))
|
|
(window (button:window button))
|
|
(options (button:options button)))
|
|
(let ((colors (get-option-value options
|
|
(if (eq? state 'up)
|
|
'up-colors
|
|
'down-colors)))
|
|
(font (get-option-value options 'font))
|
|
(r (clip-rectangle dpy window)))
|
|
(set-gc-foreground! dpy gc (first colors))
|
|
(fill-rectangle* dpy window gc r)
|
|
(draw-shadow-rectangle dpy window gc r (second colors) (third colors))
|
|
(if (string? content)
|
|
(let ((x.y (text-center-pos r font content)))
|
|
(change-gc dpy gc (make-gc-value-alist
|
|
(font (font-struct:fid font))
|
|
(foreground (fourth colors))
|
|
(background (first colors))))
|
|
(draw-image-string dpy window gc (car x.y) (cdr x.y)
|
|
content))
|
|
(let* ((ww (window-width dpy window))
|
|
(wh (window-height dpy window))
|
|
(bw (max 2 (quotient ww 5)))
|
|
(sw (max 1 (quotient ww 10))))
|
|
(case content
|
|
((kill)
|
|
(change-gc dpy gc
|
|
(make-gc-value-alist
|
|
(line-width bw)
|
|
(cap-style (cap-style round))
|
|
(foreground (fourth colors))))
|
|
(draw-line dpy window gc bw bw (- ww (* 2 bw)) (- wh (* bw 2)))
|
|
(draw-line dpy window gc bw (- wh (* bw 2)) (- ww (* bw 2)) bw))
|
|
((iconify)
|
|
(change-gc dpy gc
|
|
(make-gc-value-alist
|
|
(line-width bw)
|
|
(cap-style (cap-style round))
|
|
(foreground (fourth colors))))
|
|
(draw-line dpy window gc bw (- wh (+ bw 1))
|
|
(- ww (+ bw 1)) (- wh (+ bw 1))))
|
|
((maximize)
|
|
(change-gc dpy gc
|
|
(make-gc-value-alist
|
|
(line-width sw)
|
|
(cap-style (cap-style round))
|
|
(foreground (fourth colors))))
|
|
(draw-rectangle dpy window gc bw bw
|
|
(- ww (* 2 bw)) (- wh (* 2 bw)))
|
|
(draw-line dpy window gc bw (+ bw sw)
|
|
(- ww (* bw 2)) (+ bw sw)))
|
|
))))))
|