blob: a477dd90d40190937220be74bce96a51e461ab6f (
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
129
130
131
132
|
;;;; menus.lisp
(in-package :wheelwork)
(def:class menu (unit interactive)
((items "list of interactive units in the menu")
:prefix :type list :initform nil)
((focus "Object of menu with current focus.")
:prefix :type (or null unit) :initform nil)
((region "Region where menu is displayed.")
:required :type 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)))
(def:class vscroller (menu)
(scroll-speed :type fixnum :initform 1)
(vert-scroll
:type fixnum
:initform 0
:documentation "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))
|
