1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Tile, pack and fill functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; --------------------------------------------------------------------------
32 (defun frame-x2 (frame)
33 (+ (frame-x frame
) (frame-w frame
)))
35 (defun frame-y2 (frame)
36 (+ (frame-y frame
) (frame-h frame
)))
39 (defun find-edge-up (current-frame parent
)
42 (dolist (frame (frame-child parent
))
43 (when (and (frame-p frame
)
44 (not (equal frame current-frame
))
45 (<= (frame-y2 frame
) (frame-y current-frame
))
46 (>= (frame-x2 frame
) (frame-x current-frame
))
47 (<= (frame-x frame
) (frame-x2 current-frame
)))
48 (setf y-found
(max y-found
(frame-y2 frame
))))))
51 (defun find-edge-down (current-frame parent
)
54 (dolist (frame (frame-child parent
))
55 (when (and (frame-p frame
)
56 (not (equal frame current-frame
))
57 (>= (frame-y frame
) (frame-y2 current-frame
))
58 (>= (frame-x2 frame
) (frame-x current-frame
))
59 (<= (frame-x frame
) (frame-x2 current-frame
)))
60 (setf y-found
(min y-found
(frame-y frame
))))))
63 (defun find-edge-right (current-frame parent
)
66 (dolist (frame (frame-child parent
))
67 (when (and (frame-p frame
)
68 (not (equal frame current-frame
))
69 (>= (frame-x frame
) (frame-x2 current-frame
))
70 (>= (frame-y2 frame
) (frame-y current-frame
))
71 (<= (frame-y frame
) (frame-y2 current-frame
)))
72 (setf x-found
(min x-found
(frame-x frame
))))))
76 (defun find-edge-left (current-frame parent
)
79 (dolist (frame (frame-child parent
))
80 (when (and (frame-p frame
)
81 (not (equal frame current-frame
))
82 (<= (frame-x2 frame
) (frame-x current-frame
))
83 (>= (frame-y2 frame
) (frame-y current-frame
))
84 (<= (frame-y frame
) (frame-y2 current-frame
)))
85 (setf x-found
(max x-found
(frame-x2 frame
))))))
93 (defun pack-frame-up (frame parent
&optional sp-y-found
)
95 (let ((y-found (or sp-y-found
(find-edge-up frame parent
))))
96 (setf (frame-y frame
) y-found
)))
99 (defun pack-frame-down (frame parent
&optional sp-y-found
)
101 (let ((y-found (or sp-y-found
(find-edge-down frame parent
))))
102 (setf (frame-y frame
) (- y-found
(frame-h frame
)))))
104 (defun pack-frame-right (frame parent
&optional sp-x-found
)
105 "Pack frame to right"
106 (let ((x-found (or sp-x-found
(find-edge-right frame parent
))))
107 (setf (frame-x frame
) (- x-found
(frame-w frame
)))))
110 (defun pack-frame-left (frame parent
&optional sp-x-found
)
112 (let ((x-found (or sp-x-found
(find-edge-left frame parent
))))
113 (setf (frame-x frame
) x-found
)))
117 (defun center-frame (frame)
119 (setf (frame-x frame
) (/ (- 1 (frame-w frame
)) 2)
120 (frame-y frame
) (/ (- 1 (frame-h frame
)) 2)))
125 (defun fill-frame-up (frame parent
&optional sp-y-found
)
127 (let* ((y-found (or sp-y-found
(find-edge-up frame parent
)))
128 (dy (- (frame-y frame
) y-found
)))
129 (setf (frame-y frame
) y-found
130 (frame-h frame
) (+ (frame-h frame
) dy
))))
132 (defun fill-frame-down (frame parent
&optional sp-y-found
)
134 (let* ((y-found (or sp-y-found
(find-edge-down frame parent
)))
135 (dy (- y-found
(frame-y2 frame
))))
136 (setf (frame-h frame
) (+ (frame-h frame
) dy
))))
139 (defun fill-frame-left (frame parent
&optional sp-x-found
)
141 (let* ((x-found (or sp-x-found
(find-edge-left frame parent
)))
142 (dx (- (frame-x frame
) x-found
)))
143 (setf (frame-x frame
) x-found
144 (frame-w frame
) (+ (frame-w frame
) dx
))))
146 (defun fill-frame-right (frame parent
&optional sp-x-found
)
148 (let* ((x-found (or sp-x-found
(find-edge-right frame parent
)))
149 (dx (- x-found
(frame-x2 frame
))))
150 (setf (frame-w frame
) (+ (frame-w frame
) dx
))))
156 (defun resize-frame-down (frame)
157 "Resize down a frame"
158 (when (> (frame-w frame
) 0.1)
159 (setf (frame-x frame
) (+ (frame-x frame
) 0.01)
160 (frame-w frame
) (max (- (frame-w frame
) 0.02) 0.01)))
161 (when (> (frame-h frame
) 0.1)
162 (setf (frame-y frame
) (+ (frame-y frame
) 0.01)
163 (frame-h frame
) (max (- (frame-h frame
) 0.02) 0.01))))
166 (defun resize-minimal-frame (frame)
167 "Resize down a frame to its minimal size"
169 (resize-frame-down frame
)))
175 (defun resize-half-width-left (frame)
176 (setf (frame-w frame
)(/ (frame-w frame
) 2)))
179 (defun resize-half-width-right (frame)
180 (let* ((new-size (/ (frame-w frame
) 2))
181 (dx (- (frame-w frame
) new-size
)))
182 (setf (frame-w frame
) new-size
)
183 (incf (frame-x frame
) (max dx
0))))
186 (defun resize-half-height-up (frame)
187 (setf (frame-h frame
) (/ (frame-h frame
) 2)))
189 (defun resize-half-height-down (frame)
190 (let* ((new-size (/ (frame-h frame
) 2))
191 (dy (- (frame-h frame
) new-size
)))
192 (setf (frame-h frame
) new-size
)
193 (incf (frame-y frame
) (max dy
0))))
199 ;;;;;| Explode/Implode functions
201 (defun explode-frame (frame)
202 "Create a new frame for each window in frame"
203 (when (frame-p frame
)
204 (let ((windows (loop :for child
:in
(frame-child frame
)
205 :when
(xlib:window-p child
)
207 (dolist (win windows
)
208 (add-frame (create-frame :child
(list win
)) frame
)
209 (remove-child-in-frame win frame
)))))
212 (defun explode-current-frame ()
213 "Create a new frame for each window in frame"
214 (explode-frame (current-child))
218 (defun implode-frame (frame)
219 "Absorb all frames subchildren in frame (explode frame opposite)"
220 (when (frame-p frame
)
221 (dolist (child (frame-child frame
))
222 (when (frame-p child
)
223 (dolist (subchild (frame-child child
))
224 (setf (frame-child frame
) (append (frame-child frame
) (list subchild
))))
226 (remove-child-in-frame child frame
)))))
228 (defun implode-current-frame ()
229 "Absorb all frames subchildren in frame (explode frame opposite)"
230 (implode-frame (current-child))
237 ;;;;;| Constrained move/resize frames
239 (labels ((redisplay (frame window
)
241 (hide-all-children frame
)
242 (setf (xlib:window-border window
) (get-color *color-move-window
*)))
243 (readjust-all-frames-fl-size (parent)
244 (dolist (child (frame-child parent
))
245 (when (frame-p child
)
246 (setf (frame-x child
) (x-px->fl
(x-drawable-x (frame-window child
)) parent
)
247 (frame-y child
) (y-px->fl
(x-drawable-y (frame-window child
)) parent
)
248 (frame-w child
) (w-px->fl
(anti-adj-border-wh (x-drawable-width (frame-window child
)) child
) parent
)
249 (frame-h child
) (h-px->fl
(anti-adj-border-wh (x-drawable-height (frame-window child
)) child
)
251 (defun move-frame-constrained (frame parent orig-x orig-y
)
252 (when (and (frame-p frame
) parent
(not (child-root-p frame
)))
253 (hide-all-children frame
)
254 (with-slots (window) frame
255 (let ((snap-size (/ *snap-size
* 100.0))
262 (readjust-all-frames-fl-size parent
)
263 (move-window window orig-x orig-y
267 (setf (frame-x frame
) (x-px->fl
(x-drawable-x window
) parent
)
268 (frame-y frame
) (y-px->fl
(x-drawable-y window
) parent
))
269 (multiple-value-bind (x y
) (xlib:query-pointer
*root
*)
271 (setf l-frame-x-l nil
)
272 (let ((x-found (find-edge-right frame parent
)))
273 (when (< (abs (- x-found
(frame-x2 frame
))) snap-size
)
274 (pack-frame-right frame parent x-found
)
275 (when (not (equal (frame-x frame
) l-frame-x-r
))
276 (redisplay frame window
)
277 (setf l-frame-x-r
(frame-x frame
)))
280 (setf l-frame-x-r nil
)
281 (let ((x-found (find-edge-left frame parent
)))
282 (when (< (abs (- x-found
(frame-x frame
))) snap-size
)
283 (pack-frame-left frame parent x-found
)
284 (when (not (equal (frame-x frame
) l-frame-x-l
))
285 (redisplay frame window
)
286 (setf l-frame-x-l
(frame-x frame
)))
289 (setf l-frame-y-u nil
)
290 (let ((y-found (find-edge-down frame parent
)))
291 (when (< (abs (- y-found
(frame-y2 frame
))) snap-size
)
292 (pack-frame-down frame parent y-found
)
293 (when (not (equal (frame-y frame
) l-frame-y-d
))
294 (redisplay frame window
)
295 (setf l-frame-y-d
(frame-y frame
)))
298 (setf l-frame-y-d nil
)
299 (let ((y-found (find-edge-up frame parent
)))
300 (when (< (abs (- y-found
(frame-y frame
))) snap-size
)
301 (pack-frame-up frame parent y-found
)
302 (when (not (equal (frame-y frame
) l-frame-y-u
))
303 (redisplay frame window
)
304 (setf l-frame-y-u
(frame-y frame
)))
306 (display-frame-info frame
)
307 (when move-x
(setf lx x
))
308 (when move-y
(setf ly y
))
309 (values move-x move-y
)))))))
310 (show-all-children)))
313 (defun resize-frame-constrained (frame parent orig-x orig-y
)
314 (when (and frame parent
(not (child-root-p frame
)))
315 (hide-all-children frame
)
316 (with-slots (window) frame
317 (let ((snap-size (/ *snap-size
* 100.0))
322 (readjust-all-frames-fl-size parent
)
323 (resize-window window orig-x orig-y
327 (setf (frame-w frame
) (w-px->fl
(anti-adj-border-wh (x-drawable-width window
) frame
)
329 (frame-h frame
) (h-px->fl
(anti-adj-border-wh (x-drawable-height window
) frame
)
331 (multiple-value-bind (x y
) (xlib:query-pointer
*root
*)
333 (let ((x-found (find-edge-right frame parent
)))
334 (when (< (abs (- x-found
(frame-x2 frame
))) snap-size
)
335 (fill-frame-right frame parent x-found
)
336 (when (not (equal (frame-w frame
) l-frame-w
))
337 (redisplay frame window
)
338 (setf l-frame-w
(frame-w frame
)))
339 (setf resize-w nil
))))
341 (setf l-frame-w nil
))
343 (let ((y-found (find-edge-down frame parent
)))
344 (when (< (abs (- y-found
(frame-y2 frame
))) snap-size
)
345 (fill-frame-down frame parent y-found
)
346 (when (or (null l-frame-h
)
347 (and (numberp l-frame-h
)
348 (/= (frame-h frame
) l-frame-h
)))
349 (redisplay frame window
)
350 (setf l-frame-h
(frame-h frame
)))
351 (setf resize-h nil
))))
353 (setf l-frame-h nil
))
354 (when resize-w
(setf lx x
))
355 (when resize-h
(setf ly y
))
356 (values resize-w resize-h
)))))))
357 (show-all-children))))