Changeset 235 for branches/new-datamodel/src/model

Timestamp:

03/20/10 22:00:40 (15 years ago)

Author:

lgiessmann

Message:

new-datamodel: finalized "make-construct"

File:

• branches/new-datamodel/src/model/datamodel.lisp (modified) (9 diffs)

branches/new-datamodel/src/model/datamodel.lisp ¶

@@ -664 +664 @@
 
 
+(defun merge-all-constructs(constructs-to-be-merged)
+  "Merges all constructs contained in the given list."
+  (declare (list constructs-to-be-merged))
+  (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
+        (merged-construct (elt constructs-to-be-merged 0)))
+    (loop for construct-to-be-merged in constructs-to-be-merged
+       do (setf merged-construct
+                (merge-constructs merged-construct construct-to-be-merged)))))
+
+
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defgeneric get-all-characteristics (parent-construct characteristic-symbol)
@@ -2379 +2389 @@
             (make-characteristic class-symbol (getf args :charvalue) args))
            ((TopicC-p class-symbol)
-            (make-topic args)))))
+            (make-topic args))
+           ((TopicMapC-p class-symbol)
+            (make-tm args))
+           ((RoleC-p class-symbol)
+            (make-role args))
+           ((AssociationC-p class-symbol)
+            (make-association args)))))
     construct))
 
 
-(defun merge-all-constructs(constructs-to-be-merged)
-  "Merges all constructs contained in the given list."
-  (declare (list constructs-to-be-merged))
-  (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1))
-        (merged-construct (elt constructs-to-be-merged 0)))
-    (loop for construct-to-be-merged in constructs-to-be-merged
-       do (setf merged-construct
-                (merge-constructs merged-construct construct-to-be-merged)))))
-
-
-(defun make-tm (&rest args)
-  "Returns a topic map object. If the topic map has already existed the
+(defun make-association (args)
+  "Returns an association object. If the association has already existed the
    existing one is returned otherwise a new one is created.
    This function exists only for being used by make-construct!"
   (let ((item-identifiers (getf (first args) :item-identifiers))
         (reifier (getf (first args) :reifier))
-        (topics (getf (first args) :topics))
-        (assocs (getf (first args) :associations))
-        (start-revision (getf (first args) :start-revision)))
+        (instance-of (getf (first args) :instance-of))
+        (start-revision (getf (first args) :start-revision))
+        (themes (get (first args) :themes))
+        (roles (get (first args) :roles))
+        (err "From make-association(): "))
+    (unless start-revision (error "~astart-revision must be set" err))
+    (unless roles (error "~aroles must be set" err))
+    (unless instance-of (error "~ainstance-of must be set" err))
+    (let ((association
+           (let ((existing-association
+                  (remove-if
+                   #'null
+                   (map 'list #'(lambda(existing-association)
+                                  (when (equivalent-construct
+                                         existing-association
+                                         :start-revision start-revision
+                                         :roles roles :themes themes
+                                         :instance-of instance-of)
+                                    existing-association))
+                        (elephant:get-instances-by-class 'AssociationC)))))
+             (if existing-association
+                 existing-association
+                 (make-instance 'AssociationC)))))
+      (initialize-typable association instance-of :start-revision
+                          start-revision)
+      (dolist (role roles)
+        (add-role association role :revision start-revision))
+      (dolist (theme themes)
+        (add-theme association theme :revision start-revision))
+      (initialize-reifiable association item-identifiers reifier
+                            :start-revision start-revision))))
+
+
+(defun make-role (args)
+  "Returns a role object. If the role has already existed the
+   existing one is returned otherwise a new one is created.
+   This function exists only for being used by make-construct!"
+  (let ((item-identifiers (getf args :item-identifiers))
+        (reifier (getf args :reifier))
+        (parent (getf args :parent))
+        (instance-of (getf args :instance-of))
+        (player (getf args :player))
+        (start-revision (getf args :start-revision))
+        (err "From make-role(): "))
+    (unless start-revision (error "~astart-revision must be set" err))
+    (unless instance-of (error "~ainstance-of must be set" err))
+    (unless player (error "~aplayer must be set" err))
+    (let ((role
+           (let ((existing-role
+                  (remove-if
+                   #'null
+                   (map 'list #'(lambda(existing-role)
+                                  (when (equivalent-construct
+                                         existing-role
+                                         :player player
+                                         :instance-of instance-of)
+                                    existing-role))
+                        (slot-p parent 'roles)))))
+             (if existing-role
+                 existing-role
+                 (make-instance 'RoleC)))))
+      (when player
+        (add-player role player :revision start-revision))
+      (initialize-typable role instance-of :start-revision start-revision)
+      (when parent
+        (add-parent role parent :revision start-revision))
+      (initialize-reifiable role item-identifiers reifier
+                            :start-revision start-revision))))
+
+
+(defun make-tm (args)
+  "Returns a topic map object. If the topic map has already existed the
+   existing one is returned otherwise a new one is created.
+   This function exists only for being used by make-construct!"
+  (let ((item-identifiers (getf args :item-identifiers))
+        (reifier (getf args :reifier))
+        (topics (getf args :topics))
+        (assocs (getf args :associations))
+        (start-revision (getf args :start-revision))
+        (err "From make-tm(): "))
+    (unless item-identifiers (error "~aitem-identifiers must be set" err))
+    (unless start-revision (error "~astart-revision must be set" err))
     (let ((tm
            (let ((existing-tms
@@ -2421 +2506 @@
       (dolist (top-or-assoc (union topics assocs))
         (add-to-tm tm top-or-assoc))
-      (add-to-version-history tm :start-revision start-revision)
-      tm)))
+      (initialize-reifiable tm item-identifiers reifier
+                            :start-revision start-revision))))
            
 
@@ -2429 +2514 @@
    returned otherwise a new one is created.
    This function exists only for being used by make-construct!"
-  (let ((start-revision (getf (first args) :start-revision))
-        (psis (getf (first args) :psis))
-        (locators (getf (first args) :locators))
-        (item-identifiers (getf (first args) :item-identifiers))
-        (topic-identifiers (getf (first args) :topic-identifiers))
-        (names (getf (first args) :names))
-        (occurrences (getf (first args) :occurrences)))
+  (let ((start-revision (getf args :start-revision))
+        (psis (getf args :psis))
+        (locators (getf args :locators))
+        (item-identifiers (getf args :item-identifiers))
+        (topic-identifiers (getf args :topic-identifiers))
+        (names (getf args :names))
+        (occurrences (getf args :occurrences))
+        (err "From make-topic(): "))
+    (unless topic-identifiers (error "~atopic-identifiers must be set" err))
+    (unless start-revision (error "~astart-revision must be set" err))
     (let ((topic
            (let ((existing-topics
@@ -2455 +2543 @@
                    (t
                     (make-instance 'TopicC))))))
-      (initialize-reifiable topic item-identifiers nil
-                            :start-revision start-revision)
       (let ((merged-topic topic))
+        (setf merged-topic
+              (initialize-reifiable topic item-identifiers nil
+                                    :start-revision start-revision))
         (dolist (psi psis)
           (setf merged-topic (add-psi merged-topic psi
@@ -2465 +2554 @@
                                           :revision start-revision)))
         (dolist (name names)
-          (setf merged-topic (add-name topic name :revision start-revision)))
+          (setf merged-topic (add-name merged-topic name
+                                       :revision start-revision)))
         (dolist (occ occurrences)
           (add-occurrence merged-topic occ :revision start-revision))
-        (add-to-version-history merged-topic :start-revision start-revision)
         merged-topic))))
 
@@ -2485 +2574 @@
         (variants (getf (first args) :variants))
         (reifier (getf (first args) :reifier))
-        (parent-construct (getf (first args) :parent-construct))
-        (item-identifiers (getf (first args) :item-identifiers)))
+        (parent (getf (first args) :parent))
+        (item-identifiers (getf (first args) :item-identifiers))
+        (err "From make-characteristic(): "))
+    (unless start-revision (error "~astart-revision must be set" err))
+    (unless charvalue (error "~acharvalue must be set" err))
+    (when (and (or (OccurrenceC-p class-symbol) (NameC-p class-symbol))
+               (not instance-of))
+      (error "~ainstance-of must be set" err))
     (let ((characteristic
            (let ((existing-characteristic
-                  (when parent-construct
+                  (when parent
                     (remove-if
                      #'null
@@ -2500 +2595 @@
                                            :instance-of instance-of)
                                       existing-characteristic))
-                          (get-all-characteristics parent-construct
-                                                   class-symbol))))))
+                          (get-all-characteristics parent class-symbol))))))
              (if existing-characteristic
                  existing-characteristic
                  (make-instance class-symbol :charvalue charvalue
                                 :datatype datatype)))))
-      (let ((merged-characteristic characteristic))
-        (setf merged-characteristic
-              (initialize-reifiable merged-characteristic item-identifiers
-                                    reifier :start-revision start-revision))
-        (initialize-scopable merged-characteristic themes
-                             :start-revision start-revision)
-        (initialize-typable merged-characteristic instance-of
-                            :start-revision start-revision)
-        (initialize-name merged-characteristic variants
-                         :start-revision start-revision)
-        (when parent-construct
-          (add-parent merged-characteristic parent-construct
-                      :revision start-revision))
-        merged-characteristic))))
+      (initialize-scopable characteristic themes :start-revision start-revision)
+      (initialize-typable characteristic instance-of
+                          :start-revision start-revision)
+      (initialize-name characteristic variants :start-revision start-revision)
+      (when parent
+        (add-parent characteristic parent :revision start-revision))
+      (initialize-reifiable characteristic item-identifiers
+                            reifier :start-revision start-revision))))
 
 
@@ -2529 +2617 @@
         (xtm-id (getf (first args) :xtm-id))
         (start-revision (getf (first args) :start-revision))
-        (identified-construct (getf (first args) :identified-construct)))
+        (identified-construct (getf (first args) :identified-construct))
+        (err "From make-pointer(): "))
+    (when (and identified-construct (not start-revision))
+      (error "~astart-revision must be set" err))
     (let ((identifier
            (let ((existing-pointer