1 (in-package #:cl-gtk2-cairo)
3 (defcfun gdk-cairo-create :pointer (drawable (g-object drawable)))
5 (defclass gdk-context (cl-cairo2:context)
8 (defun create-gdk-context (gdk-drawable)
9 "Creates a context to draw on a GTK widget, more precisely on the
10 associated gdk-window. This should only be called from within the
11 expose event. In cells-gtk, use (gtk-adds-widget-window gtk-pointer)
12 to obtain the gdk-window. 'gtk-pointer' is the pointer parameter
13 passed to the expose event handler."
14 (make-instance 'gdk-context
15 :pointer (gdk-cairo-create gdk-drawable)))
17 (defmethod cl-cairo2:destroy ((self gdk-context))
18 (cl-cairo2::cairo_destroy (slot-value self 'cl-cairo2:pointer)))
20 (defmacro with-gdk-context ((context gdk-drawable) &body body)
21 "Executes body while context is bound to a valid cairo context for
22 gdk-window. This should only be called from within an expose event
23 handler. In cells-gtk, use (gtk-adds-widget-window gtk-pointer) to
24 obtain the gdk-window. 'gtk-pointer' is the pointer parameter passed
25 to the expose event handler."
26 (cl-utilities:with-gensyms (context-pointer)
27 `(let ((,context (create-gdk-context ,gdk-drawable)))
28 (cl-cairo2::with-context-pointer (,context ,context-pointer)
30 (cl-cairo2:destroy ,context))))
32 (defcfun gdk_cairo_set_source_pixbuf :void
34 (pixbuf (g-object pixbuf))
38 (defun gdk-cairo-set-source-pixbuf (pixbuf pixbuf-x pixbuf-y &optional (context cl-cairo2:*context*))
39 (gdk_cairo_set_source_pixbuf (slot-value context 'cl-cairo2:pointer)
40 pixbuf pixbuf-x pixbuf-y))
42 (defcfun gdk_cairo_set_source_pixmap :void
44 (pixmap (g-object pixmap))
48 (defun gdk-cairo-set-source-pixmap (pixmap pixmap-x pixmap-y &optional (context cl-cairo2:*context*))
49 (gdk_cairo_set_source_pixmap (slot-value context 'cl-cairo2:pointer)
50 pixmap pixmap-x pixmap-y))
52 (defcfun gdk_cairo_region :void
54 (region (g-boxed-foreign region)))
56 (defun gdk-cairo-region (region &optional (context cl-cairo2:*context*))
57 (gdk_cairo_region (slot-value context 'cl-cairo2:pointer) region))
59 (defcfun gdk_cairo_reset_clip :void
61 (drawable (g-object drawable)))
63 (defun gdk-cairo-reset-clip (drawable &optional (context cl-cairo2:*context*))
64 (gdk_cairo_reset_clip (slot-value context 'cl-cairo2:pointer) drawable))
66 ;; This looks nearly as bad as it actually is. gdk_pixbuf only supports
67 ;; 32-bit pixels / 8 bits per channel, with RGB bytes in _reverse order_
68 ;; from cairo. Needs big-endian testing.
69 (defun gdk-pixbuf-from-cairo-image (image)
70 (let ((width (cairo:image-surface-get-width image))
71 (height (cairo:image-surface-get-height image))
72 (src (cairo:image-surface-get-data image :pointer-only t))
73 (src-stride (cairo:image-surface-get-stride image))
74 (format (cairo:image-surface-get-format image)))
75 (unless (or (eq format :argb32) (eq format :rgb24))
76 (error "Unsupported format: ~A~%" format))
77 (let* ((pixbuf (gdk::gdk-pixbuf-new :rgb (eq format :argb32) 8
79 (dest-stride (gdk:pixbuf-rowstride pixbuf))
80 (dest (gdk:pixbuf-pixels pixbuf)))
81 (flet ((offset (x c y s) (+ (* x 4) c (* y s))))
84 (setf (mem-ref dest :uint8 (offset x 0 y dest-stride))
85 (mem-ref src :uint8 (offset x 2 y src-stride)))
86 (setf (mem-ref dest :uint8 (offset x 1 y dest-stride))
87 (mem-ref src :uint8 (offset x 1 y src-stride)))
88 (setf (mem-ref dest :uint8 (offset x 2 y dest-stride))
89 (mem-ref src :uint8 (offset x 0 y src-stride)))
90 (setf (mem-ref dest :uint8 (offset x 3 y dest-stride))
91 (mem-ref src :uint8 (offset x 3 y src-stride))))))