source: trunk/ccl/examples/gtk-clock.lisp @ 6

Last change on this file since 6 was 6, checked in by gb, 16 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2001 Clozure Associates
4;;;
5;;; This is a (loose) translation of the double-buffered clock GTK+
6;;; example to OpenMCL.  See p 222 of "Developing Linux Applications
7;;; with GDK and GTK+", Eric Harlow, (c) 1999 New Riders Publishing.
8;;;
9;;; Anyone who wants to use this code for any purpose is free to do so.
10;;; In doing so, the user acknowledges that this code is provided "as is",
11;;; without warranty of any kind, and that no other party is legally or
12;;; otherwise responsible for any consequences of its use.
13
14(in-package "CCL")
15
16;;;
17;;; Make GTK+ interface info available.
18(eval-when (:compile-toplevel :execute)
19  (use-interface-dir :GTK))
20
21;;; GTK+ "runtime support"; handy to have around at compile time, too.
22(eval-when (:compile-toplevel :load-toplevel :execute)
23  (require "OPENMCL-GTK-SUPPORT"))
24
25
26;;; A global alist mapping clock windows to their offscreen pixmaps.
27(defvar *gtk-clock-window-pixmaps* ())
28
29
30(defun draw-tick-at (pixmap gc nhour cx cy radius)
31  (let* ((radians (/ (* pi nhour) 6.0d0))
32         (sin-radians (sin radians))
33         (cos-radians (cos radians))
34         (95%radius (* radius .95)))
35    (#_gdk_draw_line pixmap gc
36                     (+ cx (floor (* 95%radius sin-radians)))
37                     (+ cy (floor (* 95%radius cos-radians)))
38                     (+ cx (floor (* radius sin-radians)))
39                     (+ cy (floor (* radius cos-radians))))))
40
41;;; It seems like this can get called when the drawing area's in the
42;;; process of being destroyed.  Try not to segfault in that case.
43(defcallback gtk-clock-repaint (:address data :signed-fullword)
44  (if (or (%null-ptr-p data)
45          (%null-ptr-p (pref data :<G>tk<W>idget.style)))
46    #$FALSE
47    (let* ((drawing-area data)
48           (radius 0)
49           (white-gc (pref drawing-area :<G>tk<W>idget.style.white_gc))
50           (black-gc (pref drawing-area :<G>tk<W>idget.style.black_gc))
51           (area-width  (pref drawing-area :<G>tk<W>idget.allocation.width))
52           (area-height (pref drawing-area :<G>tk<W>idget.allocation.height))
53           (dradians)
54           (midx 0)
55           (midy 0)
56           (vbox (pref drawing-area :<G>tk<W>idget.parent))
57           (window (pref vbox :<G>tk<W>idget.parent))
58           (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*))))
59      (rlet ((update-rect :<G>dk<R>ectangle))
60            ;; Clear pixmap (background image)
61            (#_gdk_draw_rectangle
62             pixmap white-gc #$TRUE 0 0 area-width area-height)
63           
64            ;; Calculate midpoint of clock.
65            (setq midx (ash area-width -1)
66                  midy (ash area-height -1))
67           
68            ;; Calculate radius
69            (setq radius (min midx midy))
70
71            ;; Draw circle
72            (#_gdk_draw_arc pixmap black-gc 0 0 0
73                            (+ midx midx) (+ midy midy) 0 (* 360 64))
74     
75            ;; Draw tickmarks on clock face.
76            (do* ((nhour 1 (1+ nhour)))
77                 ((> nhour 12))
78              (draw-tick-at pixmap black-gc nhour midx midy radius))
79            (multiple-value-bind (seconds minutes hours)
80                (decode-universal-time (get-universal-time))
81             
82              ;; Get radians from seconds
83              (setq dradians (/ (* seconds pi) 30.0d0))
84             
85              ;; Draw second hand.
86              (#_gdk_draw_line
87               pixmap black-gc midx midy
88               (+ midx (floor (* 0.9d0 radius (sin dradians))))
89               (- midy (floor (* 0.9d0 radius (cos dradians)))))
90             
91              ;; Get radians from minutes & seconds.
92              (setq dradians (+ (/ (* minutes pi) 30.0d0)
93                                (/ (* seconds pi) 1800.0d0)))
94             
95              ;; Draw minute hand.
96              (#_gdk_draw_line
97               pixmap black-gc midx midy
98               (+ midx (floor (* 0.7d0 radius (sin dradians))))
99               (- midy (floor (* 0.7d0 radius (cos dradians)))))
100             
101              ;; Get radians from hours & minutes.
102              (setq dradians (+ (/ (* (mod hours 12) pi) 6.0d0)
103                                (/ (* minutes pi) 360.0d0)))
104             
105              ;; Draw hour hand.
106              (#_gdk_draw_line
107               pixmap black-gc midx midy
108               (+ midx (floor (* 0.5d0 radius (sin dradians))))
109               (- midy (floor (* 0.5d0 radius (cos dradians)))))
110             
111              ;; Setup the update rectangle; this will force an expose event.
112              ;; The expose event handler will then copy the pixmap to the
113              ;; window.
114             
115              (setf (pref update-rect :<G>dk<R>ectangle.x) 0
116                    (pref update-rect :<G>dk<R>ectangle.y) 0
117                    (pref update-rect :<G>dk<R>ectangle.width) area-width
118                    (pref update-rect :<G>dk<R>ectangle.height) area-height)
119             
120              ;; Draw the update rectangle.
121              (#_gtk_widget_draw drawing-area update-rect)
122              #$TRUE)))))
123
124
125;;; This is called when the window's created and whenever it's
126;;; resized.  Create a new pixmap of appropriate
127;;; size; free the old one (if it's non-null).
128(defcallback gtk-clock-configure-event
129    (:address widget :address event :address window :signed-fullword)
130  (declare (ignore event))
131  (let* ((pair (assoc window *gtk-clock-window-pixmaps*)))
132    (if (cdr pair)
133      (#_gdk_pixmap_unref (cdr pair)))
134   
135    (setf (cdr pair)
136          (#_gdk_pixmap_new (pref widget :<G>tk<W>idget.window)
137                            (pref widget :<G>tk<W>idget.allocation.width)
138                            (pref widget :<G>tk<W>idget.allocation.height)
139                            -1)))
140  #$TRUE)
141
142;;; Copy the window's pixmap to the exposed region of the window.
143(defcallback gtk-clock-expose-event
144    (:address widget :address event :address window :signed-fullword)
145  (let* ((state (pref widget :<G>tk<W>idget.state))
146         (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*)))
147         (fg-gc (pref widget :<G>tk<W>idget.style.fg_gc))
148         (x (pref event :<G>dk<E>vent<E>xpose.area.x))
149         (y (pref event :<G>dk<E>vent<E>xpose.area.y))
150         (width (pref event :<G>dk<E>vent<E>xpose.area.width))
151         (height (pref event :<G>dk<E>vent<E>xpose.area.height)))
152    (#_gdk_draw_pixmap
153     (pref widget :<G>tk<W>idget.window)
154     (%get-ptr fg-gc (ash state 2))
155     pixmap
156     x y
157     x y
158     width height)
159    #$FALSE))
160
161;;; When the window's destroyed, delete its entry from the
162;;; *gtk-clock-window-pixmaps* alist.
163
164(defcallback gtk-clock-close (:address window :void)
165  (let* ((pair (assoc window *gtk-clock-window-pixmaps*)))
166    (if pair
167      (setq *gtk-clock-window-pixmaps*
168            (delete pair *gtk-clock-window-pixmaps*))
169      (break "No entry for window!"))))
170
171(defun gtk-clock ()
172  ;; Doesn't hurt to call gtk-init more than once.
173  (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL))
174         (vbox (#_gtk_vbox_new #$FALSE 0)))
175    (push (cons window nil) *gtk-clock-window-pixmaps*)
176    (#_gtk_container_add window vbox)
177    (#_gtk_widget_show vbox)
178    (let* ((drawing-area (#_gtk_drawing_area_new)))
179      (#_gtk_drawing_area_size drawing-area 200 200)
180      (#_gtk_box_pack_start vbox drawing-area #$TRUE #$TRUE 0)
181      (#_gtk_widget_show drawing-area)
182      (with-cstrs ((expose-name "expose_event")
183                   (configure-name "configure_event")
184                   (destroy-name "destroy")
185                   (window-title
186                     "Takes a lickin' and keeps on tickin'."))
187        (#_gtk_window_set_title window window-title)
188        (#_gtk_signal_connect drawing-area
189                              expose-name
190                              gtk-clock-expose-event
191                              window)
192        (#_gtk_signal_connect drawing-area
193                              configure-name
194                              gtk-clock-configure-event
195                              window)
196        (#_gtk_signal_connect window
197                              destroy-name
198                              gtk-clock-close
199                              (%null-ptr)))
200      (#_gtk_widget_show window)
201      (#_gtk_timeout_add 1000 gtk-clock-repaint drawing-area)
202      (values))))
203
Note: See TracBrowser for help on using the repository browser.