src/clfswm-placement.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Placement functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 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 ;;; Current child placement
 117 ;;;
 118 (defun current-child-coord (border-size)
 119   (typecase (current-child)
 120     (xlib:window (values (x-drawable-x (current-child))
 121                          (x-drawable-y (current-child))
 122                          (- (x-drawable-width (current-child)) (* 2 border-size))
 123                          (- (x-drawable-height (current-child)) (* 2 border-size))
 124                          (x-drawable-border-width (current-child))))
 125     (frame (values (frame-rx (current-child))
 126                    (frame-ry (current-child))
 127                    (- (frame-rw (current-child)) (* 2 border-size))
 128                    (- (frame-rh (current-child)) (* 2 border-size))
 129                    (x-drawable-border-width (frame-window (current-child)))))
 130     (t (values 0 0 10 10 1))))
 131
 132 (defmacro with-current-child-coord ((border-size x y w h bds) &body body)
 133   "Bind x y w h bds to current child coordinates and border size"
 134   `(multiple-value-bind (,x ,y ,w ,h ,bds)
 135        (current-child-coord ,border-size)
 136      (let ((width (min w width))
 137            (height (min h height)))
 138        ,@body)))
 139
 140
 141 (defun top-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 142   (with-current-child-coord (border-size x y w h bds)
 143     (values (+ x bds) (+ y bds) width height)))
 144
 145 (defun top-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 146   (with-current-child-coord (border-size x y w h bds)
 147     (values (+ x (truncate (/ (- w width) 2)) bds) (+ y bds) width height)))
 148
 149 (defun top-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 150   (with-current-child-coord (border-size x y w h bds)
 151     (values (+ x (- w width) bds) (+ y bds) width height)))
 152
 153
 154
 155 (defun middle-left-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 bds) (+ y (truncate (/ (- h height) 2)) bds) width height)))
 158
 159 (defun middle-middle-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 (truncate (/ (- w width) 2)) bds) (+ y (truncate (/ (- h height) 2)) bds)
 162             width height)))
 163
 164 (defun middle-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 165   (with-current-child-coord (border-size x y w h bds)
 166     (values (+ x (- w width) bds) (+ y (truncate (/ (- h height) 2)) bds)
 167             width height)))
 168
 169
 170 (defun bottom-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 171   (with-current-child-coord (border-size x y w h bds)
 172     (values (+ x bds) (+ y (- h height) bds) width height)))
 173
 174 (defun bottom-middle-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 (truncate (/ (- w width) 2)) bds) (+ y (- h height) bds) width height)))
 177
 178 (defun bottom-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
 179   (with-current-child-coord (border-size x y w h bds)
 180     (values (+ x (- w width) bds) (+ y (- h height) bds) width height)))
 181
 182
 183 ;;;
 184 ;;; Current root placement
 185 ;;;
 186 (defparameter *get-current-root-fun* (lambda ()
 187                                        (find-root (current-child))))
 188
 189 (defun current-root-coord (border-size)
 190   (let ((root (funcall *get-current-root-fun*)))
 191     (values (root-x root) (root-y root)
 192             (- (root-w root) (* 2 border-size))
 193             (- (root-h root) (* 2 border-size)))))
 194
 195
 196 (defmacro with-current-root-coord ((border-size x y w h) &body body)
 197   `(multiple-value-bind (,x ,y ,w ,h)
 198        (current-root-coord ,border-size)
 199      (let ((width (min w width))
 200            (height (min h height)))
 201        ,@body)))
 202
 203
 204 (defun top-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 205   (with-current-root-coord (border-size x y w h)
 206     (values x y width height)))
 207
 208 (defun top-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 209   (with-current-root-coord (border-size x y w h)
 210     (values (+ x (truncate (/ (- w width) 2))) y width height)))
 211
 212 (defun top-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 213   (with-current-root-coord (border-size x y w h)
 214     (values (+ x (- w width)) y width height)))
 215
 216
 217
 218 (defun middle-left-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 (+ y (truncate (/ (- h height) 2))) width height)))
 221
 222 (defun middle-middle-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 (truncate (/ (- w width) 2))) (+ y (truncate (/ (- h height) 2))) width height)))
 225
 226 (defun middle-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 227   (with-current-root-coord (border-size x y w h)
 228     (values (+ x (- w width)) (+ y (truncate (/ (- h height) 2))) width height)))
 229
 230
 231 (defun bottom-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 232   (with-current-root-coord (border-size x y w h)
 233     (values x (+ y (- h height)) width height)))
 234
 235 (defun bottom-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 236   (with-current-root-coord (border-size x y w h)
 237     (values (+ x (truncate  (/ (- w width) 2))) (+ y (- h height)) width height)))
 238
 239 (defun bottom-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
 240   (with-current-root-coord (border-size x y w h)
 241     (values (+ x (- w width)) (+ y (- h height)) width height)))
 242
 243
 244 ;;; Some tests
 245 (defun test-some-placement (placement)
 246   (setf *second-mode-placement* placement
 247         *query-mode-placement* placement))
 248