From pbrochard at common-lisp.net Fri Oct 1 21:46:37 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 01 Oct 2010 17:46:37 -0400 Subject: [clfswm-cvs] r340 - in clfswm: . src Message-ID: Author: pbrochard Date: Fri Oct 1 17:46:37 2010 New Revision: 340 Log: src/clfswm-nw-hooks.lisp (absorb-window-nw-hook): Absorb new window hook: the frame absorb all new windows that match nw-absorb-test frame data slot. Modified: clfswm/ChangeLog clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-nw-hooks.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Fri Oct 1 17:46:37 2010 @@ -1,3 +1,9 @@ +2010-10-01 Philippe Brochard + + * src/clfswm-nw-hooks.lisp (absorb-window-nw-hook): Absorb new + window hook: the frame absorb all new windows that match + nw-absorb-test frame data slot. + 2010-09-30 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-create-window): Show window Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Fri Oct 1 17:46:37 2010 @@ -969,12 +969,12 @@ (defun do-all-frames-nw-hook (window) "Call nw-hook of each frame." - (let ((found nil)) - (with-all-frames (*root-frame* frame) - (awhen (frame-nw-hook frame) - (call-hook it (list frame window)) - (setf found t))) - found)) + (catch 'nw-hook-loop + (let ((found nil)) + (with-all-frames (*root-frame* frame) + (awhen (frame-nw-hook frame) + (setf found (call-hook it (list frame window))))) + found))) @@ -1005,6 +1005,7 @@ (defun process-existing-windows (screen) "Windows present when clfswm starts up must be absorbed by clfswm." + (setf *in-process-existing-windows* t) (let ((id-list nil) (all-windows (get-all-windows))) (dolist (win (xlib:query-tree (xlib:screen-root screen))) @@ -1021,4 +1022,5 @@ (map-window win) (raise-window win) (pushnew (xlib:window-id win) id-list)))))) - (netwm-set-client-list id-list))) + (netwm-set-client-list id-list)) + (setf *in-process-existing-windows* nil)) Modified: clfswm/src/clfswm-nw-hooks.lisp ============================================================================== --- clfswm/src/clfswm-nw-hooks.lisp (original) +++ clfswm/src/clfswm-nw-hooks.lisp Fri Oct 1 17:46:37 2010 @@ -82,7 +82,8 @@ (leave-if-not-frame *current-child*) (when (frame-p *current-child*) (pushnew window (frame-child *current-child*))) - (default-window-placement *current-child* window)) + (default-window-placement *current-child* window) + t) (defun set-default-frame-nw-hook () "Open the next window in the current frame" @@ -98,7 +99,8 @@ (leave-if-not-frame *current-root*) (pushnew window (frame-child *current-root*)) (setf *current-child* (frame-selected-child *current-root*)) - (default-window-placement *current-root* window)) + (default-window-placement *current-root* window) + t) (defun set-open-in-current-root-nw-hook () "Open the next window in the current root" @@ -116,7 +118,8 @@ (pushnew new-frame (frame-child *current-root*)) (pushnew window (frame-child new-frame)) (setf *current-child* new-frame) - (default-window-placement new-frame window))) + (default-window-placement new-frame window)) + t) (defun set-open-in-new-frame-in-current-root-nw-hook () "Open the next window in a new frame in the current root" @@ -136,7 +139,8 @@ (setf *current-child* *current-root*) (set-layout-once #'tile-space-layout) (setf *current-child* new-frame) - (default-window-placement new-frame window))) + (default-window-placement new-frame window)) + t) (defun set-open-in-new-frame-in-root-frame-nw-hook () "Open the next window in a new frame in the root frame" @@ -160,7 +164,8 @@ (set-layout-once #'tile-space-layout) (setf *current-child* new-frame) (default-window-placement new-frame window) - (show-all-children *current-root*)))) + (show-all-children *current-root*) + t))) (defun set-open-in-new-frame-in-parent-frame-nw-hook () @@ -180,7 +185,8 @@ (with-slots (child) *current-child* (pushnew window child) (setf child (rotate-list child)))) - (default-window-placement *current-child* window)) + (default-window-placement *current-child* window) + t) (defun set-leave-focus-frame-nw-hook () "Open the next window in the current frame and leave the focus on the current child" @@ -201,14 +207,16 @@ (setf *current-child* frame) (focus-all-children window frame) (default-window-placement frame window) - (show-all-children *current-root*))) + (show-all-children *current-root*) + t)) ;;; Open a new window in a named frame (defun named-frame-nw-hook (frame window) (clear-nw-hook frame) (let* ((frame-name (ask-frame-name "Open the next window in frame named:")) (new-frame (find-frame-by-name frame-name))) - (nw-hook-open-in-frame window new-frame))) + (nw-hook-open-in-frame window new-frame)) + t) (defun set-named-frame-nw-hook () "Open the next window in a named frame" @@ -221,7 +229,8 @@ (defun numbered-frame-nw-hook (frame window) (clear-nw-hook frame) (let ((new-frame (find-frame-by-number (query-number "Open a new frame in the group numbered:")))) - (nw-hook-open-in-frame window new-frame))) + (nw-hook-open-in-frame window new-frame)) + t) (defun set-numbered-frame-nw-hook () "Open the next window in a numbered frame" @@ -229,3 +238,35 @@ (register-nw-hook 'set-numbered-frame-nw-hook) + +;;; Absorb window. +;;; The frame absorb the new window if it match the absorb-nw-test +;;; frame data slot. +(defun absorb-window-nw-hook (frame window) + (let ((absorb-nw-test (frame-data-slot frame :nw-absorb-test))) + (when (and absorb-nw-test + (funcall absorb-nw-test window)) + (pushnew window (frame-child frame)) + (unless *in-process-existing-windows* + (unless (find-child frame *current-root*) + (hide-all *current-root*) + (setf *current-root* frame)) + (setf *current-child* frame) + (focus-all-children window frame) + (default-window-placement frame window) + (show-all-children *current-root*)) + (throw 'nw-hook-loop t))) + nil) + +(defun set-absorb-window-nw-hook () + "Open the window in this frame if it match absorb-nw-test" + (set-nw-hook #'absorb-window-nw-hook)) + +(register-nw-hook 'set-absorb-window-nw-hook) + + +(defun nw-absorb-test-class (class-string) + (lambda (c) + (and (xlib:window-p c) + (string-equal (xlib:get-wm-class c) class-string)))) + Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Fri Oct 1 17:46:37 2010 @@ -211,6 +211,7 @@ +(defparameter *in-process-existing-windows* nil) ;; For debug - redefine defun ;;(shadow :defun) From pbrochard at common-lisp.net Sat Oct 2 15:56:54 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 02 Oct 2010 11:56:54 -0400 Subject: [clfswm-cvs] r341 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 2 11:56:54 2010 New Revision: 341 Log: src/clfswm-util.lisp (bind-on-slot): Add an optional parameter to bind the current child from the configuration file. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 2 11:56:54 2010 @@ -1,3 +1,8 @@ +2010-10-02 Philippe Brochard + + * src/clfswm-util.lisp (bind-on-slot): Add an optional parameter + to bind the current child from the configuration file. + 2010-10-01 Philippe Brochard * src/clfswm-nw-hooks.lisp (absorb-window-nw-hook): Absorb new Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Oct 2 11:56:54 2010 @@ -693,9 +693,9 @@ ;;; Bind or jump functions (let ((key-slots (make-array 10 :initial-element nil)) (current-slot 1)) - (defun bind-on-slot () + (defun bind-on-slot (&optional (slot current-slot)) "Bind current child to slot" - (setf (aref key-slots current-slot) *current-child*)) + (setf (aref key-slots slot) *current-child*)) (defun remove-binding-on-slot () "Remove binding on slot" From pbrochard at common-lisp.net Sat Oct 2 21:51:31 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 02 Oct 2010 17:51:31 -0400 Subject: [clfswm-cvs] r342 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 2 17:51:31 2010 New Revision: 342 Log: src/clfswm-circulate-mode.lisp (select-next-subchild): Add the possibility to circulate over subchild of the current child. Modified: clfswm/ChangeLog clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-expose-mode.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 2 17:51:31 2010 @@ -1,5 +1,12 @@ 2010-10-02 Philippe Brochard + * src/clfswm-circulate-mode.lisp (select-next-subchild): Add the + possibility to circulate over subchild of the current child. + + * src/clfswm-expose-mode.lisp (expose-all-windows-mode) + (expose-windows-generic): Add an escape-body function to return to + the original state on escape key. + * src/clfswm-util.lisp (bind-on-slot): Add an optional parameter to bind the current child from the configuration file. Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Sat Oct 2 17:51:31 2010 @@ -115,7 +115,8 @@ (define-second-key ("Tab" :mod-1) 'select-next-child) (define-second-key ("Tab" :mod-1 :shift) 'select-previous-child) - (define-second-key (#\Tab :shift) 'switch-to-last-child) + (define-second-key ("Tab" :mod-1 :control) 'select-next-subchild) + (define-second-key ("Tab" :shift) 'switch-to-last-child) (define-second-key ("Return" :mod-1) 'enter-frame) (define-second-key ("Return" :mod-1 :shift) 'leave-frame) (define-second-key ("Return" :mod-5) 'frame-toggle-maximize) Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Sat Oct 2 17:51:31 2010 @@ -50,6 +50,7 @@ (define-main-key ("Up" :mod-1) 'select-next-level) (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) (define-main-key ("Tab" :shift) 'switch-to-last-child) (define-main-key ("Return" :mod-1) 'enter-frame) (define-main-key ("Return" :mod-1 :shift) 'leave-frame) Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Sat Oct 2 17:51:31 2010 @@ -103,6 +103,18 @@ (find-parent-frame *current-child*))) (draw-circulate-mode-window))) +(defun reorder-subchild (direction) + (declare (ignore direction)) + (when (frame-p *current-child*) + (let ((selected-child (frame-selected-child *current-child*))) + (when (frame-p selected-child) + (no-focus) + (with-slots (child) selected-child + (let ((elem (first (last child)))) + (setf child (nconc (list elem) (child-remove elem child))) + (show-all-children) + (draw-circulate-mode-window))))))) + @@ -134,6 +146,10 @@ (reset-circulate-brother)) (reorder-brother -1)) +(defun circulate-select-next-subchild () + "Select the next subchild" + (reorder-subchild +1)) + (add-hook *binding-hook* 'set-default-circulate-keys) @@ -144,11 +160,13 @@ (define-circulate-key ("Escape" :alt) 'leave-circulate-mode) (define-circulate-key ("g" :control :alt) 'leave-circulate-mode) (define-circulate-key ("Tab" :mod-1) 'circulate-select-next-child) + (define-circulate-key ("Tab" :mod-1 :control) 'circulate-select-next-subchild) (define-circulate-key ("Tab" :mod-1 :shift) 'circulate-select-previous-child) (define-circulate-key ("Iso_Left_Tab" :mod-1 :shift) 'circulate-select-previous-child) (define-circulate-key ("Right" :mod-1) 'circulate-select-next-brother) (define-circulate-key ("Left" :mod-1) 'circulate-select-previous-brother) - (define-circulate-release-key ("Alt_L" :alt) 'leave-circulate-mode)) + (define-circulate-release-key ("Alt_L" :alt) 'leave-circulate-mode) + (define-circulate-release-key ("Alt_L") 'leave-circulate-mode)) (defun circulate-leave-function () @@ -180,7 +198,7 @@ -(defun circulate-mode (&key child-direction brother-direction) +(defun circulate-mode (&key child-direction brother-direction subchild-direction) (setf *circulate-hit* 0) (with-placement (*circulate-mode-placement* x y *circulate-width* *circulate-height*) (setf *circulate-font* (xlib:open-font *display* *circulate-font-string*) @@ -205,6 +223,8 @@ (reorder-child child-direction)) (when brother-direction (reorder-brother brother-direction)) + (when subchild-direction + (reorder-subchild subchild-direction)) (let ((grab-keyboard-p (xgrab-keyboard-p)) (grab-pointer-p (xgrab-pointer-p))) (xgrab-pointer *root* 92 93) @@ -253,3 +273,10 @@ (setf *circulate-orig* (frame-child *circulate-parent*))) (circulate-mode :brother-direction -1)) +(defun select-next-subchild () + "Select the next subchild" + (when (and (frame-p *current-child*) + (frame-p (frame-selected-child *current-child*))) + (setf *circulate-orig* (frame-child *current-child*) + *circulate-parent* nil) + (circulate-mode :subchild-direction +1))) Modified: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- clfswm/src/clfswm-expose-mode.lisp (original) +++ clfswm/src/clfswm-expose-mode.lisp Sat Oct 2 17:51:31 2010 @@ -142,7 +142,7 @@ (expose-draw-letter)) -(defun expose-windows-generic (first-restore-frame body) +(defun expose-windows-generic (first-restore-frame &optional body body-escape) (setf *expose-font* (xlib:open-font *display* *expose-font-string*) *expose-windows-list* nil) (xlib:warp-pointer *root* (truncate (/ (xlib:screen-width *screen*) 2)) @@ -158,14 +158,15 @@ (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) - (when (generic-mode 'expose-mode 'exit-expose-loop - :original-mode '(main-mode)) - (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))))) + (if (generic-mode 'expose-mode 'exit-expose-loop + :original-mode '(main-mode)) + (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)))) + (pfuncall body-escape)) (dolist (lwin *expose-windows-list*) (awhen (first lwin) (xlib:destroy-window it)) @@ -190,13 +191,17 @@ (defun expose-windows-mode () "Present all windows in the current frame (An expose like)" (stop-button-event) - (expose-windows-generic *current-root* nil)) + (expose-windows-generic *current-root*)) (defun expose-all-windows-mode () "Present all windows in all frames (An expose like)" (stop-button-event) - (switch-to-root-frame :show-later t) - (expose-windows-generic *root-frame* - (lambda (parent) - (hide-all-children *root-frame*) - (setf *current-root* parent)))) + (let ((orig-root *current-root*)) + (switch-to-root-frame :show-later t) + (expose-windows-generic *root-frame* + (lambda (parent) + (hide-all-children *root-frame*) + (setf *current-root* parent)) + (lambda () + (hide-all-children *current-root*) + (setf *current-root* orig-root))))) From pbrochard at common-lisp.net Sat Oct 2 21:52:17 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 02 Oct 2010 17:52:17 -0400 Subject: [clfswm-cvs] r343 - clfswm Message-ID: Author: pbrochard Date: Sat Oct 2 17:52:17 2010 New Revision: 343 Log: TODO update Modified: clfswm/TODO Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Sat Oct 2 17:52:17 2010 @@ -7,7 +7,7 @@ =============== Should handle these soon. -- Add a binding/functions to circulate over children of the current child. +- nothing here :) MAYBE ===== From pbrochard at common-lisp.net Sun Oct 3 21:40:02 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 03 Oct 2010 17:40:02 -0400 Subject: [clfswm-cvs] r344 - in clfswm: . doc src Message-ID: Author: pbrochard Date: Sun Oct 3 17:40:01 2010 New Revision: 344 Log: Documentation update Modified: clfswm/doc/keys.html clfswm/doc/keys.txt clfswm/doc/menu.html clfswm/doc/menu.txt clfswm/load.lisp clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-second-mode.lisp Modified: clfswm/doc/keys.html ============================================================================== --- clfswm/doc/keys.html (original) +++ clfswm/doc/keys.html Sun Oct 3 17:40:01 2010 @@ -115,7 +115,18 @@ Tab - Select the previouschild + Select the previous child + + + + + Mod-1 Control + + + Tab + + + Select the next subchild @@ -923,7 +934,18 @@ Tab - Select the previouschild + Select the previous child + + + + + Mod-1 Control + + + Tab + + + Select the next subchild @@ -931,7 +953,7 @@ Shift - Tab + Tab Store the current child and switch to the previous one @@ -1840,6 +1862,17 @@ + Mod-1 Control + + + Tab + + + Select the next subchild + + + + Mod-1 Shift Modified: clfswm/doc/keys.txt ============================================================================== --- clfswm/doc/keys.txt (original) +++ clfswm/doc/keys.txt Sun Oct 3 17:40:01 2010 @@ -13,7 +13,8 @@ Mod-1 Down Select the previous level in frame Mod-1 Up Select the next level in frame Mod-1 Tab Select the next child - Mod-1 Shift Tab Select the previouschild + Mod-1 Shift Tab Select the previous child + Mod-1 Control Tab Select the next subchild Shift Tab Store the current child and switch to the previous one Mod-1 Return Enter in the selected frame - ie make it the root frame Mod-1 Shift Return Leave the selected frame - ie make its parent the root frame @@ -95,7 +96,8 @@ Control Up Revert to the first speed move mouse Control Down Reset speed mouse coordinates Mod-1 Tab Select the next child - Mod-1 Shift Tab Select the previouschild + Mod-1 Shift Tab Select the previous child + Mod-1 Control Tab Select the next subchild Shift Tab Store the current child and switch to the previous one Mod-1 Return Enter in the selected frame - ie make it the root frame Mod-1 Shift Return Leave the selected frame - ie make its parent the root frame @@ -194,6 +196,7 @@ Mod-1 Escape Leave the circulate mode Mod-1 Control G Leave the circulate mode Mod-1 Tab Select the next child + Mod-1 Control Tab Select the next subchild Mod-1 Shift Tab Select the previous child Mod-1 Shift Iso_left_tab Select the previous child Mod-1 Right Select the next brother Modified: clfswm/doc/menu.html ============================================================================== --- clfswm/doc/menu.html (original) +++ clfswm/doc/menu.html Sun Oct 3 17:40:01 2010 @@ -64,6 +64,12 @@ s: Show the second mode key binding

+ r: Show the circulate mode key binding +

+

+ e: Show the expose window mode key binding +

+

c: Help on clfswm corner

@@ -2307,6 +2313,9 @@

h: Open the next window in a numbered frame

+

+ i: Open the window in this frame if it match absorb-nw-test +


Frame-Movement-Menu @@ -2678,16 +2687,19 @@ a: Configure EXPOSE-FOREGROUND

- b: Configure EXPOSE-VALID-ON-KEY + b: Configure EXPOSE-SHOW-WINDOW-TITLE +

+

+ c: Configure EXPOSE-VALID-ON-KEY

- c: Configure EXPOSE-BORDER + d: Configure EXPOSE-BORDER

- d: Configure EXPOSE-FONT-STRING + e: Configure EXPOSE-FONT-STRING

- e: Configure EXPOSE-BACKGROUND + f: Configure EXPOSE-BACKGROUND


Modified: clfswm/doc/menu.txt ============================================================================== --- clfswm/doc/menu.txt (original) +++ clfswm/doc/menu.txt Sun Oct 3 17:40:01 2010 @@ -18,6 +18,8 @@ h: Show all key binding b: Show the main mode binding s: Show the second mode key binding +r: Show the circulate mode key binding +e: Show the expose window mode key binding c: Help on clfswm corner g: Show all configurable variables d: Show the current time and date @@ -786,6 +788,7 @@ f: Open the next window in the current frame and leave the focus on the current child g: Open the next window in a named frame h: Open the next window in a numbered frame +i: Open the window in this frame if it match absorb-nw-test Frame-Movement-Menu p: < Frame pack menu > @@ -920,10 +923,11 @@ Conf-Expose-Mode-Group a: Configure EXPOSE-FOREGROUND -b: Configure EXPOSE-VALID-ON-KEY -c: Configure EXPOSE-BORDER -d: Configure EXPOSE-FONT-STRING -e: Configure EXPOSE-BACKGROUND +b: Configure EXPOSE-SHOW-WINDOW-TITLE +c: Configure EXPOSE-VALID-ON-KEY +d: Configure EXPOSE-BORDER +e: Configure EXPOSE-FONT-STRING +f: Configure EXPOSE-BACKGROUND Conf-Hook-Group a: Configure INIT-HOOK Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Sun Oct 3 17:40:01 2010 @@ -57,13 +57,11 @@ (in-package :clfswm) -#-BUILD (ignore-errors (main :read-conf-file-p t)) ;;;; Uncomment lines above to save the default documentation. -;;#-BUILD ;;(ignore-errors ;; (main :read-conf-file-p nil)) ;;(produce-all-docs) Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Sun Oct 3 17:40:01 2010 @@ -252,7 +252,7 @@ (circulate-mode :child-direction +1))) (defun select-previous-child () - "Select the previouschild" + "Select the previous child" (when (frame-p *current-child*) (setf *circulate-orig* (frame-child *current-child*) *circulate-parent* nil) Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Sun Oct 3 17:40:01 2010 @@ -120,7 +120,7 @@ (ungrab-main-keys) (xgrab-keyboard *root*) (xgrab-pointer *root* 66 67) - (speed-mouse-reset)) ;; PHIL here + (speed-mouse-reset)) (defun sm-loop-function () (raise-window *sm-window*)) @@ -151,7 +151,6 @@ (defun leave-second-mode () "Leave second mode" (cond (*in-second-mode* - ;; (banish-pointer) ;; PHIL here (setf *in-second-mode* nil) (throw 'exit-second-loop nil)) (t (setf *in-second-mode* nil) From pbrochard at common-lisp.net Mon Oct 4 20:41:16 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 04 Oct 2010 16:41:16 -0400 Subject: [clfswm-cvs] r345 - clfswm/src Message-ID: Author: pbrochard Date: Mon Oct 4 16:41:15 2010 New Revision: 345 Log: Circulate in subchild: show-all-children only for current frame Modified: clfswm/src/clfswm-circulate-mode.lisp Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Mon Oct 4 16:41:15 2010 @@ -112,7 +112,7 @@ (with-slots (child) selected-child (let ((elem (first (last child)))) (setf child (nconc (list elem) (child-remove elem child))) - (show-all-children) + (show-all-children selected-child) (draw-circulate-mode-window))))))) From pbrochard at common-lisp.net Tue Oct 5 19:53:01 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 05 Oct 2010 15:53:01 -0400 Subject: [clfswm-cvs] r346 - in clfswm: . src Message-ID: Author: pbrochard Date: Tue Oct 5 15:52:59 2010 New Revision: 346 Log: src/clfswm-internal.lisp (show-all-children): Do not raise a child when its parent is hidden. Modified: clfswm/ChangeLog clfswm/src/clfswm-internal.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Tue Oct 5 15:52:59 2010 @@ -1,3 +1,8 @@ +2010-10-05 Philippe Brochard + + * src/clfswm-internal.lisp (show-all-children): Do not raise a + child when its parent is hidden. + 2010-10-02 Philippe Brochard * src/clfswm-circulate-mode.lisp (select-next-subchild): Add the Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Tue Oct 5 15:52:59 2010 @@ -576,11 +576,10 @@ (with-slots (window show-window-p) frame (if show-window-p (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*))) - (setf (xlib:window-background window) (get-color "Black")) (map-window window) - (when raise-p (raise-window window))) - (hide-window window))) - (display-frame-info frame)) + (when raise-p (raise-window window)) + (display-frame-info frame)) + (hide-window window)))) @@ -721,8 +720,9 @@ (when (frame-p root) (let ((reversed-children (reverse (frame-child root)))) (loop for child in reversed-children - for raise-p in (raise-p-list reversed-children) - do (rec child root raise-p)))))) + for c-raise-p in (raise-p-list reversed-children) + do (rec child root (and c-raise-p + (or (null parent) raise-p)))))))) (rec-geom *current-root* nil t t) (rec display-child nil nil) (set-focus-to-current-child) From pbrochard at common-lisp.net Wed Oct 6 20:46:54 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 06 Oct 2010 16:46:54 -0400 Subject: [clfswm-cvs] r347 - in clfswm: . src Message-ID: Author: pbrochard Date: Wed Oct 6 16:46:53 2010 New Revision: 347 Log: src/clfswm-query.lisp (query-print-string): Change cursor color and show parenthesis matching with colors (on match and on errors). Modified: clfswm/ChangeLog clfswm/src/clfswm-query.lisp clfswm/src/config.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Oct 6 16:46:53 2010 @@ -1,3 +1,9 @@ +2010-10-06 Philippe Brochard + + * src/clfswm-query.lisp (query-print-string): Change cursor color + and show parenthesis matching with colors (on match and on + errors). + 2010-10-05 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Do not raise a Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Wed Oct 6 16:46:53 2010 @@ -57,14 +57,23 @@ :with level = 1 :for c = (aref string p) :do (when (char= c #\() (decf level)) (when (char= c #\)) (incf level)) - (when (= level 0) (return p))))) - (when (have-to-find-right?) - (let ((p (pos-right))) - (when p (setf (aref string p) #\])))) - (when (have-to-find-left?) - (let ((p (pos-left))) - (when p (setf (aref string p) #\[)))) - string))) + (when (= level 0) (return p)))) + (draw-bloc (p &optional (color *query-parent-color*)) + (setf (xlib:gcontext-foreground *query-gc*) (get-color color)) + (xlib:draw-rectangle *pixmap-buffer* *query-gc* + (+ 10 (* p (xlib:max-char-width *query-font*))) + (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*) 7) + (xlib:max-char-width *query-font*) + (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*)) + t))) + (cond ((have-to-find-left?) (let ((p (pos-left))) + (if p + (progn (draw-bloc p) (draw-bloc (1- pos))) + (draw-bloc (1- pos) *query-parent-error-color*)))) + ((have-to-find-right?) (let ((p (pos-right))) + (if p + (progn (draw-bloc p) (draw-bloc pos)) + (draw-bloc pos *query-parent-error-color*)))))))) (defun clear-query-history () @@ -88,21 +97,26 @@ (add-hook *binding-hook* 'init-*query-keys*) -(defun query-add-cursor (string) - (concatenate 'string (subseq string 0 *query-pos*) "|" (subseq string *query-pos*))) - (defun query-print-string () (clear-pixmap-buffer *query-window* *query-gc*) - (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*)) + (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*)) (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) *query-message*) (when (< *query-pos* 0) (setf *query-pos* 0)) (when (> *query-pos* (length *query-string*)) (setf *query-pos* (length *query-string*))) + (query-show-paren *query-string* *query-pos*) + (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*)) (xlib:draw-glyphs *pixmap-buffer* *query-gc* 10 (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5) - (query-add-cursor (query-show-paren *query-string* *query-pos*))) + *query-string*) + (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-cursor-color*)) + (xlib:draw-line *pixmap-buffer* *query-gc* + (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))) + (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 6) + (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))) + (+ (* 1 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 7)) (copy-pixmap-buffer *query-window* *query-gc*)) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Wed Oct 6 16:46:53 2010 @@ -221,8 +221,16 @@ "Config(Query string group): Query string window font string") (defparameter *query-background* "black" "Config(Query string group): Query string window background color") +(defparameter *query-message-color* "yellow" + "Config(Query string group): Query string window message color") (defparameter *query-foreground* "green" "Config(Query string group): Query string window foreground color") +(defparameter *query-cursor-color* "white" + "Config(Query string group): Query string window foreground cursor color") +(defparameter *query-parent-color* "blue" + "Config(Query string group): Query string window parenthesis color") +(defparameter *query-parent-error-color* "red" + "Config(Query string group): Query string window parenthesis color when no match") (defparameter *query-border* "red" "Config(Query string group): Query string window border color") From pbrochard at common-lisp.net Thu Oct 7 12:58:08 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 07 Oct 2010 08:58:08 -0400 Subject: [clfswm-cvs] r348 - in clfswm: . src Message-ID: Author: pbrochard Date: Thu Oct 7 08:58:08 2010 New Revision: 348 Log: src/clfswm-query.lisp (add-in-query-string): Handle correctly the mod-5 modifier. Modified: clfswm/ChangeLog clfswm/src/clfswm-query.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Oct 7 08:58:08 2010 @@ -1,3 +1,8 @@ +2010-10-07 Philippe Brochard + + * src/clfswm-query.lisp (add-in-query-string): Handle correctly + the mod-5 modifier. + 2010-10-06 Philippe Brochard * src/clfswm-query.lisp (query-print-string): Change cursor color Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Thu Oct 7 08:58:08 2010 @@ -267,8 +267,8 @@ (defun add-in-query-string (code state) (let* ((modifiers (state->modifiers state)) (keysym (keycode->keysym code modifiers)) - (char (xlib:keysym->character *display* keysym))) - (when (and (characterp char) (standard-char-p char)) + (char (xlib:keysym->character *display* keysym state))) + (when (and char (characterp char)) (setf *query-string* (concatenate 'string (when (<= *query-pos* (length *query-string*)) (subseq *query-string* 0 *query-pos*)) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Thu Oct 7 08:58:08 2010 @@ -703,9 +703,9 @@ (xlib:make-state-keys state)) (defun keycode->keysym (code modifiers) - (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1) - ((member :mod-5 modifiers) 2) - (t 0)))) + (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1) + ((member :mod-5 modifiers) 4) + (t 0)))) (defmacro with-grab-keyboard-and-pointer ((cursor mask old-cursor old-mask) &body body) From pbrochard at common-lisp.net Fri Oct 8 21:07:36 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 08 Oct 2010 17:07:36 -0400 Subject: [clfswm-cvs] r349 - in clfswm: . src Message-ID: Author: pbrochard Date: Fri Oct 8 17:07:36 2010 New Revision: 349 Log: * src/clfswm-util.lisp (): Add an Hello window at startup. * src/tools.lisp (process-timers): Add a timer system. Modified: clfswm/ChangeLog clfswm/src/clfswm-generic-mode.lisp clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/config.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Fri Oct 8 17:07:36 2010 @@ -1,3 +1,9 @@ +2010-10-08 Philippe Brochard + + * src/clfswm-util.lisp (): Add an Hello window at startup. + + * src/tools.lisp (process-timers): Add a timer system. + 2010-10-07 Philippe Brochard * src/clfswm-query.lisp (add-in-query-string): Handle correctly Modified: clfswm/src/clfswm-generic-mode.lisp ============================================================================== --- clfswm/src/clfswm-generic-mode.lisp (original) +++ clfswm/src/clfswm-generic-mode.lisp Fri Oct 8 17:07:36 2010 @@ -40,6 +40,7 @@ (unwind-protect (loop (call-hook loop-hook) + (process-timers) (nfuncall loop-function) (when (xlib:event-listen *display* *loop-timeout*) (xlib:process-event *display* :handler #'handle-event)) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Fri Oct 8 17:07:36 2010 @@ -1439,3 +1439,68 @@ (setf lx (first h) ly (second h)) (xlib:warp-pointer *root* lx ly))))))) + + + +;;; Hello window functions +(let ((font nil) + (window nil) + (gc nil) + (width 300) (height 50) + (current-child nil)) + (defun open-hello-window () + (with-placement (#'middle-middle-placement x y width height) + (setf font (xlib:open-font *display* *sm-font-string*) + window (xlib:create-window :parent *root* + :x x + :y y + :width width + :height height + :background (get-color *sm-background-color*) + :border-width 1 + :border (get-color *sm-border-color*) + :colormap (xlib:screen-default-colormap *screen*) + :event-mask '(:exposure :key-press)) + gc (xlib:create-gcontext :drawable window + :foreground (get-color *sm-foreground-color*) + :background (get-color *sm-background-color*) + :font font + :line-style :solid)) + (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) + (when (frame-p *current-child*) + (setf current-child *current-child*) + (push window (frame-forced-unmanaged-window *current-child*))) + (map-window window) + (raise-window window) + (let* ((text (format nil "Welcome to CLFSWM"))) + (xlib:draw-glyphs window gc + (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) + (truncate (- (/ (+ height text-height) 2) text-height)) + text)) + (let* ((text (format nil "Press Alt+F1 for help"))) + (xlib:draw-glyphs window gc + (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) + (truncate (+ (/ (+ height text-height) 2) text-height)) + text)) + (xlib:display-finish-output *display*)))) + + (defun close-hello-window () + (setf (frame-forced-unmanaged-window current-child) + (remove window (frame-forced-unmanaged-window current-child) :test #'xlib:window-equal)) + (when gc + (xlib:free-gcontext gc)) + (when window + (xlib:destroy-window window)) + (when font + (xlib:close-font font)) + (xlib:display-finish-output *display*) + (setf window nil + gc nil + font nil)) + + + (defun display-hello-window () + (sleep 5) + (open-hello-window) + (with-timer (10) + (close-hello-window)))) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Fri Oct 8 17:07:36 2010 @@ -146,6 +146,7 @@ (defun main-loop () (loop (call-hook *loop-hook*) + (process-timers) (with-xlib-protect (when (xlib:event-listen *display* *loop-timeout*) (xlib:process-event *display* :handler #'handle-event)) @@ -185,6 +186,7 @@ (xgrab-init-keyboard) (init-last-child) (call-hook *binding-hook*) + (clear-timers) (map-window *no-focus-window*) (dbg *display*) (setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect @@ -205,7 +207,9 @@ (process-existing-windows *screen*) (show-all-children *current-root*) (grab-main-keys) - (xlib:display-finish-output *display*)) + (xlib:display-finish-output *display*) + (when *have-to-display-hello-window* + (display-hello-window))) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Fri Oct 8 17:07:36 2010 @@ -37,6 +37,9 @@ (setf *have-to-compress-notify* t) +(defparameter *have-to-display-hello-window* t + "Config(): Display the hello window at startup") + ;;; CONFIG - Default modifiers (defparameter *default-modifiers* '() Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Fri Oct 8 17:07:36 2010 @@ -38,6 +38,11 @@ :call-hook :add-hook :remove-hook + :clear-timers + :add-timer + :with-timer + :process-timers + :timer-loop :dbg :dbgnl :dbgc @@ -169,6 +174,49 @@ (setf ,hook (remove ,i ,hook))))) +;;;,----- +;;;| Timers tools +;;;`----- +(defparameter *timer-list* nil) + +(declaim (inline realtime->s s->realtime)) + +(defun realtime->s (rtime) + (float (/ rtime internal-time-units-per-second))) + +(defun s->realtime (second) + (round (* second internal-time-units-per-second))) + + +(defun clear-timers () + (setf *timer-list* nil)) + +(defun add-timer (delay fun) + (push (let ((time (+ (get-internal-real-time) (s->realtime delay)))) + (lambda () + (when (>= (get-internal-real-time) time) + (funcall fun) + t))) + *timer-list*)) + +(defmacro with-timer ((delay) &body body) + `(add-timer ,delay + (lambda () + , at body))) + + +(defun process-timers () + (dolist (timer *timer-list*) + (when (funcall timer) + (setf *timer-list* (remove timer *timer-list* :test #'equal))))) + + +(defun timer-test-loop () + (loop + (princ ".") (force-output) + (process-timers) + (sleep 0.5))) + ;;;,----- ;;;| Debuging tools From pbrochard at common-lisp.net Sat Oct 9 06:45:49 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 09 Oct 2010 02:45:49 -0400 Subject: [clfswm-cvs] r350 - clfswm/src Message-ID: Author: pbrochard Date: Sat Oct 9 02:45:48 2010 New Revision: 350 Log: clfswm.lisp: move display-hello-window in the *init-hook* list Modified: clfswm/src/clfswm-util.lisp clfswm/src/clfswm.lisp clfswm/src/config.lisp Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Oct 9 02:45:48 2010 @@ -1500,7 +1500,6 @@ (defun display-hello-window () - (sleep 5) (open-hello-window) (with-timer (10) (close-hello-window)))) Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Sat Oct 9 02:45:48 2010 @@ -207,9 +207,7 @@ (process-existing-windows *screen*) (show-all-children *current-root*) (grab-main-keys) - (xlib:display-finish-output *display*) - (when *have-to-display-hello-window* - (display-hello-window))) + (xlib:display-finish-output *display*)) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sat Oct 9 02:45:48 2010 @@ -37,10 +37,6 @@ (setf *have-to-compress-notify* t) -(defparameter *have-to-display-hello-window* t - "Config(): Display the hello window at startup") - - ;;; CONFIG - Default modifiers (defparameter *default-modifiers* '() "Config(): Default modifiers list to append to explicit modifiers @@ -150,7 +146,7 @@ ;;; ;;; See clfswm.lisp for hooks examples. -(defparameter *init-hook* 'default-init-hook +(defparameter *init-hook* '(default-init-hook display-hello-window) "Config(Hook group): Init hook. This hook is run just after the first root frame is created") (defparameter *default-nw-hook* 'default-frame-nw-hook From pbrochard at common-lisp.net Sat Oct 9 20:02:05 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 09 Oct 2010 16:02:05 -0400 Subject: [clfswm-cvs] r351 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 9 16:02:05 2010 New Revision: 351 Log: src/clfswm-util.lisp (display-hello-window): Add a timer to hide the hello window. Add Configuration variables. Modified: clfswm/ChangeLog clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-util.lisp clfswm/src/config.lisp clfswm/src/package.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 9 16:02:05 2010 @@ -1,3 +1,10 @@ +2010-10-09 Philippe Brochard + + * src/tools.lisp (erase-timer): New function. + + * src/clfswm-util.lisp (display-hello-window): Add a timer to hide + the hello window. Add Configuration variables. + 2010-10-08 Philippe Brochard * src/clfswm-util.lisp (): Add an Hello window at startup. Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sat Oct 9 16:02:05 2010 @@ -148,8 +148,11 @@ (defun never-managed-window-p (window) (dolist (type *never-managed-window-list*) - (when (string-equal (funcall (first type) window) (second type)) - (return t)))) + (destructuring-bind (test predicate result) type + (when (funcall test (funcall predicate window) result) + (return t))))) + ;;(when (string-equal (funcall (first type) window) (second type)) + ;; (return t)))) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Oct 9 16:02:05 2010 @@ -1446,47 +1446,57 @@ (let ((font nil) (window nil) (gc nil) - (width 300) (height 50) + width height (current-child nil)) + (defun is-hello-window-p (win) + (xlib:window-equal win window)) + (defun open-hello-window () - (with-placement (#'middle-middle-placement x y width height) - (setf font (xlib:open-font *display* *sm-font-string*) + (setf width *hello-window-width* + height *hello-window-height*) + (with-placement (*hello-window-placement* x y width height) + (setf font (xlib:open-font *display* *hello-window-font-string*) window (xlib:create-window :parent *root* :x x :y y :width width :height height - :background (get-color *sm-background-color*) + :background (get-color *hello-window-background*) :border-width 1 - :border (get-color *sm-border-color*) + :border (get-color *hello-window-border*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure :key-press)) gc (xlib:create-gcontext :drawable window - :foreground (get-color *sm-foreground-color*) - :background (get-color *sm-background-color*) + :foreground (get-color *hello-window-foreground*) + :background (get-color *hello-window-background*) :font font :line-style :solid)) - (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) - (when (frame-p *current-child*) - (setf current-child *current-child*) - (push window (frame-forced-unmanaged-window *current-child*))) - (map-window window) - (raise-window window) - (let* ((text (format nil "Welcome to CLFSWM"))) - (xlib:draw-glyphs window gc - (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) - (truncate (- (/ (+ height text-height) 2) text-height)) - text)) - (let* ((text (format nil "Press Alt+F1 for help"))) - (xlib:draw-glyphs window gc - (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) - (truncate (+ (/ (+ height text-height) 2) text-height)) - text)) - (xlib:display-finish-output *display*)))) + (when (frame-p *current-child*) + (setf current-child *current-child*) + (push (list #'equal #'is-hello-window-p t) *never-managed-window-list*)) + (map-window window) + (refresh-hello-window) + (xlib:display-finish-output *display*))) + + (defun refresh-hello-window () + (add-timer 0.1 #'refresh-hello-window) + (raise-window window) + (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) + (let* ((text (format nil "Welcome to CLFSWM"))) + (xlib:draw-glyphs window gc + (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) + (truncate (- (/ (+ height text-height) 2) text-height)) + text)) + (let* ((text (format nil "Press Alt+F1 for help"))) + (xlib:draw-glyphs window gc + (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) + (truncate (+ (/ (+ height text-height) 2) text-height)) + text)))) (defun close-hello-window () - (setf (frame-forced-unmanaged-window current-child) - (remove window (frame-forced-unmanaged-window current-child) :test #'xlib:window-equal)) + (erase-timer #'refresh-hello-window) + (setf *never-managed-window-list* + (remove (list #'equal #'is-hello-window-p t) *never-managed-window-list* :test #'equal)) (when gc (xlib:free-gcontext gc)) (when window @@ -1498,8 +1508,6 @@ gc nil font nil)) - (defun display-hello-window () (open-hello-window) - (with-timer (10) - (close-hello-window)))) + (add-timer *hello-window-delay* #'close-hello-window))) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sat Oct 9 16:02:05 2010 @@ -47,9 +47,9 @@ ;;; CONFIG - Never managed window list (defparameter *never-managed-window-list* - '((xlib:get-wm-class "ROX-Pinboard") - (xlib:get-wm-class "xvkbd") - (xlib:wm-name "clfswm-terminal")) + '((string-equal xlib:get-wm-class "ROX-Pinboard") + (string-equal xlib:get-wm-class "xvkbd") + (string-equal xlib:wm-name "clfswm-terminal")) "Config(): CLFSWM will never manage windows of this type. A list of (predicate-function-on-window expected-string)") @@ -308,3 +308,21 @@ (defparameter *menu-color-menu-key* (->color #xFF9AFF) "Config(Menu group): Menu key color in menu") + +;;; CONFIG - Hello window string colors +(defparameter *hello-window-font-string* *default-font-string* + "Config(Hello Window mode group): Hello window font string") +(defparameter *hello-window-background* "black" + "Config(Hello Window mode group): Hello Window background color") +(defparameter *hello-window-foreground* "green" + "Config(Hello Window mode group): Hello Window foreground color") +(defparameter *hello-window-border* "red" + "Config(Hello Window mode group): Hello Window border color") +(defparameter *hello-window-width* 300 + "Config(Hello Window mode group): Hello Window width") +(defparameter *hello-window-height* 50 + "Config(Hello Window mode group): Hello Window height") +(defparameter *hello-window-delay* 10 + "Config(Hello Window mode group): Hello Window display delay") + + Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Sat Oct 9 16:02:05 2010 @@ -208,6 +208,8 @@ "Config(Placement group): Circulate mode window placement") (defparameter *expose-mode-placement* 'top-left-child-placement "Config(Placement group): Expose mode window placement (Selection keys position)") +(defparameter *hello-window-placement* 'bottom-right-placement + "Config(Placement group): Hello window placement") Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Sat Oct 9 16:02:05 2010 @@ -42,6 +42,7 @@ :add-timer :with-timer :process-timers + :erase-timer :timer-loop :dbg :dbgnl @@ -192,11 +193,12 @@ (setf *timer-list* nil)) (defun add-timer (delay fun) - (push (let ((time (+ (get-internal-real-time) (s->realtime delay)))) - (lambda () - (when (>= (get-internal-real-time) time) - (funcall fun) - t))) + (push (list (let ((time (+ (get-internal-real-time) (s->realtime delay)))) + (lambda () + (when (>= (get-internal-real-time) time) + (funcall fun) + t))) + fun) *timer-list*)) (defmacro with-timer ((delay) &body body) @@ -207,9 +209,13 @@ (defun process-timers () (dolist (timer *timer-list*) - (when (funcall timer) + (when (funcall (first timer)) (setf *timer-list* (remove timer *timer-list* :test #'equal))))) +(defun erase-timer (fun) + (dolist (timer *timer-list*) + (when (equal fun (second timer)) + (setf *timer-list* (remove timer *timer-list* :test #'equal))))) (defun timer-test-loop () (loop @@ -217,6 +223,20 @@ (process-timers) (sleep 0.5))) +;;(defun plop () +;; (princ 'plop) +;; (erase-timer #'toto)) +;; +;;(defun toto () +;; (princ 'toto) +;; (add-timer 5 #'toto)) +;; +;;(add-timer 5 #'toto) +;;(add-timer 30 #'plop) +;; +;;(timer-test-loop) + + ;;;,----- ;;;| Debuging tools From pbrochard at common-lisp.net Sun Oct 10 19:51:15 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 10 Oct 2010 15:51:15 -0400 Subject: [clfswm-cvs] r352 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Oct 10 15:51:15 2010 New Revision: 352 Log: src/tools.lisp (add-timer): Add an id to identify the timer. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp clfswm/src/config.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Oct 10 15:51:15 2010 @@ -1,3 +1,7 @@ +2010-10-10 Philippe Brochard + + * src/tools.lisp (add-timer): Add an id to identify the timer. + 2010-10-09 Philippe Brochard * src/tools.lisp (erase-timer): New function. Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sun Oct 10 15:51:15 2010 @@ -1451,12 +1451,27 @@ (defun is-hello-window-p (win) (xlib:window-equal win window)) + (defun refresh-hello-window () + (add-timer 0.1 #'refresh-hello-window :refresh-hello-window) + (raise-window window) + (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) + (let* ((text (format nil "Welcome to CLFSWM"))) + (xlib:draw-glyphs window gc + (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) + (truncate (- (/ (+ height text-height) 2) text-height)) + text)) + (let* ((text (format nil "Press Alt+F1 for help"))) + (xlib:draw-glyphs window gc + (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) + (truncate (+ (/ (+ height text-height) 2) text-height)) + text)))) + (defun open-hello-window () (setf width *hello-window-width* - height *hello-window-height*) + height *hello-window-height* + font (xlib:open-font *display* *hello-window-font-string*)) (with-placement (*hello-window-placement* x y width height) - (setf font (xlib:open-font *display* *hello-window-font-string*) - window (xlib:create-window :parent *root* + (setf window (xlib:create-window :parent *root* :x x :y y :width width @@ -1478,23 +1493,8 @@ (refresh-hello-window) (xlib:display-finish-output *display*))) - (defun refresh-hello-window () - (add-timer 0.1 #'refresh-hello-window) - (raise-window window) - (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) - (let* ((text (format nil "Welcome to CLFSWM"))) - (xlib:draw-glyphs window gc - (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) - (truncate (- (/ (+ height text-height) 2) text-height)) - text)) - (let* ((text (format nil "Press Alt+F1 for help"))) - (xlib:draw-glyphs window gc - (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) - (truncate (+ (/ (+ height text-height) 2) text-height)) - text)))) - (defun close-hello-window () - (erase-timer #'refresh-hello-window) + (erase-timer :refresh-hello-window) (setf *never-managed-window-list* (remove (list #'equal #'is-hello-window-p t) *never-managed-window-list* :test #'equal)) (when gc Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sun Oct 10 15:51:15 2010 @@ -313,16 +313,16 @@ (defparameter *hello-window-font-string* *default-font-string* "Config(Hello Window mode group): Hello window font string") (defparameter *hello-window-background* "black" - "Config(Hello Window mode group): Hello Window background color") + "Config(Hello Window group): Hello Window background color") (defparameter *hello-window-foreground* "green" - "Config(Hello Window mode group): Hello Window foreground color") + "Config(Hello Window group): Hello Window foreground color") (defparameter *hello-window-border* "red" - "Config(Hello Window mode group): Hello Window border color") + "Config(Hello Window group): Hello Window border color") (defparameter *hello-window-width* 300 - "Config(Hello Window mode group): Hello Window width") + "Config(Hello Window group): Hello Window width") (defparameter *hello-window-height* 50 - "Config(Hello Window mode group): Hello Window height") + "Config(Hello Window group): Hello Window height") (defparameter *hello-window-delay* 10 - "Config(Hello Window mode group): Hello Window display delay") + "Config(Hello Window group): Hello Window display delay") Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Sun Oct 10 15:51:15 2010 @@ -192,29 +192,31 @@ (defun clear-timers () (setf *timer-list* nil)) -(defun add-timer (delay fun) - (push (list (let ((time (+ (get-internal-real-time) (s->realtime delay)))) +(defun add-timer (delay fun &optional (id (gensym))) + (push (list id + (let ((time (+ (get-internal-real-time) (s->realtime delay)))) (lambda () (when (>= (get-internal-real-time) time) (funcall fun) - t))) - fun) - *timer-list*)) + t)))) + *timer-list*) + id) -(defmacro with-timer ((delay) &body body) +(defmacro with-timer ((delay &optional (id (gensym))) &body body) `(add-timer ,delay (lambda () - , at body))) + , at body) + ,id)) (defun process-timers () (dolist (timer *timer-list*) - (when (funcall (first timer)) + (when (funcall (second timer)) (setf *timer-list* (remove timer *timer-list* :test #'equal))))) -(defun erase-timer (fun) +(defun erase-timer (id) (dolist (timer *timer-list*) - (when (equal fun (second timer)) + (when (equal id (first timer)) (setf *timer-list* (remove timer *timer-list* :test #'equal))))) (defun timer-test-loop () @@ -223,18 +225,18 @@ (process-timers) (sleep 0.5))) -;;(defun plop () -;; (princ 'plop) -;; (erase-timer #'toto)) -;; -;;(defun toto () -;; (princ 'toto) -;; (add-timer 5 #'toto)) -;; -;;(add-timer 5 #'toto) -;;(add-timer 30 #'plop) -;; -;;(timer-test-loop) +(defun plop () + (princ 'plop) + (erase-timer :toto)) + +(defun toto () + (princ 'toto) + (add-timer 5 #'toto :toto)) + +(add-timer 5 #'toto :toto) +(add-timer 30 #'plop) + +(timer-test-loop) From pbrochard at common-lisp.net Sun Oct 10 19:51:48 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 10 Oct 2010 15:51:48 -0400 Subject: [clfswm-cvs] r353 - clfswm/src Message-ID: Author: pbrochard Date: Sun Oct 10 15:51:47 2010 New Revision: 353 Log: Remove test functions Modified: clfswm/src/tools.lisp Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Sun Oct 10 15:51:47 2010 @@ -225,18 +225,18 @@ (process-timers) (sleep 0.5))) -(defun plop () - (princ 'plop) - (erase-timer :toto)) - -(defun toto () - (princ 'toto) - (add-timer 5 #'toto :toto)) - -(add-timer 5 #'toto :toto) -(add-timer 30 #'plop) - -(timer-test-loop) +;;(defun plop () +;; (princ 'plop) +;; (erase-timer :toto)) +;; +;;(defun toto () +;; (princ 'toto) +;; (add-timer 5 #'toto :toto)) +;; +;;(add-timer 5 #'toto :toto) +;;(add-timer 30 #'plop) +;; +;;(timer-test-loop) From pbrochard at common-lisp.net Sun Oct 10 20:47:21 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 10 Oct 2010 16:47:21 -0400 Subject: [clfswm-cvs] r354 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Oct 10 16:47:21 2010 New Revision: 354 Log: src/clfswm-util.lisp (open-notify-window): Convert hello-window functions to a more generic Notify-window system. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp clfswm/src/config.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Oct 10 16:47:21 2010 @@ -1,5 +1,8 @@ 2010-10-10 Philippe Brochard + * src/clfswm-util.lisp (open-notify-window): Convert hello-window + functions to a more generic Notify-window system. + * src/tools.lisp (add-timer): Add an id to identify the timer. 2010-10-09 Philippe Brochard Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sun Oct 10 16:47:21 2010 @@ -1442,72 +1442,84 @@ -;;; Hello window functions -(let ((font nil) - (window nil) - (gc nil) +;;; Notify window functions +(let (font + window + gc width height - (current-child nil)) - (defun is-hello-window-p (win) - (xlib:window-equal win window)) - - (defun refresh-hello-window () - (add-timer 0.1 #'refresh-hello-window :refresh-hello-window) - (raise-window window) - (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) - (let* ((text (format nil "Welcome to CLFSWM"))) - (xlib:draw-glyphs window gc - (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) - (truncate (- (/ (+ height text-height) 2) text-height)) - text)) - (let* ((text (format nil "Press Alt+F1 for help"))) - (xlib:draw-glyphs window gc - (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2)) - (truncate (+ (/ (+ height text-height) 2) text-height)) - text)))) - - (defun open-hello-window () - (setf width *hello-window-width* - height *hello-window-height* - font (xlib:open-font *display* *hello-window-font-string*)) - (with-placement (*hello-window-placement* x y width height) - (setf window (xlib:create-window :parent *root* - :x x - :y y - :width width - :height height - :background (get-color *hello-window-background*) - :border-width 1 - :border (get-color *hello-window-border*) - :colormap (xlib:screen-default-colormap *screen*) - :event-mask '(:exposure :key-press)) - gc (xlib:create-gcontext :drawable window - :foreground (get-color *hello-window-foreground*) - :background (get-color *hello-window-background*) - :font font - :line-style :solid)) - (when (frame-p *current-child*) - (setf current-child *current-child*) - (push (list #'equal #'is-hello-window-p t) *never-managed-window-list*)) - (map-window window) - (refresh-hello-window) - (xlib:display-finish-output *display*))) - - (defun close-hello-window () - (erase-timer :refresh-hello-window) - (setf *never-managed-window-list* - (remove (list #'equal #'is-hello-window-p t) *never-managed-window-list* :test #'equal)) - (when gc - (xlib:free-gcontext gc)) - (when window - (xlib:destroy-window window)) - (when font - (xlib:close-font font)) - (xlib:display-finish-output *display*) - (setf window nil - gc nil - font nil)) - - (defun display-hello-window () - (open-hello-window) - (add-timer *hello-window-delay* #'close-hello-window))) + text + current-child) + (labels ((text-string (tx) + (typecase tx + (cons (first tx)) + (t tx))) + (text-color (tx) + (get-color (typecase tx + (cons (second tx)) + (t *notify-window-foreground*))))) + (defun is-notify-window-p (win) + (xlib:window-equal win window)) + + (defun refresh-notify-window () + (add-timer 0.1 #'refresh-notify-window :refresh-notify-window) + (raise-window window) + (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) + (loop for tx in text + for i from 1 do + (setf (xlib:gcontext-foreground gc) (text-color tx)) + (xlib:draw-glyphs window gc + (truncate (/ (- width (* (xlib:max-char-width font) (length (text-string tx)))) 2)) + (* text-height i 2) + (text-string tx))))) + + (defun close-notify-window () + (erase-timer :refresh-notify-window) + (setf *never-managed-window-list* + (remove (list #'equal #'is-notify-window-p t) *never-managed-window-list* :test #'equal)) + (when gc + (xlib:free-gcontext gc)) + (when window + (xlib:destroy-window window)) + (when font + (xlib:close-font font)) + (xlib:display-finish-output *display*) + (setf window nil + gc nil + font nil)) + + (defun open-notify-window (text-list) + (close-notify-window) + (setf font (xlib:open-font *display* *notify-window-font-string*)) + (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) + (setf text text-list) + (setf width (* (xlib:max-char-width font) (+ (loop for tx in text-list + maximize (length (text-string tx))) 2)) + height (+ (* text-height (length text-list) 2) text-height)) + (with-placement (*notify-window-placement* x y width height) + (setf window (xlib:create-window :parent *root* + :x x + :y y + :width width + :height height + :background (get-color *notify-window-background*) + :border-width 1 + :border (get-color *notify-window-border*) + :colormap (xlib:screen-default-colormap *screen*) + :event-mask '(:exposure :key-press)) + gc (xlib:create-gcontext :drawable window + :foreground (get-color *notify-window-foreground*) + :background (get-color *notify-window-background*) + :font font + :line-style :solid)) + (when (frame-p *current-child*) + (setf current-child *current-child*) + (push (list #'equal #'is-notify-window-p t) *never-managed-window-list*)) + (map-window window) + (refresh-notify-window) + (xlib:display-finish-output *display*)))))) + + +(defun display-hello-window () + (open-notify-window '(("Welcome to CLFSWM" "yellow") + "Press Alt+F1 for help")) + (add-timer *notify-window-delay* #'close-notify-window)) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sun Oct 10 16:47:21 2010 @@ -309,20 +309,16 @@ "Config(Menu group): Menu key color in menu") -;;; CONFIG - Hello window string colors -(defparameter *hello-window-font-string* *default-font-string* - "Config(Hello Window mode group): Hello window font string") -(defparameter *hello-window-background* "black" - "Config(Hello Window group): Hello Window background color") -(defparameter *hello-window-foreground* "green" - "Config(Hello Window group): Hello Window foreground color") -(defparameter *hello-window-border* "red" - "Config(Hello Window group): Hello Window border color") -(defparameter *hello-window-width* 300 - "Config(Hello Window group): Hello Window width") -(defparameter *hello-window-height* 50 - "Config(Hello Window group): Hello Window height") -(defparameter *hello-window-delay* 10 - "Config(Hello Window group): Hello Window display delay") +;;; CONFIG - Notify window string colors +(defparameter *notify-window-font-string* *default-font-string* + "Config(Notify Window mode group): Notify window font string") +(defparameter *notify-window-background* "black" + "Config(Notify Window group): Notify Window background color") +(defparameter *notify-window-foreground* "green" + "Config(Notify Window group): Notify Window foreground color") +(defparameter *notify-window-border* "red" + "Config(Notify Window group): Notify Window border color") +(defparameter *notify-window-delay* 10 + "Config(Notify Window group): Notify Window display delay") Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Sun Oct 10 16:47:21 2010 @@ -208,8 +208,8 @@ "Config(Placement group): Circulate mode window placement") (defparameter *expose-mode-placement* 'top-left-child-placement "Config(Placement group): Expose mode window placement (Selection keys position)") -(defparameter *hello-window-placement* 'bottom-right-placement - "Config(Placement group): Hello window placement") +(defparameter *notify-window-placement* 'bottom-right-placement + "Config(Placement group): Notify window placement") From pbrochard at common-lisp.net Wed Oct 13 20:36:05 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 13 Oct 2010 16:36:05 -0400 Subject: [clfswm-cvs] r355 - in clfswm: . src Message-ID: Author: pbrochard Date: Wed Oct 13 16:36:04 2010 New Revision: 355 Log: src/clfswm-info.lisp (show-first-aid-kit): Display the essential key binding in main and second mode. Modified: clfswm/ChangeLog clfswm/src/bindings.lisp clfswm/src/clfswm-autodoc.lisp clfswm/src/clfswm-info.lisp clfswm/src/clfswm-second-mode.lisp clfswm/src/clfswm-util.lisp clfswm/src/menu-def.lisp clfswm/src/tools.lisp clfswm/src/version.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Oct 13 16:36:04 2010 @@ -1,3 +1,8 @@ +2010-10-13 Philippe Brochard + + * src/clfswm-info.lisp (show-first-aid-kit): Display the essential + key binding in main and second mode. + 2010-10-10 Philippe Brochard * src/clfswm-util.lisp (open-notify-window): Convert hello-window Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Wed Oct 13 16:36:04 2010 @@ -65,6 +65,7 @@ (define-main-key ("F10" :shift :control) 'toggle-show-root-frame) (define-main-key ("F10") 'expose-windows-mode) (define-main-key ("F10" :control) 'expose-all-windows-mode) + (define-main-key ("L2" :control) 'present-clfswm-terminal) (define-main-key (#\b :mod-1) 'banish-pointer) ;; Escape (define-main-key ("Escape" :control) 'ask-close/kill-current-window) Modified: clfswm/src/clfswm-autodoc.lisp ============================================================================== --- clfswm/src/clfswm-autodoc.lisp (original) +++ clfswm/src/clfswm-autodoc.lisp Wed Oct 13 16:36:04 2010 @@ -91,7 +91,7 @@ -(defun produce-doc (hash-table-key-list &optional (stream t)) +(defun produce-doc (hash-table-key-list &optional (stream t) (display-producing-doc t)) "Produce a text doc from a hash-table key" (format stream " * CLFSWM Keys *~%") (format stream " -----------~%") @@ -109,7 +109,8 @@ (documentation (or (first v) (third v)) 'function)))) hk) (format stream "~2&")) - (format stream "~2%This documentation was produced with the CLFSWM auto-doc functions. + (when display-producing-doc + (format stream "~2%This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-doc-in-file or the produce-all-docs function from the Lisp REPL. @@ -117,7 +118,7 @@ LISP> (in-package :clfswm) CLFSWM> (produce-doc-in-file \"my-keys.txt\") or -CLFSWM> (produce-all-docs)~2%")) +CLFSWM> (produce-all-docs)~2%"))) Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Wed Oct 13 16:36:04 2010 @@ -436,12 +436,14 @@ (defun show-key-binding (&rest hash-table-key) - "Show the binding of each hash-table-key" + "Show the binding of each hash-table-key. +Pass the :no-producing-doc symbol to remove the producing doc" (info-mode (key-binding-colorize-line (split-string (append-newline-space (with-output-to-string (stream) - (produce-doc hash-table-key - stream))) + (produce-doc (remove :no-producing-doc hash-table-key) + stream + (not (member :no-producing-doc hash-table-key))))) #\Newline)))) @@ -467,6 +469,37 @@ (show-key-binding *expose-keys* *expose-mouse*)) +(defun show-first-aid-kit () + "Show the first aid kit key binding" + (labels ((add-key (hash symbol &optional (hashkey *main-keys*)) + (multiple-value-bind (k v) + (find-in-hash symbol hashkey) + (setf (gethash k hash) v)))) + (let ((hash (make-hash-table :test #'equal)) + (hash-second (make-hash-table :test #'equal))) + (setf (gethash 'name hash) "First aid kit - Main mode key binding" + (gethash 'name hash-second) "First aid kit - Second mode key binding") + (add-key hash 'select-next-child) + (add-key hash 'select-previous-child) + (add-key hash 'select-next-brother) + (add-key hash 'select-previous-brother) + (add-key hash 'select-previous-level) + (add-key hash 'select-next-level) + (add-key hash 'enter-frame) + (add-key hash 'leave-frame) + (add-key hash 'second-key-mode) + (add-key hash 'expose-windows-mode) + (add-key hash 'expose-all-windows-mode) + (add-key hash 'present-clfswm-terminal) + (add-key hash-second 'leave-second-mode *second-keys*) + (add-key hash-second 'open-menu *second-keys*) + (add-key hash-second 'run-program-from-query-string *second-keys*) + (add-key hash-second 'eval-from-query-string *second-keys*) + (add-key hash-second 'set-open-in-new-frame-in-parent-frame-nw-hook *second-keys*) + (add-key hash-second 'b-start-xterm *second-keys*) + (add-key hash-second 'b-start-emacs *second-keys*) + (show-key-binding hash hash-second :no-producing-doc)))) + (defun corner-help-colorize-line (list) (loop :for line :in list Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Wed Oct 13 16:36:04 2010 @@ -141,7 +141,7 @@ (setf *in-second-mode* nil)) (defun second-key-mode () - "Switch to editing mode" + "Switch to editing mode (second mode)" (generic-mode 'second-mode 'exit-second-loop :enter-function #'sm-enter-function Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Wed Oct 13 16:36:04 2010 @@ -330,7 +330,7 @@ (defun eval-from-query-string () "Eval a lisp form from the query input" - (let ((form (query-string "Eval:")) + (let ((form (query-string (format nil "Eval Lisp - ~A" (package-name *package*)))) (result nil)) (when (and form (not (equal form ""))) (let ((printed-result Modified: clfswm/src/menu-def.lisp ============================================================================== --- clfswm/src/menu-def.lisp (original) +++ clfswm/src/menu-def.lisp Wed Oct 13 16:36:04 2010 @@ -64,6 +64,7 @@ (create-configuration-menu) +(add-menu-key 'help-menu "a" 'show-first-aid-kit) (add-menu-key 'help-menu "h" 'show-global-key-binding) (add-menu-key 'help-menu "b" 'show-main-mode-key-binding) (add-menu-key 'help-menu "s" 'show-second-mode-key-binding) Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Wed Oct 13 16:36:04 2010 @@ -31,6 +31,7 @@ (:export :it :awhen :aif + :find-in-hash :nfuncall :pfuncall :symbol-search @@ -40,6 +41,7 @@ :remove-hook :clear-timers :add-timer + :at :with-timer :process-timers :erase-timer @@ -121,6 +123,15 @@ (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) + +(defun find-in-hash (val hashtable &optional (test #'equal)) + "Return the key associated to val in the hashtable" + (maphash #'(lambda (k v) + (when (and (consp v) (funcall test (first v) val)) + (return-from find-in-hash (values k v)))) + hashtable)) + + (defun nfuncall (function) (when function (funcall function))) @@ -193,6 +204,7 @@ (setf *timer-list* nil)) (defun add-timer (delay fun &optional (id (gensym))) + "Start the function fun at delay seconds." (push (list id (let ((time (+ (get-internal-real-time) (s->realtime delay)))) (lambda () @@ -202,7 +214,12 @@ *timer-list*) id) +(defun at (delay fun &optional (id (gensym))) + "Start the function fun at delay seconds." + (funcall #'add-timer delay fun id)) + (defmacro with-timer ((delay &optional (id (gensym))) &body body) + "Same thing as add-timer but with syntaxic sugar" `(add-timer ,delay (lambda () , at body) @@ -210,11 +227,13 @@ (defun process-timers () + "Call each timers in *timer-list* if needed" (dolist (timer *timer-list*) (when (funcall (second timer)) (setf *timer-list* (remove timer *timer-list* :test #'equal))))) (defun erase-timer (id) + "Erase the timer identified by its id" (dolist (timer *timer-list*) (when (equal id (first timer)) (setf *timer-list* (remove timer *timer-list* :test #'equal))))) Modified: clfswm/src/version.lisp ============================================================================== --- clfswm/src/version.lisp (original) +++ clfswm/src/version.lisp Wed Oct 13 16:36:04 2010 @@ -33,4 +33,4 @@ (in-package :version) -(defparameter *version* #.(concatenate 'string "Version: 1.0 built " (date-string))) +(defparameter *version* #.(concatenate 'string "Version: 10.10 built " (date-string))) From pbrochard at common-lisp.net Thu Oct 14 21:31:30 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 14 Oct 2010 17:31:30 -0400 Subject: [clfswm-cvs] r356 - clfswm/doc Message-ID: Author: pbrochard Date: Thu Oct 14 17:31:30 2010 New Revision: 356 Log: Documentation update Modified: clfswm/doc/keys.html clfswm/doc/keys.txt clfswm/doc/menu.html clfswm/doc/menu.txt Modified: clfswm/doc/keys.html ============================================================================== --- clfswm/doc/keys.html (original) +++ clfswm/doc/keys.html Thu Oct 14 17:31:30 2010 @@ -285,6 +285,17 @@ + Control + + + L2 + + + Hide/Unhide a terminal + + + + Mod-1 @@ -313,7 +324,7 @@ T - Switch to editing mode + Switch to editing mode (second mode) @@ -324,7 +335,7 @@ Less - Switch to editing mode + Switch to editing mode (second mode) Modified: clfswm/doc/keys.txt ============================================================================== --- clfswm/doc/keys.txt (original) +++ clfswm/doc/keys.txt Thu Oct 14 17:31:30 2010 @@ -29,10 +29,11 @@ Control Shift F10 Show/Hide the root frame F10 Present all windows in the current frame (An expose like) Control F10 Present all windows in all frames (An expose like) + Control L2 Hide/Unhide a terminal Mod-1 B Move the pointer to the lower right corner of the screen Control Escape Close or kill the current window (ask before doing anything) - Mod-1 T Switch to editing mode - Control Less Switch to editing mode + Mod-1 T Switch to editing mode (second mode) + Control Less Switch to editing mode (second mode) Mod-1 1 Bind or jump to a slot (a frame or a window) Mod-1 2 Bind or jump to a slot (a frame or a window) Mod-1 3 Bind or jump to a slot (a frame or a window) Modified: clfswm/doc/menu.html ============================================================================== --- clfswm/doc/menu.html (original) +++ clfswm/doc/menu.html Thu Oct 14 17:31:30 2010 @@ -55,6 +55,9 @@ Help-Menu

+ a: Show the first aid kit key binding +

+

h: Show all key binding

@@ -393,7 +396,7 @@ l: KCachegrind - Visualization of Performance Profiling Data

- m: KDE SVN Build + m: KDE Source Builder - Builds the KDE Platform and associated software from its source code. A command-line only program.

n: KImageMapEditor @@ -923,22 +926,43 @@ n: Okular

- o: OpenOffice.org 3.2 Math + o: LibreOffice 3.3 Math +

+

+ p: LibreOffice 3.3 Printer Administration +

+

+ q: LibreOffice 3.3 +

+

+ r: LibreOffice 3.3 Writer +

+

+ s: OOo4Kids 1.0 Calc +

+

+ t: OOo4Kids 1.0 Draw +

+

+ u: OOo4Kids 1.0 Impress

- p: OpenOffice.org 3.2 Printer Administration + v: OOo4Kids 1.0 Math

- q: OpenOffice.org 3.2 + w: OOo4Kids 1.0

- r: OpenOffice.org 3.2 Writer + x: OOo4Kids 1.0 Printer Administration

- s: Orage - Desktop calendar + y: OOo4Kids 1.0 Writer

- t: Xpdf - Views Adobe PDF (acrobat) files + z: Orage - Desktop calendar +

+

+ |: Xpdf - Views Adobe PDF (acrobat) files


@@ -1328,6 +1352,9 @@ |: LXTerminal - Use the command line

+ |: XMaxima - A sophisticated computer algebra system +

+

|: Mousepad - Simple text editor

@@ -2638,49 +2665,78 @@ Configuration-Menu

- a: < Expose mode group > + a: < Notify Window group >

- b: < Hook group > + b: < Notify Window mode group >

- c: < Main mode group > + c: < Expose mode group >

- d: < Frame colors group > + d: < Hook group >

- e: < Identify key group > + e: < Main mode group >

- f: < Second mode group > + f: < Frame colors group >

- g: < Corner group > + g: < Identify key group >

- h: < Query string group > + h: < Corner group >

i: < Circulate mode group >

- j: < Placement group > + j: < Query string group > +

+

+ k: < Second mode group > +

+

+ l: < Placement group >

- k: < Miscellaneous group > + m: < Miscellaneous group >

- l: < Info mode group > + n: < Info mode group >

- m: < Menu group > + o: < Menu group >

F2: Save all configuration variables in clfswmrc


+ Conf-Notify-Window-Group +

+

+ a: Configure NOTIFY-WINDOW-DELAY +

+

+ b: Configure NOTIFY-WINDOW-BORDER +

+

+ c: Configure NOTIFY-WINDOW-FOREGROUND +

+

+ d: Configure NOTIFY-WINDOW-BACKGROUND +

+
+

+ Conf-Notify-Window-Mode-Group +

+

+ a: Configure NOTIFY-WINDOW-FONT-STRING +

+
+

Conf-Expose-Mode-Group

@@ -2764,59 +2820,62 @@


- Conf-Second-Mode-Group + Conf-Corner-Group

- a: Configure SM-FOREGROUND-COLOR + a: Configure CORNER-MAIN-MODE-LEFT-BUTTON

- b: Configure SM-BACKGROUND-COLOR + b: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON

- c: Configure SM-HEIGHT + c: Configure CORNER-SECOND-MODE-LEFT-BUTTON

- d: Configure SM-WIDTH + d: Configure CORNER-MAIN-MODE-RIGHT-BUTTON

- e: Configure SM-BORDER-COLOR + e: Configure CORNER-SECOND-MODE-RIGHT-BUTTON

- f: Configure SM-FONT-STRING + f: Configure CORNER-SIZE

-
-

- Conf-Corner-Group -

- a: Configure CORNER-MAIN-MODE-LEFT-BUTTON + g: Configure CLFSWM-TERMINAL-CMD

- b: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON + h: Configure VIRTUAL-KEYBOARD-CMD

- c: Configure CORNER-SECOND-MODE-LEFT-BUTTON + i: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON

- d: Configure CORNER-MAIN-MODE-RIGHT-BUTTON + j: Configure CLFSWM-TERMINAL-NAME

+
+

+ Conf-Circulate-Mode-Group +

- e: Configure CORNER-SECOND-MODE-RIGHT-BUTTON + a: Configure CIRCULATE-WIDTH

- f: Configure CORNER-SIZE + b: Configure CIRCULATE-BORDER

- g: Configure CLFSWM-TERMINAL-CMD + c: Configure CIRCULATE-HEIGHT

- h: Configure VIRTUAL-KEYBOARD-CMD + d: Configure CIRCULATE-TEXT-LIMITE

- i: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON + e: Configure CIRCULATE-FONT-STRING

- j: Configure CLFSWM-TERMINAL-NAME + f: Configure CIRCULATE-BACKGROUND +

+

+ g: Configure CIRCULATE-FOREGROUND


@@ -2829,35 +2888,44 @@ b: Configure QUERY-FONT-STRING

- c: Configure QUERY-BORDER + c: Configure QUERY-PARENT-COLOR

- d: Configure QUERY-FOREGROUND + d: Configure QUERY-BORDER +

+

+ e: Configure QUERY-MESSAGE-COLOR +

+

+ f: Configure QUERY-PARENT-ERROR-COLOR +

+

+ g: Configure QUERY-FOREGROUND +

+

+ h: Configure QUERY-CURSOR-COLOR


- Conf-Circulate-Mode-Group + Conf-Second-Mode-Group

- a: Configure CIRCULATE-WIDTH -

-

- b: Configure CIRCULATE-BORDER + a: Configure SM-FOREGROUND-COLOR

- c: Configure CIRCULATE-HEIGHT + b: Configure SM-BACKGROUND-COLOR

- d: Configure CIRCULATE-TEXT-LIMITE + c: Configure SM-HEIGHT

- e: Configure CIRCULATE-FONT-STRING + d: Configure SM-WIDTH

- f: Configure CIRCULATE-BACKGROUND + e: Configure SM-BORDER-COLOR

- g: Configure CIRCULATE-FOREGROUND + f: Configure SM-FONT-STRING


@@ -2867,19 +2935,22 @@ a: Configure CIRCULATE-MODE-PLACEMENT

- b: Configure QUERY-MODE-PLACEMENT + b: Configure NOTIFY-WINDOW-PLACEMENT +

+

+ c: Configure QUERY-MODE-PLACEMENT

- c: Configure BANISH-POINTER-PLACEMENT + d: Configure BANISH-POINTER-PLACEMENT

- d: Configure EXPOSE-MODE-PLACEMENT + e: Configure EXPOSE-MODE-PLACEMENT

- e: Configure INFO-MODE-PLACEMENT + f: Configure INFO-MODE-PLACEMENT

- f: Configure SECOND-MODE-PLACEMENT + g: Configure SECOND-MODE-PLACEMENT


@@ -2889,13 +2960,13 @@ a: Configure HAVE-TO-COMPRESS-NOTIFY

- b: Configure HIDE-UNMANAGED-WINDOW + b: Configure DEFAULT-WINDOW-WIDTH

- c: Configure DEFAULT-WINDOW-WIDTH + c: Configure CREATE-FRAME-ON-ROOT

- d: Configure CREATE-FRAME-ON-ROOT + d: Configure HIDE-UNMANAGED-WINDOW

e: Configure DEFAULT-FRAME-DATA Modified: clfswm/doc/menu.txt ============================================================================== --- clfswm/doc/menu.txt (original) +++ clfswm/doc/menu.txt Thu Oct 14 17:31:30 2010 @@ -15,6 +15,7 @@ m: < CLFSWM menu > Help-Menu +a: Show the first aid kit key binding h: Show all key binding b: Show the main mode binding s: Show the second mode key binding @@ -133,7 +134,7 @@ j: KAppTemplate k: KBugBuster l: KCachegrind - Visualization of Performance Profiling Data -m: KDE SVN Build +m: KDE Source Builder - Builds the KDE Platform and associated software from its source code. A command-line only program. n: KImageMapEditor o: KLinkStatus p: Kompare @@ -313,12 +314,19 @@ l: KWord - Write text documents m: Lokalize n: Okular -o: OpenOffice.org 3.2 Math -p: OpenOffice.org 3.2 Printer Administration -q: OpenOffice.org 3.2 -r: OpenOffice.org 3.2 Writer -s: Orage - Desktop calendar -t: Xpdf - Views Adobe PDF (acrobat) files +o: LibreOffice 3.3 Math +p: LibreOffice 3.3 Printer Administration +q: LibreOffice 3.3 +r: LibreOffice 3.3 Writer +s: OOo4Kids 1.0 Calc +t: OOo4Kids 1.0 Draw +u: OOo4Kids 1.0 Impress +v: OOo4Kids 1.0 Math +w: OOo4Kids 1.0 +x: OOo4Kids 1.0 Printer Administration +y: OOo4Kids 1.0 Writer +z: Orage - Desktop calendar +|: Xpdf - Views Adobe PDF (acrobat) files Settings a: Assistive Technologies - Choose which accessibility features to enable when you log in @@ -450,6 +458,7 @@ |: SuperKaramba - An engine for cool desktop eyecandy. |: Sweeper |: LXTerminal - Use the command line +|: XMaxima - A sophisticated computer algebra system |: Mousepad - Simple text editor |: File Browser - Browse the file system with the file manager |: Computer - Browse all local and remote disks and folders accessible from this computer @@ -906,21 +915,32 @@ p: Prompt for an other window manager Configuration-Menu -a: < Expose mode group > -b: < Hook group > -c: < Main mode group > -d: < Frame colors group > -e: < Identify key group > -f: < Second mode group > -g: < Corner group > -h: < Query string group > +a: < Notify Window group > +b: < Notify Window mode group > +c: < Expose mode group > +d: < Hook group > +e: < Main mode group > +f: < Frame colors group > +g: < Identify key group > +h: < Corner group > i: < Circulate mode group > -j: < Placement group > -k: < Miscellaneous group > -l: < Info mode group > -m: < Menu group > +j: < Query string group > +k: < Second mode group > +l: < Placement group > +m: < Miscellaneous group > +n: < Info mode group > +o: < Menu group > F2: Save all configuration variables in clfswmrc +Conf-Notify-Window-Group +a: Configure NOTIFY-WINDOW-DELAY +b: Configure NOTIFY-WINDOW-BORDER +c: Configure NOTIFY-WINDOW-FOREGROUND +d: Configure NOTIFY-WINDOW-BACKGROUND + +Conf-Notify-Window-Mode-Group +a: Configure NOTIFY-WINDOW-FONT-STRING + Conf-Expose-Mode-Group a: Configure EXPOSE-FOREGROUND b: Configure EXPOSE-SHOW-WINDOW-TITLE @@ -952,14 +972,6 @@ c: Configure IDENTIFY-BORDER d: Configure IDENTIFY-BACKGROUND -Conf-Second-Mode-Group -a: Configure SM-FOREGROUND-COLOR -b: Configure SM-BACKGROUND-COLOR -c: Configure SM-HEIGHT -d: Configure SM-WIDTH -e: Configure SM-BORDER-COLOR -f: Configure SM-FONT-STRING - Conf-Corner-Group a: Configure CORNER-MAIN-MODE-LEFT-BUTTON b: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON @@ -972,12 +984,6 @@ i: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON j: Configure CLFSWM-TERMINAL-NAME -Conf-Query-String-Group -a: Configure QUERY-BACKGROUND -b: Configure QUERY-FONT-STRING -c: Configure QUERY-BORDER -d: Configure QUERY-FOREGROUND - Conf-Circulate-Mode-Group a: Configure CIRCULATE-WIDTH b: Configure CIRCULATE-BORDER @@ -987,19 +993,38 @@ f: Configure CIRCULATE-BACKGROUND g: Configure CIRCULATE-FOREGROUND +Conf-Query-String-Group +a: Configure QUERY-BACKGROUND +b: Configure QUERY-FONT-STRING +c: Configure QUERY-PARENT-COLOR +d: Configure QUERY-BORDER +e: Configure QUERY-MESSAGE-COLOR +f: Configure QUERY-PARENT-ERROR-COLOR +g: Configure QUERY-FOREGROUND +h: Configure QUERY-CURSOR-COLOR + +Conf-Second-Mode-Group +a: Configure SM-FOREGROUND-COLOR +b: Configure SM-BACKGROUND-COLOR +c: Configure SM-HEIGHT +d: Configure SM-WIDTH +e: Configure SM-BORDER-COLOR +f: Configure SM-FONT-STRING + Conf-Placement-Group a: Configure CIRCULATE-MODE-PLACEMENT -b: Configure QUERY-MODE-PLACEMENT -c: Configure BANISH-POINTER-PLACEMENT -d: Configure EXPOSE-MODE-PLACEMENT -e: Configure INFO-MODE-PLACEMENT -f: Configure SECOND-MODE-PLACEMENT +b: Configure NOTIFY-WINDOW-PLACEMENT +c: Configure QUERY-MODE-PLACEMENT +d: Configure BANISH-POINTER-PLACEMENT +e: Configure EXPOSE-MODE-PLACEMENT +f: Configure INFO-MODE-PLACEMENT +g: Configure SECOND-MODE-PLACEMENT Conf-Miscellaneous-Group a: Configure HAVE-TO-COMPRESS-NOTIFY -b: Configure HIDE-UNMANAGED-WINDOW -c: Configure DEFAULT-WINDOW-WIDTH -d: Configure CREATE-FRAME-ON-ROOT +b: Configure DEFAULT-WINDOW-WIDTH +c: Configure CREATE-FRAME-ON-ROOT +d: Configure HIDE-UNMANAGED-WINDOW e: Configure DEFAULT-FRAME-DATA f: Configure DEFAULT-MODIFIERS g: Configure NEVER-MANAGED-WINDOW-LIST From pbrochard at common-lisp.net Thu Oct 21 07:42:16 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 21 Oct 2010 03:42:16 -0400 Subject: [clfswm-cvs] r357 - in clfswm: . contrib src Message-ID: Author: pbrochard Date: Thu Oct 21 03:42:15 2010 New Revision: 357 Log: contrib/osd.lisp: New file: OSD (On Screen Display) for presentations. src/clfswm-menu.lisp (open-menu): Modularise function. Added: clfswm/contrib/osd.lisp Modified: clfswm/ChangeLog clfswm/src/clfswm-menu.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Oct 21 03:42:15 2010 @@ -1,3 +1,10 @@ +2010-10-21 Philippe Brochard + + * contrib/osd.lisp: New file: OSD (On Screen Display) for + presentations. + + * src/clfswm-menu.lisp (open-menu): Modularise function. + 2010-10-13 Philippe Brochard * src/clfswm-info.lisp (show-first-aid-kit): Display the essential Added: clfswm/contrib/osd.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/osd.lisp Thu Oct 21 03:42:15 2010 @@ -0,0 +1,81 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: OSD (On Screen Display) for presentations. +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2010 Philippe Brochard +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;; +;;; -------------------------------------------------------------------------- + +(in-package :clfswm) + + +;;; A more complex example I use to record my desktop and show +;;; documentation associated to each key press. +(defun display-doc (function code state) + (let* ((modifiers (state->modifiers state)) + (keysym (keysym->keysym-name (xlib:keycode->keysym *display* code 0)))) + (do-shell "pkill osd_cat") + (do-shell (format nil "echo '~A~A' | osd_cat -d 3 -p bottom -c white -o -50 -f -*-fixed-*-*-*-*-14-*-*-*-*-*-*-1" + (if keysym + (format nil "~:(~{~A+~}~A~)" modifiers keysym) + "Menu") + (aif (documentation (first function) 'function) + (format nil ": ~A" it) ""))) + (force-output))) + + +(defun funcall-key-from-code (hash-table-key code state &rest args) + (let ((function (find-key-from-code hash-table-key code state))) + (when function + (display-doc function code state) + (apply (first function) (append args (second function))) + t))) + +;;; CONFIG - Screen size +(defun get-fullscreen-size () + "Return the size of root child (values rx ry rw rh) +You can tweak this to what you want" + (values -2 -2 (+ (xlib:screen-width *screen*) 2) (- (xlib:screen-height *screen*) 25))) + + +;;; Display menu functions + +(defun open-menu-do-action (action menu parent) + (typecase action + (menu (open-menu action (cons menu parent))) + (null (awhen (first parent) + (open-menu it (rest parent)))) + (t (when (fboundp action) + (display-doc (list action) 0 0) + (funcall action))))) + + +(defun bottom-left-placement (&optional (width 0) (height 0)) + (declare (ignore width)) + (values 0 + (- (xlib:screen-height *screen*) height 26))) + +(defun bottom-middle-placement (&optional (width 0) (height 0)) + (values (truncate (/ (- (xlib:screen-width *screen*) width) 2)) + (- (xlib:screen-height *screen*) height 26))) + +(defun bottom-right-placement (&optional (width 0) (height 0)) + (values (- (xlib:screen-width *screen*) width 1) + (- (xlib:screen-height *screen*) height 26))) Modified: clfswm/src/clfswm-menu.lisp ============================================================================== --- clfswm/src/clfswm-menu.lisp (original) +++ clfswm/src/clfswm-menu.lisp Thu Oct 21 03:42:15 2010 @@ -125,38 +125,43 @@ (setf *menu* (make-menu :name 'main :doc "Main menu"))) - ;;; Display menu functions +(defun open-menu-do-action (action menu parent) + (typecase action + (menu (open-menu action (cons menu parent))) + (null (awhen (first parent) + (open-menu it (rest parent)))) + (t (when (fboundp action) + (funcall action))))) + + (defun open-menu (&optional (menu *menu*) (parent nil)) "Open the main menu" - (let ((info-list nil) - (action nil)) - (dolist (item (menu-item menu)) - (let ((value (menu-item-value item))) - (push (typecase value - (menu (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*) - (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*))) - (string (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*))) - (t (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*) - (format nil ": ~A" (documentation value 'function))))) - info-list) - (when (menu-item-key item) - (define-info-key-fun (list (menu-item-key item)) - (lambda (&optional args) - (declare (ignore args)) - (setf action value) - (leave-info-mode nil)))))) - (let ((selected-item (info-mode (nreverse info-list)))) - (dolist (item (menu-item menu)) - (undefine-info-key-fun (list (menu-item-key item)))) - (when selected-item - (awhen (nth selected-item (menu-item menu)) - (setf action (menu-item-value it)))) - (typecase action - (menu (open-menu action (cons menu parent))) - (null (awhen (first parent) - (open-menu it (rest parent)))) - (t (when (fboundp action) - (funcall action))))))) + (let ((action nil)) + (labels ((populate-menu () + (let ((info-list nil)) + (dolist (item (menu-item menu)) + (let ((value (menu-item-value item))) + (push (typecase value + (menu (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*) + (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*))) + (string (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*))) + (t (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*) + (format nil ": ~A" (documentation value 'function))))) + info-list) + (when (menu-item-key item) + (define-info-key-fun (list (menu-item-key item)) + (lambda (&optional args) + (declare (ignore args)) + (setf action value) + (leave-info-mode nil)))))) + (nreverse info-list)))) + (let ((selected-item (info-mode (populate-menu)))) + (dolist (item (menu-item menu)) + (undefine-info-key-fun (list (menu-item-key item)))) + (when selected-item + (awhen (nth selected-item (menu-item menu)) + (setf action (menu-item-value it))))) + (open-menu-do-action action menu parent)))) From pbrochard at common-lisp.net Sat Oct 23 20:02:15 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 23 Oct 2010 16:02:15 -0400 Subject: [clfswm-cvs] r358 - in clfswm: . contrib src Message-ID: Author: pbrochard Date: Sat Oct 23 16:02:14 2010 New Revision: 358 Log: src/clfswm-keys.lisp (binding-substitute-modifier): Utility to change modifiers after binding definition. Modified: clfswm/ChangeLog clfswm/contrib/keyb_fr.lisp clfswm/contrib/osd.lisp clfswm/src/clfswm-keys.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 23 16:02:14 2010 @@ -1,3 +1,8 @@ +2010-10-23 Philippe Brochard + + * src/clfswm-keys.lisp (binding-substitute-modifier): Utility to + change modifiers after binding definition. + 2010-10-21 Philippe Brochard * contrib/osd.lisp: New file: OSD (On Screen Display) for Modified: clfswm/contrib/keyb_fr.lisp ============================================================================== --- clfswm/contrib/keyb_fr.lisp (original) +++ clfswm/contrib/keyb_fr.lisp Sat Oct 23 16:02:14 2010 @@ -2,7 +2,7 @@ ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- -;;; Documentation: Music Player Daemon (MPD) interface +;;; Documentation: Define some keybindings for an azerty french keyboard ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2009 Philippe Brochard Modified: clfswm/contrib/osd.lisp ============================================================================== --- clfswm/contrib/osd.lisp (original) +++ clfswm/contrib/osd.lisp Sat Oct 23 16:02:14 2010 @@ -56,7 +56,6 @@ ;;; Display menu functions - (defun open-menu-do-action (action menu parent) (typecase action (menu (open-menu action (cons menu parent))) Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Sat Oct 23 16:02:14 2010 @@ -232,3 +232,19 @@ +(defun binding-substitute-modifier (to from &optional (hashtables (list *main-keys* *main-mouse* + *second-keys* *second-mouse* + *info-keys* *info-mouse* + *query-keys* + *circulate-keys* *circulate-keys-release* + *expose-keys* *expose-mouse*))) + "Utility to change modifiers after binding definition" + (labels ((change (&optional (hashtable *main-keys*) to from) + (maphash (lambda (k v) + (when (consp k) + (let ((state (modifiers->state (substitute to from (state->modifiers (second k)))))) + (remhash k hashtable) + (setf (gethash (list (first k) state) hashtable) v)))) + hashtable))) + (dolist (h hashtables) + (change h to from)))) From pbrochard at common-lisp.net Sat Oct 23 21:05:44 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 23 Oct 2010 17:05:44 -0400 Subject: [clfswm-cvs] r359 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 23 17:05:44 2010 New Revision: 359 Log: src/clfswm-internal.lisp (show-child): Show window only if not hidden. Modified: clfswm/ChangeLog clfswm/src/clfswm-internal.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 23 17:05:44 2010 @@ -1,5 +1,8 @@ 2010-10-23 Philippe Brochard + * src/clfswm-internal.lisp (show-child): Show window only if not + hidden. + * src/clfswm-keys.lisp (binding-substitute-modifier): Utility to change modifiers after binding definition. Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sat Oct 23 17:05:44 2010 @@ -580,8 +580,9 @@ (if show-window-p (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*))) (map-window window) - (when raise-p (raise-window window)) - (display-frame-info frame)) + (when raise-p + (raise-window window) + (display-frame-info frame))) (hide-window window)))) @@ -595,12 +596,13 @@ (defmethod show-child ((window xlib:window) parent raise-p) - (if (or (managed-window-p window parent) - (not (hide-unmanager-window-p parent)) - (child-equal-p parent *current-child*)) + (if (and raise-p + (or (managed-window-p window parent) + (not (hide-unmanager-window-p parent)) + (child-equal-p parent *current-child*))) (progn (map-window window) - (when raise-p (raise-window window))) + (raise-window window)) (hide-window window))) (defmethod show-child (child parent raise-p) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sat Oct 23 17:05:44 2010 @@ -232,6 +232,7 @@ (xlib:display-finish-output *display*)) + (defun map-window (window) (when window (xlib:map-window window) From pbrochard at common-lisp.net Sat Oct 23 21:51:20 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 23 Oct 2010 17:51:20 -0400 Subject: [clfswm-cvs] r360 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 23 17:51:20 2010 New Revision: 360 Log: * src/xlib-util.lisp: Remove unnecessary xlib:display-finish-output. Modified: clfswm/ChangeLog clfswm/src/clfswm-internal.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 23 17:51:20 2010 @@ -1,5 +1,7 @@ 2010-10-23 Philippe Brochard + * src/xlib-util.lisp: Remove unnecessary xlib:display-finish-output. + * src/clfswm-internal.lisp (show-child): Show window only if not hidden. Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sat Oct 23 17:51:20 2010 @@ -581,8 +581,8 @@ (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*))) (map-window window) (when raise-p - (raise-window window) - (display-frame-info frame))) + (raise-window window)) + (display-frame-info frame)) (hide-window window)))) @@ -596,13 +596,13 @@ (defmethod show-child ((window xlib:window) parent raise-p) - (if (and raise-p - (or (managed-window-p window parent) - (not (hide-unmanager-window-p parent)) - (child-equal-p parent *current-child*))) + (if (or (managed-window-p window parent) + (not (hide-unmanager-window-p parent)) + (child-equal-p parent *current-child*)) (progn (map-window window) - (raise-window window)) + (when raise-p + (raise-window window))) (hide-window window))) (defmethod show-child (child parent raise-p) Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sat Oct 23 17:51:20 2010 @@ -228,27 +228,20 @@ (when (window-hidden-p window) (xlib:map-window window) (setf (window-state window) +normal-state+ - (xlib:window-event-mask window) *window-events*))) - (xlib:display-finish-output *display*)) - + (xlib:window-event-mask window) *window-events*)))) (defun map-window (window) (when window - (xlib:map-window window) - (xlib:display-finish-output *display*))) + (xlib:map-window window))) + (defun delete-window (window) (send-client-message window :WM_PROTOCOLS - (xlib:intern-atom *display* "WM_DELETE_WINDOW")) - (xlib:display-finish-output *display*)) + (xlib:intern-atom *display* "WM_DELETE_WINDOW"))) (defun destroy-window (window) - (xlib:kill-client *display* (xlib:window-id window)) - (xlib:display-finish-output *display*)) - - - + (xlib:kill-client *display* (xlib:window-id window))) @@ -343,8 +336,7 @@ (setf (window-state window) +iconic-state+ (xlib:window-event-mask window) (remove :structure-notify *window-events*)) (xlib:unmap-window window) - (setf (xlib:window-event-mask window) *window-events*)) - (xlib:display-finish-output *display*)) + (setf (xlib:window-event-mask window) *window-events*))) @@ -402,25 +394,17 @@ (when window (when (window-hidden-p window) (unhide-window window)) - (setf (xlib:window-priority window) :top-if)) - (xlib:display-finish-output *display*)) + (setf (xlib:window-priority window) :top-if))) (defun focus-window (window) "Give the window focus." (when window - (xlib:set-input-focus *display* window :parent)) - (xlib:display-finish-output *display*)) - - - - - + (xlib:set-input-focus *display* window :parent))) (defun no-focus () "don't focus any window but still read keyboard events." - (xlib:set-input-focus *display* *no-focus-window* :pointer-root) - (xlib:display-finish-output *display*)) + (xlib:set-input-focus *display* *no-focus-window* :pointer-root)) From pbrochard at common-lisp.net Mon Oct 25 22:00:48 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 25 Oct 2010 18:00:48 -0400 Subject: [clfswm-cvs] r361 - in clfswm: . contrib contrib/server src Message-ID: Author: pbrochard Date: Mon Oct 25 18:00:48 2010 New Revision: 361 Log: contrib/server/server.lisp: Load clfswm client code in the main program and let the user start it with a --client command line option. * src/package.lisp (*main-entrance-hook*): New hook executed after loading configuration file and before opening the display. Modified: clfswm/ChangeLog clfswm/contrib/clfswm clfswm/contrib/server/clfswm-client.asd clfswm/contrib/server/clfswm-client.lisp clfswm/contrib/server/server.lisp clfswm/contrib/server/util-server.asd clfswm/load.lisp clfswm/src/clfswm.lisp clfswm/src/package.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Mon Oct 25 18:00:48 2010 @@ -1,3 +1,12 @@ +2010-10-25 Philippe Brochard + + * contrib/server/server.lisp: Load clfswm client code in the main + program and let the user start it with a --client command line + option. + + * src/package.lisp (*main-entrance-hook*): New hook executed after + loading configuration file and before opening the display. + 2010-10-23 Philippe Brochard * src/xlib-util.lisp: Remove unnecessary xlib:display-finish-output. Modified: clfswm/contrib/clfswm ============================================================================== --- clfswm/contrib/clfswm (original) +++ clfswm/contrib/clfswm Mon Oct 25 18:00:48 2010 @@ -137,8 +137,10 @@ --) shift break ;; - *) + -h|--help) usage ;; + *) + ARGS="$ARGS $1" ;; esac shift done @@ -188,18 +190,21 @@ rm -rf $(find "$dump_path/" -name "*svn") rm -rf "$tmp_dir"/clfswm-tmp + + echo "CLFSWM image is: $dump_image" fi # Run the resulting image if test no = "$no_start" then cd "$dump_path" + echo "Arguments: $* and $ARGS" case $lisp in - clisp ) "$dump_image" ;; - sbcl ) exec sbcl --core "$dump_image" ;; - cmucl ) exec cmucl -core "$dump_image" ;; - ccl ) exec ccl -I "$dump_image" ;; - ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" ;; + clisp ) "$dump_image" -- $ARGS ;; + sbcl ) exec sbcl --core "$dump_image" $ARGS ;; + cmucl ) exec cmucl -core "$dump_image" $ARGS ;; + ccl ) exec ccl -I "$dump_image" -- $ARGS ;; + ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" $ARGS ;; *) echo "..." ;; esac else Modified: clfswm/contrib/server/clfswm-client.asd ============================================================================== --- clfswm/contrib/server/clfswm-client.asd (original) +++ clfswm/contrib/server/clfswm-client.asd Mon Oct 25 18:00:48 2010 @@ -7,14 +7,12 @@ (defsystem clfswm-client :description "" :licence "GNU Lesser General Public License (LGPL)" - :components ((:file "clfswm-client")) - :depends-on (util-server)) - - - - - - - + :components ((:file "md5") + (:file "net") + (:file "crypt") + (:file "key" + :depends-on ("crypt")) + (:file "clfswm-client" + :depends-on ("md5" "net" "crypt" "key")))) Modified: clfswm/contrib/server/clfswm-client.lisp ============================================================================== --- clfswm/contrib/server/clfswm-client.lisp (original) +++ clfswm/contrib/server/clfswm-client.lisp Mon Oct 25 18:00:48 2010 @@ -1,22 +1,11 @@ (in-package :common-lisp-user) (defpackage :clfswm-client - (:use :common-lisp :crypt)) + (:use :common-lisp :crypt) + (:export :start-client)) (in-package :clfswm-client) -(defun args () - #+sbcl (cdr sb-ext:*posix-argv*) - #+(or clozure ccl) (cddddr (ccl::command-line-arguments)) - #+gcl (cdr si:*command-args*) - #+ecl (loop for i from 1 below (si:argc) collect (si:argv i)) - #+cmu (cdddr extensions:*command-line-strings*) - #+allegro (cdr (sys:command-line-arguments)) - #+lispworks (cdr sys:*line-arguments-list*) - #+clisp ext:*args* - #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp) - (error "get-command-line-arguments not supported for your implementation")) - (defun uquit () #+(or clisp cmu) (ext:quit) #+sbcl (sb-ext:quit) @@ -27,7 +16,6 @@ #+ccl (ccl:quit)) - (defparameter *server-port* 33333) (defun print-output (sock &optional wait) @@ -61,7 +49,7 @@ (parse-args sock (subseq args pos)))))) -(defun start-client (&optional (url "127.0.0.1") (port *server-port*)) +(defun start-client (args &optional (url "127.0.0.1") (port *server-port*)) (load-new-key) (let* ((sock (port:open-socket url port)) (key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*)))) @@ -69,7 +57,7 @@ (write-line (crypt (format nil "~A~A" *key* (md5:md5 *key*)) *key*) sock) (force-output sock) (print-output sock t) - (dolist (a (args)) + (dolist (a args) (parse-args sock a)) (loop (print-output sock) @@ -77,5 +65,6 @@ (let ((line (read-line))) (write-line (crypt line *key*) sock) (force-output sock) - (quit-on-command line sock)))))) + (quit-on-command line sock))) + (sleep 0.01)))) Modified: clfswm/contrib/server/server.lisp ============================================================================== --- clfswm/contrib/server/server.lisp (original) +++ clfswm/contrib/server/server.lisp Mon Oct 25 18:00:48 2010 @@ -37,7 +37,7 @@ (dbg asdf:*central-registry*) -(asdf:oos 'asdf:load-op :util-server) +(asdf:oos 'asdf:load-op :clfswm-client) (in-package :clfswm) @@ -234,13 +234,13 @@ (defun start-server (&optional port) - (save-new-key) (when port (setf *server-port* port)) (setf *server-socket* (port:open-socket-server *server-port*)) (add-hook *loop-hook* 'handle-server) (format t "*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%" - *server-port* *server-allowed-host*)) + *server-port* *server-allowed-host*) + (save-new-key)) @@ -248,11 +248,17 @@ (format t "done. You can now start a clfswm server with the command (start-server &optional port). -Only [~{~A~^, ~}] ~A allowed to login on the server~%" +Only [~{~A~^, ~}] ~A allowed to login on the server. +You can start the client with the '--client' command line option.~%" *server-allowed-host* (if (or (null *server-allowed-host*) (= (length *server-allowed-host*) 1)) "is" "are")) +(defun server-parse-cmdline () + (let ((args (get-command-line-words))) + (when (member "--client" args :test #'string-equal) + (clfswm-client:start-client (remove "--client" args :test #'string-equal)) + (uquit)))) - +(add-hook *main-entrance-hook* 'server-parse-cmdline) Modified: clfswm/contrib/server/util-server.asd ============================================================================== --- clfswm/contrib/server/util-server.asd (original) +++ clfswm/contrib/server/util-server.asd Mon Oct 25 18:00:48 2010 @@ -4,14 +4,16 @@ (in-package #:asdf) -(defsystem util-server +(defsystem clfswm-client :description "" :licence "GNU Lesser General Public License (LGPL)" :components ((:file "md5") (:file "net") (:file "crypt") (:file "key" - :depends-on ("crypt")))) + :depends-on ("crypt")) + (:file "clfswm-client" + :depends-on ("md5" "net" "crypt" "key")))) Modified: clfswm/load.lisp ============================================================================== --- clfswm/load.lisp (original) +++ clfswm/load.lisp Mon Oct 25 18:00:48 2010 @@ -57,8 +57,8 @@ (in-package :clfswm) -(ignore-errors - (main :read-conf-file-p t)) +;;(ignore-errors + (main :read-conf-file-p t);) ;;;; Uncomment lines above to save the default documentation. Modified: clfswm/src/clfswm.lisp ============================================================================== --- clfswm/src/clfswm.lisp (original) +++ clfswm/src/clfswm.lisp Mon Oct 25 18:00:48 2010 @@ -248,6 +248,7 @@ (conf-file-name alternate-conf) (when read-conf-file-p (read-conf-file)) + (call-hook *main-entrance-hook*) (handler-case (open-display display protocol) (xlib:access-error (c) @@ -276,6 +277,7 @@ (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))) + (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol (base-dir (directory-namestring (or *load-truename* ""))) (read-conf-file-p t) Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Mon Oct 25 18:00:48 2010 @@ -183,6 +183,10 @@ (defparameter *loop-hook* nil "Config(Hook group): Hook executed on each event loop") +(defparameter *main-entrance-hook* nil + "Config(Hook group): Hook executed on the main function entrance after +loading configuration file and before opening the display.") + (defparameter *in-second-mode* nil) Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Mon Oct 25 18:00:48 2010 @@ -717,9 +717,17 @@ (defun get-command-line-words () - #+CLISP ext:*args* - #+CMU (nthcdr 3 extensions:*command-line-strings*) - #+SBCL sb-ext:*posix-argv*) + #+sbcl (cdr sb-ext:*posix-argv*) + #+(or clozure ccl) (cddddr (ccl::command-line-arguments)) + #+gcl (cdr si:*command-args*) + #+ecl (loop for i from 1 below (si:argc) collect (si:argv i)) + #+cmu (cdddr extensions:*command-line-strings*) + #+allegro (cdr (sys:command-line-arguments)) + #+lispworks (cdr sys:*line-arguments-list*) + #+clisp ext:*args* + #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp) + (error "get-command-line-arguments not supported for your implementation")) + From pbrochard at common-lisp.net Mon Oct 25 22:16:26 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 25 Oct 2010 18:16:26 -0400 Subject: [clfswm-cvs] r362 - clfswm Message-ID: Author: pbrochard Date: Mon Oct 25 18:16:25 2010 New Revision: 362 Log: TODO update Modified: clfswm/TODO Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Mon Oct 25 18:16:25 2010 @@ -7,7 +7,10 @@ =============== Should handle these soon. -- nothing here :) +- remove uneeded files in contrib/server +- handle cursor with too long lines in info mode +- info mode: complet on [tab] without living the info mode. + MAYBE ===== From pbrochard at common-lisp.net Wed Oct 27 07:31:36 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 27 Oct 2010 03:31:36 -0400 Subject: [clfswm-cvs] r363 - in clfswm: . src Message-ID: Author: pbrochard Date: Wed Oct 27 03:31:35 2010 New Revision: 363 Log: src/clfswm-expose-mode.lisp (expose-create-window): Ensure that all characters are printable. Modified: clfswm/ChangeLog clfswm/src/clfswm-expose-mode.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Oct 27 03:31:35 2010 @@ -1,3 +1,8 @@ +2010-10-27 Philippe Brochard + + * src/clfswm-expose-mode.lisp (expose-create-window): Ensure that + all characters are printable. + 2010-10-25 Philippe Brochard * contrib/server/server.lisp: Load clfswm client code in the main Modified: clfswm/src/clfswm-expose-mode.lisp ============================================================================== --- clfswm/src/clfswm-expose-mode.lisp (original) +++ clfswm/src/clfswm-expose-mode.lisp Wed Oct 27 03:31:35 2010 @@ -107,7 +107,7 @@ (let* ((*current-child* child) (string (format nil "~A~A" (number->char n) (if *expose-show-window-title* - (format nil " - ~A" (child-fullname child)) + (format nil " - ~A" (ensure-printable (child-fullname child))) ""))) (width (if *expose-show-window-title* (min (* (xlib:max-char-width *expose-font*) (+ (length string) 2)) From pbrochard at common-lisp.net Wed Oct 27 20:00:23 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 27 Oct 2010 16:00:23 -0400 Subject: [clfswm-cvs] r364 - clfswm/contrib/server Message-ID: Author: pbrochard Date: Wed Oct 27 16:00:22 2010 New Revision: 364 Log: FIle test Added: clfswm/contrib/server/test Added: clfswm/contrib/server/test ============================================================================== From pbrochard at common-lisp.net Wed Oct 27 20:02:58 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 27 Oct 2010 16:02:58 -0400 Subject: [clfswm-cvs] r365 - clfswm/contrib/server Message-ID: Author: pbrochard Date: Wed Oct 27 16:02:58 2010 New Revision: 365 Log: File suppression test Removed: clfswm/contrib/server/test From pbrochard at common-lisp.net Wed Oct 27 20:06:58 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 27 Oct 2010 16:06:58 -0400 Subject: [clfswm-cvs] r366 - clfswm/contrib/server Message-ID: Author: pbrochard Date: Wed Oct 27 16:06:58 2010 New Revision: 366 Log: Remove uneeded files Removed: clfswm/contrib/server/Makefile From pbrochard at common-lisp.net Wed Oct 27 20:15:13 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 27 Oct 2010 16:15:13 -0400 Subject: [clfswm-cvs] r367 - in clfswm: . contrib/server Message-ID: Author: pbrochard Date: Wed Oct 27 16:15:13 2010 New Revision: 367 Log: contrib/server: Remove uneeded files Removed: clfswm/contrib/server/Makefile.template clfswm/contrib/server/configure clfswm/contrib/server/test.sh clfswm/contrib/server/test2.sh clfswm/contrib/server/util-server.asd Modified: clfswm/TODO clfswm/contrib/server/load.lisp Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Wed Oct 27 16:15:13 2010 @@ -7,7 +7,6 @@ =============== Should handle these soon. -- remove uneeded files in contrib/server - handle cursor with too long lines in info mode - info mode: complet on [tab] without living the info mode. Modified: clfswm/contrib/server/load.lisp ============================================================================== --- clfswm/contrib/server/load.lisp (original) +++ clfswm/contrib/server/load.lisp Wed Oct 27 16:15:13 2010 @@ -54,6 +54,5 @@ (in-package :clfswm-client) -#-BUILD -(start-client) +(start-client nil) From pbrochard at common-lisp.net Wed Oct 27 20:16:23 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 27 Oct 2010 16:16:23 -0400 Subject: [clfswm-cvs] r368 - clfswm/contrib/server Message-ID: Author: pbrochard Date: Wed Oct 27 16:16:23 2010 New Revision: 368 Log: contrib/server: add a test file Added: clfswm/contrib/server/test.lisp (contents, props changed) Added: clfswm/contrib/server/test.lisp ============================================================================== --- (empty file) +++ clfswm/contrib/server/test.lisp Wed Oct 27 16:16:23 2010 @@ -0,0 +1,15 @@ +(in-package :clfswm) + +(leave-frame) +(select-previous-level) + +(let ((frame (create-frame \:name \"Test root\" \:x 0.05 \:y 0.05))) + (add-frame frame *current-child*) + (add-frame (create-frame \:name \"Test 1\" \:x 0.3 \:y 0 \:w 0.7 \:h 1) frame) + (add-frame (create-frame \:name \"Test 2\" \:x 0 \:y 0 \:w 0.3 \:h 1) frame) + (setf *current-child* (first (frame-child frame)))) + +(show-all-children *current-root*) + + + From pbrochard at common-lisp.net Thu Oct 28 11:01:28 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 28 Oct 2010 07:01:28 -0400 Subject: [clfswm-cvs] r369 - clfswm Message-ID: Author: pbrochard Date: Thu Oct 28 07:01:27 2010 New Revision: 369 Log: Add CLX as system dependency Modified: clfswm/TODO clfswm/clfswm.asd Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Thu Oct 28 07:01:27 2010 @@ -16,23 +16,26 @@ - cd/pwd a la shell to navigate through frames. -- Zoom: +- Switch to a reparenting window manager to prevent remaining flickering. -Concept: - * zoom out: Behave as if the application window is bigger for the application but completely drawn in a small amount of space (miniature). The zoom factor is inferior to 100% - * zoom in: Behave as a magnifying glass. The zoom factor is superior to 100%. The part of the application window shown (viewport) can be moved. - -Operation: - * set-zoom-factor (frame, factor) - * move-viewport (frame &optional (increment 1)) - * left - * right - * up - * down - -Maybe this can be done with a compositing system on Lisp with clx that support xrender. - http://en.wikipedia.org/wiki/Compositing_window_manager - http://ktown.kde.org/~fredrik/composite_howto.html +- Zoom: + Concept: + * zoom out: Behave as if the application window is bigger for the application but + completely drawn in a small amount of space (miniature). The zoom factor is inferior to 100% + * zoom in: Behave as a magnifying glass. The zoom factor is superior to 100%. + The part of the application window shown (viewport) can be moved. + + Operation: + * set-zoom-factor (frame, factor) + * move-viewport (frame &optional (increment 1)) + * left + * right + * up + * down + + Maybe this can be done with a compositing system: + http://en.wikipedia.org/wiki/Compositing_window_manager + http://ktown.kde.org/~fredrik/composite_howto.html - Undo/redo Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Thu Oct 28 07:01:27 2010 @@ -1,4 +1,4 @@ -;;;; -*- Mode: Lisp -*- + ;;;; -*- Mode: Lisp -*- ;;;; Author: Philippe Brochard ;;;; ASDF System Definition ;;; @@ -76,7 +76,8 @@ :depends-on ("clfswm" "clfswm-internal" "clfswm-util" "clfswm-menu")) (:file "bindings-second-mode" :depends-on ("clfswm" "clfswm-util" "clfswm-query" "bindings" "clfswm-pack" "clfswm-menu" "menu-def" - "clfswm-layout")))))) + "clfswm-layout"))))) + #-:CLX :depends-on #-:CLX (:clx)) From pbrochard at common-lisp.net Fri Oct 29 21:36:30 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 29 Oct 2010 17:36:30 -0400 Subject: [clfswm-cvs] r370 - clfswm Message-ID: Author: pbrochard Date: Fri Oct 29 17:36:30 2010 New Revision: 370 Log: Add CLX as system dependency (2) Modified: clfswm/clfswm.asd Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Fri Oct 29 17:36:30 2010 @@ -77,7 +77,7 @@ (:file "bindings-second-mode" :depends-on ("clfswm" "clfswm-util" "clfswm-query" "bindings" "clfswm-pack" "clfswm-menu" "menu-def" "clfswm-layout"))))) - #-:CLX :depends-on #-:CLX (:clx)) + :depends-on ( #-:CLX :clx )) From pbrochard at common-lisp.net Sat Oct 30 20:18:56 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 30 Oct 2010 16:18:56 -0400 Subject: [clfswm-cvs] r371 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 30 16:18:55 2010 New Revision: 371 Log: src/clfswm-query.lisp (query-print-string): Handle long lines correctly. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-query.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 30 16:18:55 2010 @@ -1,3 +1,8 @@ +2010-10-30 Philippe Brochard + + * src/clfswm-query.lisp (query-print-string): Handle long lines + correctly. + 2010-10-27 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-create-window): Ensure that Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Sat Oct 30 16:18:55 2010 @@ -10,6 +10,7 @@ - handle cursor with too long lines in info mode - info mode: complet on [tab] without living the info mode. +- Make frame/window border size variable. MAYBE ===== Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Sat Oct 30 16:18:55 2010 @@ -78,7 +78,6 @@ (leave-second-mode)))) - (defun set-default-second-keys () (define-second-key ("F1" :mod-1) 'help-on-clfswm) (define-second-key ("m") 'open-menu) Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Sat Oct 30 16:18:55 2010 @@ -35,6 +35,9 @@ (add-hook *binding-hook* 'init-*main-keys* 'init-*main-mouse*) +(defun test-hello () + (info-mode '("Hello" "World"))) + (defun help-on-clfswm () "Open the help and info window" Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Sat Oct 30 16:18:55 2010 @@ -39,7 +39,7 @@ -(defun query-show-paren (orig-string pos) +(defun query-show-paren (orig-string pos dec) "Replace matching parentheses with brackets" (let ((string (copy-seq orig-string))) (labels ((have-to-find-right? () @@ -61,7 +61,7 @@ (draw-bloc (p &optional (color *query-parent-color*)) (setf (xlib:gcontext-foreground *query-gc*) (get-color color)) (xlib:draw-rectangle *pixmap-buffer* *query-gc* - (+ 10 (* p (xlib:max-char-width *query-font*))) + (+ 10 (* p (xlib:max-char-width *query-font*)) dec) (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*) 7) (xlib:max-char-width *query-font*) (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*)) @@ -98,26 +98,28 @@ (defun query-print-string () - (clear-pixmap-buffer *query-window* *query-gc*) - (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*)) - (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) *query-message*) - (when (< *query-pos* 0) - (setf *query-pos* 0)) - (when (> *query-pos* (length *query-string*)) - (setf *query-pos* (length *query-string*))) - (query-show-paren *query-string* *query-pos*) - (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*)) - (xlib:draw-glyphs *pixmap-buffer* *query-gc* - 10 - (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5) - *query-string*) - (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-cursor-color*)) - (xlib:draw-line *pixmap-buffer* *query-gc* - (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))) - (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 6) - (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))) - (+ (* 1 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 7)) - (copy-pixmap-buffer *query-window* *query-gc*)) + (let ((dec (min 0 (- (- (xlib:drawable-width *query-window*) 10) + (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))))))) + (clear-pixmap-buffer *query-window* *query-gc*) + (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*)) + (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) *query-message*) + (when (< *query-pos* 0) + (setf *query-pos* 0)) + (when (> *query-pos* (length *query-string*)) + (setf *query-pos* (length *query-string*))) + (query-show-paren *query-string* *query-pos* dec) + (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*)) + (xlib:draw-glyphs *pixmap-buffer* *query-gc* + (+ 10 dec) + (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5) + *query-string*) + (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-cursor-color*)) + (xlib:draw-line *pixmap-buffer* *query-gc* + (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec) + (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 6) + (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec) + (+ (* 1 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 7)) + (copy-pixmap-buffer *query-window* *query-gc*))) From pbrochard at common-lisp.net Sat Oct 30 20:23:46 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 30 Oct 2010 16:23:46 -0400 Subject: [clfswm-cvs] r372 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 30 16:23:46 2010 New Revision: 372 Log: TODO update Modified: clfswm/TODO clfswm/src/bindings.lisp Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Sat Oct 30 16:23:46 2010 @@ -7,18 +7,22 @@ =============== Should handle these soon. -- handle cursor with too long lines in info mode - info mode: complet on [tab] without living the info mode. + +FOR THE NEXT RELEASE +==================== + - Make frame/window border size variable. +- Switch to a reparenting window manager to prevent remaining flickering. + + MAYBE ===== - cd/pwd a la shell to navigate through frames. -- Switch to a reparenting window manager to prevent remaining flickering. - - Zoom: Concept: * zoom out: Behave as if the application window is bigger for the application but Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Sat Oct 30 16:23:46 2010 @@ -35,10 +35,6 @@ (add-hook *binding-hook* 'init-*main-keys* 'init-*main-mouse*) -(defun test-hello () - (info-mode '("Hello" "World"))) - - (defun help-on-clfswm () "Open the help and info window" (open-menu (find-menu 'help-menu))) From pbrochard at common-lisp.net Sat Oct 30 23:04:23 2010 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 30 Oct 2010 19:04:23 -0400 Subject: [clfswm-cvs] r373 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Oct 30 19:04:23 2010 New Revision: 373 Log: src/clfswm-query.lisp (query-mode-complet): New function: Handle completion in query-mode. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/clfswm-configuration.lisp clfswm/src/clfswm-query.lisp clfswm/src/clfswm-util.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Oct 30 19:04:23 2010 @@ -1,3 +1,8 @@ +2010-10-31 Philippe Brochard + + * src/clfswm-query.lisp (query-mode-complet): New function: Handle + completion in query-mode. + 2010-10-30 Philippe Brochard * src/clfswm-query.lisp (query-print-string): Handle long lines Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Sat Oct 30 19:04:23 2010 @@ -7,8 +7,6 @@ =============== Should handle these soon. -- info mode: complet on [tab] without living the info mode. - FOR THE NEXT RELEASE ==================== Modified: clfswm/src/clfswm-configuration.lisp ============================================================================== --- clfswm/src/clfswm-configuration.lisp (original) +++ clfswm/src/clfswm-configuration.lisp Sat Oct 30 19:04:23 2010 @@ -141,7 +141,7 @@ (query-string (format nil "Configure ~A" string) original) (let ((result-val (ignore-errors (eval (read-from-string result)))) (original-val (ignore-errors (eval (read-from-string original))))) - (if (member return '(:Return :Complet)) + (if (equal return :Return) (warn-wrong-type result-val original-val) original-val))))) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Sat Oct 30 19:04:23 2010 @@ -31,6 +31,7 @@ (defparameter *query-gc* nil) (defparameter *query-history* nil) +(defparameter *query-complet-list* nil) (defparameter *query-message* nil) (defparameter *query-string* nil) @@ -91,18 +92,23 @@ (defun leave-query-mode-valid () (leave-query-mode :Return)) -(defun leave-query-mode-complet () - (leave-query-mode :Complet)) - (add-hook *binding-hook* 'init-*query-keys*) +(defun query-find-complet-list () + (remove-if-not (lambda (x) + (zerop (or (search *query-string* x :test #'string-equal) -1))) + *query-complet-list*)) + + (defun query-print-string () (let ((dec (min 0 (- (- (xlib:drawable-width *query-window*) 10) (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))))))) (clear-pixmap-buffer *query-window* *query-gc*) (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*)) - (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) *query-message*) + (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) + (format nil "~A ~{~A~^, ~}" *query-message* + (query-find-complet-list))) (when (< *query-pos* 0) (setf *query-pos* 0)) (when (> *query-pos* (length *query-string*)) @@ -243,13 +249,22 @@ (setf *query-string* (subseq *query-string* 0 *query-pos*))) +(defun query-mode-complet () + (setf *query-string* (find-common-string *query-string* (query-find-complet-list))) + (let ((complet (query-find-complet-list))) + (when (= (length complet) 1) + (setf *query-string* (first complet)))) + (query-end)) + + + (add-hook *binding-hook* 'set-default-query-keys) (defun set-default-query-keys () (define-query-key ("Return") 'leave-query-mode-valid) (define-query-key ("Escape") 'leave-query-mode) (define-query-key ("g" :control) 'leave-query-mode) - (define-query-key ("Tab") 'leave-query-mode-complet) + (define-query-key ("Tab") 'query-mode-complet) (define-query-key ("BackSpace") 'query-backspace) (define-query-key ("BackSpace" :control) 'query-backspace-word) (define-query-key ("Delete") 'query-delete) @@ -288,13 +303,14 @@ -(defun query-string (message &optional (default "")) +(defun query-string (message &optional (default "") complet-list) "Query a string from the keyboard. Display msg as prompt" (let ((grab-keyboard-p (xgrab-keyboard-p)) (grab-pointer-p (xgrab-pointer-p))) (setf *query-message* message *query-string* default - *query-pos* (length default)) + *query-pos* (length default) + *query-complet-list* complet-list) (xgrab-pointer *root* 92 93) (unless grab-keyboard-p (ungrab-main-keys) @@ -310,7 +326,7 @@ (if grab-pointer-p (xgrab-pointer *root* 66 67) (xungrab-pointer))) - (when (member *query-return* '(:Return :Complet)) + (when (equal *query-return* :Return) (pushnew default *query-history* :test #'equal) (push *query-string* *query-history*)) (values *query-string* Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sat Oct 30 19:04:23 2010 @@ -364,27 +364,10 @@ ;;; Frame name actions (defun ask-frame-name (msg) "Ask a frame name" - (let ((all-frame-name nil) - (name "")) + (let ((all-frame-name nil)) (with-all-frames (*root-frame* frame) (awhen (frame-name frame) (push it all-frame-name))) - (labels ((selected-names () - (loop :for str :in all-frame-name - :when (zerop (or (search name str :test #'string-equal) -1)) - :collect str)) - (complet-alone (req sel) - (if (= 1 (length sel)) (first sel) req)) - (ask () - (let* ((selected (selected-names)) - (default (complet-alone name selected))) - (multiple-value-bind (str done) - (query-string (format nil "~A: ~{~A~^, ~}" msg selected) default) - (setf name str) - (when (or (not (string-equal name default)) (eql done :complet)) - (ask)))))) - (ask)) - name)) - + (query-string msg "" all-frame-name))) ;;; Focus by functions @@ -399,7 +382,7 @@ (defun focus-frame-by-name () "Focus a frame by name" - (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame"))) + (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:"))) (leave-second-mode)) (defun focus-frame-by-number () @@ -418,7 +401,7 @@ (defun open-frame-by-name () "Open a new frame in a named frame" - (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in"))) + (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: "))) (leave-second-mode)) (defun open-frame-by-number () @@ -441,7 +424,7 @@ (defun delete-frame-by-name () "Delete a frame by name" - (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame"))) + (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: "))) (leave-second-mode)) (defun delete-frame-by-number () @@ -463,7 +446,7 @@ "Move current child in a named frame" (move-child-to *current-child* (find-frame-by-name - (ask-frame-name (format nil "Move '~A' to frame" (child-name *current-child*))))) + (ask-frame-name (format nil "Move '~A' to frame: " (child-name *current-child*))))) (leave-second-mode)) (defun move-current-child-by-number () @@ -486,7 +469,7 @@ "Copy current child in a named frame" (copy-child-to *current-child* (find-frame-by-name - (ask-frame-name (format nil "Copy '~A' to frame" (child-name *current-child*))))) + (ask-frame-name (format nil "Copy '~A' to frame: " (child-name *current-child*))))) (leave-second-mode)) (defun copy-current-child-by-number () Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Sat Oct 30 19:04:23 2010 @@ -54,6 +54,7 @@ :export-all-functions-and-variables :ensure-function :empty-string-p + :find-common-string :is-config-p :config-documentation :config-group :setf/= :create-symbol @@ -355,6 +356,20 @@ (string= string "")) +(defun find-common-string (string list &optional orig) + "Return the string in common in all string in list" + (if list + (let ((result (remove-if-not (lambda (x) + (zerop (or (search string x :test #'string-equal) -1))) + list))) + (if (= (length result) (length list)) + (if (> (length (first list)) (length string)) + (find-common-string (subseq (first list) 0 (1+ (length string))) list string) + string) + orig)) + string)) + + ;;; Auto configuration tools ;;; Syntaxe: (defparameter symbol value "Config(config group): documentation string")