[clfswm-cvs] r450 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Fri May 6 20:13:20 UTC 2011
Author: pbrochard
Date: Fri May 6 16:13:19 2011
New Revision: 450
Log:
src/clfswm-circulate-mode.lisp (select-brother-generic-spatial-move+right/left/up/down): New function to select a brother from another in a spatial move.
Modified:
clfswm/ChangeLog
clfswm/src/bindings.lisp
clfswm/src/clfswm-circulate-mode.lisp
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/config.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Fri May 6 16:13:19 2011
@@ -1,3 +1,9 @@
+2011-05-06 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-circulate-mode.lisp
+ (select-brother-generic-spatial-move+right/left/up/down): New
+ function to select a brother from another in a spatial move.
+
2011-04-19 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-pack.lisp (move-frame-constrained)
Modified: clfswm/src/bindings.lisp
==============================================================================
--- clfswm/src/bindings.lisp (original)
+++ clfswm/src/bindings.lisp Fri May 6 16:13:19 2011
@@ -47,6 +47,10 @@
(define-main-key ("Left" :mod-1) 'select-previous-brother)
(define-main-key ("Down" :mod-1) 'select-previous-level)
(define-main-key ("Up" :mod-1) 'select-next-level)
+ (define-main-key ("Left" :control :mod-1) 'select-brother-spatial-move-left)
+ (define-main-key ("Right" :control :mod-1) 'select-brother-spatial-move-right)
+ (define-main-key ("Up" :control :mod-1) 'select-brother-spatial-move-up)
+ (define-main-key ("Down" :control :mod-1) 'select-brother-spatial-move-down)
(define-main-key ("Tab" :mod-1) 'select-next-child)
(define-main-key ("Tab" :mod-1 :shift) 'select-previous-child)
(define-main-key ("Tab" :mod-1 :control) 'select-next-subchild)
Modified: clfswm/src/clfswm-circulate-mode.lisp
==============================================================================
--- clfswm/src/clfswm-circulate-mode.lisp (original)
+++ clfswm/src/clfswm-circulate-mode.lisp Fri May 6 16:13:19 2011
@@ -62,7 +62,8 @@
*circulate-orig* (frame-child *current-child*)))
(defun reset-circulate-brother ()
- (setf *circulate-parent* (find-parent-frame *current-child*))
+ (setf *circulate-parent* (find-parent-frame *current-child*)
+ *circulate-hit* 0)
(when (frame-p *circulate-parent*)
(setf *circulate-orig* (frame-child *circulate-parent*))))
@@ -70,13 +71,14 @@
(defun reorder-child (direction)
(no-focus)
- (with-slots (child) *current-child*
+ (with-slots (child selected-pos) *current-child*
(unless *circulate-orig*
(reset-circulate-child))
(let ((len (length *circulate-orig*)))
(when (plusp len)
(let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*)))
- (setf child (cons elem (child-remove elem *circulate-orig*)))))
+ (setf child (cons elem (child-remove elem *circulate-orig*))
+ selected-pos 0)))
(show-all-children)
(draw-circulate-mode-window))))
@@ -93,6 +95,7 @@
(when (frame-p *circulate-parent*)
(let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*)))
(setf (frame-child *circulate-parent*) (cons elem (child-remove elem *circulate-orig*))
+ (frame-selected-pos *circulate-parent*) 0
*current-child* (frame-selected-child *circulate-parent*))))
(when frame-is-root?
(setf *current-root* *current-child*))))
@@ -105,10 +108,12 @@
(let ((selected-child (frame-selected-child *current-child*)))
(when (frame-p selected-child)
(no-focus)
- (with-slots (child) selected-child
+ (with-slots (child selected-pos) selected-child
(let ((elem (first (last child))))
- (setf child (cons elem (child-remove elem child)))
- (show-all-children)
+ (when elem
+ (setf child (cons elem (child-remove elem child))
+ selected-pos 0))
+ (show-all-children)
(draw-circulate-mode-window)))))))
@@ -306,3 +311,71 @@
(defun select-previous-brother-simple ()
"Select the previous brother frame (do not enter in circulate mode)"
(reorder-brother-simple #'anti-rotate-list))
+
+
+
+;;; Spatial move functions
+(defun select-brother-generic-spatial-move (fun-found)
+ "Select the nearest brother of the current child based on the fun-found function"
+ (let ((is-root? (child-equal-p *current-child* *current-root*)))
+ (when is-root?
+ (leave-frame)
+ (sleep *spatial-move-delay-before*))
+ (no-focus)
+ (select-current-frame nil)
+ (let ((parent-frame (find-parent-frame *current-child*)))
+ (when (frame-p parent-frame)
+ (with-slots (child selected-pos) parent-frame
+ (let ((found nil)
+ (found-dist nil))
+ (dolist (c child)
+ (let ((dist (funcall fun-found *current-child* c)))
+ (when (and dist
+ (not (child-equal-p *current-child* c))
+ (or (not found)
+ (and found-dist (< dist found-dist))))
+ (setf found c
+ found-dist dist))))
+ (when found
+ (setf *current-child* found
+ selected-pos 0
+ child (cons found (child-remove found child)))))))
+ (show-all-children t)
+ (when is-root?
+ (sleep *spatial-move-delay-after*)
+ (enter-frame)))))
+
+
+
+(defun select-brother-spatial-move-right ()
+ "Select spatially the nearest brother of the current child in the right direction"
+ (select-brother-generic-spatial-move #'(lambda (current child)
+ (when (> (child-x2 child) (child-x2 current))
+ (distance (child-x2 current) (middle-child-y current)
+ (child-x child) (middle-child-y child))))))
+
+
+
+(defun select-brother-spatial-move-left ()
+ "Select spatially the nearest brother of the current child in the left direction"
+ (select-brother-generic-spatial-move #'(lambda (current child)
+ (when (< (child-x child) (child-x current))
+ (distance (child-x current) (middle-child-y current)
+ (child-x2 child) (middle-child-y child))))))
+
+
+(defun select-brother-spatial-move-down ()
+ "Select spatially the nearest brother of the current child in the down direction"
+ (select-brother-generic-spatial-move #'(lambda (current child)
+ (when (> (child-y2 child) (child-y2 current))
+ (distance (middle-child-x current) (child-y2 current)
+ (middle-child-x child) (child-y child))))))
+
+
+(defun select-brother-spatial-move-up ()
+ "Select spatially the nearest brother of the current child in the up direction"
+ (select-brother-generic-spatial-move #'(lambda (current child)
+ (when (< (child-y child) (child-y current))
+ (distance (middle-child-x current) (child-y current)
+ (middle-child-x child) (child-y2 child))))))
+
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Fri May 6 16:13:19 2011
@@ -252,6 +252,46 @@
(defmethod child-height ((child frame))
(frame-rh child))
+(defgeneric child-x2 (child))
+(defmethod child-x2 ((child xlib:window))
+ (+ (xlib:drawable-x child) (xlib:drawable-width child)))
+(defmethod child-x2 ((child frame))
+ (+ (frame-rx child) (frame-rw child)))
+
+(defgeneric child-y2 (child))
+(defmethod child-y2 ((child xlib:window))
+ (+ (xlib:drawable-y child) (xlib:drawable-height child)))
+(defmethod child-y2 ((child frame))
+ (+ (frame-ry child) (frame-rh child)))
+
+
+
+(defgeneric child-center (child))
+
+(defmethod child-center ((child xlib:window))
+ (values (+ (xlib:drawable-x child) (/ (xlib:drawable-width child) 2))
+ (+ (xlib:drawable-y child) (/ (xlib:drawable-height child) 2))))
+
+(defmethod child-center ((child frame))
+ (values (+ (frame-rx child) (/ (frame-rw child) 2))
+ (+ (frame-ry child) (/ (frame-rh child) 2))))
+
+(defun child-distance (child1 child2)
+ (multiple-value-bind (x1 y1) (child-center child1)
+ (multiple-value-bind (x2 y2) (child-center child2)
+ (values (+ (abs (- x2 x1)) (abs (- y2 y1)))
+ (- x2 x1)
+ (- y2 y1)))))
+
+(defun middle-child-x (child)
+ (+ (child-x child) (/ (child-width child) 2)))
+
+(defun middle-child-y (child)
+ (+ (child-y child) (/ (child-height child) 2)))
+
+
+
+
@@ -404,6 +444,7 @@
h (h-px->fl prh parent))
(xlib:display-finish-output *display*))))
+(warn "fixe-real-size: adjust border here")
(defun fixe-real-size (frame parent)
"Fixe real (pixel) coordinates in float coordinates"
(when (frame-p frame)
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Fri May 6 16:13:19 2011
@@ -1565,4 +1565,3 @@
(show-all-children t))
(funcall run-fn))))
-
Modified: clfswm/src/config.lisp
==============================================================================
--- clfswm/src/config.lisp (original)
+++ clfswm/src/config.lisp Fri May 6 16:13:19 2011
@@ -56,6 +56,12 @@
(defconfig *snap-size* 20 nil
"Snap size (in pixels) when move or resize frame is constrained")
+(defconfig *spatial-move-delay-before* 0.2 nil
+ "Delay to wait before doing a spatial move")
+
+(defconfig *spatial-move-delay-after* 0.5 nil
+ "Delay to wait after doing a spatial move")
+
;;; CONFIG - Screen size
(defun get-fullscreen-size ()
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Fri May 6 16:13:19 2011
@@ -54,6 +54,7 @@
:dbg
:dbgnl
:dbgc
+ :distance
:with-all-internal-symbols
:export-all-functions :export-all-variables
:export-all-functions-and-variables
@@ -101,6 +102,7 @@
:exchange-one-in-list
:rotate-list
:anti-rotate-list
+ :n-rotate-list
:append-formated-list
:shuffle-list
:parse-integer-in-list
@@ -360,6 +362,9 @@
(force-output))
+(defun distance (x1 y1 x2 y2)
+ (+ (abs (- x2 x1)) (abs (- y2 y1))))
+
;;; Symbols tools
(defmacro with-all-internal-symbols ((var package) &body body)
@@ -861,6 +866,11 @@
(when list
(append (last list) (butlast list))))
+(defun n-rotate-list (list n)
+ (if (> n 0)
+ (n-rotate-list (rotate-list list) (1- n))
+ list))
+
(defun append-formated-list (base-str
lst
More information about the clfswm-cvs
mailing list