removing historical implementation

[clinton/lisp-on-lines.git] / src / mewa.lisp

diff --git a/src/mewa.lisp b/src/mewa.lisp
index 24aa788..ca40f24 100644 (file)
--- a/src/mewa.lisp
+++ b/src/mewa.lisp
@@ -1,111 +1,23 @@
 (in-package :lisp-on-lines)
 
 (in-package :lisp-on-lines)
 

-(defun persistentp (object)
-  (slot-value object 'clsql-sys::view-database))
-
-(define-layered-class description ()
-  ((description-type
-    :initarg :type
-    :accessor description-type
-    :initform 'viewer
-    :special t)
-   (description-layers
-    :initarg :layers
-    :accessor description-layers
-    :initform nil
-    :special t)
-   (described-object
-    :layered-accessor object
-    :initform nil
-    :special t)
-   (description-default-attributes
-    :accessor default-attributes
-    :initarg :default-attributes
-    :initform nil
-    :special t)
-   (description-attributes
-    :accessor attributes
-    :initarg :attributes
-    :initform nil
-    :special t)
-   (description-properties
-    :accessor description-properties
-    :initarg :properties
-    :initform '()
-    :special t)
-   (description-default-properties
-    :accessor default-properties
-    :initarg :default-properties
-    :initform '()
-    :special t)))
-
-(defmethod attributes :around ((description description))
-  "Add any default properties to the attributes"
-  
-  (let ((default-properties (default-properties description)))    (if (and (listp default-properties)
-            (not (null default-properties)))
-       (let ((a (mapcar #'(lambda (att)
-                   (append (ensure-list att) default-properties))
-               (call-next-method))))
-         
-
-         a) 
-       (call-next-method))))
-
-(defmethod print-object ((self description) stream)
-  (print-unreadable-object (self stream :type t)
-    (with-slots (description-type) self
-      (format stream "~A" description-type))))
-

 ;;;; * Occurences
 ;;;; * Occurences

+;;;; Occurences can be thought of as the class of a description. 
+;;;; Most of the occurence stuff is depreciated now.

 
 

-(defvar *occurence-map* (make-hash-table)
-  "a display is generated by associating an 'occurence' 
-with an instance of a class. This is usually keyed off class-name,
-although an arbitrary occurence could be used with an arbitrary class.")
-
-(define-layered-class
-    standard-occurence (description)
-    ((occurence-name :accessor name :initarg :name)
-     (attribute-map :accessor attribute-map :initform (make-hash-table)))
-    (:documentation

      "an occurence holds the attributes like a class holds slot-definitions.
      "an occurence holds the attributes like a class holds slot-definitions.

-Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
+Attributes are the yetadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."

 
 (defun find-or-create-occurence (name)
   "Returns the occurence associated with this name."
 
 (defun find-or-create-occurence (name)
   "Returns the occurence associated with this name."

-  (or (get-occurence name)
-      (values (setf (get-occurence name) (make-instance 'standard-occurence :name name))
-             t)))
-
-(defun get-occurence (name)
-  (gethash name *occurence-map*))
-
-(defun (setf get-occurence) (occurence name)
-    (setf (gethash name *occurence-map*) occurence))
+  (let ((description (find-description name)))
+    (if description
+       (class-of description)
+       (class-of (ensure-description name)))))

 
 (defun clear-occurence (occurence)
   "removes all attributes from the occurence"
   (setf (attribute-map occurence) (make-hash-table)))
 
 
 (defun clear-occurence (occurence)
   "removes all attributes from the occurence"
   (setf (attribute-map occurence) (make-hash-table)))
 

-(defmethod make-attribute-using-slot-definition (slotd)
-  (make-attribute
-   :name (closer-mop:slot-definition-name slotd)
-   :type-spec (closer-mop:slot-definition-type slotd)
-   :type (first (remove-if (lambda (item)
-                            (or
-                             (eql item 'or)
-                             (eql item 'null)
-                             (eql item nil)))
-                          (ensure-list (closer-mop:slot-definition-type slotd))))))
-
-(defmethod initialize-occurence-for-instance (occurence instance)
-  (let ((slots (closer-mop:class-slots (class-of instance))))
-    (dolist (s slots)
-      (let ((att (make-attribute-using-slot-definition s)))
-       (setf (find-attribute occurence (attribute-name att)) att)))
-    occurence))
-

 (defgeneric find-occurence (name)
   (:method (thing)
     nil)
 (defgeneric find-occurence (name)
   (:method (thing)
     nil)


@@ -127,6 +39,29 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
     res))
 
 
     res))
 
 

+(defmethod make-attribute-using-slot-definition (slotd)
+  (make-attribute
+   :name (closer-mop:slot-definition-name slotd)
+   :type-spec (closer-mop:slot-definition-type slotd)
+   :type (first (remove-if (lambda (item)
+                            (or
+                             (eql item 'or)
+                             (eql item 'null)
+                             (eql item nil)))
+                          (ensure-list (closer-mop:slot-definition-type slotd))))))
+
+(defmethod initialize-occurence-for-instance (occurence instance)
+  (let ((slots (closer-mop:class-slots (class-of instance))))
+    (dolist (s slots)
+      (let ((att (make-attribute-using-slot-definition s)))
+       (setf (find-attribute occurence (attribute-name att)) att)))
+    occurence))
+
+
+
+
+;;;; * Attributes
+

 (define-layered-class
     attribute (description)
     ((attribute-name :layered-accessor attribute-name
 (define-layered-class
     attribute (description)
     ((attribute-name :layered-accessor attribute-name


@@ -137,7 +72,6 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
      (label :initarg :label :layered-accessor label :initform nil :special t)))
 
 
      (label :initarg :label :layered-accessor label :initform nil :special t)))
 
 

-;;;; * Attributes

 (defmethod print-object ((self attribute) stream)
   (print-unreadable-object (self stream :type t)
     (with-slots (attribute-name description-type) self
 (defmethod print-object ((self attribute) stream)
   (print-unreadable-object (self stream :type t)
     (with-slots (attribute-name description-type) self


@@ -200,7 +134,7 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
         :properties args
         args)) 
 
         :properties args
         args)) 
 

-(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
+(defmethod ensure-attribute ((occurence description) &rest args &key name &allow-other-keys)

   "Creates an attribute in the given occurence"
   (let ((attribute (apply #'make-attribute :occurence occurence args)))
     (setf (find-attribute occurence name) attribute)))
   "Creates an attribute in the given occurence"
   (let ((attribute (apply #'make-attribute :occurence occurence args)))
     (setf (find-attribute occurence name) attribute)))


@@ -208,7 +142,7 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
 (defmethod find-attribute ((occurence null) name)
   nil)
 
 (defmethod find-attribute ((occurence null) name)
   nil)
 

-(defmethod find-attribute ((occurence standard-occurence) name)
+(defmethod find-attribute ((occurence description) name)

   (or (gethash name (attribute-map occurence))
       (let* ((class (ignore-errors (find-class (name occurence))))
             (class-direct-superclasses
   (or (gethash name (attribute-map occurence))
       (let* ((class (ignore-errors (find-class (name occurence))))
             (class-direct-superclasses


@@ -224,7 +158,7 @@ Attributes are the metadata used to display, validate, and otherwise manipulate
                  name)))
            attribute)))))
 
                  name)))
            attribute)))))
 

-(defmethod find-all-attributes ((occurence standard-occurence))
+(defmethod find-all-attributes ((occurence description))

   (loop for att being the hash-values of (attribute-map occurence)
      collect att))
 
   (loop for att being the hash-values of (attribute-map occurence)
      collect att))
 


@@ -309,9 +243,7 @@ otherwise, (setf find-attribute)"
            collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
 
 
            collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
 
 

-(defmethod find-description (object type)
-  (let ((occurence (find-occurence object)))
-       occurence))
+

 
 ;;"Unused???"
 (defmethod setter (attribute)
 
 ;;"Unused???"
 (defmethod setter (attribute)