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 (,@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 ,@args) graphic (let* ((medium (sheet-medium stream))) - (multiple-value-setq (x1 y1 x2 y2) (progn ,@body))))))) + (setf (rectangle-edges* graphic) + (progn ,@body))))))) ,(when medium-fn `(defmethod ,method-name :around ((stream output-recording-stream) ,@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@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@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)) + ,@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)))) + ,@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)))) ;;;;