Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13045

Modified Files: bezier.lisp Log Message: Bezier designs which draw in the right place in all backends (I think).

The implementation prior to this worked for the replay on an output-recording stream, and probably worked for the first draw using the pixmap (fall-through) rendering method. It did not work for the first draw on a backend with native bezier drawing routines, basically because the design was being passed through untransformed by the medium transformation. So:

* define a method on medium-draw-bezier-design* specialized on transform-coordinates-mixin, to transform the region appropriately before passing down to backend-drawing functions. This method runs after the output-recording-stream method, so sadly we're now doing some transformations twice.

* this implies deleting the translated-bezier-design class, as returning an object of a different class from transform-region meant that the idiom of doing (defmethod medium-draw-foo* :around ((medium t-c-mixin) foo) (let ((foo (transform-region (medium-transformation medium) foo))) (call-next-method medium foo))) would be in violation of the restriction that the set of applicable methods not change when using call next method.

* deleting the translated-bezier-design class would mean losing the cacheing of pixmap renderings, so restore that by keeping track of the original design in all bezier-design subclasses, and use that in ensure-pixmap.

* this on its own is still too slow, so for bezier-areas and bezier-unions additionally keep track of accumulated translation transformations, only performing the transformation of individual segments or areas when they are necessary. (A similar approach could be used for differences, but I ran out of energy; we have however recovered most of the speed loss from the introduction of this extra correctness.)

* the Postscript and gtkairo backends, with their medium-draw-bezier* methods, needed some adjustment to perform the transformations themselves.

Please test!

--- /project/mcclim/cvsroot/mcclim/bezier.lisp 2006/12/26 16:44:45 1.1 +++ /project/mcclim/cvsroot/mcclim/bezier.lisp 2007/07/11 15:26:20 1.2 @@ -56,7 +56,8 @@ (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v))))

-(defclass bezier-design (design) ()) +(defclass bezier-design (design) + ((%or :accessor original-region :initform nil)))

(defgeneric medium-draw-bezier-design* (stream design))

@@ -80,6 +81,12 @@ (when (stream-drawing-p stream) (medium-draw-bezier-design* medium design)))))

+(defmethod medium-draw-bezier-design* :around + ((medium transform-coordinates-mixin) design) + (let* ((tr (medium-transformation medium)) + (design (transform-region tr design))) + (call-next-method medium design))) + (defmethod replay-output-record ((record bezier-design-output-record) stream &optional (region +everywhere+) (x-offset 0) (y-offset 0)) (declare (ignore x-offset y-offset region)) @@ -108,12 +115,12 @@ (values min-x min-y max-x max-y)))

(defclass segments-mixin (bounding-rectangle-mixin) - ((%segments :initarg :segments :initform '() :reader segments))) + ((%segments :initarg :segments :initform '() :reader %segments)))

-(defun compute-bounding-rectangle* (segments-mixin) +(defmethod compute-bounding-rectangle* ((segments-mixin segments-mixin)) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) - (segment-bounding-rectangle (car (segments segments-mixin))) - (loop for segment in (cdr (segments segments-mixin)) + (segment-bounding-rectangle (car (%segments segments-mixin))) + (loop for segment in (cdr (%segments segments-mixin)) do (multiple-value-bind (min-x min-y max-x max-y) (segment-bounding-rectangle segment) (setf final-min-x (min final-min-x min-x) @@ -171,7 +178,7 @@ (make-instance 'bezier-curve :segments (mapcar (lambda (segment) (transform-segment transformation segment)) - (segments path)))) + (%segments path))))

(defmethod region-equal ((p1 point) (p2 point)) (let ((coordinate-epsilon (* #.(expt 2 10) double-float-epsilon))) @@ -179,49 +186,33 @@ (<= (abs (- (point-y p1) (point-y p2))) coordinate-epsilon))))

(defmethod region-union ((r1 bezier-curve) (r2 bezier-curve)) - (let ((p (slot-value (car (last (segments r1))) 'p3)) - (seg (car (segments r2)))) + (let ((p (slot-value (car (last (%segments r1))) 'p3)) + (seg (car (%segments r2)))) (if (region-equal p (slot-value seg 'p0)) (with-slots (p1 p2 p3) seg (make-instance 'bezier-curve - :segments (append (segments r1) + :segments (append (%segments r1) (cons (make-bezier-segment p p1 p2 p3) - (cdr (segments r2)))))) + (cdr (%segments r2)))))) (call-next-method))))

-;;; A region that translates a different region -(defclass translated-bezier-design (region bezier-design) - ((%translation :initarg :translation :reader translation) - (%region :initarg :region :reader original-region))) - -(defmethod bounding-rectangle* ((region translated-bezier-design)) - (let ((translation (translation region))) - (multiple-value-bind (min-x min-y max-x max-y) - (bounding-rectangle* (original-region region)) - (multiple-value-bind (final-min-x final-min-y) - (transform-position translation min-x min-y) - (multiple-value-bind (final-max-x final-max-y) - (transform-position translation max-x max-y) - (values final-min-x final-min-y final-max-x final-max-y)))))) - -(defgeneric really-transform-region (transformation region)) - ;;; an area defined as a closed path of Bezier curve segments -(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) ()) +(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) + ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+)))

(defgeneric close-path (path))

(defmethod close-path ((path bezier-curve)) - (let ((segments (segments path))) + (let ((segments (%segments path))) (assert (region-equal (slot-value (car segments) 'p0) (slot-value (car (last segments)) 'p3))) (make-instance 'bezier-area :segments segments)))

(defun path-start (path) - (slot-value (car (segments path)) 'p0)) + (slot-value (car (%segments path)) 'p0))

(defun path-end (path) - (slot-value (car (last (segments path))) 'p3)) + (slot-value (car (last (%segments path))) 'p3))

(defun make-bezier-area (point-seq) (assert (region-equal (car point-seq) (car (last point-seq)))) @@ -232,18 +223,26 @@ (coordinate= (cadr coord-seq) (car (last coord-seq))))) (make-bezier-thing* 'bezier-area coord-seq))

-(defmethod really-transform-region (transformation (area bezier-area)) - (make-instance 'bezier-area - :segments (mapcar (lambda (segment) - (transform-segment transformation segment)) - (segments area)))) +(defmethod segments ((area bezier-area)) + (let ((tr (transformation area))) + (mapcar (lambda (s) (transform-segment tr s)) (%segments area))))

(defmethod transform-region (transformation (area bezier-area)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) + (let* ((tr (transformation area)) + (result (if (translation-transformation-p transformation) + (make-instance 'bezier-area :segments (%segments area) + :transformation + (compose-transformations transformation tr)) + (make-instance 'bezier-area + :segments (mapcar (lambda (s) (transform-segment transformation s)) (segments area)))))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region area) area))) + result)) + +(defmethod compute-bounding-rectangle* ((area bezier-area)) + (multiple-value-bind (lx ly ux uy) (call-next-method) + (let ((tr (transformation area))) + (transform-rectangle* tr lx ly ux uy))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -251,20 +250,20 @@

;;; A union of bezier areas. This is not itself a bezier area. (defclass bezier-union (area bezier-design) - ((%areas :initarg :areas :initform '() :reader areas))) - -(defmethod really-transform-region (transformation (area bezier-union)) - (let ((areas (loop for area in (areas area) - collect (transform-region transformation area)))) - (make-instance 'bezier-union - :areas areas))) + ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+) + (%areas :initarg :areas :initform '() :reader areas)))

-(defmethod transform-region (transformation (area bezier-union)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) +(defmethod transform-region (transformation (union bezier-union)) + (let* ((tr (transformation union)) + (new-tr (compose-transformations transformation tr)) + (result (if (translation-transformation-p transformation) + (make-instance 'bezier-union :areas (areas union) + :transformation new-tr) + (make-instance 'bezier-union + :areas (loop for area in (areas union) collect (transform-region new-tr area)))))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region union) union))) + result))

(defun bounding-rectangle-of-areas (areas) (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y) @@ -279,43 +278,57 @@ (values final-min-x final-min-y final-max-x final-max-y)))

(defmethod bounding-rectangle* ((design bezier-union)) - (bounding-rectangle-of-areas (areas design))) + (multiple-value-bind (lx ly ux uy) + (bounding-rectangle-of-areas (areas design)) + (transform-rectangle* (transformation design) lx ly ux uy)))

(defmethod region-union ((r1 bezier-area) (r2 bezier-area)) - (make-instance 'bezier-union - :areas (list r1 r2))) + (make-instance 'bezier-union :areas (list r1 r2)))

(defmethod region-union ((r1 bezier-union) (r2 bezier-area)) - (make-instance 'bezier-union - :areas (cons r2 (areas r1)))) + (let ((tr (transformation r1))) + (make-instance 'bezier-union + :areas (cons (untransform-region tr r2) (areas r1)) + :transformation tr)))

(defmethod region-union ((r1 bezier-area) (r2 bezier-union)) - (make-instance 'bezier-union - :areas (cons r1 (areas r2)))) + (let ((tr (transformation r2))) + (make-instance 'bezier-union + :areas (cons (untransform-region tr r1) (areas r2)) + :transformation tr)))

(defmethod region-union ((r1 bezier-union) (r2 bezier-union)) - (make-instance 'bezier-union - :areas (append (areas r1) (areas r2)))) + (let ((tr1 (transformation r1)) + (tr2 (transformation r2))) + (if (transformation-equal tr1 tr2) + (make-instance 'bezier-union + :areas (append (areas r1) (areas r2)) + :transformation tr1) + (let ((len1 (length (areas r1))) + (len2 (length (areas r2)))) + (if (> len2 len1) + (make-instance 'bezier-union + :areas (append (mapcar (lambda (r) (untransform-region tr2 (transform-region tr1 r))) (areas r1)) (areas r2)) + :transformation tr2) + (make-instance 'bezier-union + :areas (append (mapcar (lambda (r) (untransform-region tr1 (transform-region tr2 r))) (areas r2)) (areas r1)) + :transformation tr1))))))

(defclass bezier-difference (area bezier-design) ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas) (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas)))

-(defmethod really-transform-region (transformation (area bezier-difference)) - (let ((pareas (loop for area in (positive-areas area) - collect (transform-region transformation area))) - (nareas (loop for area in (negative-areas area) - collect (transform-region transformation area)))) - (make-instance 'bezier-difference - :positive-areas pareas - :negative-areas nareas))) - (defmethod transform-region (transformation (area bezier-difference)) - (if (translation-transformation-p transformation) - (make-instance 'translated-bezier-design - :translation transformation - :region area) - (really-transform-region transformation area))) + (let* ((pareas (loop for area in (positive-areas area) + collect (transform-region transformation area))) + (nareas (loop for area in (negative-areas area) + collect (transform-region transformation area))) + (result (make-instance 'bezier-difference + :positive-areas pareas + :negative-areas nareas))) + (when (translation-transformation-p transformation) + (setf (original-region result) (or (original-region area) area))) + result))

(defmethod bounding-rectangle* ((design bezier-difference)) (bounding-rectangle-of-areas (positive-areas design))) @@ -326,19 +339,23 @@ :negative-areas (list r2)))

(defmethod region-difference ((r1 bezier-area) (r2 bezier-union)) - (make-instance 'bezier-difference - :positive-areas (list r1) - :negative-areas (areas r2))) + (let ((tr (transformation r2))) + (make-instance 'bezier-difference + :positive-areas (list r1) + :negative-areas (mapcar (lambda (r) (transform-region tr r)) (areas r2)))))

(defmethod region-difference ((r1 bezier-union) (r2 bezier-area)) - (make-instance 'bezier-difference - :positive-areas (areas r1) - :negative-areas (list r2))) + (let ((tr (transformation r1))) + (make-instance 'bezier-difference + :positive-areas (mapcar (lambda (r) (transform-region tr r)) (areas r1)) + :negative-areas (list r2))))

(defmethod region-difference ((r1 bezier-union) (r2 bezier-union)) - (make-instance 'bezier-difference - :positive-areas (areas r1) - :negative-areas (areas r2))) + (let ((tr1 (transformation r1)) + (tr2 (transformation r2))) + (make-instance 'bezier-difference + :positive-areas (mapcar (lambda (r) (transform-region tr1 r)) (areas r1)) + :negative-areas (mapcar (lambda (r) (transform-region tr2 r)) (areas r2)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -369,7 +386,7 @@ (%polygonalize p0 p1 p2 p3)))

(defmethod polygonalize ((path bezier-curve)) - (let ((segments (segments path))) + (let ((segments (%segments path))) (make-polyline (cons (slot-value (car segments) 'p0) (mapcan #'polygonalize segments))))) @@ -390,11 +407,12 @@

(defmethod reverse-path ((path bezier-curve)) (make-instance 'bezier-curve - :segments (reverse (mapcar #'reverse-segment (segments path))))) + :segments (reverse (mapcar #'reverse-segment (%segments path)))))

(defmethod reverse-path ((path bezier-area)) (make-instance 'bezier-area - :segments (reverse (mapcar #'reverse-segment (segments path))))) + :segments (reverse (mapcar #'reverse-segment (%segments path))) + :transformation (transformation path)))

;;; slanting transformation are used by Metafont (defun make-slanting-transformation (slant) @@ -574,7 +592,7 @@ (defmethod convolute-regions ((area bezier-area) (path bezier-curve)) (let ((polygon (polygonalize area))) (make-instance 'bezier-union - :areas (loop for segment in (segments path) + :areas (loop for segment in (%segments path) append (convolute-polygon-and-segment area polygon segment)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -670,9 +688,6 @@ (defmethod positive-negative-areas ((design bezier-difference)) (values (positive-areas design) (negative-areas design)))

-(defmethod positive-negative-areas ((design translated-bezier-design)) - (positive-negative-areas (original-region design))) - (defun render-to-array (design) (multiple-value-bind (positive-areas negative-areas) (positive-negative-areas design) @@ -695,9 +710,6 @@ (render-polygon result polygon 1 min-x min-y))) result))))

-(defparameter *x* 0) -(defparameter *y* 0) - (defparameter *pixmaps* (make-hash-table :test #'equal))

(defun resolve-ink (medium) @@ -715,8 +727,9 @@

(defgeneric ensure-pixmap (medium design))

-(defmethod ensure-pixmap (medium design) - (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) +(defmethod ensure-pixmap (medium rdesign) + (let* ((design (or (original-region rdesign) rdesign)) + (pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) (let* ((picture (render-to-array design)) @@ -743,17 +756,21 @@ pixmap))) pixmap))

-(defmethod ensure-pixmap (medium (design translated-bezier-design)) - (ensure-pixmap medium (original-region design))) - (defun render-through-pixmap (design medium) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) - (setf min-x (floor min-x) - min-y (floor min-y)) - (let ((pixmap (ensure-pixmap medium design))) - (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) - (medium-sheet medium) (+ *x* min-x) (+ *y* min-y))))) + ;; the design we've got has already been transformed by the + ;; medium/user transformation, and COPY-FROM-PIXMAP is in user + ;; coordinates. So we need to transform back (or set the medium's + ;; transformation to be +IDENTITY-TRANSFORMATION+ temporarily, but + ;; that's even uglier) + (multiple-value-bind (utmin-x utmin-y) + (untransform-position (medium-transformation medium) min-x min-y) + (setf min-x (floor utmin-x) + min-y (floor utmin-y)) + (let ((pixmap (ensure-pixmap medium design))) + (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) + (medium-sheet medium) min-x min-y)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -778,73 +795,6 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Special cases on region-union and region-intersection - -(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-curve)) - (region-union (really-transform-region (translation r1) (original-region r1)) r2)) - -(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-area))

[64 lines skipped]