define-class.lisp

;;;;****************************************************************************

;;;; SPECIALIZING SLOTS WITH THE DEFINE-CLASS MACRO

;;;;****************************************************************************

;;;;***** RATIONALE ************************************************************

;;; In this file, we introduce a DEFINE-CLASS macro that proposes a particular
;;; approach to defining CLOS classes such that type information is retained
;;; in slots and can be specialized on.

;;; Consider the following set-up

(defclass shape ()
  ((%shape :initarg :shape :accessor shape)))

(defclass circle (shape) ())
(defclass square (shape) ())
(defclass rectangle (shape) ())

(defclass color ()
  ((%color :initarg :color :accessor color)))

(defclass red-color (color) ())
(defclass green-color (color) ())
(defclass blue-color (color) ())
(defclass black-color (color) ())
(defclass brown-color (color) ())

;;; We can then create colored-shapes as follows, by inheriting from SHAPE
;;; and COLOR. We prepend this name with OLD because we will hopefully show
;;; a better way in our proposed approach

(defclass old-colored-shape (shape color) ())

;;; If we want to have a RED-CIRCLE class, we could do

(defclass red-circle (circle red-color) ())

;;; However, with 3 different types of shapes and 5 colors, we are left
;;; with 15 combinations, which is too many to manually create

;;; But why do we want to identify RED-CIRCLE objects?

;;; One situation would be if we want to specialise on RED-CIRCLES...
;;; ...something like this: (defmethod paint ((obj old-red-circle)) ...)

;;; Which brings us to our DEFINE-CLASS Proposal

;;;;****************************************************************************

;;;;***** PROPOSAL *************************************************************

;;; What if we did the following:

(defclass colored-shape (shape color)
  ((%shape :initarg :shape :accessor colored-shape-shape)
   (%color :initarg :color :accessor colored-shape-color)))

;;; And instead of putting the VALUE of a SHAPE / COLOR in the slot, we put
;;; an actual SHAPE / COLOR OBJECT into the slot, e.g.

;; (make-instance 'colored-shape :shape (make-instance 'circle) :color (make-instance 'red-color))

;;; We then add some methods to hide this indirection:

;; (defmethod shape ((obj colored-shape))
;;   (shape (colored-shape-area obj)))

;; (defmethod (setf shape) (val (obj colored-shape))
;;   (setf (colored-shape-area obj) val))

;;; This will then allow us to specialise on the components of a COLORED-SHAPE,
;;; by passing each slot as an argument:

;; (defmethod paint ((obj circle) (obj green-color)) ...)

;; which can be called by (paint (shape obj) (color obj))

;;; The benefit of this approach is that we do not need to define each of the
;;; combinations that we need to use, and the information of the type of object
;;; stored in the slots is retained

;;; The downside is the indirection and additional complexity

;;;;****************************************************************************

;;;;***** THE MACRO ************************************************************

;;; No point doing a proposal without code :-) See below for a draft version.

;;;;****************************************************************************

;;; Simple helper function to generate and intern symbols from component strings

(defun concatenate-and-intern (&rest objects)
  "Generate and intern a symbol based on the concatenation of the supplied objects."
  (intern (apply #'concatenate 'string (mapcar #'stringify objects))))

(defun concatenate-and-intern-keyword (&rest objects)
  "Generate and intern a keyword symbol based on the concatenation of the supplied objects."
  (intern (apply #'concatenate 'string (mapcar #'stringify objects)) "KEYWORD"))

(defgeneric stringify (obj)
  (:documentation "Generate a string equivalent of OBJ."))

(defmethod stringify ((obj string))
  obj)

(defmethod stringify ((obj symbol))
  (symbol-name obj))

;;;;****************************************************************************

;;; Generate Slot Forms for use in DEFINE-CLASS Macro
;;; Slots are either symbol or (symbol . initform)

(defun define-class-inherited-slot-forms (class-name slots)
  "Returns a list of slot forms for use within the DEFINE-CLASS macro expression."
  (loop for slot in slots
	collect
	(typecase slot
	  (atom (list (concatenate-and-intern "%" slot)
		      :initarg (concatenate-and-intern-keyword slot)
		      :accessor (concatenate-and-intern class-name "-" slot)))
	  (cons (list (concatenate-and-intern "%" (car slot))
		      :initarg (concatenate-and-intern (car slot))
		      :accessor (concatenate-and-intern class-name "-" (car slot))
		      :initform (concatenate-and-intern `',(cdr slot)))))))

;;;;****************************************************************************

(defun define-class-primary-slot-forms (class-name)
  "Returns a slot form for use within the DEFINE-CLASS macro expression for single-slot classes."
  (list (list (concatenate-and-intern "%" class-name)
	      :initarg (concatenate-and-intern-keyword class-name)
	      :accessor (concatenate-and-intern class-name))))

;;;;****************************************************************************

;;; Modify Accessor Functions

(defun define-class-reader-forms (class-name slots)
  "Generate a DEFMETHOD form to re-point the reader for SLOT in CLASS-NAME to (SLOT (CLASS-NAME OBJ))."
  (loop for slot in slots
	collect
	`(defmethod ,slot ((obj ,class-name))
	   (,slot (,(concatenate-and-intern class-name "-" slot) obj)))))

(defun define-class-writer-forms (class-name slots)
  "Generate a DEFMETHOD form to re-point the reader for SLOT in CLASS-NAME to (SLOT (CLASS-NAME OBJ))."
  (loop for slot in slots
	collect
	`(defmethod (setf ,slot) (val (obj ,class-name))
	   (setf (,(concatenate-and-intern class-name "-" slot) obj) val))))

;;;;****************************************************************************

;;; Primary Macro

(defmacro define-class (class-name slots non-inherited-slots &rest options)
  "Define a CLOS class for CLASS-NAME with SLOTS such that the SLOTS can be specialised in a generic function call.
Assumes SLOTS are defined as single-slot classes to begin with. [Better docstring to be written]."
  (let ((slot-forms (if (null slots)
			(define-class-primary-slot-forms class-name)
			(define-class-inherited-slot-forms class-name slots)))
	(reader-forms (define-class-reader-forms class-name slots))
	(writer-forms (define-class-writer-forms class-name slots)))
    `(progn
       (defclass ,class-name ,slots
	 (list ,@slot-forms ,non-inherited-slots)
	 ,@options)
       ,@reader-forms
       ,@writer-forms)))

doesn't make sense
dispatch on values
can have a function that generates a value and dispatch on that
but otherwise, the question when you perform an OO analyse, is to determine what concepts need to be reified, ie. made into objects/classes.
perform OO analyse