blob: f758d513badb1d3e7c96621062f838ab9e2deab7 (
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
|
;;;; 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))
|
