[clfswm-cvs] r66 - in clfswm: . src
pbrochard at common-lisp.net
pbrochard at common-lisp.net
Wed Apr 2 22:06:15 UTC 2008
Author: pbrochard
Date: Wed Apr 2 17:06:10 2008
New Revision: 66
Modified:
clfswm/ChangeLog
clfswm/src/bindings-second-mode.lisp
clfswm/src/bindings.lisp
clfswm/src/clfswm-info.lisp
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/clfswm.lisp
clfswm/src/tools.lisp
clfswm/src/xlib-util.lisp
Log:
bind-or-jump: New (great) function.
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Wed Apr 2 17:06:10 2008
@@ -1,5 +1,27 @@
+2008-04-03 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-util.lisp (bind-or-jump): New (great) function.
+
2008-04-02 Philippe Brochard <pbrochard at common-lisp.net>
+ * src/clfswm-internal.lisp (child-fullname): New function
+
+ * src/clfswm-info.lisp (info-mode-menu): Add an explicit optional
+ docstring in info-mode-menu. An item can be
+ '((key function) (key function)) or with docstring
+ '((key function "documentation 1") (key function "bla bla") (key function))
+
+ * src/tools.lisp (ensure-n-elems): New function.
+
+ * src/bindings-second-mode.lisp: Bind Alt+mouse-1/3 to move or
+ resize a frame or the window's father.
+
+ * src/clfswm.lisp (init-display): Remove tile-space-layout by
+ default on the root frame.
+
+ * src/clfswm-util.lisp (move/resize-frame): Add standard event
+ hooks handlers (map-request, configure-notify...)
+
* src/clfswm-internal.lisp (adapt-child-to-father): Limit minimal
child size to 1x1.
Modified: clfswm/src/bindings-second-mode.lisp
==============================================================================
--- clfswm/src/bindings-second-mode.lisp (original)
+++ clfswm/src/bindings-second-mode.lisp Wed Apr 2 17:06:10 2008
@@ -404,6 +404,9 @@
(define-second-mouse (1) 'sm-mouse-click-to-focus-and-move)
(define-second-mouse (3) 'sm-mouse-click-to-focus-and-resize)
+(define-second-mouse (1 :mod-1) 'mouse-click-to-focus-and-move-window)
+(define-second-mouse (3 :mod-1) 'mouse-click-to-focus-and-resize-window)
+
(define-second-mouse (4) 'sm-mouse-select-next-level)
(define-second-mouse (5) 'sm-mouse-select-previous-level)
Modified: clfswm/src/bindings.lisp
==============================================================================
--- clfswm/src/bindings.lisp (original)
+++ clfswm/src/bindings.lisp Wed Apr 2 17:06:10 2008
@@ -78,6 +78,35 @@
+;;; Bind or jump functions
+(define-main-key ("1" :mod-1) 'bind-or-jump-1)
+(define-main-key ("2" :mod-1) 'bind-or-jump-2)
+(define-main-key ("3" :mod-1) 'bind-or-jump-3)
+(define-main-key ("4" :mod-1) 'bind-or-jump-4)
+(define-main-key ("5" :mod-1) 'bind-or-jump-5)
+(define-main-key ("6" :mod-1) 'bind-or-jump-6)
+(define-main-key ("7" :mod-1) 'bind-or-jump-7)
+(define-main-key ("8" :mod-1) 'bind-or-jump-8)
+(define-main-key ("9" :mod-1) 'bind-or-jump-9)
+(define-main-key ("0" :mod-1) 'bind-or-jump-10)
+
+
+;; For an azery keyboard:
+;;(define-main-key ("ampersand" :mod-1) 'bind-or-jump-1)
+;;(define-main-key ("eacute" :mod-1) 'bind-or-jump-2)
+;;(define-main-key ("quotedbl" :mod-1) 'bind-or-jump-3)
+;;(define-main-key ("quoteright" :mod-1) 'bind-or-jump-4)
+;;(define-main-key ("parenleft" :mod-1) 'bind-or-jump-5)
+;;(define-main-key ("minus" :mod-1) 'bind-or-jump-6)
+;;(define-main-key ("egrave" :mod-1) 'bind-or-jump-7)
+;;(define-main-key ("underscore" :mod-1) 'bind-or-jump-8)
+;;(define-main-key ("ccedilla" :mod-1) 'bind-or-jump-9)
+;;(define-main-key ("agrave" :mod-1) 'bind-or-jump-10)
+
+
+
+
+
;;; Mouse actions
(defun mouse-click-to-focus-and-move-window (window root-x root-y)
"Move and focus the current child - Create a new frame on the root window"
Modified: clfswm/src/clfswm-info.lisp
==============================================================================
--- clfswm/src/clfswm-info.lisp (original)
+++ clfswm/src/clfswm-info.lisp Wed Apr 2 17:06:10 2008
@@ -294,12 +294,14 @@
(defun info-mode-menu (item-list &key (x 0) (y 0) (width nil) (height nil))
"Open an info help menu.
Item-list is: '((key function) (key function))
+or with explicit docstring: '((key function \"documentation 1\") (key function \"bla bla\") (key function))
key is a character, a keycode or a keysym"
(let ((info-list nil)
(action nil))
(dolist (item item-list)
- (destructuring-bind (key function) item
- (push (format nil "~A: ~A" key (documentation function 'function))
+ (destructuring-bind (key function explicit-doc) (ensure-n-elems item 3)
+ (push (format nil "~@(~A~): ~A" key (or explicit-doc
+ (documentation function 'function)))
info-list)
(define-info-key-fun (list key 0)
(lambda (&optional args)
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Wed Apr 2 17:06:10 2008
@@ -111,6 +111,22 @@
"???")
+(defgeneric child-fullname (child))
+
+(defmethod child-fullname ((child xlib:window))
+ (format nil "~A (~A)" (xlib:wm-name child) (xlib:get-wm-class child)))
+
+(defmethod child-fullname ((child frame))
+ (aif (frame-name child)
+ (format nil "~A (Frame ~A)" it (frame-number child))
+ (format nil "Frame ~A" (frame-number child))))
+
+(defmethod child-fullname (child)
+ (declare (ignore child))
+ "???")
+
+
+
(defgeneric rename-child (child name))
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Wed Apr 2 17:06:10 2008
@@ -505,7 +505,17 @@
(handle-event (&rest event-slots &key event-key &allow-other-keys)
(case event-key
(:motion-notify (apply #'motion-notify event-slots))
- (:button-release (setf done t)))
+ (:button-release (setf done t))
+ (:configure-request (call-hook *configure-request-hook* event-slots))
+ (:configure-notify (call-hook *configure-notify-hook* event-slots))
+ (:map-request (call-hook *map-request-hook* event-slots))
+ (:unmap-notify (call-hook *unmap-notify-hook* event-slots))
+ (:destroy-notify (call-hook *destroy-notify-hook* event-slots))
+ (:mapping-notify (call-hook *mapping-notify-hook* event-slots))
+ (:property-notify (call-hook *property-notify-hook* event-slots))
+ (:create-notify (call-hook *create-notify-hook* event-slots))
+ (:enter-notify (call-hook *enter-notify-hook* event-slots))
+ (:exposure (call-hook *exposure-hook* event-slots)))
t))
(when frame
(loop until done
@@ -537,7 +547,17 @@
(handle-event (&rest event-slots &key event-key &allow-other-keys)
(case event-key
(:motion-notify (apply #'motion-notify event-slots))
- (:button-release (setf done t)))
+ (:button-release (setf done t))
+ (:configure-request (call-hook *configure-request-hook* event-slots))
+ (:configure-notify (call-hook *configure-notify-hook* event-slots))
+ (:map-request (call-hook *map-request-hook* event-slots))
+ (:unmap-notify (call-hook *unmap-notify-hook* event-slots))
+ (:destroy-notify (call-hook *destroy-notify-hook* event-slots))
+ (:mapping-notify (call-hook *mapping-notify-hook* event-slots))
+ (:property-notify (call-hook *property-notify-hook* event-slots))
+ (:create-notify (call-hook *create-notify-hook* event-slots))
+ (:enter-notify (call-hook *enter-notify-hook* event-slots))
+ (:exposure (call-hook *exposure-hook* event-slots)))
t))
(when frame
(loop until done
@@ -676,3 +696,49 @@
(produce-doc-html-in-file tempfile))
(sleep 1)
(do-shell (format nil "~A ~A" browser tempfile)))
+
+
+
+;;; Bind or jump functions
+(let ((key-slots (make-array 10 :initial-element nil))
+ (current-slot 0))
+ (defun bind-on-slot ()
+ "Bind current child to slot"
+ (setf (aref key-slots current-slot) *current-child*))
+
+ (defun remove-binding-on-slot ()
+ "Remove binding on slot"
+ (setf (aref key-slots current-slot) nil))
+
+ (defun jump-to-slot ()
+ "Jump to slot"
+ (hide-all *current-root*)
+ (setf *current-root* (aref key-slots current-slot)
+ *current-child* *current-root*)
+ (focus-all-children *current-child* *current-child*)
+ (show-all-children))
+
+ (defun bind-or-jump (n)
+ (let ((default-bind `("Return" bind-on-slot
+ ,(format nil "Bind slot ~A on child: ~A" n (child-fullname *current-child*)))))
+ (setf current-slot (- n 1))
+ (info-mode-menu (aif (aref key-slots current-slot)
+ `(,default-bind
+ ("BackSpace" remove-binding-on-slot
+ ,(format nil "Remove slot ~A binding on child: ~A" n (child-fullname *current-child*)))
+ (" - " nil " -")
+ ("Tab" jump-to-slot
+ ,(format nil "Jump to child: ~A" (aif (aref key-slots current-slot)
+ (child-fullname it)
+ "Not set - Please, bind it with Return"))))
+ (list default-bind))))))
+
+(defmacro def-bind-or-jump ()
+ `(progn
+ ,@(loop for i from 1 to 10
+ collect `(defun ,(intern (format nil "BIND-OR-JUMP-~A" i)) ()
+ ,(format nil "Bind or jump to the child on slot ~A" i)
+ (bind-or-jump ,i)))))
+
+
+(def-bind-or-jump)
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Wed Apr 2 17:06:10 2008
@@ -219,10 +219,10 @@
(netwm-set-properties)
(xlib:display-force-output *display*)
(setf *child-selection* nil)
- (setf *root-frame* (create-frame :name "Root" :number 0 :layout #'tile-space-layout)
+ (setf *root-frame* (create-frame :name "Root" :number 0) ;; :layout #'tile-space-layout)
*current-root* *root-frame*
*current-child* *current-root*)
- (add-frame (create-frame :name "Default" :layout nil :x 0.1 :y 0.1 :w 0.8 :h 0.8) *root-frame*)
+ (add-frame (create-frame :name "Default" :layout nil :x 0.05 :y 0.05 :w 0.9 :h 0.9) *root-frame*)
(setf *current-child* (first (frame-child *current-root*)))
(call-hook *init-hook*)
(process-existing-windows *screen*)
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Wed Apr 2 17:06:10 2008
@@ -40,6 +40,7 @@
:expand-newline
:ensure-list
:ensure-printable
+ :ensure-n-elems
:find-assoc-word
:print-space
:escape-string
@@ -200,6 +201,15 @@
(substitute-if-not new #'standard-char-p string))
+(defun ensure-n-elems (list n)
+ "Ensure that list has exactly n elements"
+ (let ((length (length list)))
+ (cond ((= length n) list)
+ ((< length n) (ensure-n-elems (append list '(nil)) n))
+ ((> length n) (ensure-n-elems (butlast list) n)))))
+
+
+
(defun find-assoc-word (word line &optional (delim #\"))
Modified: clfswm/src/xlib-util.lisp
==============================================================================
--- clfswm/src/xlib-util.lisp (original)
+++ clfswm/src/xlib-util.lisp Wed Apr 2 17:06:10 2008
@@ -70,7 +70,8 @@
(progn
, at body)
((or xlib:match-error xlib:window-error xlib:drawable-error) (c)
- (dbg c ',body))))
+ (declare (ignore c)))))
+ ;;(dbg c ',body))))
More information about the clfswm-cvs
mailing list