;;; A sample demonstration of the use of some SCIX toggle-buttons. 
;;; Hakan Huss, KTH and Johan Ihren, KTH

;;; $Header: toggle.sc,v 1.4 90/03/20 23:36:58 johani Exp $

(define (demo-toggle scr)
  (let ((terminate #f)
	(t1 (make-imagetext8 40 35 "Red"))
	(t2 (make-imagetext8 40 55 "Blue"))
	(t3 (make-imagetext8 40 75 "Quit"))
	(cmap (scr 'default-colormap))
	(w (make-window 200 200 (scr 'root-depth) 0 0 (scr 'root)
			0 'CopyFromParent 'CopyfromParent scr)) )
    (let ((yellow (cmap 'allocnamedcolor "yellow"))
	  (red (cmap 'allocnamedcolor "red"))
	  (blue (cmap 'allocnamedcolor "blue"))
	  (red-w (make-window 50 50 (scr 'root-depth) 60 130 w
			      0 'CopyFromParent 'CopyFromParent scr))
	  (blue-w (make-window 50 50 (scr 'root-depth) 130 130 w
				0 'CopyFromParent 'CopyFromParent scr))
	  (gc-dw (make-gc (make-gc-value-mask `(foreground ,(scr 'blackpixel)))
			    (scr 'root)))
	  (gc-rv (make-gc (make-gc-value-mask `(foreground ,(scr 'whitepixel)))
			   (scr 'root)))
	 (gc-inv  (make-gc (make-gc-value-mask
			    '(function Xor)
			    `(foreground 
			      ,(let* ((c-inv (make-color 0 0 0)))
				 (c-inv 'set-pixel! 1)
				 c-inv)))
			   (scr 'root)))
	  (font (make-font
		 "-adobe-times-medium-r-normal--18-180-75-75-p-94-iso8859-1"
		 scr)) )
      (let* ((gc (make-gc (make-gc-value-mask
			   `(foreground ,(scr 'blackpixel))
			   `(background ,yellow)
			   `(font ,font))
			  (scr 'root)))
	     (b1 (make-toggle-button 15 15 20 20 gc-dw gc-rv gc-inv w 
				     (lambda () (red-w 'mapwindow))
				     (lambda () (red-w 'unmapwindow))
				     scr))
	     (b2 (make-toggle-button 15 15 20 40 gc-dw gc-rv gc-inv w 
				     (lambda () (blue-w 'mapwindow))
				     (lambda () (blue-w 'unmapwindow))
				     scr))
	     (b3 (make-toggle-button 15 15 20 60 gc-dw gc-rv gc-inv w
				     (lambda ()
				       (w 'destroywindow)
				       (map (lambda (o)
					      (o 'freegc) )
					    (list gc gc-dw gc-rv gc-inv) )
				       (font 'closefont)
				       (set! terminate #t) )
				     (lambda () #f)
				     scr) ))
	(w 'add-callback! 'Expose (lambda (event window)
				    (window 'draw (list t1 t2 t3) gc)
				    (scr 'flush!) ))
	
	(w 'createwindow
	   (make-window-value-mask `(background-pixel ,yellow)
				   `(event-mask ,(make-event-mask
						  'VisibilityChange
						  'Exposure))))
	(red-w 'createwindow
	       (make-window-value-mask `(background-pixel ,red)))
	(blue-w 'createwindow
		 (make-window-value-mask `(background-pixel ,blue)))
	(w 'changeproperty 'replace 'wm_name 'string 8 "SCIX Toggle-buttons")
	(w 'mapwindow)
	(b1 'activate)
	(b2 'activate)
	(b3 'activate)
	(msg-handler 'mainloop (lambda () terminate) (list scr)) ))))