[clfswm-cvs] r354 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Sun Oct 10 20:47:21 UTC 2010
Author: pbrochard
Date: Sun Oct 10 16:47:21 2010
New Revision: 354
Log:
src/clfswm-util.lisp (open-notify-window): Convert hello-window functions to a more generic Notify-window system.
Modified:
clfswm/ChangeLog
clfswm/src/clfswm-util.lisp
clfswm/src/config.lisp
clfswm/src/package.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Sun Oct 10 16:47:21 2010
@@ -1,5 +1,8 @@
2010-10-10 Philippe Brochard <pbrochard at common-lisp.net>
+ * src/clfswm-util.lisp (open-notify-window): Convert hello-window
+ functions to a more generic Notify-window system.
+
* src/tools.lisp (add-timer): Add an id to identify the timer.
2010-10-09 Philippe Brochard <pbrochard at common-lisp.net>
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Sun Oct 10 16:47:21 2010
@@ -1442,72 +1442,84 @@
-;;; Hello window functions
-(let ((font nil)
- (window nil)
- (gc nil)
+;;; Notify window functions
+(let (font
+ window
+ gc
width height
- (current-child nil))
- (defun is-hello-window-p (win)
- (xlib:window-equal win window))
-
- (defun refresh-hello-window ()
- (add-timer 0.1 #'refresh-hello-window :refresh-hello-window)
- (raise-window window)
- (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
- (let* ((text (format nil "Welcome to CLFSWM")))
- (xlib:draw-glyphs window gc
- (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2))
- (truncate (- (/ (+ height text-height) 2) text-height))
- text))
- (let* ((text (format nil "Press Alt+F1 for help")))
- (xlib:draw-glyphs window gc
- (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2))
- (truncate (+ (/ (+ height text-height) 2) text-height))
- text))))
-
- (defun open-hello-window ()
- (setf width *hello-window-width*
- height *hello-window-height*
- font (xlib:open-font *display* *hello-window-font-string*))
- (with-placement (*hello-window-placement* x y width height)
- (setf window (xlib:create-window :parent *root*
- :x x
- :y y
- :width width
- :height height
- :background (get-color *hello-window-background*)
- :border-width 1
- :border (get-color *hello-window-border*)
- :colormap (xlib:screen-default-colormap *screen*)
- :event-mask '(:exposure :key-press))
- gc (xlib:create-gcontext :drawable window
- :foreground (get-color *hello-window-foreground*)
- :background (get-color *hello-window-background*)
- :font font
- :line-style :solid))
- (when (frame-p *current-child*)
- (setf current-child *current-child*)
- (push (list #'equal #'is-hello-window-p t) *never-managed-window-list*))
- (map-window window)
- (refresh-hello-window)
- (xlib:display-finish-output *display*)))
-
- (defun close-hello-window ()
- (erase-timer :refresh-hello-window)
- (setf *never-managed-window-list*
- (remove (list #'equal #'is-hello-window-p t) *never-managed-window-list* :test #'equal))
- (when gc
- (xlib:free-gcontext gc))
- (when window
- (xlib:destroy-window window))
- (when font
- (xlib:close-font font))
- (xlib:display-finish-output *display*)
- (setf window nil
- gc nil
- font nil))
-
- (defun display-hello-window ()
- (open-hello-window)
- (add-timer *hello-window-delay* #'close-hello-window)))
+ text
+ current-child)
+ (labels ((text-string (tx)
+ (typecase tx
+ (cons (first tx))
+ (t tx)))
+ (text-color (tx)
+ (get-color (typecase tx
+ (cons (second tx))
+ (t *notify-window-foreground*)))))
+ (defun is-notify-window-p (win)
+ (xlib:window-equal win window))
+
+ (defun refresh-notify-window ()
+ (add-timer 0.1 #'refresh-notify-window :refresh-notify-window)
+ (raise-window window)
+ (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
+ (loop for tx in text
+ for i from 1 do
+ (setf (xlib:gcontext-foreground gc) (text-color tx))
+ (xlib:draw-glyphs window gc
+ (truncate (/ (- width (* (xlib:max-char-width font) (length (text-string tx)))) 2))
+ (* text-height i 2)
+ (text-string tx)))))
+
+ (defun close-notify-window ()
+ (erase-timer :refresh-notify-window)
+ (setf *never-managed-window-list*
+ (remove (list #'equal #'is-notify-window-p t) *never-managed-window-list* :test #'equal))
+ (when gc
+ (xlib:free-gcontext gc))
+ (when window
+ (xlib:destroy-window window))
+ (when font
+ (xlib:close-font font))
+ (xlib:display-finish-output *display*)
+ (setf window nil
+ gc nil
+ font nil))
+
+ (defun open-notify-window (text-list)
+ (close-notify-window)
+ (setf font (xlib:open-font *display* *notify-window-font-string*))
+ (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
+ (setf text text-list)
+ (setf width (* (xlib:max-char-width font) (+ (loop for tx in text-list
+ maximize (length (text-string tx))) 2))
+ height (+ (* text-height (length text-list) 2) text-height))
+ (with-placement (*notify-window-placement* x y width height)
+ (setf window (xlib:create-window :parent *root*
+ :x x
+ :y y
+ :width width
+ :height height
+ :background (get-color *notify-window-background*)
+ :border-width 1
+ :border (get-color *notify-window-border*)
+ :colormap (xlib:screen-default-colormap *screen*)
+ :event-mask '(:exposure :key-press))
+ gc (xlib:create-gcontext :drawable window
+ :foreground (get-color *notify-window-foreground*)
+ :background (get-color *notify-window-background*)
+ :font font
+ :line-style :solid))
+ (when (frame-p *current-child*)
+ (setf current-child *current-child*)
+ (push (list #'equal #'is-notify-window-p t) *never-managed-window-list*))
+ (map-window window)
+ (refresh-notify-window)
+ (xlib:display-finish-output *display*))))))
+
+
+(defun display-hello-window ()
+ (open-notify-window '(("Welcome to CLFSWM" "yellow")
+ "Press Alt+F1 for help"))
+ (add-timer *notify-window-delay* #'close-notify-window))
Modified: clfswm/src/config.lisp
==============================================================================
--- clfswm/src/config.lisp (original)
+++ clfswm/src/config.lisp Sun Oct 10 16:47:21 2010
@@ -309,20 +309,16 @@
"Config(Menu group): Menu key color in menu")
-;;; CONFIG - Hello window string colors
-(defparameter *hello-window-font-string* *default-font-string*
- "Config(Hello Window mode group): Hello window font string")
-(defparameter *hello-window-background* "black"
- "Config(Hello Window group): Hello Window background color")
-(defparameter *hello-window-foreground* "green"
- "Config(Hello Window group): Hello Window foreground color")
-(defparameter *hello-window-border* "red"
- "Config(Hello Window group): Hello Window border color")
-(defparameter *hello-window-width* 300
- "Config(Hello Window group): Hello Window width")
-(defparameter *hello-window-height* 50
- "Config(Hello Window group): Hello Window height")
-(defparameter *hello-window-delay* 10
- "Config(Hello Window group): Hello Window display delay")
+;;; CONFIG - Notify window string colors
+(defparameter *notify-window-font-string* *default-font-string*
+ "Config(Notify Window mode group): Notify window font string")
+(defparameter *notify-window-background* "black"
+ "Config(Notify Window group): Notify Window background color")
+(defparameter *notify-window-foreground* "green"
+ "Config(Notify Window group): Notify Window foreground color")
+(defparameter *notify-window-border* "red"
+ "Config(Notify Window group): Notify Window border color")
+(defparameter *notify-window-delay* 10
+ "Config(Notify Window group): Notify Window display delay")
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Sun Oct 10 16:47:21 2010
@@ -208,8 +208,8 @@
"Config(Placement group): Circulate mode window placement")
(defparameter *expose-mode-placement* 'top-left-child-placement
"Config(Placement group): Expose mode window placement (Selection keys position)")
-(defparameter *hello-window-placement* 'bottom-right-placement
- "Config(Placement group): Hello window placement")
+(defparameter *notify-window-placement* 'bottom-right-placement
+ "Config(Placement group): Notify window placement")
More information about the clfswm-cvs
mailing list