[clinton/lisp-on-lines.git] / src / description-class.lisp

(in-package :lisp-on-lines)

;;;; * DESCRIPTIONS
;;;; A description is an object which is used 
;;;; to describe another object.


;;; #+HACK
;;; I'm having some 'issues' with 
;;; compiled code and my initialization.
;;; So this hack initializes the world.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *defined-descriptions* nil))

(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
  ((defined-in-descriptions :initarg :in-description)
   (mixin-class-p :initarg :mixinp)))

(defmethod direct-slot-definition-class
           ((class description-access-class) &key &allow-other-keys)
  (find-class 'direct-attribute-definition-class))

(defmethod effective-slot-definition-class
           ((class description-access-class) &key &allow-other-keys)
  (find-class 'effective-attribute-definition-class))

(defmethod compute-effective-slot-definition
           ((class description-access-class) name direct-slot-definitions)
  (declare (ignore name))
  (let ((attribute (call-next-method)))
    (setf (attribute-direct-attributes attribute) direct-slot-definitions)
    (setf (attribute-object-initargs attribute)  
	  ;; This plist will be used to init the attribute object
          ;; Once the description itself is properly initiated.
	  (list :name name 
		'effective-attribute attribute))
    attribute))

(defmethod slot-value-using-class ((class description-access-class) object slotd)
        (call-next-method)
#+nil  (if (or 
       (eq (slot-definition-name slotd) 'described-object)
       (not (slot-boundp slotd 'attribute-object)))
      (call-next-method)
      (slot-definition-attribute-object slotd)))
    

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter *description-attributes* (make-hash-table)))


(defclass standard-description-class (description-access-class layered-class)
  ((attributes :accessor description-class-attributes :initform (list)))
  (:default-initargs :defining-metaclass 'description-access-class))


(defmethod validate-superclass
           ((class standard-description-class)
            (superclass standard-class))
  t)

(define-layered-class standard-description-object (standard-layer-object) 
  ((described-object :accessor described-object 
		     :special t)))

(defun description-class-name  (description-class)
    (read-from-string (symbol-name (class-name description-class))))

(defgeneric standard-description-p (description-candidate)
  (:method (not-description)
    NIL)
  (:method ((description standard-description-object))
    T))
  
(defun initialize-description-class (class)

;;; HACK: initialization does not happ   en properly 
;;; when compiling and loading or something like that.
;;; Obviously i'm not sure why.
;;; So we're going to explicitly initialize things.
;;; For now. --drewc

  (pushnew class *defined-descriptions*)

;;; ENDHACK.
  
  (let* ((description (find-layer class)) 
	 (attribute-objects 
	  (setf (description-class-attributes (class-of description))
		(mapcar 
		 (lambda (slot)
		   (or (find-attribute description 
				       (slot-definition-name slot))
		       (let* ((*init-time-description* description)
			      (attribute-class (or 
						(ignore-errors 
						  (slot-value-using-class 
						   (class-of description) description slot))
						'standard-attribute))
			      (attribute 		     
			       (apply #'make-instance 
				      attribute-class
				      :description description
				      :attribute-class attribute-class
				      (attribute-object-initargs slot))))
			 (setf (slot-definition-attribute-object slot) attribute))))
		 (remove 'described-object (class-slots (class-of description))
			 :key #'slot-definition-name))))
	 (defining-classes 
	  (partial-class-defining-classes class)))

    (loop 
       :for (layer class) 
       :on  defining-classes :by #'cddr 
       :do (funcall-with-layer-context 
	    (adjoin-layer (find-layer layer) (current-layer-context))
	    (lambda ()
	      (loop :for direct-slot :in (class-direct-slots class) 
		 :do (let ((attribute 
			    (find (slot-definition-name direct-slot) 
				  attribute-objects 
				  :key #'attribute-name)))
		       (let ((initargs 
			      (prepare-initargs attribute (direct-attribute-properties direct-slot))))
			 
			 (apply #'reinitialize-instance attribute 
				initargs )
			 (setf (slot-value description (attribute-name attribute)) 
			       (attribute-class attribute))
			 (apply #'change-class attribute  (attribute-class attribute)
				initargs)))))))))


#+old(defun initialize-description-class (class)

;;; HACK: initialization does not happ   en properly 
;;; when compiling and loading or something like that.
;;; Obviously i'm not sure why.
;;; So we're going to explicitly initialize things.
;;; For now. --drewc

  (pushnew class *defined-descriptions*)

;;; ENDHACK.

  (let* ((description (find-layer class)) 
	 (attribute-objects 
	  (mapcar 
	   (lambda (slot)
	     (let* ((*init-time-description* description)
			  (attribute 		     
			   (apply #'make-instance 
			    'standard-attribute
			    :description description
			    (attribute-object-initargs slot))))
	       
		     
	       (setf (slot-definition-attribute-object slot) attribute)))
	   (remove 'described-object (class-slots (class-of description))
		   :key #'slot-definition-name)))
	 (defining-classes (partial-class-defining-classes (class-of description))))

    (loop 
       :for (layer class) 
       :on  defining-classes :by #'cddr 
       :do (funcall-with-layer-context 
	    (adjoin-layer (find-layer layer) (current-layer-context))
	    (lambda ()
	      (loop :for direct-slot :in (class-direct-slots class) 
		 :do (let ((attribute 
			    (find (slot-definition-name direct-slot) 
				  attribute-objects 
				  :key #'attribute-name)))
		       (let ((initargs 
			      (prepare-initargs attribute (direct-attribute-properties direct-slot))))
			 
			 (apply #'reinitialize-instance attribute 
				initargs )
			 (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute))
			 (when (not (eq (find-class (attribute-class attribute))
					(class-of attribute)))
			   (warn "~%CHANGING CLASS~%")
			   
			   (apply #'change-class attribute  (attribute-class attribute) 
				  initargs))))))))))

;;;; HACK: run this at startup till we figure things out.
(defun initialize-descriptions () 
  (map nil #'initialize-description-class 
       (setf *defined-descriptions* 
	     (remove-duplicates *defined-descriptions*))))

(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
  (declare (dynamic-extent initargs))
  (prog1
      (if (loop for direct-superclass in direct-superclasses
		thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
	(call-next-method)
	(apply #'call-next-method
	       class
	       :direct-superclasses
	       (append direct-superclasses
		       (list (find-class 'standard-description-object)))
	       initargs))
    (initialize-description-class class)))


(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
  (declare (dynamic-extent initargs))
;  (warn "CLASS ~A ARGS ~A:" class initargs)
  (prog1
      (if (or (not direct-superclasses-p)
		(loop for direct-superclass in direct-superclasses
		      thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
	  (call-next-method)
	  (apply #'call-next-method
		 class
		 :direct-superclasses
		 (append direct-superclasses
			 (list (find-class 'standard-description-object)))
		 initargs))
    (initialize-description-class class)))
		      
		      
(defmethod print-object ((object standard-description-object) stream)
  (print-unreadable-object (object stream :type nil :identity t)
    (format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))

(defmethod print-object ((object standard-description-class) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (princ  (ignore-errors (description-print-name (find-layer object))) stream)))

(defun find-description (name)
  (find-layer (find-class (defining-description name))))
Commit	Line	Data
4867c86f	1	(in-package :lisp-on-lines)
4867c86f	2
4358148e	3	;;;; * DESCRIPTIONS
	4	;;;; A description is an object which is used
	5	;;;; to describe another object.
	6
4358148e	7
	8	;;; #+HACK
	9	;;; I'm having some 'issues' with
	10	;;; compiled code and my initialization.
	11	;;; So this hack initializes the world.
	12	(eval-when (:compile-toplevel :load-toplevel :execute)
	13	(defparameter defined-descriptions nil))
	14
4271ab0b	15	(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
4358148e	16	((defined-in-descriptions :initarg :in-description)
	17	(mixin-class-p :initarg :mixinp)))
	18
	19	(defmethod direct-slot-definition-class
	20	((class description-access-class) &key &allow-other-keys)
	21	(find-class 'direct-attribute-definition-class))
	22
	23	(defmethod effective-slot-definition-class
	24	((class description-access-class) &key &allow-other-keys)
	25	(find-class 'effective-attribute-definition-class))
	26
	27	(defmethod compute-effective-slot-definition
	28	((class description-access-class) name direct-slot-definitions)
4867c86f	29	(declare (ignore name))
4358148e	30	(let ((attribute (call-next-method)))
4358148e	31	(setf (attribute-direct-attributes attribute) direct-slot-definitions)
f2ff8a16	32	(setf (attribute-object-initargs attribute)
	33	;; This plist will be used to init the attribute object
	34	;; Once the description itself is properly initiated.
	35	(list :name name
e8d4fa45	36	'effective-attribute attribute))
4358148e	37	attribute))
e8d4fa45	38
e8d4fa45	39	(defmethod slot-value-using-class ((class description-access-class) object slotd)
b7657b86	40	(call-next-method)
b7657b86	41	#+nil (if (or
e8d4fa45	42	(eq (slot-definition-name slotd) 'described-object)
	43	(not (slot-boundp slotd 'attribute-object)))
	44	(call-next-method)
	45	(slot-definition-attribute-object slotd)))
4867c86f	46
4358148e	47
b7657b86	48	(eval-when (:compile-toplevel :load-toplevel :execute)
	49	(defparameter description-attributes (make-hash-table)))
	50
	51
	52
4358148e	53	(defclass standard-description-class (description-access-class layered-class)
b7657b86	54	((attributes :accessor description-class-attributes :initform (list)))
4358148e	55	(:default-initargs :defining-metaclass 'description-access-class))
4358148e	56
b7657b86	57
b7657b86	58
4358148e	59	(defmethod validate-superclass
	60	((class standard-description-class)
	61	(superclass standard-class))
	62	t)
	63
e8d4fa45	64	(define-layered-class standard-description-object (standard-layer-object)
	65	((described-object :accessor described-object
	66	:special t)))
4358148e	67
	68	(defun description-class-name (description-class)
	69	(read-from-string (symbol-name (class-name description-class))))
b7657b86	70
	71	(defgeneric standard-description-p (description-candidate)
	72	(:method (not-description)
	73	NIL)
	74	(:method ((description standard-description-object))
	75	T))
81d70610	76
4867c86f	77	(defun initialize-description-class (class)
4358148e	78
b7657b86	79	;;; HACK: initialization does not happ en properly
	80	;;; when compiling and loading or something like that.
	81	;;; Obviously i'm not sure why.
	82	;;; So we're going to explicitly initialize things.
	83	;;; For now. --drewc
	84
	85	(pushnew class defined-descriptions)
	86
	87	;;; ENDHACK.
	88
	89	(let* ((description (find-layer class))
	90	(attribute-objects
	91	(setf (description-class-attributes (class-of description))
	92	(mapcar
	93	(lambda (slot)
	94	(or (find-attribute description
	95	(slot-definition-name slot))
	96	(let* ((init-time-description description)
	97	(attribute-class (or
	98	(ignore-errors
	99	(slot-value-using-class
	100	(class-of description) description slot))
	101	'standard-attribute))
	102	(attribute
	103	(apply #'make-instance
	104	attribute-class
	105	:description description
	106	:attribute-class attribute-class
	107	(attribute-object-initargs slot))))
	108	(setf (slot-definition-attribute-object slot) attribute))))
	109	(remove 'described-object (class-slots (class-of description))
	110	:key #'slot-definition-name))))
	111	(defining-classes
	112	(partial-class-defining-classes class)))
	113
	114	(loop
	115	:for (layer class)
	116	:on defining-classes :by #'cddr
	117	:do (funcall-with-layer-context
	118	(adjoin-layer (find-layer layer) (current-layer-context))
	119	(lambda ()
	120	(loop :for direct-slot :in (class-direct-slots class)
	121	:do (let ((attribute
	122	(find (slot-definition-name direct-slot)
	123	attribute-objects
	124	:key #'attribute-name)))
	125	(let ((initargs
	126	(prepare-initargs attribute (direct-attribute-properties direct-slot))))
	127
	128	(apply #'reinitialize-instance attribute
	129	initargs )
	130	(setf (slot-value description (attribute-name attribute))
	131	(attribute-class attribute))
	132	(apply #'change-class attribute (attribute-class attribute)
	133	initargs)))))))))
	134
	135
	136	#+old(defun initialize-description-class (class)
	137
81d70610	138	;;; HACK: initialization does not happ en properly
f2ff8a16	139	;;; when compiling and loading or something like that.
	140	;;; Obviously i'm not sure why.
	141	;;; So we're going to explicitly initialize things.
	142	;;; For now. --drewc
4358148e	143
4358148e	144	(pushnew class defined-descriptions)
6de8d300	145
f2ff8a16	146	;;; ENDHACK.
4358148e	147
4358148e	148	(let* ((description (find-layer class))
f2ff8a16	149	(attribute-objects
	150	(mapcar
	151	(lambda (slot)
e8d4fa45	152	(let* ((init-time-description description)
b7657b86	153	(attribute
b7657b86	154	(apply #'make-instance
e8d4fa45	155	'standard-attribute
	156	:description description
	157	(attribute-object-initargs slot))))
b7657b86	158
e8d4fa45	159
	160	(setf (slot-definition-attribute-object slot) attribute)))
	161	(remove 'described-object (class-slots (class-of description))
	162	:key #'slot-definition-name)))
4358148e	163	(defining-classes (partial-class-defining-classes (class-of description))))
4358148e	164
4358148e	165	(loop
	166	:for (layer class)
	167	:on defining-classes :by #'cddr
	168	:do (funcall-with-layer-context
	169	(adjoin-layer (find-layer layer) (current-layer-context))
f2ff8a16	170	(lambda ()
	171	(loop :for direct-slot :in (class-direct-slots class)
	172	:do (let ((attribute
	173	(find (slot-definition-name direct-slot)
	174	attribute-objects
	175	:key #'attribute-name)))
4271ab0b	176	(let ((initargs
	177	(prepare-initargs attribute (direct-attribute-properties direct-slot))))
	178
	179	(apply #'reinitialize-instance attribute
	180	initargs )
b7657b86	181	(warn "Attribute class for ~A is ~A" attribute (attribute-class attribute))
4271ab0b	182	(when (not (eq (find-class (attribute-class attribute))
4271ab0b	183	(class-of attribute)))
b7657b86	184	(warn "~%CHANGING CLASS~%")
81d70610	185
81d70610	186	(apply #'change-class attribute (attribute-class attribute)
b7657b86	187	initargs))))))))))
4358148e	188
	189	;;;; HACK: run this at startup till we figure things out.
	190	(defun initialize-descriptions ()
	191	(map nil #'initialize-description-class
	192	(setf defined-descriptions
	193	(remove-duplicates defined-descriptions))))
	194
	195	(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
	196	(declare (dynamic-extent initargs))
	197	(prog1
	198	(if (loop for direct-superclass in direct-superclasses
	199	thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
	200	(call-next-method)
	201	(apply #'call-next-method
	202	class
	203	:direct-superclasses
	204	(append direct-superclasses
	205	(list (find-class 'standard-description-object)))
	206	initargs))
	207	(initialize-description-class class)))
	208
	209
	210	(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
	211	(declare (dynamic-extent initargs))
	212	; (warn "CLASS ~A ARGS ~A:" class initargs)
	213	(prog1
	214	(if (or (not direct-superclasses-p)
	215	(loop for direct-superclass in direct-superclasses
	216	thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
	217	(call-next-method)
	218	(apply #'call-next-method
	219	class
	220	:direct-superclasses
	221	(append direct-superclasses
	222	(list (find-class 'standard-description-object)))
	223	initargs))
	224	(initialize-description-class class)))
	225
	226
	227	(defmethod print-object ((object standard-description-object) stream)
	228	(print-unreadable-object (object stream :type nil :identity t)
	229	(format stream "DESCRIPTION ~A" (ignore-errors (description-print-name object)))))
	230
	231	(defmethod print-object ((object standard-description-class) stream)
	232	(print-unreadable-object (object stream :type t :identity t)
	233	(princ (ignore-errors (description-print-name (find-layer object))) stream)))
	234
	235	(defun find-description (name)
	236	(find-layer (find-class (defining-description name))))
	237
	238
	239
4867c86f	240
	241
	242