;;; -*- Mode: LISP -*-
;;; 
;;; Bouncy pushy window mixin
;;; By Don Hopkins


(defflavor pushy-bounce-window-mixin (x-vel y-vel gravity friction proc delay)
	   ()
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables
  (:required-flavors tv:window))

(defflavor pushy-bounce-lisp-listener
	()
	(pushy-bounce-window-mixin tv:lisp-listener))

(defmethod (pushy-bounce-window-mixin :move-rel) (dx dy)
  (multiple-value-bind (s-width s-height)
		       (send tv:superior ':inside-size)
    (let ((new-x (+ tv:x-offset dx))
	  (new-y (+ tv:y-offset dy))
	  (x-bounds (- s-width tv:width))
	  (y-bounds (- s-height tv:height)))
      (cond ((or (< new-x 0)
		 (> new-x x-bounds))
	     (setq x-vel (- x-vel))))
      (cond ((or (< new-y 0)
		 (> new-y y-bounds))
	     (setq y-vel (- y-vel))))
      (send self ':set-position
		 (max 0 (min new-x x-bounds))
		 (max 0 (min new-y y-bounds))))))

(defmethod (pushy-bounce-window-mixin :move) ()
  (send self ':move-rel x-vel y-vel))

(defmethod (pushy-bounce-window-mixin :fall) ()
  (setq y-vel (+ y-vel gravity))
  (setq x-vel (*$ x-vel friction)
	y-vel (*$ y-vel friction))
  (send self ':move))

(defmethod (pushy-bounce-window-mixin :mouse-moves) (x y)
  (tv:mouse-set-blinker-cursorpos) 
  (send self ':move-rel (setq x-vel
			      (cond ((< x (* tv:width .3)) x)
				    ((> x (* tv:width .7)) (- x tv:width))
				    (t 0)))
			(setq y-vel
			      (cond ((< y (* tv:height .3)) y)
				    ((> y (* tv:height .7)) (- y tv:height))
				    (t 0)))))

(defun make-pushy-bounce-thing (thing name x y wdt hgt xv yv grav frict delay &optional (sup terminal-io))
  (let ((window (tv:make-window thing
				':name name
				':width wdt
				':height hgt
				':x x
				':y y
;				':superior sup
				':x-vel xv
				':y-vel yv
				':gravity grav
				':friction frict
				':proc (make-process name ':warm-boot-action nil)
				':delay delay)))
    (send window ':expose)
    window))

(defun make-window-fall (window)
  (do () (())
    (send window ':fall)
    (process-sleep (send window ':delay) "Zzzzzz....")))

(defmethod (pushy-bounce-window-mixin :start-falling) ()
  (send proc ':preset 'make-window-fall self)
  (process-reset-and-enable proc))

(defmethod (pushy-bounce-window-mixin :stop-falling) ()
  (process-disable proc))

(defun test ()
  (send (make-pushy-bounce-thing 'pushy-bounce-lisp-listener
				 "Pushy Bounce Lisp Listener"
				 20 20 400 300
				 12 2 3 0.99 2)
	':start-falling))