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
231
232
233
|
;; Copyright (C) 2003-2008 Shawn Betts
;;
;; This file is part of stumpwm.
;;
;; stumpwm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; stumpwm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;; Commentary:
;;
;; Head functionality
;;
;; Code:
(in-package #:stumpwm)
(export '(current-head))
(defun head-by-number (screen n)
(find n (screen-heads screen) :key 'head-number))
(defun screen-info-head (screen-info)
"Transform SCREEN-INFO structure from CLX to a HEAD structure from StumpWM."
(make-head :number (xinerama:screen-info-number screen-info)
:x (xinerama:screen-info-x screen-info)
:y (xinerama:screen-info-y screen-info)
:width (xinerama:screen-info-width screen-info)
:height (xinerama:screen-info-height screen-info)
:window nil))
(defun output->head (output count)
(multiple-value-bind
(request-status _0 crtc _1 _2 status _3 _4 _5 _6 _7 name)
(xlib:rr-get-output-info *display* output (get-universal-time))
(declare (ignore _0 _1 _2 _3 _4 _5 _6 _7))
(when (and (eq request-status :success)
(eq status :connected)
(plusp crtc))
(multiple-value-bind
(request-status config-timestamp x y width height)
(xlib:rr-get-crtc-info *display* crtc (get-universal-time))
(declare (ignore config-timestamp))
(when (eq request-status :success)
(make-head :number count
:x x
:y y
:width width
:height height
:window nil
:name name))))))
(defun make-screen-randr-heads (root)
(loop :with outputs := (nth-value 3 (xlib:rr-get-screen-resources root))
:for count :from 0
:for output :in outputs
:for head := (output->head output count)
:when head
:collect head))
(defun make-screen-heads (screen root)
(declare (ignore screen))
;; Query for whether the server supports RANDR, if so, call the
;; randr version of make-screen-heads.
(or
(and (xlib:query-extension *display* "RANDR") (make-screen-randr-heads root))
(and (xlib:query-extension *display* "XINERAMA")
(xinerama:xinerama-is-active *display*)
(mapcar 'screen-info-head
(xinerama:xinerama-query-screens *display*)))
(list (make-head :number 0 :x 0 :y 0
:width (xlib:drawable-width root)
:height (xlib:drawable-height root)
:window nil))))
(defun copy-heads (screen)
"Return a copy of screen's heads."
(mapcar 'copy-frame (screen-heads screen)))
(defun find-head-by-position (screen x y)
(dolist (head (screen-heads screen))
(when (and (>= x (head-x head))
(>= y (head-y head))
(<= x (+ (head-x head) (head-width head)))
(<= y (+ (head-y head) (head-height head))))
(return head))))
(defgeneric frame-head (group frame)
(:documentation "Return the head frame is on")
(:method (group frame)
"As a fallback, use the frame's position on the screen to return a head
in the same position. This can be out of sync with stump's state if was
moved by something else, such as X11 during an external monitor change. It
also doesn't work in the middle of rescaling a head."
(let ((center-x (+ (frame-x frame) (ash (frame-width frame) -1)))
(center-y (+ (frame-y frame) (ash (frame-height frame) -1))))
(find-head-by-position (group-screen group) center-x center-y))))
(defun group-heads (group)
(screen-heads (group-screen group)))
(defun resize-head (number x y width height)
"Resize head number `number' to given dimension."
(let* ((screen (current-screen))
(oh (find number (screen-heads screen) :key 'head-number))
(nh (make-head :number number
:x x :y y
:width width
:height height
:window nil)))
(scale-head screen oh nh)
(dolist (group (screen-groups screen)) (group-sync-head group oh))
(update-mode-lines screen)))
(defun current-head (&optional (group (current-group)))
(group-current-head group))
(defun head-windows (group head)
"Returns a list of windows on HEAD of GROUP"
(remove-if-not
(lambda (w)
(handler-case (eq head (window-head w))
(unbound-slot () nil)))
(group-windows group)))
(defun frame-is-head (group frame)
(< (frame-number frame) (length (group-heads group))))
(defun add-head (screen head)
(dformat 1 "Adding head #~D~%" (head-number head))
(setf (screen-heads screen) (sort (push head (screen-heads screen)) #'<
:key 'head-number))
(dolist (group (screen-groups screen))
(group-add-head group head)))
(defun remove-head (screen head)
(dformat 1 "Removing head #~D~%" (head-number head))
(let ((mode-line (head-mode-line head)))
(when mode-line
(destroy-mode-line mode-line)))
(dolist (group (screen-groups screen))
(group-remove-head group head))
;; Remove it from SCREEN's head list.
(setf (screen-heads screen) (delete head (screen-heads screen))))
(defun replace-head (screen old-head new-head)
"Replaces one head with another, while preserving its frame-tree"
(dformat 1 "Replacing head ~A with head ~A" old-head new-head)
(when-let (mode-line (head-mode-line old-head))
(move-mode-line-to-head mode-line new-head))
(dolist (group (screen-groups screen))
(group-replace-head screen group old-head new-head))
(setf (screen-heads screen)
(sort (append (list new-head)
(remove old-head (screen-heads screen)))
#'<
:key 'head-number))
(scale-head screen new-head old-head)) ; opposite of its calling convention
(defun scale-head (screen oh nh)
"Scales head OH to match the dimensions of NH."
(let ((nhx (head-x nh))
(nhy (head-y nh))
(nhw (head-width nh))
(nhh (head-height nh)))
(unless (and (= (head-x oh) nhx)
(= (head-y oh) nhy)
(= (head-width oh) nhw)
(= (head-height oh) nhh))
(dolist (group (screen-groups screen))
(group-before-resize-head group oh nh))
(setf (head-x oh) nhx
(head-y oh) nhy
(head-width oh) nhw
(head-height oh) nhh)
(dolist (group (screen-groups screen))
(group-after-resize-head group oh)))))
(defun scale-screen (screen heads)
"Scale all frames of all groups of SCREEN to match the dimensions of HEADS."
(let ((old-heads (screen-heads screen)))
(let* ((added-heads (set-difference heads old-heads :test '= :key 'head-number))
(removed-heads (set-difference old-heads heads :test '= :key 'head-number))
(max-change (max (length added-heads) (length removed-heads))))
(loop repeat max-change ; This is, unfortunately, the loop syntax for stopping at the max of two lists
for added-head-list = added-heads then (cdr added-head-list)
for added-head = (car added-head-list)
for removed-head-list = removed-heads then (cdr removed-head-list)
for removed-head = (car removed-head-list)
do (if added-head
(if removed-head
(replace-head screen removed-head added-head)
(add-head screen added-head))
(remove-head screen removed-head)))
;; This rescales altered, but existing screens eg a screen resolution change
(dolist (head (intersection heads old-heads :test '= :key 'head-number))
(let ((new-head (find (head-number head) heads :test '= :key 'head-number))
(old-head (find (head-number head) old-heads :test '= :key 'head-number)))
(scale-head screen old-head new-head))))
(when-let ((orphaned-frames (orphaned-frames screen)))
(let ((group (current-group)))
(dformat 1 "Orphaned frames ~A found on screen ~A! Adopting into group ~A"
orphaned-frames screen group)
(group-adopt-orphaned-windows group screen)))))
(defun head-force-refresh (screen new-heads)
(scale-screen screen new-heads)
(mapc 'group-sync-all-heads (screen-groups screen))
(loop for new-head in new-heads
do (run-hook-with-args *new-head-hook* new-head screen)))
(defcommand refresh-heads (&optional (screen (current-screen))) ()
"Refresh screens in case a monitor was connected, but a
ConfigureNotify event was snarfed by another program."
(head-force-refresh screen (make-screen-heads screen (screen-root screen))))
(defun orphaned-frames (screen)
"Returns a list of frames on a screen not associated with any group.
These shouldn't exist."
(let ((adopted-frames (loop for group in (screen-groups screen)
unless (typep group 'float-group)
append (group-frames group))))
(set-difference (screen-frames screen) adopted-frames)))
|
