[mcclim-cvs] CVS mcclim/Extensions

[thenriksen]

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)))