From 037b2aac4d5f2205a7652dee599c7dee693aa0fe Mon Sep 17 00:00:00 2001 From: Philippe Brochard Date: Sat, 25 Sep 2010 23:41:11 +0200 Subject: [PATCH] src/clfswm-expose-mode.lisp (expose-windows-mode, expose-all-windows-mode): Use a generic mode. src/clfswm-internal.lisp (child-position): New function. --- ChangeLog | 7 ++++ clfswm.asd | 2 +- src/clfswm-expose-mode.lisp | 96 ++++++++++++++++++++++++++++++++++++++------- src/clfswm-internal.lisp | 4 +- src/clfswm-keys.lisp | 2 +- src/clfswm-layout.lisp | 29 +++++++------- src/clfswm-util.lisp | 7 ++++ src/tools.lisp | 5 ++- 8 files changed, 119 insertions(+), 33 deletions(-) diff --git a/ChangeLog b/ChangeLog index 40cb498..010b26a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,12 @@ 2010-09-25 Philippe Brochard + * 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. diff --git a/clfswm.asd b/clfswm.asd index cda725d..2406952 100644 --- a/clfswm.asd +++ b/clfswm.asd @@ -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" diff --git a/src/clfswm-expose-mode.lisp b/src/clfswm-expose-mode.lisp index ccfc231..cec179d 100644 --- a/src/clfswm-expose-mode.lisp +++ b/src/clfswm-expose-mode.lisp @@ -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) diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp index ff381a2..2e64d30 100644 --- a/src/clfswm-internal.lisp +++ b/src/clfswm-internal.lisp @@ -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)) diff --git a/src/clfswm-keys.lisp b/src/clfswm-keys.lisp index a83400e..1331175 100644 --- a/src/clfswm-keys.lisp +++ b/src/clfswm-keys.lisp @@ -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*) diff --git a/src/clfswm-layout.lisp b/src/clfswm-layout.lisp index 65f962c..2983bc7 100644 --- a/src/clfswm-layout.lisp +++ b/src/clfswm-layout.lisp @@ -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) diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp index 72b6299..975e069 100644 --- a/src/clfswm-util.lisp +++ b/src/clfswm-util.lisp @@ -1387,8 +1387,10 @@ For window: set current child to window or its parent according to window-parent (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 @@ For window: set current child to window or its parent according to window-parent (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 @@ For window: set current child to window or its parent according to window-parent (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 @@ For window: set current child to window or its parent according to window-parent (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 @@ For window: set current child to window or its parent according to window-parent (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 @@ For window: set current child to window or its parent according to window-parent 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 diff --git a/src/tools.lisp b/src/tools.lisp index 2e7ace8..087fae1 100644 --- a/src/tools.lisp +++ b/src/tools.lisp @@ -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))) -- 2.11.4.GIT