1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Placement functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2014 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 ;;; --------------------------------------------------------------------------
28 (defun get-placement-values (placement &optional
(width 0) (height 0) (border-size *border-size
*))
30 (list (values-list placement
))
31 (function (funcall placement width height border-size
))
33 (if (fboundp placement
)
34 (funcall placement width height border-size
)
35 (values 0 0 width height
)))
36 (t (values 0 0 width height
))))
38 (defmacro with-placement
((placement x y
&optional
(width 0) (height 0) border-size
) &body body
)
39 `(multiple-value-bind (,x
,y width height
)
41 `(get-placement-values ,placement
,width
,height
,border-size
)
42 `(get-placement-values ,placement
,width
,height
))
43 (declare (ignorable width height
))
48 ;;(defun fun-placement (&optional width height)
49 ;; (declare (ignore width height))
52 ;;(defparameter *placement-test* (list 10 20))
53 ;;;;(defparameter *placement-test* #'fun-placement)
54 ;;;;(defparameter *placement-test* 'fun-placement)
57 ;; (with-placement (*placement-test* x y)
58 ;; (format t "X=~A Y=~A~%" x y)))
61 ;;; Absolute placement
63 (defun root-screen-coord (border-size)
64 (values (- (screen-width) (* 2 border-size
))
65 (- (screen-height) (* 2 border-size
))))
67 (defmacro with-root-screen-coord
((border-size w h
) &body body
)
68 `(multiple-value-bind (,w
,h
)
69 (root-screen-coord ,border-size
)
70 (let ((width (min width
,w
))
71 (height (min height
,h
)))
75 (defun top-left-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
76 (with-root-screen-coord (border-size w h
)
77 (values 0 0 width height
)))
79 (defun top-middle-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
80 (with-root-screen-coord (border-size w h
)
81 (values (truncate (/ (- w width
) 2)) 0 width height
)))
83 (defun top-right-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
84 (with-root-screen-coord (border-size w h
)
85 (values (- w width
) 0 width height
)))
89 (defun middle-left-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
90 (with-root-screen-coord (border-size w h
)
91 (values 0 (truncate (/ (- h height
) 2)) width height
)))
93 (defun middle-middle-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
94 (with-root-screen-coord (border-size w h
)
95 (values (truncate (/ (- w width
) 2)) (truncate (/ (- h height
) 2)) width height
)))
97 (defun middle-right-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
98 (with-root-screen-coord (border-size w h
)
99 (values (- w width
) (truncate (/ (- h height
) 2)) width height
)))
102 (defun bottom-left-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
103 (with-root-screen-coord (border-size w h
)
104 (values 0 (- h height
) width height
)))
106 (defun bottom-middle-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
107 (with-root-screen-coord (border-size w h
)
108 (values (truncate (/ (- w width
) 2)) (- h height
) width height
)))
110 (defun bottom-right-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
111 (with-root-screen-coord (border-size w h
)
112 (values (- w width
) (- h height
) width height
)))
117 ;;; Here placement: Evaluates to current position of pointer.
119 (defun here-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
120 (declare (ignore border-size
))
122 (values x y width height
)))
126 ;;; Current child placement
128 (defun current-child-coord (border-size)
129 (typecase (current-child)
130 (xlib:window
(values (x-drawable-x (current-child))
131 (x-drawable-y (current-child))
132 (- (x-drawable-width (current-child)) (* 2 border-size
))
133 (- (x-drawable-height (current-child)) (* 2 border-size
))
134 (x-drawable-border-width (current-child))))
135 (frame (values (frame-rx (current-child))
136 (frame-ry (current-child))
137 (- (frame-rw (current-child)) (* 2 border-size
))
138 (- (frame-rh (current-child)) (* 2 border-size
))
139 (x-drawable-border-width (frame-window (current-child)))))
140 (t (values 0 0 10 10 1))))
142 (defmacro with-current-child-coord
((border-size x y w h bds
) &body body
)
143 "Bind x y w h bds to current child coordinates and border size"
144 `(multiple-value-bind (,x
,y
,w
,h
,bds
)
145 (current-child-coord ,border-size
)
146 (let ((width (min w width
))
147 (height (min h height
)))
151 (defun top-left-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
152 (with-current-child-coord (border-size x y w h bds
)
153 (values (+ x bds
) (+ y bds
) width height
)))
155 (defun top-middle-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
156 (with-current-child-coord (border-size x y w h bds
)
157 (values (+ x
(truncate (/ (- w width
) 2)) bds
) (+ y bds
) width height
)))
159 (defun top-right-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
160 (with-current-child-coord (border-size x y w h bds
)
161 (values (+ x
(- w width
) bds
) (+ y bds
) width height
)))
165 (defun middle-left-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
166 (with-current-child-coord (border-size x y w h bds
)
167 (values (+ x bds
) (+ y
(truncate (/ (- h height
) 2)) bds
) width height
)))
169 (defun middle-middle-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
170 (with-current-child-coord (border-size x y w h bds
)
171 (values (+ x
(truncate (/ (- w width
) 2)) bds
) (+ y
(truncate (/ (- h height
) 2)) bds
)
174 (defun middle-right-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
175 (with-current-child-coord (border-size x y w h bds
)
176 (values (+ x
(- w width
) bds
) (+ y
(truncate (/ (- h height
) 2)) bds
)
180 (defun bottom-left-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
181 (with-current-child-coord (border-size x y w h bds
)
182 (values (+ x bds
) (+ y
(- h height
) bds
) width height
)))
184 (defun bottom-middle-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
185 (with-current-child-coord (border-size x y w h bds
)
186 (values (+ x
(truncate (/ (- w width
) 2)) bds
) (+ y
(- h height
) bds
) width height
)))
188 (defun bottom-right-child-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
189 (with-current-child-coord (border-size x y w h bds
)
190 (values (+ x
(- w width
) bds
) (+ y
(- h height
) bds
) width height
)))
194 ;;; Current root placement
196 (defparameter *get-current-root-fun
* (lambda ()
197 (find-root (current-child))))
199 (defun current-root-coord (border-size)
200 (let ((root (funcall *get-current-root-fun
*)))
201 (values (root-x root
) (root-y root
)
202 (- (root-w root
) (* 2 border-size
))
203 (- (root-h root
) (* 2 border-size
)))))
206 (defmacro with-current-root-coord
((border-size x y w h
) &body body
)
207 `(multiple-value-bind (,x
,y
,w
,h
)
208 (current-root-coord ,border-size
)
209 (let ((width (min w width
))
210 (height (min h height
)))
214 (defun top-left-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
215 (with-current-root-coord (border-size x y w h
)
216 (values x y width height
)))
218 (defun top-middle-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
219 (with-current-root-coord (border-size x y w h
)
220 (values (+ x
(truncate (/ (- w width
) 2))) y width height
)))
222 (defun top-right-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
223 (with-current-root-coord (border-size x y w h
)
224 (values (+ x
(- w width
)) y width height
)))
228 (defun middle-left-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
229 (with-current-root-coord (border-size x y w h
)
230 (values x
(+ y
(truncate (/ (- h height
) 2))) width height
)))
232 (defun middle-middle-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
233 (with-current-root-coord (border-size x y w h
)
234 (values (+ x
(truncate (/ (- w width
) 2))) (+ y
(truncate (/ (- h height
) 2))) width height
)))
236 (defun middle-right-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
237 (with-current-root-coord (border-size x y w h
)
238 (values (+ x
(- w width
)) (+ y
(truncate (/ (- h height
) 2))) width height
)))
241 (defun bottom-left-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
242 (with-current-root-coord (border-size x y w h
)
243 (values x
(+ y
(- h height
)) width height
)))
245 (defun bottom-middle-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
246 (with-current-root-coord (border-size x y w h
)
247 (values (+ x
(truncate (/ (- w width
) 2))) (+ y
(- h height
)) width height
)))
249 (defun bottom-right-root-placement (&optional
(width 0) (height 0) (border-size *border-size
*))
250 (with-current-root-coord (border-size x y w h
)
251 (values (+ x
(- w width
)) (+ y
(- h height
)) width height
)))
255 (defun test-some-placement (placement)
256 (setf *second-mode-placement
* placement
257 *query-mode-placement
* placement
))