From pbrochard at common-lisp.net Tue Apr 12 19:52:28 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 12 Apr 2011 15:52:28 -0400 Subject: [clfswm-cvs] r439 - clfswm/src Message-ID: Author: pbrochard Date: Tue Apr 12 15:52:28 2011 New Revision: 439 Log: binding(-second-mode).lisp: minor keys update (switch-to-last-child) Modified: clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-util.lisp Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Tue Apr 12 15:52:28 2011 @@ -117,7 +117,7 @@ (define-second-key ("Tab" :mod-1) 'select-next-child) (define-second-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-second-key ("Tab" :mod-1 :control) 'select-next-subchild) - (define-second-key ("Tab" :shift) 'switch-to-last-child) + (define-second-key ("Tab") 'switch-to-last-child) (define-second-key ("Return" :mod-1) 'enter-frame) (define-second-key ("Return" :mod-1 :shift) 'leave-frame) (define-second-key ("Return" :mod-5) 'frame-toggle-maximize) Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Tue Apr 12 15:52:28 2011 @@ -50,7 +50,6 @@ (define-main-key ("Tab" :mod-1) 'select-next-child) (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-main-key ("Tab" :mod-1 :control) 'select-next-subchild) - (define-main-key ("Tab" :shift) 'switch-to-last-child) (define-main-key ("Return" :mod-1) 'enter-frame) (define-main-key ("Return" :mod-1 :shift) 'leave-frame) (define-main-key ("Return" :mod-5) 'frame-toggle-maximize) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Tue Apr 12 15:52:28 2011 @@ -1131,7 +1131,8 @@ *current-child* *current-root*) (focus-all-children *current-child* *current-child*) (show-all-children t)) - (setf last-child current-child)))) + (setf last-child current-child)) + (leave-second-mode))) From pbrochard at common-lisp.net Tue Apr 12 21:20:11 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 12 Apr 2011 17:20:11 -0400 Subject: [clfswm-cvs] r440 - clfswm/contrib/server Message-ID: Author: pbrochard Date: Tue Apr 12 17:20:11 2011 New Revision: 440 Log: contrib/server.lisp: Use the same port variable in the server and the client Modified: clfswm/contrib/server/clfswm-client.lisp clfswm/contrib/server/server.lisp Modified: clfswm/contrib/server/clfswm-client.lisp ============================================================================== --- clfswm/contrib/server/clfswm-client.lisp (original) +++ clfswm/contrib/server/clfswm-client.lisp Tue Apr 12 17:20:11 2011 @@ -50,7 +50,7 @@ #+ccl (ccl:quit)) -(defparameter *server-port* 33333) +;;(defparameter *server-port* 33333) (defun print-output (sock &optional wait) (when (or wait (ignore-errors (listen sock))) @@ -83,7 +83,7 @@ (parse-args sock (subseq args pos)))))) -(defun start-client (args &optional (url "127.0.0.1") (port *server-port*)) +(defun start-client (args &optional (url "127.0.0.1") (port clfswm::*server-port*)) (load-new-key) (let* ((sock (port:open-socket url port)) (key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*)))) Modified: clfswm/contrib/server/server.lisp ============================================================================== --- clfswm/contrib/server/server.lisp (original) +++ clfswm/contrib/server/server.lisp Tue Apr 12 17:20:11 2011 @@ -32,6 +32,9 @@ ;;; Server <-> Client: All connections are crypted with new_key ;;; -------------------------------------------------------------------------- +(in-package :clfswm) + +(defparameter *server-port* 33333) (format t "Loading the clfswm server code... ") @@ -46,9 +49,8 @@ (use-package :crypt) (defstruct server-socket stream auth form key) - (defparameter *server-socket* nil) -(defparameter *server-port* 33333) + (defparameter *server-allowed-host* '("127.0.0.1")) (defparameter *server-wait-timeout* 0.001d0) @@ -59,6 +61,12 @@ +(defun server-show-prompt (sock) + ;;(send-to-client sock nil (format nil "~A> " (package-name *package*)))) + (format (server-socket-stream sock) "~A~%" + (crypt (format nil"~A> " (package-name *package*)) (server-socket-key sock))) + (force-output (server-socket-stream sock))) + (defun send-to-client (sock show-prompt-p &rest msg) (dolist (m (if (consp (car msg)) (car msg) msg)) @@ -67,9 +75,9 @@ (when show-prompt-p (server-show-prompt sock))) +;;(defun server-show-prompt (sock) +;; (send-to-client sock nil (format nil "~A> " (package-name *package*)))) -(defun server-show-prompt (sock) - (send-to-client sock nil (format nil "~A> " (package-name *package*)))) (defun read-from-client (sock) From pbrochard at common-lisp.net Wed Apr 13 12:01:12 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 13 Apr 2011 08:01:12 -0400 Subject: [clfswm-cvs] r441 - in clfswm: . contrib Message-ID: Author: pbrochard Date: Wed Apr 13 08:01:07 2011 New Revision: 441 Log: contrib/clfswm, configure: Add a lisp binary option to choose the binary program used to build clfswm Modified: clfswm/configure clfswm/contrib/clfswm Modified: clfswm/configure ============================================================================== --- clfswm/configure (original) +++ clfswm/configure Wed Apr 13 08:01:07 2011 @@ -5,6 +5,7 @@ PREFIX="/usr/local" lisp=clisp lisp_opt='' +lisp_bin='' dump_path="\$XDG_CACHE_HOME/clfswm/" clfswm_asd_path="$PREFIX/lib/clfswm" asdf_path="$PREFIX/lib/clfswm/contrib" @@ -20,7 +21,8 @@ -h, --help display this help and exit -V, --version display version information and exit --prefix=PREFIX install architecture-independent files in PREFIX [/usr/local] - -l, --with-lisp use as the common lisp implementation [$lisp] + -l, --with-lisp use as the common lisp implementation type [$lisp] + -b, --lisp-bin use as the common lisp program [$lisp_bin] (default: same as with-lisp type) -o, --lisp-opt use as lisp option [$lisp_opt] -d, --dump-path path to the dump directory [$dump_path] --with-clfswm path to clfswm.asd file [$clfswm_asd_path] @@ -29,7 +31,7 @@ By default, 'make install' will install all the files in '/usr/local/bin', '/usr/local/lib' etc. You can specify an installation prefix other than '/usr/local' using '--prefix', -for instance '--prefix=\$HOME/clfswm'." +for instance '--prefix \$HOME/clfswm'." exit 0 } @@ -68,6 +70,9 @@ lisp="$1" ;; esac ;; + -b|--lisp-bin) + shift + lisp_bin="$1" ;; -o|--lisp-opt) shift lisp_opt="$1" ;; @@ -94,6 +99,7 @@ echo " prefix=$PREFIX with-lisp=$lisp + lisp-bin=$lisp_bin lisp-opt=$lisp_opt dump-path=$dump_path with-clfswm=$clfswm_asd_path @@ -102,6 +108,7 @@ sed -e "s?^lisp=.*# +config+?lisp=\"$lisp\" # +config+?g" \ + -e "s?^lisp_bin=.*# +config+?lisp_bin=\"$lisp_bin\" # +config+?g" \ -e "s?^lisp_opt=.*# +config+?lisp_opt=\"$lisp_opt\" # +config+?g" \ -e "s?^dump_path=.*# +config+?dump_path=\"$dump_path\" # +config+?g" \ -e "s?^clfswm_asd_path=.*# +config+?clfswm_asd_path=\"$clfswm_asd_path\" # +config+?g" \ Modified: clfswm/contrib/clfswm ============================================================================== --- clfswm/contrib/clfswm (original) +++ clfswm/contrib/clfswm Wed Apr 13 08:01:07 2011 @@ -35,6 +35,7 @@ no_start=no lisp=clisp # +config+ +lisp_bin='' # +config+ lisp_opt='' # +config+ dump_path="$XDG_CACHE_HOME/clfswm/" # +config+ clfswm_asd_path="$(pwd)" # +config+ @@ -50,6 +51,7 @@ -f, --force force image dump --rebuild same as -f, --force -l, --with-lisp use as the common lisp implementation [$lisp] + -b, --lisp-bin use as the common lisp program [$lisp_bin] (default: same as with-lisp type) -o, --lisp-opt use as lisp option [$lisp_opt] -d, --dump-path path to the dump directory [$dump_path] --with-clfswm path to clfswm.asd file [$clfswm_asd_path] @@ -65,14 +67,14 @@ build_clisp () { - clisp $lisp_opt -m 8MB -E ISO-8859-1 -q -i "$asdf_path"/asdf.lisp -x "(load \"$clfswm_asd_path/clfswm.asd\") + $lisp_bin $lisp_opt -m 8MB -E ISO-8859-1 -q -i "$asdf_path"/asdf.lisp -x "(load \"$clfswm_asd_path/clfswm.asd\") (asdf:oos 'asdf:load-op :clfswm) \ (EXT:SAVEINITMEM \"$dump_image\" :INIT-FUNCTION (lambda () (clfswm:main) (quit)) :EXECUTABLE t :norc t)" } build_sbcl() { - sbcl $lisp_opt --disable-debugger --eval "(require :asdf)" \ + $lisp_bin $lisp_opt --disable-debugger --eval "(require :asdf)" \ --eval "(require :sb-posix)" \ --eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ --eval "(require :clfswm)" \ @@ -81,16 +83,16 @@ build_cmucl() { - cmucl $lisp_opt -eval "(load \"$asdf_path/asdf.lisp\")" \ + $lisp_bin $lisp_opt -eval "(require :clx)" \ + -eval "(load \"$asdf_path/asdf.lisp\")" \ -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ - -eval "(require :clx)" \ -eval "(asdf:oos 'asdf:load-op :clfswm)" \ -eval "(save-lisp \"$dump_image\" :init-function (lambda () (clfswm:main) (quit)))" } build_ccl() { - ccl $lisp_opt --eval "(require :asdf)" \ + $lisp_bin $lisp_opt --eval "(require :asdf)" \ --eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ --eval "(asdf:oos 'asdf:load-op :clfswm)" \ --eval "(save-application \"$dump_image\" :toplevel-function (lambda () (clfswm:main) (quit)))" @@ -98,7 +100,7 @@ build_ecl() { - ecl $lisp_opt -eval "(require :asdf)" \ + $lisp_bin $lisp_opt -eval "(require :asdf)" \ -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ -eval "(asdf:make-build :clfswm :type :program :monolithic t :move-here \".\" :prologue-code '(progn (require :asdf) (require :clx)))" \ -eval "(ext:quit 0)" @@ -132,6 +134,9 @@ lisp="$1" ;; esac ;; + -b|--lisp-bin) + shift + lisp_bin="$1" ;; -o|--lisp-opt) shift lisp_opt="$1" ;; @@ -146,6 +151,9 @@ shift done +if [ "x$lisp_bin" == "x" ]; then + lisp_bin=$lisp +fi dump_image="$dump_path/clfswm-$(cksum $(type -p $lisp) | cut -d ' ' -f 1).core" @@ -202,9 +210,9 @@ echo "Arguments: $* and $ARGS" case $lisp in clisp ) "$dump_image" -- $ARGS ;; - sbcl ) exec sbcl --core "$dump_image" $ARGS ;; - cmucl ) exec cmucl -core "$dump_image" $ARGS ;; - ccl ) exec ccl -I "$dump_image" -- $ARGS ;; + sbcl ) exec $lisp_bin --core "$dump_image" $ARGS ;; + cmucl ) exec $lisp_bin -core "$dump_image" $ARGS ;; + ccl ) exec $lisp_bin -I "$dump_image" -- $ARGS ;; ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" $ARGS ;; *) echo "..." ;; esac From pbrochard at common-lisp.net Wed Apr 13 13:23:01 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 13 Apr 2011 09:23:01 -0400 Subject: [clfswm-cvs] r442 - clfswm/src Message-ID: Author: pbrochard Date: Wed Apr 13 09:23:00 2011 New Revision: 442 Log: clfswm-query.lisp, clfswm-info.lisp: redefine keys before entering in the mode Modified: clfswm/src/clfswm-info.lisp clfswm/src/clfswm-query.lisp Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Wed Apr 13 09:23:00 2011 @@ -344,6 +344,7 @@ (unless keyboard-grabbed-p (xgrab-keyboard *root*)) (wait-no-key-or-button-press) + (set-default-info-keys) (generic-mode 'info-mode 'exit-info-loop :loop-function (lambda () (raise-window (info-window info))) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Wed Apr 13 09:23:00 2011 @@ -315,6 +315,7 @@ (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) + (set-default-query-keys) (generic-mode 'query-mode 'exit-query-loop :enter-function #'query-enter-function :loop-function #'query-loop-function From pbrochard at common-lisp.net Wed Apr 13 22:24:28 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Wed, 13 Apr 2011 18:24:28 -0400 Subject: [clfswm-cvs] r443 - in clfswm: . src Message-ID: Author: pbrochard Date: Wed Apr 13 18:24:28 2011 New Revision: 443 Log: src/clfswm-menu.lisp (open-menu): Save info hash table keys instead of deleting newly created keys. Modified: clfswm/ChangeLog clfswm/src/clfswm-info.lisp clfswm/src/clfswm-menu.lisp clfswm/src/clfswm-query.lisp clfswm/src/menu-def.lisp clfswm/src/tools.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Wed Apr 13 18:24:28 2011 @@ -1,3 +1,8 @@ +2011-04-14 Philippe Brochard + + * src/clfswm-menu.lisp (open-menu): Save info hash table keys + instead of deleting newly created keys. + 2011-03-21 Philippe Brochard * src/clfswm-internal.lisp (x-px->fl, y-px->fl): Takes care of Modified: clfswm/src/clfswm-info.lisp ============================================================================== --- clfswm/src/clfswm-info.lisp (original) +++ clfswm/src/clfswm-info.lisp Wed Apr 13 18:24:28 2011 @@ -344,7 +344,6 @@ (unless keyboard-grabbed-p (xgrab-keyboard *root*)) (wait-no-key-or-button-press) - (set-default-info-keys) (generic-mode 'info-mode 'exit-info-loop :loop-function (lambda () (raise-window (info-window info))) @@ -372,7 +371,8 @@ Separator is a string or a symbol (all but a list) Function can be a function or a list (function color) for colored output" (let ((info-list nil) - (action nil)) + (action nil) + (old-info-keys (copy-hash-table *info-keys*))) (labels ((define-key (key function) (define-info-key-fun (list key) (lambda (&optional args) @@ -394,10 +394,7 @@ (define-key key function))))) (t (push (list (format nil "-=- ~A -=-" item) *menu-color-comment*) info-list)))) (let ((selected-item (info-mode (nreverse info-list) :width width :height height))) - (dolist (item item-list) - (when (consp item) - (let ((key (first item))) - (undefine-info-key-fun (list key))))) + (setf *info-keys* old-info-keys) (when selected-item (awhen (nth selected-item item-list) (when (consp it) Modified: clfswm/src/clfswm-menu.lisp ============================================================================== --- clfswm/src/clfswm-menu.lisp (original) +++ clfswm/src/clfswm-menu.lisp Wed Apr 13 18:24:28 2011 @@ -139,7 +139,8 @@ (defun open-menu (&optional (menu *menu*) (parent nil)) "Open the main menu" - (let ((action nil)) + (let ((action nil) + (old-info-keys (copy-hash-table *info-keys*))) (labels ((populate-menu () (let ((info-list nil)) (dolist (item (menu-item menu)) @@ -159,8 +160,7 @@ (leave-info-mode nil)))))) (nreverse info-list)))) (let ((selected-item (info-mode (populate-menu)))) - (dolist (item (menu-item menu)) - (undefine-info-key-fun (list (menu-item-key item)))) + (setf *info-keys* old-info-keys) (when selected-item (awhen (nth selected-item (menu-item menu)) (setf action (menu-item-value it))))) Modified: clfswm/src/clfswm-query.lisp ============================================================================== --- clfswm/src/clfswm-query.lisp (original) +++ clfswm/src/clfswm-query.lisp Wed Apr 13 18:24:28 2011 @@ -315,7 +315,6 @@ (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) - (set-default-query-keys) (generic-mode 'query-mode 'exit-query-loop :enter-function #'query-enter-function :loop-function #'query-loop-function Modified: clfswm/src/menu-def.lisp ============================================================================== --- clfswm/src/menu-def.lisp (original) +++ clfswm/src/menu-def.lisp Wed Apr 13 18:24:28 2011 @@ -107,33 +107,33 @@ (add-sub-menu 'frame-movement-menu "p" 'frame-pack-menu "Frame pack menu") (add-sub-menu 'frame-movement-menu "f" 'frame-fill-menu "Frame fill menu") -(add-sub-menu 'frame-movement-menu "z" 'frame-resize-menu "Frame resize menu") +(add-sub-menu 'frame-movement-menu "r" 'frame-resize-menu "Frame resize menu") (add-menu-key 'frame-movement-menu "c" 'center-current-frame) -(add-menu-key 'frame-movement-menu "r" 'with-movement-select-next-brother) -(add-menu-key 'frame-movement-menu "l" 'with-movement-select-previous-brother) -(add-menu-key 'frame-movement-menu "u" 'with-movement-select-next-level) -(add-menu-key 'frame-movement-menu "d" 'with-movement-select-previous-level) -(add-menu-key 'frame-movement-menu "t" 'with-movement-select-next-child) - - -(add-menu-key 'frame-pack-menu "u" 'current-frame-pack-up) -(add-menu-key 'frame-pack-menu "d" 'current-frame-pack-down) -(add-menu-key 'frame-pack-menu "l" 'current-frame-pack-left) -(add-menu-key 'frame-pack-menu "r" 'current-frame-pack-right) - - -(add-menu-key 'frame-fill-menu "u" 'current-frame-fill-up) -(add-menu-key 'frame-fill-menu "d" 'current-frame-fill-down) -(add-menu-key 'frame-fill-menu "l" 'current-frame-fill-left) -(add-menu-key 'frame-fill-menu "r" 'current-frame-fill-right) +(add-menu-key 'frame-movement-menu "Right" 'with-movement-select-next-brother) +(add-menu-key 'frame-movement-menu "Left" 'with-movement-select-previous-brother) +(add-menu-key 'frame-movement-menu "Up" 'with-movement-select-next-level) +(add-menu-key 'frame-movement-menu "Down" 'with-movement-select-previous-level) +(add-menu-key 'frame-movement-menu "Tab" 'with-movement-select-next-child) + + +(add-menu-key 'frame-pack-menu "Up" 'current-frame-pack-up) +(add-menu-key 'frame-pack-menu "Down" 'current-frame-pack-down) +(add-menu-key 'frame-pack-menu "Left" 'current-frame-pack-left) +(add-menu-key 'frame-pack-menu "Right" 'current-frame-pack-right) + + +(add-menu-key 'frame-fill-menu "Up" 'current-frame-fill-up) +(add-menu-key 'frame-fill-menu "Down" 'current-frame-fill-down) +(add-menu-key 'frame-fill-menu "Left" 'current-frame-fill-left) +(add-menu-key 'frame-fill-menu "Right" 'current-frame-fill-right) (add-menu-key 'frame-fill-menu "a" 'current-frame-fill-all-dir) (add-menu-key 'frame-fill-menu "v" 'current-frame-fill-vertical) (add-menu-key 'frame-fill-menu "h" 'current-frame-fill-horizontal) -(add-menu-key 'frame-resize-menu "u" 'current-frame-resize-up) -(add-menu-key 'frame-resize-menu "d" 'current-frame-resize-down) -(add-menu-key 'frame-resize-menu "l" 'current-frame-resize-left) -(add-menu-key 'frame-resize-menu "r" 'current-frame-resize-right) +(add-menu-key 'frame-resize-menu "Up" 'current-frame-resize-up) +(add-menu-key 'frame-resize-menu "Down" 'current-frame-resize-down) +(add-menu-key 'frame-resize-menu "Left" 'current-frame-resize-left) +(add-menu-key 'frame-resize-menu "Right" 'current-frame-resize-right) (add-menu-key 'frame-resize-menu "a" 'current-frame-resize-all-dir) (add-menu-key 'frame-resize-menu "m" 'current-frame-resize-all-dir-minimal) Modified: clfswm/src/tools.lisp ============================================================================== --- clfswm/src/tools.lisp (original) +++ clfswm/src/tools.lisp Wed Apr 13 18:24:28 2011 @@ -35,6 +35,8 @@ :config-all-groups :config-group->string :find-in-hash + :view-hash-table + :copy-hash-table :nfuncall :pfuncall :symbol-search @@ -170,6 +172,19 @@ hashtable)) +(defun view-hash-table (title hashtable) + (maphash (lambda (k v) + (format t "[~A] ~A ~A~%" title k v)) + hashtable)) + +(defun copy-hash-table (hashtable) + (let ((rethash (make-hash-table :test (hash-table-test hashtable)))) + (maphash (lambda (k v) + (setf (gethash k rethash) v)) + hashtable) + rethash)) + + (defun nfuncall (function) (when function (funcall function))) From pbrochard at common-lisp.net Thu Apr 14 19:47:37 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Thu, 14 Apr 2011 15:47:37 -0400 Subject: [clfswm-cvs] r444 - in clfswm: . src Message-ID: Author: pbrochard Date: Thu Apr 14 15:47:37 2011 New Revision: 444 Log: src/clfswm-util.lisp (with-movement-select-next-brother, with-movement-select-previous-brother, with-movement-select-next-child): Use a simple method (do not enter in the circulate mode) to allow to circulate in all children or brothers. Modified: clfswm/ChangeLog clfswm/src/clfswm-circulate-mode.lisp clfswm/src/clfswm-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Thu Apr 14 15:47:37 2011 @@ -1,5 +1,11 @@ 2011-04-14 Philippe Brochard + * src/clfswm-util.lisp (with-movement-select-next-brother) + (with-movement-select-previous-brother) + (with-movement-select-next-child): Use a simple method (do not + enter in the circulate mode) to allow to circulate in all children + or brothers. + * src/clfswm-menu.lisp (open-menu): Save info hash table keys instead of deleting newly created keys. Modified: clfswm/src/clfswm-circulate-mode.lisp ============================================================================== --- clfswm/src/clfswm-circulate-mode.lisp (original) +++ clfswm/src/clfswm-circulate-mode.lisp Thu Apr 14 15:47:37 2011 @@ -276,3 +276,33 @@ (setf *circulate-orig* (frame-child *current-child*) *circulate-parent* nil) (circulate-mode :subchild-direction +1))) + + +(defun select-next-child-simple () + "Select the next child (do not enter in circulate mode)" + (when (frame-p *current-child*) + (with-slots (child) *current-child* + (setf child (rotate-list child))) + (show-all-children))) + + + +(defun reorder-brother-simple (reorder-fun) + (unless (child-equal-p *current-child* *current-root*) + (no-focus) + (select-current-frame nil) + (let ((parent-frame (find-parent-frame *current-child*))) + (when (frame-p parent-frame) + (with-slots (child) parent-frame + (setf child (funcall reorder-fun child) + *current-child* (frame-selected-child parent-frame)))) + (show-all-children t)))) + + +(defun select-next-brother-simple () + "Select the next brother frame (do not enter in circulate mode)" + (reorder-brother-simple #'rotate-list)) + +(defun select-previous-brother-simple () + "Select the previous brother frame (do not enter in circulate mode)" + (reorder-brother-simple #'anti-rotate-list)) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Thu Apr 14 15:47:37 2011 @@ -856,11 +856,11 @@ ;;; Children navigation (defun with-movement-select-next-brother () "Select the next brother frame" - (with-movement (select-next-brother))) + (with-movement (select-next-brother-simple))) (defun with-movement-select-previous-brother () "Select the previous brother frame" - (with-movement (select-previous-brother))) + (with-movement (select-previous-brother-simple))) (defun with-movement-select-next-level () "Select the next level" @@ -872,7 +872,7 @@ (defun with-movement-select-next-child () "Select the next child" - (with-movement (select-next-child))) + (with-movement (select-next-child-simple))) From pbrochard at common-lisp.net Sun Apr 17 20:53:44 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Sun, 17 Apr 2011 16:53:44 -0400 Subject: [clfswm-cvs] r445 - in clfswm: . src Message-ID: Author: pbrochard Date: Sun Apr 17 16:53:43 2011 New Revision: 445 Log: src/clfswm-pack.lisp (move-frame-constrained, resize-frame-constrained): New function. Move and resize frame with the mouse constrained by other frame brothers. Modified: clfswm/ChangeLog clfswm/clfswm.asd clfswm/src/bindings.lisp clfswm/src/clfswm-internal.lisp clfswm/src/clfswm-pack.lisp clfswm/src/clfswm-util.lisp clfswm/src/config.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Sun Apr 17 16:53:43 2011 @@ -1,3 +1,9 @@ +2011-04-17 Philippe Brochard + + * src/clfswm-pack.lisp (move-frame-constrained) + (resize-frame-constrained): New function. Move and resize frame + with the mouse constrained by other frame brothers. + 2011-04-14 Philippe Brochard * src/clfswm-util.lisp (with-movement-select-next-brother) Modified: clfswm/clfswm.asd ============================================================================== --- clfswm/clfswm.asd (original) +++ clfswm/clfswm.asd Sun Apr 17 16:53:43 2011 @@ -70,7 +70,7 @@ (:file "clfswm-layout" :depends-on ("package" "clfswm-internal" "clfswm-util" "clfswm-info" "menu-def")) (:file "clfswm-pack" - :depends-on ("clfswm" "clfswm-util" "clfswm-second-mode")) + :depends-on ("clfswm" "clfswm-util" "clfswm-second-mode" "clfswm-layout")) (:file "clfswm-nw-hooks" :depends-on ("package" "clfswm-util" "clfswm-info" "clfswm-layout" "menu-def")) (:file "bindings" Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Sun Apr 17 16:53:43 2011 @@ -106,6 +106,20 @@ (mouse-focus-move/resize-generic root-x root-y #'resize-frame t)) +(defun mouse-click-to-focus-and-move-window-constrained (window root-x root-y) + "Move (constrained by other frames) and focus the current child - Create a new frame on the root window" + (declare (ignore window)) + (stop-button-event) + (mouse-focus-move/resize-generic root-x root-y #'move-frame-constrained t)) + + +(defun mouse-click-to-focus-and-resize-window-constrained (window root-x root-y) + "Resize and focus the current child - Create a new frame on the root window" + (declare (ignore window)) + (stop-button-event) + (mouse-focus-move/resize-generic root-x root-y #'resize-frame-constrained t)) + + (defun set-default-main-mouse () (define-main-mouse (1) 'mouse-click-to-focus-and-move) @@ -113,6 +127,8 @@ (define-main-mouse (3) 'mouse-click-to-focus-and-resize) (define-main-mouse (1 :mod-1) 'mouse-click-to-focus-and-move-window) (define-main-mouse (3 :mod-1) 'mouse-click-to-focus-and-resize-window) + (define-main-mouse (1 :mod-1 :shift) 'mouse-click-to-focus-and-move-window-constrained) + (define-main-mouse (3 :mod-1 :shift) 'mouse-click-to-focus-and-resize-window-constrained) (define-main-mouse (1 :control :mod-1) 'mouse-move-child-over-frame) (define-main-mouse (4) 'mouse-select-next-level) (define-main-mouse (5) 'mouse-select-previous-level) Modified: clfswm/src/clfswm-internal.lisp ============================================================================== --- clfswm/src/clfswm-internal.lisp (original) +++ clfswm/src/clfswm-internal.lisp Sun Apr 17 16:53:43 2011 @@ -548,7 +548,8 @@ (dolist (ch hidden-children) (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) (format nil " ~A - hidden" (ensure-printable (child-fullname ch)))))) - (copy-pixmap-buffer window gc)))) + (copy-pixmap-buffer window gc) + (values t t)))) (defun display-all-frame-info (&optional (root *current-root*)) Modified: clfswm/src/clfswm-pack.lisp ============================================================================== --- clfswm/src/clfswm-pack.lisp (original) +++ clfswm/src/clfswm-pack.lisp Sun Apr 17 16:53:43 2011 @@ -25,6 +25,7 @@ (in-package :clfswm) + ;;;,----- ;;;| Edges functions ;;;`----- @@ -208,3 +209,87 @@ "Create a new frame for each window in frame" (explode-frame *current-child*) (leave-second-mode)) + + + +;;;;;,----- +;;;;;| Constrained move/resize frames +;;;;;`----- +(defun move-frame-constrained (frame parent orig-x orig-y) + (when (and frame parent (not (child-equal-p frame *current-root*))) + (hide-all-children frame) + (with-slots (window) frame + (let ((lx orig-x) + (ly orig-y)) + (move-window window orig-x orig-y + (lambda () + (let ((move-x t) + (move-y t)) + (multiple-value-bind (x y) (xlib:query-pointer *root*) + (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) + (frame-y frame) (y-px->fl (xlib:drawable-y window) parent)) + (when (> x lx) + (let ((x-found (find-edge-right frame parent))) + (when (< (abs (- x-found (frame-x2 frame))) *snap-size*) + (setf (frame-x frame) (- x-found (frame-w frame)) + (xlib:drawable-x window) (adj-border-xy (x-fl->px (frame-x frame) parent) frame) + move-x nil)))) + (when (< x lx) + (let ((x-found (find-edge-left frame parent))) + (when (< (abs (- x-found (frame-x frame))) *snap-size*) + (setf (frame-x frame) x-found + (xlib:drawable-x window) (adj-border-xy (x-fl->px (frame-x frame) parent) frame) + move-x nil)))) + (when (> y ly) + (let ((y-found (find-edge-down frame parent))) + (when (< (abs (- y-found (frame-y2 frame))) *snap-size*) + (setf (frame-y frame) (- y-found (frame-h frame)) + (xlib:drawable-y window) (adj-border-xy (y-fl->px (frame-y frame) parent) frame) + move-y nil)))) + (when (< y ly) + (let ((y-found (find-edge-up frame parent))) + (when (< (abs (- y-found (frame-y frame))) *snap-size*) + (setf (frame-y frame) y-found + (xlib:drawable-y window) (adj-border-xy (y-fl->px (frame-y frame) parent) frame) + move-y nil)))) + (display-frame-info frame) + (when move-x (setf lx x)) + (when move-y (setf ly y)) + (values move-x move-y)))))) + (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) + (frame-y frame) (y-px->fl (xlib:drawable-y window) parent))) + (show-all-children))) + + +(defun resize-frame-constrained (frame parent orig-x orig-y) + (when (and frame parent (not (child-equal-p frame *current-root*))) + (hide-all-children frame) + (with-slots (window) frame + (let ((lx orig-x) + (ly orig-y)) + (resize-window window orig-x orig-y + (lambda () + (let ((resize-w t) + (resize-h t)) + (multiple-value-bind (x y) (xlib:query-pointer *root*) + (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent) + (frame-h frame) (h-px->fl (xlib:drawable-height window) parent)) + (when (> x lx) + (let ((x-found (find-edge-right frame parent))) + (when (< (abs (- x-found (frame-x2 frame))) *snap-size*) + (setf (frame-w frame) (+ (frame-w frame) (- x-found (frame-x2 frame))) + (xlib:drawable-width window) (adj-border-wh (w-fl->px (frame-w frame) parent) frame) + resize-w nil)))) + (when (> y ly) + (let ((y-found (find-edge-down frame parent))) + (when (< (abs (- y-found (frame-y2 frame))) *snap-size*) + (setf (frame-h frame) (+ (frame-h frame) (- y-found (frame-y2 frame))) + (xlib:drawable-height window) (adj-border-wh (h-fl->px (frame-h frame) parent) frame) + resize-h nil)))) + (display-frame-info frame) + (when resize-w (setf lx x)) + (when resize-h (setf ly y)) + (values resize-w resize-h)))))) + (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent) + (frame-h frame) (h-px->fl (xlib:drawable-height window) parent))) + (show-all-children))) Modified: clfswm/src/clfswm-util.lisp ============================================================================== --- clfswm/src/clfswm-util.lisp (original) +++ clfswm/src/clfswm-util.lisp Sun Apr 17 16:53:43 2011 @@ -531,7 +531,6 @@ (hide-all-frames-info)) - (defun move-frame (frame parent orig-x orig-y) (when (and frame parent (not (child-equal-p frame *current-root*))) (hide-all-children frame) @@ -541,7 +540,6 @@ (frame-y frame) (y-px->fl (xlib:drawable-y window) parent))) (show-all-children))) - (defun resize-frame (frame parent orig-x orig-y) (when (and frame parent (not (child-equal-p frame *current-root*))) (hide-all-children frame) @@ -632,8 +630,12 @@ (xlib:window (if (managed-window-p child parent) (funcall mouse-fn parent (find-parent-frame parent) root-x root-y) - (funcall (cond ((eql mouse-fn #'move-frame) #'move-window) - ((eql mouse-fn #'resize-frame) #'resize-window)) + (funcall (cond ((or (eql mouse-fn #'move-frame) + (eql mouse-fn #'move-frame-constrained)) + #'move-window) + ((or (eql mouse-fn #'resize-frame) + (eql mouse-fn #'resize-frame-constrained)) + #'resize-window)) child root-x root-y))) (frame (funcall mouse-fn child parent root-x root-y))) (show-all-children))) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Sun Apr 17 16:53:43 2011 @@ -53,6 +53,10 @@ (defconfig *hide-unmanaged-window* t nil "Hide or not unmanaged windows when a child is deselected.") +(defconfig *snap-size* 0.02 nil + "Snap size when move or resize frame is constrained") + + ;;; CONFIG - Screen size (defun get-fullscreen-size () "Return the size of root child (values rx ry rw rh) @@ -68,7 +72,6 @@ (defconfig *corner-size* 3 'Corner "The size of the corner square") - ;;; CONFIG: Corner actions - See in clfswm-corner.lisp for ;;; allowed functions (defconfig *corner-main-mode-left-button* Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Sun Apr 17 16:53:43 2011 @@ -525,10 +525,18 @@ (let (add-fn add-arg dx dy window) (define-handler move-window-mode :motion-notify (root-x root-y) (unless (compress-motion-notify) - (setf (xlib:drawable-x window) (+ root-x dx) - (xlib:drawable-y window) (+ root-y dy)) - (when add-fn - (apply add-fn add-arg)))) + (if add-fn + (multiple-value-bind (move-x move-y) + (apply add-fn add-arg) + (when move-x + (setf (xlib:drawable-x window) (+ root-x dx))) + (when move-y + (setf (xlib:drawable-y window) (+ root-y dy)))) + (setf (xlib:drawable-x window) (+ root-x dx) + (xlib:drawable-y window) (+ root-y dy))))) + + (define-handler move-window-mode :key-release () + (throw 'exit-move-window-mode nil)) (define-handler move-window-mode :button-release () (throw 'exit-move-window-mode nil)) @@ -559,10 +567,18 @@ min-height max-height) (define-handler resize-window-mode :motion-notify (root-x root-y) (unless (compress-motion-notify) - (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width) - (xlib:drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height)) - (when add-fn - (apply add-fn add-arg)))) + (if add-fn + (multiple-value-bind (resize-w resize-h) + (apply add-fn add-arg) + (when resize-w + (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width))) + (when resize-h + (setf (xlib:drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height)))) + (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width) + (xlib:drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height))))) + + (define-handler resize-window-mode :key-release () + (throw 'exit-resize-window-mode nil)) (define-handler resize-window-mode :button-release () (throw 'exit-resize-window-mode nil)) From pbrochard at common-lisp.net Mon Apr 18 11:50:32 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 18 Apr 2011 07:50:32 -0400 Subject: [clfswm-cvs] r446 - in clfswm: . src Message-ID: Author: pbrochard Date: Mon Apr 18 07:50:32 2011 New Revision: 446 Log: src/clfswm-pack.lisp (resize-frame-constrained): Takes care of border size. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/bindings-second-mode.lisp clfswm/src/bindings.lisp clfswm/src/clfswm-layout.lisp clfswm/src/clfswm-pack.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Mon Apr 18 07:50:32 2011 @@ -1,3 +1,8 @@ +2011-04-18 Philippe Brochard + + * src/clfswm-pack.lisp (resize-frame-constrained): Takes care of + border size. + 2011-04-17 Philippe Brochard * src/clfswm-pack.lisp (move-frame-constrained) Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Mon Apr 18 07:50:32 2011 @@ -9,6 +9,8 @@ -> Nothing here yet. +-> implode + FOR THE NEXT RELEASE ==================== Modified: clfswm/src/bindings-second-mode.lisp ============================================================================== --- clfswm/src/bindings-second-mode.lisp (original) +++ clfswm/src/bindings-second-mode.lisp Mon Apr 18 07:50:32 2011 @@ -185,6 +185,7 @@ (or (do-corner-action root-x root-y *corner-second-mode-right-button*) (mouse-focus-move/resize-generic root-x root-y #'resize-frame nil))) + (defun sm-mouse-middle-click (window root-x root-y) "Do actions on corners" (declare (ignore window)) @@ -234,6 +235,18 @@ (mouse-focus-move/resize-generic root-x root-y #'resize-frame t)) +(defun sm-mouse-click-to-focus-and-move-window-constrained (window root-x root-y) + "Move (constrained by other frames) and focus the current child - Create a new frame on the root window" + (declare (ignore window)) + (mouse-focus-move/resize-generic root-x root-y #'move-frame-constrained t)) + + +(defun sm-mouse-click-to-focus-and-resize-window-constrained (window root-x root-y) + "Resize (constrained by other frames) and focus the current child - Create a new frame on the root window" + (declare (ignore window)) + (mouse-focus-move/resize-generic root-x root-y #'resize-frame-constrained t)) + + (defun set-default-second-mouse () (define-second-mouse (1) 'sm-mouse-click-to-focus-and-move) @@ -241,6 +254,8 @@ (define-second-mouse (3) 'sm-mouse-click-to-focus-and-resize) (define-second-mouse (1 :mod-1) 'sm-mouse-click-to-focus-and-move-window) (define-second-mouse (3 :mod-1) 'sm-mouse-click-to-focus-and-resize-window) + (define-second-mouse (1 :mod-1 :shift) 'sm-mouse-click-to-focus-and-move-window-constrained) + (define-second-mouse (3 :mod-1 :shift) 'sm-mouse-click-to-focus-and-resize-window-constrained) (define-second-mouse (1 :control :mod-1) 'mouse-move-child-over-frame) (define-second-mouse (4) 'sm-mouse-select-next-level) (define-second-mouse (5) 'sm-mouse-select-previous-level) Modified: clfswm/src/bindings.lisp ============================================================================== --- clfswm/src/bindings.lisp (original) +++ clfswm/src/bindings.lisp Mon Apr 18 07:50:32 2011 @@ -114,7 +114,7 @@ (defun mouse-click-to-focus-and-resize-window-constrained (window root-x root-y) - "Resize and focus the current child - Create a new frame on the root window" + "Resize (constrained by other frames) and focus the current child - Create a new frame on the root window" (declare (ignore window)) (stop-button-event) (mouse-focus-move/resize-generic root-x root-y #'resize-frame-constrained t)) Modified: clfswm/src/clfswm-layout.lisp ============================================================================== --- clfswm/src/clfswm-layout.lisp (original) +++ clfswm/src/clfswm-layout.lisp Mon Apr 18 07:50:32 2011 @@ -143,6 +143,23 @@ (- v (* (xlib:drawable-border-width (frame-window child)) 2))) +(declaim (inline anti-adj-border-xy anti-adj-border-wh)) +(defgeneric anti-adj-border-xy (value child)) +(defgeneric anti-adj-border-wh (value child)) + +(defmethod anti-adj-border-xy (v (child xlib:window)) + (- v (xlib:drawable-border-width child))) + +(defmethod anti-adj-border-xy (v (child frame)) + (- v (xlib:drawable-border-width (frame-window child)))) + +(defmethod anti-adj-border-wh (v (child xlib:window)) + (+ v (* (xlib:drawable-border-width child) 2))) + +(defmethod anti-adj-border-wh (v (child frame)) + (+ v (* (xlib:drawable-border-width (frame-window child)) 2))) + + ;;; No layout (defgeneric no-layout (child parent) (:documentation "No layout: Maximize windows in there frame - Leave frames to there original size")) Modified: clfswm/src/clfswm-pack.lisp ============================================================================== --- clfswm/src/clfswm-pack.lisp (original) +++ clfswm/src/clfswm-pack.lisp Mon Apr 18 07:50:32 2011 @@ -290,6 +290,6 @@ (when resize-w (setf lx x)) (when resize-h (setf ly y)) (values resize-w resize-h)))))) - (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent) - (frame-h frame) (h-px->fl (xlib:drawable-height window) parent))) + (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) frame) parent) + (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) frame) parent))) (show-all-children))) From pbrochard at common-lisp.net Mon Apr 18 12:06:26 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 18 Apr 2011 08:06:26 -0400 Subject: [clfswm-cvs] r447 - in clfswm: . src Message-ID: Author: pbrochard Date: Mon Apr 18 08:06:26 2011 New Revision: 447 Log: * src/clfswm-pack.lisp (implode-frame, implode-current-frame): New functions. Absorb all frames subchildren in frame. Explode frame opposite. Modified: clfswm/ChangeLog clfswm/TODO clfswm/src/clfswm-pack.lisp clfswm/src/menu-def.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Mon Apr 18 08:06:26 2011 @@ -2,6 +2,8 @@ * src/clfswm-pack.lisp (resize-frame-constrained): Takes care of border size. + (implode-frame, implode-current-frame): New functions. Absorb all + frames subchildren in frame. Explode frame opposite. 2011-04-17 Philippe Brochard Modified: clfswm/TODO ============================================================================== --- clfswm/TODO (original) +++ clfswm/TODO Mon Apr 18 08:06:26 2011 @@ -9,8 +9,6 @@ -> Nothing here yet. --> implode - FOR THE NEXT RELEASE ==================== Modified: clfswm/src/clfswm-pack.lisp ============================================================================== --- clfswm/src/clfswm-pack.lisp (original) +++ clfswm/src/clfswm-pack.lisp Mon Apr 18 08:06:26 2011 @@ -211,6 +211,22 @@ (leave-second-mode)) +(defun implode-frame (frame) + "Absorb all frames subchildren in frame (explode frame opposite)" + (when (frame-p frame) + (dolist (child (frame-child frame)) + (when (frame-p child) + (dolist (subchild (frame-child child)) + (setf (frame-child frame) (append (frame-child frame) (list subchild)))) + (remove-child-in-frame child frame))))) + +(defun implode-current-frame () + "Absorb all frames subchildren in frame (explode frame opposite)" + (implode-frame *current-child*) + (leave-second-mode)) + + + ;;;;;,----- ;;;;;| Constrained move/resize frames Modified: clfswm/src/menu-def.lisp ============================================================================== --- clfswm/src/menu-def.lisp (original) +++ clfswm/src/menu-def.lisp Mon Apr 18 08:06:26 2011 @@ -165,11 +165,12 @@ (add-menu-key 'frame-miscellaneous-menu "s" 'show-all-frames-info) -(add-menu-key 'frame-miscellaneous-menu "i" 'hide-all-frames-info) +(add-menu-key 'frame-miscellaneous-menu "a" 'hide-all-frames-info) (add-menu-key 'frame-miscellaneous-menu "h" 'hide-current-frame-window) (add-menu-key 'frame-miscellaneous-menu "w" 'show-current-frame-window) (add-menu-key 'frame-miscellaneous-menu "u" 'renumber-current-frame) (add-menu-key 'frame-miscellaneous-menu "x" 'explode-current-frame) +(add-menu-key 'frame-miscellaneous-menu "i" 'implode-current-frame) From pbrochard at common-lisp.net Mon Apr 18 12:19:33 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Mon, 18 Apr 2011 08:19:33 -0400 Subject: [clfswm-cvs] r448 - clfswm/src Message-ID: Author: pbrochard Date: Mon Apr 18 08:19:32 2011 New Revision: 448 Log: * src/clfswm-pack.lisp (implode-frame): Hide child before removing it Modified: clfswm/src/clfswm-pack.lisp Modified: clfswm/src/clfswm-pack.lisp ============================================================================== --- clfswm/src/clfswm-pack.lisp (original) +++ clfswm/src/clfswm-pack.lisp Mon Apr 18 08:19:32 2011 @@ -218,6 +218,7 @@ (when (frame-p child) (dolist (subchild (frame-child child)) (setf (frame-child frame) (append (frame-child frame) (list subchild)))) + (hide-child child) (remove-child-in-frame child frame))))) (defun implode-current-frame () From pbrochard at common-lisp.net Tue Apr 19 21:07:10 2011 From: pbrochard at common-lisp.net (Philippe Brochard) Date: Tue, 19 Apr 2011 17:07:10 -0400 Subject: [clfswm-cvs] r449 - in clfswm: . src Message-ID: Author: pbrochard Date: Tue Apr 19 17:07:09 2011 New Revision: 449 Log: src/clfswm-pack.lisp (move-frame-constrained, resize-frame-constrained): Use pixels instead of floating measure. Modified: clfswm/ChangeLog clfswm/src/clfswm-pack.lisp clfswm/src/config.lisp clfswm/src/xlib-util.lisp Modified: clfswm/ChangeLog ============================================================================== --- clfswm/ChangeLog (original) +++ clfswm/ChangeLog Tue Apr 19 17:07:09 2011 @@ -1,3 +1,9 @@ +2011-04-19 Philippe Brochard + + * src/clfswm-pack.lisp (move-frame-constrained) + (resize-frame-constrained): Use pixels instead of floating + measure. + 2011-04-18 Philippe Brochard * src/clfswm-pack.lisp (resize-frame-constrained): Takes care of Modified: clfswm/src/clfswm-pack.lisp ============================================================================== --- clfswm/src/clfswm-pack.lisp (original) +++ clfswm/src/clfswm-pack.lisp Tue Apr 19 17:07:09 2011 @@ -232,81 +232,88 @@ ;;;;;,----- ;;;;;| Constrained move/resize frames ;;;;;`----- -(defun move-frame-constrained (frame parent orig-x orig-y) - (when (and frame parent (not (child-equal-p frame *current-root*))) - (hide-all-children frame) - (with-slots (window) frame - (let ((lx orig-x) - (ly orig-y)) - (move-window window orig-x orig-y - (lambda () - (let ((move-x t) - (move-y t)) - (multiple-value-bind (x y) (xlib:query-pointer *root*) +(labels ((readjust-all-frames-fl-size (parent) + (dolist (child (frame-child parent)) + (when (frame-p child) + (setf (frame-x child) (x-px->fl (xlib:drawable-x (frame-window child)) parent) + (frame-y child) (y-px->fl (xlib:drawable-y (frame-window child)) parent) + (frame-w child) (w-px->fl (anti-adj-border-wh (xlib:drawable-width (frame-window child)) parent) parent) + (frame-h child) (h-px->fl (anti-adj-border-wh (xlib:drawable-height (frame-window child)) parent) parent)))))) + (defun move-frame-constrained (frame parent orig-x orig-y) + (when (and frame parent (not (child-equal-p frame *current-root*))) + (hide-all-children frame) + (with-slots (window) frame + (let ((lx orig-x) + (ly orig-y)) + (readjust-all-frames-fl-size parent) + (move-window window orig-x orig-y + (lambda () + (let ((move-x t) + (move-y t)) (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) (frame-y frame) (y-px->fl (xlib:drawable-y window) parent)) - (when (> x lx) - (let ((x-found (find-edge-right frame parent))) - (when (< (abs (- x-found (frame-x2 frame))) *snap-size*) - (setf (frame-x frame) (- x-found (frame-w frame)) - (xlib:drawable-x window) (adj-border-xy (x-fl->px (frame-x frame) parent) frame) - move-x nil)))) - (when (< x lx) - (let ((x-found (find-edge-left frame parent))) - (when (< (abs (- x-found (frame-x frame))) *snap-size*) - (setf (frame-x frame) x-found - (xlib:drawable-x window) (adj-border-xy (x-fl->px (frame-x frame) parent) frame) - move-x nil)))) - (when (> y ly) - (let ((y-found (find-edge-down frame parent))) - (when (< (abs (- y-found (frame-y2 frame))) *snap-size*) - (setf (frame-y frame) (- y-found (frame-h frame)) - (xlib:drawable-y window) (adj-border-xy (y-fl->px (frame-y frame) parent) frame) - move-y nil)))) - (when (< y ly) - (let ((y-found (find-edge-up frame parent))) - (when (< (abs (- y-found (frame-y frame))) *snap-size*) - (setf (frame-y frame) y-found - (xlib:drawable-y window) (adj-border-xy (y-fl->px (frame-y frame) parent) frame) - move-y nil)))) - (display-frame-info frame) - (when move-x (setf lx x)) - (when move-y (setf ly y)) - (values move-x move-y)))))) - (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) - (frame-y frame) (y-px->fl (xlib:drawable-y window) parent))) - (show-all-children))) - - -(defun resize-frame-constrained (frame parent orig-x orig-y) - (when (and frame parent (not (child-equal-p frame *current-root*))) - (hide-all-children frame) - (with-slots (window) frame - (let ((lx orig-x) - (ly orig-y)) - (resize-window window orig-x orig-y - (lambda () - (let ((resize-w t) - (resize-h t)) (multiple-value-bind (x y) (xlib:query-pointer *root*) - (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent) - (frame-h frame) (h-px->fl (xlib:drawable-height window) parent)) (when (> x lx) - (let ((x-found (find-edge-right frame parent))) - (when (< (abs (- x-found (frame-x2 frame))) *snap-size*) - (setf (frame-w frame) (+ (frame-w frame) (- x-found (frame-x2 frame))) - (xlib:drawable-width window) (adj-border-wh (w-fl->px (frame-w frame) parent) frame) - resize-w nil)))) + (let ((x-found (x-fl->px (find-edge-right frame parent) parent))) + (when (< (abs (- x-found (window-x2 window))) *snap-size*) + (setf (xlib:drawable-x window) (- x-found (adj-border-xy (xlib:drawable-width window) window)) + (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) + move-x nil)))) + (when (< x lx) + (let ((x-found (x-fl->px (find-edge-left frame parent) parent))) + (when (< (abs (- x-found (xlib:drawable-x window))) *snap-size*) + (setf (xlib:drawable-x window) (adj-border-xy x-found window) + (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) + move-x nil)))) (when (> y ly) - (let ((y-found (find-edge-down frame parent))) - (when (< (abs (- y-found (frame-y2 frame))) *snap-size*) - (setf (frame-h frame) (+ (frame-h frame) (- y-found (frame-y2 frame))) - (xlib:drawable-height window) (adj-border-wh (h-fl->px (frame-h frame) parent) frame) - resize-h nil)))) + (let ((y-found (y-fl->px (find-edge-down frame parent) parent))) + (when (< (abs (- y-found (window-y2 window))) *snap-size*) + (setf (xlib:drawable-y window) (- y-found (adj-border-xy (xlib:drawable-height window) window)) + (frame-y frame) (y-px->fl (xlib:drawable-y window) parent) + move-y nil)))) + (when (< y ly) + (let ((y-found (y-fl->px (find-edge-up frame parent) parent))) + (when (< (abs (- y-found (xlib:drawable-y window))) *snap-size*) + (setf (xlib:drawable-y window) (adj-border-xy y-found window) + (frame-y frame) (y-px->fl (xlib:drawable-y window) parent) + move-y nil)))) (display-frame-info frame) - (when resize-w (setf lx x)) - (when resize-h (setf ly y)) - (values resize-w resize-h)))))) - (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) frame) parent) - (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) frame) parent))) - (show-all-children))) + (when move-x (setf lx x)) + (when move-y (setf ly y)) + (values move-x move-y))))))) + (show-all-children))) + + + (defun resize-frame-constrained (frame parent orig-x orig-y) + (when (and frame parent (not (child-equal-p frame *current-root*))) + (hide-all-children frame) + (with-slots (window) frame + (let ((lx orig-x) + (ly orig-y)) + (readjust-all-frames-fl-size parent) + (resize-window window orig-x orig-y + (lambda () + (let ((resize-w t) + (resize-h t)) + (multiple-value-bind (x y) (xlib:query-pointer *root*) + (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) parent) parent) + (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) parent) parent)) + (when (> x lx) + (let ((x-found (x-fl->px (find-edge-right frame parent) parent))) + (when (< (abs (- x-found (window-x2 window))) *snap-size*) + (setf (xlib:drawable-width window) (+ (xlib:drawable-width window) + (- x-found (adj-border-xy (window-x2 window) parent))) + (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) parent) parent) + resize-w nil)))) + (when (> y ly) + (let ((y-found (y-fl->px (find-edge-down frame parent) parent))) + (when (< (abs (- y-found (window-y2 window))) *snap-size*) + (setf (xlib:drawable-height window) (+ (xlib:drawable-height window) + (- y-found (adj-border-xy (window-y2 window) parent))) + (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) parent) parent) + resize-h nil)))) + (display-frame-info frame) + (when resize-w (setf lx x)) + (when resize-h (setf ly y)) + (values resize-w resize-h))))))) + (show-all-children)))) Modified: clfswm/src/config.lisp ============================================================================== --- clfswm/src/config.lisp (original) +++ clfswm/src/config.lisp Tue Apr 19 17:07:09 2011 @@ -53,8 +53,8 @@ (defconfig *hide-unmanaged-window* t nil "Hide or not unmanaged windows when a child is deselected.") -(defconfig *snap-size* 0.02 nil - "Snap size when move or resize frame is constrained") +(defconfig *snap-size* 20 nil + "Snap size (in pixels) when move or resize frame is constrained") ;;; CONFIG - Screen size Modified: clfswm/src/xlib-util.lisp ============================================================================== --- clfswm/src/xlib-util.lisp (original) +++ clfswm/src/xlib-util.lisp Tue Apr 19 17:07:09 2011 @@ -84,6 +84,15 @@ +(declaim (inline window-x2 window-y2)) +(defun window-x2 (window) + (+ (xlib:drawable-x window) (xlib:drawable-width window))) + +(defun window-y2 (window) + (+ (xlib:drawable-y window) (xlib:drawable-height window))) + + + ;;; ;;; Events management functions. ;;; @@ -246,7 +255,6 @@ (xlib:kill-client *display* (xlib:window-id window))) - ;;(defconstant +exwm-atoms+ ;; (list "_NET_SUPPORTED" "_NET_CLIENT_LIST" ;; "_NET_CLIENT_LIST_STACKING" "_NET_NUMBER_OF_DESKTOPS"