- added "switch" feature to button
- added possibility to change state and caption
This commit is contained in:
frese
parent
03c223193b
commit
0f7e0eb189
109
src/button.scm
109
src/button.scm
|
|
@ -4,14 +4,17 @@
|
|||
(down-colors colors '("gray" "black" "white" "black"))
|
||||
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
|
||||
(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)
|
||||
(make-button dpy window options in-channel)
|
||||
button?
|
||||
(dpy button:dpy)
|
||||
(window button:window)
|
||||
(options button:options))
|
||||
(options button:options)
|
||||
(in-channel button:in-channel))
|
||||
|
||||
(define-record-discloser :button
|
||||
(lambda (b)
|
||||
|
|
@ -20,44 +23,84 @@
|
|||
(define (create-button dpy parent colormap rect out-channel message options)
|
||||
(let* ((options (create-options dpy colormap button-options-spec
|
||||
options))
|
||||
(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)
|
||||
(white-pixel dpy))) ;; from options
|
||||
bgcolor))
|
||||
(gc (create-gc dpy window '()))
|
||||
(button (make-button dpy window options)))
|
||||
(in-channel (make-channel))
|
||||
(abutton (make-button dpy window options in-channel))
|
||||
(type (get-option-value options 'type)))
|
||||
(spawn*
|
||||
(list 'button button)
|
||||
(list 'button abutton)
|
||||
(lambda (release)
|
||||
(call-with-event-channel
|
||||
dpy window (event-mask exposure structure-notify
|
||||
button-press button-release)
|
||||
(lambda (event-channel)
|
||||
(release)
|
||||
(let loop ((state 'up))
|
||||
(let ((e (receive event-channel)))
|
||||
(cond
|
||||
((and (expose-event? e) (window-exists? dpy window))
|
||||
(draw-button button gc state)
|
||||
(loop state))
|
||||
((destroy-window-event? e) 'destroyed)
|
||||
((and (button-event? e) (window-exists? dpy window))
|
||||
(if (eq? (event-type button-press)
|
||||
(button-event-type e))
|
||||
(begin
|
||||
(draw-button button gc 'down)
|
||||
(loop 'down))
|
||||
(begin
|
||||
(draw-button button gc 'up)
|
||||
(send out-channel (list message (button-event-time e)))
|
||||
(loop 'up))))
|
||||
(else (loop state)))))
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(let ((state (get-option-value options 'initial-state))
|
||||
(content (get-option-value options '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)
|
||||
(free-options options #t)))))
|
||||
button))
|
||||
abutton))
|
||||
|
||||
(define (destroy-button button)
|
||||
(destroy-window (button:dpy button) (button:window button)))
|
||||
|
|
@ -71,7 +114,22 @@
|
|||
(define (move-resize-button button r)
|
||||
(move-resize-window* (button:dpy button) (button:window button) r))
|
||||
|
||||
(define (draw-button button gc state)
|
||||
(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)))
|
||||
|
|
@ -79,7 +137,6 @@
|
|||
(if (eq? state 'up)
|
||||
'up-colors
|
||||
'down-colors)))
|
||||
(content (get-option-value options 'content))
|
||||
(font (get-option-value options 'font))
|
||||
(r (clip-rectangle dpy window)))
|
||||
(set-gc-foreground! dpy gc (first colors))
|
||||
|
|
|
|||
Loading…
Reference in New Issue