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
 215 ;;;;;,-----
 216 ;;;;;| Constrained move/resize frames
 217 ;;;;;`-----
 218 (defun move-frame-constrained (frame parent orig-x orig-y)
 219   (when (and frame parent (not (child-equal-p frame *current-root*)))
 220     (hide-all-children frame)
 221     (with-slots (window) frame
 222       (let ((lx orig-x)
 223             (ly orig-y))
 224         (move-window window orig-x orig-y
 225                      (lambda ()
 226                        (let ((move-x t)
 227                              (move-y t))
 228                          (multiple-value-bind (x y) (xlib:query-pointer *root*)
 229                            (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent)
 230                                  (frame-y frame) (y-px->fl (xlib:drawable-y window) parent))
 231                            (when (> x lx)
 232                              (let ((x-found (find-edge-right frame parent)))
 233                                (when (< (abs (-  x-found (frame-x2 frame))) *snap-size*)
 234                                  (setf (frame-x frame) (- x-found (frame-w frame))
 235                                        (xlib:drawable-x window) (adj-border-xy (x-fl->px (frame-x frame) parent) frame)
 236                                        move-x nil))))
 237                            (when (< x lx)
 238                              (let ((x-found (find-edge-left frame parent)))
 239                                (when (< (abs (- x-found (frame-x frame))) *snap-size*)
 240                                  (setf (frame-x frame) x-found
 241                                        (xlib:drawable-x window) (adj-border-xy (x-fl->px (frame-x frame) parent) frame)
 242                                        move-x nil))))
 243                            (when (> y ly)
 244                              (let ((y-found (find-edge-down frame parent)))
 245                                (when (< (abs (- y-found (frame-y2 frame))) *snap-size*)
 246                                  (setf (frame-y frame) (- y-found (frame-h frame))
 247                                        (xlib:drawable-y window) (adj-border-xy (y-fl->px (frame-y frame) parent) frame)
 248                                        move-y nil))))
 249                            (when (< y ly)
 250                              (let ((y-found (find-edge-up frame parent)))
 251                                (when (< (abs (- y-found (frame-y frame))) *snap-size*)
 252                                  (setf (frame-y frame) y-found
 253                                        (xlib:drawable-y window) (adj-border-xy (y-fl->px (frame-y frame) parent) frame)
 254                                        move-y nil))))
 255                            (display-frame-info frame)
 256                            (when move-x (setf lx x))
 257                            (when move-y (setf ly y))
 258                            (values move-x move-y))))))
 259       (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent)
 260             (frame-y frame) (y-px->fl (xlib:drawable-y window) parent)))
 261     (show-all-children)))
 262
 263
 264 (defun resize-frame-constrained (frame parent orig-x orig-y)
 265   (when (and frame parent (not (child-equal-p frame *current-root*)))
 266     (hide-all-children frame)
 267     (with-slots (window) frame
 268       (let ((lx orig-x)
 269             (ly orig-y))
 270         (resize-window window orig-x orig-y
 271                        (lambda ()
 272                          (let ((resize-w t)
 273                                (resize-h t))
 274                            (multiple-value-bind (x y) (xlib:query-pointer *root*)
 275                              (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent)
 276                                    (frame-h frame) (h-px->fl (xlib:drawable-height window) parent))
 277                              (when (> x lx)
 278                                (let ((x-found (find-edge-right frame parent)))
 279                                  (when (< (abs (- x-found (frame-x2 frame))) *snap-size*)
 280                                    (setf (frame-w frame) (+ (frame-w frame) (- x-found (frame-x2 frame)))
 281                                          (xlib:drawable-width window) (adj-border-wh (w-fl->px (frame-w frame) parent) frame)
 282                                          resize-w nil))))
 283                              (when (> y ly)
 284                                (let ((y-found (find-edge-down frame parent)))
 285                                  (when (< (abs (- y-found (frame-y2 frame))) *snap-size*)
 286                                    (setf (frame-h frame) (+ (frame-h frame) (- y-found (frame-y2 frame)))
 287                                          (xlib:drawable-height window) (adj-border-wh (h-fl->px (frame-h frame) parent) frame)
 288                                          resize-h nil))))
 289                              (display-frame-info frame)
 290                              (when resize-w (setf lx x))
 291                              (when resize-h (setf ly y))
 292                              (values resize-w resize-h))))))
 293       (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent)
 294             (frame-h frame) (h-px->fl (xlib:drawable-height window) parent)))
 295     (show-all-children)))