X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=cairo%2Fcairo.lisp;h=01bfaf3a69127654391f5aa742bc6ab74fb226e6;hb=HEAD;hp=7830d1899be02f17a09d63581ca98bf23deb6863;hpb=ead1d57a689234a3604caddb0903e0bcf6e1fe52;p=cl-gtk2.git

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
index 7830d18..01bfaf3 100644
--- a/cairo/cairo.lisp
+++ b/cairo/cairo.lisp
@@ -4,9 +4,9 @@
 
 (defclass gdk-context (cl-cairo2:context)
   ())
-                          
+
 (defun create-gdk-context (gdk-drawable)
-  "creates an context to draw on a GTK widget, more precisely on the
+  "Creates a context to draw on a GTK widget, more precisely on the
 associated gdk-window.  This should only be called from within the
 expose event.  In cells-gtk, use (gtk-adds-widget-window gtk-pointer)
 to obtain the gdk-window. 'gtk-pointer' is the pointer parameter
@@ -28,3 +28,66 @@ to the expose event handler."
        (cl-cairo2::with-context-pointer (,context ,context-pointer)
          ,@body)
        (cl-cairo2:destroy ,context))))
+
+(defcfun gdk_cairo_set_source_pixbuf :void
+  (cr :pointer)
+  (pixbuf (g-object pixbuf))
+  (pixbuf-x :int)
+  (pixbuf-y :int))
+
+(defun gdk-cairo-set-source-pixbuf (pixbuf pixbuf-x pixbuf-y &optional (context cl-cairo2:*context*))
+  (gdk_cairo_set_source_pixbuf (slot-value context 'cl-cairo2:pointer)
+                               pixbuf pixbuf-x pixbuf-y))
+
+(defcfun gdk_cairo_set_source_pixmap :void
+  (cr :pointer)
+  (pixmap (g-object pixmap))
+  (pixmap-x :double)
+  (pixmap-y :double))
+
+(defun gdk-cairo-set-source-pixmap (pixmap pixmap-x pixmap-y &optional (context cl-cairo2:*context*))
+  (gdk_cairo_set_source_pixmap (slot-value context 'cl-cairo2:pointer)
+                               pixmap pixmap-x pixmap-y))
+
+(defcfun gdk_cairo_region :void
+  (cr :pointer)
+  (region (g-boxed-foreign region)))
+
+(defun gdk-cairo-region (region &optional (context cl-cairo2:*context*))
+  (gdk_cairo_region (slot-value context 'cl-cairo2:pointer) region))
+
+(defcfun gdk_cairo_reset_clip :void
+  (cr :pointer)
+  (drawable (g-object drawable)))
+
+(defun gdk-cairo-reset-clip (drawable &optional (context cl-cairo2:*context*))
+  (gdk_cairo_reset_clip (slot-value context 'cl-cairo2:pointer) drawable))
+
+;; This looks nearly as bad as it actually is.  gdk_pixbuf only supports
+;; 32-bit pixels / 8 bits per channel, with RGB bytes in _reverse order_
+;; from cairo.  Needs big-endian testing.
+(defun gdk-pixbuf-from-cairo-image (image)
+  (let ((width (cairo:image-surface-get-width image))
+        (height (cairo:image-surface-get-height image))
+        (src (cairo:image-surface-get-data image :pointer-only t))
+        (src-stride (cairo:image-surface-get-stride image))
+        (format (cairo:image-surface-get-format image)))
+    (unless (or (eq format :argb32) (eq format :rgb24))
+      (error "Unsupported format: ~A~%" format))
+    (let* ((pixbuf (gdk::gdk-pixbuf-new :rgb (eq format :argb32) 8
+                                        width height))
+           (dest-stride (gdk:pixbuf-rowstride pixbuf))
+           (dest (gdk:pixbuf-pixels pixbuf)))
+      (flet ((offset (x c y s) (+ (* x 4) c (* y s))))
+        (dotimes (y height)
+          (dotimes (x width)
+            (setf (mem-ref dest :uint8 (offset x 0 y dest-stride))
+                  (mem-ref src :uint8 (offset x 2 y src-stride)))
+            (setf (mem-ref dest :uint8 (offset x 1 y dest-stride))
+                  (mem-ref src :uint8 (offset x 1 y src-stride)))
+            (setf (mem-ref dest :uint8 (offset x 2 y dest-stride))
+                  (mem-ref src :uint8 (offset x 0 y src-stride)))
+            (setf (mem-ref dest :uint8 (offset x 3 y dest-stride))
+                  (mem-ref src :uint8 (offset x 3 y src-stride))))))
+      pixbuf)))
+