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 ... |
---|