- added "switch" feature to button

- added possibility to change state and caption

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))
+	  (call-with-current-continuation
-	    (let ((e (receive event-channel)))
+	   (lambda (exit)
-	      (cond
+	     (let ((state (get-option-value options 'initial-state))
-	       ((and (expose-event? e) (window-exists? dpy window))
+		   (content (get-option-value options 'content)))
-		(draw-button button gc state)
+	       (let loop ()
-		(loop state))
+		 (select*
-	       ((destroy-window-event? e) 'destroyed)
+		  (wrap (receive-rv in-channel)
-	       ((and (button-event? e) (window-exists? dpy window))
+			(lambda (msg)
-		(if (eq? (event-type button-press)
+			  (case (car msg)
-			 (button-event-type e))
+			    ((get-state)
-		    (begin
+			     (placeholder-set! (second msg) state))
-		      (draw-button button gc 'down)
+			    ((set-state!)
-		      (loop 'down))
+			     (let ((s (second msg)))
-		    (begin
+			       (if (not (eq? s state))
-		      (draw-button button gc 'up)
+				   (draw-button abutton gc s content))
-		      (send out-channel (list message (button-event-time e)))
+			       (set! state s)))
-		      (loop 'up))))
+			    ((set-content!)
-	       (else (loop state)))))
+			     (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))