;;;; button.lisp

(in-package #:wheelwork)

(defclass/std button (unit interactive)
  ((up down :with
       :std (error "UP and DOWN lots are required")
       :doc "Any affine renderable unit")
   ()
   (on-press on-release :doc "Function accepting the button."))
  (:documentation "A basic button class. The UP and DOWN slots should
  be filled with renderable objects having the same size."))

(defhandler button-released
    (on-mouseup ()
      (with-slots (up down on-release) target
        (setf (unit-visiblep up) t
              (unit-visiblep down) nil)
        (when on-release
          (funcall on-release target)))))

(defhandler button-pressed
    (on-mousedown ()
      (with-slots (up down on-press) target
        (setf (unit-visiblep up) nil
              (unit-visiblep down) t)
        (when on-press
          (funcall on-press target)))))

(defmethod initialize-instance :after ((button button) &key)
  (add-handler button #'button-pressed)
  (add-handler button #'button-released)
  (with-slots (up down) button 
    (setf (unit-visiblep down) nil
          (unit-visiblep up) t
          (unit-container up) button
          (unit-container down) button)))

(defmethod cleanup ((button button))
  (with-slots (up down) button
    (cleanup up)
    (cleanup down)))

(defmethod render ((button button))
  (with-slots (up down) button
    (if (unit-visiblep up)
        (render up)
        (render down))))

(defmethod x ((button button))
  (x (button-up button)))

(defmethod (setf x) (newval (button button))
  (setf (x (button-up button)) newval
        (x (button-down button)) newval))

(defmethod y ((button button))
  (y (button-up button)))

(defmethod (setf y) (newval (button button))
  (setf (y (button-up button)) newval
        (y (button-down button)) newval))

(defmethod scale-x ((thing button))
  (scale-x (button-up thing)))

(defmethod (setf scale-x) (newval (thing button))
  (setf (scale-x (button-up thing)) newval
        (scale-x (button-down thing)) newval))

(defmethod scale-y ((thing button))
  (scale-y (button-up thing)))

(defmethod (setf scale-y) (newval (thing button))
  (setf (scale-y (button-up thing)) newval
        (scale-y (button-down thing)) newval))

(defmethod rotation ((thing button))
  (rotation (button-up thing)))

(defmethod (setf rotation) (newval (thing button))
  (setf (rotation (button-up thing)) newval
        (rotation (button-down thing)) newval))


(defmethod width ((thing button))
  (width (button-up thing)))

(defmethod (setf width) (newval (thing button))
  (setf (width (button-up thing)) newval
        (width (button-down thing)) newval))

(defmethod height ((thing button))
  (height (button-up thing)))

(defmethod (setf height) (newval (thing button))
  (setf (height (button-up thing)) newval
        (height (button-down thing)) newval))



(defun make-texture-button (up down &key pressed released)
  "UP and DOWN should be strings naming assets to use as the up and
  down images for the button."
  (make-instance
   'button
   :on-press pressed :on-release released
   :up (make-instance 'bitmap :texture (get-asset up))
   :down (make-instance 'bitmap :texture (get-asset down))))