cairo/cairo.lisp

   1 (in-package #:cl-gtk2-cairo)
   2
   3 (defcfun gdk-cairo-create :pointer (drawable (g-object drawable)))
   4
   5 (defclass gdk-context (cl-cairo2:context)
   6   ())
   7
   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)))
  16
  17 (defmethod cl-cairo2:destroy ((self gdk-context))
  18   (cl-cairo2::cairo_destroy (slot-value self 'cl-cairo2:pointer)))
  19
  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)
  29          ,@body)
  30        (cl-cairo2:destroy ,context))))
  31
  32 (defcfun gdk_cairo_set_source_pixbuf :void
  33   (cr :pointer)
  34   (pixbuf (g-object pixbuf))
  35   (pixbuf-x :int)
  36   (pixbuf-y :int))
  37
  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))
  41
  42 (defcfun gdk_cairo_set_source_pixmap :void
  43   (cr :pointer)
  44   (pixmap (g-object pixmap))
  45   (pixmap-x :double)
  46   (pixmap-y :double))
  47
  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))
  51
  52 (defcfun gdk_cairo_region :void
  53   (cr :pointer)
  54   (region (g-boxed-foreign region)))
  55
  56 (defun gdk-cairo-region (region &optional (context cl-cairo2:*context*))
  57   (gdk_cairo_region (slot-value context 'cl-cairo2:pointer) region))
  58
  59 (defcfun gdk_cairo_reset_clip :void
  60   (cr :pointer)
  61   (drawable (g-object drawable)))
  62
  63 (defun gdk-cairo-reset-clip (drawable &optional (context cl-cairo2:*context*))
  64   (gdk_cairo_reset_clip (slot-value context 'cl-cairo2:pointer) drawable))
  65
  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
  78                                         width height))
  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))))
  82         (dotimes (y height)
  83           (dotimes (x width)
  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))))))
  92       pixbuf)))
  93