blob: 77ce56f7b689ec75a2182f1aced114c7fe0b03f8 (
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
|
;;;; 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 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)))
(defconstant +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))
|
