src/clfswm-pack.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Tile, pack and fill 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
  29 ;;;,-----
  30 ;;;| Edges functions
  31 ;;;`-----
  32 (defun frame-x2 (frame)
  33   (+ (frame-x frame) (frame-w frame)))
  34
  35 (defun frame-y2 (frame)
  36   (+ (frame-y frame) (frame-h frame)))
  37
  38
  39 (defun find-edge-up (current-frame parent)
  40   (let ((y-found 0))
  41     (dolist (frame (frame-child parent))
  42       (when (and (frame-p frame)
  43                  (not (equal frame current-frame))
  44                  (<= (frame-y2 frame) (frame-y current-frame))
  45                  (>= (frame-x2 frame) (frame-x current-frame))
  46                  (<= (frame-x frame) (frame-x2 current-frame)))
  47         (setf y-found (max y-found (frame-y2 frame)))))
  48     y-found))
  49
  50 (defun find-edge-down (current-frame parent)
  51   (let ((y-found 1))
  52     (dolist (frame (frame-child parent))
  53       (when (and (frame-p frame)
  54                  (not (equal frame current-frame))
  55                  (>= (frame-y frame) (frame-y2 current-frame))
  56                  (>= (frame-x2 frame) (frame-x current-frame))
  57                  (<= (frame-x frame) (frame-x2 current-frame)))
  58         (setf y-found (min y-found (frame-y frame)))))
  59     y-found))
  60
  61 (defun find-edge-right (current-frame parent)
  62   (let ((x-found 1))
  63     (dolist (frame (frame-child parent))
  64       (when (and (frame-p frame)
  65                  (not (equal frame current-frame))
  66                  (>= (frame-x frame) (frame-x2 current-frame))
  67                  (>= (frame-y2 frame) (frame-y current-frame))
  68                  (<= (frame-y frame) (frame-y2 current-frame)))
  69         (setf x-found (min x-found (frame-x frame)))))
  70     x-found))
  71
  72
  73 (defun find-edge-left (current-frame parent)
  74   (let ((x-found 0))
  75     (dolist (frame (frame-child parent))
  76       (when (and (frame-p frame)
  77                  (not (equal frame current-frame))
  78                  (<= (frame-x2 frame) (frame-x current-frame))
  79                  (>= (frame-y2 frame) (frame-y current-frame))
  80                  (<= (frame-y frame) (frame-y2 current-frame)))
  81         (setf x-found (max x-found (frame-x2 frame)))))
  82     x-found))
  83
  84
  85
  86 ;;;,-----
  87 ;;;| Pack functions
  88 ;;;`-----
  89 (defun pack-frame-up (frame parent)
  90   "Pack frame to up"
  91   (let ((y-found (find-edge-up frame parent)))
  92     (setf (frame-y frame) y-found)))
  93
  94
  95 (defun pack-frame-down (frame parent)
  96   "Pack frame to down"
  97   (let ((y-found (find-edge-down frame parent)))
  98     (setf (frame-y frame) (- y-found (frame-h frame)))))
  99
 100 (defun pack-frame-right (frame parent)
 101   "Pack frame to right"
 102   (let ((x-found (find-edge-right frame parent)))
 103     (setf (frame-x frame) (- x-found (frame-w frame)))))
 104
 105
 106 (defun pack-frame-left (frame parent)
 107   "Pack frame to left"
 108   (let ((x-found (find-edge-left frame parent)))
 109     (setf (frame-x frame) x-found)))
 110
 111
 112
 113 (defun center-frame (frame)
 114   "Center frame"
 115   (setf (frame-x frame) (/ (- 1 (frame-w frame)) 2)
 116         (frame-y frame) (/ (- 1 (frame-h frame)) 2)))
 117
 118 ;;;,-----
 119 ;;;| Fill functions
 120 ;;;`-----
 121 (defun fill-frame-up (frame parent)
 122   "Fill a frame up"
 123   (let* ((y-found (find-edge-up frame parent))
 124          (dy (- (frame-y frame) y-found)))
 125     (setf (frame-y frame) y-found
 126           (frame-h frame) (+ (frame-h frame) dy))))
 127
 128 (defun fill-frame-down (frame parent)
 129   "Fill a frame down"
 130   (let* ((y-found (find-edge-down frame parent))
 131          (dy (- y-found (frame-y2 frame))))
 132     (setf (frame-h frame) (+ (frame-h frame) dy))))
 133
 134
 135 (defun fill-frame-left (frame parent)
 136   "Fill a frame left"
 137   (let* ((x-found (find-edge-left frame parent))
 138          (dx (- (frame-x frame) x-found)))
 139     (setf (frame-x frame) x-found
 140           (frame-w frame) (+ (frame-w frame) dx))))
 141
 142 (defun fill-frame-right (frame parent)
 143   "Fill a frame rigth"
 144   (let* ((x-found (find-edge-right frame parent))
 145          (dx (- x-found (frame-x2 frame))))
 146     (setf (frame-w frame) (+ (frame-w frame) dx))))
 147
 148
 149 ;;;,-----
 150 ;;;| Lower functions
 151 ;;;`-----
 152 (defun resize-frame-down (frame)
 153   "Resize down a frame"
 154   (when (> (frame-w frame) 0.1)
 155     (setf (frame-x frame) (+ (frame-x frame) 0.01)
 156           (frame-w frame) (max (- (frame-w frame) 0.02) 0.01)))
 157   (when (> (frame-h frame) 0.1)
 158     (setf (frame-y frame) (+ (frame-y frame) 0.01)
 159           (frame-h frame) (max (- (frame-h frame) 0.02) 0.01))))
 160
 161
 162 (defun resize-minimal-frame (frame)
 163   "Resize down a frame to its minimal size"
 164   (dotimes (i 100)
 165     (resize-frame-down frame)))
 166
 167
 168
 169
 170
 171 (defun resize-half-width-left (frame)
 172   (setf (frame-w frame)(/ (frame-w frame) 2)))
 173
 174
 175 (defun resize-half-width-right (frame)
 176   (let* ((new-size (/ (frame-w frame) 2))
 177          (dx (- (frame-w frame) new-size)))
 178     (setf (frame-w frame) new-size)
 179     (incf (frame-x frame) (max dx 0))))
 180
 181
 182 (defun resize-half-height-up (frame)
 183   (setf (frame-h frame) (/ (frame-h frame) 2)))
 184
 185 (defun resize-half-height-down (frame)
 186   (let* ((new-size (/ (frame-h frame) 2))
 187          (dy (- (frame-h frame) new-size)))
 188     (setf (frame-h frame) new-size)
 189     (incf (frame-y frame) (max dy 0))))
 190
 191
 192
 193
 194 ;;;;;,-----
 195 ;;;;;| Explode/Implode functions
 196 ;;;;;`-----
 197 (defun explode-frame (frame)
 198   "Create a new frame for each window in frame"
 199   (when (frame-p frame)
 200     (let ((windows (loop :for child :in (frame-child frame)
 201                       :when (xlib:window-p child)
 202                       :collect child)))
 203       (dolist (win windows)
 204         (add-frame (create-frame :child (list win)) frame)
 205         (remove-child-in-frame win frame)))))
 206
 207
 208 (defun explode-current-frame ()
 209   "Create a new frame for each window in frame"
 210   (explode-frame *current-child*)
 211   (leave-second-mode))
 212
 213
 214 (defun implode-frame (frame)
 215   "Absorb all frames subchildren in frame (explode frame opposite)"
 216   (when (frame-p frame)
 217     (dolist (child (frame-child frame))
 218       (when (frame-p child)
 219         (dolist (subchild (frame-child child))
 220           (setf (frame-child frame) (append (frame-child frame) (list subchild))))
 221         (hide-child child)
 222         (remove-child-in-frame child frame)))))
 223
 224 (defun implode-current-frame ()
 225   "Absorb all frames subchildren in frame (explode frame opposite)"
 226   (implode-frame *current-child*)
 227   (leave-second-mode))
 228
 229
 230
 231
 232 ;;;;;,-----
 233 ;;;;;| Constrained move/resize frames
 234 ;;;;;`-----
 235 (labels ((readjust-all-frames-fl-size (parent)
 236            (dolist (child (frame-child parent))
 237              (when (frame-p child)
 238                (setf (frame-x child) (x-px->fl (xlib:drawable-x (frame-window child)) parent)
 239                      (frame-y child) (y-px->fl (xlib:drawable-y (frame-window child)) parent)
 240                      (frame-w child) (w-px->fl (anti-adj-border-wh (xlib:drawable-width (frame-window child)) parent) parent)
 241                      (frame-h child) (h-px->fl (anti-adj-border-wh (xlib:drawable-height (frame-window child)) parent) parent))))))
 242   (defun move-frame-constrained (frame parent orig-x orig-y)
 243     (when (and frame parent (not (child-equal-p frame *current-root*)))
 244       (hide-all-children frame)
 245       (with-slots (window) frame
 246         (let ((lx orig-x)
 247               (ly orig-y))
 248           (readjust-all-frames-fl-size parent)
 249           (move-window window orig-x orig-y
 250                        (lambda ()
 251                          (let ((move-x t)
 252                                (move-y t))
 253                            (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent)
 254                                  (frame-y frame) (y-px->fl (xlib:drawable-y window) parent))
 255                            (multiple-value-bind (x y) (xlib:query-pointer *root*)
 256                              (when (> x lx)
 257                                (let ((x-found (x-fl->px (find-edge-right frame parent) parent)))
 258                                  (when (< (abs (- x-found (window-x2 window))) *snap-size*)
 259                                    (setf (xlib:drawable-x window) (- x-found (adj-border-xy (xlib:drawable-width window) window))
 260                                          (frame-x frame) (x-px->fl (xlib:drawable-x window) parent)
 261                                          move-x nil))))
 262                              (when (< x lx)
 263                                (let ((x-found (x-fl->px (find-edge-left frame parent) parent)))
 264                                  (when (< (abs (- x-found (xlib:drawable-x window))) *snap-size*)
 265                                    (setf (xlib:drawable-x window) (adj-border-xy x-found window)
 266                                          (frame-x frame) (x-px->fl (xlib:drawable-x window) parent)
 267                                          move-x nil))))
 268                              (when (> y ly)
 269                                (let ((y-found (y-fl->px (find-edge-down frame parent) parent)))
 270                                  (when (< (abs (- y-found (window-y2 window))) *snap-size*)
 271                                    (setf (xlib:drawable-y window) (- y-found (adj-border-xy (xlib:drawable-height window) window))
 272                                          (frame-y frame) (y-px->fl (xlib:drawable-y window) parent)
 273                                          move-y nil))))
 274                              (when (< y ly)
 275                                (let ((y-found (y-fl->px (find-edge-up frame parent) parent)))
 276                                  (when (< (abs (- y-found (xlib:drawable-y window))) *snap-size*)
 277                                    (setf (xlib:drawable-y window) (adj-border-xy y-found window)
 278                                          (frame-y frame) (y-px->fl (xlib:drawable-y window) parent)
 279                                          move-y nil))))
 280                              (display-frame-info frame)
 281                              (when move-x (setf lx x))
 282                              (when move-y (setf ly y))
 283                              (values move-x move-y)))))))
 284       (show-all-children)))
 285
 286
 287   (defun resize-frame-constrained (frame parent orig-x orig-y)
 288     (when (and frame parent (not (child-equal-p frame *current-root*)))
 289       (hide-all-children frame)
 290       (with-slots (window) frame
 291         (let ((lx orig-x)
 292               (ly orig-y))
 293           (readjust-all-frames-fl-size parent)
 294           (resize-window window orig-x orig-y
 295                          (lambda ()
 296                            (let ((resize-w t)
 297                                  (resize-h t))
 298                              (multiple-value-bind (x y) (xlib:query-pointer *root*)
 299                                (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) parent) parent)
 300                                      (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) parent) parent))
 301                                (when (> x lx)
 302                                  (let ((x-found (x-fl->px (find-edge-right frame parent) parent)))
 303                                    (when (< (abs (- x-found (window-x2 window))) *snap-size*)
 304                                      (setf (xlib:drawable-width window) (+ (xlib:drawable-width window)
 305                                                                            (- x-found (adj-border-xy (window-x2 window) parent)))
 306                                            (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) parent) parent)
 307                                            resize-w nil))))
 308                                (when (> y ly)
 309                                  (let ((y-found (y-fl->px (find-edge-down frame parent) parent)))
 310                                    (when (< (abs (- y-found (window-y2 window))) *snap-size*)
 311                                      (setf (xlib:drawable-height window) (+ (xlib:drawable-height window)
 312                                                                             (- y-found (adj-border-xy (window-y2 window) parent)))
 313                                            (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) parent) parent)
 314                                            resize-h nil))))
 315                                (display-frame-info frame)
 316                                (when resize-w (setf lx x))
 317                                (when resize-h (setf ly y))
 318                                (values resize-w resize-h)))))))
 319       (show-all-children))))