Author: lgiessmann Date: Sat Mar 20 18:00:40 2010 New Revision: 235 Log: new-datamodel: finalized "make-construct" Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sat Mar 20 18:00:40 2010 @@ -663,6 +663,16 @@ (condition () nil))) +(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) (:documentation "Returns all characterisitcs of the passed type the parent @@ -2378,29 +2388,104 @@ ((CharacteristicC-p class-symbol) (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-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)) + (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-tm (&rest args) +(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 (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))) + (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 (remove-if @@ -2420,21 +2505,24 @@ (make-instance 'TopicMapC)))))) (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)))) (defun make-topic (&rest args) "Returns a topic object. If the topic 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 ((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 (remove-if @@ -2454,9 +2542,10 @@ (first existing-topics)) (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 :revision start-revision))) @@ -2464,10 +2553,10 @@ (setf merged-topic (add-locator merged-topic locator :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)))) @@ -2484,11 +2573,17 @@ (themes (getf (first args) :themes)) (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 (map 'list #'(lambda(existing-characteristic) @@ -2499,26 +2594,19 @@ :charvalue charvalue :themes themes :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)))) (defun make-pointer (class-symbol &rest args) @@ -2528,7 +2616,10 @@ (let ((uri (getf (first args) :uri)) (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 (remove-if Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Sat Mar 20 18:00:40 2010 @@ -61,11 +61,8 @@ :test-class-p)) -;;TODO: test merge-constructs when merging was caused by an item-dentifier, -;; a psi, a subject-locator, a topic-id -;;TODO: test merge-constructs when merging was caused by reifiers -;; (occurrences, names, variants, associations, roles) -;;TODO: test ReifiableConstructC --> reifier has to be merged +;;TODO: test make-construct +;;TODO: test merge-constructs