Commit 6dfc1b7e authored by Alastair Bridgewater's avatar Alastair Bridgewater
Browse files

geometry/: Rough-in of rectangular geometry.

  * This started with BOUNDING-RECTANGLE, but got a bit out of
hand, largely due to the interaction between the bounding
rectangle protocol and the RECTANGLE geometry class.

  * I'm not convinced about the massive code duplication here
(mandated by the CLIM II spec) or the package organization (I
suspect that several dependencies could be rearranged to good
effect).

  * This is largely untested, but compiles cleanly.
parent 4df0a661
;;;
;;; nq-clim/geometry/bounding-rectangle-api
;;;
;;; The BOUNDING-RECTANGLE API (parts of CLIM II 4.1.1 and 4.1.2)
;;;
(cl:defpackage :nq-clim/geometry/bounding-rectangle-api
(:use :cl
:nq-clim/geometry/bounding-rectangle-protocol
:nq-clim/geometry/standard-bounding-rectangle)
(:export
"BOUNDING-RECTANGLE"
"WITH-BOUNDING-RECTANGLE"
;; "BOUNDING-RECTANGLE-POSITION"
"BOUNDING-RECTANGLE-MIN-X"
"BOUNDING-RECTANGLE-MIN-Y"
"BOUNDING-RECTANGLE-MAX-X"
"BOUNDING-RECTANGLE-MAX-Y"
"BOUNDING-RECTANGLE-WIDTH"
"BOUNDING-RECTANGLE-HEIGHT"
"BOUNDING-RECTANGLE-SIZE"))
(cl:in-package :nq-clim/geometry/bounding-rectangle-api)
(defgeneric bounding-rectangle (region)
(:documentation
"Return the bounding rectangle of REGION (which is required to
conform to the bounding-rectangle protocol) as a subclass of
RECTANGLE.")
(:method ((region bounding-rectangle))
(multiple-value-call #'make-bounding-rectangle
(bounding-rectangle* region))))
(defmacro with-bounding-rectangle* ((min-x min-y max-x max-y) region &body body)
`(multiple-value-bind (,min-x ,min-y ,max-x ,max-y)
(bounding-rectangle* region)
,@body))
;; FIXME: BOUNDING-RECTANGLE-POSITION goes here, but is defined to
;; return a POINT, which we have yet to implement.
(defgeneric bounding-rectangle-min-x (region)
(:documentation
"Return the minimum X coordinate of the bounding-rectangle of
REGION (which is required to conform to the bounding-rectangle
protocol).")
(:method ((region bounding-rectangle))
(nth-value 0 (bounding-rectangle* region))))
(defgeneric bounding-rectangle-min-y (region)
(:documentation
"Return the minimum Y coordinate of the bounding-rectangle of
REGION (which is required to conform to the bounding-rectangle
protocol).")
(:method ((region bounding-rectangle))
(nth-value 1 (bounding-rectangle* region))))
(defgeneric bounding-rectangle-max-x (region)
(:documentation
"Return the maximum X coordinate of the bounding-rectangle of
REGION (which is required to conform to the bounding-rectangle
protocol).")
(:method ((region bounding-rectangle))
(nth-value 2 (bounding-rectangle* region))))
(defgeneric bounding-rectangle-max-y (region)
(:documentation
"Return the maximum Y coordinate of the bounding-rectangle of
REGION (which is required to conform to the bounding-rectangle
protocol).")
(:method ((region bounding-rectangle))
(nth-value 3 (bounding-rectangle* region))))
(defgeneric bounding-rectangle-width (region)
(:documentation
"Return the width of the bounding rectangle of REGION (which is
required to conform to the bounding-rectangle protocol).")
(:method ((region bounding-rectangle))
(multiple-value-bind (min-x ignore max-x)
(bounding-rectangle* region)
(declare (ignore ignore))
(- max-x min-x))))
(defgeneric bounding-rectangle-height (region)
(:documentation
"Return the height of the bounding rectangle of REGION (which is
required to conform to the bounding-rectangle protocol).")
(:method ((region bounding-rectangle))
(multiple-value-bind (ignore-1 min-y ignore-2 max-y)
(bounding-rectangle* region)
(declare (ignore ignore-1 ignore-2))
(- max-y min-y))))
(defgeneric bounding-rectangle-size (region)
(:documentation
"Return the width and height of the bounding rectangle of
REGION (which is required to conform to the bounding-rectangle
protocol) as (VALUES WIDTH HEIGHT).")
(:method ((region bounding-rectangle))
(multiple-value-bind (min-x min-y max-x max-y)
(bounding-rectangle* region)
(values (- max-x min-x) (- max-y min-y)))))
;;; EOF
;;;
;;; nq-clim/geometry/bounding-rectangle-protocol
;;;
;;; The BOUNDING-RECTANGLE protocol (CLIM II 4.1 and 4.1.1)
;;;
(cl:defpackage :nq-clim/geometry/bounding-rectangle-protocol
(:use :cl)
(:export
"BOUNDING-RECTANGLE"
"BOUNDING-RECTANGLE-P"
"BOUNDING-RECTANGLE*"))
(cl:in-package :nq-clim/geometry/bounding-rectangle-protocol)
;; The protocol class. Users may subclass this to provide other
;; objects that behave as bounding rectangles.
(defclass bounding-rectangle () ())
;; The protocol predicate.
(defun bounding-rectangle-p (object)
"Return TRUE iif OBJECT is a BOUNDING-RECTANGLE."
(typep object 'bounding-rectangle))
;; The one function in the protocol.
(defgeneric bounding-rectangle* (region)
(:documentation
"Return the bounding rectangle of REGION as the X and Y coordinates
of the min and max points of the rectangle. REGION must be some
object that conforms to the BOUNDING-RECTANGLE protocol.
Returns (VALUES MIN-X MIN-Y MAX-X MAX-Y), where (<= MIN-X MAX-X)
and (<= MIN-Y MAX-Y)."))
;;; EOF
;;;
;;; nq-clim/geometry/rectangle-api
;;;
;;; Parts of CLIM II 3.2.4.1.
;;;
(cl:defpackage :nq-clim/geometry/rectangle-api
(:use :cl
:nq-clim/geometry/rectangle-protocol)
(:export
;; "RECTANGLE-MIN-POINT"
;; "RECTANGLE-MAX-POINT"
"RECTANGLE-MIN-X"
"RECTANGLE-MIN-Y"
"RECTANGLE-MAX-X"
"RECTANGLE-MAX-Y"
"RECTANGLE-WIDTH"
"RECTANGLE-HEIGHT"
"RECTANGLE-SIZE"))
(cl:in-package :nq-clim/geometry/rectangle-api)
;; FIXME: RECTANGLE-{MIN,MAX}-POINT go here, but return POINT objects,
;; which we have yet to define.
(defgeneric rectangle-min-x (rectangle)
(:documentation
"Return the minimum X coordinate of RECTANGLE.")
(:method ((rectangle rectangle))
(nth-value 0 (rectangle-edges* rectangle))))
(defgeneric rectangle-min-y (rectangle)
(:documentation
"Return the minimum Y coordinate of RECTANGLE.")
(:method ((rectangle rectangle))
(nth-value 1 (rectangle-edges* rectangle))))
(defgeneric rectangle-max-x (rectangle)
(:documentation
"Return the maximum X coordinate of RECTANGLE.")
(:method ((rectangle rectangle))
(nth-value 2 (rectangle-edges* rectangle))))
(defgeneric rectangle-max-y (rectangle)
(:documentation
"Return the maximum Y coordinate of RECTANGLE.")
(:method ((rectangle rectangle))
(nth-value 3 (rectangle-edges* rectangle))))
(defgeneric rectangle-width (rectangle)
(:documentation
"Return the width of RECTANGLE.")
(:method ((rectangle rectangle))
(multiple-value-bind (min-x ignore max-x)
(rectangle-edges* rectangle)
(declare (ignore ignore))
(- max-x min-x))))
(defgeneric rectangle-height (rectangle)
(:documentation
"Return the height of RECTANGLE.")
(:method ((rectangle rectangle))
(multiple-value-bind (ignore-1 min-y ignore-2 max-y)
(rectangle-edges* rectangle)
(declare (ignore ignore-1 ignore-2))
(- max-y min-y))))
(defgeneric rectangle-size (rectangle)
(:documentation
"Return the width and height of RECTANGLE as (VALUES WIDTH HEIGHT).")
(:method ((rectangle rectangle))
(multiple-value-bind (min-x min-y max-x max-y)
(rectangle-edges* rectangle)
(values (- max-x min-x) (- max-y min-y)))))
;;; EOF
;;;
;;; nq-clim/geometry/rectangle-protocol
;;;
;;; Parts of CLIM II 3.2.4 and 3.2.4.1.
;;;
(cl:defpackage :nq-clim/geometry/rectangle-protocol
(:use :cl
:nq-clim/geometry/region)
(:export
"RECTANGLE"
"RECTANGLEP"
"RECTANGLE-EDGES*"))
(cl:in-package :nq-clim/geometry/rectangle-protocol)
;; The protocol class.
(defclass rectangle (area) ())
;; The protocol predicate.
(defun rectanglep (object)
"Return TRUE iif OBJECT is a RECTANGLE."
(typep object 'rectangle))
;; The one function in the protocol.
(defgeneric rectangle-edges* (rectangle)
(:documentation
"Return the edges of RECTANGLE as the X and Y coordinates of the
min and max points of the rectangle. REGION must be some object
that conforms to the RECTANGLE protocol. Returns (VALUES MIN-X
MIN-Y MAX-X MAX-Y), where (<= MIN-X MAX-X) and (<= MIN-Y MAX-Y)."))
;; All RECTANGLEs inherit from BOUNDING-RECTANGLE, and thus need an
;; implementation of the bounding-rectangle protocol.
(defmethod bounding-rectangle* ((region rectangle))
(rectangle-edges* region))
;;; EOF
;;;
;;; nq-clim/geometry/region
;;;
;;; Parts of CLIM II 3.1.
;;;
(cl:defpackage :nq-clim/geometry/region
(:use :cl
:nq-clim/geometry/bounding-rectangle-protocol)
(:export
"REGION"
"REGIONP"
"AREA"
"AREAP"))
(cl:in-package :nq-clim/geometry/region)
;; The REGION protocol class.
(defclass region () ())
;; The REGION protocol predicate.
(defun regionp (object)
"Return TRUE iif OBJECT is a REGION."
(typep object 'region))
;; The AREA protocol class.
(defclass area (region bounding-rectangle) ())
;; The AREA protocol predicate.
(defun areap (object)
"Return TRUE iif OBJECT is an AREA."
(typep object 'area))
;;; EOF
;;;
;;; nq-clim/geometry/standard-bounding-rectangle
;;;
;;; Parts of CLIM II 4.1.
;;;
(cl:defpackage :nq-clim/geometry/standard-bounding-rectangle
(:use :cl
:nq-clim/geometry/rectangle-protocol
:nq-clim/geometry/bounding-rectangle-protocol)
(:export
"STANDARD-BOUNDING-RECTANGLE"
"MAKE-BOUNDING-RECTANGLE"))
(cl:in-package :nq-clim/geometry/standard-bounding-rectangle)
;; This is the definition of a standard bounding-rectangle, which
;; happens to also conform to the rectangle protocol, as opposed to
;; standard-rectangle, which only conforms to the rectangle protocol
;; (which happens to also require implementing the bounding-rectangle
;; protocol). The two classes therefore are completely different,
;; their almost-identical (and copy/paste) construction
;; notwithstanding.
(defclass standard-bounding-rectangle (rectangle)
((min-x :initarg min-x)
(min-y :initarg min-y)
(max-x :initarg max-x)
(max-y :initarg max-y)))
;; RECTANGLE contains a method for implementing BOUNDING-RECTANGLE* in
;; terms of RECTANGLE-EDGES*, which covers our BOUNDING-RECTANGLE
;; contract. We just need to cover the RECTANGLE contract here:
(defmethod rectangle-edges* ((rectangle standard-bounding-rectangle))
(with-slots (min-x min-y max-x max-y)
rectangle
(values min-x min-y max-x max-y)))
(defun make-bounding-rectangle (x1 y1 x2 y2)
(make-instance 'standard-bounding-rectangle
'min-x (min x1 x2)
'min-y (min y1 y2)
'max-x (max x1 x2)
'max-y (max y1 y2)))
;;; EOF
;;;
;;; nq-clim/geometry/standard-rectangle
;;;
;;; Parts of CLIM II 3.2.4.
;;;
(cl:defpackage :nq-clim/geometry/standard-rectangle
(:use :cl
:nq-clim/geometry/rectangle-protocol
:nq-clim/geometry/bounding-rectangle-protocol)
(:export
"STANDARD-RECTANGLE"
;; "MAKE-RECTANGLE"
"MAKE-RECTANGLE*"))
(cl:in-package :nq-clim/geometry/standard-rectangle)
;; This is the definition of a standard rectangle, which conforms to
;; the rectangle protocol (which happens to also require implementing
;; the bounding-rectangle protocol), as opposed to
;; standard-bounding-rectangle, which is a bounding-rectangle that
;; happens to also conform to the rectangle protocol. The two classes
;; therefore are completely different, their almost-identical (and
;; copy/paste) construction notwithstanding.
(defclass standard-rectangle (rectangle)
((min-x :initarg min-x)
(min-y :initarg min-y)
(max-x :initarg max-x)
(max-y :initarg max-y)))
(defmethod rectangle-edges* ((rectangle standard-rectangle))
(with-slots (min-x min-y max-x max-y)
rectangle
(values min-x min-y max-x max-y)))
;; FIXME: MAKE-RECTANGLE should go here, but it's defined in terms of
;; POINTs, which we haven't implemented yet.
(defun make-rectangle* (x1 y1 x2 y2)
(make-instance 'standard-rectangle
'min-x (min x1 x2)
'min-y (min y1 y2)
'max-x (max x1 x2)
'max-y (max y1 y2)))
;;; EOF
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment