[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Tue Dec 26 12:11:04 UTC 2006
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 , at 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 () , at 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 , at 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 () , at 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 at base-engineering.com>
;;; (c) copyright 2006 David Lichteblau (david at 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 , at 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]
More information about the Mcclim-cvs
mailing list