src/clfswm-placement.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Placement functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  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.
  14 ;;;
  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.
  19 ;;;
  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.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28 (defun get-placement-values (placement &optional (width 0) (height 0) (border-size *border-size*))
  29   (typecase placement
  30     (list (values-list placement))
  31     (function (funcall placement width height border-size))
  32     (symbol
  33      (if (fboundp placement)
  34          (funcall placement width height border-size)
  35          (values 0 0 width height)))
  36     (t (values 0 0 width height))))
  37
  38 (defmacro with-placement ((placement x y &optional (width 0) (height 0) border-size) &body body)
  39   `(multiple-value-bind (,x ,y width height)
  40        ,(if border-size
  41             `(get-placement-values ,placement ,width ,height ,border-size)
  42             `(get-placement-values ,placement ,width ,height))
  43      (declare (ignorable width height))
  44      ,@body))
  45
  46 ;;;; Test functions
  47 ;;
  48 ;;(defun fun-placement (&optional width height)
  49 ;;  (declare (ignore width height))
  50 ;;  (values 30 40))
  51 ;;
  52 ;;(defparameter *placement-test* (list 10 20))
  53 ;;;;(defparameter *placement-test* #'fun-placement)
  54 ;;;;(defparameter *placement-test* 'fun-placement)
  55 ;;
  56 ;;(defun toto ()
  57 ;;  (with-placement (*placement-test* x y)
  58 ;;    (format t "X=~A  Y=~A~%" x y)))
  59
  60 ;;;
  61 ;;; Absolute placement
  62 ;;;
  63 (defun root-screen-coord (border-size)
  64   (values (- (xlib:screen-width *screen*) (* 2 border-size))
  65           (- (xlib:screen-height *screen*) (* 2 border-size))))
  66
  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)))
  72        ,@body)))
  73
  74
  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)))
  78
  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)))
  82
  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)))
  86
  87
  88
  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)))
  92
  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)))
  96
  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)))
 100
 101
 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)))
 105
 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)))
 109
 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)))
 113
 114
 115
 116 ;;;
 117 ;;; Here placement: Evaluates to current position of pointer.
 118 ;;;
 119 (defun here-placement (&optional (width 0) (height 0) (border-size *border-size*))
 120   (declare (ignore border-size))
 121   (with-x-pointer
 122       (values x y width height)))
 123
 124
 125 ;;;
 126 ;;; Current child placement
 127 ;;;
 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))))
 141
 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)))
 148        ,@body)))
 149
 150
 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)))
 154
 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)))
 158
 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)))
 162
 163
 164
 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)))
 168
 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)
 172             width height)))
 173
 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)
 177             width height)))
 178
 179
 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)))
 183
 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)))
 187
 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)))
 191
 192
 193 ;;;
 194 ;;; Current root placement
 195 ;;;
 196 (defparameter *get-current-root-fun* (lambda ()
 197                                        (find-root (current-child))))
 198
 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)))))
 204
 205
 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)))
 211        ,@body)))
 212
 213
 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)))
 217
 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)))
 221
 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)))
 225
 226
 227
 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)))
 231
 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)))
 235
 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)))
 239
 240
 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)))
 244
 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)))
 248
 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)))
 252
 253
 254 ;;; Some tests
 255 (defun test-some-placement (placement)
 256   (setf *second-mode-placement* placement
 257         *query-mode-placement* placement))
 258