source: trunk/source/examples/gtk2-clock.lisp @ 11439

Last change on this file since 11439 was 4808, checked in by gb, 13 years ago

New file.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.5 KB
Line 
1;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2006 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CL-USER")
18
19(eval-when (:compile-toplevel :load-toplevel :execute)
20  (use-interface-dir :gtk2))
21
22
23;;; Loading "libgnomeui-2.so" seems to be the easiest way to force all of
24;;; its dependent libraries to be loaded
25(open-shared-library "libgnomeui-2.so")
26
27(defloadvar *gdk-threads-inited* nil)
28(defloadvar *gthread-inited* nil)
29
30
31;;; Set things up so that GDK will use lisp locks internally.
32;;; There are a few advantages to this, including the fact
33;;; that lisp locks are that newfangled recursive kind (a thread
34;;; that owns the lock can lock it agains, which is slightly
35;;; better than waiting forever for it to be released.)
36(defvar *gdk-lock* (make-lock))
37
38
39;;; Callbacks called by #_gdk_threads_enter and #_gdk_threads_leave.
40(defcallback lock-gdk-lock (:void)
41  (grab-lock *gdk-lock*))
42
43(defcallback unlock-gdk-lock (:void)
44  (release-lock *gdk-lock*))
45
46
47(defmacro with-gdk-lock-grabbed (&body body)
48  `(with-lock-grabbed (*gdk-lock*)
49    ,@body))
50
51;;; gtk_signal_connect is a C macro. Emulate it.
52(defmacro gtk-signal-connect (object name function user-data)
53  `(external-call "gtk_signal_connect_full"
54    :address ,object
55    :address ,name
56    :address ,function
57    :<G>tk<C>allback<M>arshal (%null-ptr)
58    :gpointer ,user-data
59    :<G>tk<D>estroy<N>otify (%null-ptr)
60    :gint 0
61    :gint 0
62    :gulong))
63
64(defcallback window-destroy-handler (:address window :void)
65  (declare (ignore window))
66  (#_gtk_main_quit))
67
68
69
70(defconstant single-float-pi (coerce pi 'single-float))
71
72;;; A global alist mapping clock windows to their offscreen pixmaps.
73(defvar *gtk-clock-window-pixmaps* ())
74
75
76(defun draw-tick-at (pixmap gc nhour cx cy radius)
77  (let* ((radians (/ (* single-float-pi nhour) 6.0))
78         (sin-radians (sin radians))
79         (cos-radians (cos radians))
80         (95%radius (* radius .95)))
81    (#_gdk_draw_line pixmap gc
82                     (+ cx (floor (* 95%radius sin-radians)))
83                     (+ cy (floor (* 95%radius cos-radians)))
84                     (+ cx (floor (* radius sin-radians)))
85                     (+ cy (floor (* radius cos-radians))))))
86
87;;; It seems like this can get called when the drawing area's in the
88;;; process of being destroyed.  Try not to segfault in that case.
89(defcallback gtk-clock-repaint (:address data :signed-fullword)
90  (if (or (%null-ptr-p data)
91          (%null-ptr-p (pref data :<G>tk<W>idget.style)))
92    #$FALSE
93    (let* ((drawing-area data)
94           (radius 0)
95           (white-gc (pref drawing-area :<G>tk<W>idget.style.white_gc))
96           (black-gc (pref drawing-area :<G>tk<W>idget.style.black_gc))
97           (area-width  (pref drawing-area :<G>tk<W>idget.allocation.width))
98           (area-height (pref drawing-area :<G>tk<W>idget.allocation.height))
99           (dradians)
100           (midx 0)
101           (midy 0)
102           (vbox (pref drawing-area :<G>tk<W>idget.parent))
103           (window (pref vbox :<G>tk<W>idget.parent))
104           (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*))))
105      (rlet ((update-rect :<G>dk<R>ectangle))
106            ;; Clear pixmap (background image)
107            (#_gdk_draw_rectangle
108             pixmap white-gc #$TRUE 0 0 area-width area-height)
109           
110            ;; Calculate midpoint of clock.
111            (setq midx (ash area-width -1)
112                  midy (ash area-height -1))
113           
114            ;; Calculate radius
115            (setq radius (min midx midy))
116
117            ;; Draw circle
118            (#_gdk_draw_arc pixmap black-gc 0 0 0
119                            (+ midx midx) (+ midy midy) 0 (* 360 64))
120     
121            ;; Draw tickmarks on clock face.
122            (do* ((nhour 1 (1+ nhour)))
123                 ((> nhour 12))
124              (draw-tick-at pixmap black-gc nhour midx midy radius))
125            (multiple-value-bind (seconds minutes hours)
126                (get-decoded-time)
127             
128              ;; Get radians from seconds
129              (setq dradians (/ (* seconds single-float-pi) 30.0))
130             
131              ;; Draw second hand.
132              (#_gdk_draw_line
133               pixmap black-gc midx midy
134               (+ midx (floor (* 0.9 radius (sin dradians))))
135               (- midy (floor (* 0.9 radius (cos dradians)))))
136             
137              ;; Get radians from minutes & seconds.
138              (setq dradians (+ (/ (* minutes single-float-pi) 30.0)
139                                (/ (* seconds single-float-pi) 1800.0)))
140             
141              ;; Draw minute hand.
142              (#_gdk_draw_line
143               pixmap black-gc midx midy
144               (+ midx (floor (* 0.7 radius (sin dradians))))
145               (- midy (floor (* 0.7 radius (cos dradians)))))
146             
147              ;; Get radians from hours & minutes.
148              (setq dradians (+ (/ (* (mod hours 12) pi) 6.0)
149                                (/ (* minutes pi) 360.0)))
150             
151              ;; Draw hour hand.
152              (#_gdk_draw_line
153               pixmap black-gc midx midy
154               (+ midx (floor (* 0.5 radius (sin dradians))))
155               (- midy (floor (* 0.5 radius (cos dradians)))))
156             
157              ;; Setup the update rectangle; this will force an expose event.
158              ;; The expose event handler will then copy the pixmap to the
159              ;; window.
160             
161              (setf (pref update-rect :<G>dk<R>ectangle.x) 0
162                    (pref update-rect :<G>dk<R>ectangle.y) 0
163                    (pref update-rect :<G>dk<R>ectangle.width) area-width
164                    (pref update-rect :<G>dk<R>ectangle.height) area-height)
165             
166              ;; Draw the update rectangle.
167              (#_gtk_widget_draw drawing-area update-rect)
168              #$TRUE)))))
169
170
171;;; This is called when the window's created and whenever it's
172;;; resized.  Create a new pixmap of appropriate
173;;; size; free the old one (if it's non-null).
174(defcallback gtk-clock-configure-event
175    (:address widget :address event :address window :signed-fullword)
176  (declare (ignore event))
177  (let* ((pair (assoc window *gtk-clock-window-pixmaps*)))
178    (if (cdr pair)
179      (#_gdk_drawable_unref (cdr pair)))
180    (setf (cdr pair)
181          (#_gdk_pixmap_new (pref widget :<G>tk<W>idget.window)
182                            (pref widget :<G>tk<W>idget.allocation.width)
183                            (pref widget :<G>tk<W>idget.allocation.height)
184                            -1)))
185  #$TRUE)
186
187;;; Copy the window's pixmap to the exposed region of the window.
188(defcallback gtk-clock-expose-event
189    (:address widget :address event :address window :signed-fullword)
190  (let* ((state (pref widget :<G>tk<W>idget.state))
191         (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*)))
192         (fg-gc (pref widget :<G>tk<W>idget.style.fg_gc))
193         (x (pref event :<G>dk<E>vent<E>xpose.area.x))
194         (y (pref event :<G>dk<E>vent<E>xpose.area.y))
195         (width (pref event :<G>dk<E>vent<E>xpose.area.width))
196         (height (pref event :<G>dk<E>vent<E>xpose.area.height)))
197    (#_gdk_draw_drawable
198     (pref widget :<G>tk<W>idget.window)
199     (%get-ptr fg-gc (ash state target::word-shift))
200     pixmap
201     x y
202     x y
203     width height)
204    #$FALSE))
205
206;;; When the window's destroyed, delete its entry from the
207;;; *gtk-clock-window-pixmaps* alist.
208
209(defcallback gtk-clock-close (:address window :void)
210  (let* ((pair (assoc window *gtk-clock-window-pixmaps*)))
211    (if pair
212      (if (null (setq *gtk-clock-window-pixmaps*
213                      (delete pair *gtk-clock-window-pixmaps*)))
214        (#_gtk_main_quit))
215      (break "No entry for window!"))))
216
217(defun gtk-clock ()
218  (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL))
219         (vbox (#_gtk_vbox_new #$FALSE 0)))
220    (push (cons window nil) *gtk-clock-window-pixmaps*)
221    (#_gtk_container_add window vbox)
222    (#_gtk_widget_show vbox)
223    (let* ((drawing-area (#_gtk_drawing_area_new)))
224      (#_gtk_drawing_area_size drawing-area 200 200)
225      (#_gtk_box_pack_start vbox drawing-area #$TRUE #$TRUE 0)
226      (#_gtk_widget_show drawing-area)
227      (with-cstrs ((expose-name "expose_event")
228                   (configure-name "configure_event")
229                   (destroy-name "destroy")
230                   (window-title
231                     "Takes a licking.  Keeps on ticking."))
232        (#_gtk_window_set_title window window-title)
233        (gtk-signal-connect drawing-area
234                              expose-name
235                              gtk-clock-expose-event
236                              window)
237        (gtk-signal-connect drawing-area
238                            configure-name
239                            gtk-clock-configure-event
240                            window)
241        (gtk-signal-connect window
242                            destroy-name
243                            gtk-clock-close
244                            (%null-ptr)))
245      (#_gtk_widget_show window)
246      (#_gtk_timeout_add 1000 gtk-clock-repaint drawing-area)
247      (values))))
248
249
250(defun main (&rest args)
251  (unless *gthread-inited*
252    (#_g_thread_init (%null-ptr))
253    (setq *gthread-inited* t))
254  (unless *gdk-threads-inited*
255    ;; Tell GDK to use our locks.
256    (#_gdk_threads_set_lock_functions lock-gdk-lock unlock-gdk-lock)
257    (#_gdk_threads_init)
258    (setq *gdk-threads-inited* t))
259  (process-run-function "GTK Event thread"
260                        #'(lambda ()
261                            (#_gdk_threads_enter)
262                            (rlet ((argc :int)
263                                   (argvp (:* t)))
264                              (with-string-vector (argv args)
265                                (setf (pref argc :int) (length args)
266                                      (%get-ptr argvp ) argv)
267                                (#_gtk_init argc argvp)))
268                            (gtk-clock)
269                            (#_gtk_main)
270                            (#_gdk_threads_leave))))
271
272;;; calling (MAIN) starts an event thread and displays a clock.
273;;; subsequent calls to (GTK-CLOCK) display additional clocks,
274;;;  if/when they can get a word in edgewise ...
Note: See TracBrowser for help on using the repository browser.