[clfswm-cvs] r352 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Sun Oct 10 19:51:15 UTC 2010
Author: pbrochard
Date: Sun Oct 10 15:51:15 2010
New Revision: 352
Log:
src/tools.lisp (add-timer): Add an id to identify the timer.
Modified:
clfswm/ChangeLog
clfswm/src/clfswm-util.lisp
clfswm/src/config.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Sun Oct 10 15:51:15 2010
@@ -1,3 +1,7 @@
+2010-10-10 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/tools.lisp (add-timer): Add an id to identify the timer.
+
2010-10-09 Philippe Brochard <pbrochard at common-lisp.net>
* src/tools.lisp (erase-timer): New function.
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Sun Oct 10 15:51:15 2010
@@ -1451,12 +1451,27 @@
(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*)
+ height *hello-window-height*
+ font (xlib:open-font *display* *hello-window-font-string*))
(with-placement (*hello-window-placement* x y width height)
- (setf font (xlib:open-font *display* *hello-window-font-string*)
- window (xlib:create-window :parent *root*
+ (setf window (xlib:create-window :parent *root*
:x x
:y y
:width width
@@ -1478,23 +1493,8 @@
(refresh-hello-window)
(xlib:display-finish-output *display*)))
- (defun refresh-hello-window ()
- (add-timer 0.1 #'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 close-hello-window ()
- (erase-timer #'refresh-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
Modified: clfswm/src/config.lisp
==============================================================================
--- clfswm/src/config.lisp (original)
+++ clfswm/src/config.lisp Sun Oct 10 15:51:15 2010
@@ -313,16 +313,16 @@
(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 mode group): Hello Window background color")
+ "Config(Hello Window group): Hello Window background color")
(defparameter *hello-window-foreground* "green"
- "Config(Hello Window mode group): Hello Window foreground color")
+ "Config(Hello Window group): Hello Window foreground color")
(defparameter *hello-window-border* "red"
- "Config(Hello Window mode group): Hello Window border color")
+ "Config(Hello Window group): Hello Window border color")
(defparameter *hello-window-width* 300
- "Config(Hello Window mode group): Hello Window width")
+ "Config(Hello Window group): Hello Window width")
(defparameter *hello-window-height* 50
- "Config(Hello Window mode group): Hello Window height")
+ "Config(Hello Window group): Hello Window height")
(defparameter *hello-window-delay* 10
- "Config(Hello Window mode group): Hello Window display delay")
+ "Config(Hello Window group): Hello Window display delay")
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Sun Oct 10 15:51:15 2010
@@ -192,29 +192,31 @@
(defun clear-timers ()
(setf *timer-list* nil))
-(defun add-timer (delay fun)
- (push (list (let ((time (+ (get-internal-real-time) (s->realtime delay))))
+(defun add-timer (delay fun &optional (id (gensym)))
+ (push (list id
+ (let ((time (+ (get-internal-real-time) (s->realtime delay))))
(lambda ()
(when (>= (get-internal-real-time) time)
(funcall fun)
- t)))
- fun)
- *timer-list*))
+ t))))
+ *timer-list*)
+ id)
-(defmacro with-timer ((delay) &body body)
+(defmacro with-timer ((delay &optional (id (gensym))) &body body)
`(add-timer ,delay
(lambda ()
- , at body)))
+ , at body)
+ ,id))
(defun process-timers ()
(dolist (timer *timer-list*)
- (when (funcall (first timer))
+ (when (funcall (second timer))
(setf *timer-list* (remove timer *timer-list* :test #'equal)))))
-(defun erase-timer (fun)
+(defun erase-timer (id)
(dolist (timer *timer-list*)
- (when (equal fun (second timer))
+ (when (equal id (first timer))
(setf *timer-list* (remove timer *timer-list* :test #'equal)))))
(defun timer-test-loop ()
@@ -223,18 +225,18 @@
(process-timers)
(sleep 0.5)))
-;;(defun plop ()
-;; (princ 'plop)
-;; (erase-timer #'toto))
-;;
-;;(defun toto ()
-;; (princ 'toto)
-;; (add-timer 5 #'toto))
-;;
-;;(add-timer 5 #'toto)
-;;(add-timer 30 #'plop)
-;;
-;;(timer-test-loop)
+(defun plop ()
+ (princ 'plop)
+ (erase-timer :toto))
+
+(defun toto ()
+ (princ 'toto)
+ (add-timer 5 #'toto :toto))
+
+(add-timer 5 #'toto :toto)
+(add-timer 30 #'plop)
+
+(timer-test-loop)
More information about the clfswm-cvs
mailing list