scsh-conservatory
/
orion-wm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

first commit

This commit is contained in:
frese 2003-04-15 15:54:49 +00:00
parent 6b10b56ccf
commit af17dd9326
1 changed files with 126 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
src/button.scm Normal file
View File

@ -0,0 +1,126 @@
(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-*-*-*-*-*-*-*")
(content sexp 'none) ;; string | 'kill | 'iconize | 'maximize
)
(define-record-type button :button
(make-button dpy window options)
button?
(dpy button:dpy)
(window button:window)
(options button:options))
(define-record-discloser :button
(lambda (b)
`(Button ,(button:window b))))
(define (create-button dpy parent colormap rect out-channel message options)
(let* ((options (create-options dpy colormap button-options-spec
options))
(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
(gc (create-gc dpy window '()))
(button (make-button dpy window options)))
(spawn*
(list 'button button)
(lambda (release)
(call-with-event-channel
dpy window (event-mask exposure structure-notify button-press)
(lambda (event-channel)
(release)
(let loop ((state 'up))
(let ((e (receive event-channel)))
(cond
((expose-event? e)
(draw-button button gc state)
(loop state))
((destroy-window-event? e) 'destroyed)
((button-event? e)
(if (eq? (event-type button-press)
(button-event-type e))
(begin
(draw-button button gc 'down)
(send out-channel (list message (button-event-time e)))
(loop 'down))
(begin
(draw-button button gc 'up)
(loop 'up))))
(else (loop state)))))
(free-gc dpy gc)
(free-options options #t)))))
button))
(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 (draw-button button gc state)
(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)))
(content (get-option-value options 'content))
(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))
((iconize)
(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)))
))))))