;;; -*- Mode: LISP -*-
;;;
;;; Pushy bounce window mixin
;;; Implemented for the Lisp Machine with Flavors
;;; 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))