[clfswm-cvs] r349 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Fri Oct 8 21:07:36 UTC 2010
Author: pbrochard
Date: Fri Oct 8 17:07:36 2010
New Revision: 349
Log:
* src/clfswm-util.lisp (): Add an Hello window at startup. * src/tools.lisp (process-timers): Add a timer system.
Modified:
clfswm/ChangeLog
clfswm/src/clfswm-generic-mode.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/clfswm.lisp
clfswm/src/config.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Fri Oct 8 17:07:36 2010
@@ -1,3 +1,9 @@
+2010-10-08 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-util.lisp (): Add an Hello window at startup.
+
+ * src/tools.lisp (process-timers): Add a timer system.
+
2010-10-07 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-query.lisp (add-in-query-string): Handle correctly
Modified: clfswm/src/clfswm-generic-mode.lisp
==============================================================================
--- clfswm/src/clfswm-generic-mode.lisp (original)
+++ clfswm/src/clfswm-generic-mode.lisp Fri Oct 8 17:07:36 2010
@@ -40,6 +40,7 @@
(unwind-protect
(loop
(call-hook loop-hook)
+ (process-timers)
(nfuncall loop-function)
(when (xlib:event-listen *display* *loop-timeout*)
(xlib:process-event *display* :handler #'handle-event))
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Fri Oct 8 17:07:36 2010
@@ -1439,3 +1439,68 @@
(setf lx (first h)
ly (second h))
(xlib:warp-pointer *root* lx ly)))))))
+
+
+
+;;; Hello window functions
+(let ((font nil)
+ (window nil)
+ (gc nil)
+ (width 300) (height 50)
+ (current-child nil))
+ (defun open-hello-window ()
+ (with-placement (#'middle-middle-placement x y width height)
+ (setf font (xlib:open-font *display* *sm-font-string*)
+ window (xlib:create-window :parent *root*
+ :x x
+ :y y
+ :width width
+ :height height
+ :background (get-color *sm-background-color*)
+ :border-width 1
+ :border (get-color *sm-border-color*)
+ :colormap (xlib:screen-default-colormap *screen*)
+ :event-mask '(:exposure :key-press))
+ gc (xlib:create-gcontext :drawable window
+ :foreground (get-color *sm-foreground-color*)
+ :background (get-color *sm-background-color*)
+ :font font
+ :line-style :solid))
+ (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
+ (when (frame-p *current-child*)
+ (setf current-child *current-child*)
+ (push window (frame-forced-unmanaged-window *current-child*)))
+ (map-window window)
+ (raise-window window)
+ (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))
+ (xlib:display-finish-output *display*))))
+
+ (defun close-hello-window ()
+ (setf (frame-forced-unmanaged-window current-child)
+ (remove window (frame-forced-unmanaged-window current-child) :test #'xlib:window-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 ()
+ (sleep 5)
+ (open-hello-window)
+ (with-timer (10)
+ (close-hello-window))))
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Fri Oct 8 17:07:36 2010
@@ -146,6 +146,7 @@
(defun main-loop ()
(loop
(call-hook *loop-hook*)
+ (process-timers)
(with-xlib-protect
(when (xlib:event-listen *display* *loop-timeout*)
(xlib:process-event *display* :handler #'handle-event))
@@ -185,6 +186,7 @@
(xgrab-init-keyboard)
(init-last-child)
(call-hook *binding-hook*)
+ (clear-timers)
(map-window *no-focus-window*)
(dbg *display*)
(setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect
@@ -205,7 +207,9 @@
(process-existing-windows *screen*)
(show-all-children *current-root*)
(grab-main-keys)
- (xlib:display-finish-output *display*))
+ (xlib:display-finish-output *display*)
+ (when *have-to-display-hello-window*
+ (display-hello-window)))
Modified: clfswm/src/config.lisp
==============================================================================
--- clfswm/src/config.lisp (original)
+++ clfswm/src/config.lisp Fri Oct 8 17:07:36 2010
@@ -37,6 +37,9 @@
(setf *have-to-compress-notify* t)
+(defparameter *have-to-display-hello-window* t
+ "Config(): Display the hello window at startup")
+
;;; CONFIG - Default modifiers
(defparameter *default-modifiers* '()
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Fri Oct 8 17:07:36 2010
@@ -38,6 +38,11 @@
:call-hook
:add-hook
:remove-hook
+ :clear-timers
+ :add-timer
+ :with-timer
+ :process-timers
+ :timer-loop
:dbg
:dbgnl
:dbgc
@@ -169,6 +174,49 @@
(setf ,hook (remove ,i ,hook)))))
+;;;,-----
+;;;| Timers tools
+;;;`-----
+(defparameter *timer-list* nil)
+
+(declaim (inline realtime->s s->realtime))
+
+(defun realtime->s (rtime)
+ (float (/ rtime internal-time-units-per-second)))
+
+(defun s->realtime (second)
+ (round (* second internal-time-units-per-second)))
+
+
+(defun clear-timers ()
+ (setf *timer-list* nil))
+
+(defun add-timer (delay fun)
+ (push (let ((time (+ (get-internal-real-time) (s->realtime delay))))
+ (lambda ()
+ (when (>= (get-internal-real-time) time)
+ (funcall fun)
+ t)))
+ *timer-list*))
+
+(defmacro with-timer ((delay) &body body)
+ `(add-timer ,delay
+ (lambda ()
+ , at body)))
+
+
+(defun process-timers ()
+ (dolist (timer *timer-list*)
+ (when (funcall timer)
+ (setf *timer-list* (remove timer *timer-list* :test #'equal)))))
+
+
+(defun timer-test-loop ()
+ (loop
+ (princ ".") (force-output)
+ (process-timers)
+ (sleep 0.5)))
+
;;;,-----
;;;| Debuging tools
More information about the clfswm-cvs
mailing list