;;;; menus.lisp

(in-package :wheelwork)

(defclass/std menu (unit interactive)
  ((options :with :std nil
                  :doc "A list of interactive units")
   (focus :with :std nil
          :doc "The option that is focused in this menu, if any.")
   (region :std (error "Menus require an explicit region"))))

(defmethod initialize-instance :after ((menu menu) &key)
  (with-slots (base-width base-height region) menu 
    (setf base-width (width region)
          base-height (height region)
          (x menu) (region-left region)
          (y menu) (region-bottom region))))

(defmethod (setf closer-mop:slot-value-using-class) :before
    (new-value class (menu menu) slot)
  (case (closer-mop:slot-definition-name slot)
    (focus
     (when (slot-boundp menu 'focus)
       (unless (eq new-value (slot-value menu 'focus))
         (fire-blur-event-on (slot-value menu 'focus)))))))

(defmethod (setf closer-mop:slot-value-using-class ) :after
    (new-value class (menu menu) slot)
  (case (closer-mop:slot-definition-name slot)
    (focus
     (fire-focus-event-on new-value))))

(macrolet
    ((def-menu-accessors (&rest accessor-names)
       (let ((defs
               (loop for name in accessor-names
                     collect
                     `(defmethod ,name ((menu menu))
                        (,name (unit-region menu)))

                     collect
                     `(defmethod (setf ,name) (newval (menu menu))
                        (let ((diff (- newval (,name menu)))) 
                          (setf (,name (unit-region menu)) newval)
                          (dolist (o (menu-options menu))
                            (incf (,name o) diff)))))))
         `(progn ,@defs))))
  (def-menu-accessors x y width height))


(defmethod add-unit :after ((menu menu))
  (dolist (o (menu-options menu))
    (add-unit o)))

(defmethod drop-unit :before ((menu menu))
  (dolist (o (menu-options menu))
    (drop-unit o)))

(defgeneric add-menu-option (menu option))
(defmethod add-menu-option ((menu menu) option)
  (setf (unit-region option) (unit-region menu))
  (setf (menu-options menu)
        (nconc (menu-options menu) (list option)))
  (when (unit-in-scene-p menu)
    (add-unit option)))

(defun remove-menu-option (menu option)
  (when (member option (menu-options menu))
    (setf (unit-region option) *application*)
    (setf (menu-options menu)
          (delete option (menu-options menu)))
    (drop-unit option)))

(defmethod render ((menu menu))
  (dolist (o (menu-options menu))
    (render o)))


(defclass/std vscroller (menu) 
  ((scroll-speed :std 1)
   (vert-scroll :std 0
                :doc "Vertical distance options have been displaced.")))

(defmethod (setf vert-scroll) :after (val (vs vscroller))
  (loop
    for o in  (menu-options vs)
    for y = (+ (y vs) (height vs) val) then (- y (height o))
    do (setf (y o) y)))

(defhandler vscroller-scroll
    (on-mousewheel (vs horiz vert)
      (let ((oh (vscroller-options-height vs))
            (h (height vs)))
        (setf (vert-scroll vs)
              (clamp 0
                     (+ (vert-scroll vs) (* vert (scroll-speed vs)))
                     (- oh h))))))

(defun vscroller-options-height (vs)
  (loop for o in (menu-options vs) summing (height o)))

(defmethod add-menu-option :before ((vs vscroller) option)
  (setf (x option) (x vs)
        (y option) (- (+ (y vs) (height vs) (vert-scroll vs))
                      (vscroller-options-height vs))))

(defmethod initialize-instance :after ((vscroller vscroller) &key)
  (add-handler vscroller #'vscroller-scroll))