;;; A pointer-tracker with a quit-button. Hakan Huss, KTH and Johan Ihren, KTH

;;; $Header: tracker.sc,v 1.3 90/03/20 23:37:06 johani Exp $

;;; Note that the only use for the "main program" is to be able to report how
;;; many lines has been drawn.

(define (demo-tracker scr)
  (let* ((cmap (scr 'default-colormap))
	 (root (scr 'root))
	 (white (scr 'whitepixel))
	 (black (scr 'blackpixel))
	 (w (make-window 300 300 (scr 'root-depth) 0 0 root
			 0 'CopyFromParent 'CopyFromParent scr))
	 (gc-draw (make-gc (make-gc-value-mask `(foreground ,black)
					       `(background ,white) )
			   (scr 'root)))
	 (gc-rev  (make-gc (make-gc-value-mask `(foreground ,white)
					       `(background ,black) )
			   (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)))
	 (paint-gc (make-gc (make-gc-value-mask '(function Copy)
						`(foreground ,black) )
			    (scr 'root)))
	 (origin '(150 150))
	 (nr-of-lines 0)
	 (terminate #f)
	 (do-quit (lambda ()
		    (w 'destroywindow)
		    (map (lambda (o) (o 'freegc))
			 (list paint-gc gc-draw gc-rev gc-inv) )
		    (scr 'flush!)
		    (set! terminate #t) ))
	 (do-suspend (lambda ()
		       (set! terminate #t) ))
	 (quit-button (make-text-button 25 5 20 20 "Quit" gc-draw
					gc-rev gc-inv w do-quit scr))
	 (suspend-button (make-text-button 25 5 60 20 "Suspend" gc-draw
					   gc-rev gc-inv w do-suspend scr)) )

    (w 'createwindow (make-window-value-mask
		      `(background-pixel ,white)
		      `(event-mask ,(make-event-mask 'PointerMotion))))
    (w 'add-callback! 'MotionNotify
       (lambda (event window)
	 (let ((new-line (make-polyline 'origin
					(list origin
					      (list (event 'event-x)
						    (event 'event-y) )))))
	   (set! nr-of-lines (+ 1 nr-of-lines))
	   (w 'draw (list new-line) paint-gc)
	   (scr 'flush!) )))

    (w 'changeproperty 'replace 'wm_name 'string 8 "SCIX Tracker")
    (w 'mapwindow)
    (quit-button 'activate)
    (suspend-button 'activate)
    (scr 'flush!)
    (msg-handler 'mainloop
		 #f
		 (list scr)
		 (lambda (handle-events)
		   (let loop ()
		     (handle-events)
		     (if terminate
			 (begin
			   (format #t "~a lines drawn.~%" nr-of-lines)
			   (flush-buffer)
			   'done)
			 (loop) ))))))