chiark / gitweb /
Initial revision
[clg] / gdk / gdk.lisp
1 ;; Common Lisp bindings for GTK+ v1.2.x
2 ;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
3 ;;
4 ;; This library is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU Lesser General Public
6 ;; License as published by the Free Software Foundation; either
7 ;; version 2 of the License, or (at your option) any later version.
8 ;;
9 ;; This library is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12 ;; Lesser General Public License for more details.
13 ;;
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this library; if not, write to the Free Software
16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
17
18 ;; $Id: gdk.lisp,v 1.1 2000-08-14 16:44:39 espen Exp $
19
20
21 (in-package "GDK")
22
23
24 ;;; Events
25
26 ; (defmethod initialize-instance ((event event) &rest initargs &key)
27 ;   (declare (ignore initargs))
28 ;   (call-next-method)
29 ;   )
30
31 (defun find-event-class (event-type)
32   (find-class
33    (ecase event-type
34      (:expose 'expose-event)
35      (:delete 'delete-event))))
36
37 (deftype-method alien-copier event (type-spec)
38   (declare (ignore type-spec))
39   '%event-copy)
40
41 (deftype-method alien-deallocator event (type-spec)
42   (declare (ignore type-spec))
43   '%event-free)
44
45 (deftype-method translate-from-alien
46     event (type-spec location &optional (alloc :dynamic))
47   `(let ((location ,location))
48      (unless (null-pointer-p location)
49        (let ((event-class
50               (find-event-class
51                (funcall (get-reader-function 'event-type) location 0))))
52          ,(ecase alloc
53             (:dynamic '(ensure-alien-instance event-class location))
54             (:static '(ensure-alien-instance event-class location :static t))
55             (:copy '(ensure-alien-instance
56                      event-class (%event-copy location))))))))
57
58
59 (define-foreign event-poll-fd () int)
60
61 (define-foreign ("gdk_events_pending" events-pending-p) () boolean)
62
63 (define-foreign event-get () event)
64
65 (define-foreign event-peek () event)
66
67 (define-foreign event-get-graphics-expose () event
68   (window window))
69
70 (define-foreign event-put () event
71   (event event))
72
73 (define-foreign %event-copy (event &optional size) pointer
74   (event (or event pointer)))
75
76 (define-foreign %event-free () nil
77   (event (or event pointer)))
78
79 (define-foreign event-get-time () (unsigned 32)
80   (event event))
81
82 ;(define-foreign event-handler-set () ...)
83
84 (define-foreign set-show-events () nil
85   (show-events boolean))
86
87 ;;; Misc
88
89 (define-foreign set-use-xshm () nil
90   (use-xshm boolean))
91
92 (define-foreign get-show-events () boolean)
93
94 (define-foreign get-use-xshm () boolean)
95
96 (define-foreign get-display () string)
97
98 ; (define-foreign time-get () (unsigned 32))
99
100 ; (define-foreign timer-get () (unsigned 32))
101
102 ; (define-foreign timer-set () nil
103 ;   (milliseconds (unsigned 32)))
104
105 ; (define-foreign timer-enable () nil)
106
107 ; (define-foreign timer-disable () nil)
108
109 ; input ...
110
111 (define-foreign pointer-grab () int
112   (window window)
113   (owner-events boolean)
114   (event-mask event-mask)
115   (confine-to (or null window))
116   (cursor (or null cursor))
117   (time (unsigned 32)))
118
119 (define-foreign pointer-ungrab () nil
120   (time (unsigned 32)))
121
122 (define-foreign keyboard-grab () int
123   (window window)
124   (owner-events boolean)
125   (time (unsigned 32)))
126
127 (define-foreign keyboard-ungrab () nil
128   (time (unsigned 32)))
129
130 (define-foreign ("gdk_pointer_is_grabbed" pointer-is-grabbed-p) () boolean)
131
132 (define-foreign screen-width () int)
133 (define-foreign screen-height () int)
134
135 (define-foreign screen-width-mm () int)
136 (define-foreign screen-height-mm () int)
137
138 (define-foreign flush () nil)
139 (define-foreign beep () nil)
140
141 (define-foreign key-repeat-disable () nil)
142 (define-foreign key-repeat-restore () nil)
143
144
145
146 ;;; Visuals
147
148 (define-foreign visual-get-best-depth () int)
149
150 (define-foreign visual-get-best-type () visual-type)
151
152 (define-foreign visual-get-system () visual)
153
154
155 (define-foreign
156   ("gdk_visual_get_best" %visual-get-best-with-nothing) () visual)
157
158 (define-foreign %visual-get-best-with-depth () visual
159   (depth int))
160
161 (define-foreign %visual-get-best-with-type () visual
162   (type visual-type))
163
164 (define-foreign %visual-get-best-with-both () visual
165   (depth int)
166   (type visual-type))
167
168 (defun visual-get-best (&key depth type)
169   (cond
170    ((and depth type) (%visual-get-best-with-both depth type))
171    (depth (%visual-get-best-with-depth depth))
172    (type (%visual-get-best-with-type type))
173    (t (%visual-get-best-with-nothing))))
174
175 ;(define-foreign query-depths ..)
176
177 ;(define-foreign query-visual-types ..)
178
179 (define-foreign list-visuals () (double-list visual))
180
181
182 ;;; Windows
183
184 ; (define-foreign window-new ... )
185
186 (define-foreign window-destroy () nil
187   (window window))
188
189
190 ; (define-foreign window-at-pointer () window
191 ;   (window window)
192 ;   (x int :in-out)
193 ;   (y int :in-out))
194
195 (define-foreign window-show () nil
196   (window window))
197
198 (define-foreign window-hide () nil
199   (window window))
200
201 (define-foreign window-withdraw () nil
202   (window window))
203
204 (define-foreign window-move () nil
205   (window window)
206   (x int)
207   (y int))
208
209 (define-foreign window-resize () nil
210   (window window)
211   (width int)
212   (height int))
213
214 (define-foreign window-move-resize () nil
215   (window window)
216   (x int)
217   (y int)
218   (width int)
219   (height int))
220
221 (define-foreign window-reparent () nil
222   (window window)
223   (new-parent window)
224   (x int)
225   (y int))
226
227 (define-foreign window-clear () nil
228   (window window))
229
230 (unexport
231  '(window-clear-area-no-e window-clear-area-e))
232
233 (define-foreign ("gdk_window_clear_area" window-clear-area-no-e) () nil
234   (window window)
235   (x int) (y int) (width int) (height int))
236
237 (define-foreign window-clear-area-e () nil
238   (window window)
239   (x int) (y int) (width int) (height int))
240
241 (defun window-clear-area (window x y width height &optional expose)
242   (if expose
243       (window-clear-area-e window x y width height)
244     (window-clear-area-no-e window x y width height)))
245
246 ; (define-foreign window-copy-area () nil
247 ;   (window window)
248 ;   (gc gc)
249 ;   (x int)
250 ;   (y int)
251 ;   (source-window window)
252 ;   (source-x int)
253 ;   (source-y int)
254 ;   (width int)
255 ;   (height int))
256
257 (define-foreign window-raise () nil
258   (window window))
259
260 (define-foreign window-lower () nil
261   (window window))
262
263 ; (define-foreign window-set-user-data () nil
264
265 (define-foreign window-set-override-redirect () nil
266   (window window)
267   (override-redirect boolean))
268
269 ; (define-foreign window-add-filter () nil
270
271 ; (define-foreign window-remove-filter () nil
272
273 (define-foreign window-shape-combine-mask () nil
274   (window window)
275   (shape-mask bitmap)
276   (offset-x int)
277   (offset-y int))
278
279 (define-foreign window-set-child-shapes () nil
280   (window window))
281
282 (define-foreign window-merge-child-shapes () nil
283   (window window))
284
285 (define-foreign ("gdk_window_is_visible" window-is-visible-p) () boolean
286   (window window))
287
288 (define-foreign ("gdk_window_is_viewable" window-is-viewable-p) () boolean
289   (window window))
290
291 (define-foreign window-set-static-gravities () boolean
292   (window window)
293   (use-static boolean))
294
295 ; (define-foreign add-client-message-filter ...
296
297
298 ;;; Drag and Drop
299
300 (define-foreign drag-context-new () drag-context)
301
302 (define-foreign drag-context-ref () nil
303   (context drag-context))
304
305 (define-foreign drag-context-unref () nil
306   (context drag-context))
307
308 ;; Destination side
309
310 (define-foreign drag-status () nil
311   (context drag-context)
312   (action drag-action)
313   (time (unsigned 32)))
314
315
316
317
318 (define-foreign window-set-cursor () nil
319   (window window)
320   (cursor cursor))
321
322 (define-foreign window-get-pointer () window
323   (window window)
324   (x int :out)
325   (y int :out)
326   (mask modifier-type :out))
327
328 (define-foreign get-root-window () window)
329
330
331
332 ;;
333
334 (define-foreign rgb-init () nil)
335
336
337
338
339 ;;; Cursor
340
341 (deftype-method alien-ref cursor (type-spec)
342   (declare (ignore type-spec))
343   '%cursor-ref)
344
345 (deftype-method alien-unref cursor (type-spec)
346   (declare (ignore type-spec))
347   '%cursor-unref)
348
349
350 (define-foreign cursor-new () cursor
351   (cursor-type cursor-type))
352
353 (define-foreign cursor-new-from-pixmap () cursor
354   (source pixmap)
355   (mask bitmap)
356   (foreground color)
357   (background color)
358   (x int) (y int))
359
360 (define-foreign %cursor-ref () pointer
361   (cursor (or cursor pointer)))
362
363 (define-foreign %cursor-unref () nil
364   (cursor (or cursor pointer)))
365
366
367
368 ;;; Pixmaps
369
370 (define-foreign pixmap-new (width height depth &key window) pixmap
371   (width int)
372   (height int)
373   (depth int)
374   (window (or null window)))
375                                         
376
377 (define-foreign %pixmap-colormap-create-from-xpm () pixmap
378   (window (or null window))
379   (colormap (or null colormap))
380   (mask bitmap :out)
381   (color (or null color))
382   (filename string))
383
384 (define-foreign pixmap-colormap-create-from-xpm-d () pixmap
385   (window (or null window))
386   (colormap (or null colormap))
387   (mask bitmap :out)
388   (color (or null color))
389   (data pointer))
390
391 ; (defun pixmap-create (source &key color window colormap)
392 ;   (let ((window
393 ;        (if (not (or window colormap))
394 ;            (get-root-window)
395 ;          window)))
396 ;     (multiple-value-bind (pixmap bitmap)
397 ;         (typecase source
398 ;         ((or string pathname)
399 ;          (pixmap-colormap-create-from-xpm
400 ;           window colormap color (namestring (truename source))))
401 ;         (t
402 ;          (with-array (data :initial-contents source :free-contents t)
403 ;            (pixmap-colormap-create-from-xpm-d window colormap color data))))
404 ;       (if color
405 ;         (progn
406 ;           (bitmap-unref bitmap)
407 ;           pixmap)
408 ;       (values pixmap bitmap)))))
409     
410
411
412 ;;; Color
413
414 (defun %scale-value (value)
415   (etypecase value
416     (integer value)
417     (float (truncate (* value 65535)))))
418
419 (defmethod initialize-instance ((color color) &rest initargs
420                                 &key (colors #(0 0 0)) red green blue)
421   (declare (ignore initargs))
422   (call-next-method)
423   (with-slots ((%red red) (%green green) (%blue blue)) color
424     (setf
425      %red (%scale-value (or red (svref colors 0)))
426      %green (%scale-value (or green (svref colors 1)))
427      %blue (%scale-value (or blue (svref colors 2))))))
428
429
430 (defun ensure-color (color)
431   (etypecase color
432     (null nil)
433     (color color)
434     (vector (make-instance 'color :colors color))))
435        
436
437   
438 ;;; Fonts
439
440 (define-foreign font-load () font
441   (font-name string))
442
443 (defun ensure-font (font)
444   (etypecase font
445     (null nil)
446     (font font)
447     (string (font-load font))))
448
449 (define-foreign fontset-load () font
450   (fontset-name string))
451
452 (define-foreign font-ref () font
453   (font font))
454
455 (define-foreign font-unref () nil
456   (font font))
457
458 (defun font-maybe-unref (font1 font2)
459   (unless (eq font1 font2)
460     (font-unref font1)))
461
462 (define-foreign font-id () int
463   (font font))
464
465 (define-foreign ("gdk_font_equal" font-equalp) () boolean
466   (font-a font)
467   (font-b font))
468
469 (define-foreign string-width () int
470   (font font)
471   (string string))
472
473 (define-foreign text-width
474     (font text &aux (length (length text))) int
475   (font font)
476   (text string)
477   (length int))
478
479 ; (define-foreign ("gdk_text_width_wc" text-width-wc)
480 ;     (font text &aux (length (length text))) int
481 ;   (font font)
482 ;   (text string)
483 ;   (length int))
484
485 (define-foreign char-width () int
486   (font font)
487   (char char))
488
489 ; (define-foreign ("gdk_char_width_wc" char-width-wc) () int
490 ;   (font font)
491 ;   (char char))
492
493
494 (define-foreign string-measure () int
495   (font font)
496   (string string))
497
498 (define-foreign text-measure
499     (font text &aux (length (length text))) int
500   (font font)
501   (text string)
502   (length int))
503
504 (define-foreign char-measure () int
505   (font font)
506   (char char))
507
508 (define-foreign string-height () int
509   (font font)
510   (string string))
511
512 (define-foreign text-height
513     (font text &aux (length (length text))) int
514   (font font)
515   (text string)
516   (length int))
517
518 (define-foreign char-height () int
519   (font font)
520   (char char))
521
522
523 ;;; Drawing functions
524
525 (define-foreign draw-rectangle () nil
526   (drawable (or window pixmap bitmap))
527   (gc gc) (filled boolean)
528   (x int) (y int) (width int) (height int))
529
530
531 ;;; Key values
532
533 (define-foreign keyval-name () string
534   (keyval unsigned-int))
535
536 (define-foreign keyval-from-name () unsigned-int
537   (name string))
538
539 (define-foreign keyval-to-upper () unsigned-int
540   (keyval unsigned-int))
541
542 (define-foreign keyval-to-lower ()unsigned-int
543   (keyval unsigned-int))
544
545 (define-foreign ("gdk_keyval_is_upper" keyval-is-upper-p) () boolean
546   (keyval unsigned-int))
547
548 (define-foreign ("gdk_keyval_is_lower" keyval-is-lower-p) () boolean
549   (keyval unsigned-int))
550