Re: Examples of Meta-Object Protocol

[kanderso@DINO.BBN.COM]

OK, here are some short examples.  They might have once run in some
PCL.  Is that enough of a disclaimer?  It is basically a file i
have been using for experimentation.  I have also added structures to
PCL, and others at BBN have added method combination, specialized
slots, and various metaclasses to support knowledge based systems.

My attempt at Key units is probably incomplete, and people have told
me that my imlementation of delegation is wrong.  But, i hope this is
better than nothing:

;;;-*-Mode:LISP; Package:(PCL LISP 1000000000); Base:10; Syntax:Common-lisp -*-

(defclass named-mixin
	  ()
     ((name :initarg :name :initform NIL :reader name)))

(defmethod print-object ((thing named-mixin) stream)
  (printing-random-thing (thing stream)
   (format stream "~a ~a" (class-name (class-of thing)) (name thing))))


(defclass compatible-class-mixin
    ()
  ()
  (:documentation
   "A metaclass mixin that provides compatibility with standard-class."))

(defmethod check-super-metaclass-compatibility
	   ((class compatible-class-mixin) (super standard-class))
  t)

(defmethod describe ((thing compatible-class-mixin) &rest args)
  (apply 'describe-instance thing args))


(defclass instances-class-mixin
	  ()
     ((instances :initform () :accessor class-instances))
  (:documentation
    "Lets a class record its instances."))

(defmethod make-instance ((class instances-class-mixin) &rest initargs)
  (declare (ignore initargs))
  (let ((instance (call-next-method)))
    (add-instance class instance)
    instance))

(defmethod add-instance ((class instances-class-mixin) instance)
  (pushnew instance (class-instances class)))

(defmethod remove-instance ((class instances-class-mixin) instance)
  (setf (class-instances class)
	(delete instance (class-instances class) :test #'eq)))


;;; This version uses :class allocated slots, so each instance knows
;;; who its siblings are but the class doesn't know who its instances
;;; are.

(defclass i-mixin
	  ()
     ((instances :initform () :accessor instances :allocation :class)))

(defmethod *initialize-instance :before ((object i-mixin) &rest initargs)
	   (pushnew object (instances object)))

(defclass foo-x
	  (i-mixin)
     ((x)
      (y)))

(defclass foo-y
	  (i-mixin)
     ((z)
      (y)))

#||
;;; Example.
(defclass instance-recording-class
	  (instances-class-mixin 
	    compatible-class-mixin 
	    standard-class)
     ())

(defclass ifrob ()
     ((x :initarg x :accessor x)
      (y :initarg y :accessor y))
  (:metaclass instance-recording-class))

(defclass jfrob (ifrob)
     ((z :initarg x :accessor z))
  (:metaclass instance-recording-class))

(setq x (make-instance 'ifrob))
(setq y (make-instance 'jfrob))
(class-instances (find-class 'ifrob))

||#      

;;; Metaclass for allocating objects from a class resource.

(defclass resource-allocate-class-mixin
  ()
  ((resource :initform () :accessor class-resource)))

(defmethod allocate-instance 
	   ((class resource-allocate-class-mixin) &rest initargs)
 (or (apply #'resource-allocate class initargs)
      (call-next-method)))

(defmethod resource-allocate
    ((class resource-allocate-class-mixin) &rest initargs)
  (declare (ignore initargs))
  (pop (class-resource class)))

(defmethod deallocate ((instance object))
  (deallocate-instance (class-of instance) instance))

(defmethod deallocate-instance
    ((class resource-allocate-class-mixin) instance)
  (pushnew instance (class-resource class)))

#||
(defclass robot-class
    (resource-allocate-class-mixin
     instances-class-mixin
     standard-class)
     ())

(defclass robot
	  (named-mixin)
     ()
  (:metaclass robot-class))

(setq a (make-instance 'robot :name 'mary))
(setq b (make-instance 'robot :name 'ken))
(deallocate b)
(setq c (make-instance 'robot :name 'strange))
||#


;;;
;;; Something like KEY UNITS
;;;
(defvar *knowledgebase* NIL)

(defclass unit
	  (compatible-class-mixin standard-class)
     ((kb            :initform *knowledgebase* :initarg :kb)
      (creator       :initarg :creator)
      (date-created  :initarg :date-created)
      (modifier      :initarg :modifier)
      (date-modified :initarg :date-modified)
      (comment       :initarg :comment)
      (member-parents
	:initform () :initarg :member-parents :accessor class-member-parents)
      (own-slots
	:initform () :initarg :own-slots :accessor class-own-slots)))

(defclass classes-2
    (unit)
  ()
  (:metaclass unit))

(defclass entities
    (unit)
  ()
  (:metaclass unit))

;;;
;;; Patch std-class.lisp
;;; KRA 89/3/30:  Let class-change happen if the metaclass of a class changes.

;;;
;;; CLASS-FOR-REDEFINITION old-class proto-class name ds-options slotds
;;; protocol: class definition
;;; 
;;; When a class is being defined, and a class with that name already exists
;;; a decision must be made as to what to use for the new class object, and
;;; whether to update the old class object.  For this, class-for-redefinition
;;; is called with the old class object, the prototype of the new class, and
;;; the name ds-options and slotds corresponding to the new definition.
;;; It should return the class object to use as the new definition.  It is
;;; OK for this to be old-class if that is appropriate.
;;; 
(defmethod class-for-redefinition ((old-class standard-class)
				   (proto-class standard-class)
				   name
				   local-supers
				   local-slot-slotds
				   extra)
  (declare (ignore name local-supers local-slot-slotds extra))
  (UNLESS (EQ (CLASS-OF OLD-CLASS) (CLASS-OF PROTO-CLASS))
      (CHANGE-CLASS OLD-CLASS (CLASS-OF PROTO-CLASS)))
  old-class)

(defunit ships (entities) (classes) ((crew)) ())
(defunit sailing-ships (ships) (classes) ((masts) (sails)) ())
(defunit cutty-sark () (sailing-ships) () ((masts :initform 3)
					   (crew :initform 12)))

;;; This is a feable attempt.  For each unit named NAME we define a metaclass
;;; NAME-CLASS that provides own-slot inheritance.
;;; With a bit more work, i believe, we could avoid the metaclass, by
;;; rewriting add-named-class to let make-instance take options like
;;; member-parents and own-slots, and return an appropriate instance.
;;; otherwise, how are options to be used, anyway.
(defmacro defunit (name superclasses member-parents member-slots own-slots)
  (let ((*initfunctions* ()))
    (declare (special *initfunctions*))
    (flet ((canonicalize-slot-specifications (slots)
	     (cons 'list (mapcar #'(lambda (spec)
				     (canonicalize-slot-specification name spec))
				 slots))))
      (setq member-slots (canonicalize-slot-specifications member-slots))
      (setq own-slots (canonicalize-slot-specifications own-slots))
      `(let ,(mapcar #'cdr *initfunctions*)
	 (make-unit ',name ',superclasses ',member-parents
		    ,member-slots ,own-slots)))))

(defun make-unit (name superclasses member-parents member-slots own-slots)
    (add-named-class
     (class-prototype (find-unit-metaclass name member-parents own-slots))
     name
     superclasses
     member-slots
     ()))

(defun find-unit-metaclass (name member-parents own-slots)
  (if (or (cdr member-parents) own-slots)
      (add-named-class
       (class-prototype (find-class 'classes))
       (intern (format nil "~S-CLASS" name))
       member-parents
       own-slots
       ())
      (find-class (first member-parents))))
  
(add-named-class  -> update-class
		    
	   
1 of supperclasses or member parents is nil.
If there are superclasses, this unit is a class.  I'ts slots are its
own-slots and the slots of its member-parents.  
  (if superclasses
      ;; Make a class
      (let* ((metaclass (find-member-parents-class member-parents)))
	(when own-slots
	  (setq metaclass
		(add-named-class (class-prototype metaclass)
				 (format nil "~A-CLASS" name)
				 (or member-parents
				     (list (find-class 'classes)))
				 own-slots nil)))
	(add-named-class
	 (class-prototype metaclass)
	 name superclasses member-slots nil))
      ;; Make a member instance
      (let ((class (if member-parents (find-member-parents-class
				       member-parents)
		       'entities)))
	(when own-slots
	  (setq class
		(add-named-class
		 (class-prototype class)
		 (format nil "~A-CLASS" name)
		 (find-member-parents-class member-parents)
		 own-slots nil)))
	(*make-instance class :name name))
	 
      ))

(defclass ships
	  (unit)
     ((base))
  (:metaclass unit))

(defclass frob-1
	  ()
     (x y)
  (:metaclass unit))

(defflavor ENTITIES
	()
	(classes))


(defclass KNOWLEDGEBASES
	(classes)
	((KBMETHODFILE ())
	 (KBSIZE 0)
	 (KEE.DEVELOPMENT.VERSION.NUMBER 0)
	 (KEE.MAJOR.VERSION.NUMBER 2)
	 (KEE.MINOR.VERSION.NUMBER 1)
	 (KEE.PATCH.VERSION.NUMBER 3)
	 (KEEVERSION 'KEE2.1)
	 (units (make-hash-table)))
  (:default-init-plist :kb nil))

;;;
;;; DELEGATION
;;;
(defclass delegate-mixin
  ()
  ((delegate-to :initform nil
		:initarg :delegate-to
		:reader delegate-to
		;; No :writer so we can't change delegation, because that may cause
		;; invalidating a lot of caches.
		)))

(defmethod delegate-to ((thing t))
  ;; Normally don't delegate.
  nil)


(defmethod no-applicable-method ((gf standard-generic-function) &rest args)
    ;; Try delegation.
    (let ((method (apply #'find-delegated-method gf args)))
      (if method (apply method args)
	(call-next-method))))

(defmethod delegate ((gf standard-generic-function) &rest args)
  ;; Delegate is like apply.  
    (let ((method (apply #'find-delegated-method gf args)))
      (if method (apply method args)
	(apply #'buck-stops-here gf args))))

(defmethod buck-stops-here ((gf standard-generic-function) &rest args)
  (error "Sorry, the buck stops here: ~S ~S" gf args))

(defmethod find-delegated-method ((gf standard-generic-function)
				  (client delegate-mixin) &rest args)
  ;; Try delegating on the first argument.
  (let ((server (delegate-to client)))
    (if server
	(apply #'generic-function-effective-method gf server args))))

(defmethod find-delegated-method ((gf standard-generic-function)
				  thing &rest args)
  ;; Try delegating on the second argument if there is one.  Otherwise just try to
  ;; find an effective method.
  (or (and  args
	    (let ((server (delegate-to (first args))))
	      (if server
		  (apply #'generic-function-effective-method gf thing server (cdr args)))))
      (apply #'generic-function-effective-method gf thing args)))

(defmethod generic-function-effective-method ((gf standard-generic-function) &rest args)
  ;; Returns a function that is the effective method when GF is applied to ARGS.
  (cdr (last (apply #'lookup-method-internal gf (generic-function-combined-methods gf)
		    #'car args))))

(defmethod slot-missing (class (instance delegate-mixin) slot-name operation
			 &optional new-value)
  (declare (ignore class))
  (let ((server (delegate-to instance)))
    (if server
	(if (eq operation 'slot-value)
	    (slot-value server slot-name)
	    (setf (slot-value server slot-name) new-value))
	(call-next-method))))


#||
;;; Example
(defclass x-pos
	  ()
     ((x :initarg :x :accessor x)))

(defclass y-pos
	  ()
     ((y :initarg :y :accessor y)))

(defclass x-point
	  (delegate-mixin x-pos)
     ())

(defclass horizontal-line
	  (y-pos)
     ((p1 :accessor p1)
      (p2 :accessor p2)))

(defmethod initialize-instance :after ((instance horizontal-line) &rest initargs)
  (declare (ignore initargs))
  (setf (p1 instance) (*make-instance 'x-point :delegate-to instance :x 0)
	(p2 instance) (*make-instance 'x-point :delegate-to instance :x 100)))
	  
(setq hl (make-instance 'horizontal-line :y 20))

(y (p1 hl))
(y (make-instance 'x-point))
||#

;;; 
;;; Descrimination on non class objects
;;; TABLES:

(defmethod table-get ((table list) key)
  (let ((item (assoc key table)))
    (if item (values (cdr item) t))))

(defmethod table-get ((table hash-table) key)
  (gethash key table))

(defmethod (setf table-get) (new (table hash-table) key)
  (setf (gethash key table) new))

(defmethod (setf table-get) (new (table list) key)
  (let ((item (assoc key table)))
    (if item (setf (cdr item) new)
	(nconc table (list (cons key new))))))


;;; What if you wanted something that was wrapped in a class wrapper?
;;; It seems that CLASS-OF can't be generic.  It requires special information about
;;; each major type of object universe.

;;; Before CLOS:
(defmethod add-instance-of ((class class) instance)
  (pushnew instance (class-instances class))
  (add-instance-of-inverse instance class))

;;; With CLOS:
(defmethod add-instance-of :before ((class class) instance)
  (pushnew instance (class-instances class)))

(defmethod add-instance-of :before
  ((class class) (instance multi-instance-mixin))
  (pushnew class (instance-of instance)))

(defmethod display-on ((self displayable-object) (window window))
  ... draw operations on window ...)

(defmethod display-on :around ((self displayable-object) (window careful-window))
  (while-drawing-carefully-on (window)
    (call-next-method)))