;;; Various kinds of SCIX buttons: text-, pixmap- and toggle-buttons.
;;;
;;; $Header: /deneb/src0/johani/scix-0.96/toolkit/RCS/buttons.sc,v 1.2 90/03/30 00:03:54 johani Exp $

(module buttons)

(define-external make-dfsm dfsm)

(include "../include/util.sch")
(include "../include/masks.sch")
(include "../include/objects.sch")
(include "../include/lw-objects.sch")
(include "../macros/extend-syntax.sc")
(include "../macros/define-class.sc")

;;; Generic button.
;;;
(eval-when (compile load eval)
  (define-class (button width height x y button-semantics
			gc-draw gc-rev parent scr)
    (locals
     (i #f)    ;; For caching
     (value-mask (make-window-value-mask 
		  `(event-mask ,(make-event-mask 'ButtonPress 'ButtonRelease
						 'EnterWindow 'LeaveWindow
						 'Exposure))))
     (n-border (list (make-polyrectangle 
		      `((0 0 ,(- width 1) ,(- height 1))))))
     (w-border (list (make-polyrectangle
		      `((1 1 ,(- width 3) ,(- height 3)))))) )
    (inherit
     (window width height (parent 'depth) x y parent
	     0 'CopyFromParent 'CopyFromParent scr #f)
     (dfsm 
      `(((EnterNotify . DisArmed) Armed
				  ,(lambda ()
				     (me 'draw w-border gc-draw)
				     (scr 'flush!) ))
	((EnterNotify . DisArmedPressed) Pressed
					 ,(lambda ()
					    (me 'draw w-border gc-draw)
					    (scr 'flush!)
					    (button-semantics 'EnterNotify)))
	((LeaveNotify . DisArmed) DisArmed)
	((LeaveNotify . Armed) DisArmed
			       ,(lambda ()
				  (me 'draw w-border gc-rev)
				  (scr 'flush!) ))
	((LeaveNotify . Pressed) DisArmedPressed
				 ,(lambda ()
				    (me 'draw w-border gc-rev)
				    (scr 'flush!)
				    (button-semantics 'LeaveNotify)))
	((ButtonPress . Armed) Pressed
			       ,(lambda ()
				  (button-semantics 'ButtonPress) ))
	((ButtonRelease . Armed) Armed)
	((ButtonRelease . Pressed) Armed
				   ,(lambda ()
				      (button-semantics 'ButtonRelease)))
	((ButtonRelease . DisArmedPressed) DisArmed)
	)
      'Disarmed #t))
    (methods
     (reset (lambda reset-log
	      (me '(dfsm reset) (lambda ()
				  (me 'draw n-border gc-draw)
				  (me 'draw w-border gc-rev)
				  (scr 'flush!)
				  (button-semantics 'Reset))
		  (if (null? reset-log) #f #t))))
     (activate (lambda ()
		 (me 'createwindow value-mask)
		 (me 'mapwindow)
		 (me 'reset)))
     (destroy (lambda ()
		(me 'destroywindow) ))	; This also removes us from the
					; display's id-vector.
     (scix-event-dispatch (lambda (ev-source obj)
			    (let* ((ev-l (if (pair? ev-source)
					     ev-source
					     (ev-source 'my-events! obj))))
			      (let loop ((ev-l ev-l))
				(if (not (null? ev-l))
				    (let* ((e (car ev-l))
					   (event-name (e 'event-name)) )
				      (cond ((eq? event-name 'Expose)
					     (if (zero? (e 'count))
						 (me 'reset))
					     (loop (cdr ev-l)))
					    ((memq event-name i)
					     (me 'transit event-name)
					     (loop (cdr ev-l)))
					    (else
					     (format #t "B got ~a~%"
						     event-name))))))
			      (scr 'flush!) ))))
    (init
     (set! i (me 'i))                         ; Cache input alphabet
     (me 'scix-announce-id! me)
     (if parent                               ; i e this is not the root window
	 (parent 'scix-announce-child me) ))) ; all buttons are just "buttons"
  ) ;; End of eval-when

;;; Text-button (was push-button-text).
;;;
(eval-when (compile load eval)
  (define-class (text-button width height x y legend
				  gc-draw gc-rev gc-inv parent appl scr)
    (locals
     (legend-size (gc-draw 'querytextextents
			   (s8->s16 legend)))
     (pixelpad (legend-size 'font-descent))
     (text-width (+ 4 (* 2 pixelpad) (legend-size 'overall-width)))
     (text-height (+ 4 (* 2 pixelpad) (legend-size 'font-ascent)))
     (xsize (max width text-width))
     (ysize (max height text-height))
     (xpos (if (= xsize width)		 
	       (+ 1 (inexact->exact (round
				     (/ (- width
					   (legend-size 'overall-width)) 2))))
	       (+ 2 pixelpad) ))
     (ypos (if (= ysize height)		 
	       (+ (legend-size 'font-ascent)
		  (inexact->exact
		   (round
		    (/ (- height (legend-size 'font-ascent)) 2))))
	       (+ 1 pixelpad (legend-size 'font-ascent)) ))
     (button-area (list (make-polyfillrectangle
			 `((2 2 ,(- xsize 4) ,(- ysize 4))))))
     (button-text (list (make-imagetext8 xpos ypos legend))) )
    (inherit
     (button xsize ysize x y (lambda (input)
			       (if (eq? input 'Reset)
				   (begin
				     (me 'draw button-area gc-rev)
				     (me 'draw button-text gc-draw)
				     (scr 'flush!) )
				   (begin
				     (me 'draw button-area gc-inv)
				     (scr 'flush!)
				     (if (eq? input 'ButtonRelease)
					 (appl)))))
	     gc-draw gc-rev parent scr) ))
  ) ;; End of eval-when

;;; Pixmap-button (was push-button-pixmap).
;;;
(eval-when (compile load eval)
  (define-class (pixmap-button width height x y pixmap
				    gc-draw gc-rev gc-inv parent appl scr)
    (locals
     (p-width (pixmap 'width))
     (p-height (pixmap 'height))
     (xsize (max width (+ 4 p-width)))
     (ysize (max height (+ 4 p-height)))
     (button-area (list (make-polyfillrectangle
			 `((2 2 ,(- xsize 4) ,(- ysize 4)))))) )
    (inherit
     (button xsize ysize x y (lambda (input)
			       (if (eq? input 'Reset)
				   (begin
				     (me 'draw button-area gc-rev)
				     (pixmap 'copyarea me gc-draw
					     0 0 2 2 p-width p-height)
				     (scr 'flush!) )
				   (begin
				     (me 'draw button-area gc-inv)
				     (scr 'flush!)
				     (if (eq? input 'ButtonRelease)
					 (appl)))))
	     gc-draw gc-rev parent scr) ))
  ) ;; End of eval-when

;;; Toggle-button.
;;;
(eval-when (compile load eval)
  (define-class (toggle-button width height x y gc-draw gc-rev gc-inv
			       parent appl-on appl-off scr)
    (locals
     (button-area (list (make-polyfillrectangle
			 `((2 2 ,(- width 4) ,(- height 4))))))
     (inverse-area (lambda ()
		     (me 'draw button-area gc-inv)
		     (scr 'flush!) )))
    (inherit
     (button width height x y (lambda (input)
				(if (memq input
					  '(EnterNotify
					    LeaveNotify ButtonPress))
				    (me '(dfsm transit) 'Inverse)
				    (me '(dfsm transit) input)))
	     gc-draw gc-rev parent scr)
     (dfsm `(((Inverse . R) R ,inverse-area)
	     ((Inverse . S) S ,inverse-area)
	     ((ButtonRelease . R) S ,appl-on)
	     ((ButtonRelease . S) R ,appl-off)
	     ((Reset . Undefined) R ,(lambda ()
				       (me 'draw button-area gc-rev)
				       (scr 'flush!) ))
	     ((Reset . R) R ,(lambda ()
			       (me 'draw button-area gc-rev)
			       (scr 'flush!) ))
	     ((Reset . S) S ,(lambda ()
			       (me 'draw button-area gc-draw)
			       (scr 'flush!) )))
	   'R #f) ))
  ) ;; End of eval-when