From pbrochard at common-lisp.net Sun Apr 5 17:54:29 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 05 Apr 2009 13:54:29 -0400 Subject: [clfswm-cvs] r203 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Apr 5 13:54:28 2009 New Revision: 203 Log: info-mode: Ensure integer windows size. Use *default-font-string* for all font-string. Modified: clfswm/ChangeLog clfswm/src/clfswm-info.lisp clfswm/src/config.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Apr 5 13:54:28 2009 @@ -1,3 +1,10 @@ +2009-04-05 Philippe Brochard + + * src/package.lisp (): Use *default-font-string* for all + font-string. + + * src/clfswm-info.lisp (info-mode): Ensure integer windows size. + 2009-02-17 Philippe Brochard * src/xlib-util.lisp (null-size-window-p): Better check of null Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Sun Apr 5 13:54:28 2009 @@ -214,7 +214,7 @@ (min (* (+ (loop for l in info-list maximize (compute-size l)) 2) ilw) (- (xlib:screen-width *screen*) 2 x))) :height (or height - (min (+ (* (length info-list) ilh) (/ ilh 2)) + (min (round (+ (* (length info-list) ilh) (/ ilh 2))) (- (xlib:screen-height *screen*) 2 y))) :background (get-color *info-background*) :colormap (xlib:screen-default-colormap *screen*) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sun Apr 5 13:54:28 2009 @@ -35,7 +35,7 @@ ;; This variable may be useful to speed up some slow version of CLX. ;; It is particulary useful with CLISP/MIT-CLX. (setf *have-to-compress-notify* t) - + ;;; CONFIG - Default modifiers @@ -193,7 +193,7 @@ "Config(Second mode group): Second mode window background color") (defparameter *sm-foreground-color* "Red" "Config(Second mode group): Second mode window foreground color") -(defparameter *sm-font-string* "9x15bold" +(defparameter *sm-font-string* *default-font-string* "Config(Second mode group): Second mode window font string") (defparameter *sm-width* 300 "Config(Second mode group): Second mode window width") @@ -205,7 +205,7 @@ ;;; CONFIG - Identify key colors -(defparameter *identify-font-string* "9x15" +(defparameter *identify-font-string* *default-font-string* "Config(Identify key group): Identify window font string") (defparameter *identify-background* "black" "Config(Identify key group): Identify window background color") @@ -215,7 +215,7 @@ "Config(Identify key group): Identify window border color") ;;; CONFIG - Query string colors -(defparameter *query-font-string* "9x15" +(defparameter *query-font-string* *default-font-string* "Config(Query string group): Query string window font string") (defparameter *query-background* "black" "Config(Query string group): Query string window background color") @@ -234,7 +234,7 @@ "Config(Info mode group): Info window border color") (defparameter *info-line-cursor* "white" "Config(Info mode group): Info window line cursor color color") -(defparameter *info-font-string* "9x15" +(defparameter *info-font-string* *default-font-string* "Config(Info mode group): Info window font string") ;;; CONFIG - Show key binding colors Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Sun Apr 5 13:54:28 2009 @@ -153,7 +153,7 @@ (defparameter *main-keys* nil) (defparameter *main-mouse* nil) -(defparameter *second-keys* nil) +(defparameter *second-keys* nil) (defparameter *second-mouse* nil) (defparameter *info-keys* nil) (defparameter *info-mouse* nil) From pbrochard at common-lisp.net Fri Apr 17 20:59:48 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 17 Apr 2009 16:59:48 -0400 Subject: [clfswm-cvs] r204 - clfswm/src Message-ID: Author: pbrochard Date: Fri Apr 17 16:59:48 2009 New Revision: 204 Log: Test user name Modified: clfswm/src/bindings.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-keys.lisp clfswm/src/clfswm-query.lisp clfswm/src/clfswm-util.lisp clfswm/src/xlib-util.lisp Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Fri Apr 17 16:59:48 2009 @@ -37,10 +37,13 @@ (defun set-default-main-keys () (define-main-key ("F1" :mod-1) 'help-on-clfswm) (define-main-key ("Home" :mod-1 :control :shift) 'exit-clfswm) + (define-main-key ("Escape" :mod-2) 'exit-clfswm) ;; PHIL : TO REMOVE (define-main-key ("Right" :mod-1) 'select-next-brother) (define-main-key ("Left" :mod-1) 'select-previous-brother) (define-main-key ("Down" :mod-1) 'select-previous-level) (define-main-key ("Up" :mod-1) 'select-next-level) + (define-circulate-modifier "Alt_L") + (define-circulate-reverse-modifier '("Shift_L" "Shift_R")) (define-main-key ("Tab" :mod-1) 'select-next-child) (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-main-key ("Tab" :shift) 'switch-to-last-child) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Fri Apr 17 16:59:48 2009 @@ -725,34 +725,6 @@ - - -(defun select-next/previous-brother (fun-rotate) - "Select the next/previous brother frame" - (let ((frame-is-root? (and (equal *current-root* *current-child*) - (not (equal *current-root* *root-frame*))))) - (if frame-is-root? - (hide-all *current-root*) - (select-current-frame nil)) - (let ((parent (find-parent-frame *current-child*))) - (when (frame-p parent) - (with-slots (child) parent - (setf child (funcall fun-rotate child)) - (setf *current-child* (frame-selected-child parent))))) - (when frame-is-root? - (setf *current-root* *current-child*)) - (show-all-children *current-root*))) - - -(defun select-next-brother () - "Select the next brother frame" - (select-next/previous-brother #'anti-rotate-list)) - -(defun select-previous-brother () - "Select the previous brother frame" - (select-next/previous-brother #'rotate-list)) - - (defun select-next-level () "Select the next level in frame" (select-current-frame :maybe) @@ -771,22 +743,140 @@ -(defun select-next/previous-child (fun-rotate) - "Select the next/previous child" - (when (frame-p *current-child*) - (unselect-all-frames) - (with-slots (child) *current-child* - (setf child (funcall fun-rotate child))) - (show-all-children))) +(let ((modifier nil) + (reverse-modifiers nil)) + (defun define-circulate-modifier (keysym) + (setf modifier (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym keysym))))) + (defun define-circulate-reverse-modifier (keysym-list) + (setf reverse-modifiers keysym-list)) + (defun select-next-* (orig direction set-fun) + (let ((done nil) + (hit 0)) + (labels ((is-reverse-modifier (code state) + (member (keysym->keysym-name (keycode->keysym code (state->modifiers state))) + reverse-modifiers :test #'string=)) + (reorder () + (let ((elem (nth (mod (incf hit direction) (length orig)) orig))) + (funcall set-fun (nconc (list elem) (remove elem orig))))) + (handle-key-press (&rest event-slots &key root code state &allow-other-keys) + (declare (ignore event-slots)) + (dbg 'press root code state) + (dbg (first reverse-modifiers) (state->modifiers state)) + (if (is-reverse-modifier code state) + (setf direction -1) + (reorder))) + (handle-key-release (&rest event-slots &key root code state &allow-other-keys) + (declare (ignore event-slots)) + (dbg 'release root code state) + (when (is-reverse-modifier code state) + (setf direction 1)) + (when (member code modifier) + (setf done t))) + (handle-select-next-child-event (&rest event-slots &key display event-key &allow-other-keys) + (declare (ignore display)) + (with-xlib-protect + (case event-key + (:key-press (apply #'handle-key-press event-slots)) + (:key-release (apply #'handle-key-release event-slots)))) + t)) + (ungrab-main-keys) + (xgrab-keyboard *root*) + (reorder) + (loop until done do + (with-xlib-protect + (xlib:display-finish-output *display*) + (xlib:process-event *display* :handler #'handle-select-next-child-event))) + (xungrab-keyboard) + (grab-main-keys) + (print 'fin-du-tab))))) + +(defun set-select-next-child (new) + (setf (frame-child *current-child*) new) + (show-all-children)) + (defun select-next-child () "Select the next child" - (select-next/previous-child #'rotate-list)) + (select-next-* (frame-child *current-child*) 1 #'set-select-next-child)) (defun select-previous-child () "Select the previous child" - (select-next/previous-child #'anti-rotate-list)) + (select-next-* (frame-child *current-child*) -1 #'set-select-next-child)) + + +(let ((parent nil)) + (defun set-select-next-brother (new) + (let ((frame-is-root? (and (equal *current-root* *current-child*) + (not (equal *current-root* *root-frame*))))) + (if frame-is-root? + (hide-all *current-root*) + (select-current-frame nil)) + (setf (frame-child parent) new + *current-child* (frame-selected-child parent)) + (when frame-is-root? + (setf *current-root* *current-child*)) + (show-all-children *current-root*))) + + (defun select-next-brother () + "Select the next brother frame" + (setf parent (find-parent-frame *current-child*)) + (when (frame-p parent) + (select-next-* (frame-child parent) 1 #'set-select-next-brother))) + + (defun select-previous-brother () + "Select the previous brother frame" + (setf parent (find-parent-frame *current-child*)) + (when (frame-p parent) + (select-next-* (frame-child parent) -1 #'set-select-next-brother)))) + + + + +;;(defun select-next/previous-child (fun-rotate) +;; "Select the next/previous child" +;; (when (frame-p *current-child*) +;; (unselect-all-frames) +;; (with-slots (child) *current-child* +;; (setf child (funcall fun-rotate child))) +;; (show-all-children))) +;; +;; +;;(defun select-next-child () +;; "Select the next child" +;; (select-next/previous-child #'rotate-list)) +;; +;;(defun select-previous-child () +;; "Select the previous child" +;; (select-next/previous-child #'anti-rotate-list)) + + + +;;(defun select-next/previous-brother (fun-rotate) +;; "Select the next/previous brother frame" +;; (let ((frame-is-root? (and (equal *current-root* *current-child*) +;; (not (equal *current-root* *root-frame*))))) +;; (if frame-is-root? +;; (hide-all *current-root*) +;; (select-current-frame nil)) +;; (let ((parent (find-parent-frame *current-child*))) +;; (when (frame-p parent) +;; (with-slots (child) parent +;; (setf child (funcall fun-rotate child)) +;; (setf *current-child* (frame-selected-child parent))))) +;; (when frame-is-root? +;; (setf *current-root* *current-child*)) +;; (show-all-children *current-root*))) +;; +;; +;;(defun select-next-brother () +;; "Select the next brother frame" +;; (select-next/previous-brother #'anti-rotate-list)) +;; +;;(defun select-previous-brother () +;; "Select the previous brother frame" +;; (select-next/previous-brother #'rotate-list)) + Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Fri Apr 17 16:59:48 2009 @@ -132,7 +132,7 @@ (maphash #'(lambda (k v) (declare (ignore v)) (when (consp k) - (handler-case + (handler-case (let* ((key (first k)) (modifiers (second k)) (keycode (typecase key @@ -181,15 +181,11 @@ (function-from string))) (from-string-shift () (let* ((modifiers (state->modifiers state)) - (string (keysym->keysym-name (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1) - ((member :mod-5 modifiers) 2) - (t 0)))))) + (string (keysym->keysym-name (keycode->keysym code modifiers)))) (function-from string))) (from-string-no-shift () (let* ((modifiers (state->modifiers state)) - (string (keysym->keysym-name (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1) - ((member :mod-5 modifiers) 2) - (t 0)))))) + (string (keysym->keysym-name (keycode->keysym code modifiers)))) (function-from string (modifiers->state (remove :shift modifiers)))))) (or (from-code) (from-char) (from-string) (from-string-shift) (from-string-no-shift)))) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Fri Apr 17 16:59:48 2009 @@ -28,7 +28,7 @@ (defun query-show-paren (orig-string pos) "Replace matching parentheses with brackets" - (let ((string (copy-seq orig-string))) + (let ((string (copy-seq orig-string))) (labels ((have-to-find-right? () (and (< pos (length string)) (char= (aref string pos) #\())) (have-to-find-left? () @@ -59,7 +59,7 @@ (defun clear-history () "Clear the query-string history" (setf history nil)) - + (defun query-string (msg &optional (default "")) "Query a string from the keyboard. Display msg as prompt" (let* ((done nil) @@ -116,9 +116,7 @@ (handle-query-key (&rest event-slots &key root code state &allow-other-keys) (declare (ignore event-slots root)) (let* ((modifiers (state->modifiers state)) - (keysym (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1) - ((member :mod-5 modifiers) 2) - (t 0)))) + (keysym (keycode->keysym code modifiers)) (char (xlib:keysym->character *display* keysym)) (keysym-name (keysym->keysym-name keysym))) (setf done (cond ((string-equal keysym-name "Return") :Return) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Fri Apr 17 16:59:48 2009 @@ -58,7 +58,7 @@ (setf (frame-number *current-child*) number) (leave-second-mode)))) - + (defun add-default-frame () @@ -67,7 +67,7 @@ (let ((name (query-string "Frame name"))) (push (create-frame :name name) (frame-child *current-child*)))) (leave-second-mode)) - + (defun add-placed-frame () "Add a placed frame in the current frame" @@ -213,7 +213,7 @@ - + @@ -257,9 +257,7 @@ (declare (ignore event-slots root)) (let* ((modifiers (state->modifiers state)) (key (keycode->char code state)) - (keysym (keysym->keysym-name (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1) - ((member :mod-5 modifiers) 2) - (t 0)))))) + (keysym (keysym->keysym-name (keycode->keysym code modifiers)))) (setf done (and (equal key #\q) (equal modifiers *default-modifiers*))) (dbg code keysym key modifiers) (print-key code state keysym key modifiers) @@ -504,7 +502,7 @@ (frame-h frame) (h-px->fl (xlib:drawable-height window) parent))) (show-all-children frame))) - + (defun mouse-click-to-focus-generic (window root-x root-y mouse-fn) "Focus the current frame or focus the current window parent @@ -672,7 +670,7 @@ *current-child* *current-root*) (focus-all-children *current-child* *current-child*) (show-all-children *current-root*)))) - + (defun bind-or-jump (n) "Bind or jump to a slot" (setf current-slot (- n 1)) @@ -766,7 +764,7 @@ (let ((parent (find-parent-frame *current-child* *current-root*))) (fill-frame-left *current-child* parent) (fill-frame-right *current-child* parent)))) - + ;;; Resize (defun current-frame-resize-up () @@ -1007,7 +1005,7 @@ (setf hidden-children (remove hidden hidden-children))) (with-slots (child) frame-dest (pushnew hidden child))) - + (defun unhide-a-child () @@ -1058,7 +1056,7 @@ - + (let ((last-child nil)) (defun init-last-child () (setf last-child nil)) @@ -1084,12 +1082,12 @@ (when (frame-p *current-child*) (setf (frame-focus-policy *current-child*) focus-policy)) (leave-second-mode)) - + (defun current-frame-set-click-focus-policy () "Set a click focus policy for the current frame." (set-focus-policy-generic :click)) - + (defun current-frame-set-sloppy-focus-policy () "Set a sloppy focus policy for the current frame." (set-focus-policy-generic :sloppy)) @@ -1108,12 +1106,12 @@ (with-all-frames (*root-frame* frame) (setf (frame-focus-policy frame) focus-policy)) (leave-second-mode)) - + (defun all-frames-set-click-focus-policy () "Set a click focus policy for all frames." (set-focus-policy-generic-for-all :click)) - + (defun all-frames-set-sloppy-focus-policy () "Set a sloppy focus policy for all frames." (set-focus-policy-generic-for-all :sloppy)) @@ -1135,9 +1133,9 @@ (number (parse-integer name :junk-allowed t :start pos))) (values number (if number (subseq name 0 (1- pos)) name))))) - - + + (defun ensure-unique-name () "Ensure that all children names are unique" @@ -1190,7 +1188,7 @@ (add-sub-menu (menu-name menu) :next sec (format nil "~A" sec) menu) (um-create-section (find-menu sec menu) (rest section-list))))) menu)) - + (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu"))) (let ((output (do-shell "update-menus --stdout"))) @@ -1220,4 +1218,3 @@ - \ No newline at end of file Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Fri Apr 17 16:59:48 2009 @@ -658,6 +658,10 @@ (defun state->modifiers (state) (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)))) (defmacro with-grab-keyboard-and-pointer ((cursor mask old-cursor old-mask) &body body) From pbrochard at common-lisp.net Fri Apr 17 21:01:59 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Fri, 17 Apr 2009 17:01:59 -0400 Subject: [clfswm-cvs] r205 - clfswm Message-ID: Author: pbrochard Date: Fri Apr 17 17:01:59 2009 New Revision: 205 Log: Test user name Modified: clfswm/AUTHORS Modified: clfswm/AUTHORS ============================================================================== --- clfswm/AUTHORS (original) +++ clfswm/AUTHORS Fri Apr 17 17:01:59 2009 @@ -7,15 +7,15 @@ Contributors ------------ -Xavier Maillard xma at gnu dot org +Xavier Maillard xma at gnu dot org test Cyrille THOUVENIN ----------------------------------- -Some of the CLFSWM code is based on +Some of the CLFSWM code is based on tinywm: http://incise.org/index.cgi/TinyWM -And on the excellent Shawn Betts (sabetts at vcn bc ca) +And on the excellent Shawn Betts (sabetts at vcn bc ca) Stumpwm: http://www.nongnu.org/stumpwm/ From pbrochard at common-lisp.net Sat Apr 18 19:48:37 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 18 Apr 2009 15:48:37 -0400 Subject: [clfswm-cvs] r206 - clfswm Message-ID: Author: pbrochard Date: Sat Apr 18 15:48:37 2009 New Revision: 206 Log: End tests Modified: clfswm/AUTHORS Modified: clfswm/AUTHORS ============================================================================== --- clfswm/AUTHORS (original) +++ clfswm/AUTHORS Sat Apr 18 15:48:37 2009 @@ -7,7 +7,7 @@ Contributors ------------ -Xavier Maillard xma at gnu dot org test +Xavier Maillard xma at gnu dot org Cyrille THOUVENIN From pbrochard at common-lisp.net Sat Apr 18 20:54:05 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sat, 18 Apr 2009 16:54:05 -0400 Subject: [clfswm-cvs] r207 - in clfswm: . src Message-ID: Author: pbrochard Date: Sat Apr 18 16:54:05 2009 New Revision: 207 Log: Add a generic mode to define all other modes. Modified: clfswm/ChangeLog clfswm/clfswm.asd clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-second-mode.lisp clfswm/src/package.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sat Apr 18 16:54:05 2009 @@ -1,3 +1,8 @@ +2009-04-18 Xavier Maillard + + * src/clfswm-generic-mode.lisp (generic-mode): Add a generic mode + to define all other modes. + 2009-04-05 Philippe Brochard * src/package.lisp (): Use *default-font-string* for all Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Sat Apr 18 16:54:05 2009 @@ -29,6 +29,8 @@ :depends-on ("package" "config" "xlib-util" "keysyms")) (:file "clfswm-autodoc" :depends-on ("package" "clfswm-keys" "my-html" "tools" "config")) + (:file "clfswm-generic-mode" + :depends-on ("package" "tools")) (:file "clfswm-internal" :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config")) (:file "clfswm" @@ -37,7 +39,7 @@ (:file "version" :depends-on ("tools")) (:file "clfswm-second-mode" - :depends-on ("package" "clfswm" "clfswm-internal")) + :depends-on ("package" "clfswm" "clfswm-internal" "clfswm-generic-mode")) (:file "clfswm-corner" :depends-on ("package" "config" "clfswm-internal")) (:file "clfswm-info" Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sat Apr 18 16:54:05 2009 @@ -760,16 +760,16 @@ (reorder () (let ((elem (nth (mod (incf hit direction) (length orig)) orig))) (funcall set-fun (nconc (list elem) (remove elem orig))))) - (handle-key-press (&rest event-slots &key root code state &allow-other-keys) + (handle-key-press (&rest event-slots &key code state &allow-other-keys) (declare (ignore event-slots)) - (dbg 'press root code state) - (dbg (first reverse-modifiers) (state->modifiers state)) + ;;(dbg 'press root code state) + ;;(dbg (first reverse-modifiers) (state->modifiers state)) (if (is-reverse-modifier code state) (setf direction -1) (reorder))) - (handle-key-release (&rest event-slots &key root code state &allow-other-keys) + (handle-key-release (&rest event-slots &key code state &allow-other-keys) (declare (ignore event-slots)) - (dbg 'release root code state) + ;;(dbg 'release root code state) (when (is-reverse-modifier code state) (setf direction 1)) (when (member code modifier) @@ -789,8 +789,7 @@ (xlib:display-finish-output *display*) (xlib:process-event *display* :handler #'handle-select-next-child-event))) (xungrab-keyboard) - (grab-main-keys) - (print 'fin-du-tab))))) + (grab-main-keys))))) (defun set-select-next-child (new) (setf (frame-child *current-child*) new) Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Sat Apr 18 16:54:05 2009 @@ -125,33 +125,78 @@ -(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - ;; (dbg event-key) - (with-xlib-protect - (case event-key - (:button-press (call-hook *sm-button-press-hook* event-slots)) - (:button-release (call-hook *sm-button-release-hook* event-slots)) - (:motion-notify (call-hook *sm-motion-notify-hook* event-slots)) - (:key-press (call-hook *sm-key-press-hook* event-slots)) - (:configure-request (call-hook *sm-configure-request-hook* event-slots)) - (:configure-notify (call-hook *sm-configure-notify-hook* event-slots)) - (:map-request (call-hook *sm-map-request-hook* event-slots)) - (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots)) - (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots)) - (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots)) - (:property-notify (call-hook *sm-property-notify-hook* event-slots)) - (:create-notify (call-hook *sm-create-notify-hook* event-slots)) - (:enter-notify (call-hook *sm-enter-notify-hook* event-slots)) - (:exposure (call-hook *sm-exposure-hook* event-slots)))) - ;;(dbg "Ignore handle event" c event-slots))) - t) +;;(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys) +;; (declare (ignore display)) +;; ;; (dbg event-key) +;; (with-xlib-protect +;; (case event-key +;; (:button-press (call-hook *sm-button-press-hook* event-slots)) +;; (:button-release (call-hook *sm-button-release-hook* event-slots)) +;; (:motion-notify (call-hook *sm-motion-notify-hook* event-slots)) +;; (:key-press (call-hook *sm-key-press-hook* event-slots)) +;; (:configure-request (call-hook *sm-configure-request-hook* event-slots)) +;; (:configure-notify (call-hook *sm-configure-notify-hook* event-slots)) +;; (:map-request (call-hook *sm-map-request-hook* event-slots)) +;; (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots)) +;; (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots)) +;; (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots)) +;; (:property-notify (call-hook *sm-property-notify-hook* event-slots)) +;; (:create-notify (call-hook *sm-create-notify-hook* event-slots)) +;; (:enter-notify (call-hook *sm-enter-notify-hook* event-slots)) +;; (:exposure (call-hook *sm-exposure-hook* event-slots)))) +;; ;;(dbg "Ignore handle event" c event-slots))) +;; t) + + + +;;(defun second-key-mode () +;; "Switch to editing mode" +;; ;;(dbg "Second key ignore" c))))) +;; (setf *in-second-mode* t +;; *sm-window* (xlib:create-window :parent *root* +;; :x (truncate (/ (- (xlib:screen-width *screen*) *sm-width*) 2)) +;; :y 0 +;; :width *sm-width* :height *sm-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)) +;; *sm-font* (xlib:open-font *display* *sm-font-string*) +;; *sm-gc* (xlib:create-gcontext :drawable *sm-window* +;; :foreground (get-color *sm-foreground-color*) +;; :background (get-color *sm-background-color*) +;; :font *sm-font* +;; :line-style :solid)) +;; (xlib:map-window *sm-window*) +;; (draw-second-mode-window) +;; (no-focus) +;; (ungrab-main-keys) +;; (xgrab-keyboard *root*) +;; (xgrab-pointer *root* 66 67) +;; (unwind-protect +;; (catch 'exit-second-loop +;; (loop +;; (raise-window *sm-window*) +;; (xlib:display-finish-output *display*) +;; (xlib:process-event *display* :handler #'sm-handle-event) +;; (xlib:display-finish-output *display*))) +;; (xlib:free-gcontext *sm-gc*) +;; (xlib:close-font *sm-font*) +;; (xlib:destroy-window *sm-window*) +;; (xungrab-keyboard) +;; (xungrab-pointer) +;; (grab-main-keys) +;; (show-all-children) +;; (display-all-frame-info)) +;; (wait-no-key-or-button-press) +;; (when *second-mode-program* +;; (do-shell *second-mode-program*) +;; (setf *second-mode-program* nil)) +;; (setf *in-second-mode* nil)) - -(defun second-key-mode () - "Switch to editing mode" - ;;(dbg "Second key ignore" c))))) +(defun sm-enter-function () (setf *in-second-mode* t *sm-window* (xlib:create-window :parent *root* :x (truncate (/ (- (xlib:screen-width *screen*) *sm-width*) 2)) @@ -173,22 +218,20 @@ (no-focus) (ungrab-main-keys) (xgrab-keyboard *root*) - (xgrab-pointer *root* 66 67) - (unwind-protect - (catch 'exit-second-loop - (loop - (raise-window *sm-window*) - (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'sm-handle-event) - (xlib:display-finish-output *display*))) - (xlib:free-gcontext *sm-gc*) - (xlib:close-font *sm-font*) - (xlib:destroy-window *sm-window*) - (xungrab-keyboard) - (xungrab-pointer) - (grab-main-keys) - (show-all-children) - (display-all-frame-info)) + (xgrab-pointer *root* 66 67)) + +(defun sm-loop-function () + (raise-window *sm-window*)) + +(defun sm-leave-function () + (xlib:free-gcontext *sm-gc*) + (xlib:close-font *sm-font*) + (xlib:destroy-window *sm-window*) + (xungrab-keyboard) + (xungrab-pointer) + (grab-main-keys) + (show-all-children) + (display-all-frame-info) (wait-no-key-or-button-press) (when *second-mode-program* (do-shell *second-mode-program*) @@ -196,6 +239,26 @@ (setf *in-second-mode* nil)) +(defun second-key-mode () + (generic-mode :enter-function #'sm-enter-function + :loop-function #'sm-loop-function + :leave-function #'sm-leave-function + :button-press-hook *sm-button-press-hook* + :button-release-hook *sm-button-release-hook* + :key-press-hook *sm-key-press-hook* + :key-release-hook *sm-key-release-hook* + :motion-notify-hook *sm-motion-notify-hook* + :configure-request-hook *sm-configure-request-hook* + :configure-notify-hook *sm-configure-notify-hook* + :map-request-hook *sm-map-request-hook* + :unmap-notify-hook *sm-unmap-notify-hook* + :destroy-notify-hook *sm-destroy-notify-hook* + :mapping-notify-hook *sm-mapping-notify-hook* + :property-notify-hook *sm-property-notify-hook* + :create-notify-hook *sm-create-notify-hook* + :enter-notify-hook *sm-enter-notify-hook* + :exposure-hook *sm-exposure-hook*)) + (defun leave-second-mode () "Leave second mode" Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Sat Apr 18 16:54:05 2009 @@ -175,6 +175,8 @@ "Config(Hook group):") (defparameter *key-press-hook* nil "Config(Hook group):") +(defparameter *key-release-hook* nil + "Config(Hook group):") (defparameter *configure-request-hook* nil "Config(Hook group):") (defparameter *configure-notify-hook* nil @@ -206,6 +208,8 @@ "Config(Hook group):") (defparameter *sm-key-press-hook* nil "Config(Hook group):") +(defparameter *sm-key-release-hook* nil + "Config(Hook group):") (defparameter *sm-configure-request-hook* nil "Config(Hook group):") (defparameter *sm-configure-notify-hook* nil Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Sat Apr 18 16:54:05 2009 @@ -31,6 +31,7 @@ (:export :it :awhen :aif + :nfuncall :call-hook :add-hook :remove-hook @@ -90,7 +91,7 @@ :subst-strings :test-find-string)) - + (in-package :tools) @@ -108,6 +109,10 @@ (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) +(defun nfuncall (function) + (when function + (funcall function))) + ;;;,----- ;;;| Minimal hook @@ -198,7 +203,7 @@ (when verbose (format t "Exporting ~S~%" symbol)) (export symbol package)))) - + (defun export-all-variables (package &optional (verbose nil)) (with-all-internal-symbols (symbol package) @@ -242,7 +247,7 @@ (= (or (search start-string doc :test #'string-equal) -1) 0) (search stop-string doc) t)))) - + (defun config-documentation (symbol) (when (is-config-p symbol) (let ((doc (documentation symbol 'variable))) @@ -348,7 +353,7 @@ (pos-2 (position delim line :start (1+ (or pos-1 0))))) (when (and pos pos-1 pos-2) (subseq line (1+ pos-1) pos-2)))) - + (defun print-space (n &optional (stream *standard-output*)) "Print n spaces on stream" @@ -414,15 +419,15 @@ :stream :wait wt))) (unless proc (error "Cannot create process.")) - (make-two-way-stream - (sb-ext:process-output proc) + (make-two-way-stream + (sb-ext:process-output proc) (sb-ext:process-input proc))) #+:lispworks (system:open-pipe fullstring :direction :io) #+:allegro (let ((proc (excl:run-shell-command (apply #'vector program program args) :input :stream :output :stream :wait wt))) (unless proc - (error "Cannot create process.")) + (error "Cannot create process.")) proc) #+:ecl(ext:run-program program args :input :stream :output :stream :error :output) @@ -493,8 +498,8 @@ #+gcl (lisp:quit) #+lispworks (lw:quit) #+(or allegro-cl allegro-cl-trial) (excl:exit)) - - + + (defun remove-plist (plist &rest keys) @@ -568,7 +573,7 @@ ((zerop (or (position #\! line) -1)) (funcall shell-fun (subseq line 1))) (t (format t "~{~A~^ ;~%~}~%" - (multiple-value-list + (multiple-value-list (ignore-errors (eval (read-from-string line)))))))))) @@ -617,7 +622,7 @@ ret))) ((null char) ret))) - + ;;;(defun near-position2 (chars str &key (start 0)) ;;; (loop for i in chars ;;; minimize (position i str :start start))) @@ -679,14 +684,14 @@ (defun append-formated-list (base-str - lst + lst &key (test-not-fun #'(lambda (x) x nil)) (print-fun #'(lambda (x) x)) (default-str "")) (let ((str base-str) (first t)) (dolist (i lst) (cond ((funcall test-not-fun i) nil) - (t (setq str + (t (setq str (concatenate 'string str (if first "" ", ") (format nil "~A" From pbrochard at common-lisp.net Sun Apr 19 19:11:46 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 19 Apr 2009 15:11:46 -0400 Subject: [clfswm-cvs] r208 - clfswm/src Message-ID: Author: pbrochard Date: Sun Apr 19 15:11:45 2009 New Revision: 208 Log: Remove a test key Modified: clfswm/src/bindings.lisp Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Sun Apr 19 15:11:45 2009 @@ -37,7 +37,6 @@ (defun set-default-main-keys () (define-main-key ("F1" :mod-1) 'help-on-clfswm) (define-main-key ("Home" :mod-1 :control :shift) 'exit-clfswm) - (define-main-key ("Escape" :mod-2) 'exit-clfswm) ;; PHIL : TO REMOVE (define-main-key ("Right" :mod-1) 'select-next-brother) (define-main-key ("Left" :mod-1) 'select-previous-brother) (define-main-key ("Down" :mod-1) 'select-previous-level) From pbrochard at common-lisp.net Sun Apr 19 20:22:32 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 19 Apr 2009 16:22:32 -0400 Subject: [clfswm-cvs] r209 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Apr 19 16:22:32 2009 New Revision: 209 Log: Use generic-mode for info-mode. Modified: clfswm/ChangeLog clfswm/clfswm.asd clfswm/src/clfswm-info.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Apr 19 16:22:32 2009 @@ -1,3 +1,7 @@ +2009-04-19 Xavier Maillard + + * src/clfswm-info.lisp (info-mode): Use generic-mode for info-mode. + 2009-04-18 Xavier Maillard * src/clfswm-generic-mode.lisp (generic-mode): Add a generic mode Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Sun Apr 19 16:22:32 2009 @@ -44,7 +44,8 @@ :depends-on ("package" "config" "clfswm-internal")) (:file "clfswm-info" :depends-on ("package" "version" "xlib-util" "config" "clfswm-keys" "clfswm" "clfswm-internal" - "clfswm-autodoc" "clfswm-corner")) + "clfswm-autodoc" "clfswm-corner" + "clfswm-generic-mode")) (:file "clfswm-menu" :depends-on ("package" "clfswm-info")) (:file "clfswm-query" Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Sun Apr 19 16:22:32 2009 @@ -192,17 +192,17 @@ "Open the info mode. Info-list is a list of info: One string per line Or for colored output: a list (line_string color) Or ((1_word color) (2_word color) 3_word (4_word color)...)" - (labels ((compute-size (line) - (typecase line - (cons (typecase (first line) - (cons (let ((val 0)) - (dolist (l line val) - (incf val (typecase l - (cons (length (first l))) - (t (length l))))))) - (t (length (first line))))) - (t (length line))))) - (when info-list + (when info-list + (labels ((compute-size (line) + (typecase line + (cons (typecase (first line) + (cons (let ((val 0)) + (dolist (l line val) + (incf val (typecase l + (cons (length (first l))) + (t (length l))))))) + (t (length (first line))))) + (t (length line))))) (let* ((pointer-grabbed-p (xgrab-pointer-p)) (keyboard-grabbed-p (xgrab-keyboard-p)) (font (xlib:open-font *display* *info-font-string*)) @@ -248,23 +248,7 @@ (draw-info-window info)) (info-handle-destroy-notify (&rest event-slots) (apply #'handle-destroy-notify event-slots) - (draw-info-window info)) - (handle-events (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - (case event-key - (:key-press (apply #'handle-key event-slots) t) - (:button-press (apply #'handle-button-press event-slots) t) - (:button-release (apply #'handle-button-release event-slots) t) - (:motion-notify (apply #'handle-motion-notify event-slots) t) - (:map-request nil) - (:unmap-notify (apply #'info-handle-unmap-notify event-slots) t) - (:destroy-notify (apply #'info-handle-destroy-notify event-slots) t) - (:mapping-notify nil) - (:property-notify nil) - (:create-notify nil) - (:enter-notify nil) - (:exposure (draw-info-window info))) - t)) + (draw-info-window info))) (xlib:map-window window) (draw-info-window info) (xgrab-pointer *root* 68 69) @@ -272,9 +256,10 @@ (xgrab-keyboard *root*)) (unwind-protect (catch 'exit-info-loop - (loop - (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-events))) + (generic-mode :button-press-hook #'handle-button-press + :button-release-hook #'handle-button-release + :motion-notify-hook #'handle-motion-notify + :key-press-hook #'handle-key)) (if pointer-grabbed-p (xgrab-pointer *root* 66 67) (xungrab-pointer)) @@ -289,8 +274,6 @@ - - (defun info-mode-menu (item-list &key (x 0) (y 0) (width nil) (height nil)) "Open an info help menu. Item-list is: '((key function) separator (key function)) From pbrochard at common-lisp.net Mon Apr 20 07:03:12 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 20 Apr 2009 03:03:12 -0400 Subject: [clfswm-cvs] r210 - clfswm/src Message-ID: Author: pbrochard Date: Mon Apr 20 03:03:11 2009 New Revision: 210 Log: Adding generic-mode Added: clfswm/src/clfswm-generic-mode.lisp Added: clfswm/src/clfswm-generic-mode.lisp ============================================================================== --- (empty file) +++ clfswm/src/clfswm-generic-mode.lisp Mon Apr 20 03:03:11 2009 @@ -0,0 +1,76 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: Main functions +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2005 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) + + +(defun generic-mode (&key enter-function loop-function leave-function + (button-press-hook *button-press-hook*) + (button-release-hook *button-release-hook*) + (motion-notify-hook *motion-notify-hook*) + (key-press-hook *key-press-hook*) + (key-release-hook *key-release-hook*) + (configure-request-hook *configure-request-hook*) + (configure-notify-hook *configure-notify-hook*) + (map-request-hook *map-request-hook*) + (unmap-notify-hook *unmap-notify-hook*) + (destroy-notify-hook *destroy-notify-hook*) + (mapping-notify-hook *mapping-notify-hook*) + (property-notify-hook *property-notify-hook*) + (create-notify-hook *create-notify-hook*) + (enter-notify-hook *enter-notify-hook*) + (exposure-hook *exposure-hook*)) + "Enter in a generic mode" + (labels ((handler-function (&rest event-slots &key display event-key &allow-other-keys) + (declare (ignore display)) + ;; (dbg event-key) + (with-xlib-protect + (case event-key + (:button-press (call-hook button-press-hook event-slots)) + (:button-release (call-hook button-release-hook event-slots)) + (:motion-notify (call-hook motion-notify-hook event-slots)) + (:key-press (call-hook key-press-hook event-slots)) + (:key-release (call-hook key-release-hook event-slots)) + (:configure-request (call-hook configure-request-hook event-slots)) + (:configure-notify (call-hook configure-notify-hook event-slots)) + (:map-request (call-hook map-request-hook event-slots)) + (:unmap-notify (call-hook unmap-notify-hook event-slots)) + (:destroy-notify (call-hook destroy-notify-hook event-slots)) + (:mapping-notify (call-hook mapping-notify-hook event-slots)) + (:property-notify (call-hook property-notify-hook event-slots)) + (:create-notify (call-hook create-notify-hook event-slots)) + (:enter-notify (call-hook enter-notify-hook event-slots)) + (:exposure (call-hook exposure-hook event-slots)))) + ;;(dbg "Ignore handle event" c event-slots))) + t)) + (nfuncall enter-function) + (unwind-protect + (catch 'exit-second-loop + (loop + (nfuncall loop-function) + (xlib:display-finish-output *display*) + (xlib:process-event *display* :handler #'handler-function) + (xlib:display-finish-output *display*))) + (nfuncall leave-function)))) From pbrochard at common-lisp.net Mon Apr 20 13:01:08 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 20 Apr 2009 09:01:08 -0400 Subject: [clfswm-cvs] r211 - clfswm Message-ID: Author: pbrochard Date: Mon Apr 20 09:01:08 2009 New Revision: 211 Log: Add an xlib-util dependency for clfswm-generic-mode Modified: clfswm/clfswm.asd Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Mon Apr 20 09:01:08 2009 @@ -30,7 +30,7 @@ (:file "clfswm-autodoc" :depends-on ("package" "clfswm-keys" "my-html" "tools" "config")) (:file "clfswm-generic-mode" - :depends-on ("package" "tools")) + :depends-on ("package" "tools" "xlib-util")) (:file "clfswm-internal" :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config")) (:file "clfswm" From pbrochard at common-lisp.net Mon Apr 20 21:13:55 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 20 Apr 2009 17:13:55 -0400 Subject: [clfswm-cvs] r212 - clfswm/src Message-ID: Author: pbrochard Date: Mon Apr 20 17:13:55 2009 New Revision: 212 Log: Transitional: revert to old circulate behaviour Modified: clfswm/src/bindings.lisp clfswm/src/clfswm-info.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-second-mode.lisp Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Mon Apr 20 17:13:55 2009 @@ -41,8 +41,9 @@ (define-main-key ("Left" :mod-1) 'select-previous-brother) (define-main-key ("Down" :mod-1) 'select-previous-level) (define-main-key ("Up" :mod-1) 'select-next-level) - (define-circulate-modifier "Alt_L") - (define-circulate-reverse-modifier '("Shift_L" "Shift_R")) + ;; Work in progress + ;; (define-circulate-modifier "Alt_L") + ;; (define-circulate-reverse-modifier '("Shift_L" "Shift_R")) (define-main-key ("Tab" :mod-1) 'select-next-child) (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-main-key ("Tab" :shift) 'switch-to-last-child) Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Mon Apr 20 17:13:55 2009 @@ -256,7 +256,10 @@ (xgrab-keyboard *root*)) (unwind-protect (catch 'exit-info-loop - (generic-mode :button-press-hook #'handle-button-press + (generic-mode :loop-function (lambda () + (raise-window (info-window info)) + (draw-info-window info)) + :button-press-hook #'handle-button-press :button-release-hook #'handle-button-release :motion-notify-hook #'handle-motion-notify :key-press-hook #'handle-key)) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Mon Apr 20 17:13:55 2009 @@ -744,138 +744,135 @@ - -(let ((modifier nil) - (reverse-modifiers nil)) - (defun define-circulate-modifier (keysym) - (setf modifier (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym keysym))))) - (defun define-circulate-reverse-modifier (keysym-list) - (setf reverse-modifiers keysym-list)) - (defun select-next-* (orig direction set-fun) - (let ((done nil) - (hit 0)) - (labels ((is-reverse-modifier (code state) - (member (keysym->keysym-name (keycode->keysym code (state->modifiers state))) - reverse-modifiers :test #'string=)) - (reorder () - (let ((elem (nth (mod (incf hit direction) (length orig)) orig))) - (funcall set-fun (nconc (list elem) (remove elem orig))))) - (handle-key-press (&rest event-slots &key code state &allow-other-keys) - (declare (ignore event-slots)) - ;;(dbg 'press root code state) - ;;(dbg (first reverse-modifiers) (state->modifiers state)) - (if (is-reverse-modifier code state) - (setf direction -1) - (reorder))) - (handle-key-release (&rest event-slots &key code state &allow-other-keys) - (declare (ignore event-slots)) - ;;(dbg 'release root code state) - (when (is-reverse-modifier code state) - (setf direction 1)) - (when (member code modifier) - (setf done t))) - (handle-select-next-child-event (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - (with-xlib-protect - (case event-key - (:key-press (apply #'handle-key-press event-slots)) - (:key-release (apply #'handle-key-release event-slots)))) - t)) - (ungrab-main-keys) - (xgrab-keyboard *root*) - (reorder) - (loop until done do - (with-xlib-protect - (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-select-next-child-event))) - (xungrab-keyboard) - (grab-main-keys))))) - -(defun set-select-next-child (new) - (setf (frame-child *current-child*) new) - (show-all-children)) - -(defun select-next-child () - "Select the next child" - (select-next-* (frame-child *current-child*) 1 #'set-select-next-child)) - -(defun select-previous-child () - "Select the previous child" - (select-next-* (frame-child *current-child*) -1 #'set-select-next-child)) - - -(let ((parent nil)) - (defun set-select-next-brother (new) - (let ((frame-is-root? (and (equal *current-root* *current-child*) - (not (equal *current-root* *root-frame*))))) - (if frame-is-root? - (hide-all *current-root*) - (select-current-frame nil)) - (setf (frame-child parent) new - *current-child* (frame-selected-child parent)) - (when frame-is-root? - (setf *current-root* *current-child*)) - (show-all-children *current-root*))) - - (defun select-next-brother () - "Select the next brother frame" - (setf parent (find-parent-frame *current-child*)) - (when (frame-p parent) - (select-next-* (frame-child parent) 1 #'set-select-next-brother))) - - (defun select-previous-brother () - "Select the previous brother frame" - (setf parent (find-parent-frame *current-child*)) - (when (frame-p parent) - (select-next-* (frame-child parent) -1 #'set-select-next-brother)))) - - - - -;;(defun select-next/previous-child (fun-rotate) -;; "Select the next/previous child" -;; (when (frame-p *current-child*) -;; (unselect-all-frames) -;; (with-slots (child) *current-child* -;; (setf child (funcall fun-rotate child))) -;; (show-all-children))) +;; New circulate mode - work in progress +;;(let ((modifier nil) +;; (reverse-modifiers nil)) +;; (defun define-circulate-modifier (keysym) +;; (setf modifier (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym keysym))))) +;; (defun define-circulate-reverse-modifier (keysym-list) +;; (setf reverse-modifiers keysym-list)) +;; (defun select-next-* (orig direction set-fun) +;; (let ((done nil) +;; (hit 0)) +;; (labels ((is-reverse-modifier (code state) +;; (member (keysym->keysym-name (keycode->keysym code (state->modifiers state))) +;; reverse-modifiers :test #'string=)) +;; (reorder () +;; (let ((elem (nth (mod (incf hit direction) (length orig)) orig))) +;; (funcall set-fun (nconc (list elem) (remove elem orig))))) +;; (handle-key-press (&rest event-slots &key code state &allow-other-keys) +;; (declare (ignore event-slots)) +;; ;;(dbg 'press root code state) +;; ;;(dbg (first reverse-modifiers) (state->modifiers state)) +;; (if (is-reverse-modifier code state) +;; (setf direction -1) +;; (reorder))) +;; (handle-key-release (&rest event-slots &key code state &allow-other-keys) +;; (declare (ignore event-slots)) +;; ;;(dbg 'release root code state) +;; (when (is-reverse-modifier code state) +;; (setf direction 1)) +;; (when (member code modifier) +;; (setf done t))) +;; (handle-select-next-child-event (&rest event-slots &key display event-key &allow-other-keys) +;; (declare (ignore display)) +;; (with-xlib-protect +;; (case event-key +;; (:key-press (apply #'handle-key-press event-slots)) +;; (:key-release (apply #'handle-key-release event-slots)))) +;; t)) +;; (ungrab-main-keys) +;; (xgrab-keyboard *root*) +;; (reorder) +;; (loop until done do +;; (with-xlib-protect +;; (xlib:display-finish-output *display*) +;; (xlib:process-event *display* :handler #'handle-select-next-child-event))) +;; (xungrab-keyboard) +;; (grab-main-keys))))) ;; +;;(defun set-select-next-child (new) +;; (setf (frame-child *current-child*) new) +;; (show-all-children)) ;; ;;(defun select-next-child () ;; "Select the next child" -;; (select-next/previous-child #'rotate-list)) +;; (select-next-* (frame-child *current-child*) 1 #'set-select-next-child)) ;; ;;(defun select-previous-child () ;; "Select the previous child" -;; (select-next/previous-child #'anti-rotate-list)) - - - -;;(defun select-next/previous-brother (fun-rotate) -;; "Select the next/previous brother frame" -;; (let ((frame-is-root? (and (equal *current-root* *current-child*) -;; (not (equal *current-root* *root-frame*))))) -;; (if frame-is-root? -;; (hide-all *current-root*) -;; (select-current-frame nil)) -;; (let ((parent (find-parent-frame *current-child*))) -;; (when (frame-p parent) -;; (with-slots (child) parent -;; (setf child (funcall fun-rotate child)) -;; (setf *current-child* (frame-selected-child parent))))) -;; (when frame-is-root? -;; (setf *current-root* *current-child*)) -;; (show-all-children *current-root*))) +;; (select-next-* (frame-child *current-child*) -1 #'set-select-next-child)) ;; +;;(let ((parent nil)) +;; (defun set-select-next-brother (new) +;; (let ((frame-is-root? (and (equal *current-root* *current-child*) +;; (not (equal *current-root* *root-frame*))))) +;; (if frame-is-root? +;; (hide-all *current-root*) +;; (select-current-frame nil)) +;; (setf (frame-child parent) new +;; *current-child* (frame-selected-child parent)) +;; (when frame-is-root? +;; (setf *current-root* *current-child*)) +;; (show-all-children *current-root*))) ;; -;;(defun select-next-brother () -;; "Select the next brother frame" -;; (select-next/previous-brother #'anti-rotate-list)) +;; (defun select-next-brother () +;; "Select the next brother frame" +;; (setf parent (find-parent-frame *current-child*)) +;; (when (frame-p parent) +;; (select-next-* (frame-child parent) 1 #'set-select-next-brother))) ;; -;;(defun select-previous-brother () -;; "Select the previous brother frame" -;; (select-next/previous-brother #'rotate-list)) +;; (defun select-previous-brother () +;; "Select the previous brother frame" +;; (setf parent (find-parent-frame *current-child*)) +;; (when (frame-p parent) +;; (select-next-* (frame-child parent) -1 #'set-select-next-brother)))) + + +;;; This is only transitional +(defun select-next/previous-child (fun-rotate) + "Select the next/previous child" + (when (frame-p *current-child*) + (unselect-all-frames) + (with-slots (child) *current-child* + (setf child (funcall fun-rotate child))) + (show-all-children))) + + +(defun select-next-child () + "Select the next child" + (select-next/previous-child #'rotate-list)) + +(defun select-previous-child () + "Select the previous child" + (select-next/previous-child #'anti-rotate-list)) + + +(defun select-next/previous-brother (fun-rotate) + "Select the next/previous brother frame" + (let ((frame-is-root? (and (equal *current-root* *current-child*) + (not (equal *current-root* *root-frame*))))) + (if frame-is-root? + (hide-all *current-root*) + (select-current-frame nil)) + (let ((parent (find-parent-frame *current-child*))) + (when (frame-p parent) + (with-slots (child) parent + (setf child (funcall fun-rotate child)) + (setf *current-child* (frame-selected-child parent))))) + (when frame-is-root? + (setf *current-root* *current-child*)) + (show-all-children *current-root*))) + +(defun select-next-brother () + "Select the next brother frame" + (select-next/previous-brother #'anti-rotate-list)) + +(defun select-previous-brother () + "Select the previous brother frame" + (select-next/previous-brother #'rotate-list)) +;;; end transitional part Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Mon Apr 20 17:13:55 2009 @@ -63,7 +63,8 @@ (defun sm-handle-motion-notify (&rest event-slots &key window root-x root-y &allow-other-keys) (declare (ignore event-slots)) (unless (compress-motion-notify) - (funcall-button-from-code *second-mouse* 'motion 0 window root-x root-y *fun-press*))) + (funcall-button-from-code *second-mouse* 'motion 0 window root-x root-y *fun-press*) + (draw-second-mode-window))) (defun sm-handle-button-press (&rest event-slots &key window root-x root-y code state &allow-other-keys) (declare (ignore event-slots)) From pbrochard at common-lisp.net Wed Apr 22 20:39:09 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 22 Apr 2009 16:39:09 -0400 Subject: [clfswm-cvs] r213 - in clfswm: . src Message-ID: Author: pbrochard Date: Wed Apr 22 16:39:09 2009 New Revision: 213 Log: Use a generic mode for query-string Modified: clfswm/ChangeLog clfswm/clfswm.asd clfswm/src/clfswm-generic-mode.lisp clfswm/src/clfswm-info.lisp clfswm/src/clfswm-keys.lisp clfswm/src/clfswm-query.lisp clfswm/src/clfswm-second-mode.lisp clfswm/src/package.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Apr 22 16:39:09 2009 @@ -1,3 +1,7 @@ +2009-04-22 Xavier Maillard + + * src/clfswm-query.lisp (query-string): Use a generic mode. + 2009-04-19 Xavier Maillard * src/clfswm-info.lisp (info-mode): Use generic-mode for info-mode. Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Wed Apr 22 16:39:09 2009 @@ -49,7 +49,8 @@ (:file "clfswm-menu" :depends-on ("package" "clfswm-info")) (:file "clfswm-query" - :depends-on ("package" "config" "xlib-util")) + :depends-on ("package" "config" "xlib-util" "clfswm-keys" + "clfswm-generic-mode")) (:file "clfswm-util" :depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode" "clfswm-query" "clfswm-menu" "clfswm-autodoc" "clfswm-corner")) (:file "clfswm-layout" Modified: clfswm/src/clfswm-generic-mode.lisp ============================================================================== --- clfswm/src/clfswm-generic-mode.lisp (original) +++ clfswm/src/clfswm-generic-mode.lisp Wed Apr 22 16:39:09 2009 @@ -26,7 +26,7 @@ (in-package :clfswm) -(defun generic-mode (&key enter-function loop-function leave-function +(defun generic-mode (exit-tag &key enter-function loop-function leave-function (button-press-hook *button-press-hook*) (button-release-hook *button-release-hook*) (motion-notify-hook *motion-notify-hook*) @@ -67,7 +67,7 @@ t)) (nfuncall enter-function) (unwind-protect - (catch 'exit-second-loop + (catch exit-tag (loop (nfuncall loop-function) (xlib:display-finish-output *display*) Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Wed Apr 22 16:39:09 2009 @@ -242,37 +242,30 @@ (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info))) (handle-button-release (&rest event-slots &key window root-x root-y code state &allow-other-keys) (declare (ignore event-slots)) - (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info))) - (info-handle-unmap-notify (&rest event-slots) - (apply #'handle-unmap-notify event-slots) - (draw-info-window info)) - (info-handle-destroy-notify (&rest event-slots) - (apply #'handle-destroy-notify event-slots) - (draw-info-window info))) + (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info)))) (xlib:map-window window) (draw-info-window info) (xgrab-pointer *root* 68 69) (unless keyboard-grabbed-p (xgrab-keyboard *root*)) - (unwind-protect - (catch 'exit-info-loop - (generic-mode :loop-function (lambda () - (raise-window (info-window info)) - (draw-info-window info)) - :button-press-hook #'handle-button-press - :button-release-hook #'handle-button-release - :motion-notify-hook #'handle-motion-notify - :key-press-hook #'handle-key)) - (if pointer-grabbed-p - (xgrab-pointer *root* 66 67) - (xungrab-pointer)) - (unless keyboard-grabbed-p - (xungrab-keyboard)) - (xlib:free-gcontext gc) - (xlib:destroy-window window) - (xlib:close-font font) - (display-all-frame-info) - (wait-no-key-or-button-press))))))) + (generic-mode 'exit-info-loop + :loop-function (lambda () + (raise-window (info-window info)) + (draw-info-window info)) + :button-press-hook #'handle-button-press + :button-release-hook #'handle-button-release + :motion-notify-hook #'handle-motion-notify + :key-press-hook #'handle-key) + (if pointer-grabbed-p + (xgrab-pointer *root* 66 67) + (xungrab-pointer)) + (unless keyboard-grabbed-p + (xungrab-keyboard)) + (xlib:free-gcontext gc) + (xlib:destroy-window window) + (xlib:close-font font) + (display-all-frame-info) + (wait-no-key-or-button-press)))))) Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Wed Apr 22 16:39:09 2009 @@ -60,7 +60,7 @@ (define-init-hash-table-key *second-mouse* "Mouse buttons actions in second mode") (define-init-hash-table-key *info-keys* "Info mode keys") (define-init-hash-table-key *info-mouse* "Mouse buttons actions in info mode") - +(define-init-hash-table-key *query-keys* "Query mode keys") (defun unalias-modifiers (list) @@ -113,6 +113,7 @@ (define-define-key "main" *main-keys*) (define-define-key "second" *second-keys*) (define-define-key "info" *info-keys*) +(define-define-key "query" *query-keys*) (define-define-mouse "main-mouse" *main-mouse*) (define-define-mouse "second-mouse" *second-mouse*) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Wed Apr 22 16:39:09 2009 @@ -26,6 +26,19 @@ (in-package :clfswm) +(defparameter *query-window* nil) +(defparameter *query-font* nil) +(defparameter *query-gc* nil) + +(defparameter *query-history* nil) + +(defparameter *query-message* nil) +(defparameter *query-string* nil) +(defparameter *query-pos* nil) +(defparameter *query-return* nil) + + + (defun query-show-paren (orig-string pos) "Replace matching parentheses with brackets" (let ((string (copy-seq orig-string))) @@ -54,142 +67,234 @@ string))) -;;; CONFIG - Query string mode -(let ((history nil)) - (defun clear-history () - "Clear the query-string history" - (setf history nil)) - - (defun query-string (msg &optional (default "")) - "Query a string from the keyboard. Display msg as prompt" - (let* ((done nil) - (font (xlib:open-font *display* *query-font-string*)) - (window (xlib:create-window :parent *root* - :x 0 :y 0 - :width (- (xlib:screen-width *screen*) 2) - :height (* 3 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) - :background (get-color *query-background*) - :border-width 1 - :border (get-color *query-border*) - :colormap (xlib:screen-default-colormap *screen*) - :event-mask '(:exposure))) - (gc (xlib:create-gcontext :drawable window - :foreground (get-color *query-foreground*) - :background (get-color *query-background*) - :font font - :line-style :solid)) - (result-string default) - (pos (length default)) - (local-history history) - (grab-keyboard-p (xgrab-keyboard-p)) - (grab-pointer-p (xgrab-pointer-p))) - (labels ((add-cursor (string) - (concatenate 'string (subseq string 0 pos) "|" (subseq string pos))) - (print-string () - (clear-pixmap-buffer window gc) - (setf (xlib:gcontext-foreground gc) (get-color *query-foreground*)) - (xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5) msg) - (when (< pos 0) (setf pos 0)) - (when (> pos (length result-string)) (setf pos (length result-string))) - (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5) - (add-cursor (query-show-paren result-string pos))) - (copy-pixmap-buffer window gc)) - (call-backspace (modifiers) - (let ((del-pos (if (member :control modifiers) - (or (position #\Space result-string :from-end t :end pos) 0) - (1- pos)))) - (when (>= del-pos 0) - (setf result-string (concatenate 'string - (subseq result-string 0 del-pos) - (subseq result-string pos)) - pos del-pos)))) - (call-delete (modifiers) - (let ((del-pos (if (member :control modifiers) - (1+ (or (position #\Space result-string :start pos) (1- (length result-string)))) - (1+ pos)))) - (if (<= del-pos (length result-string)) - (setf result-string (concatenate 'string - (subseq result-string 0 pos) - (subseq result-string del-pos)))))) - (call-delete-eof () - (setf result-string (subseq result-string 0 pos))) - (handle-query-key (&rest event-slots &key root code state &allow-other-keys) - (declare (ignore event-slots root)) - (let* ((modifiers (state->modifiers state)) - (keysym (keycode->keysym code modifiers)) - (char (xlib:keysym->character *display* keysym)) - (keysym-name (keysym->keysym-name keysym))) - (setf done (cond ((string-equal keysym-name "Return") :Return) - ((string-equal keysym-name "Tab") :Complet) - ((string-equal keysym-name "Escape") :Escape) - (t nil))) - (cond ((string-equal keysym-name "Left") - (when (> pos 0) - (setf pos (if (member :control modifiers) - (let ((p (position #\Space result-string - :end (min (1- pos) (length result-string)) - :from-end t))) - (if p p 0)) - (1- pos))))) - ((string-equal keysym-name "Right") - (when (< pos (length result-string)) - (setf pos (if (member :control modifiers) - (let ((p (position #\Space result-string - :start (min (1+ pos) (length result-string))))) - (if p p (length result-string))) - (1+ pos))))) - ((string-equal keysym-name "Up") - (setf result-string (first local-history) - pos (length result-string) - local-history (rotate-list local-history))) - ((string-equal keysym-name "Down") - (setf result-string (first local-history) - pos (length result-string) - local-history (anti-rotate-list local-history))) - ((string-equal keysym-name "Home") (setf pos 0)) - ((string-equal keysym-name "End") (setf pos (length result-string))) - ((string-equal keysym-name "Backspace") (call-backspace modifiers)) - ((string-equal keysym-name "Delete") (call-delete modifiers)) - ((and (string-equal keysym-name "k") (member :control modifiers)) - (call-delete-eof)) - ((and (characterp char) (standard-char-p char)) - (setf result-string (concatenate 'string - (when (<= pos (length result-string)) - (subseq result-string 0 pos)) - (string char) - (when (< pos (length result-string)) - (subseq result-string pos)))) - (incf pos))) - (print-string))) - (handle-query (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - (case event-key - (:key-press (apply #'handle-query-key event-slots) t) - (:exposure (print-string))) - t)) - (xgrab-pointer *root* 92 93) - (unless grab-keyboard-p - (ungrab-main-keys) - (xgrab-keyboard *root*)) - (xlib:map-window window) - (print-string) - (wait-no-key-or-button-press) - (unwind-protect - (loop until (member done '(:Return :Escape :Complet)) do - (xlib:display-finish-output *display*) - (xlib:process-event *display* :handler #'handle-query)) - (xlib:destroy-window window) - (xlib:close-font font) - (unless grab-keyboard-p - (xungrab-keyboard) - (grab-main-keys)) - (if grab-pointer-p - (xgrab-pointer *root* 66 67) - (xungrab-pointer)))) - (values (when (member done '(:Return :Complet)) - (push result-string history) - result-string) - done)))) +(defun clear-query-history () + "Clear the query-string history" + (setf *query-history* nil)) + + + +(defun leave-query-mode (&optional (return :Escape)) + "Leave the query mode" + (setf *query-return* return) + (throw 'exit-query-loop nil)) + +(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-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*)) + (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*))) + (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*))) + (copy-pixmap-buffer *query-window* *query-gc*)) + + + +(defun query-enter-function () + (setf *query-font* (xlib:open-font *display* *query-font-string*) + *query-window* (xlib:create-window :parent *root* + :x 0 :y 0 + :width (- (xlib:screen-width *screen*) 2) + :height (* 3 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) + :background (get-color *query-background*) + :border-width 1 + :border (get-color *query-border*) + :colormap (xlib:screen-default-colormap *screen*) + :event-mask '(:exposure :key-press)) + *query-gc* (xlib:create-gcontext :drawable *query-window* + :foreground (get-color *query-foreground*) + :background (get-color *query-background*) + :font *query-font* + :line-style :solid)) + (xlib:map-window *query-window*) + (query-print-string) + (wait-no-key-or-button-press)) + + +(defun query-leave-function () + (xlib:destroy-window *query-window*) + (xlib:close-font *query-font*) + (wait-no-key-or-button-press)) + +(defun query-loop-function () + (raise-window *query-window*)) + + + +(add-hook *binding-hook* 'set-default-query-keys) + +(labels ((generic-backspace (del-pos) + (when (>= del-pos 0) + (setf *query-string* (concatenate 'string + (subseq *query-string* 0 del-pos) + (subseq *query-string* *query-pos*)) + *query-pos* del-pos)))) + (defun query-backspace () + "Delete a character backward" + (generic-backspace (1- *query-pos*))) + + (defun query-backspace-word () + "Delete a word backward" + (generic-backspace (or (position #\Space *query-string* :from-end t :end *query-pos*) 0)))) + + +(labels ((generic-delete (del-pos) + (when (<= del-pos (length *query-string*)) + (setf *query-string* (concatenate 'string + (subseq *query-string* 0 *query-pos*) + (subseq *query-string* del-pos)))))) + (defun query-delete () + "Delete a character forward" + (generic-delete (1+ *query-pos*))) + + (defun query-delete-word () + "Delete a word forward" + (generic-delete (1+ (or (position #\Space *query-string* :start *query-pos*) + (1- (length *query-string*))))))) + + + +(defun query-home () + "Move cursor to line begining" + (setf *query-pos* 0)) + +(defun query-end () + "Move cursor to line end" + (setf *query-pos* (length *query-string*))) + + +(defun query-left () + "Move cursor to left" + (when (> *query-pos* 0) + (setf *query-pos* (1- *query-pos*)))) + +(defun query-left-word () + "Move cursor to left word" + (when (> *query-pos* 0) + (setf *query-pos* (let ((p (position #\Space *query-string* + :end (min (1- *query-pos*) (length *query-string*)) + :from-end t))) + (if p p 0))))) + +(defun query-right () + "Move cursor to right" + (when (< *query-pos* (length *query-string*)) + (setf *query-pos* (1+ *query-pos*)))) + +(defun query-right-word () + "Move cursor to right word" + (when (< *query-pos* (length *query-string*)) + (setf *query-pos* (let ((p (position #\Space *query-string* + :start (min (1+ *query-pos*) (length *query-string*))))) + (if p p (length *query-string*)))))) + +(defun query-previous-history () + "Circulate backward in history" + (setf *query-string* (first *query-history*) + *query-pos* (length *query-string*) + *query-history* (rotate-list *query-history*))) + + +(defun query-next-history () + "Circulate forward in history" + (setf *query-string* (first *query-history*) + *query-pos* (length *query-string*) + *query-history* (anti-rotate-list *query-history*))) + + + +(defun query-delete-eof () + "Delete the end of the line" + (setf *query-string* (subseq *query-string* 0 *query-pos*))) + + +(defun set-default-query-keys () + (define-query-key ("Return") 'leave-query-mode-valid) + (define-query-key ("Escape") 'leave-query-mode) + (define-query-key ("Tab") 'leave-query-mode-complet) + (define-query-key ("BackSpace") 'query-backspace) + (define-query-key ("BackSpace" :control) 'query-backspace-word) + (define-query-key ("Delete") 'query-delete) + (define-query-key ("Delete" :control) 'query-delete-word) + (define-query-key ("Home") 'query-home) + (define-query-key ("End") 'query-end) + (define-query-key ("Left") 'query-left) + (define-query-key ("Left" :control) 'query-left-word) + (define-query-key ("Right") 'query-right) + (define-query-key ("Right" :control) 'query-right-word) + (define-query-key ("Up") 'query-previous-history) + (define-query-key ("Down") 'query-next-history) + (define-query-key ("k" :control) 'query-delete-eof)) + + + +(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)) + (setf *query-string* (concatenate 'string + (when (<= *query-pos* (length *query-string*)) + (subseq *query-string* 0 *query-pos*)) + (string char) + (when (< *query-pos* (length *query-string*)) + (subseq *query-string* *query-pos*)))) + (incf *query-pos*)))) + + + + +(defun query-handle-key (&rest event-slots &key root code state &allow-other-keys) + (declare (ignore event-slots root)) + (unless (funcall-key-from-code *query-keys* code state) + (add-in-query-string code state)) + (query-print-string)) + + + + +(defun query-string (message &optional (default "")) + "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)) + (xgrab-pointer *root* 92 93) + (unless grab-keyboard-p + (ungrab-main-keys) + (xgrab-keyboard *root*)) + (generic-mode 'exit-query-loop + :enter-function #'query-enter-function + :loop-function #'query-loop-function + :leave-function #'query-leave-function + :key-press-hook #'query-handle-key) + (unless grab-keyboard-p + (xungrab-keyboard) + (grab-main-keys)) + (if grab-pointer-p + (xgrab-pointer *root* 66 67) + (xungrab-pointer))) + (when (member *query-return* '(:Return :Complet)) + (push *query-string* *query-history*)) + (values *query-string* + *query-return*)) Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Wed Apr 22 16:39:09 2009 @@ -241,7 +241,8 @@ (defun second-key-mode () - (generic-mode :enter-function #'sm-enter-function + (generic-mode 'exit-second-loop + :enter-function #'sm-enter-function :loop-function #'sm-loop-function :leave-function #'sm-leave-function :button-press-hook *sm-button-press-hook* Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Wed Apr 22 16:39:09 2009 @@ -157,7 +157,7 @@ (defparameter *second-mouse* nil) (defparameter *info-keys* nil) (defparameter *info-mouse* nil) - +(defparameter *query-keys* nil) (defstruct menu name item doc) From pbrochard at common-lisp.net Wed Apr 22 20:41:42 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 22 Apr 2009 16:41:42 -0400 Subject: [clfswm-cvs] r214 - clfswm Message-ID: Author: pbrochard Date: Wed Apr 22 16:41:42 2009 New Revision: 214 Log: Test username Modified: clfswm/AUTHORS Modified: clfswm/AUTHORS ============================================================================== --- clfswm/AUTHORS (original) +++ clfswm/AUTHORS Wed Apr 22 16:41:42 2009 @@ -1,7 +1,7 @@ CLFSWM - A(nother) Common Lisp FullScreen Window Manager --------------------------------------------------------- -Philippe Brochard pbrochard at common-lisp dot net +Philippe Brochard pbrochard at common-lisp dot net test Contributors From pbrochard at common-lisp.net Wed Apr 22 21:03:57 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 22 Apr 2009 17:03:57 -0400 Subject: [clfswm-cvs] r215 - in clfswm: . src Message-ID: Author: pbrochard Date: Wed Apr 22 17:03:56 2009 New Revision: 215 Log: run-program-from-query-string: Launch command only with a return validation. Modified: clfswm/ChangeLog clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Apr 22 17:03:56 2009 @@ -1,3 +1,8 @@ +2009-04-22 Philippe Brochard + + * src/clfswm-util.lisp (run-program-from-query-string): Launch + command only with a return validation. + 2009-04-22 Xavier Maillard * src/clfswm-query.lisp (query-string): Use a generic mode. Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Wed Apr 22 17:03:56 2009 @@ -310,8 +310,9 @@ (defun run-program-from-query-string () "Run a program from the query input" - (let ((program (query-string "Run:"))) - (when (and program (not (equal program ""))) + (multiple-value-bind (program return) + (query-string "Run:") + (when (and (equal return :return) program (not (equal program ""))) (setf *second-mode-program* program) (leave-second-mode)))) From pbrochard at common-lisp.net Sun Apr 26 10:56:39 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 26 Apr 2009 06:56:39 -0400 Subject: [clfswm-cvs] r216 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Apr 26 06:56:39 2009 New Revision: 216 Log: Begining of circulate-mode Added: clfswm/src/clfswm-circulate-mode.lisp Modified: clfswm/clfswm.asd clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-keys.lisp clfswm/src/clfswm-query.lisp clfswm/src/config.lisp clfswm/src/package.lisp Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Sun Apr 26 06:56:39 2009 @@ -33,9 +33,12 @@ :depends-on ("package" "tools" "xlib-util")) (:file "clfswm-internal" :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config")) + (:file "clfswm-circulate-mode" + :depends-on ("xlib-util" "clfswm-keys" + "clfswm-internal" "netwm-util" "tools" "config")) (:file "clfswm" :depends-on ("xlib-util" "netwm-util" "clfswm-keys" "config" - "clfswm-internal" "tools")) + "clfswm-internal" "clfswm-circulate-mode" "tools")) (:file "version" :depends-on ("tools")) (:file "clfswm-second-mode" Added: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- (empty file) +++ clfswm/src/clfswm-circulate-mode.lisp Sun Apr 26 06:56:39 2009 @@ -0,0 +1,393 @@ +;;; -------------------------------------------------------------------------- +;;; CLFSWM - FullScreen Window Manager +;;; +;;; -------------------------------------------------------------------------- +;;; Documentation: Main functions +;;; -------------------------------------------------------------------------- +;;; +;;; (C) 2005 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) + +(defparameter *circulate-window* nil) +(defparameter *circulate-font* nil) +(defparameter *circulate-gc* nil) + +(defparameter *circulate-hit* 0) +(defparameter *circulate-orig* nil) +(defparameter *circulate-parent* nil) + +(defparameter *circulate-leave-key* nil) + + +(defun draw-circulate-mode-window () + (raise-window *circulate-window*) + (clear-pixmap-buffer *circulate-window* *circulate-gc*) + (let* ((text (format nil "Current: ~A Focus: ~A" + (child-fullname *current-child*) + (child-fullname (xlib:input-focus *display*)))) + (len (length text))) + (xlib:draw-glyphs *pixmap-buffer* *circulate-gc* + (truncate (/ (- *circulate-width* (* (xlib:max-char-width *circulate-font*) len)) 2)) + (truncate (/ (+ *circulate-height* (- (xlib:font-ascent *circulate-font*) (xlib:font-descent *circulate-font*))) 2)) + text)) + (copy-pixmap-buffer *circulate-window* *circulate-gc*)) + + + +(defun leave-circulate-mode () + "Leave the circulate mode" + (throw 'exit-circulate-loop nil)) + +(defun reorder-child (direction) + (with-slots (child) *current-child* + (when *circulate-orig* + (let ((elem (nth (mod (incf *circulate-hit* direction) (length *circulate-orig*)) *circulate-orig*))) + (setf child (nconc (list elem) (remove elem *circulate-orig*)))))) + (show-all-children) + (draw-circulate-mode-window)) + + +(defun reorder-brother (direction) + (let ((frame-is-root? (and (equal *current-root* *current-child*) + (not (equal *current-root* *root-frame*))))) + (if frame-is-root? + (hide-all *current-root*) + (select-current-frame nil)) + (let ((elem (nth (mod (incf *circulate-hit* direction) (length *circulate-orig*)) *circulate-orig*))) + (setf (frame-child *circulate-parent*) (nconc (list elem) (remove elem *circulate-orig*)) + *current-child* (frame-selected-child *circulate-parent*))) + (when frame-is-root? + (setf *current-root* *current-child*)) + (show-all-children *current-root*) + (draw-circulate-mode-window))) + + + +(defun reset-circulate-child () + (setf *circulate-hit* 0 + *circulate-parent* nil + *circulate-orig* (frame-child *current-child*))) + +(defun reset-circulate-brother () + (setf *circulate-parent* (find-parent-frame *current-child*)) + (when (frame-p *circulate-parent*) + (setf *circulate-orig* (frame-child *circulate-parent*)))) + + + +(defun circulate-select-next-child () + "Select the next child" + (when (frame-p *current-child*) + (when *circulate-parent* + (reset-circulate-child)) + (reorder-child +1))) + +(defun circulate-select-previous-child () + "Select the previous child" + (when (frame-p *current-child*) + (when *circulate-parent* + (reset-circulate-child)) + (reorder-child -1))) + + +(defun circulate-select-next-brother () + "Select the next brother" + (unless *circulate-parent* + (reset-circulate-brother)) + (reorder-brother +1)) + +(defun circulate-select-previous-brother () + "Select the previous borther" + (unless *circulate-parent* + (reset-circulate-brother)) + (reorder-brother -1)) + + + +(add-hook *binding-hook* 'set-default-circulate-keys) + +(defun set-default-circulate-keys () + (define-circulate-key ("Escape") 'leave-circulate-mode) + (define-circulate-key ("Tab" :mod-1) 'circulate-select-next-child) + (define-circulate-key ("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)) + + +(defun set-circulate-leave-key () + (maphash #'(lambda (key value) + (when (and (listp value) (member 'leave-circulate-mode value)) + (setf *circulate-leave-key* (typecase (first key) + (character (list (char->keycode (first key)))) + (number (list (first key))) + (string (multiple-value-list + (xlib:keysym->keycodes *display* (keysym-name->keysym (first key))))))))) + *circulate-keys-release*)) + + + + + + + + +(defun circulate-leave-function () + (xlib:destroy-window *circulate-window*) + (xlib:close-font *circulate-font*) + (xlib:display-finish-output *display*)) + +(defun circulate-loop-function () + ;;; Check if the key modifier is alway pressed + (let ((leave t)) + (loop for k across (xlib:query-keymap *display*) + for i from 0 + do (when (and (plusp k) (member i *circulate-leave-key*)) + (setf leave nil) + (return))) + (when leave + (leave-circulate-mode))) + (raise-window *circulate-window*)) + +(defun circulate-handle-key-press (&rest event-slots &key root code state &allow-other-keys) + (declare (ignore event-slots root)) + (unless (funcall-key-from-code *circulate-keys* code state) + (setf *circulate-hit* 0 + *circulate-orig* nil + *circulate-parent* nil) + (funcall-key-from-code *main-keys* code state))) + + +(defun circulate-handle-key-release (&rest event-slots &key root code state &allow-other-keys) + (declare (ignore event-slots root)) + (funcall-key-from-code *circulate-keys-release* code state)) + +(defun circulate-handle-exposure (&rest event-slots) + (apply #'handle-exposure event-slots) + (draw-circulate-mode-window)) + + + +(defun circulate-mode (&key child-direction brother-direction) + (setf *circulate-hit* 0) + (set-circulate-leave-key) + (setf *circulate-font* (xlib:open-font *display* *circulate-font-string*) + *circulate-window* (xlib:create-window :parent *root* + :x (truncate (/ (- (xlib:screen-width *screen*) *circulate-width*) 2)) + :y (- (xlib:screen-height *screen*) *circulate-height* 2) + :width *circulate-width* + :height *circulate-height* + :background (get-color *circulate-background*) + :border-width 1 + :border (get-color *circulate-border*) + :colormap (xlib:screen-default-colormap *screen*) + :event-mask '(:exposure :key-press)) + *circulate-gc* (xlib:create-gcontext :drawable *circulate-window* + :foreground (get-color *circulate-foreground*) + :background (get-color *circulate-background*) + :font *circulate-font* + :line-style :solid)) + (xlib:map-window *circulate-window*) + (draw-circulate-mode-window) + (when child-direction + (reorder-child child-direction)) + (when brother-direction + (reorder-brother brother-direction)) + (let ((grab-keyboard-p (xgrab-keyboard-p)) + (grab-pointer-p (xgrab-pointer-p))) + (xgrab-pointer *root* 92 93) + (unless grab-keyboard-p + (ungrab-main-keys) + (xgrab-keyboard *root*)) + (generic-mode 'exit-circulate-loop + :loop-function #'circulate-loop-function + :leave-function #'circulate-leave-function + :key-press-hook #'circulate-handle-key-press + :key-release-hook #'circulate-handle-key-release + :exposure-hook #'circulate-handle-exposure) + (unless grab-keyboard-p + (xungrab-keyboard) + (grab-main-keys)) + (if grab-pointer-p + (xgrab-pointer *root* 66 67) + (xungrab-pointer)))) + + +(defun select-next-child () + "Select the next child" + (when (frame-p *current-child*) + (setf *circulate-orig* (frame-child *current-child*) + *circulate-parent* nil) + (circulate-mode :child-direction +1))) + +(defun select-previous-child () + "Select the previouschild" + (when (frame-p *current-child*) + (setf *circulate-orig* (frame-child *current-child*) + *circulate-parent* nil) + (circulate-mode :child-direction -1))) + + +(defun select-next-brother () + "Select the next brother" + (setf *circulate-parent* (find-parent-frame *current-child*)) + (when (frame-p *circulate-parent*) + (setf *circulate-orig* (frame-child *circulate-parent*))) + (circulate-mode :brother-direction +1)) + +(defun select-previous-brother () + "Select the previous brother" + (setf *circulate-parent* (find-parent-frame *current-child*)) + (when (frame-p *circulate-parent*) + (setf *circulate-orig* (frame-child *circulate-parent*))) + (circulate-mode :brother-direction -1)) + + +;;;; New circulate mode - work in progress +;;(let ((modifier nil) +;; (reverse-modifiers nil)) +;; (defun define-circulate-modifier (keysym) +;; (setf modifier (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym keysym))))) +;; (defun define-circulate-reverse-modifier (keysym-list) +;; (setf reverse-modifiers keysym-list)) +;; (defun select-next-* (orig direction set-fun) +;; (let ((done nil) +;; (hit 0)) +;; (labels ((is-reverse-modifier (code state) +;; (member (keysym->keysym-name (keycode->keysym code (state->modifiers state))) +;; reverse-modifiers :test #'string=)) +;; (reorder () +;; (let ((elem (nth (mod (incf hit direction) (length orig)) orig))) +;; (funcall set-fun (nconc (list elem) (remove elem orig))))) +;; (handle-key-press (&rest event-slots &key code state &allow-other-keys) +;; (declare (ignore event-slots)) +;; ;;(dbg 'press root code state) +;; ;;(dbg (first reverse-modifiers) (state->modifiers state)) +;; (if (is-reverse-modifier code state) +;; (setf direction -1) +;; (reorder))) +;; (handle-key-release (&rest event-slots &key code state &allow-other-keys) +;; (declare (ignore event-slots)) +;; ;;(dbg 'release root code state) +;; (when (is-reverse-modifier code state) +;; (setf direction 1)) +;; (when (member code modifier) +;; (setf done t))) +;; (handle-select-next-child-event (&rest event-slots &key display event-key &allow-other-keys) +;; (declare (ignore display)) +;; (with-xlib-protect +;; (case event-key +;; (:key-press (apply #'handle-key-press event-slots)) +;; (:key-release (apply #'handle-key-release event-slots)))) +;; t)) +;; (ungrab-main-keys) +;; (xgrab-keyboard *root*) +;; (reorder) +;; (loop until done do +;; (with-xlib-protect +;; (xlib:display-finish-output *display*) +;; (xlib:process-event *display* :handler #'handle-select-next-child-event))) +;; (xungrab-keyboard) +;; (grab-main-keys))))) +;; +;;(defun set-select-next-child (new) +;; (setf (frame-child *current-child*) new) +;; (show-all-children)) +;; +;;(defun select-next-child () +;; "Select the next child" +;; (select-next-* (frame-child *current-child*) 1 #'set-select-next-child)) +;; +;;(defun select-previous-child () +;; "Select the previous child" +;; (select-next-* (frame-child *current-child*) -1 #'set-select-next-child)) +;; +;;(let ((parent nil)) +;; (defun set-select-next-brother (new) +;; (let ((frame-is-root? (and (equal *current-root* *current-child*) +;; (not (equal *current-root* *root-frame*))))) +;; (if frame-is-root? +;; (hide-all *current-root*) +;; (select-current-frame nil)) +;; (setf (frame-child parent) new +;; *current-child* (frame-selected-child parent)) +;; (when frame-is-root? +;; (setf *current-root* *current-child*)) +;; (show-all-children *current-root*))) +;; +;; (defun select-next-brother () +;; "Select the next brother frame" +;; (setf parent (find-parent-frame *current-child*)) +;; (when (frame-p parent) +;; (select-next-* (frame-child parent) 1 #'set-select-next-brother))) +;; +;; (defun select-previous-brother () +;; "Select the previous brother frame" +;; (setf parent (find-parent-frame *current-child*)) +;; (when (frame-p parent) +;; (select-next-* (frame-child parent) -1 #'set-select-next-brother)))) + + +;;;;; This is only transitional +;;(defun select-next/previous-child (fun-rotate) +;; "Select the next/previous child" +;; (when (frame-p *current-child*) +;; (unselect-all-frames) +;; (with-slots (child) *current-child* +;; (setf child (funcall fun-rotate child))) +;; (show-all-children))) +;; +;; +;;(defun select-next-child () +;; "Select the next child" +;; (select-next/previous-child #'rotate-list)) +;; +;;(defun select-previous-child () +;; "Select the previous child" +;; (select-next/previous-child #'anti-rotate-list)) +;; +;; +;;(defun select-next/previous-brother (fun-rotate) +;; "Select the next/previous brother frame" +;; (let ((frame-is-root? (and (equal *current-root* *current-child*) +;; (not (equal *current-root* *root-frame*))))) +;; (if frame-is-root? +;; (hide-all *current-root*) +;; (select-current-frame nil)) +;; (let ((parent (find-parent-frame *current-child*))) +;; (when (frame-p parent) +;; (with-slots (child) parent +;; (setf child (funcall fun-rotate child)) +;; (setf *current-child* (frame-selected-child parent))))) +;; (when frame-is-root? +;; (setf *current-root* *current-child*)) +;; (show-all-children *current-root*))) +;; +;; +;;(defun select-next-brother () +;; "Select the next brother frame" +;; (select-next/previous-brother #'anti-rotate-list)) +;; +;;(defun select-previous-brother () +;; "Select the previous brother frame" +;; (select-next/previous-brother #'rotate-list)) +;;;;; end transitional part Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sun Apr 26 06:56:39 2009 @@ -160,7 +160,7 @@ (defgeneric child-fullname (child)) (defmethod child-fullname ((child xlib:window)) - (format nil "~A (~A)" (xlib:wm-name child) (xlib:get-wm-class child))) + (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?"))) (defmethod child-fullname ((child frame)) (aif (frame-name child) @@ -743,139 +743,6 @@ - -;; New circulate mode - work in progress -;;(let ((modifier nil) -;; (reverse-modifiers nil)) -;; (defun define-circulate-modifier (keysym) -;; (setf modifier (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym keysym))))) -;; (defun define-circulate-reverse-modifier (keysym-list) -;; (setf reverse-modifiers keysym-list)) -;; (defun select-next-* (orig direction set-fun) -;; (let ((done nil) -;; (hit 0)) -;; (labels ((is-reverse-modifier (code state) -;; (member (keysym->keysym-name (keycode->keysym code (state->modifiers state))) -;; reverse-modifiers :test #'string=)) -;; (reorder () -;; (let ((elem (nth (mod (incf hit direction) (length orig)) orig))) -;; (funcall set-fun (nconc (list elem) (remove elem orig))))) -;; (handle-key-press (&rest event-slots &key code state &allow-other-keys) -;; (declare (ignore event-slots)) -;; ;;(dbg 'press root code state) -;; ;;(dbg (first reverse-modifiers) (state->modifiers state)) -;; (if (is-reverse-modifier code state) -;; (setf direction -1) -;; (reorder))) -;; (handle-key-release (&rest event-slots &key code state &allow-other-keys) -;; (declare (ignore event-slots)) -;; ;;(dbg 'release root code state) -;; (when (is-reverse-modifier code state) -;; (setf direction 1)) -;; (when (member code modifier) -;; (setf done t))) -;; (handle-select-next-child-event (&rest event-slots &key display event-key &allow-other-keys) -;; (declare (ignore display)) -;; (with-xlib-protect -;; (case event-key -;; (:key-press (apply #'handle-key-press event-slots)) -;; (:key-release (apply #'handle-key-release event-slots)))) -;; t)) -;; (ungrab-main-keys) -;; (xgrab-keyboard *root*) -;; (reorder) -;; (loop until done do -;; (with-xlib-protect -;; (xlib:display-finish-output *display*) -;; (xlib:process-event *display* :handler #'handle-select-next-child-event))) -;; (xungrab-keyboard) -;; (grab-main-keys))))) -;; -;;(defun set-select-next-child (new) -;; (setf (frame-child *current-child*) new) -;; (show-all-children)) -;; -;;(defun select-next-child () -;; "Select the next child" -;; (select-next-* (frame-child *current-child*) 1 #'set-select-next-child)) -;; -;;(defun select-previous-child () -;; "Select the previous child" -;; (select-next-* (frame-child *current-child*) -1 #'set-select-next-child)) -;; -;;(let ((parent nil)) -;; (defun set-select-next-brother (new) -;; (let ((frame-is-root? (and (equal *current-root* *current-child*) -;; (not (equal *current-root* *root-frame*))))) -;; (if frame-is-root? -;; (hide-all *current-root*) -;; (select-current-frame nil)) -;; (setf (frame-child parent) new -;; *current-child* (frame-selected-child parent)) -;; (when frame-is-root? -;; (setf *current-root* *current-child*)) -;; (show-all-children *current-root*))) -;; -;; (defun select-next-brother () -;; "Select the next brother frame" -;; (setf parent (find-parent-frame *current-child*)) -;; (when (frame-p parent) -;; (select-next-* (frame-child parent) 1 #'set-select-next-brother))) -;; -;; (defun select-previous-brother () -;; "Select the previous brother frame" -;; (setf parent (find-parent-frame *current-child*)) -;; (when (frame-p parent) -;; (select-next-* (frame-child parent) -1 #'set-select-next-brother)))) - - -;;; This is only transitional -(defun select-next/previous-child (fun-rotate) - "Select the next/previous child" - (when (frame-p *current-child*) - (unselect-all-frames) - (with-slots (child) *current-child* - (setf child (funcall fun-rotate child))) - (show-all-children))) - - -(defun select-next-child () - "Select the next child" - (select-next/previous-child #'rotate-list)) - -(defun select-previous-child () - "Select the previous child" - (select-next/previous-child #'anti-rotate-list)) - - -(defun select-next/previous-brother (fun-rotate) - "Select the next/previous brother frame" - (let ((frame-is-root? (and (equal *current-root* *current-child*) - (not (equal *current-root* *root-frame*))))) - (if frame-is-root? - (hide-all *current-root*) - (select-current-frame nil)) - (let ((parent (find-parent-frame *current-child*))) - (when (frame-p parent) - (with-slots (child) parent - (setf child (funcall fun-rotate child)) - (setf *current-child* (frame-selected-child parent))))) - (when frame-is-root? - (setf *current-root* *current-child*)) - (show-all-children *current-root*))) - - -(defun select-next-brother () - "Select the next brother frame" - (select-next/previous-brother #'anti-rotate-list)) - -(defun select-previous-brother () - "Select the previous brother frame" - (select-next/previous-brother #'rotate-list)) -;;; end transitional part - - - (defun enter-frame () "Enter in the selected frame - ie make it the root frame" (hide-all *current-root*) @@ -891,6 +758,9 @@ (show-all-children *current-root*)) +;;; Other actions (select-next-child, select-next-brother...) are in +;;; clfswm-circulate-mode.lisp + (defun frame-lower-child () Modified: clfswm/src/clfswm-keys.lisp ============================================================================== --- clfswm/src/clfswm-keys.lisp (original) +++ clfswm/src/clfswm-keys.lisp Sun Apr 26 06:56:39 2009 @@ -62,6 +62,10 @@ (define-init-hash-table-key *info-mouse* "Mouse buttons actions in info mode") (define-init-hash-table-key *query-keys* "Query mode keys") +(define-init-hash-table-key *circulate-keys* "Circulate mode keys") +(define-init-hash-table-key *circulate-keys-release* "Circulate mode release keys") + + (defun unalias-modifiers (list) (dolist (mod *modifier-alias*) @@ -115,6 +119,9 @@ (define-define-key "info" *info-keys*) (define-define-key "query" *query-keys*) +(define-define-key "circulate" *circulate-keys*) +(define-define-key "circulate-release" *circulate-keys-release*) + (define-define-mouse "main-mouse" *main-mouse*) (define-define-mouse "second-mouse" *second-mouse*) (define-define-mouse "info-mouse" *info-mouse*) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Sun Apr 26 06:56:39 2009 @@ -137,8 +137,6 @@ -(add-hook *binding-hook* 'set-default-query-keys) - (labels ((generic-backspace (del-pos) (when (>= del-pos 0) (setf *query-string* (concatenate 'string @@ -224,6 +222,8 @@ (setf *query-string* (subseq *query-string* 0 *query-pos*))) +(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) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sun Apr 26 06:56:39 2009 @@ -237,6 +237,22 @@ (defparameter *info-font-string* *default-font-string* "Config(Info mode group): Info window font string") +;;; CONFIG - Circulate string colors +(defparameter *circulate-font-string* *default-font-string* + "Config(Circulate mode group): Circulate string window font string") +(defparameter *circulate-background* "black" + "Config(Circulate mode group): Circulate string window background color") +(defparameter *circulate-foreground* "green" + "Config(Circulate mode group): Circulate string window foreground color") +(defparameter *circulate-border* "red" + "Config(Circulate mode group): Circulate string window border color") +(defparameter *circulate-width* 400 + "Config(Circulate mode group): Circulate mode window width") +(defparameter *circulate-height* 15 + "Config(Circulate mode group): Circulate mode window height") + + + ;;; CONFIG - Show key binding colors (defparameter *info-color-title* "Magenta" "Config(Info mode group): Colored info title color") Modified: clfswm/src/package.lisp ============================================================================== --- clfswm/src/package.lisp (original) +++ clfswm/src/package.lisp Sun Apr 26 06:56:39 2009 @@ -158,6 +158,8 @@ (defparameter *info-keys* nil) (defparameter *info-mouse* nil) (defparameter *query-keys* nil) +(defparameter *circulate-keys* nil) +(defparameter *circulate-keys-release* nil) (defstruct menu name item doc) From pbrochard at common-lisp.net Mon Apr 27 21:36:55 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 27 Apr 2009 17:36:55 -0400 Subject: [clfswm-cvs] r217 - in clfswm: . src Message-ID: Author: pbrochard Date: Mon Apr 27 17:36:54 2009 New Revision: 217 Log: circulate-mode: Optimisation in window redraw. Modified: clfswm/ChangeLog clfswm/src/clfswm-circulate-mode.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Mon Apr 27 17:36:54 2009 @@ -1,3 +1,8 @@ +2009-04-27 Philippe Brochard + + * src/clfswm-circulate-mode.lisp (circulate-mode): Optimisation in + window redraw. + 2009-04-22 Philippe Brochard * src/clfswm-util.lisp (run-program-from-query-string): Launch Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Mon Apr 27 17:36:54 2009 @@ -127,6 +127,7 @@ (define-circulate-key ("Escape") 'leave-circulate-mode) (define-circulate-key ("Tab" :mod-1) 'circulate-select-next-child) (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) @@ -165,8 +166,7 @@ (setf leave nil) (return))) (when leave - (leave-circulate-mode))) - (raise-window *circulate-window*)) + (leave-circulate-mode)))) (defun circulate-handle-key-press (&rest event-slots &key root code state &allow-other-keys) (declare (ignore event-slots root)) @@ -181,10 +181,6 @@ (declare (ignore event-slots root)) (funcall-key-from-code *circulate-keys-release* code state)) -(defun circulate-handle-exposure (&rest event-slots) - (apply #'handle-exposure event-slots) - (draw-circulate-mode-window)) - (defun circulate-mode (&key child-direction brother-direction) @@ -222,8 +218,7 @@ :loop-function #'circulate-loop-function :leave-function #'circulate-leave-function :key-press-hook #'circulate-handle-key-press - :key-release-hook #'circulate-handle-key-release - :exposure-hook #'circulate-handle-exposure) + :key-release-hook #'circulate-handle-key-release) (unless grab-keyboard-p (xungrab-keyboard) (grab-main-keys)) From pbrochard at common-lisp.net Tue Apr 28 21:26:48 2009 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 28 Apr 2009 17:26:48 -0400 Subject: [clfswm-cvs] r218 - in clfswm: . src Message-ID: Author: pbrochard Date: Tue Apr 28 17:26:48 2009 New Revision: 218 Log: sm-handle-motion-notify: Optimisation when drawing second mode window. Modified: clfswm/ChangeLog clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-second-mode.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Tue Apr 28 17:26:48 2009 @@ -1,3 +1,8 @@ +2009-04-28 Philippe Brochard + + * src/clfswm-second-mode.lisp (sm-handle-motion-notify): + Optimisation when drawing second mode window. + 2009-04-27 Philippe Brochard * src/clfswm-circulate-mode.lisp (circulate-mode): Optimisation in Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Tue Apr 28 17:26:48 2009 @@ -35,7 +35,6 @@ (defparameter *circulate-leave-key* nil) - (defun draw-circulate-mode-window () (raise-window *circulate-window*) (clear-pixmap-buffer *circulate-window* *circulate-gc*) Modified: clfswm/src/clfswm-second-mode.lisp ============================================================================== --- clfswm/src/clfswm-second-mode.lisp (original) +++ clfswm/src/clfswm-second-mode.lisp Tue Apr 28 17:26:48 2009 @@ -33,8 +33,6 @@ "Execute the program string if not nil") - - (defun draw-second-mode-window () (raise-window *sm-window*) (clear-pixmap-buffer *sm-window* *sm-gc*) @@ -63,8 +61,7 @@ (defun sm-handle-motion-notify (&rest event-slots &key window root-x root-y &allow-other-keys) (declare (ignore event-slots)) (unless (compress-motion-notify) - (funcall-button-from-code *second-mouse* 'motion 0 window root-x root-y *fun-press*) - (draw-second-mode-window))) + (funcall-button-from-code *second-mouse* 'motion 0 window root-x root-y *fun-press*))) (defun sm-handle-button-press (&rest event-slots &key window root-x root-y code state &allow-other-keys) (declare (ignore event-slots))