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