Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv28245/Backends/gtkairo

Modified Files: gtk-ffi.lisp medium.lisp pango.lisp Added Files: cairo.lisp Log Message:

Split up gtkairo/medium.lisp, moving the cairo medium into its own file.

--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/25 19:55:11 1.24 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/12/26 12:11:04 1.25 @@ -118,6 +118,9 @@ (defmacro with-cairo-floats ((&optional) &body body) `(progn ,@body))

+(defmacro slot (o c s) + `(cffi:foreign-slot-value ,o ,c ,s)) + ;; Note: There's no need for locking in single threaded mode for most ;; functions, except that the main loop functions try to release the ;; lock temporarily, so those need to be called with locking. Let's do --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/25 19:55:11 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/12/26 12:11:04 1.16 @@ -32,21 +32,16 @@ (defclass gtkairo-medium (climi::basic-medium clim:medium) ((port :initarg :port :accessor port)))

-(defclass cairo-medium (gtkairo-medium) - ((cr :initform nil :initarg :cr :accessor cr) - (flipping-original-cr :initform nil :accessor flipping-original-cr) - (flipping-pixmap :initform nil :accessor flipping-pixmap) - (flipping-region :accessor flipping-region) - (surface :initarg :surface :accessor surface) - (last-seen-sheet :accessor last-seen-sheet) - (last-seen-region :accessor last-seen-region))) - -(defmethod initialize-instance :after - ((instance cairo-medium) &key cr) - (unless cr - (setf (last-seen-sheet instance) nil))) +(defclass metrik-medium-mixin () ()) +(defclass cairo-metrik-medium (metrik-medium-mixin cairo-medium) ()) +(defclass gdk-metrik-medium (metrik-medium-mixin gdk-medium) ())

-(defparameter *antialiasingp* t) +(defgeneric invoke-with-medium (fn medium)) + +(defmacro with-medium ((medium) &body body) + `(invoke-with-medium (lambda () ,@body) ,medium)) + +(defgeneric metrik-medium-for (medium))

(defun gtkwidget-gdkwindow (widget) (cffi:foreign-slot-value widget 'gtkwidget 'gdkwindow)) @@ -55,55 +50,6 @@ (or (climi::port-lookup-mirror (port medium) (medium-sheet medium)) (error "oops, drawing operation on unmirrored sheet ~A" medium)))

-(defmethod invoke-with-medium (fn (medium cairo-medium)) - (when (or (cr medium) - (climi::port-lookup-mirror (port medium) (medium-sheet medium))) - (with-gtk () - (multiple-value-prog1 - (funcall fn) - (when (flipping-original-cr medium) - (apply-flipping-ink medium)))))) - -(defun sheet-changed-behind-our-back-p (medium) - (and (slot-boundp medium 'last-seen-sheet) - (or (not (eq (last-seen-sheet medium) (medium-sheet medium))) - (not (region-equal (last-seen-region medium) - (sheet-region (medium-sheet medium))))))) - -(defmethod metrik-medium-for ((medium cairo-medium)) - (cairo-metrik-medium (port medium))) - -(defun set-antialias (cr) - (cairo_set_antialias cr - (if *antialiasingp* - :CAIRO_ANTIALIAS_DEFAULT - :CAIRO_ANTIALIAS_NONE))) - -(defun sync-sheet (medium) - (when (medium-sheet medium) ;ignore the metrik-medium - (setf (gethash medium (dirty-mediums (port medium))) t)) - (when (or (null (cr medium)) - (sheet-changed-behind-our-back-p medium)) - (with-medium (medium) - (let* ((mirror (medium-mirror medium)) - (drawable (mirror-drawable mirror))) - (setf (cr medium) (gdk_cairo_create drawable)) - (dispose-flipping-pixmap medium) - (pushnew medium (mirror-mediums mirror)) - (set-antialias (cr medium))) - (setf (last-seen-sheet medium) (medium-sheet medium)) - (setf (last-seen-region medium) (sheet-region (medium-sheet medium)))))) - -(defun dispose-flipping-pixmap (medium) - (when (flipping-pixmap medium) - (gdk_drawable_unref (flipping-pixmap medium)) - (setf (flipping-pixmap medium) nil))) - - -;;;; ------------------------------------------------------------------------ -;;;; 8.3 Output Protocol -;;;; - (defmethod engraft-medium :after ((medium gtkairo-medium) port sheet) )

@@ -125,169 +71,6 @@ :port port :sheet sheet))

-;;;; ------------------------------------------------------------------------ -;;;; Drawing Options -;;;; - -(defun sync-transformation (medium &optional extra-transformation) - (with-slots (cr) medium - (cffi:with-foreign-object (matrix 'cairo_matrix_t) - (let ((tr - (if (medium-sheet medium) - (sheet-native-transformation (medium-sheet medium)) - clim:+identity-transformation+))) - (when extra-transformation - (setf tr (compose-transformations extra-transformation tr))) - (multiple-value-bind (mxx mxy myx myy tx ty) - (climi::get-transformation tr) - ;; Make sure not to hand transformations to cairo that it won't - ;; like, since debugging gets ugly once a cairo context goes - ;; into an error state: - (invert-transformation tr) - (cairo_matrix_init matrix - (df mxx) (df mxy) (df myx) (df myy) - (df tx) (df ty)) - (cairo_set_matrix cr matrix)))))) - -(defmacro with-cairo-matrix ((matrix transformation) &body body) - `(cffi:with-foreign-object (,matrix 'cairo_matrix_t) - (multiple-value-bind (mxx mxy myx myy tx ty) - (climi::get-transformation ,transformation) - (cairo_matrix_init ,matrix - (df mxx) (df mxy) (df myx) (df myy) - (df tx) (df ty)) - (locally ,@body)))) - -;;; ink - -(defmethod sync-ink :before (medium new-value) - (with-slots (cr) medium - (cairo_set_operator cr :over))) - -(defmethod sync-ink (medium (new-value (eql clim:+foreground-ink+))) - (sync-ink medium (clim:medium-foreground medium))) ;### circles? - -(defmethod sync-ink (medium (new-value (eql clim:+background-ink+))) - (sync-ink medium (clim:medium-background medium))) ;### circles? - -(defmethod sync-ink (medium (new-value clim:opacity)) - (with-slots (cr) medium - (cond ((= 0 (opacity-value new-value)) - (cairo_set_source_rgba cr 0d0 0d0 0d0 0d0)) - ((= 1 (opacity-value new-value)) - (sync-ink medium (clim:medium-foreground medium))) - (t - (sync-ink medium (clim:compose-in (clim:medium-foreground medium) - new-value)))))) - -(defmethod sync-ink (medium (new-value climi::uniform-compositum)) - (with-slots (cr) medium - (with-slots ((ink climi::ink) (mask climi::mask)) new-value - (multiple-value-bind (red green blue) (clim:color-rgb ink) - (cairo_set_source_rgba cr - (df red) - (df green) - (df blue) - (df (clim:opacity-value mask))))))) - -(defmethod sync-ink (medium (new-value clim:color)) - (with-slots (cr) medium - (multiple-value-bind (red green blue) (clim:color-rgb new-value) - (cairo_set_source_rgba cr (df red) (df green) (df blue) (df 1.0d0))))) - -(defvar *pattern-hash* - (make-hash-table)) - -(defun pattern-cairo-pattern (medium pattern) - (or (gethash pattern *pattern-hash*) - (setf (gethash pattern *pattern-hash*) - (let ((s (make-cairo-surface medium - (pattern-width pattern) - (pattern-height pattern)))) - (draw-design s pattern) - (cairo_pattern_create_for_surface (slot-value s 'surface)))))) - -(defmethod sync-ink (medium (pattern climi::indexed-pattern)) - (with-slots (cr) medium - (let ((s (make-cairo-surface medium - (pattern-width pattern) - (pattern-height pattern)))) - (draw-design s pattern) - (let ((p (cairo_pattern_create_for_surface (slot-value s 'surface)))) - (cairo_set_source cr p) - p)))) - -(defmethod sync-ink (medium (pattern climi::indexed-pattern)) - (with-slots (cr) medium - (let ((p (pattern-cairo-pattern medium pattern))) - (cairo_set_source cr p) - p))) - -(defmethod sync-ink (medium (design clim-internals::transformed-design)) - (with-slots ((design climi::design) (transformation climi::transformation)) - design - ;; ### hmm - (let ((p (sync-ink medium design))) - (with-cairo-matrix (matrix (invert-transformation transformation)) - (cairo_pattern_set_matrix p matrix)) - p))) - -(defun apply-flipping-ink (medium) - (let ((from-surface (cairo_get_target (cr medium))) - (from-drawable (flipping-pixmap medium)) - (to-surface (cairo_get_target (flipping-original-cr medium))) - (to-drawable (medium-gdkdrawable medium))) - (cairo_surface_flush from-surface) - (cairo_surface_flush to-surface) - (let ((gc (gdk_gc_new to-drawable)) - (region (flipping-region medium))) - (gdk_gc_set_function gc :GDK_XOR) - (gdk_draw_drawable to-drawable gc from-drawable - (floor (bounding-rectangle-min-x region)) - (floor (bounding-rectangle-min-y region)) - (floor (bounding-rectangle-min-x region)) - (floor (bounding-rectangle-min-y region)) - (ceiling (bounding-rectangle-max-x region)) - (ceiling (bounding-rectangle-max-y region))) - (gdk_gc_unref gc)) - (cairo_surface_mark_dirty to-surface)) - (cairo_destroy (cr medium)) - (setf (cr medium) (flipping-original-cr medium)) - (setf (flipping-original-cr medium) nil)) - -(defmethod sync-ink (medium (design climi::standard-flipping-ink)) - (setf (flipping-original-cr medium) (cr medium)) - (let* ((mirror (medium-mirror medium)) - (drawable (mirror-drawable mirror))) - (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) - (width (floor (bounding-rectangle-max-x region))) - (height (floor (bounding-rectangle-max-y region))) - (pixmap - (or (flipping-pixmap medium) - (setf (flipping-pixmap medium) - (gdk_pixmap_new drawable width height -1))))) - (setf (cr medium) (gdk_cairo_create pixmap)) - (set-antialias (cr medium)) - (setf (flipping-region medium) region) - (cairo_paint (cr medium)) - (sync-transformation medium) - (sync-ink medium +white+)))) - -(defmethod sync-ink (medium new-value) - (warn "SYNC-INK lost ~S." new-value)) - -;;; clipping region - -(defun sync-clipping-region (medium region) - (with-slots (cr) medium - (cairo_reset_clip cr) - (unless (eq region +everywhere+) - (unless (eq region +nowhere+) - (loop for (x y w h) in (clipping-region->rect-seq region) do - (cairo_rectangle cr (df x) (df y) (df w) (df h)))) - (cairo_clip cr)) - (cairo_new_path cr))) - ;; copy&paste from medium.lisp|CLX: ;; this seems to work, but find out why all of these +nowhere+s are coming from ;; and kill them at the source... @@ -305,67 +88,6 @@ (- (round-coordinate (rectangle-max-x rectangle)) clip-x) (- (round-coordinate (rectangle-max-y rectangle)) clip-y))))

-;;; line-style - -(defun sync-line-style (medium line-style) - (with-slots (cr) medium - (cairo_set_line_cap cr - (case (line-style-cap-shape line-style) - (:butt :butt) - (:square :square) - (:round :round) - (:no-end-point :round))) ;### - (cond ((null (line-style-dashes line-style)) - (cairo_set_dash cr (cffi:null-pointer) 0 0d0)) ;hmm - ((eq t (line-style-dashes line-style)) - (let ((d 10)) - (cairo-set-dash* cr - (case (line-style-unit line-style) - ((:point :normal) - (map 'vector (lambda (x) - (untransform-size - (medium-transformation - medium) x)) - (list d))) - (:coordinate - (list d)))))) - (t - ;; line-style-unit! - (cairo-set-dash* cr - (case (line-style-unit line-style) - ((:point :normal) - (map 'vector (lambda (x) - (untransform-size - (medium-transformation medium) - x)) - (line-style-dashes line-style))) - (:coordinate - (line-style-dashes line-style)))))) - (cairo_set_line_join cr - (case (line-style-joint-shape line-style) - (:miter :miter) - (:bevel :bevel) - (:round :round) - (:none :round))) ;### - (cairo_set_line_width cr - (max 1.0d0 - (df - (case (line-style-unit line-style) - ((:point :normal) - (untransform-size - (medium-transformation medium) - (line-style-thickness line-style))) - (:coordinate - (line-style-thickness line-style)))))) )) - -(defun cairo-set-dash* (cr dashes) - (let ((ndash (length dashes))) - (cffi:with-foreign-object (adashes :double ndash) - (loop - for i below ndash do - (setf (cffi:mem-aref adashes :double i) (df (elt dashes i)))) - (cairo_set_dash cr adashes ndash 0d0)))) - (defun untransform-size (transformation size) (multiple-value-bind (dx dy) (untransform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2))))) @@ -374,242 +96,6 @@ (multiple-value-bind (dx dy) (transform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2)))))

-(defun sync-drawing-options (medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium))) - -;;;; ------------------------------------------------------------------------ -;;;; Drawing Operations -;;;; - -(defmethod medium-draw-point* ((medium cairo-medium) x y) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (cairo_set_line_cap cr :round) - (setf x (df x)) - (setf y (df y)) - (cairo_move_to cr x y) - (cairo_line_to cr (+ x 0.5) (+ y 0.5)) - (cairo_stroke cr)))) - -(defmethod medium-draw-points* ((medium cairo-medium) coord-seq) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (cairo_set_line_cap cr :round) - (loop for i below (length coord-seq) by 2 do - (let ((x (df (elt coord-seq (+ i 0)))) - (y (df (elt coord-seq (+ i 1))))) - (cairo_move_to cr x y) - (cairo_line_to cr (+ x 0.5) (+ y 0.5)) - (cairo_stroke cr)))))) - -(defmethod medium-draw-line* ((medium cairo-medium) x1 y1 x2 y2) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (cairo_move_to cr (df x1) (df y1)) - (cairo_line_to cr (df x2) (df y2)) - (cairo_stroke cr)))) - -(defmethod medium-draw-lines* ((medium cairo-medium) position-seq) - (with-medium (medium) - (sync-sheet medium) - (sync-transformation medium) - (sync-ink medium (medium-ink medium)) - (sync-clipping-region medium (medium-clipping-region medium)) - (sync-line-style medium (medium-line-style medium)) - (with-slots (cr) medium - (loop for i below (length position-seq) by 4 do - (cairo_move_to cr - (df (elt position-seq (+ i 0))) - (df (elt position-seq (+ i 1)))) - (cairo_line_to cr - (df (elt position-seq (+ i 2))) - (df (elt position-seq (+ i 3))))) - (cairo_stroke cr))))

[353 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/25 19:55:11 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/26 12:11:04 1.5 @@ -24,20 +24,6 @@ (in-package :clim-gtkairo)

-;;; these shouldn't be here: - -(defclass metrik-medium-mixin () ()) -(defclass cairo-metrik-medium (metrik-medium-mixin cairo-medium) ()) -(defclass gdk-metrik-medium (metrik-medium-mixin gdk-medium) ()) - -(defgeneric invoke-with-medium (fn medium)) - -(defmacro with-medium ((medium) &body body) - `(invoke-with-medium (lambda () ,@body) ,medium)) - -(defgeneric metrik-medium-for (medium)) - - ;;;; Helper macros.

(defmacro with-pango-layout

--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 12:11:04 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2006/12/26 12:11:04 1.1 ;;; -*- Mode: Lisp; -*-

;;; (c) copyright 2005 by Gilbert Baumann gilbert@base-engineering.com ;;; (c) copyright 2006 David Lichteblau (david@lichteblau.com)

;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(in-package :clim-gtkairo)

;;; Locking rule for this file: Dokumented entry points in the CLIM ;;; package use WITH-GTK, internal functions can rely on that.

(defclass cairo-medium (gtkairo-medium) ((cr :initform nil :initarg :cr :accessor cr) (flipping-original-cr :initform nil :accessor flipping-original-cr) (flipping-pixmap :initform nil :accessor flipping-pixmap) (flipping-region :accessor flipping-region) (surface :initarg :surface :accessor surface) (last-seen-sheet :accessor last-seen-sheet) (last-seen-region :accessor last-seen-region)))

(defmethod initialize-instance :after ((instance cairo-medium) &key cr) (unless cr (setf (last-seen-sheet instance) nil)))

(defparameter *antialiasingp* t)

(defmethod invoke-with-medium (fn (medium cairo-medium)) (when (or (cr medium) (climi::port-lookup-mirror (port medium) (medium-sheet medium))) (with-gtk () (multiple-value-prog1 (funcall fn) (when (flipping-original-cr medium) (apply-flipping-ink medium))))))

(defun sheet-changed-behind-our-back-p (medium) (and (slot-boundp medium 'last-seen-sheet) (or (not (eq (last-seen-sheet medium) (medium-sheet medium))) (not (region-equal (last-seen-region medium) (sheet-region (medium-sheet medium)))))))

(defmethod metrik-medium-for ((medium cairo-medium)) (cairo-metrik-medium (port medium)))

(defun set-antialias (cr) (cairo_set_antialias cr (if *antialiasingp* :CAIRO_ANTIALIAS_DEFAULT :CAIRO_ANTIALIAS_NONE)))

(defun sync-sheet (medium) (when (medium-sheet medium) ;ignore the metrik-medium (setf (gethash medium (dirty-mediums (port medium))) t)) (when (or (null (cr medium)) (sheet-changed-behind-our-back-p medium)) (with-medium (medium) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (setf (cr medium) (gdk_cairo_create drawable)) (dispose-flipping-pixmap medium) (pushnew medium (mirror-mediums mirror)) (set-antialias (cr medium))) (setf (last-seen-sheet medium) (medium-sheet medium)) (setf (last-seen-region medium) (sheet-region (medium-sheet medium))))))

(defun dispose-flipping-pixmap (medium) (when (flipping-pixmap medium) (gdk_drawable_unref (flipping-pixmap medium)) (setf (flipping-pixmap medium) nil)))

;;;; ------------------------------------------------------------------------ ;;;; Drawing Options ;;;;

(defun sync-transformation (medium &optional extra-transformation) (with-slots (cr) medium (cffi:with-foreign-object (matrix 'cairo_matrix_t) (let ((tr (if (medium-sheet medium) (sheet-native-transformation (medium-sheet medium)) clim:+identity-transformation+))) (when extra-transformation (setf tr (compose-transformations extra-transformation tr))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation tr) ;; Make sure not to hand transformations to cairo that it won't ;; like, since debugging gets ugly once a cairo context goes ;; into an error state: (invert-transformation tr) (cairo_matrix_init matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) (cairo_set_matrix cr matrix))))))

(defmacro with-cairo-matrix ((matrix transformation) &body body) `(cffi:with-foreign-object (,matrix 'cairo_matrix_t) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation ,transformation) (cairo_matrix_init ,matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) (locally ,@body))))

;;; ink

(defmethod sync-ink :before (medium new-value) (with-slots (cr) medium (cairo_set_operator cr :over)))

(defmethod sync-ink (medium (new-value (eql clim:+foreground-ink+))) (sync-ink medium (clim:medium-foreground medium))) ;### circles?

(defmethod sync-ink (medium (new-value (eql clim:+background-ink+))) (sync-ink medium (clim:medium-background medium))) ;### circles?

(defmethod sync-ink (medium (new-value clim:opacity)) (with-slots (cr) medium (cond ((= 0 (opacity-value new-value)) (cairo_set_source_rgba cr 0d0 0d0 0d0 0d0)) ((= 1 (opacity-value new-value)) (sync-ink medium (clim:medium-foreground medium))) (t (sync-ink medium (clim:compose-in (clim:medium-foreground medium) new-value))))))

(defmethod sync-ink (medium (new-value climi::uniform-compositum)) (with-slots (cr) medium (with-slots ((ink climi::ink) (mask climi::mask)) new-value (multiple-value-bind (red green blue) (clim:color-rgb ink) (cairo_set_source_rgba cr (df red) (df green) (df blue) (df (clim:opacity-value mask)))))))

(defmethod sync-ink (medium (new-value clim:color)) (with-slots (cr) medium (multiple-value-bind (red green blue) (clim:color-rgb new-value) (cairo_set_source_rgba cr (df red) (df green) (df blue) (df 1.0d0)))))

(defvar *pattern-hash* (make-hash-table))

(defun pattern-cairo-pattern (medium pattern) (or (gethash pattern *pattern-hash*) (setf (gethash pattern *pattern-hash*) (let ((s (make-cairo-surface medium (pattern-width pattern) (pattern-height pattern)))) (draw-design s pattern) (cairo_pattern_create_for_surface (slot-value s 'surface))))))

(defmethod sync-ink (medium (pattern climi::indexed-pattern)) (with-slots (cr) medium (let ((s (make-cairo-surface medium (pattern-width pattern) (pattern-height pattern)))) (draw-design s pattern) (let ((p (cairo_pattern_create_for_surface (slot-value s 'surface)))) (cairo_set_source cr p) p))))

(defmethod sync-ink (medium (pattern climi::indexed-pattern)) (with-slots (cr) medium (let ((p (pattern-cairo-pattern medium pattern))) (cairo_set_source cr p) p)))

(defmethod sync-ink (medium (design clim-internals::transformed-design)) (with-slots ((design climi::design) (transformation climi::transformation)) design ;; ### hmm (let ((p (sync-ink medium design))) (with-cairo-matrix (matrix (invert-transformation transformation)) (cairo_pattern_set_matrix p matrix)) p)))

(defun apply-flipping-ink (medium) (let ((from-surface (cairo_get_target (cr medium))) (from-drawable (flipping-pixmap medium)) (to-surface (cairo_get_target (flipping-original-cr medium))) (to-drawable (medium-gdkdrawable medium))) (cairo_surface_flush from-surface) (cairo_surface_flush to-surface) (let ((gc (gdk_gc_new to-drawable)) (region (flipping-region medium))) (gdk_gc_set_function gc :GDK_XOR) (gdk_draw_drawable to-drawable gc from-drawable (floor (bounding-rectangle-min-x region)) (floor (bounding-rectangle-min-y region)) (floor (bounding-rectangle-min-x region)) (floor (bounding-rectangle-min-y region)) (ceiling (bounding-rectangle-max-x region)) (ceiling (bounding-rectangle-max-y region))) (gdk_gc_unref gc)) (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) (setf (flipping-original-cr medium) nil))

(defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium)) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) (width (floor (bounding-rectangle-max-x region))) (height (floor (bounding-rectangle-max-y region))) (pixmap (or (flipping-pixmap medium) (setf (flipping-pixmap medium) (gdk_pixmap_new drawable width height -1))))) (setf (cr medium) (gdk_cairo_create pixmap)) (set-antialias (cr medium)) (setf (flipping-region medium) region) (cairo_paint (cr medium)) (sync-transformation medium) (sync-ink medium +white+))))

(defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value))

;;; clipping region

(defun sync-clipping-region (medium region) (with-slots (cr) medium (cairo_reset_clip cr) (unless (eq region +everywhere+) (unless (eq region +nowhere+) (loop for (x y w h) in (clipping-region->rect-seq region) do (cairo_rectangle cr (df x) (df y) (df w) (df h)))) (cairo_clip cr)) (cairo_new_path cr)))

;;; line-style

(defun sync-line-style (medium line-style) (with-slots (cr) medium (cairo_set_line_cap cr (case (line-style-cap-shape line-style) (:butt :butt) (:square :square) (:round :round) (:no-end-point :round))) ;### (cond ((null (line-style-dashes line-style)) (cairo_set_dash cr (cffi:null-pointer) 0 0d0)) ;hmm ((eq t (line-style-dashes line-style)) (let ((d 10)) (cairo-set-dash* cr (case (line-style-unit line-style) ((:point :normal) (map 'vector (lambda (x) (untransform-size (medium-transformation medium) x)) (list d))) (:coordinate (list d)))))) (t ;; line-style-unit! (cairo-set-dash* cr (case (line-style-unit line-style) ((:point :normal) (map 'vector (lambda (x) (untransform-size (medium-transformation medium) x)) (line-style-dashes line-style))) (:coordinate (line-style-dashes line-style)))))) (cairo_set_line_join cr (case (line-style-joint-shape line-style) (:miter :miter) (:bevel :bevel) (:round :round) (:none :round))) ;### (cairo_set_line_width cr (max 1.0d0 (df (case (line-style-unit line-style) ((:point :normal) (untransform-size (medium-transformation medium) (line-style-thickness line-style))) (:coordinate (line-style-thickness line-style)))))) ))

(defun cairo-set-dash* (cr dashes) (let ((ndash (length dashes))) (cffi:with-foreign-object (adashes :double ndash) (loop for i below ndash do (setf (cffi:mem-aref adashes :double i) (df (elt dashes i)))) (cairo_set_dash cr adashes ndash 0d0))))

(defun sync-drawing-options (medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)))

;;;; ------------------------------------------------------------------------ ;;;; Drawing Operations ;;;;

(defmethod medium-draw-point* ((medium cairo-medium) x y) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_set_line_cap cr :round) (setf x (df x)) (setf y (df y)) (cairo_move_to cr x y) (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr))))

(defmethod medium-draw-points* ((medium cairo-medium) coord-seq) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_set_line_cap cr :round) (loop for i below (length coord-seq) by 2 do (let ((x (df (elt coord-seq (+ i 0)))) (y (df (elt coord-seq (+ i 1))))) (cairo_move_to cr x y) (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr))))))

(defmethod medium-draw-line* ((medium cairo-medium) x1 y1 x2 y2) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (cairo_move_to cr (df x1) (df y1)) (cairo_line_to cr (df x2) (df y2)) (cairo_stroke cr))))

(defmethod medium-draw-lines* ((medium cairo-medium) position-seq) (with-medium (medium) (sync-sheet medium) (sync-transformation medium) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) (with-slots (cr) medium (loop for i below (length position-seq) by 4 do (cairo_move_to cr (df (elt position-seq (+ i 0)))

[328 lines skipped]