-
Notifications
You must be signed in to change notification settings - Fork 19
/
Copy pathdesktop-mode.lisp
230 lines (206 loc) · 9.06 KB
/
desktop-mode.lisp
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
(in-package :ulubis)
(defparameter *default-mode* nil)
(defparameter *ortho* (m4:identity))
(defmode desktop-mode ()
((clear-color :accessor clear-color
:initarg :clear-color
:initform (list (random 1.0)
(random 1.0)
(random 1.0) 0.0))
(projection :accessor projection
:initarg :projection
:initform (m4:identity))
(focus-follows-mouse :accessor focus-follows-mouse
:initarg :focus-follows-mouse
:initform nil)))
(defmethod init-mode ((mode desktop-mode))
(setf *ortho* (ortho 0 (screen-width *compositor*) (screen-height *compositor*) 0 1 -1))
(cepl:map-g #'mapping-pipeline nil)
(setf (render-needed *compositor*) t))
(defun pointer-changed-surface (mode x y old-surface new-surface)
(setf (cursor-surface *compositor*) nil)
(when (focus-follows-mouse mode)
(deactivate old-surface))
(send-leave old-surface)
(setf (pointer-surface *compositor*) new-surface)
(when (focus-follows-mouse mode)
(activate-surface new-surface mode))
(send-enter new-surface x y))
(defmethod mouse-motion-handler ((mode desktop-mode) time delta-x delta-y)
(with-slots (pointer-x pointer-y) *compositor*
(update-pointer delta-x delta-y)
(when (cursor-surface *compositor*)
(setf (render-needed *compositor*) t))
(let ((old-surface (pointer-surface *compositor*))
(current-surface (surface-under-pointer pointer-x pointer-y (view mode))))
(cond
;; 1. If we are dragging a window...
((moving-surface *compositor*)
(move-surface pointer-x pointer-y (moving-surface *compositor*)))
;; 2. If we are resizing a window...
((resizing-surface *compositor*)
(resize-surface pointer-x pointer-y (view mode) (resizing-surface *compositor*)))
;; 3. The pointer has left the current surface
((not (equalp old-surface current-surface))
(setf (cursor-surface *compositor*) nil)
(pointer-changed-surface mode pointer-x pointer-y old-surface current-surface))
;; 4. Pointer is over previous surface
((equalp old-surface current-surface)
(send-surface-pointer-motion pointer-x pointer-y time current-surface))))))
(defun pulse-animation (surface)
(setf (origin-x surface) (/ (width (wl-surface surface)) 2))
(setf (origin-y surface) (/ (height (wl-surface surface)) 2))
(sequential-animation
nil
(parallel-animation
nil
(animation :duration 100
:easing-fn 'easing:linear
:to 1.05
:target surface
:property 'scale-x)
(animation :duration 100
:easing-fn 'easing:linear
:to 1.05
:target surface
:property 'scale-y))
(parallel-animation
nil
(animation :duration 100
:easing-fn 'easing:linear
:to 1.0
:target surface
:property 'scale-x)
(animation :duration 100
:easing-fn 'easing:linear
:to 1.0
:target surface
:property 'scale-y))))
(defmethod mouse-button-handler ((mode desktop-mode) time button state)
;; 1. Change (possibly) the active surface
(when (and (= button #x110) (= state 1) (= 0 (mods-depressed *compositor*)))
(let ((surface (surface-under-pointer (pointer-x *compositor*) (pointer-y *compositor*) (view mode))))
;; When we click on a client which isn't the first client
(when (and surface (not (equalp surface (active-surface (view mode)))))
(start-animation (pulse-animation surface) :finished-fn (lambda ()
(setf (origin-x surface) 0.0)
(setf (origin-y surface) 0.0))))
(activate-surface surface mode)
(when surface
(raise-surface surface (view mode))
(setf (render-needed *compositor*) t))))
;; Drag window
(when (and (= button #x110) (= state 1) (= Gui (mods-depressed *compositor*)))
(let ((surface (surface-under-pointer (pointer-x *compositor*) (pointer-y *compositor*) (view mode))))
(when surface
(setf (moving-surface *compositor*) ;;surface))))
(make-move-op :surface surface
:surface-x (x surface)
:surface-y (y surface)
:pointer-x (pointer-x *compositor*)
:pointer-y (pointer-y *compositor*))))))
;; stop drag
(when (and (moving-surface *compositor*) (= button #x110) (= state 0))
(setf (moving-surface *compositor*) nil))
;; Resize window
(when (and (= button #x110) (= state 1) (= (+ Gui Shift) (mods-depressed *compositor*)))
(let ((surface (surface-under-pointer (pointer-x *compositor*) (pointer-y *compositor*) (view mode))))
(when surface
(let ((width (effective-width surface))
(height (effective-height surface)))
(setf (resizing-surface *compositor*)
(make-resize-op :surface surface
:pointer-x (pointer-x *compositor*)
:pointer-y (pointer-y *compositor*)
:surface-width width
:surface-height height
:direction 10))))))
(when (and (resizing-surface *compositor*) (= button #x110) (= state 0))
(setf (resizing-surface *compositor*) nil))
;; 2. Send active surface mouse button
(when (surface-under-pointer (pointer-x *compositor*)
(pointer-y *compositor*)
(view mode))
(let ((surface (surface-under-pointer (pointer-x *compositor*)
(pointer-y *compositor*)
(view mode))))
(send-button surface time button state))))
(defkeybinding (:pressed "q" Ctrl Shift) () (desktop-mode)
(uiop:quit))
(defkeybinding (:pressed "s" Ctrl Shift) () (desktop-mode)
(screenshot))
(defkeybinding (:pressed "T" Ctrl Shift) () (desktop-mode)
(run-program "/usr/bin/weston-terminal"))
(defkeybinding (:pressed "Tab" Gui) (mode) (desktop-mode)
(push-mode (view mode) (make-instance 'alt-tab-mode)))
(defmethod first-commit ((mode desktop-mode) (surface isurface))
(let ((animation (sequential-animation
(lambda ()
(setf (origin-x surface) 0.0)
(setf (origin-y surface) 0.0))
(animation :target surface
:property 'scale-x
:easing-fn 'easing:out-exp
:from 0
:to 1.0
:duration 250)
(animation :target surface
:property 'scale-y
:easing-fn 'easing:out-exp
:to 1.0
:duration 250))))
(setf (origin-x surface) (/ (width (wl-surface surface)) 2))
(setf (origin-y surface) (/ (height (wl-surface surface)) 2))
(setf (scale-y surface) (/ 6 (height (wl-surface surface))))
(setf (first-commit-animation surface) animation)
(start-animation animation)))
(cepl:defun-g desktop-mode-vertex-shader ((vert cepl:g-pt) &uniform (origin :mat4) (origin-inverse :mat4) (surface-scale :mat4) (surface-translate :mat4))
(values (* *ortho* surface-translate origin-inverse surface-scale origin (rtg-math:v! (cepl:pos vert) 1))
(:smooth (cepl:tex vert))))
(cepl:defpipeline-g mapping-pipeline ()
(desktop-mode-vertex-shader cepl:g-pt) (default-fragment-shader :vec2))
(defmethod render ((surface isurface) &optional view-fbo)
(when (texture (wl-surface surface))
(with-rect (vertex-stream (width (wl-surface surface)) (height (wl-surface surface)))
(let ((texture (texture-of surface)))
(gl:viewport 0 0 (screen-width *compositor*) (screen-height *compositor*))
(map-g-default/fbo view-fbo #'mapping-pipeline vertex-stream
:origin (m4:translation (rtg-math:v! (- (origin-x surface)) (- (origin-y surface)) 0))
:origin-inverse (m4:translation (rtg-math:v! (origin-x surface) (origin-y surface) 0))
:surface-scale (m4:scale (rtg-math:v! (scale-x surface) (scale-y surface) 1.0))
:surface-translate (m4:translation (rtg-math:v! (x surface) (y surface) 0.0))
:texture texture
:alpha (opacity surface))))
(loop :for subsurface :in (reverse (subsurfaces (wl-surface surface)))
:do (render subsurface view-fbo))))
(defmethod render ((surface wl-subsurface) &optional view-fbo)
(when (texture (wl-surface surface))
(with-rect (vertex-stream (width (wl-surface surface)) (height (wl-surface surface)))
(let ((texture (texture-of surface)))
(gl:viewport 0 0 (screen-width *compositor*) (screen-height *compositor*))
(map-g-default/fbo view-fbo #'mapping-pipeline vertex-stream
:origin (m4:translation (rtg-math:v! (+ (x surface) (- (origin-x (role (parent surface)))))
(+ (y surface) (- (origin-y (role (parent surface)))))
0))
:origin-inverse (m4:translation (rtg-math:v! (+ (- (x surface)) (origin-x (role (parent surface))))
(+ (- (y surface)) (origin-y (role (parent surface))))
0))
:surface-scale (m4:scale (rtg-math:v! (scale-x (role (parent surface)))
(scale-y (role (parent surface)))
1.0))
:surface-translate (m4:translation (rtg-math:v! (+ (x (role (parent surface))) (x surface))
(+ (y (role (parent surface))) (y surface))
0.0))
:texture texture
:alpha (opacity surface))))
(loop :for subsurface :in (reverse (subsurfaces (wl-surface surface)))
:do (render subsurface view-fbo))))
(defmethod render ((mode desktop-mode) &optional view-fbo)
(apply #'gl:clear-color (clear-color mode))
(when view-fbo
(cepl:clear view-fbo))
(cepl:with-blending (blending-parameters mode)
(mapcar (lambda (surface)
(cepl:with-blending (blending-parameters mode)
(render surface view-fbo)))
(reverse (surfaces (view mode))))))