[clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen Window Manager branch test updated. R-1106-64-ge9afcbc
Philippe Brochard
pbrochard at common-lisp.net
Mon Jun 18 19:55:12 UTC 2012
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".
The branch, test has been updated
via e9afcbc29bc68c2939eaf4b852a86558f3d9c669 (commit)
from 92c06b8c12a4e3cf3adfd9868ad16974a0fe604c (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e9afcbc29bc68c2939eaf4b852a86558f3d9c669
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date: Mon Jun 18 21:55:06 2012 +0200
src/clfswm-placement.lisp: Each child can have its own border size. New binding to change the child border size on the fly.
diff --git a/ChangeLog b/ChangeLog
index d58317a..c4231cd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-06-18 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-placement.lisp: Each child can have its own border
+ size. New binding to change the child border size on the fly.
+
2012-06-08 Philippe Brochard <pbrochard at common-lisp.net>
* src/tools.lisp (process-timers): Call get-internal-real-time
diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index a3017d6..af41d01 100644
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -27,6 +27,32 @@
+(defgeneric child-border-size (child))
+
+(defmethod child-border-size ((child frame))
+ (x-drawable-border-width (frame-window child)))
+
+(defmethod child-border-size ((child xlib:window))
+ (x-drawable-border-width child))
+
+(defmethod child-border-size (child)
+ 0)
+
+(defgeneric set-child-border-size (child value))
+
+(defmethod set-child-border-size ((child frame) value)
+ (setf (x-drawable-border-width (frame-window child)) value))
+
+(defmethod set-child-border-size ((child xlib:window) value)
+ (setf (x-drawable-border-width child) value))
+
+(defmethod set-child-border-size (child value)
+ (declare (ignore child value)))
+
+(defsetf child-border-size set-child-border-size)
+
+
+
;;; Conversion functions
;;; Float -> Pixel conversion
(defun x-fl->px (x parent)
@@ -48,11 +74,11 @@
;;; Pixel -> Float conversion
(defun x-px->fl (x parent)
"Convert pixel X coordinate to float"
- (/ (- x (frame-rx parent) *border-size*) (frame-rw parent)))
+ (/ (- x (frame-rx parent) (child-border-size parent)) (frame-rw parent)))
(defun y-px->fl (y parent)
"Convert pixel Y coordinate to float"
- (/ (- y (frame-ry parent) *border-size*) (frame-rh parent)))
+ (/ (- y (frame-ry parent) (child-border-size parent)) (frame-rh parent)))
(defun w-px->fl (w parent)
"Convert pixel Width coordinate to float"
@@ -270,7 +296,6 @@
-
(defgeneric child-x (child))
(defmethod child-x ((child xlib:window))
(x-drawable-x child))
@@ -604,8 +629,7 @@
(defun unsure-at-least-one-root ()
(unless root-list
- (define-as-root *root-frame* (- *border-size*) (- *border-size*)
- (xlib:screen-width *screen*) (xlib:screen-height *screen*))))
+ (define-as-root *root-frame* 0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*))))
(defun find-root-by-coordinates (x y)
(dolist (root root-list)
@@ -754,7 +778,7 @@ XINERAMA version 1.1 opcode: 150
do (when (search " head " line)
(destructuring-bind (w h x y)
(parse-xinerama-info line)
- (push (list (- x *border-size*) (- y *border-size*) w h) sizes))))
+ (push (list x y w h) sizes))))
(dbg sizes)
(remove-duplicates sizes :test #'equal)))))
@@ -766,22 +790,22 @@ XINERAMA version 1.1 opcode: 150
(height (xlib:screen-height *screen*)))
;;(add-placed-frame-tmp (first (frame-child *root-frame*)) 2)
(if (<= (length sizes) 1)
- (define-as-root *root-frame* (- *border-size*) (- *border-size*) width height)
- (progn
- (loop while (< (length (frame-child *root-frame*)) (length sizes))
- do (let ((frame (create-frame)))
- ;;(add-placed-frame-tmp frame 2)))
- (add-frame frame *root-frame*)))
- (loop for size in sizes
- for frame in (frame-child *root-frame*)
- do (destructuring-bind (x y w h) size
- (setf (frame-x frame) (float (/ x width))
- (frame-y frame) (float (/ y height))
- (frame-w frame) (float (/ w width))
- (frame-h frame) (float (/ h height)))
- (add-frame (create-frame) frame)
- (define-as-root frame x y w h)))
- (setf (current-child) (first (frame-child (first (frame-child *root-frame*)))))))))
+ (define-as-root *root-frame* 0 0 width height))
+ (progn
+ (loop while (< (length (frame-child *root-frame*)) (length sizes))
+ do (let ((frame (create-frame)))
+ ;;(add-placed-frame-tmp frame 2)))
+ (add-frame frame *root-frame*)))
+ (loop for size in sizes
+ for frame in (frame-child *root-frame*)
+ do (destructuring-bind (x y w h) size
+ (setf (frame-x frame) (float (/ x width))
+ (frame-y frame) (float (/ y height))
+ (frame-w frame) (float (/ w width))
+ (frame-h frame) (float (/ h height)))
+ (add-frame (create-frame) frame)
+ (define-as-root frame x y w h)))
+ (setf (current-child) (first (frame-child (first (frame-child *root-frame*))))))))
@@ -879,17 +903,16 @@ XINERAMA version 1.1 opcode: 150
(declare (ignore child name)))
-
-
(defun get-parent-layout (child parent)
(aif (child-root-p child)
- (values (root-x it) (root-y it) (root-w it) (root-h it))
+ (values (- (root-x it) (child-border-size child)) (- (root-y it) (child-border-size child))
+ (root-w it) (root-h it))
(if (or (frame-p child) (managed-window-p child parent))
(if (frame-p parent)
(aif (frame-layout parent)
(funcall it child parent)
(no-layout child parent))
- (values (- *border-size*) (- *border-size*)
+ (values (- (child-border-size child)) (- (child-border-size child))
(xlib:screen-width *screen*)
(xlib:screen-height *screen*)))
(values (x-drawable-x child) (x-drawable-y child)
diff --git a/src/clfswm-layout.lisp b/src/clfswm-layout.lisp
index e8dafad..83953fc 100644
--- a/src/clfswm-layout.lisp
+++ b/src/clfswm-layout.lisp
@@ -156,14 +156,14 @@
(defmethod no-layout ((child xlib:window) parent)
(with-slots (rx ry rw rh) parent
- (values (adj-border-xy rx child)
- (adj-border-xy ry child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy ry parent)
(adj-border-wh rw child)
(adj-border-wh rh child))))
(defmethod no-layout ((child frame) parent)
- (values (adj-border-xy (x-fl->px (frame-x child) parent) child)
- (adj-border-xy (y-fl->px (frame-y child) parent) child)
+ (values (adj-border-xy (x-fl->px (frame-x child) parent) parent)
+ (adj-border-xy (y-fl->px (frame-y child) parent) parent)
(adj-border-wh (w-fl->px (frame-w child) parent) child)
(adj-border-wh (h-fl->px (frame-h child) parent) child)))
@@ -191,8 +191,8 @@
(defmethod maximize-layout (child parent)
(with-slots (rx ry rw rh) parent
- (values (adj-border-xy rx child)
- (adj-border-xy ry child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy ry parent)
(adj-border-wh rw child)
(adj-border-wh rh child))))
@@ -269,8 +269,8 @@
(if (zerop pos)
(setf width (* dx (1+ dpos)))
(incf pos dpos)))
- (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) child))
- (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) child))
+ (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) parent))
+ (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) parent))
(round (adj-border-wh width child))
(round (adj-border-wh dy child)))))
@@ -299,8 +299,8 @@
(if (zerop pos)
(setf height (* dy (1+ dpos)))
(incf pos dpos)))
- (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) child))
- (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) child))
+ (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) parent))
+ (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) parent))
(round (adj-border-wh dx child))
(round (adj-border-wh height child)))))
@@ -333,9 +333,9 @@
(setf width (* dx (1+ dpos)))
(incf pos dpos)))
(values (round (adj-border-xy (+ (frame-rx parent)
- (truncate (* (mod pos nx) dx))) child))
+ (truncate (* (mod pos nx) dx))) parent))
(round (adj-border-xy (+ (frame-ry parent)
- (truncate (* (truncate (/ pos nx)) dy))) child))
+ (truncate (* (truncate (/ pos nx)) dy))) parent))
(round (adj-border-wh width child))
(round (adj-border-wh dy child)))))
@@ -355,8 +355,8 @@
(pos (child-position child managed-children))
(len (length managed-children))
(dy (/ (frame-rh parent) len)))
- (values (round (adj-border-xy (frame-rx parent) child))
- (round (adj-border-xy (+ (frame-ry parent) (* pos dy)) child))
+ (values (round (adj-border-xy (frame-rx parent) parent))
+ (round (adj-border-xy (+ (frame-ry parent) (* pos dy)) parent))
(round (adj-border-wh (frame-rw parent) child))
(round (adj-border-wh dy child)))))
@@ -375,8 +375,8 @@
(pos (child-position child managed-children))
(len (length managed-children))
(dx (/ (frame-rw parent) len)))
- (values (round (adj-border-xy (+ (frame-rx parent) (* pos dx)) child))
- (round (adj-border-xy (frame-ry parent) child))
+ (values (round (adj-border-xy (+ (frame-rx parent) (* pos dx)) parent))
+ (round (adj-border-xy (frame-ry parent) parent))
(round (adj-border-wh dx child))
(round (adj-border-wh (frame-rh parent) child)))))
@@ -410,10 +410,8 @@
(child-width (floor (- rw col-space-total) cols))
(child-height (floor (- rh row-space-total) rows))
)
- (values (round (adj-border-xy (+ rx col-space
- (* (+ col-space child-width) col)) child))
- (round (adj-border-xy (+ ry row-space
- (* (+ row-space child-height) row)) child))
+ (values (round (adj-border-xy (+ rx col-space (* (+ col-space child-width) col)) parent))
+ (round (adj-border-xy (+ ry row-space (* (+ row-space child-height) row)) parent))
(round (adj-border-wh child-width child))
(round (adj-border-wh child-height child))))))
@@ -447,12 +445,12 @@
(size (or (frame-data-slot parent :tile-size) 0.8)))
(if (> (length managed-children) 1)
(if (= pos 0)
- (values (adj-border-xy rx child)
- (adj-border-xy ry child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy ry parent)
(adj-border-wh (round (* rw size)) child)
(adj-border-wh rh child))
- (values (adj-border-xy (round (+ rx (* rw size))) child)
- (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
+ (values (adj-border-xy (round (+ rx (* rw size))) parent)
+ (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
(adj-border-wh (round (* rw (- 1 size))) child)
(adj-border-wh (round dy) child)))
(no-layout child parent)))))
@@ -477,12 +475,12 @@
(size (or (frame-data-slot parent :tile-size) 0.8)))
(if (> (length managed-children) 1)
(if (= pos 0)
- (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
- (adj-border-xy ry child)
+ (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) parent)
+ (adj-border-xy ry parent)
(adj-border-wh (round (* rw size)) child)
(adj-border-wh rh child))
- (values (adj-border-xy rx child)
- (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
(adj-border-wh (round (* rw (- 1 size))) child)
(adj-border-wh (round dy) child)))
(no-layout child parent)))))
@@ -510,12 +508,12 @@
(size (or (frame-data-slot parent :tile-size) 0.8)))
(if (> (length managed-children) 1)
(if (= pos 0)
- (values (adj-border-xy rx child)
- (adj-border-xy ry child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy ry parent)
(adj-border-wh rw child)
(adj-border-wh (round (* rh size)) child))
- (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
- (adj-border-xy (round (+ ry (* rh size))) child)
+ (values (adj-border-xy (round (+ rx (* dx (1- pos)))) parent)
+ (adj-border-xy (round (+ ry (* rh size))) parent)
(adj-border-wh (round dx) child)
(adj-border-wh (round (* rh (- 1 size))) child)))
(no-layout child parent)))))
@@ -541,12 +539,12 @@
(size (or (frame-data-slot parent :tile-size) 0.8)))
(if (> (length managed-children) 1)
(if (= pos 0)
- (values (adj-border-xy rx child)
- (adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy (round (+ ry (* rh (- 1 size)))) parent)
(adj-border-wh rw child)
(adj-border-wh (round (* rh size)) child))
- (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
- (adj-border-xy ry child)
+ (values (adj-border-xy (round (+ rx (* dx (1- pos)))) parent)
+ (adj-border-xy ry parent)
(adj-border-wh (round dx) child)
(adj-border-wh (round (* rh (- 1 size))) child)))
(no-layout child parent)))))
@@ -589,12 +587,12 @@
(space (or (frame-data-slot parent :tile-left-space) 100)))
(if (> (length managed-children) 1)
(if (= pos 0)
- (values (adj-border-xy (+ rx space) child)
- (adj-border-xy ry child)
+ (values (adj-border-xy (+ rx space) parent)
+ (adj-border-xy ry parent)
(adj-border-wh (- (round (* rw size)) space) child)
(adj-border-wh rh child))
- (values (adj-border-xy (round (+ rx (* rw size))) child)
- (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
+ (values (adj-border-xy (round (+ rx (* rw size))) parent)
+ (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
(adj-border-wh (round (* rw (- 1 size))) child)
(adj-border-wh (round dy) child)))
(multiple-value-bind (rnx rny rnw rnh)
@@ -632,12 +630,12 @@
(if (child-member child main-windows)
(let* ((dy (/ rh len))
(pos (child-position child main-windows)))
- (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
- (adj-border-xy (round (+ ry (* dy pos))) child)
+ (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) parent)
+ (adj-border-xy (round (+ ry (* dy pos))) parent)
(adj-border-wh (round (* rw size)) child)
(adj-border-wh (round dy) child)))
- (values (adj-border-xy rx child)
- (adj-border-xy ry child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy ry parent)
(adj-border-wh (round (* rw (- 1 size))) child)
(adj-border-wh rh child)))))))
@@ -660,12 +658,12 @@
(if (child-member child main-windows)
(let* ((dy (/ rh len))
(pos (child-position child main-windows)))
- (values (adj-border-xy rx child)
- (adj-border-xy (round (+ ry (* dy pos))) child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy (round (+ ry (* dy pos))) parent)
(adj-border-wh (round (* rw size)) child)
(adj-border-wh (round dy) child)))
- (values (adj-border-xy (round (+ rx (* rw size))) child)
- (adj-border-xy ry child)
+ (values (adj-border-xy (round (+ rx (* rw size))) parent)
+ (adj-border-xy ry parent)
(adj-border-wh (round (* rw (- 1 size))) child)
(adj-border-wh rh child)))))))
@@ -687,12 +685,12 @@
(if (child-member child main-windows)
(let* ((dx (/ rw len))
(pos (child-position child main-windows)))
- (values (adj-border-xy (round (+ rx (* dx pos))) child)
- (adj-border-xy ry child)
+ (values (adj-border-xy (round (+ rx (* dx pos))) parent)
+ (adj-border-xy ry parent)
(adj-border-wh (round dx) child)
(adj-border-wh (round (* rh size)) child)))
- (values (adj-border-xy rx child)
- (adj-border-xy (round (+ ry (* rh size))) child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy (round (+ ry (* rh size))) parent)
(adj-border-wh rw child)
(adj-border-wh (round (* rh (- 1 size))) child)))))))
@@ -714,12 +712,12 @@
(if (child-member child main-windows)
(let* ((dx (/ rw len))
(pos (child-position child main-windows)))
- (values (adj-border-xy (round (+ rx (* dx pos))) child)
- (adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
+ (values (adj-border-xy (round (+ rx (* dx pos))) parent)
+ (adj-border-xy (round (+ ry (* rh (- 1 size)))) parent)
(adj-border-wh (round dx) child)
(adj-border-wh (round (* rh size)) child)))
- (values (adj-border-xy rx child)
- (adj-border-xy ry child)
+ (values (adj-border-xy rx parent)
+ (adj-border-xy ry parent)
(adj-border-wh rw child)
(adj-border-wh (round (* rh (- 1 size))) child)))))))
diff --git a/src/clfswm-pack.lisp b/src/clfswm-pack.lisp
index 00fffa6..f921e77 100644
--- a/src/clfswm-pack.lisp
+++ b/src/clfswm-pack.lisp
@@ -90,26 +90,26 @@
;;;,-----
;;;| Pack functions
;;;`-----
-(defun pack-frame-up (frame parent)
+(defun pack-frame-up (frame parent &optional sp-y-found)
"Pack frame to up"
- (let ((y-found (find-edge-up frame parent)))
+ (let ((y-found (or sp-y-found (find-edge-up frame parent))))
(setf (frame-y frame) y-found)))
-(defun pack-frame-down (frame parent)
+(defun pack-frame-down (frame parent &optional sp-y-found)
"Pack frame to down"
- (let ((y-found (find-edge-down frame parent)))
+ (let ((y-found (or sp-y-found (find-edge-down frame parent))))
(setf (frame-y frame) (- y-found (frame-h frame)))))
-(defun pack-frame-right (frame parent)
+(defun pack-frame-right (frame parent &optional sp-x-found)
"Pack frame to right"
- (let ((x-found (find-edge-right frame parent)))
+ (let ((x-found (or sp-x-found (find-edge-right frame parent))))
(setf (frame-x frame) (- x-found (frame-w frame)))))
-(defun pack-frame-left (frame parent)
+(defun pack-frame-left (frame parent &optional sp-x-found)
"Pack frame to left"
- (let ((x-found (find-edge-left frame parent)))
+ (let ((x-found (or sp-x-found (find-edge-left frame parent))))
(setf (frame-x frame) x-found)))
@@ -122,30 +122,30 @@
;;;,-----
;;;| Fill functions
;;;`-----
-(defun fill-frame-up (frame parent)
+(defun fill-frame-up (frame parent &optional sp-y-found)
"Fill a frame up"
- (let* ((y-found (find-edge-up frame parent))
+ (let* ((y-found (or sp-y-found (find-edge-up frame parent)))
(dy (- (frame-y frame) y-found)))
(setf (frame-y frame) y-found
(frame-h frame) (+ (frame-h frame) dy))))
-(defun fill-frame-down (frame parent)
+(defun fill-frame-down (frame parent &optional sp-y-found)
"Fill a frame down"
- (let* ((y-found (find-edge-down frame parent))
+ (let* ((y-found (or sp-y-found (find-edge-down frame parent)))
(dy (- y-found (frame-y2 frame))))
(setf (frame-h frame) (+ (frame-h frame) dy))))
-(defun fill-frame-left (frame parent)
+(defun fill-frame-left (frame parent &optional sp-x-found)
"Fill a frame left"
- (let* ((x-found (find-edge-left frame parent))
+ (let* ((x-found (or sp-x-found (find-edge-left frame parent)))
(dx (- (frame-x frame) x-found)))
(setf (frame-x frame) x-found
(frame-w frame) (+ (frame-w frame) dx))))
-(defun fill-frame-right (frame parent)
+(defun fill-frame-right (frame parent &optional sp-x-found)
"Fill a frame rigth"
- (let* ((x-found (find-edge-right frame parent))
+ (let* ((x-found (or sp-x-found (find-edge-right frame parent)))
(dx (- x-found (frame-x2 frame))))
(setf (frame-w frame) (+ (frame-w frame) dx))))
@@ -236,19 +236,29 @@
;;;;;,-----
;;;;;| Constrained move/resize frames
;;;;;`-----
-(labels ((readjust-all-frames-fl-size (parent)
+(labels ((redisplay (frame window)
+ (show-all-children)
+ (hide-all-children frame)
+ (setf (xlib:window-border window) (get-color *color-move-window*)))
+ (readjust-all-frames-fl-size (parent)
(dolist (child (frame-child parent))
(when (frame-p child)
(setf (frame-x child) (x-px->fl (x-drawable-x (frame-window child)) parent)
(frame-y child) (y-px->fl (x-drawable-y (frame-window child)) parent)
- (frame-w child) (w-px->fl (anti-adj-border-wh (x-drawable-width (frame-window child)) parent) parent)
- (frame-h child) (h-px->fl (anti-adj-border-wh (x-drawable-height (frame-window child)) parent) parent))))))
+ (frame-w child) (w-px->fl (anti-adj-border-wh (x-drawable-width (frame-window child)) child) parent)
+ (frame-h child) (h-px->fl (anti-adj-border-wh (x-drawable-height (frame-window child)) child)
+ parent))))))
(defun move-frame-constrained (frame parent orig-x orig-y)
- (when (and frame parent (not (child-root-p frame)))
+ (when (and (frame-p frame) parent (not (child-root-p frame)))
(hide-all-children frame)
(with-slots (window) frame
- (let ((lx orig-x)
- (ly orig-y))
+ (let ((snap-size (/ *snap-size* 100.0))
+ (lx orig-x)
+ (ly orig-y)
+ (l-frame-x-r nil)
+ (l-frame-x-l nil)
+ (l-frame-y-u nil)
+ (l-frame-y-d nil))
(readjust-all-frames-fl-size parent)
(move-window window orig-x orig-y
(lambda ()
@@ -258,29 +268,41 @@
(frame-y frame) (y-px->fl (x-drawable-y window) parent))
(multiple-value-bind (x y) (xlib:query-pointer *root*)
(when (> x lx)
- (let ((x-found (x-fl->px (find-edge-right frame parent) parent)))
- (when (< (abs (- x-found (window-x2 window))) *snap-size*)
- (setf (x-drawable-x window) (- x-found (adj-border-xy (x-drawable-width window) window))
- (frame-x frame) (x-px->fl (x-drawable-x window) parent)
- move-x nil))))
+ (setf l-frame-x-l nil)
+ (let ((x-found (find-edge-right frame parent)))
+ (when (< (abs (- x-found (frame-x2 frame))) snap-size)
+ (pack-frame-right frame parent x-found)
+ (when (not (equal (frame-x frame) l-frame-x-r))
+ (redisplay frame window)
+ (setf l-frame-x-r (frame-x frame)))
+ (setf move-x nil))))
(when (< x lx)
- (let ((x-found (x-fl->px (find-edge-left frame parent) parent)))
- (when (< (abs (- x-found (x-drawable-x window))) *snap-size*)
- (setf (x-drawable-x window) (adj-border-xy x-found window)
- (frame-x frame) (x-px->fl (x-drawable-x window) parent)
- move-x nil))))
+ (setf l-frame-x-r nil)
+ (let ((x-found (find-edge-left frame parent)))
+ (when (< (abs (- x-found (frame-x frame))) snap-size)
+ (pack-frame-left frame parent x-found)
+ (when (not (equal (frame-x frame) l-frame-x-l))
+ (redisplay frame window)
+ (setf l-frame-x-l (frame-x frame)))
+ (setf move-x nil))))
(when (> y ly)
- (let ((y-found (y-fl->px (find-edge-down frame parent) parent)))
- (when (< (abs (- y-found (window-y2 window))) *snap-size*)
- (setf (x-drawable-y window) (- y-found (adj-border-xy (x-drawable-height window) window))
- (frame-y frame) (y-px->fl (x-drawable-y window) parent)
- move-y nil))))
+ (setf l-frame-y-u nil)
+ (let ((y-found (find-edge-down frame parent)))
+ (when (< (abs (- y-found (frame-y2 frame))) snap-size)
+ (pack-frame-down frame parent y-found)
+ (when (not (equal (frame-y frame) l-frame-y-d))
+ (redisplay frame window)
+ (setf l-frame-y-d (frame-y frame)))
+ (setf move-y nil))))
(when (< y ly)
- (let ((y-found (y-fl->px (find-edge-up frame parent) parent)))
- (when (< (abs (- y-found (x-drawable-y window))) *snap-size*)
- (setf (x-drawable-y window) (adj-border-xy y-found window)
- (frame-y frame) (y-px->fl (x-drawable-y window) parent)
- move-y nil))))
+ (setf l-frame-y-d nil)
+ (let ((y-found (find-edge-up frame parent)))
+ (when (< (abs (- y-found (frame-y frame))) snap-size)
+ (pack-frame-up frame parent y-found)
+ (when (not (equal (frame-y frame) l-frame-y-u))
+ (redisplay frame window)
+ (setf l-frame-y-u (frame-y frame)))
+ (setf move-y nil))))
(display-frame-info frame)
(when move-x (setf lx x))
(when move-y (setf ly y))
@@ -292,31 +314,43 @@
(when (and frame parent (not (child-root-p frame)))
(hide-all-children frame)
(with-slots (window) frame
- (let ((lx orig-x)
- (ly orig-y))
+ (let ((snap-size (/ *snap-size* 100.0))
+ (lx orig-x)
+ (ly orig-y)
+ (l-frame-w nil)
+ (l-frame-h nil))
(readjust-all-frames-fl-size parent)
(resize-window window orig-x orig-y
(lambda ()
(let ((resize-w t)
(resize-h t))
+ (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) frame)
+ parent)
+ (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) frame)
+ parent))
(multiple-value-bind (x y) (xlib:query-pointer *root*)
- (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) parent) parent)
- (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) parent) parent))
(when (> x lx)
- (let ((x-found (x-fl->px (find-edge-right frame parent) parent)))
- (when (< (abs (- x-found (window-x2 window))) *snap-size*)
- (setf (x-drawable-width window) (+ (x-drawable-width window)
- (- x-found (adj-border-xy (window-x2 window) parent)))
- (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) parent) parent)
- resize-w nil))))
+ (let ((x-found (find-edge-right frame parent)))
+ (when (< (abs (- x-found (frame-x2 frame))) snap-size)
+ (fill-frame-right frame parent x-found)
+ (when (not (equal (frame-w frame) l-frame-w))
+ (redisplay frame window)
+ (setf l-frame-w (frame-w frame)))
+ (setf resize-w nil))))
+ (when (< x lx)
+ (setf l-frame-w nil))
(when (> y ly)
- (let ((y-found (y-fl->px (find-edge-down frame parent) parent)))
- (when (< (abs (- y-found (window-y2 window))) *snap-size*)
- (setf (x-drawable-height window) (+ (x-drawable-height window)
- (- y-found (adj-border-xy (window-y2 window) parent)))
- (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) parent) parent)
- resize-h nil))))
- (display-frame-info frame)
+ (let ((y-found (find-edge-down frame parent)))
+ (when (< (abs (- y-found (frame-y2 frame))) snap-size)
+ (fill-frame-down frame parent y-found)
+ (when (or (null l-frame-h)
+ (and (numberp l-frame-h)
+ (/= (frame-h frame) l-frame-h)))
+ (redisplay frame window)
+ (setf l-frame-h (frame-h frame)))
+ (setf resize-h nil))))
+ (when (< y ly)
+ (setf l-frame-h nil))
(when resize-w (setf lx x))
(when resize-h (setf ly y))
(values resize-w resize-h)))))))
diff --git a/src/clfswm-placement.lisp b/src/clfswm-placement.lisp
index 242bc91..4e8d4e9 100644
--- a/src/clfswm-placement.lisp
+++ b/src/clfswm-placement.lisp
@@ -60,161 +60,123 @@
;;;
;;; Absolute placement
;;;
+(defun root-screen-coord (border-size)
+ (values (- (xlib:screen-width *screen*) (* 2 border-size))
+ (- (xlib:screen-height *screen*) (* 2 border-size))))
+
+(defmacro with-root-screen-coord ((border-size w h) &body body)
+ `(multiple-value-bind (,w ,h)
+ (root-screen-coord ,border-size)
+ (let ((width (min width ,w))
+ (height (min height ,h)))
+ , at body)))
+
+
(defun top-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (values 0 0 width height))
+ (with-root-screen-coord (border-size w h)
+ (values 0 0 width height)))
(defun top-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
- 0
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values (truncate (/ (- w width) 2)) 0 width height)))
(defun top-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (values (- (xlib:screen-width *screen*) width (* border-size 2))
- 0
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values (- w width) 0 width height)))
(defun middle-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (values 0
- (truncate (/ (- (xlib:screen-height *screen*) height) 2))
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values 0 (truncate (/ (- h height) 2)) width height)))
(defun middle-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
- (truncate (/ (- (xlib:screen-height *screen*) height) 2))
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values (truncate (/ (- w width) 2)) (truncate (/ (- h height) 2)) width height)))
(defun middle-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (values (- (xlib:screen-width *screen*) width (* border-size 2))
- (truncate (/ (- (xlib:screen-height *screen*) height) 2))
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values (- w width) (truncate (/ (- h height) 2)) width height)))
(defun bottom-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (values 0
- (- (xlib:screen-height *screen*) height (* border-size 2))
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values 0 (- h height) width height)))
(defun bottom-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
- (- (xlib:screen-height *screen*) height (* border-size 2))
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values (truncate (/ (- w width) 2)) (- h height) width height)))
(defun bottom-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (values (- (xlib:screen-width *screen*) width (* border-size 2))
- (- (xlib:screen-height *screen*) height (* border-size 2))
- width height))
+ (with-root-screen-coord (border-size w h)
+ (values (- w width) (- h height) width height)))
;;;
;;; Current child placement
;;;
-(defun current-child-coord ()
+(defun current-child-coord (border-size)
(typecase (current-child)
(xlib:window (values (x-drawable-x (current-child))
(x-drawable-y (current-child))
- (x-drawable-width (current-child))
- (x-drawable-height (current-child))))
+ (- (x-drawable-width (current-child)) (* 2 border-size))
+ (- (x-drawable-height (current-child)) (* 2 border-size))))
(frame (values (frame-rx (current-child))
(frame-ry (current-child))
- (frame-rw (current-child))
- (frame-rh (current-child))))
+ (- (frame-rw (current-child)) (* 2 border-size))
+ (- (frame-rh (current-child)) (* 2 border-size))))
(t (values 0 0 10 10))))
-(defmacro with-current-child-coord ((x y w h) &body body)
+(defmacro with-current-child-coord ((border-size x y w h) &body body)
`(multiple-value-bind (,x ,y ,w ,h)
- (current-child-coord)
- , at body))
+ (current-child-coord ,border-size)
+ (let ((width (min w width))
+ (height (min h height)))
+ , at body)))
(defun top-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x 2)
- (+ y 2)
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x border-size) (+ y border-size) width height)))
(defun top-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (truncate (/ (- w width) 2)))
- (+ y 2)
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x (truncate (/ (- w width) 2)) border-size) (+ y border-size) width height)))
(defun top-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (- w width 2))
- (+ y 2)
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x (- w width) border-size) (+ y border-size) width height)))
(defun middle-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x 2)
- (+ y (truncate (/ (- h height) 2)))
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x border-size) (+ y (truncate (/ (- h height) 2)) border-size) width height)))
(defun middle-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (truncate (/ (- w width) 2)))
- (+ y (truncate (/ (- h height) 2)))
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x (truncate (/ (- w width) 2)) border-size)
+ (+ y (truncate (/ (- h height) 2)) border-size)
+ width height)))
(defun middle-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (- w width 2))
- (+ y (truncate (/ (- h height) 2)))
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x (- w width) border-size)
+ (+ y (truncate (/ (- h height) 2)) border-size)
+ width height)))
(defun bottom-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x 2)
- (+ y (- h height 2))
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x border-size) (+ y (- h height) border-size) width height)))
(defun bottom-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (truncate (/ (- w width) 2)))
- (+ y (- h height 2))
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x (truncate (/ (- w width) 2)) border-size) (+ y (- h height) border-size) width height)))
(defun bottom-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-child-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (- w width 2))
- (+ y (- h height 2))
- width height))))
+ (with-current-child-coord (border-size x y w h)
+ (values (+ x (- w width) border-size) (+ y (- h height) border-size) width height)))
;;;
@@ -223,93 +185,63 @@
(defparameter *get-current-root-fun* (lambda ()
(find-root (current-child))))
-(defun current-root-coord ()
+(defun current-root-coord (border-size)
(let ((root (funcall *get-current-root-fun*)))
(values (root-x root) (root-y root)
- (root-w root) (root-h root))))
-
+ (- (root-w root) (* 2 border-size))
+ (- (root-h root) (* 2 border-size)))))
-
-(defmacro with-current-root-coord ((x y w h) &body body)
+(defmacro with-current-root-coord ((border-size x y w h) &body body)
`(multiple-value-bind (,x ,y ,w ,h)
- (current-root-coord)
- , at body))
+ (current-root-coord ,border-size)
+ (let ((width (min w width))
+ (height (min h height)))
+ , at body)))
(defun top-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x border-size)
- (+ y border-size)
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values x y width height)))
(defun top-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (truncate (/ (- w width) 2)))
- (+ y border-size)
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values (+ x (truncate (/ (- w width) 2))) y width height)))
(defun top-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (- w width border-size))
- (+ y border-size)
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values (+ x (- w width)) y width height)))
(defun middle-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x border-size)
- (+ y (truncate (/ (- h height) 2)))
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values x (+ y (truncate (/ (- h height) 2))) width height)))
(defun middle-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (declare (ignore border-size))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (truncate (/ (- w width) 2)))
- (+ y (truncate (/ (- h height) 2)))
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values (+ x (truncate (/ (- w width) 2))) (+ y (truncate (/ (- h height) 2))) width height)))
(defun middle-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (- w width border-size))
- (+ y (truncate (/ (- h height) 2)))
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values (+ x (- w width)) (+ y (truncate (/ (- h height) 2))) width height)))
(defun bottom-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x border-size)
- (+ y (- h height border-size))
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values x (+ y (- h height)) width height)))
(defun bottom-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (truncate (/ (- w width) 2)))
- (+ y (- h height border-size))
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values (+ x (truncate (/ (- w width) 2))) (+ y (- h height)) width height)))
(defun bottom-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
- (with-current-root-coord (x y w h)
- (let ((width (min (- w 4) width))
- (height (min (- h 4) height)))
- (values (+ x (- w width border-size))
- (+ y (- h height border-size))
- width height))))
+ (with-current-root-coord (border-size x y w h)
+ (values (+ x (- w width)) (+ y (- h height)) width height)))
+
+
+;;;;; Some tests
+;;(defun test-some-placement (placement)
+;; (setf *second-mode-placement* placement
+;; *query-mode-placement* placement))
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index 9bbd8e8..d31aa88 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -213,6 +213,21 @@
(leave-second-mode))
+(defun ask-child-border-size (msg child)
+ (let ((size (query-number (format nil "New ~A border size: (last: ~A)"
+ msg
+ (child-border-size child))
+ (child-border-size child))))
+ (when (numberp size)
+ (setf (child-border-size child) size))))
+
+
+(defun set-current-child-border-size ()
+ "Set the current child border size"
+ (ask-child-border-size "child" (current-child))
+ (leave-second-mode))
+
+
(defun renumber-current-frame ()
"Renumber the current frame"
(when (frame-p (current-child))
@@ -711,8 +726,8 @@
(hide-all-children frame)
(with-slots (window) frame
(resize-window window orig-x orig-y #'display-frame-info (list frame))
- (setf (frame-w frame) (w-px->fl (x-drawable-width window) parent)
- (frame-h frame) (h-px->fl (x-drawable-height window) parent)))
+ (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) frame) parent)
+ (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) frame) parent)))
(show-all-children)))
diff --git a/src/config.lisp b/src/config.lisp
index 1db5f51..f93c9e6 100644
--- a/src/config.lisp
+++ b/src/config.lisp
@@ -63,8 +63,8 @@ A list of (list match-function handle-function)")
(defconfig *hide-unmanaged-window* t nil
"Hide or not unmanaged windows when a child is deselected.")
-(defconfig *snap-size* 20 nil
- "Snap size (in pixels) when move or resize frame is constrained")
+(defconfig *snap-size* 5 nil
+ "Snap size (in % of parent size) when move or resize frame is constrained")
(defconfig *spatial-move-delay-before* 0.2 nil
"Delay to display the current child before doing a spatial move")
diff --git a/src/menu-def.lisp b/src/menu-def.lisp
index 593038b..76bf799 100644
--- a/src/menu-def.lisp
+++ b/src/menu-def.lisp
@@ -79,6 +79,7 @@
(add-menu-key 'child-menu "r" 'rename-current-child)
(add-menu-key 'child-menu "t" 'set-current-child-transparency)
+(add-menu-key 'child-menu "b" 'set-current-child-border-size)
(add-menu-key 'child-menu "e" 'ensure-unique-name)
(add-menu-key 'child-menu "n" 'ensure-unique-number)
(add-menu-key 'child-menu "Delete" 'delete-current-child)
-----------------------------------------------------------------------
Summary of changes:
ChangeLog | 5 +
src/clfswm-internal.lisp | 75 +++++++++-----
src/clfswm-layout.lisp | 110 ++++++++++----------
src/clfswm-pack.lisp | 152 ++++++++++++++++-----------
src/clfswm-placement.lisp | 256 +++++++++++++++++----------------------------
src/clfswm-util.lisp | 19 +++-
src/config.lisp | 4 +-
src/menu-def.lisp | 1 +
8 files changed, 315 insertions(+), 307 deletions(-)
hooks/post-receive
--
CLFSWM - A(nother) Common Lisp FullScreen Window Manager
More information about the clfswm-cvs
mailing list