[clfswm-cvs] r332 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Sat Sep 25 21:39:26 UTC 2010
Author: pbrochard
Date: Sat Sep 25 17:39:26 2010
New Revision: 332
Log:
src/clfswm-expose-mode.lisp (expose-windows-mode, expose-all-windows-mode): Use a generic mode. src/clfswm-internal.lisp (child-position): New function.
Modified:
clfswm/ChangeLog
clfswm/clfswm.asd
clfswm/src/clfswm-expose-mode.lisp
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-keys.lisp
clfswm/src/clfswm-layout.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Sat Sep 25 17:39:26 2010
@@ -1,5 +1,12 @@
2010-09-25 Philippe Brochard <pbrochard at common-lisp.net>
+ * src/clfswm-layout.lisp (*-layout): Use child-position.
+
+ * src/clfswm-internal.lisp (child-position): New function.
+
+ * src/clfswm-expose-mode.lisp (expose-windows-mode)
+ (expose-all-windows-mode): Use a generic mode.
+
* src/xlib-util.lisp (with-handle-event-symbol): Use a filled list
with handle-event-fun symbols instead of inspecting clfswm
internals symbols on each mode change.
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Sat Sep 25 17:39:26 2010
@@ -47,7 +47,7 @@
:depends-on ("package" "clfswm" "clfswm-internal" "clfswm-generic-mode"
"clfswm-placement"))
(:file "clfswm-expose-mode"
- :depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools"))
+ :depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools" "clfswm-keys"))
(:file "clfswm-corner"
:depends-on ("package" "config" "clfswm-internal" "clfswm-expose-mode" "xlib-util"))
(:file "clfswm-info"
Modified: clfswm/src/clfswm-expose-mode.lisp
==============================================================================
--- clfswm/src/clfswm-expose-mode.lisp (original)
+++ clfswm/src/clfswm-expose-mode.lisp Sat Sep 25 17:39:26 2010
@@ -25,26 +25,94 @@
(in-package :clfswm)
-(defun expose-windows-generic (first-restore-frame func)
+(defun leave-expose-mode ()
+ "Leave the expose mode"
+ (throw 'exit-expose-loop nil))
+
+(defun valid-expose-mode ()
+ "Valid the expose mode"
+ (throw 'exit-expose-loop t))
+
+(defun mouse-leave-expose-mode (window root-x root-y)
+ "Leave the expose mode"
+ (declare (ignore window root-x root-y))
+ (throw 'exit-expose-loop nil))
+
+(defun mouse-valid-expose-mode (window root-x root-y)
+ "Valid the expose mode"
+ (declare (ignore window root-x root-y))
+ (throw 'exit-expose-loop t))
+
+
+(define-handler expose-mode :key-press (code state)
+ (funcall-key-from-code *expose-keys* code state))
+
+(define-handler expose-mode :button-press (code state window root-x root-y)
+ (funcall-button-from-code *expose-mouse* code state window root-x root-y *fun-press*))
+
+
+
+(add-hook *binding-hook* 'set-default-expose-keys)
+
+(defun set-default-expose-keys ()
+ (define-expose-key ("Escape") 'leave-expose-mode)
+ (define-expose-key ("g" :control) 'leave-expose-mode)
+ (define-expose-key ("Escape" :alt) 'leave-expose-mode)
+ (define-expose-key ("g" :control :alt) 'leave-expose-mode)
+ (define-expose-key ("Return") 'valid-expose-mode)
+ (define-expose-key ("space") 'valid-expose-mode)
+ (define-expose-key ("Tab") 'valid-expose-mode)
+ (define-expose-key ("Right") 'speed-mouse-right)
+ (define-expose-key ("Left") 'speed-mouse-left)
+ (define-expose-key ("Down") 'speed-mouse-down)
+ (define-expose-key ("Up") 'speed-mouse-up)
+ (define-expose-key ("Left" :control) 'speed-mouse-undo)
+ (define-expose-key ("Up" :control) 'speed-mouse-first-history)
+ (define-expose-key ("Down" :control) 'speed-mouse-reset)
+ (define-expose-mouse (1) 'mouse-valid-expose-mode)
+ (define-expose-mouse (2) 'mouse-leave-expose-mode)
+ (define-expose-mouse (3) 'mouse-leave-expose-mode))
+
+
+
+
+(defun expose-windows-generic (first-restore-frame body)
+ (xlib:warp-pointer *root* (truncate (/ (xlib:screen-width *screen*) 2))
+ (truncate (/ (xlib:screen-height *screen*) 2)))
(with-all-frames (first-restore-frame frame)
(setf (frame-data-slot frame :old-layout) (frame-layout frame)
(frame-layout frame) #'tile-space-layout))
(show-all-children *current-root*)
- (wait-no-key-or-button-press)
- (wait-a-key-or-button-press )
- (wait-no-key-or-button-press)
- (multiple-value-bind (x y) (xlib:query-pointer *root*)
- (let* ((child (find-child-under-mouse x y))
- (parent (find-parent-frame child *root-frame*)))
- (when (and child parent)
- (pfuncall func parent)
- (focus-all-children child parent))))
- (with-all-frames (first-restore-frame frame)
- (setf (frame-layout frame) (frame-data-slot frame :old-layout)
- (frame-data-slot frame :old-layout) nil))
- (show-all-children *current-root*)
+ (dbg 'ici)
+ (let ((grab-keyboard-p (xgrab-keyboard-p))
+ (grab-pointer-p (xgrab-pointer-p)))
+ (xgrab-pointer *root* 92 93)
+ (unless grab-keyboard-p
+ (ungrab-main-keys)
+ (xgrab-keyboard *root*))
+ (dbg 'ici-2)
+ (when (generic-mode 'expose-mode 'exit-expose-loop
+ :original-mode '(main-mode))
+ (dbg 'ici-3)
+ (multiple-value-bind (x y) (xlib:query-pointer *root*)
+ (let* ((child (find-child-under-mouse x y))
+ (parent (find-parent-frame child *root-frame*)))
+ (when (and child parent)
+ (pfuncall body parent)
+ (focus-all-children child parent)))))
+ (with-all-frames (first-restore-frame frame)
+ (setf (frame-layout frame) (frame-data-slot frame :old-layout)
+ (frame-data-slot frame :old-layout) nil))
+ (show-all-children *current-root*)
+ (unless grab-keyboard-p
+ (xungrab-keyboard)
+ (grab-main-keys))
+ (if grab-pointer-p
+ (xgrab-pointer *root* 66 67)
+ (xungrab-pointer)))
t)
+
(defun expose-windows-mode ()
"Present all windows in the current frame (An expose like)"
(stop-button-event)
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Sat Sep 25 17:39:26 2010
@@ -102,7 +102,7 @@
nil)
-(declaim (inline child-member child-remove))
+(declaim (inline child-member child-remove child-position))
(defun child-member (child list)
(member child list :test #'child-equal-p))
@@ -110,6 +110,8 @@
(defun child-remove (child list)
(remove child list :test #'child-equal-p))
+(defun child-position (child list)
+ (position child list :test #'child-equal-p))
Modified: clfswm/src/clfswm-keys.lisp
==============================================================================
--- clfswm/src/clfswm-keys.lisp (original)
+++ clfswm/src/clfswm-keys.lisp Sat Sep 25 17:39:26 2010
@@ -128,7 +128,7 @@
(define-define-mouse "main-mouse" *main-mouse*)
(define-define-mouse "second-mouse" *second-mouse*)
(define-define-mouse "info-mouse" *info-mouse*)
-(define-define-mouse "expose" *expose-mouse*)
+(define-define-mouse "expose-mouse" *expose-mouse*)
Modified: clfswm/src/clfswm-layout.lisp
==============================================================================
--- clfswm/src/clfswm-layout.lisp (original)
+++ clfswm/src/clfswm-layout.lisp Sat Sep 25 17:39:26 2010
@@ -208,7 +208,7 @@
(defmethod tile-layout (child parent)
(let* ((managed-children (update-layout-managed-children child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (length managed-children))
(n (ceiling (sqrt len)))
(dx (/ (frame-rw parent) n))
@@ -231,7 +231,7 @@
(defmethod tile-horizontal-layout (child parent)
(let* ((managed-children (update-layout-managed-children child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (length managed-children))
(n (ceiling (sqrt len)))
(dx (/ (frame-rw parent) (ceiling (/ len n))))
@@ -254,7 +254,7 @@
(defmethod one-column-layout (child parent)
(let* ((managed-children (update-layout-managed-children child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (length managed-children))
(dy (/ (frame-rh parent) len)))
(values (round (+ (frame-rx parent) 1))
@@ -274,7 +274,7 @@
(defmethod one-line-layout (child parent)
(let* ((managed-children (update-layout-managed-children child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (length managed-children))
(dx (/ (frame-rw parent) len)))
(values (round (+ (frame-rx parent) (* pos dx) 1))
@@ -296,13 +296,14 @@
"Tile Space: tile child in its frame leaving spaces between them"
(with-slots (rx ry rw rh) parent
(let* ((managed-children (get-managed-child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (length managed-children))
(n (ceiling (sqrt len)))
(dx (/ rw n))
(dy (/ rh (ceiling (/ len n))))
(size (or (frame-data-slot parent :tile-space-size) 0.1)))
(when (> size 0.5) (setf size 0.45))
+ (dbg pos len n dx dy size) ;; PHIL here
(values (round (+ rx (truncate (* (mod pos n) dx)) (* dx size) 1))
(round (+ ry (truncate (* (truncate (/ pos n)) dy)) (* dy size) 1))
(round (- dx (* dx size 2) 2))
@@ -332,7 +333,7 @@
"Tile Left: main child on left and others on right"
(with-slots (rx ry rw rh) parent
(let* ((managed-children (get-managed-child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (max (1- (length managed-children)) 1))
(dy (/ rh len))
(size (or (frame-data-slot parent :tile-size) 0.8)))
@@ -361,7 +362,7 @@
"Tile Right: main child on right and others on left"
(with-slots (rx ry rw rh) parent
(let* ((managed-children (get-managed-child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (max (1- (length managed-children)) 1))
(dy (/ rh len))
(size (or (frame-data-slot parent :tile-size) 0.8)))
@@ -393,7 +394,7 @@
"Tile Top: main child on top and others on bottom"
(with-slots (rx ry rw rh) parent
(let* ((managed-children (get-managed-child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (max (1- (length managed-children)) 1))
(dx (/ rw len))
(size (or (frame-data-slot parent :tile-size) 0.8)))
@@ -423,7 +424,7 @@
"Tile Bottom: main child on bottom and others on top"
(with-slots (rx ry rw rh) parent
(let* ((managed-children (get-managed-child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (max (1- (length managed-children)) 1))
(dx (/ rw len))
(size (or (frame-data-slot parent :tile-size) 0.8)))
@@ -469,7 +470,7 @@
"Tile Left Space: main child on left and others on right. Leave some space on the left."
(with-slots (rx ry rw rh) parent
(let* ((managed-children (get-managed-child parent))
- (pos (position child managed-children))
+ (pos (child-position child managed-children))
(len (max (1- (length managed-children)) 1))
(dy (/ rh len))
(size (or (frame-data-slot parent :tile-size) 0.8))
@@ -517,7 +518,7 @@
(no-layout child parent)
(if (child-member child main-windows)
(let* ((dy (/ rh len))
- (pos (position child main-windows)))
+ (pos (child-position child main-windows)))
(values (1+ (round (+ rx (* rw (- 1 size)))))
(1+ (round (+ ry (* dy pos))))
(- (round (* rw size)) 2)
@@ -545,7 +546,7 @@
(no-layout child parent)
(if (child-member child main-windows)
(let* ((dy (/ rh len))
- (pos (position child main-windows)))
+ (pos (child-position child main-windows)))
(values (1+ rx)
(1+ (round (+ ry (* dy pos))))
(- (round (* rw size)) 2)
@@ -572,7 +573,7 @@
(no-layout child parent)
(if (child-member child main-windows)
(let* ((dx (/ rw len))
- (pos (position child main-windows)))
+ (pos (child-position child main-windows)))
(values (1+ (round (+ rx (* dx pos))))
(1+ ry)
(- (round dx) 2)
@@ -599,7 +600,7 @@
(no-layout child parent)
(if (child-member child main-windows)
(let* ((dx (/ rw len))
- (pos (position child main-windows)))
+ (pos (child-position child main-windows)))
(values (1+ (round (+ rx (* dx pos))))
(1+ (round (+ ry (* rh (- 1 size)))))
(- (round dx) 2)
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Sat Sep 25 17:39:26 2010
@@ -1387,8 +1387,10 @@
(add-in-history (x y)
(push (list x y) history)))
(defun speed-mouse-reset ()
+ "Reset speed mouse coordinates"
(setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil))
(defun speed-mouse-left ()
+ "Speed move mouse to left"
(with-x-pointer
(reset-if-moved x y)
(setf maxx x)
@@ -1396,6 +1398,7 @@
(setf lx (middle (or minx 0) maxx))
(xlib:warp-pointer *root* lx y)))
(defun speed-mouse-right ()
+ "Speed move mouse to right"
(with-x-pointer
(reset-if-moved x y)
(setf minx x)
@@ -1403,6 +1406,7 @@
(setf lx (middle minx (or maxx (xlib:screen-width *screen*))))
(xlib:warp-pointer *root* lx y)))
(defun speed-mouse-up ()
+ "Speed move mouse to up"
(with-x-pointer
(reset-if-moved x y)
(setf maxy y)
@@ -1410,6 +1414,7 @@
(setf ly (middle (or miny 0) maxy))
(xlib:warp-pointer *root* x ly)))
(defun speed-mouse-down ()
+ "Speed move mouse to down"
(with-x-pointer
(reset-if-moved x y)
(setf miny y)
@@ -1417,6 +1422,7 @@
(setf ly (middle miny (or maxy (xlib:screen-height *screen*))))
(xlib:warp-pointer *root* x ly)))
(defun speed-mouse-undo ()
+ "Undo last speed mouse move"
(when history
(let ((h (pop history)))
(when h
@@ -1426,6 +1432,7 @@
miny nil maxy nil)
(xlib:warp-pointer *root* lx ly))))))
(defun speed-mouse-first-history ()
+ "Revert to the first speed move mouse"
(when history
(let ((h (first (last history))))
(when h
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Sat Sep 25 17:39:26 2010
@@ -120,8 +120,9 @@
(funcall function)))
(defun pfuncall (function &rest args)
- (when (or (functionp function)
- (and (symbolp function) (fboundp function)))
+ (when (and function
+ (or (functionp function)
+ (and (symbolp function) (fboundp function))))
(apply function args)))
More information about the clfswm-cvs
mailing list