[clfswm-cvs] r352 - in clfswm: . src

[Philippe Brochard]

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)