;;; demo-bounce -- a black ball bounces around in a white window.
;;; Hakan Huss, KTH and Johan Ihren, KTH

;;; $Header: bounce.sc,v 1.3 90/03/20 23:36:27 johani Exp $

(define (demo-bounce width height scr)
  (let* ((w (make-window width height (scr 'root-depth) 0 0 (scr 'root)
			 0 'CopyFromParent 'CopyFromParent scr))
	 (ball-w (make-window 50 50 0 0 0 w
			      0 'CopyFromParent 'CopyFromParent scr))
	 (gc (make-gc (make-gc-value-mask `(foreground ,(scr 'blackpixel))
					  `(background ,(scr 'whitepixel))
					  `(arc-mode Chord) )
		      (scr 'root) ))
	 (black (scr 'blackpixel))
	 (white (scr 'whitepixel))
	 (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)))
	 (ball (make-polyfillarc `((0 0 50 50 0 ,(* 64 360)))))
	 (terminate #f)
	 (do-quit (lambda ()
		    (w 'destroywindow)
		    (map (lambda (o) (o 'freegc))
			 (list gc gc-draw gc-rev gc-inv) )
		    (scr 'flush!)
		    (set! terminate #t) ))
	 (quit-button (make-text-button 25 5 20 20 "Quit" gc-draw
					gc-rev gc-inv w do-quit scr) ))
    
    (w 'createwindow
       (make-window-value-mask `(background-pixel ,(scr 'whitepixel))
			       `(event-mask
				 ,(make-event-mask 'StructureNotify) )))
    
    (ball-w 'createwindow
	    (make-window-value-mask `(background-pixel ,(scr 'whitepixel))
				    `(event-mask 
				      ,(make-event-mask 'Exposure
							'VisibilityChange) )))
    
    (w 'add-callback! 'ConfigureNotify (lambda (event window)
					 (set! width (event 'width))
					 (set! height (event 'height)) ))

    (ball-w 'add-callback! 'Expose (lambda (event window)
				     (if (and (zero? (event 'count))
					      (not terminate) )
					 (begin
					   (ball-w 'draw (list ball) gc)
					   (scr 'flush!) ))))

    (w 'changeproperty 'replace 'wm_name 'string 8 "SCIX Bounce!")
    (quit-button 'activate)
    (ball-w 'mapwindow)
    (w 'mapwindow)
    (scr 'flush!)

    (msg-handler 'mainloop
		 (lambda () terminate)
		 (list scr)
		 (lambda (event-handler)
		   (let ((dx 2) (dy 2) (xmin 0) (xmax (- width 50))
				(ymin 0) (ymax (- height 50)))
		     (let loop ((moves 0) (count 10) (xpos 0) (ypos 0))
		       (ball-w 'configurewindow
			       (make-configure-value-mask `(x ,xpos)
							  `(y ,ypos) ))
		       (if (zero? count)
			   (begin
			     (event-handler)
			     (set! xmax (- width 50))
			     (set! ymax (- height 50))
			     (set! count 10) ))
		       (if (not terminate)
			   (begin
			     (cond ((< xpos xmin) (set! dx 2))
				   ((> xpos xmax) (set! dx -2)) )
			     (cond ((< ypos ymin) (set! dy 2))
				   ((> ypos ymax) (set! dy -2)) )
			     (loop (+ moves 1) (- count 1)
				   (+ xpos dx) (+ ypos dy)) )
			   (begin
			     (format #t "Ball moved ~a times.~%" moves)
			     (flush-buffer)
			     'done))))))))