orion-wm/src/button.scm

(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 button-release)
	(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)))
	      ))))))