chiark / gitweb /
3ea51ac1c444c8df7b2d11371d0e5033dd78e3af
[clg] / gdk / gdk.lisp
1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2005 Espen S. Johnsen <espen@users.sf.net>
3 ;;
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23 ;; $Id: gdk.lisp,v 1.19 2006-02-07 13:22:14 espen Exp $
24
25
26 (in-package "GDK")
27
28 ;;; Initialization
29  
30 (defbinding (gdk-init "gdk_parse_args") () nil
31   "Initializes the library without opening the display."
32   (nil null)
33   (nil null))
34
35
36
37 ;;; Display
38
39 (defbinding %display-open () display
40   (display-name (or null string)))
41
42 (defun display-open (&optional display-name)
43   (let ((display (%display-open display-name)))
44     (unless (display-get-default)
45       (display-set-default display))
46     display))
47
48 (defbinding %display-get-n-screens () int
49   (display display))
50
51 (defbinding %display-get-screen () screen
52   (display display)
53   (screen-num int))
54
55 (defun display-screens (&optional (display (display-get-default)))
56   (loop
57    for i from 0 below (%display-get-n-screens display)
58    collect (%display-get-screen display i)))
59
60 (defbinding display-get-default-screen 
61     (&optional (display (display-get-default))) screen
62   (display display))
63
64 (defbinding display-beep (&optional (display (display-get-default))) nil
65   (display display))
66
67 (defbinding display-sync (&optional (display (display-get-default))) nil
68   (display display))
69
70 (defbinding display-flush (&optional (display (display-get-default))) nil
71   (display display))
72
73 (defbinding display-close (&optional (display (display-get-default))) nil
74   (display display))
75
76 (defbinding display-get-event
77     (&optional (display (display-get-default))) event
78   (display display))
79
80 (defbinding display-peek-event
81     (&optional (display (display-get-default))) event
82   (display display))
83
84 (defbinding display-put-event
85     (event &optional (display (display-get-default))) event
86   (display display)
87   (event event))
88
89 (defbinding (display-connection-number "clg_gdk_connection_number")
90     (&optional (display (display-get-default))) int
91   (display display))
92
93
94
95 ;;; Display manager
96
97 (defbinding display-get-default () display)
98
99 (defbinding (display-manager "gdk_display_manager_get") () display-manager)
100
101 (defbinding (display-set-default "gdk_display_manager_set_default_display")
102     (display) nil
103   ((display-manager) display-manager)
104   (display display))
105
106
107
108 ;;; Events
109
110 (defbinding (events-pending-p "gdk_events_pending") () boolean)
111
112 (defbinding event-get () event)
113
114 (defbinding event-peek () event)
115
116 (defbinding event-get-graphics-expose () event
117   (window window))
118
119 (defbinding event-put () event
120   (event event))
121
122 ;(defbinding event-handler-set () ...)
123
124 (defbinding set-show-events () nil
125   (show-events boolean))
126
127 (defbinding get-show-events () boolean)
128
129
130 ;;; Miscellaneous functions
131
132 (defbinding screen-width () int)
133 (defbinding screen-height () int)
134
135 (defbinding screen-width-mm () int)
136 (defbinding screen-height-mm () int)
137
138 (defbinding pointer-grab 
139     (window &key owner-events events confine-to cursor time) grab-status
140   (window window)
141   (owner-events boolean)
142   (events event-mask)
143   (confine-to (or null window))
144   (cursor (or null cursor))
145   ((or time 0) (unsigned 32)))
146
147 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
148     (&optional time (display (display-get-default))) nil
149   (display display)
150   ((or time 0) (unsigned 32)))
151
152 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed") 
153     (&optional (display (display-get-default))) boolean)
154
155 (defbinding keyboard-grab (window &key owner-events time) grab-status
156   (window window)
157   (owner-events boolean)
158   ((or time 0) (unsigned 32)))
159
160 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
161     (&optional time (display (display-get-default))) nil
162   (display display)
163   ((or time 0) (unsigned 32)))
164
165
166
167 (defbinding atom-intern (atom-name &optional only-if-exists) atom
168   ((string atom-name) string)
169   (only-if-exists boolean))
170
171 (defbinding atom-name () string
172   (atom atom))
173
174
175
176 ;;; Visuals
177
178 (defbinding visual-get-best-depth () int)
179
180 (defbinding visual-get-best-type () visual-type)
181
182 (defbinding visual-get-system () visual)
183
184
185 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
186
187 (defbinding %visual-get-best-with-depth () visual
188   (depth int))
189
190 (defbinding %visual-get-best-with-type () visual
191   (type visual-type))
192
193 (defbinding %visual-get-best-with-both () visual
194   (depth int)
195   (type visual-type))
196
197 (defun visual-get-best (&key depth type)
198   (cond
199    ((and depth type) (%visual-get-best-with-both depth type))
200    (depth (%visual-get-best-with-depth depth))
201    (type (%visual-get-best-with-type type))
202    (t (%visual-get-best-with-nothing))))
203
204 ;(defbinding query-depths ..)
205
206 ;(defbinding query-visual-types ..)
207
208 (defbinding list-visuals () (glist visual))
209
210
211 ;;; Windows
212
213 (defbinding window-destroy () nil
214   (window window))
215
216
217 (defbinding window-at-pointer () window
218   (x int :out)
219   (y int :out))
220
221 (defbinding window-show () nil
222   (window window))
223
224 (defbinding window-show-unraised () nil
225   (window window))
226
227 (defbinding window-hide () nil
228   (window window))
229
230 (defbinding window-is-visible-p () boolean
231   (window window))
232
233 (defbinding window-is-viewable-p () boolean
234   (window window))
235
236 (defbinding window-withdraw () nil
237   (window window))
238
239 (defbinding window-iconify () nil
240   (window window))
241
242 (defbinding window-deiconify () nil
243   (window window))
244
245 (defbinding window-stick () nil
246   (window window))
247
248 (defbinding window-unstick () nil
249   (window window))
250
251 (defbinding window-maximize () nil
252   (window window))
253
254 (defbinding window-unmaximize () nil
255   (window window))
256
257 (defbinding window-fullscreen () nil
258   (window window))
259
260 (defbinding window-unfullscreen () nil
261   (window window))
262
263 (defbinding window-set-keep-above () nil
264   (window window)
265   (setting boolean))
266
267 (defbinding window-set-keep-below () nil
268   (window window)
269   (setting boolean))
270
271 (defbinding window-move () nil
272   (window window)
273   (x int)
274   (y int))
275
276 (defbinding window-resize () nil
277   (window window)
278   (width int)
279   (height int))
280
281 (defbinding window-move-resize () nil
282   (window window)
283   (x int)
284   (y int)
285   (width int)
286   (height int))
287
288 (defbinding window-scroll () nil
289   (window window)
290   (dx int)
291   (dy int))
292
293 (defbinding window-reparent () nil
294   (window window)
295   (new-parent window)
296   (x int)
297   (y int))
298
299 (defbinding window-clear () nil
300   (window window))
301
302 (defbinding %window-clear-area () nil
303   (window window)
304   (x int) (y int) (width int) (height int))
305
306 (defbinding %window-clear-area-e () nil
307   (window window)
308   (x int) (y int) (width int) (height int))
309
310 (defun window-clear-area (window x y width height &optional expose)
311   (if expose
312       (%window-clear-area-e window x y width height)
313     (%window-clear-area window x y width height)))
314
315 (defbinding window-raise () nil
316   (window window))
317
318 (defbinding window-lower () nil
319   (window window))
320
321 (defbinding window-focus () nil
322   (window window)
323   (timestamp unsigned-int))
324
325 (defbinding window-register-dnd () nil
326   (window window))
327
328 (defbinding window-begin-resize-drag () nil
329   (window window)
330   (edge window-edge)
331   (button int)
332   (root-x int)
333   (root-y int)
334   (timestamp unsigned-int))
335
336 (defbinding window-begin-move-drag () nil
337   (window window)
338   (button int)
339   (root-x int)
340   (root-y int)
341   (timestamp unsigned-int))
342
343 ;; komplett så langt
344
345 (defbinding window-set-user-data () nil
346   (window window)
347   (user-data pointer))
348
349 (defbinding window-set-override-redirect () nil
350   (window window)
351   (override-redirect boolean))
352
353 ; (defbinding window-add-filter () nil
354
355 ; (defbinding window-remove-filter () nil
356
357 (defbinding window-shape-combine-mask () nil
358   (window window)
359   (shape-mask bitmap)
360   (offset-x int)
361   (offset-y int))
362
363 (defbinding window-set-child-shapes () nil
364   (window window))
365
366 (defbinding window-merge-child-shapes () nil
367   (window window))
368
369
370 (defbinding window-set-static-gravities () boolean
371   (window window)
372   (use-static boolean))
373
374 ; (defbinding add-client-message-filter ...
375
376 (defbinding window-set-cursor () nil
377   (window window)
378   (cursor (or null cursor)))
379
380 (defbinding window-get-pointer () window
381   (window window)
382   (x int :out)
383   (y int :out)
384   (mask modifier-type :out))
385
386 (defbinding %window-get-toplevels () (glist window))
387
388 (defun window-get-toplevels (&optional screen)
389   (if screen
390       (error "Not implemented")
391     (%window-get-toplevels)))
392
393 (defbinding %get-default-root-window () window)
394
395 (defun get-root-window (&optional display)
396   (if display
397       (error "Not implemented")
398     (%get-default-root-window)))
399
400
401
402 ;;; Drag and Drop
403
404 ;; Destination side
405
406 (defbinding drag-status () nil
407   (context drag-context)
408   (action drag-action)
409   (time (unsigned 32)))
410
411
412
413
414
415
416 ;;
417
418 (defbinding rgb-init () nil)
419
420
421
422
423 ;;; Cursor
424
425 (defmethod initialize-instance ((cursor cursor) &key type mask fg bg 
426                                 (x 0) (y 0) (display (display-get-default)))
427   (setf 
428    (slot-value cursor 'location)
429    (etypecase type
430      (keyword (%cursor-new-for-display display type))
431      (pixbuf (%cursor-new-from-pixbuf display type x y))
432      (pixmap (%cursor-new-from-pixmap type mask fg bg x y)))))
433
434
435 (defbinding %cursor-new-for-display () pointer
436   (display display)
437   (cursor-type cursor-type))
438
439 (defbinding %cursor-new-from-pixmap () pointer
440   (source pixmap)
441   (mask bitmap)
442   (foreground color)
443   (background color)
444   (x int) (y int))
445
446 (defbinding %cursor-new-from-pixbuf () pointer
447   (display display)
448   (pixbuf pixbuf)
449   (x int) (y int))
450
451 (defbinding %cursor-ref () pointer
452   (location pointer))
453
454 (defbinding %cursor-unref () nil
455   (location pointer))
456
457 (defmethod reference-foreign ((class (eql (find-class 'cursor))) location)
458   (declare (ignore class))
459   (%cursor-ref location))
460
461 (defmethod unreference-foreign ((class (eql (find-class 'cursor))) location)
462   (declare (ignore class))
463   (%cursor-unref location))
464
465
466 ;;; Pixmaps
467
468 (defbinding pixmap-new (width height depth &key window) pixmap
469   (width int)
470   (height int)
471   (depth int)
472   (window (or null window)))
473                                         
474 (defbinding %pixmap-colormap-create-from-xpm () pixmap
475   (window (or null window))
476   (colormap (or null colormap))
477   (mask bitmap :out)
478   (color (or null color))
479   (filename string))
480
481 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
482   (window (or null window))
483   (colormap (or null colormap))
484   (mask bitmap :out)
485   (color (or null color))
486   (data (vector string)))
487
488 (defun pixmap-create (source &key color window colormap)
489   (let ((window
490          (if (not (or window colormap))
491              (get-root-window)
492            window)))
493     (multiple-value-bind (pixmap mask)
494         (etypecase source
495           ((or string pathname)
496            (%pixmap-colormap-create-from-xpm
497             window colormap color (namestring (truename source))))
498           ((vector string)
499            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
500 ;;       (unreference-instance pixmap)
501 ;;       (unreference-instance mask)
502       (values pixmap mask))))
503
504
505
506 ;;; Color
507
508 (defun %scale-value (value)
509   (etypecase value
510     (integer value)
511     (float (truncate (* value 65535)))))
512
513 (defmethod initialize-instance ((color color) &rest initargs
514                                 &key red green blue)
515   (declare (ignore initargs))
516   (call-next-method)
517   (with-slots ((%red red) (%green green) (%blue blue)) color
518     (setf
519      %red (%scale-value red)
520      %green (%scale-value green)
521      %blue (%scale-value blue))))
522
523 (defun ensure-color (color)
524   (etypecase color
525     (null nil)
526     (color color)
527     (vector
528      (make-instance
529       'color :red (svref color 0) :green (svref color 1)
530       :blue (svref color 2)))))
531        
532
533   
534 ;;; Drawable
535
536 (defbinding drawable-get-size () nil
537   (drawable drawable)
538   (width int :out)
539   (height int :out))
540
541 (defbinding (drawable-width "gdk_drawable_get_size") () nil
542   (drawable drawable)
543   (width int :out)
544   (nil null))
545
546 (defbinding (drawable-height "gdk_drawable_get_size") () nil
547   (drawable drawable)
548   (nil null)
549   (height int :out))
550
551 ;; (defbinding drawable-get-clip-region () region
552 ;;   (drawable drawable))
553
554 ;; (defbinding drawable-get-visible-region () region
555 ;;   (drawable drawable))
556
557 (defbinding draw-point () nil
558   (drawable drawable) (gc gc) 
559   (x int) (y int))
560
561 (defbinding %draw-points () nil
562   (drawable drawable) (gc gc) 
563   (points pointer)
564   (n-points int))
565
566 ;; (defun draw-points (drawable gc &rest points)
567   
568 ;;   )
569
570 (defbinding draw-line () nil
571   (drawable drawable) (gc gc) 
572   (x1 int) (y1 int)
573   (x2 int) (y2 int))
574
575 ;; (defbinding draw-lines (drawable gc &rest points) nil
576 ;;   (drawable drawable) (gc gc) 
577 ;;   (points (vector point))
578 ;;   ((length points) int))
579
580 (defbinding draw-pixbuf
581     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
582      width height (dither :none) (x-dither 0) (y-dither 0)) nil
583   (drawable drawable) (gc (or null gc))
584   (pixbuf pixbuf)
585   (src-x int) (src-y int)
586   (dest-x int) (dest-y int)
587   ((or width -1) int) ((or height -1) int)
588   (dither rgb-dither)
589   (x-dither int) (y-dither int))
590
591 ;; (defbinding draw-segments (drawable gc &rest points) nil
592 ;;   (drawable drawable) (gc gc) 
593 ;;   (segments (vector segments))
594 ;;   ((length segments) int))
595
596 (defbinding draw-rectangle () nil
597   (drawable drawable) (gc gc) 
598   (filled boolean)
599   (x int) (y int) 
600   (width int) (height int))
601
602 (defbinding draw-arc () nil
603   (drawable drawable) (gc gc) 
604   (filled boolean)
605   (x int) (y int) 
606   (width int) (height int)
607   (angle1 int) (angle2 int))
608
609 ;; (defbinding draw-polygon (drawable gc &rest points) nil
610 ;;   (drawable drawable) (gc gc) 
611 ;;   (points (vector point))
612 ;;   ((length points) int))
613
614 ;; (defbinding draw-trapezoid (drawable gc &rest points) nil
615 ;;   (drawable drawable) (gc gc) 
616 ;;   (points (vector point))
617 ;;   ((length points) int))
618
619 ;; (defbinding %draw-layout-line () nil
620 ;;   (drawable drawable) (gc gc) 
621 ;;   (font pango:font)
622 ;;   (x int) (y int)
623 ;;   (line pango:layout-line))
624
625 ;; (defbinding %draw-layout-line-with-colors () nil
626 ;;   (drawable drawable) (gc gc) 
627 ;;   (font pango:font)
628 ;;   (x int) (y int)
629 ;;   (line pango:layout-line)
630 ;;   (foreground (or null color))
631 ;;   (background (or null color)))
632
633 ;; (defun draw-layout-line (drawable gc font x y line &optional foreground background)
634 ;;   (if (or foreground background)
635 ;;       (%draw-layout-line-with-colors drawable gc font x y line foreground background)
636 ;;     (%draw-layout-line drawable gc font x y line)))
637
638 (defbinding %draw-layout () nil
639   (drawable drawable) (gc gc) 
640   (font pango:font)
641   (x int) (y int)
642   (layout pango:layout))
643
644 (defbinding %draw-layout-with-colors () nil
645   (drawable drawable) (gc gc) 
646   (font pango:font)
647   (x int) (y int)
648   (layout pango:layout)
649   (foreground (or null color))
650   (background (or null color)))
651
652 (defun draw-layout (drawable gc font x y layout &optional foreground background)
653   (if (or foreground background)
654       (%draw-layout-with-colors drawable gc font x y layout foreground background)
655     (%draw-layout drawable gc font x y layout)))
656
657 (defbinding draw-drawable 
658     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
659   (drawable drawable) (gc gc) 
660   (src drawable)
661   (src-x int) (src-y int)
662   (dest-x int) (dest-y int)
663   ((or width -1) int) ((or height -1) int))
664
665 (defbinding draw-image 
666     (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
667   (drawable drawable) (gc gc) 
668   (image image)
669   (src-x int) (src-y int)
670   (dest-x int) (dest-y int)
671   ((or width -1) int) ((or height -1) int))
672
673 (defbinding drawable-get-image () image
674   (drawable drawable)
675   (x int) (y int)
676   (width int) (height int))
677
678 (defbinding drawable-copy-to-image 
679     (drawable src-x src-y width height &optional image dest-x dest-y) image
680   (drawable drawable)
681   (image (or null image))
682   (src-x int) (src-y int)
683   ((if image dest-x 0) int) 
684   ((if image dest-y 0) int)
685   (width int) (height int))
686
687
688 ;;; Key values
689
690 (defbinding keyval-name () string
691   (keyval unsigned-int))
692
693 (defbinding keyval-from-name () unsigned-int
694   (name string))
695
696 (defbinding keyval-to-upper () unsigned-int
697   (keyval unsigned-int))
698
699 (defbinding keyval-to-lower () unsigned-int
700   (keyval unsigned-int))
701
702 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
703   (keyval unsigned-int))
704
705 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
706   (keyval unsigned-int))
707
708 ;;; Cairo interaction
709
710 #+gtk2.8
711 (progn
712   (defbinding cairo-create () cairo:context
713     (drawable drawable))
714
715   (defmacro with-cairo-context ((cr drawable) &body body)
716     `(let ((,cr (cairo-create ,drawable)))
717        (unwind-protect
718            (progn ,@body)
719          (unreference-foreign 'cairo:context (foreign-location ,cr))
720          (invalidate-instance ,cr))))
721
722   (defbinding cairo-set-source-color () nil
723     (cr cairo:context)
724     (color color))
725
726   (defbinding cairo-set-source-pixbuf () nil
727     (cr cairo:context)
728     (pixbuf pixbuf)
729     (x double-float)
730     (y double-float))
731  
732   (defbinding cairo-rectangle () nil
733     (cr cairo:context)
734     (rectangle rectangle))
735  
736 ;;   (defbinding cairo-region () nil
737 ;;     (cr cairo:context)
738 ;;     (region region))
739 )