aboutsummaryrefslogtreecommitdiffhomepage
path: root/gui/menus.lisp
blob: 25abd7b201f6bf1194c445b819cbe3d5585febc3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
;;;; 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))