;;;; menus.lisp

(in-package :wheelwork)

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

(defmethod cleanup :after ((menu menu))
  (loop for item in (menu-items menu) do (cleanup item)))

(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))
         (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-items menu))
                            (incf (,name o) diff)))))))
         `(progn ,@defs))))
  (def-menu-accessors x y width height))


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

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

(defparameter +menu-mouseover-tag+ "menu-mouseover-tag")

(defgeneric add-menu-item (menu item))
(defmethod add-menu-item ((menu menu) item)
  (setf (unit-region item) (unit-region menu)
        (focusablep item) nil)  ; so that event handling here doesn't steal menu focus
  (add-handler
   item
   (on-mousemotion ()
     :tag +menu-mouseover-tag+
     (setf (menu-focus menu) item)))
  (setf (menu-items menu)
        (nconc (menu-items menu) (list item)))
  (when (unit-in-scene-p menu)
    (add-unit item)))

(defgeneric remove-menu-item (menu item))

(defmethod remove-menu-item ((menu menu) item)
  (when (member item (menu-items menu))
    (setf (unit-region item) *application*)
    (setf (menu-items menu)
          (delete item (menu-items menu)))
    (remove-handler item :mousemotion :tag +menu-mouseover-tag+)
    (drop-unit item)))

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


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

(defmethod (setf vert-scroll) :after (val (vs vscroller))
  (loop
    for o in  (menu-items 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-items-height vs))
            (h (height vs)))
        (setf (vert-scroll vs)
              (clamp 0
                     (+ (vert-scroll vs) (* vert (scroll-speed vs)))
                     (- oh h))))))

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

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

(defun refresh-vscroller (vs)
  (setf (vert-scroll vs) (vert-scroll vs)))

(defmethod remove-menu-item :after ((vs vscroller) item)
  (refresh-vscroller vs)) 

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