;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-CAIRO; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CAIRO Medium for CLIM ;;; Created: 2005-03-05 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2005 by Gilbert Baumann ;;; 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. ;;;; TODO ;; - real general designs and optimization short cuts ;; - new drawing options: ;; - :transform-glyphs-p ;; - :alu ;; - proper way to conclude the Xlib display from the CLX display, ;; also include display and window in the cairo-medium object. ;; - integration with CLX backend ;; - MEDIUM-DRAW-ELLIPSE* ;; Need to find a good bezier approximation of circles. ;; - MEDIUM-BEEP ;; - MEDIUM-FINISH-OUTPUT, MEDIUM-FORCE-OUTPUT ;; - pixmaps and bliting ;; - flipping ink ;; - device text styles ;; - cairo uses premultipled alpha, while we don't. ;; - find a substitue for CAIRO-FONT-SET-TRANSFORM ;; - abolish this silly CLIM-INTERNALS::DO-GRAPHICS-WITH-OPTIONS ;; - INVOKE-WITH-DRAWING-OPTIONS ;; - why do pop up windows generate a BadDrawable error on the C side? ;; [what happens here?] ;; - we need to cross sync CLX and Xlib ;; - do less syncing, maybe even maintain a cache of cairo contexts. ;; - care for the proper text transformations. ;;;; NOTES ;; SYNCHRONIZATION NIGHTMARE -- We still use CLX for X11 graphics, while Cairo ;; is a C library using its own Xlib. The morale is that we have _two_ ;; connections to the X display. This involves synchronization issues. Say we ;; create a window by xlib:create-window and then subsequently ask cairo to ;; somehow operate on that window. This will fail with a BadDrawable error, ;; since out xlib:create-window request is still buffered and so the x server ;; does not yet know about our new shiny window. This is solved by extra ;; synchronization pretty much like what you are used to using OpenGL. So be ;; careful. ;; RESOURCES, WHO TO FREE IT? -- It seems that if you destroy a window, a Render ;; picture associated with said window is also destroyed. ;; CAIRO-SET-TARGET-DRAWABLE and perhaps CAIRO-DESTROY do want to destroy that ;; picture on their own. So when we destroy a window we need to know all cairo ;; contexts floating around which associate to the window at hand and target ;; them at the root window (or better the spare window, more below) before we ;; destroy a window. And we need to do this recursively. And we need the extra ;; book keeping. ;; UNGRAFTED MEDIA -- It happens that an application wants to use a medium ;; before its sheet is grafted. In those situations we'd need a spare window to ;; target the associated cairo medium at. We could use the root window, but bad ;; things happen if the user actually does some drawing instead of merely ;; querying stuff like text extents. So I want to allocate a specific unmapped ;; spare window for those occasions. ;; FLIPPING INKS -- Cairo can't and for ideological reasons perhaps never will ;; support flipping inks. I myself hate flipping inks even more so than ;; bit-blittering, but there are still a few ancient applications around, which ;; use it. So we'd need to think about some way to support it. One idea is to ;; render the shape to an A1 temporary pixmap surface and use good old X11 to ;; make that pixmap flip pixels around. This breaks some abtractions established ;; by Cairo and will perhaps stop working around 2012. The fun thing is: ;; Flipping will now turn into a rather slow operation. (in-package :CLIM-CAIRO) ;;;; ------------------------------------------------------------------------------------------ ;;;; CAIRO-MEDIUM ;;;; (defvar *window*) (defvar *display* nil) (defvar *cr*) (defvar *m*) ;;; CLIM-INTERNALS::DO-GRAPHICS-WITH-OPTIONS (defun make-test-medium () (unless *display* (setf *display* (x-open-display nil))) (x-synchronize *display* 1) (setf *window* (x-create-simple-window *display* (x-default-root-window *display*) 0 0 600 600 1 0 #xFFFFFF)) (x-map-window *display* *window*) (x-flush *display*) (setf *cr* (cairo-create)) (cairo-set-target-drawable *cr* *display* *window*) (setf *m* (make-instance 'cairo-medium :cr *cr*))) ;;;; ------------------------------------------------------------------------------------------ ;;;; Cairo Medium ;;;; (defclass cairo-medium (climi::basic-medium clim:medium) ((cr :initarg :cr) (surface :initarg :surface) (my-sheet :initarg :my-sheet :initform :none) (sheet-synced-p :initform nil) )) ;;;; ------------------------------------------------------------------------------------------ ;;;; Drawing Options ;;;; (defun sync-transformation (medium transformation) (with-slots (cr) medium (cairo-default-matrix cr) (let ((matrix (cairo-matrix-create))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation transformation) (cairo-matrix-set-affine matrix (coerce mxx 'double-float) (coerce mxy 'double-float) (coerce myx 'double-float) (coerce myy 'double-float) (coerce tx 'double-float) (coerce ty 'double-float)) (cairo-concat-matrix cr matrix) (cairo-matrix-destroy matrix))))) (defmacro with-cairo-matrix ((matrix transformation) &body body) `(let ((,matrix (cairo-matrix-create))) (unwind-protect (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation ,transformation) (cairo-matrix-set-affine ,matrix (coerce mxx 'double-float) (coerce mxy 'double-float) (coerce myx 'double-float) (coerce myy 'double-float) (coerce tx 'double-float) (coerce ty 'double-float)) (locally ,@body)) (cairo-matrix-destroy ,matrix)))) ;;; 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-rgb-color cr 0d0 0d0 0d0) (cairo-set-alpha cr 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-rgb-color cr (coerce red 'double-float) (coerce green 'double-float) (coerce blue 'double-float)) (cairo-set-alpha cr (coerce (clim:opacity-value mask) 'double-float) ))))) (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-rgb-color cr (coerce red 'double-float) (coerce green 'double-float) (coerce blue 'double-float)) (cairo-set-alpha cr (coerce 1.0d0 'double-float)) ))) (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-pattern cr p) p)))) (defmethod sync-ink (medium (pattern climi::indexed-pattern)) (with-slots (cr) medium (let ((p (pattern-cairo-pattern medium pattern))) (cairo-set-pattern 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))) (defmethod sync-ink (medium (design climi::standard-flipping-ink)) (with-slots ((d1 climi::design1) (d2 climi::design2)) design (with-slots (cr) medium (cairo-set-rgb-color cr 1.0d0 1.0d0 1.0d0) (cairo-set-alpha cr 1d0) (cairo-set-operator cr :xor)))) ;Naturally this doesn't work, what you'd thought?. (defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) ;;; clipping region (defun sync-clipping-region (medium region) '(print region *trace-output*) '(finish-output *trace-output*) (with-slots (cr) medium (cairo-init-clip cr) (when (rectanglep region) (with-bounding-rectangle* (x1 y1 x2 y2) region (cairo-rectangle cr (coerce x1 'double-float) (coerce y1 'double-float) (coerce (- x2 x1) 'double-float) (coerce (- y2 y1) 'double-float)) (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 nil 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 (coerce (case (line-style-unit line-style) ((:point :normal) (untransform-size (medium-transformation medium) (line-style-thickness line-style))) (:coordinate (line-style-thickness line-style))) 'double-float))) )) (defun cairo-set-dash* (cr dashes) (let ((ndash (length dashes))) (let ((adashes (alien:make-alien double-float ndash))) (loop for i below ndash do (setf (alien:deref adashes i) (coerce (elt dashes i) 'double-float))) (cairo-set-dash cr adashes ndash 0d0) (alien:free-alien adashes)))) (defun untransform-size (transformation size) (multiple-value-bind (dx dy) (untransform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2))))) (defun transform-size (transformation size) (multiple-value-bind (dx dy) (transform-distance transformation size 0) (sqrt (+ (expt dx 2) (expt dy 2))))) ;;; text-style (defun sync-text-style (medium text-style transform-glyphs-p) (with-slots (cr) medium (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) (setf size (coerce (case size (:normal 12) (:tiny 6) (:small 10) (:very-small 8) (:large 14) (:very-large 16) (:huge 24) (otherwise size)) 'double-float)) ;; (cairo-select-font cr (ecase family ((:fix :fixed) "mono") (:serif "serif") (:sans-serif "sansserif")) (ecase face ((:roman :bold) :normal) ((:italic :bold-italic :italic-bold) :italic) ((:oblique :bold-oblique :oblique-bold) :oblique)) (ecase face ((:roman :italic :oblique) :normal) ((:bold :bold-italic :italic-bold :bold-oblique :oblique-bold) :bold))) ;; (cond (transform-glyphs-p (cairo-scale-font cr size)) (t (cairo-scale-font cr size) ;### (let ((matrix (cairo-matrix-create))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation (medium-transformation medium)) (cairo-matrix-set-affine matrix (coerce mxx 'double-float) (coerce mxy 'double-float) (coerce myx 'double-float) (coerce myy 'double-float) (coerce tx 'double-float) (coerce ty 'double-float)) (cairo-matrix-invert matrix) ;;(cairo-transform-font cr matrix) (cairo-matrix-destroy matrix) ))))))) ;;;; (defun sync-drawing-options (medium) (sync-transformation medium (medium-transformation medium)) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-line-style medium (medium-line-style medium)) ;;(sync-text-style medium (medium-text-style medium)) ) ;;;; ------------------------------------------------------------------------------------------ ;;;; Drawing Operations ;;;; ;; Okay, patch xlib:destroy-window. (defvar *id-medium-hash* (make-hash-table)) (defvar *orig-xlib-destroy-window* #'xlib:destroy-window) (defun xlib:destroy-window (window) (let ((medium (gethash (xlib:window-id window) *id-medium-hash*))) (when medium (warn "A medium still on a window about to be destroyed.") (sync-sheet medium))) (when *display* (x-sync *display* 0)) ;; If we opt out of destroying the window, cairo is kept happy. '(funcall *orig-xlib-destroy-window* window) (xlib:unmap-window window) ) (defun valid-drawable-id-p (display id) (let ((drawable (xlib::lookup-window display id))) (ignore-errors (xlib:drawable-depth drawable)))) (defun sync-sheet (medium) (with-slots (sheet-synced-p) medium (unless sheet-synced-p (let ((p (port medium))) (when p (xlib:display-finish-output (slot-value p 'clim-clx::display)))) (with-slots (cr my-sheet) medium (cond ((eql my-sheet :none)) ;this only happens on "pixmaps". ((null (sheet-direct-mirror my-sheet)) (warn "No mirror.") (cairo-set-target-drawable cr *display* (x-default-root-window *display*)) (cairo-set-target-drawable cr *display* (x-default-root-window *display*))) (t (let ((id (xlib:window-id (sheet-direct-mirror my-sheet))) (dpy (slot-value (port medium) 'clim-clx::display))) (unless (valid-drawable-id-p dpy id) (error "oops")) (setf (gethash id *id-medium-hash*) medium) (cairo-set-target-drawable cr *display* id)))))))) (defmethod medium-draw-point* ((medium cairo-medium) x y) (sync-sheet medium) (sync-transformation medium (medium-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 (coerce x 'double-float)) (setf y (coerce y 'double-float)) (cairo-move-to cr x y) (cairo-line-to cr (+ x (/ x (expt 2 16))) y) (cairo-stroke cr))) (defmethod medium-draw-points* ((medium cairo-medium) coord-seq) (sync-sheet medium) (sync-transformation medium (medium-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 (coerce (elt coord-seq (+ i 0)) 'double-float)) (y (coerce (elt coord-seq (+ i 1)) 'double-float))) (cairo-move-to cr x y) (cairo-line-to cr (+ x (/ x (expt 2 16))) y) (cairo-stroke cr))))) (defmethod medium-draw-line* ((medium cairo-medium) x1 y1 x2 y2) (sync-sheet medium) (sync-transformation medium (medium-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 (coerce x1 'double-float) (coerce y1 'double-float)) (cairo-line-to cr (coerce x2 'double-float) (coerce y2 'double-float)) (cairo-stroke cr))) (defmethod medium-draw-lines* ((medium cairo-medium) position-seq) (sync-sheet medium) (sync-transformation medium (medium-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 (coerce (elt position-seq (+ i 0)) 'double-float) (coerce (elt position-seq (+ i 1)) 'double-float)) (cairo-line-to cr (coerce (elt position-seq (+ i 2)) 'double-float) (coerce (elt position-seq (+ i 3)) 'double-float))) (cairo-stroke cr))) (defmethod medium-draw-polygon* ((medium cairo-medium) coord-seq closed filled) (sync-sheet medium) (sync-transformation medium (medium-transformation medium)) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (unless filled (sync-line-style medium (medium-line-style medium))) (with-slots (cr) medium (cairo-move-to cr (coerce (elt coord-seq 0) 'double-float) (coerce (elt coord-seq 1) 'double-float)) (loop for i from 2 below (length coord-seq) by 2 do (cairo-line-to cr (coerce (elt coord-seq i) 'double-float) (coerce (elt coord-seq (+ i 1)) 'double-float))) (when closed (cairo-line-to cr (coerce (elt coord-seq 0) 'double-float) (coerce (elt coord-seq 1) 'double-float))) (if filled (cairo-fill cr) (cairo-stroke cr)))) (defmethod medium-draw-rectangle* ((medium cairo-medium) x1 y1 x2 y2 filled) (sync-sheet medium) (sync-transformation medium (medium-transformation medium)) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (unless filled (sync-line-style medium (medium-line-style medium))) (with-slots (cr) medium (setf x1 (coerce x1 'double-float)) (setf y1 (coerce y1 'double-float)) (setf x2 (coerce x2 'double-float)) (setf y2 (coerce y2 'double-float)) (when (< x2 x1) (rotatef x1 x2)) (when (< y2 y1) (rotatef y1 y2)) (cairo-rectangle cr x1 y1 (- x2 x1) (- y2 y1)) (if filled (cairo-fill cr) (cairo-stroke cr)))) (defmethod medium-draw-rectangles* ((medium cairo-medium) position-seq filled) (sync-sheet medium) (sync-transformation medium (medium-transformation medium)) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (unless filled (sync-line-style medium (medium-line-style medium))) (with-slots (cr) medium (loop for i below (length position-seq) by 4 do (let ((x1 (coerce (elt position-seq (+ i 0)) 'double-float)) (y1 (coerce (elt position-seq (+ i 1)) 'double-float)) (x2 (coerce (elt position-seq (+ i 2)) 'double-float)) (y2 (coerce (elt position-seq (+ i 3)) 'double-float))) (when (< x2 x1) (rotatef x1 x2)) (when (< y2 y1) (rotatef y1 y2)) (cairo-rectangle cr x1 y1 (- x2 x1) (- y2 y1)) (if filled (cairo-fill cr) (cairo-stroke cr)))))) (defmethod medium-draw-ellipse* ((medium cairo-medium) cx cy rx1 ry1 rx2 ry2 start end filled) ;; This one is tricky. Cairo doesn't know ellipses, it only knows circles. But ;; then it is fully capable to draw circles under affine transformations only ;; that the line style is transformed too. So what we do: We setup an ;; [additional] transformation to from our ellipse to a circle and setup line ;; style properly transformed. --- This is not entirely correct in case of ;; shearing or odd scaling transformations. ;; ;; Also: What is done to patterns? ;; ;; Anyhow, let's hack along. ;; ;; Quick test if this is a circle: (cond ((= (+ (expt rx1 2) (expt ry1 2)) (+ (expt rx2 2) (expt ry2 2))) (let ((radius (sqrt (+ (expt rx1 2) (expt ry1 2))))) (sync-sheet medium) (sync-transformation medium (medium-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-new-path cr) (cairo-arc cr (coerce cx 'double-float) (coerce cy 'double-float) (coerce radius 'double-float) (coerce start 'double-float) (coerce end 'double-float)) ;; Incredible cool: Cairo doesn't respect line dashes while drawing ;; arcs. Quite useful feature actually. (if filled (cairo-fill cr) (cairo-stroke cr))))) ;; general case (t (let ((tr (make-3-point-transformation* 0 0 1 0 0 1 cx cy (+ cx rx1) (+ cy ry1) (+ cx rx2) (+ cy ry2)))) (sync-sheet medium) ;; hmm, something is wrong here. (sync-transformation medium (compose-transformations tr (medium-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-new-path cr) (cairo-arc cr 0d0 0d0 1d0 (coerce start 'double-float) (coerce end 'double-float)) (cairo-fill cr) (cairo-set-rgb-color cr 0.0d0 0.0d0 1.0d0) (loop for a from 0 below (* 2 pi) by .1 do (cairo-new-path cr) (cairo-rectangle cr (coerce (sin a) 'double-float) (coerce (cos a) 'double-float) .05d0 .05d0) (cairo-fill cr))) )) )) (defmethod medium-draw-text* ((medium cairo-medium) text x y start end align-x align-y toward-x toward-y transform-glyphs) (sync-sheet medium) (with-slots (cr) medium (sync-transformation medium (medium-transformation medium)) (sync-ink medium (medium-ink medium)) (sync-clipping-region medium (medium-clipping-region medium)) (sync-text-style medium (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)) transform-glyphs) (cairo-move-to cr (coerce x 'double-float) (coerce y 'double-float)) (cairo-show-text cr (subseq text start end)) )) (defmethod medium-finish-output ((medium cairo-medium)) (x-flush *display*)) ;### (defmethod medium-force-output ((medium cairo-medium)) (x-flush *display*)) ;### (defmethod medium-beep ((medium cairo-medium)) ) ;;;; ------------------------------------------------------------------------------------------ ;;;; Text Styles ;;;; (defmethod text-style-ascent (text-style (medium cairo-medium)) (with-slots (cr) medium (sync-sheet medium) (cairo-default-matrix cr) (sync-text-style medium text-style t) (alien:with-alien ((res (struct cairo-font-extents))) (cairo-current-font-extents cr (alien:addr res)) (alien:slot res 'ascent)))) (defmethod text-style-descent (text-style (medium cairo-medium)) (with-slots (cr) medium (sync-sheet medium) (cairo-default-matrix cr) (sync-text-style medium text-style t) (alien:with-alien ((res (struct cairo-font-extents))) (cairo-current-font-extents cr (alien:addr res)) (- (alien:slot res 'descent))))) (defmethod text-style-height (text-style (medium cairo-medium)) (with-slots (cr) medium (sync-sheet medium) (cairo-default-matrix cr) (sync-text-style medium text-style t) (alien:with-alien ((res (struct cairo-font-extents))) (cairo-current-font-extents cr (alien:addr res)) (alien:slot res 'height)))) ;### let's hope that cairo respects height = ascent + descent. (defmethod text-style-width (text-style (medium cairo-medium)) (with-slots (cr) medium (sync-sheet medium) (cairo-default-matrix cr) (sync-text-style medium text-style t) (alien:with-alien ((res (struct cairo-text-extents))) (cairo-text-extents cr "m" (alien:addr res)) (alien:slot res 'width)))) (defmethod text-style-fixed-width-p (text-style (medium cairo-medium)) (with-slots (cr) medium (sync-sheet medium) (cairo-default-matrix cr) (sync-text-style medium text-style t) (alien:with-alien ((res (struct cairo-text-extents))) (let (i m) (cairo-text-extents cr "i" (alien:addr res)) (setf i (alien:slot res 'width)) (cairo-text-extents cr "m" (alien:addr res)) (setf m (alien:slot res 'width)) (= i m))))) (defun nyi () (error "nyi")) (def-alien-type cairo-text-extents (* (struct cairo-text-extents (x-bearing double-float) (y-bearing double-float) (width double-float) (height double-float) (x-advance double-float) (y-advance double-float)))) (defmethod text-size ((medium cairo-medium) string &key text-style (start 0) end) ;; -> width height final-x final-y baseline (sync-sheet medium) (when (characterp string) (setf string (string string))) (setf text-style (or text-style (make-text-style nil nil nil))) (setf text-style (merge-text-styles text-style (medium-default-text-style medium))) (with-slots (cr) medium (cairo-default-matrix cr) (sync-text-style medium text-style t) (alien:with-alien ((res (struct cairo-text-extents))) (let (i m) (cairo-text-extents cr (subseq string start (or end (length string))) (alien:addr res)) (values (alien:slot res 'width) (alien:slot res 'height) (alien:slot res 'x-advance) (alien:slot res 'y-advance) ;; baseline? (text-style-ascent text-style medium)))))) ;;;; ------------------------------------------------------------------------------------------ ;;;; Pixmaps ;;;; (defmethod allocate-pixmap ((medium cairo-medium) width height) (nyi)) '(defmethod deallocate-pixmap ((pixmap cairo-pixmap)) (nyi)) '(defmethod pixmap-width ((pixmap cairo-pixmap)) (nyi)) '(defmethod pixmap-height ((pixmap cairo-pixmap)) (nyi)) '(defmethod pixmap-depth ((pixmap cairo-pixmap)) (nyi)) (defmethod medium-copy-area ((from-drawable cairo-medium) from-x from-y width height (to-drawable cairo-medium) to-x to-y) '(nyi)) ;;;; ------------------------------------------------------------------------------------------ ;;;; General Designs ;;;; (defun make-cairo-surface (compatible-medium width height &optional (format :argb32)) (let* ((s (cairo-surface-create-similar (cairo-current-target-surface (slot-value compatible-medium 'cr)) format width height)) (c (cairo-create))) (cairo-set-target-surface c s) (make-instance 'cairo-medium :cr c :surface s))) (defun destroy-cairo-surface (medium) (cairo-destroy (slot-value medium 'cr)) (cairo-surface-destroy (slot-value medium 'surface))) (defmacro with-pattern ((m1 mp) &body body) (let ((p (gensym "P."))) `(let ((,p (cairo-pattern-create-for-surface (slot-value ,mp 'surface)))) (unwind-protect (progn (cairo-set-pattern (slot-value ,m1 'cr) ,p) (locally ,@body) (cairo-pattern-destroy ,p)))))) ;;;; draw design (defmethod draw-design ((medium cairo-medium) (pattern clim-internals::indexed-pattern) &key &allow-other-keys) (with-slots ((designs climi::designs) (array climi::array)) pattern (loop for y below (array-dimension array 0) do (loop for x below (array-dimension array 1) do (draw-rectangle* medium x y (+ x 1) (+ y 1) :ink (elt designs (aref array y x))))))) (defmethod draw-design ((medium cairo-medium) (pattern clim-internals::stencil) &key &allow-other-keys) (with-slots ((array climi::array)) pattern (loop for y below (array-dimension array 0) do (loop for x below (array-dimension array 1) do (draw-rectangle* medium x y (+ x 1) (+ y 1) :ink (make-opacity (aref array y x))))))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::transformed-design) &key &allow-other-keys) (with-slots ((design climi::design) (transformation climi::transformation)) design (with-drawing-options (medium :transformation transformation) (draw-design medium design)))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::rectangular-tile) &key &allow-other-keys) (with-slots ((design climi::design) (width climi::width) (height climi::height)) design ;; ### (loop for x below 600 by width do (loop for y below 600 by height do ;; ### (draw-design medium (transform-region (make-translation-transformation x y) design)))))) (defmethod draw-design ((medium cairo-medium) (design clim:opacity) &key &allow-other-keys) (draw-design medium (compose-in (clim:medium-foreground medium) design))) (defmethod draw-design ((medium cairo-medium) (design climi::uniform-compositum) &key &allow-other-keys) (draw-rectangle* medium 0 0 600 600 :ink design)) (defmethod draw-design ((medium cairo-medium) (design clim:color) &key &allow-other-keys) (draw-rectangle* medium 0 0 600 600 :ink design)) (defmethod draw-design ((medium cairo-medium) (design clim-internals::in-compositum) &key &allow-other-keys) (with-slots ((ink climi::ink) (mask climi::mask)) design (let ((mink (make-cairo-surface medium 600 600)) (mmask (make-cairo-surface medium 600 600 :a8))) (draw-design mink ink) (draw-design mmask mask) (with-pattern (mink mmask) (cairo-set-operator (slot-value mink 'cr) :in-reverse) (cairo-rectangle (slot-value mink 'cr) 0d0 0d0 600d0 600d0) (cairo-fill (slot-value mink 'cr))) (with-pattern (medium mink) (sync-transformation medium (medium-transformation medium)) ;### (cairo-rectangle (slot-value medium 'cr) 0d0 0d0 600d0 600d0) (cairo-fill (slot-value medium 'cr))) ;; (destroy-cairo-surface mink) (destroy-cairo-surface mmask) ))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::out-compositum) &key &allow-other-keys) (with-slots ((ink climi::ink) (mask climi::mask)) design (let ((mink (make-cairo-surface medium 600 600)) (mmask (make-cairo-surface medium 600 600 :a8))) (draw-design mink ink) (draw-design mmask mask) (with-pattern (mink mmask) (cairo-set-operator (slot-value mink 'cr) :out-reverse) (cairo-rectangle (slot-value mink 'cr) 0d0 0d0 600d0 600d0) (cairo-fill (slot-value mink 'cr))) (with-pattern (medium mink) (sync-transformation medium (medium-transformation medium)) ;### (cairo-rectangle (slot-value medium 'cr) 0d0 0d0 600d0 600d0) (cairo-fill (slot-value medium 'cr))) ;; (destroy-cairo-surface mink) (destroy-cairo-surface mmask) ))) (defmethod draw-design ((medium cairo-medium) (design clim-internals::over-compositum) &key &allow-other-keys) (with-slots ((foreground climi::foreground) (background climi::background)) design (draw-design medium background) (draw-design medium foreground))) ;;;; ------------------------------------------------------------------------------------------ ;;;; Hmm ;;;; (defmethod medium-current-text-style ((medium cairo-medium)) (merge-text-styles (medium-text-style medium) (medium-default-text-style medium))) (defmethod medium-merged-text-style ((medium cairo-medium)) (merge-text-styles (medium-text-style medium) (medium-default-text-style medium))) ;;;; ------------------------------------------------------------------------------------------ ;;; Note: text-style stuff needs an reimplementation too. (defun make-cairo-medium-for-sheet (window) (unless *display* (setf *display* (x-open-display nil))) (let ((cr (cairo-create))) (make-instance 'cairo-medium :cr cr :my-sheet window))) ;;;;;; (defmethod make-medium ((port CLIM-CLX::CLX-PORT) sheet) (make-cairo-medium-for-sheet sheet))