[clfswm-cvs] r51 - in clfswm: . src
pbrochard at common-lisp.net
pbrochard at common-lisp.net
Fri Mar 21 21:58:05 UTC 2008
Author: pbrochard
Date: Fri Mar 21 16:58:00 2008
New Revision: 51
Modified:
clfswm/ChangeLog
clfswm/clfswm.asd
clfswm/src/bindings-second-mode.lisp
clfswm/src/clfswm-layout.lisp
clfswm/src/clfswm-pack.lisp
clfswm/src/clfswm-second-mode.lisp
Log:
Pack, Fill, Resize functions.
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Fri Mar 21 16:58:00 2008
@@ -1,3 +1,7 @@
+2008-03-21 Philippe Brochard <hocwp at free.fr>
+
+ * src/clfswm-pack.lisp: Pack, Fill, Resize functions.
+
2008-03-16 Philippe Brochard <hocwp at free.fr>
* src/clfswm-nw-hooks.lisp: Register system for new window hooks.
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Fri Mar 21 16:58:00 2008
@@ -44,6 +44,8 @@
:depends-on ("package" "config"))
(:file "clfswm-layout"
:depends-on ("package" "clfswm-util" "clfswm-info"))
+ (:file "clfswm-pack"
+ :depends-on ("clfswm" "clfswm-util"))
(:file "clfswm-nw-hooks"
:depends-on ("package" "clfswm-util" "clfswm-info"))
(:file "bindings"
Modified: clfswm/src/bindings-second-mode.lisp
==============================================================================
--- clfswm/src/bindings-second-mode.lisp (original)
+++ clfswm/src/bindings-second-mode.lisp Fri Mar 21 16:58:00 2008
@@ -58,29 +58,137 @@
-
(defun group-pack-menu ()
"Group pack menu"
- (info-mode-menu '(("Up" group-pack-up)
- ("Down" group-pack-down))))
+ (info-mode-menu '(("Up" current-group-pack-up)
+ ("Down" current-group-pack-down)
+ ("Left" current-group-pack-left)
+ ("Right" current-group-pack-right))))
+
+
+(defun group-fill-menu ()
+ "Group fill menu"
+ (info-mode-menu '(("Up" current-group-fill-up)
+ ("Down" current-group-fill-down)
+ ("Left" current-group-fill-left)
+ ("Right" current-group-fill-right)
+ (#\a current-group-fill-all-dir)
+ (#\v current-group-fill-vertical)
+ (#\h current-group-fill-horizontal))))
+
+(defun group-resize-menu ()
+ "Group resize menu"
+ (info-mode-menu '(("Up" current-group-resize-up)
+ ("Down" current-group-resize-down)
+ ("Left" current-group-resize-left)
+ ("Right" current-group-resize-right)
+ (#\d current-group-resize-all-dir)
+ (#\a current-group-resize-all-dir-minimal))))
(defun group-movement-menu ()
"Group movement menu"
(info-mode-menu '((#\p group-pack-menu)
(#\f group-fill-menu)
- (#\r group-resize-menu))))
+ (#\r group-resize-menu)
+ (#\c center-current-group))))
-(defun group-pack-up ()
- "Pack group up"
- (print 'pack-up)
- (group-movement-menu))
-
-(defun group-pack-down ()
- "Pack group down"
- (print 'pack-down)
- (group-movement-menu))
+(defmacro with-movement (&body body)
+ `(when (group-p *current-child*)
+ , at body
+ (show-all-childs)
+ (draw-second-mode-window)
+ (group-movement-menu)))
+
+
+;;; Pack
+(defun current-group-pack-up ()
+ "Pack the current group up"
+ (with-movement (pack-group-up *current-child* (find-father-group *current-child* *current-root*))))
+
+(defun current-group-pack-down ()
+ "Pack the current group down"
+ (with-movement (pack-group-down *current-child* (find-father-group *current-child* *current-root*))))
+
+(defun current-group-pack-left ()
+ "Pack the current group left"
+ (with-movement (pack-group-left *current-child* (find-father-group *current-child* *current-root*))))
+
+(defun current-group-pack-right ()
+ "Pack the current group right"
+ (with-movement (pack-group-right *current-child* (find-father-group *current-child* *current-root*))))
+
+;;; Center
+(defun center-current-group ()
+ "Center the current group"
+ (with-movement (center-group *current-child*)))
+
+;;; Fill
+(defun current-group-fill-up ()
+ "Fill the current group up"
+ (with-movement (fill-group-up *current-child* (find-father-group *current-child* *current-root*))))
+
+(defun current-group-fill-down ()
+ "Fill the current group down"
+ (with-movement (fill-group-down *current-child* (find-father-group *current-child* *current-root*))))
+
+(defun current-group-fill-left ()
+ "Fill the current group left"
+ (with-movement (fill-group-left *current-child* (find-father-group *current-child* *current-root*))))
+
+(defun current-group-fill-right ()
+ "Fill the current group right"
+ (with-movement (fill-group-right *current-child* (find-father-group *current-child* *current-root*))))
+
+(defun current-group-fill-all-dir ()
+ "Fill the current group in all directions"
+ (with-movement
+ (let ((father (find-father-group *current-child* *current-root*)))
+ (fill-group-up *current-child* father)
+ (fill-group-down *current-child* father)
+ (fill-group-left *current-child* father)
+ (fill-group-right *current-child* father))))
+
+(defun current-group-fill-vertical ()
+ "Fill the current group vertically"
+ (with-movement
+ (let ((father (find-father-group *current-child* *current-root*)))
+ (fill-group-up *current-child* father)
+ (fill-group-down *current-child* father))))
+
+(defun current-group-fill-horizontal ()
+ "Fill the current group horizontally"
+ (with-movement
+ (let ((father (find-father-group *current-child* *current-root*)))
+ (fill-group-left *current-child* father)
+ (fill-group-right *current-child* father))))
+
+
+;;; Resize
+(defun current-group-resize-up ()
+ "Resize the current group up to its half height"
+ (with-movement (resize-half-height-up *current-child*)))
+
+(defun current-group-resize-down ()
+ "Resize the current group down to its half height"
+ (with-movement (resize-half-height-down *current-child*)))
+
+(defun current-group-resize-left ()
+ "Resize the current group left to its half width"
+ (with-movement (resize-half-width-left *current-child*)))
+
+(defun current-group-resize-right ()
+ "Resize the current group right to its half width"
+ (with-movement (resize-half-width-right *current-child*)))
+
+(defun current-group-resize-all-dir ()
+ "Resize down the current group"
+ (with-movement (resize-group-down *current-child*)))
+
+(defun current-group-resize-all-dir-minimal ()
+ "Resize down the current group to its minimal size"
+ (with-movement (resize-minimal-group *current-child*)))
Modified: clfswm/src/clfswm-layout.lisp
==============================================================================
--- clfswm/src/clfswm-layout.lisp (original)
+++ clfswm/src/clfswm-layout.lisp Fri Mar 21 16:58:00 2008
@@ -131,12 +131,12 @@
(1+ ry)
(- (round (* rw size)) 2)
(- rh 2)
- nil)
+ t)
(values (1+ (round (+ rx (* rw size))))
(1+ (round (+ ry (* dy (1- pos)))))
(- (round (* rw (- 1 size))) 2)
(- (round dy) 2)
- nil)))))
+ t)))))
(defun set-tile-left-layout ()
@@ -164,12 +164,12 @@
(1+ ry)
(- (round (* rw size)) 2)
(- rh 2)
- nil)
+ t)
(values (1+ rx)
(1+ (round (+ ry (* dy (1- pos)))))
(- (round (* rw (- 1 size))) 2)
(- (round dy) 2)
- nil)))))
+ t)))))
(defun set-tile-right-layout ()
@@ -199,12 +199,12 @@
(1+ ry)
(- rw 2)
(- (round (* rh size)) 2)
- nil)
+ t)
(values (1+ (round (+ rx (* dx (1- pos)))))
(1+ (round (+ ry (* rh size))))
(- (round dx) 2)
(- (round (* rh (- 1 size))) 2)
- nil)))))
+ t)))))
(defun set-tile-top-layout ()
@@ -231,11 +231,13 @@
(values (1+ rx)
(1+ (round (+ ry (* rh (- 1 size)))))
(- rw 2)
- (- (round (* rh size)) 2))
+ (- (round (* rh size)) 2)
+ t)
(values (1+ (round (+ rx (* dx (1- pos)))))
(1+ ry)
(- (round dx) 2)
- (- (round (* rh (- 1 size))) 2))))))
+ (- (round (* rh (- 1 size))) 2)
+ t)))))
@@ -269,7 +271,7 @@
(round (+ ry (truncate (* (truncate (/ pos n)) dy)) (* dy size) 1))
(round (- dx (* dx size 2) 2))
(round (- dy (* dy size 2) 2))
- nil))))
+ t))))
(defun set-space-tile-layout ()
"Tile Space: tile child in its group leaving spaces between them"
Modified: clfswm/src/clfswm-pack.lisp
==============================================================================
--- clfswm/src/clfswm-pack.lisp (original)
+++ clfswm/src/clfswm-pack.lisp Fri Mar 21 16:58:00 2008
@@ -26,212 +26,58 @@
(in-package :clfswm)
;;;,-----
-;;;| Tile functions
-;;;`-----
-(defun tile-workspace-vertically (workspace)
- "Tile a workspace vertically"
- (let* ((len (max (length (workspace-group-list workspace)) 1))
- (n (ceiling (sqrt len)))
- (dx (/ (xlib:screen-width *screen*) n))
- (dy (/ (xlib:screen-height *screen*) (ceiling (/ len n)))))
- (loop for group in (workspace-group-list workspace)
- for i from 0 do
- (setf (group-x group) (1+ (truncate (* (mod i n) dx)))
- (group-y group) (1+ (truncate (* (truncate (/ i n)) dy)))
- (group-width group) (- (truncate dx) 2)
- (group-height group) (- (truncate dy) 2)))))
-
-
-(defun tile-current-workspace-vertically ()
- "Tile the current workspace vertically"
- (minimize-group (current-group))
- (tile-workspace-vertically (current-workspace))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-
-(defun tile-workspace-horizontally (workspace)
- "Tile a workspace horizontally"
- (let* ((len (max (length (workspace-group-list workspace)) 1))
- (n (ceiling (sqrt len)))
- (dx (/ (xlib:screen-width *screen*) (ceiling (/ len n))))
- (dy (/ (xlib:screen-height *screen*) n)))
- (loop for group in (workspace-group-list workspace)
- for i from 0 do
- (setf (group-x group) (1+ (truncate (* (truncate (/ i n)) dx)))
- (group-y group) (1+ (truncate (* (mod i n) dy)))
- (group-width group) (- (truncate dx) 2)
- (group-height group) (- (truncate dy) 2)))))
-
-
-(defun tile-current-workspace-horizontally ()
- "Tile the current workspace horizontally"
- (minimize-group (current-group))
- (tile-workspace-horizontally (current-workspace))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-(defun tile-workspace-right (workspace)
- "Tile workspace with the current window on the left and others on the right"
- (let ((len (length (workspace-group-list workspace)))
- (group (first (workspace-group-list workspace))))
- (if (<= len 1)
- (setf (group-x group) 0
- (group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dy (/ (xlib:screen-height *screen*) (1- len))))
- (setf (group-x group) 1
- (group-y group) 1
- (group-width group) (- (xlib:screen-width *screen*) *tile-border-size* 1)
- (group-height group) (- (xlib:screen-height *screen*) 1))
- (loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) (- (xlib:screen-width *screen*) *tile-border-size* -1)
- (group-y g) (truncate (* i dy))
- (group-width g) (- *tile-border-size* 2)
- (group-height g) (truncate (- dy 1))))))))
-
-(defun tile-workspace-left (workspace)
- "Tile workspace with the current window on the right and others on the left"
- (let ((len (length (workspace-group-list workspace)))
- (group (first (workspace-group-list workspace))))
- (if (<= len 1)
- (setf (group-x group) 0
- (group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dy (/ (xlib:screen-height *screen*) (1- len))))
- (setf (group-x group) *tile-border-size*
- (group-y group) 1
- (group-width group) (- (xlib:screen-width *screen*) *tile-border-size* 1)
- (group-height group) (- (xlib:screen-height *screen*) 1))
- (loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) 0
- (group-y g) (truncate (* i dy))
- (group-width g) (- *tile-border-size* 2)
- (group-height g) (truncate (- dy 1))))))))
-
-
-(defun tile-workspace-top (workspace)
- "Tile workspace with the current window on the bottom and others on the top"
- (let ((len (length (workspace-group-list workspace)))
- (group (first (workspace-group-list workspace))))
- (if (<= len 1)
- (setf (group-x group) 0
- (group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dx (/ (xlib:screen-width *screen*) (1- len))))
- (setf (group-x group) 1
- (group-y group) *tile-border-size*
- (group-width group) (- (xlib:screen-width *screen*) 1)
- (group-height group) (- (xlib:screen-height *screen*) *tile-border-size* 1))
- (loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) (truncate (* i dx))
- (group-y g) 0
- (group-width g) (truncate (- dx 1))
- (group-height g) (- *tile-border-size* 2)))))))
-
-(defun tile-workspace-bottom (workspace)
- "Tile workspace with the current window on the top and others on the bottom"
- (let ((len (length (workspace-group-list workspace)))
- (group (first (workspace-group-list workspace))))
- (if (<= len 1)
- (setf (group-x group) 0
- (group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dx (/ (xlib:screen-width *screen*) (1- len))))
- (setf (group-x group) 1
- (group-y group) 1
- (group-width group) (- (xlib:screen-width *screen*) 1)
- (group-height group) (- (xlib:screen-height *screen*) *tile-border-size* 1))
- (loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) (truncate (* i dx))
- (group-y g) (- (xlib:screen-height *screen*) *tile-border-size* -1)
- (group-width g) (truncate (- dx 1))
- (group-height g) (- *tile-border-size* 2)))))))
-
-
-(defun tile-current-workspace-to ()
- "Tile the current workspace with the current window on one side and others on the other"
- (funcall *tile-workspace-function* (current-workspace))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-(defun reconfigure-tile-workspace ()
- "Reconfigure the workspace tiling for the current session"
- (let ((method (loop :for m = (intern (string-upcase
- (query-string "Workspace tiling method (R)ight, (L)eft, (T)op, (B)ottom:"))
- :keyword)
- :when (member m '(:r :l :t :b)) :return m))
- (size (loop :for s = (parse-integer (query-string "Workspace tiling border size"
- (format nil "~A" *tile-border-size*))
- :junk-allowed t)
- :when (numberp s) :return s)))
- (setf *tile-workspace-function* (case method
- (:r 'tile-workspace-right)
- (:l 'tile-workspace-left)
- (:t 'tile-workspace-top)
- (:b 'tile-workspace-bottom))
- *tile-border-size* size)))
-
-
-
-
-;;;,-----
;;;| Edges functions
;;;`-----
(defun group-x2 (group)
- (+ (group-x group) (group-width group)))
+ (+ (group-x group) (group-w group)))
(defun group-y2 (group)
- (+ (group-y group) (group-height group)))
+ (+ (group-y group) (group-h group)))
-(defun find-edge-up (current-group workspace)
+(defun find-edge-up (current-group father)
(let ((y-found 0))
- (dolist (group (workspace-group-list workspace))
- (when (and (not (equal group current-group))
+ (dolist (group (group-child father))
+ (when (and (group-p group)
+ (not (equal group current-group))
(<= (group-y2 group) (group-y current-group))
(>= (group-x2 group) (group-x current-group))
(<= (group-x group) (group-x2 current-group)))
- (setf y-found (max y-found (+ (group-y2 group) 2)))))
+ (setf y-found (max y-found (group-y2 group)))))
y-found))
-(defun find-edge-down (current-group workspace)
- (let ((y-found (xlib:screen-height *screen*)))
- (dolist (group (workspace-group-list workspace))
- (when (and (not (equal group current-group))
+(defun find-edge-down (current-group father)
+ (let ((y-found 1))
+ (dolist (group (group-child father))
+ (when (and (group-p group)
+ (not (equal group current-group))
(>= (group-y group) (group-y2 current-group))
(>= (group-x2 group) (group-x current-group))
(<= (group-x group) (group-x2 current-group)))
- (setf y-found (min y-found (- (group-y group) 2)))))
+ (setf y-found (min y-found (group-y group)))))
y-found))
-(defun find-edge-right (current-group workspace)
- (let ((x-found (xlib:screen-width *screen*)))
- (dolist (group (workspace-group-list workspace))
- (when (and (not (equal group current-group))
+(defun find-edge-right (current-group father)
+ (let ((x-found 1))
+ (dolist (group (group-child father))
+ (when (and (group-p group)
+ (not (equal group current-group))
(>= (group-x group) (group-x2 current-group))
(>= (group-y2 group) (group-y current-group))
(<= (group-y group) (group-y2 current-group)))
- (setf x-found (min x-found (- (group-x group) 2)))))
+ (setf x-found (min x-found (group-x group)))))
x-found))
-(defun find-edge-left (current-group workspace)
+(defun find-edge-left (current-group father)
(let ((x-found 0))
- (dolist (group (workspace-group-list workspace))
- (when (and (not (equal group current-group))
+ (dolist (group (group-child father))
+ (when (and (group-p group)
+ (not (equal group current-group))
(<= (group-x2 group) (group-x current-group))
(>= (group-y2 group) (group-y current-group))
(<= (group-y group) (group-y2 current-group)))
- (setf x-found (max x-found (+ (group-x2 group) 2)))))
+ (setf x-found (max x-found (group-x2 group)))))
x-found))
@@ -239,239 +85,139 @@
;;;,-----
;;;| Pack functions
;;;`-----
-
-
-
-(defun pack-group-up (workspace group)
+(defun pack-group-up (group father)
"Pack group to up"
- (let ((y-found (find-edge-up group workspace)))
+ (let ((y-found (find-edge-up group father)))
(setf (group-y group) y-found)))
-(defun pack-group-down (workspace group)
+(defun pack-group-down (group father)
"Pack group to down"
- (let ((y-found (find-edge-down group workspace)))
- (setf (group-y group) (- y-found (group-height group)))))
+ (let ((y-found (find-edge-down group father)))
+ (setf (group-y group) (- y-found (group-h group)))))
-(defun pack-group-right (workspace group)
+(defun pack-group-right (group father)
"Pack group to right"
- (let ((x-found (find-edge-right group workspace)))
- (setf (group-x group) (- x-found (group-width group)))))
+ (let ((x-found (find-edge-right group father)))
+ (setf (group-x group) (- x-found (group-w group)))))
-(defun pack-group-left (workspace group)
+(defun pack-group-left (group father)
"Pack group to left"
- (let ((x-found (find-edge-left group workspace)))
+ (let ((x-found (find-edge-left group father)))
(setf (group-x group) x-found)))
-
-(defun pack-current-group-up ()
- "Pack current group to up"
- (pack-group-up (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-(defun pack-current-group-down ()
- "Pack current group to down"
- (pack-group-down (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-(defun pack-current-group-right ()
- "Pack current group to right"
- (pack-group-right (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-(defun pack-current-group-left ()
- "Pack current group to left"
- (pack-group-left (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-
(defun center-group (group)
"Center group"
- (setf (group-x group) (truncate (/ (- (xlib:screen-width *screen*) (group-width group)) 2))
- (group-y group) (truncate (/ (- (xlib:screen-height *screen*) (group-height group)) 2))))
-
-(defun center-current-group ()
- "Center the current group"
- (center-group (current-group))
- (show-all-windows-in-workspace (current-workspace)))
+ (setf (group-x group) (/ (- 1 (group-w group)) 2)
+ (group-y group) (/ (- 1 (group-h group)) 2)))
;;;,-----
;;;| Fill functions
;;;`-----
-
-
-(defun fill-group-up (workspace group)
+(defun fill-group-up (group father)
"Fill a group up"
- (let* ((y-found (find-edge-up group workspace))
+ (let* ((y-found (find-edge-up group father))
(dy (- (group-y group) y-found)))
(setf (group-y group) y-found
- (group-height group) (+ (group-height group) dy))))
+ (group-h group) (+ (group-h group) dy))))
-(defun fill-group-down (workspace group)
+(defun fill-group-down (group father)
"Fill a group down"
- (let* ((y-found (find-edge-down group workspace))
+ (let* ((y-found (find-edge-down group father))
(dy (- y-found (group-y2 group))))
- (setf (group-height group) (+ (group-height group) dy))))
+ (setf (group-h group) (+ (group-h group) dy))))
-(defun fill-group-left (workspace group)
+(defun fill-group-left (group father)
"Fill a group left"
- (let* ((x-found (find-edge-left group workspace))
+ (let* ((x-found (find-edge-left group father))
(dx (- (group-x group) x-found)))
(setf (group-x group) x-found
- (group-width group) (+ (group-width group) dx))))
+ (group-w group) (+ (group-w group) dx))))
-(defun fill-group-right (workspace group)
+(defun fill-group-right (group father)
"Fill a group rigth"
- (let* ((x-found (find-edge-right group workspace))
+ (let* ((x-found (find-edge-right group father))
(dx (- x-found (group-x2 group))))
- (setf (group-width group) (+ (group-width group) dx))))
-
-
-(defun fill-current-group-up ()
- "Fill the current group up"
- (fill-group-up (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-(defun fill-current-group-down ()
- "Fill the current group down"
- (fill-group-down (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-(defun fill-current-group-left ()
- "Fill the current group left"
- (fill-group-left (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-(defun fill-current-group-right ()
- "Fill the current group rigth"
- (fill-group-right (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
+ (setf (group-w group) (+ (group-w group) dx))))
;;;,-----
;;;| Lower functions
;;;`-----
-
-(defun resize-down-group (group)
+(defun resize-group-down (group)
"Resize down a group"
- (when (> (group-width group) 100)
- (setf (group-x group) (+ (group-x group) 10)
- (group-width group) (max (- (group-width group) 20))))
- (when (> (group-height group) 100)
- (setf (group-y group) (+ (group-y group) 10)
- (group-height group) (max (- (group-height group) 20)))))
+ (when (> (group-w group) 0.1)
+ (setf (group-x group) (+ (group-x group) 0.01)
+ (group-w group) (max (- (group-w group) 0.02) 0.01)))
+ (when (> (group-h group) 0.1)
+ (setf (group-y group) (+ (group-y group) 0.01)
+ (group-h group) (max (- (group-h group) 0.02) 0.01))))
(defun resize-minimal-group (group)
"Resize down a group to its minimal size"
- (loop while (> (group-width group) 100) do
- (setf (group-x group) (+ (group-x group) 10)
- (group-width group) (max (- (group-width group) 20))))
- (loop while (> (group-height group) 100) do
- (setf (group-y group) (+ (group-y group) 10)
- (group-height group) (max (- (group-height group) 20)))))
-
-
-
-(defun resize-down-current-group ()
- "Resize down the current group"
- (resize-down-group (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
+ (dotimes (i 100)
+ (resize-group-down group)))
-(defun resize-minimal-current-group ()
- "Resize down the current group to its minimal size"
- (resize-minimal-group (current-group))
- (show-all-windows-in-workspace (current-workspace)))
(defun resize-half-width-left (group)
- (setf (group-width group)
- (max (truncate (/ (group-width group) 2))
- 100)))
+ (setf (group-w group)(/ (group-w group) 2)))
+
(defun resize-half-width-right (group)
- (let* ((new-size (max (truncate (/ (group-width group) 2)) 100))
- (dx (- (group-width group) new-size)))
- (setf (group-width group) new-size)
+ (let* ((new-size (/ (group-w group) 2))
+ (dx (- (group-w group) new-size)))
+ (setf (group-w group) new-size)
(incf (group-x group) (max dx 0))))
(defun resize-half-height-up (group)
- (setf (group-height group)
- (max (truncate (/ (group-height group) 2))
- 100)))
+ (setf (group-h group) (/ (group-h group) 2)))
(defun resize-half-height-down (group)
- (let* ((new-size (max (truncate (/ (group-height group) 2)) 100))
- (dy (- (group-height group) new-size)))
- (setf (group-height group) new-size)
+ (let* ((new-size (/ (group-h group) 2))
+ (dy (- (group-h group) new-size)))
+ (setf (group-h group) new-size)
(incf (group-y group) (max dy 0))))
-(defun resize-half-width-left-current-group ()
- "Resize the current group to its half width to left"
- (resize-half-width-left (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-(defun resize-half-width-right-current-group ()
- "Resize the current group to its half width to right"
- (resize-half-width-right (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-(defun resize-half-height-up-current-group ()
- "Resize the current group to its half height to up"
- (resize-half-height-up (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-(defun resize-half-height-down-current-group ()
- "Resize the current group to its half height to down"
- (resize-half-height-down (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-
-;;;,-----
-;;;| Explode/Implode functions
-;;;`-----
-(defun explode-group (workspace group)
- "Create a new group for each window in group"
- (dolist (w (rest (group-window-list group)))
- (add-group-in-workspace (copy-group *default-group*) workspace)
- (add-window-in-group w (first (workspace-group-list workspace)))
- (remove-window-in-group w group)))
-
-(defun implode-group (workspace)
- "Move all windows in workspace to one group and remove other groups"
- (dolist (g (rest (workspace-group-list workspace)))
- (dolist (w (group-window-list g))
- (add-window-in-group w (first (workspace-group-list workspace)))
- (remove-window-in-group w g))
- (remove-group-in-workspace g workspace)))
-
-
-
-(defun explode-current-group ()
- "Create a new group for each window in the current group"
- (explode-group (current-workspace) (current-group))
- (show-all-windows-in-workspace (current-workspace)))
-
-
-(defun implode-current-group ()
- "Move all windows in the current workspace to one group and remove other groups"
- (implode-group (current-workspace))
- (show-all-windows-in-workspace (current-workspace)))
+;;;;;,-----
+;;;;;| Explode/Implode functions
+;;;;;`-----
+;;(defun explode-group (workspace group)
+;; "Create a new group for each window in group"
+;; (dolist (w (rest (group-window-list group)))
+;; (add-group-in-workspace (copy-group *default-group*) workspace)
+;; (add-window-in-group w (first (workspace-group-list workspace)))
+;; (remove-window-in-group w group)))
+;;
+;;(defun implode-group (workspace)
+;; "Move all windows in workspace to one group and remove other groups"
+;; (dolist (g (rest (workspace-group-list workspace)))
+;; (dolist (w (group-window-list g))
+;; (add-window-in-group w (first (workspace-group-list workspace)))
+;; (remove-window-in-group w g))
+;; (remove-group-in-workspace g workspace)))
+;;
+;;
+;;
+;;(defun explode-current-group ()
+;; "Create a new group for each window in the current group"
+;; (explode-group (current-workspace) (current-group))
+;; (show-all-windows-in-workspace (current-workspace)))
+;;
+;;
+;;(defun implode-current-group ()
+;; "Move all windows in the current workspace to one group and remove other groups"
+;; (implode-group (current-workspace))
+;; (show-all-windows-in-workspace (current-workspace)))
Modified: clfswm/src/clfswm-second-mode.lisp
==============================================================================
--- clfswm/src/clfswm-second-mode.lisp (original)
+++ clfswm/src/clfswm-second-mode.lisp Fri Mar 21 16:58:00 2008
@@ -54,6 +54,7 @@
(defun draw-second-mode-window ()
+ (raise-window *sm-window*)
(xlib:clear-area *sm-window*)
(let* ((text (format nil "Second mode"))
(len (length text)))
More information about the clfswm-cvs
mailing list