[STUMP] Still more hacking

[Manuel Giraud]

Here's the ability to configure input and message window gravity through
2 variables: *message-window-gravity* and *input-window-gravity* (the
default being the classical top-right gravity) (+ help + bug fix).

cvs diff: Diffing .
Index: core.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/core.lisp,v
retrieving revision 1.39
diff -u -r1.39 core.lisp
--- core.lisp   8 Apr 2006 01:31:08 -0000       1.39
+++ core.lisp   14 Apr 2006 12:25:15 -0000
@@ -212,7 +212,7 @@
 
 (defun find-free-window-number (screen)
   "Return a free window number for SCREEN."
-  (find-free-number (mapcar-hash (lambda (val) (gethash :number val))
+  (find-free-number (mapcar-hash (lambda (key val) (declare (ignore key)) 
(gethash :number val))
                                 (screen-window-hash screen))))
 
 (defun process-new-window (win)
@@ -487,22 +487,38 @@
   (loop for i in l
        maximize (xlib:text-width font i)))
 
+(defun setup-win-gravity (screen win gravity)
+  "Position the x, y of the window according to its gravity."
+  (let ((w (xlib:drawable-width win))
+       (h (xlib:drawable-height win))
+       (screen-width (xlib:drawable-width (xlib:screen-root (screen-number 
screen))))
+       (screen-height (xlib:drawable-height (xlib:screen-root (screen-number 
screen)))))
+    (let ((x (ecase gravity
+              ((top-right bottom-right) (- screen-width w
+                                           (* (xlib:drawable-border-width win) 
2)))
+              ((top-left bottom-left) 0)
+              (center (truncate (- screen-width w
+                                   (* (xlib:drawable-border-width win) 2)) 
2))))
+         (y (ecase gravity
+              ((top-right top-left) 0)
+              ((bottom-right bottom-left) (- screen-height h
+                                             (* (xlib:drawable-border-width 
win) 2)))
+              (center (truncate (- screen-height h (* 
(xlib:drawable-border-width win) 2)) 2)))))
+      (setf (xlib:drawable-y win) y
+           (xlib:drawable-x win) x))))
+      
 (defun setup-message-window (screen l)
   (let ((height (* (length l)
                   (+ (xlib:font-ascent (screen-font screen))
                      (xlib:font-descent (screen-font screen)))))
        (width (max-width (screen-font screen) l))
-       (screen-width (xlib:drawable-width (xlib:screen-root (screen-number 
screen))))
        (win (screen-message-window screen)))
     ;; Now that we know the dimensions, raise and resize it.
     (xlib:map-window (screen-message-window screen))
-    (setf (xlib:drawable-y win) 0
-         (xlib:drawable-height win) height
-         (xlib:drawable-x win) (- screen-width width
-                                  (* (xlib:drawable-border-width win) 2)
-                                  (* *message-window-padding* 2))
+    (setf (xlib:drawable-height win) height
          (xlib:drawable-width win) (+ width (* *message-window-padding* 2))
          (xlib:window-priority win) :above)
+    (setup-win-gravity screen win *message-window-gravity*)
     ;; Clear the window
     (xlib:clear-area win)))
 
Index: input.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/input.lisp,v
retrieving revision 1.13
diff -u -r1.13 input.lisp
--- input.lisp  8 Apr 2006 01:31:08 -0000       1.13
+++ input.lisp  14 Apr 2006 12:25:16 -0000
@@ -64,8 +64,7 @@
     ;; Window dimensions
     (xlib:map-window win)
     (setf (xlib:window-priority win) :above)
-    (setf (xlib:drawable-y win) 0
-         (xlib:drawable-height win) height)
+    (setf (xlib:drawable-height win) height)
     ;; Draw the prompt
     (draw-input-bucket screen prompt input)
     ;; Ready to recieve input
@@ -112,7 +111,7 @@
       (setup-input-window screen prompt input)
       (catch 'abort
        (unwind-protect
-            (key-loop)
+            (key-loop) 
          (shutdown-input-window screen))))))
 
 (defun read-one-char (screen)
@@ -138,10 +137,9 @@
                               prompt-width
                               (xlib:text-width (screen-font screen) string)))
     (xlib:with-state (win)
-                    (setf (xlib:drawable-x win) (- screen-width width
-                                                   (* 
(xlib:drawable-border-width win) 2)
-                                                   (* *message-window-padding* 
2))
-                          (xlib:drawable-width win) (+ width (* 
*message-window-padding* 2))))
+                    (setf (xlib:drawable-width win) (+ width (* 
*message-window-padding* 2)))
+                    (setup-win-gravity screen win *input-window-gravity*))
+
     (xlib:draw-image-glyphs win gcontext
                            *message-window-padding*
                            (xlib:font-ascent (screen-font screen))
Index: kmap.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/kmap.lisp,v
retrieving revision 1.4
diff -u -r1.4 kmap.lisp
--- kmap.lisp   8 Apr 2006 01:31:08 -0000       1.4
+++ kmap.lisp   14 Apr 2006 12:25:16 -0000
@@ -82,9 +82,11 @@
 
 (defun parse-char-name (string)
   "Return the char-code of the char whose name is STRING."
-  (or (name-char string)
+  (let ((ch (name-char string)))
+    (if ch
+       (char-code ch)
       (and (= (length string) 1)
-          (char-code (char string 0)))))
+          (char-code (char string 0))))))
 
 (defun parse-key (string)
   "Parse STRING and return a key structure."
Index: primitives.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/primitives.lisp,v
retrieving revision 1.23
diff -u -r1.23 primitives.lisp
--- primitives.lisp     8 Apr 2006 00:08:21 -0000       1.23
+++ primitives.lisp     14 Apr 2006 12:25:16 -0000
@@ -129,6 +129,13 @@
 ;; Message window variables
 (defvar *message-window-padding* 5)
 
+;; Message window gravity (one of 'top-left, 'top-right, 'bottom-left,
+;; 'bottom-right or 'center).
+(defvar *message-window-gravity* 'top-right)
+
+;; Input window gravity
+(defvar *input-window-gravity* 'top-right)
+
 ;; line editor
 (defvar *editor-bindings* nil
   "A list of key-bindings for line editing.")
@@ -214,12 +221,10 @@
     (sort copy sort-fn)))
 
 (defun mapcar-hash (fn hash)
-  "Just like maphash except it accumulates the result in a list and
-calls fn on the value for the key hash-key, not the pair."
+  "Just like maphash except it accumulates the result in a list."
   (let ((accum nil))
     (labels ((mapfn (key val)
-              (declare (ignore key))
-              (push (funcall fn val) accum)))
+               (push (funcall fn key val) accum)))
       (maphash #'mapfn hash))
     accum))
 
Index: user.lisp
===================================================================
RCS file: /cvsroot/stumpwm/stumpwm/user.lisp,v
retrieving revision 1.30
diff -u -r1.30 user.lisp
--- user.lisp   8 Apr 2006 01:31:08 -0000       1.30
+++ user.lisp   14 Apr 2006 12:25:16 -0000
@@ -67,9 +67,10 @@
     (define-key m (kbd "f") "fselect")
     (define-key m (kbd "F") "curframe")
     (define-key m (kbd "t") "meta")
-    ;;(define-key m (kbd "C-N") "number")
+    (define-key m (kbd "C-N") "number")
     (define-key m (kbd ";") "colon")
     (define-key m (kbd ":") "eval")
+    (define-key m (kbd "C-h") "help")
     m)
   "The default bindings that hang off the prefix key.")
 
@@ -467,6 +468,12 @@
   (asdf:operate 'asdf:load-op :stumpwm)
   (echo-string screen "Reloading StumpWM...Done."))
 
+(defun display-keybinding (screen kmap)
+  (echo-string-list screen (mapcar-hash #'(lambda (k v) (format nil "~A -> ~A" 
(print-key k) v)) kmap)))
+
+(define-stumpwm-command "help" (screen)
+  (display-keybinding screen *root-map*))
+
 ;; Trivial function
 (define-stumpwm-command "abort" (screen)
   (declare (ignore screen)))

-- 
Manuel Giraud                _      10-12 avenue de l'Europe
tel: +33 1 39253902         { \,"   78140 Vélizy
fax: +33 1 39254778        {_`/     France
address@hidden   `      http://www.cetp.ipsl.fr