[clfswm-cvs] r14 - clfswm
pbrochard at common-lisp.net
pbrochard at common-lisp.net
Tue Mar 4 21:45:10 UTC 2008
Author: pbrochard
Date: Tue Mar 4 16:45:09 2008
New Revision: 14
Added:
clfswm/clfswm-query.lisp
Modified:
clfswm/bindings-second-mode.lisp
clfswm/clfswm-internal.lisp
clfswm/clfswm-util.lisp
clfswm/clfswm.asd
clfswm/load.lisp
Log:
Rename and renumber childs. Move query-* in a separate file
Modified: clfswm/bindings-second-mode.lisp
==============================================================================
--- clfswm/bindings-second-mode.lisp (original)
+++ clfswm/bindings-second-mode.lisp Tue Mar 4 16:45:09 2008
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sat Mar 1 23:26:11 2008
+;;; #Date#: Tue Mar 4 22:41:24 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Bindings keys and mouse for second mode
@@ -105,7 +105,9 @@
"Group menu"
(info-mode-menu '((#\a group-adding-menu)
(#\l group-layout-menu)
- (#\m group-movement-menu))))
+ (#\m group-movement-menu)
+ (#\r rename-current-child)
+ (#\n renumber-current-group))))
@@ -203,9 +205,29 @@
(define-second-key ("Delete") 'remove-current-child)
+;;; default shell programs
+(defmacro define-shell (key name docstring cmd)
+ "Define a second key to start a shell command"
+ `(define-second-key ,key
+ (defun ,name ()
+ ,docstring
+ (setf *second-mode-program* ,cmd)
+ (leave-second-mode))))
+(define-shell (#\c) b-start-xterm "start an xterm" "exec xterm")
+(define-shell (#\e) b-start-emacs "start emacs" "exec emacs")
+(define-shell (#\e :control) b-start-emacsremote
+ "start an emacs for another user"
+ "exec emacsremote-Eterm")
+(define-shell (#\h) b-start-xclock "start an xclock" "exec xclock -d")
+
+
+
+
+
+;;; Mouse action
(defun sm-handle-click-to-focus (root-x root-y)
"Give the focus to the clicked child"
(let ((win (find-child-under-mouse root-x root-y)))
Modified: clfswm/clfswm-internal.lisp
==============================================================================
--- clfswm/clfswm-internal.lisp (original)
+++ clfswm/clfswm-internal.lisp Tue Mar 4 16:45:09 2008
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sat Mar 1 23:56:57 2008
+;;; #Date#: Tue Mar 4 22:36:13 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
@@ -79,6 +79,19 @@
+(defgeneric rename-child (child name))
+
+(defmethod rename-child ((child group) name)
+ (setf (group-name child) name))
+
+(defmethod rename-child ((child xlib:window) name)
+ (setf (xlib:wm-name child) name))
+
+(defmethod rename-child (child name)
+ (declare (ignore child name)))
+
+
+
;; (with-all-childs (*root-group* child) (typecase child (xlib:window (print child)) (group (print (group-number child)))))
(defmacro with-all-childs ((root child) &body body)
(let ((rec (gensym))
Added: clfswm/clfswm-query.lisp
==============================================================================
--- (empty file)
+++ clfswm/clfswm-query.lisp Tue Mar 4 16:45:09 2008
@@ -0,0 +1,191 @@
+;;; --------------------------------------------------------------------------
+;;; CLFSWM - FullScreen Window Manager
+;;;
+;;; #Date#: Tue Mar 4 22:39:47 2008
+;;;
+;;; --------------------------------------------------------------------------
+;;; Documentation: Query utility
+;;; --------------------------------------------------------------------------
+;;;
+;;; (C) 2005 Philippe Brochard <hocwp at free.fr>
+;;;
+;;; 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 query-show-paren (orig-string pos)
+ "Replace matching parentheses with brackets"
+ (let ((string (copy-seq orig-string)))
+ (labels ((have-to-find-right? ()
+ (and (< pos (length string)) (char= (aref string pos) #\()))
+ (have-to-find-left? ()
+ (and (> (1- pos) 0) (char= (aref string (1- pos)) #\))))
+ (pos-right ()
+ (loop :for p :from (1+ pos) :below (length string)
+ :with level = 1 :for c = (aref string p)
+ :do (when (char= c #\() (incf level))
+ (when (char= c #\)) (decf level))
+ (when (= level 0) (return p))))
+ (pos-left ()
+ (loop :for p :from (- pos 2) :downto 0
+ :with level = 1 :for c = (aref string p)
+ :do (when (char= c #\() (decf level))
+ (when (char= c #\)) (incf level))
+ (when (= level 0) (return p)))))
+ (when (have-to-find-right?)
+ (let ((p (pos-right)))
+ (when p (setf (aref string p) #\]))))
+ (when (have-to-find-left?)
+ (let ((p (pos-left)))
+ (when p (setf (aref string p) #\[))))
+ string)))
+
+
+;;; 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))
+ (labels ((add-cursor (string)
+ (concatenate 'string (subseq string 0 pos) "|" (subseq string pos)))
+ (print-string ()
+ (xlib:clear-area window)
+ (setf (xlib:gcontext-foreground gc) (get-color *query-foreground*))
+ (xlib:draw-image-glyphs window 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-image-glyphs window gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
+ (add-cursor (query-show-paren result-string pos))))
+ (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 (xlib:make-state-keys state))
+ (keysym (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1)
+ ((member :mod-5 modifiers) 2)
+ (t 0))))
+ (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)
+ (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)
+ (xgrab-pointer *root* 66 67)))
+ (values (when (member done '(:Return :Complet))
+ (push result-string history)
+ result-string)
+ done))))
+
+
+
+(defun query-number (msg &optional (default 0))
+ "Query a number from the query input"
+ (parse-integer (or (query-string msg (format nil "~A" default)) "") :junk-allowed t))
Modified: clfswm/clfswm-util.lisp
==============================================================================
--- clfswm/clfswm-util.lisp (original)
+++ clfswm/clfswm-util.lisp Tue Mar 4 16:45:09 2008
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Mar 4 11:14:45 2008
+;;; #Date#: Tue Mar 4 22:41:07 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Utility
@@ -35,6 +35,27 @@
(load truename))))
+
+
+(defun rename-current-child ()
+ "Rename the current child"
+ (let ((name (query-string (format nil "New child name: (last: ~A)" (child-name *current-child*))
+ (child-name *current-child*))))
+ (rename-child *current-child* name)
+ (leave-second-mode)))
+
+
+(defun renumber-current-group ()
+ "Renumber the current group"
+ (when (group-p *current-child*)
+ (let ((number (query-number (format nil "New child number: (last: ~A)" (group-number *current-child*))
+ (group-number *current-child*))))
+ (setf (group-number *current-child*) number)
+ (leave-second-mode))))
+
+
+
+
(defun add-default-group ()
"Add a default group"
(when (group-p *current-child*)
@@ -223,167 +244,6 @@
-(defun query-show-paren (orig-string pos)
- "Replace matching parentheses with brackets"
- (let ((string (copy-seq orig-string)))
- (labels ((have-to-find-right? ()
- (and (< pos (length string)) (char= (aref string pos) #\()))
- (have-to-find-left? ()
- (and (> (1- pos) 0) (char= (aref string (1- pos)) #\))))
- (pos-right ()
- (loop :for p :from (1+ pos) :below (length string)
- :with level = 1 :for c = (aref string p)
- :do (when (char= c #\() (incf level))
- (when (char= c #\)) (decf level))
- (when (= level 0) (return p))))
- (pos-left ()
- (loop :for p :from (- pos 2) :downto 0
- :with level = 1 :for c = (aref string p)
- :do (when (char= c #\() (decf level))
- (when (char= c #\)) (incf level))
- (when (= level 0) (return p)))))
- (when (have-to-find-right?)
- (let ((p (pos-right)))
- (when p (setf (aref string p) #\]))))
- (when (have-to-find-left?)
- (let ((p (pos-left)))
- (when p (setf (aref string p) #\[))))
- string)))
-
-
-;;; 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))
- (labels ((add-cursor (string)
- (concatenate 'string (subseq string 0 pos) "|" (subseq string pos)))
- (print-string ()
- (xlib:clear-area window)
- (setf (xlib:gcontext-foreground gc) (get-color *query-foreground*))
- (xlib:draw-image-glyphs window 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-image-glyphs window gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
- (add-cursor (query-show-paren result-string pos))))
- (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 (xlib:make-state-keys state))
- (keysym (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1)
- ((member :mod-5 modifiers) 2)
- (t 0))))
- (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)
- (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)
- (xgrab-pointer *root* 66 67)))
- (values (when (member done '(:Return :Complet))
- (push result-string history)
- result-string)
- done))))
-
-
-
-(defun query-number (msg)
- "Query a number from the query input"
- (parse-integer (or (query-string msg) "") :junk-allowed t))
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Tue Mar 4 16:45:09 2008
@@ -2,7 +2,7 @@
;;;; Author: Philippe Brochard <hocwp at free.fr>
;;;; ASDF System Definition
;;;
-;;; #date#: Fri Feb 22 21:39:37 2008
+;;; #date#: Tue Mar 4 22:30:25 2008
(in-package #:asdf)
@@ -37,6 +37,8 @@
:depends-on ("package" "xlib-util" "config" "clfswm-keys" "clfswm" "clfswm-internal"))
(:file "clfswm-util"
:depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode"))
+ (:file "clfswm-query"
+ :depends-on ("package" "config"))
(:file "clfswm-layout"
:depends-on ("package" "clfswm-util" "clfswm-info"))
(:file "bindings"
Modified: clfswm/load.lisp
==============================================================================
--- clfswm/load.lisp (original)
+++ clfswm/load.lisp Tue Mar 4 16:45:09 2008
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Mar 4 11:11:02 2008
+;;; #Date#: Tue Mar 4 22:29:03 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: System loading functions
More information about the clfswm-cvs
mailing list