[mcclim-cvs] CVS update: mcclim/decls.lisp mcclim/recording.lisp mcclim/regions.lisp
Timothy Moore
tmoore at common-lisp.net
Fri Feb 11 09:10:38 UTC 2005
Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv2906
Modified Files:
decls.lisp recording.lisp regions.lisp
Log Message:
Changed the representation of STANDARD-RECTANGLE from slots for the
coordinates to an array of coordinates. This should enable
opportunities for hashing the coordinates in interesting, inexpensive
ways. Introduced the macros WITH-STANDARD-RECTANGLE and
WITH-STANDARD-RECTANGLE* to provide convenient access to the
coordinates. Added (SETF RECTANGLE-EDGES*).
This change may well break code that depends on the internal
representation of output records.
Date: Fri Feb 11 10:10:37 2005
Author: tmoore
Index: mcclim/decls.lisp
diff -u mcclim/decls.lisp:1.31 mcclim/decls.lisp:1.32
--- mcclim/decls.lisp:1.31 Wed Feb 2 12:33:58 2005
+++ mcclim/decls.lisp Fri Feb 11 10:10:36 2005
@@ -32,8 +32,26 @@
;;; (exported) generic functions here? --GB
;;;
;;; YES! -- CSR
+;;; We'll get right on it :) -- moore
+;;; Whose numbers are we using here?
+
+;;; 3.2.1
(defgeneric point-x (point))
(defgeneric point-y (point))
+
+;;; 3.2.4.1
+
+(defgeneric rectangle-edges* (rectangle))
+(defgeneric rectangle-min-point (rectangle))
+(defgeneric rectangle-max-point (rectangle))
+(defgeneric rectangle-min-x (rectangle))
+(defgeneric rectangle-min-y (rectangle))
+(defgeneric rectangle-max-x (rectangle))
+(defgeneric rectangle-max-y (rectangle))
+(defgeneric rectangle-width (rectangle))
+(defgeneric rectangle-height (rectangle))
+(defgeneric rectangle-size (rectangle))
+
(defgeneric transform-region (transformation region))
Index: mcclim/recording.lisp
diff -u mcclim/recording.lisp:1.116 mcclim/recording.lisp:1.117
--- mcclim/recording.lisp:1.116 Wed Feb 2 12:33:58 2005
+++ mcclim/recording.lisp Fri Feb 11 10:10:36 2005
@@ -184,9 +184,14 @@
unspecified. "))
;;; From the Franz CLIM user's guide but not in the spec... clearly necessary.
-;;; What is its status? -- APD, 2002-06-14.
-(defgeneric map-over-output-records
- (continuation record &optional x-offset y-offset &rest continuation-args))
+
+(defgeneric map-over-output-records-1
+ (continuation record continuation-args))
+
+(defun map-over-output-records
+ (continuation record &optional x-offset y-offset &rest continuation-args)
+ (declare (ignore x-offset y-offset))
+ (map-over-output-records-1 continuation record continuation-args))
;;; 16.2.3. Output Record Change Notification Protocol
@@ -438,15 +443,14 @@
(:documentation "Implementation class for the Basic Output Record Protocol."))
(defmethod initialize-instance :after ((record basic-output-record)
- &rest args
- &key (x-position 0.0d0) (y-position 0.0d0))
+ &key (x-position 0.0d0)
+ (y-position 0.0d0))
(declare (ignore args))
- (with-slots (x1 y1 x2 y2) record
- (setq x1 x-position
- y1 y-position
- x2 x-position
- y2 y-position)))
+ (setf (rectangle-edges* record)
+ (values x-position y-position x-position y-position)))
+;;; XXX I'd really like to get rid of the x and y slots. They are surely
+;;; redundant with the bounding rectangle coordinates.
(defclass compound-output-record (basic-output-record)
((x :initarg :x-position
:initform 0.0d0
@@ -463,11 +467,12 @@
(bounding-rectangle-position record))
(defmethod* (setf output-record-position) (nx ny (record basic-output-record))
- (with-slots (x1 y1 x2 y2) record
+ (with-standard-rectangle (x1 y1 x2 y2)
+ record
(let ((dx (- nx x1))
(dy (- ny y1)))
- (setf x1 nx y1 ny
- x2 (+ x2 dx) y2 (+ y2 dy))))
+ (setf (rectangle-edges* record)
+ (values nx ny (+ x2 dx) (+ y2 dy)))))
(values nx ny))
(defmethod* (setf output-record-position) :around
@@ -480,10 +485,11 @@
min-x min-y max-x max-y))))
(values nx ny))
-(defmethod* (setf output-record-position) :before
- (nx ny (record compound-output-record))
- (with-slots (x1 y1 in-moving-p) record
- (letf ((in-moving-p t))
+(defmethod* (setf output-record-position)
+ :before (nx ny (record compound-output-record))
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
+ record
+ (letf (((slot-value record 'in-moving-p) t))
(let ((dx (- nx x1))
(dy (- ny y1)))
(map-over-output-records
@@ -673,19 +679,18 @@
(when sheet
(map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet))))
-(defmethod clear-output-record :after ((record compound-output-record))
- (with-slots (x y x1 y1 x2 y2) record
- (setf x1 x y1 y
- x2 x y2 y)))
+(defmethod clear-output-record :after ((record compound-output-record))
+ ;; XXX banish x and y
+ (with-slots (x y)
+ record
+ (setf (rectangle-edges* record) (values x y x y))))
(defmethod output-record-count ((record basic-output-record))
0)
-(defmethod map-over-output-records
- (function (record displayed-output-record)
- &optional (x-offset 0) (y-offset 0)
- &rest function-args)
- (declare (ignore function x-offset y-offset function-args))
+(defmethod map-over-output-records-1
+ (function (record displayed-output-record) function-args)
+ (declare (ignore function function-args))
nil)
;;; This needs to work in "most recently added last" order. Is this
@@ -743,6 +748,7 @@
(apply function child function-args)))
(output-record-children record)))
+;;; XXX Dunno about this definition... -- moore
(defun null-bounding-rectangle-p (bbox)
(with-bounding-rectangle* (x1 y1 x2 y2) bbox
(and (zerop x1) (zerop y1)
@@ -751,19 +757,19 @@
;;; 16.2.3. Output Record Change Notification Protocol
(defmethod recompute-extent-for-new-child
((record compound-output-record) child)
- (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
- (with-slots (parent x1 y1 x2 y2) record
- (if (= 1 (output-record-count record))
- (setf (values x1 y1 x2 y2) (bounding-rectangle* child))
- (unless (null-bounding-rectangle-p child)
- (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) child
- (minf x1 x1-child)
- (minf y1 y1-child)
- (maxf x2 x2-child)
- (maxf y2 y2-child))))
- (when parent
- (recompute-extent-for-changed-child parent record
- old-x1 old-y1 old-x2 old-y2))))
+ (unless (null-bounding-rectangle-p child)
+ (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record
+ (if (eql 1 (output-record-count record))
+ (setf (rectangle-edges* record) (bounding-rectangle* child))
+ (with-bounding-rectangle* (x1-child y1-child x2-child y2-child)
+ child
+ (setf (rectangle-edges* record)
+ (values (min old-x1 x1-child) (min old-y1 y1-child)
+ (max old-x2 x2-child) (max old-y2 y2-child)))))
+ (let ((parent (output-record-parent record)))
+ (when parent
+ (recompute-extent-for-changed-child
+ parent record old-x1 old-y1 old-x2 old-y2)))))
record)
(defmethod %tree-recompute-extent* ((record compound-output-record))
@@ -787,6 +793,7 @@
(maxf new-y2 cy2))))
record)
(if first-time
+ ;; XXX banish x y
(with-slots (x y) record
(values x y x y))
(values new-x1 new-y1 new-x2 new-y2))))
@@ -816,14 +823,16 @@
(maxf new-x2 cx2)
(maxf new-y2 cy2))))
record)
- (with-slots (x y x1 y1 x2 y2)
+ (with-slots (x y)
record
(if first-time ;No children
- (values x1 y1 x2 y2)
+ (bounding-rectangle* record)
(progn
- (setf (values x y x1 y1 x2 y2)
- (values new-x1 new-y1 new-x1 new-y1 new-x2 new-y2))
- (values new-x1 new-y1 new-x2 new-y2))))))
+ ;; XXX banish x,y
+ (setf x new-x1 y new-y1)
+ (setf (rectangle-edges* record)
+ (values new-x1 new-y1 new-x2 new-y2)))))))
+
(defmethod recompute-extent-for-changed-child
((record compound-output-record) changed-child
@@ -850,13 +859,17 @@
(values (min cx1 ox1) (min cy1 oy1)
(max cx2 ox2) (max cy2 oy2)))
(T (%tree-recompute-extent* record)))
-
- (with-slots (x y x1 y1 x2 y2 parent) record
- (setf x nx1 y ny1 x1 nx1 y1 ny1 x2 nx2 y2 ny2)
- (unless (or (null parent)
- (and (= nx1 ox1) (= ny1 oy1)
- (= nx2 ox2) (= nx2 oy2)))
- (recompute-extent-for-changed-child parent record ox1 oy1 ox2 oy2))))))
+ ;; XXX banish x, y
+ (with-slots (x y)
+ record
+ (setf x nx1 y ny1)
+ (setf (rectangle-edges* record) (values nx1 ny1 nx2 ny2))
+ (let ((parent (output-record-parent record)))
+ (unless (or (null parent)
+ (and (= nx1 ox1) (= ny1 oy1)
+ (= nx2 ox2) (= nx2 oy2)))
+ (recompute-extent-for-changed-child parent record
+ ox1 oy1 ox2 oy2)))))))
record)
;; There was once an :around method on recompute-extent-for-changed-child here,
@@ -919,15 +932,18 @@
(defmethod output-record-count ((record standard-sequence-output-record))
(length (output-record-children record)))
-(defmethod map-over-output-records
- (function (record standard-sequence-output-record)
- &optional (x-offset 0) (y-offset 0)
- &rest function-args)
+(defmethod map-over-output-records-1
+ (function (record standard-sequence-output-record) function-args)
"Applies FUNCTION to all children in the order they were added."
(declare (ignore x-offset y-offset))
- (loop with children = (output-record-children record)
- for child across children
- do (apply function child function-args)))
+ (if function-args
+ (loop with children = (output-record-children record)
+ for child across children
+ do (apply function child function-args))
+ (loop with children = (output-record-children record)
+ for child across children
+ do (funcall function child))))
+
(defmethod map-over-output-records-containing-position
(function (record standard-sequence-output-record) x y
@@ -1175,11 +1191,11 @@
(ceiling (+ max-x border))
(ceiling (+ max-y border)))))
-;;; x1, y1 slots must exist in class...
+;;; record must be a standard-rectangle
(defmethod* (setf output-record-position) :around
(nx ny (record coord-seq-mixin))
- (with-slots (x1 y1)
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
record
(let ((dx (- nx x1))
(dy (- ny y1))
@@ -1249,14 +1265,15 @@
,@(when class
`((defclass ,class-name (, at mixins standard-graphics-displayed-output-record)
,class-vars)
- (defmethod initialize-instance :after ((graphic ,class-name) &rest args)
+ (defmethod initialize-instance :after ((graphic ,class-name)
+ &key)
(declare (ignore args))
- (with-slots (x1 y1 x2 y2
- stream ink clipping-region
+ (with-slots (stream ink clipping-region
line-style text-style , at args)
graphic
(let* ((medium (sheet-medium stream)))
- (multiple-value-setq (x1 y1 x2 y2) (progn , at body)))))))
+ (setf (rectangle-edges* graphic)
+ (progn , at body)))))))
,(when medium-fn
`(defmethod ,method-name :around ((stream output-recording-stream) , at args)
;; XXX STANDARD-OUTPUT-RECORDING-STREAM ^?
@@ -1285,14 +1302,16 @@
(defmethod* (setf output-record-position) :around
(nx ny (record draw-point-output-record))
- (with-slots (x1 y1 point-x point-y)
- record
- (let ((dx (- nx x1))
- (dy (- ny y1)))
- (multiple-value-prog1
- (call-next-method)
- (incf point-x dx)
- (incf point-y dy)))))
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
+ record
+ (with-slots (point-x point-y)
+ record
+ (let ((dx (- nx x1))
+ (dy (- ny y1)))
+ (multiple-value-prog1
+ (call-next-method)
+ (incf point-x dx)
+ (incf point-y dy))))))
(defrecord-predicate draw-point-output-record (point-x point-y)
(and (if-supplied (point-x coordinate)
@@ -1323,17 +1342,18 @@
(defmethod* (setf output-record-position) :around
(nx ny (record draw-line-output-record))
- (with-slots (x1 y1
- point-x1 point-y1 point-x2 point-y2)
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
record
- (let ((dx (- nx x1))
- (dy (- ny y1)))
- (multiple-value-prog1
- (call-next-method)
- (incf point-x1 dx)
- (incf point-y1 dy)
- (incf point-x2 dx)
- (incf point-y2 dy)))))
+ (with-slots (point-x1 point-y1 point-x2 point-y2)
+ record
+ (let ((dx (- nx x1))
+ (dy (- ny y1)))
+ (multiple-value-prog1
+ (call-next-method)
+ (incf point-x1 dx)
+ (incf point-y1 dy)
+ (incf point-x2 dx)
+ (incf point-y2 dy))))))
(defrecord-predicate draw-line-output-record (point-x1 point-y1
point-x2 point-y2)
@@ -1507,17 +1527,18 @@
(defmethod* (setf output-record-position) :around
(nx ny (record draw-rectangle-output-record))
- (with-slots (x1 y1
- left top right bottom)
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
record
- (let ((dx (- nx x1))
- (dy (- ny y1)))
- (multiple-value-prog1
- (call-next-method)
- (incf left dx)
- (incf top dy)
- (incf right dx)
- (incf bottom dy)))))
+ (with-slots (left top right bottom)
+ record
+ (let ((dx (- nx x1))
+ (dy (- ny y1)))
+ (multiple-value-prog1
+ (call-next-method)
+ (incf left dx)
+ (incf top dy)
+ (incf right dx)
+ (incf bottom dy))))))
(defrecord-predicate draw-rectangle-output-record (left top right bottom filled)
(and (if-supplied (left coordinate)
@@ -1565,14 +1586,16 @@
(defmethod* (setf output-record-position) :around
(nx ny (record draw-ellipse-output-record))
- (with-slots (x1 y1 center-x center-y)
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
record
- (let ((dx (- nx x1))
- (dy (- ny y1)))
- (multiple-value-prog1
- (call-next-method)
- (incf center-x dx)
- (incf center-y dy)))))
+ (with-slots (center-x center-y)
+ record
+ (let ((dx (- nx x1))
+ (dy (- ny y1)))
+ (multiple-value-prog1
+ (call-next-method)
+ (incf center-x dx)
+ (incf center-y dy))))))
(defrecord-predicate draw-ellipse-output-record (center-x center-y)
(and (if-supplied (center-x coordinate)
@@ -1591,15 +1614,18 @@
(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-pattern-output-record))
- (with-slots (x1 y1 x y)
+(defmethod* (setf output-record-position) :around
+ (nx ny (record draw-pattern-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)))))
+ (incf y dy))))))
(defrecord-predicate draw-pattern-output-record (x y pattern)
;; ### I am not so sure about the correct usage of DEFRECORD-PREDICATE
@@ -1650,16 +1676,18 @@
(defmethod* (setf output-record-position) :around
(nx ny (record draw-text-output-record))
- (with-slots (x1 y1 point-x point-y toward-x toward-y)
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
record
- (let ((dx (- nx x1))
- (dy (- ny y1)))
- (multiple-value-prog1
- (call-next-method)
- (incf point-x dx)
- (incf point-y dy)
- (incf toward-x dx)
- (incf toward-y dy)))))
+ (with-slots (point-x point-y toward-x toward-y)
+ record
+ (let ((dx (- nx x1))
+ (dy (- ny y1)))
+ (multiple-value-prog1
+ (call-next-method)
+ (incf point-x dx)
+ (incf point-y dy)
+ (incf toward-x dx)
+ (incf toward-y dy))))))
(defrecord-predicate draw-text-output-record
(string start end point-x point-y align-x align-y toward-x toward-y
@@ -1752,25 +1780,27 @@
(defmethod* (setf output-record-position) :around
(nx ny (record standard-text-displayed-output-record))
- (with-slots (x1 y1 start-x start-y end-x end-y strings baseline)
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
record
- (let ((dx (- nx x1))
- (dy (- ny y1)))
- (multiple-value-prog1
- (call-next-method)
- (incf start-x dx)
- (incf start-y dy)
- (incf end-x dx)
- (incf end-y dy)
- ;(incf baseline dy)
- (loop for s in strings
- do (incf (slot-value s 'start-x) dx))))))
+ (with-slots (start-x start-y end-x end-y strings baseline)
+ record
+ (let ((dx (- nx x1))
+ (dy (- ny y1)))
+ (multiple-value-prog1
+ (call-next-method)
+ (incf start-x dx)
+ (incf start-y dy)
+ (incf end-x dx)
+ (incf end-y dy)
+ ;(incf baseline dy)
+ (loop for s in strings
+ do (incf (slot-value s 'start-x) dx)))))))
(defmethod replay-output-record ((record standard-text-displayed-output-record)
stream
&optional region (x-offset 0) (y-offset 0))
(declare (ignore region x-offset y-offset))
- (with-slots (strings baseline max-height start-y wrapped x1 y1)
+ (with-slots (strings baseline max-height start-y wrapped)
record
(with-sheet-medium (medium stream) ;is sheet a sheet-with-medium-mixin? --GB
;; FIXME:
@@ -1803,9 +1833,14 @@
(defmethod tree-recompute-extent
((text-record standard-text-displayed-output-record))
- (with-slots (parent x1 y1 x2 y2 width max-height) text-record
- (setq x2 (coordinate (+ x1 width))
- y2 (coordinate (+ y1 max-height))))
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
+ text-record
+ (with-slots (width max-height)
+ text-record
+ (setf (rectangle-edges* text-record)
+ (values x1 y1
+ (coordinate (+ x1 width))
+ (coordinate (+ y1 max-height))))))
text-record)
(defmethod add-character-output-to-text-record ; XXX OAOO with ADD-STRING-...
Index: mcclim/regions.lisp
diff -u mcclim/regions.lisp:1.28 mcclim/regions.lisp:1.29
--- mcclim/regions.lisp:1.28 Wed Mar 24 10:30:29 2004
+++ mcclim/regions.lisp Fri Feb 11 10:10:37 2005
@@ -4,7 +4,7 @@
;;; Created: 1998-12-02 19:26
;;; Author: Gilbert Baumann <unk6 at rz.uni-karlsruhe.de>
;;; License: LGPL (See file COPYING for details).
-;;; $Id: regions.lisp,v 1.28 2004/03/24 09:30:29 moore Exp $
+;;; $Id: regions.lisp,v 1.29 2005/02/11 09:10:37 tmoore Exp $
;;; --------------------------------------------------------------------------------------
;;; (c) copyright 1998,1999,2001 by Gilbert Baumann
;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr)
@@ -366,10 +366,42 @@
;; rectangle-edges*
(defclass standard-rectangle (rectangle)
- ((x1 :type coordinate :initarg :x1)
- (y1 :type coordinate :initarg :y1)
- (x2 :type coordinate :initarg :x2)
- (y2 :type coordinate :initarg :y2)))
+ ((coordinates :initform (make-array 4 :element-type 'coordinate))))
+
+(defmethod initialize-instance :after ((obj standard-rectangle)
+ &key (x1 0.0d0) (y1 0.0d0)
+ (x2 0.0d0) (y2 0.0d0))
+ (let ((coords (slot-value obj 'coordinates)))
+ (setf (aref coords 0) x1)
+ (setf (aref coords 1) y1)
+ (setf (aref coords 2) x2)
+ (setf (aref coords 3) y2)))
+
+(defmacro with-standard-rectangle ((x1 y1 x2 y2) rectangle &body body)
+ (with-gensyms (coords)
+ `(let ((,coords (slot-value ,rectangle 'coordinates)))
+ (declare (type (array coordinate 4) ,coords))
+ (let ((,x1 (aref ,coords 0))
+ (,y1 (aref ,coords 1))
+ (,x2 (aref ,coords 2))
+ (,y2 (aref ,coords 3)))
+ (declare (type coordinate ,x1 ,y1 ,x2 ,y2))
+ , at body))))
+
+(defmacro with-standard-rectangle* ((&key x1 y1 x2 y2) rectangle &body body)
+ (with-gensyms (coords)
+ `(let ((,coords (slot-value ,rectangle 'coordinates)))
+ (declare (type (array coordinate 4) ,coords))
+ (let (,@(and x1 `((,x1 (aref ,coords 0))))
+ ,@(and y1 `((,y1 (aref ,coords 1))))
+ ,@(and x2 `((,x2 (aref ,coords 2))))
+ ,@(and y2 `((,y2 (aref ,coords 3)))))
+ (declare (type coordinate
+ ,@(and x1 `(,x1))
+ ,@(and y1 `(,y1))
+ ,@(and x2 `(,x2))
+ ,@(and y2 `(,y2))))
+ , at body))))
(defun make-rectangle (point1 point2)
(make-rectangle* (point-x point1) (point-y point1) (point-x point2) (point-y point2)))
@@ -378,70 +410,135 @@
(psetq x1 (coerce (min x1 x2) 'coordinate)
x2 (coerce (max x1 x2) 'coordinate)
y1 (coerce (min y1 y2) 'coordinate)
- y2 (coerce (max y1 y2) 'coordinate))
+ y2 (coerce (max y1 y2) 'coordinate))
(if (or (coordinate= x1 x2)
(coordinate= y1 y2))
+nowhere+
(make-instance 'standard-rectangle :x1 x1 :x2 x2 :y1 y1 :y2 y2)))
(defmethod rectangle-edges* ((rect standard-rectangle))
- (with-slots (x1 y1 x2 y2) rect
+ (with-standard-rectangle (x1 y1 x2 y2)
+ rect
(values x1 y1 x2 y2)))
+;;; standard-rectangles are immutable and all that, but we still need to set
+;;; their positions and dimensions (in output recording)
+(defgeneric* (setf rectangle-edges*) (x1 y1 x2 y2 rectangle))
+
+(defmethod* (setf rectangle-edges*)
+ (x1 y1 x2 y2 (rectangle standard-rectangle))
+ (let ((coords (slot-value rectangle 'coordinates)))
+ (declare (type (array coordinate 4) coords))
+ (setf (aref coords 0) x1)
+ (setf (aref coords 1) y1)
+ (setf (aref coords 2) x2)
+ (setf (aref coords 3) y2))
+ (values x1 y1 x2 y2))
+
(defmethod rectangle-min-point ((rect rectangle))
(multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
(declare (ignore x2 y2))
(make-point x1 y1)))
+(defmethod rectangle-min-point ((rect standard-rectangle))
+ (with-standard-rectangle* (:x1 x1 :y1 y1)
+ rect
+ (make-point x1 y1)))
+
(defmethod rectangle-max-point ((rect rectangle))
(multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
(declare (ignore x1 y1))
(make-point x2 y2)))
+(defmethod rectangle-max-point ((rect standard-rectangle))
+ (with-standard-rectangle* (:x2 x2 :y2 y2)
+ rect
+ (make-point x2 y2)))
+
(defmethod rectangle-min-x ((rect rectangle))
(nth-value 0 (rectangle-edges* rect)))
+(defmethod rectangle-min-x ((rect standard-rectangle))
+ (with-standard-rectangle* (:x1 x1)
+ rect
+ x1))
+
(defmethod rectangle-min-y ((rect rectangle))
(nth-value 1 (rectangle-edges* rect)))
+(defmethod rectangle-min-y ((rect standard-rectangle))
+ (with-standard-rectangle* (:y1 y1)
+ rect
+ y1))
+
+
(defmethod rectangle-max-x ((rect rectangle))
(nth-value 2 (rectangle-edges* rect)))
+(defmethod rectangle-max-x ((rect standard-rectangle))
+ (with-standard-rectangle* (:x2 x2)
+ rect
+ x2))
+
(defmethod rectangle-max-y ((rect rectangle))
(nth-value 3 (rectangle-edges* rect)))
+(defmethod rectangle-max-y ((rect standard-rectangle))
+ (with-standard-rectangle* (:y2 y2)
+ rect
+ y2))
+
(defmethod rectangle-width ((rect rectangle))
(multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
(declare (ignore y1 y2))
(- x2 x1)))
+(defmethod rectangle-width ((rect standard-rectangle))
+ (with-standard-rectangle* (:x1 x1 :x2 x2)
+ rect
+ (- x2 x1)))
+
(defmethod rectangle-height ((rect rectangle))
(multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
(declare (ignore x1 x2))
(- y2 y1)))
+(defmethod rectangle-height ((rect standard-rectangle))
+ (with-standard-rectangle* (:y1 y1 :y2 y2)
+ rect
+ (- y2 y1)))
+
(defmethod rectangle-size ((rect rectangle))
(multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
(values (- x2 x1) (- y2 y1))))
+(defmethod rectangle-size ((rect standard-rectangle))
+ (with-standard-rectangle (x1 y1 x2 y2)
+ rect
+ (values (- x2 x1) (- y2 y1))))
+
;; polyline/polygon protocol for standard-rectangle's
(defmethod polygon-points ((rect standard-rectangle))
- (with-slots (x1 y1 x2 y2) rect
+ (with-standard-rectangle (x1 y1 x2 y2)
+ rect
(list (make-point x1 y1)
(make-point x1 y2)
(make-point x2 y2)
(make-point x2 y1))))
+
(defmethod map-over-polygon-coordinates (fun (rect standard-rectangle))
- (with-slots (x1 y1 x2 y2) rect
+ (with-standard-rectangle (x1 y1 x2 y2)
+ rect
(funcall fun x1 y1)
(funcall fun x1 y2)
(funcall fun x2 y2)
(funcall fun x2 y1)))
(defmethod map-over-polygon-segments (fun (rect standard-rectangle))
- (with-slots (x1 y1 x2 y2) rect
+ (with-standard-rectangle (x1 y1 x2 y2)
+ rect
(funcall fun x1 y1 x1 y2)
(funcall fun x1 y2 x2 y2)
(funcall fun x2 y2 x2 y1)
@@ -449,7 +546,8 @@
(defmethod transform-region (transformation (rect standard-rectangle))
(cond ((rectilinear-transformation-p transformation)
- (with-slots (x1 y1 x2 y2) rect
+ (with-standard-rectangle (x1 y1 x2 y2)
+ rect
(multiple-value-bind (x1* y1*) (transform-position transformation x1 y1)
(multiple-value-bind (x2* y2*) (transform-position transformation x2 y2)
(make-rectangle* x1* y1* x2* y2*)))))
@@ -458,7 +556,8 @@
(polygon-points rect)))) ))
(defmethod region-contains-position-p ((self standard-rectangle) x y)
- (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* self)
+ (with-standard-rectangle (x1 y1 x2 y2)
+ self
(and (<= x1 (coerce x 'coordinate) x2)
(<= y1 (coerce y 'coordinate) y2))))
@@ -2142,7 +2241,8 @@
(values (min x1 x2) (min y1 y2) (max x1 x2) (max y1 y2))))
(defmethod bounding-rectangle* ((a standard-rectangle))
- (with-slots (x1 y1 x2 y2) a
+ (with-standard-rectangle (x1 y1 x2 y2)
+ a
(values x1 y1 x2 y2)))
(defmethod bounding-rectangle* ((self standard-rectangle-set))
@@ -2235,11 +2335,11 @@
(defmethod set-bounding-rectangle-position ((self standard-rectangle) x y)
;;(error "DO NOT CALL ME")
- (with-slots (x1 y1 x2 y2) self
- (setq x2 (+ x (- x2 x1))
- y2 (+ y (- y2 y1))
- x1 x
- y1 y)))
+ ;;Yes, but... output records are based on rectangles
+ (with-standard-rectangle (x1 y1 x2 y2)
+ self
+ (setf (rectangle-edges* self)
+ (values x y (+ x (- x2 x1)) (+ y (- y2 y1))))))
(defmethod bounding-rectangle-min-x ((self bounding-rectangle))
(nth-value 0 (bounding-rectangle* self)))
@@ -2271,11 +2371,9 @@
(defmethod print-object ((self standard-rectangle) stream)
(print-unreadable-object (self stream :type t :identity t)
- (if (slot-boundp self 'x1)
- (with-slots (x1 y1 x2 y2) self
- (format stream "X ~S:~S Y ~S:~S" x1 x2 y1 y2))
- (format stream "X 0:0 Y 0:0"))))
-
+ (with-standard-rectangle (x1 y1 x2 y2)
+ self
+ (format stream "X ~S:~S Y ~S:~S" x1 x2 y1 y2))))
;;;;
More information about the Mcclim-cvs
mailing list