← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/clx/demo/clclock.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/clx/demo/clclock.lisp
 
1
(defpackage "XCLCLOCK"
 
2
  (:use "CL")
 
3
  (:export "CLOCK"))
 
4
 
 
5
(in-package "XCLCLOCK")
 
6
 
 
7
(defvar *display* (xlib:open-default-display))
 
8
(defvar *screen* (xlib:display-default-screen *display*))
 
9
(defvar *colormap* (xlib:screen-default-colormap *screen*))
 
10
 
 
11
(defvar *font* (xlib:open-font *display* "fixed"))
 
12
(defvar *win*)
 
13
 
 
14
(multiple-value-bind (width ascent)
 
15
    (xlib:text-extents *font* "XVIIII XXXVIIII XXXVIIII")
 
16
  (setq *win*
 
17
    (xlib:create-window
 
18
     :parent (xlib:screen-root *screen*)
 
19
     :x 512
 
20
     :y 512
 
21
     :width (+ 20 width) 
 
22
     :height (+ 20 ascent)
 
23
     :background (xlib:alloc-color *colormap*
 
24
                                   (xlib:lookup-color *colormap*
 
25
                                                      "midnightblue")))))
 
26
 
 
27
(defvar *gcontext* (xlib:create-gcontext
 
28
                    :drawable *win*
 
29
                    :fill-style :solid
 
30
                    :background (xlib:screen-white-pixel *screen*)
 
31
                    :foreground (xlib:alloc-color *colormap*
 
32
                                                  (xlib:lookup-color
 
33
                                                   *colormap*
 
34
                                                   "yellow"))
 
35
                    :font *font*))
 
36
 
 
37
(defvar *background* (xlib:create-gcontext
 
38
                      :drawable *win*
 
39
                      :fill-style :solid
 
40
                      :background (xlib:screen-white-pixel *screen*)
 
41
                      :foreground (xlib:alloc-color *colormap*
 
42
                                   (xlib:lookup-color *colormap*
 
43
                                                      "midnightblue"))
 
44
                      :font *font*))
 
45
(defvar *palette* nil)
 
46
(defvar *black* (xlib:screen-black-pixel *screen*))
 
47
 
 
48
(defun romanize (arg)
 
49
  (if (zerop arg)
 
50
      "O"
 
51
      (format nil "~@R" arg)))
 
52
 
 
53
(defun clock-string ()
 
54
  (multiple-value-bind (s m h) (decode-universal-time (get-universal-time))
 
55
    (format nil "~a ~a ~a" (romanize h) (romanize m) (romanize s))))
 
56
 
 
57
(defun update-clockface ()
 
58
  (let ((string (clock-string)))
 
59
    (let ((string-width (xlib:text-width *gcontext* string)))
 
60
      (xlib:draw-rectangle *win* *background*
 
61
                           0 0
 
62
                           (xlib:drawable-width *win*)
 
63
                           (xlib:drawable-height *win*)
 
64
                           :fill-p)
 
65
      (xlib:draw-glyphs *win* *gcontext*
 
66
                        (- (truncate
 
67
                            (- (xlib:drawable-width *win*) string-width)
 
68
                            2)
 
69
                           10)
 
70
                        (- (xlib:drawable-height *win*) 10)
 
71
                        string)))
 
72
  (xlib:display-force-output *display*))
 
73
 
 
74
(defun clock ()
 
75
  (xlib:map-window *win*)
 
76
  (loop
 
77
   (update-clockface)
 
78
   (sleep 1)))