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

Modified Files: rgb-image.lisp Log Message: Added fixes for drawing of rgb-images so that they properly add output records.

--- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/06 16:05:46 1.3 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/09 16:59:04 1.4 @@ -44,7 +44,8 @@

(defclass rgb-image-design (design) ((medium :initform nil :initarg :medium) - (image :initarg :image) + (image :reader image + :initarg :image) (medium-data :initform nil)))

(defun make-rgb-image-design (image) @@ -71,6 +72,39 @@ (setf medium current-medium) (setf medium-data nil))))

+(defmethod medium-draw-image-design* + ((medium sheet-with-medium-mixin) design x y) + (medium-draw-image-design* (sheet-medium medium) design x y)) + +;;; Output recording stuff, this was copied from the pattern code. + +(def-grecording draw-image-design (() image-design x y) () + (let ((width (image-width (image image-design))) + (height (image-height (image image-design))) + (transform (medium-transformation medium))) + (setf (values x y) (transform-position transform x y)) + (values x y (+ x width) (+ y height)))) + +(defmethod* (setf output-record-position) :around + (nx ny (record draw-image-design-output-record)) +(with-standard-rectangle* (:x1 x1 :y1 y1) + record + (with-slots (x y) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf x dx) + (incf y dy)))))) + +(defrecord-predicate draw-image-design-output-record (x y image-design) + (and (if-supplied (x coordinate) + (coordinate= (slot-value record 'x) x)) + (if-supplied (y coordinate) + (coordinate= (slot-value record 'y) y)) + (if-supplied (image-design rgb-image-design) + (eq (slot-value record 'image-design) image-design))))

;;; Fetching protocol

@@ -93,15 +127,10 @@ (defgeneric sheet-rgb-data (port sheet &key x y width height))

-;;; Output recording - -(defun draw-image-design* - (medium design &rest options &key x y &allow-other-keys) - (unless (and x y) - (setf (values x y) (clim:stream-cursor-position medium))) - (climi::with-medium-options (medium options) - (medium-draw-image-design* (sheet-medium medium) design x y))) - (defmethod draw-design - (medium (design rgb-image-design) &rest options &key &allow-other-keys) - (apply #'draw-image-design* medium design options)) + (medium (design rgb-image-design) &rest options + &key x y &allow-other-keys) + (unless (and x y) + (setf (values x y) (stream-cursor-position medium))) + (with-medium-options (medium options) + (medium-draw-image-design* medium design x y)))