src/clfswm-pack.lisp

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