src/clfswm-pack.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Tile, pack and fill functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 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 ;;;| Edges functions
  30 ;;;`-----
  31 (defun frame-x2 (frame)
  32   (+ (frame-x frame) (frame-w frame)))
  33
  34 (defun frame-y2 (frame)
  35   (+ (frame-y frame) (frame-h frame)))
  36
  37
  38 (defun find-edge-up (current-frame parent)
  39   (let ((y-found 0))
  40     (dolist (frame (frame-child parent))
  41       (when (and (frame-p frame)
  42                  (not (equal frame current-frame))
  43                  (<= (frame-y2 frame) (frame-y current-frame))
  44                  (>= (frame-x2 frame) (frame-x current-frame))
  45                  (<= (frame-x frame) (frame-x2 current-frame)))
  46         (setf y-found (max y-found (frame-y2 frame)))))
  47     y-found))
  48
  49 (defun find-edge-down (current-frame parent)
  50   (let ((y-found 1))
  51     (dolist (frame (frame-child parent))
  52       (when (and (frame-p frame)
  53                  (not (equal frame current-frame))
  54                  (>= (frame-y frame) (frame-y2 current-frame))
  55                  (>= (frame-x2 frame) (frame-x current-frame))
  56                  (<= (frame-x frame) (frame-x2 current-frame)))
  57         (setf y-found (min y-found (frame-y frame)))))
  58     y-found))
  59
  60 (defun find-edge-right (current-frame parent)
  61   (let ((x-found 1))
  62     (dolist (frame (frame-child parent))
  63       (when (and (frame-p frame)
  64                  (not (equal frame current-frame))
  65                  (>= (frame-x frame) (frame-x2 current-frame))
  66                  (>= (frame-y2 frame) (frame-y current-frame))
  67                  (<= (frame-y frame) (frame-y2 current-frame)))
  68         (setf x-found (min x-found (frame-x frame)))))
  69     x-found))
  70
  71
  72 (defun find-edge-left (current-frame parent)
  73   (let ((x-found 0))
  74     (dolist (frame (frame-child parent))
  75       (when (and (frame-p frame)
  76                  (not (equal frame current-frame))
  77                  (<= (frame-x2 frame) (frame-x current-frame))
  78                  (>= (frame-y2 frame) (frame-y current-frame))
  79                  (<= (frame-y frame) (frame-y2 current-frame)))
  80         (setf x-found (max x-found (frame-x2 frame)))))
  81     x-found))
  82
  83
  84
  85 ;;;,-----
  86 ;;;| Pack functions
  87 ;;;`-----
  88 (defun pack-frame-up (frame parent)
  89   "Pack frame to up"
  90   (let ((y-found (find-edge-up frame parent)))
  91     (setf (frame-y frame) y-found)))
  92
  93
  94 (defun pack-frame-down (frame parent)
  95   "Pack frame to down"
  96   (let ((y-found (find-edge-down frame parent)))
  97     (setf (frame-y frame) (- y-found (frame-h frame)))))
  98
  99 (defun pack-frame-right (frame parent)
 100   "Pack frame to right"
 101   (let ((x-found (find-edge-right frame parent)))
 102     (setf (frame-x frame) (- x-found (frame-w frame)))))
 103
 104
 105 (defun pack-frame-left (frame parent)
 106   "Pack frame to left"
 107   (let ((x-found (find-edge-left frame parent)))
 108     (setf (frame-x frame) x-found)))
 109
 110
 111
 112 (defun center-frame (frame)
 113   "Center frame"
 114   (setf (frame-x frame) (/ (- 1 (frame-w frame)) 2)
 115         (frame-y frame) (/ (- 1 (frame-h frame)) 2)))
 116
 117 ;;;,-----
 118 ;;;| Fill functions
 119 ;;;`-----
 120 (defun fill-frame-up (frame parent)
 121   "Fill a frame up"
 122   (let* ((y-found (find-edge-up frame parent))
 123          (dy (- (frame-y frame) y-found)))
 124     (setf (frame-y frame) y-found
 125           (frame-h frame) (+ (frame-h frame) dy))))
 126
 127 (defun fill-frame-down (frame parent)
 128   "Fill a frame down"
 129   (let* ((y-found (find-edge-down frame parent))
 130          (dy (- y-found (frame-y2 frame))))
 131     (setf (frame-h frame) (+ (frame-h frame) dy))))
 132
 133
 134 (defun fill-frame-left (frame parent)
 135   "Fill a frame left"
 136   (let* ((x-found (find-edge-left frame parent))
 137          (dx (- (frame-x frame) x-found)))
 138     (setf (frame-x frame) x-found
 139           (frame-w frame) (+ (frame-w frame) dx))))
 140
 141 (defun fill-frame-right (frame parent)
 142   "Fill a frame rigth"
 143   (let* ((x-found (find-edge-right frame parent))
 144          (dx (- x-found (frame-x2 frame))))
 145     (setf (frame-w frame) (+ (frame-w frame) dx))))
 146
 147
 148 ;;;,-----
 149 ;;;| Lower functions
 150 ;;;`-----
 151 (defun resize-frame-down (frame)
 152   "Resize down a frame"
 153   (when (> (frame-w frame) 0.1)
 154     (setf (frame-x frame) (+ (frame-x frame) 0.01)
 155           (frame-w frame) (max (- (frame-w frame) 0.02) 0.01)))
 156   (when (> (frame-h frame) 0.1)
 157     (setf (frame-y frame) (+ (frame-y frame) 0.01)
 158           (frame-h frame) (max (- (frame-h frame) 0.02) 0.01))))
 159
 160
 161 (defun resize-minimal-frame (frame)
 162   "Resize down a frame to its minimal size"
 163   (dotimes (i 100)
 164     (resize-frame-down frame)))
 165
 166
 167
 168
 169
 170 (defun resize-half-width-left (frame)
 171   (setf (frame-w frame)(/ (frame-w frame) 2)))
 172
 173
 174 (defun resize-half-width-right (frame)
 175   (let* ((new-size (/ (frame-w frame) 2))
 176          (dx (- (frame-w frame) new-size)))
 177     (setf (frame-w frame) new-size)
 178     (incf (frame-x frame) (max dx 0))))
 179
 180
 181 (defun resize-half-height-up (frame)
 182   (setf (frame-h frame) (/ (frame-h frame) 2)))
 183
 184 (defun resize-half-height-down (frame)
 185   (let* ((new-size (/ (frame-h frame) 2))
 186          (dy (- (frame-h frame) new-size)))
 187     (setf (frame-h frame) new-size)
 188     (incf (frame-y frame) (max dy 0))))
 189
 190
 191
 192
 193 ;;;;;,-----
 194 ;;;;;| Explode/Implode functions
 195 ;;;;;`-----
 196 (defun explode-frame (frame)
 197   "Create a new frame for each window in frame"
 198   (when (frame-p frame)
 199     (let ((windows (loop :for child :in (frame-child frame)
 200                       :when (xlib:window-p child)
 201                       :collect child)))
 202       (dolist (win windows)
 203         (add-frame (create-frame :child (list win)) frame)
 204         (remove-child-in-frame win frame)))))
 205
 206
 207 (defun explode-current-frame ()
 208   "Create a new frame for each window in frame"
 209   (explode-frame *current-child*)
 210   (leave-second-mode))