src/clfswm-placement.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Placement functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
   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 *border-size*)) &body body)
  39   `(multiple-value-bind (,x ,y width height)
  40        (get-placement-values ,placement ,width ,height ,border-size)
  41      (declare (ignorable width height))
  42      ,@body))
  43
  44 ;;;; Test functions
  45 ;;
  46 ;;(defun fun-placement (&optional width height)
  47 ;;  (declare (ignore width height))
  48 ;;  (values 30 40))
  49 ;;
  50 ;;(defparameter *placement-test* (list 10 20))
  51 ;;;;(defparameter *placement-test* #'fun-placement)
  52 ;;;;(defparameter *placement-test* 'fun-placement)
  53 ;;
  54 ;;(defun toto ()
  55 ;;  (with-placement (*placement-test* x y)
  56 ;;    (format t "X=~A  Y=~A~%" x y)))
  57
  58 ;;;
  59 ;;; Absolute placement
  60 ;;;
  61 (defun top-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
  62   (declare (ignore border-size))
  63   (values 0 0 width height))
  64
  65 (defun top-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
  66   (declare (ignore border-size))
  67   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
  68           0
  69           width height))
  70
  71 (defun top-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
  72   (values (- (xlib:screen-width *screen*) width (* border-size 2))
  73           0
  74           width height))
  75
  76
  77
  78 (defun middle-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
  79   (declare (ignore border-size))
  80   (values 0
  81           (truncate (/ (- (xlib:screen-height *screen*) height) 2))
  82           width height))
  83
  84 (defun middle-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
  85   (declare (ignore border-size))
  86   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
  87           (truncate (/ (- (xlib:screen-height *screen*) height) 2))
  88           width height))
  89
  90 (defun middle-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
  91   (values (- (xlib:screen-width *screen*) width (* border-size 2))
  92           (truncate (/ (- (xlib:screen-height *screen*) height) 2))
  93           width height))
  94
  95
  96 (defun bottom-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
  97   (values 0
  98           (- (xlib:screen-height *screen*) height (* border-size 2))
  99           width height))
 100
 101 (defun bottom-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
 102   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
 103           (- (xlib:screen-height *screen*) height (* border-size 2))
 104           width height))
 105
 106 (defun bottom-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
 107   (values (- (xlib:screen-width *screen*) width (* border-size 2))
 108           (- (xlib:screen-height *screen*) height (* border-size 2))
 109           width height))
 110
 111
 112 ;;;
 113 ;;; Current child placement
 114 ;;;
 115 (defun current-child-coord ()
 116   (typecase (current-child)
 117     (xlib:window (values (x-drawable-x (current-child))
 118                          (x-drawable-y (current-child))
 119                          (x-drawable-width (current-child))
 120                          (x-drawable-height (current-child))))
 121     (frame (values (frame-rx (current-child))
 122                    (frame-ry (current-child))
 123                    (frame-rw (current-child))
 124                    (frame-rh (current-child))))
 125     (t (values 0 0 10 10))))
 126
 127 (defmacro with-current-child-coord ((x y w h) &body body)
 128   `(multiple-value-bind (,x ,y ,w ,h)
 129        (current-child-coord)
 130      ,@body))
 131
 132
 133 (defun top-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 134   (declare (ignore border-size))
 135   (with-current-child-coord (x y w h)
 136     (let ((width (min (- w 4) width))
 137           (height (min (- h 4) height)))
 138       (values (+ x 2)
 139               (+ y 2)
 140               width height))))
 141
 142 (defun top-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 143   (declare (ignore border-size))
 144   (with-current-child-coord (x y w h)
 145     (let ((width (min (- w 4) width))
 146           (height (min (- h 4) height)))
 147       (values (+ x (truncate (/ (- w width) 2)))
 148               (+ y 2)
 149               width height))))
 150
 151 (defun top-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 152   (declare (ignore border-size))
 153   (with-current-child-coord (x y w h)
 154     (let ((width (min (- w 4) width))
 155           (height (min (- h 4) height)))
 156       (values (+ x (- w width 2))
 157               (+ y 2)
 158               width height))))
 159
 160
 161
 162 (defun middle-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 163   (declare (ignore border-size))
 164   (with-current-child-coord (x y w h)
 165     (let ((width (min (- w 4) width))
 166           (height (min (- h 4) height)))
 167       (values (+ x 2)
 168               (+ y (truncate (/ (- h height) 2)))
 169               width height))))
 170
 171 (defun middle-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 172   (declare (ignore border-size))
 173   (with-current-child-coord (x y w h)
 174     (let ((width (min (- w 4) width))
 175           (height (min (- h 4) height)))
 176       (values (+ x (truncate (/ (- w width) 2)))
 177               (+ y (truncate (/ (- h height) 2)))
 178               width height))))
 179
 180 (defun middle-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 181   (declare (ignore border-size))
 182   (with-current-child-coord (x y w h)
 183     (let ((width (min (- w 4) width))
 184           (height (min (- h 4) height)))
 185       (values (+ x (- w width 2))
 186               (+ y (truncate (/ (- h height) 2)))
 187               width height))))
 188
 189
 190 (defun bottom-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 191   (declare (ignore border-size))
 192   (with-current-child-coord (x y w h)
 193     (let ((width (min (- w 4) width))
 194           (height (min (- h 4) height)))
 195       (values (+ x 2)
 196               (+ y (- h height 2))
 197               width height))))
 198
 199 (defun bottom-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 200   (declare (ignore border-size))
 201   (with-current-child-coord (x y w h)
 202     (let ((width (min (- w 4) width))
 203           (height (min (- h 4) height)))
 204       (values (+ x (truncate (/ (- w width) 2)))
 205               (+ y (- h height 2))
 206               width height))))
 207
 208 (defun bottom-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 209   (declare (ignore border-size))
 210   (with-current-child-coord (x y w h)
 211     (let ((width (min (- w 4) width))
 212           (height (min (- h 4) height)))
 213       (values (+ x (- w width 2))
 214               (+ y (- h height 2))
 215               width height))))
 216
 217
 218 ;;;
 219 ;;; Current root placement
 220 ;;;
 221 (defparameter *get-current-root-fun* (lambda ()
 222                                        (find-root (current-child))))
 223
 224 (defun current-root-coord ()
 225   (let ((root (funcall *get-current-root-fun*)))
 226     (values (root-x root) (root-y root)
 227             (root-w root) (root-h root))))
 228
 229
 230
 231
 232 (defmacro with-current-root-coord ((x y w h) &body body)
 233   `(multiple-value-bind (,x ,y ,w ,h)
 234        (current-root-coord)
 235      ,@body))
 236
 237
 238 (defun top-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 239   (with-current-root-coord (x y w h)
 240     (let ((width (min (- w 4) width))
 241           (height (min (- h 4) height)))
 242       (values (+ x border-size 1)
 243               (+ y border-size 1)
 244               width height))))
 245
 246 (defun top-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 247   (with-current-root-coord (x y w h)
 248     (let ((width (min (- w 4) width))
 249           (height (min (- h 4) height)))
 250       (values (+ x (truncate (/ (- w width) 2)))
 251               (+ y border-size 1)
 252               width height))))
 253
 254 (defun top-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 255   (with-current-root-coord (x y w h)
 256     (let ((width (min (- w 4) width))
 257           (height (min (- h 4) height)))
 258       (values (+ x (- w width border-size 1))
 259               (+ y border-size 1)
 260               width height))))
 261
 262
 263
 264 (defun middle-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 265   (with-current-root-coord (x y w h)
 266     (let ((width (min (- w 4) width))
 267           (height (min (- h 4) height)))
 268       (values (+ x border-size 1)
 269               (+ y (truncate (/ (- h height) 2)))
 270               width height))))
 271
 272 (defun middle-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 273   (declare (ignore border-size))
 274   (with-current-root-coord (x y w h)
 275     (let ((width (min (- w 4) width))
 276           (height (min (- h 4) height)))
 277     (values (+ x (truncate (/ (- w width) 2)))
 278             (+ y (truncate (/ (- h height) 2)))
 279             width height))))
 280
 281 (defun middle-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 282   (with-current-root-coord (x y w h)
 283     (let ((width (min (- w 4) width))
 284           (height (min (- h 4) height)))
 285       (values (+ x (- w width border-size 1))
 286               (+ y (truncate (/ (- h height) 2)))
 287               width height))))
 288
 289
 290 (defun bottom-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 291   (with-current-root-coord (x y w h)
 292     (let ((width (min (- w 4) width))
 293           (height (min (- h 4) height)))
 294       (values (+ x border-size 1)
 295               (+ y (- h height border-size 1))
 296               width height))))
 297
 298 (defun bottom-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 299   (with-current-root-coord (x y w h)
 300     (let ((width (min (- w 4) width))
 301           (height (min (- h 4) height)))
 302       (values (+ x (truncate (/ (- w width) 2)))
 303               (+ y (- h height border-size 1))
 304               width height))))
 305
 306 (defun bottom-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 307   (with-current-root-coord (x y w h)
 308     (let ((width (min (- w 4) width))
 309           (height (min (- h 4) height)))
 310       (values (+ x (- w width border-size 1))
 311               (+ y (- h height border-size 1))
 312               width height))))
 313